Ebenen zusammenführen

[koter]

Hallo Günther,

Kannst Du in das erste Makro qKopieren eine Abfrage (Meldungsfenster) einbauen:
„Ist ein Objekt markiert“ Auswahl Ja, Nein
Bei Ja geht es weiter, bei Nein wird abgebrochen...

Die Kontrolle ist ja schon eingebaut.
Vor der Ausführung wird geprüft, ob etwas ausgewählt ist.
Wenn nicht bricht die Funktion mit einer Meldung ab.

Eine zusätzliche Abfrage wäre also überflüssig.
Falls Du Sie trotzdem wünscht, Gib Bescheid.

...Und in das Zweite Makro qKopieren ein Meldungsfenster
Mit Mauszeiger (Kreuz) gewünschten Zielquadrant auswählen
Auswahl OK, dann verschwindet das Meldungsfenster

Ich hoffe das richtig verstanden zu haben. So wäre der Ablauf jetzt:



Wenn das Kreuz erscheint kannst Du die Aktion immer noch mit der ESC-Taste abbrechen.

Lass Dich nicht durch die drei letzten Bedienelemente auf der Symbolleiste verwirren.
Die habe ich nur für mich zum testen erstellt. In meiner Beispieldatei sind nicht alle Quadranten leer.

Code:

Sub qKopieren()
   Dim HRe As Shape
   On Error GoTo ende
   If ActiveSelectionRange.Count <> 1 Then
       MsgBox "Bitte ein Objekt auswählen!", vbExclamation, "Kopieren"
       Exit Sub
   End If
   Optimization = True
   Set HRe = Hilfsrechteck(Quadrant(ActiveShape))
   markieren
   QuellgruppeErzeugen
   kopieren
   HRe.Delete
   QuellgruppeVerteilen
ende:
   Optimization = False
   Application.Refresh
   Refresh
End Sub

Sub qEinfügen()
   Dim QGr As Shape, HRe As Shape
   Dim q1 As Integer, q2 As Integer, weiter
   On Error GoTo ende
   weiter = MsgBox("Bitte mit dem Mauszeiger (Kreuz)" & Chr(13) & "den gewünschten Zielquadranten auswählen", vbOKCancel, "Anzeige einfügen")
   If weiter = 2 Then Exit Sub
   q2 = quadrantKlick
   If q2 = 0 Then Exit Sub
   ActiveDocument.BeginCommandGroup "Anzeige einfügen"
   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
ende:
   ActiveDocument.EndCommandGroup
   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
   q = 0
   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
   If b Then quadrantKlick = 0
End Function

Sub InhaltLöschen()
   ActiveSelection.Delete
End Sub

Wenn Du an der Reihenfolge im Modul nichts geädert hast,
kannst den Code ab „qKopieren“ mit diesem überschreiben.

...b.t.w. Gibt es eine Möglichkeit, den Code mit einem Klick auszuwählen...

Ich glaube nicht.

...Meine eMail-Benachrichtigungen funktioniere seit kurzem nicht mehr, ist das nur bei mir so oder ein Forumproblem, weißt Du da evtl. was?...

Bei mir funktioniert das auch manchmal nicht. Der Grund ist mir nicht bekannt.

Gruß

Koter