 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 |
Crear PDF mediante VBA con BulZip PDF Virtual
| Selection | File type icon | File name | Description | Size | Revision | Time | User |
|---|---|---|---|---|---|---|---|
|
ċ
|
Descargar |
Descargue El Ejemplo | 86 kb | v. 1 | 24 oct. 2011 19:33 | Jefferson Jimenez |