Crear un Modulo Clase y . . . . (copiar - pegar este código)
Option Compare Database
Option Explicit
'Need a reference to bzpdfc.dll (Bullzip).
Private mPDFSettings As Bullzip.PDFPrinterSettings
Private mstrCurrentPrinterName As String
Private mstrPDFPrinterName As String
Private Const mintNoPDFPrinter As Integer = 1980
Private Const mintNoCurrentPrinter As Integer = 1981
Public Enum YesNoEnum
ynYes
ynNo
End Enum
Public Enum NofileAlwaysNeverEnum
nanNofile
nanAlways
nanNever
End Enum
Public Enum AlwaysNeverEnum
anAlways
anNever
End Enum
Public Enum YesNoAskEnum
ynaYes
ynaNo
ynaAsk
End Enum
Public Enum TargetEnum
tScreen
tEbook
tPrinter
tPrepress
tDefault
End Enum
Public Enum ZoomFitEnum
zfFitall
zfFitWidth
zfNone
End Enum
Public Enum TopBottomEnum
tbTop
tbBottom
End Enum
Public Enum TopBottomCenterEnum
tbcTop
tbcBottom
tbcCenter
End Enum
Public Enum LeftRightCenterEnum
lrcLeft
lrcRight
lrcCenter
End Enum
Public Enum KeyLengthEnum
klLength40 = 40
klLength128 = 128
End Enum
Public Enum SecuritySettingsEnum
ssPrintDocument = 4
ssModifyDocument = 8
ssCopyDetails = 16
ssModifyTextAndFillInFields = 32
ssFillInFields = 256
ssExtractTextAndGraphics = 512
ssAssembleDocumentIncBookmarks = 1024
ssPrintHightQuality = 2048
End Enum
Public Enum NoneAllEnum
naNone
naAll
End Enum
Public Enum OrientationEnum
oPortrait
oLandscapte
oSeascape
oUpsideDown
End Enum
Public Enum DeviceEnum
dBMPmono
dBMPGray
dBMPsep1
dBMPsep8
dBMP16
dBMP256
dBMP16m
dBMP32b
dEPSWrite
dJPEG
dJPEGGray
dPCXMono
dPCXGray
dPCX16
dPCX256
dPCX24b
dPCXcmyk
dPNGMono
dPNGGray
dPNG16
dPNG256
dPNG16m
dPNGAlpha
dTIFFGray
dTIFF12nc
dTIFF24nc
dTIFF32nc
dTIFFsep
dTIFFcrle
dTIFFg3
dTIFFg32d
dTIFFg4
dTIFFlzw
dTIFFpack
dPDFWrite
End Enum
Public Enum AlphaBitsEnum
ab1 = 1
ab2 = 2
ab4 = 4
End Enum
Public Enum PDFA1BEnum
PDFA1B
End Enum
'CLASS INITIALISATION AND TERMINATION ROUTINES.
Private Sub Class_Initialize()
Dim intI As Integer
Dim intPDFPrinterIndex As Integer
Dim intCurrentPrinterIndex As Integer
Set mPDFSettings = New Bullzip.PDFPrinterSettings
'Printer specific settings
mstrPDFPrinterName = mPDFSettings.GetPrinterName
'Find the index of the printer that we want to use
intPDFPrinterIndex = -1
intCurrentPrinterIndex = -1
mstrCurrentPrinterName = Application.Printer.DeviceName
For intI = 0 To Application.Printers.Count - 1
If Application.Printers.Item(intI).DeviceName = mstrPDFPrinterName Then
intPDFPrinterIndex = intI
End If
If Application.Printers.Item(intI).DeviceName = mstrCurrentPrinterName Then
intCurrentPrinterIndex = intI
End If
Next intI
'Exit here if the pdf printer was not found
If intPDFPrinterIndex = -1 Then
MsgBox "The printer '" & mstrPDFPrinterName & "' was not found on this computer."
Err.Raise mintNoPDFPrinter, Err.Source, "Unable to find PDF printer."
End If
'Exit here if the current printer was not found
If intCurrentPrinterIndex = -1 Then
MsgBox "The current printer '" & mstrCurrentPrinterName & "' was not found on this computer." & _
" Without this printer the code will not be able to restore the original printer selection."
Err.Raise mintNoCurrentPrinter, Err.Source, "Unable to find current printer."
End If
'Set the printer to the PDF printer.
Application.Printer = Application.Printers(intPDFPrinterIndex)
End Sub
Private Sub Class_Terminate()
Dim intI As Integer
Dim intCurrentPrinterIndex As Integer
For intI = 0 To Application.Printers.Count - 1
If Application.Printers.Item(intI).DeviceName = mstrCurrentPrinterName Then
intCurrentPrinterIndex = intI
End If
Next intI
If intCurrentPrinterIndex = -1 Then
Err.Raise mintNoCurrentPrinter, Err.Source, "Unable to find original printer to change back to from PDF printer."
Else
Application.Printer = Application.Printers(intCurrentPrinterIndex)
End If
Set mPDFSettings = Nothing
End Sub
'HELPER FUNCTIONS
Private Function YesNo(YesNoValue As YesNoEnum) As String
Select Case YesNoValue
Case YesNoEnum.ynYes
YesNo = "yes"
Case YesNoEnum.ynNo
YesNo = "no"
End Select
End Function
Private Function NofileAlwaysNever(NofileAlwaysNeverValue As NofileAlwaysNeverEnum) As String
Select Case NofileAlwaysNeverValue
Case NofileAlwaysNeverEnum.nanNofile
NofileAlwaysNever = "noFile"
Case NofileAlwaysNeverEnum.nanAlways
NofileAlwaysNever = "always"
Case NofileAlwaysNeverEnum.nanNever
NofileAlwaysNever = "never"
End Select
End Function
Private Function AlwaysNever(AlwaysNeverValue As AlwaysNeverEnum) As String
Select Case AlwaysNeverValue
Case AlwaysNeverEnum.anAlways
AlwaysNever = "always"
Case AlwaysNeverEnum.anNever
AlwaysNever = "never"
End Select
End Function
Private Function YesNoAsk(YesNoAskValue As YesNoAskEnum) As String
Select Case YesNoAskValue
Case YesNoAskEnum.ynaYes
YesNoAsk = "yes"
Case YesNoAskEnum.ynaNo
YesNoAsk = "no"
Case YesNoAskEnum.ynaAsk
YesNoAsk = "ask"
End Select
End Function
Private Function TargetFromEnum(TargetValue As TargetEnum) As String
'Case sensitive. Keep in lower case.
Select Case TargetValue
Case TargetEnum.tDefault
TargetFromEnum = "default"
Case TargetEnum.tEbook
TargetFromEnum = "ebook"
Case TargetEnum.tPrepress
TargetFromEnum = "prepress"
Case TargetEnum.tPrinter
TargetFromEnum = "printer"
Case TargetEnum.tScreen
TargetFromEnum = "screen"
End Select
End Function
Private Function ZoomFit(ZoomFitValue As ZoomFitEnum) As String
'Note needed as we have Zoom? TODO
Select Case ZoomFitValue
Case ZoomFitEnum.zfFitall
ZoomFit = "fitall"
Case ZoomFitEnum.zfFitWidth
ZoomFit = "fitwidth"
End Select
End Function
Private Function TopBottom(TopBottomValue As TopBottomEnum) As String
Select Case TopBottomValue
Case TopBottomEnum.tbTop
TopBottom = "top"
Case TopBottomEnum.tbBottom
TopBottom = "bottom"
End Select
End Function
Private Function TopBottomCenter(TopBottomCenterValue As TopBottomCenterEnum) As String
Select Case TopBottomCenterValue
Case TopBottomCenterEnum.tbcTop
TopBottomCenter = "top"
Case TopBottomCenterEnum.tbcBottom
TopBottomCenter = "bottom"
Case TopBottomCenterEnum.tbcCenter
TopBottomCenter = "center"
End Select
End Function
Private Function LeftRightCenter(LeftRightCenterValue As LeftRightCenterEnum) As String
Select Case LeftRightCenterValue
Case LeftRightCenterEnum.lrcLeft
LeftRightCenter = "left"
Case LeftRightCenterEnum.lrcRight
LeftRightCenter = "right"
Case LeftRightCenterEnum.lrcCenter
LeftRightCenter = "center"
End Select
End Function
Private Function NoneAll(NoneAllValue As NoneAllEnum) As String
Select Case NoneAllValue
Case NoneAllEnum.naAll
NoneAll = "all"
Case NoneAllEnum.naNone
NoneAll = "none"
End Select
End Function
Private Function OrientationFromEnum(OrientationValue As OrientationEnum) As String
Select Case OrientationValue
Case OrientationEnum.oPortrait
OrientationFromEnum = "portrait"
Case OrientationEnum.oLandscapte
OrientationFromEnum = "landscape"
Case OrientationEnum.oSeascape
OrientationFromEnum = "seascape"
Case OrientationEnum.oUpsideDown
OrientationFromEnum = "upsidedown"
End Select
End Function
Private Function DeviceFromEnum(DeviceValue As DeviceEnum) As String
Select Case DeviceValue
Case DeviceEnum.dBMPmono
DeviceFromEnum = "bmpmono"
Case DeviceEnum.dBMPGray
DeviceFromEnum = "bmpgray"
Case DeviceEnum.dBMPsep1
DeviceFromEnum = "bmpsep1"
Case DeviceEnum.dBMPsep8
DeviceFromEnum = "bmpsep8"
Case DeviceEnum.dBMP16
DeviceFromEnum = "bmp16"
Case DeviceEnum.dBMP256
DeviceFromEnum = "bmp256"
Case DeviceEnum.dBMP16m
DeviceFromEnum = "bmp16m"
Case DeviceEnum.dBMP32b
DeviceFromEnum = "bmp32b"
Case DeviceEnum.dEPSWrite
DeviceFromEnum = "epswrite"
Case DeviceEnum.dJPEG
DeviceFromEnum = "jpeg"
Case DeviceEnum.dJPEGGray
DeviceFromEnum = "jpeggray"
Case DeviceEnum.dPCXMono
DeviceFromEnum = "pcxmono"
Case DeviceEnum.dPCXGray
DeviceFromEnum = "pcxgray"
Case DeviceEnum.dPCX16
DeviceFromEnum = "pcx16"
Case DeviceEnum.dPCX256
DeviceFromEnum = "pcx256"
Case DeviceEnum.dPCX24b
DeviceFromEnum = "pcx24b"
Case DeviceEnum.dPCXcmyk
DeviceFromEnum = "pcxcmyk"
Case DeviceEnum.dPNGMono
DeviceFromEnum = "pngmono"
Case DeviceEnum.dPNGGray
DeviceFromEnum = "pnggray"
Case DeviceEnum.dPNG16
DeviceFromEnum = "png16"
Case DeviceEnum.dPNG256
DeviceFromEnum = "png256"
Case DeviceEnum.dPNG16m
DeviceFromEnum = "png16m"
Case DeviceEnum.dPNGAlpha
DeviceFromEnum = "pngalpha"
Case DeviceEnum.dTIFFGray
DeviceFromEnum = "tiffgray"
Case DeviceEnum.dTIFF12nc
DeviceFromEnum = "tiff12nc"
Case DeviceEnum.dTIFF24nc
DeviceFromEnum = "tiff24nc"
Case DeviceEnum.dTIFF32nc
DeviceFromEnum = "tiff32nc"
Case DeviceEnum.dTIFFsep
DeviceFromEnum = "tiffsep"
Case DeviceEnum.dTIFFcrle
DeviceFromEnum = "tiffcrle"
Case DeviceEnum.dTIFFg3
DeviceFromEnum = "tiffg3"
Case DeviceEnum.dTIFFg32d
DeviceFromEnum = "tiffg32d"
Case DeviceEnum.dTIFFg4
DeviceFromEnum = "tiffg4"
Case DeviceEnum.dTIFFlzw
DeviceFromEnum = "tifflzw"
Case DeviceEnum.dTIFFpack
DeviceFromEnum = "tiffpack"
Case DeviceEnum.dPDFWrite
DeviceFromEnum = "pdfwrite"
End Select
End Function
Private Function PDFA1BFromEnum(PDFA1BValue As PDFA1BEnum)
Select Case PDFA1BValue
Case PDFA1BEnum.PDFA1B
PDFA1BFromEnum = "pdfa1b"
End Select
End Function
'PDF PRINTER SETTINGS
Public Function Output(OutputFilePath As String)
mPDFSettings.SetValue "Output", OutputFilePath
End Function
Public Function ConfirmOverwrite(YesNoValue As YesNoEnum)
mPDFSettings.SetValue "ConfirmOverwrite", YesNo(YesNoValue)
End Function
Public Function ShowSaveAS(NofileAlwaysNeverValue As NofileAlwaysNeverEnum)
mPDFSettings.SetValue "NoFileAlwaysNever", NofileAlwaysNever(NofileAlwaysNeverValue)
End Function
Public Function ShowSettings(AlwaysNeverValue As AlwaysNeverEnum)
mPDFSettings.SetValue "ShowSettings", AlwaysNever(AlwaysNeverValue)
End Function
Public Function ShowPDF(YesNoAskValue As YesNoAskEnum)
mPDFSettings.SetValue "ShowPDF", YesNoAsk(YesNoAskValue)
End Function
'PDF DOCUMENT SETTINGS
Public Function Target(TargetValue As TargetEnum)
mPDFSettings.SetValue "Target", TargetFromEnum(TargetValue)
End Function
Public Function Author(AuthorValue As String)
mPDFSettings.SetValue "Author", "AuthorValue"
End Function
Public Function UseDefaultAuthor(YesNoValue As YesNoEnum)
mPDFSettings.SetValue "UseDefaultAuthor", YesNo(YesNoValue)
End Function
Public Function Title(TitleValue As String)
mPDFSettings.SetValue "Title", TitleValue
End Function
Public Function UseDefaultTitle(YesNoValue As YesNoEnum)
mPDFSettings.SetValue "UseDefaultTitle", YesNo(YesNoValue)
End Function
Public Function Subject(SubjectValue As String)
mPDFSettings.SetValue "Subject", SubjectValue
End Function
Public Function Keywords(KeywordsValues As String)
mPDFSettings.SetValue "Keywords", KeywordsValues
End Function
'PDF DISPLAY SETTINGS
Public Function Zoom(ZoomFitValue As ZoomFitEnum, Optional ZoomPercent As Byte)
'ZoomPercent of 0 gives no zoom.
If ZoomFitValue = zfNone Then
mPDFSettings.SetValue "Zoom", ZoomPercent
Else
mPDFSettings.SetValue "Zoom", ZoomFit(ZoomFitValue)
End If
End Function
Public Function UseThumbs(YesNoValue As YesNoEnum)
mPDFSettings.SetValue "UseThumbs", YesNo(YesNoValue)
End Function
Public Function AutoRotatePages(Optional NoneAllValue As NoneAllEnum = NoneAllEnum.naAll)
mPDFSettings.SetValue "AutoRotatePages", NoneAll(NoneAllValue)
End Function
Public Function Orientation(OrientationValue As OrientationEnum)
mPDFSettings.SetValue "Orientation", OrientationFromEnum(OrientationValue)
End Function
'WATERMARK SETTINGS
Public Function WatermarkText(WatermarkTextValue As String)
mPDFSettings.SetValue "WatermarkText", WatermarkTextValue
End Function
Public Function WatermarkTransparency(WatermarkTransparencyPercentValue As Byte)
If WatermarkTransparencyPercentValue > 100 Then
mPDFSettings.SetValue "WatermarkTransparency", 100
Else
mPDFSettings.SetValue "WatermarkTransparency", WatermarkTransparencyPercentValue
End If
End Function
Public Function WatermarkRotation(WatermarkRotationDegreesValue As Integer)
'Currently doesn't accept c2c or -c2c.
mPDFSettings.SetValue "WatermarkRotation", WatermarkRotationDegreesValue Mod 360
End Function
Public Function WatermarkColor(WatermarkColorHTMLColorValue As String)
'Pass as #RRGGBB
mPDFSettings.SetValue "WatermarkColor", WatermarkColorHTMLColorValue
End Function
Public Function WatermarkFontName(WatermarkFontNameValue As String)
'Default is arial.ttf
mPDFSettings.SetValue "WatermarkFontName", WatermarkFontNameValue
End Function
Public Function WatermarkFontSize(WatermarkFontSizeValue As Byte)
mPDFSettings.SetValue "WatermarkFontSize", WatermarkFontSizeValue
End Function
Public Function WatermarkOutlineWidth(WatermarkOutlineWidthValue As Byte)
'Default is 2.
mPDFSettings.SetValue "WatermarkOutlineWidth", WatermarkOutlineWidthValue
End Function
Public Function WatermarkLayer(WatermarkLayerValue As TopBottomEnum)
'Default is top.
mPDFSettings.SetValue "WatermarkLayer", TopBottom(WatermarkLayerValue)
End Function
Public Function WatermarkVerticalPosition(WatermarkVerticalPositionValue As TopBottomCenterEnum)
'Default is center.
mPDFSettings.SetValue "WatermarkVerticalPosition", TopBottomCenter(WatermarkVerticalPositionValue)
End Function
Public Function WatermarkHorizontalPosition(WatermarkHorizontalPositionValue As LeftRightCenterEnum)
'Default is center.
mPDFSettings.SetValue "WatermarkHorizontalPosition", LeftRightCenter(WatermarkHorizontalPositionValue)
End Function
Public Function WatermarkVerticalAdjustment(WatermarkVerticalAdjustmentValue As Byte)
'Percentage of page height.
mPDFSettings.SetValue "WatermarkVerticalAdjustment", WatermarkVerticalAdjustmentValue
End Function
Public Function WatermarkHorizontalAdjustment(WatermarkHorizontalAdjustmentValue As Byte)
'Percentage of page width.
mPDFSettings.SetValue "WatermarkHorizontalAdjustment", WatermarkHorizontalAdjustmentValue
End Function
Public Function PrinterName()
PrinterName = mPDFSettings.GetPrinterName
End Function
Public Function ShowProgress(ShowProgressValue As Boolean)
mPDFSettings.SetValue "ShowProgress", ShowProgressValue
End Function
Public Function ShowProgressFinished(ShowProgressFinishedValue As Boolean)
mPDFSettings.SetValue "ShowProgressFinished", ShowProgressFinishedValue
End Function
'MERGE SETTINGS.
Public Function MergeFiles(MergeIntoFileValue As String)
mPDFSettings.SetValue "MergeFile", MergeIntoFileValue
End Function
Public Function MergePosition(MergePositionValue As TopBottomEnum)
mPDFSettings.SetValue "MergePosition", TopBottom(MergePositionValue)
End Function
Public Function Superimpose(SuperimposeOnFileNameValue As String)
mPDFSettings.SetValue "Superimpose", SuperimposeOnFileNameValue
End Function
Public Function SuperimposeLayer(SuperimposeLayerValue As TopBottomEnum)
mPDFSettings.SetValue "SuperimposeLayer", TopBottom(SuperimposeLayerValue)
End Function
Public Function SuperimposeResolution(superimposeLayerResolutionDPIValue As Long)
If superimposeLayerResolutionDPIValue > 14400 Then
mPDFSettings.SetValue "SuperimposeResolution", 14400
Else
mPDFSettings.SetValue "SuperimposeResolution", superimposeLayerResolutionDPIValue
End If
End Function
'PDF SECURITY SETTINGS
Public Function OwnerPassword(PasswordValue As String)
mPDFSettings.SetValue "OwnerPassword", PasswordValue
End Function
Public Function UserPassword(PasswordValue As String)
mPDFSettings.SetValue "UserPassword", PasswordValue
End Function
Public Function KeyLength(KeyLengthValue As KeyLengthEnum)
mPDFSettings.SetValue "KeyLength)", KeyLengthValue
End Function
Public Function Permissions(Optional PrintDocument As Boolean = True, _
Optional ModifyDocument As Boolean = False, _
Optional CopyDetails As Boolean = True, _
Optional ModifyTextAndFillInFields As Boolean = False, _
Optional FillInFields As Boolean = True, _
Optional ExtractTextAndGraphics As Boolean = True, _
Optional AssembleDocumentIncBookmarks As Boolean = False, _
Optional PrintHighQuality As Boolean = True)
Dim lngPermissions As Long
'Default
lngPermissions = 61632
If PrintDocument = True Then
lngPermissions = lngPermissions + SecuritySettingsEnum.ssPrintDocument
End If
If ModifyDocument = True Then
lngPermissions = lngPermissions + SecuritySettingsEnum.ssModifyDocument
End If
If CopyDetails = True Then
lngPermissions = lngPermissions + SecuritySettingsEnum.ssCopyDetails
End If
If ModifyTextAndFillInFields = True Then
lngPermissions = lngPermissions + SecuritySettingsEnum.ssModifyTextAndFillInFields
End If
If FillInFields = True Then
lngPermissions = lngPermissions + SecuritySettingsEnum.ssFillInFields
End If
If ExtractTextAndGraphics = True Then
lngPermissions = lngPermissions + SecuritySettingsEnum.ssExtractTextAndGraphics
End If
If AssembleDocumentIncBookmarks = True Then
lngPermissions = lngPermissions + SecuritySettingsEnum.ssAssembleDocumentIncBookmarks
End If
If PrintHighQuality = True Then
lngPermissions = lngPermissions + SecuritySettingsEnum.ssPrintHightQuality
End If
mPDFSettings.SetValue "Permissions", lngPermissions
End Function
'IMAGE CREATION SETTINGS
Public Function Device(DeviceValue As DeviceEnum)
mPDFSettings.SetValue "Device", DeviceFromEnum(DeviceValue)
End Function
Public Function Res(DPIValue As Integer)
mPDFSettings.SetValue "Res", DPIValue
End Function
Public Function ResX(DPIValue As Integer)
mPDFSettings.SetValue "ResX", DPIValue
End Function
Public Function RexY(DPIValue As Integer)
mPDFSettings.SetValue "ResY", DPIValue
End Function
Public Function TextAlphaBits(TextAlphaBitsValue As AlphaBitsEnum)
mPDFSettings.SetValue "TextAlphaBits", TextAlphaBitsValue
End Function
Public Function GraphicsAlphaBits(GraphicsAlphaBitsValue As AlphaBitsEnum)
mPDFSettings.SetValue "GraphicsAlphaBits", GraphicsAlphaBitsValue
End Function
Public Function Format(MakePDFA1BCompliantValue As PDFA1BEnum)
mPDFSettings.SetValue "Format", PDFA1BFromEnum(MakePDFA1BCompliantValue)
End Function
'DO IT
Public Function WriteSettings(TrueOrFalse As Boolean)
mPDFSettings.WriteSettings TrueOrFalse
End Function