CREA UN MODULO DI CLASSE:
Option Explicit
Private Type BROWSEINFO 'Browser Folder
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
LParam As Long
iImage As Long
End Type
Private Type OPENFILENAME
lStructSize As Long
hWnd 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 Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long 'Browser Folder
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long 'Browser Folder
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) _
As Long 'Common DiaLog
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias _
"GetSaveFileNameA" (pOpenfilename As OPENFILENAME) _
As Long 'Common DiaLog
Private Const BIF_RETURNONLYFSDIRS = &H1 'Browser Folder
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_SAVE = 0
Private Const OFN_OPEN = 1
Private clsFolderName As String 'Browser Folder
Private lngHWnd As Long
Private wMode As Boolean
Private szDialogTitle As String
Private szFileName As String
Private szFilter As String
Private szDefDir As String
Private szDefExt As String
Private szFileTitle As String
Private szFileDir As String
Private intFilterIndex As Integer
Public Function Save_File() As String
wMode = False
Save_File = Action()
End Function
Public Function Open_File() As String
wMode = True
Open_File = Action()
End Function
'Pass a bar separated string and returns a Null separated string
Private Function NullSepString(ByVal BarString As String) As String
Dim intInstr As Integer
Const vbBar = "|"
Do
intInstr = InStr(BarString, vbBar)
If intInstr > 0 Then Mid$(BarString, intInstr, 1) = vbNullChar
Loop While intInstr > 0
NullSepString = BarString
End Function
Private Sub getFile_Dir()
Dim intInstr As Integer
intInstr = InStr(szFileName, szFileTitle) - 1
szFileDir = Left(szFileName, intInstr)
End Sub
Property Let hWnd(SourceHwnd As Long)
lngHWnd = SourceHwnd
End Property
Property Let Title(DialogTitle As String)
szDialogTitle = DialogTitle
End Property
Property Let FileName(DefaultFile As String)
szFileName = DefaultFile
End Property
Property Get FileName() As String
FileName = szFileName
End Property
Property Let Filter(FilterList As String)
szFilter = NullSepString(FilterList)
End Property
Property Let StartDir(InitialDir As String)
szDefDir = InitialDir
End Property
Property Let DefaultExtension(DefExt As String)
szDefExt = DefExt
End Property
Property Get FileTitle()
FileTitle = szFileTitle
End Property
Property Get FileDir() As String
FileDir = szFileDir
End Property
Private Sub SetDefs()
If lngHWnd = 0 Then lngHWnd = hWndAccessApp
If szDialogTitle = "" Then szDialogTitle = CurrentDb.Name
If szFilter = "" Then szFilter = NullSepString("All Files|*.*")
If szDefDir = "" Then szDefDir = "C:\"
If intFilterIndex = 0 Then intFilterIndex = 1
End Sub
Private Function Action() As String
Dim x As Long, OFN As OPENFILENAME
Call SetDefs
With OFN
.lStructSize = Len(OFN)
.hWnd = lngHWnd
.lpstrTitle = szDialogTitle
.lpstrFile = szFileName & String$(250 - Len(szFileName), 0)
.nMaxFile = 255
.lpstrFileTitle = String$(255, 0)
.nMaxFileTitle = 255
.lpstrFilter = szFilter
.nFilterIndex = intFilterIndex
.lpstrInitialDir = szDefDir
.lpstrDefExt = szDefExt
If wMode = True Then
OFN.flags = OFN_HIDEREADONLY Or OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST
x = GetOpenFileName(OFN)
Else
OFN.flags = OFN_HIDEREADONLY Or OFN_OVERWRITEPROMPT Or OFN_PATHMUSTEXIST
x = GetSaveFileName(OFN)
End If
If x <> 0 Then
If InStr(.lpstrFile, Chr$(0)) > 0 Then
szFileName = Left$(.lpstrFile, InStr(.lpstrFile, Chr$(0)) - 1)
szFileTitle = Left$(.lpstrFileTitle, InStr(.lpstrFileTitle, Chr$(0)) - 1)
Call getFile_Dir
End If
Else
szFileName = ""
End If
End With
Action = szFileName
End Function
Public Function OpenBrowseFolder()
Dim x As Long, bi As BROWSEINFO, dwIList As Long
Dim szPath As String, wPos As Integer
If szDialogTitle = vbNullString Then szDialogTitle = "Seleziona la Directory..."
With bi
.hOwner = hWndAccessApp
.lpszTitle = szDialogTitle
.ulFlags = BIF_RETURNONLYFSDIRS
End With
dwIList = SHBrowseForFolder(bi)
szPath = Space$(512)
x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
If x Then
wPos = InStr(szPath, Chr(0))
clsFolderName = Left$(szPath, wPos - 1)
Else
clsFolderName = ""
End If
End Function
Property Get Folder_Name()
Folder_Name = clsFolderName
End Property
'CREA LA MASCHERA CON IL PULSANTE cmd_Folder ED UNA CASELLA DI TESTO txt_Folder
Option Explicit
Dim Cmdlg As New clsBrowserDialog
Private Sub cmd_Folder_Click()
On Error GoTo GestoreErrori
With Cmdlg
.Save_File
Me.txt_Folder = .FileName ' scrivo il percorso in txt_Folder
End With
Exit Sub
GestoreErrori:
If Err.number = 32755 Then Exit Sub
End Sub
'Aggiorno il percorso con chiamata o con pulsante evento click
Private Sub Aggiorna()
DB.Execute ("UPDATE T_Directory SET Percorso = " & "'" & txt_Folder & "'"
End Sub
DOVREBBE FUNZIONARE