'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 
'***************************************************************