zlhcform.frm

计算力学特性曲线

'确定档距个数
Sub DangJuNumber()
    '确定档距个数
    Number = Excelsheet.Cells(62, 27)
End Sub


'读取代表档距及相应代表档距下的张力、弧垂
Sub DuQuShuJu()
On Error Resume Next
    If Conductor = "导线：" Then
        Number1 = 12
    Else
        Number1 = 9
    End If
    
    ReDim Span(Number - 1) As Double
    ReDim ZLVolume(Number1 - 1, Number - 1) As Double
    ReDim HCVolume(2, Number - 1) As Double
    Dim i As Long, k As Long
    '读取代表档距
    For i = 0 To Number - 1
        Span(i) = Excelsheet.Cells(60 + i, 2)
    Next i
    '读取对应代表档距下的张力
    If Number1 = 12 Then
        For k = 0 To 8
            For i = 0 To Number - 1
                ZLVolume(k, i) = Excelsheet.Cells(60 + i, 2 * k + 4)
            Next i
        Next k
        For k = 9 To 11
            For i = 0 To Number - 1
                ZLVolume(k, i) = Excelsheet.Cells(240 + i, 2 * (k - 9) + 4)
            Next i
        Next k
    Else
        For k = 0 To 8
            For i = 0 To Number - 1
                ZLVolume(k, i) = Excelsheet.Cells(60 + i, 2 * k + 4)
            Next i
        Next k
    End If
    If Err <> 0 Then
        MsgBox "张力数据有错误！", vbOKOnly, "绘制力学特性曲线"
        Exit Sub
    End If
    '读取对应代表档距下的弧垂
    If Conductor = "导线：" Then
        For i = 0 To Number - 1
            HCVolume(0, i) = Excelsheet.Cells(106 + i, 10)
        Next
        For i = 0 To Number - 1
            HCVolume(1, i) = Excelsheet.Cells(106 + i, 12)
        Next
    End If
    
    For i = 0 To Number - 1
        HCVolume(2, i) = Excelsheet.Cells(106 + i, 16)
    Next
        If Err <> 0 Then
        MsgBox "弧垂数据有错误！", vbOKOnly, "绘制力学特性曲线"
        Exit Sub
    End If

End Sub



'********************以下为绘制坐标轴及标注坐标值部分******************************
Sub HuiZhiZuoBiao()
    Dim HLine As AcadLine
    Dim VLine As AcadLine
    Dim HLine1 As AcadPolyline
    Dim VLine1 As AcadPolyline
    Dim HNum As Long, VNum As Long
    Dim HLinePoint1(2) As Double
    Dim HLinePoint2(2) As Double
    Dim VLinePoint1(2) As Double
    Dim VLinePoint2(2) As Double
    Dim QXPoint(5) As Double
    
'设置层
On Error Resume Next
    Dim zuobiaolayer As AcadLayer
    AcadDoc.ActiveLayer = AcadDoc.Layers.Item("zuobiao")
    If Err <> 0 Then
        Set zuobiaolayer = AcadDoc.Layers.Add("zuobiao")
        AcadDoc.ActiveLayer = zuobiaolayer
        Err.Clear
    End If
    
    '绘制水平标尺
    For HNum = 0 To VAxis
        HLinePoint1(0) = -1#
        HLinePoint1(1) = HNum * VDist
        HLinePoint1(2) = 0#
        HLinePoint2(0) = 0#
        HLinePoint2(1) = HNum * VDist
        HLinePoint2(2) = 0#
        Set HLine = MoSpace.AddLine(HLinePoint1, HLinePoint2)
        With HLine
            .Color = 252
            .Lineweight = acLnWt005
            .Update
        End With
        
        HLinePoint1(0) = 250#
        HLinePoint1(1) = HNum * VDist
        HLinePoint1(2) = 0#
        HLinePoint2(0) = 251#
        HLinePoint2(1) = HNum * VDist
        HLinePoint2(2) = 0#
        Set HLine = MoSpace.AddLine(HLinePoint1, HLinePoint2)
        With HLine
            .Color = 252
            .Lineweight = acLnWt005
            .Update
        End With
        
        QXPoint(0) = 0#
        QXPoint(1) = HNum * VDist
        QXPoint(2) = 0#
        QXPoint(3) = 250#
        QXPoint(4) = HNum * VDist
        QXPoint(5) = 0#
        Set HLine1 = MoSpace.AddPolyline(QXPoint)
        With HLine1
            .ConstantWidth = 0.3
            .Color = 7
            .Update
        End With
    
    Next
    '绘制水平小间隔标尺
    For HNum = 0 To VAxis - 1
        For VNum = 0 To 3
            HLinePoint1(0) = 0#
            HLinePoint1(1) = (VNum + 1) * VDist / 5 + HNum * VDist
            HLinePoint1(2) = 0#
            HLinePoint2(0) = 250#
            HLinePoint2(1) = (VNum + 1) * VDist / 5 + HNum * VDist
            HLinePoint2(2) = 0#
            Set HLine = MoSpace.AddLine(HLinePoint1, HLinePoint2)
            With HLine
                .Color = 252
                .Lineweight = acLnWt005
                .Update
            End With
        Next
    Next
    '绘制垂直标尺
    For VNum = 0 To HAxis
        QXPoint(0) = VNum * HDist
        QXPoint(1) = 0#
        QXPoint(2) = 0#
        QXPoint(3) = VNum * HDist
        QXPoint(4) = 200#
        QXPoint(5) = 0#
        Set VLine1 = MoSpace.AddPolyline(QXPoint)
        With VLine1
            .ConstantWidth = 0.3
            .Color = 7
            .Update
        End With
    Next
    '绘制垂直小间隔标尺
    For VNum = 0 To HAxis - 1
        For HNum = 0 To 3
            VLinePoint1(0) = VNum * HDist + (HNum + 1) * HDist / 5
            VLinePoint1(1) = 0#
            VLinePoint1(2) = 0#
            VLinePoint2(0) = VNum * HDist + (HNum + 1) * HDist / 5
            VLinePoint2(1) = 200#
            VLinePoint2(2) = 0#
            Set VLine = MoSpace.AddLine(VLinePoint1, VLinePoint2)
            With VLine
                .Color = 252
                .Lineweight = acLnWt005
                .Update
            End With
        Next
    Next
    '绘制垂直标尺数值
    '绘制张力标尺
    Dim ZLText As AcadText
    Dim ZhangLi As Long
    For HNum = 0 To VAxis
        HLinePoint1(0) = -3#
        HLinePoint1(1) = HNum * VDist
        HLinePoint1(2) = 0#
        ZhangLi = (ZLMin * ZLUnit + HNum * ZLUnit) / 1000
        Set ZLText = MoSpace.AddText(ZhangLi, HLinePoint1, 3)
        With ZLText
            .Alignment = acAlignmentMiddleRight
            .TextAlignmentPoint = HLinePoint1
            .ScaleFactor = 0.8
            .Update
        End With
    Next
    '绘制弧垂标尺
    If Not (PanDuan) Then
        Dim HCText As AcadText
        Dim HuChui As Long
        For HNum = 0 To VAxis
            HLinePoint1(0) = 253#
            HLinePoint1(1) = HNum * VDist
            HLinePoint1(2) = 0#
            HuChui = HCMin * HCUnit + HNum * HCUnit
            Set HCText = MoSpace.AddText(HuChui, HLinePoint1, 3)
            With HCText
                .Alignment = acAlignmentMiddleLeft
                .TextAlignmentPoint = HLinePoint1
                .ScaleFactor = 0.8
                .Update
            End With
        Next
    End If
    '绘制水平标尺数值
    '绘制代表档距标尺
    Dim DBText As AcadText
    Dim DaiBiao As Long
    For VNum = 0 To HAxis
        VLinePoint1(0) = VNum * HDist
        VLinePoint1(1) = -3#
        VLinePoint1(2) = 0#
        DaiBiao = DBMin + VNum * DBUnit
        Set DBText = MoSpace.AddText(DaiBiao, VLinePoint1, 3)
        With DBText
            .Alignment = acAlignmentTopCenter
            .TextAlignmentPoint = VLinePoint1
            .ScaleFactor = 0.8
            .Update
        End With
    Next
End Sub



'********************以下为绘制张力弧垂曲线部分************************************
Sub HuiZhiQuXian()
    Dim QXPoint() As Double
    Dim QuXian As AcadPolyline
    Dim LvPoint1(5) As Double
    Dim LvPoint2(2) As Double
    Dim j As Long
    Dim LvLine As AcadPolyline
    Dim LvText As AcadText
    Dim quxianlayer As AcadLayer
    
    On Error Resume Next
    
    AcadDoc.ActiveLayer = AcadDoc.Layers.Item("quxian")
    If Err <> 0 Then
        Set quxianlayer = AcadDoc.Layers.Add("quxian")
        AcadDoc.ActiveLayer = quxianlayer
        Err.Clear
    End If
    
    '绘制临界档距线、标注临界档距值、确定临界档距个数
    Dim LvNumber As Long
    Dim LvXuHao() As Long
    LvNumber = 0
    
    For i = 0 To Number - 1
        If Span(i) > Int(Span(i)) Then
            LvNumber = LvNumber + 1
            LvPoint1(0) = (Span(i) - DBMin) * HDist / DBUnit
            LvPoint1(1) = 0#
            LvPoint1(2) = 0#
            LvPoint1(3) = (Span(i) - DBMin) * HDist / DBUnit
            LvPoint1(4) = 200#
            LvPoint1(5) = 0#
            Set LvLine = MoSpace.AddPolyline(LvPoint1)
            With LvLine
                .Color = acRed
                .ConstantWidth = 0.5
                .Update
            End With
            LvPoint2(0) = LvPoint1(3)
            LvPoint2(1) = LvPoint1(4) + 3#
            LvPoint2(2) = LvPoint1(5)
            Set LvText = MoSpace.AddText("Lj=" & Format(Span(i), "0.000"), LvPoint2, 2.5)
            With LvText
                .Alignment = acAlignmentBottomCenter
                .TextAlignmentPoint = LvPoint2
                .ScaleFactor = 0.8
                .Color = acRed
                .Update
            End With
        End If
    Next
    ReDim LvXuHao(LvNumber + 1) As Long
    k = 0
    LvXuHao(0) = 0
    For i = 0 To Number - 1
        If Span(i) > Int(Span(i)) Then
            k = k + 1
            LvXuHao(k) = i
        End If
    Next
    LvXuHao(LvNumber + 1) = Number - 1
    '绘制张力曲线
    Dim BiaoZhu1(2) As Double
    Dim BiaoZhu2(3) As Double
    Dim BZLine As AcadLWPolyline
    Dim Circle1 As AcadCircle
    Dim BZText As AcadText
    Dim DjJg As Long
    Dim YanSe(11) As Long   '设置颜色
        YanSe(0) = 1: YanSe(1) = 2: YanSe(2) = 3: YanSe(3) = 4
        YanSe(4) = 5: YanSe(5) = 6: YanSe(6) = 4: YanSe(7) = 30
        YanSe(8) = 3: YanSe(9) = 41: YanSe(10) = 7: YanSe(11) = 140
            
    If Not (PanDuan) Then
        For k = 0 To 8
            For j = 0 To LvNumber
            DjJg = LvXuHao(j + 1) - LvXuHao(j)
            ReDim QXPoint(3 * (DjJg + 1) - 1)
            
                If j = 0 Then
                    For i = 0 To DjJg
                        QXPoint(3 * i) = (Span(i) - DBMin) * HDist / DBUnit
                        QXPoint(3 * i + 1) = (ZLVolume(k, i) - ZLMin * ZLUnit) * VDist / ZLUnit
                        QXPoint(3 * i + 2) = 0#
                    Next
                    
                    Set QuXian = MoSpace.AddPolyline(QXPoint)
                    With QuXian
                        .Color = YanSe(k)
                        .ConstantWidth = 0.5
                        .Update
                    End With
                    AcadDoc.SendCommand "_pedit L F  "
                    
                    '标注曲线编号
                    If QXPoint(1) > QXPoint(4) Then
                        BiaoZhu1(0) = QXPoint(0) + 5#
                        BiaoZhu1(1) = QXPoint(1) + 5#
                        BiaoZhu1(2) = QXPoint(2)
                        BiaoZhu2(0) = QXPoint(0)
                        BiaoZhu2(1) = QXPoint(1)
                        BiaoZhu2(2) = QXPoint(0) + 3.2
                        BiaoZhu2(3) = QXPoint(1) + 3.2
                    Else
                        BiaoZhu1(0) = QXPoint(0) + 5#
                        BiaoZhu1(1) = QXPoint(1) - 5#
                        BiaoZhu1(2) = QXPoint(2)
                        BiaoZhu2(0) = QXPoint(0)
                        BiaoZhu2(1) = QXPoint(1)
                        BiaoZhu2(2) = QXPoint(0) + 3.2
                        BiaoZhu2(3) = QXPoint(1) - 3.2
                    End If
                    Set Circle1 = MoSpace.AddCircle(BiaoZhu1, 2.5)
                    Circle1.Color = YanSe(k)
                    Set BZText = MoSpace.AddText(k + 1, BiaoZhu1, 3)
                    With BZText
                        .Color = YanSe(k)
                        .Alignment = acAlignmentMiddleCenter
                        .TextAlignmentPoint = BiaoZhu1
                        .ScaleFactor = 0.8
                        .Update
                    End With
                    Set BZLine = MoSpace.AddLightWeightPolyline(BiaoZhu2)
                    BZLine.Color = YanSe(k)
                    BZLine.SetWidth 0, 0#, 0.5
                    BZLine.Update
                 Else
                    For i = 0 To DjJg
                        QXPoint(3 * i) = (Span(i + LvXuHao(j)) - DBMin) * HDist / DBUnit
                        QXPoint(3 * i + 1) = (ZLVolume(k, i + LvXuHao(j)) - ZLMin * ZLUnit) * VDist / ZLUnit
                        QXPoint(3 * i + 2) = 0#
                    Next
                    Set QuXian = MoSpace.AddPolyline(QXPoint)
                    With QuXian
                        .Color = YanSe(k)
                        .ConstantWidth = 0.5
                        .Update
                    End With
                    AcadDoc.SendCommand "_pedit L F  "
                    
                End If
            Next
        Next
    End If
    
    If PanDuan Then
        For k = 9 To 11
            For j = 0 To LvNumber
            DjJg = LvXuHao(j + 1) - LvXuHao(j)
            ReDim QXPoint(3 * (DjJg + 1) - 1)
            
                If j = 0 Then
                    For i = 0 To DjJg
                        QXPoint(3 * i) = (Span(i) - DBMin) * HDist / DBUnit
                        QXPoint(3 * i + 1) = (ZLVolume(k, i) - ZLMin * ZLUnit) * VDist / ZLUnit
                        QXPoint(3 * i + 2) = 0#
                    Next
                    
                    Set QuXian = MoSpace.AddPolyline(QXPoint)
                    With QuXian
                        .Color = YanSe(k)
                        .ConstantWidth = 0.5
                        .Update
                    End With
                    AcadDoc.SendCommand "_pedit L F  "
                    
                    '标注曲线编号
                    If QXPoint(1) > QXPoint(4) Then
                        BiaoZhu1(0) = QXPoint(0) + 5#
                        BiaoZhu1(1) = QXPoint(1) + 5#
                        BiaoZhu1(2) = QXPoint(2)
                        BiaoZhu2(0) = QXPoint(0)
                        BiaoZhu2(1) = QXPoint(1)
                        BiaoZhu2(2) = QXPoint(0) + 3.2
                        BiaoZhu2(3) = QXPoint(1) + 3.2
                    Else
                        BiaoZhu1(0) = QXPoint(0) + 5#
                        BiaoZhu1(1) = QXPoint(1) - 5#
                        BiaoZhu1(2) = QXPoint(2)
                        BiaoZhu2(0) = QXPoint(0)
                        BiaoZhu2(1) = QXPoint(1)
                        BiaoZhu2(2) = QXPoint(0) + 3.2
                        BiaoZhu2(3) = QXPoint(1) - 3.2
                    End If
                    Set Circle1 = MoSpace.AddCircle(BiaoZhu1, 2.5)
                    Circle1.Color = YanSe(k)
                    Set BZText = MoSpace.AddText(k - 8, BiaoZhu1, 3)
                    With BZText
                        .Color = YanSe(k)
                        .Alignment = acAlignmentMiddleCenter
                        .TextAlignmentPoint = BiaoZhu1
                        .ScaleFactor = 0.8
                        .Update
                    End With
                    Set BZLine = MoSpace.AddLightWeightPolyline(BiaoZhu2)
                    BZLine.Color = YanSe(k)
                    BZLine.SetWidth 0, 0#, 0.5
                    BZLine.Update
                 Else
                    For i = 0 To DjJg
                        QXPoint(3 * i) = (Span(i + LvXuHao(j)) - DBMin) * HDist / DBUnit
                        QXPoint(3 * i + 1) = (ZLVolume(k, i + LvXuHao(j)) - ZLMin * ZLUnit) * VDist / ZLUnit
                        QXPoint(3 * i + 2) = 0#
                    Next
                    Set QuXian = MoSpace.AddPolyline(QXPoint)
                    With QuXian
                        .Color = YanSe(k)
                        .ConstantWidth = 0.5
                        .Update
                    End With
                    AcadDoc.SendCommand "_pedit L F  "
                    
                End If
            Next
        Next
    End If
    
    '绘制弧垂曲线
    Dim dianxian As Long
    Dim BZHCtext(2) As String
    BZHCtext(0) = 4: BZHCtext(1) = 5: BZHCtext(2) = 7
    '判断是否为地线
    If Conductor = "导线：" Then
        dianxian = 0
    Else
        dianxian = 2