田草博客

互联网田草博客


网友交流QQ群:11740834 需注明申请加入原因

微信 公众号:ByCAD

邮箱:tiancao1001x126.com
ByCAD,微信公众号
首页 | 普通 | 电脑 | AutoCAD | VB/VB.NET | FLash | 结构 | 建筑 | 电影 | BIM | 规范 | 软件 | ID
-随机-|-分布-
-博客论坛-|-﨣﨤﨧﨨-
-网站导航-|-规范下载-
-BelovedFLash欣赏-

用户登陆
用户:
密码:
 

站点日历
73 2024 - 3 48
     12
3456789
10111213141516
17181920212223
24252627282930
31


站点统计

最新评论



从PKPM钢筋标注比如"2%%13112"中分析出钢筋根数S1,级别S2,直径S3,面积S4 VBA平法梁配筋率分析
未知 VBA分析梁平法标注   [ 日期:2008-11-10 ]   [ 来自:本站原创 ]  HTML
'分析梁平法标注
Sub GetLPF()
    Dim ssText As AcadSelectionSet          '选择集
    Dim acText As AcadText                  '选择集中的文本
    
    Dim Txt As String '文本的字符串
    
    Dim x As Integer '字符串中是否含有乘号
    Dim a As Integer '字符串中是否含有@符号
    Dim Temp As Integer
    Dim Temp1 As Integer
    Dim Temp2 As String
    Dim Temp3 As String
    Dim Temp4 As String
    Dim LLX As String
    Dim LB As Integer
    Dim LG As Integer
    Dim LK As Integer
    Dim GJZJ As Integer
    Dim GJJB As Integer
    Dim GJZS As Integer
    Dim GJJMQ As Integer
    Dim GJFJMQ As Integer
    Dim N1 As Integer
    Dim N2 As Integer
    Dim N3 As Integer
    Dim N4 As Long
    Dim G1 As Integer
    Dim G2 As Integer
    Dim G3 As Integer
    Dim G4 As Long
    Dim BG As Double
    Dim AT As Long
    Dim AB As Long
    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") '标志他是平法标注的第一行
        a = InStr(Txt, "@") ' 平法标注的第二行
        Temp2 = Left(Txt, 1)
        'MsgBox X
        If x > 0 Then
           Temp = InStr(Txt, "(")
           Temp1 = InStr(Txt, ")")
           LLX = Left(Txt, Temp - 1)
           MsgBox LLX
           Select Case LLX
           Case "KL"
                MsgBox "框架梁"
           Case "LL"
                MsgBox "连梁"
           Case "L"
                MsgBox "梁"
           Case "KZL"
                MsgBox "框支梁"
           Case "WKL"
                MsgBox "屋面框架梁"
           Case "QZL"
                MsgBox "墙支梁"
           Case "JZL"
                MsgBox "井字梁"
           Case "XL"
                MsgBox "悬挑梁"
           End Select
           
           LB = Val(Mid(Txt, Temp1 + 1, x - Temp1))
           MsgBox "梁宽" & LB
           LG = Val(Mid(Txt, x + 1))
           MsgBox "梁高" & LG '
            If Mid(Txt, Temp1 - 1, 1) = "A" Then
                LK = Mid(Txt, Temp + 1, Temp1 - Temp - 2)
                MsgBox LK & "跨一端悬挑"
            ElseIf Mid(Txt, Temp1 - 1, 1) = "B" Then
                LK = Mid(Txt, Temp + 1, Temp1 - Temp - 2)
                MsgBox LK & "跨二端悬挑"
            Else
                LK = Mid(Txt, Temp + 1, Temp1 - Temp - 1)
                MsgBox LK & "跨"
            End If
        End If
        If a > 0 Then
           GJZJ = Val(Mid(Txt, 6, a - 6))
           MsgBox "箍筋直径" & GJZJ
           If Mid(Txt, 3, 3) = "130" Then
            GJJB = 1
           ElseIf Mid(Txt, 3, 3) = "131" Then
            GJJB = 2
           ElseIf Mid(Txt, 3, 3) = "132" Then
            GJJB = 3
           End If
           MsgBox "箍筋级别" & GJJB
           Temp = InStr(Txt, "(")
           Temp1 = InStr(Txt, "/")
           
           If Temp = 0 Then
              GJZS = 2
              If Temp1 <> 0 Then
                 GJJMQ = Val(Mid(Txt, a + 1, Temp1 - a))
                 GJFJMQ = Val(Mid(Txt, Temp1 + 1))
              Else
                 GJJMQ = Val(Mid(Txt, a + 1))
                 GJFJMQ = GJJMQ
              End If
           Else
              GJZS = Val(Right(Txt, 2))
              If Temp1 <> 0 Then
                 GJJMQ = Val(Mid(Txt, a + 1, Temp1 - a))
                 GJFJMQ = Val(Mid(Txt, Temp1 + 1, Temp - Temp1 - 1))
              Else
                 GJJMQ = Val(Mid(Txt, a + 1, Temp - a - 1))
                 GJFJMQ = GJJMQ
              End If
           End If
           MsgBox "箍筋肢数" & GJZS
           MsgBox "箍筋加密区" & GJJMQ
           MsgBox "箍筋非加密器" & GJFJMQ
        End If
        If Temp2 = "N" Then '受扭钢筋
           Txt = Right(Txt, Len(Txt) - 1)
           GetSteels Txt, N1, N2, N3, N4
           MsgBox "抗扭钢筋根数" & N1
           MsgBox "抗扭钢筋级别" & N2
           MsgBox "抗扭钢筋直径" & N3
           MsgBox "抗扭钢筋面积" & N4
        ElseIf Temp2 = "G" Then '腰筋
           Txt = Right(Txt, Len(Txt) - 1)
           GetSteels Txt, G1, G2, G3, G4
           MsgBox "构造纵筋根数" & G1
           MsgBox "构造纵筋级别" & G2
           MsgBox "构造纵筋直径" & G3
           MsgBox "构造纵筋面积" & G4
        ElseIf Temp2 = "(" Then '标高
           Txt = Right(Txt, Len(Txt) - 1)
           BG = Val(Txt)
           MsgBox "梁的相当标高" & BG
        Else '梁纵筋
           If x = 0 And a = 0 Then
                Temp = InStr(Txt, ";")
                If Temp > 0 Then
                    Temp3 = Left(Txt, Temp - 1)
                    Temp4 = Mid(Txt, Temp + 1)
                    Do
                       Temp1 = InStr(Temp3, "%")
                       If Temp1 = 0 Then Exit Do
                       AT = Int(Val(Mid(Temp3, Temp1 - 1, 1)) * Val(Mid(Temp3, Temp1 + 5, 2)) ^ 2) * 3.14 / 4 + AT
                       Temp3 = Mid(Temp3, Temp1 + 8)
                    Loop
                    MsgBox "上部钢筋面积" & AT
                    Do
                       Temp1 = InStr(Temp4, "%")
                       If Temp1 = 0 Then Exit Do
                       AB = Int(Val(Mid(Temp4, Temp1 - 1, 1)) * Val(Mid(Temp4, Temp1 + 5, 2)) ^ 2) * 3.14 / 4 + AB
                       Temp4 = Mid(Temp4, Temp1 + 8)
                    Loop
                    MsgBox "下部钢筋面积" & AB
                 Else
                    Temp3 = Txt
                    Do
                       Temp1 = InStr(Temp3, "%")
                       If Temp1 = 0 Then Exit Do
                       AT = Int(Val(Mid(Temp3, Temp1 - 1, 1)) * Val(Mid(Temp3, Temp1 + 5, 2)) ^ 2) * 3.14 / 4 + AT
                       Temp3 = Mid(Temp3, Temp1 + 8)
                    Loop
                    MsgBox "上部钢筋面积" & AT
                 End If
            End If
        End If
    Next i
        '删除选择集
    ThisDrawing.SelectionSets.item("Text").Delete
End Sub


[本日志由 tiancao1001 于 2008-11-10 05:35 PM 编辑]


引用这个评论 tiancao1001 于 2010-02-26 06:57 PM 发表评论: 
看来你不懂编程,你只能用现成的软件了,如果有兴趣你可以下载我的田草结构工具箱

引用这个评论 ivi 于 2010-02-23 11:41 PM 发表评论: 
请问下这个源码应该怎么使用?    

发表评论 - 不要忘了输入验证码哦!
作者: 用户:  密码:   注册? 验证:  防止恶意留言请输入问题答案:2*4=?  
评论:

禁止表情
禁止UBB
禁止图片
识别链接
识别关键字

字体样式 文字大小 文字颜色
插入粗体文本 插入斜体文本 插入下划线
左对齐 居中对齐 右对齐
插入超级链接 插入邮件地址 插入图像
插入 Flash 插入代码 插入引用
插入列表 插入音频文件 插入视频文件
插入缩进符合
点击下载按钮 下标 上标
水平线 简介分割标记
表  情
 
Tiancao Blog All Rights Reserved 田草博客 版权所有
Copyright ©