Image Viewer for Outlook

[Dave Ostrander]

Hey Team,

I am trying to get an Image viewer macro for outlook to work, and despite
wracking my brain, I don't see my mistake. It compiles, the code looks right,
but it dosen't activate. Of note, this is my 3rd VBA project and I am
using the examples found at http://msdn2.microsoft.
com/en-us/library/aa168469(office.11).aspx . Thank you Mr. Legault for
posting the code that you did.

Here is the source I am using, any help would be excellent thank you.

Option Explicit
Dim objCurrentMessage As MailItem
Dim objFS As New Scripting.FileSystemObject
Dim objTempFolder As Scripting.Folder
Dim strTempFolderPath As String
Dim strTempFilesUsed() As String
Dim lngTempFileCount As Long
Dim strCustomImageViewerFilePath As String
Dim lngViewerType As ImageViewers

Private Sub UserForm_Activate()
On Error Resume Next

If GetTempFolder = False Then
MsgBox "Unable to cache the picture attachments for viewing.
", _
vbOKOnly + vbExclamation, "Picture Attachments Helper
Error"
Exit Sub
End If


RetrieveViewerSettings

End Sub

Public Sub FillList()
On Error Resume Next

'PRE-POPULATE THE LIST BOX WITH PICTURE ATTACHMENT FILE NAMES
Dim objAtt As Attachment, objAtts As Attachments

Set objCurrentMessage = ActiveInspector.CurrentItem
Set objAtts = objCurrentMessage.Attachments
lstAtts.Clear
For Each objAtt In objAtts
Select Case LCase(Right(objAtt.FileName, 3))
Case "jpg", "peg", "gif", "bmp", "tif", "iff"
'Note: iff and peg will handle .tiff and .jpeg extensions
Me.lstAtts.AddItem objAtt.Index
Me.lstAtts.List(lstAtts.ListCount - 1, 1) = objAtt.FileName
End Select
Next
End Sub


Function GetTempFolder() As Boolean
On Error Resume Next

Dim objTempFolder As Scripting.Folder

'GET THE TEMP FOLDER
Set objTempFolder = objFS.GetSpecialFolder(2)
'returns the path found in the TMP environment variable

If objTempFolder Is Nothing Then Exit Function

'Get or create the AttachmentsTemp folder
If objFS.FolderExists(objTempFolder & "\AttachmentsTemp") = False Then
Set objTempFolder = objFS.CreateFolder(objTempFolder _
& "\AttachmentsTemp")
Else
Set objTempFolder = objFS.GetFolder(objTempFolder _
& "\AttachmentsTemp")
End If

If Err.Number <> 0 Then
'UNABLE TO RETRIEVE TEMP FOLDER
'YOU MAY WANT TO HARD-CODE A FOLDER HERE THAT WILL WORK ON YOUR
SYSTEM
strTempFolderPath = "C:\Temp"

If objFS.FolderExists(strTempFolderPath) = False Then
objFS.CreateFolder strTempFolderPath
End If
Set objTempFolder = objFS.GetFolder(strTempFolderPath)
Else
strTempFolderPath = objTempFolder.Path
End If

GetTempFolder = True
End Function






Private Sub cmdOpen_Click()
On Error Resume Next

Dim intX As Integer, blnCancel As Boolean

If lstAtts.ListIndex = -1 Then Exit Sub

'LOOP THROUGH SELECTED PICTURE ATTACHMENTS
For intX = 0 To lstAtts.ListCount - 1
If lstAtts.Selected(intX) = True Then
OpenImage intX, blnCancel
If blnCancel = True Then Exit Sub
End If
Next
End Sub

Private Sub cmdOpenAll_Click()
On Error Resume Next

Dim intX As Integer, blnCancel As Boolean

If Me.lstAtts.ListCount <= 0 Then Exit Sub

'LOOP THROUGH ALL PICTURE ATTACHMENTS
For intX = 0 To lstAtts.ListCount - 1
OpenImage intX, blnCancel
If blnCancel = True Then Exit Sub
Next
End Sub

Private Sub lstAtts_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
cmdOpen_Click
End Sub

Private Sub optCustom_Click()
lngViewerType = Custom
Me.fraCustomViewer.Enabled = True
End Sub

Private Sub optIE_Click()
lngViewerType = IE
Me.fraCustomViewer.Enabled = False
End Sub

Private Sub optRegisteredViewer_Click()
lngViewerType = Default
Me.fraCustomViewer.Enabled = False
End Sub

Private Sub cmdClose_Click()
Unload Me
End Sub

Sub DeleteTempFiles()
On Error GoTo EH:

Dim objFile As Scripting.File
Dim intX As Integer

For intX = 0 To UBound(strTempFilesUsed)
Set objFile = objFS.GetFile(strTempFilesUsed(intX))
objFile.Delete True
Next

EH:
If Err.Number <> 0 Then
If Err.Number = 9 Then
'strTempFilesUsed ARRAY IS EMPTY; NO FILES WERE OPENED
Exit Sub
End If
If Err.Number = 53 Then
'FILE NOT FOUND; MAY HAVE BEEN DELETED ALREADY IF THE SAME FILE
WAS
'OPENED MORE THAN ONCE, AS THE FILE NAME WOULD HAVE BEEN
'DUPLICATED IN THE ARRAY YOU ARE PARSING
Resume Next
End If
MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & vbCrLf & _
"[error in DeleteTempFiles]", vbOKOnly + vbExclamation _
, "Picture Attachments Helper Error"
Exit Sub
End If
End Sub
Sub SaveViewerSettings()
SaveSetting "Picture Attachments Helper", "Settings", _
"ViewerType", lngViewerType
SaveSetting "Picture Attachments Helper", "Settings", _
"CustomImageViewerFilePath", txtApplicationPath.Text
End Sub

Private Sub UserForm_Terminate()
DeleteTempFiles
SaveViewerSettings
Set objCurrentMessage = Nothing
Set objFS = Nothing
Set objTempFolder = Nothing
End Sub

Sub RetrieveViewerSettings()
On Error Resume Next

'Retrieve previous settings from the registry

lngViewerType = CLng(GetSetting("Picture Attachments Helper", _
"Settings", "ViewerType", "1"))
strCustomImageViewerFilePath = GetSetting( _
"Picture Attachments Helper", "Settings", "CustomImageViewerFilePath")

Select Case lngViewerType
Case ImageViewers.Custom
Me.fraCustomViewer.Enabled = True
Me.optCustom.Value = True
Me.txtApplicationPath.Text = strCustomImageViewerFilePath
Case ImageViewers.Default
Me.optRegisteredViewer.Value = True
Case ImageViewers.IE
Me.optIE.Value = True
End Select
End Sub

Sub OpenImage(intListIndex As Integer, ByRef blnCancel As Boolean)
On Error GoTo EH:

Dim strImageFile As String, varRet As Variant
Dim strExecutePath As String

strImageFile = strTempFolderPath & "\" & _
objCurrentMessage.Attachments.Item(lstAtts.List( _
intListIndex, 0)).DisplayName
objCurrentMessage.Attachments.Item(lstAtts.List( _
intListIndex, 0)).SaveAsFile strImageFile
ReDim Preserve strTempFilesUsed(lngTempFileCount)
strTempFilesUsed(lngTempFileCount) = strImageFile
lngTempFileCount = lngTempFileCount + 1

'LAUNCH IMAGES IN DEFINED IMAGE VIEWER
Select Case lngViewerType
Case ImageViewers.Default
ShellExecute 0, "open", strImageFile, _
vbNullString, strTempFolderPath, conSwNormal
Exit Sub
Case ImageViewers.Custom
strExecutePath = strCustomImageViewerFilePath & " " &
strImageFile
Case ImageViewers.IE
strExecutePath = strIEPath & " " & strImageFile
End Select

varRet = Shell(strExecutePath, vbNormalFocus)


EH:
If Err.Number <> 0 Then
MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & vbCrLf _
& "[error in OpenImage; file = '" & strImageFile & "']" _
, vbOKOnly + vbExclamation, "Picture Attachments Helper Error"
blnCancel = True
Exit Sub
End If
End Sub