aqui otra forma de crear PDF desde ASP

[lexus]

Código:

  Class TextArea
	 Public default Property Get ClassName() 'As FontStyles
	  ClassName = "TextArea"
	 End Property
	 Private m_Texts 'As Scripting.Dictionary ' texts To be word wrapped
	 Private m_LineQ 'As Scripting.Dictionary ' word wrapped lines
	 Private m_StartV 'As Integer
	 Private m_widthPDFUnits 'As Integer
	 Public HeightInPDFunits 'As Integer
	 Public StartPDFH 'As Integer
	 Private Sub Class_Initialize()
	  Set m_Texts = CreateObject("Scripting.Dictionary")
	  StartPDFH = 72
	 End Sub
	 Sub CalculateHeight(ByVal width)
	  Dim myText 'As TextObject
	  Dim FontRef 'As String
	  Dim key 'As String
	  Dim sFontRef 'As String
	  Dim found 'As Boolean
	  Dim FontSize 'As Integer
	  Dim sFontSize 'As Integer
	  Dim i 'As Integer
	  Dim lineNo 'As Integer
	  Dim linelen 'As Integer
	  Dim textLine 'As TextObject
	  Dim line 'As String' Text line
	  Dim tmpline 'As String
	  Dim vspace 'As Integer
	  Dim ret 'As String
	  Dim fonto 'As FontObj
	  if width < 1 Then
	  Err.Raise 100,"","Invalid width For TextArea"
	  End if
	  
	  m_widthPDFUnits = width
	  Set m_LineQ = CreateObject("Scripting.Dictionary")
	  ' Split the text up In lines
	  For Each myText In m_Texts
	  line = myText.Text
	  ' Escape PDF special characters ( and )
	  line = ReplaceText(ReplaceText(line, "(", "\("), ")", "\)")
	  line = Trim(line)
	  FontSize = myText.FontSize
	  linelen = myText.FontObj.HorizontalSpace * width / myText.FontSize
	  if Len(line) > linelen Then
	 'word wrap
	 Do While Len(line) > linelen
	 tmpline = Left(line, linelen)
	 For i = Len(tmpline) To Len(tmpline) / 2 Step -1
	  if InStr("*&^%$#,. ;<=>[])}!""", mid(tmpline, i, 1)) Then
	  ' find appropriate End of line
	  tmpline = Left(tmpline, i)
	  Exit For
	  End if
	 Next
	 line = mid(line, Len(tmpline) + 1)
	 Set textLine = New TextObject
	 With textLine
	  .Text = tmpline
	  Set .FontObj = myText.FontObj
	  .FontSize = myText.FontSize
	 End With
	 m_LineQ.Add textLine, ""
	 Loop
	 Set textLine = New TextObject
	 With textLine
	 .Text = line
	 Set .FontObj = myText.FontObj
	 .FontSize = myText.FontSize
	 End With
	 m_LineQ.Add textLine, ""
	  Else
	 Set textLine = New TextObject
	 With textLine
	 .Text = line
	 Set .FontObj = myText.FontObj
	 .FontSize = myText.FontSize
	 End With
	 m_LineQ.Add textLine, ""
	  End if
	  Next
	  HeightInPDFunits = 0
	  For Each myText In m_LineQ
	  FontSize = myText.FontSize
	  HeightInPDFunits = HeightInPDFunits + 1.2 * FontSize
	  Next
	 End Sub
	 function Draw(ByRef StartV, ByVal width, ByRef FontAlias, _
	  ByRef pagenum, ByVal TopStart) 'As PDFObject
	  
	  Dim PDFO 'As PDFObject
	  Dim myText 'As TextObject
	  Dim FontName 'As String
	  Dim TempPdfo 'As PDFObject
	  Dim FontRef 'As String
	  Dim key 'As String
	  Dim sFontRef 'As String
	  Dim found 'As Boolean
	  Dim FontSize 'As Integer
	  Dim sFontSize 'As Integer
	  Dim i 'As Integer
	  Dim lineNo 'As Integer
	  Dim linelen 'As Integer
	  Dim textLine 'As TextObject
	  Dim line 'As String' Text line
	  Dim tmpline 'As String
	  Dim vspace 'As Integer
	  Dim ret 'As String
	  Dim fonto 'As FontObj
	  Dim page 'As PageBreak
	  Dim save 'As String
	  Call CalculateHeight(width)
	  Set PDFO = New PDFObject
	  Set page = New PageBreak
	  ' Process fonts
	  For Each myText In m_Texts
	  ret = myText.Text
	  ' Set if we have this font
	  FontRef = getFontNumber(myText.Font, myText.FontStyle, FontAlias)
	  if FontRef = "" Then
	 'Add a new font
	 FontRef = Trim(CStr(FontAlias.count + 1))
	 Set fonto = New CFontObj
	 With fonto
	 .FontRef = FontRef
	 .Font = myText.Font
	 .FontStyle = myText.FontStyle
	 End With
	 FontAlias.Add FontRef, fonto
	  End if
	  myText.FontObj.FontRef = FontRef
	  found = False
	  For Each key In PDFO.m_fonts
	 if key = FontRef Then found = True
	  Next
	  if found = False Then
	 if Not PDFO.m_fonts.Exists(FontRef) Then
	 PDFO.m_fonts.Add FontRef, ""
	 End if
	  End if
	  Next
	  ' Print the lines To the PDF document
	  lineNo = -1
	  ret = " BT" + vbCr ' Begin text object
	  For Each myText In m_LineQ
	  line = myText.Text
	  FontName = myText.FontObj.FontName()
	  FontRef = myText.FontObj.FontRef
	  FontSize = myText.FontSize
	  vspace = 1.2 * FontSize
	  if (sFontRef <> FontRef) Or sFontSize <> FontSize Then
	 ret = ret + "/F" & FontRef & " " & FontSize & " Tf" & vbCr ' Text and font
	 ret = ret + "1 0 0 1 " & StartPDFH & " " & StartV & " Tm" & vbCr ' Set text matrix
	 ret = ret + CStr(vspace) & " TL" & vbCr ' Set text leading
	 'lineNo = lineNo + 1
	  End if
	  sFontRef = FontRef
	  sFontSize = FontSize
	  ret = ret + "T* (" & line & vbCrLf & ") Tj" & vbCr
	  StartV = StartV - vspace
	  if StartV < 100 Then
	 ' Print footer
	 page.StartPDFH = StartPDFH
	 ret = ret + "ET " + vbCrLf
	 Set TempPdfo = page.Draw(StartV, width, FontAlias, pagenum, TopStart)
	 ret = ret + TempPdfo.getStream()
	 PDFO.addStream (ret)
	 PDFO.PageBreak = True
	 ' Start new page
	 save = ret
	 ret = ""
	 ret = "BT " + vbCrLf
	 sFontRef = ""
	 StartV = TopStart
	  End if
	  Next
	  StartV = StartV - vspace
	  ret = ret + " ET" + vbCr
	  PDFO.addStream (ret)
	  Set Draw = PDFO
	 End function
	 function GetCopy()
	  Dim Text 'As TextArea
	  Dim tobj 'As TextObject
	  Set Text = New TextArea
	  For Each tobj In m_Texts
	  Text.AddText tobj.Text, tobj.Font, tobj.FontSize, tobj.FontStyle
	  Next
	  With Text
	  .StartPDFH = StartPDFH
	  End With
	  Set GetCopy = Text
	 End function
	 function getTexts() 'As Scripting.Dictionary
	  Set getTexts = m_Texts
	 End function
	 Public Sub AddText(ByVal Text, ByVal Font, ByVal FontSize, ByVal style)
	  if Font = "" Then Font = Fonts_Helvetica
	  if FontSize = "" Then FontSize = 10
	  if CStr(style) = "" Then style = FontStyles_Regular
	  
	  Dim myText 'As TextObject
	  Set myText = New TextObject
	  With myText
	  .Font = Font
	  .FontSize = FontSize
	  .Text = Text
	  .FontStyle = style
	  End With
	  m_Texts.Add myText, ""
	 End Sub
	  function toString() 'As String
	  Dim ret 'As String
	  ret = "TextArea: "
	  if m_Texts.count > 0 Then
	  ret = ret + GetDictionaryItem(m_Texts, 1).Text
	  End if
	  toString = ret
	 End function
	 function GetDictionaryItem(dic, ByVal iIndex)
	  Dim oItem, i
	  i = 0
	  For Each oItem In dic
	  i = i + 1
	  if i = iIndex Then
	 if IsObject(oItem) Then
	 Set GetDictionaryItem = oItem
	 Else
	 GetDictionaryItem = oItem
	 End if
	 Exit function
	  End if
	  Next
	 End function
	 Private function getFontNumber(ByVal Font, _
	 ByVal FontStyle, _
	 ByRef Fonts) 'As String
	 
	  Dim i 'As Integer
	  Dim key 'As String
	  Dim fName 'As String
	  Dim fonto 'As FontObj
	  For i = 1 To Fonts.count
	  key = Trim(CStr(i))
	  Set fonto = Fonts(key)
	  if fonto.Font = Font And fonto.FontStyle = FontStyle Then
	 'If Font.equals(fonto) Then
	 getFontNumber = fonto.FontRef
	  End if
	  Next
	 End function
	 Public function ReplaceText(ByRef Text_Renamed, ByRef TextToReplace, ByRef NewText) 'As String
	  Dim mtext 'As String
	  Dim SpacePos 'As Integer
	  mtext = Text_Renamed
	  SpacePos = InStr(mtext, TextToReplace)
	  Do While SpacePos
	  mtext = Left(mtext, SpacePos) & NewText & mid(mtext, SpacePos + Len(TextToReplace))
	  SpacePos = InStr(SpacePos + Len(NewText), mtext, TextToReplace)
	  Loop
	  ReplaceText = mtext
	 End function
	End Class
	'===================