Makro zum drucken der ersten Seite von Stck. 200 Word2007 Doc in einem Verz.

Option Explicit
->fuer FSO muss im VB-Editor unter Extras->Verweise Microsoft Scripting Runtime angehakt sein

'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


Sub Verz_Dateien_ersteSeiteDrucken()
 Dim sPfad As String, sDateiendung As String
 Dim f() As String, fCnt As Long, x As Long
 
->Dateiendung definieren'
 sDateiendung = .docx
->Pfad definieren
 sPfad = VerzeichnisWählen(Bitte wählen Sie das Verzeichnis)
 If sPfad =  Then MsgBox Es wurde kein Suchpfad eingegeben !: GoTo AUFRAEUMEN
 
->Filenamen mittels FileSystemObject besorgen
 fCnt = 0
 If Not FSO_Folder_List_Files(sPfad, sDateiendung, f(), fCnt) Then GoTo AUFRAEUMEN
 If fCnt = 0 Then MsgBox Keine entsprechende Datei im Verzeichnis.: GoTo AUFRAEUMEN
 
 For x = 1 To fCnt
  Call Datei_Oeffnen_ersteSeiteDrucken_Schliessen(f(x))
 Next
 
AUFRAEUMEN:
End Sub

'**************************************************************************************************************
Function Datei_Oeffnen_ersteSeiteDrucken_Schliessen(sDateiNameFull As String)
 Dim doc As Document
 
->Datei öffnen
 On Error Resume Next
 Set doc = Documents.Open(FileName:=sDateiNameFull)
 On Error GoTo 0
 If doc Is Nothing Then MsgBox Datei konnte nicht geöffnet werden. & vbCrLf & sDateiNameFull: GoTo AUFRAEUMEN
 
->erste Seite drucken
 doc.PrintOut Range:=wdPrintFromTo, From:=1, To:=1
 
->Datei schliessen
 doc.Close SaveChanges:=False
AUFRAEUMEN:
 Set doc = Nothing
End Function

'**************************************************************************************************************
Function FSO_Folder_List_Files(sPfad As String, sDateiendung As String, f() As String, fCnt As Long) As Boolean
->fuer FSO muss im VB-Editor unter Extras->Verweise Microsoft Scripting Runtime angehakt sein
 Dim oFso As FileSystemObject, oVerzeichnis As Folder, oFile As File
 
 FSO_Folder_List_Files = False
 
->FileSystemObject für den Zugriff auf Verzeichnis-Struktur erzeugen
 Set oFso = New Scripting.FileSystemObject
 
 On Error Resume Next
->Verzeichnis lesen
 Set oVerzeichnis = oFso.GetFolder(sPfad)
 If oVerzeichnis Is Nothing Then MsgBox Pfad nicht vorhanden:  & vbCrLf & sPfad: GoTo AUFRAEUMEN
 On Error GoTo 0
 
->Alle Filenamen speichern
 If oVerzeichnis.Files.Count > 0 Then
  ReDim f(1 To oVerzeichnis.Files.Count)
  fCnt = 0
  For Each oFile In oVerzeichnis.Files
  ->Nur Dateien mit entsprechender Dateiendung bearbeiten
   If (Right(oFile.Name, Len(sDateiendung)) = LCase(sDateiendung)) Then
    fCnt = fCnt + 1
    f(fCnt) = oFso.BuildPath(oVerzeichnis.Path, oFile.Name)
   End If
  Next
  ReDim Preserve f(1 To fCnt)
 End If
 
 FSO_Folder_List_Files = True
AUFRAEUMEN:
 Set oFso = Nothing: Set oVerzeichnis = Nothing: Set oFile = Nothing
End Function