问将新版本从Google推送给用户(VBA)

EN

Public filetypeNewVersion As String
Public myURL As String
Public newURL As String
Public MostUpdated As Boolean
Public WhatsNewInVersion As String
Public versionNumINT As Long
Public FilePath As String

Sub RunDownloadGoogleDriveVersion()
Call DownloadGoogleDrive(PushVersion.Range("A3"), "doc", False) ' downloads Google doc file as TXT without opening the folder path
Call TextIORead(PushVersion.Range("C3")) ' If a newer version is avialable it will read its path on Google drive
filetypeNewVersion = PushVersion.Range("B4") 'docs\drive\folder

If filetypeNewVersion <> "folder" Then 'if filetypeNewVersion is "doc" (Google doc or Google Sheets) or "drive" (e.g. EXCEL, PDF, WORD, ZIP etc)
        If Not MostUpdated Then
            PushVersion.Range("A4") = newURL
            Call DownloadGoogleDrive(newURL, PushVersion.Range("B4"), True)
        End If
Else 'if filetypeNewVersion is "folder"
        If Not MostUpdated Then
            Shell ("C:\Program Files (x86)\Google\Chrome\Application\Chrome.exe -url " & myURL) '' shell works, ThisWorkbook.FollowHyperlink myURL does not work (opens msg "Update your browser to use Google Drive")
            End 'Just opens link to download but doesn't automatically downlaod.
                'For downloading a whole folder in Google Drive (as ZIP file) we will íô÷î URL and let the user manually click
                'because unfortunately there is no simple way to download a whole folder programmatically
                '(even with Google API in year 2022).  Folder URL: https://drive.google.com/drive/folders/[FileID]?usp=sharing
        End If
End If
End Sub
  
' myOriginalURL - The original google drive URL path (Before modifications of UrlLeft & FileID & UrlRight)
' filetypeNewVersion - doc/ drive/folder (see CASE in filetypeNewVersion)
' OpenFolderPath- open new file? the first time use False, the second time you can choose True.
Sub DownloadGoogleDrive(myOriginalURL As String, filetypeNewVersion As String, OpenFolderPath As Boolean)
Dim FileID As String
Dim UrlLeft As String
Dim UrlRight As String
Dim wasDownloaded As Boolean
Dim FolderPath As String
Application.ScreenUpdating = False

Select Case filetypeNewVersion
    Case "doc" 'for Google doc or Google Sheets
        ' myOriginalURL = "https://drive.google.com/file/d/..." ''This is used in TXT file "myVersionUpdateWarning"
        UrlLeft = "https://docs.google.com/document/d/"
        UrlRight = "/export?format=txt"
        FileID = Split(myOriginalURL, "/d/")(1) ''split after "/d/"
        FileID = Split(FileID, "/")(0)  ''split before single "/"
        myURL = UrlLeft & FileID & UrlRight
    Case "drive" 'for a local file e.g. EXCEL, PDF, WORD, ZIP that is saved in Google Drive
        UrlLeft = "http://drive.google.com/u/0/uc?id="
        UrlRight = "&export=download"
        FileID = Split(myOriginalURL, "/d/")(1) ''split after "/d/"
        FileID = Split(FileID, "/")(0)  ''split before single "/"
        myURL = UrlLeft & FileID & UrlRight
    Case "folder"
         UrlLeft = "https://drive.google.com/drive/folders/"
         UrlRight = ""
         FileID = Split(myOriginalURL, "/folders/")(1) ''split after "/folders/"
         FileID = Split(FileID, "?")(0)  ''split before single "?"
         myURL = UrlLeft & FileID & UrlRight
    Case Else
        MsgBox "Wrong file type", vbCritical
        End
End Select
'Debug.Print myURL

Call GetFileNameAndSaveToFilePath(myURL)

   If FileExists(FilePath) Then
              wasDownloaded = True
              ''open folder path location to look at the downloded file
             If OpenFolderPath Then Call Shell("explorer.exe" & " " & FolderPath, vbNormalFocus)
        Else
              wasDownloaded = False
              MsgBox "Download failed", vbCritical
  End If
  
 Application.ScreenUpdating = True
Exit Sub
skip:
 Application.ScreenUpdating = True
   MsgBox "Tried to download file with same name as current file," & vbCrLf & _
          "check in google docs the version number and link are correct", vbCritical
End Sub


'TextIORead opens a text file, retrieving some text, closes the text file.
Sub TextIORead(TXTname As String)
On Error GoTo skip
  Dim sFile As String
  Dim iFileNum As Long
  Dim sText As String
  Dim versionNum As String
  sFile = ThisWorkbook.path & "\" & TXTname
  
  If Not FileExists(sFile) Then
        MsgBox "version download doc file not found", vbCritical
        End
  End If

'For Input - extract information. modify text not available in this mode.
'FreeFile - supply a file number that is not already in use. This is similar to referencing Workbook(1) vs. Workbook(2).
'By using FreeFile, the function will automatically return the next available reference number for your text file.
  iFileNum = FreeFile
  Open sFile For Input As iFileNum
  Input #iFileNum, sText
  Close #iFileNum
  
versionNum = Split(sText, ";")(0)
versionNum = Replace(versionNum, "", "") ''junk caused by the UTF-8 BOM that can't be changed when downloading from google docs
versionNumINT = VBA.CLng(versionNum)
newURL = Split(sText, ";")(1)
WhatsNewInVersion = Split(sText, ";")(2) ' split by semi-colons but also "," splits it!!!!?!

MostUpdated = CheckVersionMostUpdated(versionNum, newURL)
''Comment out for tests- sFile is just a temporary file that the user doesn't need and can just be deleted.
Kill sFile
Exit Sub
skip:
MsgBox "The updated file was not found, please contact the developer for the new version", vbCritical
End Sub

''Compares Version of ThisWorkbook to doc file in google drive
''called by TextIORead sub
Function CheckVersionMostUpdated(ByVal versionNum As String, ByVal newURL As String) As Boolean
Dim wkbVersion As String
Dim wkbVersionINT As Long
Dim response As String
wkbVersion = ThisWorkbook.Name
wkbVersion = Split(wkbVersion, "_")(1)
wkbVersion = Split(wkbVersion, ".")(0)
wkbVersionINT = VBA.CLng(wkbVersion)
'Debug.Print wkbVersion
CheckVersionMostUpdated = True
If versionNumINT > wkbVersionINT Then
''Hebrew Display problems caused by the UTF-8 BOM:  https://www.w3.org/International/questions/qa-utf8-bom.en.html
MsgBox WhatsNewInVersion, vbInformation
' Download new version?
    response = MsgBox("This workook version: " & wkbVersion & vbCrLf & _
    "Available version: " & versionNum & vbCrLf & _
    "There is a newer version available, Download to the current file folder?", vbOKCancel + vbQuestion)
    If response = vbOK Then CheckVersionMostUpdated = False
    If response = vbCancel Then CheckVersionMostUpdated = True
    Else
    MsgBox "You have the most updated version", vbInformation
End If
End Function

''checks if a file is in a local path
Function FileExists(FilePath As String) As Boolean
Dim TestStr As String
    TestStr = ""
    On Error Resume Next
    TestStr = Dir(FilePath)
    On Error GoTo 0
    FileExists = True
    If TestStr = "" Then
        FileExists = False
    End If
End Function

'Gets a FileName on Google drive by URL And Saves the file To a local FilePath with its original name
Sub GetFileNameAndSaveToFilePath(ByVal myURL As String)
Dim xmlhttp As Object
Dim name0 As Variant
Dim oStream As Object
Dim FolderPath As String

 ''This part is gets the file name in google drive by URL
Set xmlhttp = CreateObject("winhttp.winhttprequest.5.1")
        xmlhttp.Open "GET", myURL, False  ', "username", "password"
        xmlhttp.Send
'  Debug.Print xmlhttp.responseText
On Error Resume Next
        name0 = xmlhttp.getResponseHeader("Content-Disposition")
    If Err.Number = 0 Then
            If name0 = "" Then
                  MsgBox "file name not found", vbCritical
                  Exit Sub
             End If
                  name0 = Split(name0, "=""")(1) ''split after "=""
                  name0 = Split(name0, """;")(0)  ''split before "";"
'                  Debug.Print name0
'                  Debug.Print FilePath
    End If
        
   If Err.Number <> 0 Then
         Err.Clear
'         Debug.Print xmlhttp.responseText
        ''<a href="/open?id=FileID">JustCode_CodeUpdate.bas</a>
         name0 = xmlhttp.responseText
         name0 = ExtractPartOfstring(name0)
    End If
On Error GoTo 0

    FolderPath = ThisWorkbook.path
    If name0 <> "" Then
        FilePath = FolderPath & "\" & name0
    End If
    
 ''This part is does the same as Windows API URLDownloadToFile function(no declarations needed)
 On Error GoTo skip
    If xmlhttp.Status = 200 Then
        Set oStream = CreateObject("ADODB.Stream")
        With oStream
                .Open
                .Charset = "utf-8"
                .Type = 1  'Binary Type
                .Write xmlhttp.responseBody
                .SaveToFile FilePath, 2 ' 1 = no overwrite, 2 = overwrite
                .Close
        End With
    End If
    
     Application.ScreenUpdating = True
Exit Sub
 Application.ScreenUpdating = True
skip:
   MsgBox "Tried to download file with same name as current file," & vbCrLf & _
          "check in google docs the version number and link are correct", vbCritical
End Sub

' string manipulation- get the part string "JustCode_CodeUpdate.bas" from mystring
'' mystring= <a href="/open?id=1HYx4987q2dB1M1OEginG5dTnD2SIwsy-">JustCode_CodeUpdate.bas</a>
Function ExtractPartOfstring(ByVal mystring As String) As String
  Dim first As Long, second As Long
  second = InStr(mystring, "</a>")
  first = InStrRev(mystring, ">", second)
  ExtractPartOfstring = Mid$(mystring, first + 1, second - first - 1)
'  Debug.Print ExtractPartOfstring
End Function

Public myPath As String
Const ModuleName As String = "JustCode_SomeCodeToReplace"

Sub RunDownloadCODEGoogleDriveVersion()
Dim response As String
''myOriginalURL - The original google drive URL path (Before modifications of UrlLeft & FileID & UrlRight)
' filetypeNewVersion - doc/ drive (see CASE in filetypeNewVersion)
' OpenFolderPath- open new file? the first time false, the second time can be true.
Call DownloadGoogleDrive(PushVersion.Range("A5"), "doc", False)
Call TextIORead(PushVersion.Range("C5"))  ' If a newer version is avialable it will return MostUpdated=FALSE as global variable
''If MostUpdated=FALSE Run DownloadGoogleDrive to updated workbook, otherwise do nothing.
If Not MostUpdated Then
    PushVersion.Range("A6") = newURL
' if Downloads aleardy has the file delete it so the downloaded file won't be renamed to filename(1)
    myPath = Environ$("USERPROFILE") & "\Downloads\" & ModuleName & ".bas"
    Kill myPath
    ' open browser with google drive download path
    ThisWorkbook.FollowHyperlink Address:=newURL
' User has to Download the BAS file manually to his Downloads folder
    response = MsgBox("First confirm download BAS file to your download folder " & vbCrLf & _
    "then Press 'OK'", vbOKCancel + vbQuestion)
    If response = vbOK Then UpdateCodeGoogleDrive
End If
End Sub

'' Update code from a location on Google drive

Public Sub UpdateCodeGoogleDrive()
    On Error GoTo skip
    'include reference to "Microsoft Visual Basic for Applications Extensibility 5.3"
    Dim vbproj As VBProject
    Dim vbc As VBComponent
    Set vbproj = ThisWorkbook.VBProject

'Error will occur if a component with this name is not in the project, so this will help avoid the error
Set vbc = vbproj.VBComponents.Item(ModuleName)
If Err.Number <> 0 Then
    Err.Clear
    vbproj.VBComponents.Import myPath
    If Err.Number <> 0 Then GoTo skip
Else
    'no error - vbc should be valid object
    'remove existing version first before adding new version
    vbproj.VBComponents.Remove vbc
    vbproj.VBComponents.Import myPath
    If Err.Number <> 0 Then GoTo skip
End If

Exit Sub
skip:
MsgBox "Could not update VBA code from: " & myPath & "Sub UpdateCodeGoogleDrive"
End Sub

''https://support.microfocus.com/kb/doc.php?id=7021399

'Tools > References> select the Microsoft Visual Basic for Applications Extensibility

Public Sub UpdateCodeLocalpath()
Const myPath As String = "X:\SharedMacroCode\JustCode_SomeCodeToReplace.bas"
Const ModuleName As String = "JustCode_SomeCodeToReplace"

On Error Resume Next

'include reference to "Microsoft Visual Basic for Applications Extensibility 5.3"
Dim vbproj As VBProject
Dim vbc As VBComponent
Set vbproj = ThisWorkbook.VBProject

'Error will occur if component with this name is not in the project, so this will help avoid the error
Set vbc = vbproj.VBComponents.Item(ModuleName)
If Err.Number <> 0 Then
    Err.Clear
    vbproj.VBComponents.Import myPath
    If Err.Number <> 0 Then GoTo skip
Else
    'no error - vbc should be valid object
    'remove existing version first before adding new version
    vbproj.VBComponents.Remove vbc
    vbproj.VBComponents.Import myPath
    If Err.Number <> 0 Then GoTo skip
End If

Exit Sub
skip:
MsgBox "Could not update VBA code from: " & myPath & "Sub UpdateCodeLocalpath"
End Sub

Private Sub Workbook_Open()
'check if an updated version is available
Application.AutoFormatAsYouTypeReplaceHyperlinks = False
RunDownloadGoogleDriveVersion
End Sub