OK, dit wordt weer een kanjer van een post. Wie geen bijlagen wil/kan/mag downloaden, heeft meteen alles bij de hand.
Speel eens effe met de bijlage.
BESCHRIJVING
USERFORM met
1 combobox
2 Labels (default_printer, pdf_printer)
4 CommandButtons (btn1, btn2, btn3, btn4)
(+ wat frames voor een mooiere indeling en "titels")
UserForm MODULE
Option Explicit
Private Declare Function lstrcpy Lib "kernel32.dll" _
Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Private Declare Function lstrlen Lib "kernel32.dll" _
Alias "lstrlenA" (ByVal lpString As Long) As Long
Private Declare Function EnumPrinters Lib "winspool.drv" _
Alias "EnumPrintersA" (ByVal PrI_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
Private Declare Function GetProfileString& Lib "Kernel32" Alias "GetProfileStringA" _
(ByVal lpApplicationName As String, ByVal lpKeyName As String, _
ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long)
Const PRINTER_ENUM_LOCAL = &H2
Private Type PrinterInfo
PrI_Flags As Long
PrI_Description As String
PrI_Name As String
PrI_Comment As String
End Type
Private Sub ComboBox1_Change()
update_btns
End Sub
Private Sub btn1_Click()
default_printer.Caption = ComboBox1
update_btns
End Sub
Private Sub btn2_Click()
pdf_printer.Caption = ComboBox1
update_btns
End Sub
Private Sub btn3_Click()
Unload Me
End Sub
Private Sub btn4_Click()
Range("default_printer") = default_printer
Range("pdf_printer") = pdf_printer
Unload Me
End Sub
Private Sub UserForm_Initialize()
default_printer = Range("default_printer")
pdf_printer = Range("pdf_printer")
ListPrinters
update_btns
End Sub
Private Sub update_btns()
Dim ok As Boolean
ok = ComboBox1 <> vbNullString
btn1.Enabled = ok And default_printer <> ComboBox1
btn2.Enabled = ok And pdf_printer <> ComboBox1
If Not ok Then Exit Sub
btn1.Caption = IIf(default_printer.Caption = vbNullString, "SET", "REPLACE")
btn2.Caption = IIf(pdf_printer.Caption = vbNullString, "SET", "REPLACE")
End Sub
Private Sub ListPrinters()
Dim longbuffer() As Long
Dim printinfo() As PrinterInfo
Dim numbytes As Long
Dim numneeded As Long
Dim numprinters As Long
Dim c As Integer, retval As Long
Dim PrinterList As String
Dim FullPrinterName As String
numbytes = 3076
ReDim longbuffer(0 To numbytes / 4) As Long
retval = EnumPrinters(PRINTER_ENUM_LOCAL, "", 1, longbuffer(0), numbytes, numneeded, numprinters)
If retval = 0 Then
numbytes = numneeded
ReDim longbuffer(0 To numbytes / 4) As Long
retval = EnumPrinters(PRINTER_ENUM_LOCAL, "", 1, longbuffer(0), numbytes, numneeded, numprinters)
If retval = 0 Then
MsgBox "Could not successfully enumerate the printers."
End
End If
End If
If numprinters <> 0 Then ReDim printinfo(0 To numprinters - 1) As PrinterInfo
For c = 0 To numprinters - 1
With printinfo(c)
.PrI_Name = Space(lstrlen(longbuffer(4 * c + 2)))
retval = lstrcpy(.PrI_Name, longbuffer(4 * c + 2))
End With
Next c
With Me.ComboBox1
.Clear
For c = 0 To numprinters - 1
GetFullPrinterName printinfo(c).PrI_Name, FullPrinterName
.AddItem FullPrinterName
Next c
End With
'**** DELETE THIS TEST ****
MsgBox "5 dummy printernames are added to test." & vbLf & "Delete that part of the code.", 64, "DUMMY PRINTERS"
Dim i As Long
For i = ComboBox1.ListCount To ComboBox1.ListCount + 4
ComboBox1.AddItem "Printer" & i & " on LPT" & i
Next i
'**** END DELETE ****
End Sub
Private Sub GetFullPrinterName(PrinterName As String, FullPrinterName)
Dim buf As String
Dim retvalue As Long
Dim DriverName As String
Dim PortName As String
Dim strKeyWord As String
buf = Space(1024)
retvalue = GetProfileString("PrinterPorts", PrinterName, "", buf, Len(buf))
GetDriverAndPort buf, DriverName, PortName
If Len(DriverName) > 0 And Len(PortName) > 0 Then
GetKeyWord Application.ActivePrinter, strKeyWord
FullPrinterName = PrinterName & strKeyWord & PortName
End If
End Sub
Private Sub GetDriverAndPort(ByVal buf As String, DriverName As String, PortName As String)
Dim i1 As Long
Dim i2 As Long
'driver name starts string till ","
i1 = InStr(buf, ",")
If i1 > 0 Then
DriverName = Left(buf, i1 - 1)
i2 = InStr(i1 + 1, buf, ",")
If i2 > 0 Then
PortName = Mid(buf, i1 + 1, i2 - i1 - 1)
End If
End If
End Sub
Private Sub GetKeyWord(ActPrinter, KeyWord)
'needs input like "PrinterX on PTLx:"
'retrieving " on " from this string (Spanish = " en ", Dutch = " op ", ...)
Dim il As Long
Dim i1 As Long
Dim i2 As Long
'StrReverse not compatible with all versions: so using reverse loop
For il = Len(ActPrinter) To 1 Step -1
If Mid(ActPrinter, il, 1) = Space(1) Then
If i2 = 0 Then
i2 = il
Else
i1 = il
Exit For
End If
End If
Next il
'with spaces at start & end
If i1 * i2 Then KeyWord = Mid(ActPrinter, i1, i2 - i1 + 1)
End Sub
WERKBLAD met
2 benoemde cellen (default_printer, pdf_printer)
3 CommandButtons (CommandButton1, ...2, ...3)
WERKBLADMODULE
Option Explicit
Private Sub CommandButton1_Click()
SetPrinters_Form.Show
End Sub
Private Sub CommandButton2_Click()
'Application.ActivePrinter = Range("default_printer").Text
Me.PrintOut Copies:=1, ActivePrinter:=Range("default_printer").Text, Collate:=True
End Sub
Private Sub CommandButton3_Click()
'Application.ActivePrinter = Range("pdf_printer").Text
Me.PrintOut Copies:=1, ActivePrinter:=Range("pdf_printer").Text, Collate:=True
End Sub
Er staan wat testlijnen in de userformmodule, zodat iedereen die 'maar' 1 printer heeft, kan zien wat er gebeurt. Het lijkt me heel duidelijk welke lijnen dit zijn: zo kan je ze verwijderen.
Ik koos er voor om alle code onder te brengen binnen de userformmodule, zodat je bij 'verhuis' meteen alle bagage mee hebt.
veel zon gewenst :-)
Erik
