More Outlook Resource Sites

Microsoft Developer Network (MSDN)

FAQs and other general resources

share code 21-Feb-2019 21:16

Looking for help with Outlook programming projects — VSTO, add-ins, VBA, custom Outlook forms, etc.? You′ve come to the right place!

NEW! >> Subscribe to this site via RSS. For more RSS options, see the complete list of feeds on our main news page.

Code level: intermediate    Code area: Outlook Expert Techniques Printer Friendly Version
Title: Printing Forms inside Outlook (Working Code)
Description: 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. Its works for me but not flawlessly.
Date: 02-Sep-2005  06:31
Code level: intermediate
Code area: Outlook Expert Techniques
Posted by: Shawn Craig
This message is displayed as VB.NET
 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





All 19comments
Page [ 1 2 Next >>  
  05-Oct-2005  15:13   
Hi, Just checking back. Has anyone found this useful. Was hoping someone would pick this up.
  13-Oct-2005  10:00   
Thanks for posting it, Shawn! Maybe you could provide a little description of what problems it solved and what techniques people can learn from studying it.
  13-Oct-2005  14:43   
Well. I was trying to provide XPrint like plugin that printed forms for outlook 2003.
Basicly your just converting the form into a webpage and printing out. Seems simple enough.

I am not on the exchange team anymore so I thought that a better programmer than myself could get it from where it is, to a plug-in that doesn't present a security pop-up.
 
  17-Oct-2005  19:21   
Cool. The main reason your sample triggers security popups (at least in Outlook 2003) is that it is instantiating its own Outlook.Application object. Someone incorporating it into an addin would derive all the objects from the Application passed in the OnConnection event handler and thus avoid the prompts. Thanks again!
  07-Dec-2005  08:31   
I have tried to run this macro, but seem to get an error when it hits the following code.

Sub AddControl(oldControl As Control)

Any advice on how to get this macro to work?
 
  09-Dec-2005  12:11   
Spree, if you don't have any VBA userforms in your Outlook VBA project, add one. That will automatically add a reference to the MSForms 2.0 library to the project.
  01-Feb-2006  14:41   
Should this code be added as macro to the form or should it be in the code section of a form?
  01-Feb-2006  14:45   
It should be in the macro section
  01-Feb-2006  16:39   
I'm missing something here. I can't get the macro to stay with the form. If I add it to ThisOutlookSession the macro works with no problem but doesn't travel with the form when installed on a new machine. If I add it to a module, the macro fails but it travels with the form.
  02-Feb-2006  01:31   
Pete, macros and form code are two entirely different things. They don't "stay" togetherat all. If you want to incorporate the macro into your form, you'll have to rework it for VBScript. That will involve at least removing any typed variable or procedure declarations and using literal values or declared constants instead of Outlook or other non-VB intrinsic constants.
Page [ 1 2 Next >>