![]() |
![]() ![]() v.5.2011.12.30 |
Бесплатные домены для портфолио и электронных визиток |
|
Visual Basic 5.0/6.0 - РазноеВсе примеры / РазноеСоздание PDF
Автор: vb6.us | добавлено: 28.03.2011, 17:49 | просмотров: 7812 (1+) | комментариев: 1 | рейтинг:
Простой пример создания документа в формате PDF на Visual Basic 6.0.
![]() ИнструкцииИспользовать так:Private Sub Command1_Click() Dim objPDF As New mjwPDF objPDF.PDFTitle = "Тестовый документ" objPDF.PDFFileName = App.Path & "\test.pdf" objPDF.PDFLoadAfm = App.Path & "\Fonts" objPDF.PDFView = True objPDF.PDFBeginDoc objPDF.PDFSetFont FONT_ARIAL, 15, FONT_BOLD objPDF.PDFSetTextColor = vbBlue objPDF.PDFTextOut "Привет, мир!" objPDF.PDFEndDoc End Sub КодVERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "mjwPDF" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Attribute VB_HelpID = 2005 '============================================================================== ' The original source code for this was posted online with no copyright info. ' I have since built upon it and made changes to create the mjwPDF class. ' I now copyright this Matthew West 2008. If you helped contribitute to the ' original source please email me (admin@vb6.us) and I will give you credit. ' ' This source was included with a tutorial posted at (www.vb6.us). Visit ' this site to see more PDF and other VB tutorials. ' ' This code can be used in any application as long as you notify me ' (admin@vb6.us). '============================================================================== Option Explicit Private Const mjwPDF = "1.3" Private Const mjwPDFVersion = "mjwPDF 1.0" Private wsPathConfig As String Private wsPathAdobe As String Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long Private Declare Function PostMessage Lib "user32" _ Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function FindWindow Lib "user32" _ Alias "FindWindowA" (ByVal szClass$, ByVal szTitle$) As Long Private Const WM_CLOSE = &H10 Private Declare Function PDFReadFile Lib "kernel32" Alias "ReadFile" _ (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Any) As Long Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Declare Function PDFCreateFile Lib "kernel32" Alias "CreateFileA" _ (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, _ ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long Private Declare Function PDFGetFileSize Lib "kernel32" Alias "GetFileSize" _ (ByVal hFile As Long, lpFileSizeHigh As Long) As Long Private Declare Function PDFCloseHandle Lib "kernel32" Alias "CloseHandle" _ (ByVal hObject As Long) As Long Private Type oOutlines sText As String iLevel As Integer yPos As Double iPageNb As Integer bPrev As Boolean bNext As Boolean bFirst As Boolean bLast As Boolean iFirst As Integer iNext As Integer iPrev As Integer iLast As Integer iParent As Integer End Type Private aOutlines() As oOutlines Private iOutlines As Integer Private aPage() As Variant Private Type PDFRGB in_r As Integer in_g As Integer in_b As Integer End Type Private Fso As Object Private Strm As Object Private sPDFName As String Private Arr_Font() As Variant Private in_offset As Integer Private in_FontNum As Integer Private in_PagesNum As Integer Private in_Ech As Double Private in_Canvas As Integer Private iWidthStr As Double Private in_xCurrent As Double Private in_yCurrent As Double Private ImgWidth As Double Private ImgHeight As Double Private xlink As Double Private yLink As Double Private strTLink As String Private strTyLink As String Private wRect As Long Private str_TmpFont As String Private PDFTextColor As String Private PDFLineColor As String Private PDFDrawColor As String Private PDFstrTextColor As String Private PDFstrLineColor As String Private PDFstrDrawColor As String Private PDFstrTempColor As String Private PDFstrTempAlign As String Private PDFstrTempBorder As String Private pTempAngle As Double Private PDFboTempFill As Boolean Private bPageBreak As Boolean Private PDFLnStyle As String Private PDFLnWidth As Double Private PDFDrawMode As String Private PDFZoomMode Private PDFLayoutMode Private PDFViewerPref Private bPDFViewerPref As Boolean Private bPDFWatermark As Boolean Private sPDFWatermark As String Private PDFAngle As Double Private bAngle As Double Private PDFFontName As String Private PDFFontSize As Integer Private PDFFontNum As Integer Private boPDFUnderline As Boolean Private boPDFItalic As Boolean Private boPDFBold As Boolean Private boPDFConfirm As Boolean Private boPDFView As Boolean Private PDFboThumbs As Boolean Private PDFboOutlines As Boolean Private PDFboImage As Boolean Private PDFlMargin As Integer ' Left Margin Private PDFtMargin As Integer ' Top Margin Private PDFrMargin As Integer ' Right Margin Private PDFbMargin As Integer ' Bottom Margin Private PDFcMargin As Integer ' Center Margin Private PDFMargin As Integer Private FFileName As String Private FTitle As String Private FPageNumber As Integer Private FPageLink As Integer Private FOrientation As String Private FAuthor As String Private FCreator As String Private FKeywords As String Private FSubject As String Private FProducer As String Private FFileCompress As Boolean Private ParentNum, ContentNum, ResourceNum, FontNum, CatalogNum, _ FontNumber, CurrentPDFSetPageObject, NumberofImages, iOutlineRoot As Integer Private PDFCanvasWidth() Private PDFCanvasHeight() Private PDFCanvasOrientation() Private CurrentObjectNum As Integer Private ObjectOffset As Long Private ObjectOffsetList As Variant Private PageNumberList As Variant Private PageLinksList(1 To 1000, 1 To 1000) As Variant Private LinksList As Variant Private PageCanvasWidth As Variant Private PageCanvasHeight As Variant Private FontNumberList As Variant Private Type aIMG in_1 As Variant in_2 As Variant in_3 As Variant in_4 As Variant in_5 As Variant in_6 As Variant in_7 As Variant in_8 As Variant End Type Private ArrIMG() As aIMG Private boPageLinksList As Variant Private NbPageLinksList As Variant Private CRCounter As Long Private ColorSpace As String Private ColorCount As Byte Private ImageStream As String Private TempStream As String Private pTempStream As String Private sTempStream As String Private cTempStream As String Private dTempStream As String Private StreamSize1, StreamSize2 As Integer Private bScanAdobe As Boolean Enum PDFStyleLgn pPDF_SOLID = 0 pPDF_DASH = 1 pPDF_DASHDOT = 2 pPDF_DASHDOTDOT = 3 End Enum Enum PDFFontStl FONT_NORMAL = 0 FONT_ITALIC = 1 FONT_BOLD = 2 FONT_UNDERLINE = 3 End Enum Enum PDFFontNme FONT_ARIAL = 0 FONT_COURIER = 1 FONT_TIMES = 2 FONT_SYMBOL = 3 FONT_ZAPFDINGBATS = 4 End Enum Enum PDFZoomMd ZOOM_FULLPAGE = 0 ZOOM_FULLWIDTH = 1 ZOOM_REAL = 2 ZOOM_DEFAULT = 3 End Enum Enum PDFLayoutMd LAYOUT_SINGLE = 0 LAYOUT_CONTINOUS = 1 LAYOUT_TWO = 2 LAYOUT_DEFAULT = 3 End Enum Enum PDFUnitStr UNIT_PT = 0 UNIT_MM = 1 UNIT_CM = 2 End Enum Enum PDFOrientationStr ORIENT_PAYSAGE = 0 ORIENT_PORTRAIT = 1 End Enum Enum PDFFormatPgStr FORMAT_A4 = 0 FORMAT_A3 = 1 FORMAT_A5 = 2 FORMAT_LETTER = 3 FORMAT_LEGAL = 4 End Enum Enum PDFDrawMd DRAW_NORMAL = 0 DRAW_DRAW = 1 DRAW_DRAWBORDER = 2 End Enum Enum PDFAlignValue ALIGN_CENTER = 0 ALIGN_LEFT = 1 ALIGN_RIGHT = 2 ALIGN_FJUSTIFY = 3 End Enum Enum PDFBorderValue BORDER_NONE = 0 BORDER_ALL = 1 BORDER_TOP = 2 BORDER_BOTTOM = 3 BORDER_LEFT = 4 BORDER_RIGHT = 5 End Enum Enum PDFViewerCst VIEW_HIDETOOLBAR = 1 VIEW_HIDEMENUBAR = 2 VIEW_HIDEWINDOWUI = 3 VIEW_FITWINDOW = 4 VIEW_CENTERWINDOW = 5 VIEW_DISPLAYDOCTITLE = 6 End Enum Property Let PDFPathConfiguration(sPathConfig As String) wsPathConfig = sPathConfig End Property Property Let PDFSetViewerPreferences(pViewerPref As PDFViewerCst) bPDFViewerPref = True PDFViewerPref = pViewerPref End Property Property Let PDFWatermark(sWatermark As String) bPDFWatermark = True sPDFWatermark = sWatermark End Property Private Sub PDFRotationText(x As Double, y As Double, sText As String, pAngle As Integer) PDFSetRotation = pAngle PDFTextOut sText, x, y PDFSetRotation = 0 End Sub Private Sub PDFHeader() Dim dH As Double Dim dL As Double If bPDFWatermark Then PDFSetFont FONT_ARIAL, 50, FONT_BOLD PDFSetTextColor = Array(255, 192, 203) dH = (PDFGetPageHeight + PDFGetStringWidth(sPDFWatermark, "", 50) * Sin(45)) / 2.15 dL = (PDFGetPageWidth - PDFGetStringWidth(sPDFWatermark, "", 50) * Cos(45)) / 2.75 PDFRotationText dL, dH, sPDFWatermark, 45 End If End Sub Property Let PDFSetZoomMode(pZoomMode As PDFZoomMd) Attribute PDFSetZoomMode.VB_HelpID = 2009 If pZoomMode = ZOOM_FULLPAGE Or pZoomMode = ZOOM_FULLWIDTH Or _ pZoomMode = ZOOM_REAL Or pZoomMode = ZOOM_DEFAULT Or _ (IsNumeric(pZoomMode) And (pZoomMode <> ZOOM_FULLPAGE Or _ pZoomMode <> ZOOM_FULLWIDTH Or _ pZoomMode <> ZOOM_REAL Or _ pZoomMode <> ZOOM_DEFAULT)) Then If IsNumeric(pZoomMode) Then PDFZoomMode = Int(pZoomMode) Else PDFZoomMode = pZoomMode End If Else MsgBox "Incorrect Zoom Mode : " & pZoomMode & "." & _ vbNewLine & _ "Focus will be set to full-page zoom", vbCritical, "Zoom Mode - " & mjwPDFVersion PDFZoomMode = ZOOM_FULLPAGE End If End Property Property Get PDFGetZoomMode() As Variant Attribute PDFGetZoomMode.VB_HelpID = 2010 PDFGetZoomMode = PDFZoomMode End Property Property Let PDFUseThumbs(boThumbs As Boolean) Attribute PDFUseThumbs.VB_HelpID = 2011 PDFboThumbs = boThumbs End Property Property Let PDFUseOutlines(boOutlines As Boolean) Attribute PDFUseOutlines.VB_HelpID = 2012 PDFboOutlines = boOutlines End Property Property Let PDFSetLayoutMode(pLayoutMode As PDFLayoutMd) Attribute PDFSetLayoutMode.VB_HelpID = 2013 If pLayoutMode = LAYOUT_SINGLE Or pLayoutMode = LAYOUT_CONTINOUS Or _ pLayoutMode = LAYOUT_TWO Or pLayoutMode = LAYOUT_DEFAULT Then PDFLayoutMode = pLayoutMode Else MsgBox "Layout incorrect : " & pLayoutMode & "." & _ vbNewLine & _ "Layout will be set to simple single page.", vbCritical, "Layout Mode - " & mjwPDFVersion PDFLayoutMode = LAYOUT_SINGLE End If End Property Property Get PDFGetLayoutMode() As Variant Attribute PDFGetLayoutMode.VB_HelpID = 2014 PDFGetLayoutMode = PDFLayoutMode End Property Property Let PDFSetUnit(str_Unite As PDFUnitStr) Attribute PDFSetUnit.VB_HelpID = 2015 Select Case str_Unite Case UNIT_PT in_Ech = 1 Case UNIT_MM in_Ech = 72 / 25.4 Case UNIT_CM in_Ech = 72 / 2.54 Case Else MsgBox "Incorrect Unit of Measure : " & str_Unite & "." & _ vbNewLine & _ "Using centimeter ", vbCritical, "Error in measurement unit - " & mjwPDFVersion in_Ech = 72 / 2.54 End Select End Property Property Get PDFGetUnit() As String Attribute PDFGetUnit.VB_HelpID = 2016 Select Case in_Ech Case 1 PDFGetUnit = "pt" Case 72 / 25.4 PDFGetUnit = "mm" Case 72 / 2.54 PDFGetUnit = "cm" End Select End Property Property Let PDFOrientation(str_Orientation As PDFOrientationStr) Attribute PDFOrientation.VB_HelpID = 2017 Dim tmp_PDFCanvasWidth As Integer Dim tmp_PDFCanvasHeight As Integer ReDim Preserve PDFCanvasWidth(1 To in_Canvas) ReDim Preserve PDFCanvasHeight(1 To in_Canvas) ReDim Preserve PDFCanvasOrientation(1 To in_Canvas) tmp_PDFCanvasWidth = PDFCanvasWidth(in_Canvas) tmp_PDFCanvasHeight = PDFCanvasHeight(in_Canvas) Select Case str_Orientation Case ORIENT_PORTRAIT PDFCanvasWidth(in_Canvas) = tmp_PDFCanvasWidth PDFCanvasHeight(in_Canvas) = tmp_PDFCanvasHeight PDFCanvasOrientation(in_Canvas) = "p" Case ORIENT_PAYSAGE PDFCanvasWidth(in_Canvas) = tmp_PDFCanvasHeight PDFCanvasHeight(in_Canvas) = tmp_PDFCanvasWidth PDFCanvasOrientation(in_Canvas) = "l" Case Else MsgBox "Orientation set incorrectly: " & str_Orientation & "." & _ vbNewLine & _ "Orientation set to portrait.", vbCritical, "Error in orientation - " & mjwPDFVersion PDFCanvasWidth(in_Canvas) = tmp_PDFCanvasWidth PDFCanvasHeight(in_Canvas) = tmp_PDFCanvasHeight PDFCanvasOrientation(in_Canvas) = "p" End Select ReDim Preserve PDFCanvasWidth(1 To in_Canvas) ReDim Preserve PDFCanvasHeight(1 To in_Canvas) ReDim Preserve PDFCanvasOrientation(1 To in_Canvas) End Property Property Let PDFFormatPage(str_FormatPage As Variant) Attribute PDFFormatPage.VB_HelpID = 2018 ReDim Preserve PDFCanvasWidth(1 To in_Canvas) ReDim Preserve PDFCanvasHeight(1 To in_Canvas) ReDim Preserve PDFCanvasOrientation(1 To in_Canvas) Select Case TypeName(str_FormatPage) Case "Long" Select Case str_FormatPage Case FORMAT_A4 PDFCanvasWidth(in_Canvas) = 595.28 PDFCanvasHeight(in_Canvas) = 841.89 Case FORMAT_A3 PDFCanvasWidth(in_Canvas) = 841.89 PDFCanvasHeight(in_Canvas) = 1190.55 Case FORMAT_A5 PDFCanvasWidth(in_Canvas) = 420.94 PDFCanvasHeight(in_Canvas) = 595.28 Case FORMAT_LETTER PDFCanvasWidth(in_Canvas) = 612 PDFCanvasHeight(in_Canvas) = 792 Case FORMAT_LEGAL PDFCanvasWidth(in_Canvas) = 612 PDFCanvasHeight(in_Canvas) = 1008 Case Else MsgBox "Format page set incorrectly : " & str_FormatPage & "." & _ vbNewLine & _ "Format page set to A4.", vbCritical, "Format Page - " & mjwPDFVersion PDFCanvasWidth(in_Canvas) = 595.28 PDFCanvasHeight(in_Canvas) = 841.89 End Select Case "Double()" PDFCanvasWidth(in_Canvas) = str_FormatPage(0) PDFCanvasHeight(in_Canvas) = str_FormatPage(1) Case Else MsgBox "Format page set incorrectly : " & str_FormatPage & "." & _ vbNewLine & _ "Format page set to A4", vbCritical, "Format Page - " & mjwPDFVersion PDFCanvasWidth(in_Canvas) = 595.28 PDFCanvasHeight(in_Canvas) = 841.89 End Select End Property Property Get PDFPageNumber() As Integer Attribute PDFPageNumber.VB_HelpID = 2019 PDFPageNumber = FPageNumber End Property Property Get PDFNbPage() As Integer Attribute PDFNbPage.VB_HelpID = 2020 PDFNbPage = UBound(PageNumberList) End Property Property Let PDFProducer(str_Producer As String) Attribute PDFProducer.VB_HelpID = 2021 FProducer = str_Producer End Property Property Let PDFSubject(str_Subject As String) Attribute PDFSubject.VB_HelpID = 2022 FSubject = str_Subject End Property Property Let PDFKeywords(str_Keywords As String) Attribute PDFKeywords.VB_HelpID = 2023 FKeywords = str_Keywords End Property Property Let PDFCreator(str_Creator As String) Attribute PDFCreator.VB_HelpID = 2024 FCreator = str_Creator End Property Property Let PDFAuthor(str_Author As String) Attribute PDFAuthor.VB_HelpID = 2025 FAuthor = str_Author End Property Property Let PDFTitle(str_Title As String) Attribute PDFTitle.VB_HelpID = 2027 FTitle = str_Title End Property Property Let PDFFileName(str_FileName As String) Attribute PDFFileName.VB_HelpID = 2028 Dim Items() As String Dim sFilePath As String Dim sFileName As String Dim hWnd As Long Dim retval As Long Dim in_i As Long On Error GoTo Err_File FFileName = str_FileName Items = Split(str_FileName, "\") If UBound(Items) = -1 Then Exit Property sFileName = Items(UBound(Items)) sFilePath = Left(str_FileName, Len(str_FileName) - Len(Items(UBound(Items)))) sPDFName = Fso.BuildPath(sFilePath, sFileName) Set Strm = Fso.CreateTextFile(sPDFName, True) Exit Property Err_File: If Err = 70 Then hWnd = FindWindow(vbNullString, "Adobe Reader - [" & sFileName & "]") retval = PostMessage(hWnd, WM_CLOSE, 0&, 0&) Sleep 17 Set Strm = Fso.CreateTextFile(sPDFName, True) Resume Next End If End Property Property Get PDFGetFileName() As String PDFGetFileName = FFileName End Property Property Let PDFConfirm(boConfirm As Boolean) Attribute PDFConfirm.VB_HelpID = 2029 boPDFConfirm = boConfirm End Property Property Let PDFView(boView As Boolean) boPDFView = boView End Property Property Let PDFPageHeight(in_PageHeight As Double) Attribute PDFPageHeight.VB_HelpID = 2030 PDFCanvasHeight(in_Canvas) = in_PageHeight End Property Property Get PDFGetPageHeight() As Double Attribute PDFGetPageHeight.VB_HelpID = 2031 PDFGetPageHeight = PDFCanvasHeight(in_Canvas) End Property Property Let PDFPageWidth(in_PageWidth As Double) Attribute PDFPageWidth.VB_HelpID = 2032 PDFCanvasWidth(in_Canvas) = in_PageWidth End Property Property Get PDFGetPageWidth() As Double Attribute PDFGetPageWidth.VB_HelpID = 2033 PDFGetPageWidth = PDFCanvasWidth(in_Canvas) End Property Property Let PDFSetLeftMargin(in_left As Double) Attribute PDFSetLeftMargin.VB_HelpID = 2034 PDFlMargin = in_left End Property Property Get PDFGetLeftMargin() As Double Attribute PDFGetLeftMargin.VB_HelpID = 2035 PDFGetLeftMargin = PDFlMargin End Property Property Let PDFSetRightMargin(in_right As Double) Attribute PDFSetRightMargin.VB_HelpID = 2036 PDFrMargin = in_right End Property Property Get PDFGetRightMargin() As Double Attribute PDFGetRightMargin.VB_HelpID = 2037 PDFGetRightMargin = PDFrMargin End Property Property Let PDFSetTopMargin(in_top As Double) Attribute PDFSetTopMargin.VB_HelpID = 2038 PDFtMargin = in_top End Property Property Get PDFGetTopMargin() As Double Attribute PDFGetTopMargin.VB_HelpID = 2039 PDFGetTopMargin = PDFtMargin End Property Property Let PDFSetBottomMargin(in_bottom As Double) Attribute PDFSetBottomMargin.VB_HelpID = 2040 PDFbMargin = in_bottom End Property Property Get PDFGetBottomMargin() As Double Attribute PDFGetBottomMargin.VB_HelpID = 2041 PDFGetBottomMargin = PDFbMargin End Property Property Let PDFSetCellMargin(in_cell As Double) Attribute PDFSetCellMargin.VB_HelpID = 2042 PDFcMargin = in_cell End Property Property Get PDFGetCellMargin() As Double Attribute PDFGetCellMargin.VB_HelpID = 2043 PDFGetCellMargin = PDFcMargin End Property Public Sub PDFSetMargins(in_left As Integer, in_top As Integer, Optional in_right As Integer = -1, Optional in_bottom As Integer = -1) Attribute PDFSetMargins.VB_HelpID = 2044 PDFlMargin = in_left PDFtMargin = in_top If in_right = -1 Then in_right = in_left If in_bottom = -1 Then in_bottom = in_top PDFrMargin = in_right PDFbMargin = in_bottom End Sub Property Get PDFGetX() As Integer Attribute PDFGetX.VB_HelpID = 2045 PDFGetX = in_xCurrent End Property Property Get PDFGetY() As Integer Attribute PDFGetY.VB_HelpID = 2046 PDFGetY = in_yCurrent End Property Property Let PDFSetLineStyle(pLineStyle As PDFStyleLgn) Attribute PDFSetLineStyle.VB_HelpID = 2047 PDFLnStyle = PDFLineStyle(pLineStyle) End Property Property Let PDFSetLineWidth(pLineWidth As Double) Attribute PDFSetLineWidth.VB_HelpID = 2048 PDFLnWidth = pLineWidth End Property Property Let PDFSetDrawMode(pDrawMode As PDFDrawMd) Attribute PDFSetDrawMode.VB_HelpID = 2049 Dim pTmpDrawMode As String pTmpDrawMode = LCase(pDrawMode) Select Case pTmpDrawMode Case DRAW_NORMAL PDFDrawMode = "" Case DRAW_DRAW PDFDrawMode = "D" Case DRAW_DRAWBORDER PDFDrawMode = "DB" Case Else MsgBox "Draw Mode set incorrectly : " & pDrawMode & "." & _ vbNewLine & _ "Draw mode set to normal", vbCritical, "Object Rectangle - " & mjwPDFVersion PDFDrawMode = "" End Select End Property Private Function PDFLineStyle(pLineStyle As PDFStyleLgn) As String Attribute PDFLineStyle.VB_HelpID = 2050 Dim pTmpLineStyle As PDFStyleLgn PDFLineStyle = "" pTmpLineStyle = pLineStyle Select Case pTmpLineStyle Case pPDF_SOLID PDFLineStyle = "[] 0 d" Case pPDF_DASH PDFLineStyle = "[" & Int(16 * in_Ech) & " " & Int(8 * in_Ech) & " ] 0 d" Case pPDF_DASHDOT PDFLineStyle = "[" & Int(8 * in_Ech) & " " & Int(7 * in_Ech) & " " & _ Int(2 * in_Ech) & " " & Int(7 * in_Ech) & " ] 0 d" Case pPDF_DASHDOTDOT PDFLineStyle = "[" & Int(8 * in_Ech) & " " & Int(4 * in_Ech) & " " & _ Int(2 * in_Ech) & " " & Int(4 * in_Ech) & " " & _ Int(2 * in_Ech) & " " & Int(4 * in_Ech) & " ] 0 d" Case Else MsgBox "Line style set incorrectly : " & pLineStyle & "." & _ vbNewLine & _ "Line style set to solid.", vbCritical, "Line Style - " & mjwPDFVersion PDFLineStyle = "[] 0 d" End Select End Function Public Sub PDFSetFont(str_Fontname As PDFFontNme, in_FontSize As Integer, Optional str_Style As PDFFontStl) Attribute PDFSetFont.VB_HelpID = 2051 Dim str_TmpFontName As String Dim str_TmpFontNm As String If str_Fontname <> FONT_ARIAL And _ str_Fontname <> FONT_COURIER And _ str_Fontname <> FONT_SYMBOL And _ str_Fontname <> FONT_TIMES And _ str_Fontname <> FONT_ZAPFDINGBATS Then MsgBox "Font name set incorrectly : " & str_Style & "." & _ vbNewLine & _ "Font set to Times New Roman.", vbCritical, "Font name - " & mjwPDFVersion str_TmpFontName = "TimesRoman" boPDFItalic = False boPDFBold = False PDFFontName = str_TmpFontName PDFFontNum = FontNum PDFFontSize = in_FontSize FontNum = FontNum + 1 Exit Sub End If Select Case str_Fontname Case FONT_ARIAL str_TmpFontNm = "Arial" Case FONT_COURIER str_TmpFontNm = "Courier" Case FONT_TIMES str_TmpFontNm = "Times" Case FONT_SYMBOL str_TmpFontNm = "Symbol" Case FONT_ZAPFDINGBATS str_TmpFontNm = "ZapfDingbats" End Select If str_TmpFontNm = "Arial" Then str_TmpFontName = "Helvetica" Else str_TmpFontName = str_TmpFontNm End If boPDFItalic = False boPDFBold = False str_TmpFont = str_TmpFontName If InStr(1, str_Style, FONT_ITALIC) <> 0 Then boPDFItalic = True If InStr(1, str_Style, FONT_BOLD) <> 0 Then boPDFBold = True If InStr(1, str_Style, FONT_UNDERLINE) <> 0 Then boPDFUnderline = True If boPDFItalic = True And boPDFBold = False Then Select Case str_TmpFontName Case "Times" str_TmpFontName = "TimesItalic" Case Else str_TmpFontName = str_TmpFontName & "-Oblique" End Select End If If boPDFItalic = True And boPDFBold = True Then Select Case str_TmpFontName Case "Times" str_TmpFontName = str_TmpFontName & "-BoldItalic" Case Else str_TmpFontName = str_TmpFontName & "-BoldOblique" End Select End If If boPDFItalic = False And boPDFBold = True Then str_TmpFontName = str_TmpFontName & "-Bold" End If If boPDFItalic = False And boPDFBold = False Then Select Case str_TmpFontName Case "Times" str_TmpFontName = str_TmpFontName & "-Roman" Case Else str_TmpFontName = str_TmpFontName End Select End If PDFFontName = str_TmpFontName PDFFontNum = FontNum PDFFontSize = in_FontSize FontNum = FontNum + 1 End Sub Public Sub PDFDrawEllipse(x As Double, y As Double, rx As Double, Optional ry As Double = 0, Optional URLLink As String = "") Attribute PDFDrawEllipse.VB_HelpID = 2056 Dim sTempDrawMode As String If ry = 0 Then ry = rx Select Case PDFDrawMode Case "D" PDFOutStream sTempStream, PDFDrawColor sTempDrawMode = "h f" Case "DB" PDFOutStream sTempStream, PDFDrawColor PDFOutStream sTempStream, PDFLineColor sTempDrawMode = "B" Case "" PDFOutStream sTempStream, PDFLineColor sTempDrawMode = "s" End Select PDFOutStream sTempStream, PDFLnStyle PDFOutStream sTempStream, PDFFormatDouble(x * in_Ech) & " " & PDFFormatDouble(PDFCanvasHeight(in_Canvas) - (y + ry / 2) * in_Ech) & " m" PDFOutStream sTempStream, PDFCurve(x * in_Ech, _ PDFCanvasHeight(in_Canvas) - (y + ry / 2 - ry / 2 * 11 / 20) * in_Ech, _ (x + rx / 2 - rx / 2 * 11 / 20) * in_Ech, _ PDFCanvasHeight(in_Canvas) - y * in_Ech, _ (x + rx / 2) * in_Ech, _ PDFCanvasHeight(in_Canvas) - y * in_Ech) PDFOutStream sTempStream, PDFCurve((x + rx / 2 + rx / 2 * 11 / 20) * in_Ech, _ PDFCanvasHeight(in_Canvas) - y * in_Ech, _ (x + rx) * in_Ech, _ PDFCanvasHeight(in_Canvas) - (y + ry / 2 - ry / 2 * 11 / 20) * in_Ech, _ (x + rx) * in_Ech, _ PDFCanvasHeight(in_Canvas) - (y + ry / 2) * in_Ech) PDFOutStream sTempStream, PDFCurve((x + rx) * in_Ech, _ PDFCanvasHeight(in_Canvas) - (y + ry / 2 + ry / 2 * 11 / 20) * in_Ech, _ (x + rx / 2 + rx / 2 * 11 / 20) * in_Ech, _ PDFCanvasHeight(in_Canvas) - (y + ry) * in_Ech, _ (x + rx / 2) * in_Ech, _ PDFCanvasHeight(in_Canvas) - (y + ry) * in_Ech) PDFOutStream sTempStream, PDFCurve((x + rx / 2 - rx / 2 * 11 / 20) * in_Ech, _ PDFCanvasHeight(in_Canvas) - (y + ry) * in_Ech, _ x * in_Ech, _ PDFCanvasHeight(in_Canvas) - (y + ry / 2 + ry / 2 * 11 / 20) * in_Ech, _ x * in_Ech, _ PDFCanvasHeight(in_Canvas) - (y + ry / 2) * in_Ech) PDFOutStream sTempStream, PDFFormatDouble(PDFLnWidth * in_Ech) & " w " & sTempDrawMode PDFSetTextColor = vbWhite strTLink = "LINK" strTyLink = "ELLIPSE" PDFSetLink URLLink, "ELLIPSE", Int((x - rx / 2)), Int((y + ry / 2 - ry / 2 * 11 / 20)) strTyLink = "" in_xCurrent = x in_yCurrent = y + ry / 2 End Sub Private Function PDFCurve(x1, y1, x2, y2, x3, y3 As Double) As String Attribute PDFCurve.VB_HelpID = 2057 PDFCurve = PDFFormatDouble(x1) & " " & _ PDFFormatDouble(y1) & " " & _ PDFFormatDouble(x2) & " " & _ PDFFormatDouble(y2) & " " & _ PDFFormatDouble(x3) & " " & _ PDFFormatDouble(y3) & " c" End Function Public Sub PDFDrawPolygon(ParamArray pParam() As Variant) Dim sTempDrawMode As String Dim nbP As Double Dim in_i As Integer nbP = (UBound(pParam(0), 1) + 1) / 2 Select Case PDFDrawMode Case "D" PDFOutStream sTempStream, PDFDrawColor sTempDrawMode = "h f" Case "DB" PDFOutStream sTempStream, PDFDrawColor PDFOutStream sTempStream, PDFLineColor sTempDrawMode = "B" Case "" PDFOutStream sTempStream, PDFLineColor sTempDrawMode = "s" End Select PDFOutStream sTempStream, "%DEBUT_POLY/%" PDFOutStream sTempStream, PDFLnStyle PDFPoint CDbl(pParam(0)(0)), CDbl(pParam(0)(1)) For in_i = 2 To nbP * 2 - 1 If in_i Mod 2 = 0 Then PDFLine CDbl(pParam(0)(in_i)), CDbl(pParam(0)(in_i + 1)) End If Next in_i PDFLine CDbl(pParam(0)(0)), CDbl(pParam(0)(1)) PDFOutStream sTempStream, PDFFormatDouble(PDFLnWidth * in_Ech) & " w " & sTempDrawMode PDFOutStream sTempStream, "%FIN_POLY/%" End Sub Private Function PDFPoint(x As Double, y As Double) PDFOutStream sTempStream, PDFFormatDouble(x * in_Ech) & " " & _ PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y * in_Ech) & " m" End Function Private Function PDFLine(x As Double, y As Double) PDFOutStream sTempStream, PDFFormatDouble(x * in_Ech) & " " & _ PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y * in_Ech) & " l" End Function Public Sub PDFDrawLineHor(x As Double, y As Double, w As Double) Attribute PDFDrawLineHor.VB_HelpID = 2059 If Right(PDFLineColor, 2) = "RG" Then PDFDrawColor = Left(PDFLineColor, Len(PDFLineColor) - 2) & "rg" Else PDFDrawColor = Left(PDFLineColor, Len(PDFLineColor) - 1) & "g" End If PDFOutStream sTempStream, "%DEBUT_LNH/%" PDFOutStream sTempStream, PDFLnStyle PDFOutStream sTempStream, PDFFormatDouble(x * in_Ech) & " " & PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y * in_Ech) & " m" PDFOutStream sTempStream, PDFFormatDouble((x + w) * in_Ech) & " " & PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y * in_Ech) & " l" PDFOutStream sTempStream, PDFLineColor PDFOutStream sTempStream, PDFFormatDouble(PDFLnWidth * in_Ech) & " w S" PDFOutStream sTempStream, "%FIN_LNH/%" in_xCurrent = x + w in_yCurrent = y End Sub Public Sub PDFDrawLineVer(x As Double, y As Double, h As Double) Attribute PDFDrawLineVer.VB_HelpID = 2060 If Right(PDFLineColor, 2) = "RG" Then PDFDrawColor = Left(PDFLineColor, Len(PDFLineColor) - 2) & "rg" Else PDFDrawColor = Left(PDFLineColor, Len(PDFLineColor) - 1) & "g" End If PDFOutStream sTempStream, "%DEBUT_LNV/%" PDFOutStream sTempStream, PDFLnStyle PDFOutStream sTempStream, PDFFormatDouble(x * in_Ech) & " " & PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y * in_Ech) & " m" PDFOutStream sTempStream, PDFFormatDouble(x * in_Ech) & " " & PDFFormatDouble(PDFCanvasHeight(in_Canvas) - (y + h) * in_Ech) & " l" PDFOutStream sTempStream, PDFLineColor PDFOutStream sTempStream, PDFFormatDouble(PDFLnWidth * in_Ech) & " w S" PDFOutStream sTempStream, "%FIN_LNV/%" in_xCurrent = x in_yCurrent = y + h End Sub Public Sub PDFDrawLine(x1 As Double, y1 As Double, x2 As Double, y2 As Double) Attribute PDFDrawLine.VB_HelpID = 2061 PDFOutStream sTempStream, "%DEBUT_LN/%" PDFOutStream sTempStream, PDFLnStyle PDFOutStream sTempStream, PDFFormatDouble(x1 * in_Ech) & " " & PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y1 * in_Ech) & " m" PDFOutStream sTempStream, PDFFormatDouble(x2 * in_Ech) & " " & PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y2 * in_Ech) & " l" PDFOutStream sTempStream, PDFLineColor PDFOutStream sTempStream, PDFFormatDouble(PDFLnWidth * in_Ech) & " w S" PDFOutStream sTempStream, "%FIN_LN/%" If x1 > x2 Then in_xCurrent = x1 Else in_xCurrent = x2 End If If y1 > y2 Then in_yCurrent = y1 Else in_yCurrent = y2 End If End Sub Public Sub PDFDrawRectangle(x As Double, y As Double, w As Double, h As Double, Optional URLLink As String = "") Dim sTempDrawMode As String PDFOutStream sTempStream, "%DEBUT_RECT/%" Select Case PDFDrawMode Case "D" PDFOutStream sTempStream, PDFDrawColor sTempDrawMode = "f" Case "DB" PDFOutStream sTempStream, PDFDrawColor PDFOutStream sTempStream, PDFLineColor sTempDrawMode = "B" Case "" PDFOutStream sTempStream, PDFLineColor sTempDrawMode = "s" End Select PDFOutStream sTempStream, PDFLnStyle PDFOutStream sTempStream, PDFFormatDouble(x * in_Ech) & " " & _ PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y * in_Ech) & " " & _ PDFFormatDouble(w * in_Ech) & " " & _ PDFFormatDouble(-1 * h * in_Ech) & " re " & sTempDrawMode PDFOutStream sTempStream, PDFFormatDouble(PDFLnWidth * in_Ech) & " w S" PDFSetTextColor = vbWhite strTLink = "LINK" strTyLink = "RECTANGLE" wRect = w PDFSetLink URLLink, "RECTANGLE", Int(x + 5), Int(y + h / 2) PDFOutStream sTempStream, "%FIN_RECT/%" strTyLink = "" in_xCurrent = x in_yCurrent = y + h End Sub Private Function PDFHtml2RgbColor(sColor As String) As PDFRGB Dim sTmpColor As String sTmpColor = Right("000000" & sColor, 6) PDFHtml2RgbColor.in_r = CByte("&h" & Mid(sTmpColor, 1, 2)) PDFHtml2RgbColor.in_g = CByte("&h" & Mid(sTmpColor, 3, 2)) PDFHtml2RgbColor.in_b = CByte("&h" & Mid(sTmpColor, 5, 2)) End Function Property Let PDFSetTextColor(gColor As Variant) Attribute PDFSetTextColor.VB_HelpID = 2063 Dim TxtCl As PDFRGB Dim sColor As String Select Case TypeName(gColor) Case "Variant()" TxtCl.in_r = gColor(0) TxtCl.in_g = gColor(1) TxtCl.in_b = gColor(2) Case "String" If Left(gColor, 1) <> "#" Then MsgBox "Invalid HTMl color set" & gColor & "." & _ vbNewLine & _ "Set color to black.", vbCritical, "Text Color " & mjwPDFVersion TxtCl = PDFGetRGB(vbBlack) Else TxtCl = PDFHtml2RgbColor(CStr(gColor)) End If Case Else TxtCl = PDFGetRGB(Int(gColor)) End Select PDFTextColor = PDFStreamColor(TxtCl, "TEXT") End Property Property Get PDFGetTextColor() As String Attribute PDFGetTextColor.VB_HelpID = 2064 PDFGetTextColor = PDFstrTextColor End Property Property Let PDFSetLineColor(gColor As Variant) Attribute PDFSetLineColor.VB_HelpID = 2065 Dim TxtCl As PDFRGB Dim sColor As String Select Case TypeName(gColor) Case "Variant()" TxtCl.in_r = gColor(0) TxtCl.in_g = gColor(1) TxtCl.in_b = gColor(2) Case "String" If Left(gColor, 1) <> "#" Then MsgBox "Invalid line color set " & gColor & "." & _ vbNewLine & _ "Setting line color to black.", vbCritical, "Line Color - " & mjwPDFVersion TxtCl = PDFGetRGB(vbBlack) Else TxtCl = PDFHtml2RgbColor(CStr(gColor)) End If Case Else TxtCl = PDFGetRGB(Int(gColor)) End Select PDFLineColor = PDFStreamColor(TxtCl, "LINE") End Property Property Get PDFGetLineColor() As String Attribute PDFGetLineColor.VB_HelpID = 2066 PDFGetLineColor = PDFstrLineColor End Property Property Let PDFSetDrawColor(gColor As Variant) Attribute PDFSetDrawColor.VB_HelpID = 2067 Dim TxtCl As PDFRGB Dim sColor As String Select Case TypeName(gColor) Case "Variant()" TxtCl.in_r = gColor(0) TxtCl.in_g = gColor(1) TxtCl.in_b = gColor(2) Case "String" If Left(gColor, 1) <> "#" Then MsgBox "Invalid Draw Color set " & gColor & "." & _ vbNewLine & _ "Using black.", vbCritical, "Draw Color - " & mjwPDFVersion TxtCl = PDFGetRGB(vbBlack) Else TxtCl = PDFHtml2RgbColor(CStr(gColor)) End If Case Else TxtCl = PDFGetRGB(Int(gColor)) End Select PDFDrawColor = PDFStreamColor(TxtCl, "BORDER") End Property Property Get PDFGetDrawColor() As String Attribute PDFGetDrawColor.VB_HelpID = 2068 PDFGetDrawColor = PDFstrDrawColor End Property Private Function PDFStreamColor(PDFRgbColor As PDFRGB, str_Type As String) As String Attribute PDFStreamColor.VB_HelpID = 2069 Dim int_r As Integer Dim int_g As Integer Dim int_b As Integer Dim str_TxtColor As String int_r = PDFRgbColor.in_r int_g = PDFRgbColor.in_g int_b = PDFRgbColor.in_b Select Case str_Type Case "TEXT", "BORDER" str_TxtColor = Replace(Format(int_r / 255, "0.000"), ",", ".") & " " & _ Replace(Format(int_g / 255, "0.000"), ",", ".") & " " & _ Replace(Format(int_b / 255, "0.000"), ",", ".") & " rg" Case "LINE" str_TxtColor = Replace(Format(int_r / 255, "0.000"), ",", ".") & " " & _ Replace(Format(int_g / 255, "0.000"), ",", ".") & " " & _ Replace(Format(int_b / 255, "0.000"), ",", ".") & " RG" End Select PDFStreamColor = str_TxtColor End Function Property Let PDFSetAlignement(gAlignement As PDFAlignValue) Select Case gAlignement Case 2 PDFstrTempAlign = "R" Case 0 PDFstrTempAlign = "C" Case 1 PDFstrTempAlign = "L" Case 3 PDFstrTempAlign = "FJ" Case Else MsgBox "Invalid alignment set. : " & gAlignement & "." & _ vbNewLine & _ "Using left alignment.", vbCritical, "Alignment - " & mjwPDFVersion PDFstrTempAlign = "L" End Select End Property Property Get PDFGetAlignement() As String Dim strTempAlign As String Select Case PDFstrTempAlign Case "C" strTempAlign = "Center" Case "R" strTempAlign = "Right" Case "L" strTempAlign = "Left" Case Else strTempAlign = "Left" End Select PDFGetAlignement = strTempAlign End Property Public Sub PDFLink(x As Double, y As Double, str_Text As String, Optional str_Link As String = "") Attribute PDFLink.VB_HelpID = 2070 Dim w As Integer Dim h As Integer pTempAngle = 0 PDFOutStream sTempStream, "%DEBUT_LINK/%" boPDFUnderline = True If PDFboImage = True Then PDFSetTextColor = vbBlue w = Int(ImgWidth) h = Int(ImgHeight) PDFTextOut "", x, y Else Select Case strTyLink Case "ELLIPSE" w = Int(PDFGetStringWidth(strTLink, PDFFontName, PDFFontSize)) h = Int(PDFFontSize) PDFTextOut "", x, y Case "RECTANGLE" w = wRect h = Int(PDFFontSize) PDFTextOut "", x, y Case "CELL" w = Int(PDFGetStringWidth(strTLink, PDFFontName, PDFFontSize)) h = Int(PDFFontSize) PDFTextOut "", x, y Case Else w = Int(PDFGetStringWidth(str_Text, PDFFontName, PDFFontSize)) h = Int(PDFFontSize) PDFTextOut str_Text, x, y End Select End If PDFboImage = False boPDFUnderline = False strTyLink = "" If str_Link = "" Then str_Link = str_Text PDFTabLinks x, y, w, h, str_Text, str_Link PDFOutStream sTempStream, "%FIN_LINK/%" End Sub Private Sub PDFTabLinks(x As Double, y As Double, w As Integer, h As Integer, str_Text As String, Optional str_Link As Variant = 0) Attribute PDFTabLinks.VB_HelpID = 2071 FPageLink = FPageLink + 1 ReDim Preserve LinksList(1 To FPageLink) LinksList(FPageLink) = Array(FPageNumber, y, str_Link) If str_Link <> 0 Then PageLinksList(FPageNumber, FPageLink) = Array(x * in_Ech, PDFCanvasHeight(in_Canvas) - y * in_Ech, w * in_Ech, h * in_Ech, str_Link) Else PageLinksList(FPageNumber, FPageLink) = Array(x * in_Ech, PDFCanvasHeight(in_Canvas) - y * in_Ech, w * in_Ech, h * in_Ech, str_Text) End If ReDim Preserve boPageLinksList(1 To FPageNumber) ReDim Preserve NbPageLinksList(1 To FPageNumber) boPageLinksList(FPageNumber) = True NbPageLinksList(FPageNumber) = FPageLink End Sub Property Get PDFTextHeight() As Double PDFTextHeight = PDFFontSize * in_Ech End Property Property Let PDFSetRotation(pAngle As Double) PDFAngle = -1 * pAngle End Property Private Sub PDFStreamRotate(pAngle As Double, x As Double, y As Double) Dim dSin As Double Dim dCos As Double Dim CenterX As Double Dim CenterY As Double If pAngle <> 0 Then pAngle = pAngle * 3.1416 / 180 dCos = Cos(pAngle) dSin = Sin(pAngle) CenterX = x * in_Ech CenterY = PDFCanvasHeight(in_Canvas) - y * in_Ech PDFOutStream sTempStream, PDFFormatDouble(dCos, 5) & " " & _ PDFFormatDouble(-1 * dSin, 5) & " " & _ PDFFormatDouble(dSin, 5) & " " & _ PDFFormatDouble(dCos, 5) & " " & _ PDFFormatDouble(CenterX) & " " & _ PDFFormatDouble(CenterY) & " Tm" End If bAngle = True End Sub Public Sub PDFTextOut(str_Text As String, Optional x As Double = 0, Optional y As Double = 0) Attribute PDFTextOut.VB_HelpID = 2072 Dim j As Integer Dim in_PositionFont As Integer Dim str_Tmp As String Dim str_TmpText As String str_TmpText = Replace(str_Text, "\", "\\") str_TmpText = Replace(str_TmpText, "\\", "\\\\") str_TmpText = Replace(str_TmpText, "(", "\(") str_TmpText = Replace(str_TmpText, ")", "\)") str_Tmp = "" If x = 0 Then x = in_xCurrent If y = 0 Then y = in_yCurrent If PDFFontName = "" Then in_PositionFont = 1 Else For j = 0 To UBound(Arr_Font) If Arr_Font(j) = PDFFontName Then in_PositionFont = j + 1 Exit For End If Next j End If If PDFFontSize = 0 Then PDFFontSize = 10 If PDFTextColor <> "" Then PDFOutStream sTempStream, "q " & PDFTextColor & " " If boPDFUnderline Then str_Tmp = PDFUnderline(False, str_Text, CDbl(x * in_Ech), CDbl(y * in_Ech)) PDFOutStream sTempStream, "%DEBUT_TEXT/%" PDFOutStream sTempStream, "BT" If PDFAngle = 0 Then PDFOutStream sTempStream, PDFFormatDouble((x + PDFlMargin) * in_Ech) & " " & PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y * in_Ech) & " Td" Else PDFStreamRotate PDFAngle, x, y PDFAngle = 0 End If PDFOutStream sTempStream, "/F" & in_PositionFont & " " & PDFFormatDouble(PDFFontSize) & " Tf" PDFOutStream sTempStream, "(" & str_TmpText & ") Tj" If PDFTextColor <> "" Then PDFOutStream sTempStream, "ET" If boPDFUnderline = True Then PDFOutStream sTempStream, str_Tmp End If PDFOutStream sTempStream, "Q" Else PDFOutStream sTempStream, "ET" If boPDFUnderline = True Then PDFOutStream sTempStream, str_Tmp End If End If PDFOutStream sTempStream, "%FIN_TEXT/%" boPDFUnderline = False in_xCurrent = x + PDFGetStringWidth(str_Text, PDFFontName, PDFFontSize) in_yCurrent = y + PDFFontSize End Sub Property Let PDFSetBorder(gBorder As PDFBorderValue) PDFstrTempBorder = "" Select Case gBorder Case BORDER_ALL PDFstrTempBorder = "1" Case BORDER_NONE PDFstrTempBorder = "0" Case BORDER_TOP PDFstrTempBorder = "T" Case BORDER_BOTTOM PDFstrTempBorder = "B" Case BORDER_LEFT PDFstrTempBorder = "L" Case BORDER_RIGHT PDFstrTempBorder = "R" Case Else If InStr(1, gBorder, BORDER_LEFT, 1) <> 0 Then PDFstrTempBorder = PDFstrTempBorder & "L" If InStr(1, gBorder, BORDER_RIGHT, 1) <> 0 Then PDFstrTempBorder = PDFstrTempBorder & "R" If InStr(1, gBorder, BORDER_TOP, 1) <> 0 Then PDFstrTempBorder = PDFstrTempBorder & "T" If InStr(1, gBorder, BORDER_BOTTOM, 1) <> 0 Then PDFstrTempBorder = PDFstrTempBorder & "B" End Select End Property Property Let PDFSetFill(bFill As Boolean) PDFboTempFill = bFill End Property Public Sub PDFCell(str_Text As String, x As Double, y As Double, w As Double, h As Double, Optional URLLink As String = "") Dim WidthMax As Double Dim lText As Integer Dim sCar As String Dim tWidth As Double Dim tBorder As String Dim yPos As Double Dim bMulti As Boolean Dim bBorder1 As String Dim bBorder2 As String Dim iSep As Integer Dim I, j, l As Integer Dim nl As Integer tWidth = w yPos = y WidthMax = (w - 2 * PDFcMargin) * 10 / PDFFontSize lText = Len(str_Text) If lText > 0 And Right(str_Text, lText - 1) = vbNewLine Then lText = lText - 1 End If bBorder1 = "" tBorder = PDFstrTempBorder If PDFstrTempBorder = "LRTB" Or PDFstrTempBorder = 1 Then bBorder1 = "LRT" bBorder2 = "LR" Else bBorder2 = "" If InStr(1, PDFstrTempBorder, "L", 1) <> 0 Then bBorder2 = bBorder2 & BORDER_LEFT If InStr(1, PDFstrTempBorder, "R", 1) <> 0 Then bBorder2 = bBorder2 & BORDER_RIGHT bBorder1 = IIf(InStr(1, PDFstrTempBorder, "T", 1) <> 0, bBorder2 = bBorder2 & BORDER_TOP, bBorder2) End If iSep = -1 I = 1 j = 1 l = 0 nl = 1 PDFOutStream sTempStream, "%DEBUT_CELL/%" While I <= lText sCar = Mid(str_Text, I, 1) If sCar = vbCrLf Then PDFstrTempBorder = bBorder1 PDFCell2 Mid(str_Text, j, I - j), x, yPos, tWidth, h yPos = in_yCurrent bMulti = True I = I + 1 iSep = -1 j = I l = 0 nl = nl + 1 If nl = 2 Then bBorder1 = bBorder2 End If If sCar = " " Then iSep = I End If l = l + PDFGetStringWidth(sCar, PDFFontName, PDFFontSize) If l > WidthMax Then If iSep = -1 Then If I = j Then I = I + 1 PDFstrTempBorder = bBorder1 PDFCell2 Mid(str_Text, j, I - j), x, yPos, tWidth, h yPos = in_yCurrent bMulti = True Else PDFstrTempBorder = bBorder1 PDFCell2 Mid(str_Text, j, iSep - j), x - PDFcMargin, yPos, tWidth, h yPos = in_yCurrent bMulti = True I = iSep + 1 End If iSep = -1 j = I l = 0 nl = nl + 1 If nl = 2 Then bBorder1 = bBorder2 Else I = I + 1 End If Wend If InStr(1, tBorder, "B", 1) <> 0 Or tBorder = 1 Then bBorder1 = bBorder1 & "B" PDFstrTempBorder = bBorder1 End If yPos = IIf(bMulti, in_yCurrent, yPos) PDFCell2 Mid(str_Text, j, I - j), x - PDFcMargin, yPos, tWidth, h boPDFUnderline = False If PDFstrTempAlign = "FJ" Then PDFOutStream sTempStream, "0 Tw" iWidthStr = 0 End If PDFOutStream sTempStream, "%FIN_CELL/%" End Sub Private Function PDFGetNumberOfCar(sText As String, sCar As String) As Integer Dim iNbCar As Integer Dim in_i As Integer iNbCar = 0 in_i = InStr(1, sText, sCar) If in_i <> 0 Then iNbCar = 1 Do While in_i <> 0 in_i = InStr(in_i + 1, sText, sCar) If in_i <> 0 Then iNbCar = iNbCar + 1 Loop PDFGetNumberOfCar = iNbCar End Function Private Sub PDFCell2(str_Text As String, x As Double, y As Double, w As Double, h As Double, Optional URLLink As String = "") Attribute PDFCell2.VB_HelpID = 2073 Dim j As Integer Dim dx As Integer Dim ltmp As Integer Dim in_PositionFont As Integer Dim str_Tmp As String Dim str_TmpSTR As String Dim str_TmpText As String Dim in_Px As Integer Dim in_Pw As String Dim in_Py As String Dim iWidthMax As Double Dim str_Tmp1 As String str_TmpText = Replace(str_Text, "\", "\\") str_TmpText = Replace(str_TmpText, "\\", "\\\\") str_TmpText = Replace(str_TmpText, "(", "\(") str_TmpText = Replace(str_TmpText, ")", "\)") str_Tmp1 = "" dx = 0 'x = x + PDFcMargin If PDFFontName = "" Then in_PositionFont = 1 Else For j = 0 To UBound(Arr_Font) If Arr_Font(j) = PDFFontName Then in_PositionFont = j + 1 Exit For End If Next j End If If PDFFontSize = 0 Then PDFFontSize = 10 If PDFLineColor <> "" Then PDFOutStream sTempStream, Trim(PDFLineColor) If PDFDrawColor <> "" Then PDFOutStream sTempStream, PDFDrawColor If PDFboTempFill = True Or PDFstrTempBorder = "1" Then If PDFboTempFill = True Then If PDFstrTempBorder = "1" Then str_Tmp = "B" Else str_Tmp = "f" End If Else str_Tmp = "S" End If str_TmpSTR = PDFFormatDouble(x * in_Ech) & " " & _ PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y * in_Ech) & " " & _ PDFFormatDouble(w * in_Ech) & " " & _ PDFFormatDouble(-h * in_Ech) & " re " & str_Tmp & vbCr End If If PDFstrTempBorder <> "0" And PDFstrTempBorder <> "1" Then PDFOutStream sTempStream, PDFFormatDouble(PDFLnWidth * in_Ech) & " w" If InStr(1, PDFstrTempBorder, "L", 1) <> 0 Then _ str_TmpSTR = str_TmpSTR & PDFFormatDouble(x * in_Ech) & " " & _ PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y * in_Ech) & " m " & PDFFormatDouble(x * in_Ech) & " " & _ PDFFormatDouble(PDFCanvasHeight(in_Canvas) - (y + h) * in_Ech) & " l S" & vbCr If InStr(1, PDFstrTempBorder, "T", 1) <> 0 Then _ str_TmpSTR = str_TmpSTR & PDFFormatDouble(x * in_Ech) & " " & _ PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y * in_Ech) & " m " & PDFFormatDouble(x * in_Ech + w * in_Ech) & " " & _ PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y * in_Ech) & " l S " & vbCr If InStr(1, PDFstrTempBorder, "R", 1) <> 0 Then _ str_TmpSTR = str_TmpSTR & PDFFormatDouble(x * in_Ech + w * in_Ech) & " " & _ PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y * in_Ech) & " m " & PDFFormatDouble(x * in_Ech + w * in_Ech) & " " & _ PDFFormatDouble(PDFCanvasHeight(in_Canvas) - (y + h) * in_Ech) & " l S " & vbCr If InStr(1, PDFstrTempBorder, "B", 1) <> 0 Then _ str_TmpSTR = str_TmpSTR & PDFFormatDouble(x * in_Ech) & " " & _ PDFFormatDouble(PDFCanvasHeight(in_Canvas) - (y + h) * in_Ech) & " m " & PDFFormatDouble(x * in_Ech + w * in_Ech) & " " & _ PDFFormatDouble(PDFCanvasHeight(in_Canvas) - (y + h) * in_Ech) & " l S " & vbCr End If PDFstrTempBorder = "0" If PDFstrTempAlign = "" Then PDFstrTempAlign = "L" Select Case PDFstrTempAlign Case "R" ltmp = PDFGetStringWidth(str_Text, PDFFontName, PDFFontSize) dx = w * in_Ech - PDFcMargin - Format(ltmp, "###0.00") Case "C" ltmp = PDFGetStringWidth(str_Text, PDFFontName, PDFFontSize) dx = (w * in_Ech - ltmp) / 2 Case "L" dx = 2 * PDFcMargin Case "FJ" iWidthMax = (w * in_Ech - (PDFGetNumberOfCar(str_Text, " ") + 1) * PDFcMargin) iWidthStr = (iWidthMax - PDFGetStringWidth(str_Text, PDFFontName, PDFFontSize)) / IIf(PDFGetNumberOfCar(str_Text, " ") <> 0, PDFGetNumberOfCar(str_Text, " "), 1) PDFOutStream sTempStream, PDFFormatDouble(iWidthStr * in_Ech, 3) & " Tw" dx = 2 * PDFcMargin End Select If str_TmpSTR <> "" Then PDFOutStream sTempStream, str_TmpSTR If URLLink <> "" Then boPDFUnderline = True PDFTabLinks (x + dx), _ (y + 0.5 * h - 0.5 * PDFFontSize), _ PDFGetStringWidth(str_Text, PDFFontName, PDFFontSize), _ CDbl(PDFFontSize), _ str_Text, URLLink End If If boPDFUnderline Then str_Tmp1 = PDFUnderline(True, str_Text, CDbl((x * in_Ech + dx)), _ PDFCanvasHeight(in_Canvas) - (y * in_Ech + 0.5 * h * in_Ech + 0.3 * PDFFontSize)) If PDFTextColor <> "" Then PDFOutStream sTempStream, "q " & PDFTextColor & " " If boPDFUnderline = True Then PDFOutStream sTempStream, str_Tmp1 End If End If xlink = 0 xlink = x yLink = 0 yLink = y PDFOutStream sTempStream, "BT" PDFOutStream sTempStream, "/F" & in_PositionFont & " " & PDFFontSize & " Tf" PDFOutStream sTempStream, PDFFormatDouble((x * in_Ech + dx)) & " " & _ PDFFormatDouble((PDFCanvasHeight(in_Canvas) - (y * in_Ech + 0.5 * h * in_Ech + 0.3 * PDFFontSize))) & _ " Td" PDFOutStream sTempStream, "(" & str_TmpText & ") Tj" If PDFTextColor <> "" Then PDFOutStream sTempStream, "ET" PDFOutStream sTempStream, "Q" Else PDFOutStream sTempStream, "ET" End If strTLink = str_Text strTyLink = "CELL" PDFSetLink URLLink, "CELL", xlink, yLink strTyLink = "" in_xCurrent = x + w in_yCurrent = y + h End Sub Private Sub PDFSetLink(URLLink As String, OType As String, x As Double, y As Double) Attribute PDFSetLink.VB_HelpID = 2074 If TypeName(URLLink) = "String" Then If OType = "IMAGE" Then PDFboImage = True Else PDFboImage = False End If If URLLink <> "" Then PDFLink x, y, URLLink strTLink = "" PDFboImage = False Else Select Case OType Case "CELL" MsgBox "Invalid URL link : " & URLLink & "." & _ vbNewLine & _ "Unable to include link.", vbCritical, "Url Link - " & mjwPDFVersion Case "IMAGE" MsgBox "Invalid URL image object: " & URLLink & "." & _ vbNewLine & _ "Unable to include URL image.", vbCritical, "Url Link Image - " & mjwPDFVersion Case "RECT" MsgBox "Invalid URL rectangle: " & URLLink & "." & _ vbNewLine & _ "Unable to include URL rectangle.", vbCritical, "Url Link Rectangle - " & mjwPDFVersion Case "ELLIPSE" MsgBox "Invalid URL Ellipse : " & URLLink & "." & _ vbNewLine & _ "Unable ot include URL Ellipse.", vbCritical, "Url Link Ellipse - " & mjwPDFVersion End Select End If End Sub Public Function PDFImageWidth(pFileName As String) As Double Dim ArrInfo As Variant Dim in_pos As Integer in_pos = InStr(1, pFileName, ".", 1) If in_pos = 0 Then MsgBox "File " & pFileName & " does not have an extension" & _ vbNewLine & _ "Invalid filename specified.", vbCritical, "Image File - " & mjwPDFVersion Exit Function End If If Right(pFileName, 3) = "jpg" Or Right(pFileName, 4) = "jpeg" Then ArrInfo = PDFParseJPG(pFileName) If TypeName(ArrInfo) = "Boolean" Then If ArrInfo = False Then Exit Function End If Else MsgBox "Image format not supported." & _ vbNewLine & _ "Only JPEG images are supported." & _ vbNewLine & _ "Impossible to include image in PDF file.", vbCritical, "Image File - " & mjwPDFVersion Exit Function End If PDFImageWidth = ArrInfo(0) End Function Public Function PDFImageHeight(pFileName As String) As Double Dim ArrInfo As Variant Dim in_pos As Integer in_pos = InStr(1, pFileName, ".", 1) If in_pos = 0 Then MsgBox "File " & pFileName & " does not have an extension" & _ vbNewLine & _ "Invalid filename specified.", vbCritical, "Image File - " & mjwPDFVersion Exit Function End If If Right(pFileName, 3) = "jpg" Or Right(pFileName, 4) = "jpeg" Then ArrInfo = PDFParseJPG(pFileName) If TypeName(ArrInfo) = "Boolean" Then If ArrInfo = False Then Exit Function End If Else MsgBox "Image format not supported." & _ vbNewLine & _ "Only JPEG images are supported." & _ vbNewLine & _ "Impossible to include image in PDF file.", vbCritical, "Image File - " & mjwPDFVersion Exit Function End If PDFImageHeight = ArrInfo(1) End Function Public Sub PDFImage(pFileName As String, x As Double, y As Double, Optional w As Double = 0, Optional h As Double = 0, Optional URLLink As String = "") Attribute PDFImage.VB_HelpID = 2075 Dim in_pos As Integer Dim ArrInfo As Variant in_pos = InStr(1, pFileName, ".", 1) If in_pos = 0 Then MsgBox "File " & pFileName & " does not have an extension" & _ vbNewLine & _ "Invalid filename specified.", vbCritical, "Image File - " & mjwPDFVersion Exit Sub End If If Right(pFileName, 3) = "jpg" Or Right(pFileName, 4) = "jpeg" Then ArrInfo = PDFParseJPG(pFileName) If TypeName(ArrInfo) = "Boolean" Then If ArrInfo = False Then Exit Sub End If Else MsgBox "Image format not supported." & _ vbNewLine & _ "Only JPEG images are supported." & _ vbNewLine & _ "Impossible to include image in PDF file.", vbCritical, "Image File - " & mjwPDFVersion Exit Sub End If If w = 0 And h = 0 Then w = ArrInfo(0) / in_Ech h = ArrInfo(1) / in_Ech End If If w = 0 Then w = h * ArrInfo(0) / ArrInfo(1) If h = 0 Then h = w * ArrInfo(1) / ArrInfo(0) NumberofImages = NumberofImages + 1 PDFOutStream sTempStream, "q" PDFOutStream sTempStream, PDFFormatDouble(w * in_Ech) & " 0 0 " & _ PDFFormatDouble(h * in_Ech) & " " & _ PDFFormatDouble(x * in_Ech) & " " & _ PDFFormatDouble(PDFCanvasHeight(in_Canvas) - (y + h) * in_Ech) & " cm /ImgJPEG" & _ NumberofImages & " Do Q" ImgWidth = w ImgHeight = h PDFSetLink URLLink, "IMAGE", x, y in_xCurrent = (x + w) * in_Ech in_yCurrent = (y + h) * in_Ech End Sub Private Function PDFParseJPG(pFileName As String) As Variant Attribute PDFParseJPG.VB_HelpID = 2076 Const OPEN_EXISTING = 3 Const FILE_SHARE_READ = &H1 Const GENERIC_READ = &H80000000 Const FILE_BEGIN = 0 Dim in_File As Long Dim in_Bytes As Long Dim str_TChar As String Dim in_res As Long Dim sIMG As Long Dim inIMG Dim in_PEnd As Long Dim in_idx As Long Dim str_SegmMk As String Dim in_SegmSz As Long Dim bChar As Byte Dim in_TmpColor As Long Dim in_bpc As Long Dim ArrBFile() As Byte ReDim Preserve ArrIMG(1 To NumberofImages + 1) ' Extract info from a JPEG file inIMG = FreeFile in_File = PDFCreateFile(pFileName, GENERIC_READ, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, 0, 0) sIMG = PDFGetFileSize(in_File, 0) If sIMG < 250 Then MsgBox "File Image is non JPEG" & _ vbNewLine & _ "Cannot add image to PDF file.", vbCritical, "File Image - " & mjwPDFVersion PDFParseJPG = False PDFCloseHandle in_File Exit Function End If ArrIMG(NumberofImages + 1).in_8 = sIMG ReDim Preserve ArrBFile(1 To 1, 1 To sIMG) As Byte in_res = PDFReadFile(in_File, ArrBFile(1, 1), sIMG, in_Bytes, ByVal 0&) in_PEnd = UBound(ArrBFile, 2) - 1 If PDFIntAsHex(ArrBFile, 1) <> "FFD8" Or PDFIntAsHex(ArrBFile, in_PEnd) <> "FFD9" Then MsgBox "Invalid JPEG marker" & _ vbNewLine & _ "Cannot add iamge to PDF file.", vbCritical, "File Image - " & mjwPDFVersion PDFParseJPG = False PDFCloseHandle in_File Exit Function End If in_idx = 3 Do While in_idx < in_PEnd str_SegmMk = PDFIntAsHex(ArrBFile, in_idx) in_SegmSz = PDFIntVal(ArrBFile, in_idx + 2) If str_SegmMk = "FFFF" Then Do While ArrBFile(1, in_idx + 1) = &HFF in_idx = in_idx + 1 Loop in_SegmSz = PDFIntVal(ArrBFile, in_idx + 2) End If Select Case str_SegmMk Case "FFE0" bChar = ArrBFile(1, in_idx + 11) If bChar = 0 Then ArrIMG(NumberofImages + 1).in_7 = "Dots" ElseIf bChar = 1 Then ArrIMG(NumberofImages + 1).in_7 = "Dots/inch (DPI)" ElseIf bChar = 2 Then ArrIMG(NumberofImages + 1).in_7 = "Dots/cm" Else MsgBox "Invalid image resolution" & bChar & _ "Valid resolution is: 0, 1, 2." & _ vbNewLine & _ "Cannot add image to PDF file.", vbCritical, "File Image - " & mjwPDFVersion PDFParseJPG = False PDFCloseHandle in_File Exit Function End If Case "FFC0", "FFC1", "FFC2", "FFC3", "FFC5", "FFC6", "FFC7" ArrIMG(NumberofImages + 1).in_1 = PDFIntVal(ArrBFile, in_idx + 7) ArrIMG(NumberofImages + 1).in_2 = PDFIntVal(ArrBFile, in_idx + 5) in_TmpColor = ArrBFile(1, in_idx + 9) * 8 If in_TmpColor = 8 Then ArrIMG(NumberofImages + 1).in_3 = "DeviceGray" ElseIf in_TmpColor = 24 Then ArrIMG(NumberofImages + 1).in_3 = "DeviceRGB" ElseIf in_TmpColor = 32 Then ArrIMG(NumberofImages + 1).in_3 = "DeviceCMYK" Else ArrIMG(NumberofImages + 1).in_4 = in_TmpColor End If End Select in_idx = in_idx + in_SegmSz + 2 Loop PDFCloseHandle in_File If ArrIMG(NumberofImages + 1).in_4 <> "" Then in_bpc = ArrIMG(NumberofImages + 1).in_4 Else in_bpc = 8 ArrIMG(NumberofImages + 1).in_4 = 8 End If ArrIMG(NumberofImages + 1).in_5 = "DCTDecode" ArrIMG(NumberofImages + 1).in_6 = "" Open pFileName For Binary As #inIMG str_TChar = String(sIMG, " ") Get #inIMG, , str_TChar ArrIMG(NumberofImages + 1).in_6 = ArrIMG(NumberofImages + 1).in_6 & str_TChar Close #inIMG PDFParseJPG = Array(ArrIMG(NumberofImages + 1).in_1, _ ArrIMG(NumberofImages + 1).in_2, _ ArrIMG(NumberofImages + 1).in_3, _ in_bpc, ArrIMG(NumberofImages + 1).in_5, _ ArrIMG(NumberofImages + 1).in_6, _ ArrIMG(NumberofImages + 1).in_7, _ ArrIMG(NumberofImages + 1).in_8) End Function Private Function PDFIntAsHex(ArrBF As Variant, in_Index As Long) As String Attribute PDFIntAsHex.VB_HelpID = 2077 PDFIntAsHex = Right("00" & Hex(ArrBF(1, in_Index)), 2) & _ Right("00" & Hex(ArrBF(1, in_Index + 1)), 2) End Function Private Function PDFIntVal(ArrBF As Variant, in_idx As Long) As Long Attribute PDFIntVal.VB_HelpID = 2078 PDFIntVal = CLng(ArrBF(1, in_idx)) * 256& + _ CLng(ArrBF(1, in_idx + 1)) End Function Private Sub PDFWriteImage(in_Img As Integer) Attribute PDFWriteImage.VB_HelpID = 2079 Dim TmpImg As String TmpImg = ArrIMG(in_Img).in_6 CurrentObjectNum = CurrentObjectNum + 1 TempStream = "" PDFOutStream sTempStream, "%DEBUT_OBJ/%" PDFOutStream TempStream, CurrentObjectNum & " 0 obj" ImageStream = "" PDFOutStream ImageStream, "<</Type /XObject" PDFOutStream ImageStream, "/Subtype /Image" PDFOutStream ImageStream, "/Filter [/DCTDecode ]" PDFOutStream ImageStream, "/Width " & ArrIMG(in_Img).in_1 PDFOutStream ImageStream, "/Height " & ArrIMG(in_Img).in_2 PDFOutStream ImageStream, "/ColorSpace /" & ArrIMG(in_Img).in_3 PDFOutStream ImageStream, "/BitsPerComponent " & ArrIMG(in_Img).in_4 PDFOutStream ImageStream, "/Length " & Len(ArrIMG(in_Img).in_6) PDFOutStream ImageStream, "/Name /ImgJPEG" & in_Img & ">>" PDFOutStream ImageStream, "stream" PDFOutStream ImageStream, TmpImg PDFOutStream ImageStream, "endstream" PDFOutStream ImageStream, "endobj" PDFOutStream sTempStream, "%FIN_OBJ/%" TempStream = TempStream & ImageStream PDFAddToOffset Len(TempStream) Strm.WriteLine TempStream End Sub Public Sub PDFBeginDoc() FPageNumber = 1 in_offset = 1 NumberofImages = 0 CurrentObjectNum = 0 ObjectOffset = 0 CurrentPDFSetPageObject = 0 CRCounter = 0 FontNumber = 0 ReDim ObjectOffsetList(1 To 1) ReDim PageNumberList(1 To 1) ReDim PageCanvasHeight(1 To 1) ReDim PageCanvasWidth(1 To 1) ReDim boPageLinksList(1 To 1) ReDim NbPageLinksList(1 To 1) ReDim LinksList(1 To 1) ReDim FontNumberList(1 To 1) TempStream = "" ImageStream = "" PDFSetHeader PDFSetDocInfo PDFStartStream End Sub Public Sub PDFEndDoc() Dim iRet As Long Dim in_i As Integer PDFHeader PDFEndStream PDFSetFontType PDFSetPages PDFSetArray For in_i = 1 To NumberofImages PDFWriteImage (in_i) Next in_i For in_i = 1 To FPageNumber PDFSetPageObject (in_i) Next in_i PDFSetBookmarks PDFSetCatalog PDFSetXref Strm.WriteLine "%%EOF" Strm.Close If boPDFConfirm Then MsgBox "PDF file generated.", vbOKOnly, "Generated PDF file - " & mjwPDFVersion If boPDFView Then PDFScanRepAdobe "C:\Program Files\", 0 If wsPathAdobe <> "" Then iRet = Shell(wsPathAdobe & " " & PDFGetFileName, vbMaximizedFocus) End If End If End Sub Public Sub PDFEndPage() in_Canvas = in_Canvas + 1 ReDim Preserve PDFCanvasWidth(1 To in_Canvas) ReDim Preserve PDFCanvasHeight(1 To in_Canvas) ReDim Preserve PDFCanvasOrientation(1 To in_Canvas) If PDFCanvasWidth(in_Canvas) = "" Then PDFCanvasWidth(in_Canvas) = PDFCanvasWidth(in_Canvas - 1) PDFCanvasHeight(in_Canvas) = PDFCanvasHeight(in_Canvas - 1) PDFCanvasOrientation(in_Canvas) = PDFCanvasOrientation(in_Canvas - 1) End If PDFHeader End Sub Public Sub PDFNewPage() Dim TempSize As Long in_xCurrent = PDFlMargin in_yCurrent = PDFtMargin FPageNumber = FPageNumber + 1 FPageLink = 0 TempStream = TempStream & sTempStream If dTempStream <> "" Then TempStream = TempStream & dTempStream sTempStream = "" dTempStream = "" PDFOutStream TempStream, "endstream" PDFOutStream TempStream, "endobj" PDFOutStream TempStream, "%FIN_OBJ/%" StreamSize2 = 6 PDFAddToOffset Len(TempStream) Strm.WriteLine TempStream TempSize = Len(TempStream) - StreamSize1 - StreamSize2 - Len("Stream") - Len("endstream") - 6 ContentNum = CurrentObjectNum CurrentObjectNum = CurrentObjectNum + 1 TempStream = "" PDFOutStream TempStream, "%DEBUT_OBJ/%" PDFOutStream TempStream, CurrentObjectNum & " 0 obj" PDFOutStream TempStream, CStr(TempSize) PDFOutStream TempStream, "endobj" PDFOutStream TempStream, "%FIN_OBJ/%" PDFAddToOffset Len(TempStream) Strm.WriteLine TempStream ContentNum = CurrentObjectNum CurrentObjectNum = CurrentObjectNum + 1 TempStream = "" PDFOutStream sTempStream, "%DEBUT_OBJ/%" PDFOutStream TempStream, CurrentObjectNum & " 0 obj" PDFOutStream TempStream, "<< /Length " & (CurrentObjectNum + 1) & " 0 R" PDFOutStream TempStream, " >>" StreamSize1 = Len(TempStream) PDFOutStream TempStream, "stream" PDFHeader End Sub Private Sub PDFSetHeader() Attribute PDFSetHeader.VB_HelpID = 2080 CurrentObjectNum = 0 Strm.WriteLine "%PDF-" & mjwPDF PDFAddToOffset Len("%PDF-" & mjwPDF) End Sub Private Sub PDFSetDocInfo() Attribute PDFSetDocInfo.VB_HelpID = 2081 CurrentObjectNum = CurrentObjectNum + 1 TempStream = "" PDFOutStream sTempStream, "%DEBUT_OBJ/%" PDFOutStream TempStream, CurrentObjectNum & " 0 obj" PDFOutStream TempStream, "<<" PDFOutStream TempStream, "/Producer (" + FProducer + ")" PDFOutStream TempStream, "/Author (" + FAuthor + ")" PDFOutStream TempStream, "/CreationDate (D:" + Format(Now, "YYYYMMDDHHmmSS") + ")" PDFOutStream TempStream, "/Creator (" + FCreator + ")" PDFOutStream TempStream, "/Keywords (" + FKeywords + ")" PDFOutStream TempStream, "/Subject (" + FSubject + ")" PDFOutStream TempStream, "/Title (" + FTitle + ")" PDFOutStream TempStream, "/ModDate ()" PDFOutStream TempStream, ">>" PDFOutStream TempStream, "endobj" PDFOutStream sTempStream, "%FIN_OBJ/%" PDFAddToOffset Len(TempStream) Strm.WriteLine TempStream End Sub Private Sub PDFSetArray() Attribute PDFSetArray.VB_HelpID = 2082 Dim I As Integer CurrentObjectNum = CurrentObjectNum + 1 ResourceNum = CurrentObjectNum TempStream = "" PDFOutStream sTempStream, "%DEBUT_OBJ/%" PDFOutStream TempStream, CurrentObjectNum & " 0 obj" PDFOutStream TempStream, "<< /ProcSet [ /PDF /Text /ImageC]" PDFOutStream TempStream, "/XObject << " For I = 1 To NumberofImages PDFOutStream TempStream, "/ImgJPEG" & I & " " & (CurrentObjectNum + I) & " 0 R" Next I PDFOutStream TempStream, ">>" PDFOutStream TempStream, "/Font << " For I = 1 To FontNumber PDFOutStream TempStream, "/F" & I & " " & FontNumberList(I) & " 0 R " Next I PDFOutStream TempStream, ">>" PDFOutStream TempStream, ">>" PDFOutStream TempStream, "endobj" PDFOutStream sTempStream, "%FIN_OBJ/%" PDFAddToOffset Len(TempStream) Strm.WriteLine TempStream End Sub Private Sub PDFSetFontType() Attribute PDFSetFontType.VB_HelpID = 2083 Dim in_i As Integer For in_i = 0 To UBound(Arr_Font) PDFCreateFont "Type1", Arr_Font(in_i), "WinAnsiEncoding" Next in_i End Sub Private Sub PDFSetPages() Attribute PDFSetPages.VB_HelpID = 2085 Dim I, PageObjNum As Integer CurrentObjectNum = CurrentObjectNum + 1 ParentNum = CurrentObjectNum 'TempStream = "" PDFOutStream TempStream, "%DEBUT_OBJ/%" PDFOutStream TempStream, CurrentObjectNum & " 0 obj" PDFOutStream TempStream, "<< /Type /Pages" PDFOutStream TempStream, "/Kids [" PageObjNum = 2 For I = 1 To FPageNumber PDFOutStream TempStream, (CurrentObjectNum + I + 1 + NumberofImages) & " 0 R" ReDim Preserve PageNumberList(1 To in_PagesNum) ReDim Preserve PageCanvasHeight(1 To in_PagesNum) ReDim Preserve PageCanvasWidth(1 To in_PagesNum) ReDim Preserve boPageLinksList(1 To FPageNumber) ReDim Preserve NbPageLinksList(1 To FPageNumber) PageCanvasHeight(in_PagesNum) = PDFCanvasHeight(in_PagesNum) PageCanvasWidth(in_PagesNum) = PDFCanvasWidth(in_PagesNum) PageNumberList(in_PagesNum) = PageObjNum in_PagesNum = in_PagesNum + 1 PageObjNum = PageObjNum + 2 Next I PDFOutStream TempStream, "]" PDFOutStream TempStream, "/Count " & FPageNumber PDFOutStream TempStream, ">>" PDFOutStream TempStream, "endobj" PDFOutStream sTempStream, "%FIN_OBJ/%" PDFAddToOffset Len(TempStream) Strm.WriteLine TempStream End Sub Private Sub PDFSetPageObject(in_pg As Integer) Attribute PDFSetPageObject.VB_HelpID = 2086 Dim I As Integer Dim str_Rect As String Dim str_Annots As String Dim str_TmpAnnots As String ContentNum = ContentNum + 1 CurrentObjectNum = CurrentObjectNum + 1 TempStream = "" ReDim Preserve aPage(1 To in_pg) aPage(in_pg) = CurrentObjectNum PDFOutStream sTempStream, "%DEBUT_OBJ/%" PDFOutStream TempStream, CurrentObjectNum & " 0 obj" PDFOutStream TempStream, "<< /Type /Page" PDFOutStream TempStream, "/Parent " & ParentNum & " 0 R" PDFOutStream TempStream, "/MediaBox [ 0 0 " & PageCanvasWidth(CurrentPDFSetPageObject + 1) & " " & PageCanvasHeight(CurrentPDFSetPageObject + 1) & "]" PDFOutStream TempStream, "/Resources " & ResourceNum & " 0 R" If boPageLinksList(in_pg) = True Then str_Annots = "/Annots [" For I = 1 To NbPageLinksList(in_pg) str_Rect = "" str_Rect = PageLinksList(in_pg, I)(0) & " " & _ PageLinksList(in_pg, I)(1) & " " & _ PageLinksList(in_pg, I)(0) + PageLinksList(in_pg, I)(2) & " " & _ PageLinksList(in_pg, I)(1) - PageLinksList(in_pg, I)(3) str_Annots = str_Annots & "<</Type /Annot /Subtype /Link /Rect [" & str_Rect & "] /Border [0 0 0] " If TypeName(PageLinksList(in_pg, I)(4)) = "String" And PageLinksList(in_pg, I)(4) <> "" Then str_TmpAnnots = PageLinksList(in_pg, I)(4) str_TmpAnnots = Replace(str_TmpAnnots, "\", "\\") str_TmpAnnots = Replace(str_TmpAnnots, "\\", "\\\\") str_TmpAnnots = Replace(str_TmpAnnots, "(", "\(") str_TmpAnnots = Replace(str_TmpAnnots, ")", "\)") str_Annots = str_Annots & "/A <</S /URI /URI (" & str_TmpAnnots & ")>>>>" & vbCr & vbLf End If Next I PDFOutStream TempStream, str_Annots & "]" 'MsgBox str_Annots End If PDFOutStream TempStream, "/Contents " & PageNumberList(CurrentPDFSetPageObject + 1) & " 0 R" PDFOutStream TempStream, ">>" PDFOutStream TempStream, "endobj" PDFOutStream TempStream, "%FIN_OBJ/%" PDFAddToOffset Len(TempStream) Strm.WriteLine TempStream CurrentPDFSetPageObject = CurrentPDFSetPageObject + 1 End Sub Private Sub PDFSetCatalog() Attribute PDFSetCatalog.VB_HelpID = 2087 CurrentObjectNum = CurrentObjectNum + 1 CatalogNum = CurrentObjectNum TempStream = "" PDFOutStream sTempStream, "%DEBUT_OBJ/%" PDFOutStream TempStream, CurrentObjectNum & " 0 obj" PDFOutStream TempStream, "<<" PDFOutStream TempStream, "/Type /Catalog" PDFOutStream TempStream, "/Pages " & ParentNum & " 0 R" If PDFZoomMode = ZOOM_FULLPAGE Then PDFOutStream TempStream, "/OpenAction [3 0 R /Fit]" ElseIf PDFZoomMode = ZOOM_FULLWIDTH Then PDFOutStream TempStream, "/OpenAction [3 0 R /FitH null]" ElseIf PDFZoomMode = ZOOM_REAL Then PDFOutStream TempStream, "/OpenAction [3 0 R /XYZ null null 1]" ElseIf IsNumeric(PDFZoomMode) Then PDFOutStream TempStream, "/OpenAction [3 0 R /XYZ null null " & PDFFormatDouble(PDFZoomMode / 100) & "]" End If If PDFLayoutMode = LAYOUT_SINGLE Then PDFOutStream TempStream, "/PageLayout /SinglePage" ElseIf PDFLayoutMode = LAYOUT_CONTINOUS Then PDFOutStream TempStream, "/PageLayout /OneColumn" ElseIf PDFLayoutMode = LAYOUT_TWO Then PDFOutStream TempStream, "/PageLayout /TwoColumnLeft" End If If PDFboThumbs = True Then PDFOutStream TempStream, "/PageMode /UseThumbs" End If If PDFboOutlines = True Then PDFOutStream TempStream, "/Outlines " & iOutlines & " 0 R" PDFOutStream TempStream, "/PageMode /UseOutlines" End If If bPDFViewerPref Then PDFOutStream TempStream, "/ViewerPreferences<<" If InStr(1, PDFViewerPref, VIEW_HIDEMENUBAR) <> 0 Then PDFOutStream TempStream, "/HideMenubar true" If InStr(1, PDFViewerPref, VIEW_HIDETOOLBAR) <> 0 Then PDFOutStream TempStream, "/HideToolbar true" If InStr(1, PDFViewerPref, VIEW_HIDEWINDOWUI) <> 0 Then PDFOutStream TempStream, "/HideWindowUI true" If InStr(1, PDFViewerPref, VIEW_DISPLAYDOCTITLE) <> 0 Then PDFOutStream TempStream, "/DisplayDocTitle true" If InStr(1, PDFViewerPref, VIEW_CENTERWINDOW) <> 0 Then PDFOutStream TempStream, "/CenterWindow true" If InStr(1, PDFViewerPref, VIEW_FITWINDOW) <> 0 Then PDFOutStream TempStream, "/FitWindow true" PDFOutStream TempStream, ">>" End If PDFOutStream TempStream, ">>" PDFOutStream TempStream, "endobj" PDFOutStream sTempStream, "%FIN_OBJ/%" PDFAddToOffset Len(TempStream) Strm.WriteLine TempStream End Sub Private Sub PDFStartStream() Attribute PDFStartStream.VB_HelpID = 2088 ContentNum = CurrentObjectNum CurrentObjectNum = CurrentObjectNum + 1 TempStream = "" PDFOutStream sTempStream, "%DEBUT_OBJ/%" PDFOutStream TempStream, CurrentObjectNum & " 0 obj" PDFOutStream TempStream, "<< /Length " & (CurrentObjectNum + 1) & " 0 R" PDFOutStream TempStream, " >>" StreamSize1 = Len(TempStream) PDFOutStream TempStream, "stream" sTempStream = "" dTempStream = "" End Sub Private Sub PDFEndStream() Attribute PDFEndStream.VB_HelpID = 2089 Dim TempSize As Long TempStream = TempStream & sTempStream If dTempStream <> "" Then TempStream = TempStream & dTempStream sTempStream = "" dTempStream = "" PDFOutStream TempStream, "endstream" PDFOutStream TempStream, "endobj" PDFOutStream sTempStream, "%FIN_OBJ/%" StreamSize2 = 6 PDFAddToOffset Len(TempStream) Strm.WriteLine TempStream TempSize = Len(TempStream) - StreamSize1 - StreamSize2 - Len("Stream") - Len("endstream") - 6 ContentNum = CurrentObjectNum CurrentObjectNum = CurrentObjectNum + 1 TempStream = "" PDFOutStream sTempStream, "%DEBUT_OBJ/%" PDFOutStream TempStream, CurrentObjectNum & " 0 obj" PDFOutStream TempStream, CStr(TempSize) PDFOutStream TempStream, "endobj" PDFOutStream sTempStream, "%FIN_OBJ/%" PDFAddToOffset Len(TempStream) Strm.WriteLine TempStream End Sub Private Sub PDFSetXref() Attribute PDFSetXref.VB_HelpID = 2090 Dim I As Integer CurrentObjectNum = CurrentObjectNum + 1 TempStream = "" PDFOutStream TempStream, "xref" PDFOutStream TempStream, "0 " & CurrentObjectNum PDFOutStream TempStream, "0000000000 65535 f" For I = 1 To CurrentObjectNum - 1 PDFOutStream TempStream, PDFGetOffsetNumber(Trim(ObjectOffsetList(I))) + " 00000 n" Next I PDFOutStream TempStream, "trailer" PDFOutStream TempStream, "<< /Size " & CurrentObjectNum PDFOutStream TempStream, "/Root " & CatalogNum & " 0 R" PDFOutStream TempStream, "/Info 1 0 R" PDFOutStream TempStream, ">>" PDFOutStream TempStream, "startxref" PDFOutStream TempStream, Trim(ObjectOffsetList(CurrentObjectNum)) Strm.WriteLine TempStream End Sub Private Function PDFUnderline(boCell As Boolean, str_Text As String, x As Double, y As Double) As String Attribute PDFUnderline.VB_HelpID = 2091 Dim in_wUp As Integer Dim in_wUt As Integer Dim in_wTxt As String Dim in_Px As Integer Dim in_Pw As String Dim in_Py As String Dim str_TmpUnderl As String Dim str_xLeft As String Dim str_yTop As String Dim str_wText As String Dim str_hLine As String Dim iNbSpace As Integer str_TmpUnderl = "" in_wUp = PDFGetStringWidth("up", PDFFontName, PDFFontSize) in_wUt = 2 iNbSpace = PDFGetNumberOfCar(str_Text, " ") in_wTxt = PDFGetStringWidth(str_Text, PDFFontName, PDFFontSize) + _ iNbSpace * PDFGetStringWidth(" ", PDFFontName, PDFFontSize) + _ iWidthStr * iNbSpace - _ IIf(iWidthStr <> 0, (iNbSpace + 1) * PDFcMargin, 0) in_Px = x + PDFlMargin * in_Ech in_Pw = (PDFCanvasHeight(in_Canvas) - (y - in_wUp / 1000 * PDFFontSize) - 2) in_Py = -in_wUt / 1000 * in_wTxt str_hLine = PDFFormatDouble(in_Py) If boCell = False Then str_wText = PDFFormatDouble(in_wTxt) str_xLeft = PDFFormatDouble(in_Px) str_yTop = PDFFormatDouble(in_Pw) str_TmpUnderl = str_xLeft & " " & str_yTop & " " & str_wText & " " & str_hLine & " re f" Else str_wText = PDFFormatDouble(in_wTxt - PDFcMargin) str_xLeft = PDFFormatDouble(x) str_yTop = PDFFormatDouble(y - 3) str_TmpUnderl = str_xLeft & " " & str_yTop & " " & str_wText & " " & str_hLine & " re f" End If PDFUnderline = str_TmpUnderl End Function Private Sub PDFCreateFont(Subtype, BaseFont, Encoding As String) Attribute PDFCreateFont.VB_HelpID = 2092 FontNumber = FontNumber + 1 CurrentObjectNum = CurrentObjectNum + 1 ReDim Preserve FontNumberList(1 To in_FontNum) FontNumberList(in_FontNum) = CurrentObjectNum in_FontNum = in_FontNum + 1 TempStream = "" PDFOutStream sTempStream, "%DEBUT_OBJ/%" PDFOutStream TempStream, CurrentObjectNum & " 0 obj" PDFOutStream TempStream, "<< /Type /Font" PDFOutStream TempStream, "/Subtype /" & Subtype PDFOutStream TempStream, "/Name /F" & FontNumber PDFOutStream TempStream, "/BaseFont /" & BaseFont PDFOutStream TempStream, "/Encoding /" + Encoding PDFOutStream TempStream, ">>" PDFOutStream TempStream, "endobj" PDFOutStream sTempStream, "%FIN_OBJ/%" PDFAddToOffset Len(TempStream) Strm.WriteLine TempStream End Sub Private Function PDFGetOffsetNumber(offset As String) As String Attribute PDFGetOffsetNumber.VB_HelpID = 2094 Dim x, y As Long x = Len(offset) For y = 1 To 10 - x PDFGetOffsetNumber = PDFGetOffsetNumber + "0" Next y PDFGetOffsetNumber = PDFGetOffsetNumber + offset End Function Private Sub PDFOutStream(ms As String, S As String) Attribute PDFOutStream.VB_HelpID = 2095 CRCounter = CRCounter + 2 ms = ms & S & vbCrLf End Sub Private Sub PDFAddToOffset(offset As Long) Attribute PDFAddToOffset.VB_HelpID = 2096 ReDim Preserve ObjectOffsetList(1 To in_offset) ObjectOffset = ObjectOffset + offset ObjectOffsetList(in_offset) = ObjectOffset in_offset = in_offset + 1 CRCounter = 0 End Sub Public Function PDFGetStringWidth(str_Txt As String, Optional str_FName As String, Optional in_FSize As Integer) As Double Attribute PDFGetStringWidth.VB_HelpID = 2097 Dim str_TmpINI As String Dim in_Tmp As Long Dim in_i As Integer Dim in_j As Integer Dim ArrFNT() As Integer Dim in_Asc As Integer Dim Fso As Object Dim f As Object Dim aTempFNT As Variant Dim bWX As Boolean Dim iAscMin As Integer Dim iAscMax As Integer Dim aAsc As Variant Dim aWX As Variant Dim sReadLine As String If str_FName = "" Then str_FName = PDFFontName End If ReDim ArrFNT(1 To 255) iAscMin = 0 iAscMax = 0 bWX = False Set Fso = CreateObject("Scripting.FileSystemObject") Set f = Fso.OpenTextFile(wsPathConfig & "\" & str_FName & ".afm", 1, 0) Do While f.AtEndOfStream <> True sReadLine = f.ReadLine If InStr(1, sReadLine, "StartCharMetrics") <> 0 Then bWX = True sReadLine = f.ReadLine End If If InStr(1, sReadLine, "-1 ;") <> 0 Or _ InStr(1, sReadLine, "EndCharMetrics") <> 0 Then iAscMax = aAsc(1) Exit Do End If If bWX = True Then aTempFNT = Split(sReadLine, ";") aAsc = Split(Trim(aTempFNT(0)), " ") If iAscMin = 0 Then iAscMin = aAsc(1) aWX = Split(Trim(aTempFNT(1)), " ") ArrFNT(aAsc(1)) = Int(aWX(1)) End If Loop f.Close For in_i = 1 To 255 If in_i < iAscMin Then ArrFNT(in_i) = 0 If in_i > iAscMax Then ArrFNT(in_i) = 0 Next in_i in_Tmp = 0 For in_i = 1 To Len(str_Txt) in_Asc = Asc(Mid(str_Txt, in_i, 1)) in_Tmp = in_Tmp + Int(ArrFNT(in_Asc)) ' + FontBBoxAbout Next in_i PDFGetStringWidth = (in_Tmp * in_FSize) / 1000 End Function Private Function PDFGetRGB(lColor As Long) As PDFRGB Attribute PDFGetRGB.VB_HelpID = 2099 With PDFGetRGB .in_b = CByte(Int(lColor / 65536)) .in_g = CByte(Int((lColor - CLng(.in_b) * 65536) / 256)) .in_r = CByte(lColor - CLng(.in_b) * 65536 - CLng(.in_g) * 256) End With End Function Private Function PDFFormatDouble(in_dbl As Variant, Optional nZero As Integer = 2) As String Attribute PDFFormatDouble.VB_HelpID = 2100 Dim sZero As String sZero = String(nZero, "0") PDFFormatDouble = Replace(Format(in_dbl, "###0." & sZero), ",", ".") End Function Private Sub Class_Initialize() PDFInit End Sub Property Let PDFLoadAfm(sPathAFM As String) Dim Fso As Object Dim oRep As Object Dim oFiles As Object Dim in_Font As Integer Set Fso = CreateObject("Scripting.FileSystemObject") Set oRep = Fso.GetFolder(sPathAFM) in_Font = -1 For Each oFiles In oRep.Files If InStr(1, LCase(oFiles.Path), ".afm") <> 0 Then in_Font = in_Font + 1 ReDim Preserve Arr_Font(0 To in_Font) Arr_Font(in_Font) = Mid(oFiles.Name, 1, Len(oFiles.Name) - 4) End If Next oFiles If in_Font <> -1 Then wsPathConfig = sPathAFM End Property Private Function PDFScanRepAdobe(sPathBegin As String, iIndexFolder As Long) As Boolean Dim Fso As Object Dim oRep As Object Dim oSubRep As Object Dim oFolder As Object Dim oFiles As Object Set Fso = CreateObject("Scripting.FileSystemObject") Set oRep = Fso.GetFolder(sPathBegin) For Each oFolder In oRep.SubFolders iIndexFolder = iIndexFolder + 1 If oFolder.Attributes <> 22 Then For Each oFiles In oFolder.Files If InStr(1, oFiles.Path, "AcroRd32.exe") <> 0 Then wsPathAdobe = oFiles.Path bScanAdobe = True Exit For End If Next oFiles End If If bScanAdobe = True Then Exit For Next oFolder For Each oSubRep In oRep.SubFolders If bScanAdobe = True Then Exit For PDFScanRepAdobe oSubRep.Path, iIndexFolder Next oSubRep Set Fso = Nothing If bScanAdobe = True Then Exit Function End Function Public Sub PDFInit() bScanAdobe = False Set Fso = CreateObject("scripting.filesystemobject") If wsPathConfig = "" Then wsPathConfig = App.Path PDFLoadAfm = wsPathConfig ObjectOffsetList = Array() PageNumberList = Array() PageCanvasWidth = Array() PageCanvasHeight = Array() boPageLinksList = Array() NbPageLinksList = Array() LinksList = Array() FontNumberList = Array() in_offset = 1 in_FontNum = 1 in_PagesNum = 1 in_Canvas = 1 FPageLink = 0 boPDFUnderline = False boPDFBold = False boPDFItalic = False ' Unitй de mesure par dйfaut : cm in_Ech = 72 / 2.54 ' Marges de la page (1 cm) PDFMargin = in_Ech / 28.35 PDFSetMargins PDFMargin, PDFMargin ' Marge interieure des cellules (1 mm) PDFcMargin = in_Ech * (PDFMargin / 10) ' Largeur de ligne (0.2 mm) PDFLnWidth = 0.567 in_xCurrent = PDFlMargin in_yCurrent = PDFtMargin TempStream = "" ImageStream = "" pTempStream = "" sTempStream = "" cTempStream = "" dTempStream = "" FontNum = 1 ' Dйfinition dzes couleurs par dйfaut PDFLineColor = "0 G" PDFDrawColor = "0 g" PDFTextColor = "0 g" ' Format d'orientation de page par dйfaut : A4 ReDim Preserve PDFCanvasWidth(1 To in_Canvas) ReDim Preserve PDFCanvasHeight(1 To in_Canvas) ReDim Preserve PDFCanvasOrientation(1 To in_Canvas) PDFCanvasWidth(in_Canvas) = 595.28 PDFCanvasHeight(in_Canvas) = 841.89 PDFCanvasOrientation(in_Canvas) = "p" FProducer = "" FAuthor = "" FCreator = "" FKeywords = "" FSubject = "" Exit Sub End Sub Function PDFSetBookmark(str_Text As String, Optional iLevel As Integer = 0, Optional y As Double = -1) If y = -1 Then y = in_yCurrent ReDim Preserve aOutlines(0 To iOutlines) aOutlines(iOutlines).sText = str_Text aOutlines(iOutlines).iLevel = iLevel aOutlines(iOutlines).yPos = y aOutlines(iOutlines).iPageNb = PDFPageNumber iOutlines = iOutlines + 1 End Function Private Function PDFSetBookmarks() Dim iNbBookMrk As Integer Dim aTemp() As Variant Dim iLevel As Integer Dim in_i As Integer Dim iParent As Integer Dim iFirst As Integer Dim iPrev As Integer Dim iNb As Integer Dim iPageOut As Integer On Error Resume Next iNbBookMrk = UBound(aOutlines) If iNbBookMrk = 0 Then Exit Function On Error GoTo 0 iLevel = 0 For in_i = 0 To iNbBookMrk If aOutlines(in_i).iLevel > 0 Then iParent = aTemp(aOutlines(in_i).iLevel - 1) aOutlines(in_i).iParent = iParent aOutlines(iParent).iLast = in_i aOutlines(iParent).bLast = True If aOutlines(in_i).iLevel > iLevel Then aOutlines(iParent).iFirst = in_i aOutlines(iParent).bFirst = True End If Else aOutlines(in_i).iParent = iNbBookMrk + 1 End If If aOutlines(in_i).iLevel <= iLevel And in_i > 1 Then iPrev = aTemp(aOutlines(in_i).iLevel) aOutlines(iPrev).iNext = in_i aOutlines(iPrev).bNext = True aOutlines(in_i).iPrev = iPrev aOutlines(in_i).bPrev = True End If ReDim Preserve aTemp(0 To aOutlines(in_i).iLevel) aTemp(aOutlines(in_i).iLevel) = in_i iLevel = aOutlines(in_i).iLevel Next in_i iNb = CurrentObjectNum + 1 iOutlineRoot = iNb For in_i = 0 To iNbBookMrk CurrentObjectNum = CurrentObjectNum + 1 TempStream = "" PDFOutStream sTempStream, "%DEBUT_OBJ/%" PDFOutStream TempStream, CurrentObjectNum & " 0 obj" PDFOutStream TempStream, "<</Title (" & aOutlines(in_i).sText & ")" PDFOutStream TempStream, "/Parent " & (iNb + aOutlines(in_i).iParent) & " 0 R" If aOutlines(in_i).bPrev Then PDFOutStream TempStream, "/Prev " & (iNb + aOutlines(in_i).iPrev) & " 0 R" End If If aOutlines(in_i).bNext Then PDFOutStream TempStream, "/Next " & (iNb + aOutlines(in_i).iNext) & " 0 R" End If If aOutlines(in_i).bFirst Then PDFOutStream TempStream, "/First " & (iNb + aOutlines(in_i).iFirst) & " 0 R" End If If aOutlines(in_i).bLast Then PDFOutStream TempStream, "/Last " & (iNb + aOutlines(in_i).iLast) & " 0 R" End If iPageOut = aPage(aOutlines(in_i).iPageNb) PDFOutStream TempStream, "/Dest [" & iPageOut & _ " 0 R /XYZ 0 " & PDFFormatDouble(PDFCanvasHeight(aOutlines(in_i).iPageNb) - aOutlines(in_i).yPos * in_Ech) & " null]" PDFOutStream TempStream, "/Count 0>>" PDFOutStream TempStream, "endobj" PDFOutStream sTempStream, "%FIN_OBJ/%" PDFAddToOffset Len(TempStream) Strm.WriteLine TempStream Next in_i CurrentObjectNum = CurrentObjectNum + 1 TempStream = "" iOutlines = CurrentObjectNum PDFOutStream sTempStream, "%DEBUT_OBJ/%" PDFOutStream TempStream, CurrentObjectNum & " 0 obj" PDFOutStream TempStream, "<</Type /Outlines /First " & iNb & " 0 R" PDFOutStream TempStream, "/Last " & (iNb + aTemp(1)) & " 0 R>>" PDFOutStream TempStream, "endobj" PDFOutStream sTempStream, "%FIN_OBJ/%" PDFAddToOffset Len(TempStream) Strm.WriteLine TempStream End Function
Язык Visual Basic 6.0 является устаревшим. Многие примеры, размещенные на нашем сайте, были созданы еще во времена Windows 98 и могут не работать в современных операционных системах. Если у вас возникнут какие-либо проблемы или вопросы, вы можете обратиться за помощью на наш форум.
![]() ![]() ![]() ![]() ![]() ![]() ![]() ![]() ![]() ![]() Все похожие примеры (всего: 33)
Добавлять комментарии могут только зарегистрированные пользователи сайта. Если у Вас уже есть учетная запись на Kbyte.Ru, пройдите процедуру авторизации ![]() Если Вы еще не зарегистрированы на Kbyte.Ru - зарегистрируйтесь. |
Зарегистрируйся и получи 10% скидку на добавление своего сайта в каталоги! Подробнее »
|
|
29 марта 2011, 17:00
С уважением...