I have 2 questions. The first one is 1) My macro does the job, but it really
seems to repeat itself. Is there a better way of writing it? My second
question is 2) we originally were just looking to identify .msg attachments.
Now however, we want to identify and separately process several other types
of attachments (.htm, .zip). I'm not very knowlegeable in vba. What is the
cleanest way to go from working with one extension to working with several?
I appreciate your help.

Public Sub StripAttachments()
Dim objApp As Outlook.Application
Dim ns As Outlook.NameSpace
Dim Item As Object
Dim objAttachments As Outlook.attachments
Dim i As Long
Dim lngCount As Long
Dim strfile As String
Dim tempfile As String
Dim tempdir As String
Dim del As String ' ttimport delete parameter
Dim app As String ' ttimport application parameter
Dim result
Dim fso
Dim fil
Dim ext As String
Dim strsubject As String
Dim FileName As String
Dim path As String
Dim Response As VbMsgBoxResult

On Error Resume Next

Set fso = CreateObject("Scripting.filesystemobject")
Set ns = GetNamespace("MAPI")
' Instantiate an Outlook Application object.
Set objApp = CreateObject("Outlook.Application")
Set objApp = Application

' Get the collection of selected objects.
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set Item = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set Item = objApp.ActiveInspector.CurrentItem
Case Else
'
End Select

'Call SaveEmailNoAtt
app = "/a=clmdoc"

Set objAttachments = Item.attachments
lngCount = objAttachments.Count
If lngCount 0 Then
For i = lngCount To 1 Step -1
strfile = objAttachments.Item(i).FileName
If Right(strfile, 3) = "msg" Then
If (FileExists("C:\Program Files\RLI\MSGImport.txt")) Then
MsgBox "This email contains attachments that are emails." &
vbCrLf & "Please process these attachments separately.", vbOKOnly +
vbExclamation
Else
Response = MsgBox("This email requires special
handling and must be processed by ClaimHelp." & vbCrLf & "Do you wish to
forward to ClaimHelp now?", vbYesNo + vbExclamation)
If Response = vbYes Then
ForwardEmail
'MsgBox "This email requires special handling,
please forward it to ClaimHelp for processing.", vbOKOnly + vbExclamation
Else
End If
Exit Sub
End If
End If
Next i
End If

' Get the Temp folder.
tempdir = ("c:\temp\outlookimport\")
CheckFolder

strsubject = Item.Subject
FileName = StripIllegalChar(strsubject)
FileName = Replace(FileName, " ", "_")
If FileName = "" Then
FileName = "No Subject"
End If

If fso.GetExtensionName(FileName) = "" Then
FileName = FileName & ".rtf"
End If

ext = fso.GetExtensionName(FileName)
path = fso.BuildPath(tempdir, FileName)

Do While fso.FileExists(path)
tempfile = fso.GetTempName
tempfile = fso.GetBaseName(tempfile) & "." & ext
path = fso.BuildPath(tempdir, tempfile)
Loop

Item.SaveAs path, olRTF


Set fil = fso.GetFile(path)
path = fil.ShortPath
Set fil = Nothing

ExecCmd "ttimport.exe " & app & " " & path
Kill (path)

' Get the Attachments collection of the item.
If lngCount 0 Then
' We need to use a count down loop for
' removing items from a collection. Otherwise,
' the loop counter gets confused and only every
' other item is removed.
For i = lngCount To 1 Step -1
' Get the file name.
strfile = objAttachments.Item(i).FileName
If Right(strfile, 3) "msg" Then
strfile = Replace(strfile, " ", "_")
'Combine with the path to the Temp folder.
strfile = tempdir & strfile
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strfile
ExecCmd "ttimport.exe " & app & " " & strfile
Kill (strfile)
End If
Next i
End If
'Item.Save

If lngCount 0 Then
For i = lngCount To 1 Step -1
strfile = objAttachments.Item(i).FileName
If Right(strfile, 3) = "msg" Then
MsgBox "Email and attachments Saved Individually." & vbCrLf
& "Please verify your documents imported correctly." & vbCrLf & "Remember to
process the attached email separately!", vbOKOnly + vbExclamation
Exit Sub
Else
MsgBox "Email and attachments Saved Individually." & vbCrLf
& "Please verify your documents imported correctly.", vbOKOnly
Exit Sub
End If
Next i
End If
ExitSub:
Set objAttachments = Nothing
Set Item = Nothing
Set objApp = Nothing

'MsgBox "Email and attachments Saved Individually. Please verify your
documents imported correctly."

End Sub