Sub OLtest()
'Set reference (Tools | References) to:
'Microsoft Excel xx.0 Object Library, where xx is the version number
Dim ObjInputXLS As Excel.Application
Dim ObjInputWorkBook As Excel.Workbook
Dim ObjInputSheet As Excel.Worksheet
Dim OutputFile As Variant, OutputName As String
Dim myFolder As Folder, blnExcel As Boolean
Dim myMail, blnSuccess As Boolean
Dim ItemCnt As Long, LastItem As Long
Dim SurveyMailSubject, DefaultResultFileName
ItemCnt = 1
LastItem = 1
'In case when runs in the open mail.
On Error Resume Next
Set myMail = ActiveWindow.CurrentItem
On Error GoTo 0
'In case when runs in mail box.
If myMail = Empty Then
'Deal with current folder.
Set myFolder = ActiveExplorer.CurrentFolder
'If current folder is not a mail box, exit.
If myFolder.DefaultItemType <> olMailItem Then
MsgBox "This folder is not an e-mail folder" & vbCrLf & _
"Please try again in MailBox", vbCritical, "Caution!"
Exit Sub
End If
LastItem = myFolder.Items.Count
End If
If ObjInputXLS = Empty Then
On Error Resume Next
blnExcel = False
Set ObjInputXLS = GetObject(, "Excel.Application")
If Err <> 0 Then
blnExcel = True
Set ObjInputXLS = CreateObject("Excel.Application")
End If
End If
Do While ItemCnt <= LastItem
If myFolder <> Empty Then
Set myMail = myFolder.Items(ItemCnt)
End If
'Take care unread survey mails in mail box or currently activated mail.
If myMail.Subject = SurveyMailSubject And (myFolder = Empty Or myMail.UnRead) Then
'Select the ouput file.
If OutputFile = "" Then
OutputFile = ObjInputXLS.GetSaveAsFilename(DefaultResultFileName, "Excel Files (*.xls), *.xls")
'OutputFile = DefaultResultFileName 'Ana put this is as test
If TypeName(OutputFile) = "Boolean" Then
Exit Do
End If
OutputName = Right(OutputFile, Len(OutputFile) - InStrRev(OutputFile, "\"))
If WbOpen(OutputName, ObjInputXLS) Then
Set ObjInputWorkBook = ObjInputXLS.Workbooks(OutputName)
Else
Set ObjInputWorkBook = ObjInputXLS.Workbooks.Open(OutputFile)
End If
Set ObjInputSheet = ObjInputWorkBook.Worksheets(1)
End If
'Parse the mail and input data.
If blnSuccess = False Then
blnSuccess = GetResult(myMail, ObjInputSheet)
Else
GetResult myMail, ObjInputSheet
End If
End If
ItemCnt = ItemCnt + 1
Loop
On Error GoTo ErrorMsg
If OutputFile = "" Then
MsgBox "No unread survey mail exists.", vbCritical
ElseIf OutputFile <> "" And OutputFile <> "False" Then
ObjInputXLS.DisplayAlerts = False
ObjInputXLS.ActiveWorkbook.Close True, OutputFile
ObjInputXLS.DisplayAlerts = True
If blnSuccess Then
MsgBox "The result file was saved successfully.", vbDefaultButton1, "blnSuccess!"
ObjInputXLS.Quit
End If
End If
Initialize:
If blnExcel = True Then
ObjInputXLS.Quit
End If
Set ObjInputSheet = Nothing
Set ObjInputWorkBook = Nothing
Set ObjInputXLS = Nothing
On Error GoTo 0
Exit Sub
ErrorMsg:
MsgBox "Can't save the output file." & vbCrLf & "Please try again after close the file!"
GoTo Initialize
End Sub
Function WbOpen(wbName As String, appXL As Excel.Application) As Boolean
On Error Resume Next
WbOpen = Len(appXL.Workbooks(wbName).Name)
End Function
