Printing Forms inside Outlook (Working Code)

S

shawncraig

I am no longer in the outlook form business so I am turning over this
code for someone else to finish as long as it remains freeware. It
works for me but not flawlessly. Maybe someone with better skills than
me can get this thing working well enough for public use.

Dim iBasePixel
Dim iTempPixel

Sub PrintForm()
Dim OL As Outlook.Application
Dim oldPages As Outlook.Pages
Dim oldProp As Outlook.UserProperty
Dim oldForm As Object
Dim oldControl As Control

Set OL = New Outlook.Application
Set oldForm = OL.ActiveInspector.CurrentItem
Set oldPages = oldForm.GetInspector.ModifiedFormPages

strFile = Environ("USERPROFILE") & "\Desktop\Form.HTML"
Open strFile For Output As #1

Print #1, "<HTML><HEAD></HEAD><BODY>"
iBasePixel = 0
iTempPixel = 0

For i = 1 To oldPages.Count
Set oldPage = oldPages.Item(i)
AddPageBreak oldPage.Name
For Each oldControl In oldPage.Controls
ProcessControl oldControl, oldForm, oldPage.Name
Next
Next
Print #1, "</BODY></HTML>"
Close #1
Call PrintFormInIE(strFile)
End Sub

Sub ProcessControl(oldControl, oldForm, strParentName)
'todo: Change oldPage to strParentName
If oldControl.Parent.Name = strParentName Then
strValue = ""
sProgID = GetProgID(oldControl)
Debug.Print sProgID
Select Case sProgID
Case "Forms.CheckBox.1"
If oldControl.Value = True Then
strValue = "<INPUT TYPE=Checkbox checked>"
Else
strValue = "<INPUT TYPE=Checkbox>"
End If
strValue = strValue & oldControl.Caption
PrintToHTML strValue, oldControl
Case "Forms.OptionButton.1"
If oldControl.Value = True Then
strValue = "<INPUT TYPE=Radio Checked>"
Else
strValue = "<INPUT TYPE=Radio>"
End If
' Only add the caption of the control is larger than 16
since controls
' smaller than 16 do not show text on Outlook forms
(caption is hidden).
If oldControl.Width > 16 Then strValue = strValue &
oldControl.Caption
PrintToHTML strValue, oldControl
Case "Forms.Label.1"
strValue = oldControl.Caption
PrintToHTML strValue, oldControl
Case "Forms.ComboBox.1"
strValue = "<INPUT TYPE=text Value=" & Chr(34) &
oldControl.Value & Chr(34)
strValue = AppendStyle(strValue, oldControl)
PrintToHTML strValue, oldControl
Case "Forms.TextBox.1"
ctlValue = oldControl.Value
If InStr(1, ctlValue, vbCr) Then
strValue = "<textarea "
strValue = AppendStyle(strValue, oldControl) & ctlValue
& "</textarea>"
Else
strValue = "<INPUT TYPE=text value=" & Chr(34) &
ctlValue & Chr(34)
strValue = AppendStyle(strValue, oldControl)
End If
PrintToHTML strValue, oldControl
Case "RecipientControl"
Select Case oldControl.Name
Case "Email"
strValue = "<INPUT TYPE=text Value=" & Chr(34) &
oldForm.Email1Address & Chr(34)
Case "WebPage"
strValue = "<INPUT TYPE=text Value=" & Chr(34) &
oldForm.WebPage & Chr(34)
Case "_RecipientControl1"
strLinks = ""
For Each oLink In oldForm.Links
strLinks = strLinks & oLink.Name & ";"
Next
strValue = "<INPUT TYPE=text Value=" & Chr(34) &
strLinks & Chr(34)
Case "IMAddress"
strValue = "<INPUT TYPE=text Value=" & Chr(34) &
oldForm.IMAddress & Chr(34)
Case "To"
strValue = "<INPUT TYPE=text Value=" & Chr(34) &
oldForm.To & Chr(34)
Case "CC"
strValue = "<INPUT TYPE=text Value=" & Chr(34) &
oldForm.CC & Chr(34)
Case "Bcc"
strValue = "<INPUT TYPE=text Value=" & Chr(34) &
oldForm.BCC & Chr(34)
Case Else
strValue = "<INPUT TYPE=text Value=" & Chr(34) &
oldControl.Value & Chr(34)
End Select
If strValue <> "" Then strValue = AppendStyle(strValue,
oldControl)
PrintToHTML strValue, oldControl
Case "DocSiteControl"
strValue = "<textarea "
strValue = AppendStyle(strValue, oldControl) & oldForm.Body
& "</textarea>"
PrintToHTML strValue, oldControl
Case "Forms.CommandButton.1"
strValue = "<INPUT TYPE=button "
strValue = strValue & "Value=" & Chr(34) &
oldControl.Caption & Chr(34)
strValue = AppendStyle(strValue, oldControl)
PrintToHTML strValue, oldControl
Case "Forms.Frame.1"
strBorder = ""
If oldControl.BorderStyle = 1 Then strBorder =
"border-style: solid; border-width: 1px;"
strValue = "<fieldset style=""width: " & oldControl.Width &
"; height: " & oldControl.Height & "; " & strBorder & " padding-left:
4px; padding-right: 4px; padding-top: 1px; padding-bottom: 1px"">"
strValue = strValue & "<legend>" & oldControl.Caption &
"</legend>"
PrintToHTML strValue, oldControl

For Each oSubControl In oldControl.Controls
ProcessControl oSubControl, oldForm, oldControl.Name
Next

Print #1, "</fieldset>"
Case "Forms.Image.1"
strValue = ""
PrintToHTML strValue, oldControl
Case "Forms.MultiPage.1"
'strValue = Trim(Chr(34) & oldControl.Caption & " " &
oldControl.Value & Chr(34))
strValue = Chr(34) & "MP1" & Chr(34)
PrintToHTML strValue, oldControl
Case Else
strValue = Trim(Chr(34) & oldControl.Caption & " " &
oldControl.Value & Chr(34))
PrintToHTML strValue, oldControl
End Select

End If
End Sub


Sub PrintToHTML(strValue, oldControl)
If strValue <> "" Then
strValue = "<FONT SIZE=" & Chr(34) & 1 & Chr(34) & ">" &
strValue & "</FONT>"
If TypeName(oldControl.Parent) = "UserForm" Then
intTop = oldControl.Top
PrintHTML strValue, intTop, oldControl.Left,
oldControl.Height
Else
intTop = oldControl.Top + oldControl.Parent.Top
PrintHTML strValue, intTop, oldControl.Left +
oldControl.Parent.Left, oldControl.Height
End If
End If
End Sub

Function AppendStyle(sValue, oControl) As String
On Error Resume Next
iWidth = oControl.Width
iHeight = oControl.Height
iFontSize = oControl.FONTSIZE
If iFontSize = "" Then iFontSize = 10


sValue = sValue & "style=" & Chr(34)
sValue = sValue & "width: " & iWidth & ";"
sValue = sValue & "height: " & iHeight & ";"
sValue = sValue & "font-size:" & iFontSize & ";"
sValue = sValue & Chr(34) & ">"
AppendStyle = sValue
End Function

Sub AddPageBreak(strname)
iBasePixel = (iBasePixel + iTempPixel + 25)

' iBorderLen = 60
' iBorderLen = iBorderLen - Len(strName)
' iBorderLen = Int(iBorderLen / 2)
' strBorder = String(iBorderLen, "=")
' strHTML = "<B>" & strName & "</B>"
' strHTML = strBorder & strHTML & strBorder
' PrintHTML strHTML, 5, 0, 0
PrintHTML "<B>" & strname & "</B>", 5, 0, 0
iBasePixel = iBasePixel + 25
iTempPixel = 0
End Sub

Sub PrintHTML(Value, iTop, iLeft, iHeight)
If iTop + iHeight > iTempPixel Then iTempPixel = iTop + iHeight

'Value = Replace(Value, vbCr, "<BR>")

strHTML = "<SPAN STYLE=" & Chr(34)
strHTML = strHTML & "position: absolute; "
strHTML = strHTML & "top: " & iTop + iBasePixel & ";"
strHTML = strHTML & "left: " & iLeft & ";"
strHTML = strHTML & Chr(34) & ">"
'strHTML = strHTML & "<FONT SIZE=" & Chr(34) & 1 & Chr(34) & ">"
strHTML = strHTML & Value
'strHTML = strHTML & "</FONT>"
strHTML = strHTML & "</SPAN>"
Print #1, strHTML
End Sub

Function GetProgID(oldControl) As String
sType = TypeName(oldControl.Object)
Select Case sType
Case "IMdcCheckBox"
sProgID = "Forms.CheckBox.1"
Case "ILabelControl"
sProgID = "Forms.Label.1"
Case "IMdcText"
sProgID = "Forms.TextBox.1"
Case "IMdcCombo"
sProgID = "Forms.ComboBox.1"
Case "IMdcList"
sProgID = "Forms.ListBox.1"
Case "IMdcOptionButton"
sProgID = "Forms.OptionButton.1"
Case "IMdcToggleButton"
sProgID = "Forms.ToggleButton.1"
Case "ICommandButton"
sProgID = "Forms.CommandButton.1"
Case "IMultiPage"
sProgID = "Forms.MultiPage.1"
Case "UserForm"
sProgID = "Forms.Frame.1"
Case "IImage"
sProgID = "Forms.Image.1"
Case "RecipientControl"
sProgID = sType
Case "DocSiteControl"
sProgID = sType
Case Else
Debug.Print sType
sProgID = "Forms.TextBox.1"
End Select
GetProgID = sProgID
End Function

'======================================================================
'======================================================================
'======================================================================

Sub AddControl(oldControl As Control)
sProgID = GetProgID(oldControl)
On Error Resume Next
With newControl
.Top = oldControl.Top
.Left = oldControl.Left
.Width = oldControl.Width
.Height = oldControl.Height
.TabIndex = oldControl.TabIndex
.TabStop = oldControl.TabStop
.Tag = oldControl.Tag
.Caption = oldControl.Caption
.Text = oldControl.Text
.Value = oldControl.Value
.ItemProperty = oldControl.ItemProperty
.Font = oldControl.Font
.Font.Bold = oldControl.Font.Bold
.ForeColor = oldControl.ForeColor
.BackColor = oldControl.BackColor
End With

Select Case sProgID
Case "Forms.MultiPage.1"
HandleMultipageControls oldControl, newControl
Case "Forms.Frame.1"
AddChildControls oldControl, newControl
Case Else
End Select
End Sub

Sub AddChildControls(oldControl, newControl)
Dim childControl As Control
For Each childControl In oldControl.Controls
If childControl.Parent.Name = newControl.Name Then
AddControl childControl ', newControl.Controls
End If
Next
End Sub

Sub HandleMultipageControls(oldMultiPage, newMultiPage)
newMultiPage.Pages.Clear
For Each oldPage In oldMultiPage.Pages
Set newPage = newMultiPage.Pages.Add(oldPage.Name)
AddChildControls oldPage, newPage
Next
End Sub

Sub PrintFormInIE(strURL)
Dim IE
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = False
IE.navigate strURL
Do Until IE.ReadyState = 4: WScript.Sleep 50: Loop
IE.ExecWB 6, 2
End Sub
 
S

Sue Mosher [MVP-Outlook]

Cool! Would you like to post it over at http://www.outlookcode.com/code.aspx as well?

--
Sue Mosher, Outlook MVP
Author of Configuring Microsoft Outlook 2003

and Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers
 
S

shawncraig

Sue said:
Cool! Would you like to post it over at http://www.outlookcode.com/code.aspx as well?
Click to expand...

Sue, maybe you can tell which group to focus on so this code will get
the most attention. Hopefully an active community will pick this up and
produce a plug-in that can replace xprint.
I posted this code on your site awhile back and no one has commented on
it so I thought I'd move it here.
 
S

Sue Mosher [MVP-Outlook]

Since it's for forms, I'd post it under the section for Outlook Forms code samples. Sorry I didn't remember that you'd posted it earlier. (So many samples, so little time to play. :()

--
Sue Mosher, Outlook MVP
Author of Configuring Microsoft Outlook 2003

and Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Multi Select List Not Working 1
VBA code to distinguish Links 1
VBA Sting Manipulation Replace Path Record 1 step 6
Winzip and email multiple files (RondeBriuins code not working) 1
VBA Code for converting Type-E UPC to Type-A (barcodes) 1
convert a template + macros from Win to Mac? 0
Dynamic VBA for dynamic Forms 0
FormCode - Converting Type-E UPC to Type-A (barcodes) 2

Top