Foros del Web - Ver Mensaje Individual

lexus · #1 (**permalink**) 29/01/2005, 07:51

hola a todos,
esta es otra forma diferente a la que postean aqui para generar pdfs con asp.. no la he probado espero la pruebenm y nos cuenten quetal es.....

el codigo es muy largo asi que lo voy a dividir en varios mensajes.. pero todo va en una sola pagina..

Código:

 
   <%@ Language=VBScript %>
	<%
	Option Explicit
	Response.Expires = 0
	Public Const Fonts_Helvetica = 0
	Public Const Fonts_Courier = 1
	Public Const Fonts_Times_Roman = 2
	Public Const FontStyles_Regular = 0
	Public Const FontStyles_Bold = 1
	Public Const FontStyles_Italic = 2
	Public Const FontStyles_BoldItalic = 3
	Public Const Borders_thick = 1
	Public Const Borders_thin = 2
	Public Const Borders_none = 3
	'===================
	Dim oPdf 'As PDFDocument
	Dim sText 'As String
	Dim oTexts 'As TextArea
	Dim oTable 'As table
	Dim oRow 'As row
	Dim oCell 'As cell
	Set oPdf = New PDFDocument
	oPdf.Creator = "Igor Krupitsky"
	Set oTexts = New TextArea
	oTexts.AddText "Server side PDF rules!", Fonts_Times_Roman, 15, ""
	oTexts.AddText "Planet Source Code.", Fonts_Courier, 15, FontStyles_Bold
	oTexts.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 oTexts
	Set oTable = New Table
	oTable.Border = Borders_thin 'Borders_none, Borders_thick
	Set oRow = New row
	Set oCell = New cell
	oCell.AddText "First Name", Fonts_Helvetica, 10
	oRow.AddCell oCell
	Set oCell = New cell
	oCell.AddText "Last Name", Fonts_Helvetica, 10
	oRow.AddCell oCell
	Set oCell = New cell
	oCell.AddText "Phone", Fonts_Helvetica, 10
	oRow.AddCell oCell
	oTable.AddRow oRow
	Set oRow = New row
	Set oCell = New cell
	oCell.AddText "James", Fonts_Helvetica, 14
	oRow.AddCell oCell
	Set oCell = New cell
	oCell.AddText "Bond", Fonts_Helvetica, 14
	oRow.AddCell oCell
	Set oCell = New cell
	oCell.AddText "007", Fonts_Helvetica, 14
	oRow.AddCell oCell
	oTable.AddRow oRow
	oPdf.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 Property
	End Class
	'===================