Macro Imprimir

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

Hola manu,

Podrias tambien explicar en que consiste el "..no va..."? Algun error? "Simplemente no ocurre nada? Etc.

Saludos,
KL


"manu" (novale)> wrote in message news:
> 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
>>
>>

Hola manu,

Podrias tambien explicar en que consiste el "..no va..."? Algun error? "Simplemente no ocurre nada? Etc.

Saludos,
KL


"manu" (novale)> wrote in message news:
> 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
>>
>>

Hola KL

Ante todo pedirte disculpas, puesto que el procedimiento que te he enviado
corre perfectamente y funciona a la perfección. El problema es que el Pc
donde hice la prueba, no tenia configurada bien esa impresora.

Muchas gracias por todo.

"KL" escribió:

Hola manu,

Podrias tambien explicar en que consiste el "..no va..."? Algun error? "Simplemente no ocurre nada? Etc.

Saludos,
KL


"manu" (novale)> wrote in message news:
> 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
>>
>>