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 DOC_TXTAusVerzOeffneUndAlsDocSpeichern()
'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, sZielpfad As String, s_path As String
Dim appsep As String, sZielname As String
Dim ret As Integer
appsep = Application.PathSeparator->Pfadtrennzeichen
-> Auswahl der Pfade
sSuchpfad = VerzeichnisWählen(Bitte wählen Sie das Quell-Verzeichnis)
If sSuchpfad = Then
ret = MsgBox(Es wurde kein Suchpfad eingegeben ! & vbCrLf & _
Der Makro wird beendet., _
vbOKOnly + vbInformation, Kein Suchpfad ausgewählt)
Exit Sub
End If
sZielpfad = VerzeichnisWählen(Bitte wählen Sie das Ziel-Verzeichnis)
If sZielpfad = Then
ret = MsgBox(Es wurde kein Zielpfad eingegeben ! & vbCrLf & _
Der Makro wird beendet., _
vbOKOnly + vbInformation, Kein Zielpfad ausgewählt)
Exit Sub
End If
->Filenamen aus dem Directory sPath auflisten
Set fs = Application.FileSearch
fs.NewSearch
fs.LookIn = sSuchpfad
fs.FileName = *.txt
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
On Error GoTo Errorhandler
Documents.Open FileName:=fs.FoundFiles(i)
Selection.MoveDown Unit:=wdLine, Count:=5
Selection.MoveRight Unit:=wdSentence, Count:=1, Extend:=wdExtend
sZielname = Selection
ActiveDocument.SaveAs FileName:=sZielpfad & appsep & sZielname & .doc, _
FileFormat:=wdFormatDocument
ActiveDocument.Close Savechanges:=False
DoEvents
End If
Next i
Else
MsgBox Keine Dokumente gefunden
End If
Exit Sub
Errorhandler:
MsgBox (Beim Öffnen der Datei & fs.FoundFiles(i) & _
ist leider etwas schiefgegangen & vbLf & vbLf & _
Nun ist guter Rat teuer :-) :-) :-))
End Sub
