Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1068to1072
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Bilder aus Word speichern
27.04.2009 09:12:42
Dirk
Hallo Excelgemeinde,
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.

13
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Bilder aus Word speichern
27.04.2009 20:57:06
Josef
Hallo Dirk,
wohin sollen die Bilder kopiert werden?
Gruß Sepp

AW: Bilder aus Word speichern
28.04.2009 07:46:28
Dirk
Hallo Sepp,
ertsmal danke, dass du dich gemeldet hast.
Perfekt wäre es, wenn die Bilder in Ordner gespeichert werden könnten. Die Ordner sollten den Namen "Bilder"+ Ordnername haben, wie der Ordner aus dem die Worddateien stammen.
z.B.: Worddatei mit Bilder im Ordner "KO-01" dann sollte der Ordnername mit den Bildern "Bilder KO-01" sein.
Der Pfad der Ordner sollte der gleiche sein, in der sich die Excel-Datei befindet.
Noch eine Frage:
leider erstellt der code, der in Word funzt von jedem Bild 2 Bilddateien mit unterschiedlicher Auflösung und Seitenverhältnis.
Wie muss der Code geändert werden, damit nur eine Bilddatei erstellt wird, die dem Original am nächsten ist?
Ich habe deinen Code seiner Zeit erweitert mit:
'("Gliederungsnummer")---------------------------------------------------------------
Set rngWo = ActiveWorkbook.ActiveSheet.Range("A1:A50").Find("G*l*i*e*d*e*r*u*n*g*s*n*u*m*m*e*r*", LookIn:=xlValues, LookAt:=xlPart)
If Not rngWo Is Nothing Then
I = IIf(Cells(rngWo.Row + 3, 1) = "", 2 + rngWo.Row, 3 + rngWo.Row)
Zelle = JVA & "-" & Sheets(1).Cells(I, 1).Value
Zelle = Replace(Zelle, " ", "")
If Right(Zelle, 1) = "." Then Zelle = Left(Zelle, Len(Zelle) - 1)
Sheets(2).Cells(1 + lngR2, 1).Value = Replace(Zelle, ",", ".")
End If
Durch diesen Code ermittele ich eine Gliederungsnummer, die ins Tabellenblatt2 geschrieben wird.
z.B.: KO-1.1.2
Spitze wäre natürlich, wenn die Bilddateien auch diesen Namen bekommen würden.
Ich hoffe, dass ich nicht zu viel erwarte, aber dies wäre spitze!!!!!
Gruß
Dirk R.
Anzeige
AW: Bilder aus Word speichern
28.04.2009 21:41:21
Josef
Hallo Dirk,
lässt sich alles lösen, aber dazu brauche ich noch einige Informationen.
  • Befindet sich in jedem Word-Dokument nur ein Bild, oder mehrere?

  • Wie kann man bei den Bilder erkennen, welches näher am Original ist? (Vielleicht an der Größe)

  • Wo im Code ermittelst du die Gliederungsnummer? (Poste deinen aktuellen Code)

  • Gruß Sepp

    AW: Bilder aus Word speichern
    28.04.2009 22:15:59
    Dirk
    Hallo Sepp,
    zu Punkt1:
    Einige Word-Dateien haben nur 1 Bild, einige haben 2 Bilder.
    Bei den Datein, die 2 Bilder haben wäre es toll, wenn Bild 1 dann unter "Worddateiname" & ".jpg" und Bild 2 unter "Worddateiname" & "b.jpg" gespeichert werden könnte
    Bei den Dateien, die nur ein Bild haben soll dieses unter "Worddateiname" & ".jpg" gespeichert werden.
    zu Punkt2:
    Ich habe festgestellt, das ein Bild zweimal gespeichert wird. Das erste Foto ist viel größer in der Auflösung. Ich gehe davon aus, dass dieses das Originalbild ist. Das zweite Bild wird so gespeichert, wie es auf dem Bildschirm in der Worddatei dargestellt wird. Das Bild ist allerdings verkleinert worden und in die Breite gezogen worden. Daher benötige ich dieses 2. Bild nicht.
    zu Punkt3:
    Ich habe mir überlegt, der Dateiname des Bildes sollte der Dateiname der Worddatei sein. s. zu Punkt 1
    zu Punkt3:
    Der Code ist leider nicht aktuell, da ich nun zu Hause bin und die aktuellste Änderung nur auf der Dienststelle habe. Aber das ist nicht weiter schlimm, da ich denke, dass dies keinen Einfluss hat.
    Im aktuellen Code habe ich noch Einfluss auf die Ermittlung der gefilterten Gliederungsnummer genommen.
    Wenn du möchtest kann ich dir den Code aber gerne Morgen posten.
    Hier der Code:
    Option Explicit
    Dim ClipAbLage As DataObject 'benötigt Verweis zur Microsoft Forms 2.0 Object Library
    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 ComboBox1_Change()
    On Error Resume Next
    Dim I As Long, J As Integer
    I = ComboBox1.ListIndex
    Tabelle1_Schutzweg
    For J = 1 To 9
    Cells(3 + J * 2, 4) = Sheets("Datenbank").Cells(1 + I, J).Value
    Next J
    Tabelle1_Schutz
    End Sub
    


    Sub CommandButton1_Click()
    Application.ScreenUpdating = False
    Tabelle1_Schutzweg
    Call Entsperren
    Tabelle1_Schutz
    Dim msg
    msg = MsgBox("Möchten Sie evtl. vorhandene Daten überschreiben?", vbYesNo, "Achtung!")
    Tabelle2_Schutzweg
    If msg = vbYes Then Datenbereich_löschen
    Dim rng As Range, z As Range, rngWo As Range, rngWo2 As Range
    Dim A As Integer, I As Integer, t As Integer, Q As Integer
    Dim AppWD As Object
    Dim objFiles() As Object
    Dim lngR As Long, lngR2 As Long, lngRes As Long, lngIndex As Long
    Dim strDirectory As String, strText As String, strVar1 As String, s As String, strWasSuchen As String, Zelle As String
    Dim intTable As Integer, lngC As Long
    On Error Resume Next ' GoTo ErrExit
    GMS
    strDirectory = fncBrowseForFolder("")
    If strDirectory "" Then
    lngRes = FileSearchINFO(objFiles, strDirectory, "*.doc", True)
    If lngRes > 0 Then
    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))
    If .documents(1).tables.Count > 0 Then
    For intTable = 1 To .documents(1).tables.Count
    lngR = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    With .documents(1).tables(intTable).Range
    For lngC = 1 To .Cells.Count
    strText = .Cells(lngC)
    strText = Replace(Replace(strText, Chr(7), ""), Chr(13), Chr(10))
    If Right$(strText, 1) = Chr(10) _
    Or Right$(strText, 1) = Chr(9) _
    Then strText = Left$(strText, Len(strText) - 1)
    If InStr(1, strText, Chr(10)) 0 Then strText = _
    Left(strText, InStr(1, strText, Chr(10)) - 1) & " " & Mid(strText, InStr(1, strText, Chr(10)) + 1)
    For I = Len(strText) To 1 Step -1
    If Asc(Mid(strText, I, 1)) = 32 Then
    strText = Left(strText, I - 1)
    Else
    Exit For
    End If
    Next I
    For I = 1 To Len(strText)
    If Asc(Mid(strText, I, 1)) = 32 Then
    strText = Mid(strText, I + 1)
    I = I - 1
    Else
    Exit For
    End If
    Next I
    Sheets(1).Cells(.Cells(lngC).RowIndex + lngR, .Cells(lngC).ColumnIndex) = strText
    Next
    End With
    Next
    End If
    .documents.Close False
    lngR2 = Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
    '("Gliederungsnummer")---------------------------------------------------------------
    Set rngWo = ActiveWorkbook.ActiveSheet.Range("A1:A50").Find("G*l*i*e*d*e*r*u*n*g*s*n*u*m*m*e*r*", LookIn:=xlValues, LookAt:=xlPart)
    If Not rngWo Is Nothing Then
    I = IIf(Cells(rngWo.Row + 3, 1) = "", 2 + rngWo.Row, 3 + rngWo.Row)
    Zelle = Sheets(1).Cells(I, 1).Value
    If Right(Zelle, 1) = "." Then Zelle = Left(Zelle, Len(Zelle) - 1)
    Sheets(2).Cells(1 + lngR2, 1).Value = Replace(Zelle, ",", ".")
    End If
    '------------------------------------------------------------------------------------
    For Q = 2 To 6
    If Q = 2 Then strWasSuchen = "K*o*n*t*r*o*l*l*g*e*g*e*n*s*t*a*n*d"
    If Q = 3 Then strWasSuchen = "Z*e*i*t*p*u*n*k*t"
    If Q = 4 Then strWasSuchen = "K*o*n*t*r*o*l*l*v*o*r*g*a*n*g"
    If Q = 5 Then strWasSuchen = "S*o*l*l*z*u*s*t*a*n*d"
    If Q = 6 Then strWasSuchen = "K*o*n*t*r*o*l*l*p*e*r*s*o*n"
    Set rngWo = ActiveWorkbook.ActiveSheet.Range("A1:A50").Find(strWasSuchen, LookIn:=xlValues, LookAt:=xlPart)
    If Not rngWo Is Nothing Then Sheets(2).Cells(1 + lngR2, Q) = Sheets(1).Cells(rngWo.Row, 2).Value
    Next Q
    '("Grundzeit")-----------------------------------------------------------------------
    Set rngWo = ActiveWorkbook.ActiveSheet.Range("A9:A50").Find("G*r*u*n*d*z*e*i*t", LookIn:=xlValues, LookAt:=xlPart)
    If Not rngWo Is Nothing Then
    strVar1 = Range(rngWo.Address)
    End If
    InStrZahlen strVar1
    If IsNumeric(strVar1) Then
    Sheets(2).Cells(1 + lngR2, 7) = Replace(strVar1, ".", ",")
    End If
    strVar1 = ""
    '------------------------------------------------------------------------------------
    '("Punkte")--------------------------------------------------------------------------
    Set rngWo = ActiveWorkbook.ActiveSheet.Range("A1:A50").Find("K*o*n*t*r*o*l*l*v*o*r*g*a*n*g", LookIn:=xlValues, LookAt:=xlPart)
    Set rngWo = ActiveWorkbook.ActiveSheet.Range(Cells(rngWo.Row + 2, 2), Cells(50, 2)).Find("P*u*n*k*t*e*:", LookIn:=xlValues, LookAt:=xlPart)
    If Not rngWo Is Nothing Then
    Set z = Range(rngWo.Address)
    End If
    Sheets(2).Cells(1 + lngR2, 8) = NurZiffern(z)
    '------------------------------------------------------------------------------------
    '("Mitglieder der Refa-Arbeitsgruppe der")-------------------------------------------
    Set rngWo = ActiveWorkbook.ActiveSheet.Range("A1:A50").Find("Mitglieder", LookIn:=xlValues, LookAt:=xlPart)
    If Not rngWo Is Nothing Then Sheets(2).Cells(1 + lngR2, 9).Value = Right(Sheets(1).Cells(rngWo.Row, 1).Value, InStr(1, StrReverse(Sheets(1).Cells(rngWo.Row, 1).Value), "J"))
    '------------------------------------------------------------------------------------
    Sheets(1).Range("A1:B50").ClearContents
    lngR2 = lngR2 + 1
    Next
    '("Datenbank") Zeilenumbruch in Zellen löschen-------------------------------------------------------------
    Call ZU
    '------------------------------------------------------------------------------------
    .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
    Call CombBLFR
    Tabelle1_Schutzweg
    Call Sperren
    Set rngWo = Nothing
    Set rngWo2 = Nothing
    Set AppWD = Nothing
    'Set Zelle = Nothing
    '("Datenbank") sortieren-------------------------------------------------------------
    Sheets(2).Select
    Call DBSort
    '------------------------------------------------------------------------------------
    'Sheets(1).Activate
    Tabelle1_Schutz
    Tabelle2_Schutz
    Application.ScreenUpdating = True
    End Sub


    Sub InStrZahlen(ByRef strString As String)
    Dim Regex As Object, objMatch As Object
    Dim KommaOderPunkt As String
    'KommaOderPunkt = IIf("0.5" * 2 = 1, ".", ",")
    Set Regex = CreateObject("Vbscript.Regexp")
    With Regex
    .IgnoreCase = True
    .Global = True
    .Pattern = "\d{1,}.\d{1,}"
    Set objMatch = .Execute(strString)
    If objMatch.Count > 0 Then
    strString = objMatch(0)
    'strString = Replace(strString, ",", KommaOderPunkt)
    Else
    strString = ""
    End If
    End With
    Set Regex = 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
    


    Danke für deine Mühe schon mal im Vorraus!
    Gruß
    Dirk R.

    Anzeige
    AW: Bilder aus Word speichern
    28.04.2009 22:46:03
    Josef
    Hallo Dirk,
    probier diesen Code.
    Das mit den doppelten Bildern, habe ich mal ausgelassen, weil es durch den Umstand, das sich
    mehrere Bilder in einer Worddatei befinden können, praktisch unmöglich ist Original und Dumpnail zu unterscheiden, die kleinere Datei könnte ja auch das Original des zweiten Bildes sein.
    ' **********************************************************************
    ' Modul: Modul1 Typ: Allgemeines Modul
    ' **********************************************************************

    Option Explicit


    Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal Pfad As String) As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    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, objPix As Object
      Dim lngR As Long, lngRes As Long, lngIndex As Long, lngCnt As Long
      Dim strDirectory As String, strTmpFile As String, strPic As String, strPicPath As String
      
      
      On Error GoTo ErrExit
      GMS
      strTmpFile = Environ("TEMP") & "\dummy.htm"
      strDirectory = fncBrowseForFolder("E:\")
      If strDirectory <> "" Then
        lngRes = FileSearchINFO(objFiles, strDirectory, "*.doc*", True)
        
        If lngRes > 0 Then
          
          Set AppWD = CreateObject("Word.Application") 'Word als Object starten
          With AppWD
            .DisplayAlerts = False
            .Visible = False
            For lngIndex = 0 To lngRes - 1
              lngR = ThisWorkbook.Sheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row + 1
              strPicPath = ThisWorkbook.Path & "\Bilder " & objFiles(lngIndex).ParentFolder.Name & "\"
              MakeSureDirectoryPathExists strPicPath
              .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
              '### START Bilder Auslesen
              On Error Resume Next
              If .documents(1).InlineShapes.Count > 0 Then
                .documents(1).SaveAs FileName:=strTmpFile, FileFormat:=10, _
                  LockComments:=False, Password:="", AddToRecentFiles:=False, _
                  WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
                  SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:=False
                
                strPic = Dir(Environ("Temp") & "\dummy-Dateien\*.*")
                lngCnt = 0
                Do While strPic <> ""
                  Name Environ("Temp") & "\dummy-Dateien\" & strPic As strPicPath & _
                    Left(objFiles(lngIndex).Name, InStrRev(objFiles(lngIndex).Name, ".") - 1) & _
                    IIf(lngCnt > 0, Chr(97 + lngCnt), "") & Mid(strPic, InStrRev(strPic, "."))
                  Sleep 500
                  Kill strPic
                  strPic = Dir
                  lngCnt = lngCnt + 1
                Loop
              End If
              .documents(1).Close
              Kill strTmpFile
              Err.Clear
              On Error GoTo ErrExit
              '### ENDE Bilder Auslesen
            Next
            .DisplayAlerts = True
            .Quit
          End With
        End If
      End If
      
      ErrExit:
      With Err
        If .Number = 5792 Then .Clear
        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

    Gruß Sepp

    Anzeige
    AW: Bilder aus Word speichern
    29.04.2009 09:36:22
    Dirk
    Hallo Sepp,
    Erst einmal vielen Dank für deine Mühe. Der Code funzt fast perfekt.
    Ich habe 3 Worddateien, mit jeweils einem Bild, in einen Testordner kopiert.
    Danach habe ich mit deinem Code die Bilder erstellt.
    Die erstellten Bilder sehen wie folgt aus:
    Name /Größe / Abmessungen
    FT-1.1.2.jpg /11 KB /363 x 294
    FT-1.1.2b.jpg /76 KB /604 x 854
    FT-1.1.2c.jpg /102 KB /854 x 604
    Teilweise wurden die Bilder in den Worddateien auch im Seitenverhältnis geändert.
    Diese gespeicherten Bilder entsprechen der Ansicht in der Worddatei, d.h. sie entsprechen nicht dem Original.
    Ich habe parallel mit dem Code, der in Word verwendet wird, die selben Worddateien eingelesen. Dabei kam folgendes raus:
    Name /Größe /Abmessungen
    FT-1.1.2.DOC_Bild1.jpg /544 KB /960 x 1280
    FT-1.1.2.DOC_Bild2.jpg /11 KB /363 x 294
    FT-1.1.2b.doc_Bild1.jpg /700 KB /1241 x 1754
    FT-1.1.2b.doc_Bild2.jpg /76 KB /604 x 854
    FT-1.1.2c.doc_Bild1.jpg /718 KB /1754 x 1241
    FT-1.1.2c.doc_Bild2.jpg /102 KB /854 x 604
    Die gespeicherten Bilder mit deinem Code entsprechen genau dem jeweiligen Bild2, das der Code der Worddatei anlegt.
    Perfekt wäre es, wenn dein Code das Bild so speichern würde, wie es der Code in der Worddatei mit Bild1 macht.
    Leider löst dein Code den ErrExit aus mit folgender Fehlermeldung:
    Fehler im Modul……
    Fehler – 2147023170
    Automatisierungsfehler
    Der Remoteprozeduraufruf ist fehlgeschlagen.
    Laufzeitfehler ‚462’:
    Der Remote-Server-Computer existiert nicht oder ist nicht verfügbar.
    Klick auf Debuggen:
    ‚
    ‚
    GMS True
    If Not AppWD is Nothing Then AppWD.Quit
    ‚
    ‚
    AppWD.Quit wird markiert
    Wenn du das alles noch hinbekommen würdest, das wäre spitze!
    Danke für deine Mühe schon mal im Vorraus!
    Gruß
    Dirk
    Anzeige
    AW: Bilder aus Word speichern
    29.04.2009 10:23:06
    Dirk
    Nachtrag:
    Ist es möglich die Bilddateien auch als GIF Bilddateien zu speichern?
    Gruß
    Dirk R.
    AW: Bilder aus Word speichern
    29.04.2009 15:22:36
    Dirk
    Hallo Sepp,
    ich habe drei Dateien zur besseren Darstellung hochgeladen:
    https://www.herber.de/bbs/user/61499.doc

    Die Datei https://www.herber.de/bbs/user/61500.xls wurde aus Datenschutzgründen gelöscht


    https://www.herber.de/bbs/user/61501.doc
    1. Datei: Test Bilder auslesen.doc
    2. Datei: Test Bilder auslesen.xls
    3. Datei: Test Doc1.doc
    Ich habe in der Datei Test Dok1.doc ein Bild extra verkleinert und das Seitenverhältnis verzerrt.
    beim Testen durch Datei 1 werden 2 Bilder gespeichert, eins wie das ursprüngliche Original und eins in der Auflösung, wie es in der Ansicht im Worddokument ist.
    Beim Testen durch Datei 2 wird das Bild nur einmal gespeichert, in der Auflösung, wie es in der Ansicht im Worddokument vorhanden ist.
    Ich hoffe du hast noch den Nerv mir zu helfen?!?!
    Gruß
    Dirk R.
    Anzeige
    AW: Bilder aus Word speichern
    29.04.2009 15:27:19
    Dirk
    Noch offen
    AW: Bilder aus Word speichern
    29.04.2009 17:00:48
    Dieter
    Hi,
    kopier die Bilder übers Clipboard nach Powerpoint, von da aus kannst du sie als datei speichern.
    mfg Dieter
    AW: Bilder aus Word speichern
    29.04.2009 18:56:02
    Dirk
    Hallo Dieter,
    die Exceldatei soll später von meheren Bediensteten an verschiedenen Rechnern genutzt werden.
    Powerpoint ist nicht auf jedem Rechner installiert, Excel schon.
    Aber danke für deinen Tip.
    Gruß
    Dirk R.
    AW: Bilder aus Word speichern
    30.04.2009 23:21:32
    Josef
    Hallo Dirk,
    https://www.herber.de/bbs/user/61548.xls
    hatte erst heute Zeit.
    Ich habe jetzt ein Limit der minimalen Dateigröße der Bilder gesetzt (> 200KB, ggf. anpassen),
    damt sollten nur die Originale ausgelesen werden.
    "kann man die Bilder auch als .gif speichern?"
    Der Dateityp hängt vom Original ab, jpg bleibt jpg, gif bleibt gif.
    Gruß Sepp

    Anzeige
    AW: Bilder aus Word speichern
    01.05.2009 13:47:19
    Dirk
    Hallo Sepp,
    vielen, vielen Dank für deine viele Mühe!!!!!!!!
    Ich habe deinen Code noch ergänzt mit:
    .documents(1).InlineShapes(1).Reset
    Damit schaffe ich es, die Originalgröße des Bildes im Worddokument wieder herzustellen. Dann speichert dein Code das Bild auch in Originalgröße im richtigen Seitenverhältnis.
    Die ersten Test liefen perfekt. Ich werde später oder morgen noch ausgiebig testen. :0)
    Dein Code läuft perfekt!!!!!!!!
    Falls ich noch mal Fragen haben sollte, kann ich mich dann nochmal an dich wenden?
    LG
    Dirk

    296 Forumthreads zu ähnlichen Themen

    Anzeige
    Anzeige
    Anzeige

    Links zu Excel-Dialogen

    Beliebteste Forumthreads (12 Monate)

    Anzeige

    Beliebteste Forumthreads (12 Monate)

    Anzeige
    Anzeige
    Anzeige