[Resolvido]Selecionar no Listbox

Boa tarde!!

Uso a função abaixo para listar as impressoras e selecionar a padrão, teria como ao invés de selecionar a padrão selecionar uma especifica?

Gostaria que selecionasse uma impressora com o nome Cupons poe exemplo.

Private Sub Form_Load()
Dim objPrinter As Object
'Adicione nome das impressoras na ListBox
For Each objPrinter In Printers
Me!ListaImpressoras.AddItem objPrinter.DeviceName
Next
'Seleciona a impressora padrão do Windows
Me!ListaImpressoras.Value = Application.printer.DeviceName
End Sub

Código:


Sub DefinirImpressora()
    Dim prt As Printer
    
    'Armazena a impressora padrão atual
    Set prt = Application.Printer
    
    'Define a impressora padrão desejada
    Application.Printer = Application.Printers("Cupons")

    'Imprimir
    DoCmd.PrintOut

    'Redefine para a impressora padrão
    Set Application.Printer = prt
End Sub


Fonte: http://answers.microsoft.com/en-us/office/forum/office_2010-access/how-do-i-change-default-printers-in-vba/d046a937-6548-4d2b-9517-7f622e2cfed2

Muito bom o exemplo Avelino.
Creio que daria pra sugerir uma melhoria colocando tudo num módulo de classe.

Abs

Marco e Avelino muito obrigado pela atenção!!

O problema é que esqueci de mencionar, o nome da impressora muda a cada conexão pois se trata de um ambiente de conexão remota, então o nome sempre vem acompanhado da palavra (Redirecionada X).

Então na verdade precisava desse mesmo código que o Marco passou mas que pegasse a impressora somente pelas 6 primeiras letras "Cupons"

Novamente agradeço a atenção!!

Abs.

O código a seguir deve ser colocado em um módulo:

Código:


Option Explicit

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' modListPrinters
' By Chip Pearson, chip@cpearson.com  www.cpearson.com
' Created 22-Sept-2012
' This provides a function named GetPrinterFullNames that
' returns a String array, each element of which is the name
' of a printer installed on the machine.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const HKEY_CURRENT_USER As Long = &H80000001
Private Const HKCU = HKEY_CURRENT_USER
Private Const KEY_QUERY_VALUE = &H1&
Private Const ERROR_NO_MORE_ITEMS = 259&
Private Const ERROR_MORE_DATA = 234

Private Declare Function RegOpenKeyEx Lib "advapi32" _
    Alias "RegOpenKeyExA" ( _
    ByVal HKey As Long, _
    ByVal lpSubKey As String, _
    ByVal ulOptions As Long, _
    ByVal samDesired As Long, _
    phkResult As Long) As Long

Private Declare Function RegEnumValue Lib "advapi32.dll" _
    Alias "RegEnumValueA" ( _
    ByVal HKey As Long, _
    ByVal dwIndex As Long, _
    ByVal lpValueName As String, _
    lpcbValueName As Long, _
    ByVal lpReserved As Long, _
    lpType As Long, _
    lpData As Byte, _
    lpcbData As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32.dll" ( _
    ByVal HKey As Long) As Long

Public Function GetPrinterFullNames() As String()
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' GetPrinterFullNames
    ' By Chip Pearson, chip@cpearson.com, www.cpearson.com
    ' Returns an array of printer names, where each printer name
    ' is the device name followed by the port name. The value can
    ' be used to assign a printer to the ActivePrinter property of
    ' the Application object. Note that setting the ActivePrinter
    ' changes the default printer for Excel but does not change
    ' the Windows default printer.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim Printers() As String ' array of names to be returned
    Dim PNdx As Long    ' index into Printers()
    Dim HKey As Long    ' registry key handle
    Dim Res As Long    ' result of API calls
    Dim Ndx As Long    ' index for RegEnumValue
    Dim ValueName As String ' name of each value in the printer key
    Dim ValueNameLen As Long    ' length of ValueName
    Dim DataType As Long        ' registry value data type
    Dim ValueValue() As Byte    ' byte array of registry value value
    Dim ValueValueS As String  ' ValueValue converted to String
    Dim CommaPos As Long        ' position of comma character in ValueValue
    Dim ColonPos As Long        ' position of colon character in ValueValue
    Dim M As Long              ' string index
   
    ' registry key in HCKU listing printers
    Const PRINTER_KEY = "Software\Microsoft\Windows NT\CurrentVersion\Devices"
   
    PNdx = 0
    Ndx = 0
    ' assume printer name is less than 256 characters
    ValueName = String$(256, Chr(0))
    ValueNameLen = 255
    ' assume the port name is less than 1000 characters
    ReDim ValueValue(0 To 999)
    ' assume there are less than 1000 printers installed
    ReDim Printers(1 To 1000)
   
    ' open the key whose values enumerate installed printers
    Res = RegOpenKeyEx(HKCU, PRINTER_KEY, 0&, _
        KEY_QUERY_VALUE, HKey)
    ' start enumeration loop of printers
    Res = RegEnumValue(HKey, Ndx, ValueName, _
        ValueNameLen, 0&, DataType, ValueValue(0), 1000)
    ' loop until all values have been enumerated
    Do Until Res = ERROR_NO_MORE_ITEMS
        M = InStr(1, ValueName, Chr(0))
        If M > 1 Then
            ' clean up the ValueName
            ValueName = Left(ValueName, M - 1)
        End If
        ' find position of a comma and colon in the port name
        CommaPos = InStr(1, ValueValue, ",")
        ColonPos = InStr(1, ValueValue, ":")
        ' ValueValue byte array to ValueValueS string
        On Error Resume Next
        ValueValueS = Mid(ValueValue, CommaPos + 1, ColonPos - CommaPos)
        On Error GoTo 0
        ' next slot in Printers
        PNdx = PNdx + 1
        Printers(PNdx) = ValueName & " on " & ValueValueS
        ' reset some variables
        ValueName = String(255, Chr(0))
        ValueNameLen = 255
        ReDim ValueValue(0 To 999)
        ValueValueS = vbNullString
        ' tell RegEnumValue to get the next registry value
        Ndx = Ndx + 1
        ' get the next printer
        Res = RegEnumValue(HKey, Ndx, ValueName, ValueNameLen, _
            0&, DataType, ValueValue(0), 1000)
        ' test for error
        If (Res <> 0) And (Res <> ERROR_MORE_DATA) Then
            Exit Do
        End If
    Loop
    ' shrink Printers down to used size
    ReDim Preserve Printers(1 To PNdx)
    Res = RegCloseKey(HKey)
    ' Return the result array
    GetPrinterFullNames = Printers
End Function

Function BuscarNomeImpressora(NomeImpressora As String)
        Dim Impressoras() As String
        Dim i As Integer
       
        Impressoras = GetPrinterFullNames()
       
        For i = LBound(Impressoras) To UBound(Impressoras)
            If Impressoras(i) Like "*utodesk*" Then
                Debug.Print Impressoras(i)
                Exit Function
            End If
        Next i
End Function


Você deve usar a última função que eu criei (BuscarNomeImpressora) da seguinte maneira:

Ex.:

Código:


Sub DefinirImpressora()
    Dim prt As Printer
   
    'Armazena a impressora padrão atual
    Set prt = Application.Printer
   
    'Define a impressora padrão desejada
    Application.Printer = Application.Printers(BuscarNomeImpressora("Cupons*"))

    'Imprimir
    DoCmd.PrintOut

    'Redefine para a impressora padrão
    Set Application.Printer = prt
End Sub


Você utiliza o asterisco da mesma maneira que busca arquivos no windows explorer.

Parte do código foi tirado da fonte: http://www.cpearson.com/excel/GetPrinters.aspx

Marco, boa tarde.

É exatamente oq preciso, mas não sei se pelo fato de meu Windows Server ser de 64 bits a função (BuscarNomeImpressora) não retorna nenhum nome de impressora, já alterei a função com PtrSafe para ela rodar em 64 bits mas não funciona.

Alguma luz?

Muito obrigado!!!

Sim, tenho... eu estava debugando antes de criar e esqueci de retornar o valor pra função.

Segue o código:

Código:


Function BuscarNomeImpressora(NomeImpressora As String) as String
        Dim Impressoras() As String
        Dim i As Integer
       
        Impressoras = GetPrinterFullNames()
       
        For i = LBound(Impressoras) To UBound(Impressoras)
            If Impressoras(i) Like "*utodesk*" Then
                BuscarNomeImpressora = Impressoras(i)
                Exit Function
            End If
        Next i
End Function


Tinha um Debug.Print ao invés de retornar o valor.
Uma crítica construtiva, sempre depure o código pra entender como ele funciona.
Bem, foi um erro besta meu.

Abs

Marco, bom dia!!

Infelizmente não retorna os nomes, será que tenho que alterar mais alguma coisa pelo fato de o SO ser de 64 bits??

Abs.

A comparação no Like estava fixa pro teste que eu estava fazendo aqui, não estava usando o parâmetro.

Segue todo o código novamente:

Código:


Option Explicit

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' modListPrinters
' By Chip Pearson, chip@cpearson.com  www.cpearson.com
' Created 22-Sept-2012
' This provides a function named GetPrinterFullNames that
' returns a String array, each element of which is the name
' of a printer installed on the machine.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const HKEY_CURRENT_USER As Long = &H80000001
Private Const HKCU = HKEY_CURRENT_USER
Private Const KEY_QUERY_VALUE = &H1&
Private Const ERROR_NO_MORE_ITEMS = 259&
Private Const ERROR_MORE_DATA = 234

Private Declare PtrSafe Function RegOpenKeyEx Lib "advapi32" _
    Alias "RegOpenKeyExA" ( _
    ByVal HKey As Long, _
    ByVal lpSubKey As String, _
    ByVal ulOptions As Long, _
    ByVal samDesired As Long, _
    phkResult As Long) As Long

Private Declare PtrSafe Function RegEnumValue Lib "advapi32.dll" _
    Alias "RegEnumValueA" ( _
    ByVal HKey As Long, _
    ByVal dwIndex As Long, _
    ByVal lpValueName As String, _
    lpcbValueName As Long, _
    ByVal lpReserved As Long, _
    lpType As Long, _
    lpData As Byte, _
    lpcbData As Long) As Long

Private Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" ( _
    ByVal HKey As Long) As Long

Private Function GetPrinterFullNames() As String()
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' GetPrinterFullNames
    ' By Chip Pearson, chip@cpearson.com, www.cpearson.com
    ' Returns an array of printer names, where each printer name
    ' is the device name followed by the port name. The value can
    ' be used to assign a printer to the ActivePrinter property of
    ' the Application object. Note that setting the ActivePrinter
    ' changes the default printer for Excel but does not change
    ' the Windows default printer.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim Printers() As String ' array of names to be returned
    Dim PNdx As Long    ' index into Printers()
    Dim HKey As Long    ' registry key handle
    Dim Res As Long    ' result of API calls
    Dim Ndx As Long    ' index for RegEnumValue
    Dim ValueName As String ' name of each value in the printer key
    Dim ValueNameLen As Long    ' length of ValueName
    Dim DataType As Long        ' registry value data type
    Dim ValueValue() As Byte    ' byte array of registry value value
    Dim ValueValueS As String  ' ValueValue converted to String
    Dim CommaPos As Long        ' position of comma character in ValueValue
    Dim ColonPos As Long        ' position of colon character in ValueValue
    Dim M As Long              ' string index
   
    ' registry key in HCKU listing printers
    Const PRINTER_KEY = "Software\Microsoft\Windows NT\CurrentVersion\Devices"
   
    PNdx = 0
    Ndx = 0
    ' assume printer name is less than 256 characters
    ValueName = String$(256, Chr(0))
    ValueNameLen = 255
    ' assume the port name is less than 1000 characters
    ReDim ValueValue(0 To 999)
    ' assume there are less than 1000 printers installed
    ReDim Printers(1 To 1000)
   
    ' open the key whose values enumerate installed printers
    Res = RegOpenKeyEx(HKCU, PRINTER_KEY, 0&, _
        KEY_QUERY_VALUE, HKey)
    ' start enumeration loop of printers
    Res = RegEnumValue(HKey, Ndx, ValueName, _
        ValueNameLen, 0&, DataType, ValueValue(0), 1000)
    ' loop until all values have been enumerated
    Do Until Res = ERROR_NO_MORE_ITEMS
        M = InStr(1, ValueName, Chr(0))
        If M > 1 Then
            ' clean up the ValueName
            ValueName = Left(ValueName, M - 1)
        End If
        ' find position of a comma and colon in the port name
        CommaPos = InStr(1, ValueValue, ",")
        ColonPos = InStr(1, ValueValue, ":")
        ' ValueValue byte array to ValueValueS string
        On Error Resume Next
        ValueValueS = Mid(ValueValue, CommaPos + 1, ColonPos - CommaPos)
        On Error GoTo 0
        ' next slot in Printers
        PNdx = PNdx + 1
        Printers(PNdx) = ValueName & " on " & ValueValueS
        ' reset some variables
        ValueName = String(255, Chr(0))
        ValueNameLen = 255
        ReDim ValueValue(0 To 999)
        ValueValueS = vbNullString
        ' tell RegEnumValue to get the next registry value
        Ndx = Ndx + 1
        ' get the next printer
        Res = RegEnumValue(HKey, Ndx, ValueName, ValueNameLen, _
            0&, DataType, ValueValue(0), 1000)
        ' test for error
        If (Res <> 0) And (Res <> ERROR_MORE_DATA) Then
            Exit Do
        End If
    Loop
    ' shrink Printers down to used size
    ReDim Preserve Printers(1 To PNdx)
    Res = RegCloseKey(HKey)
    ' Return the result array
    GetPrinterFullNames = Printers
End Function

Public Function BuscarNomeImpressora(NomeImpressora As String) As String
        Dim Impressoras() As String
        Dim i As Integer
       
        'Busca o nome de todas as impressoras
        Impressoras = GetPrinterFullNames()
       
        'Percorre cada impressora e verifica se existe alguma similaridade no nome informado
        For i = LBound(Impressoras) To UBound(Impressoras)
            If UCase(Impressoras(i)) Like UCase(NomeImpressora) Then
                BuscarNomeImpressora = Impressoras(i)
                Exit Function
            End If
        Next i
End Function

Public Sub DefinirImpressora()
    Dim prt As Printer
   
    'Armazena a impressora padrão atual
    Set prt = Application.Printer
   
    'Define a impressora padrão desejada
    Application.Printer = Application.Printers(BuscarNomeImpressora("Cupons*"))

    'Imprimir
    DoCmd.PrintOut

    'Redefine para a impressora padrão
    Set Application.Printer = prt
End Sub


Repito: sempre depure o código pra entender como ele funciona.

Sucesso

Marco, boa tarde!!

Perfeito!!!

Muito obrigado pela atenção e pelas dicas.

Abs.