Application.Dialogs(xlDialogPrint).Show 

Option Explicit

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 String) As Long

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

Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String *  128 
End Type


Private Declare Function GetVersionExA Lib "Kernel32" _
    (lpVersionInformation As OSVERSIONINFO) As Integer

Private Declare Function OpenPrinter Lib "winspool.drv" _
    Alias "OpenPrinterA" _
    (ByVal pPrinterName As String, _
    phPrinter As Long, _
    pDefault As PRINTER_DEFAULTS) 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 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 Function lstrcpy Lib "Kernel32" _
    Alias "lstrcpyA" _
    (ByVal lpString1 As String, _
    ByVal lpString2 As Any) As Long

Private Declare Function ClosePrinter Lib "winspool.drv" _
    (ByVal hPrinter As Long) As Long

Private Declare Function GetLastError Lib "Kernel32" () As Long

Private Const CCHDEVICENAME =  32 
Private Const CCHFORMNAME =  32 

Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const PRINTER_ACCESS_ADMINISTER = &H4
Private Const PRINTER_ACCESS_USE = &H8
Private Const PRINTER_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or PRINTER_ACCESS_ADMINISTER Or PRINTER_ACCESS_USE)

Private Const PRINTER_ATTRIBUTE_DEFAULT =  4 

Private Type DEVMODE
    dmDeviceName As String * CCHDEVICENAME
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    dmFormName As String * CCHFORMNAME
    dmLogPixels As Integer
    dmBitsPerPel As Long
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
    dmICMMethod As Long
    dmICMIntent As Long
    dmMediaType As Long
    dmDitherType As Long
    dmReserved1 As Long
    dmReserved2 As Long
End Type

Private Type PRINTER_INFO_5
    pPrinterName As String
    pPortName As String
    Attributes As Long
    DeviceNotSelectedTimeout As Long
    TransmissionRetryTimeout As Long
End Type

Private Type PRINTER_DEFAULTS
    pDatatype As Long
    pDevmode As DEVMODE
    DesiredAccess As Long
End Type

Private m_sCurrPrinterDevName As String
Private m_sPrevPrinterDevName As String
Private m_sPrevPrinterDriver As String
Private m_sPrevPrinterPort As String

Private Function PtrCtoVbString(Add As Long) As String
    'Source - Article ID: Q78304
    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 Function SetDefaultPrinter(ByVal DeviceName As String, ByVal DriverName As String, ByVal PrinterPort As String) As Boolean
    Dim DeviceLine As String
    Dim r As Long
    Dim l As Long
    
    DeviceLine = DeviceName & "," & DriverName & "," & PrinterPort

    r = WriteProfileString("windows", "Device", DeviceLine)
    
    If r Then

        l = SendMessage(HWND_BROADCAST, WM_WININICHANGE,  0 , "windows")
        SetDefaultPrinter = True
        m_sCurrPrinterDevName = DeviceName
    Else
        SetDefaultPrinter = False
    End If
End Function

Private Function Win95SetDefaultPrinter(ByRef DeviceName As String) As Boolean
    Dim Handle As Long
    Dim pd As PRINTER_DEFAULTS
    Dim x As Long
    Dim need As Long
    Dim pi5 As PRINTER_INFO_5
    Dim LastError As Long


    If DeviceName = "" Then
        Win95SetDefaultPrinter = False
        Exit Function
    End If


    pd.pDatatype =  0 &
    pd.DesiredAccess = PRINTER_ALL_ACCESS


    x = OpenPrinter(DeviceName, Handle, pd)

    If x = False Then
        Win95SetDefaultPrinter = False
        Exit Function
    End If

    x = GetPrinter(Handle,  5 , ByVal  0 &,  0 , need)

    ReDim t((need \  4 )) As Long

    x = GetPrinter(Handle,  5 , t( 0 ), need, need)

    If x = False Then
        Win95SetDefaultPrinter = False
        Exit Function
    End If

    pi5.pPrinterName = PtrCtoVbString(t( 0 ))
    pi5.pPortName = PtrCtoVbString(t( 1 ))
    pi5.Attributes = t( 2 )
    pi5.DeviceNotSelectedTimeout = t( 3 )
    pi5.TransmissionRetryTimeout = t( 4 )


    pi5.Attributes = PRINTER_ATTRIBUTE_DEFAULT


    x = SetPrinter(Handle,  5 , pi5,  0 )
    
    If x = False Then
        Win95SetDefaultPrinter = False
        Exit Function
    End If

    Call ClosePrinter(Handle)
    m_sCurrPrinterDevName = DeviceName
    Win95SetDefaultPrinter = True
End Function

Private Sub GetDriverAndPort(ByVal Buffer As String, ByRef DriverName As String, ByRef PrinterPort As String)
    Dim iDriver As Integer
    Dim iPort As Integer
    
    DriverName = ""
    PrinterPort = ""

    iDriver = InStr(Buffer, ",")
    If iDriver >  0  Then

        DriverName = Left(Buffer, iDriver -  1 )

        iPort = InStr(iDriver +  1 , Buffer, ",")

        If iPort >  0  Then

            PrinterPort = Mid(Buffer, iDriver +  1 , iPort - iDriver -  1 )
        End If
    End If
End Sub

Private Function WinNTSetDefaultPrinter(ByRef DeviceName As String) As Boolean
    Dim Buffer As String
    Dim DriverName As String
    Dim PrinterPort As String
    Dim r As Long
    
    If DeviceName <> "" Then

        Buffer = Space( 1024 )
        r = GetProfileString("PrinterPorts", DeviceName, "", Buffer, Len(Buffer))
        

        Call GetDriverAndPort(Buffer, DriverName, PrinterPort)

        If DriverName <> "" And PrinterPort <> "" Then
            WinNTSetDefaultPrinter = SetDefaultPrinter(DeviceName, DriverName, PrinterPort)
        Else
            WinNTSetDefaultPrinter = False
        End If
    End If
End Function

Function SetPrinterAsDefault(ByVal DeviceName As String) As Boolean
    Dim osinfo As OSVERSIONINFO
    Dim retvalue As Integer

    osinfo.dwOSVersionInfoSize =  148 
    osinfo.szCSDVersion = Space$( 128 )
    retvalue = GetVersionExA(osinfo)
    

    If m_sCurrPrinterDevName <> DeviceName Then

        If osinfo.dwMajorVersion =  3  And osinfo.dwMinorVersion =  51  And osinfo.dwBuildNumber =  1057  And osinfo.dwPlatformId =  2  Then
            SetPrinterAsDefault = WinNTSetDefaultPrinter(DeviceName)

        ElseIf osinfo.dwMajorVersion =  4  And osinfo.dwPlatformId =  1  Then
            SetPrinterAsDefault = Win95SetDefaultPrinter(DeviceName)

        ElseIf osinfo.dwMajorVersion =  4  And osinfo.dwMinorVersion =  0  And osinfo.dwBuildNumber =  1381  And osinfo.dwPlatformId =  2  Then
            SetPrinterAsDefault = WinNTSetDefaultPrinter(DeviceName)
            
        ElseIf osinfo.dwMajorVersion >  4  Then
            SetPrinterAsDefault = WinNTSetDefaultPrinter(DeviceName)
        End If
    Else
        SetPrinterAsDefault = True
    End If
End Function

Private Sub Class_Initialize()
    Dim Buffer As String
    Dim r As Long
    
    Buffer = Space( 8192 )
    r = GetProfileString("windows", "Device", "", Buffer, Len(Buffer))
    If r Then
        
        Buffer = Mid(Buffer,  1 , r)
        
        m_sPrevPrinterDevName = Mid(Buffer,  1 , InStr(Buffer, ",") -  1 )
        m_sPrevPrinterDriver = Mid(Buffer, InStr(Buffer, ",") +  1 , InStrRev(Buffer, ",") - InStr(Buffer, ",") -  1 )
        m_sPrevPrinterPort = Mid(Buffer, InStrRev(Buffer, ",") +  1 )
    Else
        m_sPrevPrinterDevName = ""
        m_sPrevPrinterDriver = ""
        m_sPrevPrinterDevName = ""
    End If
    m_sCurrPrinterDevName = m_sPrevPrinterDevName
End Sub

Private Sub Class_Terminate()

    Call SetPrinterAsDefault(m_sPrevPrinterDevName)
End Sub