Shape içindeki shape Weld VBA

Merhaba arkadaşlar makro ile şu işlemi yapmak istiyorum bilen varsa öğretirse minnettar olurum.

Varsayalım ki corel çalışma alanımızda yüzlerce curve nesne var ve bunlardan bazıları iç içe duruyor. yani kare içinde kare  varmış gibi düşünün. ben diğer nesnelere hiç dokunmadan bu iç içe olan nesneleri bulup bunları weld ile birleştiren bir makro yapmak istiyorum. bunun için ne yapmam lazım.

yardımcı olacak kişiye şimdiden çok teşekkür ediyorum.

  • Former Member
    Former Member over 5 years ago

    Hi my friend you can do it at once in a tool
    ============

    ================

    • Teşekkür ediyorum. Ancak aradığım cevap bu değil. soruyu yanlış sordum sanırım

      For Each s In sr
      If s.Type = cdrContourGroupShape Then

      s.BreakApartEx

      s.combine ????????????????

      'buraya kadar tamam ancak contour'dan ayırdığım şeklin ayrıldığı şekille combine olmasını istiyorum.

      bu nesneyi ayır ve ayırdığın nesne ile combine et. demeye çalışıyorum yapamıyorum

      G curve        -----------------------> g curve

      G curve        ----------------------> g curve

      B curve + contour --------------> B combine

      • Dim OrigSelection As ShapeRange
        Set OrigSelection = ActiveSelectionRange
        ActiveSelection.Separate
        Dim grp1 As ShapeRange
        Set grp1 = ActiveDocument.CreateShapeRangeFromArray(ActiveLayer.Shapes(3), OrigSelection(1)).UngroupAllEx
        ActiveDocument.CreateSelection grp1(2), grp1(1)
        Dim s1 As Shape
        Set s1 = ActiveSelection.Combine


        bu kodlar işime yaramıyor çünkü activelayer.shapes(3) her zaman aynı değil. 

        • Former Member
          Former Member over 5 years ago in reply to kurgucu

          STEP***1

          ---------------

          • Former Member
            Former Member over 5 years ago in reply to Former Member

            STEP***2

            This step is optional, not mandatory

            ---------------

            ==========

            • Former Member
              Former Member over 5 years ago in reply to kurgucu

              STEP***3

              Select the two cursor layers inside the red rectangle

              ---------------

              • Former Member
                Former Member over 5 years ago in reply to kurgucu

                STEP***4

                ----------------

            • Dim sr As ShapeRange
              Dim srFound As ShapeRange
              Dim X As Double, Y As Double, w As Double, h As Double

              ActiveSelectionRange.ConvertToCurves
              Set sr = ActiveSelectionRange.BreakApartEx

              Do
              sr.Shapes.First.GetBoundingBox X, Y, w, h
              Set srFound = ActivePage.SelectShapesFromRectangle(X, Y, X + w, Y + h, False).Shapes.FindShapes()
              sr.RemoveRange srFound
              If srFound.Count > 1 Then srFound.Combine
              Loop Until sr.Count = 0
              ActiveDocument.CreateSelection ActivePage.Shapes.All

              • Former Member
                Former Member over 5 years ago in reply to kurgucu

                It looks like you are writing mathematical functions or code
                I don't understand this programming language because I'm not a programmer

                • Hello my friend

                  First of all, thank you for your interest.

                  in the screenshot you send

                  I was trying to code.

                  I've been trying the code and found the solution. The code I sent does this. The code doesn't belong to me, it does what I want. Thanks again.

                  This translation has been made with google translation.

              • merkezleri ayni olan (yani ic ice) daireleri kombine etmek icin bir kod:

                Private Sub CombineShapes()
                Dim sr As ShapeRange, src As New ShapeRange, z&, m&
                    Set sr = ActiveSelectionRange
                    Optimization = True
                    For z = 1 To sr.Count - 1
                        For m = z + 1 To sr.Count
                            If Round(sr(z).centerX, 2) = Round(sr(m).centerX, 2) Then
                                If Round(sr(z).centerY, 2) = Round(sr(m).centerY, 2) Then
                                    src.Add sr(z): src.Add sr(m)
                                    src.Combine:  sr.Remove m: src.RemoveAll
                                    Exit For
                                End If
                            End If
                        Next m
                    Next z
                    Optimization = False: Refresh
                End Sub