W2007: Bilder proportional einfügen ohne ".LockAspectRatio = msoTrue"

[Heiko Rompel]

Moin,

ich brauche dringend ein VBA-Makro das mir
a) eine Dialog zum Auswählen von Bilder zur Verfügung stellt
b) ALLE ausgewählten Bilder in das Dokument einfügt
c) alle Bilder proportional auf eine Höhe von 16 cm scaliert
d) mit Word 2007 funktioniert (also ohne ".LockAspectRatio = msoTrue")

Bisher bekomme ich zwar das Einfügen eines Bildes hin, aber weder das
Skalieren noch das ich nach dem Einfügen mehr als ein Bild zur Zeit
markieren kann um es z.B. verschieben.

Hier mein Script (Das einfügen des Dateinamens habe ich deaktiviert):
=======
Sub InsertPicture()
Dim ret As Integer, sPic As String, fName As String, shpPicture As Shape
With Dialogs(wdDialogInsertPicture)
ret = .Display
If ret = vbTrue Then
fName = .Name
Rem Bild einfügen
With Selection.InlineShapes.AddPicture(FileName:=fName)
.LockAspectRatio = msoTrue
' eine von diesen vier Eigenschaften sollte reichen zum
proportionalen Skalieren
' .Width = CentimetersToPoints(10)
.Height = CentimetersToPoints(16)
' .ScaleWidth = 50
' .ScaleHeight = 50
End With
Selection.Style = ActiveDocument.Styles("Standard")
Selection.InsertBreak wdLineBreak
Selection.InsertParagraphAfter
Selection.Collapse wdCollapseEnd
Selection.TypeParagraph
Rem Text einfügen
'fName = Dateiname_von(fName)
'Selection.TypeText Text:=fName
'Selection.Style = ActiveDocument.Styles("Untertitel")
'Selection.InsertBreak wdLineBreak
'Selection.InsertParagraphAfter
'Selection.Collapse wdCollapseEnd
End If
End With
End Sub

Function Dateiname_von(aa) As String 'Dateiname abtrennen
Dateiname_von = Mid(aa, InStrRev(aa, "\") + 1)
Dateiname_von = Mid(Dateiname_von, 1, Len(Dateiname_von) - 4)
End Function
=======

Kann mir hier jemand weiter helfen?

Gruß Heiko

[Lisa Wilke-Thissen]

Hallo Heiko,

"Heiko Rompel" schrieb

> Bisher bekomme ich zwar das Einfügen eines Bildes hin, aber weder das

> Skalieren noch dass

> ich nach dem Einfügen mehr als ein Bild zur Zeit markieren kann um es z.B.
> verschieben.

hier tummeln sich leider kaum VBA-Experten.

Sofern ich erkenne, verwendest du in deinem Skript "InlineShapes". Demnach
sind die Bilder "Mit Text in Zeile" positioniert.
Dann können auch nicht mehrere gleichzeitig markiert werden. Du musst sie
einzeln durchlaufen.
Und ebenso wenig wie du Texte verschieben kannst, lassen sich InlineShapes
verschieben. Sie können höchstens per Absatzeinzug, Tabulator o. ä.
positioniert werden.

Was ich zum Skalieren gefunden habe, vielleicht hilft's weiter:

http://stackoverflow.com/questions/1955886/visual-basic-macro-in-word-to-resize-center-delete-all-images

Dim oILShp As InlineShape

For Each oILShp In ActiveDocument.InlineShapes
With oILShp
.Height = AspectHt(.Width, .Height, _
CentimetersToPoints(11))
.Width = CentimetersToPoints(11)
End With


http://social.msdn.microsoft.com/Forums/office/en-US/f265ddb0-b016-4bb4-9812-110bad9a93c8/merging-images-and-resizing-using-vba?forum=worddev

For Each image In ActiveDocument.InlineShapes
image.Select
With Selection
height = .InlineShapes(1).height
width = .InlineShapes(1).width
ratio = desiredHeight / height
Selection.Fields.Update
.InlineShapes(1).height = height * ratio
.InlineShapes(1).width = width * ratio
End With
Next image

--
Viele Grüße
Lisa

[Heiko Rompel]

Hallo Lisa,

> Sofern ich erkenne, verwendest du in deinem Skript "InlineShapes".
> Demnach sind die Bilder "Mit Text in Zeile" positioniert.
> Dann können auch nicht mehrere gleichzeitig markiert werden. Du musst
> sie einzeln durchlaufen.
> Und ebenso wenig wie du Texte verschieben kannst, lassen sich
> InlineShapes verschieben. Sie können höchstens per Absatzeinzug,
> Tabulator o. ä. positioniert werden.

Das ist doch schon mal eine wichtige Information.
Da ich mir das Sript auch nur zusammengesucht / gebettelt habe,
wussste ich nicht was jeder Teil genau macht.

>
> Was ich zum Skalieren gefunden habe, vielleicht hilft's weiter:

Muß ich die Tage mal ausprobieren...

Gruß HEiko