I've used this before, but you might to tweak it a little
1)
'Save orig printer default setting
PtrType = DefaultPrinterName
'chg defualt printer to Distiller
ufnSetDefaultPrinter ("Printer Named 2")
'print your report to Printer Named 2
DoCmd.OpenReport "Your_Report", acViewNormal
'Reset to orig default printer
ufnSetDefaultPrinter (PtrType)
2) Create a module and add
Public PtrType As String 'this string has to be public
3) Create another module named PrinterAPI and add
Option Compare Database
Option Explicit
'API functions
Private Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long
Private Declare Function WriteProfileString Lib "kernel32" Alias "WriteProfileStringA" (ByVal lpszSection As String, ByVal lpszKeyName As String, ByVal lpszString As String) As Long
Private Declare Function OpenPrinter Lib _
"winspool.drv" Alias "OpenPrinterA" (ByVal _
pPrinterName As String, phPrn As Long, _
pDefault As Any) As Long
Private Declare Function GetPrinter Lib _
"winspool.drv" Alias "GetPrinterA" (ByVal _
hPrinter As Long, ByVal Level As Long, _
pPrinter As Any, ByVal cbBuf As Long, _
pcbNeeded As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function SetPrinter Lib "winspool.drv" Alias "SetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, pPrinter As Any, ByVal Command As Long) As Long
Private Declare Function SetDefaultPrinter Lib "winspool.drv" Alias "SetDefaultPrinterA" (ByVal pszPrinter As String) As Long
Private Declare Function ClosePrinter Lib "winspool.drv" (ByVal hPrn As Long) As Long
Private Declare Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" (ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function EnumPrinters Lib "winspool.drv" Alias "EnumPrintersA" (ByVal Flags As Long, ByVal name As String, ByVal Level As Long, pPrinterEnum As Any, ByVal cdBuf As Long, pcbNeeded As Long, pcReturned As Long) As Long
Private Declare Function GetDefaultPrinter Lib "winspool.drv" Alias "GetDefaultPrinterA" (ByVal pszBuffer As String, pcchBuffer As Long) As Long
Private Declare Function lstrlenA Lib "kernel32" (ByVal lpString As Long) As Long
'Global variables needed for API functions
Private Const ERROR_INSUFFICIENT_BUFFER = 122&
Private Const PRINTER_ATTRIBUTE_DEFAULT As Long = &H4
Private Const HWND_BROADCAST = &HFFFF&
Private Const WM_SETTINGCHANGE = &H1A
' SendMessageTimeout values
Private Const SMTO_NORMAL = &H0
' dwPlatformId defines:
Private Const VER_PLATFORM_WIN32s = 0
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32_NT = 2
' Used to indicate what to enumerate
Private Const PRINTER_ENUM_DEFAULT As Long = &H1
' Some calls need to know OS version
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Sub test()
If ufnSetDefaultPrinter("HP LaserJet 5M - LPT 3") Then
MsgBox "It worked!"
Else
MsgBox "Failure!"
End If
End Sub
Function ufnSetDefaultPrinter(ByVal m_DevName As String) As Boolean
Dim os As OSVERSIONINFO
'm_DevName = NewPrinter 'currently "HP LaserJet 5M - LPT 3"
' Fork based on what OS we're running on...
os.dwOSVersionInfoSize = Len(os)
Call GetVersionEx(os)
Select Case os.dwPlatformId
Case VER_PLATFORM_WIN32_WINDOWS '95/98/ME
Call DefaultPrinterSet9x(m_DevName)
Case VER_PLATFORM_WIN32_NT
Call DefaultPrinterSetNT(os.dwMajorVersion, m_DevName)
End Select
' Return results based on test in IsDefault.
'Me.Refresh
ufnSetDefaultPrinter = IsDefault(m_DevName)
End Function
Private Sub DefaultPrinterSet9x(m_DevName As String)
Dim hPrn As Long
Dim BytesNeeded As Long
Dim Buffer() As Byte
Dim BytesUsed As Long
Dim Attributes As Long
' Get handle to printer.
Call OpenPrinter(m_DevName, hPrn, ByVal 0&)
If hPrn Then
' Call once to get proper buffer size.
Call GetPrinter(hPrn, 2, ByVal 0&, 0, BytesNeeded)
If Err.LastDllError = ERROR_INSUFFICIENT_BUFFER Then
' Size buffer and get printer data.
ReDim Buffer(0 To BytesNeeded - 1) As Byte
If GetPrinter(hPrn, 2, Buffer(0), BytesNeeded, BytesUsed) Then
' Set default printer attribute for this printer...
' Attributes is the 14th element in structure
Const AttribOffset As Long = 13 * 4&
Call CopyMemory(Attributes, Buffer(AttribOffset), 4&)
Attributes = Attributes Or PRINTER_ATTRIBUTE_DEFAULT
Call CopyMemory(Buffer(AttribOffset), Attributes, 4&)
' Send back updated structure.
If SetPrinter(hPrn, 2, Buffer(0), 0) Then
' Alert all other running applications,
' giving each 1/2 second to react.
Call SettingChangeAlert(500)
End If
End If
End If
Call ClosePrinter(hPrn)
End If
End Sub
Private Sub DefaultPrinterSetNT(ByVal MajorVersion As Long, ByVal m_DevName As String)
Dim os As OSVERSIONINFO
Dim BufSize As Long
Dim pPrinterName As Long
Dim Result As String
Dim comma As Long
' Use either SetDefaultPrinter (2k+) or WIN.INI (NT4).
If MajorVersion >= 5 Then
' Almost so easy as to be boring. <g>
Call SetDefaultPrinter(m_DevName)
Else ' (NT4 or less)
' Create satisfactory buffer.
BufSize = 1024
Result = Space$(BufSize)
' In NT, the old WIN.INI [PrinterPorts] section is mapped to
' HKCU\Software\Microsoft\Windows NT\CurrentVersion\PrinterPorts
' and we can just use GetProfileString to extract!
' Returns: "driver name,port,timeout1,timeout2"
If GetProfileString("PrinterPorts", ByVal m_DevName, "", Result, _
BufSize) Then
' Find 2nd comma and truncate
comma = InStr(Result, ",")
comma = InStr(comma + 1, Result, ",")
If comma Then
Result = Left$(Result, comma - 1)
' Prepend devname and write to registry.
Result = m_DevName & "," & Result
Call WriteProfileString("Windows", "device", Result)
' Alert all other running applications,
' giving each 1/2 second to react.
Call SettingChangeAlert(500)
End If
End If
End If
End Sub
Private Sub SettingChangeAlert(Optional ByVal Delay As Long = 500)
' Send out alert to notify all other running applications
' that a system setting has been updated.
Call SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, _
0, 0, SMTO_NORMAL, Delay, ByVal 0&)
End Sub
Public Property Get IsDefault(m_DevName As String) As Boolean
Dim DefPrn As String
' PRINTER_ATTRIBUTE_DEFAULT only works to *set* default.
DefPrn = DefaultPrinterName
IsDefault = (UCase$(DefPrn) = UCase$(m_DevName))
End Property
Function DefaultPrinterName() As String
' HOWTO: Retrieve and Set the Default Printer in Windows
'
http://support.microsoft.com/support.../q246/7/72.asp
' HOWTO: Get and Set the Default Printer in Windows
'
http://support.microsoft.com/support.../q135/3/87.asp
Dim os As OSVERSIONINFO
Dim Buffer() As Byte
Dim BufSize As Long
Dim pPrinterName As Long
Dim Returned As Long
Dim Result As String
' Get OS version info, so we know which way to fork.
os.dwOSVersionInfoSize = Len(os)
Call GetVersionEx(os)
If os.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then '95/98/ME
' Determine how big the buffer needs to be
Call EnumPrinters(PRINTER_ENUM_DEFAULT, vbNullString, 2, ByVal 0&, 0, BufSize, Returned)
If BufSize > 0 Then
' Size buffer accordingly
ReDim Buffer(0 To BufSize - 1) As Byte
' Call again to retrieve needed info
Call EnumPrinters(PRINTER_ENUM_DEFAULT, vbNullString, 2, Buffer(0), BufSize, BufSize, Returned)
' A pointer to the default printer name is
' returned at the 5th byte in the buffer.
Call CopyMemory(pPrinterName, Buffer(4), 4)
Result = PointerToStringA(pPrinterName)
End If
ElseIf os.dwPlatformId = VER_PLATFORM_WIN32_NT Then
' Create satisfactory buffer.
BufSize = 1024
Result = Space$(BufSize)
' Use either GetDefaultPrinter (2k+) or WIN.INI (NT4).
If os.dwMajorVersion >= 5 Then
If GetDefaultPrinter(Result, BufSize) Then
' Truncate at first NULL
Result = Left$(Result, InStr(Result, vbNullChar) - 1)
End If
Else 'NT4 or less
' The old WIN.INI [Windows] section is mapped to
' HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows
' and we can just use GetProfileString to extract!
' Returns: "printer name,driver name,port"
If GetProfileString("Windows", ByVal "device", "", Result, BufSize) Then
' Truncate buffer at end of name.
Result = Left$(Result, InStr(Result, ",") - 1)
End If
End If
End If
' Return default printer name.
DefaultPrinterName = Result
End Function
Private Function PointerToStringA(ByVal lpStringA As Long) As String
Dim Buffer() As Byte
Dim nLen As Long
If lpStringA Then
nLen = lstrlenA(ByVal lpStringA)
If nLen Then
ReDim Buffer(0 To (nLen - 1)) As Byte
CopyMemory Buffer(0), ByVal lpStringA, nLen
PointerToStringA = StrConv(Buffer, vbUnicode)
End If
End If
End Function
printing report
