【VBA】SeleniumBasicのchromedriverを自動更新する

Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" _
                         (ByVal lpApplicationName As String, _
                          ByVal lpKeyName As Any, _
                          ByVal lpDefault As String, _
                          ByVal lpReturnedString As String, _
                          ByVal nSize As Long, _
                          ByVal lpFileName As String) As Long
                           
Private Declare PtrSafe Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" _
                         (ByVal lpApplicationName As String, _
                          ByVal lpKeyName As Any, _
                          ByVal lpString As Any, _
                          ByVal lpFileName As String) As Long
                           
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
                        (ByVal pCaller As Long, _
                         ByVal szURL As String, _
                         ByVal szFileName As String, _
                         ByVal dwReserved As Long, _
                         ByVal lpfnCB As Long) As Long
#Else
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" _
                         (ByVal lpApplicationName As String, _
                          ByVal lpKeyName As Any, _
                          ByVal lpDefault As String, _
                          ByVal lpReturnedString As String, _
                          ByVal nSize As Long, _
                          ByVal lpFileName As String) As Long
                           
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" _
                         (ByVal lpApplicationName As String, _
                          ByVal lpKeyName As Any, _
                          ByVal lpString As Any, _
                          ByVal lpFileName As String) As Long
                           
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
                        (ByVal pCaller As Long, _
                         ByVal szURL As String, _
                         ByVal szFileName As String, _
                         ByVal dwReserved As Long, _
                         ByVal lpfnCB As Long) As Long
#End If
 
Private Type VersionClass '---本当はクラスオブジェクトにしたいけどこれだけのためにモジュール作りたくない
    Major As Long
    Minor As Long
    Build As Long
    Revision As Long
    FullVersion As String
    ShortVersion As String
End Type

Private Const CONFIG_FILE As String = "config.ini" '---chromedriverの情報を残すiniファイル
Private Const SECTION_NAME As String = "chromedriver" '---セクション名
Private Const CHROME_VERSION_KEY As String = "chrome_version"
Private Const CHROMEDRIVER_VERSION_KEY As String = "chromedriver_version"

Private Const DOWNLOAD_DIR_NAME As String = "drivercheck" '---chromedriverのzipファイルを保存するフォルダ名
Private Const DOWNLOAD_FILE_NAME As String = "chromedriver.zip" '---chromedriverのzipをダウンロードする時のファイル名
Public Function ChromeDriverAutoUpdate(Optional ByVal ForcedExecution As Boolean = False) As Boolean
'====================================================================================================
'chrome.exeとchromedriver.exeのバージョンを比較してchromedriverを自動更新する
'もしくは強制実行フラグ（ForcedExecution）がTrueでも実行する
'====================================================================================================
Dim chromePath As String '---chrome.exeが保存されているパス
Dim ChromeFullpath As String '---chrome.exeまで含めたフルパス
Dim ChromedriverPath As String '---chromedriverが保存されているパス
Dim ChromedriverVersion As VersionClass
Dim ChromeVersion As VersionClass
Dim objFso As Object

'---chrome本体のフォルダを探す
Set objFso = CreateObject("Scripting.FileSystemObject")
Select Case True
    Case objFso.FolderExists(Environ("ProgramW6432") & "\Google\Chrome\Application")
        chromePath = Environ("ProgramW6432") & "\Google\Chrome\Application"
    Case objFso.FolderExists(Environ("ProgramFiles") & "\Google\Chrome\Application")
        chromePath = Environ("ProgramFiles") & "\Google\Chrome\Application"
    Case objFso.FolderExists(Environ("LOCALAPPDATA") & "\Google\Chrome\Application")
        chromePath = Environ("LOCALAPPDATA") & "\Google\Chrome\Application"
    Case Else
        MsgBox "'chrome'フォルダが見つかりません", vbCritical
        ChromeDriverAutoUpdate = False
        Exit Function
End Select
'---念のためchrome.exeを確認する
If objFso.FileExists(chromePath & "\chrome.exe") = True Then
    ChromeFullpath = chromePath & "\chrome.exe"
Else
    MsgBox "'chrome.exe'が見つかりません", vbCritical
    Exit Function
End If
Set objFso = Nothing

'---SeleniumBasicのフォルダを探す
Set objFso = CreateObject("Scripting.FileSystemObject")
Select Case True
    Case objFso.FolderExists(Environ("ProgramW6432") & "\SeleniumBasic")
        ChromedriverPath = Environ("ProgramW6432") & "\SeleniumBasic"
    Case objFso.FolderExists(Environ("ProgramFiles") & "\SeleniumBasic")
        ChromedriverPath = Environ("ProgramFiles") & "\SeleniumBasic"
    Case objFso.FolderExists(Environ("LOCALAPPDATA") & "\SeleniumBasic")
        ChromedriverPath = Environ("LOCALAPPDATA") & "\SeleniumBasic"
    Case Else
        MsgBox "'SeleniumBasic'のフォルダが見つかりません", vbCritical
        ChromeDriverAutoUpdate = False
        Exit Function
End Select
'---念のためchromedriver.exeを確認する
If objFso.FileExists(ChromedriverPath & "\chromedriver.exe") = True Then
    
Else
    MsgBox "'chromedriver.exe'が見つかりません", vbCritical
    Exit Function
End If
Set objFso = Nothing

'---chrome.exeのバージョンを取得する
If GetChromeVersion(ChromeFullpath, ChromeVersion.Major, ChromeVersion.Minor, ChromeVersion.Build, ChromeVersion.Revision, ChromeVersion.FullVersion, ChromeVersion.ShortVersion) = False Then '---chrome.exeのバージョンを取得する
    MsgBox "'chrome.exe'のバージョンが取得できませんでした", vbCritical
    ChromeDriverAutoUpdate = False
    Exit Function
End If

'---chromedriver.exeのバージョンを取得する
If GetChromeDriverVersion(ChromedriverPath, ChromedriverVersion.Major, ChromedriverVersion.Minor, ChromedriverVersion.Build, ChromedriverVersion.Revision, ChromedriverVersion.FullVersion, ChromedriverVersion.ShortVersion) = False Then '---chromedriverのバージョンを取得する
    MsgBox "'chromedriver.exe'のバージョンが取得できませんでした", vbCritical
    ChromeDriverAutoUpdate = False
    Exit Function
End If

'---chrome.exeとchromedriver.exeのバージョンが不一致か強制実行フラグがTrueだったらexeとchromedriver.exeを更新する
If (ChromeVersion.FullVersion <> ChromedriverVersion.FullVersion) Or ForcedExecution Then
    '---chromeのバージョン情報でchromedriverを更新する ※本当はTargetPlatformをwin32とwin64のどちらにするか判定したい
    If UpdateChromeDriver(ChromedriverPath, ChromeVersion, ChromedriverVersion, ForcedExecution:=ForcedExecution, TargetPlatform:="win32") = True Then
        Call WritePrivateProfileString(SECTION_NAME, CHROME_VERSION_KEY, ChromeVersion.FullVersion, ChromedriverPath & "\" & CONFIG_FILE) '---chromeのバージョン情報をiniに上書きする
        Call WritePrivateProfileString(SECTION_NAME, CHROMEDRIVER_VERSION_KEY, ChromedriverVersion.FullVersion, ChromedriverPath & "\" & CONFIG_FILE) '---chromedriverのバージョン情報をiniに上書きする
    End If
End If
'---結果として更新していない場合もあるが、更新失敗じゃなくて更新不要な判定だからTrueにしている
ChromeDriverAutoUpdate = True
End Function
Private Function GetChromeVersion(ByVal ChromeFullpath As String, ByRef Major As Long, ByRef Minor As Long, ByRef Build As Long, ByRef Revision As Long, ByRef FullVersion As String, ByRef ShortVersion As String) As Boolean
'====================================================================================================
'PowerShellでchrome.exeのバージョン情報を取得する　※一瞬PowerShellが立ち上がる
'====================================================================================================
Dim strCmd As String
Dim objRet As Object

On Error GoTo ErrLabel
    '---chromeバージョン情報の初期値
    Major = 1
    Minor = 0
    Build = 0
    Revision = 0
    '---chrome.exeのバージョンを取得するPowerShellコマンド
    strCmd = "(Get-Item -Path '" & ChromeFullpath & "').VersionInfo.FileVersion"
    '---PowerShellの実行結果をセット
    Set objRet = CreateObject("WScript.Shell").EXEC("powershell -NoProfile -ExecutionPolicy Unrestricted " & strCmd)
    '---PowerShellのコマンドレットの実行結果を取得
    FullVersion = Trim(objRet.StdOut.ReadAll)
    '---情報の取得が終わったらオブジェクトをクリアする
    Set objRet = Nothing
    '---改行コードが含まれているから削除する
    FullVersion = Trim(Replace(Replace(Replace(FullVersion, vbCrLf, vbNullString), vbCr, vbNullString), vbLf, vbNullString))
    '---バージョン情報を分けて返す
    With CreateObject("VBScript.RegExp") '---正規表現の準備
        .Pattern = "\d+\.\d+\.\d+(\.\d+)?"
        .Global = True
        If .test(FullVersion) Then '---念のため正規表現でバージョン情報をチェックする
            Major = CLng(Split(FullVersion, ".")(0))
            Minor = CLng(Split(FullVersion, ".")(1))
            Build = CLng(Split(FullVersion, ".")(2))
            If UBound(Split(FullVersion, ".")) >= 3 Then Revision = CLng(Split(FullVersion, ".")(3)) '---リビジョン番号があれば※基本あるはず
            FullVersion = Join(Array(Major, Minor, Build, Revision), ".") '---念のためバージョン情報を再セットする
            ShortVersion = Join(Array(Major, Minor, Build), ".") '---リビジョンを覗いたショートバージョン情報をセットする
        Else '---正規表現不一致なら失敗で返す
            GetChromeVersion = False
            Exit Function
        End If
    End With
    GetChromeVersion = True
On Error GoTo 0
Exit Function
ErrLabel: '---予期せぬエラーの分岐
GetChromeVersion = False
End Function
Private Function GetChromeDriverVersion(ByVal ChromedriverPath As String, ByRef Major As Long, ByRef Minor As Long, ByRef Build As Long, ByRef Revision As Long, ByRef FullVersion As String, ByRef ShortVersion As String) As Boolean
'====================================================================================================
'chromedriver.exeと同じフォルダにconfig.iniを保存してバージョンを管理して取得している
'====================================================================================================
Dim intFF As Long
Dim objFso As Object

On Error GoTo ErrLabel
    Set objFso = CreateObject("Scripting.FileSystemObject")
    If objFso.FileExists(ChromedriverPath & "\" & CONFIG_FILE) Then
        FullVersion = ReadIni(ChromedriverPath & "\" & CONFIG_FILE, SECTION_NAME, CHROMEDRIVER_VERSION_KEY, Default)
        If FullVersion = "0" Then
            '---ファイルはあるけどキーがない時の分岐
            Major = 1
            Minor = 0
            Build = 0
            Revision = 0
        Else
            '---iniに情報がある時
            Major = CLng(Split(FullVersion, ".")(0))
            Minor = CLng(Split(FullVersion, ".")(1))
            Build = CLng(Split(FullVersion, ".")(2))
            Revision = CLng(Split(FullVersion, ".")(3))
        End If
        FullVersion = Join(Array(Major, Minor, Build, Revision), ".") '---リビジョンを覗いたショートバージョン情報をセットする
        ShortVersion = Join(Array(Major, Minor, Build), ".") '---リビジョンを覗いたショートバージョン情報をセットする
    Else '---config.iniが無いなら作る
        intFF = FreeFile
        Open ChromedriverPath & "\" & CONFIG_FILE For Output As #intFF
            Major = 1
            Minor = 0
            Build = 0
            Revision = 0
            FullVersion = Join(Array(Major, Minor, Build, Revision), ".") '---リビジョンを覗いたショートバージョン情報をセットする
            ShortVersion = Join(Array(Major, Minor, Build), ".") '---リビジョンを覗いたショートバージョン情報をセットする
            Print #intFF, "[" & SECTION_NAME & "]"
            Print #intFF, CHROME_VERSION_KEY & "=1.0.0.0"
            Print #intFF, CHROMEDRIVER_VERSION_KEY & "=1.0.0.0"
        Close
    End If
     
    If objFso.FolderExists(ChromedriverPath & "\" & DOWNLOAD_DIR_NAME) = True Then '---zip保存用フォルダが残っていたら一度削除する
        objFso.DeleteFolder ChromedriverPath & "\" & DOWNLOAD_DIR_NAME, True
    End If
    objFso.CreateFolder ChromedriverPath & "\" & DOWNLOAD_DIR_NAME
    Set objFso = Nothing
    GetChromeDriverVersion = True
On Error GoTo 0
Exit Function
ErrLabel: '---予期せぬエラーの分岐
GetChromeDriverVersion = False
End Function
Private Function UpdateChromeDriver(ByVal ChromedriverPath As String, _
                                    ByRef ChromeVersion As VersionClass, _
                                    ByRef ChromedriverVersion As VersionClass, _
                                    Optional ByVal ForcedExecution As Boolean = False, _
                                    Optional ByVal TargetPlatform As String = "win32") As Boolean
'====================================================================================================
'ビルドまでの情報が不一致だったらchromedriverをダウンロードする
'全リビジョンのバージョンが準備されるわけではないので準備されている中で一番近いバージョンを探している
'※TargetPlatformは固定にしているがwin64でもいいかもしれない
'====================================================================================================
Dim RC As Long
Dim strUrl As String
Dim objHttp As Object
Dim compatible_versions As Object
Dim compatible_version_key As Variant
Dim objRet As Object
Dim objVersion As Object
Dim objDownloads As Object
Dim tmpRevision As Long
Dim targetRevision As Long
Const JSON_ENDPOINTS_URL As String = "https://googlechromelabs.github.io/chrome-for-testing/known-good-versions-with-downloads.json"

On Error GoTo ErrLabel
    Set objHttp = CreateObject("MSXML2.XMLHTTP")
    With objHttp
        .Open "GET", JSON_ENDPOINTS_URL, False
        .Send
        Set objRet = JsonConverter.ParseJson(.responseText) '---JSON endpoints から情報を収集する
        Set compatible_versions = CreateObject("Scripting.Dictionary") '---対象候補を一時的に取得する
        For Each objVersion In objRet("versions")
            If objVersion("version") Like ChromeVersion.ShortVersion & "*" Then '---リビジョンを除いたバージョン情報が一致して入れば候補にする
                For Each objDownloads In objVersion("downloads")("chromedriver") '---取得対象をchromedriverに限定して
                    If objDownloads("platform") = TargetPlatform Then '---対象のplatformかチェックしてcompatible_versionsに追加する
                        compatible_versions.Add objVersion("version"), objDownloads("url")
                    End If
                Next
            End If
        Next
        Set objRet = Nothing
        
        targetRevision = 0 '---取得対象にするバージョンのリビジョンの初期値
        For Each compatible_version_key In compatible_versions.Keys
            tmpRevision = CLng(Replace(compatible_version_key, ChromeVersion.ShortVersion & ".", vbNullString)) '---バージョン情報からリビジョンだけ取得する
            If tmpRevision <= ChromeVersion.Revision Then '---取得対象（Chrome.exe）のリビジョン以下で候補の中の最大値を確認する
                If targetRevision < tmpRevision Then
                    targetRevision = tmpRevision
                End If
            End If
        Next
    End With
    Set objHttp = Nothing
    
    
    If (ChromeVersion.ShortVersion <> ChromedriverVersion.ShortVersion) Or _
        (targetRevision <> ChromedriverVersion.Revision) Or _
        ForcedExecution Then  '---ビルドまでの情報不一致orリビジョン情報不一致or強制実行フラグがTrueだったらダウンロードする
        strUrl = compatible_versions(ChromeVersion.ShortVersion & "." & CStr(targetRevision)) '---取得対象バージョン情報からchromedriverのURLを取得する
        RC = URLDownloadToFile(0, strUrl, ChromedriverPath & "\" & DOWNLOAD_DIR_NAME & "\" & DOWNLOAD_FILE_NAME, 0, 0) '---ファイルをダウンロードするWinAPI
        If RC = 0 Then
            Application.DisplayAlerts = False
            With CreateObject("Shell.Application") '---zipを既定のフォルダに向けて解凍する
                .Namespace((ChromedriverPath & "\" & DOWNLOAD_DIR_NAME)).CopyHere .Namespace((ChromedriverPath & "\" & DOWNLOAD_DIR_NAME & "\" & DOWNLOAD_FILE_NAME)).Items
            End With
            
            MoveFiles ChromedriverPath & "\" & DOWNLOAD_DIR_NAME, ChromedriverPath '---サブフォルダを含めて全てのファイルを移動する
            Application.DisplayAlerts = True
            UpdateChromeDriver = True
        Else
            UpdateChromeDriver = False
        End If
        
        '---ini上書き用に最終的なダッシュボードから取得できたchromedriverのバージョンで上書きする
        ChromedriverVersion = ChromeVersion
        With ChromedriverVersion
            .Revision = targetRevision
            .FullVersion = Join(Array(.Major, .Minor, .Build, .Revision), ".") '---リビジョンを覗いたショートバージョン情報をセットする
            .ShortVersion = Join(Array(.Major, .Minor, .Build), ".") '---リビジョンを覗いたショートバージョン情報をセットする
        End With
    End If
On Error GoTo 0
Exit Function
ErrLabel: '---予期せぬエラーの分岐
UpdateChromeDriver = False
End Function
Private Function MoveFiles(ByVal TransfereeFolder As String, ByVal DestinationFolder As String) As Boolean
'====================================================================================================
'移動元フォルダ（TransfereeFolder）にあるzip以外のファイルをサブフォルダ含めて全て移動先フォルダ（DestinationFolder）へ移動させる
'====================================================================================================
Dim objFso As Object
Dim objFolder As Object
Dim objFile As Object

On Error GoTo ErrLabel
    DestinationFolder = DestinationFolder & IIf(Right(DestinationFolder, 1) <> "\", "\", "") '---最後が\じゃないとエラーになるので追加する
    Set objFso = CreateObject("Scripting.FileSystemObject")
    For Each objFile In objFso.GetFolder(TransfereeFolder).Files
        If LCase(objFso.GetExtensionName(objFile.Path)) <> "zip" Then '---zipファイル以外を移動対象にする
            If objFso.FileExists(DestinationFolder & objFile.Name) = True Then '---移動先に同名ファイルがあったら削除する
                objFso.DeleteFile DestinationFolder & objFile.Name, True
            End If
            objFile.Move DestinationFolder
        End If
    Next
    
    For Each objFolder In objFso.GetFolder(TransfereeFolder).SubFolders '---再帰処理でサブフォルダをチェックする
        MoveFiles objFolder.Path, DestinationFolder
    Next
    Set objFso = Nothing
    MoveFiles = True
On Error GoTo 0
Exit Function
ErrLabel: '---予期せぬエラーの分岐
MoveFiles = False
End Function
Private Function ReadIni(ByVal FName As String, ByVal SName As String, ByVal KName As String, ByVal Default As String) As String
'====================================================================================================
'WinAPIでiniファイルから情報を取得する
'====================================================================================================
Dim retStr As String
Dim retCD As Long

retStr = Space$(256)
retCD = GetPrivateProfileString(SName, KName, Default, retStr, 255, FName)
' 戻り値設定
If retCD > 0 Then
    If InStr(retStr, Chr$(0)) > 0 Then
        ReadIni = Left$(retStr, InStr(retStr, Chr$(0)) - 1)
    Else
        ReadIni = ""
    End If
Else
    ReadIni = Default
End If
End Function

Sub main()
'---Chromedriverの自動更新 ※別モジュールを参照
If ChromeDriverAutoUpdateModule.ChromeDriverAutoUpdate Then
    Exit Sub
End If

'－－・－－・－－以下にプログラムを－－・－－・－－
End Sub