http://dieseyer.de • all rights reserved • © 2011 v11.4
'*** v9.5 *** www.dieseyer.de ******************************
'
' Datei: DateiTypRegistrieren.vbs
' Autor: dieseyer@gmx.de
' Auf: www.dieseyer.de
'
' Die Sub-Prozedur
' DateiTypRegistrieren( DateiTyp, Progr )
' legt ein Programm als Standard-Anwendung für einen
' Dateityp fest (Dateiendung registrieren). Bei einem
' Doppelklick auf eine Datei mit dieser Dateiendung öffnet
' sich künftig diese Anwendung und erhält als Parameter die
' doppelt geklickte Datei - so, wie Word geöffnet wird, wenn
' man eine .doc - Datei doppelt klickt.
'
'***********************************************************
Option Explicit ' Siehe http://dieseyer.de/dse-wsh-lernen.html#OptionExpl
Dim fso : Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Const TestEndung = "n-p"
Const TestProgr = "notepad.exe"
Dim TestDatei : TestDatei = WScript.ScriptFullName & "." & TestEndung
Dim Txt, Tst
Txt = ""
Txt = Txt & "Als erstes wird eine Datei mit der Endung '." & TestEndung & "' erstellt. Im Anschluß" & vbCRLF
Txt = Txt & "daran wird als Standard-Anwendung für '." & TestEndung & "'' - Dateien 'notepad'" & vbCRLF
Txt = Txt & "festgelegt (Dateiendung registrieren) und dann die '." & TestEndung & "'' - Datei" & vbCRLF
Txt = Txt & "gestartet - es sollte sich 'notepad' mit diesem Text öffnen." & vbCRLF & vbCRLF
Txt = Txt & "Mit dem Schließen von Notepad wird die registrierte Dateiendung " & vbCRLF
Txt = Txt & "wieder entfernt." & vbCRLF & vbCRLF
Txt = Txt & "Und? Soll 's los gehen?"
' Kontroll-Frage
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tst = MsgBox( Txt, vbQuestion + vbOkCancel, "038 :: " & WScript.ScriptName )
If not Tst = vbOK Then MsgBox " . . . dann eben nicht!", , "040 :: " & WScript.ScriptName : WScript.Quit
' Datei schreiben
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CreateObject("Scripting.FileSystemObject").OpenTextFile( TestDatei, 2, True).Write Txt
' Datei starten - es muss eine Fehlermeldung folgen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' WScript.CreateObject("WScript.Shell").Run TestDatei, , True
Call DateiTypRegistrieren( TestEndung, TestProgr )
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Datei starten - keine Fehlermeldung
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WScript.CreateObject("WScript.Shell").Run TestDatei, , True
WScript.Quit
'*** 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%") & "\dieseyer.de\" & 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 Txt, Tst
Trace32Log "082 :: DateiTyp: " & DateiTyp, 1
Trace32Log "083 :: Progr: " & Progr, 1
Trace32Log "084 :: HilfsProgr: " & HilfsProgr, 1
Trace32Log "085 :: DateiTyp: " & DateiTyp, 1
Trace32Log "086 :: Zielverz: " & Zielverz, 1
' Ziel-Verzeichnis für das Progr ggf. anlegen
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If fso.FolderExists( Zielverz ) Then
Else
Trace32Log "092 :: 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
WSHShell.Popup "= = = E N D E = = =" & Txt , 15, "099 :: Sub 'DateiTypRegistrieren'", 4096 + vbCritical
Trace32Log "100 :: Verzeichnis kann nicht ertellt werden: " & Zielverz & " _ " & Tst, 3
Trace32Log "101 :: Ende - Sub 'DateiTypRegistrieren'", 3
Exit Sub
Else
Trace32Log "104 :: 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 "115 :: ZielProgr (evtl. neu) festgelegt: " & ZielProgr, 1
Else
Trace32Log "117 :: Datei soll kopiert werden: (von..nach)", 1
Trace32Log "118 :: " & Progr, 1
Trace32Log "119 :: " & 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, "126 :: Sub 'DateiTypRegistrieren'", 4096 + vbCritical
Trace32Log "127 :: Kann nicht erstellt werden: " & ZielProgr & " _ " & Tst, 3
Trace32Log "128 :: Ende - Sub 'DateiTypRegistrieren'", 3
Exit Sub
Else
Trace32Log "131 :: Erstellt: " & ZielProgr & " _ " & Tst, 1
End If
End If
Txt = "HKLM\SOFTWARE\Classes\." & DateiTyp & "\"
WSHShell.RegWrite Txt, DateiTyp & "_auto_file"
Trace32Log "137 :: RegWrite erfolgreich: " & Txt, 1
Txt = "HKLM\SOFTWARE\Classes\" & DateiTyp & "_auto_file\shell\open\command\"
WSHShell.RegWrite Txt, HilfsProgr & """" & ZielProgr & """ " & chr(34) & "%1" & chr(34)
Trace32Log "141 :: 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, "147 :: Sub 'DateiTypRegistrieren'", vbInformation
Trace32Log "149 :: Ende - Sub 'DateiTypRegistrieren'", 1
End Sub ' DateiTypRegistrieren( DateiTyp, Progr )
'*** 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, , "205 :: "
' MsgBox "AktDMTF: '" & AktDMTF & "'", , "206 :: "
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 )
http://dieseyer.de • all rights reserved • © 2011 v11.4