'平法梁配筋率分析 Sub GetLPJL() Dim ssText As AcadSelectionSet '选择集 Dim acText As AcadText '选择集中的文本 Dim Txt As String '文本的字符串 Dim X As Integer '字符串中是否含有乘号 Dim Temp As Integer Dim Temp1 As Integer Dim Temp2 As String Dim Temp3 As String Dim Temp4 As String Dim LK As Integer Dim LG As Integer Dim AT As Long Dim AB As Long Dim LH As String Dim i As Integer Dim j As Integer On Error Resume Next Set ssText = ThisDrawing.SelectionSets.Add("Text") '定义过滤机制 Dim filterType(0) As Integer Dim filterData(0) As Variant filterType(0) = 0 filterData(0) = "TEXT" '提示用户在屏幕上选择文字 ssText.SelectOnScreen filterType, filterData N = ssText.Count - 1 For i = 0 To N Set acText = ssText.item(i) Txt = acText.textString X = InStr(Txt, "x") '标志他是平法标注的第一行 Temp2 = Left(Txt, 1) 'MsgBox X If X > 0 Then Temp = InStr(Txt, "(") Temp1 = InStr(Txt, ")") LH = Left(Txt, Temp - 1) LK = Val(Mid(Txt, Temp1 + 1, X - Temp1)) 'MsgBox "梁宽" & LK LG = Val(Mid(Txt, X + 1)) 'MsgBox "梁高" & LG ' End If '平法标注中只会存在一行第一个字符串是数字的。 If IsNumeric(Temp2) Then Temp = InStr(Txt, ";") If Temp > 0 And j = 0 Then '假如存在分号且为第一个,把他的上部和下部钢筋全部分析出来 Temp3 = Left(Txt, Temp - 1) Temp4 = Mid(Txt, Temp + 1) AT = GetSteels2(Temp3) AB = GetSteels2(Temp4) ElseIf Temp = 0 And j = 0 Then '没有分号,且为第一个,肯定是上部钢筋 AT = GetSteels2(Txt) ElseIf Temp = 0 And j = 1 Then '没有分号,且是第二个,肯定是下部钢筋 AB = GetSteels2(Txt) ElseIf Temp >= 0 And j = 1 Then '有分号其是第二个,只用分析其下部钢筋。 Temp3 = Left(Txt, Temp - 1) Temp4 = Mid(Txt, Temp + 1) AB = GetSteels2(Temp4) End If j = j + 1 End If Next i 'MsgBox "上部钢筋面积" & AT 'MsgBox "上部钢筋配筋率" & Format(AT / LK / LG * 100, "0.0000") 'MsgBox "下部钢筋面积" & AB 'MsgBox "下部钢筋配筋率" & Format(AB / LK / LG * 100, "0.0000") 'MsgBox "上下钢筋面积比" & Format(AT / AB, "0.00") Dim P As Variant P = ThisDrawing.Utility.GetPoint(, "文字插入点") Dim S(5) As String S(0) = LH '梁编号 S(1) = "上部钢筋面积" & AT S(2) = "上部钢筋配筋率" & Format(AT / LK / LG * 100, "0.0000") S(3) = "下部钢筋面积" & AB S(4) = "下部钢筋配筋率" & Format(AB / LK / LG * 100, "0.0000") S(5) = "上下钢筋面积比" & Format(AT / AB, "0.00") AddTexts S, P, 300 '删除选择集 ThisDrawing.SelectionSets.item("Text").Delete End Sub |