Option Explicit
Private Declare Function GetSaveFileNameA Lib "comdlg32.dll" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetActiveWindow Lib "user32" () 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
Public Function SaveAsCommonDialog(Optional sTitle = "Save File", Optional sFilter As String = "", Optional sDefaultDir As String, Optional filename As String = "") As String
Const clBufferLen As Long = 255
Dim OFName As OPENFILENAME, sBuffer As String * clBufferLen
On Error GoTo ExitFunction
OFName.lStructSize = Len(OFName)
OFName.hwndOwner = GetActiveWindow 'or Me.hwnd in VB
OFName.hInstance = 0 'or App.hInstance in VB
If Len(sFilter) Then
OFName.lpstrFilter = sFilter
Else
OFName.lpstrFilter = "Text Files (*.txt)" & Chr$(0) & "*.txt" & Chr$(0) & "All Files (*.*)" & Chr$(0) & "*.*" & Chr$(0)
End If
' set file to initialDir and Filename (Note - need to retain length of sBuffer)
If filename <> "" Then
Dim initialFilePath As String
If Right(sDefaultDir, 1) = "\" Then
initialFilePath = sDefaultDir & filename
Else
initialFilePath = sDefaultDir & "\" & filename
End If
sBuffer = initialFilePath & (Right(sBuffer, Len(sBuffer) - Len(initialFilePath)))
End If
OFName.lpstrFile = sBuffer
OFName.nMaxFile = clBufferLen 'Set max number of characters
OFName.lpstrFileTitle = sBuffer
OFName.nMaxFileTitle = clBufferLen 'Set max number of characters
'Set the initial directory
If Len(sDefaultDir) Then
OFName.lpstrInitialDir = sDefaultDir
Else
OFName.lpstrInitialDir = CurDir$
End If
OFName.lpstrTitle = sTitle
OFName.Flags = 0
'debug.Print "sBuffer: " & sBuffer
'Show dialog
If GetSaveFileNameA(OFName) Then
SaveAsCommonDialog = Left$(OFName.lpstrFile, InStr(1, OFName.lpstrFile, Chr(0)) - 1)
Else
SaveAsCommonDialog = ""
End If
ExitFunction:
On Error GoTo 0
End Function
'Demostration routine
Private Function Test() As Boolean
Dim sFilePath As String
sFilePath = SaveAsCommonDialog("Save Presentation", "*.ppt", "C:\Program Files\", "Test FileName")
If Len(sFilePath) > 0 Then
MsgBox "File to save '" & sFilePath & "'."
Else
MsgBox "No file selected"
End If
End Function