Een invoegtoepassing bijwerken via internet
Inhoud
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 is niet ongebruikelijk dat je foutjes in je code hebt ontdekt
(of erop wordt gewezen) of dat je je invoegtoepassing hebt bijgewerkt en
dat je je gebruikers hiervan wilt laten profiteren. Het kan dan handig zijn
als je gebruikers op de hoogte gehouden worden van zulke 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);
- Ergens in de invoegtoepassing zal de VBA code een web query invoegen
met als adres bovenstaande URL. het bereik van die webquery is "Available_Build"
genoemd (invoegen, naam, definieren).
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 vernieuwd de webquery 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. Ik heb
verhalen gehoord, dat dit met een netwerk schijf WEL mogelijk is, maar
ik kan dit niet reproduceren.
- 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 de webquery toegevoegd aan de addin,
maar het bijwerken van de query gebeurt asynchroon. Een worksheet_change
event wordt ingesteld, die zal reageren zodra de query haar resultaten binnen
heeft (of een time-out is opgetreden). Dit wordt gedaan, zodat Excel door
kan gaan met laden terwijl op de achtergrond de update check wordt uitgevoerd.
Op deze manier merkt de gebruiker zo min mogelijk van eht hele proces, totdat
er een update gevonden wordt.
In het handmatige geval, wordt de web query synchroon bijgewerkt (niets
werkt in Excel totdat het resultaat is opgehaald). Dit is gedaan omdat het
voor de gebuiker verwarrend zal zijn als er niets lijkt te gebeuren, waarna
"plotseling" er een dialoogvenstertje verschijnt met een mededeling over
het al dan niet bijgewerkt zijn van je applicatie.
Code
De code die het eigenlijke bijwerken uitvoert is geplaatst in een klasse
module genaamd "clsUpdate", zie hieronder.
Option Explicit
'-------------------------------------------------------------------------
' 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
Public WithEvents
Sht As Worksheet
#If VBA7 Then
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
#Else
Private Declare
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
#End If
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 Sub Class_Terminate()
Set Sht = Nothing
End Sub
Private Sub DownloadFile(strWebFilename
As String, strSaveFileName
As String)
' Download the file.
URLDownloadToFile 0, strWebFilename, strSaveFileName, 0,
0
End Sub
Public Function
IsThereAnUpdate(Optional bShowMsg
As Boolean =
False) As
Boolean
Dim sNewBuild
As String
On Error
Resume Next
SaveSetting AppName, "Updates", "LastUpdate",
CStr(Int(Now))
If Err.Number <> 0 And bShowMsg
Then
MsgBox "Error retrieving update
information, please try again later.", vbInformation + vbOKOnly
End If
End Function
Public Sub DoUpdate()
Dim sNewBuild
As String
sNewBuild = ThisWorkbook.Names("Available_build").RefersToRange.Value
If Len(sNewBuild) = 0
Or Len(sNewBuild) > 4
Then
MsgBox "Unable to fetch version
information, please try again later.", vbOKOnly + vbInformation
Exit
Sub
End If
If CLng(sNewBuild) >
CLng(msBuild) Then
If MsgBox("We
have an update, do you wish to download?", vbQuestion + vbYesNo) = vbYes
Then
DownloadName
= "https://jkp-ads.com/downloadscript.asp?filename=" & ThisWorkbook.Name
If
GetUpdate Then
Application.Cursor
= xlDefault
MsgBox
"Successfully updated the addin, please restart Excel to start using
the new version!", vbOKOnly + vbInformation
Else
Application.Cursor
= xlDefault
MsgBox
"Updating has failed.", vbInformation + vbOKOnly
End
If
Else
Application.Cursor
= xlDefault
End
If
ElseIf Manual
Then
Application.Cursor = xlDefault
MsgBox "Your program is up to date.",
vbInformation + vbOKOnly
End If
TidyUp:
On Error
GoTo 0
Exit Sub
End Sub
Private Sub Sht_Change(ByVal
Target As Range)
Application.Cursor = xlDefault
If Len(Target.Value) <= 4
Then
DoUpdate
Application.Cursor = xlDefault
ElseIf Manual
Then
'Query failed
to refresh and was called manually
Application.Cursor = xlDefault
MsgBox "Unable to retrieve version
information, please try again later", vbInformation + vbOKOnly
End If
Set Sht = Nothing
TidyUp:
On Error
GoTo 0
Exit Sub
End Sub
Public Sub PlaceBuildQT(ByVal
bManual As Boolean)
Dim oNm As
Name
On Error
GoTo LocErr
Application.ScreenUpdating = False
For Each
oNm In ThisWorkbook.Worksheets("Sheet1").Names
oNm.Delete
Next
If CInt(Left(Application.Version,
2)) > 11 Then
' Trick!! Somehow
Excel 2007 cannot insert a web query into an add-in!!
ThisWorkbook.IsAddin =
False
End If
With ThisWorkbook.Worksheets("Sheet1").QueryTables.Add(Connection:=
_
"URL;" & CheckURL, Destination:=ThisWorkbook.Names( _
"Available_Build").RefersToRange)
.Name = "autosafebuild"
.FieldNames =
True
.RowNumbers =
False
.FillAdjacentFormulas =
False
.PreserveFormatting =
True
.RefreshOnFileOpen =
False
.BackgroundQuery =
Not bManual
.RefreshStyle = xlOverwriteCells
.SavePassword =
False
.SaveData = True
.AdjustColumnWidth =
False
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns =
True
.WebConsecutiveDelimitersAsOne =
True
.WebSingleBlockTextImport =
False
.WebDisableDateRecognition =
False
' .WebDisableRedirections
= False
On
Error Resume
Next
.Refresh BackgroundQuery:=Not
(bManual)
On
Error GoTo 0
If
Not bManual Then
Set
Sht = ThisWorkbook.Worksheets("Sheet1")
Else
DoUpdate
End
If
End With
TidyUp:
If CInt(Left(Application.Version,
2)) > 11 Then
ThisWorkbook.IsAddin =
True
' Trick!! Otherwise,
Excel 2007 will ask to save your add-in when it closes.
ThisWorkbook.Saved =
True
End If
Application.ScreenUpdating = True
On Error
GoTo 0
Exit Sub
LocErr:
If CInt(Left(Application.Version,
2)) > 11 Then
ThisWorkbook.IsAddin =
True
ThisWorkbook.Saved =
True
End If
Application.ScreenUpdating = True
Application.Cursor = xlDefault
If Err.Description
Like "*QueryTables*" Then
MsgBox "Error retrieving version
information, please try again later.", vbInformation + vbOKOnly
Resume
TidyUp
End If
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()
CurrentAddinName = ThisWorkbook.FullName
TempAddInName = CurrentAddinName & "(OldVersion)"
On Error
Resume Next
Kill TempAddInName
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
dtNow = Int(Now)
mdtLastUpdate = CDate(GetSetting(AppName,
"Updates", "LastUpdate", "0"))
If mdtLastUpdate = 0
Then
'Never checked
for an update, save today!
SaveSetting AppName, "Updates",
"LastUpdate", CStr(Int(dtNow))
End If
LastUpdate = mdtLastUpdate
End Property
Public Property
Let LastUpdate(ByVal
dtLastUpdate As Date)
mdtLastUpdate = dtLastUpdate
SaveSetting AppName, "Updates", "LastUpdate",
CStr(Int(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
Als alternatief voor het gebruik van een webquery, kan het InternetExplorer
control worden gebruikt (en is dus ook een verwijzing naar de bijbehorende
bibliotheek nodig). Dan wordt de routine "IsThereAnUpdate":
Option Explicit
'-------------------------------------------------------------------------
' 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
Public WithEvents
Sht As Worksheet
Private Declare
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
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 Sub Class_Terminate()
Set Sht = Nothing
End Sub
Private Sub DownloadFile(strWebFilename
As String, strSaveFileName
As String)
' Download the file.
URLDownloadToFile 0, strWebFilename, strSaveFileName, 0,
0
End Sub
Public Function
IsThereAnUpdate(Optional bShowMsg
As Boolean =
False) As
Boolean
Dim sNewBuild
As String
On Error
Resume Next
SaveSetting AppName, "Updates", "LastUpdate",
CStr(Int(Now))
If Err.Number <> 0 And bShowMsg
Then
MsgBox "Error retrieving update
information, please try again later.", vbInformation + vbOKOnly
End If
End Function
Public Sub DoUpdate()
Dim sNewBuild
As String
sNewBuild = ThisWorkbook.Names("Available_build").RefersToRange.Value
If Len(sNewBuild) = 0
Or Len(sNewBuild) > 4
Then
MsgBox "Unable to fetch version
information, please try again later.", vbOKOnly + vbInformation
Exit
Sub
End If
If CLng(sNewBuild) >
CLng(msBuild) Then
If MsgBox("We
have an update, do you wish to download?", vbQuestion + vbYesNo) = vbYes
Then
DownloadName
= "https://jkp-ads.com/downloadscript.asp?filename=" & ThisWorkbook.Name
If
GetUpdate Then
Application.Cursor
= xlDefault
MsgBox
"Successfully updated the addin, please restart Excel to start using
the new version!", vbOKOnly + vbInformation
Else
Application.Cursor
= xlDefault
MsgBox
"Updating has failed.", vbInformation + vbOKOnly
End
If
Else
Application.Cursor
= xlDefault
End
If
ElseIf Manual
Then
Application.Cursor = xlDefault
MsgBox "Your program is up to date.",
vbInformation + vbOKOnly
End If
TidyUp:
On Error
GoTo 0
Exit Sub
End Sub
Private Sub Sht_Change(ByVal
Target As Range)
Application.Cursor = xlDefault
If Len(Target.Value) <= 4
Then
DoUpdate
Application.Cursor = xlDefault
ElseIf Manual
Then
'Query failed
to refresh and was called manually
Application.Cursor = xlDefault
MsgBox "Unable to retrieve version
information, please try again later", vbInformation + vbOKOnly
End If
Set Sht = Nothing
TidyUp:
On Error
GoTo 0
Exit Sub
End Sub
Public Sub PlaceBuildQT(ByVal
bManual As Boolean)
Dim oNm As
Name
On Error
GoTo LocErr
Application.ScreenUpdating = False
For Each
oNm In ThisWorkbook.Worksheets("Sheet1").Names
oNm.Delete
Next
If CInt(Left(Application.Version,
2)) > 11 Then
' Trick!! Somehow
Excel 2007 cannot insert a web query into an add-in!!
ThisWorkbook.IsAddin =
False
End If
With ThisWorkbook.Worksheets("Sheet1").QueryTables.Add(Connection:=
_
"URL;" & CheckURL, Destination:=ThisWorkbook.Names( _
"Available_Build").RefersToRange)
.Name = "autosafebuild"
.FieldNames =
True
.RowNumbers =
False
.FillAdjacentFormulas =
False
.PreserveFormatting =
True
.RefreshOnFileOpen =
False
.BackgroundQuery =
Not bManual
.RefreshStyle = xlOverwriteCells
.SavePassword =
False
.SaveData = True
.AdjustColumnWidth =
False
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns =
True
.WebConsecutiveDelimitersAsOne =
True
.WebSingleBlockTextImport =
False
.WebDisableDateRecognition =
False
' .WebDisableRedirections
= False
On
Error Resume
Next
.Refresh BackgroundQuery:=Not
(bManual)
On
Error GoTo 0
If
Not bManual Then
Set
Sht = ThisWorkbook.Worksheets("Sheet1")
Else
DoUpdate
End
If
End With
TidyUp:
If CInt(Left(Application.Version,
2)) > 11 Then
ThisWorkbook.IsAddin =
True
' Trick!! Otherwise,
Excel 2007 will ask to save your add-in when it closes.
ThisWorkbook.Saved =
True
End If
Application.ScreenUpdating = True
On Error
GoTo 0
Exit Sub
LocErr:
If CInt(Left(Application.Version,
2)) > 11 Then
ThisWorkbook.IsAddin =
True
ThisWorkbook.Saved =
True
End If
Application.ScreenUpdating = True
Application.Cursor = xlDefault
If Err.Description
Like "*QueryTables*" Then
MsgBox "Error retrieving version
information, please try again later.", vbInformation + vbOKOnly
Resume
TidyUp
End If
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()
CurrentAddinName = ThisWorkbook.FullName
TempAddInName = CurrentAddinName & "(OldVersion)"
On Error
Resume Next
Kill TempAddInName
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
dtNow = Int(Now)
mdtLastUpdate = CDate(GetSetting(AppName,
"Updates", "LastUpdate", "0"))
If mdtLastUpdate = 0
Then
'Never checked
for an update, save today!
SaveSetting AppName, "Updates",
"LastUpdate", CStr(Int(dtNow))
End If
LastUpdate = mdtLastUpdate
End Property
Public Property
Let LastUpdate(ByVal
dtLastUpdate As Date)
mdtLastUpdate = dtLastUpdate
SaveSetting AppName, "Updates", "LastUpdate",
CStr(Int(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
In een normale module wordt een instantie van bovenstaande klasse gemaakt,
haar initiele waarden worden ingesteld en het updated kan beginnen. Zie
het commentaar in de code voor uitleg.
Option Explicit
Dim mcUpdate As
clsUpdate
Public Declare Function
InternetGetConnectedState _
Lib "wininet.dll" (lpdwFlags As
Long, _
ByVal
dwReserved As Long)
As Boolean
Function IsConnected()
As Boolean
Dim Stat As
Long
IsConnected = (InternetGetConnectedState(Stat, 0&) <>
0)
End Function
Sub AutoUpdate()
CheckAndUpdate False
End Sub
Sub ManualUpdate()
On Error
Resume Next
Application.OnTime Now, "CheckAndUpdate"
End Sub
Public Sub CheckAndUpdate(Optional
bManual As Boolean
= True)
Set mcUpdate =
New clsUpdate
If bManual
Then
Application.Cursor = xlWait
End If
With mcUpdate
'Set intial values
of class
'Current build
.Build = 0
'Name of this
app, probably a global variable, such as GSAPPNAME
.AppName = "UpdateAnAddin"
'Get rid of possible
old backup copy
.RemoveOldCopy
'URL which contains
build # of new version
.CheckURL = "https://jkp-ads.com/downloads/UpdateAnAddinBuild.htm"
'Started check
automatically or manually?
.Manual = bManual
'Check once a
week
If (Now
- .LastUpdate >= 7) Or bManual
Then
.PlaceBuildQT
bManual
End
If
End With
TidyUp:
On Error
GoTo 0
Exit Sub
End Sub
Download een Demo
Download de demo file hier:
Update An addin