将新版本从 Google 驱动器推送给用户 (VBA)
Push new version from Google Drive to users (VBA)
从 Google Drive (VBA)
向用户推送新版本
我在这里介绍的所有 3 种方法都按原样工作，但方法 1+2 从 Google 文档下载一个 TXT 文件以从云中提取信息，也许这部分可以简化？非常感谢您的见解和赞成票。
你建立了一个伟大的 Excel sheet。你分享它，得到它的人都会喜欢它，而且它会被传递得更多——你甚至不知道传递给了谁。
然后它发生了 - 文件中需要更改一些内容：工作中的一些值更改sheet，一些值是硬编码的，用户无法更改，
你想到另一个有用的功能，它连接的数据库移动到一个新的服务器，你发现一个错误，你如何让每个人都知道？如果您甚至不知道这些用户是谁，您如何告诉文件的用户有可用的更新版本？
也许您懒得收集和管理用户的邮件列表。
方法 1 归功于 Florian Lindstaedt：
how-to-recall-an-old-excel-spreadsheet-version-control-with-vba
本方案解决的现有方案缺点：
● 一些解决方案需要保存用户的电子邮件并向多个用户发送邮件。如果有人分享文件，无论谁收到文件，都不会收到版本更新。
● 一些解决方案要求开发人员注册到 Zapeir 或 Integrate 帐户才能配置 webhooks。
● 一些解决方案需要一个固定的文件名（新文件名不能从Google驱动器中获取）。
● 一些解决方案需要使用Google API，其中包括一组必须配置的复杂权限（使用令牌颁发和密码进行身份验证）。由于在我们的例子中文件是共享的 publicly，可以避免对此类权限的需求，因此可以实现更简单的解决方案。
它是如何工作的？
原始文件通过永久 link 从 Google 文档下载一个 TXT 文件，其中包含以下数据：
最新版本号； new link 到新文件版本；新版本中的更新。
如果在打开文件时有更新版本，用户将收到有关其存在及其包含的更新的通知，并请求允许从 Google 驱动器将新版本下载到与原始文件相同的文件路径。
P.s 如果不将 google 文档下载为 TXT，Florian Lindstaedts 解决方案对我不起作用。
本地文件 VBA 版本更新（VBA 包含在您分发的原始文件中）。
验证文件的更新版本是否可用并下载它。
google 驱动器上的 Google 文档文件将以“;”分隔格式：
[新版本号] ; [Google 驱动 link] ; [WhatsNewInVersion 向用户显示的消息] 例如：
8;https://drive.google.com/file/d/[FileID]/view?usp=sharing; 有新版本可用。
方法 1：从 Google 驱动器向用户推送新文件版本 (VBA)
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
方法 2：将新代码从 Google 驱动器推送到原始用户文件 (VBA)
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
方法 3：将新代码从本地网络上的共享路径推送到原始用户文件 (VBA)
''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
Workbook_Open
每次打开工作簿时都会调用 RunDownloadGoogleDriveVersion 并安静地调用
根据文件的内容从 public GoogleDrive 文件夹下载一个文本文件
文本文件新工作簿路径将用于下载新版本。
Private Sub Workbook_Open()
'check if an updated version is available
Application.AutoFormatAsYouTypeReplaceHyperlinks = False
RunDownloadGoogleDriveVersion
End Sub
从 Google Drive (VBA)
向用户推送新版本
本方案解决的现有方案缺点：
● 一些解决方案需要保存用户的电子邮件并向多个用户发送邮件。如果有人分享文件，无论谁收到文件，都不会收到版本更新。
● 一些解决方案要求开发人员注册到 Zapeir 或 Integrate 帐户才能配置 webhooks。
● 一些解决方案需要一个固定的文件名（新文件名不能从Google驱动器中获取）。
● 一些解决方案需要使用Google API，其中包括一组必须配置的复杂权限（使用令牌颁发和密码进行身份验证）。由于在我们的例子中文件是共享的 publicly，可以避免对此类权限的需求，因此可以实现更简单的解决方案。
它是如何工作的？
原始文件通过永久 link 从 Google 文档下载一个 TXT 文件，其中包含以下数据：
最新版本号； new link 到新文件版本；新版本中的更新。
如果在打开文件时有更新版本，用户将收到有关其存在及其包含的更新的通知，并请求允许将新版本从 Google 驱动器下载到与原始文件相同的文件路径。
P.s 如果不将 google 文档下载为 TXT，Florian Lindstaedts 解决方案对我不起作用。
本地文件 VBA 版本更新（VBA 包含在您分发的原始文件中）。
验证文件的更新版本是否可用并下载它。
google 驱动器上的 Google 文档文件将以“;”分隔格式：
[新版本号] ; [Google 驱动器 link] ; [WhatsNewInVersion 向用户显示的消息] 例如：
8;https://drive.google.com/file/d/[FileID]/view?usp=sharing; 有新版本可用。
方法 1：从 Google 驱动器向用户推送新文件版本 (VBA)
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
方法 2：将新代码从 Google 驱动器推送到原始用户文件 (VBA)
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
方法 3：将新代码从本地网络上的共享路径推送到原始用户文件 (VBA)
''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
Workbook_Open
每次打开工作簿时都会调用 RunDownloadGoogleDriveVersion 并安静地调用
根据文件的内容从 public GoogleDrive 文件夹下载一个文本文件
文本文件新工作簿路径将用于下载新版本。
Private Sub Workbook_Open()
'check if an updated version is available
Application.AutoFormatAsYouTypeReplaceHyperlinks = False
RunDownloadGoogleDriveVersion
End Sub
从 Google Drive (VBA)
向用户推送新版本我在这里介绍的所有 3 种方法都按原样工作，但方法 1+2 从 Google 文档下载一个 TXT 文件以从云中提取信息，也许这部分可以简化？非常感谢您的见解和赞成票。
你建立了一个伟大的 Excel sheet。你分享它，得到它的人都会喜欢它，而且它会被传递得更多——你甚至不知道传递给了谁。 然后它发生了 - 文件中需要更改一些内容：工作中的一些值更改sheet，一些值是硬编码的，用户无法更改， 你想到另一个有用的功能，它连接的数据库移动到一个新的服务器，你发现一个错误，你如何让每个人都知道？如果您甚至不知道这些用户是谁，您如何告诉文件的用户有可用的更新版本？ 也许您懒得收集和管理用户的邮件列表。
方法 1 归功于 Florian Lindstaedt：
how-to-recall-an-old-excel-spreadsheet-version-control-with-vba
本方案解决的现有方案缺点：
● 一些解决方案需要保存用户的电子邮件并向多个用户发送邮件。如果有人分享文件，无论谁收到文件，都不会收到版本更新。
● 一些解决方案要求开发人员注册到 Zapeir 或 Integrate 帐户才能配置 webhooks。
● 一些解决方案需要一个固定的文件名（新文件名不能从Google驱动器中获取）。
● 一些解决方案需要使用Google API，其中包括一组必须配置的复杂权限（使用令牌颁发和密码进行身份验证）。由于在我们的例子中文件是共享的 publicly，可以避免对此类权限的需求，因此可以实现更简单的解决方案。
它是如何工作的？
原始文件通过永久 link 从 Google 文档下载一个 TXT 文件，其中包含以下数据： 最新版本号； new link 到新文件版本；新版本中的更新。 如果在打开文件时有更新版本，用户将收到有关其存在及其包含的更新的通知，并请求允许从 Google 驱动器将新版本下载到与原始文件相同的文件路径。 P.s 如果不将 google 文档下载为 TXT，Florian Lindstaedts 解决方案对我不起作用。
本地文件 VBA 版本更新（VBA 包含在您分发的原始文件中）。 验证文件的更新版本是否可用并下载它。
google 驱动器上的 Google 文档文件将以“;”分隔格式： [新版本号] ; [Google 驱动 link] ; [WhatsNewInVersion 向用户显示的消息] 例如：
8;https://drive.google.com/file/d/[FileID]/view?usp=sharing; 有新版本可用。
方法 1：从 Google 驱动器向用户推送新文件版本 (VBA)
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
方法 2：将新代码从 Google 驱动器推送到原始用户文件 (VBA)
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
方法 3：将新代码从本地网络上的共享路径推送到原始用户文件 (VBA)
''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
Workbook_Open
每次打开工作簿时都会调用 RunDownloadGoogleDriveVersion 并安静地调用 根据文件的内容从 public GoogleDrive 文件夹下载一个文本文件 文本文件新工作簿路径将用于下载新版本。
Private Sub Workbook_Open()
'check if an updated version is available
Application.AutoFormatAsYouTypeReplaceHyperlinks = False
RunDownloadGoogleDriveVersion
End Sub
从 Google Drive (VBA)
向用户推送新版本本方案解决的现有方案缺点：
● 一些解决方案需要保存用户的电子邮件并向多个用户发送邮件。如果有人分享文件，无论谁收到文件，都不会收到版本更新。
● 一些解决方案要求开发人员注册到 Zapeir 或 Integrate 帐户才能配置 webhooks。
● 一些解决方案需要一个固定的文件名（新文件名不能从Google驱动器中获取）。
● 一些解决方案需要使用Google API，其中包括一组必须配置的复杂权限（使用令牌颁发和密码进行身份验证）。由于在我们的例子中文件是共享的 publicly，可以避免对此类权限的需求，因此可以实现更简单的解决方案。
它是如何工作的？
原始文件通过永久 link 从 Google 文档下载一个 TXT 文件，其中包含以下数据： 最新版本号； new link 到新文件版本；新版本中的更新。 如果在打开文件时有更新版本，用户将收到有关其存在及其包含的更新的通知，并请求允许将新版本从 Google 驱动器下载到与原始文件相同的文件路径。 P.s 如果不将 google 文档下载为 TXT，Florian Lindstaedts 解决方案对我不起作用。
本地文件 VBA 版本更新（VBA 包含在您分发的原始文件中）。 验证文件的更新版本是否可用并下载它。
google 驱动器上的 Google 文档文件将以“;”分隔格式： [新版本号] ; [Google 驱动器 link] ; [WhatsNewInVersion 向用户显示的消息] 例如：
8;https://drive.google.com/file/d/[FileID]/view?usp=sharing; 有新版本可用。
方法 1：从 Google 驱动器向用户推送新文件版本 (VBA)
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
方法 2：将新代码从 Google 驱动器推送到原始用户文件 (VBA)
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
方法 3：将新代码从本地网络上的共享路径推送到原始用户文件 (VBA)
''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
Workbook_Open
每次打开工作簿时都会调用 RunDownloadGoogleDriveVersion 并安静地调用 根据文件的内容从 public GoogleDrive 文件夹下载一个文本文件 文本文件新工作簿路径将用于下载新版本。
Private Sub Workbook_Open()
'check if an updated version is available
Application.AutoFormatAsYouTypeReplaceHyperlinks = False
RunDownloadGoogleDriveVersion
End Sub