Automation Error using xlDialogSaveAs

[Casey]

Hi,
I'm having trouble moving a worksheet to a new workbook and then saving
it to a specific file. The error I'm getting is:

run-time error '-2147221080 (800401a8)':
Automation error.

I have googled and came up with a couple of ideas I adapted and thought
would work but they each still generate the same error. I'm out of
ideas.

Here is my Code:

Private Sub cmdSubCOCopySave_Click()
Dim c As Range, d As Range
Dim NewSht As Worksheet
Dim obj As OLEObject
Dim myshape As Shape
Dim MyPath As String
Dim Str As Variant, Str2 As Variant
Dim Str3 As Variant, Fname As Variant

Call SendToSubConDB 'Tranfers pertinent data to database

Str = ActiveSheet.Range("SubConName").Value
Str2 = "CO " & ActiveSheet.Range("SubCon_CHANGE_ORDER_NO").Value
Str3 = ActiveSheet.Range("ProjectSubVen").Value
Fname = Str & " " & Str2 & " " & Str3
On Error Resume Next
MkDir ThisWorkbook.Path & "\Subcon-Vendor CO\"
MyPath = ThisWorkbook.Path & "\Subcon-Vendor CO\"

ActiveSheet.Move
Set NewSht = ActiveSheet
On Error GoTo 0
Application.Dialogs(xlDialogSaveAs).Show MyPath & Fname & ".xls"
'ActiveWorkbook.SaveAs Filename:=MyPath & Fname & ".xls" This
didn't work either

Application.ScreenUpdating = False
Application.EnableEvents = False

With NewSht
Unprotect ("geekk")
On Error Resume Next
OLEObjects.Visible = True
OLEObjects.Delete
For Each myshape In NewSht.Shapes
Select Case myshape.Type
Case 1: myshape.Delete
Case 17: myshape.Delete
End Select
Next myshape
On Error GoTo 0
Set d = NewSht.Cells.SpecialCells(xlCellTypeFormulas)
For Each c In d
With c
Value = .Value
End With
Next c
Protect ("geekk")
End With
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

 

[Casey]

I have checked all the other code. It all works as intended, except for
the line
Application.Dialogs(xlDialogSaveAs).Show MyPath & Fname & ".xls"
Really could use some help.

 

[Casey]

I researched the MS Knowledge base and found this page.

http://support.microsoft.com/kb/158997/en-us#appliesto

The article states that the problem occurs only in xl97, however I'
running xl2002. The conditions for creating this error seem to fit m
situation and so I made some changes to my code based on the firs
recommendation and now the routine performs exactly as I expect it to
but at the end of execution up pops the same error message. I need thi
error message to not pop up.

Here is my revised code:

Private Sub cmdSubCOCopySave_Click()
Dim c As Range, d As Range
Dim NewSht As Worksheet
Dim obj As OLEObject
Dim myshape As Shape
Dim MyPath As String
Dim Str As Variant, Str2 As Variant
Dim Str3 As Variant, Fname As Variant

Call SendToSubConDB 'Tranfers pertinent data to database

Str = ActiveSheet.Range("SubConName").Value
Str2 = "CO " & ActiveSheet.Range("SubCon_CHANGE_ORDER_NO").Value
Str3 = ActiveSheet.Range("ProjectSubVen").Value
Fname = Str & " " & Str2 & " " & Str3
On Error Resume Next
MkDir ThisWorkbook.Path & "\Subcon-Vendor CO\"
MyPath = ThisWorkbook.Path & "\Subcon-Vendor CO\"

ActiveSheet.Move
Set NewSht = ActiveWorkbook.ActiveSheet

Application.ScreenUpdating = False
Application.EnableEvents = False

With NewSht
On Error Resume Next
ActiveWorkbook.SaveAs Filename:=MyPath & Fname & ".xls"
.Unprotect ("geekk")
On Error Resume Next
.OLEObjects.Visible = True
.OLEObjects.Delete
For Each myshape In NewSht.Shapes
Select Case myshape.Type
Case 1: myshape.Delete
Case 17: myshape.Delete
End Select
Next myshape
On Error GoTo 0
Set d = NewSht.Cells.SpecialCells(xlCellTypeFormulas)
For Each c In d
With c
.Value = .Value
End With
Next c
.Protect ("geekk")
End With
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.EnableEvents = True
Application.ScreenUpdating = True
End Su