Can I set the Windows default printer using VBA? (1 Viewer)

CreateObject("shell.application").namespace(0).parsename(document).invokeverb ("Print")

sub btnPrintDocs()
dim ptr1

ptr1 = GetDefaultPrinter ()      'save old printer
setDefaultPrinter "Printer2"     'set new printer
  docmd.openreport "myReport"    'print my report
setDefaultPrinter ptr1      'set back to old printer
end sub

Option Compare Database
Option Explicit

Private Declare Function ShellExecute _
Lib "shell32.dll" _
Alias "ShellExecuteA" ( _
ByVal hWnd As Long, ByVal lpszOp As String, _
ByVal lpszFile As String, _
ByVal lpszParams As String, _
ByVal lpszDir As String, _
ByVal FsShowCmd As Long _
) As Long

Private Const SE_ERR_FNF = 2&
Private Const SE_ERR_PNF = 3&
Private Const SE_ERR_ACCESSDENIED = 5&
Private Const SE_ERR_OOM = 8&
Private Const SE_ERR_DLLNOTFOUND = 32&
Private Const SE_ERR_SHARE = 26&
Private Const SE_ERR_ASSOCINCOMPLETE = 27&
Private Const SE_ERR_DDETIMEOUT = 28&
Private Const SE_ERR_DDEFAIL = 29&
Private Const SE_ERR_DDEBUSY = 30&
Private Const SE_ERR_NOASSOC = 31&
Private Const SE_ERR_BAD_FORMAT = 11&

Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1

Private Const HWND_BROADCAST As Long = &HFFFF&
Private Const WM_WININICHANGE As Long = &H1A

' The following code allows one to read, and write to the WIN.INI files
' In win 2000 the printer settings are actually in the registry. However, windows
' handles this correctly
'
Private Declare Function GetProfileString Lib "kernel32" _
   Alias "GetProfileStringA" _
  (ByVal lpAppName As String, _
   ByVal lpKeyName As String, _
   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 SendMessage Lib "user32" _
   Alias "SendMessageA" _
  (ByVal hWnd As Long, _
   ByVal wMsg As Long, _
   ByVal wParam As Long, _
   lparam As Any) As Long


Private Function fstrDField(mytext As String, delim As String, groupnum As Integer) As String

   ' this is a standard delimiter routine that every developer I know has.
   ' This routine has a million uses. This routine is great for splitting up
   ' data fields, or sending multiple parms to a openargs of a form
   '
   '  Parms are
   '        mytext   - a delimited string
   '        delim    - our delimiter (usually a , or / or a space)
   '        groupnum - which of the delimited values to return
   '
   
Dim startpos As Integer, endpos As Integer
Dim groupptr As Integer, chptr As Integer

chptr = 1
startpos = 0
 For groupptr = 1 To groupnum - 1
    chptr = InStr(chptr, mytext, delim)
    If chptr = 0 Then
       fstrDField = ""
       Exit Function
    Else
       chptr = chptr + 1
    End If
 Next groupptr
startpos = chptr
endpos = InStr(startpos + 1, mytext, delim)
If endpos = 0 Then
   endpos = Len(mytext) + 1
End If

fstrDField = Mid$(mytext, startpos, endpos - startpos)

End Function

Function SetDefaultPrinter(strPrinterName As String) As Boolean

   Dim strDeviceLine As String
   Dim strBuffer     As String
   Dim lngbuf        As Long
    
  ' get the full device string
  '
   strBuffer = Space(1024)
   lngbuf = GetProfileString("PrinterPorts", strPrinterName, "", strBuffer, Len(strBuffer))
  
  'Write out this new printer information in
  ' WIN.INI file for DEVICE item
  If lngbuf > 0 Then
     
     strDeviceLine = strPrinterName & "," & _
                     fstrDField(strBuffer, Chr(0), 1) & "," & _
                     fstrDField(strBuffer, Chr(0), 2)
                     
     Call WriteProfileString("windows", "Device", strDeviceLine)
     SetDefaultPrinter = True
     
     ' Below is optional, and should be done. It updates the existing windows
     ' so the "default" printer icon changes. If you don't do the below..then
     ' you will often see more than one printer as the default! The reason *not*
     ' to do the SendMessage is that many open applications will now sense the change
     ' in printer. I vote to leave it in..but your case you might not want this.
     '
     
     'Call SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, ByVal "windows")
    
  Else
     SetDefaultPrinter = False
  End If
       
End Function


Function GetDefaultPrinter() As String

   Dim strDefault    As String
   Dim lngbuf        As Long

   strDefault = String(255, Chr(0))
   lngbuf = GetProfileString("Windows", "Device", "", strDefault, Len(strDefault))
   If lngbuf > 0 Then
      GetDefaultPrinter = fstrDField(strDefault, ",", 1)
   Else
      GetDefaultPrinter = ""
   End If

End Function

Public Sub ListPrinters()

   Debug.Print GetDefaultPrinter
   Debug.Print "------------"
   Debug.Print GetPrinters
   
End Sub

Function GetPrinters() As String
   
   ' this routine returns a list of printers, separated by
   ' a ";", and thus the results are suitable for stuffing into a combo box
   
   Dim strBuffer  As String
   Dim strOnePtr  As String
   Dim intPos     As Integer
   Dim lngChars   As Long
   
   strBuffer = Space(2048)
   lngChars = GetProfileString("PrinterPorts", vbNullString, "", strBuffer, Len(strBuffer))
   
   If lngChars > 0 Then
      intPos = InStr(strBuffer, Chr(0))
     Do While intPos > 1
        strOnePtr = Left(strBuffer, intPos - 1)
        strBuffer = Mid(strBuffer, intPos + 1)
        If GetPrinters <> "" Then GetPrinters = GetPrinters & vbCrLf
        'Debug.Print strOnePtr
        GetPrinters = GetPrinters & strOnePtr
        intPos = InStr(strBuffer, Chr(0))
        
     Loop
   Else
      GetPrinters = ""
   End If
   
 End Function


Public Sub PrinterSides(ByVal pyNum As Byte)
   'acPRDPSimplex = 1
   'acPRDPHorizontal =  2
   'acPRDPVertical = 3
   Select Case pyNum
    Case ": 'nothing to do"
    Case 1
       rpt.Printer.Duplex = acPRDPSimplex
    Case 2
       rpt.Printer.Duplex = acPRDPHorizontal
    Case 3
       rpt.Printer.Duplex = acPRDPVertical
   End Select
   Printer.Duplex = pyNum
End Sub

Public Sub PrinterOrient()

'If CommonDialog1.Orientation = cdlLandscape Then
'       Printer.Orientation = cdlLandscape  '2
'Else
'       Printer.Orientation = cdlPortrait  '1
'End If
End Sub

Private Sub ProcessList(FileOp As String)
Dim varItem As Variant
Dim strFile As String
If Me.lstFiles.ItemsSelected.Count = 0 Then
   MsgBox " No file selected for " & FileOp & "ing", vbExclamation, "Process"
   Exit Sub
End If

For Each varItem In Me.lstFiles.ItemsSelected
   strFile = Me.lstFiles.Column(1, varItem)
   If ExecuteFile(strFile, FileOp) Then MsgBox "File " & FileOp & "ed"""
   Debug.Print strFile
Next
End Sub


Public Sub PrintListOfFiles()
Dim sOld As String, sFilename As String


ExecuteFile sFilename, "print"

End Sub

Public Function ExecuteFile(DocName As String, Optional FileOp As String = "open") As Boolean
Dim lRetVal As Long, sMsg As String

lRetVal = ShellExecute(0&, FileOp, DocName, vbNullString, vbNullString, IIf(FileOp = "print", SW_HIDE, SW_SHOWNORMAL))

If lRetVal <= 32 Then
    ExecuteFile = False
'There was an error
Select Case lRetVal
    Case SE_ERR_FNF
    sMsg = "File not found"
    Case SE_ERR_PNF
    sMsg = "Path not found"
    Case SE_ERR_ACCESSDENIED
    sMsg = "Access denied"
    Case SE_ERR_OOM
    sMsg = "Out of memory"
    Case SE_ERR_DLLNOTFOUND
    sMsg = "DLL not found"
    Case SE_ERR_SHARE
    sMsg = "A sharing violation occurred"
    Case SE_ERR_ASSOCINCOMPLETE
    sMsg = "Incomplete or invalid file association"
    Case SE_ERR_DDETIMEOUT
    sMsg = "DDE Time out"
    Case SE_ERR_DDEFAIL
    sMsg = "DDE transaction failed"
    Case SE_ERR_DDEBUSY
    sMsg = "DDE busy"
    Case SE_ERR_NOASSOC
    sMsg = "No association for file extension"
    Case SE_ERR_BAD_FORMAT
    sMsg = "Invalid EXE file or error in EXE image"
    Case Else
    sMsg = "Unknown error"
End Select
    MsgBox "Cannot " & FileOp & " " & DocName & vbCrLf & vbCrLf & sMsg, vbExclamation
Else
   ExecuteFile = True
End If
End Function