[CADVBA]计算板材重量.doc

原创-CAD/VBA计算板材重量2009年12月29日 星期二 19:21 计算板材重量，输入板材厚度，材料密度，然后选取轮廓内一点就可以了，程序自动搜索创建边界，计算质量。 相关程序见： /suddenday/blog/item/b74ab8eccdfc5a4679f05530.html /suddenday/blog/item/97d14f32a11504f21b4cff6b.html代码如下 - By:忽又一天 /suddenday/Public Sub PlateKg() 计算板材重量 + + Code By icy/忽又一天 + + Email: + + Q Q: 365052003 + + Blog: Http://suddenday/ + + On Error Resume Next Dim Pnt As Variant Dim strPnt As String Dim i As Integer, J As Integer Dim ObjArea As Double, tmpAreas() As Double, PlateWeight As Double Dim txtObj As AcadEntity Dim BoundaryObj As Variant Dim CurScale As Double CurScale = GetVariable(DIMSCALE) Dim PriCount As Long PriCount = ThisDrawing.ModelSpace.count Dim ObjType As Integer ObjType = ThisDrawing.GetVariable(HPBOUND) Dim CurLayer As String CurLayer = ThisDrawing.ActiveLayer.Name Dim CurColor As String CurColor = ThisDrawing.GetVariable(CECOLOR) Dim AreaLayer As AcadLayer Set AreaLayer = ThisDrawing.Layers.Add(Wee_Area) AreaLayer.color = 11 ThisDrawing.ActiveLayer = AreaLayer Dim CurSnapMode As Integer CurSnapMode = ThisDrawing.GetVariable(OSMODE) ThisDrawing.ObjectSnapMode = False ThisDrawing.SetVariable CECOLOR, BYLAYER Dim pThickness As String pThickness = ThisDrawing.Utility.GetString(0, vbCrLf & 输入板材厚度(mm)：) If Err.Number 0 Then Err.Clear GoTo ErrorHandler End If If Val(pThickness) = 0 Then pThickness = 10 Else pThickness = Val(pThickness) End If Dim Mdensity As String Mdensity = ThisDrawing.Utility.GetString(0, vbCrLf & 输入材料密度(x103 kg/m3)：) If Err.Number 0 Then Err.Clear GoTo ErrorHandler End If If Val(Mdensity) = 0 Then Mdensity = 7.85 Else Mdensity = Val(Mdensity) End If Dim ifIsland As String ifIsland = ThisDrawing.Utility.GetString(0, vbCrLf & 是否除去内部孤岛 Yes/No：) If Err.Number 0 Then Err.Clear GoTo ErrorHandler End If If UCase(ifIsland) = NO Or UCase(ifIsland) = N Then ifIsland = 0 Else ifIsland = 1 End If Dim objName As String Dim objLayer As String Dim PreCount As Long, CurCount As Long Do While True ObjArea = 0 PlateWeight = 0 Pnt = ThisDrawing.Utility.GetPoint(, vbCrLf & 拾取对象内部一点：) If Err.Number 0 Then Err.Clear GoTo ErrorHandler End If ReDim Preserve Pnt(0 To 2) As Double strPnt = Pnt(0) & , & Pnt(1) With ThisDrawing PreCount = ModelSpace.count ThisDrawing.SetVariable HPBOUND, 0 SendCommand Chr(3) & Chr(3) & -boundary & strPnt & & If PreCount = ModelSpace.count Then ThisDrawing.SetVariable HPBOUND, 1 SendCommand Chr(3) & Chr(3) & -boundary & strPnt & & End If CurCount = ModelSpace.count Select Case CurCount - PreCount Case Is 1 ReDim tmpAreas(0 To CurCount - PreCount - 1) As Double For i = 0 To CurCount - PreCount - 1 Set BoundaryObj = ModelSpace.Item(PreCount + i) If (BoundaryObj.ObjectName = AcDbRegion) Or (BoundaryObj.ObjectName = AcDbPolyline) And (BoundaryObj.Layer = Wee_Area) Then tmpAreas(i) = BoundaryObj.Area End If Next NumSortAZ tmpAreas, 0, UBound(tmpAreas) ObjArea = tmpAreas(UBound(tmpAreas) If CBool(ifIsland) Then For i = 0 To UBound(tmpAreas) - 1 ObjArea = ObjArea - tmpAreas(i) Next End If Case Is 0 Then PlateWeight = ObjArea * CDbl(pThickness) * CDbl(Mdensity) / 1000000 Utility.Prompt vbCrLf & 区域面积： & Format(ObjArea, 0.000) & (mm4) 厚度： & pThickness & (mm) 密度： & _ Mdensity & x103 kg/m3 质量： & Format(PlateWeight, 0.000) & (kg) & vbCrLf Set txtObj = ModelSpace.AddText(Format(PlateWeight, 0.000) & (kg), Pnt, 3.5 * CurScale) txtObj.Layer = 0 txtObj.TrueColor = AreaLayer.TrueColor End If End With Loop ErrorHandler: Dim ObjCount As Double ObjCount = ThisDrawing.ModelSpace.count - PriCount - 1 Dim ssetObj As AcadSelectionSet, EntObj As AcadEntity ReDim ssobjs(0 To ObjCount) As AcadEntity For i = 0 To ObjCount Set ssobjs(i) = ThisDrawing.ModelSpace.Item(PriCount + i) Next Set ssetObj = ThisDrawing.SelectionSets.Add(AreaSets) ssetObj.AddItems ssobjs For Each EntObj In ssetObj If EntObj.Layer = Wee_Area Then EntObj.Delete Next ssetObj.Delete ThisDrawing.ActiveLayer = ThisDrawing.Layers.I