AW: Zeichenfolge im Dateinamen ersetzen
12.05.2009 13:27:43
Dirk
Hallo Dierk,
hatte ich auch schon versucht, aber leider funzt es nicht.
Der unten aufgeführte Code (von Sepp aus dem Forum) habe ich ein wenig angepasst.
Es werden Worddokumente geöffnet und die vorhandenen Bilder gespeichert und genau das ist der Knackpunkt, wo ich nicht weiter komme.
Der Dateiname, der Bilder, die gespeichert werden ist analog des Dateinnamen der Worddatei.
Beispiele, wo mein Code funzt:
FT-1.1.1.b.doc
FT-1.1.2b.doc
FT-1.1.3.doc
Wobei das b dann auch durch -ZF ersetzt wird.
Das Resultat sieht dann so aus:
FT-1.1.1-ZF.jpg
FT-1.1.2-ZF.jpg
FT-1.1.3.jpg
Beispiel, wo mein Code nicht funzt:
FT-1.1.4b (irgendwas).doc
Das Resultat sieht dann so aus:
FT-1.1.4-ZF (irgendwas).jpg
Aber es sollte so aussehen:
FT-1.1.4-ZF.jpg
Wenn ich deinen Code ab As einsetze und den anderen lösche, werden keine Dateien erstellt!?!?!
Ich bitte daher weiterhin um Hilfe!!!
Gruß
Dirk R.
Public Sub Lese()
Dim AppWD As Object
Dim objFiles() As Object, objPix As Object, S As Object
Dim 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
Dim lngPic As Long
On Error GoTo ErrExit
GMS
Set objFSO = CreateObject("Scripting.FileSystemObject")
strTmpFile = Environ("TEMP") & "\dummy.htm"
strDirectory = fncBrowseForFolder("") 'C:\
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
strPicPath = ThisWorkbook.Path & "\Bilder " & objFiles(lngIndex).ParentFolder.Name & " _
MakeSureDirectoryPathExists strPicPath
.Documents.Open CStr(objFiles(lngIndex))
'loeschen_Zwischenablage
'### START Bilder Auslesen
On Error Resume Next
'### Test Bilder umwandeln
For Each S In .Documents(1).Shapes
If S.Type = msoLine Then S.Delete
If S.Type = msoPicture Then
S.ConvertToInlineShape
End If
Next S
If .Documents(1).InlineShapes.Count > 0 Then
For lngPic = 1 To .Documents(1).InlineShapes.Count
'Bilder zurüchsetzen auf Originalabmessungen
With .Documents(1).InlineShapes(lngPic)
.LockAspectRatio = msoFalse
.Reset
.ScaleHeight 1, True
.ScaleWidth 1, True
End With
Next
'Worddatei als HTM speichern
.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.... As Left(strPic, InStr(strPic, "(") - 1) & Right(strPic, 4)
Name Environ("Temp") & "\dummy-Dateien\" & strPic As Replace(Replace(Replace( _
Replace(strPicPath & _
Left(objFiles(lngIndex).Name, InStrRev(objFiles(lngIndex).Name, ".") - 1) & _
IIf(lngCnt > 0, "(" & lngCnt & ")", "") & Mid(strPic, InStrRev(strPic, ".")) _
_
, ". b", ".b"), ".b", "b"), "b", "-ZF"), "..", ".")
Sleep 500
Kill strPic
strPic = Dir
lngCnt = lngCnt + 1
Loop
End If
.Documents(1).Close saveChanges:=False
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
MsgBox "Die Bilddateien sind erstellt worden", vbInformation, "Speichern beendet"
End Sub