Ebenen zusammenführen

[koter]

Hallo Günther,

...Bei so vielen Makros macht es ja vielleicht keinen Sinn, jedes einzeln in die Symbolleiste zu zsetzen?

Das stimmt!

Ich habe noch zwei Makros zusammengeschustert, welche die anderen Makros ausführen:



Das sind die Makros „qKopieren“ und „qEinfügen“

Beim Ausführen von „qEinfügen“ wird der Mauspfeil zu einem Kreuz,
mit dem Du den Zielquadranten auswählen musst.

Code:

Sub qKopieren()
   Dim HRe As Shape
   Optimization = True
   Set HRe = Hilfsrechteck(Quadrant(ActiveShape))
   markieren
   QuellgruppeErzeugen
   kopieren
   HRe.Delete
   QuellgruppeVerteilen
   Optimization = False
   Application.Refresh
   Refresh
End Sub

Sub qEinfügen()
   Dim QGr As Shape, HRe As Shape
   Dim q1 As Integer, q2 As Integer
   q2 = quadrantKlick
   Set QGr = ActiveLayer.Paste
   Optimization = True
   Select Case q2
   Case 1
       QGr.LeftX = 0
       QGr.TopY = ActivePage.TopY
   Case 2
       QGr.RightX = ActivePage.RightX
       QGr.TopY = ActivePage.TopY
   Case 3
       QGr.LeftX = 0
       QGr.BottomY = 0
   Case 4
       QGr.RightX = ActivePage.RightX
       QGr.BottomY = 0
   End Select
   Set HRe = QGr.Shapes("Hilfsrechteck")
   q1 = HRe.Properties("Quadrant", 1)
   If q1 = 1 Xor q1 = 3 Then
       If q2 = 2 Or q2 = 4 Then QGr.Rotate 180
   Else
       If q2 = 1 Or q2 = 3 Then QGr.Rotate 180
   End If
   HRe.Delete
   QuellgruppeVerteilen
   Optimization = False
   Application.Refresh
   Refresh
End Sub

Private Function Hilfsrechteck(q As Integer) As Shape
   Dim x As Double, y As Double, w As Double, h As Double
   w = ActivePage.SizeWidth / 2
   h = ActivePage.SizeHeight / 2
   Select Case q
   Case 1
       x = 0: y = h
   Case 2
       x = w: y = h
   Case 3
       x = 0: y = 0
   Case 4
       x = w: y = 0
   End Select
   Set Hilfsrechteck = ActiveLayer.CreateRectangle2(x, y, w, h)
   Hilfsrechteck.Properties("Quadrant", 1) = q
   Hilfsrechteck.name = "Hilfsrechteck"
End Function

Private Function quadrantKlick() As Integer
   Dim mX As Double, mY As Double, sX As Double, sY As Double
   Dim q As Integer
   Dim Shift As Long
   Dim b As Boolean
   mX = ActivePage.CenterX
   mY = ActivePage.CenterY
   b = False
   b = ActiveDocument.GetUserClick(sX, sY, Shift, 10, False, cdrCursorWinCross)
   q = Switch(sX < mX And sY > mY, 1, sX > mX And sY > mY, 2, sX < mX And sY < mY, 3, sX > mX And sY < mY, 4)
   quadrantKlick = q
End Function

Die Makros habe ich schnell zusammengeschustert.
Du solltest sie in der richtigen Reihenfolge ausführen, sonst kann es zu Abstürzen kommen.

ich hoffe es klappt!

Gruß

Koter