aqui otra forma de crear PDF desde ASP

[lexus]

Código:

 '===================
	Class PageBreak
	 Public default Property Get ClassName() 'As FontStyles
	  ClassName = "PageBreak"
	 End Property
	 Public StartPDFH 'As Integer
	 function GetCopy()
	  Dim pg 'As PageBreak
	  pg = New PageBreak
	  pg.StartPDFH = StartPDFH
	  GetCopy = pg
	 End function
	 function Draw(ByRef StartV, ByVal width, ByRef FontAlias, _
	  ByRef pagenum, ByVal TopStart) 'As PDFObject
	  Dim stream 'As String
	  Dim PDFO 'As PDFObject
	  Dim mid 'As Integer
	  Set PDFO = New PDFObject
	  mid = StartPDFH + width / 2
	  pagenum = pagenum + 1
	  stream = "BT" & vbCr
	  stream = stream & "/F1 " & 10 & " Tf" & vbCr
	  stream = stream & "1 0 0 1 " & mid & " 50 Tm" & vbCr
	  stream = stream & "(" & pagenum & ") Tj" & vbCr
	  stream = stream & "/F1 " & 6 & " Tf" & vbCr
	  stream = stream & "1 0 0 1 " & StartPDFH & " 50 Tm" & vbCr
	  stream = stream & "(Copyright [email protected]) Tj" & vbCr
	  stream = stream & "ET" & vbCr
	  PDFO.addStream (stream)
	  Set Draw = PDFO
	 End function
	 function toString() 'As String
	  toString = "Page Break"
	 End function
	End Class
	'===================
	Class PDFDocument
	 Public default Property Get ClassName() 'As FontStyles
	  ClassName = "PDFDocument"
	 End Property
	 Dim m_Title 'As String
	 Dim m_keywords 'As String
	 Dim m_subject 'As String
	 Dim m_FontAlias 'As Scripting.Dictionary ' One entry per font
	 Dim m_PageNumber 'As Integer
	 Public Author 'As String
	 Public Creator 'As String
	 Public Producer 'As String
	 Public OutputFileName 'As String
	 Dim m_OutputStream
	 Dim m_OutputToStream 'As Boolean 
	 Dim Position 'As Integer
	 Dim m_PDFLocation(5000) 'As Integer ' Positions of all the PDF objects
	 Dim pageObj(5000) 'As Integer' Page objects
	 Dim obj 'As Integer ' PDF objects
	 Dim m_rootObj 'As Integer' RootObject is the object after properties
	 Dim m_TopPagesObj 'As Integer ' Top page comes after rootobject
	 Dim m_EncodingObj 'As Integer ' Object For Encoding Type
	 Dim m_PropObj 'As Integer
	 Dim cache 'As String
	 Dim m_controls 'As Scripting.Dictionary
	 Dim m_PageHeight 'As Integer
	 Dim m_Pagewidth 'As Integer
	 Dim m_drawableWidth 'As Integer
	 Dim m_TopMargin 'As Integer ' 3/4 inch, An adobe document has another 1/4 inch built in margin
	 Dim m_LeftMargin 'As Integer ' 1 inch, An adobe document has another 1/4 inch built in margin
	 Private Sub Class_Initialize()
	  m_Pagewidth = 612
	  m_PageHeight = 792
	  m_TopMargin = 54
	  m_LeftMargin = 72
	  Set m_controls = CreateObject("Scripting.Dictionary")
	  Set m_FontAlias = CreateObject("Scripting.Dictionary")
	  obj = 0
	  Position = 0
	  cache = ""
	  m_OutputToStream = False
	 End Sub
	 Public Property Get PageWidth() 'As Integer
	  PageWidth = m_Pagewidth / 72
	 End Property
	 Public Sub AddControl(ByVal control)
	  Dim ta 'As TextArea
	  if TypeName(control) = "TextArea" Then
	  Set ta = control.GetCopy
	  m_controls.Add ta, ""
	  Else
	  m_controls.Add control, ""
	  End if
	 End Sub
	 Public Sub OutputToFile(ByVal filename)
	  if filename <> "" Then
	  OutputFileName = filename
	  End if
	  if FileExists(OutputFileName) Then
	  Kill (OutputFileName)
	  End if
	  Call WriteStart
	  Call WriteHead
	  Call WritePage
	  Call endPDF
	 End Sub
	 Public function OutputToStream()
	  m_OutputToStream = True
	  Call WriteStart
	  Call WriteHead
	  Call WritePage
	  Call endPDF
	  OutputToStream = m_OutputStream
	  m_OutputToStream = False
	 End function
	 Private function WritePage()
	  Dim beginstream 'As String
	  Dim Fonts 'As String
	  Dim FontRef
	  Dim key 'As String
	  Dim PDFO 'As PDFObject
	  Dim fonto 'As FontObj
	  Dim Resources 'As String
	  Dim contents 'As String
	  Dim stream 'As String
	  Dim StartY 'As Integer
	  Dim width 'As Integer
	  Dim control
	  Dim dummy 'As String
	  Dim page 'As PageBreak
	  Dim PageFonts 'As PDFObject
	  Dim TopStart 'As Integer
	  Set PageFonts = New PDFObject
	  Fonts = " /Font << "
	  StartY = m_PageHeight - m_TopMargin
	  TopStart = StartY
	  width = m_Pagewidth - 2 * m_LeftMargin
	  For Each control In m_controls
	  dummy = control.toString' Debug statement
	  if control.StartPDFH = 0 Then
	 control.StartPDFH = m_LeftMargin
	  End if
	  Set PDFO = control.Draw(StartY, width, m_FontAlias, m_PageNumber, TopStart)
	  if PDFO.count > 1 Then
	 stream = stream + PDFO.getStream()
	 StartPage contents, Resources, stream, Fonts
	 stream = ""
	 Set PageFonts = New PDFObject
	 Fonts = " /Font << "
	  End if
	  stream = stream + PDFO.getStream()
	  Call WriteNewFonts
	  For Each FontRef In PDFO.m_fonts
	 Set fonto = m_FontAlias.Item(FontRef)
	 if PageFonts.FontExists(fonto.FontObj) = False Then
	 if Not PageFonts.m_fonts.Exists(fonto.FontObj) Then
	  PageFonts.m_fonts.Add fonto.FontObj, ""
	 End if
	 Fonts = Fonts + "/F" & FontRef & fonto.FontObj & " 0 R "
	 End if
	  Next
	  Next
	  if Len(stream) Then
	  Set page = New PageBreak
	  page.StartPDFH = m_LeftMargin
	  Set PDFO = page.Draw(StartY, width, m_FontAlias, m_PageNumber, TopStart)
	  stream = stream + PDFO.getStream()
	  StartPage contents, Resources, stream, Fonts
	  End if
	 End function
	 Private Sub StartPage(ByVal contents, ByVal Resources, ByVal stream, ByVal Fonts)
	  Fonts = Fonts + ">>"
	  Resources = Resources + Fonts + vbCrLf
	  Resources = Resources + "/Procset [/PDF /Text]"
	  obj = obj + 1
	  contents = contents + CStr(obj) & " 0 R"
	  m_PDFLocation(obj) = Position
	  writepdf obj & " 0 obj", False
	  writepdf "<< /Length " & Len(stream) & " >>", False
	  writepdf "stream", False
	  writepdf stream, False
	  writepdf "endstream", False
	  writepdf "endobj", False
	  obj = obj + 1
	  m_PDFLocation(obj) = Position
	  pageObj(m_PageNumber) = obj
	  writepdf obj & " 0 obj", False
	  writepdf "<<", False
	  writepdf "/Type /Page", False
	  writepdf "/Parent " & m_TopPagesObj & " 0 R", False
	  writepdf "/Resources << " & Resources & " >> ", False
	  writepdf "/Contents " & contents, False
	  writepdf ">>", False
	  writepdf "endobj", False
	 End Sub
	 Private Sub WriteNewFonts()
	  Dim i 'As Integer
	  Dim Fonts 'As String
	  Dim key 'As String
	  Dim fonto 'As FontObj
	  Dim FontName 'As String
	  Dim fontNumber 'As Integer
	  Dim sobj 'As Integer
	  
	  sobj = obj
	  For i = 1 To m_FontAlias.count
	  key = Trim(CStr(i))
	  Set fonto = m_FontAlias.Item(key)
	  if fonto.FontObj = "" Then
	 obj = obj + 1
	 fonto.FontObj = " " & CStr(obj)
	 m_PDFLocation(obj) = Position
	 writepdf obj & " 0 obj", False
	 writepdf "<<", False
	 writepdf "/Type /Font", False
	 writepdf "/Subtype /Type1", False ' Adobe Type 1
	 writepdf "/Name /F" & fonto.FontRef, False
	 writepdf "/BaseEncoding /WinAnsiEncoding", False
	 writepdf "/BaseFont /" & fonto.FontName, False
	 writepdf ">>", False
	 writepdf "endobj", False
	  End if
	  Next
	 End Sub
	 Private Sub WriteHead()
	  WriteProperties
	  obj = obj + 1
	  m_rootObj = obj ' The root object will be written at the End
	  obj = obj + 1
	  m_TopPagesObj = obj' The Pages object will be written at the End
	  obj = obj + 1
	 End Sub
	 Private Sub writepdf(ByRef stre, ByRef flush)
	  if flush = "" Then flush = False
	  
	  if m_OutputToStream = True Then
	   m_OutputStream = m_OutputStream & stre & vbCrLf
	   Exit Sub
	  End if
	  
	  ' On Error Resume Next
	  Dim i 'As Integer
	  Dim fso 'As FileSystemObject
	  Dim oFile 'As Scripting.TextStream
	  Set fso = CreateObject("Scripting.FileSystemObject")
	  
	  Position = Position + Len(stre) ' Position For the Next object
	  cache = cache & stre & vbCrLf
	  
	  if Len(cache) > 32000 Or flush Then
	  Set oFile = fso.OpenTextFile(OutputFileName, 8, True)
	  oFile.Write cache
	  oFile.Close
	  cache = ""
	  End if
	  
	 End Sub
	 Private Sub WriteStart()
	  writepdf "%PDF-1.2", False ' Acrobat version 3.0
	  writepdf "%", False
	 End Sub
	 Sub endPDF()
	  Dim ty 'As String
	  Dim i 'As Integer
	  Dim xreF 'As Integer
	  m_PDFLocation(m_rootObj) = Position
	  writepdf m_rootObj & " 0 obj", False
	  writepdf "<<", False
	  writepdf "/Type /Catalog", False
	  writepdf "/Pages " & m_TopPagesObj & " 0 R", False
	  writepdf ">>", False
	  writepdf "endobj", False
	  m_PDFLocation(m_TopPagesObj) = Position
	  writepdf m_TopPagesObj & " 0 obj", False
	  writepdf "<<", False
	  writepdf "/Type /Pages", False
	  writepdf "/Count " & m_PageNumber, False
	  writepdf "/MediaBox [ 0 0 " & m_Pagewidth & " " & m_PageHeight & " ]", False
	  ty = ("/Kids [ ")
	  For i = 1 To m_PageNumber
	  ty = ty & pageObj(i) & " 0 R "
	  Next
	  ty = ty & "]"
	  writepdf ty, False
	  writepdf ">>", False
	  writepdf "endobj", False
	  ' Xref
	  xreF = Position
	  writepdf "0 " & obj + 1, False
	  writepdf "0000000000 65535 f ", ""
	  For i = 1 To obj
	  writepdf Right("0000000000" & m_PDFLocation(i), 10) & " 00000 n", False
	  Next
	  ' Trailer
	  writepdf "trailer", False
	  writepdf "<<", False
	  writepdf "/Size " & obj + 1, False
	  writepdf "/Root " & m_rootObj & " 0 R", False
	  writepdf "/Info " & m_PropObj & " 0 R", False
	  writepdf ">>", False
	  writepdf "startxref", False
	  writepdf CStr(xreF), False
	  writepdf "%%EOF", True
	 End Sub
	 Private Sub WriteProperties()
	  Dim CreationDate 'As String
	  CreationDate = "D:" & GetPdfFormatedDate()
	  
	  obj = obj + 1
	  m_PDFLocation(obj) = Position
	  m_PropObj = obj
	  writepdf obj & " 0 obj", False
	  writepdf "<<", False
	  writepdf "/Author (" & Author & ")", False
	  writepdf "/CreationDate (" & CreationDate & ")", False
	  writepdf "/Creator (" & Creator & ")", False
	  writepdf "/Producer (" & Producer & ")", False
	  writepdf "/Title (" & m_Title & ")", False
	  writepdf "/Subject (" & m_subject & ")", False
	  writepdf "/Keywords (" & m_keywords & ")", False
	  writepdf ">>", False
	  writepdf "endobj", False
	 End Sub
	 Public function FileExists(ByVal filename) 'As Boolean
	  On Error Resume Next
	  FileExists = FileLen(filename) > 0
	  Err.Clear
	 End function
	End Class
	'===================