• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Convert VBScript to VBA (Copy and Replace Activeworkbook)

Marc L

Excel Ninja
Not sure as I don't have all the logic …​
If using a procedure in an independant workbook you do not ever need to interact between other workbooks via an event​
as it just needs to dowload a file, close old file if opened, copy downloaded file as new one, so very not difficult …​
Or now you understand why a VBScript …​
 

Marc L

Excel Ninja
As my logic is yet explained since several posts, again in last post so I do not ever need any event !​
So instead of guessing, the better is you must explain your context from A to Z so complete and as clear as possible …​
 

YasserKhalil

Well-Known Member
The issue in simple words:
----------------------------
* I will have a workbook with that will be distributed to many users and this workbook will be updated periodically (Myproject.xlsm)
* I will upload the latest version to Google Drive. I will also upload a word document with fixed link (included in the workbook_open event)
* The code in (MyProject.xlsm) workbook open event will check the current version with the version existed in the word document (uploded to Google Drive too) and if the current version is less that the version existing on Google Drive Document, then a message box appears to ask the user to download the newer version and the download process implemented (MyFiles.zip) is the downloaded file (password = 123)
* The files are extracted to ProgramData\MyFolder
* The point now that I am stuck at is that I need to copy and replace the old workbook with the new one .. and rename the old workbook with a different name with suffix of BAK (to refer to backup file)

That's the whole idea ..
 

Marc L

Excel Ninja
According to the last point :​
  • So the user must close the workbook MyProject.xlsm then launch whatever a VBScript or just another workbook, that's it !
    You can use a MsgBox to explain and confirm then the old workbook full name can be passed via a text file,
    the VBA registry space (post #25) …

  • If it's another workbook you can use the Name VBA function to rename the old workbook
    (and you can ever change the folder like the Move VBA function) …
 

Marc L

Excel Ninja
  • So what did you choose in order to save the old workbook full name ?

  • What did you choose to run, a VBScript or a workbook ?
 

YasserKhalil

Well-Known Member
Thanks a lot my tutor
As for saving the old workbook full name I think using registry is OK but to delete the entry at the end if possible
As for the second question: Workbook ... The main target of this thread is to not to use VBScript (It already works with VBScript >>> But causes antivirus problems)

Regards
 

Marc L

Excel Ninja
There is some ActiveX to read / modify whatever in the Windows Registry​
but VBA already has inner features to access the Windows Registry in its own area​
(SaveSetting - GetSetting - DeleteSetting like you can - must - see in the VBA help).​
So according to VBA help to save something to the registry : SaveSetting {appname}, {section}, {key}, {value}​
For your need it can be something like SaveSetting "YourProjectName", "Workbook", "Old", "C:\Folder\Workbook.xlsm" …​
To read the "Old" value :​
F = GetSetting("YourProjectName", "Workbook", "Old")
If F > "" Then
DeleteSetting "YourProjectName", "Workbook"
copy file here …​
End If
You can use constants for the fixed parameters when you need them several times within the same procedure.​
As a reminder see post #31 …​
 

YasserKhalil

Well-Known Member
Thanks a lot for your patience
Now I updated the code in MyProject.xlsm to be like that
Code:
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
Dim currVer As Single

Private Sub Workbook_Open()
    Dim objReq      As MSXML2.ServerXMLHTTP60
    Dim oApp        As Object
    Dim dlPath      As Variant
    Dim sFile       As String
    Dim strResponse As String
    Dim wbHelper    As String
    
    Const sURL      As String = "https://docs.google.com/document/d/e/2PACX-1vSnj9bynjBnlLyr60ExmmXWD1b-_qgfatglmDhLhIQaHM_8EvXC0zucOsWlLIlSfhyDUuuAWrRhWnF7/pub"
    
    currVer = 0.5
    Set objReq = New ServerXMLHTTP60

    With objReq
        .Open "GET", sURL, False
        .send
        If .Status = 200 Then
            strResponse = .responseText
            If Val(Trim(Split(Split(strResponse, "Version:")(1), "</span>")(0))) > currVer Then
                If MsgBox("You Have Newer Version. Would You Like To Download It?", vbYesNo + vbQuestion) = vbYes Then
                    dlPath = Environ("PROGRAMDATA") & "\MyFolder\"
                    sFile = "MyFiles.zip"
                    If Len(Dir(dlPath & "*.*")) > 0 Then Kill dlPath & "*.*"
                    If Len(Dir(dlPath, vbDirectory)) = 0 Then MkDir dlPath

                    URLDownloadToFile 0, Trim(Replace(Split(Split(strResponse, "Link:")(1), "</span>")(0), "open", "uc") & "&export=download"), dlPath & sFile, 0, 0
                    
                    Set oApp = CreateObject("Shell.Application")
                    oApp.Namespace(dlPath).CopyHere oApp.Namespace(dlPath & sFile).items
                    SaveSetting "MyProjectEntry", "Workbook", "Old", ThisWorkbook.FullName
                    wbHelper = dlPath & "\TempWorkbook.xlsm"
                    
                    If Dir(wbHelper) > "" Then
                        Workbooks.Open wbHelper
                        ThisWorkbook.Close False
                    Else
                        MsgBox "Update Not Completed. Make Sure " & wbHelper & " Exists", vbCritical
                    End If
                End If
            End If
        End If
        .abort
    End With
End Sub
Now as you advised, I stored the variable in this line
Code:
SaveSetting "MyProjectEntry", "Workbook", "Old", ThisWorkbook.FullName
So I have the path of the old workbook stored in the registry
Till now everything is fine
-------------------------------------------------------------------------------

Now in the TempWorkbook.xlsm in workbook_open event I put these lines to retrieve the path of the old workbook and to close the old workbook
Code:
Private Sub Workbook_Open()
    Dim sOldWorbook As String
    sOldWorbook = GetSetting("MyProjectEntry", "Workbook", "Old")
    Workbooks(Split(sOldWorbook, "\")(UBound(Split(sOldWorbook, "\")))).Close False
    
    MsgBox "OK"
    Stop
End Sub
I get the old workbook closed and now the TempWorkbook is open but I didn't get the message box
The code stops after the Close line
Code:
Workbooks(Split(sOldWorbook, "\")(UBound(Split(sOldWorbook, "\")))).Close False
 

YasserKhalil

Well-Known Member
At last it is solved ... Thanks a lot Mr. Kenneth and Mr. Marc for great contributions

For those who are insterested
--------------------------------
** On Google Drive there will be a folder and inside that folder there will be two files
1) MyProjectFiles.zip
The zipped file has two workbooks. The first one is "MyProject.xlsm". The second one is "TempWorkbook.xlsm"
2) MyLink
This will have two lines which indicates the version number and the link of MyProjectFiles.zip. Right-click on MyLink file >> Open with 'Google Docs' and insert the lines
Code:
Version: 1.0
Link: https://drive.google.com/open?id=1f81uCVN0XYofvO8dRHWxa5KL_hy_fOgp
The VBA Codes in "MyProject.xlsm" in workbook_open event
Code:
Option Explicit

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
Dim currVer As Single

Private Sub Workbook_Open()
    Dim objReq      As MSXML2.ServerXMLHTTP60
    Dim oApp        As Object
    Dim dlPath      As Variant
    Dim sFile       As String
    Dim strResponse As String
    Dim wbHelper    As String
  
    Const sURL      As String = "https://docs.google.com/document/d/e/2PACX-1vSnj9bynjBnlLyr60ExmmXWD1b-_qgfatglmDhLhIQaHM_8EvXC0zucOsWlLIlSfhyDUuuAWrRhWnF7/pub"
  
    dlPath = Environ("PROGRAMDATA") & "\MyFolder\"
    On Error Resume Next
        If Len(Dir(dlPath & "*.*")) > 0 Then Kill dlPath & "*.*": RmDir dlPath
        If Len(Dir(Environ("TEMP") & "\TempWorkbook.xlsm")) > 0 Then Kill Environ("TEMP") & "\TempWorkbook.xlsm"
        DeleteSetting "MyProjectEntry"
    On Error GoTo 0
  
    currVer = 1
    Set objReq = New ServerXMLHTTP60

    With objReq
        .Open "GET", sURL, False
        .send
        If .Status = 200 Then
            strResponse = .responseText
            If Val(Trim(Split(Split(strResponse, "Version:")(1), "</span>")(0))) > currVer Then
                If MsgBox("You Have Newer Version. Would You Like To Download It?", vbYesNo + vbQuestion) = vbYes Then
                    sFile = "MyProjectFiles.zip"
                    If Len(Dir(dlPath, vbDirectory)) = 0 Then MkDir dlPath
                    URLDownloadToFile 0, Trim(Replace(Split(Split(strResponse, "Link:")(1), "</span>")(0), "open", "uc") & "&export=download"), dlPath & sFile, 0, 0
                  
                    Set oApp = CreateObject("Shell.Application")
                    oApp.Namespace(dlPath).CopyHere oApp.Namespace(dlPath & sFile).items
                  
                    With CreateObject("Scripting.Filesystemobject")
                        If .FileExists(dlPath & "TempWorkbook.xlsm") Then .MoveFile dlPath & "TempWorkbook.xlsm", Environ("TEMP") & "\TempWorkbook.xlsm"
                    End With
                  
                    SaveSetting "MyProjectEntry", "Workbook", "Old", ThisWorkbook.FullName
                    wbHelper = Environ("TEMP") & "\TempWorkbook.xlsm"
                  
                    If Dir(wbHelper) > "" Then
                        Workbooks.Open wbHelper
                    Else
                        MsgBox "Update Not Completed. Make Sure " & wbHelper & " Exists", vbCritical
                    End If
                End If
            End If
        End If
        .abort
    End With
End Sub
And the code in "TempWorkbook.xlsm" in workbook_open event
Code:
Private Sub Workbook_Open()
    Application.OnTime Now + TimeSerial(0, 0, 1), "CloseOldProject"
End Sub
And in Module1 (in the "TempWorkbook.xlsm")
Code:
Option Explicit

Const sNewWorkbook = "C:\ProgramData\MyFolder\MyProject.xlsm"

Sub CloseOldProject()
    Dim sOldWorbook As String
  
    sOldWorbook = GetSetting("MyProjectEntry", "Workbook", "Old")
    Workbooks(Split(sOldWorbook, "\")(UBound(Split(sOldWorbook, "\")))).Close False
  
    If Dir(sNewWorkbook) > "" Then CreateObject("Scripting.FileSystemObject").CopyFile sNewWorkbook, sOldWorbook
    Workbooks.Open (sOldWorbook)
  
    With ThisWorkbook
        .Save
        .ChangeFileAccess Mode:=xlReadOnly
        Kill .FullName
        .Close SaveChanges:=False
    End With
End Sub
By the way, similar issue posted here at
https://ask.wellsr.com/817/download-and-install-newer-version-of-excel-file-with-vba
 
Top