[编程交流] Excel VBA：添加工字钢截面

Option Explicit
Sub AddIbeamToDwg()
    On Error Resume Next
    
    'Connect to AutoCad application
    Dim acadApp As AcadApplication
    Set acadApp = GetObject(, "AutoCad.Application")
    If Err <> 0 Then
        Err.Clear
        MsgBox "Open the AutoCad application first and then execute!"
        Exit Sub
    End If
    
    'Connect to AutoCad drawing document
    Dim acadDoc As AcadDocument
    Set acadDoc = acadApp.ActiveDocument
    
    'Call excel to get data
    Dim excel As Object
    Set excel = GetObject(, "Excel.Application")
    Dim excelSheet As Object
    Set excelSheet = excel.ActiveWorkbook.Sheets(ActiveSheet.Name)
    
    'Setup i-beam variables
    Dim ibStr As String
    Dim insertionPoint(0 To 2) As Double
    Dim height As Double
    Dim ibDepth As Double
    Dim ibWidth As Double
    Dim ibtw As Double
    Dim ibtf As Double
    Dim ibSc As Double
    
    Dim dblPi As Double
    dblPi = WorksheetFunction.Pi()
    
    Dim rw As Integer
    rw = ActiveCell.Row
    
    'Check if row & 1st cell empty then stop
    If ActiveCell.Value = 0 Or excelSheet.Cells(rw, 1) = 0 Then
        MsgBox "No I-Beam data selected, please select row that contains data!"
        Exit Sub
        End If
        
    If excelSheet.Cells(rw, 1) Then
    ibStr = excelSheet.Cells(rw, 2)
    ibDepth = excelSheet.Cells(rw, 3)
    ibWidth = excelSheet.Cells(rw, 4)
    ibtw = excelSheet.Cells(rw, 5)
    ibtf = excelSheet.Cells(rw, 6)
    ibSc = excelSheet.Cells(rw, 7)
 
    End If
    
      Dim ibeamName As AcadText
      Dim plineObj As AcadLWPolyline
      Dim plineObj1 As AcadLWPolyline
      Dim ibRad As Double
      Dim ibRad1 As Double
      ibRad = 0
      
      Dim points(0 To 37) As Double
      'Create a temporary lwPolyline for calculating the area
      '4 corner area ratio = 3.65979236632549
      points(0) = 0: points(1) = ibDepth
      points(2) = (ibWidth / 2): points(3) = ibDepth
      points(4) = (ibWidth / 2): points(5) = (ibDepth - ibtf)
      points(6) = (ibtw / 2 + ibRad): points(7) = (ibDepth - ibtf)
      points(8) = (ibtw / 2): points(9) = (ibDepth - (ibtf + ibRad))
      points(10) = (ibtw / 2): points(11) = (ibtf + ibRad)
      points(12) = (ibtw / 2 + ibRad): points(13) = ibtf
      points(14) = (ibWidth / 2): points(15) = ibtf
      points(16) = (ibWidth / 2): points(17) = 0
      points(18) = 0: points(19) = 0
      points(20) = (ibWidth / 2) * (-1): points(21) = 0
      points(22) = (ibWidth / 2) * (-1): points(23) = ibtf
      points(24) = (ibtw / 2 + ibRad) * (-1): points(25) = ibtf
      points(26) = (ibtw / 2) * (-1): points(27) = (ibtf + ibRad)
      points(28) = (ibtw / 2) * (-1): points(29) = (ibDepth - (ibtf + ibRad))
      points(30) = ((ibtw / 2) + ibRad) * (-1): points(31) = (ibDepth - ibtf)
      points(32) = (ibWidth / 2) * (-1): points(33) = (ibDepth - ibtf)
      points(34) = (ibWidth / 2) * (-1): points(35) = ibDepth
      points(36) = 0: points(37) = ibDepth
      Set plineObj = acadDoc.ModelSpace.AddLightWeightPolyline(points)
      plineObj.Closed = True
      'ibArea = plineObj.Area
      ibRad1 = VBA.Sqr(((ibSc - plineObj.Area) * 3.65979236632549) / dblPi)
      plineObj.Delete
            
      Dim vertices(0 To 37) As Double
      
      'I-beam drawn after calculate radius base on lwPolyline above
      vertices(0) = 0: vertices(1) = ibDepth
      vertices(2) = (ibWidth / 2): vertices(3) = ibDepth
      vertices(4) = (ibWidth / 2): vertices(5) = (ibDepth - ibtf)
      vertices(6) = (ibtw / 2 + ibRad1): vertices(7) = (ibDepth - ibtf)
      vertices(8) = (ibtw / 2): vertices(9) = (ibDepth - (ibtf + ibRad1))
      vertices(10) = (ibtw / 2): vertices(11) = (ibtf + ibRad1)
      vertices(12) = (ibtw / 2 + ibRad1): vertices(13) = ibtf
      vertices(14) = (ibWidth / 2): vertices(15) = ibtf
      vertices(16) = (ibWidth / 2): vertices(17) = 0
      vertices(18) = 0: vertices(19) = 0
      vertices(20) = (ibWidth / 2) * (-1): vertices(21) = 0
      vertices(22) = (ibWidth / 2) * (-1): vertices(23) = ibtf
      vertices(24) = (ibtw / 2 + ibRad1) * (-1): vertices(25) = ibtf
      vertices(26) = (ibtw / 2) * (-1): vertices(27) = (ibtf + ibRad1)
      vertices(28) = (ibtw / 2) * (-1): vertices(29) = (ibDepth - (ibtf + ibRad1))
      vertices(30) = ((ibtw / 2) + ibRad1) * (-1): vertices(31) = (ibDepth - ibtf)
      vertices(32) = (ibWidth / 2) * (-1): vertices(33) = (ibDepth - ibtf)
      vertices(34) = (ibWidth / 2) * (-1): vertices(35) = ibDepth
      vertices(36) = 0: vertices(37) = ibDepth
      
      'Create a light weight Polyline object and draw in AutoCAD application
      Set plineObj1 = acadDoc.ModelSpace.AddLightWeightPolyline(vertices)
      plineObj1.Closed = True
      
      'Add a bulge to segment 3
      plineObj1.SetBulge 3, Tan(dblPi / 8)
      plineObj1.SetBulge 5, Tan(dblPi / 8)
      plineObj1.SetBulge 12, Tan(dblPi / 8)
      plineObj1.SetBulge 14, Tan(dblPi / 8)
      
      insertionPoint(0) = 0: insertionPoint(1) = -2: insertionPoint(2) = 0
      height = 0.5
      
      Set ibeamName = acadDoc.ModelSpace.AddText(ibStr, insertionPoint, height)
      ibeamName.Alignment = acAlignmentCenter
      
      ibeamName.Update
      plineObj1.Update
   
End Sub