ich habe ein großes Problem und hoffe auf eure Unterstützung.
Folgendes Problem:
Wir haben in unserer Firma hunderte Worddateien mit Daten und Bilder.
Dank Sepp (Josef Ehrensberger) nutze ich nun folgenden Code, der die Daten aus den Worddateien in eine Excel-Tabelle speichert.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Public Sub loeschen_Zwischenablage()
OpenClipboard FindWindow("xlMain", vbNullString)
EmptyClipboard
CloseClipboard
End Sub
Private Sub CommandButton1_Click()
Dim AppWD As Object
Dim objFiles() As Object
Dim lngR As Long, lngRes As Long, lngIndex As Long
Dim strDirectory As String
On Error GoTo ErrExit
GMS
strDirectory = fncBrowseForFolder("C:\")
If strDirectory "" Then
lngRes = FileSearchINFO(objFiles, strDirectory, "*.doc", True)
If lngRes > 0 Then
lngR = ThisWorkbook.Sheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row + 1
Set AppWD = CreateObject("Word.Application") 'Word als Object starten
With AppWD
.DisplayAlerts = False
.Visible = False
For lngIndex = 0 To lngRes - 1
.documents.Open CStr(objFiles(lngIndex))
.Selection.wholestory
.Selection.Copy
ThisWorkbook.Sheets("Tabelle1").Cells(lngR, 1).Select
ThisWorkbook.Sheets("Tabelle1").PasteSpecial _
Format:="Text", Link:=False, DisplayAsIcon:=False
loeschen_Zwischenablage
.documents.Close
lngR = lngR + 1
Next
.DisplayAlerts = True
.Quit
End With
End If
End If
ErrExit:
With Err
If .Number 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
.Description & vbLf & vbLf & "In Prozedur (CommandButton1_Click) in Modul Modul1", _
vbExclamation, "Fehler in Modul1 / CommandButton1_Click"
End With
GMS True
If Not AppWD Is Nothing Then AppWD.Quit
Set AppWD = Nothing
End Sub
Public Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long
With Application
.ScreenUpdating = Modus
.EnableEvents = Modus
.DisplayAlerts = Modus
.EnableCancelKey = IIf(Modus, 1, 0)
If Not Modus Then lngCalc = .Calculation
If Modus And lngCalc = 0 Then lngCalc = -4105
.Calculation = IIf(Modus, lngCalc, -4135)
.Cursor = IIf(Modus, -4143, 2)
End With
End Sub
Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String
Dim objFlderItem As Object, objShell As Object, objFlder As Object
Set objShell = CreateObject("Shell.Application")
Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)
If objFlder Is Nothing Then GoTo ErrExit
Set objFlderItem = objFlder.Self
fncBrowseForFolder = objFlderItem.Path
ErrExit:
Set objShell = Nothing
Set objFlder = Nothing
Set objFlderItem = Nothing
End Function
Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional _
ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long
'# PARAMETERINFO:
'# Files: Datenfeld zur Ausgabe der Suchergebnisse
'# InitialPath: String der das zu durchsuchende Verzeichnis angibt
'# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*. _
*" findet alle Dateien)
'# Beispiele: "*.txt" - Findet alle Textdateien
'# "*name*" - Findet alle Dateien mit "name" im Dateinamen
'# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
'# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard= _
False)
Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
Dim intC As Integer, varFiles As Variant
Set fobjFSO = CreateObject("Scripting.FileSystemObject")
Set ffsoFolder = fobjFSO.GetFolder(InitialPath)
On Error GoTo ErrExit
If InStr(1, FileName, ";") > 0 Then
varFiles = Split(FileName, ";")
Else
Redim varFiles(0)
varFiles(0) = FileName
End If
For Each ffsoFile In ffsoFolder.Files
If Not ffsoFile Is Nothing Then
For intC = 0 To UBound(varFiles)
If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
If IsArray(Files) Then
Redim Preserve Files(UBound(Files) + 1)
Else
Redim Files(0)
End If
Set Files(UBound(Files)) = ffsoFile
Exit For
End If
Next
End If
Next
If SubFolders Then
For Each ffsoSubFolder In ffsoFolder.SubFolders
FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
Next
End If
If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
ErrExit:
Set fobjFSO = Nothing
Set ffsoFolder = Nothing
End Function
An dieser Stelle nochmals vielen Dank für den Code!!!
Nun muß ich leider auch alle Bilder aus den Worddokumenten speichern.
Ich habe nun aus einem Office Forum folgenden Code, der in einer Worddatei funzt. Leider funzt er nicht in Excel!?!?!
Option Explicit
Const sSuchPfad As String = "C:\Temp\Test\Input\"
Const sZielPfad As String = "C:\Temp\Test\"
Const ZielName As String = "Output"
Dim cDir As String
Sub speichereBilderAusWordDokumenten()
Dim i As Long
Dim a As Long
Dim tempDoc As Document
Dim newDoc As Document
Dim cDateiListe() As String
Dim bfound As Boolean
Application.ScreenUpdating = False
'alle Files in SuchPfad lesen und merken
holeFiles sSuchPfad, "doc", cDateiListe()
For i = 1 To UBound(cDateiListe) - 1
Set newDoc = Documents.Add
Documents.Open cDateiListe(i), ReadOnly:=True
Set tempDoc = ActiveDocument
For a = 1 To tempDoc.InlineShapes.Count
bfound = True
tempDoc.Activate
tempDoc.InlineShapes(a).Select
With Selection
.Copy
End With
newDoc.Activate
Selection.Paste
Next a
If bfound Then
erstelleBilder newDoc, tempDoc.Name
bfound = False
Else
newDoc.Close False
End If
tempDoc.Close False
Next i
Application.ScreenUpdating = True
End Sub
Function holeFiles(sPfad As String, sFilter As String, ByRef cDateiListe)
Dim lInd As Long
cDir = Dir(sPfad & "*." & sFilter)
If cDir = "" Then
MsgBox "Keine Dateien gefunden!", vbInformation
End
End If
Do While cDir ""
lInd = lInd + 1
ReDim Preserve cDateiListe(lInd + 1)
cDateiListe(lInd) = sPfad & cDir
cDir = Dir
Loop
End Function
Function erstelleBilder(newDoc As Document, sDocName As String)
Dim i As Long
Const sFilter As String = ".jpg"
newDoc.SaveAs FileName:=sZielPfad & ZielName & ".htm", FileFormat:=wdFormatHTML, _
LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _
:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False
Documents(ZielName & ".htm").Close False
'erstellte Bilder suchen
cDir = Dir(sZielPfad & ZielName & "-Dateien\*" & sFilter)
Do While cDir ""
i = i + 1
'jpg in ZielPfad kopieren & umbenennen
FileCopy sZielPfad & ZielName & "-Dateien\" & cDir, sZielPfad & sDocName & "_Bild" & i & sFilter
cDir = Dir
Loop
'restliche Files in Output Ordner löschen & diesen selbst löschen
cDir = Dir(sZielPfad & ZielName & "-Dateien\*.*")
Do While cDir ""
Kill sZielPfad & ZielName & "-Dateien\" & cDir
cDir = Dir
Loop
RmDir sZielPfad & ZielName & "-Dateien\"
Kill sZielPfad & ZielName & ".htm"
End Function
Jetzt meine Frage:
Wie kann ich den VB-Code, der in Word funzt in meinen bestehenden Code einbauen?
Dann könnte ich mit einer Excel-Datei alles auf einen Schlag bewerkstelligen.
für Hilfe wäre ich sehr dankbar!!!!
Gruß
Dirk R.