GERAR PDF

MARCELO.TREZE 05/04/2012 14:20:57
#399228 Resposta escolhida

qual é a rotina filho

DIONISIO 05/04/2012 14:31:58
#399230

Citação:

:
qual é a rotina filho

Option Explicit
Option Base 1
[ô]This class contains all the functions to create
[ô]PDF file from the ascii file.

[ô] Written by Dinesh Asanka
[ô] Copyright 2003 by Dinesh Asanka
[ô]
[ô] This software is FREEWARE. You may use it as you see fit for
[ô] your own projects but you may not re-sell the original or the
[ô] source code. Do not copy this sample to a collection, such as
[ô] a CD-ROM archive.
[ô]
[ô] No warranty express or implied, is given as to the use of this
[ô] program. Use at your own risk.

[ô]I would like to know your comments and any
[ô]improvement that you wich to see
[ô]Please send an email to
[ô]dineshasanka@hotmail.com or dineshasanka@yahoo.com
[ô]
[ô]For contacting information, see other module
Dim strSourceFile As String
Dim strTargetFiler As String
Dim strFontName As String
Dim intWidth As Integer
Dim intRPP As Integer
Dim intPGCount As Integer

[ô]Internal Variables
Dim strPage As String
Dim intObject As Long
Dim intOffSet As Long
Dim strCR As String
Dim strPR As String
Dim strTI As String
Dim intLen As Integer
Dim rows As Long
Dim arcount As Long
[ô]Data Arrays
Dim arrXREF() As String
Dim arrData() As String
Dim arrTmp() As String
[ô]Conntant value
Const END_OBJECT = [Ô]endobj[Ô]
Const BEG_OBJECT = [Ô] 0 obj[Ô]
Const AR_1 = [Ô]<<[Ô]
Const AR_2 = [Ô]>>[Ô]
Const AR_OR = [Ô] 0 R[Ô]
Const XREF_END_CHAR = [Ô] 00000 n[Ô]
[ô]
Public Property Get SourceFile() As Variant
SourceFile = strSourceFile
End Property

Public Property Let SourceFile(ByVal vNewValue As Variant)
strSourceFile = vNewValue
End Property

Public Property Get TargetFile() As Variant
strTargetFiler = TargetFile
End Property

Public Property Let TargetFile(ByVal vNewValue As Variant)
strTargetFiler = vNewValue
End Property

Public Property Get Width() As Variant
Width = intWidth
End Property

Public Property Let Width(ByVal vNewValue As Variant)
intWidth = vNewValue
End Property

Public Property Get RecordsPerPage() As Variant
RecordsPerPage = intRPP
End Property

Public Property Let RecordsPerPage(ByVal vNewValue As Variant)
intRPP = vNewValue
End Property

Public Sub CreatePDFFile()
If isFileExist Then
InitVar
FillXREFArray
FillDataArray
FillTmpArrayFromTextFile
FillData
FillFotter
WriteToReport
Else
MsgBox strSourceFile & [Ô] File does not exist[Ô], vbInformation
End If
End Sub

Private Function isFileExist() As Boolean
isFileExist = IIf(Len(Dir(strSourceFile)) > 0, 1, 0)
End Function

Private Sub InitVar()
strCR = [Ô]Creator (Alice Anderson)[Ô] [ô]Chr(67) & Chr(114) & Chr(101) & Chr(97) & Chr(116) & Chr(111) & Chr(114)
strPR = [Ô]Producer (VB to PDF someone@someplace.com)[Ô] [ô]Chr(80) & Chr(114) & Chr(111) & Chr(100) & Chr(117) & Chr(99) & Chr(101) & Chr(114)
strTI = [Ô]Title (VBTOPDF)[Ô] [ô]Chr(84) & Chr(105) & Chr(116) & Chr(108) & Chr(101)
intObject = 6
intOffSet = 396
End Sub

Private Sub FillXREFArray()
ReDim Preserve arrXREF(1 To 10)
arrXREF(1) = [Ô]xref[Ô]
arrXREF(2) = [Ô]0 10[Ô]
arrXREF(3) = [Ô]0000000000 65535 f[Ô]
arrXREF(4) = [Ô]0000000017[Ô] & XREF_END_CHAR
arrXREF(5) = [Ô]0000000790[Ô] & XREF_END_CHAR
arrXREF(6) = [Ô]0000000869[Ô] & XREF_END_CHAR
arrXREF(7) = [Ô]0000000144[Ô] & XREF_END_CHAR
arrXREF(8) = [Ô]0000000247[Ô] & XREF_END_CHAR
arrXREF(9) = [Ô]0000000321[Ô] & XREF_END_CHAR
arrXREF(10) = [Ô]0000000396[Ô] & XREF_END_CHAR

End Sub
Private Sub FillDataArray()
ReDim Preserve arrData(1 To 29)

[ô][ô] arrData(1) = [Ô]%[Ô] & Chr(80) & Chr(68) & Chr(70) & [Ô]-1.2 [Ô]
arrData(1) = [Ô]%[Ô] & Chr(80) & Chr(68) & Chr(70) & [Ô]-1.2 [Ô]
arrData(2) = [Ô]%ÓÓÓÓ[Ô]
arrData(3) = [Ô]1[Ô] & BEG_OBJECT
arrData(4) = AR_1
arrData(5) = [Ô]/[Ô] & strCR
arrData(6) = [Ô]/[Ô] & strPR
arrData(7) = [Ô]/[Ô] & strTI
arrData(8) = AR_2
arrData(9) = END_OBJECT
arrData(10) = [Ô]4[Ô] & BEG_OBJECT
arrData(11) = AR_1
arrData(12) = [Ô]/Type /Font[Ô]
arrData(13) = [Ô]/Subtype /Type1[Ô]
arrData(14) = [Ô]/Name /F1[Ô]
arrData(15) = [Ô]/Encoding 5[Ô] & AR_OR
arrData(16) = [Ô]/BaseFont /[Ô] & strFontName
arrData(17) = AR_2
arrData(18) = END_OBJECT
arrData(19) = [Ô]5[Ô] & BEG_OBJECT
arrData(20) = AR_1
arrData(21) = [Ô]/Type /Encoding[Ô]
arrData(22) = [Ô]/BaseEncoding /WinAnsiEncoding[Ô]
arrData(23) = AR_2
arrData(24) = END_OBJECT
arrData(25) = [Ô]6[Ô] & BEG_OBJECT
arrData(26) = AR_1
arrData(27) = [Ô]/Font [Ô] & AR_1 & [Ô] /F1 4[Ô] & AR_OR & [Ô] [Ô] & AR_2 & [Ô] /ProcSet [ /[Ô] & Chr(80) & Chr(68) & Chr(70) & [Ô] /Text ][Ô]
arrData(28) = AR_2
arrData(29) = END_OBJECT

End Sub
Private Sub FillTmpArrayFromTextFile()
Dim strRow As String
Open strSourceFile For Input As #1
Dim i As Integer
i = 0
Do Until EOF(1)
i = i + 1
ReDim Preserve arrTmp(1 To i)
Line Input #1, strRow
arrTmp(i) = strRow
Loop
intPGCount = Int(i / intRPP) + 1
Close #1

End Sub

Private Sub FillData()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim h As Integer

arcount = 29
For i = 1 To intPGCount
intObject = intObject + 1
strPage = strPage & [Ô] [Ô] & intObject & AR_OR
h = intObject + 1
intLen = Len(CStr(intObject)) + Len(CStr(h))

ReDim Preserve arrData(1 To arcount + 18)

arrData(arcount + 1) = intObject & BEG_OBJECT
arrData(arcount + 2) = AR_1
arrData(arcount + 3) = [Ô]/Type /Page[Ô]
arrData(arcount + 4) = [Ô]/Parent 3[Ô] & AR_OR
arrData(arcount + 5) = [Ô]/Resources 6[Ô] & AR_OR
intObject = intObject + 1
arrData(arcount + 6) = [Ô]/Contents [Ô] & intObject & AR_OR
arrData(arcount + 7) = AR_2
arrData(arcount + 8) = END_OBJECT
intOffSet = intLen + 86 + intOffSet
Dim s As String
s = [Ô]0000000000[Ô] & intOffSet
ReDim Preserve arrXREF(1 To UBound(arrXREF) + 1)
arrXREF(UBound(arrXREF)) = Mid(s, Len(s) - 9, Len(s)) & XREF_END_CHAR

arrData(arcount + 9) = intObject & BEG_OBJECT
arrData(arcount + 10) = AR_1
intObject = intObject + 1
arrData(arcount + 11) = [Ô]/Length [Ô] & intObject & AR_OR
arrData(arcount + 12) = AR_2
arrData(arcount + 13) = [Ô]stream[Ô]
arrData(arcount + 14) = [Ô]BT[Ô]
arrData(arcount + 15) = [Ô]/F1 10 Tf[Ô]
arrData(arcount + 16) = [Ô]1 0 0 1 50 802 Tm[Ô]
arrData(arcount + 17) = [Ô]12 TL[Ô]
arcount = arcount + 17
k = 0
For j = 1 To intRPP
ReDim Preserve arrData(1 To arcount + j)
If UBound(arrTmp) < ((i - 1) * intRPP + j) Then
Exit For
Else
k = k + 1
If Len(arrTmp((i - 1) * intRPP + j)) > intWidth - 9 Then
arrData(arcount + j) = [Ô]T* ([Ô] & arrTmp((i - 1) * intRPP + j) & [Ô]) Tj[Ô]
Else
arrData(arcount + j) = [Ô]T* ([Ô] & arrTmp((i - 1) * intRPP + j) & Space(intWidth - Len(arrTmp((i - 1) * intRPP + j))) & [Ô]) Tj[Ô]
End If
End If
Next
arcount = arcount + k

ReDim Preserve arrData(1 To arcount + 18)

arrData(arcount + 1) = [Ô]ET[Ô]
arrData(arcount + 2) = [Ô]endstream[Ô]
arrData(arcount + 3) = END_OBJECT


rows = k * 90 + 45
h = intObject - 1
intLen = Len(CStr(intObject)) + Len(CStr(h))
intOffSet = intLen + 57 + intOffSet + rows
s = [Ô]0000000000[Ô] & intOffSet

ReDim Preserve arrXREF(1 To UBound(arrXREF) + 1)
arrXREF(UBound(arrXREF)) = Mid(s, Len(s) - 9, Len(s)) & XREF_END_CHAR

arrData(arcount + 4) = intObject & BEG_OBJECT
arrData(arcount + 5) = rows
arrData(arcount + 6) = END_OBJECT


intLen = Len(CStr(intObject)) + Len(CStr(rows))
intOffSet = intLen + 18 + intOffSet

s = [Ô]0000000000[Ô] & intOffSet
ReDim Preserve arrXREF(1 To UBound(arrXREF) + 1)
arrXREF(UBound(arrXREF)) = Mid(s, Len(s) - 9, Len(s)) & XREF_END_CHAR
arcount = arcount + 6
Next

[ô]
[ô]
End Sub

Private Sub FillFotter()
Dim s As String
ReDim Preserve arrData(1 To arcount + 15)
arrData(arcount + 1) = [Ô]2[Ô] & BEG_OBJECT
arrData(arcount + 2) = AR_1
arrData(arcount + 3) = [Ô]/Type /Catalog[Ô]
arrData(arcount + 4) = [Ô]/Pages 3[Ô] & AR_OR
arrData(arcount + 5) = [Ô]/PageLayout /OneColumn[Ô]
arrData(arcount + 6) = AR_2
arrData(arcount + 7) = END_OBJECT

UpdatexresWithLastNumber

arrData(arcount + 8) = [Ô]3[Ô] & BEG_OBJECT
arrData(arcount + 9) = AR_1
arrData(arcount + 10) = [Ô]/Type /Pages[Ô]
arrData(arcount + 11) = [Ô]/Count [Ô] & intPGCount
arrData(arcount + 12) = [Ô]/MediaBox [ 0 0 595 842 ][Ô]
arrData(arcount + 13) = [Ô]/Kids [[Ô] & strPage & [Ô] ][Ô]
arrData(arcount + 14) = AR_2
arrData(arcount + 15) = END_OBJECT
arcount = arcount + 15
intOffSet = intOffSet + 79

s = [Ô]0000000000[Ô] & intOffSet
s = Mid(s, Len(s) - 9, Len(s)) & XREF_END_CHAR

arrXREF(6) = s

ReDim Preserve arrXREF(1 To UBound(arrXREF) + 1)
arrXREF(UBound(arrXREF)) = [Ô]trailer[Ô]

ReDim Preserve arrXREF(1 To UBound(arrXREF) + 1)
arrXREF(UBound(arrXREF)) = AR_1

intObject = intObject + 1
arrXREF(2) = [Ô]0[Ô] & intObject

ReDim Preserve arrXREF(1 To UBound(arrXREF) + 1)
arrXREF(UBound(arrXREF)) = [Ô]/Size [Ô] & intObject

ReDim Preserve arrXREF(1 To UBound(arrXREF) + 1)
arrXREF(UBound(arrXREF)) = [Ô]/Root 2[Ô] & AR_OR

ReDim Preserve arrXREF(1 To UBound(arrXREF) + 1)
arrXREF(UBound(arrXREF)) = [Ô]/Info 1[Ô] & AR_OR

ReDim Preserve arrXREF(1 To UBound(arrXREF) + 1)
arrXREF(UBound(arrXREF)) = AR_2

ReDim Preserve arrXREF(1 To UBound(arrXREF) + 1)
arrXREF(UBound(arrXREF)) = [Ô]startxref[Ô]

intLen = Len(CStr(intPGCount)) + Len(CStr(strPage))
intOffSet = intLen + 86 + intOffSet

ReDim Preserve arrXREF(1 To UBound(arrXREF) + 1)
arrXREF(UBound(arrXREF)) = intOffSet

ReDim Preserve arrXREF(1 To UBound(arrXREF) + 1)
arrXREF(UBound(arrXREF)) = [Ô]%%[Ô] & Chr(69) & Chr(79) + Chr(70)

FillDataFromXRef

End Sub
Private Sub UpdatexresWithLastNumber()
arrXREF(5) = arrXREF(UBound(arrXREF))
arrXREF(UBound(arrXREF)) = [Ô][Ô]
End Sub

Private Sub FillDataFromXRef()
Dim i As Integer
For i = 1 To UBound(arrXREF)