(Sepp oder auch andere, die mir helfen möchten)
Ich habe von Sepp den unten aufgeführten Code. Der Funzt soweit auch gut.
Ich habe in den Code:
.documents(1).InlineShapes.Reset
eingebaut.
Damit schaffe ich es, dass das erste Bild im Document vor dem speichern in Originalgröße vergrößert wird. Leider bekomme ich das nur mit dem ersten Bild in der Worddatei hin.
Wie muss der Code aussehen, dass alle Bilddateien erstmal "Resettet" werden?
Die Bilder sind unterschiedlich in den Worddateien. Es gibt Worddateien, dort befindet sich ein Bild frei auf einer Seite oder das Bild ist in einer Wordtabelle eingefügt.
Leider schaffe ich es auch nicht, dass der Code nur die Bilder speichert. Ich würde gerne den Code löschen, der für das Kopieren des Textes verantwortlich ist. Lösche ich den Code, dann werden meine Bilddateien plötzlich teilweise mit kleiner Auflösung abgespeichert!?!?!?!?
Lösche ich z.B.:
ThisWorkbook.Sheets("Tabelle1").PasteSpecial _
Format:="Text", Link:=False, DisplayAsIcon:=False
werden Bilder kleiner gespeichert!?!?!
Kann man generell eine Auflösung festlegen?
Für Hilfe wäre ich sehr dankbar!!!
Gruß
Dirk R.
Hier der Originalcode:
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
Public Sub Lese()
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
Dim objFSO As Object, objFSOFile As Object
On Error GoTo ErrExit
GMS
Set objFSO = CreateObject("Scripting.FileSystemObject")
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
.documents(1).InlineShapes.Reset
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 ""
Set objFSOFile = objFSO.GetFile(Environ("Temp") & "\dummy-Dateien\" & strPic)
If objFSOFile.Size / 1024 > 200 Then
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, "."))
End If
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
On Error Resume Next
If Not AppWD Is Nothing Then AppWD.Quit
On Error GoTo 0
Set AppWD = Nothing
Set objFSO = Nothing
Set objFSOFile = 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