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