Convert VBScript to VBA (Copy and Replace Activeworkbook)

YasserKhalil · Sep 3, 2019

Can you help me with that point please?
What do you mean near a gas factory ..? Is it too bad you mean?

Marc L · Sep 3, 2019

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 …

YasserKhalil · Sep 3, 2019

I am sure you will have all the logic ...

Marc L · Sep 3, 2019

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 · Sep 3, 2019

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 · Sep 3, 2019

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) …

YasserKhalil · Sep 3, 2019

Thanks a lot for your interest ..
I hope you would help me with this last point ...

Marc L · Sep 3, 2019

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 · Sep 4, 2019

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 · Sep 4, 2019

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 · Sep 4, 2019

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 · Sep 4, 2019

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

Marc L · Sep 4, 2019

Well done !

YasserKhalil · Sep 4, 2019

Thank you very much for great and awesome help
Best and Kind Regards

Convert VBScript to VBA (Copy and Replace Activeworkbook)

YasserKhalil

Well-Known Member

Marc L

Excel Ninja

YasserKhalil

Well-Known Member

Marc L

Excel Ninja

YasserKhalil

Well-Known Member

Marc L

Excel Ninja

YasserKhalil

Well-Known Member

Marc L

Excel Ninja

YasserKhalil

Well-Known Member

Marc L

Excel Ninja

YasserKhalil

Well-Known Member

YasserKhalil

Well-Known Member

Marc L

Excel Ninja

YasserKhalil

Well-Known Member