Save As Windows API

[caerdydd]

Hello
Can someone help with the code below which i have lifted from the web to bring up the Save As form when the Save As button has been clicked on. At work that button has been changed to default to something else and i want to get it back to the Windows Save As form. This code works but won't save the actual files. Anyone have an idea why?
Thanks very much.


Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias _
"GetSaveFileNameA" (pSavefilename As OPENFILENAME) As Long

Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Private Sub GlobalProject_BookLoad(ByVal LoadedBook As Book)
Dim cmdBar As CommandBar
Dim myCmd As Object

On Error GoTo errhandler

Set cmdBar = Application.CommandBars("Menu Bar")
Set myCmd = CommandBars("menu bar").Controls("File")

myCmd.Controls("Save As...").Delete

With CommandBars("menu bar").Controls("File")
.Controls.Add(Type:=ControlButton, Before:=5).Caption = "Save As..."
.Controls("Save As...").OnAction = Me.FullName & "!ThisProj.SaveMyFile"
End With

errhandler:
End Sub

Public Sub OpenMyFile()

' Dim OpenFile As OPENFILENAME
' Dim lReturn As Long
' Dim sFilter As String
' Dim uPath As String
'
' uPath = GetSysSetting("USERPATH")
' If uPath <> "" Then
' uPath = uPath & "THEPATH"
' CheckDir uPath
' Else
' Exit Sub
' End If
'
' OpenFile.lStructSize = Len(OpenFile)
' OpenFile.hwndOwner = hWnd
'' OpenFile.hInstance = app.hInstance
' sFilter = "XML File (*.xml)" & Chr(0) & sLike & "*.xml" & Chr(0)
' OpenFile.lpstrFilter = sFilter
' OpenFile.nFilterIndex = 1
' OpenFile.lpstrFile = String(257, 0)
' OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
' OpenFile.lpstrFileTitle = OpenFile.lpstrFile
' OpenFile.nMaxFileTitle = OpenFile.nMaxFile
' OpenFile.lpstrInitialDir = uPath
' OpenFile.lpstrTitle = "Open Exchange List"
' OpenFile.flags = 0
' lReturn = GetOpenFileName(OpenFile)
' If lReturn = 0 Then
' Exit Sub
' Else
'
' Dim sFileName As String
' sFileName = VBA.Replace(OpenFile.lpstrFileTitle, VBA.Chr(0), "")
' 'check if file/file format is supported
' If Not VBA.StrComp(VBA.left(sFileName, VBA.Len(sLike)), sLike, vbTextCompare) = 0 Or _
' Not VBA.StrComp(VBA.Right(sFileName, 3), "xml", vbTextCompare) = 0 Then MsgBox "File or format not supported": Exit Sub
'
' Dim res
' res = fileExist(Trim(OpenFile.lpstrFile))
' res = res(0)
' If res Then
'' If oTw Is Sheet1.TwAlert Then Sheet1.ClearAllAlerts
' LoadTvw Trim(OpenFile.lpstrFile), oTw
'' Sheet1.LblExchFile.Caption = sFileName 'added on 22 Mar 06
' Else
' MsgBox "Unable to open " & VBA.Replace(Trim(OpenFile.lpstrFile), VBA.Chr(0), "") & ".xml." & VBA.Chr(10) & "File does not exist!", vbCritical
' Exit Sub
' End If
' End If
End Sub


Sub SaveMyFile()
Dim SaveFile As OPENFILENAME
Dim lReturn As Long
Dim sFilter As String
Dim uPath As String

' uPath = GetSysSetting("USERDATA")
' If uPath <> "" Then
' uPath = uPath & "THEPATH"
' CheckDir uPath
' Else
' Exit Sub
' End If

SaveFile.lStructSize = Len(SaveFile)
SaveFile.hwndOwner = hWnd
sFilter = "Xml File (*.xml)" & Chr(0) & sLike & "*.xml" & Chr(0)
SaveFile.lpstrFilter = sFilter
SaveFile.nFilterIndex = 1
SaveFile.lpstrFile = sLike & String(257 - VBA.Len(sLike), 0)
SaveFile.nMaxFile = Len(SaveFile.lpstrFile) - 1
SaveFile.lpstrFileTitle = SaveFile.lpstrFile
SaveFile.nMaxFileTitle = SaveFile.nMaxFile
SaveFile.lpstrInitialDir = uPath
SaveFile.lpstrTitle = "Save Exchange List"
SaveFile.flags = 0
lReturn = GetSaveFileName(SaveFile)
If lReturn = 0 Then
Exit Sub
Else
Dim res
If VBA.InStr(1, SaveFile.lpstrFile, SaveFile.lpstrInitialDir & sLike) = 0 Then
SaveFile.lpstrFile = SaveFile.lpstrInitialDir & sLike & SaveFile.lpstrFileTitle
End If
Dim sName As String
Dim sNameLen As Integer
Dim sPathName As String
sNameLen = VBA.InStr(1, SaveFile.lpstrFileTitle, VBA.Chr(0)) - 1
sName = VBA.Left(SaveFile.lpstrFileTitle, sNameLen)
If VBA.InStr(sName, sLike) = 0 Then
sName = sLike & sName
End If
sPathName = VBA.Trim(VBA.Replace(SaveFile.lpstrFile, VBA.Chr(0), ""))
sPathName = VBA.Left(sPathName, VBA.Len(sPathName) - sNameLen)
sPathName = sPathName & sName

SaveFile.lpstrFile = sPathName

res = fileExist(Trim(SaveFile.lpstrFile))
If res(0) Then
If PromptMsg(VBA.Dir(Trim(SaveFile.lpstrFile), vbNormal) & " already exists. Do you want to replace it?", "Save As") = True Then

Else
Exit Sub
End If
Else

Do While VBA.Dir(res(1)) = " "
DoEvents
Loop
End If

End If
End Sub

Private Function fileExist(ByVal sFile As String) As Variant
sFile = VBA.Replace(sFile, VBA.Chr(0), "")
If VBA.Right(sFile, 4) = ".xml" Then
sFile = sFile
Else
sFile = sFile & ".xml"
End If

If Not VBA.Dir(sFile, vbNormal) = "" Then
fileExist = Array(True, sFile)
Else
fileExist = Array(False, sFile)
End If
End Function

Private Function PromptMsg(ByVal Msg As String, ByVal Title As String) As Boolean
Dim Style
Dim Response As Variant
Dim sRes As String
Style = vbYesNo + vbExclamation + vbDefaultButton2
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then
sRes = 1
Else
sRes = 0
End If
PromptMsg = sRes
End Function

 

[CautionMP]

caerdydd,
Because the API only prompts the user for a save filename and returns the filename back to your code. You will need to add the code to actually save your workbook using the filename returned from the API.

...
            If PromptMsg(VBA.Dir(Trim(SaveFile.lpstrFile), vbNormal) & " already exists. Do you want to replace it?", "Save As") = True Then
            [red]Add your code to save the file here[/red]
            Else
                Exit Sub
            End If
        Else
            [red][b]and[/b] here[/red]
            Do While VBA.Dir(res(1)) = " "
                DoEvents
            Loop
        End If
...

One thought, if your using a 'newer' version of Excel you might take a look at [tt]Application.FileDialog[/tt]. It might be a little easier to work with since it doesn't require any API calls.

Hope this helps,
CMP

[small]For the best results do what I'm thinking, not what I'm saying.[/small]
(GMT-07:00) Mountain Time (US & Canada)

 

[strongm]

Furthermore, there may be a good reason why "at work that button has been changed to default to something else"

 

[fumei]

Indeed. You do not state what application this is for - please try to mention that when you post - but it is quite common for corporate systems to redirect SaveAs to a specific network drive. Our corporate normal.dot (Word) does this.

Gerry
My paintings and sculpture