zlhcform.frm

计算力学特性曲线

    '确定水平轴的绘制间隔数目、间隔单位
        
        If DBMax - DBMin > 500 Then
            If (DBMax - DBMin) Mod 100 = 0 Then
                HAxis = (DBMax - DBMin) / 100
            Else
                HAxis = Int((DBMax - DBMin) / 100) + 1
            End If
            DBUnit = 100
        ElseIf (DBMax - DBMin) Mod 50 = 0 Then
            HAxis = (DBMax - DBMin) / 50
            DBUnit = 50
        Else
            HAxis = Int(DBMax - DBMin / 50) + 1
            DBUnit = 50
        End If
        
        If DBMax - DBMin <= 200 Then
            If (DBMax - DBMin) Mod 25 = 0 Then
                HAxis = (DBMax - DBMin) / 25
                DBUnit = 25
            Else
                HAxis = Int((DBMax - DBMin) / 25) + 1
                DBUnit = 25
            End If
        End If
   
    '确定每个间隔的距离(毫米)
        HDist = 200 / HAxis: VDist = 120 / VAxis
End Sub


'********************以下为绘制坐标轴及标注坐标值部分******************************
Sub HuiZhiZuoBiao2()
    Dim HLine As AcadLine
    Dim VLine As AcadLine
    Dim HLine1 As AcadPolyline
    Dim VLine1 As AcadPolyline
    Dim HNum As Long, VNum As Long
    Dim HLinePoint0(2) As Double
    Dim HLinePoint1(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

    '字型设置
    Dim DWQXStyle As AcadTextStyle
    found1 = False
    For Each DWQXStyle In AcadDoc.TextStyles
        If StrComp(DWQXStyle.Name, "DWQX", 1) = 0 Then
            found1 = True
            Exit For
        End If
    Next
    If Not (found1) Then
        Set DWQXStyle = AcadDoc.TextStyles.Add("DWQX")
        AcadDoc.ActiveTextStyle = DWQXStyle
    Else
        AcadDoc.ActiveTextStyle = AcadDoc.TextStyles.Item("DWQX")
    End If
    AcadDoc.ActiveTextStyle.BigFontFile = "Hztxt.shx"
    AcadDoc.ActiveTextStyle.fontFile = "ZX.shx"
    AcadDoc.ActiveTextStyle.Width = 0.8

    
    '绘制水平标尺
    For HNum = 0 To VAxis
        QXPoint(0) = 0#
        QXPoint(1) = HNum * VDist
        QXPoint(2) = 0#
        QXPoint(3) = 200#
        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
            HLinePoint0(0) = 0#
            HLinePoint0(1) = (VNum + 1) * VDist / 5 + HNum * VDist
            HLinePoint0(2) = 0#
            HLinePoint1(0) = 200#
            HLinePoint1(1) = (VNum + 1) * VDist / 5 + HNum * VDist
            HLinePoint1(2) = 0#
            Set HLine = MoSpace.AddLine(HLinePoint0, HLinePoint1)
            HLine.Color = 252
            HLine.Update
        Next
    Next
    '绘制垂直标尺
    For VNum = 0 To HAxis
        QXPoint(0) = VNum * HDist
        QXPoint(1) = 0#
        QXPoint(2) = 0#
        QXPoint(3) = VNum * HDist
        QXPoint(4) = 120#
        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) = 120#
            VLinePoint2(2) = 0#
            Set VLine = MoSpace.AddLine(VLinePoint1, VLinePoint2)
            VLine.Color = 252
            VLine.Update
        Next
    Next
    '绘制垂直标尺数值
    '绘制K值标尺
    Dim KZText As AcadText
    Dim KZhi As Double
    For HNum = 0 To VAxis
        HLinePoint0(0) = -3#
        HLinePoint0(1) = HNum * VDist
        HLinePoint0(2) = 0#
        KZhi = KMin * KUnit + HNum * KUnit + 0.005
        Set KZText = MoSpace.AddText(Format(KZhi, "0.###"), HLinePoint0, 3)
        With KZText
            .Alignment = acAlignmentMiddleRight
            .TextAlignmentPoint = HLinePoint0
            .ScaleFactor = 0.8
            .Update
        End With
    Next
    '绘制水平标尺数值
    '绘制代表档距标尺
    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

'读取代表档距及相应代表档距下的K值
Sub DuQuShuJu2()
On Error Resume Next
    ReDim Span(Number - 1) As Double
    ReDim KVolume1(Number - 1) As Double
    ReDim KVolume2(Number - 1) As Double
    ReDim KVolume3(Number - 1) As Double
    Dim i As Long
    
    '读取代表档距
    For i = 0 To Number - 1
        Span(i) = Excelsheet.Cells(60 + i, 2)
    Next i
    
    '读取对应代表档距下的K值
    For i = 0 To Number - 1
        KVolume1(i) = Excelsheet.Cells(152 + i, 12)
    Next i
    For i = 0 To Number - 1
        KVolume2(i) = Excelsheet.Cells(175 + i, 6)
    Next i
    For i = 0 To Number - 1
        KVolume3(i) = Excelsheet.Cells(175 + i, 4)
    Next i
    
    If Err <> 0 Then
        MsgBox "K值有错误！", vbOKOnly, "绘制模板曲线"
        Exit Sub
    End If

End Sub


'**以下为绘制模板曲线部分***
Sub HuiZhiQuXian2()
    Dim QXPoint() As Double
    Dim QuXian As AcadPolyline
    Dim i As Long
    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 BiaoZhu(2) As Double
    Dim BiaoZhuShuJu As String
    Dim BZText As AcadText
    Dim YanSe(2) As Long   '设置颜色
        YanSe(0) = 1: YanSe(1) = 2: YanSe(2) = 3
    ReDim QXPoint(3 * Number - 1)
    
    If PanDuan1 = "GW" Then
        For i = 0 To Number - 1
            QXPoint(3 * i) = (Span(i) - DBMin) * HDist / DBUnit
            QXPoint(3 * i + 1) = (KVolume1(i) - KMin * KUnit - 0.005) * VDist / KUnit
            QXPoint(3 * i + 2) = 0#
            
            If i = 0 Then
                BiaoZhu(0) = QXPoint(0) + 1#
                BiaoZhu(1) = QXPoint(1) + 1#
                BiaoZhu(2) = QXPoint(2)
                BiaoZhuShuJu = Excelsheet.Cells(22, 9) & "℃"
                Set BZText = MoSpace.AddText(BiaoZhuShuJu, BiaoZhu, 3.5)
                With BZText
                    .Color = YanSe(0)
                    .Alignment = acAlignmentBottomLeft
                    .TextAlignmentPoint = BiaoZhu
                    .ScaleFactor = 0.8
                    .Update
                End With
            End If
            
        Next
        Set QuXian = MoSpace.AddPolyline(QXPoint)
        With QuXian
            .Color = YanSe(0)
            .ConstantWidth = 0.5
            .Update
        End With
        AcadDoc.SendCommand "_pedit L F  "
    ElseIf PanDuan1 = "FB" Then
        For i = 0 To Number - 1
            QXPoint(3 * i) = (Span(i) - DBMin) * HDist / DBUnit
            QXPoint(3 * i + 1) = (KVolume2(i) - KMin * KUnit - 0.005) * VDist / KUnit
            QXPoint(3 * i + 2) = 0#
            
            If i = 0 Then
                BiaoZhu(0) = QXPoint(0) + 1#
                BiaoZhu(1) = QXPoint(1) + 1#
                BiaoZhu(2) = QXPoint(2)
                BiaoZhuShuJu = "V=0，C=" & Excelsheet.Cells(21, 15)
                Set BZText = MoSpace.AddText(BiaoZhuShuJu, BiaoZhu, 3.5)
                With BZText
                    .Color = YanSe(1)
                    .Alignment = acAlignmentBottomLeft
                    .TextAlignmentPoint = BiaoZhu
                    .ScaleFactor = 0.8
                    .Update
                End With
            End If
            
        Next
        Set QuXian = MoSpace.AddPolyline(QXPoint)
        With QuXian
            .Color = YanSe(1)
            .ConstantWidth = 0.5
            .Update
        End With
        AcadDoc.SendCommand "_pedit L F  "
    Else
        For i = 0 To Number - 1
            QXPoint(3 * i) = (Span(i) - DBMin) * HDist / DBUnit
            QXPoint(3 * i + 1) = (KVolume1(i) - KMin * KUnit - 0.005) * VDist / KUnit
            QXPoint(3 * i + 2) = 0#
            
            If i = 0 Then
                BiaoZhu(0) = QXPoint(0) + 1#
                BiaoZhu(1) = QXPoint(1) + 1#
                BiaoZhu(2) = QXPoint(2)
                BiaoZhuShuJu = Excelsheet.Cells(22, 9) & "℃"
                Set BZText = MoSpace.AddText(BiaoZhuShuJu, BiaoZhu, 3.5)
                With BZText
                    .Color = YanSe(0)
                    .Alignment = acAlignmentBottomLeft
                    .TextAlignmentPoint = BiaoZhu
                    .ScaleFactor = 0.8
                    .Update
                End With
            End If
            
        Next
        Set QuXian = MoSpace.AddPolyline(QXPoint)
        With QuXian
            .Color = YanSe(0)
            .ConstantWidth = 0.5
            .Update
        End With
        AcadDoc.SendCommand "_pedit L F  "
        For i = 0 To Number - 1
            QXPoint(3 * i) = (Span(i) - DBMin) * HDist / DBUnit
            QXPoint(3 * i + 1) = (KVolume2(i) - KMin * KUnit - 0.005) * VDist / KUnit
            QXPoint(3 * i + 2) = 0#
            
            If i = 0 Then
                BiaoZhu(0) = QXPoint(0) + 1#
                BiaoZhu(1) = QXPoint(1) + 1#
                BiaoZhu(2) = QXPoint(2)
                BiaoZhuShuJu = "V=0，C=" & Excelsheet.Cells(21, 15)
                Set BZText = MoSpace.AddText(BiaoZhuShuJu, BiaoZhu, 3.5)
                With BZText
                    .Color = YanSe(1)
                    .Alignment = acAlignmentBottomLeft
                    .TextAlignmentPoint = BiaoZhu
                    .ScaleFactor = 0.8
                    .Update
                End With
            End If
            
        Next
        Set QuXian = MoSpace.AddPolyline(QXPoint)
        With QuXian
            .Color = YanSe(1)
            .ConstantWidth = 0.5
            .Update
        End With
        AcadDoc.SendCommand "_pedit L F  "
    End If
    
    For i = 0 To Number - 1
        QXPoint(3 * i) = (Span(i) - DBMin) * HDist / DBUnit
        QXPoint(3 * i + 1) = (KVolume3(i) - KMin * KUnit - 0.005) * VDist / KUnit
        QXPoint(3 * i + 2) = 0#
        If i = 0 Then
            BiaoZhu(0) = QXPoint(0) + 1#
            BiaoZhu(1) = QXPoint(1) + 1#
            BiaoZhu(2) = QXPoint(2)
            BiaoZhuShuJu = Excelsheet.Cells(27, 6)
            Set BZText = MoSpace.AddText(BiaoZhuShuJu, BiaoZhu, 3.5)
            With BZText
                .Color = YanSe(2)
                .Alignment = acAlignmentBottomLeft
                .TextAlignmentPoint = BiaoZhu
                .ScaleFactor = 0.8
                .Update
            End With
        End If
    Next
        Set QuXian = MoSpace.AddPolyline(QXPoint)
        With QuXian
            .Color = YanSe(2)
            .ConstantWidth = 0.5
            .Update
        End With
        AcadDoc.SendCommand "_pedit L F  "
End Sub

'绘制图框、图名
Sub HuiZhiTuKuang()
    Dim TKPoint1(2) As Double
    Dim TKPoint2(2) As Double
    Dim TKLine As AcadLine
    Dim TKText As AcadText
    Dim TKShuJu As String
    
    TKPoint1(0) = -30#
    TKPoint1(1) = -20#
    TKPoint1(2) = 0#
    TKPoint2(0) = 220#
    TKPoint2(1) = -20#
    TKPoint2(2) = 0#
    Set TKLine = MoSpace.AddLine(TKPoint1, TKPoint2)
    TKLine.Color = 252
    TKLine.Update
    
    TKPoint1(0) = -30#
    TKPoint1(1) = -20#
    TKPoint1(2) = 0#
    TKPoint2(0) = -30#
    TKPoint2(1) = 140#
    TKPoint2(2) = 0#
    Set TKLine = MoSpace.AddLine(TKPoint1, TKPoint2)
    TKLine.Color = 252
    TKLine.Update
    
    TKPoint1(0) = -30#
    TKPoint1(1) = 140#
    TKPoint1(2) = 0#
    TKPoint2(0) = 220#
    TKPoint2(1) = 140#
    TKPoint2(2) = 0#
    Set TKLine = MoSpace.AddLine(TKPoint1, TKPoint2)
    TKLine.Color = 252
    TKLine.Update
    
    TKPoint1(0) = 220#
    TKPoint1(1) = 140#
    TKPoint1(2) = 0#
    TKPoint2(0) = 220#
    TKPoint2(1) = -20#
    TKPoint2(2) = 0#
    Set TKLine = MoSpace.AddLine(TKPoint1, TKPoint2)
    TKLine.Color = 252
    TKLine.Update
    
    TKPoint1(0) = 100#
    TKPoint1(1) = -12.5
    TKPoint1(2) = 0#
    TKShuJu = "代 表 档 距 (米)"
    Set TKText = MoSpace.AddText(TKShuJu, TKPoint1, 5)
    With TKText
        .Color = 7
        .Alignment = acAlignmentMiddleCenter
        .TextAlignmentPoint = TKPoint1
        .StyleName = "DWQX"
        .ScaleFactor = 0.8
        .Update
    End With

    TKPoint1(0) = 100#
    TKPoint1(1) = 130#
    TKPoint1(2) = 0#
    TKShuJu = ConductorType & "导线模板K值曲线"
    Set TKText = MoSpace.AddText(TKShuJu, TKPoint1, 6)
    With TKText
        .Color = 7
        .Alignment = acAlignmentMiddleCenter
        .TextAlignmentPoint = TKPoint1
        .StyleName = "DWQX"
        .ScaleFactor = 0.8
        .Update
    End With

    TKPoint1(0) = -20#
    TKPoint1(1) = 60#
    TKPoint1(2) = 0#
    TKShuJu = "K×10E-3"
    Set TKText = MoSpace.AddText(TKShuJu, TKPoint1, 6)
    With TKText
        .Color = 7
        .Alignment = acAlignmentMiddleCenter
        .TextAlignmentPoint = TKPoint1
        .StyleName = "DWQX"
        .ScaleFactor = 0.8
        .Rotation = 3.1415926 / 2#
        .Update
    End With

End Sub
'*****************************************************************************************************************