Private Sub Command1_Click()
On Error Resume Next
Dim sTempDir As String
Dim sMyNewDirectory As String

sTempDir = CurDir 'Remember the current active directory
CommonDialog1.DialogTitle = "Select a directory" 'titlebar
CommonDialog1.InitDir =  App.Path 'start dir, might be "C:\" or so also
CommonDialog1.filename = "Select a  Directory" 'Something in filenamebox
CommonDialog1.Flags = cdlOFNNoValidate + cdlOFNHideReadOnly
CommonDialog1.Filter = "Directories|*.~#~" 'set files-filter to show dirs only
CommonDialog1.CancelError =True 'allow escape key/cancel 
CommonDialog1.ShowSave

'show the dialog screen 

If Err <>  32755 Then    ' User didn't chose Cancel.
    sMyNewDirectory = CurDir
    MsgBox ("Directory selected: " & sMyNewDirectory)
End If

ChDir sTempDir  'restore path to what it was at entering

End Sub