Oude code die volgens mij al ergens op notes.net staat, maar vanmorgen leverde een korte zoektocht naar de code geen resultaat op, vandaar hier nog maar een keer zodat ik het zelf tenminste snel kan terug vinden

De code hieronder wordt gebruikt om vanuit een actie knop een locatie te kiezen om een bestand op te slaan.

Maakt gebruik van een API aanroep naar comdlg32.dll

Option Declare

Type OPENFILENAME
 lStructSize As Long
 hwndOwner As Long
 hInstance As Long
 lpstrFilter As String
 lpstrCustomFilter As Long
 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 Long
End Type

Dim fStructure As OPENFILENAME

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

Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long

Const OFN_ALLOWMULTISELECT = &H200
Const OFN_CREATEPROMPT = &H2000
Const OFN_ENABLEHOOK = &H20
Const OFN_ENABLETEMPLATE = &H40
Const OFN_ENABLETEMPLATEHANDLE = &H80
Const OFN_EXPLORER = &H80000
Const OFN_EXTENSIONDIFFERENT = &H400
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_HIDEREADONLY = &H4
Const OFN_LONGNAMES = &H200000
Const OFN_NOCHANGEDIR = &H8
Const OFN_NODEREFERENCELINKS = &H100000
Const OFN_NOLONGNAMES = &H40000
Const OFN_NONETWORKBUTTON = &H20000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOTESTFILECREATE = &H10000
Const OFN_NOVALIDATE = &H100
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_PATHMUSTEXIST = &H800
Const OFN_READONLY = &H1
Const OFN_SHAREAWARE = &H4000
Const OFN_SHAREFALLTHROUGH = 2
Const OFN_SHARENOWARN = 1
Const OFN_SHAREWARN = 0
Const OFN_SHOWHELP = &H10
Const OFS_MAXPATHNAME = 128

Sub Click(Source As Button)
 
 Dim exportFile As String
 exportFile$ = FileSaveDialog("c:\","myexport.pdf","Adobe PDF File (*.pdf)|*.pdf","*.pdf","Save as")
 If (exportFile$ = "") Then
  Exit Sub
 End If
 
End Sub

Function FileSaveDialog(dialogPath As String, dialogFile As String, Byval dialogFilter As String, dialogDefExt, dialogTitle As String) As String
 On Error Goto ErrorHandler
 
 Dim mNewFile As String
 Dim mInstr As Integer
 Dim mReply As Integer
 Dim mFileTitle As String
 Dim FileTitle As String
 FileSaveDialog = ""
 
 mNewFile = dialogFile & Space$(255 - Len(dialogFile)) & Chr(0)
 mInstr = Instr(dialogFilter, "|")
 Do While mInstr > 0
  dialogFilter = Trim(Left(dialogFilter, mInstr - 1)) & Chr(0) & Trim(Mid(dialogFilter, mInstr + 1))
  mInstr = Instr(dialogFilter, "|")
 Loop
 dialogFilter = dialogFilter & String(2, Chr(0))
 If dialogTitle = "" Then dialogTitle = "Open"
 dialogTitle = dialogTitle & Chr(0)
 dialogDefExt = dialogDefExt & Chr(0)
 dialogPath = dialogPath & Chr(0)
 mFileTitle = Space$(255) & Chr$(0)
 fStructure.lStructSize = Len(fStructure)
 fStructure.hwndOwner = 0&
 fStructure.lpstrFilter = dialogFilter
 fStructure.nFilterIndex = 1
 fStructure.lpstrTitle = dialogTitle
 fStructure.lpstrFile = mNewFile
 fStructure.nMaxFile = Len(mNewFile)
 fStructure.lpstrFileTitle = mFileTitle
 fStructure.nMaxFileTitle = Len(FileTitle)    
 fStructure.lpstrInitialDir = dialogPath
 fStructure.Flags = OFN_ALLOWMULTISELECT Or OFN_EXPLORER Or OFN_HIDEREADONLY Or OFN_NOCHANGEDIR
 fStructure.lpstrDefExt = dialogDefExt
 fStructure.hInstance = 0
 fStructure.lpstrCustomFilter = 0
 fStructure.nMaxCustFilter = 0
 fStructure.nFileOffset = 0
 fStructure.nFileExtension = 0
 fStructure.lCustData = 0
 fStructure.lpfnHook = 0
 fStructure.lpTemplateName = 0
 mReply = GetSaveFileName(fStructure)
 If mReply = 1 Then
  FileSaveDialog = fStructure.lpstrFile
  mInstr = Instr(FileSaveDialog, Chr(0))
  If mInstr > 0 Then
   FileSaveDialog = Left(FileSaveDialog, mInstr - 1)
  End If
 End If
 
 Exit Function
 
ErrorHandler:
 Msgbox "Error " & Err & " (" & Error & ") on line " & Erl
 Exit Function
 Resume Next
 
End Function