Hallo liebe Leute und zwar hab ich folgendes Problem:
Ich soll mehrere Bilder auswählen und dann jeweils 3 pro Seite in Word einfügen!
Alles kein Problem nur müsste ich sie jetzt auch zentriert einfügen jedoch gelingt es mir nur immer das erste Bild + Bildbeschreibung zentriert auszugeben und die folgenden sind immer linksbündig
Hier mein Code:
Option Explicit
'Code by Koert 2012
Sub AddPicture(ByVal sFilename As String)
If sFilename = "" Then
MsgBox " Kein Dateiname!", vbInformation
Exit Sub
End If
Dim x As Variant
Dim objInlineShape As InlineShape
Set objInlineShape = Selection.InlineShapes.AddPicture(FileName:= _
sFilename, LinkToFile:=False, SaveWithDocument _
:=True)
Selection.TypeParagraph
'Zentrieren
ActiveDocument.InlineShapes(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
'Scale Sperre
objInlineShape.LockAspectRatio = msoTrue
'Zuerst Breite Einstellen
objInlineShape.Width = 226.7634
If objInlineShape.ScaleWidth > 0 Then
objInlineShape.ScaleHeight = objInlineShape.ScaleWidth
End If
'Dann nochmal Höhe prüfen
If objInlineShape.Height > 170.0787 Then
'Hochformat
'Höhe kürzen
objInlineShape.Height = 170.0787
If objInlineShape.ScaleWidth > 0 Then
objInlineShape.ScaleWidth = objInlineShape.ScaleHeight
End If
End If
'Beschriftung einstellen
CaptionLabels.Add Name:="Abbildung"
'Beschriftung hinzufügen
objInlineShape.Range.InsertCaption "Abbildung", , "bla", wdCaptionPositionAbove
End Sub
Sub GetFile()
Const msoFileDialogOpen = 1
Dim objWord As Application
Dim objfile As Variant
Dim lCurrentWindowstate As Long
Set objWord = Application
'objWord.ChangeFileOpenDirectory ("C:\Scripts")
objWord.FileDialog(msoFileDialogOpen).Title = "Bilder auswählen"
objWord.FileDialog(msoFileDialogOpen).AllowMultiSelect = True
objWord.FileDialog(msoFileDialogOpen).Filters.Add "Bilder", "*.gif; *.jpg; *.jpeg", 1
lCurrentWindowstate = objWord.WindowState
If objWord.FileDialog(msoFileDialogOpen).Show = -1 Then
' objWord.WindowState = 2
For Each objfile In objWord.FileDialog(msoFileDialogOpen).SelectedItems
AddPicture objfile
Next
End If
objWord.WindowState = lCurrentWindowstate
objWord.ScreenRefresh
Set objWord = Nothing
End Sub
|