@dieseyer
Die Funktion AktuelleVersion überprüft, ob ein neue Programmversion auf WinTuC.de verfügbar ist. Die Funktion Herunterladen lädt die angebene Programmversion herunter.

Code:
OPTION EXPLICIT
Const WINTUC_VERSION = "0.9.a"
Dim Wert
Dim NeueVersion
 
NeueVersion = AktuelleVersion()
If WINTUC_VERSION < NeueVersion Then
  Wert = MsgBox("Es ist eine neue Version von WinTuC verfügbar." & vbCrLf & "Wollen Sie die Datei herunterladen", vbYesNo + vbQuestion,"WinTuC")
  If Wert = vbYes Then
    Herunterladen(NeueVersion)
  End If
End If
'*** ENDE HAUPTSKRIPT
 
'*************************************************************************************************************
'*
'* Prozedurname ....: AktuelleVersion
'*
'* -----------------------------------------------------------------------------------------------------------
'*
'* Beschreibung ....: Liefert die letzte Versionsnummer, die auf WinTuC.de verfügbar ist.
'* Parameter .......: - Keine -
'* Rückgabewert ....: Versionsnummer als Zeichenkette
'*
'*************************************************************************************************************
Function AktuelleVersion() 'Als Zeichenkette
  Const URL = "http://wintuc.de/downloads.html"
  Const HTTP_STATUS_OK = 200
  Dim RegularerAusdruck  'RegExpression-Objekt
  Dim Uebereinstimmungen 'Matches-Objekt
  Dim XMLHttpReq   'XMLHttpRequest-Objekt
  Dim AntwortText   'Zeichenkette
  Dim VersionNr   'Zeichenkette
  
  VersionNr = 0
  Set XMLHttpReq = CreateObject("Microsoft.XMLHTTP")
  XmlHttpReq.Open "Get", URL, FALSE
  XmlHttpReq.Send
 
  If XMLHttpReq.Status = HTTP_STATUS_OK Then
    AntwortText = XMLHttpReq.ResponseText
    Set RegularerAusdruck = New RegExp
    RegularerAusdruck.Pattern = "WinTuC Beta v([0-9]+(\.[0-9]+)(\.\w+))"
    RegularerAusdruck.IgnoreCase = FALSE
    RegularerAusdruck.Global = TRUE
 
    Set Uebereinstimmungen = RegularerAusdruck.Execute(AntwortText)
    If Uebereinstimmungen.Count > 0 Then
      VersionNr = Uebereinstimmungen.Item(0).Submatches.Item(0)
    End If
  End If
 
  AktuelleVersion = VersionNr
End Function '--> AktuelleVersion
 
'*************************************************************************************************************
'*
'* Prozedurname ....: Herunterladen()
'*
'* -----------------------------------------------------------------------------------------------------------
'*
'* Beschreibung ....: Lädt das aktuelle Programm ins Skriptverzeichni.
'* Parameter .......: ProgrammVersion als Zeichenkette
'* Rückgabewert ....: Erfolgreich = TRUE / Erfolglos = FALSE 
'*
'*************************************************************************************************************
Function HerunterLaden(ByVal ProgrammVersion) 'Als Boolesch
  Const adTypeBinary = 1
  Const adSaveCreateOverWrite = 2
  Const HTTP_STATUS_OK = 200
  Dim ADOStream   'ADoStream-Object
  Dim XMLHttpReq  'XMLHttpRequest-Objekt  
  Dim DateiURL   'Zeichenkette
  Dim DateiName   'Zeichenkette
  Dim DownLoadOrdner  'Zeichenkette
 
  DateiName = "wintuc_v" & ProgrammVersion & ".exe"
  DateiURL = "http://wintuc.com/" & DateiName
  ON ERROR RESUME NEXT

  Set XMLHttpReq = CreateObject("Microsoft.XMLHTTP")
  XMLHttpReq.Open "Get", DateiURL, FALSE
  XMLHttpReq.Send
  If Err.Number <> 0 Then 
    Herunterladen = FALSE
    EXIT FUNCTION
  End If
  ON ERROR GOTO 0
 
  If XMLHttpReq.Status = HTTP_STATUS_OK Then
    ON ERROR RESUME NEXT
    Set ADOStream = CreateObject("ADODB.Stream")
    ADOStream.Open
    ADOStream.Type = adTypeBinary
    ADOStream.Write XMLHttpReq.ResponseBody
    ADOStream.Position = 0
    DownLoadOrdner = CreateObject("Scripting.FileSystemObject").GetFile(WScript.ScriptFullName).ParentFolder
    ADOStream.SaveToFile DownLoadOrdner & "\" & DateiName, adSaveCreateOverWrite
    ADOStream.Close
    If Err.Number <> 0 Then 
      Herunterladen = FALSE
      EXIT FUNCTION
    Else
      Herunterladen = TRUE
      EXIT FUNCTION
    End If
    ON ERROR GOTO 0
  Else
    Herunterladen = FALSE
    EXIT FUNCTION
  End If  
End Function '--> Herunterladen