Een invoegtoepassing bijwerken via internet

Inhoud

Inleiding
Aannames voor dit artikel
Update mechanisme
Update modi
Code
Download een Demo

Inleiding

Wanneer je een invoegtoepassing aanbiedt via je website, heb je meestal niet de mogelijkheid contact te onderhouden met de mensen die je programmeerwerk gebruiken. Het kan handig zijn als je gebruikers op de hoogte gehouden worden van updates (veel applicaties hebben dergelijke functionaliteit ingebouwd, zoals Windows en vele virus scanners). Dit kleine artikel laat zien hoe je dergelijke functionaliteit in je eigen invoegtoepassingen kunt inbouwen.

Aannames voor dit artikel

Ik ga uit van de volgende zaken:

Alleen de invoegtoepassing zelf wordt bijgewerkt, niet mogelijke bijbehorende bestanden;
De naam van het bestand dat moet worden gedownload is gelijk aan de bestandsnaam van de invoegtoepassing;
De invoegtoepassing heeft een build (=versie) nummer.
Er is een html pagina op je website (of je genereert er een gebruik makend van een database en een query in enige php of asp code) welke niets anders bevat dan het build nummer (geen HTML tags om het nummer heen);

Update mechanisme

Het update proces werkt als volgt:

De invoegtoepassing controleert wanneer voor het laatst is gekeken naar updates;
Als dit meer dan 7 dagen geleden is (of nog nooit is gebeurd), dan wordt de controle gestart;
De invoegtoepassing haalt het build nummer op van de website en vergelijkt de build nummers met elkaar;
Als het build nummer op de site hoger is, dan wordt toestemming gevraagd de nieuwere versie te downloaden;
De huidige invoetoepassing slaat zichzelf op onder een nieuwe naam, waarbij "(OldVersion)" aan de bestandsnaam wordt toegevoegd;

Noot: Ik heb geprobeerd of ik door het bestand van de invoegtoepassing als readonly aan te duiden het bestand kon verwijderen, ondanks dat deze in Excel geopend is, maar dit kon ik niet werkend krijgen.

De nieuwe file wordt gedownload en een bericht wordt getoond dat de gebruiker Excel moet sluiten en weer openen om deze in gebruik te nemen.
Excel opent automatisch het nieuwe bestand. De code in het bestand verwijdert automatisch het bestand dat "(OldVersion)" achter haar naam heeft staan.

Update modi

De code kent twee modi, automatische updates en handmatige updates.

In het automatische geval wordt eens per 7 dagen gecheckt of er een update is. Bij de handmatige modus wordt dat direct gedaan, ongeacht wanneer het de laatste keer was.

Code

De code die het eigenlijke bijwerken uitvoert is geplaatst in een klasse module genaamd "clsUpdate", zie hieronder.

'-------------------------------------------------------------------------
' Module    : clsUpdate
' Company   : JKP Application Development Services (c)
' Author    : Jan Karel Pieterse
' Created   : 19-2-2007
' Purpose   : Class to check for program updates
'-------------------------------------------------------------------------
Option Explicit

Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
        Alias "URLDownloadToFileA" (ByVal pCaller As LongPtr, _
                                    ByVal szURL As String, ByVal szFileName As String, _
                                    ByVal dwReserved As LongPtr, ByVal lpfnCB As LongPtr) As Long

Private mdtLastUpdate As Date

Private msAppName As String
Private msBuild As String
Private msCheckURL As String
Private msCurrentAddinName As String
Private msDownloadName As String
Private msTempAddInName As String
Private mbManual As Boolean
Private msNewBuild As String

Private Sub DownloadFile(strWebFilename As String, strSaveFileName As String)
' Download the file.
    URLDownloadToFile 0, strWebFilename, strSaveFileName, 0, 0
End Sub

Public Function IsThereAnUpdate(sError As String, Optional bShowMsg As Boolean = False) As Boolean
'-------------------------------------------------------------------------
' Procedure : IsThereAnUpdate
' Company   : JKP Application Development Services (c)
' Author    : Jan Karel Pieterse (www.jkp-ads.com)
' Created   : 2-6-2009
' Purpose   : Fetches version information from a webpage
'-------------------------------------------------------------------------
    Dim oHTTP As MSXML2.XMLHTTP
    Dim sURL As String
    Dim lError As Long
    Dim sTextResponse As String
    Dim dTime As Double
    Dim ct As Long
    On Error GoTo LocErr
    sURL = CheckURL
    Set oHTTP = New MSXML2.XMLHTTP
    NewBuild = 0
    lError = 0
    With oHTTP
        .Open "get", sURL & "?" & Format(Date + Time, "yyyymmdd_hhmmss"), True
        .setRequestHeader "pragma", "no-cache"
        .setRequestHeader "cache-control", "no-store, must-revalidate, private"
        .Send ""
        dTime = Now
        Application.StatusBar = Me.AppName & " is checking for updates"
        Do
            DoEvents
            ct = ct + 1
            If ct Mod 500 = 0 Then
                Application.StatusBar = Me.AppName & " is checking for updates " & Format(TimeValue("00:00:05") - (Now - dTime), "s")
            End If
        Loop Until Now - dTime > TimeValue("00:00:05") Or .readyState = 4
        sTextResponse = .responseBody

        Select Case True
        Case Err.Number <> 0
            sError = " ##Error " & Err.Number & ": " & Err.Description
            IsThereAnUpdate = False
        Case InStr(sTextResponse, "404 Not Found")
            sError = " ##Error## 404 Not Found."
            IsThereAnUpdate = False
        Case Else
            NewBuild = Val(sTextResponse)
            IsThereAnUpdate = True
        End Select
        On Error GoTo 0
    End With

TidyUp:
    On Error Resume Next
    Set oHTTP = Nothing
    Exit Function
LocErr:
    Select Case ReportError(Err.Description, Err.Number, "IsThereAnUpdate", "Class Module clsUpdate")
    Case vbRetry
        Resume
    Case vbIgnore
        Resume Next
    Case vbAbort
        Resume TidyUp
    End Select
End Function

Public Sub DoUpdate()
    Dim sNewBuild As String
    Dim sError As String
    On Error GoTo LocErr
    If IsThereAnUpdate(sError, Manual) Then
        If CLng(NewBuild) > CLng(Build) Then
            If MsgBox("There is an update for " & AppName & "." & _
                      vbNewLine & "Do you wish to download now?", vbQuestion + vbYesNo, AppName) = vbYes Then
                If GetUpdate Then
                    Application.Cursor = xlDefault
                    MsgBox "Successfully updated the " & AppName & " Add-In, " & vbNewLine & _
                           "please restart Excel to start using the new version!", vbOKOnly + vbInformation, AppName
                Else
                    Application.Cursor = xlDefault
                    MsgBox "Updating " & AppName & " has failed, please try again later.", _
                           vbInformation + vbOKOnly, AppName
                End If
            End If
        ElseIf Manual Then
            Application.Cursor = xlDefault
            MsgBox AppName & " is up to date.", vbInformation + vbOKOnly, AppName
        End If
    Else
        MsgBox "Error fetching version information: " & sError, vbExclamation + vbOKOnly, AppName
    End If
TidyUp:
    On Error GoTo 0
    Exit Sub
LocErr:
    Select Case ReportError(Err.Description, Err.Number, "DoUpdate", "Class Module clsUpdate")
    Case vbRetry
        Resume
    Case vbIgnore
        Resume Next
    Case vbAbort
        Resume TidyUp
    End Select
End Sub

Public Property Get Build() As String
    Build = msBuild
End Property

Public Property Let Build(ByVal sBuild As String)
    msBuild = sBuild
End Property

Public Sub RemoveOldCopy()
    On Error GoTo LocErr
    CurrentAddinName = ThisWorkbook.FullName
    TempAddInName = CurrentAddinName & "(OldVersion)"
    On Error Resume Next
    Kill TempAddInName
TidyUp:
    On Error GoTo 0
    Exit Sub
LocErr:
    Select Case ReportError(Err.Description, Err.Number, "RemoveOldCopy", "Class Module clsUpdate")
    Case vbRetry
        Resume
    Case vbIgnore
        Resume Next
    Case vbAbort
        Resume TidyUp
    End Select
End Sub

Public Function GetUpdate() As Boolean
    On Error Resume Next
    'If workbook has been saved readonly, we can safely delete the file!
    If ThisWorkbook.ReadOnly Then
        Err.Clear
        Kill CurrentAddinName
    End If
    LastUpdate = Now
    ThisWorkbook.SaveAs TempAddInName
    DoEvents
    Kill CurrentAddinName
    On Error GoTo 0
    DownloadFile DownloadName, CurrentAddinName
    If Err = 0 Then GetUpdate = True
End Function

Private Property Get CurrentAddinName() As String
    CurrentAddinName = msCurrentAddinName
End Property

Private Property Let CurrentAddinName(ByVal sCurrentAddinName As String)
    msCurrentAddinName = sCurrentAddinName
End Property

Private Property Get TempAddInName() As String
    TempAddInName = msTempAddInName
End Property

Private Property Let TempAddInName(ByVal sTempAddInName As String)
    msTempAddInName = sTempAddInName
End Property

Public Property Get DownloadName() As String
    DownloadName = msDownloadName
End Property

Public Property Let DownloadName(ByVal sDownloadName As String)
    msDownloadName = sDownloadName
End Property

Public Property Get CheckURL() As String
    CheckURL = msCheckURL
End Property

Public Property Let CheckURL(ByVal sCheckURL As String)
    msCheckURL = sCheckURL
End Property

Public Property Get LastUpdate() As Date
    Dim dtNow As Date
    On Error GoTo LocErr
    dtNow = Int(Now)
    mdtLastUpdate = CDate(GetSetting(AppName, "Updates", "LastUpdate", "0"))
    If mdtLastUpdate = 0 Then
        'Never checked for an update, save today!
        LastUpdate = dtNow
    End If
    LastUpdate = mdtLastUpdate
TidyUp:
    On Error GoTo 0
    Exit Property
LocErr:
    Select Case ReportError(Err.Description, Err.Number, "LastUpdate", "Class Module clsUpdate")
    Case vbRetry
        Resume
    Case vbIgnore
        Resume Next
    Case vbAbort
        Resume TidyUp
    End Select
End Property

Public Property Let LastUpdate(ByVal dtLastUpdate As Date)
    mdtLastUpdate = dtLastUpdate
    SaveSetting AppName, "Updates", "LastUpdate", CStr(CLng(mdtLastUpdate))
End Property

Public Property Get AppName() As String
    AppName = msAppName
End Property

Public Property Let AppName(ByVal sAppName As String)
    msAppName = sAppName
End Property

Public Property Get Manual() As Boolean
    Manual = mbManual
End Property

Public Property Let Manual(ByVal bManual As Boolean)
    mbManual = bManual
End Property

Public Property Get NewBuild() As String
    NewBuild = msNewBuild
End Property

Public Property Let NewBuild(ByVal sNewBuild As String)
    msNewBuild = sNewBuild
End Property

De clsUpdate klasse wordt gebruikt in de module modUpdate, hieronder staat de code uit die module:

Option Explicit

Dim mcUpdate As clsUpdate

Public Declare PtrSafe Function InternetGetConnectedState _
                         Lib "wininet.dll" (lpdwFlags As LongPtr, _
                                            ByVal dwReserved As Long) As Boolean

Function IsConnected() As Boolean
    Dim Stat As LongPtr
    IsConnected = (InternetGetConnectedState(Stat, 0&) <> 0)
End Function

Sub ManualUpdate()
    On Error Resume Next
    Application.OnTime Now, "'" & ThisWorkbook.FullName & "'!CheckAndUpdate"
End Sub

Public Sub CheckAndUpdate(Optional bManual As Boolean = True)
    On Error GoTo LocErr
    Set mcUpdate = New clsUpdate
    If bManual Then
        Application.Cursor = xlWait
    End If
    With mcUpdate
        'Set intial values of class
        'Current build
        .Build = BUILDOFAPP
        'Name of this app
        .AppName = "UpdateAnAddin"
        'Get rid of possible old backup copy
        .RemoveOldCopy
        'URL which contains build # of new version
        .CheckURL = "https://jkp-ads.com/updateanaddinbuild.aspx"
        .DownloadName = "https://jkp-ads.com/downloadscript.aspx?filename=" & ThisWorkbook.Name
        'Started check automatically or manually?
        .Manual = bManual
        'Check once a week
        If (Now - .LastUpdate >= 7) Or bManual Then
            .LastUpdate = Int(Now)
            .DoUpdate
        End If
        Set mcUpdate = Nothing
    End With
TidyUp:
    On Error GoTo 0
    Application.Cursor = xlDefault
    Exit Sub
LocErr:
    Select Case ReportError(Err.Description, Err.Number, "CheckAndUpdate", "Module modUpdate")
    Case vbRetry
        Resume
    Case vbIgnore
        Resume Next
    Case vbAbort
        Resume TidyUp
    End Select
End Sub

Tenslotte is er nog de module modGlobals, die onze project-niveau variabelen en constanten bevat:

Option Explicit

Public Const GSAPPNAME As String = "Update Addin Demo"
Public Const BUILDOFAPP As String = "1" '< change to 0 to test doenloading the new version