| 12
 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