Code to name specific printer

[steveo0707]

Hello,



We use Access to track Non-Conforming products.

We enter the information into a form and then print and save from a Printable Form.

i currently have this code to Print. I have it selected for Print to PDF as default so they can save to our Network drive location. Then they Hit Ctrl P to actually select the printer to print to.

This is the code I have:

Private Sub PrintButton_Click()
On Error GoTo Err_Print_Record_Click


DoCmd.RunCommand acCmdSelectRecord
DoCmd.PrintOut acSelection


Exit_Print_Record_Click:
Exit Sub


Err_Print_Record_Click:
MsgBox Err.Description
Resume Exit_Print_Record_Click

End Sub

Is there a way to write the code so I can click one button to save to our network (print to PDF) and then click another button to print to the selected printer. This will eliminate the confusion.

I am asking because it is not always resetting baack to the Print to PDF option and I have some older gentlemen not too familiar with Access.

[ranman256]

My users have 2 printers, i keep their default in a table: tPrinters
IP, Printer


when user clicks Print button, it sets it as default in case they changed it:
SetMyPrinter


which sets the default printer




'modPrinterDefault

Option Compare Database
Option Explicit


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 kTypALL = 0
Private Const kTypBRO = 1
Private Const kTypTAG = 2


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


#If Win64 Then      'Public Dclare PtrSafe Function
    Public Declare PtrSafe 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
    
    Public Declare PtrSafe 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
    
    Public Declare PtrSafe Function WriteProfileString Lib "kernel32" _
       Alias "WriteProfileStringA" _
      (ByVal lpszSection As String, _
       ByVal lpszKeyName As String, _
       ByVal lpszString As String) As Long
    
    Public Declare PtrSafe Function SendMessage Lib "user32" _
       Alias "SendMessageA" _
      (ByVal hWnd As Long, _
       ByVal wMsg As Long, _
       ByVal wParam As Long, _
       lParam As Any) As Long
       
#Else   '----32 bit
    Public 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
    
    Public 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
    
    Public Declare Function WriteProfileString Lib "kernel32" _
       Alias "WriteProfileStringA" _
      (ByVal lpszSection As String, _
       ByVal lpszKeyName As String, _
       ByVal lpszString As String) As Long
    
    Public Declare PtrSafe Function SendMessage Lib "user32" _
       Alias "" _
      (ByVal hWnd As Long, _
       ByVal wMsg As Long, _
       ByVal wParam As Long, _
       lParam As Any) As Long
#End If


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 gazillion 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
    
On Error Resume Next
  ' 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
     
     'gT1Printer = strPrinterName
     Set Application.Printer = Application.Printers(strPrinterName)
     
     
     'Application.Printer.Orientation = 2  'landscape


     ' 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




Sub SetMyPrinter()
SetDefaultPrinter getMyPrinter()
End Sub


Function getMyPrinter()
getMyPrinter = DLookup("[Printer]", "tPrinters", "[IP]='" & getMyIp() & "'") & ""
End Function

'modIP
'if stored by IP

' VBA MODULE: Get all IP Addresses of your machine
' (c) 2005 Wayne Phillips (http://www.everythingaccess.com)
' Written 18/05/2005
'
' REQUIREMENTS: Windows 98 or above, Access 97 and above
'
' Please read the full tutorial here:
' http://www.everythingaccess.com/tutorials.asp?ID=Get-all-IP-Addresses-of-your-machine
'
' Please leave the copyright notices in place.
' Thank you.
'


'A couple of API functions we need in order to query the IP addresses in this machine
#If VBA7 Then      'Public Declare PtrSafe Function
    Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal LENGTH As Long)
    Public Declare PtrSafe Function GetIpAddrTable Lib "Iphlpapi" (pIPAdrTable As Byte, pdwSize As Long, ByVal Sort As Long) As Long


#Else
    Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal LENGTH As Long)
    Public Declare Function GetIpAddrTable Lib "Iphlpapi" (pIPAdrTable As Byte, pdwSize As Long, ByVal Sort As Long) As Long


#End If




'The structures returned by the API call GetIpAddrTable...
Type IPINFO
    dwAddr As Long         ' IP address
    dwIndex As Long         ' interface index
    dwMask As Long         ' subnet mask
    dwBCastAddr As Long     ' broadcast address
    dwReasmSize As Long    ' assembly size
    Reserved1 As Integer
    Reserved2 As Integer
End Type


Public Function getMyIp()
getMyIp = GetMyIPAddr
End Function


Public Function ConvertIPAddressToString(longAddr As Long) As String
    
    Dim IPBytes(3) As Byte
    Dim lngCount As Long
    
    'Converts a long IP Address to a string formatted 255.255.255.255
    'Note: Could use inet_ntoa instead
    
    CopyMemory IPBytes(0), longAddr, 4 ' IP Address is stored in four bytes (255.255.255.255)
    
    'Convert the 4 byte values to a formatted string
    While lngCount < 4
    
        ConvertIPAddressToString = ConvertIPAddressToString + _
                                    CStr(IPBytes(lngCount)) + _
                                    IIf(lngCount < 3, ".", "")


        lngCount = lngCount + 1
        
    Wend
    
End Function


Public Function GetMyIPAddr(Optional blnFilterLocalhost As Boolean = False)


    Dim ret As Long, Tel As Long
    Dim bytBuffer() As Byte
    Dim IPTableRow As IPINFO
    Dim lngCount As Long
    Dim lngBufferRequired As Long
    Dim lngStructSize As Long
    Dim lngNumIPAddresses As Long
    Dim strIPAddress As String


On Error GoTo ErrorHandler:
    
    Call GetIpAddrTable(ByVal 0&, lngBufferRequired, 1)


    If lngBufferRequired > 0 Then
     
        ReDim bytBuffer(0 To lngBufferRequired - 1) As Byte
     
        If GetIpAddrTable(bytBuffer(0), lngBufferRequired, 1) = 0 Then
     
            'We've successfully obtained the IP Address details...
     
            'How big is each structure row?...
            lngStructSize = LenB(IPTableRow)
    
            'First 4 bytes is a long indicating the number of entries in the table
            CopyMemory lngNumIPAddresses, bytBuffer(0), 4
     
            While lngCount < lngNumIPAddresses
         
                'bytBuffer contains the IPINFO structures (after initial 4 byte long)
                CopyMemory IPTableRow, _
                            bytBuffer(4 + (lngCount * lngStructSize)), _
                            lngStructSize
                 
                strIPAddress = ConvertIPAddressToString(IPTableRow.dwAddr)
                 
                If Not ((strIPAddress = "127.0.0.1") _
                        And blnFilterLocalhost) Then
                        
                    'Replace this with whatever you want to do with the IP Address...
                    GetMyIPAddr = strIPAddress
                    Exit Function
                End If
             
                lngCount = lngCount + 1
             
            Wend
         
        End If
        
    End If


Exit Function


ErrorHandler:
    MsgBox "An error has occured in GetIPAddresses():" & vbCrLf & vbCrLf & _
            Err.Description & " (" & CStr(Err.Number) & ")"


End Function




Public Function NSLookup(lookupVal As String, Optional addressOpt As Integer) As String
   Const ADDRESS_LOOKUP = 1
   Const NAME_LOOKUP = 2
   Const AUTO_DETECT = 0
   Dim ipLookup, cmdStr, loc1, loc2, nameStr
   
   'Skip everything if the field is blank
   If lookupVal <> "" Then
        Dim oFSO As Object, oShell As Object, oTempFile As Object
        Dim sLine As String, sFilename As String
        Dim intFound As Integer
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        Set oShell = CreateObject("Wscript.Shell")
        
        'Handle the addresOpt operand
        'Regular Expressions are used to complete a substring match for an IP Address
        'If an IP Address is found, a DNS Name Lookup will be forced
        If addressOpt = AUTO_DETECT Then
            ipLookup = FindIP(lookupVal)
            If ipLookup = "" Then
                addressOpt = ADDRESS_LOOKUP
            Else
                addressOpt = NAME_LOOKUP
                lookupVal = ipLookup
            End If
        'Do a regular expression substring match for an IP Address
        ElseIf addressOpt = NAME_LOOKUP Then
            lookupVal = FindIP(lookupVal)
        End If
        
        'Run the nslookup command
        sFilename = oFSO.GetTempName
        oShell.Run "cmd /c nslookup " & lookupVal & " > " & sFilename, 0, True
        Set oTempFile = oFSO.OpenTextFile(sFilename, 1)
        Do While oTempFile.AtEndOfStream <> True
            sLine = oTempFile.ReadLine
            cmdStr = cmdStr & Trim(sLine) & vbCrLf
        Loop
        oTempFile.Close
        oFSO.DeleteFile (sFilename)
        
        'Process the result
        intFound = InStr(1, cmdStr, "Name:", vbTextCompare)
        If intFound = 0 Then
            NSLookup = ""
            Exit Function
        ElseIf intFound > 0 Then
            'TODO: Cleanup with RegEx
            If addressOpt = ADDRESS_LOOKUP Then
                loc1 = InStr(intFound, cmdStr, "Address:", vbTextCompare) + InStr(intFound, cmdStr, "Addresses:", vbTextCompare)
                loc2 = InStr(loc1, cmdStr, vbCrLf, vbTextCompare)
                nameStr = Trim(Mid(cmdStr, loc1 + 8, loc2 - loc1 - 8))
            ElseIf addressOpt = NAME_LOOKUP Then
                loc1 = InStr(intFound, cmdStr, "Name:", vbTextCompare)
                loc2 = InStr(loc1, cmdStr, vbCrLf, vbTextCompare)
                nameStr = Trim(Mid(cmdStr, loc1 + 5, loc2 - loc1 - 5))
            End If
        End If
        NSLookup = nameStr
    Else
        NSLookup = "N/A"
    End If
End Function


Function FindIP(strTest As String) As String
    Dim RegEx As Object
    Dim valid As Boolean
    Dim Matches As Object
    Dim i As Integer
    Set RegEx = CreateObject("VBScript.RegExp")
    
    RegEx.Pattern = "\b(?:\d{1,3}\.){3}\d{1,3}\b"
    valid = RegEx.test(strTest)
    If valid Then
        Set Matches = RegEx.Execute(strTest)
        FindIP = Matches(0)
    Else
        FindIP = ""
    End If
End Function






'usage: GetIPfromHostName("CVSUPER-PC.okonite4.lan")
Function GetIPfromHostName(p_sHostName)
    Dim wmiQuery
    Dim objWMIService
    Dim objPing
    Dim objStatus


    wmiQuery = "Select * From Win32_PingStatus Where Address = '" & p_sHostName & "'"


    Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
    Set objPing = objWMIService.ExecQuery(wmiQuery)


    For Each objStatus In objPing
        If objStatus.StatusCode = 0 Then
            GetIPfromHostName = objStatus.ProtocolAddress
        Else
            GetIPfromHostName = "Unreachable"
        End If
    Next


End Function






Public Function cvtIpFolder2IP(pvWord)
    pvWord = Mid(pvWord, 3)
    cvtIpFolder2IP = Left(pvWord, InStr(pvWord, "\") - 1)
End Function


Function WhatSiteIsThis()
Dim vIP
vIP = getMyIp()


Select Case True
   Case InStr(vIP, "10.7.") = 1
     WhatSiteIsThis = "RICH"
   Case InStr(vIP, "10.4.") = 1
     WhatSiteIsThis = "OBRG"
   Case InStr(vIP, "10.5.") = 1
     WhatSiteIsThis = "MARIA"
   Case InStr(vIP, "10.186.") = 1
     WhatSiteIsThis = "PITT"
   Case InStr(vIP, "10.183.") = 1
     WhatSiteIsThis = "KS"
   Case InStr(vIP, "10.185.") = 1
     WhatSiteIsThis = "PORT"
   Case InStr(vIP, "10.189.") = 1
     WhatSiteIsThis = "HOU"
End Select
End Function




Private Function getPcNameViaIpLong(ByVal psIP As String)
'run shell NSLOOKUP
getPcNameViaIpLong = NSLookup(psIP, 2)
End Function


Public Function getPcNameViaIp(ByVal pvIP)
Dim vRet
On Error Resume Next
vRet = getPcNameViaIpLong(pvIP)
vRet = Left(vRet, InStr(vRet, ".") - 1)
getPcNameViaIp = vRet
End Function






Public Function getIPfromPath(ByVal pvPath)
Dim vRet, i


vRet = Mid(pvPath, 3)
If Left(vRet, 1) = 1 Then
 i = InStr(vRet, "\")
  getIPfromPath = Left(vRet, i - 1)
Else
 getIPfromPath = ""
End If
End Function

[Gicu]

For the button that saves the form (you really should change it to a report but that's another thing) look up Docmd.OutputTo:
https://learn.microsoft.com/en-us/of...docmd.outputto

For the button that prints the form you can use your existing code (once you save the default printer), but again, printing a report using Docmd.OpenReport rptYourReport,acViewNormal is the safer and preferred option:
https://learn.microsoft.com/en-us/of...cmd.openreport

Cheers,