1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54
| Option Explicit
Call BrowseForFile
Private Sub BrowseForFile()
Dim oDlg, sInitDIr
Set oDlg = CreateObject("UserAccounts.CommonDialog")
oDlg.Filter = "Tout fichier(*.*)|*.*|Fichier texte(*.txt)|*.txt|Visual basic form(*.frm)|*.frm" & _
"|Documents Word(*.doc;*.docx)|*.doc;*.docx|Bibliothèque(*.dll)|*.dll"
sInitDir = SelectFolder
oDlg.InitialDir = sInitDir
oDlg.FilterIndex = 4 ' correspond à Documents Word, filtre par défaut
oDlg.ShowOpen
If oDlg.FileName = "" Then Exit Sub
MsgBox oDlg.FileName
End Sub
'======================
Function SelectFolder()
Const BIF_returnonlyfsdirs = &H1 ' On peut mettre &H4000 pour retourner les fichiers et/ou dossiers
'mais une erreur se produit si on sélectionne un fichier
Dim WSH, Item, lngFlag, Result, InitDir, DialogTitle, drv, fso, WS
Set WSH = CreateObject("Shell.Application")
lngFlag = BIF_returnonlyfsdirs
'InitDir = "C:"
DialogTitle = "Sélection de dossier : Pas de Poste de travail, Favoris réseau et/ou ses sous-éléments:"
Set Item = WSH.BrowseForFolder(0, DialogTitle, lngFlag, "")
If Item Is Nothing Then WScript.Quit 0
Set WS = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
If LCase(Item.Title) = "poste de travail" Or LCase(Item.Title) = "favoris réseau" Then
MsgBox "Mauvais choix de répertoire [" & UCase(Item.Title) & "]" & vbCrLf & _
"Choisir un répertoire valide puis réessayer."
WScript.Quit 0
End If
If LCase(Item.Title) = "mes documents" Or LCase(Item.Title) = "bureau" Then
Result = WS.ExpandEnvironmentStrings("%UserProfile%") & "\" & Item.Title
ElseIf Is_Value(Item) Then
Result = Item.Title
If Right(Result, 2) = ":)" Then
Set drv = fso.GetDrive(Left(Right(Result, 3), 2))
Result = drv.RootFolder
ElseIf InStr(1, Result, ":") = 0 Then
Result = Item.ParentFolder.ParseName(Item.Title).Path
End If
End If
SelectFolder = Result
End Function
'================================
Function Is_Value(obj)
Dim stmp
On Error Resume Next
stmp = " " & obj
Is_Value = (Err = 0)
On Error GoTo 0
End Function |
Partager