图形生成.bas

钢筋混凝土框架结构设计计算源程序

Attribute VB_Name = "Module10"
Option Explicit
DefInt I-K, M-N
DefSng L, X-Y
Public Const PI = 3.1416
Public Xmax, Ymax, Lmax
Dim qmax As Single, Pmax As Single
Dim B As Single
Sub 杆件图(Pict As PictureBox)
    Dim i, j, L, dL As Single
    Dim sinA As Single, cosA As Single
    Dim X1, Y1, x2, y2, Nd, Nd2
    Xmax = 0: Ymax = 0: Lmax = 0
    For i = 1 To Nodg
        If Xmax < XY(i, 1) Then Xmax = XY(i, 1)
        If Ymax < XY(i, 2) Then Ymax = XY(i, 2)
    Next i
    If Ymax > Xmax Then      '留边，上下左右居中
        dL = Xmax * 0.15
    Else
        dL = Ymax * 0.15
    End If
    Y1 = Ymax + 2 * dL
    X1 = Xmax + 2 * dL
    If Y1 / X1 > Pict.Height / Pict.Width Then
        x2 = (Y1 * Pict.Width / Pict.Height - Xmax) / 2
        Pict.Scale (-x2, Ymax + dL)-(Xmax + x2, -dL)
    Else
        y2 = (X1 * Pict.Height / Pict.Width - Ymax) / 2
        Pict.Scale (-dL, Ymax + y2)-(Xmax + dL, -y2)
    End If
    For i = 1 To Ncell                 ' 画杆件
        Call SetT(i, L, sinA, cosA, X1, Y1, x2, y2)
        If L > Lmax Then Lmax = L
        Pict.Line (X1, Y1)-(x2, y2), vbBlack
        If Form1.Check1.Value = 1 Then
            Pict.CurrentX = (X1 + x2) / 2
            Pict.CurrentY = (Y1 + y2) / 2
            Pict.ForeColor = vbRed
            Pict.Print Format(i, "##")
        End If
    Next i
    Pict.FillStyle = vbFSSolid
    Pict.FillColor = &HE0E0E0
    B = Xmax / 15
    For i = 1 To Kuashu + 1
        Call 固定支座(Pict, i)
    Next i
    For i = 1 To Nodg
        If Form1.Check2.Value = 1 Then
            Pict.CurrentX = XY(i, 1)
            Pict.CurrentY = XY(i, 2)
            Pict.ForeColor = &H8000&
            Pict.Print Format(i, "##")
        End If
    Next i
'    For i = 1 To Nodg                  '画支座
'        If XYM(i, 1) = "0" And XYM(i, 2) = "0" And XYM(i, 3) = "0" Then
'            Call 固定支座(Pict, i)
'        ElseIf XYM(i, 1) = "0" And XYM(i, 1) = "0" Then
'            Call X向铰支座(Pict, i)
'            Call Y向铰支座(Pict, i)
'        ElseIf XYM(i, 1) = "0" And XYM(i, 3) = "0" Then
'            Call X向不动的滑动支座(Pict, i)
'        ElseIf XYM(i, 2) = "0" And XYM(i, 3) = "0" Then
'            Call Y向不动的滑动支座(Pict, i)
'        ElseIf XYM(i, 2) = "0" Then
'            Call Y向铰支座(Pict, i)
'        ElseIf XYM(i, 1) = "0" Then
'            Call X向铰支座(Pict, i)
'        End If
'        If Form1.Check2.Value = 1 Then
'            Pict.CurrentX = XY(i, 1)
'            Pict.CurrentY = XY(i, 2)
'            Pict.ForeColor = &H8000&
'            Pict.Print Format(i, "##")
'        End If
'    Next i
'    For i = 1 To Ncell                '画铰结点
'        For j = 1 To 2
'            Nd = NGN(i, j)
'            If Nd < 0 Then
'                Nd = Abs(Nd)
'                If Neq(Nd, 3) = 0 Then
'                    pict.Circle (XY(Nd, 1), XY(Nd, 2)), b / 4
'                Else
'                    If j = 1 Then Nd2 = Abs(NGN(i, 2)) Else Nd2 = Abs(NGN(i, 1))
'                    x1 = XY(Nd, 1): y1 = XY(Nd, 2): x2 = XY(Nd2, 1): y2 = XY(Nd2, 2)
'                    If x1 > x2 Then x1 = x1 - b / 4 Else x1 = x1 + b / 4
'                    If y1 > y2 Then y1 = y1 - b / 4 Else y1 = y1 + b / 4
'                    pict.Circle (x1, y1), b / 4
'                End If
'            End If
'        Next j
'    Next i
End Sub
Sub 固定支座(Pict As PictureBox, ii As Integer)
    Dim i, j, X1, Y1, x2, y2
    Dim X, Y, j1, Ang As Single
    For i = 1 To Ncell
        For j = 1 To 2
            If NGN(i, j) = ii Then
                X1 = XY(Abs(NGN(i, j)), 1)
                Y1 = XY(Abs(NGN(i, j)), 2)
                If j = 1 Then j1 = 2 Else j1 = 1
                x2 = XY(Abs(NGN(i, j1)), 1)
                y2 = XY(Abs(NGN(i, j1)), 2)
                GoTo L
            End If
        Next j
    Next i
L:  If x2 <> X1 Then
        Ang = Atn((y2 - Y1) / (x2 - X1)) - PI / 2 '计算垂直角度
    Else
        Ang = 0
    End If
    Call 地基(X1, Y1, Ang, Pict)
End Sub
Sub X向铰支座(Pict As PictureBox, ii As Integer)
    Dim i, j, X1, Y1, x2, y2
    X1 = XY(ii, 1)
    Y1 = XY(ii, 2)
    y2 = Y1
    If X1 < Xmax Then
        x2 = X1 - B * 1.2
        Call 地基(x2, y2, -PI / 2, Pict)
    Else
        x2 = X1 + B * 1.2
        Call 地基(x2, y2, PI / 2, Pict)
    End If
    Pict.Line (X1, Y1)-(x2, y2)
    Pict.Circle (X1, Y1), B / 4
    Pict.Circle (x2, y2), B / 4
End Sub

Sub Y向铰支座(Pict As PictureBox, ii As Integer)
    Dim i, j, X1, Y1, x2, y2
    X1 = XY(ii, 1)
    x2 = X1
    Y1 = XY(ii, 2)
    If Y1 < Ymax / 2 Then
        y2 = Y1 - B * 1.2
        Call 地基(x2, y2, 0, Pict)
    Else
        y2 = Y1 + B * 1.2
        Call 地基(x2, y2, PI, Pict)
    End If
    Pict.Line (X1, Y1)-(x2, y2)
    Pict.Circle (X1, Y1), B / 4
    Pict.Circle (x2, y2), B / 4
End Sub

Sub 地基(X As Single, Y As Single, Ang As Single, Pict As PictureBox)
    Dim i, j, X1, Y1, x2, y2
    X1 = X + B * Cos(Ang)
    x2 = X - B * Cos(Ang)
    Y1 = Y + B * Sin(Ang)
    y2 = Y - B * Sin(Ang)
    Pict.ForeColor = vbBlack
    Pict.Line (X1, Y1)-(x2, y2)
    For i = 0 To 3  '移点
        X1 = X + (B * 0.75 - i * B / 2) * Cos(Ang)
        Y1 = Y + (B * 0.75 - i * B / 2) * Sin(Ang)
        x2 = X1 + B / 1.5 * Cos(Ang - PI * 3 / 4)
        y2 = Y1 + B / 1.5 * Sin(Ang - PI * 3 / 4)
        Pict.Line (X1, Y1)-(x2, y2)
    Next i
End Sub
Sub X向不动的滑动支座(Pict As PictureBox, i As Integer)

End Sub
Sub Y向不动的滑动支座(Pict As PictureBox, i As Integer)

End Sub
Sub 荷载图(Pict As PictureBox)
    Dim i, j, L, dL As Single, Cq As Single, Cp As Single
    Dim sinA As Single, cosA As Single, aa As Single
    Dim X1, Y1, x2, y2, Nd, Nd2, xx1, yy1, xx2, yy2, y_, yy_, X, Y
    Pict.ForeColor = vbBlue
    qmax = 0
    Pmax = 0
    aa = 0
    For i = 1 To Ncell
        Select Case Ld(i).Pq
            Case "q", "Q"         'qmax-最大荷载
                If Ld(i).s > qmax Then
                    qmax = Ld(i).s
                End If
            Case "p", "P"
                If Ld(i).s > Pmax Then
                    Pmax = Ld(i).s
                End If
            Case "T", "t"
                If Ld(i).s > qmax Then
                    qmax = Ld(i).s
                End If
            Case Else
        End Select
    Next i
    For i = 1 To Nodg   '改,加上节点荷载的比较
       For j = 1 To 2
         If Abs(Val((XYM(i, j)))) > Pmax Then Pmax = Abs(Val((XYM(i, j))))
    Next j, i
    If qmax = 0 Then
        Cq = 1
    Else
        Cq = Lmax / (qmax * 6)   'qmax与Lmax/10等长
    End If
    If Pmax = 0 Then
        Cp = 1
        Else
        Cp = Lmax / (Pmax * 3)      'pmax与lmax/3等长
    End If
    For i = 1 To Ncell                 ' 画杆件
        Call SetT(i, L, sinA, cosA, X1, Y1, x2, y2)
        Select Case Ld(i).Pq
            Case "q", "Q"
                y_ = Ld(i).s * Cq '荷载竖标长，dL-竖标间隔
                dL = Ld(i).Po / Int(Ld(i).Po * 15 / Lmax)
                For X = 0 To Ld(i).Po + 0.1 Step dL
                    坐标变换 X, 0, xx1, yy1, X1, Y1, cosA, sinA
                    坐标变换 X, y_, xx2, yy2, X1, Y1, cosA, sinA
                    Pict.Line (xx1, yy1)-(xx2, yy2)
                    均布箭头 Pict, X, X1, Y1, cosA, sinA
                Next X
                坐标变换 0, y_, xx1, yy1, X1, Y1, cosA, sinA
                坐标变换 Ld(i).Po, y_, xx2, yy2, X1, Y1, cosA, sinA
                Pict.Line (xx1, yy1)-(xx2, yy2)
            Case "p", "P"
                y_ = Ld(i).s * Cq  '有所改动
                X = Ld(i).Po
                坐标变换 X, 0, xx1, yy1, X1, Y1, cosA, sinA
                坐标变换 X, y_, xx2, yy2, X1, Y1, cosA, sinA
                Pict.Line (xx1, yy1)-(xx2, yy2)
                均布箭头 Pict, X, X1, Y1, cosA, sinA
            Case "T", "t"
                y_ = Ld(i).s * Cq: aa = Ld(i).Po
                dL = L / 15
                For X = 0 To L + 0.1 Step dL
                    If X <= aa Then
                        yy_ = y_ * X / aa
                    ElseIf X < L - aa Then
                        yy_ = y_
                    Else
                        yy_ = y_ * (L - X) / aa
                    End If
                    坐标变换 X, 0, xx1, yy1, X1, Y1, cosA, sinA
                    坐标变换 X, yy_, xx2, yy2, X1, Y1, cosA, sinA
                    Pict.Line (xx1, yy1)-(xx2, yy2)
                    If X > dL Or X < L - dL Then
                        均布箭头 Pict, X, X1, Y1, cosA, sinA
                    End If
                Next X
                坐标变换 0, 0, xx1, yy1, X1, Y1, cosA, sinA
                坐标变换 aa, y_, xx2, yy2, X1, Y1, cosA, sinA
                Pict.Line (xx1, yy1)-(xx2, yy2)
                坐标变换 aa, y_, xx1, yy1, X1, Y1, cosA, sinA
                坐标变换 L - aa, y_, xx2, yy2, X1, Y1, cosA, sinA
                Pict.Line (xx1, yy1)-(xx2, yy2)
                坐标变换 L - aa, y_, xx1, yy1, X1, Y1, cosA, sinA
                坐标变换 L, 0, xx2, yy2, X1, Y1, cosA, sinA
                Pict.Line (xx1, yy1)-(xx2, yy2)
            Case Else
        End Select
    Next i
    Pict.ForeColor = vbMagenta  '画节点荷载
    For i = 1 To Nodg
        X1 = XY(i, 1)
        Y1 = XY(i, 2)
        If Val(XYM(i, 1)) <> 0 Then
            x2 = X1 - Abs(XYM(i, 1)) * Cq / 10 '有所改动
            If 当前荷载 = "地震作用" Then x2 = X1 - Abs(XYM(i, 1)) * Cq / 80
            y2 = Y1
            Pict.Line (X1, Y1)-(x2, y2)
            If XYM(i, 1) > 0 Then
                箭头 Pict, X1, Y1, 0
            Else
                箭头 Pict, x2, y2, PI
            End If
        End If
        If Val(XYM(i, 2)) <> 0 Then
            y2 = Y1 + Abs(XYM(i, 2)) * Cq  '有所改动
            x2 = X1
            Pict.Line (X1, Y1)-(X1, y2)
            If XYM(i, 2) > 0 Then
                箭头 Pict, x2, y2, PI / 2
            Else
                箭头 Pict, X1, Y1, -PI / 2
            End If
        End If
        If Val(XYM(i, 3)) <> 0 Then
        End If
    Next i
End Sub
'单元坐标转化为整体坐标
Sub 坐标变换(ByVal X As Single, ByVal Y As Single, xx As Single, yy As Single, ByVal X1 As Single, ByVal Y1 As Single, ByVal cosA As Single, ByVal sinA As Single)
    xx = X1 + X * cosA - Y * sinA
    yy = Y1 + X * sinA + Y * cosA
End Sub

Sub 均布箭头(Pict As PictureBox, ByVal X As Single, ByVal X1 As Single, ByVal Y1 As Single, ByVal cosA As Single, ByVal sinA As Single)
    Dim A As Single, dL As Single, x0, y0, xx1, yy1, xx2, yy2
    A = 15 / 180 * PI: dL = Lmax / 25
    坐标变换 X, 0, xx1, yy1, X1, Y1, cosA, sinA
    x0 = X + dL * Sin(A): y0 = dL * Cos(A)
    坐标变换 x0, y0, xx2, yy2, X1, Y1, cosA, sinA
    Pict.Line (xx1, yy1)-(xx2, yy2)
    x0 = X - dL * Sin(A)
    坐标变换 x0, y0, xx2, yy2, X1, Y1, cosA, sinA
    Pict.Line (xx1, yy1)-(xx2, yy2)
End Sub

Sub 箭头(Pict As PictureBox, ByVal X1 As Single, ByVal Y1 As Single, ByVal Ang As Single)
    Dim A As Single, dL As Single, x0, y0, xx1, yy1, xx2, yy2
    Dim ang1 As Single, ang2 As Single
    A = 20 / 180 * PI: dL = Lmax / 12
    ang1 = Ang + PI - A
    ang2 = Ang + PI + A
    Pict.Line (X1, Y1)-(X1 + dL * Cos(ang1), Y1 + dL * Sin(ang1))
    Pict.Line (X1, Y1)-(X1 + dL * Cos(ang2), Y1 + dL * Sin(ang2))
End Sub