http://dieseyer.de • all rights reserved • © 2011 v11.4
'v3.C***********************************************************
' File: TXTQuerDruck.VBS
' Autor: dieseyer@gmx.de
' dieseyer.de
'
' kopiert Datei(en) zum Drucker, die dann im Querformat gedruckt
' werden.
'
' ACHTUNG:
' Jedes Zeichen der Datei(en) kommt beim Drucker an. Man sollte
' also nur ASCII-Dateien (z.B. Quelltexte) verwenden, sonst werden
' !!! HUNDERTE !!! Seiten mit Schwachsinn bedruckt.
'***************************************************************
Option Explicit
Dim SendToLink, Text, TextX, i
Dim oArgs, WSHShell, fso
Dim Drucker, Datei, TmpDatei, FileOut
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
set oArgs = Wscript.Arguments
SendToLink = "Text quer drucken"
' Argumente testen/holen
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If oArgs.Count = 0 then SkriptInfo ' SUB Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~
'***************************************************************
' ANFANG des eigentlichen Skripts
'***************************************************************
Text = ""
' WSHShell.run UCase("net use lpt2 /DELETE") , 0, True
' WSHShell.run UCase("net use lpt2: \\PrintSrv\LJ4plus") , 0, True
TmpDatei = WScript.ScriptFullName & ".Tmp"
For i = 0 to oArgs.Count - 1 ' hole alle Argumente
if i = 0 then
Text = Left( UCase(oArgs.item(i)), 2)
if Text = "-S" OR Text = "-I" then AutoStartLink ( SendToLink ) ' Function Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~
Text = ""
End If
If Drucker = "" then Drucker = Druckerauswahl ' Function Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~
Datei = Datei & i & vbTab & oArgs.item(i) & vbTab & Drucker & vbCRLF ' Protokoll
Set FileOut = fso.OpenTextFile (TmpDatei, 2, true) ' TmpDatei neu anlegen (2)
' FileOut.WriteLine ( Chr(27) & "E" & Chr(27) & "&l1O" )
FileOut.WriteLine ( Chr(27) & "E" & Chr(27) & "&l1O" & Chr(27) & "(s16H" & Chr(27) & "&l12D" )
' | | | 12 Zeilen pro Zoll - 8, 12, 16 sind möglich
' | | 16 Zeichen pro Zoll - Schriftgröße
' | &l1O Querformat
' E DruckerReset - in Einschaltzustand zurück setzen
FileOut.WriteLine ("#-#-# => " & oArgs.item(i) & " - gedruckt am " & now() & " <= #-#-#" )
Set FileOut = nothing ' TmpDatei schließen
Text = "%comspec% /c copy /b """ & TmpDatei & """ +""" & oArgs.item(i) & """ """ & TmpDatei & """ "
' Zusammensetzen der TmpDatei: TmpDatei und zu druckende Datei
' WSHShell.Popup Text, 10, WScript.ScriptName , 64
WSHShell.run Text , 0, True
Set FileOut = fso.OpenTextFile (TmpDatei, 8, true) ' TmpDatei erweitern (8)
' FileOut.WriteLine (Text)
FileOut.WriteLine (Chr(27) & "E") ' TmpDatei mit DruckerReset-Esc-Sequenz (SeitenVorschub) (PCL)
Set FileOut = nothing ' TmpDatei schließen
' WSHShell.Popup TmpDatei & vbTab & Drucker , 10, WScript.ScriptName , 64
FSO.CopyFile TmpDatei, Drucker ' Datei zum Drucker kopieren
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Text = Datei & vbCRLF
Next
' if fso.FileExists (TmpDatei) then MsgBox "fso.FileDelete (" & TmpDatei & ")"
if fso.FileExists (TmpDatei) then fso.DeleteFile (TmpDatei)
'***************************************************************
' ENDE des eigentlichen Skripts
'***************************************************************
WSHShell.Popup Text, 10, WScript.ScriptName & " . . . ist zu Ende!" , 64
WScript.Quit
'***************************************************************
Sub SkriptInfo ' Sub Aufruf
'***************************************************************
Text = ""
Text = Text & "Das ganze funktioniert so:" & vbCRLF & vbCRLF
Text = Text & "Entweder ein oder mehrere Dateien bzw. Verzeichnisse " & vbCRLF
Text = Text & "mit der Maus auf das Skript ziehen und fallen lassen, " & vbCRLF
Text = Text & "oder dem Skript über 'Senden an' die Dateien bzw. " & vbCRLF
Text = Text & "Verzeichnisse übergeben. " & vbCRLF & vbCRLF
Text = Text & "Wenn es sich nicht um TXT- oder PRN- Dateien handelt," & vbCRLF
Text = Text & "können es ! HUNDERTE ! Seiten werden!" & vbCRLF & vbCRLF
Text = Text & "Soll das Skript über 'Senden an' (SendTo) erreichbar sein?" & vbCRLF
If not vbYes = WSHShell.Popup (Text , 30, WScript.ScriptName, 32 + 4 ) then
WSHShell.Popup " . . . dann eben nicht!", 10, WScript.ScriptName & " . . . ist zu Ende!" , 48
WScript.Quit
End If
Text = ""
Text = Text & "Das Skript " & UCase( WScript.ScriptName ) & " wird jetzt für alle Benutzerkonten " & vbCRLF
Text = Text & "oder, wenn das nicht geht, für den angemeldeten Benutzer " & vbCRLF
Text = Text & "unter 'Senden an' eingerichtet." & vbCRLF & vbCRLF
Text = Text & "Es ist dann als '" & fso.GetBaseName( WScript.ScriptName ) & "' verfügbar."
WSHShell.Popup Text, 10, WScript.ScriptName , 64
AutoStartLink ( SendToLink ) ' SUB Aufruf
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~
WScript.Quit
End Sub ' SkriptInfo
'***************************************************************
'***************************************************************
Function AutoStartLink( SendToLink ) ' Function Aufruf
'***************************************************************
Dim Text, TextX, ShellLink
Dim WSHShell, fso
Set WSHShell = WScript.CreateObject("WScript.Shell")
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
' wohin soll das Skript kopiert werden?
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' folgende Zeile müsste c:\ ergeben
Text = Left( WSHShell.ExpandEnvironmentStrings("%WinDir%") , 3)
if fso.FolderExists( WSHShell.ExpandEnvironmentStrings("%Temp%") ) then TextX = WSHShell.ExpandEnvironmentStrings("%Temp%")
if fso.FolderExists( Text & "PROGRAM FILES" ) then TextX = Text & "PROGRAM FILES"
if fso.FolderExists( Text & "programme" ) then TextX = Text & "programme"
TextX = TextX & "\dieseyer.de"
On Error Resume Next
if not fso.FolderExists( TextX ) then fso.CreateFolder( TextX )
On Error GoTo 0
if not fso.FolderExists( TextX ) then
WSHShell.Popup TextX & " konnte nicht angelegt werden!" , 30, WScript.ScriptName & " . . . ist zu Ende!" , 64
WScript.Quit
End If
' das Skript kopieren
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
TextX = TextX & "\" & SendToLink & ".vbs"
' das Skript kopieren, wenn das Zielskript nicht das aktuelle,
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' laufende Skript ist
If not LCase(TextX) = LCase(WScript.ScriptFullName) then
On Error Resume Next
fso.CopyFile WScript.ScriptName, TextX , True
if not err.number = 0 then
WSHShell.Popup TextX & " konnte nicht angelegt werden!" , 30, WScript.ScriptName & " . . . ist zu Ende!" , 64
WScript.Quit
End If
On Error GoTo 0
End If
' Link in 'Autostart' von 'All Users' installieren ...
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' ... der wird dann bei jedem Aufruf den 'Senden An' - Link erstellen
Text = WSHShell.SpecialFolders("AllUsersStartup") & "\" & SendToLink & ".lnk"
If Text = "\" & SendToLink & ".lnk" then ' bei Win9x
Text = WSHShell.SpecialFolders("Startup") & "\" & SendToLink & ".lnk"
End If
Set ShellLink = WSHShell.CreateShortcut( Text)
ShellLink.TargetPath = TextX
ShellLink.Arguments = "-install"
ShellLink.WorkingDirectory = fso.GetParentFolderName( TextX )
On Error Resume Next
ShellLink.Save
On Error GoTo 0
If not err.number = 0 then
WSHShell.Popup Text & " konnte nicht angelegt werden!" , 30, WScript.ScriptName , 64
End If
Text = WSHShell.SpecialFolders("SendTo") & "\" & SendToLink & ".lnk"
Set ShellLink = WSHShell.CreateShortcut( Text)
ShellLink.TargetPath = TextX
ShellLink.WorkingDirectory = fso.GetParentFolderName( TextX )
' ShellLink.Save =======> kommt später
On Error Resume Next
if fso.FileExists( Text ) then
' WSHShell.Popup Text & " wird überschrieben!" , 10, WScript.ScriptName , 64
ShellLink.Save ' =======> kommt hier
If err.number = 0 then
' WSHShell.Popup Text & " wurde überschrieben!" , 10, WScript.ScriptName , 64
Else
WSHShell.Popup Text & " konnte nicht überschrieben werden!" , 30, WScript.ScriptName , 64
End If
Else
ShellLink.Save ' =======> kommt hier
If err.number = 0 then
' WSHShell.Popup Text & " wurde angelegt!" , 10, WScript.ScriptName , 64
Else
WSHShell.Popup Text & " konnte nicht angelegt werden!" , 30, WScript.ScriptName , 64
End If
End If
On Error GoTo 0
WScript.Quit
End Function ' AutoStartLink ( SendToLink )
'***************************************************************
'***************************************************************
Function Druckerauswahl ' Anfanfg
'***************************************************************
' Es kann nur auf LPT? und Netzwerkdrucker kopiert werden
Dim i, n, Text, DruckerNr, NetPRN, WSHNet
Set WSHNet = WScript.CreateObject("WScript.Network")
Set NetPRN = WSHNet.EnumPrinterConnections
n = 0
' welche Drucker sind verwendbar:
For i = 0 To NetPRN.Count-1 Step 2
if Left(NetPRN(i+1),2) = "\\" then
n = n + 1
Text = Text & n & ": " & NetPRN(i) & vbTab & NetPRN(i+1) & vbCRLF
End If
if not Left(NetPRN(i+1),2) = "\\" then
if UCase(Left(NetPRN(i), 3)) = "LPT" then
n = n + 1
Text = Text & n & ": " & NetPRN(i) & vbTab & NetPRN(i+1) & vbCRLF
End If
End If
Next
Text = Text & vbCRLF & "Auf welchen Drucker soll gedruckt werden?"
DruckerNr = InputBox (Text, WScript.ScriptName)
On Error Resume Next
DruckerNr = Asc( DruckerNr ) -48
On Error GoTo 0
If DruckerNr > n OR DruckerNr < 1 then
Text = "!!! FALSCHE EINGABE !!!" & vbCRLF & vbCRLF & Text
DruckerNr = InputBox (Text, WScript.ScriptName)
On Error Resume Next
DruckerNr = Asc( DruckerNr ) -48
On Error GoTo 0
End If
If DruckerNr > n OR DruckerNr < 1 then DruckerNr = ""
If DruckerNr = "" then WSHShell.Popup " . . . denn eben nicht!", 10, WScript.ScriptName & " . . . ist zu Ende!" , 64
If DruckerNr = "" then WScript.Quit
n = 0
' gewählten Drucker ermitteln
For i = 0 To NetPRN.Count-1 Step 2
if Left(NetPRN(i+1),2) = "\\" then
n = n + 1
If n = DruckerNr Then Druckerauswahl = NetPRN(i+1)
End If
if not Left(NetPRN(i+1),2) = "\\" then
if UCase(Left(NetPRN(i), 3)) = "LPT" then
n = n + 1
If n = DruckerNr Then Druckerauswahl = NetPRN(i )
End If
End If
Next
End Function ' Druckerauswahl
'***************************************************************
http://dieseyer.de • all rights reserved • © 2011 v11.4