Crear pdf con asp clásico

Código ASP clásico

La creación de archivos PDF desde aplicaciones ASP clásicas es una herramienta muy útil para la generación de documentos electrónicos de alta calidad. Este formato de archivo es ampliamente utilizado en la industria para la presentación de informes, formularios, facturas y todo tipo de documentos empresariales. Al crear archivos PDF desde una aplicación ASP, se puede generar documentos de manera automatizada y personalizada, ahorrando tiempo y reduciendo el margen de error humano. Además, los archivos PDF son fáciles de compartir y visualizar en diferentes plataformas, lo que los hace ideales para la colaboración y el intercambio de información en entornos empresariales. En resumen, la capacidad de crear archivos PDF desde una aplicación ASP clásica es una herramienta valiosa que puede ayudar a las empresas a mejorar su eficiencia, reducir costos y aumentar la calidad de sus documentos.

Script en ASP clásico para generar archivos PDF en el servidor sin ningún componente instalado.

Limitaciones: El párrafo (TextArea) no puede exceder la página. La tabla no puede exceder una págna.

 

'**************************************' Name: Server Side PDF' Description:Generate PDF files on the server without any server-side components. Based on X2PDF.NET library created by Arne Garvander. Limitations: Paragraph (TextArea) cannot exceed on page. Table cannot exceed one page. To read about PDF file specifications go to: http://partners.adobe.com/asn/tech/pdf/specifications.jspTo learn how to edit an existing PDF file go to: http://www.15seconds.com/issue/990902.htmTo learn how to merge PDF file go to: http://www.planetsourcecode.com/vb/scripts/ShowCode.asp?txtCodeId=37121&lngWId=1' By: Igor Krupitsky''This code is copyrighted and has' limited warranties.Please see http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=8633&lngWId=4'for details.'**************************************<%@ Language=VBScript %><%Option ExplicitResponse.Expires = 0Public Const Fonts_Helvetica = 0Public Const Fonts_Courier = 1Public Const Fonts_Times_Roman = 2Public Const FontStyles_Regular = 0Public Const FontStyles_Bold = 1Public Const FontStyles_Italic = 2Public Const FontStyles_BoldItalic = 3Public Const Borders_thick = 1Public Const Borders_thin = 2Public Const Borders_none = 3'===================Dim oPdf 'As PDFDocumentDim sText 'As StringDim oTexts 'As TextAreaDim oTable 'As tableDim oRow 'As rowDim oCell 'As cellSet oPdf = New PDFDocumentoPdf.Creator = "Igor Krupitsky"Set oTexts = New TextAreaoTexts.AddText "Server side PDF rules!", Fonts_Times_Roman, 15, ""oTexts.AddText "Planet Source Code.", Fonts_Courier, 15, FontStyles_BoldoTexts.AddText "The largest Public source code database on the Internet With 8,297,283 lines of code, articles and tutorials in 11 languages,as well as 1,127 open job postings.", Fonts_Courier, 12, ""oPdf.AddControl oTextsSet oTable = New TableoTable.Border = Borders_thin 'Borders_none, Borders_thickSet oRow = New rowSet oCell = New celloCell.AddText "First Name", Fonts_Helvetica, 10oRow.AddCell oCellSet oCell = New celloCell.AddText "Last Name", Fonts_Helvetica, 10oRow.AddCell oCellSet oCell = New celloCell.AddText "Phone", Fonts_Helvetica, 10oRow.AddCell oCelloTable.AddRow oRowSet oRow = New rowSet oCell = New celloCell.AddText "James", Fonts_Helvetica, 14oRow.AddCell oCellSet oCell = New celloCell.AddText "Bond", Fonts_Helvetica, 14oRow.AddCell oCellSet oCell = New celloCell.AddText "007", Fonts_Helvetica, 14oRow.AddCell oCelloTable.AddRow oRowoPdf.AddControl oTable'oPdf.OutputToFile "c:\temp\test.pdf"Dim sTemp: sTemp = oPdf.OutputToStream()Response.ContentType = "application/pdf"Response.BinaryWrite StringToMultiByte(sTemp)'===================Class Cell	Public default Property Get ClassName() 'As FontStyles		ClassName = "Cell"	End Property	Private m_textArea 'As TextArea	Private m_Height 'As Integer ' PDFUnits	Public ColumnSpan 'As Integer	Public WidthInPDFUnits 'As Integer	Public StartPDFH 'As Integer ' Start of text	Public StartPDFV 'As Integer	Public WidthInPercent 'As Integer	Private Sub Class_Initialize()	 Set m_textArea = New TextArea	 ColumnSpan = 1	End Sub	function GetCopy() 'As cell	 Dim myCell 'As cell	 Dim myText 'As TextObject	 Set myCell = New cell	 With myCell	 For Each myText In m_textArea.getTexts	.AddText myText.Text, myText.Font, myText.FontSize	 Next	 .ColumnSpan = ColumnSpan	 End With	 Set GetCopy = myCell	End function	function Draw(ByRef FontAlias, ByRef pagenum, ByVal TopMargin) 'As PDFObject	 m_textArea.StartPDFH = StartPDFH	 Set Draw = m_textArea.Draw(StartPDFV, WidthInPDFUnits, FontAlias, pagenum, TopMargin)	End function	Public Sub AddText(ByVal Text, ByVal Font, ByVal FontSize)	 if Font = "" Then Font = Fonts_Helvetica	 if FontSize = "" Then FontSize = 10	 m_textArea.AddText Text, Font, FontSize, FontStyles_Regular	End Sub	function CalculateHeight(ByVal width) 'As Integer	 WidthInPDFUnits = width	 m_textArea.CalculateHeight (width)	 m_Height = m_textArea.HeightInPDFunits	 CalculateHeight = m_Height	End function	End Class'===================Class CFontObj	Public default Property Get ClassName() 'As FontStyles		ClassName = "FontObj"	End Property	Dim m_Font 'As Fonts	Dim m_FontName 'As String	Dim m_fontStyle 'As FontStyles	Public FontRef 'As String	Public FontObj 'As String	Private Sub Class_Initialize()	 m_Font = Fonts_Helvetica	 m_fontStyle = FontStyles_Regular	 m_FontName = ""	End Sub	function equals(ByVal FontObj) 'As Boolean	 equals = True	 if m_Font <> FontObj.Font Or m_fontStyle <> FontObj.FontStyle Then	 equals = False	 Else	 equals = True	 End if	End function	Public Property Get FontStyle() 'As FontStyles	FontStyle = m_fontStyle	End Property	Public Property Let FontStyle(ByVal myFontStyle)	m_fontStyle = myFontStyle	Call SetFontName	End Property	Public function ValidFont(ByVal Font) 'As Boolean	if -1 < Font And Font < 5 Then	 ValidFont = True	Else	 ValidFont = False	End if	End function	Public Property Get HorizontalSpace() 'As Double	 Dim space 'As Double	 Select Case m_Font	 Case Fonts_Courier	space = 1.7	 Case Fonts_Helvetica	space = 2.2	 Case Fonts_Times_Roman	space = 2.4	 Case Else	space = 2	 End Select	 if m_fontStyle = FontStyles_Bold Or m_fontStyle = FontStyles_BoldItalic Then	 space = space * 0.91	 End if	 HorizontalSpace = space	End Property	Public Property Get Font() 'As Fonts	 Font = m_Font	End Property	Public Property Let Font(ByVal myFont)	 m_Font = myFont	 Call SetFontName	End Property	Private Sub SetFontName()	 Select Case m_Font	 Case Fonts_Courier	Select Case m_fontStyle	Case FontStyles_Regular	 m_FontName = "Courier"	Case FontStyles_Bold	 m_FontName = "Courier-Bold"	Case FontStyles_Italic	 m_FontName = "Courier-Oblique"	Case FontStyles_BoldItalic	 m_FontName = "Courier-BoldOblique"	Case Else	 Err.Raise 100,"","Invalid Font style."	End Select	 Case Fonts_Helvetica	Select Case m_fontStyle	Case FontStyles_Regular	 m_FontName = "Helvetica"	Case FontStyles_Bold	 m_FontName = "Helvetica-Bold"	Case FontStyles_Italic	 m_FontName = "Helvetica-Oblique"	Case FontStyles_BoldItalic	 m_FontName = "Helvetica-BoldOblique"	Case Else	 Err.Raise 100,"","Invalid Font style."	End Select	 Case Fonts_Times_Roman	Select Case m_fontStyle	Case FontStyles_Regular	 m_FontName = "Times-Roman"	Case FontStyles_Bold	 m_FontName = "Times-Bold"	Case FontStyles_Italic	 m_FontName = "Times-Italic"	Case FontStyles_BoldItalic	 m_FontName = "Times-BoldItalic"	Case Else	 Err.Raise 100,"","Invalid Font style."	End Select	 Case Else	Err.Raise 100,"","Invalid Font"	 End Select	End Sub	Public Property Get FontName() 'As String	 FontName = m_FontName	End PropertyEnd Class'===================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 Arne@garvander.com) Tj" & vbCr	 stream = stream & "ET" & vbCr	 PDFO.addStream (stream)	 Set Draw = PDFO	End function	function toString() 'As String	 toString = "Page Break"	End functionEnd 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 functionEnd Class'===================Class PDFObject	Public default Property Get ClassName() 'As FontStyles		ClassName = "PDFObject"	End Property	Dim m_resources 'As String	Public m_fonts 'As Scripting.Dictionary	Private m_streams 'As Scripting.Dictionary	Public PageBreak 'As Boolean	Private Sub Class_Initialize()	Set m_fonts = CreateObject("Scripting.Dictionary")	Set m_streams = CreateObject("Scripting.Dictionary")	End Sub	Public Sub addStream(ByVal stream)	m_streams.Add stream, ""	End Sub	Public Function FontExists(ByVal Font) 'As Boolean	Dim FontObj 'As String	' FontExists = False	For Each FontObj In m_fonts	If FontObj = Font Then	' FontExists = True	FontExists = True	End If	Next	FontExists = False	End Function	Public Function GetStream() 'As String	Dim sItem	For Each sItem In m_streams	GetStream = sItem	m_streams.Remove sItem	Exit Function	Next	End Function	Public Function count() 'As Integer	count = m_streams.count	End Function	Public Property Get Resources() 'As String	Resources = m_resources	End Property	Public Property Let Resources(ByVal Value)	m_resources = Value	End PropertyEnd Class'===================Class Row	Public default Property Get ClassName() 'As FontStyles		ClassName = "Row"	End Property	Private m_cells 'As Scripting.Dictionary	Private m_Height 'As Integer	Private Sub Class_Initialize()	 Set m_cells = CreateObject("Scripting.Dictionary")	End Sub	Public Sub AddCell(ByVal myCell)	 Dim aCell 'As cell	 Set aCell = myCell.GetCopy	 m_cells.Add aCell, ""	End Sub	 Property Get HeightInPDFunits()	 HeightInPDFunits = m_Height	End Property	 Property Get cells() 'As Scripting.Dictionary	 Set cells = m_cells	End Property	function CalculateHeight(ByVal width, ByVal cellpadding)	 Dim cell 'As cell	 Dim H 'As Integer	 Dim w 'As Integer' Printable width	 m_Height = 0	 width = width / m_cells.count	 w = width - 2 * cellpadding	 For Each cell In m_cells	 H = cell.CalculateHeight(w)	 if H > m_Height Then	m_Height = H	 End if	 Next	 m_Height = m_Height + 2 * cellpadding	 CalculateHeight = m_Height	End functionEnd Class'===================Class Table	Public default Property Get ClassName() 'As FontStyles		ClassName = "Table"	End Property	Private m_border 'As Borders	Private m_rows 'As Scripting.Dictionary	Private m_Height 'As Integer	Public CellPaddingInPDFUnits 'As Integer	Private m_ColumnWidth 'As Integer' PDF measurement	Private m_cellCount 'As Integer	Private m_ActualHeight 'As Integer	Private m_startH 'As Integer	Private m_StartV 'As Integer	Private Sub Class_Initialize()	 Set m_rows = CreateObject("Scripting.Dictionary")	 m_border = Borders_thick	 CellPaddingInPDFUnits = 4	End Sub	function GetCopy()	End function	Public Property Get StartPDFH() 'As Integer	 StartPDFH = m_startH	End Property	Public Property Let StartPDFH(ByVal MyStartInPDFUnits)	 m_startH = MyStartInPDFUnits	End Property	Public function Draw(ByRef StartV, ByVal width, ByRef FontAlias, _	 ByRef pagenum, ByVal TopMargin) 'As PDFObject	 Dim pdfObj 'As PDFObject	 Dim row 'As row	 Dim count 'As Integer	 Dim TotalCols 'As Integer	 Dim stream 'As String' Text Stream	 Dim GStream 'As String' graphics stream	 Dim cell 'As cell	 Dim RightH 'As Integer	 Dim V 'As Integer	 Dim H 'As Integer	 Dim RowStartV 'As Integer	 Dim cols 'As Integer	 Dim c 'As Integer	 Dim accumColumn 'As Integer	 Dim RowStarty 'As Integer	 Set pdfObj = New PDFObject	 Call CalculateTable(width)	 ' Save start point	 m_StartV = StartV	 if m_border <> Borders_none Then	 stream = "0.0 G " + vbCr ' Black color	 if m_border = Borders_thick Then	stream = "2 w " + vbCr ' Line width	 Else	stream = "1 w " + vbCr ' Line width	 End if	 RightH = m_startH + width	 ' Top level line of the table	 stream = stream + line(m_startH, StartV, RightH, StartV)	 For Each row In m_rows	' Print first vertical bar For Each cell	V = StartV - row.HeightInPDFunits	stream = stream + line(m_startH, StartV, m_startH, V)	' Print right vertical bar For Each cell	cols = 0	c = 1	accumColumn = 0	For Each cell In row.cells	cols = cols + cell.ColumnSpan	if c = row.cells.count Then	 H = RightH	Else	 if cell.WidthInPercent = 0 Then	 H = m_startH + cols * m_ColumnWidth	 Else	 accumColumn = accumColumn + cell.WidthInPercent * width	 H = m_startH + accumColumn	 End if	End if	V = StartV - row.HeightInPDFunits	if V < 1 Then Exit For	stream = stream + line(H, StartV, H, V)	c = c + 1	Next	' Print row divider	StartV = StartV - row.HeightInPDFunits	stream = stream + line(m_startH, StartV, RightH, StartV)	 Next	 End if	 ' Print text in cells	 V = m_StartV	 For Each row In m_rows	 H = m_startH	 For Each cell In row.cells	cell.StartPDFH = H + CellPaddingInPDFUnits	cell.StartPDFV = V	Set pdfObj = cell.Draw(FontAlias, 1, TopMargin)	stream = stream + pdfObj.getStream	if cell.WidthInPercent = 0 Then	H = H + cell.ColumnSpan * m_ColumnWidth	Else	H = H + width * cell.WidthInPercent	End if	 Next	 V = V - row.HeightInPDFunits	 if V < 1 Then Exit For	 Next	 pdfObj.addStream (stream)	 Set Draw = pdfObj	End function	Sub CalculateTable(ByVal width)	 Dim row 'As row	 m_ActualHeight = 0	 ' Calculate table width	 if width = 0 Then	 Err.Raise 100,"","Zero Width table Not supported."	 End if	 ' Check To see that we have a column count	 if m_rows.count < 1 Then	 Err.Raise 100,"","No Rows To draw."	 End if	 m_cellCount = CalculateCellCount()	 ' Column width when all columns have the same width	 m_ColumnWidth = (width - 2 * m_border) / m_cellCount	 ' Calculate	 For Each row In m_rows	 row.CalculateHeight m_ColumnWidth, CellPaddingInPDFUnits	 m_ActualHeight = m_ActualHeight + row.HeightInPDFunits + 2 * m_border	 Next	 m_ActualHeight = m_ActualHeight + 2 * m_border	End Sub	Public Sub setColumnWidth(ByVal width)	 ' This method sets the width of the table columns	 ' Columns are from index 1 To the upper bound of width(). With(0) is Not used.	 ' Each entry In the input array becomes a percentage of the sum of all entries in the input array	 Dim row 'As row	 Dim cell 'As cell	 Dim totalWidth 'As Integer	 Dim i 'As Integer	 Dim cols 'As Integer	 if m_rows.count < 1 Then	 Err.Raise 100,"","No rows."	 End if	 m_cellCount = CalculateCellCount()	 if m_cellCount <> UBound(width) Then	 Err.Raise 100,"","Number of columns doesn't match the setting For column width."	 End if	 For i = 1 To UBound(width)	 totalWidth = totalWidth + width(i) ' Calculate the total	 Next	 if totalWidth <= 0 Then	 Err.Raise 100,"","Can't Set column width on table."	 End if	 For Each row In m_rows	 cols = 0	 For Each cell In row.cells	cols = cols + cell.ColumnSpan	cell.WidthInPercent = Math.Round(width(cols) / totalWidth, 2) ' Percent	 Next	 Next	End Sub	Private function CalculateCellCount() 'As Integer	 Dim scellCnt 'As Integer	 Dim cellCnt 'As Integer	 Dim row 'As row	 Dim cell 'As cell	 For Each row In m_rows	 cellCnt = 0	 For Each cell In row.cells	cellCnt = cellCnt + cell.ColumnSpan	 Next	 if scellCnt <> 0 And scellCnt <> cellCnt Then	Err.Raise 100,"","Uneven number of cells With column span In the row collection."	 End if	 scellCnt = cellCnt	 Next	 if cellCnt = 0 Then	 Err.Raise 100,"","No columns/cells."	 End if	 CalculateCellCount = cellCnt	End function	Private function line(ByVal x, ByVal y, ByVal x1, ByVal y1) 'As String	 Dim stream 'As String	 stream = stream & x & " " & y & " m" + vbCr	 stream = stream & x1 & " " & y1 & " l" + vbCr	 stream = stream & "S" + vbCr	 line = stream	End function	Public Property Get Border() 'As Borders	 Border = m_border	End Property	Public Property Let Border(ByVal myBorder)	 Select Case myBorder	 Case Borders_none	m_border = myBorder	 Case Borders_thick	m_border = myBorder	 Case Borders_thin	m_border = myBorder	 Case Else	Err.Raise 100,"","Invalid Border"	 End Select	End Property	Public Sub AddRow(ByVal myRow)	 m_rows.Add myRow, ""	End Sub	Public function toString() 'As String	 toString = "Table rows: " & m_rows.count	End functionEnd Class'===================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 functionEnd Class'===================Class TextObject	Public default Property Get ClassName() 'As FontStyles		ClassName = "TextObject"	End Property	Dim m_Text 'As String	Dim m_Font 'As FontObj	Public FontSize 'As Integer	Private Sub Class_Initialize()	 Set m_Font = New CFontObj	 FontSize = 10	End Sub	Public Property Get FontStyle() 'As FontStyles	 FontStyle = FontObj.FontStyle	End Property	Public Property Let FontStyle(ByVal MyStyle)	 m_Font.FontStyle = MyStyle	End Property	Public Property Get Font() 'As Fonts	 Font = m_Font.Font	End Property	Public Property Let Font(ByVal myFont)	 m_Font.Font = myFont	End Property	Public Property Get Text() 'As String	 Text = m_Text	End Property	Public Property Let Text(ByVal myText)	 m_Text = myText	End Property	Public Property Get FontObj() 'As FontObj	 Set FontObj = m_Font	End Property	Public Property Set FontObj(ByVal myFont)	 Set m_Font = myFont	End PropertyEnd Class'===================Function GetPdfFormatedDate()	GetPdfFormatedDate = year(Now) & _		PadLeftWithZeros(month(now),2) & _		PadLeftWithZeros(day(now),2) & _		PadLeftWithZeros(hour(now),2) & _		PadLeftWithZeros(minute(now),2) & _		PadLeftWithZeros(second(now),2)End functionFunction PadLeftWithZeros(sValue,iSize)	PadLeftWithZeros = right("00000000" + trim(sValue),iSize)	End function	function StringToMultiByte(S)	Dim i, MultiByte	For i=1 To Len(S)	MultiByte = MultiByte & ChrB(Asc(Mid(S,i,1)))	Next	StringToMultiByte = MultiByteEnd function%>

Basaso en la librería X2pdf.net creada por Arne Garvander. Creado por Igor Krupitsky.

tags: generar pdf con asp clásico, generar pdf con asp, generar pdf asp clásico, asp classic pdf, asp classic pdf generator, classic asp generate pdf from html, asp classic export to pdf, asp classic save pdf from html

En esta sección encontrarás una mezcla de códigos recopilados de fuentes públicas de Internet y otros creados por nosotros. Compartimos recursos útiles de buena fe para formar una base de conocimiento en el desarrollo de aplicaciones en ASP Clásico.