Option Explicit
'© 2003 Matthias Köhler, [email][email protected][/email]
' 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
Dim hWndAccessApp As Long
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 DokumenteAusVerzeichnis_1Seite_Drucken()
'Makro zum Ausdrucken der ersten Seite aller *.doc-Files eines Directories
'mit Auswahl des Pfades
'(die Ausgabe des eigenen Dokumentes wird unterdrückt)
Dim fs As FileSearch
Dim i As Long
Dim sSuchpfad As String
Dim ret As Integer
-> Auswahl des Pfades
sSuchpfad = VerzeichnisWählen(Bitte wählen Sie das Verzeichnis)
If sSuchpfad = Then
ret = MsgBox(Es wurde kein Suchpfad eingegeben ! & vbCrLf & Der Makro wird beendet., _
vbOKOnly + vbInformation, Kein Suchpfad ausgewählt)
Else
->Filenamen aus dem Directory sPath auflisten
Set fs = Application.FileSearch
fs.NewSearch
fs.LookIn = sSuchpfad
fs.FileName = *.doc
i = fs.Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending)
If fs.FoundFiles.Count > 0 Then
For i = 1 To fs.FoundFiles.Count
->nicht das eigene Dokument
If fs.FoundFiles(i) <> (ThisDocument.FullName) Then
Application.PrintOut FileName:=fs.FoundFiles(i), _
Range:=wdPrintFromTo, From:=1, To:=1
DoEvents
End If
Next i
Else
MsgBox Keine Dokumente gefunden
End If
End If
End Sub