Macro Imprimir

Hola Manu,

La siguiente funcion escrita por KeepItCool creo que hace lo que buscas. Tienes que copiar el codigo en un modulo estandar (p.ej.:
Modulo1) y ejecutar el procedimiento Test.

Saludos,
KL

'-inicio
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

Public Function PrinterFind(Optional Match As String) As String()
Dim n%, lRet&, sBuf$, sCon$, aPrn$()
Const lLen& = 1024, sKey$ = "devices"

'
'written by keepITcool

'requires xl2000 or newer.
'returns a zerobased array of complete localized printer strings
'results are filtered on Match string, if no result the ubound = -1
'

'Split ActivePrinter string to get localized word for "on"
aPrn = Split(Excel.ActivePrinter)
sCon = " " & aPrn(UBound(aPrn) - 1) & " "

'Read all installed printers (1k bytes s/b enough)
sBuf = Space(lLen)
lRet = GetProfileString(sKey, vbNullString, vbNullString, sBuf, lLen)
If lRet = 0 Then
Err.Raise vbObjectError + 513, , "Can't read Profile"
Exit Function
End If

'Split buffer string
aPrn = Split(Left(sBuf, lRet - 1), vbNullChar)
'Filter array on Match
If Match <> vbNullString Then aPrn = Filter(aPrn, Match, -1, 1)

For n = LBound(aPrn) To UBound(aPrn)
'Add 16bit portname for each Printer
sBuf = Space(lLen)
lRet = GetProfileString(sKey, aPrn(n), vbNullString, sBuf, lLen)
aPrn(n) = aPrn(n) & sCon & _
Mid(sBuf, InStr(sBuf, ",") + 1, lRet - InStr(sBuf, ","))
Next
'Return the result
PrinterFind = aPrn

End Function

Sub Test()
Dim vaList, miImpresora As String
vaList = PrinterFind(Match:="Spa46433\Color Inforcom")
On Error Resume Next
MsgBox Application.Index(vaList, 1)
End Sub
'-Final

Gracias KL, probaré el codigo y te comento.

"KL" escribió:

Hola Manu,

La siguiente funcion escrita por KeepItCool creo que hace lo que buscas. Tienes que copiar el codigo en un modulo estandar (p.ej.:
Modulo1) y ejecutar el procedimiento Test.

Saludos,
KL

'-inicio
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

Public Function PrinterFind(Optional Match As String) As String()
Dim n%, lRet&, sBuf$, sCon$, aPrn$()
Const lLen& = 1024, sKey$ = "devices"

'
'written by keepITcool

'requires xl2000 or newer.
'returns a zerobased array of complete localized printer strings
'results are filtered on Match string, if no result the ubound = -1
'

'Split ActivePrinter string to get localized word for "on"
aPrn = Split(Excel.ActivePrinter)
sCon = " " & aPrn(UBound(aPrn) - 1) & " "

'Read all installed printers (1k bytes s/b enough)
sBuf = Space(lLen)
lRet = GetProfileString(sKey, vbNullString, vbNullString, sBuf, lLen)
If lRet = 0 Then
Err.Raise vbObjectError + 513, , "Can't read Profile"
Exit Function
End If

'Split buffer string
aPrn = Split(Left(sBuf, lRet - 1), vbNullChar)
'Filter array on Match
If Match <> vbNullString Then aPrn = Filter(aPrn, Match, -1, 1)

For n = LBound(aPrn) To UBound(aPrn)
'Add 16bit portname for each Printer
sBuf = Space(lLen)
lRet = GetProfileString(sKey, aPrn(n), vbNullString, sBuf, lLen)
aPrn(n) = aPrn(n) & sCon & _
Mid(sBuf, InStr(sBuf, ",") + 1, lRet - InStr(sBuf, ","))
Next
'Return the result
PrinterFind = aPrn

End Function

Sub Test()
Dim vaList, miImpresora As String
vaList = PrinterFind(Match:="Spa46433\Color Inforcom")
On Error Resume Next
MsgBox Application.Index(vaList, 1)
End Sub
'-Final

Hola KL
Agradezco tu respuesta, pero seguramente, no se utilizar el código de forma
adecuada.
El mensaje que sale(Msgbox), es el nombre y el valor de la impresora, pero.
¿Como mando el mensaje para imprimir?, ¿Donde debo colocar el rango de
impresión en el código?, y ¿Como retorno después de imprimir, el equipo a la
impresora por defecto del mismo?.
Gracias por tu colaboración


"KL" escribió:

Hola Manu,

La siguiente funcion escrita por KeepItCool creo que hace lo que buscas. Tienes que copiar el codigo en un modulo estandar (p.ej.:
Modulo1) y ejecutar el procedimiento Test.

Saludos,
KL

'-inicio
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

Public Function PrinterFind(Optional Match As String) As String()
Dim n%, lRet&, sBuf$, sCon$, aPrn$()
Const lLen& = 1024, sKey$ = "devices"

'
'written by keepITcool

'requires xl2000 or newer.
'returns a zerobased array of complete localized printer strings
'results are filtered on Match string, if no result the ubound = -1
'

'Split ActivePrinter string to get localized word for "on"
aPrn = Split(Excel.ActivePrinter)
sCon = " " & aPrn(UBound(aPrn) - 1) & " "

'Read all installed printers (1k bytes s/b enough)
sBuf = Space(lLen)
lRet = GetProfileString(sKey, vbNullString, vbNullString, sBuf, lLen)
If lRet = 0 Then
Err.Raise vbObjectError + 513, , "Can't read Profile"
Exit Function
End If

'Split buffer string
aPrn = Split(Left(sBuf, lRet - 1), vbNullChar)
'Filter array on Match
If Match <> vbNullString Then aPrn = Filter(aPrn, Match, -1, 1)

For n = LBound(aPrn) To UBound(aPrn)
'Add 16bit portname for each Printer
sBuf = Space(lLen)
lRet = GetProfileString(sKey, aPrn(n), vbNullString, sBuf, lLen)
aPrn(n) = aPrn(n) & sCon & _
Mid(sBuf, InStr(sBuf, ",") + 1, lRet - InStr(sBuf, ","))
Next
'Return the result
PrinterFind = aPrn

End Function

Sub Test()
Dim vaList, miImpresora As String
vaList = PrinterFind(Match:="Spa46433\Color Inforcom")
On Error Resume Next
MsgBox Application.Index(vaList, 1)
End Sub
'-Final

Hola manu,

Aunque has omitido la mayor parte del codigo que usas, juzgando por el trozo que expones se ve que el codigo ya hace lo que
preguntas solo tienes que usar la funcion que te he posteado. Usando el trozo que has facilitado (el procedimiento Test), yo lo
haria de la siguiente manera (habra que llenar los vacios que se crearon al cortar tu el procedimiento original):

'-Inicio--
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

Public Function PrinterFind(Optional Match As String) As String()
Dim n%, lRet&, sBuf$, sCon$, aPrn$()
Const lLen& = 1024, sKey$ = "devices"

'
'written by keepITcool

'requires xl2000 or newer.
'returns a zerobased array of complete localized printer strings
'results are filtered on Match string, if no result the ubound = -1
'

'Split ActivePrinter string to get localized word for "on"
aPrn = Split(Excel.ActivePrinter)
sCon = " " & aPrn(UBound(aPrn) - 1) & " "

'Read all installed printers (1k bytes s/b enough)
sBuf = Space(lLen)
lRet = GetProfileString(sKey, vbNullString, vbNullString, sBuf, lLen)
If lRet = 0 Then
Err.Raise vbObjectError + 513, , "Can't read Profile"
Exit Function
End If

'Split buffer string
aPrn = Split(Left(sBuf, lRet - 1), vbNullChar)
'Filter array on Match
If Match <> vbNullString Then aPrn = Filter(aPrn, Match, -1, 1)

For n = LBound(aPrn) To UBound(aPrn)
'Add 16bit portname for each Printer
sBuf = Space(lLen)
lRet = GetProfileString(sKey, aPrn(n), vbNullString, sBuf, lLen)
aPrn(n) = aPrn(n) & sCon & _
Mid(sBuf, InStr(sBuf, ",") + 1, lRet - InStr(sBuf, ","))
Next
'Return the result
PrinterFind = aPrn

End Function

Sub Test()
Dim vaList, miImpresora As String
vaList = PrinterFind(Match:="Spa46433\Color Inforcom")
On Error Resume Next
miImpresora = Application.Index(vaList, 1)
On Error GoTo 0
If miImpresora <> "" Then

'aqui va el codigo que has omitido
nombreimpre =Application.ActivePrinter
ActiveWindow.SelectedSheets.PrintOut Copies:=2, ActivePrinter:= _
miImpresora, Collate:=True
'Restaura la impresora por defecto
Application.ActivePrinter = nombreimpre

Application.DisplayAlerts = False
ActiveWorkbook.Save
Sheets("DatosCliInfoComercial").Activate
'aqui va el codigo que has omitido

End If
End Sub
'-Final

Gracias por tu respuesta KL, y disculpa por haber tardado varios días en
responder.
Lamentablemente para mi, pero soy un poco torpe. Te adjunto el código
completo de la macro con las incorparaciones del código que me enviaste, para
ver si puedes ayudarme, puesto que tal y como esta el procedimiento no va.
Sub test()
Dim vaList, miImpresora As String
vaList = PrinterFind(Match:="Spa46433\Color Inforcom")
On Error Resume Next
miImpresora = Application.Index(vaList, 1)
On Error GoTo 0
If miImpresora <> "" Then ' no se que tengo que poner

Application.ScreenUpdating = False
Sheets("ForCliente").Activate
Contador
'Si se ejecuta la macro CopiaDatosCliAutomatico,entonces almacena los
datos en el
'fichero de AlmacendatosCli
CopiaDatosCliAutomatico
'Se guarda la impresora por defecto
nombreimpre = Application.ActivePrinter
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = "$A$1:$BP$96"
With ActiveSheet.PageSetup
'Configuración de impresión,sin problemas puedo hacerlo
End With
ActiveWindow.SelectedSheets.PrintOut Copies:=2, ActivePrinter:= _
miImpresora, Collate:=True
'Restaura la impresora por defecto
Application.ActivePrinter = nombreimpre
Sheets("DatosCliInfoComercial").Activate
Application.DisplayAlerts = False
ActiveWorkbook.Save

End If
End Sub

"KL" escribió:

Hola manu,

Aunque has omitido la mayor parte del codigo que usas, juzgando por el trozo que expones se ve que el codigo ya hace lo que
preguntas solo tienes que usar la funcion que te he posteado. Usando el trozo que has facilitado (el procedimiento Test), yo lo
haria de la siguiente manera (habra que llenar los vacios que se crearon al cortar tu el procedimiento original):

'-Inicio--
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

Public Function PrinterFind(Optional Match As String) As String()
Dim n%, lRet&, sBuf$, sCon$, aPrn$()
Const lLen& = 1024, sKey$ = "devices"

'
'written by keepITcool

'requires xl2000 or newer.
'returns a zerobased array of complete localized printer strings
'results are filtered on Match string, if no result the ubound = -1
'

'Split ActivePrinter string to get localized word for "on"
aPrn = Split(Excel.ActivePrinter)
sCon = " " & aPrn(UBound(aPrn) - 1) & " "

'Read all installed printers (1k bytes s/b enough)
sBuf = Space(lLen)
lRet = GetProfileString(sKey, vbNullString, vbNullString, sBuf, lLen)
If lRet = 0 Then
Err.Raise vbObjectError + 513, , "Can't read Profile"
Exit Function
End If

'Split buffer string
aPrn = Split(Left(sBuf, lRet - 1), vbNullChar)
'Filter array on Match
If Match <> vbNullString Then aPrn = Filter(aPrn, Match, -1, 1)

For n = LBound(aPrn) To UBound(aPrn)
'Add 16bit portname for each Printer
sBuf = Space(lLen)
lRet = GetProfileString(sKey, aPrn(n), vbNullString, sBuf, lLen)
aPrn(n) = aPrn(n) & sCon & _
Mid(sBuf, InStr(sBuf, ",") + 1, lRet - InStr(sBuf, ","))
Next
'Return the result
PrinterFind = aPrn

End Function

Sub Test()
Dim vaList, miImpresora As String
vaList = PrinterFind(Match:="Spa46433\Color Inforcom")
On Error Resume Next
miImpresora = Application.Index(vaList, 1)
On Error GoTo 0
If miImpresora <> "" Then

'aqui va el codigo que has omitido
nombreimpre =Application.ActivePrinter
ActiveWindow.SelectedSheets.PrintOut Copies:=2, ActivePrinter:= _
miImpresora, Collate:=True
'Restaura la impresora por defecto
Application.ActivePrinter = nombreimpre

Application.DisplayAlerts = False
ActiveWorkbook.Save
Sheets("DatosCliInfoComercial").Activate
'aqui va el codigo que has omitido

End If
End Sub
'-Final