Const PROGRAM_FILES = &H26&
Const Version = "3.0.01"
Const fold = "pilze.ch"
Dim Debug
Dim foldok
Dim DBOrdner
Dim foundfile
Dim foundfolder
Dim foundLaunchAccess
Dim LaunchAccess
Dim foundAccess
Dim MSAccess
Dim foundProg 
Dim RepDat
Dim Dat
Dim SteuerDat
Dim PilzDir
Dim ws, fso, objshell, objfolder, objfolderItem
Dim DesktopPath, Doku, Programme

Versionen = ""
HoechsteVersion = ""
VersionAktuell = false
foundLaunchAccess = false
foundAccess = false
foundfolder = false
foundProg = false
RepDat = false
Dat = false
SteuerDat = false
LeerZeile = vbcr 
VorString =  "--------------------------------------------------------------------------------------" _
             & vbcr & vbcr 
NachString = vbcr & vbcr _
           & "--------------------------------------------------------------------------------------"
'VorString = ""
'NachString = ""

Debug = true

Set ws = WScript.CreateObject("WScript.Shell")
set fso = CreateObject("scripting.FilesystemObject")

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(PROGRAM_FILES)
Set objFolderItem = objFolder.Self 

if Debug then	
  LogName = ws.SpecialFolders("Desktop") & "\Log2000Pilze.txt"
  fso.CreateTextFile LogName
  Set fileObj = fso.GetFile(LogName)
  Set ts = fileObj.OpenAsTextStream(2, -2)
End If

DesktopPath = ws.SpecialFolders("Desktop")
Doku = ws.SpecialFolders("MyDocuments")
Programme = objFolderItem.path

'-------------------------------------------------------------------------------------------------------------------
'Erläuterungen zum Update
'-------------------------------------------------------------------------------------------------------------------

MeldeString = "Update ""2000Pilze"" auf Version " & Version & "." _
& vbcr & vbcr & "Während des Vorganges wird geprüft," _
       & vbcr & "ob auf dem Computer ein Verzeichnis ""pilze.ch""" _
       & vbcr & "und eine passende Accessversion vorhanden sind." _
& vbcr & vbcr & "Es wird ein Verzeichnis für die neue Version " & Version & "," _
       & vbcr & "die Verbindung zu den passenden Downloads" _
       & vbcr & "und eine Desktop-Verküpfung zu den neuen Dateien erstellt."

Antwort = MsgBox (VorString & Meldestring & NachString, vbokcancel, "2000Pilze")
if Antwort = 2 then wscript.quit

'-------------------------------------------------------------------------------------------------------------------
'Ordner "pilze.ch" suchen in Standarddokumenten, Programmordner oder auf dem Desktop.
'-------------------------------------------------------------------------------------------------------------------

if Debug then ts.WriteLine "Aufruf Ordnersuche: " & Doku
folderlist(Doku)
if Debug then 
  ts.WriteLine "Ordnersuche abgeschlossen in: " & Doku
  if foldok then ts.WriteLine "pilze.ch gefunden in: " & Doku
End If
if not foldok then 
  if Debug then ts.WriteLine "Aufruf Ordnersuche: " & Programme
  folderlist(Programme)
  if Debug then 
    ts.WriteLine "Ordnersuche abgeschlossen in: " & Programme
    if foldok then ts.WriteLine "pilze.ch gefunden in: " & Programme
  End If
End If
if not foldok then 
  if Debug then ts.WriteLine "Aufruf Ordnersuche: " & DesktopPath
  folderlist(DesktopPath)
  if Debug then 
    ts.WriteLine "Ordnersuche abgeschlossen in: " & DesktopPath
    if foldok then ts.WriteLine "pilze.ch gefunden in: " & DesktopPath
  End If
End If

if not foldok then
  Antwort = MsgBox (VorString & "Das Verzeichnis ""pilze.ch"" konnte im" _
            & vbcr & "Standardordner für eigene Dokumente," _
            & vbcr & "im Programmordner" _
            & vbcr & "sowie auf dem Schreibtisch nicht gefunden werden." _ 
            & vbcr & "Können Sie den Standort des Ordners selber angeben?" & NachString, vbyesno, "2000Pilze")
  if Antwort = 2 then wscript.quit

  '-----------------------------------------------------------------------------------------------------------------
  'Ort des Ordners pilze.ch selber angeben.
  '-----------------------------------------------------------------------------------------------------------------
  Set Verzeichnis = CreateObject("Shell.Application") _ 
  .BrowseForFolder(0, "Datei oder Verzeichnis wählen", &H4011, 17) 
  PilzDir = Verzeichnis.Self.Path

  foldertest(PilzDir)

  if Debug then ts.WriteLine "Ordnerpfad selber angegeben: " & PilzDir

  if not foldok then
    MsgBox VorString & Leerzeile & "Das Verzeichnis ""pilze.ch"" enthält nicht die notwendigen Unterverzeichnisse." _
            & vbcr & "Der Vorgang wird abgebrochen." & Leerzeile & NachString , ,"2000Pilze"
    wscript.quit
  End If
End If

'-------------------------------------------------------------------------------------------------------------------
'Der Ordner "pilze.ch" ist gefunden und enthält die nötigen Unterverzeichnisse.
'-------------------------------------------------------------------------------------------------------------------

FoundPilze = "Der Ordner ""pilze.ch"" mit der Programmversion " & HoechsteVersion & " befindet sich auf: " _
      & vbcr & PilzDir

'-------------------------------------------------------------------------------------------------------------------
'Accessversion ermitteln.
'-------------------------------------------------------------------------------------------------------------------

On error resume next
Vers = Ws.RegRead("HKCR\Access.Application\CurVer\")
If err.number = 0 then
  do while len (Vers) > 0 and right (Vers,1) <>"."
    Num = right (Vers,1) & Num
    Vers = left(Vers,len(Vers)-1)
  loop
  Select Case Num
    Case 8
      MsgBox VorString & Leerzeile & FoundPilze _
              & vbcr & "Access97 ist eine zu alte Programmversion." _
	      & vbcr & "Bitte zuerst eine aktuellere Accessversion" _
              & vbcr & "(Vollversion oder RunTime) installieren." & NachString, ,"2000Pilze"
      wscript.quit
    Case 9
      MsgBox VorString & Leerzeile & FoundPilze _
              & vbcr & "Auf dem Computer gibt es ein Access 2000." _
              & Leerzeile & NachString, ,"2000Pilze"
      Adresse = "download_" & Version & "_00.asp"
      VersionsString = "_00.mde"
    Case 10
      MsgBox VorString & Leerzeile & FoundPilze _
              & vbcr & "Auf dem Computer gibt es ein Access XP/2002." _
             & Leerzeile & NachString, ,"2000Pilze" 
      Adresse = "download_" & Version & "_02.asp"
      VersionsString = "_02.mde"
    Case 11
      MsgBox VorString & Leerzeile & FoundPilze _
              & vbcr & "Auf dem Computer gibt es ein Access 2003." _
             & Leerzeile & NachString, ,"2000Pilze"
      Adresse = "download_" & Version & "_03.asp"
      VersionsString = "_03.mde"
    Case 12
      MsgBox VorString & Leerzeile & FoundPilze _
              & vbcr & "Auf dem Computer gibt es ein Access 2007." _
             & Leerzeile & NachString, ,"2000Pilze"
      Adresse = "download_" & Version & "_07.asp"
      VersionsString = "_07.accde"
    Case 14
      MsgBox VorString & Leerzeile & FoundPilze _
              & vbcr & "Auf dem Computer gibt es ein Access 2010." _
             & Leerzeile & NachString, ,"2000Pilze"
      Adresse = "download_" & Version & "_10.asp"
      VersionsString = "_10.accde"
    Case Else
      MsgBox VorString & Leerzeile & FoundPilze _
              & vbcr & "Auf dem Computer gibt es eine unbekannte Accessversion." _
              & vbcr & "Das Update für ""2000Pilze"" wird in der Version 2010 heruntergeladen." _
              & Leerzeile & NachString, ,"2000Pilze"
      Adresse = "download_3.0.01_10.asp"
      VersionsString = "_10.accde"
  End Select
Else
  Meldestring = "Auf dem Computer konnte keine Version von Access gefunden werden." _
     & vbcr & "Der Vorgang zum Update wird abgebrochen." _ 
     & vbcr & "Wollen Sie gleich zur Downloadseite für die kostenlose" _
     & vbcr & "Access Runtimeversion 2007 weitergeleitet werden?"
  Antwort = MsgBox (VorString & FoundPilze & Meldestring & NachString, vbokcancel, "2000Pilze")
  if Antwort = 2 then wscript.quit
  nRetVal = ws.Run("http://www.microsoft.com/downloads/details.aspx?" _
                 & "FamilyID=d9ae78d9-9dc6-4b38-9fa6-2c745a175aed&displaylang=de", 1, false)
  wscript.quit
End if


'-------------------------------------------------------------------------------------------------------------------
'DBOrdner erstellen.
'-------------------------------------------------------------------------------------------------------------------


'MeldeString = "Soll das Verzeichnis " & vbcr & DBOrdner & Version _
'        & vbcr & "für die aktuelle Version " & Version & " erstellt werden?"
'Antwort = MsgBox (VorString & Leerzeile & MeldeString & Leerzeile & NachString, vbokcancel, "2000Pilze")
'if Antwort = 2 then wscript.quit

if fso.folderexists(DBOrdner &  Version) then
  'MeldeString = "Das Verzeichnis" _
  '       & vbcr & DBOrdner & Version & vbcr _
  '       & "existiert schon." _
  '& vbcr & "Das entspricht der aktuellsten Version von 2000Pilze." _
  '& vbcr & "Wollen Sie dennoch weiterfahren oder den Vorgang abbrechen?"
  'Antwort = MsgBox (VorString & Leerzeile & MeldeString & Leerzeile & NachString, vbokcancel, "2000Pilze")
  'if Antwort = 2 then wscript.quit
Else
  Set makedir = Fso.CreateFolder(DBOrdner & Version) 
End if

'-------------------------------------------------------------------------------------------------------------------
'Fundliste kopieren.
'-------------------------------------------------------------------------------------------------------------------

CopyString = "xcopy " & """" & DBOrdner & HoechsteVersion & "/Replikat_2000Pilze_Fundliste.mdb" & """" _
                & " " & """" & DBOrdner & Version _
	        & """" & " /I /E /F /D"  
if Debug then ts.WriteLine CopyString  
MeldeString =  "Sollen die bisherigen Fundlistendateien ins neue Verzeichnis " _
               & vbcr & "DB2000Pilze_" & Version & " kopiert werden, damit die" _
	       & vbcr & "bisherigen Funderfassungen weiterhin zur Verfügung stehen?" _
	& vbcr & vbcr & "Der neue Ordner mit den kopierten Dateien wird geöffnet." _
	       & vbcr & "Die Dateien am bisherigen Ort werden nicht gelöscht."
Antwort = MsgBox (VorString & Leerzeile & Meldestring & Leerzeile & NachString, vbokcancel, "2000Pilze")

if Antwort = 2 then wscript.quit

Ws.MinimizeAll
ws.run("""" & DBOrdner & Version & """")

Ws.Run CopyString,2,True     ' Parameter 5 zeigt DOS Konsole
CopyString = "xcopy " & """" & DBOrdner & HoechsteVersion & "/2000Pilze_Fundliste.mdb" & """" _
                & " " & """" & DBOrdner & Version _
	        & """" & " /I /E /F /D" 
if Debug then ts.WriteLine CopyString 

Ws.Run CopyString,2,True     ' Parameter 5 zeigt DOS Konsole

'-------------------------------------------------------------------------------------------------------------------
'Updates herunterladen.
'-------------------------------------------------------------------------------------------------------------------

if fso.fileexists(DBOrdner & Version & "/Replikat_2000Pilze_Daten.mdb") then RepDat = true
if fso.fileexists(DBOrdner & Version & "/2000Pilze_Daten.mdb") then Dat = true
if fso.fileexists(DBOrdner & Version & "/2000Pilze_" & Version & VersionsString) then SteuerDat = true

if not SteuerDat then

  Meldestring = "Soll die passende Steuerdatei für 2000Pilze heruntergeladen werden?" _
              & vbcr & "Bitte warten, bis der Browser geöffnet ist." _
              & vbcr & "Die persönlichen Zugangsdaten Vorname, Nachname und Kennnummer eingeben" _
              & vbcr & "und die Datei im Zip-Datei an einem beliebigen Ort speichern."

  Antwort = MsgBox (VorString & Leerzeile & Meldestring & Leerzeile & NachString, vbokcancel, "2000Pilze")

  if Antwort = 2 then wscript.quit

  nRetVal = ws.Run("http://www.pilze.ch/pilzbestimmung/Download/" & Adresse, 1, false)

  wscript.sleep(3000)

  Meldestring = "Die persönlichen Zugangsdaten Vorname, Nachname und Kennnummer eingeben" _
              & vbcr & "und die Datei im Zip-Datei an einem beliebigen Ort speichern." _
       & vbcr & vbcr & "Entpacken Sie die Datei nach dem Download" _
              & vbcr & "und verschieben Sie diese in den geöffneten Ordner:" _ 
              & vbcr & DBOrdner & Version & Leerzeile _ 
              & vbcr & "Bestätigen Sie diese Meldung erst nach dem Download." _
              & vbcr & "und lassen Sie den Browser geöffnet."

  Antwort = MsgBox (VorString & Meldestring & NachString, vbokcancel, "2000Pilze")
  if Antwort = 2 then wscript.quit

End If

if not (RepDat or Dat) then
  Meldestring = Leerzeile & "Soll die aktuelle Datendatei für 2000Pilze herutergeladen werden?" _
              & vbcr & "Bitte warten, bis der Browser geöffnet ist."

  Antwort = MsgBox (VorString & Meldestring & Leerzeile & NachString, vbokcancel, "2000Pilze")
  if Antwort = 2 then wscript.quit

  nRetVal = ws.Run("http://www.pilze.ch/pilzbestimmung/Download/2000Pilze_Replikat_Datenzip.asp", 1, false)

  wscript.sleep(3000)

  Meldestring = "Entpacken Sie die Datei nach dem Download" _
              & vbcr & "und verschieben Sie diese in den geöffneten Ordner:" _ 
              & vbcr & DBOrdner & Version & Leerzeile _ 
              & vbcr & "Klappt der Download zur Zeit aus irgendeinem Grund nicht" _
              & vbcr & "versuchen Sie es nochmals direkt unter" _
              & vbcr & "http://www.pilze.ch/pilzbestimmung/Updates.asp"

  Antwort = MsgBox (VorString & Meldestring & NachString, vbokcancel, "2000Pilze")
  if Antwort = 2 then wscript.quit
End If

if fso.fileexists(DBOrdner & Version & "/Replikat_2000Pilze_Daten.mdb") then RepDat = true
if fso.fileexists(DBOrdner & Version & "/2000Pilze_Daten.mdb") then Dat = true
if fso.fileexists(DBOrdner & Version & VersionsString) then SteuerDat = true

If (RepDat or Dat) and SteuerDat then
  MsgBox VorString & Leerzeile & "Die notwendigen Dateien für die aktuelle Version 3.0.01." _
         & vbcr & "stehen bereits zur Verfügung." _
         & vbcr & "Auf dem Desktop wird eine passende Verknüpfung erstellt." & Leerzeile & NachString, ,"2000Pilze"
Else
  MeldeString = "Vor dem Weiterfahren sollten die heruntergeladenen Dateien im Verzeichnis" _
         & vbcr & DBOrdner & Version _
         & vbcr & "zur Verfügung stehen." _
  & vbcr & vbcr & "Falls der Download zur Zeit nicht möglich ist, kann dieses Skript" _
         & vbcr & "abgebrochen und später wiederholt werden. Ein mehrmaliger Durchlauf" _
         & vbcr & "ist problemlos. Bereits erledigte Vorgänge werden übersprungen." _
  & vbcr & vbcr & "Es ist auch möglich mit OK zu bestätigen und die Dateien nachträglich" _
         & vbcr & "einzufügen. Der neue Link auf das Update wird jedoch erst funktionieren, " _
         & vbcr & "wenn die Dateien der Version " & Version & " tatsächlich am Ort sind."
  Antwort = MsgBox (VorString & Meldestring & NachString, vbokcancel, "2000Pilze")
  if Antwort = 2 then wscript.quit

  'MsgBox VorString & "Die Daten für die Version 3.0.01 stehen zur Verfügung." _
  '       & vbcr & "Um auf dem Desktop eine aktive Verknüpfung zu erstellen" _
  '       & vbcr & "müssen die heruntergeladenen Dateien ins Verzeichnis" _
  '       & vbcr & DBOrdner & Version & " verschoben werden." & NachString, ,"2000Pilze"
End If

'-------------------------------------------------------------------------------------------------------------------
'ShortCut erstellen.
'-------------------------------------------------------------------------------------------------------------------

if Debug then
  ts.WriteLine "" 
  ts.WriteLine "ShortCut erstellen."
  ts.WriteLine "-------------------" 
  ts.WriteLine ""
End if

MicrosoftSearch(objFolderItem.Path) 

Set objShortcut = ws.CreateShortcut(DesktopPath & "\" & "2000Pilze_" & Version & ".lnk")

If foundLaunchAccess then
  if Debug then 
    ts.WriteLine "objShortcut.arguments: " &  DBOrdner & Version & "\2000Pilze_" & Version & VersionsString
    ts.WriteLine "objShortcut.TargetPath: " & LaunchAccess 
  End IF
  objShortcut.arguments = """" & DBOrdner & Version & "\2000Pilze_" & Version & VersionsString & """" & " /runtime"
  objShortcut.TargetPath = LaunchAccess 
Else
  If foundAccess then
    if Debug then 
      ts.WriteLine "objShortcut.TargetPath: " & DBOrdner & Version & "\2000Pilze_" & Version & VersionsString 
    End IF
    objShortcut.TargetPath = DBOrdner & Version & "\2000Pilze_" & Version & VersionsString
  End If
End If
objShortcut.Description = "2000Pilze"
objShortcut.WorkingDirectory = DBOrdner & Version
'objshortCut.IconLocation = fs.getparentfoldername(Wscript.ScriptFullName) &"\Installation\2000Pilze.ico,0"

objShortcut.Save
MsgBox VorString & "Die Verknüpfung auf dem Desktop ist erstellt worden." _
       & vbcr & "Der Updatevorgang ist abgeschlossen." _
& vbcr & vbcr & "Auf dem Desktop findet sich die Datei ""Log2000Pilze.txt""." _
       & vbcr & "Bei Meldungen zu Schwierigkeiten an ""winkler@pilze.ch.""" _
       & vbcr & "bitte diese Datei zur Fehleranalyse anfügen." _
       & vbcr & "Andernfalls kann sie gelöscht werden." & NachString, ,"2000Pilze"

'-------------------------------------------------------------------------------------------------------------------
'Schluss.
'-------------------------------------------------------------------------------------------------------------------

wscript.quit

'-------------------------------------------------------------------------------------------------------------------
'===================================================================================================================
'-------------------------------------------------------------------------------------------------------------------

'-------------------------------------------------------------------------------------------------------------------
'Sub Routinen
'-------------------------------------------------------------------------------------------------------------------

Sub folderlist(folderspec)
  set f = fso.GetFolder(folderspec)
  set sf = f.SubFolders
  for each f1 in sf
  if not left(f1.name, 6) = "Eigene" then
    if f1.name = fold then
      if Debug then ts.WriteLine f.path
      foldertest(f1)
      if foldok then 
        PilzDir = f1.path
        Exit Sub
      else
        Msgbox VorString & "Der Ordner ist vorhanden aber er ist nicht vollständig." & NachString, ,"2000Pilze"
        wscript.quit
      End If
    End if
    'folderlist(f1.path)
  End If
  next
end Sub

'-------------------------------------------------------------------------------------------------------------------
  
  Sub foldertest(folderspec)
    set f = fso.GetFolder(folderspec)
    set sf = f.SubFolders

    for each f1 in sf
      select case f1.name
        case "BilderFix"
          BilderFix = true
        case "EigenePilzbilder"
          EigenePilzbilder = true
        case "Gatt250"
          Gatt250 = true
        case "LeitfadenJPG"
          LeitfadenJPG = true
        case else
          DBOrdner = "DB2000Pilze_"
          if left(f1.name,12) = "DB2000Pilze_" then 
            DBOrdner = f1.Parentfolder.path & "/DB2000Pilze_"
            DB2000Pilze = true
            If right(f1.name, 6) = "3.0.01" then
              VersionAktuell = true
            End if
            if Versionen = "" then
              Versionen = right(f1.name, len(f1.name)-12)
              HoechsteVersion = Versionen
            Else
              Versionen = Versionen & ", " & right(f1.name, len(f1.name)-12)
              if right(f1.name, len(f1.name)-12) > HoechsteVersion then  
                HoechsteVersion = right(f1.name, len(f1.name)-12)
              End If
            End if
          End If
      End select
    next
    foldok = BilderFix and EigenePilzbilder and Gatt250 and LeitfadenJPG and DB2000Pilze 
  End Sub

'-------------------------------------------------------------------------------------------------------------------

Sub MicrosoftSearch(folderspec)
   set f = fso.GetFolder(folderspec)
   for each f1 in f.SubFolders  
     if Debug then ts.WriteLine "Suche nach MS Office/ Runtime in: " & f1.path
     if LCase(f1.name) = "microsoft office" or LCase(f1.name) = "microsoft access runtime" then 
       OfficeSearch(f1)
       if foundProg then 
         if Debug then ts.WriteLine "Ordner Microsoft Office/ Access Runtime: " & f1.path
         exit sub
         if Debug then ts.WriteLine "Achtung Exit Sub funktioniert nicht!!!!!"
       End If
     End if
     'MicrosoftSearch(f1.path)
   next
end Sub

'-------------------------------------------------------------------------------------------------------------------

Sub OfficeSearch(folderspec)
   set f = fso.GetFolder(folderspec)
   for each f1 in f.SubFolders
     if UCase(left(f1.name,6)) = "OFFICE" then
       filesearch(f1)
       if foundProg then 
         if Debug then ts.WriteLine "Ordner OfficeXX: " & f1.path
         exit sub
         if Debug then ts.WriteLine "Achtung Exit Sub funktioniert nicht!!!!!"
       End If
     End if
     'OfficeSearch(f1.path)
   next
end Sub

'-------------------------------------------------------------------------------------------------------------------

Sub filesearch(folderspec)
    set f = fso.GetFolder(folderspec)
    for each fn in f.files
      select case UCase(fn.name)
      case "LAUNCHACCESS.EXE"
        foundLaunchAccess = true
        LaunchAccess = fn.path
        if Debug then ts.WriteLine "File LaunchAccess: " & LaunchAccess 
        Exit Sub
      case "MSACCESS.EXE"
        foundAccess = true
        MSAccess = fn.path  
        if Debug then ts.WriteLine "File MSAccess: " & MSAccess
        Exit Sub
      End select
    next
    if foundLaunchAccess or foundAccess then foundProg = true
End Sub


'-------------------------------------------------------------------------------------------------------------------
'Ende
'-------------------------------------------------------------------------------------------------------------------
'===================================================================================================================