簡易管理ソフト


gitではないけどバージョン管理をvbaで手軽にできないかなと思い作成した。

フォルダのサイズが異なったらbackupを作成する簡易バージョン管理ツールとなる。


```:VBS
'更新日が新しい2つのFolderのサイズを取得しサイズが異なったらWork日付でフォルダがコピーされる

Option Explicit

Dim fso, folderPath, folder, subFolders, latestFolder, secondLatestFolder
Dim latestSize, secondLatestSize, currentDateTime, NewFolderName
Dim shell
Set shell = CreateObject("WScript.Shell")

Dim objFSO 
Set objFSO = CreateObject("Scripting.FileSystemObject")


folderPath = shell.CurrentDirectory
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(folderPath) Then
    MsgBox "指定されたフォルダが存在しません: " & folderPath
    WScript.Quit
End If

Set folder = fso.GetFolder(folderPath)
Set subFolders = folder.SubFolders

' 最新とその次に新しいフォルダを取得
Dim folderArray(), i
ReDim folderArray(subFolders.Count - 1)
i = 0

Dim subFolder
For Each subFolder In subFolders
    Set folderArray(i) = subFolder
    i = i + 1
Next

' 作成日でソート
Call QuickSort(folderArray, 0, UBound(folderArray))

If UBound(folderArray) >= 1 Then
    Set latestFolder = folderArray(UBound(folderArray))
    Set secondLatestFolder = folderArray(UBound(folderArray) - 1)
    
    latestSize = GetFolderSize(latestFolder)
    secondLatestSize = GetFolderSize(secondLatestFolder)
    
    ' サイズの比較
    If latestSize <> secondLatestSize Then
        currentDateTime = Year(Now) & Right("0" & Month(Now), 2) & Right("0" & Day(Now), 2) &"_"& Right("0" & Hour(Now), 2) & Right("0" & Minute(Now), 2)
        
        ' "WORK" を削除
        Dim latestFolderName,latestFolderName2
        latestFolderName = latestFolder.Name
        latestFolderName2 = Replace(latestFolderName, "WORK_", "")
        objFSO.GetFolder(latestFolderName).Name=latestFolderName2
        newFolderName = folderPath & "\WORK_" & currentDateTime
        fso.CopyFolder latestFolder.Path, newFolderName
    Else
        MsgBox "フォルダのサイズに変更はありません。"
    End If
Else
    MsgBox "フォルダが2つ以上存在しません。"
   Dim singleFolder
    For Each singleFolder In subFolders
        currentDateTime = Year(Now) & Right("0" & Month(Now), 2) & Right("0" & Day(Now), 2) & Right("0" & Hour(Now), 2) & Right("0" & Minute(Now), 2)
        newFolderName = folderPath & "\WORK_" & currentDateTime
        fso.CopyFolder singleFolder.Path, newFolderName
        MsgBox "フォルダが1つしかないため、コピーしました。新しいフォルダ名: " & newFolderName
    Next

End If

' フォルダサイズを取得する関数
Function GetFolderSize(folder)
    Dim totalSize, subFolder, file
    totalSize = 0
    
    For Each file In folder.Files
        totalSize = totalSize + file.Size
    Next
    
    For Each subFolder In folder.SubFolders
        totalSize = totalSize + GetFolderSize(subFolder)
    Next
    
    GetFolderSize = totalSize
End Function

' QuickSortアルゴリズム
Sub QuickSort(arr, low, high)
    Dim i, j, pivot, temp
    i = low
    j = high
    pivot = arr((low + high) \ 2).DateCreated
    
    Do While i <= j
        Do While arr(i).DateCreated < pivot
            i = i + 1
        Loop
        Do While arr(j).DateCreated > pivot
            j = j - 1
        Loop
        If i <= j Then
            Set temp = arr(i)
            Set arr(i) = arr(j)
            Set arr(j) = temp
            i = i + 1
            j = j - 1
        End If
    Loop
    
    If low < j Then Call QuickSort(arr, low, j)
    If i < high Then Call QuickSort(arr, i, high)
End Sub
```