Juergens-Workshops.de Forum
Ebenen zusammenführen - Druckversion

+- Juergens-Workshops.de Forum (https://forum.juergens-workshops.de)
+-- Forum: Corel Grafik Forum (https://forum.juergens-workshops.de/forumdisplay.php?fid=65)
+--- Forum: Corel Draw (https://forum.juergens-workshops.de/forumdisplay.php?fid=93)
+--- Thema: Ebenen zusammenführen (/showthread.php?tid=38842)

Seiten: 1 2

RE: Ebenen zusammenführen - Karthagos - 14.09.2025

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

RE: Ebenen zusammenführen - koter - 14.09.2025

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

Nachtrag:
Hast Du vor dem Kopieren ein Objekt markiert?

RE: Ebenen zusammenführen - Karthagos - 14.09.2025

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

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

RE: Ebenen zusammenführen - koter - 15.09.2025

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

RE: Ebenen zusammenführen - Karthagos - 15.09.2025

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

RE: Ebenen zusammenführen - koter - 16.09.2025

Hallo Günther,

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

Gruß

Koter

RE: Ebenen zusammenführen - Karthagos - 17.09.2025

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
[attachment=22316]
Meine eMail-Benachrichtigungen funktioniere seit kurzem nicht mehr, ist das nur bei mir so oder ein Forumproblem, weißt Du da evtl. was?
[attachment=22315]

RE: Ebenen zusammenführen - koter - 17.09.2025

Hallo Günther,

(17.09.2025, 06:52)Karthagos schrieb: 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.

(17.09.2025, 06:52)Karthagos schrieb: ...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:

[Bild: Tegut2.gif]

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.

(17.09.2025, 06:52)Karthagos schrieb: ...b.t.w. Gibt es eine Möglichkeit, den Code mit einem Klick auszuwählen...

Ich glaube nicht.

(17.09.2025, 06:52)Karthagos schrieb: ...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

RE: Ebenen zusammenführen - Karthagos - 17.09.2025

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  Big Grin , deswegen ist die Hinweiseinblendung für mich sehr hilfreich  Daumenhoch .

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