Makro für Word

'Verzeichnis Wählen von [url]http://www.arstechnica.de/computer/msoffice/vba/vba0060.html[/url]
''' Typdeklaration für API-Dialog 'Verzeichnis auswählen'
    Private Type BrowseInfo
        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 Declare Function SHGetPathFromIDList Lib shell32.dll (ByVal pidl As Long, ByVal pszPath As String) As Long
    Private Declare Function SHBrowseForFolder Lib shell32.dll (lpBrowseInfo As BrowseInfo) As Long

' Ermittelt Verzeichnisnamen und zeigt Windows-Dialog an
Public Function VerzeichnisWählen(Optional DialogTitel) As String
    Dim StrukturVerzeichnisInfo As BrowseInfo, ListenNr As Long, Pfad As String
  
    With StrukturVerzeichnisInfo
        .hOwner = hWndAccessApp
        .lpszTitle = IIf(IsMissing(DialogTitel), Verzeichnispfad auswählen, CStr(DialogTitel))
        .ulFlags = &H1 ' BIF_RETURNONLYFSDIRS
    End With
    
    ListenNr = SHBrowseForFolder(StrukturVerzeichnisInfo)
    Pfad = Space$(512)
    
    If SHGetPathFromIDList(ByVal ListenNr, ByVal Pfad) Then VerzeichnisWählen = Left(Pfad, InStr(Pfad, vbNullChar) - 1)
    
End Function









Public Sub DokumenteAusVerzeichnisInDokument()
'Soll alle Dokumente eines auszuwählenden Verzeichnisses in ein Dokument schreiben.
'Das Verzeichnis soll aber nicht mit dem identisch sein, in dem das Dokument gespeichert ist.

'Definition: nach welchen files gesucht werden soll
Const c_Filenamen = *.xls

Dim b_mitPfadangabe   'True= Dokument mit Pfadangabe , false=ohne
Dim fs As FileSearch
Dim i As Long
Dim sPath As String, sname As String, s_tmp As String, sSuchpfad As String, sFilename As String

  ' Auswahl des Pfades
  sSuchpfad = VerzeichnisWählen

  'Wahl: Ausgabe mit Pfadnamen oder ohne
  ret = MsgBox(Wollen Sie die Ausgabe der Filenamen mit komplettem Pfad ?, _
        vbQuestion + vbYesNo)
  If ret = vbYes Then
    b_mitPfadangabe = True
  Else
    b_mitPfadangabe = False
  End If
  
  'Wahl: Filename
  sFilename = InputBox(Geben Sie bitte den Filenamen ein !, Eingabe Filname, *.xls)

  'Filename und Pfad des eigenen Dokuments, um in aus der Fileliste auszublenden
  sPath = ActiveDocument.Path 'Pfad des Dokuments
  sname = ActiveDocument.Name 'Name des Dokuments
    
  'Schreibmarke vorbereiten
  Selection.Collapse Direction:=wdCollapseEnd
  Selection.InsertAfter Text:=vbCrLf
  
  If Not b_mitPfadangabe Then
    Selection.InsertAfter Text:=sSuchpfad & vbCrLf
  End If
 
  'Filenamen aus dem Directory sSuchpfad auflisten
  Set fs = Application.FileSearch
  
  With fs
    .NewSearch
    .LookIn = sSuchpfad
    .FileName = sFilename
    If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) > 0 Then
      For i = 1 To .FoundFiles.Count
        If .FoundFiles(i) <> (sPath & \ & sname) Then 'nicht aktives Dokument
          s_tmp = .FoundFiles(i)
          If b_mitPfadangabe Then
            Selection.InsertAfter Text:=s_tmp & vbCrLf
          Else
            Selection.InsertAfter Text:=vbTab & NurFilenamen(s_tmp) & vbCrLf
          End If
        End If
      Next i
    Else
      MsgBox Keine Dokumente gefunden
    End If
  End With
End Sub
Private Function NurFilenamen(s_vollstaendigerFilename As String) As String
'schneidet die Pfadangaben aus einem String und gibt den Filenamen zurueck
Dim p1 As Integer, p2 As Integer

  p2 = 0: p1 = 0
  Do
    p1 = InStr(p1 + 1, s_vollstaendigerFilename, \)
    If p1 <> 0 Then p2 = p1
  Loop While p1 <> 0
  NurFilenamen = Right(s_vollstaendigerFilename, Len(s_vollstaendigerFilename) - p2)
End Function