Grafik verschieben per Makro

01/11/2009 - 10:01 von puck | Report spam
Hi!
In ein Blatt habe ich eine Grafik importiert. Nun soll die Grafik in einen
bestimmten Bereich verschoben und in der Groesse angepasst werden. Dazu
nutze ich ein angepasstes Makro aus dem Buch von Mel. Breden.
Aber es funktioniert nicht.

Sub Hàndlerlogo()
'
' Hàndlerlogo Makro
' Makro am 31.10.2009 von aufgezeichnet
'

If ActiveSheet.Pictures.Count < 2 Then Exit Sub
ActiveSheet.Shapes("Bild 1").Select
Selection.Delete
ActiveSheet.Pictures(1).Name = "Bild 2"

Hier in dieser Zeile oben verabschiedet sich das Makro mit Fehler 13 =
Typen unvertràglich. Weiss jemand eine "richtige" Zeile?

Sonntagsgruß
GvB

'ActiveSheet.Shapes("Bild 2").Select
' Selection.Cut

'Range("E3").Select
' ActiveSheet.Paste

Dim strPath As String
Dim pic As Pictures
Dim dblWidth As Double
Dim dblHeight As Double
Dim rng As Range

'strPath = ThisWorkbook.Path & "\Bild 2.jpg"

Set rng = ActiveSheet.Range("e2:g6")
Set pic = ActiveSheet.Shapes("Bild 2")

dblHeight = rng.Offset(rng.Rows.Count, 0).Top - rng.Top
dblWidth = rng.Offset(0, rng.Columns.Count).Left - rng.Left

With pic
.Width = dbl.Width
.Height = dblHeight
.Left = rng.Left
.Top = rng.Top
End With

Set rng = Nothing
Set pic = Nothing

'Set p = ActiveSheet.Shapes("Bild 2")
'p.Top = Range("e3").Top
'p.Left = Range("e3").Left


Range("A1").Select
End Sub
 

Lesen sie die antworten

#1 Andreas Killer
01/11/2009 - 10:39 | Warnen spam
Gebhard von Busse schrieb:

In ein Blatt habe ich eine Grafik importiert. Nun soll die Grafik in einen
bestimmten Bereich verschoben und in der Groesse angepasst werden. Dazu


Das Makro von Melanie macht (vermute ich) was ganz anderes und Deine
Ergànzungen sind sehr mysteriös, wieso löscht Du das Bild?

Das Bild platzieren und dimensionieren geht ganz einfach so.

Andreas.

Sub Hàndlerlogo()
ResizePicture "Bild 1", Range("e2:g6")
End Sub

Private Sub ResizePicture(ByVal PicName As String, R As Range)
'Dimensioniert ein Bild auf einen Zellbereich
Dim S As Shape
'Zugriff auf das Bild versuchen
On Error Resume Next
Set S = ActiveSheet.Shapes(PicName)
'Erfolgreich?
If S Is Nothing Then
Err.Raise 481, "ResizePicture", "Bild nicht vorhanden"
Exit Sub
End If
'Dimensionieren
With S
.Left = R.Left
.Top = R.Top
.Height = R.Height
.Width = R.Width
'Ggf. Höhe erneut setzen, sonst ist das Bild zu groß
If .Height > R.Height Then .Height = R.Height
End With
End Sub

Ähnliche fragen