Shapes.Copy - Activesheet.Paste mit Bug

daniel · 2024-09-18T14:57:54+00:00

Hallo ich kämpfe grad mit folgendem Problem: ich kopiere ein Shape auf einem Tabellenblatt und möchte es an anderer Stelle wieder einfügen. also im Prinzip: ActiveSheet.Shapes(1).Copy ActiveSheet.Paste allerdings bekomme ich hier einen Laufzeitfehler 1004 beim .Paste: "die Paste-Methode konnte nicht ausgeführt werden" ein echter Fehler kann es aber nicht zu sein, denn im Einzelstepmodus funktioniert es. ebenso funktioniert es, wenn das Blatt nicht aktiv ist. also klar einfacher Workaround: zum Einfügen anderes Blatt selektieren. trotzdem würde ich gerne das ganze im aktiven Blatt ausführen lassen, damit man zusehen kann, wie das Bild wächst (es sind viele Punkte die so eingefügt werden, deswegen ist Einzelstepmodus auch keine Lösung) Weiß jemand, wie man diesen Bug austricksen kann? Gruß Daniel

Hi Daniel,
habe mit der von dir geposteten Datei getestet und meine vermeintliche Ursache könnte sein, dass a) Shape Code hat und VBE hakt oder b) keine Deklaration verwendet wird.
so funktioniert es bei mir ohne irgendwelche Fehler



Sub test()

    Dim sh As Shape

    Set sh = ThisWorkbook.Worksheets(1).Shapes(1)

    Dim i As Integer, dblI As Double

    For i = 20 To 100 Step 10

        dblI = CDbl(i + 200)

        If Not Zeichnen_Ort(dblI, dblI, sh, "Nr " & CStr(i / 10), True) Then

            Exit Sub

        End If

    Next

End Sub



Function Zeichnen_Ort(Ko_OW As Double, Ko_NS As Double, Icon As Shape, Optional Bez As String, Optional BezAnz As Boolean) As Boolean

    On Error GoTo Zeichnen_OrtERR

    Dim wks As Worksheet

    Ko_NS = Ko_NS - Icon.Height / 2

    Ko_OW = Ko_OW - Icon.Width / 2

    Set wks = ThisWorkbook.Worksheets(2)

    Icon.Copy

    With wks

        .Activate

        .Paste

        With .Shapes(.Shapes.Count)

            .Top = Ko_NS

            .Left = Ko_OW

            If Not IsMissing(Bez) Then

                .Name = Replace(Bez, " ", "_")

                If Not IsMissing(BezAnz) Then

                    If BezAnz Then .TextFrame2.TextRange.Characters.Text = Bez '----- Fehler, wenn Shape mit PasteSpecial eingefügt

                End If

            End If

        End With

    End With

    Zeichnen_Ort = True

Zeichnen_OrtOUT:

    Exit Function

Zeichnen_OrtERR:

    Debug.Print Err.Number & vbCrLf & Err.Description & vbCrLf & Err.Source

    Zeichnen_Ort = False

    Resume Zeichnen_OrtOUT

End Function

hth
Ulf

Hi
ok, Code wäre das. Es geht um die Funktion Zeichnen_Ort.
mit dem Makro Test kannst du sie ausführen.

du benötigst eine Datei mit zwei Tabellenblättern.
auf dem ersten Sollte eine Grafik liegen (Kreis oder sowas)

die Funktion kopiert das angegebene Shape aus dem ersten Blatt und fügt es im zweiten Tabellenblatt an den angegebenen Koordinaten ein (die ersten beiden Parameter).

kritisch sind die beiden Paste bzw PasteSpecial-Varianten (durch ------------ markiert)

wenn ich die Variante nehme: Sheets(2).Paste funktioniert es, außer das Sheets(2) ist aktiv (was ich aber gerne hätte). Im Einzelstepmodus gibt es keinen Fehler
die Variante Sheets(2).Cells(1, 1).PasteSpecial funktioniert zunächst wie gewünscht, bringt aber dann beim hinzufügen des Textes den Fehler "Laufzeitfehler -214704809 (80070057) Der angegebene Wert ist ausßerhalb des zulässigen Bereichs"

Sub test()

Zeichnen_Ort 20, 20, Sheets(1).Shapes(1), "Hallo Welt", True

End Sub









Function Zeichnen_Ort(Ko_OW As Double, Ko_NS As Double, Icon As Shape, Optional Bez As String, Optional BezAnz As Boolean) As Boolean

    Zeichnen_Ort = True

    Ko_NS = Ko_NS - Icon.Height / 2

    Ko_OW = Ko_OW - Icon.Width / 2

    

    Icon.Copy

    With Sheets(2)

'----------------------------------------------------------------------------------------------

        Sheets(2).Paste '--- Fehler, wenn Sheet(2) aktiv

        'Sheets(2).Cells(1, 1).PasteSpecial '--- Zuweisen des Textes funktioniert nicht mehr

'-----------------------------------------------------------------------------------------------

        With .Shapes(.Shapes.Count)

            .Top = Ko_NS

            .Left = Ko_OW

            If Not IsMissing(Bez) Then

                .Name = Replace(Bez, " ", "_")

                If Not IsMissing(BezAnz) Then

                    If BezAnz Then .TextFrame2.TextRange.Characters.Text = Bez '----- Fehler, wenn Shape mit PasteSpecial eingefügt

                End If

                

            End If

        End With

    End With

End Function

Danke für deine Mühe

Gruß Daniel

Shapes.Copy - Activesheet.Paste mit Bug

Forumthread: Shapes.Copy - Activesheet.Paste mit Bug

20
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Shapes.Copy - Activesheet.Paste mit Bug

Forumthread: Shapes.Copy - Activesheet.Paste mit Bug

20 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

20
Beiträge zum Forumthread

Beiträge zu diesem Forumthread