home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / Scan_all_F2146633112009.psc / MakeHTMLDir / clsPDF.cls next >
Text File  |  2009-03-11  |  12KB  |  431 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "clsPDF"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14.  ' File name (.PDF)
  15. Public FileName As String
  16.  
  17. ' Info - these are optional
  18. Public Producer As String   ' Producer
  19. Public Title As String      ' Title
  20. Public Subject As String    ' Subject
  21. Public Author As String     ' Author
  22.  
  23. ' Paper specifications
  24. Public PaperSize As pdfPaperSize    ' Paper Size
  25. Public LandScape As Boolean ' If TRUE, swap height & width
  26. Public TopMargin As Long    ' Top margin
  27. Public LeftMargin As Long   ' Left margin
  28. Private PaperWidth As Long  ' Paper width (computed)
  29. Private PaperHeight As Long ' Paper height (computed)
  30.  
  31. ' Font specifications
  32. Public FontSize As Long     ' Font size
  33. Public FontType As pdfFont  ' Type (Bold/Italic/Regular)
  34. Public VertSpace As Long    ' Spacing between rows
  35.  
  36. ' Support variables
  37. Private nStartStream
  38. Private nObject As Long             ' Number of Objects
  39. Private Objects As New Collection   ' Objects collection (with offset from the start of the file)
  40. Private Kids As New Collection      ' Pages collection
  41.  
  42. ' Font types
  43. Public Enum pdfFont
  44.     pdfRegular = 1
  45.     pdfItalic = 2
  46.     pdfBold = 3
  47.     pdfBoldItalic = 4
  48. End Enum
  49.     
  50. ' Paper sizes
  51. Public Enum pdfPaperSize
  52.     pdfA3 = 1
  53.     pdfA4 = 2
  54.     pdfA5 = 3
  55.     pdfTABLOID = 4
  56.     pdfLEDGER = 5
  57.     pdfLEGAL = 6
  58.     pdfSTATEMENT = 7
  59.     pdfEXECUTIVE = 8
  60. End Enum
  61.  
  62. ' Setup default values
  63. Private Sub Class_Initialize()
  64.     PaperSize = pdfA4
  65.     LandScape = False
  66.     TopMargin = 50
  67.     LeftMargin = 50
  68.     FontType = pdfRegular
  69.     FontSize = 10
  70.     VertSpace = 12
  71. End Sub
  72.  
  73. ' Write the header
  74. Sub StartPDF()
  75.     Dim nLen As Long
  76.     Dim cObj As String
  77.     Dim nTemp As Long
  78.     
  79.     ' Compute width & height
  80.     Select Case PaperSize
  81.         Case pdfA3
  82.             PaperWidth = 842
  83.             PaperHeight = 1190
  84.         Case pdfA4
  85.             PaperWidth = 595
  86.             PaperHeight = 842
  87.         Case pdfA5
  88.             PaperWidth = 421
  89.             PaperHeight = 595
  90.         Case pdfTABLOID
  91.             PaperWidth = 792
  92.             PaperHeight = 1224
  93.         Case pdfLEDGER
  94.             PaperWidth = 1224
  95.             PaperHeight = 792
  96.         Case pdfLETTER
  97.             PaperWidth = 612
  98.             PaperHeight = 1008
  99.         Case pdfSTATEMENT
  100.             PaperWidth = 396
  101.             PaperHeight = 612
  102.         Case pdfEXECUTIVE
  103.             PaperWidth = 540
  104.             PaperHeight = 720
  105.         Case Else
  106.             ' The default is A4
  107.             PaperWidth = 595
  108.             PaperHeight = 842
  109.     End Select
  110.     
  111.     ' If landscape, swap width & height
  112.     If LandScape Then
  113.         nTemp = PaperWidth
  114.         PaperWidth = PaperHeight
  115.         PaperHeight = nTemp
  116.     End If
  117.     
  118.     ' Create the output file
  119.     n = FreeFile
  120.     Open FileName For Output As #n
  121.     
  122.     ' Version
  123.     Print #n, "%PDF-1.2" & vbLf & _
  124.               "%Γπ╧╙" & vbLf;
  125.     Close #n
  126.     
  127.     ' Info
  128.     nObject = 1
  129.     cObj = "/CreationDate (D:" + Format(Now, "YYYYMMDDHHMMSS") + ")"
  130.     cObj = cObj + vbLf + "/Creator (Visual Basic)"
  131.     cObj = cObj + vbLf + "/Producer (vb2pdf v1.2 \251 M. Nicolato)"
  132.     If Title <> "" Then cObj = cObj + vbLf + "/Title (" + Title + ")"
  133.     If Subject <> "" Then cObj = cObj + vbLf + "/Subject (" + Subject + ")"
  134.     If Author <> "" Then cObj = cObj + vbLf + "/Author (" + Author + ")"
  135.     WriteObject cObj
  136.     
  137.     ' Objects 2 and 3 will be created in the trailer
  138.     nObject = 4
  139.     
  140.     ' Font REGULAR
  141.     cObj = "/Type /Font"
  142.     cObj = cObj + vbLf + "/Subtype /Type1"
  143.     cObj = cObj + vbLf + "/Name /F1"
  144.     cObj = cObj + vbLf + "/Encoding 8 0 R"
  145.     cObj = cObj + vbLf + "/BaseFont /Courier"
  146.     WriteObject cObj
  147.     
  148.     ' Font ITALIC
  149.     nObject = nObject + 1
  150.     cObj = "/Type /Font"
  151.     cObj = cObj + vbLf + "/Subtype /Type1"
  152.     cObj = cObj + vbLf + "/Name /F2"
  153.     cObj = cObj + vbLf + "/Encoding 8 0 R"
  154.     cObj = cObj + vbLf + "/BaseFont /Courier-Oblique"
  155.     WriteObject cObj
  156.     
  157.     ' Font BOLD
  158.     nObject = nObject + 1
  159.     cObj = "/Type /Font"
  160.     cObj = cObj + vbLf + "/Subtype /Type1"
  161.     cObj = cObj + vbLf + "/Name /F3"
  162.     cObj = cObj + vbLf + "/Encoding 8 0 R"
  163.     cObj = cObj + vbLf + "/BaseFont /Courier-Bold"
  164.     WriteObject cObj
  165.     
  166.     ' Font BOLD ITALIC
  167.     nObject = nObject + 1
  168.     cObj = "/Type /Font"
  169.     cObj = cObj + vbLf + "/Subtype /Type1"
  170.     cObj = cObj + vbLf + "/Name /F4"
  171.     cObj = cObj + vbLf + "/Encoding 8 0 R"
  172.     cObj = cObj + vbLf + "/BaseFont /Courier-BoldOblique"
  173.     WriteObject cObj
  174.     
  175.     ' Font Encoding
  176.     nObject = nObject + 1
  177.     cObj = "/Type /Encoding"
  178.     cObj = cObj + vbLf + "/BaseEncoding /WinAnsiEncoding"
  179.     WriteObject cObj
  180.     
  181.     ' Fonts object
  182.     nObject = nObject + 1
  183.     cObj = "  /Font << /F1 4 0 R /F2 5 0 R /F3 6 0 R /F4 7 0 R >>"
  184.     cObj = cObj + vbLf + "  /ProcSet [ /PDF /Text ]"
  185.     WriteObject cObj
  186.     
  187.     ' Start with a new page
  188.     NewPage
  189.     
  190. End Sub
  191.  
  192. ' Write the PDF terminator
  193. Public Sub EndPDF()
  194.     Dim cObj As String
  195.     Dim n As Long
  196.     Dim nOffset As Long
  197.     
  198.     ' Close the last page
  199.     EndPage
  200.     
  201.     ' Catalog
  202.     cObj = "2 0 obj"
  203.     cObj = cObj + vbLf + "<<"
  204.     cObj = cObj + vbLf + "/Type /Catalog"
  205.     cObj = cObj + vbLf + "/Pages 3 0 R"
  206.     cObj = cObj + vbLf + "/PageLayout /OneColumn"
  207.     cObj = cObj + vbLf + ">>"
  208.     cObj = cObj + vbLf + "endobj"
  209.     nOffset = WriteText(cObj)
  210.     Objects.Add (nOffset), CStr(2)
  211.     
  212.     ' Pages
  213.     cObj = "3 0 obj"
  214.     cObj = cObj + vbLf + "<<"
  215.     cObj = cObj + vbLf + "/Type /Pages"
  216.     cObj = cObj + vbLf + "/Count " + CStr(Kids.Count)
  217.     cObj = cObj + vbLf + "/MediaBox [ 0 0 " + CStr(PaperWidth) + " " + CStr(PaperHeight) + " ]"
  218.     cObj = cObj + vbLf + "/Kids [ "
  219.     ' List each page object
  220.     For n = 1 To Kids.Count
  221.         cObj = cObj + CStr(Kids(n)) + " 0 R "
  222.     Next
  223.     cObj = cObj + "]"
  224.     cObj = cObj + vbLf + ">>"
  225.     cObj = cObj + vbLf + "endobj"
  226.     ' Write
  227.     nOffset = WriteText(cObj)
  228.     Objects.Add (nOffset), CStr(3)
  229.     
  230.     ' CrossReference
  231.     nObject = nObject + 1
  232.     cObj = "xref"
  233.     cObj = cObj + vbLf + "0 " + CStr(nObject)
  234.     cObj = cObj + vbLf + "0000000000 65535 f "
  235.     ' List all the object's offset, ordering by object number
  236.     For n = 1 To Objects.Count
  237.         cObj = cObj + vbCr + Format(Objects(CStr(n)), "0#########") + " 00000 n "
  238.     Next
  239.     cObj = cObj + vbCr + "trailer" ' prova
  240.     nOffset = WriteText(cObj)
  241.     
  242.     ' Trailer
  243.     cObj = "<<"
  244.     cObj = cObj + vbLf + "/Size " + CStr(nObject)
  245.     cObj = cObj + vbLf + "/Root 2 0 R"
  246.     cObj = cObj + vbLf + "/Info 1 0 R"
  247.     cObj = cObj + vbLf + ">>"
  248.     cObj = cObj + vbLf + "startxref"
  249.     cObj = cObj + vbLf + CStr(nOffset)
  250.     cObj = cObj + vbLf + "%%EOF"
  251.     WriteText cObj
  252. End Sub
  253.  
  254. ' Create a new page
  255. Public Sub NewPage()
  256.     Dim cObj As String
  257.     Dim nLen As Long
  258.     Dim nOffset As Long
  259.     
  260.     ' Close the previous page
  261.     If Kids.Count > 0 Then
  262.         EndPage
  263.     End If
  264.     
  265.     ' Page resources
  266.     nObject = nObject + 1
  267.     cObj = "/Type /Page"
  268.     cObj = cObj + vbLf + "/Parent 3 0 R"
  269.     cObj = cObj + vbLf + "/Resources 9 0 R"
  270.     cObj = cObj + vbLf + "/Contents " + CStr(nObject + 1) + " 0 R"
  271.     WriteObject cObj
  272.     
  273.     ' Add this object to the pages's collection
  274.     Kids.Add nObject
  275.     
  276.     ' Page length is in the next object
  277.     nObject = nObject + 1
  278.     cObj = CStr(nObject) + " 0 obj"
  279.     cObj = cObj + vbLf + "<<"
  280.     cObj = cObj + vbLf + "/Length " + CStr(nObject + 1) + " 0 R"
  281.     cObj = cObj + vbLf + ">>"
  282.     cObj = cObj + vbLf + "stream"
  283.     cObj = cObj + vbLf + "BT"
  284.     nOffset = WriteText(cObj)
  285.     Objects.Add nOffset, CStr(nObject)
  286.     
  287.     ' Store the offset of the stream
  288.     nStartStream = nOffset + Len(cObj) - 5 ' Adjust start of stream
  289.     
  290.     ' Start with the font, page offset and vertical spacing
  291.     cObj = "/F" + CStr(FontType) + " " + CStr(FontSize) + " Tf"
  292.     WriteText cObj
  293.     
  294.     ' Start offset and rotation at default position
  295.     SetOrigin LeftMargin, PaperHeight - TopMargin, 0
  296.         
  297. End Sub
  298.  
  299. ' Close the page
  300. Private Sub EndPage()
  301.     Dim cObj As String
  302.     Dim nLen As Long
  303.     Dim nOffset As Long
  304.     cObj = "ET"
  305.     cObj = cObj + vbLf + "endstream"
  306.     cObj = cObj + vbLf + "endobj"
  307.     
  308.     ' Calculate the length of the page
  309.     nLen = WriteText(cObj) - nStartStream
  310.     nObject = nObject + 1
  311.     cObj = CStr(nObject) + " 0 obj"
  312.     cObj = cObj + vbLf + CStr(nLen)
  313.     cObj = cObj + vbLf + "endobj"
  314.     nOffset = WriteText(cObj)
  315.     Objects.Add (nOffset), CStr(nObject)
  316.  
  317. End Sub
  318.  
  319. ' Write the text in the PDF file
  320. Public Sub WritePDF(ByVal cText As String, bNewRow As Boolean, Optional NewFont As pdfFont)
  321.     Dim cObj As String
  322.     Dim cRestoreFont As String
  323.     
  324.     ' Change the current font ?
  325.     If NewFont <> 0 And NewFont <> FontType Then
  326.         cObj = "/F" + CStr(NewFont) + " " + CStr(FontSize) + " Tf" + vbLf
  327.         cRestoreFont = vbLf + "/F" + CStr(FontType) + " " + CStr(FontSize) + " Tf"
  328.     End If
  329.     
  330.     ' New row ?
  331.     If bNewRow Then
  332.         cObj = cObj + "T* "
  333.     End If
  334.     
  335.     ' Convert special chars
  336.     cObj = cObj + "(" + Convert(cText) + ") Tj"
  337.     
  338.     ' Restore original font
  339.     cObj = cObj + cRestoreFont
  340.     WriteText cObj
  341.  
  342. End Sub
  343.  
  344. ' Set origin & text orientation (added 2003, may)
  345. Public Sub SetOrigin(nStartX As Long, nStartY As Long, Optional nDegree As Long = 0)
  346.     Dim cObj As String
  347.     Dim a As Single
  348.     Dim b As Single
  349.     Dim c As Single
  350.     Dim d As Single
  351.     
  352.     ' calculate (Tm) matrix coefficents
  353.     Const pi = 3.141592654
  354.     a = Cos(pi * nDegree / 180)
  355.     b = Sin(pi * nDegree / 180)
  356.     c = -b
  357.     d = a
  358.     
  359.     ' Tm text matrix
  360.     WriteText Number2Str(a, 3) & " " & _
  361.               Number2Str(b, 3) & " " & _
  362.               Number2Str(c, 3) & " " & _
  363.               Number2Str(d, 3) & " " & _
  364.               Str(nStartX) & " " & _
  365.               Str(nStartY) & _
  366.               " Tm"
  367.     
  368.     ' Vertical spacing
  369.     WriteText CStr(VertSpace) + " TL"
  370.  
  371.  
  372. End Sub
  373.  
  374. ' Write this text as an object using PDF syntax
  375. Private Sub WriteObject(cObject As String)
  376.     Dim nOffset As Long
  377.     Dim cObj As String
  378.     cObj = CStr(nObject) + " 0 obj"
  379.     cObj = cObj + vbLf + "<<"
  380.     cObj = cObj + vbLf + cObject
  381.     cObj = cObj + vbLf + ">>"
  382.     cObj = cObj + vbLf + "endobj"
  383.     nOffset = WriteText(cObj)
  384.     ' Add the offset of this objetc to the Objects collection
  385.     Objects.Add (nOffset), CStr(nObject)
  386. End Sub
  387.  
  388. ' Write this text and return his offset from the start of the file
  389. Private Function WriteText(cText As String) As Long
  390.     Dim n As Long
  391.     n = FreeFile
  392.     Open FileName For Append As #n
  393.     WriteText = LOF(n)
  394.     Print #n, cText & vbLf;
  395.     Close #n
  396. End Function
  397.  
  398. ' Convert special chars as "\", "(" or ")"
  399. Private Function Convert(cText As String) As String
  400.     Dim i As Long
  401.     Dim t As String
  402.     For i = 1 To Len(cText)
  403.         t = Mid(cText, i, 1)
  404.         If t = "\" Or t = "(" Or t = ")" Then
  405.             t = "\" + t
  406.         End If
  407.         Convert = Convert + t
  408.     Next
  409. End Function
  410.  
  411. ' Same as FORMAT function, but returns a DOT instead of local decimal separator
  412. ' (it may be different by country)
  413. Private Function Number2Str(nValue As Variant, nDecimals As Long) As String
  414.     Dim cMask As String
  415.     ' create a mask for decimal point
  416.     If nDecimals <> 0 Then
  417.         cMask = "0." & String(nDecimals - 1, "#") & "0"
  418.     Else
  419.         cMask = "0"
  420.     End If
  421.     Number2Str = Format(nValue, cMask)
  422.     ' replace local decimal separator with "."
  423.     Dim cDecSep As String
  424.     cDecSep = Mid(CStr(0.1), 2, 1)  ' get local decimal separator character
  425.     Dim nDecPos As Long
  426.     nDecPos = InStr(Number2Str, cDecSep)     ' find where used
  427.     If nDecPos <> 0 Then
  428.         Mid(Number2Str, nDecPos, 1) = "."    ' substitute with a DOT
  429.     End If
  430. End Function
  431.