title image


Smiley Re: untere Papierschacht kann nicht angesteuert werden
Hallo



ich habe mir ein Globales Addin erstellt, das es ermöglicht vor dem Druckdialog die Druckerschächte einzustellen.

Es besteht aus 2 Formularen und 2 Modulen



hier der code:





      

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

' Module    : frmDruckerPapierfaecher

' DateTime  : 25.11.2004 11:05

' Author    : Thomas Brill

' Purpose   :

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

'Dieser Sourcecode stammt von http://www.VB-fun.de und kann frei verwendet werden.

'Für eventuell auftretende Schäden wird keine Haftung übernommen.

'Bei Fehlern oder Fragen einfach eine Mail an: tipps@VB-fun.de

'Ansonsten viel Spaß und Erfolg mit diesem Sourcecode.

Option Explicit

    

Private Declare Function OpenPrinter Lib "winspool.drv" Alias _

    "OpenPrinterA" (ByVal pPrinterName As String, phPrinter _

    As Long, ByVal pDefault As Long) As Long

Private Declare Function ClosePrinter Lib "winspool.drv" ( _

    ByVal hPrinter As Long) As Long

Private Declare Function DeviceCapabilities Lib "winspool.drv" _

    Alias "DeviceCapabilitiesA" (ByVal lpsDeviceName As String, _

    ByVal lpPort As String, ByVal iIndex As Long, lpOutput As Any, _

    ByVal dev As Long) As Long

Private Drucker As Variant



Const DC_BINS = 6

Const DC_BINNAMES = 12



Dim fachErsteSeite As Long

Dim fachFolgeSeite As Long

Private frmComboFlag As Boolean



Private Sub CheckBox1_Click()

   Set oDoc = ActiveDocument

   If CheckBox1.Value = True Then

      oDoc.Variables(Var21).Value = "-1"

      Options.PrintHiddenText = False

   ElseIf CheckBox1.Value = False Then

      oDoc.Variables(Var21).Value = "0"

      Options.PrintHiddenText = True

   End If



End Sub



Private Sub cmdAbbrechen_Click()

  Documents(Me.Tag).Activate

  frmDruckerFlag = False

  Unload Me



End Sub



Private Sub cmdWeiter_Click()

  Documents(Me.Tag).Activate

  Set oDoc = ActiveDocument

  If CheckBoxPrint.Value = True Then aktuellerDrucker = ActivePrinter

  'Ausgewählte Papierzufuhr übernehmen:

  oDoc.PageSetup.FirstPageTray = fachErsteSeite

  oDoc.PageSetup.OtherPagesTray = fachFolgeSeite

  frmDruckerFlag = True

  If Not DocVarCheckExistence(Var54) Then

     oDoc.Variables.Add name:=Var54, Value:="1"

  End If

  Unload Me



End Sub



Private Sub ComboBox1_Change()

   If frmComboFlag = False Then Exit Sub

   ActivePrinter = ComboBox1.Value

   

   Call DruckerAnzeigen

End Sub



Private Sub UserForm_Activate()

Dim rngInR As Long, strP As String

  Me.Tag = ActiveDocument.name

  Me.CheckBoxPrint.Value = False

  Set oDoc = ActiveDocument

  frmComboFlag = False

  If DocVarCheckExistence(Var21) = True Then

     CheckBox1.Visible = True

     If oDoc.Variables(Var21).Value = "-1" Then

        CheckBox1.Value = True

     ElseIf oDoc.Variables(Var21).Value = "0" Then

        CheckBox1.Value = False

     End If

  Else

     CheckBox1.Visible = False

  End If

  Drucker = PrinterListing

  If Not IsArray(Drucker) Then

    MsgBox "Fehler beim erstellen der Druckerauflistung"

  Else

    Me.ComboBox1.List = Drucker

    'strP = ActivePrinter

    'rngInR = InStr(1, strP, "on NE")

    'strP = Trim(Mid(strP, 1, rngInR - 1))

    Me.ComboBox1.Text = ActivePrinter

  frmComboFlag = True

  End If

End Sub



Private Sub UserForm_Initialize()

   Call DruckerAnzeigen

End Sub



Private Sub DruckerAnzeigen()

  Dim sDeviceName As String

  Dim sDevicePort As String

  Dim hPrinter As Long

  Dim bins As Long

  Dim binList As String

  Dim binNum() As Integer

  Dim binString As String

  Dim x As Integer

  Dim strListe() As String



  DruckerNameErmitteln sDeviceName, sDevicePort

    

  If OpenPrinter(sDeviceName, hPrinter, 0) <> 0 Then



    'Label1.Caption = "   " & aktuellerDrucker

    ListBox1.Clear

    ListBox1.ColumnCount = 2

    'ListBox-Spalte mit Konstanten "unsichtbar" machen:

    ListBox1.ColumnWidths = 120 & ";" & 0

    ListBox2.Clear

    ListBox2.ColumnCount = 2

    'ListBox-Spalte mit Konstanten "unsichtbar" machen:

    ListBox2.ColumnWidths = 120 & ";" & 0

    

    bins = DeviceCapabilities(sDeviceName, sDevicePort, _

            DC_BINS, ByVal vbNullString, 0)



    ReDim binNum(1 To bins)



    bins = DeviceCapabilities(sDeviceName, sDevicePort, _

            DC_BINS, binNum(1), 0)

    binList = String$(24 * bins, 0)

    bins = DeviceCapabilities(sDeviceName, sDevicePort, _

            DC_BINNAMES, ByVal binList, 0)

    

    ReDim strListe(1 To bins, 2)

    

    For x = 1 To bins

      binString = Mid(binList, 24 * (x - 1) + 1, 24)

      binString = Left(binString, InStr(1, binString, Chr(0)) - 1)

      

      strListe(x, 0) = binString

      strListe(x, 1) = (binNum(x))

    Next x

      

    ClosePrinter (hPrinter)

    

    'ListBox1 und 2 mit ermittelten Papierfächern füllen:

    ListBox1.List() = strListe

    ListBox2.List() = strListe

    

    Call PapierzufuhrErmitteln

        

  Else

    'Label1.Caption = ActivePrinter & " nicht ansprechbar!"

    ListBox1.Clear

    ListBox2.Clear

    cmdWeiter.Enabled = False

  End If



End Sub



Private Sub DruckerNameErmitteln(druckerName As String, _

    druckerPort As String)



  Dim sString As String

  Const suchText As String = " on "

  

  sString = ActivePrinter

  druckerName = Left(sString, InStr(1, sString, suchText) - 1)

  druckerPort = Right(sString, Len(sString) - Len(druckerName) - _

      Len(suchText))



End Sub



Private Sub PapierzufuhrErmitteln()

  Dim x As Integer



  'Aktuelle Einstellung der Papierzufuhr für erste Seite

  ' und ListIndex ermitteln:

  fachErsteSeite = ActiveDocument.PageSetup.FirstPageTray

  If fachErsteSeite = 0 Then

      ListBox1.ListIndex = 0

  Else

    For x = 0 To ListBox1.ListCount - 1

      If ListBox1.List(x, 1) = fachErsteSeite Then

        ListBox1.ListIndex = x

        Exit For

      End If

    Next x

  End If

  

  'Aktuelle Einstellung der Papierzufuhr für Folgeseiten

  ' und ListIndex ermitteln:

  fachFolgeSeite = ActiveDocument.PageSetup.OtherPagesTray

  If fachFolgeSeite = 0 Then

      ListBox2.ListIndex = 0

  Else

    For x = 0 To ListBox1.ListCount - 1

      If ListBox2.List(x, 1) = fachFolgeSeite Then

        ListBox2.ListIndex = x

        Exit For

      End If

    Next x

  End If



End Sub



Private Sub ListBox1_Click()

  'Konstante des gewählten Schachtes in der 2. Spalte der ListBox:

  If ListBox1.ListCount >= 1 Then

    fachErsteSeite = ListBox1.List(ListBox1.ListIndex, 1)

  End If

End Sub



Private Sub ListBox2_Click()

  'Konstante des gewählten Schachtes in der 2. Spalte der ListBox:

  If ListBox2.ListCount >= 1 Then

    fachFolgeSeite = ListBox2.List(ListBox2.ListIndex, 1)

  End If

End Sub 





Code eingefügt mit Syntaxhighlighter 3.0











      

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

' Module    : frmWordOptionen

' DateTime  : 25.11.2004 11:07

' Author    : dv00030

' Purpose   :

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

Option Explicit

' Formular stellt den Original Druckdialog im Menu an oder aus.

' Wird vom Formular frmEmpfaenger aufgerufen

'\'a9 2000, Thomas Brill

'Constante Variablen

Private boolClick As Boolean



Private Sub CheckBox1_Click()

  oPfad = Environ("Windir") & "\" & oFile

  If CheckBox1.Value = True Then

    System.PrivateProfileString(oPfad, Section:=secPrint, Key:=Var56) = "JA"

  Else

    System.PrivateProfileString(oPfad, Section:=secPrint, Key:=Var56) = ""

  End If



End Sub



Private Sub CommandButton1_Click()

  Unload Me

    

End Sub



Private Sub OptionButton6_Click()

  If boolClick = False Then Exit Sub

  oPfad = Environ("Windir") & "\" & oFile

  System.PrivateProfileString(oPfad, Section:=secPrint, Key:=Var15) = "JA"



End Sub



Private Sub OptionButton7_Click()

  If boolClick = False Then Exit Sub

  oPfad = Environ("Windir") & "\" & oFile

  System.PrivateProfileString(oPfad, Section:=secPrint, Key:=Var15) = "NEIN"



End Sub



Private Sub OptionButton8_Click()

  If boolClick = False Then Exit Sub

  oPfad = Environ("Windir") & "\" & oFile

  System.PrivateProfileString(oPfad, Section:=secPrint, Key:=Var16) = "JA"

  System.PrivateProfileString(oPfad, Section:=secPrint, Key:=Var56) = ""

  CheckBox1.Enabled = False



End Sub



Private Sub OptionButton9_Click()

  If boolClick = False Then Exit Sub

  oPfad = Environ("Windir") & "\" & oFile

  System.PrivateProfileString(oPfad, Section:=secPrint, Key:=Var16) = "NEIN"

  CheckBox1.Enabled = True



End Sub



Private Sub UserForm_Activate()

  On Error Resume Next

  Dim strButton1 As String, strButton2 As String, strButton3 As String

  boolClick = False

  oPfad = Environ("Windir") & "\" & oFile

  'Stellt den Original Druckdialog im Menu an oder aus

  strButton1 = System.PrivateProfileString(oPfad, Section:=secPrint, Key:=Var15)

  If strButton1 = "JA" Then

    OptionButton6.Value = True

    OptionButton7.Value = False

  ElseIf strButton1 = "NEIN" Then

    OptionButton6.Value = False

    OptionButton7.Value = True

  Else

    System.PrivateProfileString(oPfad, Section:=secPrint, Key:=Var15) = "JA"

    OptionButton6.Value = True

    OptionButton7.Value = False

  End If

  'Stellt den Original Druckdialog in der Symbolleiste an oder aus

  strButton2 = System.PrivateProfileString(oPfad, Section:=secPrint, Key:=Var16)

  If strButton2 = "JA" Then

    OptionButton8.Value = True

    OptionButton9.Value = False

  ElseIf strButton2 = "NEIN" Then

    OptionButton8.Value = False

    OptionButton9.Value = True

  Else

    System.PrivateProfileString(oPfad, Section:=secPrint, Key:=Var16) = "JA"

    OptionButton8.Value = True

    OptionButton9.Value = False

  End If

  strButton3 = System.PrivateProfileString(oPfad, Section:=secPrint, Key:=Var56)

    If strButton3 <> "JA" Then

      CheckBox1.Value = False

    Else

      CheckBox1.Value = True

    End If

    boolClick = True

  If strButton2 = "JA" Then

    System.PrivateProfileString(oPfad, Section:=secPrint, Key:=Var56) = ""

    CheckBox1.Enabled = False

  Else

    CheckBox1.Enabled = True

  End If

  

End Sub 





Code eingefügt mit Syntaxhighlighter 3.0











      

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

' Module    : basAutoExec

' DateTime  : 25.11.2004 11:07

' Author    : Thomas Brill

' Purpose   :

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

' INI-Datei darin werden die Einstellungen der Druckoptionen gespeichert.

Public Const oFile = "Addins.ini"

' Konstanten für Druckdialoge

Private oExecPfad As String

Public aktuellerDrucker As String

Public frmDruckerFlag As Boolean

Public pBool As Boolean

' Konstanten für Dokumentenschutz

Public exitFlag As Boolean

Public protectFlag As Boolean

'

Public Const Var15 = "Standard"

Public Const Var16 = "StandardIcon"

Public Const Var21 = "frmEmpfaenger.chkTextDrucken"

Public Const Var53 = "PrintFax"

Public Const Var54 = "Papierfaecher"

'Wert 1 besagt das Formular Papierfächer schon eimal aufgerufen wurde?

Public Const Var55 = "Printer"

Public Const Var56 = "AutoPapierFach"

'Public Const frmWOpt = "frmWordOptionen"

Public Const secPrint = "Drucken"

Public Const frmOpt = "frmOptionen"

Public Const frmEmp = "frmEmpfaenger"

Public oDoc As Document

Public TMRange As Variant

Public oRange1 As Range, oRange2 As Range

Public oPfad As String, chkPfad As String, strDName As String, strDFile As String

Private RC

Public Errortext

Public chkINI



Sub AutoExec()

    Dim sPath1 'As String

    sPath1 = Options.DefaultFilePath(wdToolsPath)

    sPath1 = sPath1 & "\Startup\Druck.dot"

    Application.Templates(sPath1).Saved = True

    

End Sub

'Ersetzt den Origialen Druckdialog im Menü

Sub DateiDrucken()

   Dim oPfad As String, pType As Variant

   Set oDoc = ActiveDocument

   protectFlag = False

   frmDruckerFlag = False

   'Der Aktuelle Drucker wird ermittelt

   aktuellerDrucker = ActivePrinter

   If DocVarCheckExistence(Var21) Then

     If oDoc.Variables(Var21).Value = "-1" Then Options.PrintHiddenText = False

     If oDoc.Variables(Var21).Value = "0" Then Options.PrintHiddenText = True

   End If

   If ActiveDocument.FormFields.Count = 0 Then

     GoTo FormEnd    'MsgBox "Es sind keine Formfelder vorhanden"

   Else

     If oDoc.ProtectionType = wdNoProtection Then

       ActiveDocument.Protect Type:=wdAllowOnlyFormFields, NoReset:=True, Password:=""

     End If

   End If

   

FormEnd:

   'Es wird in der INI-Datei geprüft ob die Standard Option aktiv ist und zu Ihr gewechselt.

   oPfad = Environ("Windir") & "\" & oFile

   pType = System.PrivateProfileString(oPfad, Section:="Drucken", Key:=Var15)

   If pType <> "NEIN" Then

      Call DruckOriginal

      Exit Sub

   End If

   If oDoc.ProtectionType <> wdNoProtection Then

     protectFlag = True

   End If

   

Start:

   If protectFlag = False Then      'Das Dokument ist nicht Schreibgeschützt

     If ActiveDocument.PageSetup.DifferentFirstPageHeaderFooter = True Then

     

        Call VergleichPrinter

        

        If Not DocVarCheckExistence(Var54) Then

        

           Call DruckerPapierfaecherShow

           

           If frmDruckerFlag = False Then GoTo NoPrint

        End If

     Else

       frmDruckerFlag = True

     End If

   Else

       frmDruckerFlag = True

   End If

   

   'Der Dialog "Drucken" wird aufgerufen

   With Dialogs(wdDialogFilePrint)

      RC = .Display

      If RC = 0 Then

         GoTo EndePrint

      ElseIf RC = -2 Then

         If ActivePrinter <> aktuellerDrucker Then

         

           Call VergleichPrinter

           

           If protectFlag = False Then      'Das Dokument ist nicht Schreibgeschützt

             If ActiveDocument.PageSetup.DifferentFirstPageHeaderFooter = True Then

               If Not DocVarCheckExistence(Var54) Then

               

                 Call DruckerPapierfaecherShow

                 

                 If frmDruckerFlag = False Then GoTo NoPrint

                 .Execute

               End If

             End If

           End If

         End If

         GoTo EndePrint

      ElseIf RC = -1 Then

         'If frmDruckerFlag = True Then

           .Execute

           GoTo EndePrint

         'End If

         'GoTo NoPrint

      End If

   End With

   

ErrorHandler:    ' Fehlerbehandlungsroutine.

    Select Case Err.Number    ' Fehlernummer auswerten. 5141 Ungültiger Druckbereich.

     Case 4605

       Selection.EndKey Unit:=wdStory

     Case 5097   'Unzureichender Arbeitsspeicher. Speichern Sie jetzt Ihr Dokument.

       ActiveDocument.Save

       Resume

     Case 5155

       MsgBox "Diese Datei ist schreibgeschützt:" & ActiveDocument.name _

       & "Speicher Sie das Dokument unter einem anderen Namen!", vbInformation

     Case 5633

       Dim Zeit1

       Zeit1 = Time    ' Aktuelle Systemzeit zurückgeben.

       MsgBox "Bitte geben Sie ein gültiges Datum oder eine gültige Uhrzeit ein.", vbInformation

     Case Else

       Errortext = "Modul_DateiDruckenStandard"

       Call MsgError(Err.Number, Err.Description, Errortext)

       GoTo NoPrint

    End Select

    Resume    ' Ausführung in der Zeile fortsetzen, die den Fehler ausgelöst hat.

   

EndePrint:

   ActivePrinter = aktuellerDrucker

   Call DocVariablePrinter(ActivePrinter)

   

NoPrint:

   

End Sub

'Ersetzt den Origialen Druckdialog in der Symbolleiste

Sub DateiDruckenStandard()

   Dim oPfad As String, pType As Variant

   protectFlag = False

   pBool = False

   Set oDoc = ActiveDocument

   

   If DocVarCheckExistence(Var21) Then

     If oDoc.Variables(Var21).Value = "-1" Then Options.PrintHiddenText = False

     If oDoc.Variables(Var21).Value = "0" Then Options.PrintHiddenText = True

   End If

   

   If ActiveDocument.FormFields.Count = 0 Then

     GoTo FormEnd  'MsgBox "Es sind keine Formfelder vorhanden"

   Else

     If oDoc.ProtectionType = wdNoProtection Then

       ActiveDocument.Protect Type:=wdAllowOnlyFormFields, NoReset:=True, Password:=""

     End If

     'MsgBox "Es sind Formfelder vorhanden"

   End If

   

FormEnd:

   'Es wird in der INI-Datei geprüft ob die Standard Option aktiv ist.

   oPfad = Environ("Windir") & "\" & oFile

   pType = System.PrivateProfileString(oPfad, Section:="Drucken", Key:=Var16)

   If pType <> "NEIN" Then

   

      GoTo Sprungende

      

      Exit Sub

   End If

   

   On Error GoTo ErrorHandler

   If oDoc.ProtectionType <> wdNoProtection Then

   

     Call DruckOriginal

     

     Exit Sub

   Else

     GoTo Start

   End If



Start:

   On Error GoTo ErrorHandler

   If ActiveDocument.PageSetup.DifferentFirstPageHeaderFooter = False Then

     

     Call DruckOriginal

     

     Exit Sub

   Else

     

     Call VergleichPrinter

     

     If System.PrivateProfileString(oPfad, Section:=secPrint, Key:=Var56) = "JA" Then

        Call SelectPrinter(ActivePrinter, pBool)

     End If

     If Not DocVarCheckExistence(Var54) Then

        If pBool = False Then

        

          Call DruckerPapierfaecherShow  'Das Dokument ist nicht Schreibgeschützt

          

        End If

        

        Call DocVariablePrinter(ActivePrinter)

        

        If frmDruckerFlag = False Then GoTo NoPrint

     End If

   End If

   

   GoTo Sprungende

   

ErrorHandler:    ' Fehlerbehandlungsroutine.

   Select Case Err.Number    ' Fehlernummer auswerten.

     'Case 28    'Nicht genügend Stapelspeicher

     Case 4605

       Selection.EndKey Unit:=wdStory

     Case 5097   'Unzureichender Arbeitsspeicher. Speichern Sie jetzt Ihr Dokument.

       ActiveDocument.Save

       Resume

     Case 5155

       MsgBox "Diese Datei ist schreibgeschützt:" & ActiveDocument.name _

       & "Speicher Sie das Dokument unter einem anderen Namen!", vbInformation

     Case 5633

       MsgBox "Bitte geben Sie ein gültiges Datum oder eine gültige Uhrzeit ein.", vbInformation

     Case Else

       Errortext = "Modul_DateiDruckenStandard"

       Call MsgError(Err.Number, Err.Description, Errortext)

       GoTo NoPrint

    End Select

    Resume    ' Ausführung in der Zeile fortsetzen, die den Fehler ausgelöst hat.

  

Sprungende:

   ActiveDocument.PrintOut

   

NoPrint:



End Sub

'Stellt den Origialen Druckdialog der Menüleiste wieder her

Sub DruckOriginal()

   With Dialogs(wdDialogFilePrint)

      RC = .Display

      If RC = 0 Then Exit Sub

      .Execute

   End With
geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: