Outro VBA para automatizar tarefa AutoCAD

[btzywoo]

Boa tarde,

 

Meu projeto seria a criação de múltiplas plaquinhas em um mesmo DWG.

Consegui criar o script para adicionar o Mtext conforme a segunda coluna do Excel, e quantidade de vezes que se repete conforme a terceira coluna.

 

Para finalizar preciso criar esse retângulo com o Mtext centralizado, mas não estou conseguindo, ele é criado mas não fica centralizado. O retângulo precisa ser 60x40.

 

 

Em anexo deixei minha planilha e dwg.

 

Sub UpdateAutoCADMTextAndCreateCopies()

    ' Defina a referência ao AutoCAD
    Dim AcadApp As Object
    On Error Resume Next
    Set AcadApp = GetObject(, "AutoCAD.Application")
    If AcadApp Is Nothing Then
        Set AcadApp = CreateObject("AutoCAD.Application")
    End If
    On Error GoTo 0

    ' Defina a referência à planilha do Excel
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Plan1") ' Altere para o nome da sua planilha

    ' Abra o desenho do AutoCAD
    Dim AcadDoc As Object
    Set AcadDoc = AcadApp.Documents.Open(ws.Cells(1, "A").Value)

    ' Percorra as células na coluna B (novo valor mtext) e C (quantidade de cópias)
    Dim i As Long
    For i = 1 To ws.Cells(ws.Rows.Count, "B").End(xlUp).Row

        ' Crie as cópias do mtext
        Dim j As Long
        For j = 1 To ws.Cells(i, "C").Value

            ' Crie um novo mtext
            Dim insertionPoint(0 To 2) As Double
            insertionPoint(0) = 2469 + (i - 1) * 100 ' X coordinate
            insertionPoint(1) = 1390 + (j - 1) * 100 ' Y coordinate
            insertionPoint(2) = 0 ' Z coordinate
            
            Dim AcadEntity As Object
            Set AcadEntity = AcadDoc.ModelSpace.AddMText(insertionPoint, 54, ws.Cells(i, "B").Value)
            AcadEntity.StyleName = "Stencil"
            AcadEntity.Height = 4.25
            
            ' Crie um retângulo em volta do mtext
            Dim lowerLeft(0 To 2) As Double
            lowerLeft(0) = insertionPoint(0) - 30 ' X coordinate
            lowerLeft(1) = insertionPoint(1) - 20 ' Y coordinate
            lowerLeft(2) = 0 ' Z coordinate
            
            Dim upperRight(0 To 2) As Double
            upperRight(0) = insertionPoint(0) + 30 ' X coordinate
            upperRight(1) = insertionPoint(1) + 20 ' Y coordinate
            upperRight(2) = 0 ' Z coordinate
            
            Dim points(0 To 9) As Double
            points(0) = lowerLeft(0): points(1) = lowerLeft(1)
            points(2) = upperRight(0): points(3) = lowerLeft(1)
            points(4) = upperRight(0): points(5) = upperRight(1)
            points(6) = lowerLeft(0): points(7) = upperRight(1)
            points(8) = lowerLeft(0): points(9) = lowerLeft(1)
            
            Dim AcadRectangle As Object
            Set AcadRectangle = AcadDoc.ModelSpace.AddLightWeightPolyline(points)
            AcadRectangle.Closed = True
        Next j

    Next i

    ' Salve o desenho do AutoCAD
    AcadDoc.Save
    AcadDoc.Close SaveChanges:=True

End Sub

 

Dados.7z