Hello Sorry for the English translation. Imagine that there are many shapes with or without holes in the work area, each consisting of different shapes. What I want to do is to find out how many pieces a rectangle 13 cm wide and 10 cm high fits into each of these shapes. It's like a simple nesting. In the coding I compiled, it only works for one shape, it gives an error when there are multiple shapes and it does not rotate the rectangles according to the structure of the shape.
Private Sub CommandButton18_Click()
Dim sr As ShapeRange Dim boundaryShape As Shape Dim rectWidth As Double Dim rectHeight As Double Dim rect As Shape Dim rectCount As Integer Dim i As Integer, j As Integer Dim xOffset As Double, yOffset As Double Dim stepAngle As Double Dim minX As Double, minY As Double, maxX As Double, maxY As Double
' Ölçü birimini cm olarak ayarla ActiveDocument.ReferencePoint = cdrCenter ActiveDocument.Unit = cdrCentimeter Set sr = ActiveSelectionRange
' Boundary şekli Set boundaryShape = sr.Shapes(1)
' Dikdörtgenin boyutları (örneğin: 15 cm x 10 cm) rectWidth = 10 rectHeight = 3
' Açısal adım (döndürme açısı) stepAngle = 0 ' 15 derece örnek
rectCount = 0
' Dikdörtgenlerin yerleştirilmesi For i = 0 To Int(boundaryShape.SizeWidth / rectWidth) - 1 For j = 0 To Int(boundaryShape.SizeHeight / rectHeight) - 1 xOffset = boundaryShape.LeftX + i * rectWidth yOffset = boundaryShape.BottomY + j * rectHeight 'xOffset = i * rectWidth 'yOffset = j * rectHeight ' Dikdörtgen oluştur Set rect = ActiveLayer.CreateRectangle2(xOffset, yOffset, rectWidth, rectHeight)
' Dikdörtgeni döndür rect.Rotate stepAngle ' Bounding box koordinatlarını al rect.GetBoundingBox minX, minY, maxX, maxY ' Dikdörtgenin köşe noktalarının boundary şekli içinde olup olmadığını kontrol et If IsRectangleInside(minX, minY, minX + maxX, minY + maxY, boundaryShape) Then rectCount = rectCount + 1 End If
' Dikdörtgeni sil 'rect.Delete Next j Next i
' Sonucu mesaj kutusunda göster MsgBox "Boundary içinde " & rectCount & " adet dikdörtgen sığabilir (döndürme ile)."End Sub
Function IsRectangleInside(minX As Double, minY As Double, maxX As Double, maxY As Double, boundaryShape As Shape) As Boolean ' Bu fonksiyon, bounding box'ın boundary içinde olup olmadığını kontrol eder Dim inside As Boolean inside = True
If minX < boundaryShape.LeftX Or maxX > boundaryShape.RightX Or _ minY < boundaryShape.BottomY Or maxY > boundaryShape.TopY Then inside = False End If
IsRectangleInside = insideEnd Function
Hello,
You want to improve your VBA code for fitting rectangles into various shapes in CorelDRAW. Your current code handles only one shape and doesn't rotate the rectangles or fit them into multiple shapes. Here's how you can modify and expand your code to address these issues:
Support Multiple Shapes: Iterate over all shapes in the ShapeRange.Rectangle Rotation: Consider rotations when placing rectangles.Check Fit: Ensure the rectangles fit inside the shapes considering the rotation.
Revised code:
Here’s a revised version of your VBA code that addresses these needs:
Private Sub CommandButton18_Click() Dim sr As ShapeRange Dim boundaryShape As Shape Dim rectWidth As Double Dim rectHeight As Double Dim rect As Shape Dim rectCount As Integer Dim i As Integer, j As Integer Dim xOffset As Double, yOffset As Double Dim stepAngle As Double Dim minX As Double, minY As Double, maxX As Double, maxY As Double Dim fitCount As Integer
' Set the unit to cm ActiveDocument.Unit = cdrCentimeter Set sr = ActiveSelectionRange
' Rectangle dimensions rectWidth = 13 rectHeight = 10
' Rotation angles (0 to 360 degrees in 15-degree steps) For stepAngle = 0 To 345 Step 15 fitCount = 0
' Loop through each shape in the selected range For Each boundaryShape In sr.Shapes If boundaryShape.Type = cdrCurveShape Then ' For each rotation, try to fit rectangles For i = 0 To Int(boundaryShape.SizeWidth / rectWidth) - 1 For j = 0 To Int(boundaryShape.SizeHeight / rectHeight) - 1 xOffset = boundaryShape.LeftX + i * rectWidth yOffset = boundaryShape.BottomY + j * rectHeight
' Create and rotate the rectangle Set rect = ActiveLayer.CreateRectangle2(xOffset, yOffset, rectWidth, rectHeight) rect.Rotate stepAngle
' Get bounding box coordinates rect.GetBoundingBox minX, minY, maxX, maxY
' Check if rectangle is within boundaryShape If IsRectangleInside(minX, minY, maxX, maxY, boundaryShape) Then fitCount = fitCount + 1 End If
' Delete the rectangle rect.Delete Next j Next i End If Next boundaryShape
' Display the result for this rotation MsgBox "With rotation " & stepAngle & " degrees, " & fitCount & " rectangles fit into the selected shapes." Next stepAngleEnd Sub
Function IsRectangleInside(minX As Double, minY As Double, maxX As Double, maxY As Double, boundaryShape As Shape) As Boolean ' This function checks if the rectangle's bounding box is within the boundary shape Dim inside As Boolean inside = True
Tips: Multiple Shapes: The code loops through all shapes in the selected range.Rectangle Rotation: It tests rectangle placement for every 15-degree rotation.Fit Check: The IsRectangleInside function checks Maxim Time Clock if the rotated rectangle fits within the boundary shape.
Hope that helps!
can you please show in coreldraw as how to do. i have selected the few shapes and run.... then lots of messages came but no result is shown
how you achieved this... video please
I made the drawing in the picture manually. I'm trying to create a macro to do this, but I don't have enough knowledge. That's why I wrote here to get help. I want the macro to place such squares inside the shapes in the graphic work. google translate