http://dieseyer.de • all rights reserved • © 2011 v11.4
<html>
<head>
<!--
'*** v10.B *** www.dieseyer.de *****************************
'
' Datei: WIM-BuR.hta
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Eine kurze Beschreibung wird beim Start des Hta angezeigt,
' bevor es irgend etwas 'macht'.
'
'***********************************************************
SHOWINTASKBAR="no"
WINDOWSTATE="maximize"
BORDER="none"
INNERBORDER="no"
SCROLL="No"
NAVIGABLE="no"
-->
<HTA:APPLICATION ID="oHTA"
APPLICATIONNAME="WIM-BuR"
SINGLEINSTANCE="yes"
MAXIMIZEBUTTON="no"
ICON="WIM-BuR.ico"
>
<title>WIM - Backup und Restore</title>
<style type="text/css">
html, body { background-color: #116; color: #ec0; font-weight: normal; font-size:9pt; line-height=1.1em; font-family: verdana,arial,sans-serif,Microsoft Sans Serif,times }
.InputStart{ background-color: #116; color: #ec0; font-weight: bold; border: 2px solid #339; margin-left: 3px; width: 25px; height: 12px; }
.InputNr{ background-color: #116; color: #ec0; font-weight: bold; margin-left: 0px; width: 2.5em; height: 22px; }
.WIMAanzWahl1{ background-color: #116; color: #f60; font-weight: bold; font-size: 7pt; margin-left: 0px; width: 605px; height: 22px; }
.WIMAanzWahl2{ background-color: #116; color: #0C0; font-weight: bold; font-size: 7pt; margin-left: 0px; width: 605px; height: 22px; }
.InputInst{ background-color: #116; color: #ec0; font-weight: bold; margin-left: 0px; width: 0.9em; height: 22px; }
.InputMini{ background-color: #116; color: #ec0; font-weight: bold; margin-left: 0px; width: 0; height: 0; }
.InputExpert{ background-color: #116; color: #ec0; font-weight: bold; margin-left: 09px; width: 180px; height: 22px; }
.InputSonst{ background-color: #116; color: #ec0; font-weight: bold; margin-left: 09px; width: 80px; height: 22px; }
.InputMenu { background-color: #116; color: #ec0; font-weight: bold; border: 2px solid #339; margin-left: 03px; width: 125px; height: 26px; }
div#Inhalt { clear: both; }
div#Inhalt span { text-decoration: underline; }
a { color: #ec0; text-decoration: underline; }
a:hover { background-color: #11F; }
</style>
</head>
<script language="VBscript">
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Const ZeitTest = "-Ja"
Const KeineLog = "-JA"
Dim ProgrOK : ProgrOK = vbFalse ' vbTrue, wenn ProgrExe erreichbar ist
Dim ProgrExe : ProgrExe = "IMAGEX.EXE"
Dim ProgrPara, ProgrVersion, LfdKey, GottModus
ProgrPara = "/COMPRESS maximum /CHECK /VERIF"
ProgrPara = "/COMPRESS maximum /VERIFY"
ProgrPara = "/COMPRESS maximum"
' "maximum" spart im Durchschnitt 10% Platz, dauert
' aber häufig bis zu drei Mal so lange wie "fast"
ProgrPara = "/COMPRESS fast /CHECK /VERIFY"
ProgrPara = "/COMPRESS fast /VERIFY"
ProgrPara = "/COMPRESS fast"
Dim WIMDateiDatum
Dim WIMGewaehlt : WIMGewaehlt = "Aktuell ist kein WIM ausgewählt."
' : WIMGewaehlt = "I:\Test-x.Wim"
Dim DatenQuelle : DatenQuelle = ""
' : DatenQuelle = "D:\dieseyer.de"
Dim DatenZiel : DatenZiel = ""
' : DatenZiel = "C:\summe.wim"
' : DatenZiel = "C:\xxxx"
Dim Titel, HtaSelbst, HtaDatum, AktVerz
Dim TastTaste
Dim MenueAkt ' speichert den zu letzt angewählte Menü-Reiter
Dim VOW ' speichert Datei- / Verzeichnis-Auswahl für Restore (in Verzeichnise oder in WIM)
Dim TempVerz, XMLDatei, XSLDatei, CMDPfad, HTMDatei, DirDatei, HTMLTxt
Dim BuRInfoMenue, BuRBackupMenue, BuRRestoreMenue, BuRDeleteMenue, BuRWIMInfoMenue
Dim LogDatei
ReDim Preserve zwTxt( 2, 0 ) ' die Prozedur zwLog speichert die Log-Informationen, bis der Name der Log-Datei festgelegt ist
Dim Tst
Dim ProgrVerz : ProgrVerz = ""
Tst = CreateObject("WScript.Network").ComputerName
If InStr( UCase( Tst ), "MININT" ) = 1 Then ProgrVerz = "MININT" ' bei WinPE
If InStr( UCase( Tst ), "MINWINPC" ) = 1 Then ProgrVerz = "MININT" ' bei WinPE
If ProgrVerz = "" Then ProgrVerz = CreateObject("Shell.Application").Namespace( 38 ).Self.Path ' ergibt C:\Programme
Const DSProgr = "dieseyer.de"
' MsgBox "ProgrVerz: """ & ProgrVerz & """" & vbCRLF & "ProgrPara: " & ProgrPara, , "0107 :: "
'***********************************************************
Sub zwLog( Txt, Farb )
'***********************************************************
Dim i : i = UBound( zwTxt, 2 ) + 1
If Len( zwTxt( 0, 0 ) ) = 0 AND Len( zwTxt( 1, 0 ) ) = 0 Then i = 0
ReDim Preserve zwTxt( 2, i ) : zwTxt( 0, i ) = Txt : zwTxt( 1, i ) = Farb
End Sub ' zwLog( Txt )
'***********************************************************
Sub LogSchreibenAnzeigen()
'***********************************************************
Dim i
For i = LBound( zwTxt, 2 ) to UBound( zwTxt, 2 )
Trace32Log zwTxt( 0, i ), zwTxt( 1, i )
Next
End Sub ' LogSchreibenAnzeigen()
'***********************************************************
Function BeimLaden() ' ruft einige Routinen auf
'***********************************************************
On Error Resume Next
window.moveto 0, 0
On Error Goto 0
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim Tst
Titel = oHTA.APPLICATIONNAME
' Call zwLog( "-", 0 ) ' erstellt neue LogDatei
' Call zwLog( " ", 1 ) ' fügt Leerzeile in LogDatei ein
zwLog " ", 1 ' fügt Leerzeile in LogDatei ein
zwLog "0143 :: Start " & Titel, 1
HtaSelbst = oHTA.CommandLine
zwLog "0146 :: Erhaltene Parameter: " & HtaSelbst, 1
Tst = InStr( HtaSelbst, """ """ )
' MsgBox ">" & HtaSelbst & "<", , "0148 :: " & Titel & Tst
If Tst > 10 Then
WIMGewaehlt = Mid( HtaSelbst, Tst )
WIMGewaehlt = Replace( WIMGewaehlt, """ ", "" )
WIMGewaehlt = Replace( WIMGewaehlt, """", "" )
HtaSelbst = Mid( HtaSelbst, 1, Tst )
zwLog "0154 :: WIMGewaehlt (als Parameter erhalten): " & WIMGewaehlt, 1
End If
' MsgBox "HtaSelbst >" & HtaSelbst & "<" & vbCRLF & "WIMGewaehlt >" & WIMGewaehlt & "<", , "0158 :: " & Titel
HtaSelbst = Replace( HtaSelbst, """ ", "" )
HtaSelbst = Replace( HtaSelbst, """", "" )
zwLog "0161 :: HtaSelbst: " & HtaSelbst, 1
' MsgBox ">" & HtaSelbst & "<", , "0162 :: " & Titel
' Dateitype .WIM registrieren - nur unter WinPE
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If ProgrVerz = "MININT" AND InStr( UCase( HtaSelbst ), "\" & UCase( DSProgr ) & "\" ) = 0 Then DateiTypRegistrieren "wim", HtaSelbst
HtaDatum = fso.GetFile( HtaSelbst ).DateLastModified
zwLog "0168 :: HtaDatum: " & HtaDatum, 1
' MsgBox ">" & HtaDatum & "<", , "0169 :: " & Titel
AktVerz = fso.GetParentFolderName( HtaSelbst ) ' : MsgBox "AktVerz: " & AktVerz, , "0171 :: "
AktVerz = Replace( AktVerz, """", "" ) ' : MsgBox "AktVerz: " & AktVerz, , "0172 :: "
zwLog "0173 :: AktVerz: " & AktVerz, 1
LogDatei = Replace( HtaSelbst, fso.GetExtensionName( HtaSelbst ), "log" )
zwLog "0176 :: LogDatei: " & LogDatei, 1
zwLog "0177 :: LogDatei wird jetzt geschrieben . . . ", 1
' MsgBox "LogDatei: " & LogDatei, , "0178 :: " & Titel
Call LogSchreibenAnzeigen() ' : CreateObject("WScript.Shell").Run LogDatei, , False
' Das Icon gibts nur bei einer Installation
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = LCase( ProgrVerz & "\" & DSProgr & "\" )
If InStr( LCase( HtaSelbst ), Tst ) = 1 Then
Tst = ProgrVerz & "\" & DSProgr & "\" & Titel & ".ico"
Trace32Log "0186 :: Icon-Datei soll erstellt werden: " & Tst, 1
If not fso.FileExists( Tst ) Then Call IcoAusHexDaten( Tst, "mm" )
Trace32Log "0188 :: Icon-Datei ist erstellt: " & Tst, 1
End If
Call BuRMenue()
Call WIMBuRMenu()
Call WIMBuRInfo()
Tst = HtaSelbst & " (vom " & HtaDatum & "; " & CreateObject("Scripting.FileSystemObject").GetFile( HtaSelbst ).Size & ")"
window.setTimeout "HtaInfoZeigen('" & "0196 :: " & Tst & "')", 0 * 333
' window.setTimeout "HtaInfoZeigen('" & now() & "')", 7 * 333
window.setTimeout "HtaInfoZeigen(' ')", 4 * 333
' Umgebung
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
window.setTimeout "WIMBuRDateien()", 1 * 333
' Erreichbarkeit des Programms IMAGEX.EXE prüfen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
window.setTimeout "ProgrExeErreichbar()", 2 * 333
window.setTimeout "ProgrExeVersion()", 5 * 333
If InStr( WIMGewaehlt, "\\" ) = 1 OR InStr( WIMGewaehlt, ":\" ) = 2 Then
Trace32Log "0212 :: Anzeige wird zeitverzögert auf 'Informations' umgeschaltet.", 1
window.setTimeout "MenueAkt = ""WIMINFO""", 3 * 333
window.setTimeout "WIMBuRMenu()", 4 * 333
' MsgBox "0215 :: ", , "0215 :: " & Titel
Else
' MsgBox "0217 :: ", , "0217 :: " & Titel
End If
' MsgBox Replace( oHTA.CommandLine, """", "" ) & vbCRLF & ProgrVerz & "\" & DSProgr, , "0220 :: "
' fso.CopyFile Replace( oHTA.CommandLine, """", "" ), ProgrVerz & "\" & DSProgr : MsgBox "Port", , "0221 :: "
Trace32Log "0223 :: Beendet 'Function BeimLaden()'", 1
End Function ' BeimLaden()
'***********************************************************
Sub window_onbeforeunload
'***********************************************************
' window.event.returnValue = "> > > > > Mit dem Schließen dieser Anwendung wird das Programm gestartet! < < < < <"
' sollte [F5] (116) gedrückt worden sein (beendet das HTA und lädt es neu)
If TastTaste = 116 Then Exit Sub
Trace32Log "0234 :: Wird (normal) beendet: " & HtaSelbst, 1
End Sub ' window_onbeforeunload
'***********************************************************
Sub document_onKeyDown
'***********************************************************
TastTaste = window.event.keyCode
' Trace32Log "0242 :: Betätigte Taste: '" & TastTaste & "'", 1
' If TastTaste = 13 Then Call neuesEnde()
End Sub
'***********************************************************
Sub HtaInfoZeigen( Txt )
'***********************************************************
On Error Resume Next
document.all.HtaInfo.innerHTML = Txt
On Error Goto 0
End Sub ' HtaInfoZeigen( Txt )
'***********************************************************
Sub WIMBuRDateien()
'***********************************************************
Trace32Log "0259 :: Anfang 'Sub WIMBuRDateien()'", 1
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim Txt
TempVerz = UserTempVerz() & "\" ' : MsgBox "UserTempVerz: '" & TempVerz & "'", , "0262 :: "
If not fso.FolderExists( TempVerz ) Then fso.CreateFolder( TempVerz ) ' : MsgBox "Verz. erstellt: '" & TempVerz & "'", , "0263 :: "
XMLDatei = TempVerz & fso.GetBaseName( HtaSelbst ) & ".xml"
XSLDatei = TempVerz & fso.GetBaseName( HtaSelbst ) & ".xsl"
CMDPfad = TempVerz & fso.GetBaseName( HtaSelbst )
HTMDatei = TempVerz & fso.GetBaseName( HtaSelbst ) & ".html"
DirDatei = TempVerz & fso.GetBaseName( HtaSelbst ) & ".dir"
Trace32Log "0270 :: WIM-BuR - Umgebung:", 1
Trace32Log "0271 :: TempVerz: " & TempVerz, 1
Trace32Log "0272 :: XMLDatei: " & XMLDatei, 1
Trace32Log "0273 :: XSLDatei: " & XSLDatei, 1
Trace32Log "0274 :: CMDPfad: " & CMDPfad, 1
Trace32Log "0275 :: HTMDatei: " & HTMDatei, 1
Trace32Log "0276 :: DirDatei: " & DirDatei, 1
Txt = ""
Txt = Txt & vbCRLF & "HtaSelbst: " & HtaSelbst
Txt = Txt & vbCRLF & "AktVerz: " & AktVerz
Txt = Txt & vbCRLF & "TempVerz: " & TempVerz
Txt = Txt & vbCRLF & "XMLDatei: " & XMLDatei
Txt = Txt & vbCRLF & "XSLDatei: " & XSLDatei
Txt = Txt & vbCRLF & "CMDPfad: " & CMDPfad
Txt = Txt & vbCRLF & "HTMDatei: " & HTMDatei
Txt = Txt & vbCRLF & "DirDatei: " & DirDatei
' MsgBox Txt, , "0287 :: " & Titel
Trace32Log "0289 :: Beendet 'Sub WIMBuRDateien()'", 1
End Sub ' WIMBuRDateien()
'***********************************************************
Sub BuRMenue
'***********************************************************
Trace32Log "0297 :: Anfang 'Sub BuRMenue'", 1
Dim T
T = T & "<div style=""position: absolute; width: 130px; height: 32px; top: 46px; left: 11px; border-bottom: 2px solid #dd0;"" />"
T = T & "<div style=""position: absolute; width: 130px; height: 32px; top: 0px; left: 128px; border: 2px solid #dd0; border-bottom: 2px solid #116; "" />"
T = T & "<div style=""position: absolute; width: 384px; height: 32px; top: -2px; left: 128px; border-bottom: 2px solid #dd0;"" />"
T = T & "<div style=""position: absolute; width: 642px; height: 535px; top: 32px; left: -258px; border: 2px solid #dd0; border-top: none; padding: 3px; "" >"
BuRBackupMenue = T : T = ""
T = T & "<div style=""position: absolute; width: 130px; height: 32px; top: 46px; left: 11px; border: 2px solid #dd0; border-bottom: 2px solid #116; "" />"
T = T & "<div style=""position: absolute; width: 513px; height: 32px; top: -2px; left: 127px; border-bottom: 2px solid #dd0;"" />"
T = T & "<div style=""position: absolute; width: 642px; height: 535px; top: 32px; left: -129px; border: 2px solid #dd0; border-top: none; padding: 13px; "" >"
BuRInfoMenue = T : T = ""
T = T & "<div style=""position: absolute; width: 258px; height: 32px; top: 46px; left: 11px; border-bottom: 2px solid #dd0;"" />"
T = T & "<div style=""position: absolute; width: 130px; height: 32px; top: 0px; left: 256px; border: 2px solid #dd0; border-bottom: 2px solid #116; "" />"
T = T & "<div style=""position: absolute; width: 256px; height: 32px; top: -2px; left: 128px; border-bottom: 2px solid #dd0;"" />"
T = T & "<div style=""position: absolute; width: 642px; height: 535px; top: 32px; left: -386px; border: 2px solid #dd0; border-top: none; padding: 3px; "" >"
BuRRestoreMenue = T : T = ""
T = T & "<div style=""position: absolute; width: 386px; height: 32px; top: 46px; left: 11px; border-bottom: 2px solid #dd0;"" />"
T = T & "<div style=""position: absolute; width: 130px; height: 32px; top: 0px; left: 384px; border: 2px solid #dd0; border-bottom: 2px solid #116; "" />"
T = T & "<div style=""position: absolute; width: 128px; height: 32px; top: -2px; left: 128px; border-bottom: 2px solid #dd0;"" />"
T = T & "<div style=""position: absolute; width: 642px; height: 535px; top: 32px; left: -514px; border: 2px solid #dd0; border-top: none; padding: 3px; "" >"
BuRDeleteMenue = T : T = ""
T = T & "<div style=""position: absolute; width: 514px; height: 32px; top: 46px; left: 11px; border-bottom: 2px solid #dd0;"" />"
T = T & "<div style=""position: absolute; width: 130px; height: 32px; top: 0px; left: 512px; border: 2px solid #dd0; border-bottom: 2px solid #116; "" />"
T = T & "<div style=""position: absolute; width: 642px; height: 535px; top: 30px; left: -514px; border: 2px solid #dd0; border-top: none; padding: 3px; "" >"
BuRWIMInfoMenue = T : T = ""
Trace32Log "0328 :: Beendet 'Sub BuRMenue'", 1
End Sub ' BuRMenue
'***********************************************************
Sub ProgrExeVersion()
'***********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
' If not ProgrExeErreichbar = vbTrue Then window.setTimeout "ProgrExeVersion()", 5 * 333 : Exit Sub
If not ProgrOK = vbTrue Then window.setTimeout "ProgrExeVersion()", 5 * 333 : Exit Sub
If not fso.FileExists( ProgrExe ) Then window.setTimeout "ProgrExeVersion()", 5 * 333 : Exit Sub
ProgrVersion = "(v" & fso.GetFileVersion( ProgrExe ) & ")"
' "ImageX.exe " & ProgrVersion & " -"
End Sub ' ProgrExeVersion()
'***********************************************************
Function ProgrExeErreichbar
'***********************************************************
Trace32Log "0349 :: Anfang 'Function ProgrExeErreichbar'", 1
Trace32Log "0350 :: Aktuelle ProgrExe: " & ProgrExe, 1
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim Txt, Tst, errTst
' ProgrExe muss kompletten Pfad enthalten (für CmdBef)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = TempVerz & ProgrExe : ' MsgBox Txt, , "0358 :: "
If fso.FileExists( Txt ) Then ProgrExe = Txt : Trace32Log "0359 :: ProgrExe: " & ProgrExe, 1 : ProgrExeErreichbar = vbTrue : ProgrOK = vbTrue : Exit Function
Trace32Log "0360 :: ProgrExe fehlt: " & Txt, 2
Txt = AktVerz & "\" & ProgrExe : ' MsgBox Txt, , "0362 :: "
If fso.FileExists( Txt ) Then ProgrExe = Txt : Trace32Log "0363 :: ProgrExe: " & ProgrExe, 1 : ProgrExeErreichbar = vbTrue : ProgrOK = vbTrue : Exit Function
Trace32Log "0364 :: ProgrExe fehlt: " & Txt, 2
Txt = RemoteWinDir( "." ) & "\" & ProgrExe : ' MsgBox Txt, , "0366 :: "
If fso.FileExists( Txt ) Then ProgrExe = Txt : Trace32Log "0367 :: ProgrExe: " & ProgrExe, 1 : ProgrExeErreichbar = vbTrue : ProgrOK = vbTrue : Exit Function
Trace32Log "0368 :: ProgrExe fehlt: " & Txt, 2
Txt = RemoteWinDir( "." ) & "\System32\" & ProgrExe : ' MsgBox Txt, , "0370 :: "
If fso.FileExists( Txt ) Then ProgrExe = Txt : Trace32Log "0371 :: ProgrExe: " & ProgrExe, 1 : ProgrExeErreichbar = vbTrue : ProgrOK = vbTrue : Exit Function
Trace32Log "0372 :: ProgrExe fehlt: " & Txt, 2
Txt = RemoteWinDir( "." ) & "\SysWOW64\" & ProgrExe : ' MsgBox Txt, , "0374 :: "
If fso.FileExists( Txt ) Then ProgrExe = Txt : Trace32Log "0375 :: ProgrExe: " & ProgrExe, 1 : ProgrExeErreichbar = vbTrue : ProgrOK = vbTrue : Exit Function
Trace32Log "0376 :: ProgrExe fehlt: " & Txt, 2
Txt = RemoteWinDir( "." ) & "\SysWOW64\" & ProgrExe : ' MsgBox Txt, , "0378 :: "
If fso.FileExists( Txt ) Then ProgrExe = Txt : Trace32Log "0379 :: ProgrExe: " & ProgrExe, 1 : ProgrExeErreichbar = vbTrue : ProgrOK = vbTrue : Exit Function
Trace32Log "0380 :: ProgrExe fehlt: " & Txt, 2
' 0| C:\Windows
Txt = fso.GetSpecialFolder( 0 ) & "\" & ProgrExe : ' MsgBox Txt, , "0383 :: "
If fso.FileExists( Txt ) Then ProgrExe = Txt : Trace32Log "0384 :: ProgrExe: " & ProgrExe, 1 : ProgrExeErreichbar = vbTrue : ProgrOK = vbTrue : Exit Function
Trace32Log "0385 :: ProgrExe fehlt: " & Txt, 2
' 1| C:\Windows\System32
Txt = fso.GetSpecialFolder( 1 ) & "\" & ProgrExe : ' MsgBox Txt, , "0388 :: "
If fso.FileExists( Txt ) Then ProgrExe = Txt : Trace32Log "0389 :: ProgrExe: " & ProgrExe, 1 : ProgrExeErreichbar = vbTrue : ProgrOK = vbTrue : Exit Function
Trace32Log "0390 :: ProgrExe fehlt: " & Txt, 2
' 2| C:\Users\[UserName]\AppData\Local\Temp
Txt = fso.GetSpecialFolder( 2 ) & "\" & ProgrExe : ' MsgBox Txt, , "0393 :: "
If fso.FileExists( Txt ) Then ProgrExe = Txt : Trace32Log "0394 :: ProgrExe: " & ProgrExe, 1 : ProgrExeErreichbar = vbTrue : ProgrOK = vbTrue : Exit Function
Trace32Log "0395 :: ProgrExe fehlt: " & Txt, 2
' Suchen-Dialog, weil imagex.exe nicht gefunden
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "0400 :: " & ProgrExe & " nicht gefunden . . .", 1
Txt = vbCRLF & vbCRLF & "Programm kann nicht gestartet werden bzw. ist nicht erreichbar: " & vbCRLF & vbCRLF & vbTab & ProgrExe & vbCRLF & vbCRLF & "Soll der Datei-Suchen-Dialog geöffnet werden?"
Tst = MsgBox( Txt, vbQuestion + vbYesNo, "0402 :: " & Titel )
If Tst = vbYes Then
Trace32Log "0404 :: Suchen-Dialog wird geöffnet . . .", 1
Txt = BFFVerzDateitype( AktVerz, "exe" )
If Txt = "EXIT" Then Exit Function
' Txt = ChooseFile( )
Tst = InStrRev( Txt, "\" )
If Tst > 0 Then Tst = UCase( Mid( Txt, Tst + 1 ) )
If ProgrExe = Tst Then
ProgrExe = Txt
Trace32Log "0412 :: Neue ProgrExe: " & ProgrExe, 1
Txt = RemoteWinDir( "." ) & "\System32\" & Tst
ProgrExeErreichbar = vbTrue
ProgrOK = vbTrue
' document.all.InfoTxt.innerHTML = "0416 :: " & "vbTrue" & " " & ProgrExe
Tst = MsgBox( ProgrExe & vbCRLF & vbCRLF & "kopieren nach:" & vbCRLF & vbCRLF & Txt, vbQuestion + vbYesNo, "0417 :: " & Titel )
If Tst = vbYes Then
Trace32Log "0419 :: Datei kopieren (von..nach)", 1
Trace32Log "0420 :: " & ProgrExe, 1
Trace32Log "0421 :: " & Txt, 1
On Error Resume Next
fso.CopyFile ProgrExe, Txt, True
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
' MsgBox errTst, , "0427 :: "
If Len( errTst ) > 4 Then
Trace32Log "0429 :: LinkErstellen( " & AktVerz & ", " & document.title & ", " & HTASelbst & " )", 1
Call LinkErstellen( AktVerz, document.title, HTASelbst )
Tst = errTst
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "Die Datei """ & Txt & """ muss im 'Administrator'-Kontext erstellt werden - dafür "
Tst = Tst & "wurde im selben Verzeichnis, in der sich das """ & HTASelbst & """ "
Tst = Tst & "befindet, eine Verknüpfung (Link, ShortCut) mit dem selben Namen angelegt. "
Tst = Tst & "Klickt man mit der rechten Maus-Taste auf diesen Link, "
Tst = Tst & "kann 'Als Administrator ausführen' (Run as Administrator) ausgewählt werden - "
Tst = Tst & "so sollte das Kopieren nach " & Txt & " gelingen."
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "Soll '" & HTASelbst & "' beendet werden?"
Tst = MsgBox( Tst, 4096 + vbCritical + vbYesNo, "0441 :: " & Titel )
If Tst = vbYes Then self.close : BFFAusWahlOCX = "EXIT"
Exit Function
End If
If not fso.FileExists( Txt ) Then
Trace32Log "0447 :: LinkErstellen( " & AktVerz & ", " & document.title & ", " & HTASelbst & " )", 1
Call LinkErstellen( AktVerz, document.title, HTASelbst )
Tst = ""
Tst = Tst & "Die Datei """ & Txt & """ muss im 'Administrator'-Kontext erstellt werden - dafür "
Tst = Tst & "wurde im selben Verzeichnis, in der sich das """ & HTASelbst & """ "
Tst = Tst & "befindet, eine Verknüpfung (Link, ShortCut) mit dem selben Namen angelegt. "
Tst = Tst & "Klickt man mit der rechten Maus-Taste auf diesen Link, "
Tst = Tst & "kann 'Als Administrator ausführen' (Run as Administrator) ausgewählt werden - "
Tst = Tst & "so sollte das Kopieren nach " & Txt & " gelingen."
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "Soll '" & HTASelbst & "' beendet werden?"
Tst = MsgBox( Tst, 4096 + vbCritical + vbYesNo, "0458 :: " & Titel )
If Tst = vbYes Then self.close : BFFAusWahlOCX = "EXIT"
Exit Function
End If
ProgrExe = Txt
Trace32Log "0463 :: Neue ProgrExe: " & ProgrExe, 1
MsgBox "Erstellt: " & vbCRLF & vbCRLF & ProgrExe, vbInformation, "0464 :: " & Titel
End If
Exit Function
Else
Trace32Log "0468 :: Suchen-Dialog vom Benutzer abgebrochen.", 2
End If
Else
Trace32Log "0471 :: Suchen-Dialog vom Benutzer abgebrochen.", 2
End If
' imagex.exe nicht gefunden
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = vbCRLF & vbCRLF & "Programm kann nicht gestartet werden bzw. ist nicht erreichbar: " & vbCRLF & vbCRLF & vbTab & ProgrExe & vbCRLF & vbCRLF
WSHShell.Popup vbTab & "= = = F E H L E R = = =" & Txt , 15, "0477 :: " & Titel, 4096 + vbCritical
ProgrOK = vbFalse
ProgrExeErreichbar = vbFalse
Trace32Log "0481 :: Beendet 'Function ProgrExeErreichbar'", 3
End Function ' ProgrExeErreichbar( Exe )
'***********************************************************
Sub WIMAuswahl()
'***********************************************************
Trace32Log "0489 :: Anfang 'Sub WIMAuswahl()'", 1
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim Tst
Trace32Log "0494 :: Aktuell WIMGewaehlt (Dateiname): '" & WIMGewaehlt & "'", 1
Tst = WIMGewaehlt
If InStr( Tst, "\" ) = 0 And InStr( Tst, ":" ) = 0 Then
Tst = RemoteSystemDrive( "." )
End If
If Len( WIMGewaehlt ) > 7 Then Tst = fso.GetParentFolderName( WIMGewaehlt )
' MsgBox WIMGewaehlt, , "0500 :: "
If not fso.FileExists( Tst ) AND not fso.FolderExists( Tst ) Then
Tst = fso.GetParentFolderName( AktVerz )
If not fso.FolderExists( Tst ) Then Tst = AktVerz
End If
If ProgrVerz = "MININT" Then ' bei WinPE
Trace32Log "0508 :: Input-Dialog für WIM-Auswahl wird angezeigt mit Verz.: " & AktVerz, 1
Tst = BFFAusWahlOCX( AktVerz, Tst, "wim" )
' Tst = InputBox( "Bitte den kompletten Pfad zu einem WIM eingeben:", Titel, AktVerz )
Trace32Log "0511 :: Input-Dialog für WIM-Auswahl Ergebnis: '" & Tst & "'", 1
Else
Trace32Log "0513 :: Datei-Suchen-Dialog für WIM-Auswahl öffnet mit Verz.: " & Tst, 1
Tst = BFFVerzDateitype( Tst, "wim" )
' Tst = ChooseFile( )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "0517 :: Datei-Suchen-Dialog für WIM-Auswahl Ergebnis: '" & Tst & "'", 1
End If
Trace32Log "0520 :: Datei-Suchen-Dialog für WIM-Auswahl Ergebnis: '" & Tst & "'", 1
If InStr( Tst, "\\" ) = 1 OR InStr( Tst, ":\" ) = 2 Then
WIMGewaehlt = Tst
Trace32Log "0524 :: Neu WIMGewaehlt: '" & WIMGewaehlt & "'", 1
If not fso.GetExtensionName( UCase( WIMGewaehlt ) ) = "WIM" Then
WIMGewaehlt = WIMGewaehlt & ".WIM"
Trace32Log "0527 :: Neu WIMGewaehlt mit Dateiendung: '" & WIMGewaehlt & "'", 1
End If
Else
Trace32Log "0530 :: Datei-Suchen-Dialog für WIM-Auswahl ohne 'vernüftiges' Ergebnis '" & Tst & "'", 2
End If
Trace32Log "0533 :: Beendet 'Sub WIMAuswahl()'", 1
Call WIMBuRMenu()
End Sub ' WIMAuswahl()
'***********************************************************
Sub WIMBuRMenu()
'***********************************************************
Trace32Log "0543 :: Anfang 'Sub WIMBuRMenu()'", 1
On Error Resume Next
window.moveto 0, 0
window.resizeto 700, 670
On Error Goto 0
Dim Txt, Tst, T
Tst = LCase( ProgrVerz & "\" & DSProgr & "\" )
Tst = LCase( DSProgr & "\" & Titel )
' MsgBox LCase( HtaSelbst ) & vbCRLF & Tst, , "0553 :: " & Titel
If InStr( LCase( HtaSelbst ), Tst ) > 1 OR ProgrVerz = "MININT" Then ' bei WinPE
T = ""
Else
T = "<input class=""InputNr"" onClick=""SubWIMBuRInst()"" type=""submit"" value=""Inst."" title=""" & Titel & " auf diesen PC installieren.""> "
End If
If not InStr( WIMGewaehlt, "\\" ) = 1 AND not InStr( WIMGewaehlt, ":\" ) = 2 Then
T = T & "<input class=""WIMAanzWahl1"" onClick=""WIMAuswahl()"" accesskey=""a"" type=""submit"" value=""" & WIMGewaehlt & " Hier klicken und auswählen . . . "" title=""WIM auswählen."">"
Else
Txt = Mid( WIMGewaehlt, 1, InStr( Mid( WIMGewaehlt, 7 ), "\" ) + 6 )
Txt = Txt & " . . . " & Mid( WIMGewaehlt, InStrRev( WIMGewaehlt, "\" ) )
If Len( WIMGewaehlt ) < 90 Then Txt = WIMGewaehlt
T = T & "<input class=""WIMAanzWahl2"" onClick=""WIMAuswahl()"" accesskey=""a"" type=""submit"" value=""" & Txt & """ title=""" & WIMGewaehlt & """>"
End If
T = T & "</center><span Style="" height: 34px; ""></span>"
T = T & "<input class=""InputMenu"" onClick=""WIMBuRInfo()"" accesskey=""w"" type=""submit"" value="" WIM-BuR "" title=""Informationen über 'WIM - Backup und Restore'."">"
T = T & "<input class=""InputMenu"" onClick=""WIMBuRBackup()"" accesskey=""b"" type=""submit"" value="" Backup "" title=""Datei(en) in ein WIM sichern."">"
T = T & "<input class=""InputMenu"" onClick=""WIMBuRRestore()"" accesskey=""r"" type=""submit"" value="" Restore "" title=""Datei(en) aus einem WIM wiederherstellen."">"
T = T & "<input class=""InputMenu"" onClick=""WIMBuRDelete()"" accesskey=""d"" type=""submit"" value="" Delete "" title=""Daten aus einem WIM löschen."">"
T = T & "<input class=""InputMenu"" onClick=""WIMBuRWIMInfo()"" accesskey=""i"" type=""submit"" value="" Informations "" title=""Statistik und Informationen über ein WIM."">"
document.all.MenuEing.innerHTML = T
If MenueAkt = "BURINFO" Then WIMBuRInfo()
If MenueAkt = "BACKUP" Then WIMBuRBackup()
If MenueAkt = "RESTORE" Then WIMBuRRestore()
If MenueAkt = "DELETE" Then WIMBuRDelete()
If MenueAkt = "WIMINFO" Then WIMBuRWIMInfo()
Trace32Log "0584 :: Beendet 'Sub WIMBuRMenu()'", 1
End Sub ' WIMBuRMenu()
'***********************************************************
Sub WIMBuRInfo()
'***********************************************************
Trace32Log "0591 :: Anfang 'Sub WIMBuRInfo()'", 1
MenueAkt = "BURINFO"
Const Abstand = "<br><span style="" line-height: 1.0em; font-size:0.5em; ""><br></span>"
Dim T
T = T & "<span>"
' T = T & "<span style="" line-height: 1.1em; "">"
T = T & "<b>" & Titel & "</b> ist ein HTA und ermöglicht "
T = T & "eine Datensicherung bzw. Datenrücksicherung in/aus WIM-Dateien "
T = T & "mit dem Microsoft-Tool <b>ImageX.exe</b> . . . oder man nehme "
T = T & "<a href=""http://www.autoitscript.com/gimagex"">GImageX</a>."
T = T & Abstand
T = T & "Seit Windows Vista befinden sich auf der Installations-DVD die Dateien zur "
T = T & "Windows-Installation in einem WIM (Windows Imaging File Format) und werden "
T = T & "von ImageX.exe (von der DVD) extrahiert. "
T = T & "ImageX.exe gilt als zuverlässig um Daten in WIMs zu speichern."
T = T & Abstand
T = T & "<u>Vorteile</u> durch die Verwendung von ImageX.exe:"
T = T & "<br> • Das verwendete ""Single-Instancing""-Verfahren speichert Dateidaten getrennt von den<br>"
T = T & " Pfadinformationen, d.h. Dateien, die in mehreren Pfaden oder mehreren Images im WIM<br>"
T = T & " vorhanden sind, werden nur einmal gespeichert, sind aber für alle Images verfügbar."
T = T & "<br> • Wählbare Komprimierung (none, maximum, fast)."
T = T & "<br> • WIMs lassen sich in die Verzeichnisstruktur einbinden (mounten; vergl. "
T = T & "<a href=""http://technet.microsoft.com/de-de/library/cc766067(loband).aspx"">WIM bereit stellen</a>)."
T = T & Abstand
T = T & "<u>Nachteile</u> bzw. Einschränkungen bei der Verwendung von ImageX.exe:"
T = T & "<br> • <span style=""color:#f60; font-weight: bold"">Netzlaufwerke lassen sich nicht sichern!</span> Und: Nein, mappen hilft nicht!"
T = T & "<br> • Beim Löschen von im WIM enthaltenen Images werden 'nur' die Pfadinformationen zu den<br>"
T = T & " Dateien gelöscht, nicht aber überflüssige Dateien selbst - das WIM wird also nicht kleiner."
T = T & "<br> • Beim Löschen des letzten Image im WIM bleiben die Image-Informationen erhalten, auf die<br>"
T = T & " Daten ist aber kein Zugriff (Restore) möglich! "
T = T & "<br> • WIMs sind auf NTFS-Dateisysteme zu speichern (u.a. wegen der 2GB-Grenze bei FAT). "
T = T & "<br> • Folgende NTFS-Features werden nicht unterstützt: Erweiterte Attribute; Objektkennungen;<br>"
T = T & " Analysepunkte, die weder symbolische Verknüpfungen noch Abzweigungen sind; <br>"
T = T & " ursprünglich komprimierte Dateien sind nach der Wiederherstellung nicht komprimiert."
T = T & "<br> • Während Lese-/Schreibzugriffen ist kein Lesen/Schreiben möglich. "
T = T & "<br> • Die Daten in einem WIM lassen sich nicht verschlüsseln - kein Passwortschutz. "
T = T & "<br> • Bei Dateizugriff-Fehlern bricht ImageX.exe <u>immer</u> mit einem Fehler ab. "
T = T & Abstand
T = T & "<u>Informationen</u>: "
T = T & "<br> • "
T = T & "MS wünscht keinen ImageX.exe-Download - man muss das WAIK installieren."
T = T & "<br> • "
T = T & "<a href=""http://technet.microsoft.com/de-de/library/cc722145(loband).aspx"">""Was ist ImageX.exe?""</a> "
T = T & "<a href=""http://technet.microsoft.com/en-us/library/cc722145(loband).aspx"">(en)</a>; "
T = T & "<a href=""http://technet.microsoft.com/de-de/library/cc749447%28WS.10%29.aspx"">""ImageX - Befehlszeilenoptionen""</a> "
T = T & "<a href=""http://technet.microsoft.com/en-us/library/cc749447%28WS.10%29.aspx"">(en)</a>"
T = T & "<br> • "
T = T & "<a href=""http://technet.microsoft.com/de-de/library/dd349350(WS.10).aspx"">WAIK (Win Automated Installation Kit)</a> "
T = T & "<a href=""http://technet.microsoft.com/en-us/library/dd349343(WS.10).aspx"">(en)</a>; "
T = T & "<a href=""http://www.microsoft.com/downloads/details.aspx?displaylang=de&FamilyID=696dd665-9f76-4177-a811-39c26d3b3b34"">WAIK-Download</a> "
T = T & "<a href=""http://www.microsoft.com/downloads/details.aspx?displayLang=en&FamilyID=696dd665-9f76-4177-a811-39c26d3b3b34"">(en)</a>"
T = T & "<br> • "
T = T & "<a href=""http://technet.microsoft.com/de-de/library/cc749528(WS.10).aspx"">Benutzerhandbuch zum Windows Automated Installation Kit (Windows AIK)</a> "
T = T & "<a href=""http://technet.microsoft.com/en-us/library/cc749528(WS.10).aspx"">(en)</a>"
' T = T & "<a href=""http://www.microsoft.com/downloads/details.aspx?familyid=fbbe4826-883b-4893-92d1-4ed1cc4d6a7f&displaylang=de"">WAIK - Benutzerhandbuch für Windows Vista</a> "
' T = T & "<a href=""http://www.microsoft.com/downloads/details.aspx?FamilyID=993c567d-f12c-4676-917f-05d9de73ada4&DisplayLang=en"">(en)</a>"
T = T & "<br> • "
T = T & "<a href=""http://msdn.microsoft.com/en-us/library/ms536471.aspx"">HTA (HTML Applications; en)</a> "
T = T & "<a href=""http://dieseyer.de/dse-wsh-mehr-hta.html"">HTA auf dieseyer.de</a>"
' T = T & Abstand
' T = T & "Ursprünglich sollte diese Anwendung und das Menü durchgehend deutschsprachig "
' T = T & "sein. Leider gibt es im Deutschen für 'Backup' und 'Restore' "
' T = T & "keine ähnlich kurzen und geläufigen Begriffe. Aus diesem Grund "
' T = T & "ist 'nur' das Menü englisch - der REST deutsch. "
T = T & Abstand
T = T & "Änderungswünsche und Ergänzungen bitte an 'dieseyer@gmx.de' . . . "
T = T & "Fehler natürlich auch.<br>"
T = T & Abstand
T = T & "<center style="" font-size:7Pt; "">"
T = T & "<a href=""http://dieseyer.de/scr/WIM-BuR.hta"" ><b>" & Titel & ".hta v1.00</b></a>"
T = T & "<a href=""http://dieseyer.de/dse-impressum.html"" > • © 2010 by dieseyer • all rights reserved • </a>"
T = T & "<a href=""http://dieseyer.de"" ><b><b>www.dieseyer.de</b></b></a>"
' T = T & "<a href=""http://dieseyer.de"" ><b>" & Titel & ".hta</b> • © 2010 by dieseyer • all rights reserved • <b>www.dieseyer.de</b></a>"
T = T & "</center>"
T = T & Abstand
T = T & "<center style="" font-size:7Pt; ""><span id=""HtaInfo"" ></span></center>"
T = T & "</span>"
document.all.MenuRahmen.innerHTML = BuRInfoMenue & T
Trace32Log "0684 :: Beendet 'Sub WIMBuRInfo()'", 1
End Sub ' WIMBuRInfo()
'***********************************************************
Sub SubWIMBuRInst()
'***********************************************************
Trace32Log "0692 :: Anfang 'Sub SubWIMBuRInst()'", 1
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim Txt, T, errTst
Dim ZielDatei : ZielDatei = TempVerz & fso.GetBaseName( HtaSelbst ) & "_Install.hta"
On Error Resume Next
If not fso.FolderExists( ProgrVerz & "\" & DSProgr & "\" ) Then fso.CreateFolder ProgrVerz & "\" & DSProgr & "\"
errTst = err.Number & " - " & err.Description
On Error Goto 0
If Len( errTst ) > 4 Then
Trace32Log "0702 :: Verzeichnis kann nicht erstellt werden: " & ProgrVerz & "\" & DSProgr & "\", 3
Trace32Log "0703 :: LinkErstellen( " & AktVerz & ", " & document.title & ", " & HTASelbst & " )", 1
Call LinkErstellen( AktVerz, document.title, HTASelbst )
Txt = ""
Txt = Txt & "Verzeichnis kann nicht erstellt werden: " & ProgrVerz & "\" & DSProgr & "\"
Txt = Txt & vbCRLF & vbCRLF
Txt = Txt & "Diese Aktion muss ggf. im 'Administrator'-Kontext ausgeführt werden - dafür "
Txt = Txt & "wurde im selben Verzeichnis, in der sich """ & HTASelbst & """ "
Txt = Txt & "befindet, eine Verknüpfung (Link, ShortCut) mit dem selben Namen angelegt. "
Txt = Txt & "Klickt man mit der rechten Maus-Taste auf diesen Link, "
Txt = Txt & "kann 'Als Administrator ausführen' (Run as Administrator) ausgewählt werden - "
Txt = Txt & "so sollte 'es' dann gelingen . . ."
Txt = Txt & vbCRLF & vbCRLF
Txt = Txt & "Soll '" & HTASelbst & "' beendet werden?"
Txt = MsgBox( Txt, 4096 + vbCritical + vbYesNo, "0716 :: " & Titel )
If Txt = vbYes Then Trace32Log "0717 :: Wird (normal) beendet: " & HtaSelbst, 1
If Txt = vbYes Then self.close
Exit Sub
End If
' MsgBox HTASelbst & vbCRLF & ProgrVerz & "\" & DSProgr & "\", , "0721 :: "
On Error Resume Next
fso.CopyFile HTASelbst, ProgrVerz & "\" & DSProgr & "\"
errTst = err.Number & " - " & err.Description
On Error Goto 0
If Len( errTst ) > 4 Then
Trace32Log "0728 :: In Verzeichnis kann nicht geschrieben werden: " & ProgrVerz & "\" & DSProgr & "\", 3
Trace32Log "0729 :: LinkErstellen( " & AktVerz & ", " & document.title & ", " & HTASelbst & " )", 1
Call LinkErstellen( AktVerz, document.title, HTASelbst )
Txt = ""
Txt = Txt & vbTab & "In das Verzeichnis kann nicht gesschrieben werden: "
Txt = Txt & vbCRLF & vbCRLF
Txt = Txt & ProgrVerz & "\" & DSProgr & "\"
Txt = Txt & vbCRLF & vbCRLF
Txt = Txt & "Diese Aktion muss ggf. im 'Administrator'-Kontext ausgeführt werden - dafür "
Txt = Txt & "wurde im selben Verzeichnis, in der sich """ & HTASelbst & """ "
Txt = Txt & "befindet, eine Verknüpfung (Link, ShortCut) mit dem selben Namen angelegt. "
Txt = Txt & "Klickt man mit der rechten Maus-Taste auf diesen Link, "
Txt = Txt & "kann 'Als Administrator ausführen' (Run as Administrator) ausgewählt werden - "
Txt = Txt & "so sollte 'es' dann gelingen . . ."
Txt = Txt & vbCRLF & vbCRLF
Txt = Txt & "Soll '" & HTASelbst & "' beendet werden?"
Txt = MsgBox( Txt, 4096 + vbCritical + vbYesNo, "0744 :: " & Titel )
If Txt = vbYes Then Trace32Log "0745 :: Wird (normal) beendet: " & HtaSelbst, 1
If Txt = vbYes Then self.close
Exit Sub
End If
Trace32Log "0750 :: Soll erstellt werden: '" & ZielDatei & "'", 1
' MsgBox ZielDatei, , "0751 :: "
T = T & vbCRLF & "</html><head>"
T = T & vbCRLF & "<HTA:APPLICATION ID=""oHTA"" APPLICATIONNAME=""Installieren"" SINGLEINSTANCE=""yes"" MAXIMIZEBUTTON=""no"" SHOWINTASKBAR=""yes"" SCROLL=""No"" NAVIGABLE=""no"" >"
T = T & vbCRLF & "<title>Installieren . . . </title>"
T = T & vbCRLF & "<style type=""text/css"">"
T = T & vbCRLF & "html, body { font-size: 9pt; background-color: #116; color: #ec0; font-weight: normal; font-family: verdana, arial, sans-serif; }"
T = T & vbCRLF & ".InputBttn { margin-left: 09px; font-weight: bold; background-color: #116; color: #ec0; width: 120px; height: 30px; }"
T = T & vbCRLF & "</style>"
T = T & vbCRLF & "</head>"
T = T & vbCRLF & "<script language=""VBscript"">"
T = T & vbCRLF & " Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl"
T = T & vbCRLF & " Dim fso : Set fso = CreateObject(""Scripting.FileSystemObject"")"
T = T & vbCRLF & " Const Titel = """ & Titel & " installieren"""
T = T & vbCRLF & " Const ProgrName = """ & Titel & """"
T = T & vbCRLF & " Const ProgrBeschr = """ & document.title & """"
T = T & vbCRLF & " Const ProgrQuelle = """ & AktVerz & "\"""
T = T & vbCRLF & " Const TestDatei = ""Test.txt"""
T = T & vbCRLF & " Const DSProgr = """ & DSProgr & """"
T = T & vbCRLF & " Trace32Log ""Es geht los . . ."", 1"
T = T & vbCRLF & " Dim ProgrVerz : ProgrVerz = """ & ProgrVerz & "\" & DSProgr & """"
'T = T & vbCRLF & " Dim ProgrVerz"
'T = T & vbCRLF & " ProgrVerz = CreateObject(""WScript.Shell"").ExpandEnvironmentStrings(""%ProgramFiles(x86)%"")"
'T = T & vbCRLF & " If InStr( ProgrVerz, ""%"" ) > 0 Then"
'T = T & vbCRLF & " ProgrVerz = CreateObject(""WScript.Shell"").ExpandEnvironmentStrings(""%ProgramFiles%"")"
'T = T & vbCRLF & " End If"
'T = T & vbCRLF & " ProgrVerz = ProgrVerz & ""\" & DSProgr & """"
' T = T & vbCRLF & " ' Verzeichnis und TestDatei erstellen"
' T = T & vbCRLF & " ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
' T = T & vbCRLF & " ' für späteren Test auf Existenz"
' T = T & vbCRLF & " ' On Error Resume Next"
' T = T & vbCRLF & " If not fso.FolderExists( ProgrVerz ) Then fso.CreateFolder ProgrVerz"
' T = T & vbCRLF & " fso.OpenTextFile( ProgrVerz & ""\"" & TestDatei, 2, true).WriteLine ( ""dieseyer.de - "" & Now() & vbCRLF & ProgrVerz & ""\"" & TestDatei )"
' T = T & vbCRLF & " fso.CopyFile oHTA.CommandLine, ProgrVerz & ""\"", True"
T = T & vbCRLF & " "
' T = T & vbCRLF & " Sub Trace32Log( LogTxt, ErrType ) : End Sub"
T = T & vbCRLF & ProzedurInTxt( "InstBeimLaden(" )
T = T & vbCRLF & ProzedurInTxt( "SchreibTest(" )
T = T & vbCRLF & ProzedurInTxt( "InsInstStart(" )
T = T & vbCRLF & ProzedurInTxt( "LinkErstellen(" )
T = T & vbCRLF & ProzedurInTxt( "InstFehlerMsgBox(" )
T = T & vbCRLF & ProzedurInTxt( "DateiTypRegistrieren(" )
T = T & vbCRLF & ProzedurInTxt( "ist64bit(" )
T = T & vbCRLF & ProzedurInTxt( "Trace32Log(" )
T = T & vbCRLF & "<" & "/" & "script>"
T = T & vbCRLF & "<body onLoad=""InstBeimLaden()"">"
T = T & vbCRLF & "<span id=""AllesHtml""></span><br>"
' T = T & vbCRLF & "<center style="" font-size:6Pt; "">" & ZielDatei & "</center>"
T = T & vbCRLF & "</body></html>"
' Trace32Log "0803 :: " & T, 1
' HTA schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "0807 :: Datei soll geschrieben werden: " & ZielDatei, 1
CreateObject("Scripting.FileSystemObject").OpenTextFile( ZielDatei, 2, true, -1 ).Write( T )
Trace32Log "0809 :: Datei ist geschrieben: " & ZielDatei, 1
' HTA starten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ZielDatei = "mshta.exe """ & ZielDatei & """"
Trace32Log "0814 :: Folgt (verzögert): " & Zieldatei, 1
window.setTimeout "ProgrRun('" & ZielDatei & "')", 1*333
Trace32Log "0817 :: 'Self.Close' folgt (verzögert) . . . ", 1
window.setTimeout "Self.Close", 2*333
Trace32Log "0820 :: Beendet 'Sub SubWIMBuRInst()'", 1
End Sub ' SubWIMBuRInst()
'***********************************************************
Sub SchreibTest()
'***********************************************************
Dim errTst
On Error Resume Next
If not fso.FolderExists( ProgrVerz ) Then fso.CreateFolder ProgrVerz
errTst = err.Number & " - " & err.Description
On Error Goto 0
If Len( errTst ) > 4 Then Call InstFehlerMsgBox( "0833 :: Verzeichnis kann nicht erstellt werden: " & ProgrVerz & vbCRLF & vbCRLF & errTst & vbCRLF & vbCRLF & "HTA wird beendet!" ) : Self.Close : Exit Sub
On Error Resume Next
fso.CopyFile Replace( oHTA.CommandLine, """", "" ), ProgrVerz & "\"
errTst = err.Number & " - " & err.Description
On Error Goto 0
If Len( errTst ) > 4 Then Call InstFehlerMsgBox( "0839 :: In Verzeichnis kann nicht geschrieben werden: " & vbCRLF & vbCRLF & ProgrVerz & vbCRLF & vbCRLF & errTst & vbCRLF & vbCRLF & "HTA wird beendet." ) : Self.Close : Exit Sub
' If not fso.FolderExists( ProgrVerz ) Then Call InstFehlerMsgBox( "0841 :: Verzeichnis konnte nicht erstellt werden: " & ProgrVerz ) : Self.Close : Exit Sub
' If not fso.FileExists( ProgrVerz & "\" & TestDatei ) Then Call InstFehlerMsgBox( "0842 :: Datei konnte nicht erstellt werden: " & ProgrVerz & "\" & TestDatei ) : Self.Close : Exit Sub
' MsgBox fso.OpenTextFile( ProgrVerz & "\" & TestDatei, 1 ).ReadAll, , "830:: "
End Sub ' SchreibTest()
'***********************************************************
Sub ProgrRun( Progr )
'***********************************************************
' MsgBox "Progr: " & Progr, , "0850 :: "
Trace32Log "0851 :: Progr: " & Progr, 1
Trace32Log "0852 :: 'Progr' wird gestartet (ohne Warten auf Ende) . . . ", 1
CreateObject("WScript.Shell").Run Progr, , False
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "0857 :: Ist gestartet '" & Progr & "'", 1
End Sub ' ProgrRun( Progr )
'***********************************************************
Function InstBeimLaden() ' ruft einige Routinen auf
'***********************************************************
Dim Txt
Dim User : User = CreateObject("WScript.Network").UserName
window.moveto 30, 30
window.resizeto 370, 360
Txt = Txt & "<center>"
Txt = Txt & "Installation des Programms"
Txt = Txt & "<h2>''" & ProgrName & "''</h2>"
Txt = Txt & "</center>"
Txt = Txt & " <input type=""checkbox"" name=""InstAuswahl"" accesskey=""1"" value=""1""> Desktop-Symbol nur für """ & User & """ erzeugen.<br>"
Txt = Txt & " <input type=""checkbox"" name=""InstAuswahl"" accesskey=""2"" value=""2""> Desktop-Symbol für alle Anwender erzeugen.<br>"
Txt = Txt & "<br>"
Txt = Txt & " <input type=""checkbox"" name=""InstAuswahl"" accesskey=""3"" value=""3""> In 'Programme' nur für """ & User & """ eintragen.<br>"
Txt = Txt & " <input type=""checkbox"" name=""InstAuswahl"" accesskey=""4"" value=""4""> In 'Programme' für alle Anwender eintragen.<br>"
Txt = Txt & "<br>"
' Txt = Txt & " <input type=""checkbox"" name=""InstAuswahl"" accesskey=""5"" value=""5""> Schnellstart-Symbol für """ & User & """ anlegen.<br>"
' Txt = Txt & "<br>"
Txt = Txt & " <input type=""checkbox"" name=""InstAuswahl"" accesskey=""6"" value=""6""> ''" & ProgrName & "'' für WIM-Dateien registrieren.<br>"
Txt = Txt & "<br>"
Txt = Txt & "<center>"
Txt = Txt & "<input class=""InputBttn"" type=""SubMit"" onClick=""InsInstStart()"" accesskey=""s"" value=""Installieren"">"
Txt = Txt & " "
Txt = Txt & "<input class=""InputBttn"" type=""SubMit"" onClick=""Self.Close()"" accesskey=""a"" value=""Abbrechen"">"
' Txt = Txt & "<input class=""InputBttn"" type=""SubMit"" onClick=""InstEnde()"" value=""Abbrechen""><br>"
Txt = Txt & " "
Txt = Txt & "</center>"
document.all.AllesHtml.innerHTML = Txt
window.setTimeout "SchreibTest", 1*333
End Function ' InstBeimLaden()
'***********************************************************
Sub InsInstStart()
'***********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim AusgewLink : Set AusgewLink = document.getElementsByName("InstAuswahl")
Dim ProgrPfad : ProgrPfad = ProgrVerz & "\" & ProgrName & ".hta"
' : ProgrPfad = ProgrName & ".hta"
' MsgBox "ProgrVerz: " & ProgrVerz & vbCRLF & "ProgrPfad: " & ProgrPfad, , "0908 :: " ' Program Files C:\Programme\dieseyer.de\
Trace32Log "0909 :: ProgrPfad : '" & ProgrPfad & "'", 1
Trace32Log "0910 :: ProgrVerz : '" & ProgrVerz & "'", 1
Dim Ausw, Txt, Tst, m
' ausgewählte (angehakte) CheckBoxen prüfen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For m = 0 to AusgewLink.length - 1
If AusgewLink( m ).checked Then Ausw = Ausw & "*" & m & "*"
Next
' MsgBox Ausw, , "0919 :: " & Titel
If InStr( Ausw, "*" ) = 0 Then
Txt = "Ohne Link bzw. ohne Symbol macht eine" & vbCRLF & "Installation keinen Sinn - stimmts?!"
MsgBox Txt, vbInformation, "0923 :: " & Titel
Exit Sub
End If
' zusätzliche Dateien kopieren
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
On Error Resume Next
If not fso.FolderExists( ProgrVerz ) Then fso.CreateFolder ProgrVerz ' : MsgBox "fso.CreateFolder " & ProgrVerz, , "0930 :: "
Tst = err.Number & " - " & err.Description
If Len( Tst ) > 4 Then Call InstFehlerMsgBox( "0932 :: " & Tst ) : Self.Close : Exit Sub
Txt = ProgrQuelle & "comdlg32.ocx"
If fso.FileExists( Txt ) Then fso.CopyFile Txt, ProgrVerz & "\", True ' : MsgBox "fso.CopyFile " & Txt & ", " & ProgrVerz & "\", , "0935 :: "
Tst = err.Number & " - " & err.Description
If Len( Tst ) > 4 Then Call InstFehlerMsgBox( "0937 :: " & Tst ) : Self.Close : Exit Sub
Txt = ProgrQuelle & "ImageX.exe"
If fso.FileExists( Txt ) Then fso.CopyFile Txt, ProgrVerz & "\", True ' : MsgBox "fso.CopyFile " & Txt & ", " & ProgrVerz & "\", , "0940 :: "
Tst = err.Number & " - " & err.Description
If Len( Tst ) > 4 Then Call InstFehlerMsgBox( "0942 :: " & Tst ) : Self.Close : Exit Sub
On Error GoTo 0
' .hta und .ico nach C:\Programme\dieseyer.de kopieren
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = ""
On Error Resume Next
If not fso.FolderExists( ProgrVerz ) Then fso.CreateFolder ProgrVerz ' : MsgBox "fso.CreateFolder " & ProgrVerz, , "0952 :: "
Tst = err.Number & " - " & err.Description
If Len( Tst ) > 4 Then Call InstFehlerMsgBox( "0954 :: " & Tst ) : Self.Close : Exit Sub
Txt = ProgrQuelle & ProgrName & ".hta"
If fso.FileExists( Txt ) Then fso.CopyFile Txt, ProgrVerz & "\", True ' : MsgBox "fso.CopyFile " & Txt & ", " & ProgrVerz & "\", , "0957 :: "
Tst = err.Number & " - " & err.Description
If Len( Tst ) > 4 Then Call InstFehlerMsgBox( "0959 :: " & Tst ) : Self.Close : Exit Sub
Txt = ProgrQuelle & ProgrName & ".exe"
If fso.FileExists( Txt ) Then fso.CopyFile Txt, ProgrVerz & "\", True ' : MsgBox "fso.CopyFile " & Txt & ", " & ProgrVerz & "\", , "0962 :: "
Tst = err.Number & " - " & err.Description
If Len( Tst ) > 4 Then Call InstFehlerMsgBox( "0964 :: " & Tst ) : Self.Close : Exit Sub
Txt = ProgrQuelle & ProgrName & ".com"
If fso.FileExists( Txt ) Then fso.CopyFile Txt, ProgrVerz & "\", True ' : MsgBox "fso.CopyFile " & Txt & ", " & ProgrVerz & "\", , "0967 :: "
Tst = err.Number & " - " & err.Description
If Len( Tst ) > 4 Then Call InstFehlerMsgBox( "0969 :: " & Tst ) : Self.Close : Exit Sub
Txt = ProgrQuelle & ProgrName & ".ico"
If fso.FileExists( Txt ) Then fso.CopyFile Txt, ProgrVerz & "\", True : MsgBox "fso.CopyFile " & Txt & ", " & ProgrVerz & "\", , "0972 :: "
' Tst = err.Number & " - " & err.Description
If Len( Tst ) > 4 Then Call InstFehlerMsgBox( "0974 :: " & Tst ) : Self.Close : Exit Sub
On Error GoTo 0
' Verknüpfungen erstellen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If InStr( Ausw, "*0*" ) > 0 AND InStr( Ausw, "*1*" ) = 0 Then
Tst = 00 ' C:\Dokumente und Einstellungen\DSeyer\Desktop
Tst = CreateObject("Shell.Application").Namespace( Tst ).Self.Path
' MsgBox "LinkErstellen( " & Tst & ", " & ProgrName & ", " & ProgrName & ".hta" & ", " & ProgrName & ".ico )", , "0983 :: " & Titel
Trace32Log "0984 :: LinkErstellen( " & Tst & ", " & ProgrBeschr & ", " & ProgrPfad & " )", 1
Call LinkErstellen( Tst, ProgrBeschr, ProgrPfad )
End If
If InStr( Ausw, "*1*" ) > 0 Then
Tst = 25 ' C:\Dokumente und Einstellungen\All Users\Desktop
Tst = CreateObject("Shell.Application").Namespace( Tst ).Self.Path
' MsgBox "LinkErstellen( " & Tst & ", " & ProgrName & ", " & ProgrName & ".hta" & ", " & ProgrName & ".ico )", , "0991 :: " & Titel
Trace32Log "0992 :: LinkErstellen( " & Tst & ", " & ProgrBeschr & ", " & ProgrPfad & " )", 1
Call LinkErstellen( Tst, ProgrBeschr, ProgrPfad )
End If
If InStr( Ausw, "*2*" ) > 0 AND InStr( Ausw, "*3*" ) = 0 Then
Tst = 02 ' C:\Dokumente und Einstellungen\DSeyer\Startmenü\Programme
Tst = CreateObject("Shell.Application").Namespace( Tst ).Self.Path
' MsgBox "LinkErstellen( " & Tst & ", " & ProgrName & ", " & ProgrName & ".hta" & ", " & ProgrName & ".ico )", , "0999 :: " & Titel
Trace32Log "1000 :: LinkErstellen( " & Tst & ", " & ProgrBeschr & ", " & ProgrPfad & " )", 1
Call LinkErstellen( Tst, ProgrBeschr, ProgrPfad )
End If
If InStr( Ausw, "*3*" ) > 0 Then
Tst = 23 ' C:\Dokumente und Einstellungen\All Users\Startmenü\Programme
Tst = CreateObject("Shell.Application").Namespace( Tst ).Self.Path
' MsgBox "LinkErstellen( " & Tst & ", " & ProgrName & ", " & ProgrName & ".hta" & ", " & ProgrName & ".ico )", , "1007 :: " & Titel
Trace32Log "1008 :: LinkErstellen( " & Tst & ", " & ProgrBeschr & ", " & ProgrPfad & " )", 1
Call LinkErstellen( Tst, ProgrBeschr, ProgrPfad )
End If
If InStr( Ausw, "*4*" ) > 0 Then
Tst = 26 ' Schnellstart C:\Dokumente und Einstellungen\DSeyer\Anwendungsdaten
Tst = CreateObject("Shell.Application").Namespace( Tst ).Self.Path
Tst = Tst & "\Microsoft\Internet Explorer\Quick Launch"
' MsgBox "LinkErstellen( " & Tst & ", " & ProgrName & ", " & ProgrName & ".hta" & ", " & ProgrName & ".ico )", , "1016 :: " & Titel
Trace32Log "1017 :: LinkErstellen( " & Tst & ", " & ProgrBeschr & ", " & ProgrPfad & " )", 1
Call LinkErstellen( Tst, ProgrBeschr, ProgrPfad )
End If
If InStr( Ausw, "*5*" ) > 0 Then
' MsgBox fso.GetFileName( ProgrPfad ) & vbCRLF & ProgrPfad, , "1022 :: "
Call DateiTypRegistrieren( "wim", ProgrPfad )
End If
MsgBox """" & ProgrName & """ wurde nach" & vbCRLF & vbCRLF & ProgrPfad & vbCRLF & vbCRLF & "kopiert und wird jetzt gestartet.", vbInformation, "1026 :: " & Titel
Tst = "mshta.exe """ & ProgrPfad & """"
Trace32Log "1029 :: Soll gestartet : " & Tst, 1
Trace32Log "1030 :: Wird gestartet (ohne Warten auf Ende) . . . ", 1
CreateObject("WScript.Shell").Run Tst, , False
Trace32Log "1034 :: Ist gestartet : " & Tst, 1
Trace32Log "1036 :: 'Self.Close' folgt . . . ", 1
window.setTimeout "Self.Close", 333
Trace32Log "1038 :: 'Self.Close' wurde (mit Zeitverzögerung) abgesetzt.", 1
End Sub ' InsInstStart()
'***********************************************************
Sub LinkErstellenAlt( LinkVerz, ProgrBeschr, ProgrPfad )
'***********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim ProgrName : ProgrName = fso.GetBaseName( ProgrPfad )
Dim LinkPfad : LinkPfad = LinkVerz & "\" & ProgrName & ".lnk"
Dim IconPfad : IconPfad = Mid( ProgrPfad, 1, InStrRev( ProgrPfad, "." ) ) & "ico"
Dim oShellLink
Dim Tst
Tst = Tst & "LinkVerz: " & vbTab & LinkVerz & vbCRLF
Tst = Tst & "ProgrBeschr: " & vbTab & ProgrBeschr & vbCRLF
Tst = Tst & "ProgrPfad: " & vbTab & ProgrPfad & vbCRLF
Tst = Tst & "ProgrName: " & vbTab & ProgrName & vbCRLF
Tst = Tst & "LinkPfad: " & vbTab & LinkPfad & vbCRLF
Tst = Tst & "IconPfad: " & vbTab & IconPfad & vbCRLF
' MsgBox Tst, , "1061 :: "
' Set oShellLink = CreateObject("WScript.Shell").CreateShortcut(strDesktop & "\Shortcut Script.lnk")
Set oShellLink = CreateObject("WScript.Shell").CreateShortcut( LinkPfad )
' oShellLink.TargetPath = WScript.ScriptFullName
oShellLink.TargetPath = ProgrPfad
oShellLink.WindowStyle = 1
' oShellLink.Hotkey = "CTRL+SHIFT+F"
' oShellLink.IconLocation = "notepad.exe, 0"
oShellLink.IconLocation = IconPfad
' oShellLink.Description = "Shortcut Script"
oShellLink.Description = ProgrBeschr
' oShellLink.WorkingDirectory = strDesktop
' oShellLink.WorkingDirectory = LinkVerz
oShellLink.WorkingDirectory = "%TEMP%"
oShellLink.Save
End Sub ' LinkErstellenAlt( LinkVerz, ProgrBeschr, ProgrPfad )
'***********************************************************
Sub InstFehlerMsgBox( Txt )
'***********************************************************
MsgBox vbTab & "Fehler:" & vbCRLF & vbCRLF & Txt, vbCritical , "1091 :: " & Titel
End Sub ' InstFehlerMsgBox( Txt )
'*** v8.4 *** www.dieseyer.de ******************************
Function ProzedurInTxt( ProzName )
'***********************************************************
' Übergibt (aus dem aktuellen VBS) den Inhalt einer Prozedur
ProzName = LCase( ProzName )
Dim i
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst, Tyt, ZeileAkt, ProzOK
ProzOK = "-OK"
Txt = "'***********************************************************"
Dim FileIn : Set FileIn = fso.OpenTextFile( HtaSelbst, 1 )
Do While Not ( FileIn.atEndOfStream )
ZeileAkt = FileIn.Readline
Tst = LCase( ZeileAkt )
If ProzOK = "-OK" Then
Tyt = InStr( Tst, "function " & ProzName ) : If Tyt > 0 AND Tyt < 4 Then ProzOK = "OK"
Tyt = InStr( Tst, "sub " & ProzName ) : If Tyt > 0 AND Tyt < 4 Then ProzOK = "OK"
End If
If ProzOK = "OK" Then Txt = Txt & vbCRLF & ZeileAkt ' : MsgBox now() & vbCRLF & Txt, , "1119 :: " : i = i + 1 : If i > 10 Then WScript.Quit
If ProzOK = "OK" AND InStr( Tst, "end function" ) > 0 Then Exit Do
If ProzOK = "OK" AND InStr( Tst, "end sub" ) > 0 Then Exit Do
Loop
FileIn.Close : Set FileIn = nothing
Txt = Txt & vbCRLF & "'***********************************************************"
ProzedurInTxt = Txt ' : MsgBox now() & vbCRLF & ProzedurInTxt, , "1130 :: "
End Function ' ProzedurInTxt( ProzName )
'***********************************************************
Sub WIMBuRBackup()
'***********************************************************
Trace32Log "1138 :: Anfang 'Sub WIMBuRBackup()'", 1
MenueAkt = "BACKUP"
Dim T
T = T & "<br> <b>ACHTUNG</b>: Folgenden NTFS-Features werden von ImageX.exe nicht unterstützt:"
T = T & "<br> • Erweiterte Attribute."
T = T & "<br> • Objektkennungen."
T = T & "<br> • Analysepunkte, die weder symbolische Verknüpfungen noch Abzweigungen sind."
T = T & "<br> • Komprimierte Dateien werden beim Restore unkomprimiert gespeichert."
T = T & "<br> Näheres bei MS: "
T = T & "<a href=""http://technet.microsoft.com/de-de/library/cc722145(loband).aspx"">'de-de'</a> oder "
T = T & "<a href=""http://technet.microsoft.com/en-us/library/cc722145(loband).aspx"">'en-us'</a><br>"
T = T & "<br>"
T = T & "<input class=""InputSonst"" onClick=""BackupQuelle()"" type=""submit"" accesskey=""q"" value=""Quelle""> "
If DatenQuelle = "" Then
T = T & "(Es ist kein Quell-Verzeichnis für eine Datensicherung fest gelegt.)"
Else
T = T & " """ & DatenQuelle & """ <br><br>"
T = T & "<input class=""InputSonst"" onClick=""SubBackup()"" type=""submit"" accesskey=""s"" value="" Start ""> "
' T = T & " Mit einem Klick auf [Start] werden die Dateien der 'Quelle' in das WIM kopiert. "
T = T & " Datei(en) und Verzeichnis(se) der 'Quelle' werden in das WIM kopiert. "
T = T & "<br>"
If not ProgrVerz = "MININT" Then ' bei WinPE
T = T & "<br>"
T = T & "<input class=""InputSonst"" onClick=""SubBackupTask()"" type=""submit"" accesskey=""t"" value="" Task ""> "
T = T & " Es wird ein 'Geplanter Taks' für ein tägliches Backup konfiguriert."
T = T & "<br>"
End If
T = T & "<br>"
T = T & " ImageX.exe " & ProgrVersion & " erhält folgende Startparameter bei der WIM-Erstellung:"
T = T & "<br>"
T = T & "<br>"
T = T & " <b>" & ProgrPara & "</b>"
End If
document.all.MenuRahmen.innerHTML = BuRBackupMenue & T
Trace32Log "1175 :: Beendet 'Sub WIMBuRBackup()'", 1
End Sub ' WIMBuRBackup()
'***********************************************************
Sub SubBackup()
'***********************************************************
Trace32Log "1182 :: Anfang 'Sub SubBackup()'", 1
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst, Tyt, errTst, i, CmdBef, ExeDauer, ZeitPunkt
Dim CMDDatei : CMDDatei = CMDPfad & "_Backup.cmd"
Trace32Log "1187 :: Gebildete CMDDatei-Name: " & CMDDatei, 1
ZeitPunkt = AktuelleDMTFDateTime
ZeitPunkt = Mid( ZeitPunkt, 1, InStr( ZeitPunkt, "." ) - 1 )
Tst = WIMGewaehlt
If not InStr( Tst, "\\" ) = 1 AND not InStr( Tst, ":\" ) = 2 Then
MsgBox WIMGewaehlt & vbCRLF & vbCRLF & ". . . es kann also kein Sicherung gestartet werden.", vbCritical, "1194 :: " & Titel
Call WIMAuswahl()
Exit Sub
End if
' MsgBox "WIMGewaehlt: '" & WIMGewaehlt & "'", , "1198 :: "
If fso.FileExists( WIMGewaehlt ) Then
If fso.GetFile( WIMGewaehlt ).Size < 50 Then
MsgBox WIMGewaehlt & vbCRLF & "ist nur " & fso.GetFile( WIMGewaehlt ).Size & "Byte groß und wird gelöscht.", vbInformation,"1201 :: " & Titel
fso.DeleteFile WIMGewaehlt, True
Trace32Log "1203 :: 'WIMGewaehlt' gelöscht, weil zu klein: " & WIMGewaehlt, 1
' Ein WIM ohne Inhalt ist min 1,5 KByte groß
Else
' MsgBox WIMGewaehlt & ": " & fso.GetFile( WIMGewaehlt ).Size & "Bytes", , "1206 :: "
Trace32Log "1207 :: 'WIMGewaehlt' nicht gelöscht, weil " & fso.GetFile( WIMGewaehlt ).Size & "Bytes groß.", 1
End If
Else
Trace32Log "1210 :: 'WIMGewaehlt' wird neu angelegt . . . ", 1
End If
' MsgBox CmdBef, , "1213 :: "
' imagex /capture d: d:\imaging\data.wim "Drive D"
' imagex /append d: d:\imaging\data.wim "Drive D"
' /CHECK
' Enables WIM integrity checking. Flag must be supplied during updates.
' /COMPRESS [maximum | fast | none]
' Specifies the type of compression used for the initial capture operation.
' /CONFIG configuration_file.ini
' Enables use of a configuration file for exclusion and compression options.
' configuration_file.ini - The path to the configuration file.
' /NORPFIX
' Disables reparse point tag fixup. If not provided, reparse points that
' resolve to paths outside of image_path will not be captured
' /SCROLL
' Scrolls output for redirection.
' /VERIFY
' Enables file
Tst = ""
If ProgrVerz = "MININT" AND fso.FolderExists( "X:\" ) Then
' bei WinPE als winpe.wim im RAM; %systemdrive%=X:
' es gibt keine Geschwindigkeitsvorteile!
Tyt = "X:\" & fso.GetTempName()
On Error Resume Next
fso.OpenTextFile( Tyt, 2, True).WriteLine Now()
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
' If Len( errTst ) < 5 Then Tst = " /TEMP X:" : fso.DeleteFile Tyt, True
End If
If ProgrVerz = "MININT" AND fso.FolderExists( "R:\" ) Then
' bei WinPE und %systemdrive%=X: und mit 'seperater' RAM-Disk R:
Tyt = "R:\" & fso.GetTempName()
On Error Resume Next
fso.OpenTextFile( Tyt, 2, True).WriteLine Now()
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
If Len( errTst ) < 5 Then Tst = " /TEMP R:" : fso.DeleteFile Tyt, True
End If
Txt = "@echo off"
Txt = Txt & vbCRLF & "@echo " & "1254 :: Start: %DATE% %TIME% "
Txt = Txt & vbCRLF & "@echo " & "1255 :: Start: %DATE% %TIME%>>""%~dpn0.log"""
Txt = Txt & vbCRLF & "" & " Set CmdBef=/CAPTURE"
Txt = Txt & vbCRLF & "if exist """ & WIMGewaehlt & """ Set CmdBef=/APPEND"
' Txt = Txt & vbCRLF & "@Set CmdBef=""" & ProgrExe & """ " & ProgrPara & " %CmdBef% """ & DatenQuelle & """ """ & WIMGewaehlt & """ """ & Titel & " " & ZeitPunkt & """ ""Quelle: " & DatenQuelle & """"
Txt = Txt & vbCRLF & "@Set CmdBef=""" & ProgrExe & """ " & ProgrPara & Tst & " %CmdBef% """ & DatenQuelle & """ """ & WIMGewaehlt & """ """ & Titel & " %DATE% %TIME%"" ""Quelle: " & DatenQuelle & """"
Txt = Txt & vbCRLF & "@echo " & "1260 :: %CmdBef%"
Txt = Txt & vbCRLF & "@echo " & "1261 :: %CmdBef%>>""%~dpn0.log"""
Txt = Txt & vbCRLF & "%CmdBef%"
Txt = Txt & vbCRLF & "@Set RC=%errorlevel%"
Txt = Txt & vbCRLF & "@echo " & "1264 :: Ende: %DATE% %TIME% "
Txt = Txt & vbCRLF & "@echo " & "1265 :: Ende: %DATE% %TIME%>>""%~dpn0.log"""
Txt = Txt & vbCRLF & "@echo."
Txt = Txt & vbCRLF & "@echo Ende: %0 - RC: %RC%"
Txt = Txt & vbCRLF & "@if not ""%RC%""==""0"" Color E4"
Txt = Txt & vbCRLF & "@echo."
Txt = Txt & vbCRLF & "@if not ""%RC%""==""0"" @echo !!! FEHLER !!! FEHLER !!! FEHLER !!! FEHLER !!! FEHLER !!! FEHLER !!! FEHLER !!!"
Txt = Txt & vbCRLF & "@echo."
If not ZeitTest = "Ja" Then
Txt = Txt & vbCRLF & "@pause && @pause"
End If
Txt = Txt & vbCRLF & "exit %RC%"
Trace32Log "1277 :: Folgendes wird in die CMD-Datei geschrieben: " & vbCRLF & Txt, 1
' MsgBox "CMDDatei: '" & CMDDatei & "'", , "1278 :: "
' CMD-Zeilen in CMD-Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "1281 :: Datei soll geschrieben werden: " & CMDDatei, 1
CreateObject("Scripting.FileSystemObject").OpenTextFile( CMDDatei, 2, True).WriteLine Txt
Trace32Log "1283 :: Datei ist geschrieben: " & CMDDatei, 1
' CMD-Datei starten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "1287 :: CMDDatei (ImageX-Befehlszeile) wird gestartet . . . ", 1
ExeDauer = Timer()
i = WSHShell.Run( """" & CMDDatei & """", , True )
' MsgBox "RC: '" & i & "'", , "1290 :: "
If ZeitTest = "Ja" Then ExeDauer = vbCRLF & vbCRLF & "ExeDauer: " & ( Timer() - ExeDauer ) & "s"
If not ZeitTest = "Ja" Then ExeDauer = ""
Trace32Log "1293 :: CMDDatei (ImageX-Befehlszeile) ist beendet.", 1
Txt = vbTab & "Datei(en) und Verzeichnis(se) von " & vbCRLF & vbCRLF & DatenQuelle & vbCRLF & vbCRLF & vbTab & "wurden in folgendes WIM kopiert (eingefügt):" & vbCRLF & vbCRLF & WIMGewaehlt & ExeDauer
Tst = vbCritical
Select Case i
Case 0 Tst = vbInformation : Txt = Txt & ExeDauer
Case 1 Tst = vbCritical : Txt = Replace( Txt, "wurden in", "wurden NICHT in" ) & vbCRLF & vbCRLF & "Fehler " & i & ": Ungültige Befehlszeilenoption!"
Case 2 Tst = vbCritical : Txt = Replace( Txt, "wurden in", "wurden NICHT in" ) & vbCRLF & vbCRLF & "Fehler " & i & ": WIMGAPI-Fehler!"
Case 3 Tst = vbCritical : Txt = Replace( Txt, "wurden in", "wurden NICHT in" ) & vbCRLF & vbCRLF & "Fehler " & i & ": Ungültiges Konfigurationsskript!"
Case 4 Tst = vbCritical : Txt = Replace( Txt, "wurden in", "wurden NICHT in" ) & vbCRLF & vbCRLF & "Fehler " & i & ": Zugriff verweigert, Administratorrechte erforderlich!"
End Select
If Tst = vbCritical Then
Txt = Txt & vbCRLF & vbCRLF
Txt = Txt & "Wenn keine Zugriffsprobleme beim Schreiben in das WIM "
Txt = Txt & "und keine Zugriffsprobleme beim Lesen der zu sichernden Daten bestehen, "
Txt = Txt & "muss diese Aktion ggf. im 'Administrator'-Kontext ausgeführt werden - dafür wurde "
Tst = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%ProgramFiles%")
' MsgBox UCase( HTASelbst ) & vbCRLF & UCase( Tst & "\" & DSProgr & "\" ), , "1310 :: "
If InStr( UCase( HTASelbst ), UCase( Tst & "\" & DSProgr & "\" ) ) = 0 Then
Trace32Log "1313 :: LinkErstellen( " & AktVerz & ", " & document.title & ", " & HTASelbst & " )", 1
Tst = LinkErstellen( AktVerz, document.title, HTASelbst )
Txt = Txt & "im selben Verzeichnis, in der sich das """ & HTASelbst & """ befindet, "
Else
Tst = CreateObject("Shell.Application").Namespace( 0 ).Self.Path
Trace32Log "1318 :: LinkErstellen( " & AktVerz & ", " & document.title & ", " & HTASelbst & " )", 1
Tst = LinkErstellen( Tst, document.title, HTASelbst )
Txt = Txt & "auf dem Desktop "
End If
Txt = Txt & "eine Verknüpfung (Link, ShortCut) mit dem selben Namen angelegt. "
Txt = Txt & "Klickt man mit der rechten Maus-Taste auf diesen Link, kann "
Txt = Txt & "'Als Administrator ausführen' (Run as Administrator) ausgewählt werden - "
Txt = Txt & "so sollte 'es' dann gelingen . . ."
Txt = Txt & vbCRLF & vbCRLF
If InStr( Tst, "Fehler:" ) = 1 Then Txt = Txt & Tst & vbCRLF & vbCRLF
Txt = Txt & "Soll '" & HTASelbst & "' beendet werden?"
Txt = MsgBox( Txt, 4096 + vbCritical + vbYesNo, "1329 :: " & Titel )
' Txt = MsgBox( Txt, 4096 + vbCritical + vbYesNo, "1330 :: " & Titel & " " & Len( Txt ) )
If Txt = vbYes Then self.close
If Txt = vbYes Then Trace32Log "1332 :: Wird (normal) beendet: " & HtaSelbst, 1
If Txt = vbYes Then Exit Sub
Else
MsgBox Txt, Tst + 4096, "1335 :: " & Titel
End If
Trace32Log "1338 :: Beendet 'Sub SubBackup()'", 1
Call WIMBuRWIMInfo()
End Sub ' SubBackup()
'***********************************************************
Sub SubBackupTask()
'***********************************************************
Trace32Log "1348 :: Anfang 'Sub SubBackupTask()'", 1
' Frage nach Zeitpunkt für autom. Backup (SCHTASKS)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "1352 :: Frage nach Zeitpunkt für autom. Backup (SCHTASKS) . . .", 1
' MsgBox "SubBackupTask", , "1353 :: " & Titel
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim CmdBef, ZeitPunkt, Txt, T, Tst, CMDGepltask
T = ""
T = T & "Zu welcher Uhrzeit sollen täglich Datei(en) und Verzeichnis(se) von" & vbCRLF & vbCRLF
T = T & " " & DatenQuelle & vbCRLF & vbCRLF
T = T & "in dieses WIM (neues Image) kopiert werden?" & vbCRLF & vbCRLF
T = T & " " & WIMGewaehlt & vbCRLF & vbCRLF
T = T & "(Es sind nur volle Stunden wählbar.)" & vbCRLF
Tst = InputBox( T, "1362 :: " & Titel, "18" )
' Bediener-Abbruch
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Tst = vbCancel Then Trace32Log "1366 :: Bediener-Abbruch", 1 : Exit Sub
If VarType( Tst ) = 0 Then Trace32Log "1367 :: Keine Eingabe", 1 : Exit Sub
' Bediener-Fehler (falsche Eingabe)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Prüfung mit 'Exit Sub' am Zeilenende
If InStr( Tst, "." ) > 0 Then MsgBox "Ungültige Eingabe: '" & Tst & "'", vbCritical, "1372 :: " & Titel : Trace32Log "1372 :: Falsche Eingabe: " & Tst, 1 : Exit Sub
If InStr( Tst, "," ) > 0 Then MsgBox "Ungültige Eingabe: '" & Tst & "'", vbCritical, "1373 :: " & Titel : Trace32Log "1373 :: Falsche Eingabe: " & Tst, 1 : Exit Sub
On Error Resume Next
Tst = Int( Tst )
On Error Goto 0
If not IsNumeric( Tst ) Then MsgBox "Ungültige Eingabe: '" & Tst & "'", vbCritical, "1377 :: " & Titel : Trace32Log "1377 :: Falsche Eingabe: " & Tst, 1 : Exit Sub
If Tst < 0 OR Tst > 24 Then MsgBox "Ungültige Eingabe: '" & Tst & "'", vbCritical, "1378 :: " & Titel : Trace32Log "1378 :: Falsche Eingabe: " & Tst, 1 : Exit Sub
If Len( Tst ) = 1 Then Tst = "0" & Tst
ZeitPunkt = Tst
Trace32Log "1382 :: Erhaltener Zeitpunkt für autom. Backup (SCHTASKS): " & ZeitPunkt, 1
' Befehlszeile für löschen eines evtl. vorhandenen Tasks
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "1386 :: Löschen eines evtl. vorhandenen Tasks (SCHTASKS) . . . ", 1
CmdBef = "SCHTASKS /Delete /TN " & Titel & " /F"
Trace32Log "1388 :: Gebildete CmdBef (SCHTASKS-Befehlszeile): " & CmdBef, 1
Trace32Log "1389 :: CmdBef (SCHTASKS-Befehlszeile) wird gestartet . . . ", 1
WSHShell.Run CmdBef, , True
Trace32Log "1391 :: CmdBef (SCHTASKS-Befehlszeile) ist beendet.", 1
' Befehlszeile für löschen eines evtl. vorhandenen Tasks
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' CmdBef = """" & ProgrExe & """ " & ProgrPara & " /APPEND """ & DatenQuelle & """ """ & WIMGewaehlt & """ """ & Titel & " %date% %time%"" ""Quelle: " & DatenQuelle & """ "
' Trace32Log "1396 :: Gebildete CmdBef (ImageX-Befehlszeile): " & CmdBef, 1
Txt = "@echo off"
Txt = Txt & vbCRLF & "@Set Log=""%~dpn0.log"""
Txt = Txt & vbCRLF & "@echo " & "1401 :: Start: %DATE% %TIME% "
Txt = Txt & vbCRLF & "@echo " & "1402 :: Start: %DATE% %TIME% >> %Log%"
Txt = Txt & vbCRLF & "" & " Set CmdBef=/CAPTURE"
Txt = Txt & vbCRLF & "if exist """ & WIMGewaehlt & """ Set CmdBef=/APPEND"
Txt = Txt & vbCRLF & "@Set CmdBef=""" & ProgrExe & """ " & ProgrPara & " %CmdBef% """ & DatenQuelle & """ """ & WIMGewaehlt & """ """ & Titel & " %DATE% %TIME% "" ""Quelle: " & DatenQuelle & """"
Txt = Txt & vbCRLF & "@echo " & "1406 :: %CmdBef% >> %Log%"
Txt = Txt & vbCRLF & "@echo " & "1407 :: %CmdBef%"
Txt = Txt & vbCRLF & "%CmdBef%"
Txt = Txt & vbCRLF & "@Set RC=%errorlevel%"
Txt = Txt & vbCRLF & "@echo " & "1410 :: Ende: %DATE% %TIME% "
Txt = Txt & vbCRLF & "@echo " & "1411 :: Ende: %DATE% %TIME%>>%Log%.log"
Txt = Txt & vbCRLF & "@echo."
Txt = Txt & vbCRLF & "@if not ""%RC%""==""0"" Color E4"
Txt = Txt & vbCRLF & "@if not ""%RC%""==""0"" @echo !!! FEHLER !!! FEHLER !!! FEHLER !!! FEHLER !!! FEHLER !!! FEHLER !!! FEHLER !!!"
Txt = Txt & vbCRLF & "@if not ""%RC%""==""0"" @echo !!! FEHLER !!! >> %Log%"
Txt = Txt & vbCRLF & "@echo."
Txt = Txt & vbCRLF & "@echo " & "1417 :: %DATE% %TIME% >> %Log%"
Txt = Txt & vbCRLF & "@echo " & "1418 :: %DATE% %TIME% "
Txt = Txt & vbCRLF & "@echo."
Txt = Txt & vbCRLF & "@echo Ende: %0 - RC: %RC%"
Txt = Txt & vbCRLF & "@echo."
Txt = Txt & vbCRLF & ":@if not ""%RC%""==""0"" @pause && @pause"
Txt = Txt & vbCRLF & "@pause && @pause"
Trace32Log "1425 :: Folgendes wird in die CMD-Datei geschrieben: " & vbCRLF & Txt, 1
' CMD-Zeilen in CMD-Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CMDGepltask = CMDPfad & "_GeplTask.cmd"
' MsgBox "CMDGepltask: """ & CMDGepltask & """", , "1430 :: "
Trace32Log "1432 :: Datei soll geschrieben werden: " & CMDGepltask, 1
CreateObject("Scripting.FileSystemObject").OpenTextFile( CMDGepltask, 2, True).WriteLine Txt
Trace32Log "1434 :: Datei ist geschrieben: " & CMDGepltask, 1
' Befehlszeile für neuen Tasks
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CmdBef = "SCHTASKS /Create /TN " & Titel & " /SC Täglich /ST " & ZeitPunkt & ":00:00 /TR """"""""" & CMDGepltask & """"""""""
Trace32Log "1440 :: Gebildete CmdBef (SCHTASKS-Befehlszeile): " & CmdBef, 1
' InputBox CmdBef, "1442 :: ", CmdBef
Trace32Log "1443 :: CmdBef (SCHTASKS-Befehlszeile) wird gestartet . . . ", 1
Tst = WSHShell.Run( CmdBef, , True )
Trace32Log "1445 :: CmdBef (SCHTASKS-Befehlszeile) ist beendet.", 1
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = "Diese Funktion ist als Demo implementiert!" & vbCRLF & vbCRLF
Txt = Txt & "Ggf. mus die Ausführung im Administrator-Kontext ausgeführt werden!" & vbCRLF & vbCRLF
Txt = Txt & "Benutzung auf eigene Gefahr! " & vbCRLF & vbCRLF
Txt = Txt & "Das ist _KEIN_ sicheres Verfahren!" & vbCRLF & vbCRLF
Txt = Txt & "! ! ! Unbedingt regelmäßig Prüfen ! ! !" & vbCRLF
Txt = Txt & "~~~~~~~~~~~~~~~~~~~~~~~~"
MsgBox Txt, vbCritical , "1454 :: " & Titel ' & " " & Tst
Trace32Log "1456 :: Beendet 'Sub SubBackupTask()'", 1
End Sub ' SubBackupTask()
'***********************************************************
Sub BackupQuelle()
'***********************************************************
Trace32Log "1464 :: Anfang 'Sub BackupQuelle()'", 1
Trace32Log "1465 :: Aktuelles Verzeichnis DatenQuelle (für Backup): " & DatenQuelle, 1
If ProgrVerz = "MININT" Then ' bei WinPE
Trace32Log "1467 :: InputBox für Verzeichnis-Auswahl (für Backup) wird angezeigt . . . ", 1
DatenQuelle = InputBox( "Bitte den kompletten Pfad zu einem WIM eingeben:", "1468 :: " & Titel, AktVerz )
Trace32Log "1469 :: Neues Verzeichnis DatenQuelle (für Backup): '" & DatenQuelle & "'", 1
Else
Trace32Log "1471 :: Verzeichnis-Auswahl (für Backup) wird gestartet . . . ", 1
DatenQuelle = BFFVerzAuswahl( "1472 :: Zu sicherndes Verzeichnis auswählen:" )
Trace32Log "1473 :: Neues Verzeichnis DatenQuelle (für Backup): '" & DatenQuelle & "'", 1
End If
' MsgBox "Neue DatenQuelle: '" & DatenQuelle & "'" & vbCRLF & "UserProfilVerz: '" & UserProfilVerz & "'", , "1475 :: "
If DatenQuelle = "" Then DatenQuelle = UserProfilVerz()
' MsgBox "Neue DatenQuelle: '" & DatenQuelle & "'", , "1477 :: "
If Len( DatenQuelle ) = 3 AND Mid( DatenQuelle, 3, 1 ) = "\" Then
Trace32Log "1479 :: DatenQuelle '" & DatenQuelle & "' wird gekürzt . . .", 1
DatenQuelle = Left( DatenQuelle, 2 )
Trace32Log "1481 :: DatenQuelle ist gekürzt auf '" & DatenQuelle & "'.", 1
' MsgBox Len( DatenQuelle ) & " - DatenQuelle: '" & DatenQuelle & "'", , "1482 :: " & Titel
End If
Trace32Log "1484 :: Beendet 'Sub BackupQuelle()'", 1
Call WIMBuRBackup()
End Sub ' BackupQuelle()
'***********************************************************
Sub WIMBuRRestore()
'***********************************************************
Trace32Log "1491 :: Anfang 'Sub WIMBuRRestore()'", 1
MenueAkt = "RESTORE"
document.all.MenuRahmen.innerHTML = BuRRestoreMenue & "<br> " & "1493 :: Die WIM-Informationen werden eingelesen. Bitte warten . . ."
window.setTimeout "WIMBuRWIMInfoDaten()", 333
Trace32Log "1495 :: Beendet 'Sub WIMBuRRestore()'", 1
End Sub ' WIMBuRRestore()
'***********************************************************
Sub Partitionieren()
'***********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim DiskPartDatei : DiskPartDatei = UserTempVerz & "\WIM-BuR.diskpart"
Dim FormatCMD : FormatCMD = UserTempVerz & "\WIM-BuRFormat.cmd"
Dim DateiCMD : DateiCMD = UserTempVerz & "\DP_LisDis.cmd"
Dim DiskPartParm, FromatPart, SplitTst, Txt, Tst, Tyt, i, n, PartName, PartSize
' aktuelle HDDs anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
DiskPartParm = "lis dis"
fso.OpenTextFile( DiskPartDatei, 2, true).WriteLine( DiskPartParm )
document.all.MenuRahmen.innerHTML = BuRInfoMenue & "Bitte warten . . . "
' MsgBox "DiskPartDatei: '" & DiskPartDatei & "'" & vbCRLF & "DateiCMD: '" & DateiCMD & "' " & vbCRLF & "ExecHiddenPlus", , "1517 :: "
Tst = ExecHiddenPlus( "DISKPART.EXE /s """ & DiskPartDatei & """" )
SplitTst = Split( Tst, vbLF, -1, 1) : n = 0
For i = LBound( SplitTst ) To UBound( SplitTst )
If InStr( UCase( SplitTst( i ) ), "ONLINE" ) > 5 Then
Tyt = SplitTst( i ) : Tyt = Trim( Tyt )
Tyt = Replace( Tyt, vbTab, "" ) : Tyt = Replace( Tyt, " ", " " ) : Tyt = Replace( Tyt, " ", " " )
Tyt = Replace( Tyt, vbCRLF, "" ) : Tyt = Replace( Tyt, vbLF, "" ) : Tyt = Replace( Tyt, vbCR, "" )
Tyt = Tyt & " frei"
' Txt = Txt & vbCRLF & i & " " & SplitTst( i ) & " frei"
Txt = Txt & vbCRLF & "Nr. " & n & " => " & Tyt
ReDim Preserve SplitTxt( n ) : SplitTxt( n ) = Tyt : n = n + 1
' ReDim Preserve SplitTxt( n ) : SplitTxt( n ) = SplitTst( i ) : n = n + 1
' MsgBox SplitTst( i ), , "1530 :: " & n
End If
Next
n = n - 1
' HDD-Auswahl anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = "Folgende Festplatten (Disks; HDDs) befinden sich auf diesem PC:" & vbCRLF & Txt & vbCRLF & vbCRLF
Txt = Txt & "Welche Festplatte soll neu partitioniert werden?" & vbCRLF
Txt = Txt & "ALLE Daten der Festplatte gehen verloren!"
n = 9
n = InputBox( Txt, "1542 :: " & Titel, "" )
If n = "" Then
MsgBox "Ungültige Eingabe!" & vbCRLF & vbCRLF & "Abbruch der Partitionierung!", 4096 + vbInformation, "1544 :: " & Titel
Call WIMBuRRestore()
Exit Sub
End If
' MsgBox n, , "1548 :: "
If IsNumeric( n ) Then
n = Int( n )
Else
MsgBox "Es sind nur Zahl als Eingabe möglich!" & vbCRLF & vbCRLF & "Abbruch der Partitionierung!", 4096 + vbInformation, "1552 :: " & Titel
Call WIMBuRRestore()
Exit Sub
End If
If n > n OR n < 0 Then
MsgBox "Die eingegebene Zahl (" & n & ") ist zu groß oder zu klein! (0-" & n & ")" & vbCRLF & vbCRLF & "Abbruch der Partitionierung!", 4096 + vbInformation, "1557 :: " & Titel
Call WIMBuRRestore()
Exit Sub
End If
' (künftige) Partitionierung erfragen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
FromatPart = ""
DiskPartParm = "sel dis " & n & vbCRLF
DiskPartParm = DiskPartParm & "clean" & vbCRLF
Txt = vbTab & "Die Festplatte" & vbCRLF & vbCRLF & Trim( SplitTxt( n ) ) & " frei" & vbCRLF & vbCRLF & vbTab & "soll neu partitioniert werden . . ." & vbCRLF & vbCRLF
Txt = Txt & "Bitte die Laufwerksbuchstaben und die Größen der einzelnen Laufwerke (Partitionen) angeben!" & vbCRLF & vbCRLF
Txt = Txt & vbTab & """C:12 E:8 F:"" steht für: " & vbCRLF & "Lw. C: mit 12GB, Lw. E: mit 8GB, Lw. F: restliche GB (CD-Lw. wird D:)." & vbCRLF
Txt = Txt & vbTab & """C:12 D:"" steht für: " & vbCRLF & "Lw. C: mit 12GB, Lw. E: restliche GB (CD-Lw. wird E:)." & vbCRLF
Txt = Txt & vbTab & "Die Eingabe ""C:12"" steht für: " & vbCRLF & "Lw. C: mit 12GB, restliche GB ungenutzt (CD-Lw. wird D:)." & vbCRLF
Tst = " C:13 E:5 I:"
Tst = " C:12 E:15 J:"
Tst = " C:12 I:"
Tst = InputBox( Txt, "1576 :: " & Titel, Tst )
If Tst = "" Then
MsgBox "Ungültige Eingabe!" & vbCRLF & vbCRLF & "Abbruch der Partitionierung!", 4096 + vbInformation, "1578 :: " & Titel
Call WIMBuRRestore()
Exit Sub
End If
Tst = Trim( Tst ) : Tst = Replace( Tst, " ", " " ) : Tst = Replace( Tst, " ", " " ) : Tst = Replace( Tst, " ", " " )
Txt = "'Disk " & n & "' => " & SplitTxt( n ) & vbCRLF & vbCRLF
' Partitionierungs-Eingabe auswerten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SplitTst = Split( Tst, " ", -1, 1) : n = 0
For i = LBound( SplitTst ) To UBound( SplitTst )
' Txt = Txt & vbCRLF & i & " " & SplitTst( i )
Tst = UCase( SplitTst( i ) )
PartName = Left( Tst, 1 ) ' das erste Zeichen; muss Lw. Buchstabe sein
PartSize = Mid( Tst, 3 ) ' alles ab 3. Zeichen; muss Größe in GB sein
' If Len( PartSize ) > 0 Then PartSize = " size=" & PartSize * 1024
' MsgBox "PartSize: '" & PartSize & "'" & vbCRLF & "PartName: '" & PartName & "'", , "1597 :: "
If Len( PartSize ) > 0 Then Txt = Txt & "Lw. " & PartName & " wird auf " & PartSize & " GByte gesetzt." & vbCRLF
If Len( PartSize ) = 0 Then Txt = Txt & "Lw. " & PartName & " erhält den (restlichen) freien Platz der Disk." & vbCRLF
If i = 0 Then
FromatPart = FromatPart & "format " & PartName & ": /FS:NTFS /Y /Q /X /V:LW_" & PartName & vbCRLF
If Len( PartSize ) > 0 Then PartSize = " size=" & PartSize * 1024
DiskPartParm = DiskPartParm & "cre par pri" & PartSize & " noerr" & vbCRLF
DiskPartParm = DiskPartParm & "ass letter=" & PartName & " noerr" & vbCRLF
DiskPartParm = DiskPartParm & "act" & vbCRLF
End If
If i = 1 Then
DiskPartParm = DiskPartParm & "cre par ext noerr" & vbCRLF
End If
If i > 0 Then
FromatPart = FromatPart & "format " & PartName & ": /FS:NTFS /Y /Q /X /V:LW_" & PartName & vbCRLF
If Len( PartSize ) > 0 Then PartSize = " size=" & PartSize * 1024
DiskPartParm = DiskPartParm & "cre par log" & PartSize & " noerr" & vbCRLF
DiskPartParm = DiskPartParm & "ass letter=" & PartName & " noerr" & vbCRLF
End If
Next
' FromatPart = FromatPart & "@pause&&@pause" & vbCRLF
fso.OpenTextFile( FormatCMD, 2, true).WriteLine( FromatPart )
fso.OpenTextFile( DiskPartDatei, 2, true).WriteLine( DiskPartParm )
' Kontrollfrage
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = MsgBox( "Partitionierung starten?" & vbCRLF & vbCRLF & Txt, vbYesNo + vbQuestion, "1626 :: " & Titel )
If Tst = vbYes Then
Tst = MsgBox( "Partitionierung wirklich starten?" & vbCRLF & vbCRLF & "ALLE Daten gehen verloren!", vbYesNo + 4096 + vbCritical + vbDefaultButton2, "1628 :: " & Titel )
If not ProgrVerz = "MININT" Then Tst = vbNo
If not Tst = vbYes Then
MsgBox "Abbruch der Partitionierung!", 4096 + vbInformation, "1631 :: " & Titel
Call WIMBuRRestore()
Exit Sub
End If
fso.OpenTextFile( DiskPartDatei, 2, true).WriteLine( DiskPartParm )
' fso.OpenTextFile( "DISKPART.EXE /s """ & DiskPartDatei & """", 2, true).WriteLine( FromatPart )
' CreateObject("WScript.Shell").Run """" & "DISKPART.EXE /s """ & DiskPartDatei & """" & """", , False
Tst = ExecHiddenPlus( "DISKPART.EXE /s """ & DiskPartDatei & """" )
MsgBox Tst, , "1641 :: " & Titel
' fso.OpenTextFile( FormatCMD, 2, true).WriteLine( FromatPart )
CreateObject("WScript.Shell").Run """" & FormatCMD & """", , False
' Tst = ExecHiddenPlus( FormatCMD )
' MsgBox "Formatierung ist gestartet . . .", , "1646 :: " & Titel
Else
MsgBox "KEINE Partitionisreung!", vbInformation, "1648 :: " & Titel
End If
window.setTimeout "WIMBuRWIMInfoDaten()", 333
End Sub ' Partitionieren()
'*** v7.C *** www.dieseyer.de ******************************
Function ArrayZeigen( InArray )
'***********************************************************
' Durch die Prozedur
' ArrayZeigen( InArray )
' werden von einem Array nur die ersten
' und letzten Elemente angezeigt. Da die MsgBox nur 1024
' Zeichen anzeigen kann, ist die Anzahl der angezeigten
' Elemente von der Länge der einzelnen Elemente abhängig.
Dim TxtOben, TxtUnten, Tst, i, n, o, u
Dim Kopf ' für Tests
' Kopf = "LBound( InArray )=" & LBound( InArray ) & " UBound( InArray )=" & UBound( InArray ) & vbCRLF & vbCRLF & Kopf
' Kopf = "O=00000" & " U=00000" & " Len( TxtOben )=00000" & vbCRLF & Kopf
For i = LBound( InArray ) to UBound( InArray )
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n >= i Then
' TxtOben = TxtOben & "i = " & i & vbTab & "n = " & n & vbTab & Tst & vbTab & InArray( i ) & vbCRLF
TxtOben = TxtOben & i & vbTab & InArray( i ) & vbCRLF
o = i
End If
n = UBound( InArray ) - i
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( n ) )
Tst = Len( TxtOben ) + Len( TxtUnten ) + Len( InArray( i ) ) + Len( Kopf )
If Tst < 1000 AND n > i Then
' TxtUnten = "n = " & n & vbTab & "i = " & i & vbTab & Tst & vbTab & InArray( n ) & vbCRLF & TxtUnten
TxtUnten = n & vbTab & InArray( n ) & vbCRLF & TxtUnten
u = n
End If
If n <=i then Exit For
Next
Tst = ""
If o <> u AND o + 1 <> u Then Tst = "." & vbCRLF & "." & vbCRLF
Kopf = Replace( Kopf, "O=00000", "O=" & o )
Kopf = Replace( Kopf, "U=00000", "U=" & u )
Kopf = Replace( Kopf, ")=00000", ")=" & Len( Kopf & TxtOben & Tst & TxtUnten ) )
TxtOben = Kopf & TxtOben & Tst & TxtUnten
' LogEintrag "1701 :: " & vbCRLF & TxtOben
MsgBox TxtOben , , "1702 :: " & Titel
End Function ' ArrayZeigen( InArray )
'***********************************************************
Sub RestoreZiel( VerzeichnisOderWim )
'***********************************************************
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Trace32Log "1710 :: Anfang 'Sub RestoreZiel( " & VerzeichnisOderWim & " )'", 1
' MsgBox "VerzeichnisOderWim: '" & VerzeichnisOderWim & "'" , , "1711 :: "
VOW = VerzeichnisOderWim
If ProgrVerz = "MININT" Then ' bei WinPE
' Else
Trace32Log "1715 :: Aktuelles DatenZiel (für Restore): " & DatenZiel, 1
Trace32Log "1716 :: Verzeichnis-Auswahl (für Restore) wird gestartet . . . ", 1
' If VOW = "V" Then DatenZiel = BFFVerzAuswahl( "Verzeichnis für Restore auswählen:" )
If VOW = "W" Then DatenZiel = BFFAusWahlOCX( AktVerz, Left( fso.GetSpecialFolder( 0 ), 3 ), "wim" ) ' %windir%
If VOW = "V" Then DatenZiel = InputBox( "Bitte ein Laufwerk / Verzeichnis zur Datenwiederherstellung (Restore) eingeben:", "1719 :: " & Titel, "C:" ) : Trace32Log "1719 :: Neues DatenZiel (für Restore): '" & DatenZiel & "'", 1
Trace32Log "1720 :: Neues DatenZiel (für Restore): " & DatenZiel, 1
Else
Trace32Log "1722 :: Aktuelles DatenZiel (für Restore): " & DatenZiel, 1
Trace32Log "1723 :: Verzeichnis-Auswahl (für Restore) wird gestartet . . . ", 1
' ! If VOW = "V" Then DatenZiel = BFFVerzAuswahl( "Verzeichnis für Restore auswählen:" )
' If VOW = "W" Then DatenZiel = ChooseFile()
' ! If VOW = "W" Then DatenZiel = BFFAusWahlOCX( AktVerz, AktVerz, "wim" )
If VOW = "V" Then DatenZiel = BFFVerzAuswahl( "Verzeichnis für Restore auswählen:" ) : Trace32Log "1727 :: Neues DatenZiel (für Restore): '" & DatenZiel & "'", 1
If VOW = "W" Then DatenZiel = ChooseFile() : Trace32Log "1728 :: Neues DatenZiel (für Restore): '" & DatenZiel & "'", 1
Trace32Log "1729 :: Neues DatenZiel (für Restore): " & DatenZiel, 1
End If
Trace32Log "1732 :: Beendet 'Sub RestoreZiel()'", 1
Call WIMBuRRestore()
End Sub ' RestoreZiel( VerzeichnisOderWim )
'***********************************************************
Sub WIMBuRDelete()
'***********************************************************
Trace32Log "1739 :: Anfang 'Sub WIMBuRDelete()'", 1
MenueAkt = "DELETE"
document.all.MenuRahmen.innerHTML = BuRDeleteMenue & "<br> " & "1741 :: Die WIM-Informationen werden eingelesen. Bitte warten . . ."
window.setTimeout "WIMBuRWIMInfoDaten()", 333
Trace32Log "1743 :: Beendet 'Sub WIMBuRDelete()'", 1
End Sub ' WIMBuRDelete()
'***********************************************************
Sub WIMBuRWIMInfo()
'***********************************************************
Trace32Log "1749 :: Anfang 'Sub WIMBuRWIMInfo()'", 1
MenueAkt = "WIMINFO"
document.all.MenuRahmen.innerHTML = BuRWIMInfoMenue & "<br> " & "1751 :: Die WIM-Informationen werden eingelesen. Bitte warten . . ."
window.setTimeout "WIMBuRWIMInfoDaten()", 333
Trace32Log "1753 :: Beendet 'Sub WIMBuRWIMInfo()'", 1
End Sub ' WIMBuRWIMInfo
'***********************************************************
Sub ExportHTML()
'***********************************************************
' MsgBox "HTMLExport", , "1759 :: "
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim HtmDatei, errTst
HtmDatei = WIMGewaehlt & ".html"
On Error Resume Next
fso.OpenTextFile( HtmDatei, 2, True).WriteLine "Test"
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
If Len( errTst ) > 4 Then
HtmDatei = UserTempVerz & "\" & fso.GetFileName( WIMGewaehlt ) & ".html"
End If
' MsgBox HtmDatei, , "1772 :: "
XSLDateiSchreiben XSLDatei, "VBS"
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "1776 :: Datei geschrieben: " & XSLDatei, 1
XMLXSLalsHTML WIMGewaehlt, XSLDatei, XMLDatei, HtmDatei
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "1780 :: Datei geschrieben: " & HtmDatei, 1
On Error Resume Next
CreateObject("WScript.Shell").Run """" & HtmDatei & """", , False
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
If Len( errTst ) > 4 Then
CreateObject("WScript.Shell").Run "mshta.exe """ & HtmDatei & """", , False
End If
End Sub ' ExportHTML()
'***********************************************************
Function WIMBuRWIMInfoDaten()
'***********************************************************
Trace32Log "1796 :: Anfang 'Function WIMBuRWIMInfoDaten()'", 1
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst, MenueAnz, ExeDauer
If MenueAkt = "BURINFO" Then MenueAnz = BuRInfoMenue
If MenueAkt = "BACKUP" Then MenueAnz = BuRBackupMenue
If MenueAkt = "RESTORE" Then MenueAnz = BuRRestoreMenue
If MenueAkt = "DELETE" Then MenueAnz = BuRDeleteMenue
If MenueAkt = "WIMINFO" Then MenueAnz = BuRWIMInfoMenue
' Enthält WIMGewaehlt einen Dateinamen?
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "1809 :: Aktuell WIMGewaehlt (Dateiname): '" & WIMGewaehlt & "'", 1
Trace32Log "1810 :: Prüfen ob WIMGewaehlt gültig . . .", 1
Tst = WIMGewaehlt
If not InStr( Tst, "\\" ) = 1 AND not InStr( Tst, ":\" ) = 2 Then
' MsgBox WIMGewaehlt & vbCRLF & vbCRLF & ". . . es kann also kein WIM geprüft werden.", vbCritical, "1813 :: " & Titel
document.all.MenuRahmen.innerHTML = MenueAnz & "<br> " & "1814 :: " & WIMGewaehlt & "</b><br><br> . . . es kann also kein WIM geprüft werden."
Trace32Log "1815 :: Aktuell WIMGewaehlt (Dateiname) nicht verwendbar: '" & WIMGewaehlt & "'", 2
Exit Function
End if
' Ist WIMGewaehlt erreichbar?
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "1821 :: Prüfen ob WIMGewaehlt erreichbar . . .", 1
If fso.FileExists( WIMGewaehlt ) Then
Else
' MsgBox "Die Datei ist nicht verfügbar bzw. nicht erreichbar:" & vbCRLF & vbCRLF & WIMGewaehlt, vbCritical, "1824 :: " & Titel
document.all.MenuRahmen.innerHTML = MenueAnz & "<br> " & "1825 :: <b>Die Datei ist nicht verfügbar bzw. nicht erreichbar:</b><br><br> " & WIMGewaehlt
Trace32Log "1826 :: Aktuell WIMGewaehlt nicht erreichbar: " & WIMGewaehlt, 2
Exit Function
End If
Trace32Log "1829 :: Aktuell WIMGewaehlt (Dateiname) erreichbar: '" & WIMGewaehlt & "'", 1
If not ProgrOK Then
MsgBox "If not ProgrExeErreichbar( ProgrExe )", , "1832 :: "
Exit Function
End If
Tst = fso.GetFile( WIMGewaehlt ).DateLastModified
Trace32Log "1837 :: Aktuell WIMGewaehlt Dateidatum: " & Tst, 1
If WIMDateiDatum = Tst Then
Trace32Log "1839 :: Aktuell WIMGewaehlt ist NICHT neu(er), muss nicht neu getestet werden", 1
' MsgBox WIMDateiDatum & vbCRLF & Tst, , "1840 :: "
Else
' MsgBox "HTMLTxt wir aus XSL und XML neu aufgebaut . . . " & vbCRLF & WIMDateiDatum & vbCRLF & Tst, , "1842 :: " & Titel
Trace32Log "1843 :: Aktuell WIMGewaehlt ist neuer als das zuletzt getestete: " & WIMDateiDatum, 1
WIMDateiDatum = Tst
Trace32Log "1845 :: HTMLTxt wird neu erstellt . . . ", 1
HTMLTxt = WIMNeuTesten( WIMGewaehlt )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "1848 :: HTMLTxt ist neu: '" & HTMLTxt & "'", 1
End If
Trace32Log "1851 :: HTMLTxt wird komplettiert . . .", 1
Tst = "<span Style="" font-size: 3pt; ""><br></span>"
If DatenZiel = "" Then
Tst = Tst & "<input class=""InputSonst"" onClick=""RestoreZiel('V')"" type=""submit"" accesskey=""z"" value=""Ziel""> "
Tst = Tst & "Es ist kein <b>Ziel-Verzeichnis</b> für eine Datenwiederherstellung fest gelegt."
Else
Tst = Tst & "<input class=""InputSonst"" onClick=""RestoreZiel('V')"" type=""submit"" accesskey=""z"" value=""Ziel""> "
Tst = Tst & " """ & DatenZiel & """ "
End If
If GottModus Then Tst = Tst & "<br><input class=""InputExpert"" onClick=""RestoreZiel('W')"" type=""submit"" accesskey=""g"" value=""Ziel-WIM (g)"">"
' Tst = Tst & "<input class=""InputMini"" onClick=""RestoreZiel('W')"" type=""submit"" accesskey=""g"" value=""WIM als Ziel""> "
If GottModus Then Tst = Tst & "<br><input class=""InputExpert"" onClick=""Partitionieren"" type=""submit"" accesskey=""p"" value=""Disk-Partitionieren (p)"">"
' Tst = Tst & "<input class=""InputMini"" onClick=""Partitionieren"" type=""submit"" accesskey=""p"" value=""Disk-Partitionieren""> "
' Tst = Tst & "Es ist kein <b>Ziel-WIM</b> für eine Datenwiederherstellung fest gelegt."
Tst = Tst & "<br><br> <b> Mit der Auswahl eines Button wird das im WIM enthaltenen Image in den Zielpfad kopiert.</b><br><br>"
Txt = "<span Style="" font-size: 3pt; ""><br></span>"
Txt = Txt & "<input class=""InputSonst"" onClick=""ExportHTML()"" type=""submit"" accesskey=""e"" value=""Export""> "
Txt = Txt & "der Anzeige als HTML-Datei.<br>"
Txt = Txt & "<br><b> Mit der Auswahl eines Button werden Infos zu dem im WIM enthaltenen Image angezeigt.</b><br><br>"
If MenueAkt = "BURINFO" Then MenueAnz = BuRInfoMenue
If MenueAkt = "BACKUP" Then MenueAnz = BuRBackupMenue
If MenueAkt = "RESTORE" Then MenueAnz = BuRRestoreMenue & Tst
If MenueAkt = "DELETE" Then MenueAnz = BuRDeleteMenue & "<br><b> Mit dem Klick auf einen Button werden <u>nur die Verweise auf die Dateien</u> des Images im<br> WIM gelöscht, nicht jedoch die Datei(en) selbst - das WIM wird also nicht kleiner!</b><br><br>"
If MenueAkt = "WIMINFO" Then MenueAnz = BuRWIMInfoMenue & Txt
Trace32Log "1878 :: HTMLTxt ist komplett und wird angezeigt . . .", 1
document.all.MenuRahmen.innerHTML = MenueAnz & HTMLTxt
Trace32Log "1881 :: Beendet 'Function WIMBuRWIMInfoDaten()'", 1
End Function ' WIMBuRWIMInfoDaten()
'***********************************************************
Function WIMNeuTesten( WINDatei )
'***********************************************************
Trace32Log "1889 :: Anfang 'Function WIMNeuTesten( WINDatei )'", 1
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim CmdBef, ExeDauer, Txt, Tst, Tyt, errTst
Dim CMDDatei : CMDDatei = CMDPfad & "_WIMTest.cmd"
Trace32Log "1896 :: Gebildete CMDDatei-Name: " & CMDDatei, 1
' Befehlszeile bilden
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CmdBef = """" & ProgrExe & """ /XML /INFO """ & WINDatei & """>""" & XMLDatei & """"
If InStr( UCase( ProgrPara), "/CHECK" ) > 0 Then
CmdBef = """" & ProgrExe & """ /XML /CHECK /INFO """ & WINDatei & """>""" & XMLDatei & """"
End If
Trace32Log "1905 :: Gebildete CmdBef (ImageX-Befehlszeile): " & CmdBef, 1
Tst = ""
If ProgrVerz = "MININT" AND fso.FolderExists( "X:\" ) Then
' bei WinPE als winpe.wim im RAM; %systemdrive%=X:
' es gibt keine Geschwindigkeitsvorteile!
Tyt = "X:\" & fso.GetTempName()
On Error Resume Next
fso.OpenTextFile( Tyt, 2, True).WriteLine Now()
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
If Len( errTst ) < 5 Then Tst = " /TEMP X:" : fso.DeleteFile Tyt, True
End If
If ProgrVerz = "MININT" AND fso.FolderExists( "R:\" ) Then
' bei WinPE und %systemdrive%=X: und mit 'seperater' RAM-Disk R:
Tyt = "R:\" & fso.GetTempName()
On Error Resume Next
fso.OpenTextFile( Tyt, 2, True).WriteLine Now()
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
If Len( errTst ) < 5 Then Tst = " /TEMP R:" : fso.DeleteFile Tyt, True
End If
CmdBef = Replace( CmdBef, " /INFO ", Tst & " /INFO " )
Trace32Log "1930 :: Gebildete CmdBef (ImageX-Befehlszeile): " & CmdBef, 1
' CMD-Zeilen in CMD-Datei schreiben und starten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "1935 :: Datei soll geschrieben werden: " & CMDDatei, 1
CreateObject("Scripting.FileSystemObject").OpenTextFile( CMDDatei, 2, True).WriteLine CmdBef
Trace32Log "1937 :: Datei ist geschrieben: " & CMDDatei, 1
Trace32Log "1938 :: CMDDatei (ImageX-Befehlszeile) wird gestartet . . . ", 1
ExeDauer = Timer()
Tst = WSHShell.Run( """" & CMDDatei & """", 0, True )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' If ZeitTest = "Ja" Then MsgBox "WIM testen - ExeDauer: " & ( Timer() - ExeDauer ) & "s", , "1944 :: " & Titel
Trace32Log "1945 :: CMDDatei (ImageX-Befehlszeile) ist beendet.", 1
Trace32Log "1948 :: Datei soll erstellt werden: " & XSLDatei, 1
Trace32Log "1949 :: 'Call XSLDateiSchreiben( XSLDatei, ""HTA"" )' starten . . . ", 1
Call XSLDateiSchreiben( XSLDatei, "HTA" )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "1952 :: 'Call XSLDateiSchreiben( XSLDatei, ""HTA"" )' ist beendet.", 1
Trace32Log "1955 :: HTML-Daten erzeugen: " & XSLDatei, 1
Trace32Log "1956 :: 'XMLXSLalsHTML( WINDatei, XSLDatei, XMLDatei, HTMDatei )' starten (HTML-Daten erzeugen) . . . ", 1
WIMNeuTesten = XMLXSLalsHTML( WINDatei, XSLDatei, XMLDatei, "" )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "1959 :: 'XMLXSLalsHTML( WINDatei, XSLDatei, XMLDatei, HTMDatei )' ist beendet.", 1
Trace32Log "1962 :: Beendet 'Function WIMNeuTesten( WINDatei )'", 1
End Function ' WIMNeuTesten( WINDatei )
'*** v6.B *** www.dieseyer.de ******************************
Function ChooseFile()
'***********************************************************
' aus http://groups.google.de/group/microsoft.public.scripting.vbscript/browse_thread/thread/f00a1c5d856c731f/c1d22782d2816bff?lnk=st&q=Joseph+Morales+Here%27s+the+code+with+the+additions+to+make+things&rnum=1#c1d22782d2816bff
Dim IE : Set IE = CreateObject("InternetExplorer.Application")
ChooseFile = ""
IE.visible = False
IE.Navigate("about:blank")
Do Until IE.ReadyState = 4
' WScript.Sleep 33
Loop
IE.TheaterMode = False
IE.Document.Write "<HTML><BODY><INPUT ID=""Fil""Type=""file""></BODY></HTML>"
IE.height = "0"
IE.width = "0"
IE.visible = True
IE.visible = False
With IE.Document.all.Fil
.focus
.click
ChooseFile = .value
End With
IE.Quit
Set IE = Nothing
End Function 'ChooseFile()
'*** v10.B *** www.dieseyer.de *****************************
Function LinkErstellen( Zielverz, Beschr, Datei )
'***********************************************************
Dim Txt, Tst
Dim fso : Set fso = CreateObject( "Scripting.FileSystemObject" )
Dim WshShell : Set WshShell = CreateObject( "WScript.Shell" )
Tst = CreateObject("Scripting.FileSystemObject").GetSpecialFolder( 1 ) ' C:\Windows\System32
Dim ZielArg, ZielLink, IconPfad
Dim ZielAnw : ZielAnw = Datei
Txt = fso.GetExtensionName( UCase( Datei ) )
If Txt = "HTA" Then ZielAnw = Tst & "\mshta.exe" : ZielArg = """" & Datei & """"
If Txt = "VBS" Then ZielAnw = Tst & "\wscript.exe" : ZielArg = """" & Datei & """"
If Txt = "VBE" Then ZielAnw = Tst & "\wscript.exe" : ZielArg = """" & Datei & """"
If Txt = "CMD" Then ZielAnw = "%comspec%" : ZielArg = "/c """ & Datei & """"
If Txt = "BAT" Then ZielAnw = "%comspec%" : ZielArg = "/c """ & Datei & """"
Tst = Mid( Datei, 1, InStrRev( Datei, "." ) ) & "ico"
If fso.FileExists( Tst ) Then IconPfad = Tst
ZielLink = Zielverz & "\" & fso.GetBaseName( Datei ) & ".lnk" ' : MsgBox ZielLink, , "2016 :: "
' MsgBox "IconPfad: '" & IconPfad & "'" & vbCRLF & "Datei: '" & Datei & "'" & vbCRLF & "Zielverz: '" & Zielverz & "'" & vbCRLF & "ZielAnw: '" & ZielAnw & "'" & vbCRLF & "ZielArg: '" & ZielArg & "'" & vbCRLF & "ZielLink: '" & ZielLink & "'", 4096, "2018 :: "
Dim oShellLink : Set oShellLink = WshShell.CreateShortcut( ZielLink )
oShellLink.TargetPath = ZielAnw
oShellLink.Arguments = ZielArg
' oShellLink.WindowStyle = 1
' oShellLink.Hotkey = "CTRL+SHIFT+F"
If not IconPfad = "" Then
oShellLink.IconLocation = IconPfad
End If
oShellLink.Description = Beschr
' oShellLink.WorkingDirectory = Zielverz
oShellLink.WorkingDirectory = "%TEMP%"
On Error Resume Next
err.Clear
oShellLink.Save()
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then
LinkErstellen = "Fehler: " & Tst
Tst = "Verknüpfung (Link, ShortCut) konnte nicht erstellt werden:" & vbCRLF & vbCRLF & Tst
' Tst = Tst & vbCRLF & vbCRLF & Zielverz & "\" & fso.GetBaseName( Datei ) & ".lnk"
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "Soll statt dessen eine Verknüpfung auf dem Desktopt erstellt werden?"
Tst = Replace( Tst, ":\\", ":\")
Tst = MsgBox( Tst, 4096 + vbCritical + vbYesNo, "2044 :: " & Titel )
If Tst = vbNo Then Exit Function
' CreateObject("Shell.Application").Namespace( 0 ).Self.Path => Desktop des aktuellen Users
Tst = LinkErstellen( CreateObject("Shell.Application").Namespace( 0 ).Self.Path, Beschr, Datei )
LinkErstellen = Tst
Exit Function
End If
LinkErstellen = ""
End Function ' LinkErstellen( Zielverz, Beschr, Datei )
'*** v10.8 *** www.dieseyer.de *****************************
Function BFFAusWahlOCX( AktVerz, StartVerz, DateiType )
'***********************************************************
' http://www.access-paradies.de/tipps/dateiauswahldialog.php
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Const OCXDatei = "comdlg32.ocx"
Const OCXDownLoad = "http://activex.microsoft.com/controls/vb5/comdlg32.cab"
Dim OCXPfad, Tst, errTst
OCXPfad = AktVerz & "\" & OCXDatei
On Error Resume Next
Tst = CreateObject("MSComDlg.CommonDialog")
errTst = err.Number & " - " & err.Description
On Error Goto 0
' MsgBox Tst & vbCRLF & errTst , , "2069 :: "
' If Len( errTst ) > 4 Then ' Nicht verfügbar: "MSComDlg.CommonDialog"
' OCXDatei registrieren
Trace32Log "2072 :: '" & errTst & "' / '" & Tst & "' nach CreateObject(""MSComDlg.CommonDialog"")", 1
If Left( errTst, 6 ) = "429 - " Then ' Nicht verfügbar: "MSComDlg.CommonDialog"
' MsgBox OCXPfad & vbCRLF & Tst & vbCRLF & errTst , , "2075 :: "
On Error Resume Next
Tst = CreateObject("Wscript.Shell").Run( "regsvr32.exe /s " & OCXPfad, 1, true )
errTst = err.Number & " - " & err.Description
On Error Goto 0
' MsgBox "VarType( " & Tst & " ) = " & VarType( Tst ) & " RC: '" & Tst & "'", , "2080 :: "
If Tst = 3 Then
Tst = "Fehler: '" & OCXPfad & "' nicht erreichbar!"
BFFAusWahlOCX = Tst
Trace32Log "2084 :: " & Tst, 3
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "Diese Datei muss im '" & AktVerz & "'-Verzeichnise liegen!"
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "Soll der entspr. DownLoad von '" & OCXDownLoad & "' gestartet werden?"
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "[Abbrechen] beendet '" & HTASelbst & "'."
Tst = MsgBox( Tst, 4096 + vbCritical + vbYesNoCancel, "2091 :: " & Titel )
If Tst = vbCancel Then self.close : BFFAusWahlOCX = "EXIT"
If Tst = vbYes Then CreateObject("Wscript.Shell").Run OCXDownLoad, , False
BFFAusWahlOCX = "EXIT"
Exit Function
End If
End If
If not Left( errTst, 6 ) = "394 - " Then ' bereits erledigt - kann nicht wiederholt werden: CreateObject("MSComDlg.CommonDialog")
On Error Resume Next
Tst = CreateObject("Wscript.Shell").Run( "regsvr32.exe /s " & OCXPfad, 1, true )
errTst = err.Number & " - " & err.Description
On Error Goto 0
Trace32Log "2104 :: '" & errTst & "' / '" & Tst & "' nach regsvr32.exe /s " & OCXPfad, 1
If Tst = 5 Then
Tst = "Fehler: '" & OCXDatei & "' kann nicht registriert werden."
Tst = "Fehler: '" & OCXPfad & "' kann nicht registriert werden."
BFFAusWahlOCX = Tst
Trace32Log "2109 :: " & Tst, 3
Trace32Log "2110 :: LinkErstellen( " & AktVerz & ", " & document.title & ", " & HTASelbst & " )", 1
Call LinkErstellen( AktVerz, document.title, HTASelbst )
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "Diese Datei muss im 'Administrator'-Kontext registriert werden - dafür "
Tst = Tst & "wurde im selben Verzeichnis, in der sich """ & HTASelbst & """ "
Tst = Tst & "befindet, eine Verknüpfung (Link, ShortCut) mit dem selben Namen angelegt. "
Tst = Tst & "Klickt man mit der rechten Maus-Taste auf diesen Link, "
Tst = Tst & "kann 'Als Administrator ausführen' (Run as Administrator) ausgewählt werden - "
Tst = Tst & "so sollte die Registrierung der " & OCXDatei & " gelingen."
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "Soll '" & HTASelbst & "' beendet werden?"
Tst = MsgBox( Tst, 4096 + vbCritical + vbYesNo, "2121 :: " & Titel )
If Tst = vbYes Then self.close : BFFAusWahlOCX = "EXIT"
Exit Function
End If
' MsgBox Tst & vbCRLF & errTst , , "2126 :: "
If not( errTst = "0 - " ) And (Len( errTst ) > 4 OR Tst = 3 ) Then
Tst = "Fehler: '" & OCXPfad & "' nicht erreichbar - " & errTst & " (" & Tst & ")"
BFFAusWahlOCX = Tst
Trace32Log "2130 :: " & Tst, 3
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "Diese Datei muss im '" & AktVerz & "'-Verzeichnise liegen!"
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "Soll '" & HTASelbst & "' beendet werden?"
Tst = MsgBox( Tst, 4096 + vbCritical + vbYesNo, "2135 :: " & Titel )
If Tst = vbYes Then self.close : BFFAusWahlOCX = "EXIT"
Exit Function
End If
On Error Resume Next
Tst = CreateObject("WScript.Shell").RegWrite( "HKCR\Licenses\4D553650-6ABE-11cf-8ADB-00AA00C00905\", "gfjmrfkfifkmkfffrlmmgmhmnlulkmfmqkqj", "REG_SZ" )
errTst = err.Number & " - " & err.Description
On Error Goto 0
' MsgBox Tst & vbCRLF & errTst , , "2144 :: "
Trace32Log "2145 :: '" & errTst & "' / '" & Tst & "' nach CreateObject(""WScript.Shell"").RegWrite ""HKCR\Licenses\...""", 1
If Len( errTst ) > 4 Then ' Nicht 'beschreibbar': HKCR\Licenses\...
Trace32Log "2147 :: LinkErstellen( " & AktVerz & ", " & document.title & ", " & HTASelbst & " )", 1
Call LinkErstellen( AktVerz, document.title, HTASelbst )
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "'" & HTASelbst & "' muss im 'Administrator'-Kontext gestartet werden - dafür "
Tst = Tst & "wurde im selben Verzeichnis, in der sich """ & HTASelbst & """ "
Tst = Tst & "befindet, eine Verknüpfung (Link, ShortCut) mit dem selben Namen angelegt. "
Tst = Tst & "Klickt man mit der rechten Maus-Taste auf diesen Link, "
Tst = Tst & "kann 'Als Administrator ausführen' (Run as Administrator) ausgewählt werden - "
Tst = Tst & "so sollte die Registrierung der " & OCXDatei & " gelingen."
Tst = Tst & vbCRLF & vbCRLF
Tst = Tst & "Soll '" & HTASelbst & "' beendet werden?"
Tst = MsgBox( Tst, 4096 + vbCritical + vbYesNo, "2158 :: " & Titel )
If Tst = vbYes Then self.close : BFFAusWahlOCX = "EXIT"
Exit Function
End If
End If
Tst = CreateObject("WScript.Shell").ExpandEnvironmentStrings( "%ALLUSERSPROFILE%" ) ' : MsgBox Tst, , "2164 :: "
If fso.FolderExists( "R:\" ) Then Tst = "R:\Documents and Settings" ' : MsgBox Tst, , "2166 :: "
If not fso.FolderExists( Tst ) Then fso.CreateFolder Tst ' : MsgBox "Erstellt: " & Tst, , "2167 :: "
Tst = Tst & "\Default User" ' : MsgBox Tst, , "2169 :: "
If not fso.FolderExists( Tst ) Then fso.CreateFolder Tst ' : MsgBox "Erstellt: " & Tst, , "2170 :: "
' MsgBox Tst, , "2172 :: "
If fso.FolderExists( Tst ) Then
Tst = Tst & "\Desktop"
If not fso.FolderExists( Tst ) Then fso.CreateFolder Tst : Trace32Log "2175 :: Erstellt: " & Tst, 1 ' : MsgBox "Erstellt: " & vbCRLF & vbCRLF & Tst, , "2175 :: "
End If
If not Right( StartVerz, 1 ) = "\" Then StartVerz = StartVerz & "\"
' MsgBox "'" & StartVerz & "'", , "2179 :: "
DateiType = LCase( DateiType )
Dim objDialog : Set objDialog = CreateObject("MSComDlg.CommonDialog")
' objDialog.Filter = "Alle Dateien (*.*)*.*"
' objDialog.Filter = "ImageX-Dateien (*.wim)|*.wim|Alle Dateien (*.*)|*.*"
' objDialog.Filter = "ImageX-Dateien (*.wim)|*.wim"
objDialog.Filter = UCase( DateiType ) & "-Dateien (*." & DateiType & ")|*." & DateiType
' objDialog.Filter = "Textdateien (*.txt)|*.txt"
objDialog.DialogTitle = "2189 :: " & UCase( DateiType ) & " auswählen . . . "
objDialog.InitDir = StartVerz
objDialog.MaxFileSize = 256
' objDialog.Flags = &H4 + &H400
objDialog.Flags = &H80000 OR &H4 OR &H2000 ' + &H800 + &H8
' objDialog.Flags = &H2000 ' + &H800 + &H8
' objDialog.FilterIndex = 1
' cdlOFNAllowMultiselect &H200 Ermöglicht, dass im Listenfeld Dateiname mehrere Dateien ausgewählt werden.
' Die FileName-Eigenschaft gibt einen String zurück, der alle ausgewählten
' Dateinamen enthält (die Namen sind im String durch Leerzeichen voneinander getrennt).
' cdlOFNCreatePrompt &H2000 Fragt den Benutzer, ob eine Datei angelegt werden soll, die noch nicht existiert.
' Dieses Flag setzt automatisch die Flags cdlOFNPathMustExist und cdlOFNFileMustExist.
' cdlOFNExplorer &H80000 Verwendet das dem Explorer ähnliche Dialogfeld zum Öffnen von Dateien.
' cdlOFNExtensionDifferent &H400 Weist darauf hin, dass sich die Dateinamenerweiterung des zurückgegebenen Dateinamens
' von der in der DefaultExt-Eigenschaft angegebenen Erweiterung unterscheidet. Dieses
' Flag wird nicht gesetzt, wenn die DefaultExt-Eigenschaft Null enthält, wenn die
' Erweiterungen übereinstimmen, oder wenn die Datei keine Erweiterung hat. Man kann
' den Wert dieses Flags überprüfen, nachdem das Dialogfeld geschlossen wurde.
' cdlOFNFileMustExist &H1000 Die Benutzer dürfen nur Dateinamen eingeben, die existieren. Wenn dieses Flag gesetzt
' ist und der Benutzer gibt einen ungültigen Dateinamen ein, wird eine Warnung angezeigt.
' Dieses Flag setzt automatisch das Flag cdlOFNPathMustExist.
' cdlOFNHelpButton &H10 Zeigt die Hilfe-Schaltfläche für das Dialogfeld an.
' cdlOFNHideReadOnly &H4 Verbirgt das Kontrollkästchen Mit Schreibschutz öffnen.
' cdlOFNLongNames &H200000 Erlaubt lange Dateinamen.
' cdlOFNNoChangeDir &H8 Zwingt das Dialogfeld, das aktuelle Verzeichnis so zu setzen, wie es beim Öffnen des
' Dialogfelds gesetzt war.
' cdlOFNNoDereferenceLinks &H100000 Verbietet die Dereferenzierung von Shell-Links (auch als Shortcuts bezeichnet). Standardmäßig
' bewirkt die Auswahl eines Shell-Links, dass dieser von der Shell dereferenziert wird.
' cdlOFNNoLongNames &H40000 Verbietet lange Dateinamen.
' cdlOFNNoReadOnlyReturn &H8000 Spezifiziert, dass die zurückgegebene Datei das Attribut Read-Only nicht gesetzt hat und
' sich nicht in einem schreibgeschützten Verzeichnis befindet.
' cdlOFNNoValidate &H100 Erlaubt ungültige Zeichen im zurückgegebenen Dateinamen.
' cdlOFNOverwritePrompt &H2 Bewirkt, dass das Dialogfeld Speichern unter eine Warnung erzeugt, wenn der angegebene
' Dateiname bereits existiert. (Die Benutzer können dann wählen, ob die Datei überschrieben
' werden soll.)
' cdlOFNPathMustExist &H800 Die Benutzer dürfen nur gültige Pfade eingeben. Wenn dieses Flag gesetzt ist und die Benutzer
' einen ungültigen Pfad eingeben, erscheint eine Warnung.
' cdlOFNReadOnly &H1 Markiert das Kontrollkästchen Mit Schreibschutz öffnen, wenn das Dialogfeld erzeugt wird.
' Dieses Flag gibt außerdem den Status des Kontrollkästchens Mit Schreibschutz öffnen nach dem
' Schließen des Dialogfelds an.
' cdlOFNShareAware &H4000 Zeigt an, dass mögliche Freigabe-Fehler ignoriert werden.
objDialog.ShowOpen()
' intResult = objDialog.ShowOpen()
BFFAusWahlOCX = objDialog.Filename
Set objDialog = nothing
End Function ' BFFAusWahlOCX( AktVerz, StartVerz, DateiType )
'*** v10.8 *** www.dieseyer.de *****************************
Function BFFVerzDateitype( Verz, DateiType )
'***********************************************************
' aus http://www.source-center.de/forum/showthread.php?t=25743
' http://www.coding-board.de/board/showthread.php?t=19261
' Set oFolder = oFSO.GetFolder("C:\")
' Exit Function
Dim Tst, Dialog
' neu in v10.8
On Error Resume Next
err.Clear
Set Dialog = CreateObject("UserAccounts.CommonDialog")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then
BFFVerzDateitype = BFFAusWahlOCX( AktVerz, Verz, DateiType )
Exit Function
End If
' objDialog.Filter = "ImageX-Dateien (*.wim)|*.wim|Alle Dateien (*.*)|*.*"
Dialog.Filter = """" & UCase( DateiType ) & """ Dateien|*." & DateiType & "|All Files|*.*" ' zeigt nur *.txt
Dialog.FilterIndex = 1
Dialog.InitialDir = Verz
Dialog.Flags = &H4 ' HIDEREADONLY
Dialog.ShowOpen
BFFVerzDateitype = Dialog.FileName
End Function ' BFFVerzDateitype( Verz, DateiType )
'*** v10.B *** www.dieseyer.de ******************************
Function BFFVerzAuswahl( Frage )
'***********************************************************
' u.a. http://blogs.msdn.com/gstemp/archive/2004/02/17/74868.aspx
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim AppShell : Set AppShell = CreateObject("Shell.Application")
Dim objFolder : Set objFolder = AppShell.BrowseForFolder( 0, Frage, &H0010 + &H0020 + &H0001 )
Dim Tst
On Error Resume Next
BFFVerzAuswahl = objFolder.ParentFolder.ParseName( objFolder.Title ).Path
Tst = err.number
' MsgBox objFolder.Title & vbCRLF & Tst, , "2282 :: "
If Tst = 424 then
BFFVerzAuswahl = WSHShell.SpecialFolders( objFolder.Title )
End If
'On Error Goto 0
If InStr( objFolder.Title, ":" ) > 0 Then
BFFVerzAuswahl = Mid( objFolder.Title, InStr( objFolder.Title, ":" ) - 1, 2) ' & "\"
End If
If UCase( objFolder.Title ) = UCase( CreateObject("WScript.Network").Username ) Then
BFFVerzAuswahl = AppShell.Namespace( 40 ).Self.Path
End If
' MsgBox AppShell.Namespace( 40 ).Self.Path, , "2294 :: "
If InStr( objFolder.Title, "Eigene Dateien" ) > 0 Then
BFFVerzAuswahl = AppShell.Namespace( 5 ).Self.Path
End If
' MsgBox BFFVerzAuswahl, , "2300 :: "
End Function ' BFFVerzAuswahl( Frage )
'*** v10.3 *** www.dieseyer.de *****************************
Function RemoteSystemDrive( PCName )
'***********************************************************
' http://msdn2.microsoft.com/en-us/library/aa394596(vs.85).aspx
' ermittelt %SystemDrive%; häufig C:
Dim objWMIService, colOperatingSystems, objOperatingSystem, Tst
On Error Resume Next
err.Clear
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PCName & "\root\cimv2")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteSystemDrive = "Fehler: WMI SysLw " & Tst : Exit Function
On Error Resume Next
err.Clear
Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteSystemDrive = "Fehler: WMI SysLwOS " & Tst : Exit Function
On Error Resume Next
err.Clear
For Each objOperatingSystem in colOperatingSystems
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteSystemDrive = "Fehler: WMI SysLwDr " & Tst : Exit Function
RemoteSystemDrive = objOperatingSystem.SystemDrive
Next
Set colOperatingSystems = nothing
Set objWMIService = nothing
' RemoteSystemDrive = "%systemdrive%: " & RemoteSystemDrive
End Function ' RemoteSystemDrive( PCName )
'***********************************************************
Function XMLXSLalsHTML( Titel, DateiXSL, DateiXML, DateiHTM )
'***********************************************************
Dim Txt
Txt = Txt & vbCRLF & "Titel: " & vbTab & vbTab & Titel
Txt = Txt & vbCRLF & "DateiXSL: " & vbTab & DateiXSL
Txt = Txt & vbCRLF & "DateiXML: " & vbTab & DateiXML
Txt = Txt & vbCRLF & "DateiHTM: " & vbTab & "'" & DateiHTM & "'"
' MsgBox Txt, , "2347 :: "
Txt = ""
Txt = Txt & vbCRLF & "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.01 Transitional//EN"">"
Txt = Txt & vbCRLF & "<html><head>"
Txt = Txt & vbCRLF & "</head><body style="" font-size:9Pt; font-weight:normal; font-family:verdana,arial,sans-serif"">"
Txt = Txt & vbCRLF & "<title>" & Mid( Titel, InStrRev( Titel, "\" ) + 1 ) & "</title>"
' es soll _eine_ HTML-Datei geschrieben werden
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If not DateiHTM = "" Then
' Txt = Txt & vbCRLF & "<h2> " & Titel & "</h2>"
Txt = Txt & vbCRLF & "<span style="" font-size:12Pt; font-weight:bold;"" > " & Titel & "</span><br><br>"
End If
Txt = Txt & vbCRLF & " Die letzte Änderung (an) der Datei """ & Mid( Titel, InStrRev( Titel, "\" ) + 1 ) & """ "
Txt = Txt & vbCRLF & " erfolgte am " & CreateObject("Scripting.FileSystemObject").GetFile( Titel ).DateLastModified & ".<br>"
Dim xslDoc
Set xslDoc = CreateObject("Microsoft.XMLDOM")
xslDoc.async = false
xslDoc.load( DateiXSL )
Dim xmlDoc
Set xmlDoc=CreateObject("Microsoft.XMLDOM")
xmlDoc.async=false
xmlDoc.load( DateiXML )
Txt = Txt & vbCRLF & xmlDoc.transformNode(xslDoc)
Set xmlDoc = nothing
Set xslDoc = nothing
Txt = Txt & vbCRLF & "</body></html>"
' es soll _keine_ HTML-Datei geschrieben werden
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If DateiHTM = "" Then
XMLXSLalsHTML = Txt ' HTML-Code wird übergeben
Exit Function
End If
' HTML-Code vervollständigen für HTML-Datei
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = Txt & vbCRLF & "<br><br><span style="" font-size:7Pt; "">"
' Txt = Txt & vbCRLF & "<a href=""http://dieseyer.de"" ><b>" & WScript.ScriptName & "</b> • © 2010 by dieseyer • all rights reserved • <b>www.dieseyer.de</b></a>"
Txt = Txt & vbCRLF & "<a href=""http://dieseyer.de/scr/wim-inhalt.vbs"" ><b>wim-inhalt.vbs</b></a>"
Txt = Txt & vbCRLF & "<a href=""http://dieseyer.de/dse-impressum.html"" > • © 2010 by dieseyer • all rights reserved • </a>"
Txt = Txt & vbCRLF & "<a href=""http://dieseyer.de"" ><b><b>www.dieseyer.de</b></b></a>"
Txt = Txt & vbCRLF & "</span>"
Txt = Txt & vbCRLF & "</body></html>"
' HTML-Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CreateObject("Scripting.FileSystemObject").OpenTextFile( DateiHTM, 2, True).Write Txt
End Function ' XMLXSLalsHTML( DateiXSL, DateiXML, DateiHTM )
'***********************************************************
Sub SubStart( Nr )
'***********************************************************
Trace32Log "2406 :: Anfang 'SubStart( " & Nr & " )'", 1
' MsgBox "Nr: " & vbTab & vbTab & Nr & vbCRLF & "MenueAkt: " & vbTab & MenueAkt, , "2407 :: " & Titel
' If MenueAkt = "BURINFO" Then Call SubBuRInfo( Nr )
' If MenueAkt = "BACKUP" Then Call SubBackup( Nr )
' If MenueAkt = "RESTORE" Then document.all.MenuRahmen.innerHTML = BuRRestoreMenue & "<br> " & "2413 :: Wiederherstellung der Daten aus dem <b>Image " & Nr & "</b> wird vorbereitet . . ."
If MenueAkt = "RESTORE" Then window.setTimeout "SubRestore( '" & Nr & "' )", 333
If MenueAkt = "DELETE" Then document.all.MenuRahmen.innerHTML = BuRDeleteMenue & "<br> " & "2416 :: Das Löschen des <b>Image " & Nr & "</b> im WIM wird vorbereitet . . . <br><br><br>" & HTMLTxt
If MenueAkt = "DELETE" Then window.setTimeout "SubDelete( '" & Nr & "' )", 333
If MenueAkt = "WIMINFO" Then document.all.MenuRahmen.innerHTML = BuRWIMInfoMenue & "<br> " & "2419 :: Die Dateiliste (DIR) des <b>Image " & Nr & "</b> im WIM wird erstellt . . .<br><br>" & HTMLTxt
If MenueAkt = "WIMINFO" Then window.setTimeout "SubWIMInfo( '" & Nr & "' )", 333
Trace32Log "2422 :: Beendet 'SubStart( Nr )'", 1
End Sub ' SubStart( Nr )
'***********************************************************
Sub SubRestore( Nr )
'***********************************************************
Trace32Log "2429 :: Anfang 'SubRestore( " & Nr & " )'", 1
' MsgBox "SubRestore( " & Nr & " )", , "2430 :: " & Titel
Dim T, Tst
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Tst = "'VOW' - Inhalt: alt '" & VOW & "'"
If VOW = "" AND fso.FolderExists( DatenZiel ) Then VOW = "V"
If VOW = "" AND fso.FileExists( DatenZiel ) Then VOW = "W"
Tst = Tst & " - neu '" & VOW & "'"
' MsgBox "DatenZiel: " & vbTab & DatenZiel & vbCRLF & vbCRLF & Tst, , "2439 :: "
Trace32Log "2441 :: " & Tst, 1
Trace32Log "2443 :: Aktuelles DatenZiel für Restore: '" & DatenZiel & "'", 1
' DatenZiel Prüfen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Tst = fso.GetExtensionName( LCase( DatenZiel ) ) : Trace32Log "2449 :: Neues DatenZiel (für Restore) Erweiterung: '" & Tst & "'", 1
' If not fso.FolderExists( DatenZiel ) AND Tst = "wim" Then
' Trace32Log "2451 :: Neues DatenZiel (für Restore) erstellt: '" & DatenZiel & "'", 1
' If not fso.FileExists( DatenZiel ) Then
' fso.OpenTextFile( DatenZiel, 2, True).WriteLine "Wird ggf. von WIM-BuR.hta gelöscht"
' Trace32Log "2454 :: Neues DatenZiel (für Restore) erstellt: '" & DatenZiel & "'", 1
' Else
' Trace32Log "2456 :: Neues DatenZiel (für Restore) erstellt: '" & DatenZiel & "'", 1
' End If
' End If
'
Tst = fso.GetExtensionName( LCase( DatenZiel ) ) : Trace32Log "2460 :: Neues DatenZiel (für Restore) Erweiterung: '" & Tst & "'", 1
If fso.FolderExists( DatenZiel ) OR Tst = "wim" Then
Trace32Log "2462 :: DatenZiel (für Restore) wird 'akzepitert': '" & DatenZiel & "'", 1
Else
Trace32Log "2464 :: Aktuelles DatenZiel für Restore ist ungültig: '" & DatenZiel & "'", 2
MsgBox "Es wurde kein (gültiges) Ziel für eine Datenwiederherstellung ausgewählt.", vbInformation, "2465 :: " & Titel
Trace32Log "2466 :: Restore (Versuch) wird abgebrochen.", 1
' Call RestoreZiel( )
Exit Sub
End If
' ZielLw. formatieren?
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If Len( DatenZiel ) = 2 AND InStr( DatenZiel, ":" ) = 2 Then
Tst = MsgBox( "Soll " & DatenZiel & " noch 'schnell' (NTFS) formatiert werden?", vbQuestion + vbOKCancel, "2475 :: " & Titel )
If Tst = vbOK Then
Tst = "format " & DatenZiel & " /Y /V:" & Titel & " /Q /FS:NTFS"
InputBox Tst, Tst, Tst
Tst = CreateObject("Wscript.Shell").Run( Tst, 1, true )
Tst = "(NTFS-) Formatierung von " & DatenZiel & " beendet mit RC: " & Tst
MsgBox Tst, 4096 + vbInformation, "2481 :: " & Titel
Trace32Log Tst, 1
Else
Trace32Log "2484 :: Angebotene Formatierung von " & DatenZiel & " wurde nicht gestartet.", 1
End If
End If
' Kontrollfrage
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
T = "Soll das Image mit der Nr. """ & Nr & """ aus dem WIM" & vbCRLF & vbCRLF
T = T & WIMGewaehlt & vbCRLF & vbCRLF
T = T & "in dieses Ziel-Verzeichnis kopiert werden?" & vbCRLF & vbCRLF
T = T & "Ziel: " & DatenZiel & vbCRLF & vbCRLF
If VOW = "V" Then
T = T & "ACHTUNG: Evtl. vorhandene Dateien werden überschrieben!"
End If
Tst = MsgBox( T, vbQuestion + vbOKCancel, "2498 :: " & Titel )
If not Tst = vbOK Then
Trace32Log "2502 :: Benutzer-Abbruch für Restore", 2
MsgBox "Datenwiederherstellung wurde abgebrochen.", vbInformation, "2503 :: " & Titel
Call WIMBuRRestore()
Exit Sub
End If
Trace32Log "2507 :: KEIN Benutzer-Abbruch für Restore", 1
document.all.MenuRahmen.innerHTML = BuRRestoreMenue & "<br> " & "2510 :: Der Inhalt des <b>Image " & Nr & "</b> im WIM wird nach " & DatenZiel & " kopiert . . ."
window.setTimeout "SubRestore2( '" & Nr & "' )", 333
Trace32Log "2513 :: Beendet 'SubRestore( Nr )'", 1
End Sub ' SubRestore( Nr )
'***********************************************************
Sub SubRestore2( Nr )
'***********************************************************
Trace32Log "2521 :: Anfang 'SubRestore2( " & Nr & " )'", 1
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim Txt, Tst, Tyt, errTst, CmdBef, ExeDauer, i
Dim CMDDatei : CMDDatei = CMDPfad & "_Restore.cmd"
Dim IXParam
Trace32Log "2529 :: 'DatenZiel': " & DatenZiel, 1
If VOW = "V" Then IXParam = "/APPLY" ' : MsgBox "IXParam: " & IXParam, , "2531 :: "
If VOW = "W" Then IXParam = "/EXPORT" ' : MsgBox "IXParam: " & IXParam, , "2532 :: "
If VOW = "W" AND fso.FileExists( DatenZiel ) Then
If fso.GetFile( DatenZiel ).Size < 50 Then
MsgBox DatenZiel & vbCRLF & "ist nur " & fso.GetFile( DatenZiel ).Size & "Byte groß und wird gelöscht.", vbInformation,"2535 :: " & Titel
fso.DeleteFile DatenZiel, True
Trace32Log "2537 :: 'DatenZiel' gelöscht, weil zu klein: " & DatenZiel, 1
' Ein WIM ohne Inhalt ist min 1,5 KByte groß
Else
' MsgBox DatenZiel & ": " & fso.GetFile( DatenZiel ).Size & "Bytes", , "2540 :: "
End If
End If
' If fso.FileExists( DatenZiel ) Then MsgBox DatenZiel & vbCRLF & "ist " & fso.GetFile( DatenZiel ).Size & "Byte groß - wird NICHT gelöscht!", vbInformation,"2543 :: " & Titel
' Befehlszeile bilden
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CmdBef = """" & ProgrExe & """ "& IXParam &" /VERIFY """ & WIMGewaehlt & """ " & Nr & " """ & DatenZiel & """ "
If InStr( UCase( ProgrPara), "/CHECK" ) > 0 Then
CmdBef = """" & ProgrExe & """ " & IXParam & " /CHECK /VERIFY """ & WIMGewaehlt & """ " & Nr & " """ & DatenZiel & """ "
End If
Trace32Log "2551 :: Gebildete CmdBef (ImageX-Befehlszeile): " & CmdBef, 1
Tst = ""
If ProgrVerz = "MININT" AND fso.FolderExists( "X:\" ) Then
' bei WinPE als winpe.wim im RAM; %systemdrive%=X:
' es gibt keine Geschwindigkeitsvorteile!
Tyt = "X:\" & fso.GetTempName()
On Error Resume Next
fso.OpenTextFile( Tyt, 2, True).WriteLine Now()
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
' If Len( errTst ) < 5 Then Tst = " /TEMP X:" : fso.DeleteFile Tyt, True
End If
If ProgrVerz = "MININT" AND fso.FolderExists( "R:\" ) Then
' bei WinPE und %systemdrive%=X: und mit 'seperater' RAM-Disk R:
Tyt = "R:\" & fso.GetTempName()
On Error Resume Next
fso.OpenTextFile( Tyt, 2, True).WriteLine Now()
errTst = Err.Number & " - " & Err.Description
On Error GoTo 0
If Len( errTst ) < 5 Then Tst = " /TEMP R:" : fso.DeleteFile Tyt, True
End If
CmdBef = Replace( CmdBef, " /APPLY ", Tst & " /APPLY " )
Trace32Log "2576 :: Gebildete CmdBef (ImageX-Befehlszeile): " & CmdBef, 1
' CMD-Zeilen bilden
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Txt = "@echo off"
Txt = Txt & vbCRLF & "cls"
Txt = Txt & vbCRLF & "@echo " & "2582 :: Start: %DATE% %TIME% "
Txt = Txt & vbCRLF & "@echo " & "2583 :: Start: %DATE% %TIME%>>""%~dpn0.log"""
Txt = Txt & vbCRLF & "@echo " & "2584 :: " & CmdBef & ">>""%~dpn0.log"""
Txt = Txt & vbCRLF & "@echo " & "2585 :: " & CmdBef
Txt = Txt & vbCRLF & "@" & CmdBef
Txt = Txt & vbCRLF & "@Set RC=%errorlevel%"
Txt = Txt & vbCRLF & "@echo " & "2588 :: Ende: %DATE% %TIME% "
Txt = Txt & vbCRLF & "@echo " & "2589 :: Ende: %DATE% %TIME%>>""%~dpn0.log"""
Txt = Txt & vbCRLF & "@echo."
Txt = Txt & vbCRLF & "@echo Ende: %0 - RC: %RC%"
Txt = Txt & vbCRLF & "@if not ""%RC%""==""0"" Color E4"
Txt = Txt & vbCRLF & "@echo."
Txt = Txt & vbCRLF & "@if not ""%RC%""==""0"" @echo !!! FEHLER !!! FEHLER !!! FEHLER !!! FEHLER !!! FEHLER !!! FEHLER !!! FEHLER !!!"
Txt = Txt & vbCRLF & "@echo."
If not ZeitTest = "Ja" Then
Txt = Txt & vbCRLF & "@pause && @pause"
End If
Txt = Txt & vbCRLF & "exit %RC%"
' CMD-Zeilen in CMD-Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "2603 :: Datei soll geschrieben werden: " & CMDDatei, 1
CreateObject("Scripting.FileSystemObject").OpenTextFile( CMDDatei, 2, True).WriteLine Txt
Trace32Log "2605 :: Datei ist geschrieben: " & CMDDatei, 1
' CMD-Datei starten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' MsgBox CMDDatei & vbCRLF & vbCRLF & vbTab & "ist erstellt.", , "2609 :: " & Titel
Trace32Log "2610 :: CMDDatei (ImageX-Befehlszeile) wird gestartet . . . ", 1
ExeDauer = Timer()
i = WSHShell.Run( """" & CMDDatei & """", , True )
' MsgBox "RC: '" & i & "'", , "2614 :: "
If ZeitTest = "Ja" Then ExeDauer = vbCRLF & vbCRLF & "ExeDauer: " & ( Timer() - ExeDauer ) & "s"
If not ZeitTest = "Ja" Then ExeDauer = ""
Trace32Log "2618 :: CMDDatei (ImageX-Befehlszeile) ist beendet.", 1
Txt = " Der Inhalt des Image " & Nr & " im WIM " & vbCRLF & vbCRLF & WIMGewaehlt & vbCRLF & vbCRLF & " wurde nach " & vbCRLF & vbCRLF & DatenZiel & vbCRLF & vbCRLF & " kopiert."
Tst = 0
Select Case i
Case 0 Tst = vbInformation : Txt = Txt & ExeDauer
Case 1 Tst = vbCritical : Txt = Replace( Txt, "wurde nach", "wurde NICHT nach" ) & vbCRLF & vbCRLF & "Fehler " & i & ": Ungültige Befehlszeilenoption!"
Case 2 Tst = vbCritical : Txt = Replace( Txt, "wurde nach", "wurde NICHT nach" ) & vbCRLF & vbCRLF & "Fehler " & i & ": WIMGAPI-Fehler!"
Case 3 Tst = vbCritical : Txt = Replace( Txt, "wurde nach", "wurde NICHT nach" ) & vbCRLF & vbCRLF & "Fehler " & i & ": Ungültiges Konfigurationsskript!"
Case 4 Tst = vbCritical : Txt = Replace( Txt, "wurde nach", "wurde NICHT nach" ) & vbCRLF & vbCRLF & "Fehler " & i & ": Zugriff verweigert, Administratorrechte erforderlich!"
End Select
MsgBox Txt, Tst + 4096, "2628 :: " & Titel
Trace32Log "2630 :: Beendet 'SubRestore2( Nr )'", 1
Call WIMBuRRestore()
End Sub ' SubRestore2( Nr )
'***********************************************************
Sub SubDelete( Nr )
'***********************************************************
Trace32Log "2640 :: Anfang 'SubDelete( " & Nr & " )'", 1
Dim T, Tst
T = "Soll das Image mit der Nr. """ & Nr & """ aus dem WIM" & vbCRLF & vbCRLF
T = T & WIMGewaehlt & vbCRLF & vbCRLF
T = T & "gelöscht werden?"
Trace32Log "2645 :: WIMGewaehlt: '" & WIMGewaehlt & "'", 1
Trace32Log "2646 :: Frage, ob Image mit Nr. " & Nr & " aus WIMGewaehlt gelöscht werden soll . . . ", 1
Tst = MsgBox( T, vbQuestion + vbOKCancel, "2647 :: " & Titel )
If not Tst = vbOK Then
Trace32Log "2650 :: Benutzer-Abbruch für Delete", 2
MsgBox "Löschen wurde abgebrochen.", vbInformation, "2651 :: " & Titel
Call WIMBuRDelete()
Exit Sub
End If
Trace32Log "2655 :: KEIN Benutzer-Abbruch für Delete", 1
document.all.MenuRahmen.innerHTML = BuRDeleteMenue & "<br> 0759 :: Das <b>Image " & Nr & "</b> im WIM wird gelöscht . . .<br><br><br>" & HTMLTxt
window.setTimeout "SubDelete2( '" & Nr & "' )", 333
Trace32Log "2660 :: Beendet 'SubDelete( Nr )'", 1
End Sub ' SubDelete( Nr )
'***********************************************************
Sub SubDelete2( Nr )
'***********************************************************
Trace32Log "2667 :: Anfang 'SubDelete2( " & Nr & " )'", 1
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim Txt, Tst, CmdBef
Trace32Log "2671 :: WIMGewaehlt: '" & WIMGewaehlt & "'", 1
Trace32Log "2672 :: Image mit Nr. " & Nr & " wird aus WIMGewaehlt gelöscht . . . ", 1
' Befehlszeile bilden
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CmdBef = """" & ProgrExe & """ /DELETE """ & WIMGewaehlt & """ " & Nr
If InStr( UCase( ProgrPara), "/CHECK" ) > 0 Then
CmdBef = """" & ProgrExe & """ /DELETE /CHECK """ & WIMGewaehlt & """ " & Nr
End If
Trace32Log "2681 :: Gebildete CmdBef (ImageX-Befehlszeile): " & CmdBef, 1
' Befehlszeile startn
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "2686 :: ExecHiddenPlus( CmdBef ) wird gestartet . . . ", 1
Tst = ExecHiddenPlus( CmdBef )
Trace32Log "2688 :: ExecHiddenPlus( CmdBef ) ist beendet.", 1
' Befehlszeilen-Ausgaben auswerten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Replace( Tst, vbCRLF, "²µ" ) ' ²µ wird als Platzhalter verwendet
Tst = Replace( Tst, vbCR, "" )
Tst = Replace( Tst, vbLF, "" )
Tst = Replace( Tst, "²µ²µ", "²µ" )
Tst = Replace( Tst, "²µ²µ", "²µ" )
If InStr( Tst, "²µ" ) = 1 Then Tst = Mid( Tst, 4 )
Tst = Replace( Tst, "²µ", vbCRLF ) ' : InputBox Tst, "2700 :: " & Titel, Tst
' Befehlszeilen-Ausgaben (formatiert) anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
document.all.MenuRahmen.innerHTML = BuRDeleteMenue & "<br> " & "2705 :: " & Replace( Tst, vbCRLF, "<br> " )
MsgBox Tst, , "2706 :: " & Titel
Trace32Log "2708 :: Beendet 'SubDelete2( Nr )'", 1
Call WIMBuRDelete()
End Sub ' SubDelete2( Nr )
'***********************************************************
Sub SubWIMInfo( Nr )
'***********************************************************
' MsgBox "SubWIMInfo( " & Nr & " )" & vbCRLF & "DirDatei: " & vbTab & DirDatei, , "2718 :: " & Titel
Trace32Log "2719 :: Anfang 'SubWIMInfo( " & Nr & " )'", 1
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim CmdBef, Txt, Tst
Dim CMDDatei : CMDDatei = CMDPfad & "_WIMImageInfo.cmd"
Trace32Log "2724 :: Gebildete CMDDatei-Name: " & CMDDatei, 1
' Befehlszeile bilden
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CmdBef = """" & ProgrExe & """ /DIR """ & WIMGewaehlt & """ " & Nr & " >>""" & DirDatei & """"
Trace32Log "2730 :: Gebildete CmdBef (ImageX-Befehlszeile): " & CmdBef, 1
' Kopf in die Ausgabedatei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = HtaSelbst & " (Hta-Dateidatum: " & HtaDatum & "; " & CreateObject("Scripting.FileSystemObject").GetFile( HtaSelbst ).Size & ")"
Tst = "http://dieseyer.de/scr/WIM-BuR.hta (Hta-Dateidatum: " & HtaDatum & "; " & CreateObject("Scripting.FileSystemObject").GetFile( HtaSelbst ).Size & " Bytes)"
Tst = Tst & vbCRLF
Tst = Tst & vbCRLF & "Diese Liste wurde durch folgende Befehlszeile erstellt:"
Tst = Tst & vbCRLF & CmdBef
Tst = Tst & vbCRLF
Tst = Tst & vbCRLF & "Folgende Dateien befinden sich im Image-Nr >>>" & Nr & "<<< des WIM"
Tst = Tst & vbCRLF & """" & WIMGewaehlt & """ "
Tst = Tst & vbCRLF & "WIM-Dateidatum: " & WIMDateiDatum
Tst = Tst & vbCRLF
Trace32Log "2745 :: Datei (Kopf für DirDatei) soll geschrieben werden: " & DirDatei, 1
CreateObject("Scripting.FileSystemObject").OpenTextFile( DirDatei, 2, True).Write Tst
Trace32Log "2747 :: Datei (Kopf für DirDatei) ist geschrieben: " & DirDatei, 1
' CMD-Zeile in CMD-Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "2752 :: Datei soll geschrieben werden: " & CMDDatei, 1
CreateObject("Scripting.FileSystemObject").OpenTextFile( CMDDatei, 2, True).WriteLine CmdBef
Trace32Log "2754 :: Datei ist geschrieben: " & CMDDatei, 1
' CMD-Datei starten
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "2759 :: CMDDatei (ImageX-Befehlszeile) wird gestartet . . . ", 1
Tst = WSHShell.Run( """" & CMDDatei & """", 0, True )
Trace32Log "2761 :: CMDDatei (ImageX-Befehlszeile) ist beendet.", 1
' Ausgabedatei (DirDatei) mit NotePad anzeigen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Trace32Log "2766 :: Ausgabedatei (DirDatei) soll mit NotePad angezeigt werden . . . ", 1
Txt = "CreateObject(""WScript.Shell"").Run 'notepad """ & DirDatei & """'"
window.setTimeout Txt, 1 * 333
Trace32Log "2769 :: Wird verzögert gestartet: " & Txt, 1
window.setTimeout "WIMBuRWIMInfo()", 6 * 333
Trace32Log "2772 :: Wird verzögert gestartet: " & Txt, 1
Trace32Log "2774 :: Beendet 'SubWIMInfo( Nr )'", 1
End Sub ' SubWIMInfo( Nr )
'***********************************************************
Sub XSLDateiSchreiben( XSLDatei, VOH )
'***********************************************************
' Diese Prozedur wird in
' http://dieseyer.de/scr/WIM-BuR.hta
' und
' http://dieseyer.de/scr/wim_inhalt.vbs
' verwendet - in der HTA-Version sind Buttons in der Anzeige
' erforderlich.
Dim T
' VOH - VBS oder HTA
' MsgBox VOH, , "2791 :: "
On Error Resume Next
If VOH = "" Then T = WScript.ScriptFullName
On Error GoTo 0
If VOH = "" AND InStr( T, "." ) > 0 Then VOH = "VBS"
If VOH = "" Then VOH = "HTA"
' MsgBox VOH, , "2797 :: "
T = "<xsl:stylesheet version=""1.0"" xmlns:xsl=""http://www.w3.org/1999/XSL/Transform"">"
T = T & vbCRLF & "<xsl:decimal-format name=""de"" decimal-separator="","" grouping-separator="".""/>"
T = T & vbCRLF & "<xsl:template match=""/"">"
T = T & vbCRLF & "<span style="" font-size:9Pt; font-weight:normal; font-family:verdana,arial,sans-serif"">"
T = T & vbCRLF & "<xsl:for-each select=""WIM"">"
T = T & vbCRLF & " WIM-Größe:"
T = T & vbCRLF & "<xsl:choose>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '10995116277.76'""> <xsl:value-of select=""format-number(TOTALBYTES*0.000000000931322574615478515625,'#.##0,0','de')"" /> GBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '1099511627.776'""> <xsl:value-of select=""format-number(TOTALBYTES*0.000000000931322574615478515625,'#.##0,00','de')"" /> GBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '10737418.24'""> <xsl:value-of select=""format-number(TOTALBYTES*0.00000095367431640625,'#.##0,00','de')"" /> MBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '1073741.824'""> <xsl:value-of select=""format-number(TOTALBYTES*0.00000095367431640625,'#.##0,00','de')"" /> MBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '104857.6'""> <xsl:value-of select=""format-number(TOTALBYTES*0.0009765625,'#.##0,0','de')"" /> kBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '10485.76'""> <xsl:value-of select=""format-number(TOTALBYTES*0.0009765625,'#.##0,00','de')"" /> kBytes</xsl:when>"
T = T & vbCRLF & "<xsl:otherwise> <xsl:value-of select=""format-number(TOTALBYTES,'#.##0','de')"" /> Bytes</xsl:otherwise>"
T = T & vbCRLF & "</xsl:choose>; "
T = T & vbCRLF & "'<xsl:value-of select=""COMPRESSION"" />' Kompression; "
T = T & vbCRLF & "</xsl:for-each>"
T = T & vbCRLF & "das WIM enthält "
T = T & vbCRLF & "<xsl:value-of select=""count(WIM/IMAGE/TOTALBYTES)"" />"
T = T & vbCRLF & "Images mit zusammen<br /> "
T = T & vbCRLF & "<xsl:value-of select=""format-number(sum(WIM/IMAGE/TOTALBYTES),'#.##0','de')"" /> Bytes ="
T = T & vbCRLF & "<xsl:value-of select=""format-number(sum(WIM/IMAGE/TOTALBYTES)*0.0009765625,'#.##0,0','de')"" /> kB ="
T = T & vbCRLF & "<xsl:value-of select=""format-number(sum(WIM/IMAGE/TOTALBYTES)*0.00000095367431640625,'#.##0,0','de')"" /> MB ="
T = T & vbCRLF & "<xsl:value-of select=""format-number(sum(WIM/IMAGE/TOTALBYTES)*0.000000000931322574615478515625,'#.##0,00','de')"" /> GB<br />"
T = T & vbCRLF & "<span style="" font-size:3Pt; height:2.5em; border:0px blue solid; width:98%; "" > <br /></span>"
T = T & vbCRLF & "<xsl:for-each select=""WIM/IMAGE"">"
T = T & vbCRLF & "<span style="" margin-left:-1px; margin-top:-1px; "
If VOH = "VBS" Then
T = T & vbCRLF & "height:3.5em; border:1px red solid; width:98%; padding:0.6em; float:left;"" >"
T = T & vbCRLF & "<xsl:value-of select=""@INDEX"" />. "
T = T & vbCRLF & "<b>""<xsl:value-of select=""NAME"" />""</b><br />"
T = T & vbCRLF & " Image enthält "
Else
T = T & vbCRLF & "height:5.6em; border:1px red solid; width:100%; padding:0.6em; float:left;"" >"
T = T & vbCRLF & "<span style="" font-size: 5Pt; font-weight: bold"" >"
T = T & vbCRLF & "<input type=""submit"" >"
T = T & vbCRLF & "<xsl:attribute name=""name""><xsl:value-of select=""@INDEX"" /></xsl:attribute>"
T = T & vbCRLF & "<xsl:attribute name=""value""><xsl:value-of select=""format-number(@INDEX,'000','de')"" /></xsl:attribute>"
T = T & vbCRLF & "<xsl:attribute name=""onClick"">SubStart('<xsl:value-of select=""@INDEX"" />')</xsl:attribute>"
T = T & vbCRLF & "<xsl:attribute name=""class"">InputNr</xsl:attribute>"
T = T & vbCRLF & "<xsl:attribute name=""accesskey""><xsl:value-of select=""@INDEX"" /></xsl:attribute>"
T = T & vbCRLF & "</input>"
T = T & vbCRLF & "</span>"
T = T & vbCRLF & " "
T = T & vbCRLF & "<b>""<xsl:value-of select=""NAME"" />""</b><br />"
T = T & vbCRLF & " "
T = T & vbCRLF & "enthält "
End If
T = T & vbCRLF & "<xsl:value-of select=""format-number(DIRCOUNT,'#.##0','de')"" /> Verzeichnis(se) und"
T = T & vbCRLF & "<xsl:value-of select=""format-number(FILECOUNT,'#.##0','de')"" /> Datei(en) "
T = T & vbCRLF & " in"
T = T & vbCRLF & "<xsl:choose>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '10995116277.76'""> <xsl:value-of select=""format-number(TOTALBYTES*0.000000000931322574615478515625,'#.##0,0','de')"" /> GBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '1099511627.776'""> <xsl:value-of select=""format-number(TOTALBYTES*0.000000000931322574615478515625,'#.##0,00','de')"" /> GBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '10737418.24'""> <xsl:value-of select=""format-number(TOTALBYTES*0.00000095367431640625,'#.##0,00','de')"" /> MBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '1073741.824'""> <xsl:value-of select=""format-number(TOTALBYTES*0.00000095367431640625,'#.##0,00','de')"" /> MBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '104857.6'""> <xsl:value-of select=""format-number(TOTALBYTES*0.0009765625,'#.##0,0','de')"" /> kBytes</xsl:when>"
T = T & vbCRLF & "<xsl:when test=""TOTALBYTES > '10485.76'""> <xsl:value-of select=""format-number(TOTALBYTES*0.0009765625,'#.##0,00','de')"" /> kBytes</xsl:when>"
T = T & vbCRLF & "<xsl:otherwise> <xsl:value-of select=""format-number(TOTALBYTES,'#.##0','de')"" /> Bytes</xsl:otherwise>"
T = T & vbCRLF & "</xsl:choose>;<br />"
If VOH = "VBS" Then
T = T & vbCRLF & " "
Else
T = T & vbCRLF & " "
End If
T = T & vbCRLF & "<xsl:value-of select=""DESCRIPTION"" /> "
T = T & vbCRLF & "</span>"
T = T & vbCRLF & "</xsl:for-each>"
T = T & vbCRLF & "<span style="" font-size:3Pt; height:2em; border:0px blue solid; width:98%; "" > <br /></span>"
T = T & vbCRLF & "<xsl:for-each select=""WIM"">"
T = T & vbCRLF & "<br /> GUID: <xsl:value-of select=""GUID"" /> "
T = T & vbCRLF & "(<xsl:value-of select=""PARTNUMBER"" /> - "
T = T & vbCRLF & "<xsl:value-of select=""TOTALPARTS"" /> - "
T = T & vbCRLF & "<xsl:value-of select=""ATTRIBUTES"" />) "
T = T & vbCRLF & "</xsl:for-each>"
T = T & vbCRLF & "</span>"
T = T & vbCRLF & "</xsl:template>"
T = T & vbCRLF & "</xsl:stylesheet>"
If VOH = "VBS" Then
CreateObject("Scripting.FileSystemObject").OpenTextFile( XSLDatei, 2, True).Write T
Exit Sub
End If
Trace32Log "2883 :: Datei soll geschrieben werden: " & XSLDatei, 1
CreateObject("Scripting.FileSystemObject").OpenTextFile( XSLDatei, 2, True).Write T
Trace32Log "2885 :: Datei ist geschrieben: " & XSLDatei, 1
Trace32Log "2887 :: Beendet 'XSLDateiSchreiben( XSLDatei )'", 1
End Sub ' XSLDateiSchreiben( XSLDatei, VOH )
'*** v10.B *** www.dieseyer.de *****************************
Function UserProfilVerz
'***********************************************************
' aus 'Scriptomatic v2.0' by 'The MS Scripting Guys'
Dim objWMIService : Set objWMIService = GetObject("winmgmts:\\.\root\CIMV2")
Dim colItems : Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_UserProfile", "WQL", &h10 + &h20 )
Dim objItem, Tst
UserProfilVerz = ""
For Each objItem In colItems
If InStr( UCase( objItem.LocalPath ), UCase( CreateObject("WScript.Network").Username ) ) > 0 Then
UserProfilVerz = objItem.LocalPath
Exit For
End If
Next
Exit Function
' MsgBox UserProfilVerz & vbCRLF & UCase( CreateObject("WScript.Network").Username ), , "2909 :: "
If InStr( UCase( UserProfilVerz ), "%USERPROFILE%" ) = 1 Then
UserProfilVerz = Mid( UserProfilVerz, Len( "%USERPROFILE%" ) + 1 )
' UserProfilVerz = CreateObject("WScript.Shell").Environment("PROCESS")("USERPROFILE") & UserProfilVerz
End If
' MsgBox "UserProfilVerz: '" & UserProfilVerz & "'", , "2914 :: "
If UserProfilVerz = "" Then UserProfilVerz = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%Temp%")
' MsgBox "UserProfilVerz: '" & UserProfilVerz & "'", , "2917 :: "
If InStr( LCase( UserProfilVerz ), "%systemroot%" ) > 0 Then
Tst = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%systemroot%")
UserProfilVerz = Replace( LCase( UserProfilVerz ), "%systemroot%", Tst )
MsgBox "UserProfilVerz: '" & UserProfilVerz & "'", , "2922 :: "
End If
End Function ' UserProfilVerz
'*** v9.4 *** www.dieseyer.de ******************************
Function UserTempVerz
'***********************************************************
' aus 'Scriptomatic v2.0' by 'The MS Scripting Guys'
Dim objWMIService : Set objWMIService = GetObject("winmgmts:\\.\root\CIMV2")
Dim colItems : Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Environment", "WQL", &h10 + &h20 )
Dim objItem, Tst
UserTempVerz = ""
For Each objItem In colItems
If InStr( UCase( objItem.UserName ), UCase( CreateObject("WScript.Network").Username ) ) > 0 Then
' If objItem.SystemVariable = vbFalse Then UserTempVerz = objItem.VariableValue : Exit For
If InStr( UCase( objItem.VariableValue ), "TEMP" ) > 0 Then UserTempVerz = objItem.VariableValue : Exit For
If InStr( UCase( objItem.VariableValue ), "TMP" ) > 0 Then UserTempVerz = objItem.VariableValue : Exit For
End If
Next
' MsgBox UserTempVerz, , "2944 :: "
If InStr( UCase( UserTempVerz ), "%USERPROFILE%" ) = 1 Then
UserTempVerz = Mid( UserTempVerz, Len( "%USERPROFILE%" ) + 1 )
UserTempVerz = CreateObject("WScript.Shell").Environment("PROCESS")("USERPROFILE") & UserTempVerz
End If
' MsgBox "UserTempVerz: '" & UserTempVerz & "'", , "2949 :: "
If UserTempVerz = "" Then UserTempVerz = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%Temp%")
' MsgBox "UserTempVerz: '" & UserTempVerz & "'", , "2952 :: "
If InStr( LCase( UserTempVerz ), "%systemroot%" ) > 0 Then
Tst = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%systemroot%")
UserTempVerz = Replace( LCase( UserTempVerz ), "%systemroot%", Tst )
' MsgBox "UserTempVerz: '" & UserTempVerz & "'", , "2957 :: "
End If
End Function ' UserTempVerz
'*** v9.4 *** www.dieseyer.de ******************************
Function ExecHiddenPlus( CMD )
'***********************************************************
Dim FileOut, oWsh, Tmp
Tmp = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%Temp%") & "\" & "ExecHiddenPlus.VBS"
If CreateObject("Scripting.FileSystemObject").FileExists( Tmp ) Then
CreateObject("Scripting.FileSystemObject").DeleteFile Tmp, True
End If
If not CreateObject("Scripting.FileSystemObject").FileExists( Tmp ) Then
' zum Test nächste Zeile frei geben
' MsgBox Tmp & vbCRLF & vbCRLF & "F E H L T und wird deshalb neu geschrieben.", , "2978 :: " & Titel
Set FileOut = CreateObject("Scripting.FileSystemObject").OpenTextFile( Tmp , 2, true)
FileOut.WriteLine( " WScript.CreateObject(""WScript.Shell"").Environment( ""Volatile"" )( ""Ergebnis"" ) = """" " )
FileOut.WriteLine( " set oArgs = Wscript.Arguments " )
FileOut.WriteLine( " For i = 0 to oArgs.Count - 1 " )
' zum Test nächste Zeile frei geben
' FileOut.WriteLine( " MsgBox oArgs.item(i) , , Titel & "" - oArgs "" " )
FileOut.WriteLine( " if Instr( oArgs.item(i), "" "" ) > 0 Then CMD = CMD & """""""" & oArgs.item(i) & """""""" & "" "" " )
FileOut.WriteLine( " if not Instr( oArgs.item(i), "" "" ) > 0 Then CMD = CMD & oArgs.item(i) & "" "" " )
FileOut.WriteLine( " Next " )
' zum Test nächste Zeile frei geben
' FileOut.WriteLine( " MsgBox CMD , , Titel & "" Anfang "" " )
FileOut.WriteLine( " Set oExec = WScript.CreateObject(""WScript.Shell"").Exec( CMD ) " )
FileOut.WriteLine( " Do Until oExec.status : WScript.Sleep 100 : Loop " )
FileOut.WriteLine( " WScript.CreateObject(""WScript.Shell"").Environment( ""Volatile"" )( ""Ergebnis"" ) = oExec.StdOut.ReadAll() " )
' zum Test nächste Zeile frei geben
' FileOut.WriteLine( " MsgBox WScript.CreateObject(""WScript.Shell"").Environment( ""Volatile"" )( ""Ergebnis"" ), , Titel & "" Ende "" " )
FileOut.Close
Set FileOuT = nothing
End If
Set oWsh = CreateObject("WScript.Shell")
oWsh.Run "CScript.exe //NOLOGO " & Tmp & " " & CMD , 0, true
ExecHiddenPlus = oWsh.Environment("Volatile")( "Ergebnis" )
' zum Test nächste Zeile frei geben - Löschen der 'Tmp-Datei
' WScript.CreateObject("Scripting.FileSystemObject").DeleteFile( Tmp )
End Function ' ExecHiddenPlus( CMD )
'*** v10.3 *** www.dieseyer.de *****************************
Function RemoteWinDir( PCName )
'***********************************************************
' http://msdn2.microsoft.com/en-us/library/aa394596(vs.85).aspx
' ermittelt %WINDIR% == %SYSTEMROOT%; häufig C:\Windows
Dim objWMIService, colOperatingSystems, objOperatingSystem, Tst
Dim WindowsDirectory, SystemDirectory
On Error Resume Next
err.Clear
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PCName & "\root\cimv2")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteWinDir = "Fehler: WMI-Sys " & Tst : Exit Function
On Error Resume Next
err.Clear
Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteWinDir = "Fehler: WMI-SysOS " & Tst : Exit Function
On Error Resume Next
err.Clear
For Each objOperatingSystem in colOperatingSystems
Tst = err.Number & " - " & err.Description
On Error Goto 0
If Len( Tst ) > 4 Then : RemoteWinDir = "Fehler: WMI-SysDir " & Tst : Exit Function
WindowsDirectory = objOperatingSystem.WindowsDirectory
SystemDirectory = objOperatingSystem.SystemDirectory
Next
Set colOperatingSystems = nothing
Set objWMIService = nothing
If WindowsDirectory = "" Then
SystemDirectory = UCase( SystemDirectory )
If InStr( SystemDirectory, "\SYSTEM32" ) Then WindowsDirectory = Replace( SystemDirectory, "\SYSTEM32", "" )
End If
RemoteWinDir = WindowsDirectory
' RemoteWinDir = "%..root%: " & RemoteWinDir
End Function ' RemoteWinDir( PCName )
'*** v9.C *** www.dieseyer.de ******************************
Function AktuelleDMTFDateTime()
'***********************************************************
Dim DMTF, Tst
Tst = Timer
' Die (aktuell) zehntel und hundertstel Sekunden ermitteln.
' Zeit mit zwei Nachkommastellen: 14:25:36,47
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If InStr( Tst, "," ) Then
Tst = Mid( Tst, InStr( Tst, "," ) + 1 )
Else
Tst = ""
End If
If Len( Tst ) < 2 Then Tst = Tst & "0"
If Len( Tst ) < 2 Then Tst = Tst & "0"
Tst = "." & Tst
' aktuelle DMTF-Zeit (ohne Nachkommastellen)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Set DMTF = CreateObject("WbemScripting.SWbemDateTime")
DMTF.SetVarDate Now(), True
' aktuelle DMTF-Zeit um Nachkommastellen erweitern
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Replace( DMTF, ".00", Tst)
Set DMTF = nothing
AktuelleDMTFDateTime = Tst
End Function ' AktuelleDMTFDateTime()
'***********************************************************
Sub IcoAusHexDaten( ZielDatei, Txt )
'***********************************************************
Txt = "0000010001002020080000000000A8080000160000002800000020000000400000000100080000000000000400000000000000000000000000000000000000000000000080000080000000808000800000008000800080800000C0C0C000C0DCC000F0CAA6000020400000206000002080000020A0000020C0000020E00000400000004020000040400000406000004080000040A0000040C0000040E00000600000006020000060400000606000006080000060A0000060C0000060E00000800000008020000080400000806000008080000080A0000080C0000080E00000A0000000A0200000A0400000A0600000A0800000A0A00000A0C00000A0E00000C0000000C0200000C0400000C0600000C0800000C0A00000C0C00000C0E00000E0000000E0200000E0400000E0600000E0800000E0A00000E0C00000E0E00040000000400020004000400040006000400080004000A0004000C0004000E00040200000402020004020400040206000402080004020A0004020C0004020E00040400000404020004040400040406000404080004040A0004040C0004040E00040600000406020004060400040606000406080004060A0004060C0004060E00040800000408020004080400040806000408080004080A0004080C0004080E00040A0000040A0200040A0400040A0600040A0800040A0A00040A0C00040A0E00040C0000040C0200040C0400040C0600040C0800040C0A00040C0C00040C0E00040E0000040E0200040E0400040E0600040E0800040E0A00040E0C00040E0E00080000000800020008000400080006000800080008000A0008000C0008000E00080200000802020008020400080206000802080008020A0008020C0008020E00080400000804020008040400080406000804080008040A0008040C0008040E00080600000806020008060400080606000806080008060A0008060C0008060E00080800000808020008080400080806000808080008080A0008080C0008080E00080A0000080A0200080A0400080A0600080A0800080A0A00080A0C00080A0E00080C0000080C0200080C0400080C0600080C0800080C0A00080C0C00080C0E00080E0000080E0200080E0400080E0600080E0800080E0A00080E0C00080E0E000C0000000C0002000C0004000C0006000C0008000C000A000C000C000C000E000C0200000C0202000C0204000C0206000C0208000C020A000C020C000C020E000C0400000C0402000C0404000C0406000C0408000C040A000C040C000C040E000C0600000C0602000C0604000C0606000C0608000C060A000C060C000C060E000C0800000C0802000C0804000C0806000C0808000C080A000C080C000C080E000C0A00000C0A02000C0A04000C0A06000C0A08000C0A0A000C0A0C000C0A0E000C0C00000C0C02000C0C04000C0C06000C0C08000C0C0A000F0FBFF00A4A0A000808080000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF008989898989898989898989898989898989898989898937378989898989892D3789898989898989898989898989898989898989898989373789898989895C372D898989898989898989898989898989898989898989893737898989895237374A8989898989898989898989898989898989898989898937378989894A37375B89898989898989898989898989895B373764493737898937378989522D376489898989898989898989898989895B3737373737373789893737373737373753898989898989898989898989898937375289895B373789893737373737373737374A89898989898989898989898937378989898937378989373789898989895B3764373737373737376452898989373789898989373789893737898989898989373737373737373737373752898937378989898937378989373789898989895B376537378989898989523765898937378989898937378989373737373737373737523737898989898989373789893737898989893737898937373737373737645289373789898989895337648989373789898989373789898989898989898989898937373737373737372D498989898989898989898989898989898989898989898937373737373737375289898989898989898989898989898989898989898989893737898989895237648989898989898989898989898989898989898989898989373789898989893737898989898989898989898989898989898989898989898937378989898952372D8989898989898989898989898989898989898989898989373737373737373752898989898989898989898989898989898989898989898937373737373765528989898989898989898989898989898989898989898989898989895B376489898965375B898989893737898937378989523752898937378989898965373789898937372D8989898937378989373789895B375B8989373789898949373737498949373737498989893737898937378989373737898937378989895237373752895237373753898989373789893737894A3737374A89373789898964375B375B895B375337648989893737898937378953375B3753893737898989372D493764896437892D3789898937378989373789652D892D65893737898952375B89373789372D895B3752898937378989373789375B895B3789373789895B3752895C3752375C8952375B898937378989373752375289523752373789892D37898953376537538989372D89893737898937375B37898989375B37378949376489895237373752898964374A8937378989373737648989896437373789533752898949373737498989523753893737898937373752898989523737378965374989898937373789898949376589373789893737374989898949373737890000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim FileOut, Tst, i
' Läßt sich die ZielDatei anlegen?
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
On Error Resume Next
Set FileOut = fso.OpenTextFile( ZielDatei, 2, True )
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then Exit Sub
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i = 1
Do
FileOut.Write Chr( CInt( "&H" & Mid( Txt, i, 2 ) ) )
i = i + 2 : If i > Len( Txt ) Then Exit Do
Loop
FileOut.Close
Set FileOut = nothing
' MsgBox "{F5} folgt . . . ", , "3119 :: "
CreateObject("WScript.Shell").SendKeys "{F5}"
End Sub ' IcoAusHexDaten( ZielDatei, Txt )
'*** v9.5 *** www.dieseyer.de ******************************
Sub DateiTypRegistrieren( DateiTyp, Progr )
'***********************************************************
' in VBS und HTA verwendbar
Dim WSHShell : Set WSHShell = CreateObject("WScript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim ZielProgr : ZielProgr = WSHShell.ExpandEnvironmentStrings("%ProgramFiles%")
If Left( UCase( ZielProgr ), 15 ) = "X:\I386\PROGRAM" Then ZielProgr = "R:" ' unter WinPE
: ZielProgr = ZielProgr & "\" & DSProgr & "\" & fso.GetFileName( Progr )
Dim Zielverz : Zielverz = fso.GetParentFolderName( ZielProgr )
Dim HilfsProgr : HilfsProgr = ""
If fso.GetExtensionName( LCase( Progr ) ) = "vbs" Then HilfsProgr = "wscript.exe "
If fso.GetExtensionName( LCase( Progr ) ) = "hta" Then HilfsProgr = "mshta.exe "
DateiTyp = LCase( DateiTyp )
Dim HKey, Txt, Tst
Trace32Log "3148 :: %ProgramFiles%: " & WSHShell.ExpandEnvironmentStrings("%ProgramFiles%"), 1
Trace32Log "3149 :: DateiTyp: " & DateiTyp, 1
Trace32Log "3150 :: Progr: " & Progr, 1
Trace32Log "3151 :: HilfsProgr: " & HilfsProgr, 1
Trace32Log "3152 :: DateiTyp: " & DateiTyp, 1
Trace32Log "3153 :: Zielverz: " & Zielverz, 1
Trace32Log "3154 :: ZielProgr: " & ZielProgr, 1
' Ziel-Verzeichnis für das Progr ggf. anlegen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' MsgBox Zielverz, , "3158 :: "
If fso.FolderExists( Zielverz ) Then
Else
Trace32Log "3161 :: Zielverz soll anlegt werden: " & Zielverz, 1
On Error Resume Next
fso.CreateFolder Zielverz
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then
Txt = vbCRLF & vbCRLF & "Verzeichnis kann nicht ertellt werden:" & vbCRLF & vbCRLF & Tst & vbCRLF & vbCRLF & Zielverz
WSHShell.Popup "= = = E N D E = = =" & Txt , 15, "3168 :: Sub 'DateiTypRegistrieren'", 4096 + vbCritical
Trace32Log "3169 :: Verzeichnis kann nicht ertellt werden: " & Zielverz & " _ " & Tst, 3
Trace32Log "3170 :: Ende - Sub 'DateiTypRegistrieren'", 3
Exit Sub
Else
Trace32Log "3173 :: Erstellt: " & Zielverz & " _ " & Tst, 1
End If
End If
' Wenn Progr erreichbar, Prog ins Ziel-Verzeichnis kopieren
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Wenn Progr NICHT erreichbar ist, wird davon ausgegangen,
' dass das Prog über die Umgebungsvariable PATH vom
' Betriebssystem gefunden wird.
If not fso.FileExists( Progr ) Then
ZielProgr = Progr
Trace32Log "3184 :: ZielProgr (evtl. neu) festgelegt: " & ZielProgr, 1
Else
Trace32Log "3186 :: Datei soll kopiert werden: (von..nach)", 1
Trace32Log "3187 :: " & Progr, 1
Trace32Log "3188 :: " & ZielProgr, 1
On Error Resume Next
fso.CopyFile Progr, ZielProgr, true
Tst = err.Number & " - " & err.Description
On Error GoTo 0
If Len( Tst ) > 4 Then
Txt = vbCRLF & vbCRLF & "Datei kann nicht ertellt werden:" & vbCRLF & vbCRLF & ZielProgr
WSHShell.Popup "= = = E N D E = = =" & Txt , 15, "3195 :: Sub 'DateiTypRegistrieren'", 4096 + vbCritical
Trace32Log "3196 :: Kann nicht erstellt werden: " & ZielProgr & " _ " & Tst, 3
Trace32Log "3197 :: Ende - Sub 'DateiTypRegistrieren'", 3
Exit Sub
Else
Trace32Log "3200 :: Erstellt: " & ZielProgr & " _ " & Tst, 1
End If
End If
' MsgBox ist64bit( "." ), , "3204 :: "
HKey = "HKLM\SOFTWARE\Classes"
If ist64bit( "." ) Then ' Win7 64Bit'
HKey = "HKCU\SOFTWARE\Classes"
End If
Txt = HKey & "\." & DateiTyp & "\"
WSHShell.RegWrite Txt, DateiTyp & "_auto_file"
Trace32Log "3212 :: RegWrite erfolgreich: " & Txt, 1
Txt = HKey & "\" & DateiTyp & "_auto_file\shell\open\command\"
WSHShell.RegWrite Txt, HilfsProgr & """" & ZielProgr & """ " & chr(34) & "%1" & chr(34)
Trace32Log "3216 :: RegWrite erfolgreich: " & Txt, 1
Txt = vbTab & ZielProgr & vbCRLF & vbCRLF
Txt = Txt & "wurde als Standard-Anwendung für '" & DateiTyp & "' -Dateien registriert." & vbCRLF & vbCRLF
Txt = Txt & "Künftig genügt es, eine Datei mit der Endung ." & DateiTyp & " doppelt an zu" & vbCRLF
Txt = Txt & "klicken und die Anwendung startet mit dieser Datei als Parameter. " & vbCRLF
WSHShell.PopUp Txt, 30, "3222 :: Sub 'DateiTypRegistrieren'", vbInformation
Trace32Log "3224 :: Ende - Sub 'DateiTypRegistrieren'", 1
End Sub ' DateiTypRegistrieren( DateiTyp, Progr )
'*** v10.C *** www.dieseyer.de *****************************
Function ist64bit( PC )
'***********************************************************
Dim objWMIService, colSettings, objOperatingSystem
Dim Tst
On Error resume Next
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & PC & "\root\cimv2")
Set colSettings = objWMIService.ExecQuery ("Select * from Win32_OperatingSystem")
For Each objOperatingSystem in colSettings
Tst = objOperatingSystem.OSArchitecture
If InStr( Tst, "64" ) = 1 Then ist64bit = True : Exit Function
Next
' If InStr( Tst, 64 ) = 1 Then ist64bit = True
ist64bit = False
End Function ' ist64bit( PC )
'***********************************************************
Sub document_onkeypress
'***********************************************************
Dim Tst
Tst = window.event.keyCode
If Len( LfdKey ) > 11 Then LfdKey = Mid( LfdKey, 2 )
LfdKey = LfdKey & Chr( Tst )
If InStr( LfdKey, "expert" ) Then GottModus = True : Call WIMBuRRestore() : LfdKey = ""
If InStr( LfdKey, "logdatei" ) Then
LfdKey = ""
CreateObject("WScript.Shell").Run "trace32.exe """ & LogDatei & """", , False
Tst = MsgBox( "Soll " & LogDatei & " gelöscht werden?", 4096 + vbYesNo, "3262 :: " &Titel )
If Tst = vbYes Then CreateObject("Scripting.FileSystemObject").DeleteFile LogDatei, True
End If
' document.all.ZeigeInfo.innerHTML = LfdKey & "3265 :: " & Len( LfdKey )
End Sub ' document_onkeypress
'*** v9.C *** www.dieseyer.de ******************************
Sub Trace32Log( LogTxt, ErrType )
'***********************************************************
' in VBS und HTA verwendbar
' Aufbau einer LOG-Datei für trace32.exe ( SMS Trace;
' ALLES in einer Zeile!):
' <![LOG[...]LOG]!>
' <
' time="08:12:54.309+-60"
' date="03-14-2008"
' component="SrcUpdateMgr"
' context=""
' type="0"
' thread="1812"
' file="productpackage.cpp:97"
' >
'
' "context=" Info wird nicht angezeigt
' type="0" normale Zeie => NEUE LOG-DATEI - ggf. alte überschreiben !!!!!!!!!!!!
' type="1" normale Zeie
' type="2" gelbe Zeie
' type="3" rote Zeie
' type="F" rote Zeie
' "thread=" kann eine Dezimalzahl aufnehmen; trace32 zeigt
' neben der Dezimalzahl in Klammern die entspr.
' Hexadezimalzahl an - z.B. "33 (0x21)"
' "file=" wird in "Source:" angezeigt
'
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim LogDateiX, TitelX, Tst, Nr
On Error Resume Next
Tst = KeineLog
On Error Goto 0
If UCase( Tst ) = "JA" Then Exit Sub
On Error Resume Next
TitelX = Titel ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
TitelX = title ' Fehler, wenn die Variable 'Titel' nicht außerhalb der Prozedur definiert wurde
If Len( TitelX ) < 2 Then TitelX = document.title ' .hta
If Len( TitelX ) < 2 Then TitelX = WScript.ScriptName ' .vbs
On Error Goto 0
On Error Resume Next
LogDateiX = LogDatei ' wurde die Variable 'LogDatei' nicht außerhalb der Prozedur definiert
If Len( LogDateiX ) < 2 Then LogDateiX = WScript.ScriptFullName & ".log" ' .vbs
If Len( LogDateiX ) < 2 Then LogDateiX = TitelX & ".log" ' .hta
On Error Goto 0
Nr = 0 ' Wenn in Thread die Zeilennummer stehen soll:
Nr = 999999
If Nr = 0 AND InStr( LogTxt, " :" & ": " ) > 0 Then
' Wenn in Thread die Zeilennummer stehen soll - Voraussetzung
' ist eine ZeilenNr. im Format '22 :: '
Nr = LogTxt
Nr = Mid( Nr, 1, InStrRev( Nr, " :" & ": " ) -1 ) ' nach der Zeilennummer
Nr = Mid( Nr, InStrRev( Nr, " " ) + 1 ) ' vor der Zeilennummer
On Error Resume Next : Tst = Int( Nr ) : On Error Goto 0 ' Zeilennummer als (Integer) Zahl
Do ' Tst für Vergleich auf gleiche Länge wie Nr anpassen
If Len( Tst ) = Len( Nr ) Then Exit Do
Tst = "0" & Tst
Loop
If "x" & Tst = "x" & Nr Then
LogTxt = Replace( LogTxt, Tst & " :" & ": ", "" )
Nr = Int( Nr )
End If
End If
If Nr = 999999 Then Nr = 0
' Zwei Nachkommastellen (nach Sekunden) der aktuellen Zeit
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = Timer() ' timer() in USA: 1234.22
Tst = Replace( Tst, "," , ".") ' timer() in Deutschland: 123454,12
If InStr( Tst, "." ) = 0 Then Tst = Tst & ".000"
Tst = Mid( Tst, InStr( Tst, "." ), 4 )
If Len( Tst ) < 3 Then Tst = Tst & "0"
' Zeitzone ermitteln - neu (v9.C) und immer richtig(er)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim AktDMTF : Set AktDMTF = CreateObject("WbemScripting.SWbemDateTime")
AktDMTF.SetVarDate Now(), True : Tst = Tst & Mid( AktDMTF, 22 ) ' : MsgBox Tst, , "3354 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "3355 :: "
Set AktDMTF = nothing
LogTxt = "<![LOG[" & LogTxt & "]LOG]!>"
LogTxt = LogTxt & "<"
LogTxt = LogTxt & "time=""" & Hour( Time() ) & ":" & Minute( Time() ) & ":" & Second( Time() ) & Tst & """ "
LogTxt = LogTxt & "date=""" & Month( Date() ) & "-" & Day( Date() ) & "-" & Year( Date() ) & """ "
LogTxt = LogTxt & "component=""" & TitelX & """ "
LogTxt = LogTxt & "context="""" "
LogTxt = LogTxt & "type=""" & ErrType & """ "
LogTxt = LogTxt & "thread=""" & Nr & """ "
LogTxt = LogTxt & "file=""dieseyer.de"" "
LogTxt = LogTxt & ">"
Tst = 8 ' LOG-Datei erweitern
If ErrType = 0 Then Tst = 2 ' LOG-Datei erneuern (alte löschen, neue erstellen)
On Error Resume Next
If LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
If not LogTxt = vbCRLF Then fso.OpenTextFile( LogDateiX, Tst, true).WriteLine ( LogTxt )
On Error Goto 0
Set fso = Nothing
End Sub ' Trace32Log( LogTxt, ErrType )
</script>
<body onLoad="BeimLaden()">
<span id="ZeigeInfo" ></span>
<span id="MenuEing"></span><br>
<span id="MenuRahmen" ></span>
<!--
<span id="InfoTxt" style="text-align: center; width: 642px; height: 3em; position: absolute; top: 478px; left: 11px; border: 2px solid red; background-color: #00d;"></span>
-->
</body>
</html>
http://dieseyer.de • all rights reserved • © 2011 v11.4