I agree with Brian on their being no way to do this from Outlook itself, but
we can accomplish this with a bit of scripting. The script below will print
the currrently selected contact to include a picture if present. This is
only a proof of concept. A production script would print all the relevant
fields rather than the small list of fields I am using here. It would also
check to see if there are multiple attachments and, if so, scan through them
to find the picture. This does work though. I've tested using Outlook 2003
and it worked beautifully. The advantage of doing it this way is that you
have full control over the resulting output. You can choose your fonts, add
graphics, lay it out any way you want to.
Sub PrintContact()
'Picture is named: ContactPicture.jpg
Const PICTURE_PATH = "C:\Temp\ContactPicture.jpg"
Const FILE_PATH = "C:\Temp\PrintContact.html"
Const OLECMDID_PRINT = 6
Const OLECMDEXECOPT_DONTPROMPTUSER = 2
Const READYSTATE_COMPLETE = 4
Dim olkContact As Outlook.ContactItem, _
olkProp As Outlook.ItemProperty, _
objFSO As Object, _
objFile As Object, _
objIE As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.CreateTextFile(FILE_PATH, True)
Set olkContact = Application.ActiveExplorer.Selection(1)
With olkContact
objFile.WriteLine Session.CurrentUser
objFile.WriteLine "<hr>"
objFile.WriteLine "<table>"
objFile.WriteLine " <tr><td width=""15%""><b>Full Name:</b></td><td
width=""85%"">" & .FullName & "</td></tr>"
objFile.WriteLine " <tr><td width=""15%""><b>Last Name:</b></td><td
width=""85%"">" & .LastName & "</td></tr>"
objFile.WriteLine " <tr><td width=""15%""><b>First
Name:</b></td><td width=""85%"">" & .FirstName & "</td></tr>"
objFile.WriteLine " <tr><td width=""15%""><b>Company:</b></td><td
width=""85%"">" & .CompanyName & "</td></tr>"
objFile.WriteLine " <tr><td width=""15%""><b>Business
Address:</b></td><td width=""85%"">" & .BusinessAddress & "<br>" &
..BusinessAddressCity & ", " & .BusinessAddressState & " " &
..BusinessAddressPostalCode & "</td></tr>"
objFile.WriteLine " <tr><td width=""15%""><b>Business:</b></td><td
width=""85%"">" & .BusinessTelephoneNumber & "</td></tr>"
objFile.WriteLine " <tr><td width=""15%""><b>Mobile:</b></td><td
width=""85%"">" & .MobileTelephoneNumber & "</td></tr>"
objFile.WriteLine " <tr><td width=""15%""><b>Business
Fax:</b></td><td width=""85%"">" & .BusinessFaxNumber & "</td></tr>"
objFile.WriteLine " <tr><td width=""15%""><b>E-mail:</b></td><td
width=""85%"">" & .Email1Address & "</td></tr>"
objFile.WriteLine " <tr><td width=""15%""><b>E-mail Display
As:</b></td><td width=""85%"">" & .Email1DisplayName & "</td></tr>"
objFile.WriteLine " <tr><td width=""15%""><b>Web Page:</b></td><td
width=""85%"">" & .WebPage & "</td></tr>"
If .HasPicture Then
If .Attachments.Count = 1 Then
.Attachments.Item(1).SaveAsFile PICTURE_PATH
objFile.WriteLine " <tr><td
width=""15%""><b>Picture:</b></td><td width=""85%""><img src=""" &
PICTURE_PATH & """</td></tr>"
End If
End If
objFile.WriteLine "</table>"
End With
objFile.Close
Set objIE = CreateObject("InternetExplorer.Application")
objIE.Navigate2 "file:\\" & FILE_PATH
Do Until objIE.readyState = READYSTATE_COMPLETE
DoEvents
Loop
objIE.ExecWB OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER
Set objFile = Nothing
Set objFSO = Nothing
Set olkProp = Nothing
Set olkContact = Nothing
Set objIE = Nothing
End Sub
--
David Lee - MVP Outlook
Similar Threads
