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

08/04/2014 - 10:59 von Heiko Rompel | Report spam
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
 

Lesen sie die antworten

#1 Lisa Wilke-Thissen
10/04/2014 - 15:38 | Warnen spam
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/...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/Fo...um=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

Ähnliche fragen