Option Compare Database
Option Explicit
'Verwendet mdlPrinterDefault
'Verwendet mdlINIDatei
Private Const LOWERLIMIT As Long = -32768
Private Const UPPERLIMIT As Long = 32767
Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Private Sub SetDefault_Click()
Dim OSInfo As OSVERSIONINFO
Dim retValue As Integer
Dim x As String
Dim r As Long
OSInfo.dwOSVersionInfoSize = 148
OSInfo.szCSDVersion = Space$(128)
retValue = GetVersionExA(OSInfo)
If OSInfo.dwMajorVersion = 3 And OSInfo.dwMinorVersion = 51 And _
OSInfo.dwPlatformId = 2 Then
If MsgBox("Change Deafult Printer / Fax to '" & Me!List1 & "'." & vbCrLf & vbCrLf & _
"Are You sure?" & vbCrLf & vbCrLf & "By changing Default Printer / Fax here, " & _
"You change it on the System.", (vbYesNo + vbQuestion), "Win NT 3.51 Printer Change") = vbYes Then
DoCmd.Hourglass (True)
Call WinNTSetDefaultPrinter(Me!List1)
x = GetProfile("win.ini", "Windows", "Device")
r = InStr(1, x, ",")
If r > 0 Then
x = Left(x, r - 1)
End If
Me!DefPrint = x
If IsLoaded("Print") Then
Forms!Print!DefPrint = " " & x
End If
If IsLoaded("TC") Then
Forms!TC!DefPrint = " " & x
End If
Else
Exit Sub
End If
ElseIf OSInfo.dwMajorVersion = 4 _
And OSInfo.dwPlatformId = 1 Then
If MsgBox("Change Deafult Printer / Fax to '" & Me!List1 & "'." & vbCrLf & vbCrLf & _
"Are You sure?" & vbCrLf & vbCrLf & "By changing Default Printer / Fax here, " & _
"You change it on the System.", (vbYesNo + vbQuestion), "Win 95 / 98 Printer Change") = vbYes Then
DoCmd.Hourglass (True)
Call Win95SetDefaultPrinter(Me!List1)
x = GetProfile("win.ini", "Windows", "Device")
r = InStr(1, x, ",")
If r > 0 Then
x = Left(x, r - 1)
End If
Me!DefPrint = x
If IsLoaded("Print") Then
Forms!Print!DefPrint = " " & x
End If
If IsLoaded("TC") Then
Forms!TC!DefPrint = " " & x
End If
Else
Exit Sub
End If
ElseIf OSInfo.dwMajorVersion >= 4 And OSInfo.dwMinorVersion >= 0 _
And OSInfo.dwPlatformId = 2 Then
If MsgBox("Change Deafult Printer / Fax to '" & Me!List1 & "'." & vbCrLf & vbCrLf & _
"Are You sure?" & vbCrLf & vbCrLf & "By changing Default Printer / Fax here, " & _
"You change it on the System.", (vbYesNo + vbQuestion), "Win NT 4 / 2000 Printer Change") = vbYes Then
DoCmd.Hourglass (True)
Call WinNTSetDefaultPrinter(Me!List1)
x = GetProfile("win.ini", "Windows", "Device")
r = InStr(1, x, ",")
If r > 0 Then
x = Left(x, r - 1)
End If
Me!DefPrint = " " & x
If IsLoaded("Print") Then
Forms!Print!DefPrint = " " & x
End If
If IsLoaded("TC") Then
Forms!TC!DefPrint = " " & x
End If
Else
Exit Sub
End If
End If
End Sub
Private Sub Settings_Click()
On Error GoTo err_list1_click
Dim xxnam As String
Dim PD As PRINTER_DEFAULTS
Dim RetVal As Long, hPrinter As Long
PD.pDatatype = 0
PD.DesiredAccess = PRINTER_ALL_ACCESS
PD.pDevMode = 0
xxnam = Trim(Me!DefPrint.Value)
RetVal = OpenPrinter(xxnam, hPrinter, PD)
If RetVal = 0 Then
MsgBox "Open Printer Settings: Unsuccessfully!"
Else
RetVal = PrinterProperties(hWndAccessApp, hPrinter)
RetVal = ClosePrinter(hPrinter)
End If
End Sub
Private Sub Form_Load()
If Me.List1 <> Trim(Me.DefPrint) Then
Me.SetDefault.Enabled = True
Else
Me.SetDefault.Enabled = False
End If
Dim r As Long
Dim Buffer As String, x As String
'Dieser Code füllt die Listbox mit allen verfügbaren Druckern. Der Anwender
'kann per Doppelklick einen Drucker auswählen und zum Standarddrucker machen.
'Get the list of available printers from WIN.INI
Buffer = Space(8192)
r = GetProfileString("PrinterPorts", vbNullString, "", Buffer, Len(Buffer))
'Display the list of printer in the list box List1
'ParseList Me!List1, Buffer
Buffer = Trim(Buffer)
x = ParseList(Buffer)
Me!List1.RowSource = x
x = GetProfile("win.ini", "Windows", "Device")
r = InStr(1, x, ",")
If r > 0 Then
x = Left(x, r - 1)
End If
Me.DefPrint = " " & x
Me.List1 = x
End Sub
Private Function ParseList(ByVal Buffer As String) As String
Dim i As Integer, ZStr As String
ParseList = ""
Do While (Right(Buffer, 1) = Chr(0) Or Right(Buffer, 1) = " " Or Right(Buffer, 1) = ";")
Buffer = Left(Buffer, Len(Buffer) - 1)
Loop
Do
i = InStr(Buffer, Chr(0))
ZStr = ""
If i > 0 Then
ZStr = Left(Buffer, i - 1)
Buffer = Mid(Buffer, i + 1)
Else
ZStr = Buffer
Buffer = ""
End If
If Len(ParseList) > 0 Then
ParseList = ParseList & ";" & ZStr
Else
ParseList = ZStr
End If
Loop While i > 0
End Function
Private Sub List1_Click()
If Me.List1 <> Trim(Me.DefPrint) Then
Me.Command7.Enabled = True
Else
Me.Command7.Enabled = False
End If
End Sub
Private Sub Win95SetDefaultPrinter(Druckername As String)
Dim handle As Long 'Drucker Handle
Dim PrinterName As String
Dim PD As PRINTER_DEFAULTS
Dim x As Long
Dim need As Long ' benötigte Bytes
Dim pi5 As PRINTER_INFO_5 ' eigene PRINTER_INFO Struktur
Dim LastError As Long
' ausgewählten Drucker bestimmen
'PrinterName = List1.List(List1.ListIndex)
PrinterName = Druckername
' none - exit
If PrinterName = "" Then
Exit Sub
End If
' PRINTER_DEFAULTS members setzen
PD.pDatatype = 0&
PD.DesiredAccess = PRINTER_ALL_ACCESS
' Drucker Handle bestimmen
x = OpenPrinter(PrinterName, handle, PD)
' failed the open
If x = False Then
'Error Handler Code wird hier plaziert
Exit Sub
End If
' Aufruf von GetPrinter() zum Vorbereiten von (PRINTER_INFO_5) Information
' um die Anzahl der benötigten Bytes zu bestimmen
x = GetPrinter(handle, 5, ByVal 0&, 0, need)
'GetLastError() Aufrufe schlagen hier fehl mit
' 122 - ERROR_INSUFFICIENT_BUFFER
ReDim t((need \ 4)) As Long
' zweiter administrativer Aufruf von GetPrinter
x = GetPrinter(handle, 5, t(0), need, need)
' auf Gültigkeit überprüfen
If x = False Then
'Error Handler Code wird hier plaziert
Exit Sub
End If
'Struktur schreiben um SetPrinter erfolgreich auszuführen.
' PtrCtoVbString kopiert den Inhalt des Speichers der beiden
' String Pointer des t() arrays in einen Visual Basic String.
' Die anderen 3 Elemente sind einfache DWORDS (Long Integer)
' und benötigen dementsprechend keine Konvertierung.
pi5.pPrinterName = PtrCtoVbString(t(0))
pi5.pPortName = PtrCtoVbString(t(1))
pi5.Attributes = t(2)
pi5.DeviceNotSelectedTimeout = t(3)
pi5.TransmissionRetryTimeout = t(4)
' Flag für Standarddrucker setzen
pi5.Attributes = PRINTER_ATTRIBUTE_DEFAULT
' call SetPrinter to set it
x = SetPrinter(handle, 5, pi5, 0)
' Ausführung überprüfen
If x = False Then
MsgBox "SetPrinterFailed. Error code: " & GetLastError()
Exit Sub
End If
' Handle wieder schließen
ClosePrinter (handle)
End Sub
Private Sub WinNTSetDefaultPrinter(Druckername As String)
Dim Buffer As String
Dim DeviceName As String
Dim DriverName As String
Dim PrinterPort As String
Dim PrinterName As String
Dim r As Long
'If List1.ListIndex > -1 Then
If Len(Nz(Druckername)) > 0 Then
'Druckerinformationen des aktuellen Standarddruckers
'aus der WIN.INI bestimmen
Buffer = Space(1024)
' PrinterName = List1.Text
PrinterName = Druckername
r = GetProfileString("PrinterPorts", PrinterName, "", _
Buffer, Len(Buffer))
'Treibernamen und Anschluß aus Puffer parsen
GetDriverAndPort Buffer, DriverName, PrinterPort
If DriverName <> "" And PrinterPort <> "" Then
SetDefaultPrinter Druckername, DriverName, PrinterPort
End If
End If
End Sub
Private Function PtrCtoVbString(Add As Long) As String
Dim sTemp As String * 512, x As Long
x = lstrcpy(sTemp, Add)
If (InStr(1, sTemp, Chr(0)) = 0) Then
PtrCtoVbString = ""
Else
PtrCtoVbString = Left(sTemp, InStr(1, sTemp, Chr(0)) - 1)
End If
End Function
Private Sub SetDefaultPrinter(ByVal PrinterName As String, _
ByVal DriverName As String, ByVal PrinterPort As String)
Dim DeviceLine As String
Dim r As Long
Dim L As Long
DeviceLine = PrinterName & "," & DriverName & "," & PrinterPort
' Neue Drucker Informationen im [WINDOWS] Abschnitt der WIN.INI speichern
r = WriteProfileString("windows", "Device", DeviceLine)
' Alle Applikationen müssen die WIN.INI neu einlesen:
L = SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, "windows")
End Sub
Private Sub GetDriverAndPort(ByVal Buffer As String, DriverName As String, _
PrinterPort As String)
On Error GoTo err_list1_click
Dim iDriver As Integer
Dim iPort As Integer
DriverName = ""
PrinterPort = ""
'Der Treibername steht am Anfang des "Komma"-terminierten Strings
iDriver = InStr(Buffer, ",")
If iDriver > 0 Then
'Treibernamen extrahieren
DriverName = Left(Buffer, iDriver - 1)
'Nach dem Treibernamen folgt der Anschluß
iPort = InStr(iDriver + 1, Buffer, ",")
If iPort > 0 Then
'Anschluß bestimmen
PrinterPort = Mid(Buffer, iDriver + 1, _
iPort - iDriver - 1)
End If
End If
End Sub
Private Sub DefPrint_DblClick(Cancel As Integer)
Dim xxnam As String
Dim PD As PRINTER_DEFAULTS
Dim RetVal As Long, hPrinter As Long
PD.pDatatype = 0
PD.DesiredAccess = PRINTER_ALL_ACCESS
PD.pDevMode = 0
xxnam = Trim(Me!DefPrint.Value)
RetVal = OpenPrinter(xxnam, hPrinter, PD)
If RetVal = 0 Then
MsgBox "Otvori pisa?: Neuspješno!"
Else
RetVal = PrinterProperties(hWndAccessApp, hPrinter)
RetVal = ClosePrinter(hPrinter)
End If
End Sub
