Cannot create Excel file from MS OUTLOOK macro using CreateObject

[Ucaihc]

I am trying to create an Excel file from a macro in MS OUTLOOK using basically the following code:

Dim objXL As Object
Dim objWB As Object
Dim sXLSFile As String

'Create excel object
Set objXL = CreateObject("Excel.Application")

'Open existing workbook
sXLSFile = "c:\ee\shrink.xls"
Set objWB = objXL.Workbooks.Open(sXLSFile)

But I get an error saying file is not found. Do I have to create a blank file of that name manually before I run the code? Also when i try to save the file using objXL.GetSaveAsFilename, the file gets locked and I cannot run the macro again.
Finally, my macro only runs if I leave out the words "As Object" in the Dim statements above. Please help

 

[PHV]

Doe's "c:\ee\shrink.xls" already exists when you try to Open it (as suggested by the comment) ?
It should, otherwise you may consider the objXL.Workbooks.Add method.

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[Ucaihc]

That did not work when I tried it before. Could you show me exactly how it would go?

 

[PHV]

Set objXL = CreateObject("Excel.Application")
objXL.Visible = True
'Create a new workbook
sXLSFile = "c:\ee\shrink.xls"
Set objWB = objXL.Workbooks.Add
objWB.SaveAs sXLSFile

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[firefytr]

You can test for existence of items (files) with the (Scripting) File System Object or the Dir() function, you should also test if the workbook is open too...

Sub testTT()

    Dim FSO
    Dim objXL As Object, objWB As Object
    Dim sXLSFile As String, sXLSName As String
    Dim blnExcelCreated As Boolean

    'Create excel object
    On Error Resume Next
    Set objXL = GetObject(, "Excel.Application")
    blnExcelCreated = False
    If Err <> 0 Then
        Set objXL = CreateObject("Excel.Application")
        blnExcelCreated = True
        Err.Clear
    End If

    'Set variables
    sXLSFile = "c:\ee\shrink.xls"
    sXLSName = Right(sXLSFile, Len(sXLSFile) - InStrRev(sXLSFile, "\"))

    'Create instance of File Scripting Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.fileexists(sXLSFile) Then
        'Open existing workbook
        If WbOpen(sXLSName) = True Then
            Set objWB = objXL.Workbooks(sXLSName)
        Else
            Set objWB = objXL.Workbooks.Open(sXLSFile)
        End If
    Else
        MsgBox "The workbook is not located in the indicated location!", vbCritical
    End If
    
    If blnExcelCreated = True Then
        objXL.Quit
    End If
    
End Sub

Do you want to save the file automatically? Do you want the user to choose where? More details will get you more results.

HTH

Regards,
Zack Barresse

Simplicity is the ultimate sophistication. What is a MS MVP? PODA
- Leonardo da Vinci

 

[Ucaihc]

Thank you. This was very helpful.

Just one more thing. What is it that locks the Excel file so that if you run the macro a second time, you get a message that the file can't be saved since it is locked for editing.

 

[PHV]

Without seing the whole it's hard to say.
Usually an implicit instantiation of Excel due to use not fully qualified Excel objects.
Have a look at the processus in the Task Manager (Shift+Ctrl+Esc)

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[firefytr]

Is the file shared at all? Do you want to close the file when the procedure comes to an end?

Regards,
Zack Barresse

Simplicity is the ultimate sophistication. What is a MS MVP? PODA
- Leonardo da Vinci

 

[Ucaihc]

As a guarantee, should I just put a .Quit after each object created?

 

[firefytr]

Only if you want to quit it. I generally use the boolean to test if I created it or not. If I did, then I quit, or else I will not quit the application. This has the benefit of leaving it in the same situation as before the code started running.

Regards,
Zack Barresse

Simplicity is the ultimate sophistication. What is a MS MVP? PODA
- Leonardo da Vinci

 

[firefytr]

Oh, and the same goes for the file, if that's an issue.

Regards,
Zack Barresse

Simplicity is the ultimate sophistication. What is a MS MVP? PODA
- Leonardo da Vinci

 

[Ucaihc]

HERE IS MY CODE. IS THERE ANYTHING THAT WILL MAKE IT HANG?


Dim ObjInputXLS
Dim ObjInputWorkBook
Dim ObjInputSheet
Dim OutputFile As String

Dim myFolder
Dim myMail
Dim ItemCnt As Integer, LastItem As Integer
Dim Success As Boolean

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

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
'Open Excel program
If ObjInputXLS = Empty Then
Set ObjInputXLS = CreateObject("Excel.Application")
End If

'Select the ouput file.
If OutputFile = "" Then
OutputFile = ObjInputXLS.GetSaveAsFilename(DefaultResultFileName, "Excel Files (*.xls), *.xls")
'OutputFile = DefaultResultFileName 'Ana put this is as test
If OutputFile = "False" Then
Exit Do
End If
Set ObjInputWorkBook = ObjInputXLS.Workbooks.Open(OutputFile)
Set ObjInputSheet = ObjInputWorkBook.Worksheets(1)
End If

'Parse the mail and input data.
If Success = False Then
Success = 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 Success Then
MsgBox "The result file was saved successfully.", vbDefaultButton1, "Success!"
ObjInputXLS.Quit
End If
End If


Initialize:
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

 

[firefytr]

As I mentioned before, you might want to throw a couple of tests in there ...

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

And I apologize, I don't think I threw in the WbOpen function before.

HTH

Regards,
Zack Barresse

Simplicity is the ultimate sophistication. What is a MS MVP? PODA
- Leonardo da Vinci