Excel VBA：添加工字钢截面
基于已知尺寸绘制工字钢截面图的Excel函数重点是与表值匹配的截面积。
请注意，基于我的知识和使用，excel中的I-Beam数据收集，
我对任何错误或遗漏信息概不负责
Phh公司
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
对于我来说，看看WiseySteelShapes吧
谢谢你的信息，
欢呼
Phh公司
页:
[1]