Ebenen zusammenführen

[Karthagos]

Hallo Koter, jetzt habe ich alle Subs und Funktionen in ein Modul kopiert, Reichenfolge ist egal?
Nun kommt folgende Fehlermeldung:
   

[koter]

Hallo Günther,
leider sehe ich auf dem Screenshot keine Fehlermeldung!

Nachtrag:
Hast Du vor dem Kopieren ein Objekt markiert?

[Karthagos]

Hallo Koter,
brauchte ein paar Versuche, aber jetzt habe ich es hinbekommen,  . 
Phantastisch wie immer bei Deinen Makros. 

Aber wenn ich die Vielzahl der Makros und Funktionen sehe, was eine Arbeit, Hut ab  
Noch einen schönen Sonntag

[koter]

Hallo Günther,

wenn „qKopieren“ ausgeführt wird, ohne dass etwas ausgewählt ist,
kann CorelDraw einfrieren oder komplett abstürzen.

Du solltest deshalb „qKopieren“ und „qEinfügen“ durch folgendes austauschen:

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
   On Error GoTo ende
   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
ende:
   Optimization = False
   Application.Refresh
   Refresh
End Sub

Vor der Ausführung wird geprüft, ob etwas ausgewählt ist. Wenn nicht bricht die Funktion ab.
So ist das etwas sicherer, man klickt ja schnell mal zu früh.

Gruß

Koter

[Karthagos]

Hallo Koter,
habe jetzt die Makros ausgetauscht. Es befinden sich folgende Makros im Modul:
   
Wenn ich qKopieren ausführe, kommt folgende Fehlermeldung.
   

[koter]

Hallo Günther,

die Funktionen „Hilfsrechteck“ und „quadrantKlick“ fehlen im Modul.
Das sind die letzten beiden aus Beitrag 8.

Gruß

Koter

[Karthagos]

Hallo Koter,
 
vielen Dank für Deine Geduld und den Hinweis der fehlenden Module, jetzt funktioniert es wieder.
 
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
 
Und in das Zweite Makro qKopieren ein Meldungsfenster
Mit Mauszeiger (Kreuz) gewünschten Zielquadrant auswählen
Auswahl OK, dann verschwindet das Meldungsfenster
 
b.t.w. Gibt es eine Möglichkeit, den Code mit einem Klick auszuwählen oder muss man den mit durchfahren des Mauszeigers markieren
   
Meine eMail-Benachrichtigungen funktioniere seit kurzem nicht mehr, ist das nur bei mir so oder ein Forumproblem, weißt Du da evtl. was?
   

[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

[Karthagos]

Hallo Koter,

danke für die Ergänzung. Es ist zwar eigentlich selbsterklärend, aber wenn ich das Makro mal ein paar Wochen nicht benutze und dann wieder, fällt mir diese Mauszeigergeschichte bestimmt auf die Füße (partielle Amnesie  , deswegen ist die Hinweiseinblendung für mich sehr hilfreich  .

Nochmals 1000 Dank   und einen schönen Abend für Dich