Kode til udskrift på bestemt netværksprinter

Denne er lidt lang, men har hjulpet mig mange gange.


Option Explicit

Public Const PRINTER_ENUM_CONNECTIONS = &H4
Public Const PRINTER_ENUM_LOCAL = &H2

Public Type PRINTER_INFO_1
  flags As Long
  pDescription As String
  pName As String
  pComment As String
End Type

Public Type PRINTER_INFO_4
  pPrinterName As String
  pServerName As String
  Attributes As Long
End Type

Public Declare Function EnumPrinters Lib "winspool.drv" Alias _
  "EnumPrintersA" (ByVal flags As Long, ByVal name As String, _
  ByVal Level As Long, pPrinterEnum As Long, ByVal cdBuf As Long, _
  pcbNeeded As Long, pcReturned As Long) As Long
Public Declare Function PtrToStr Lib "kernel32" Alias "lstrcpyA" _
  (ByVal retval As String, ByVal Ptr As Long) As Long
Public Declare Function StrLen Lib "kernel32" Alias "lstrlenA" _
  (ByVal Ptr As Long) As Long

Function EnumeratePrinters4() As Collection

'This is the enumeration of the printers bit
'Code has all been nicked from
'Microsoft KnowledgeBase article Q166008
'Returns a collection of all printers installed
'on the local PC

Dim success As Boolean, cbRequired As Long, cbBuffer As Long
Dim Buffer() As Long, nEntries As Long
Dim I As Long, pName As String, SName As String
Dim Attrib As Long, Temp As Long
Dim strPrinters As String

  cbBuffer = 3072
 
  ReDim Buffer((cbBuffer \ 4) - 1) As Long
 
  success = EnumPrinters(PRINTER_ENUM_CONNECTIONS Or _
                          PRINTER_ENUM_LOCAL, _
                          vbNullString, _
                          4, _
                          Buffer(0), _
                          cbBuffer, _
                          cbRequired, _
                          nEntries)
  If success Then
      If cbRequired > cbBuffer Then
          cbBuffer = cbRequired
          Debug.Print "Buffer too small. Trying again with " & _
          cbBuffer & " bytes."
          ReDim Buffer(cbBuffer \ 4) As Long
          success = EnumPrinters(PRINTER_ENUM_CONNECTIONS Or _
                                  PRINTER_ENUM_LOCAL, _
                                  vbNullString, _
                                  4, _
                                  Buffer(0), _
                                  cbBuffer, _
                                  cbRequired, _
                                  nEntries)
          If Not success Then
              Debug.Print "Error enumerating printers."
              Exit Function
          End If
      End If
     
      Dim colPrinters As Collection
     
      Set colPrinters = New Collection
     
      For I = 0 To nEntries - 1
          pName = Space$(StrLen(Buffer(I * 3)))
          Temp = PtrToStr(pName, Buffer(I * 3))
          SName = Space$(StrLen(Buffer(I * 3 + 1)))
          Temp = PtrToStr(SName, Buffer(I * 3 + 1))
          Attrib = Buffer(I * 3 + 2)
          colPrinters.Add pName
      Next I
  Else
      Debug.Print "Error enumerating printers."
  End If
 
  Set EnumeratePrinters4 = colPrinters

End Function

Public Function GetFullPrinterName(strQName As String) As String
Dim strPrinter As String
Dim varPrinter As Variant
Dim colPrinters As Collection
Dim iPNum As Integer
On Error GoTo GetFullPrinterName_Err

  iPNum = 0
  'Get a list of installed printers
  Set colPrinters = EnumeratePrinters4()
 
  'Find the specific printer we want
  'Looks for a particular set of characters that we know
  'will be in the printer name if its the one we want
  For Each varPrinter In colPrinters
      If InStr(1, varPrinter, strQName) Then
          strPrinter = varPrinter
          Exit For
      End If
  Next
 
  'Report back if there's no hit
  If strPrinter = "" Then
      MsgBox "Sorry, We were unable to find the appropriate printer.", vbInformation, "Print"
      Exit Function
  End If
 
  'Otherwise try to point to the new printer
  ActivePrinter = strPrinter & " på ne" & Format(iPNum, "00") & ":"
  GetFullPrinterName = ActivePrinter
  iPNum = 10

Exit_Here:
  Exit Function
 
GetFullPrinterName_Err:
  iPNum = iPNum + 1
  If iPNum > 10 Then
      MsgBox "Error Number: " & Err.Number & vbCrLf & _
              "Description: " & Err.Description
      GoTo Exit_Here
  Else
      Resume
  End If

End Function



Sub ChangeActivePrinter()
'This macro change active printer to Canon LBP-1260.
' Modified 16/05/2003 by Mik Agergaard

  Static x As Integer
  Dim Cancel As Boolean
  Dim defaultPrinter As String
  Dim newPrinter As String
  On Error GoTo Errhandler
 
  'Save the current printer assignment
  defaultPrinter = Application.ActivePrinter
 
  'Try to set the printer to the main lobby Canon LBP-1260.
  newPrinter = GetFullPrinterName("Adobe")
 
  'If the desired printer could not be found, leave.
  If newPrinter = "" Then
      Exit Sub
  End If
  ActivePrinter = newPrinter
 
  'Unmark colate in printdialog
    'If x = 2 Then
    '    x = 1
    '    Cancel = True
    '    Exit Sub
    'End If
    'x = 1
    'Application.SendKeys "{TAB}"
    'Application.SendKeys "s"
    'x = 2
   
    'Shows Print dialog
    Application.Dialogs(xlDialogPrint).Show
 
  'reset the printer back to the default
  Application.ActivePrinter = defaultPrinter
 
  GoTo ExitPoint
 
Errhandler:

  MsgBox "Write down this message and notify your system administrator:" & vbCrLf & _
      Err.Number & vbCrLf & Err.Description
  Resume Next
 
ExitPoint:
End Sub

Sorry,
Skulle lige ændres, til den rigtige printer.


Option Explicit

Public Const PRINTER_ENUM_CONNECTIONS = &H4
Public Const PRINTER_ENUM_LOCAL = &H2

Public Type PRINTER_INFO_1
  flags As Long
  pDescription As String
  pName As String
  pComment As String
End Type

Public Type PRINTER_INFO_4
  pPrinterName As String
  pServerName As String
  Attributes As Long
End Type

Public Declare Function EnumPrinters Lib "winspool.drv" Alias _
  "EnumPrintersA" (ByVal flags As Long, ByVal name As String, _
  ByVal Level As Long, pPrinterEnum As Long, ByVal cdBuf As Long, _
  pcbNeeded As Long, pcReturned As Long) As Long
Public Declare Function PtrToStr Lib "kernel32" Alias "lstrcpyA" _
  (ByVal retval As String, ByVal Ptr As Long) As Long
Public Declare Function StrLen Lib "kernel32" Alias "lstrlenA" _
  (ByVal Ptr As Long) As Long

Function EnumeratePrinters4() As Collection

'This is the enumeration of the printers bit
'Code has all been nicked from
'Microsoft KnowledgeBase article Q166008
'Returns a collection of all printers installed
'on the local PC

Dim success As Boolean, cbRequired As Long, cbBuffer As Long
Dim Buffer() As Long, nEntries As Long
Dim I As Long, pName As String, SName As String
Dim Attrib As Long, Temp As Long
Dim strPrinters As String

  cbBuffer = 3072
 
  ReDim Buffer((cbBuffer \ 4) - 1) As Long
 
  success = EnumPrinters(PRINTER_ENUM_CONNECTIONS Or _
                          PRINTER_ENUM_LOCAL, _
                          vbNullString, _
                          4, _
                          Buffer(0), _
                          cbBuffer, _
                          cbRequired, _
                          nEntries)
  If success Then
      If cbRequired > cbBuffer Then
          cbBuffer = cbRequired
          Debug.Print "Buffer too small. Trying again with " & _
          cbBuffer & " bytes."
          ReDim Buffer(cbBuffer \ 4) As Long
          success = EnumPrinters(PRINTER_ENUM_CONNECTIONS Or _
                                  PRINTER_ENUM_LOCAL, _
                                  vbNullString, _
                                  4, _
                                  Buffer(0), _
                                  cbBuffer, _
                                  cbRequired, _
                                  nEntries)
          If Not success Then
              Debug.Print "Error enumerating printers."
              Exit Function
          End If
      End If
     
      Dim colPrinters As Collection
     
      Set colPrinters = New Collection
     
      For I = 0 To nEntries - 1
          pName = Space$(StrLen(Buffer(I * 3)))
          Temp = PtrToStr(pName, Buffer(I * 3))
          SName = Space$(StrLen(Buffer(I * 3 + 1)))
          Temp = PtrToStr(SName, Buffer(I * 3 + 1))
          Attrib = Buffer(I * 3 + 2)
          colPrinters.Add pName
      Next I
  Else
      Debug.Print "Error enumerating printers."
  End If
 
  Set EnumeratePrinters4 = colPrinters

End Function

Public Function GetFullPrinterName(strQName As String) As String
Dim strPrinter As String
Dim varPrinter As Variant
Dim colPrinters As Collection
Dim iPNum As Integer
On Error GoTo GetFullPrinterName_Err

  iPNum = 0
  'Get a list of installed printers
  Set colPrinters = EnumeratePrinters4()
 
  'Find the specific printer we want
  'Looks for a particular set of characters that we know
  'will be in the printer name if its the one we want
  For Each varPrinter In colPrinters
      If InStr(1, varPrinter, strQName) Then
          strPrinter = varPrinter
          Exit For
      End If
  Next
 
  'Report back if there's no hit
  If strPrinter = "" Then
      MsgBox "Sorry, We were unable to find the appropriate printer.", vbInformation, "Print"
      Exit Function
  End If
 
  'Otherwise try to point to the new printer
  ActivePrinter = strPrinter & " på ne" & Format(iPNum, "00") & ":"
  GetFullPrinterName = ActivePrinter
  iPNum = 10

Exit_Here:
  Exit Function
 
GetFullPrinterName_Err:
  iPNum = iPNum + 1
  If iPNum > 10 Then
      MsgBox "Error Number: " & Err.Number & vbCrLf & _
              "Description: " & Err.Description
      GoTo Exit_Here
  Else
      Resume
  End If

End Function



Sub ChangeActivePrinter()
'This macro change active printer to Canon LBP-1260.
' Modified 16/05/2003 by Mik Agergaard

  Static x As Integer
  Dim Cancel As Boolean
  Dim defaultPrinter As String
  Dim newPrinter As String
  On Error GoTo Errhandler
 
  'Save the current printer assignment
  defaultPrinter = Application.ActivePrinter
 
  'Try to set the printer to the main lobby Canon LBP-1260.
  newPrinter = GetFullPrinterName("Canon LBP-1260")
 
  'If the desired printer could not be found, leave.
  If newPrinter = "" Then
      Exit Sub
  End If
  ActivePrinter = newPrinter
 
  'Unmark colate in printdialog
    'If x = 2 Then
    '    x = 1
    '    Cancel = True
    '    Exit Sub
    'End If
    'x = 1
    'Application.SendKeys "{TAB}"
    'Application.SendKeys "s"
    'x = 2
   
    'Shows Print dialog
    Application.Dialogs(xlDialogPrint).Show
 
  'reset the printer back to the default
  Application.ActivePrinter = defaultPrinter
 
  GoTo ExitPoint
 
Errhandler:

  MsgBox "Write down this message and notify your system administrator:" & vbCrLf & _
      Err.Number & vbCrLf & Err.Description
  Resume Next
 
ExitPoint:
End Sub

Hej Mip

Jeg havde problemer med at logge på Eksperten i går. Jeg ville ellers gerne takke dig og give dig nogle velfortjente points. Det får du hermed. Tusind tak.

Nu er jeg lidt ny i brugen af makro'er i excel og har måske lidt svært ved at gennemskue denne løsning af problemet, sidder nemlig selv med samme problem!

så hvis der evt er nogen der kan hjælpe med noget forklaring, eller evt har andre forslag til løsning af det ovennævnte problem

på forhånd tak