suntex
08-25-2008, 12:00 PM
Hello everyone, first I would like to state that I know very very little about VBA. I do need some help though and thought maybe you guys could lend a hand.
I have switched over some of the people in our office over to Outlook 2003 instead of Outlook Express. One feature they are missing and really need is the ability to voew and print emails with image attachments showing. That way they can have a copy of the email text with the thumb of the image attached under it. Outlook express does this by default but Outlook 2003 does not.
I have found a couple macros online that are close to what I need but they need to be combined I guess, and I do not know how to do that.
Here's one that opens a copy of the email in Internet Explorer, which would work if it would shot the attachments too....
Sub OpenInBrowser()
Dim BrowserLocation As String
Dim AlwaysConvert As Boolean
Dim EvaluateHTML As Boolean
'=============Set your variables in the section below==========================
'The default settings are optimized for viewing newsletters and receiving
'messages with HTML forms or animated gif-files embedded in the message.
'Set the location of the executable of the browser you want to use.
'Standard value: "C:\Program Files\Internet Explorer\iexplore.exe"
BrowserLocation = "C:\Program Files\Internet Explorer\iexplore.exe"
'When set to True, we will let Outlook convert the message to HTML.
'The message will be opened in the configured browser just as it
'appears in Outlook.
'Standard value: False
AlwaysConvert = False
'When set to True, we will look for embedded resources in the HTML message and
'determine whether Outlook should convert the message or whether we can strip
'the HTML directly. When set to False, we will always strip the HTML and ignore
'embedded resources.
'For this setting to take effect, AlwaysConvert must be set to False.
'Standard value: True
EvaluateHTML = True
'=======Don't modify the code below unless you know what you are doing=========
'Get the user's TempFolder to store the item in
Dim FSO As Object, TmpFolder As Object
Set FSO = CreateObject("scripting.filesystemobject")
Set FileName = FSO.GetSpecialFolder(2)
'Get all selected items
Dim MyOlNamespace As Outlook.NameSpace
Set MyOlNamespace = Application.GetNamespace("MAPI")
Set MyOlSelection = Application.ActiveExplorer.Selection
'Make sure at least one item is selected
If MyOlSelection.Count = 0 Then
Response = MsgBox("Please select an item first", vbExclamation, MyApplName)
Exit Sub
End If
'Make sure only one item is selected
If MyOlSelection.Count > 1 Then
Response = MsgBox("Please select only one item", vbExclamation, MyApplName)
Exit Sub
End If
'Retrieve the selected item
Set MyselectedItem = MyOlSelection.Item(1)
'construct the filename
strname = "www_howto-outlook_com"
FileName = FileName & "\" & strname & ".htm"
'If the message is in HTML format we directly capture the HTML from the message
'to construct our htm-file. This will allow us to capture as many HTML elements
'as possible. If it is a different format, or if the HTML mail includes embedded
'resources we let Outlook convert it to HTML.
Dim OutlookConvert As Boolean
OutlookConvert = True
If MyselectedItem.BodyFormat = olFormatHTML And AlwaysConvert = False Then
Dim rawHTML As String
rawHTML = MyselectedItem.HTMLBody
If EvaluateHTML = False Then
OutlookConvert = False
Else
'Check if there are embedded resources in the message.
'If it does, we let Outlook convert the message.
If InStr(UCase(rawHTML), UCase("src=""cid:")) = 0 Then
OutlookConvert = False
End If
End If
End If
'Write the temp-file
If OutlookConvert = False Then
'create the htm-file in the temp folder and write the HTML code to it
Set objFile = FSO.CreateTextFile(FileName, True)
objFile.Write "" & rawHTML
objFile.Close
Set objFile = Nothing
Else
'let Outlook convert the message and save the selected item
'as htm to the temp folder
MyselectedItem.SaveAs FileName, olHTML
End If
'open the saved item in the browser
Shell BrowserLocation & " " & FileName, vbNormalFocus
'Cleanup
Set FSO = Nothing
Set FileName = Nothing
Set MyOlNamespace = Nothing
Set MyOlSelection = Nothing
Set MyselectedItem = Nothing
End Sub
Now here is another macro that opens the attachment files and displays them in a new window. Combine this with the above macro and it would be perfect.
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub view_attachments()
'***************************************************************
' ver. 1/30/04
' - Select one or multiple emails.
' - Copies files to 'Temporary Internet Files\view_attachments'
' (previously copied files are deleted each time it's run).
' - Only image files are displayed (no others are executed).
' - Right-click images to 'Save As', 'Email', 'Print', etc.
' - Hover over image to see original size & scaled size.
' - Clicking each image will toggle between original size
' & browser width (unless original size is smaller).
' - To scale all images to browser width, resize the browser,
' right-click on background & choose 'Refresh'.
'***************************************************************
On Error Resume Next
Dim oOL As Outlook.Application
Dim oSelection As Outlook.Selection
Set oOL = New Outlook.Application
Set oSelection = oOL.ActiveExplorer.Selection
Set objShell = CreateObject("WScript.Shell")
Set fs = CreateObject("Scripting.FileSystemObject")
vTempInt = objShell.RegRead("HKCU\software\microsoft\" _
& "Windows\CurrentVersion\Explorer\Shell Folders\Cache")
vPath = vTempInt & "\view_attachments\"
If fs.FolderExists(vPath) Then
fs.DeleteFile (vPath & "*.*")
Else
fs.CreateFolder vPath
End If
vBkgrColor = "000000"
vFontColor = "FFFFFF"
vHTMLBody = "<HTML><title>View Email Attachments</title>" _
& "<body bgcolor=#" & vBkgrColor & " link=#" & vFontColor _
& " alink=#" & vFontColor & " vlink=#" & vFontColor _
& "><font face=Arial size=3 color=#" & vFontColor & ">"
vEmailNum = 0
For Each obj In oSelection
vEmailNum = vEmailNum + 10
vSubject = "Attachments from: <a href=""Outlook:" _
& obj.EntryID & """><b>" & obj.Subject & "</b></a><br>"
vHTMLBody = vHTMLBody & vSubject
vAttachNum = vEmailNum
For Each Attachment In obj.Attachments
vAttachNum = vAttachNum + 1
vImg = "document.img" & vAttachNum
vWidth = "document.body.clientWidth - 20"
Attachment.SaveAsFile (vPath & Attachment.FileName)
vHTMLBody = vHTMLBody _
& "<b>" & Attachment.FileName & "</b><br>" _
& "<a href=""javascript:fWidth(" & vImg & ");"">" _
& "<center><IMG name=""img" & vAttachNum & """ alt="""" hspace=0 " _
& "src=""" & vPath & Attachment.FileName & """ align=baseline " _
& "border=0 " & "onload=""vOrig=String(" & vImg & ".width)" _
& "+ ' x ' + String(" & vImg & ".height);vRatio=(" & vWidth _
& ")/" & vImg & ".width;" & vImg & ".alt='Original Size: ' + " _
& "vOrig + '\n Scaled Size: ';if(" & vImg & ".width <=" _
& vWidth & "){" & vImg & ".alt=" & vImg & ".alt + vOrig;}" _
& "else{" & vImg & ".alt=" & vImg & ".alt + String(" & vWidth _
& ")+ ' x ' + String(Math.round(vRatio *" & vImg & ".height));}" _
& "if (" & vImg & ".width >" & vWidth & "){" & vImg & ".width = " _
& vWidth & ";}""></center></a><br><br><br>"
Next
vHTMLBody = vHTMLBody & "</a><br><br>"
Next
If Not vImg = "" Then
vHTMLBody = vHTMLBody & "<script>function fWidth (vImg){" _
& "vCRLF=vImg.alt.indexOf('\n');vOrgWidth=vImg.alt.substring" _
& "(vImg.alt.indexOf(':')+2, vImg.alt.indexOf('x')-1);" _
& "if(vImg.width == " & vWidth & "|| vOrgWidth <= " & vWidth _
& "){vImg.width=vOrgWidth;vImg.alt=vImg.alt.substring(0,vCRLF)" _
& "+ '\n Scaled Size: '+ vImg.alt.substring(vImg.alt." _
& "indexOf(':')+2,vCRLF);}else{vImg.width=" & vWidth & ";" _
& "vImg.alt=vImg.alt.substring(0,vCRLF) + '\n Scaled Size: '" _
& "+ String(" & vWidth & ")+ ' x ' + String(vImg.height);}}</script>"
End If
vHTMLBody = vHTMLBody & "</font></body></html>"
Set ie = CreateObject("internetexplorer.application")
With ie
.toolbar = 0
.menubar = 0
.statusbar = 0
.Left = 100
.Top = 50
.Height = 600
.Width = 800
.navigate "about:blank"
.document.Open
.document.Write vHTMLBody
.document.Close
.Visible = True
End With
vTimer = 0
Do Until ie.readyState = 4 Or vTimer = 10000
Sleep 10
vTimer = vTimer + 10
Loop
Set ie = Nothing
Set fs = Nothing
Set objShell = Nothing
Set oSelection = Nothing
Set oOL = Nothing
End Sub
Can anyone help with this? You would really really help me out.
Thanks.
I have switched over some of the people in our office over to Outlook 2003 instead of Outlook Express. One feature they are missing and really need is the ability to voew and print emails with image attachments showing. That way they can have a copy of the email text with the thumb of the image attached under it. Outlook express does this by default but Outlook 2003 does not.
I have found a couple macros online that are close to what I need but they need to be combined I guess, and I do not know how to do that.
Here's one that opens a copy of the email in Internet Explorer, which would work if it would shot the attachments too....
Sub OpenInBrowser()
Dim BrowserLocation As String
Dim AlwaysConvert As Boolean
Dim EvaluateHTML As Boolean
'=============Set your variables in the section below==========================
'The default settings are optimized for viewing newsletters and receiving
'messages with HTML forms or animated gif-files embedded in the message.
'Set the location of the executable of the browser you want to use.
'Standard value: "C:\Program Files\Internet Explorer\iexplore.exe"
BrowserLocation = "C:\Program Files\Internet Explorer\iexplore.exe"
'When set to True, we will let Outlook convert the message to HTML.
'The message will be opened in the configured browser just as it
'appears in Outlook.
'Standard value: False
AlwaysConvert = False
'When set to True, we will look for embedded resources in the HTML message and
'determine whether Outlook should convert the message or whether we can strip
'the HTML directly. When set to False, we will always strip the HTML and ignore
'embedded resources.
'For this setting to take effect, AlwaysConvert must be set to False.
'Standard value: True
EvaluateHTML = True
'=======Don't modify the code below unless you know what you are doing=========
'Get the user's TempFolder to store the item in
Dim FSO As Object, TmpFolder As Object
Set FSO = CreateObject("scripting.filesystemobject")
Set FileName = FSO.GetSpecialFolder(2)
'Get all selected items
Dim MyOlNamespace As Outlook.NameSpace
Set MyOlNamespace = Application.GetNamespace("MAPI")
Set MyOlSelection = Application.ActiveExplorer.Selection
'Make sure at least one item is selected
If MyOlSelection.Count = 0 Then
Response = MsgBox("Please select an item first", vbExclamation, MyApplName)
Exit Sub
End If
'Make sure only one item is selected
If MyOlSelection.Count > 1 Then
Response = MsgBox("Please select only one item", vbExclamation, MyApplName)
Exit Sub
End If
'Retrieve the selected item
Set MyselectedItem = MyOlSelection.Item(1)
'construct the filename
strname = "www_howto-outlook_com"
FileName = FileName & "\" & strname & ".htm"
'If the message is in HTML format we directly capture the HTML from the message
'to construct our htm-file. This will allow us to capture as many HTML elements
'as possible. If it is a different format, or if the HTML mail includes embedded
'resources we let Outlook convert it to HTML.
Dim OutlookConvert As Boolean
OutlookConvert = True
If MyselectedItem.BodyFormat = olFormatHTML And AlwaysConvert = False Then
Dim rawHTML As String
rawHTML = MyselectedItem.HTMLBody
If EvaluateHTML = False Then
OutlookConvert = False
Else
'Check if there are embedded resources in the message.
'If it does, we let Outlook convert the message.
If InStr(UCase(rawHTML), UCase("src=""cid:")) = 0 Then
OutlookConvert = False
End If
End If
End If
'Write the temp-file
If OutlookConvert = False Then
'create the htm-file in the temp folder and write the HTML code to it
Set objFile = FSO.CreateTextFile(FileName, True)
objFile.Write "" & rawHTML
objFile.Close
Set objFile = Nothing
Else
'let Outlook convert the message and save the selected item
'as htm to the temp folder
MyselectedItem.SaveAs FileName, olHTML
End If
'open the saved item in the browser
Shell BrowserLocation & " " & FileName, vbNormalFocus
'Cleanup
Set FSO = Nothing
Set FileName = Nothing
Set MyOlNamespace = Nothing
Set MyOlSelection = Nothing
Set MyselectedItem = Nothing
End Sub
Now here is another macro that opens the attachment files and displays them in a new window. Combine this with the above macro and it would be perfect.
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub view_attachments()
'***************************************************************
' ver. 1/30/04
' - Select one or multiple emails.
' - Copies files to 'Temporary Internet Files\view_attachments'
' (previously copied files are deleted each time it's run).
' - Only image files are displayed (no others are executed).
' - Right-click images to 'Save As', 'Email', 'Print', etc.
' - Hover over image to see original size & scaled size.
' - Clicking each image will toggle between original size
' & browser width (unless original size is smaller).
' - To scale all images to browser width, resize the browser,
' right-click on background & choose 'Refresh'.
'***************************************************************
On Error Resume Next
Dim oOL As Outlook.Application
Dim oSelection As Outlook.Selection
Set oOL = New Outlook.Application
Set oSelection = oOL.ActiveExplorer.Selection
Set objShell = CreateObject("WScript.Shell")
Set fs = CreateObject("Scripting.FileSystemObject")
vTempInt = objShell.RegRead("HKCU\software\microsoft\" _
& "Windows\CurrentVersion\Explorer\Shell Folders\Cache")
vPath = vTempInt & "\view_attachments\"
If fs.FolderExists(vPath) Then
fs.DeleteFile (vPath & "*.*")
Else
fs.CreateFolder vPath
End If
vBkgrColor = "000000"
vFontColor = "FFFFFF"
vHTMLBody = "<HTML><title>View Email Attachments</title>" _
& "<body bgcolor=#" & vBkgrColor & " link=#" & vFontColor _
& " alink=#" & vFontColor & " vlink=#" & vFontColor _
& "><font face=Arial size=3 color=#" & vFontColor & ">"
vEmailNum = 0
For Each obj In oSelection
vEmailNum = vEmailNum + 10
vSubject = "Attachments from: <a href=""Outlook:" _
& obj.EntryID & """><b>" & obj.Subject & "</b></a><br>"
vHTMLBody = vHTMLBody & vSubject
vAttachNum = vEmailNum
For Each Attachment In obj.Attachments
vAttachNum = vAttachNum + 1
vImg = "document.img" & vAttachNum
vWidth = "document.body.clientWidth - 20"
Attachment.SaveAsFile (vPath & Attachment.FileName)
vHTMLBody = vHTMLBody _
& "<b>" & Attachment.FileName & "</b><br>" _
& "<a href=""javascript:fWidth(" & vImg & ");"">" _
& "<center><IMG name=""img" & vAttachNum & """ alt="""" hspace=0 " _
& "src=""" & vPath & Attachment.FileName & """ align=baseline " _
& "border=0 " & "onload=""vOrig=String(" & vImg & ".width)" _
& "+ ' x ' + String(" & vImg & ".height);vRatio=(" & vWidth _
& ")/" & vImg & ".width;" & vImg & ".alt='Original Size: ' + " _
& "vOrig + '\n Scaled Size: ';if(" & vImg & ".width <=" _
& vWidth & "){" & vImg & ".alt=" & vImg & ".alt + vOrig;}" _
& "else{" & vImg & ".alt=" & vImg & ".alt + String(" & vWidth _
& ")+ ' x ' + String(Math.round(vRatio *" & vImg & ".height));}" _
& "if (" & vImg & ".width >" & vWidth & "){" & vImg & ".width = " _
& vWidth & ";}""></center></a><br><br><br>"
Next
vHTMLBody = vHTMLBody & "</a><br><br>"
Next
If Not vImg = "" Then
vHTMLBody = vHTMLBody & "<script>function fWidth (vImg){" _
& "vCRLF=vImg.alt.indexOf('\n');vOrgWidth=vImg.alt.substring" _
& "(vImg.alt.indexOf(':')+2, vImg.alt.indexOf('x')-1);" _
& "if(vImg.width == " & vWidth & "|| vOrgWidth <= " & vWidth _
& "){vImg.width=vOrgWidth;vImg.alt=vImg.alt.substring(0,vCRLF)" _
& "+ '\n Scaled Size: '+ vImg.alt.substring(vImg.alt." _
& "indexOf(':')+2,vCRLF);}else{vImg.width=" & vWidth & ";" _
& "vImg.alt=vImg.alt.substring(0,vCRLF) + '\n Scaled Size: '" _
& "+ String(" & vWidth & ")+ ' x ' + String(vImg.height);}}</script>"
End If
vHTMLBody = vHTMLBody & "</font></body></html>"
Set ie = CreateObject("internetexplorer.application")
With ie
.toolbar = 0
.menubar = 0
.statusbar = 0
.Left = 100
.Top = 50
.Height = 600
.Width = 800
.navigate "about:blank"
.document.Open
.document.Write vHTMLBody
.document.Close
.Visible = True
End With
vTimer = 0
Do Until ie.readyState = 4 Or vTimer = 10000
Sleep 10
vTimer = vTimer + 10
Loop
Set ie = Nothing
Set fs = Nothing
Set objShell = Nothing
Set oSelection = Nothing
Set oOL = Nothing
End Sub
Can anyone help with this? You would really really help me out.
Thanks.