Hallo Ralf,
>die alle durch Verknüpfungen zu
> ersetzen. Kann man das evtl. automatisiert machen?
ich habe vor Jahren mal das unten angefügte Makro geschrieben, das
genau das macht.
Wenn Du es damit versuchst:
- Teste es nur mit einer Kopie(!) - wenn etwas beim Extrahieren nicht
funktionieren
sollte, dann ist das Dokument ziemlich sicher kaputt...
- Gib den Bildern im Dokument vorher aussagekräftige Namen, die
extrahierten
Bilddateien werden danach benannt, sonst hast Du Bild1, Bild2 etc.
- Das Makro vom geöffnetem Dokument aus starten.
Die Bilder liegen dann im Unterordner "Bilder"
Bei 200 Bildern dürfte das eine ganze Weile benötigen.
Gruß
Oliver
--
OPTION EXPLICIT
Sub Start()
Call ExtractWriterGraphics(ThisComponent, "Bilder")
MsgBox "Fertig"
End Sub
Function ExtractWriterGraphics(oDocument, ByVal sFolderName as String)
On Local Error Goto ErrorHandler
Dim oGraphics as Object
Dim oZipArchive as Object
Dim oPictures as Object
Dim mZipFile(0) as Variant
Dim mFiles() as String
Dim mFileProps(1) as New com.sun.star.beans.PropertyValue
Dim oFileAccess as Object
Dim oFile as Object
Dim oInputStream as Object
Dim oOutputStream as Object
Dim mData() as Variant
Dim sDestFolder as String
Dim sGraphicName as String
Dim sGraphicURL as String
Dim sTmp as String
Dim oUrl as New com.sun.star.util.URL
Dim oTransformer as Object
Dim n as Long
Dim i as Integer
Dim j as Integer
Dim k as Integer
' create destination folder relative to document ...
oTransformer = createUnoService("com.sun.star.util.URLTransformer")
oUrl.Complete = oDocument.URL
oTransformer.parsestrict(oUrl)
If sFolderName = "" Then
sFolderName = "Pictures"
EndIf
sDestfolder = "file://" & oURL.Path & sFolderName & "/"
' create backup...
oDocument.storeToURL(oURL.Complete + ".bak", mFileProps())
' open zip file and get content of "Pictures" folder ...
oZipArchive = createUnoService("com.sun.star.packages.Package")
mZipFile(0) = oDocument.URL
oZipArchive.initialize(mZipFile())
If Not oZipArchive.hasByHierarchicalName("Pictures") Then
ExtractWriterGraphics = -2
Exit Function
EndIf
oPictures = oZipArchive.getByHierarchicalName("Pictures")
oGraphics = oDocument.getGraphicObjects
' for all pictures in document ...
For i = 0 to oGraphics.getCount()-1
mFiles() = oPictures.getElementNames
sGraphicURL = oGraphics.getByIndex(i).GraphicURL
sTmp = sGraphicURL
' internal picture names start with "vnd.sun..."
If InStr(1, sGraphicURL, "vnd.sun.star.GraphicObject:", 0) = 1 Then
' get the picture name (comes without the extension)
sGraphicURL = Mid(sGraphicURL, 28, Len(sGraphicURL))
' so search all files in pictures folder for the current picture ...
For j = 0 to uBound(mFiles())
If InStr(1, mFiles(j), sGraphicURL, 0) Then
' create new name with extension ...
sGraphicName = oGraphics.getByIndex(i).getName() & Mid(mFiles(j),
Len(sGraphicURL)+1, Len(mFiles(j))
Exit For
EndIf
Next j
' copy file to external folder relative to stored document...
oFileAccess = createUnoService("com.sun.star.ucb.SimpleFileAccess")
oFile = oFileAccess.openFileWrite(sDestFolder & sGraphicName)
oOutputStream = createUnoService("com.sun.star.io.DataOutputStream")
oOutputStream.setOutputStream(oFile)
oInputStream = oPictures.getByName(mFiles(j)).getInputStream()
n = -1
While n <> 0
n = oInputStream.readBytes(mData(), 16384)
oOutputStream.writeBytes(mData())
Wend
oOutputStream.flush()
oOutputStream.closeOutput()
oInputStream.closeInput()
ReDim mData() as Variant
' now link picture to new external file ...
oGraphics.getByIndex(i).GraphicURL = sDestFolder & sGraphicName
' check for duplicates, link them too ...
For k = i + 1 to oGraphics.getCount-1
If sTmp = oGraphics.getByIndex(k).GraphicURL Then
oGraphics.getByIndex(k).GraphicURL = sDestFolder &
sGraphicName
EndIf
Next k
EndIf
Next i
' this automatically removes the unused internal pictures too :-)
oDocument.store()
ExtractWriterGraphics = 0
Exit Function
ErrorHandler:
ExtractWriterGraphics = -1
End Function
-- Liste abmelden mit E-Mail an: users+unsubscribe@de.libreoffice.org
Probleme?
https://de.libreoffice.org/hilfe-kontakt/mailing-listen/abmeldung-liste/
Tipps zu Listenmails: https://wiki.documentfoundation.org/Netiquette/de
Listenarchiv: https://listarchives.libreoffice.org/de/users/
Datenschutzerklärung: https://www.documentfoundation.org/privacy
Privacy Policy |
Impressum (Legal Info) |
Copyright information: Unless otherwise specified, all text and images
on this website are licensed under the
Creative Commons Attribution-Share Alike 3.0 License.
This does not include the source code of LibreOffice, which is
licensed under the Mozilla Public License (
MPLv2).
"LibreOffice" and "The Document Foundation" are
registered trademarks of their corresponding registered owners or are
in actual use as trademarks in one or more countries. Their respective
logos and icons are also subject to international copyright laws. Use
thereof is explained in our
trademark policy.