Print Preview ActiveX Active Users: 60 / Visits Today: 203
Highest Active Users: 101
Print Preview ActiveX
Home | Profile | Register | Active Topics | Members | Search | FAQ | RSS
 All Forums
 Print Preview
 Tips & Tricks
 Generic Form Preview

Note: You must be registered in order to post a reply.
To register, click here. Registration is FREE!

Screensize:
UserName:
Password:
Format Mode:
Format: BoldItalicizedUnderlineStrikethrough Align LeftCenteredAlign Right Horizontal Rule Insert HyperlinkInsert Email Insert CodeInsert QuoteInsert List
   
Message:

* HTML is OFF
* Forum Code is ON
Smilies
Smile [:)] Big Smile [:D] Cool [8D] Blush [:I]
Tongue [:P] Evil [):] Wink [;)] Clown [:o)]
Black Eye [B)] Eight Ball [8] Frown [:(] Shy [8)]
Shocked [:0] Angry [:(!] Dead [xx(] Sleepy [|)]
Kisses [:X] Approve [^] Disapprove [V] Question [?]

   Insert a File

Check here to subscribe to this topic.
   

T O P I C    R E V I E W
Waty Thierry Posted - 01/26/2004 : 23:12:39
You can see a demo of this generic routine
by downloading the ImmoAssist application on http://www.immoassist.com

Public Sub DoPrint(frm As Form, Optional bEmpty As Boolean = False, Optional sPrinter As String)
' #VBIDEUtils#************************************************************
' * Author : Waty Thierry
' * Web Site : http://www.vbdiamond.com
' * E-Mail : waty.thierry@vbdiamond.com
' * Date : 02/06/2003
' * Project Name : ImmoAssist
' * Module Name : Main_Module
' * Module Filename : Main.bas
' * Procedure Name : DoPrint
' * Purpose :
' * Parameters :
' * frm As Form
' * Optional bEmpty As Boolean = False
' * Optional sPrinter As String
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * Screenshot :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************

' #VBIDEUtilsERROR#
On Error GoTo ERROR_DoPrint

Dim oPreview As PrintPreview5.Preview

Dim nI As Integer
Dim nJ As Long

Dim nOldFontSize As Integer

Dim nRowTitle As Long

Dim nRow As Long
Dim nCol As Long

Dim oControl As Control
Dim oColControls As Collection

Dim sTmp As String

Dim sFrame1 As String

Dim oHourglass As class_Hourglass
Set oHourglass = New class_Hourglass

' *** Create a list of controls ordered by tabindex
Set oColControls = New Collection

On Error Resume Next
For Each oControl In frm.Controls
oColControls.Add oControl, "TabIndex" & oControl.TabIndex
If LCase$(oControl.Name) = "frametab" Then oControl.Visible = True
Next
On Error GoTo ERROR_DoPrint

Set oPreview = New PrintPreview5.Preview
With oPreview
.AddFirstPage "0,25 in", "0.25 in", "0.25 in", "0.25 in", , , prPSA4

.ShowStatusBarIcon = True
.ShowPrintable = False
.ShowMailButton = False
.ShowFindButton = False

.WindowState = prMaximized
.Zoom = prZMWholePage

.CurrentFrame = "Inside"
sFrame1 = .CurrentFrame

nRow = .ConvertToTwip(prCentimeter, 1)
nCol = .ConvertToTwip(prCentimeter, 0)

If FileExist(gsConfig_Logo) Then
' *** Print the logo
On Error Resume Next
Set frmMain.pictLogo = LoadPicture(gsConfig_Logo)
nRow = .ConvertToTwip(prCentimeter, 0)

.DrawPicture gsConfig_Logo, prSTExternal, nCol, nRow, frmMain.pictLogo.ScaleWidth / 1.5, frmMain.pictLogo.ScaleHeight / 1.5
On Error GoTo ERROR_DoPrint
nRow = .CurrentY + frmMain.pictLogo.ScaleHeight / 1.5
.CurrentY = nRow
End If

.FontBold = True
.FontName = "Arial"

.FontSize = 16
.AddTextAt vbNullString

.AddTextAt gsRegisteredName, nCol

.FontSize = 12
If Len(gsRegisteredAddress1) > 0 Then .AddTextAt gsRegisteredAddress1, nCol
If Len(gsRegisteredAddress1) > 0 Then .AddTextAt gsRegisteredAddress2, nCol
If Len(gsRegisteredAddress1) > 0 Then .AddTextAt Trim$(Replace(gsRegisteredAddress3, "%EXECUTION%", gnExpired)), nCol

.FontBold = False

If Len(gsRegisteredTelephone) > 0 Then .AddTextAt IIf(bRegistered, Translation("Téléphone: µ1257"), "") & gsRegisteredTelephone, nCol

.FontBold = False
If Len(gsRegisteredFax) > 0 Then .AddTextAt IIf(bRegistered, Translation("Fax: µ582"), "") & gsRegisteredFax, nCol

.FontBold = False
If Len(gsRegisteredEmailAddress) > 0 Then .AddTextAt IIf(bRegistered, Translation("Email: µ542"), "") & gsRegisteredEmailAddress, nCol

.FontSize = 10
.FontBold = False
If Len(gsRegisteredTVAReference) > 0 Then .AddTextAt IIf(bRegistered, Translation("TVA : µ1300"), "") & gsRegisteredTVAReference, nCol
.FontSize = 12

.FontSize = 10
.FontBold = False
If Len(gsRegisteredRegistreCommerce) > 0 Then .AddTextAt IIf(bRegistered, Translation("Registre Commerce: µ1169"), "") & gsRegisteredRegistreCommerce, nCol
.FontSize = 12

.AddTextAt vbNullString
nRowTitle = .CurrentY

' *** First, check all controls to see if we are not in landscape
For nI = 0 To oColControls.Count - 1
Set oControl = oColControls("TabIndex" & nI)
' *** Print only if it is visible
If oControl.Visible Then
If TypeOf oControl Is ImmoGrid Then
' *** Estimate the Grid
If (InStr(oControl.Tag, "NOPRINT") = 0) Then
Call EstimateGridWidth(oPreview, oControl, 0)
End If
End If
End If
Next

' *** Add all inside controls
For nI = 0 To oColControls.Count - 1
Set oControl = oColControls("TabIndex" & nI)

' *** Print only if it is visible
If oControl.Visible Then
If TypeOf oControl Is CustomizedTextBox Then
' **** Print the Customized textbox

If (InStr(oControl.Tag, "NOPRINT") = 0) Then
nRow = .CurrentY

sTmp = oControl.Text

If bEmpty Then
sTmp = String$(IIf(oControl.MaxLength > 100, oControl.MaxLength / 2, oControl.MaxLength), ".")
If Len(sTmp) = 0 Then
sTmp = String$(20, ".")
End If

End If

.FontSize = 12
.FontBold = False
.FontName = "Arial"

Dim nSkipMode As eAutoStep

nSkipMode = prASPage

If (TypeOf oColControls("TabIndex" & nI + 1) Is Label) And (InStr(oColControls("TabIndex" & nI + 1).Tag, "PUTAFTER") > 0) Then
nSkipMode = prASLine
End If

If oControl.MultiLine = False Then
.AddTextAt sTmp, nCol, nRow, , nSkipMode

Else
If Len(sTmp) > 0 Then
.ParaText sTmp, nCol, nRow + 60
Else
.AddTextAt sTmp, nCol, nRow, , nSkipMode
End If

End If

If (TypeOf oColControls("TabIndex" & nI + 1) Is Label) And (InStr(oColControls("TabIndex" & nI + 1).Tag, "PUTAFTER") > 0) Then
' *** Add the length of this caption
nCol = nCol + .TextWidth(sTmp) + 100

.FontSize = 12
.FontBold = False
.FontName = "Arial"
.ForeColor = oColControls("TabIndex" & nI + 1).ForeColor
.AddTextAt oColControls("TabIndex" & nI + 1).Caption, nCol, nRow
.ForeColor = vbBlack
End If

End If

ElseIf TypeOf oControl Is Label Then
' **** Print the Label
sTmp = oControl.Caption
If (Len(sTmp) > 0) And (InStr(oControl.Tag, "NOPRINT") = 0) Then
' *** Check if next control is well a Textbox
If nI < oColControls.Count - 1 Then
If (TypeOf oColControls("TabIndex" & nI + 1) Is CustomizedTextBox) Or _
(TypeOf oColControls("TabIndex" & nI + 1) Is CheckBox) Or _
(TypeOf oColControls("TabIndex" & nI + 1) Is OptionButton) Then
' *** Ok, we can add this label

' *** Check to skip a page, fixed to 2 cm
If .CurrentY + .ConvertToTwip(prCentimeter, 2) >= .PageInsideHeight Then
.AddPageTemplate
End If

nCol = .ConvertToTwip(prCentimeter, 0)
nRow = .CurrentY

' *** Check to remove the *
If right$(Trim$(sTmp), 2) = " *" Then
sTmp = Replace(sTmp, " *", vbNullString)
End If

.FontSize = 12
.FontBold = True
.FontName = "Arial"
.ForeColor = oControl.ForeColor
.AddTextAt sTmp, nCol, nRow

' *** Add the length of this caption
If .ConvertToTwip(prCentimeter, 6) < .TextWidth(sTmp) + .ConvertToTwip(prCentimeter, 1) Then
nCol = nCol + .TextWidth(sTmp) + .ConvertToTwip(prCentimeter, 1)
Else
nCol = nCol + .ConvertToTwip(prCentimeter, 6)
End If

.FontBold = False
.CurrentY = nRow
.ForeColor = vbBlack

End If

End If
End If

ElseIf TypeOf oControl Is CheckBox Then
If (InStr(oControl.Tag, "NOPRINT") = 0) Then
If bEmpty Then
.DrawSymbol "Internal", "checkbox", False, nCol + .C_Twips("0.05 in"), nRow + .C_Twips("0.10 in"), ".10 in"

Else
.DrawSymbol "Internal", "checkbox", IIf(oControl.Value = vbChecked, True, False), nCol + .C_Twips("0.05 in"), nRow + .C_Twips("0.10 in"), ".10 in"

End If

.CurrentY = .CurrentY + 137
End If

ElseIf TypeOf oControl Is OptionButton Then
If (InStr(oControl.Tag, "NOPRINT") = 0) Then
If bEmpty Then
.DrawSymbol "Internal", "radio", False, nCol + .C_Twips("0.05 in"), nRow + .C_Twips("0.10 in"), ".10 in"

Else
.DrawSymbol "Internal", "radio", oControl.Value, nCol + .C_Twips("0.05 in"), nRow + .C_Twips("0.10 in"), ".10 in"

End If

.CurrentY = .CurrentY + 137
End If

ElseIf TypeOf oControl Is ThumbNailList Then
' *** Add picture from preview
Dim oPicture As Picture

.CurrentX = .PageInsideLeft
For nJ = 0 To oControl.GetNumberPicture() - 1
Set oPicture = LoadPicture(oControl.GetPictureFilename(nJ))
If (nJ Mod oControl.Print_NrThumbCols = 0) And (nJ > 0) Then
.CurrentY = .CurrentY + oPicture.Height
.CurrentX = .PageInsideLeft
End If

If .CurrentY + .ConvertToTwip(prCentimeter, 5) >= .PageInsideHeight Then
.AddPageTemplate
.CurrentX = .PageInsideLeft
End If

.DrawPicture oControl.GetPictureFilename(nJ), prSTExternal, .CurrentX, .CurrentY
.CurrentX = .CurrentX + oPicture.Width

Next
If nJ > 0 Then .CurrentY = .CurrentY + oPicture.Height
If .CurrentY + .ConvertToTwip(prCentimeter, 5) >= .PageInsideHeight Then
.AddPageTemplate
End If

ElseIf (TypeOf oControl Is Frame) Or (TypeOf oControl Is ImmoAssistFrame.Frame) Then
' *** Print the frame

sTmp = oControl.Caption
If (Len(sTmp) > 0) And (InStr(oControl.Tag, "NOPRINT") = 0) Then
' *** Check to skip a page, fixed to 5 cm for the frame
If .CurrentY + .ConvertToTwip(prCentimeter, 5) >= .PageInsideHeight Then
.AddPageTemplate
End If

.AddTextAt vbNullString
nRow = .CurrentY

nCol = .ConvertToTwip(prCentimeter, 0)
nRow = .CurrentY

.FontSize = 14
.FontBold = True
.ForeColor = vbBlack
.FontName = "Arial"
.AddTextAt sTmp, nCol, nRow

nRow = .CurrentY
.DrawLine nCol, nRow, .TextWidth(sTmp) + .ConvertToTwip(prCentimeter, 1), nRow, prLBLine
nRow = .CurrentY + .ConvertToTwip(prCentimeter, 0.1)
.DrawLine nCol, nRow, .TextWidth(sTmp) + .ConvertToTwip(prCentimeter, 2), nRow, prLBLine

.FontItalic = False
.FontBold = False
.FontSize = 12

.AddTextAt vbNullString

nRow = .CurrentY

End If

ElseIf TypeOf oControl Is ImmoGrid Then
' *** Print the Grid

If (InStr(oControl.Tag, "NOPRINT") = 0) Then
' *** Check to skip a page, fixed to 2 cm
If .CurrentY + .ConvertToTwip(prCentimeter, 2) >= .PageInsideHeight Then
.AddPageTemplate
End If

Call DoPrintGrid(oPreview, oControl, 0)

End If

End If

End If

Next

' *** Main Title
sTmp = frm.Caption

.CurrentPage = 1
.CurrentFrame = sFrame1

.FontSize = 14
.FontItalic = True
.FontBold = True
.ForeColor = vbBlue
.FontName = "Arial"
.DrawWidth = 5
.DrawLine 0, nRowTitle, .PageInsideWidth - .TextWidth(sTmp) - .ConvertToTwip(prCentimeter, 2), nRowTitle, prLBLine
.AddTextAt sTmp, .PageInsideWidth - .TextWidth(sTmp) - .ConvertToTwip(prCentimeter, 1), nRowTitle - .ConvertToTwip(prCentimeter, 0.4)
.FontItalic = False
.FontBold = False

nRowTitle = nRowTitle + .ConvertToTwip(prCentimeter, 0.1)

.DrawWidth = 3
.DrawLine 0, nRowTitle, .PageInsideWidth, nRowTitle, prLBLine

For nI = 1 To .TotalPages
.CurrentPage = nI
If (gnLicense = 0) Or (gsRegisteredName = vbNullString) Then
.Watermark Translation("Version Demoµ1350"), RGB(255, 230, 204), "Arial", True, False
End If

.ShowBorder = False

nOldFontSize = .FontSize
.FontSize = 10
sTmp = .FontName
.FontName = "Arial"
.FontBold = False
.ForeColor = QBColor(2)
If (gnLicense = 0) Or (gsRegisteredName = vbNullString) Then
.AddTextAt "(c) " & Year(Date) & " " & Translation(" ImmoAssist, imprimé leµ85") & " " & Format$(Now, "dd mmmm yyyy") & Translation(", Version Démoµ169"), 0, .PageInsideHeight - .PageInsideTop * 2 - 100, , prASNone
Else
.AddTextAt "(c) " & Year(Date) & " " & Translation(" ImmoAssist, imprimé leµ85") & " " & Format$(Now, "dd mmmm yyyy") & Translation(", Licence d'utilisation accordée ŕµ167") & " " & gsRegisteredName, 0, .PageInsideHeight - .PageInsideTop * 2 - 100, , prASNone
End If
.AddTextAt Translation("Page µ1031") & " " & nI, .PageInsideWidth - 200, .PageInsideHeight - .PageInsideTop * 2 - 100, prALRight, prASNone
.FontSize = 10
.FontBold = False
.ForeColor = vbBlack
.FontName = sTmp
.FontSize = nOldFontSize
Next

'.ShowPrintToFile = False

If (gnLicense = 0) Or (gsRegisteredName = vbNullString) Then
.ShowPrintButton = False
End If

' *** Set the language
Select Case gnLanguage
Case FRENCH_LANG
.SetLanguage prFrench

Case DUTCH_LANG
.SetLanguage prDutch

Case Else
.SetLanguage prEnglish

End Select

If sPrinter = vbNullString Then
' *** Preview on screen
.EndDocument

Else
.SetPrinter sPrinter

.EndDocument prOTPrinter

End If

End With

EXIT_DoPrint:
On Error Resume Next

Set oPreview = Nothing

For Each oControl In frm.Controls
If LCase$(oControl.Name) = "frametab" Then
If oControl.Parent.maintab.SelectedTab = oControl.Index Then
oControl.Visible = True
Else
oControl.Visible = False
End If
End If
Next

Exit Sub

' #VBIDEUtilsERROR#
ERROR_DoPrint:
Select Case IAErrorHandler("Error " & Err.Number & ": " & Err.Description & vbCrLf & "in DoPrint", vbAbortRetryIgnore + vbCritical, "Error")
Case vbAbort
Screen.MousePointer = vbDefault
Resume EXIT_DoPrint
Case vbRetry
Resume
Case vbIgnore
Resume Next
End Select

Resume EXIT_DoPrint

End Sub


Come and visit :
www.immoassist.com
www.ppreview.net
www.vbdiamond.com
www.d2dsources.com
www.mandix.com

Print Preview ActiveX © Mandix Go To Top Of Page
This page was generated in 0.22 seconds. Powered By: Snitz Forums 2000 Version 3.4.02