draw.cls

《管状换热器计算机辅助设计系统ExhCAD绘图系统(版本:1.01a Final)》为自由软件

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Draw"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'**********************************************************
'    File Name      :     draw.cls
'    Author         :     endlessfree
'    Last updated   :     10.05.2002
'    Compiler       :     Visucal Basic 6.0
'    Description    :     ExhCAD0.99.1 绘图Dll
'**********************************************************
'结构体和变量
'**********************************************************
'ExhDesign 'CAD画图用的数据
'ExhCADSetupHeater'参数设置数据
'ExhCADComputeHeater'输入数据
'ExhCADDrawHeater'输出数据
'Design'画图数据
'Acadapp'ACAD应用程序对象
'Acaddoc'ACAD文档对象
'MoSpace'ACAD模型空间对象
'Pvport'ACAD视图对象
'AcadUtility'ACAD实用工具集对象
'LnContinous'细实线对象
'LnCenter'点划线对象
'LnDash'虚线对象
'**********************************************************
'函数               *功能描述
'**********************************************************
'Setup()Boolean              *启动AutoCAD R14绘图对象
'Unsetup                     *卸载AutoCAD R14绘图对象
'LoadDrawData(Variant,       *
'             Variant,       *
'             Variant)       * 装载绘图数据
'DrawInit                    *绘图初始化
'MainView                    *主视图
'OverView                    *俯视图
'LeftView                    *左视图
'Draw(Variant,               *
'     Variant,               *
'     Variant)               *绘图
'**********************************************************


Private Function Setup() As Boolean
     Setup = True
     On Error Resume Next
     Set Acadapp = GetObject(, "AutoCAD.Application")
     If Err Then
       Err.Clear
       Set Acadapp = CreateObject("AutoCAD.Application")
       If Err Then
       Err.Clear
       Setup = False
       End If
     End If
     
End Function
Private Sub Unsetup()
      Set Acadapp = Nothing
      Set Acaddoc = Nothing
      Set AcadUtility = Nothing
      Set Pvport = Nothing
End Sub
Private Sub LoadDrawData(m_RecordSetup() As Integer, _
                m_RecordCompute() As Double, _
                m_RecordDraw() As Double)
                
Design.PipDiameter = m_RecordCompute(0)
Thick = m_RecordCompute(1)
Design.VeriticalBetweenPipeDistance = m_RecordCompute(2)
Design.HorizonBetweenPipeDistance = m_RecordCompute(3)
Design.RouteNum = m_RecordCompute(4)

Design.LinNum = m_RecordDraw(0)
Design.ColNum = m_RecordDraw(1)
Design.PipLen = m_RecordDraw(2)

Design.PipInDiameter = Design.PipDiameter - 2 * Thick
Design.PipeNum = Design.LinNum / Design.RouteNum

If Design.RouteNum Mod 2 = 0 Then
     Design.DistanceBetweenRoute1 = 2 * Design.HorizonBetweenPipeDistance
     Design.DistanceBetweenRoute2 = 4 * Design.HorizonBetweenPipeDistance
Else
    Design.DistanceBetweenRoute1 = 2 * Design.HorizonBetweenPipeDistance
    Design.DistanceBetweenRoute2 = 4 * Design.HorizonBetweenPipeDistance
End If

End Sub
Private Sub DrawInit()
Dim Point1(0 To 2) As Double, Point2(0 To 2) As Double
Dim Point3(0 To 2) As Double, Point4(0 To 2) As Double
Dim lineobj As Object

Set Acaddoc = Acadapp.ActiveDocument
Set Pvport = Acaddoc.ActiveViewport
Set MoSpace = Acaddoc.ModelSpace
Set AcadUtility = Acaddoc.Utility
Set TxStyle = Acaddoc.ActiveTextStyle

Set LnContinous = Acaddoc.ActiveLinetype
Acaddoc.Linetypes.Load "CENTER", "acad.lin"
Acaddoc.Linetypes.Load "DASHED", "acad.lin"
Set LnDash = Acaddoc.Linetypes.Item("DASHED")
Set LnCenter = Acaddoc.Linetypes.Item("CENTER")
Acaddoc.ActiveLinetype = LnContinous
Acadapp.Visible = True
AppActivate Acadapp.Caption
Set DmStyle = Acaddoc.DimStyles.Item("STANDARD")
Acaddoc.ActiveDimStyle = DmStyle
TxStyle.BigFontFile = ExhCADBigFontFile

Point1(0) = 0: Point1(1) = 0: Point1(2) = 0
Point2(0) = 559: Point2(1) = 0: Point2(2) = 0
Point3(0) = 559: Point3(1) = 400: Point3(2) = 0
Point4(0) = 0: Point4(1) = 400: Point4(2) = 0
Set lineobj = MoSpace.AddLine(Point1, Point2)
Set lineobj = MoSpace.AddLine(Point2, Point3)
Set lineobj = MoSpace.AddLine(Point3, Point4)
Set lineobj = MoSpace.AddLine(Point4, Point1)

Point1(0) = 15: Point1(1) = 10: Point1(2) = 0
Point2(0) = 549: Point2(1) = 10: Point2(2) = 0
Point3(0) = 549: Point3(1) = 390: Point3(2) = 0
Point4(0) = 15: Point4(1) = 390: Point4(2) = 0
Set lineobj = MoSpace.AddLine(Point1, Point2)
Set lineobj = MoSpace.AddLine(Point2, Point3)
Set lineobj = MoSpace.AddLine(Point3, Point4)
Set lineobj = MoSpace.AddLine(Point4, Point1)
End Sub
Private Sub MainView(Beginpoint1() As Double, _
                     Beginpoint2() As Double, _
                     Endpoint1() As Double, _
                     Endpoint2() As Double)
                     
      Dim Point1(0 To 2) As Double, Point2(0 To 2) As Double
      Dim HPoint1(0 To 2) As Double, HPoint2(0 To 2) As Double
      Dim HPoint3(0 To 2) As Double, HPoint4(0 To 2) As Double
      Dim CPoint1(0 To 2) As Double, CPoint2(0 To 2) As Double
      Dim CPoint3(0 To 2) As Double, CPoint4(0 To 2) As Double
    
      Dim CenterPoint1(0 To 2) As Double, CenterPoint2(0 To 2) As Double
      Dim i As Integer, j As Integer
      Dim lineobj As Object
      
      Point1(0) = 35: Point1(1) = 400 - 75: Point1(2) = 0
      Point2(0) = 35: Point2(1) = 400 - 75 - Design.PipLen / 100: Point2(2) = 0
    
      
      '主俯视图
     For i = 0 To 2: Beginpoint1(i) = Point1(i): Next i
     For i = 0 To 2: Beginpoint2(i) = Point2(i): Next i
  
     
     
     For i = 0 To 2: CenterPoint1(i) = Point1(i): Next i
     For i = 0 To 2: CenterPoint2(i) = Point2(i): Next i
     CenterPoint1(1) = CenterPoint1(1) + 5
     CenterPoint2(1) = CenterPoint2(1) - 5
     
     For i = 0 To 2: CPoint1(i) = Point1(i): Next i
     For i = 0 To 2: CPoint3(i) = Point2(i): Next i
     For i = 0 To 2: CPoint2(i) = Point1(i): Next i
     For i = 0 To 2: CPoint4(i) = Point2(i): Next i
     
     For i = 0 To 2: HPoint1(i) = Point1(i): Next i
     
     HPoint1(1) = HPoint1(1) - 5
     For i = 0 To 2: HPoint2(i) = HPoint1(i): Next i
     For i = 0 To 2: HPoint3(i) = Point2(i): Next i
     HPoint3(1) = HPoint3(1) + 5
     For i = 0 To 2: HPoint4(i) = HPoint3(i): Next i
     
     For j = 0 To Design.RouteNum - 1
     
       For i = 1 To 2 * Design.PipeNum
         Set lineobj = MoSpace.AddLine(Point1, Point2)
         
         If i <> 2 * Design.PipeNum Then
         
             If i Mod 2 <> 0 Then
                 CenterPoint1(0) = Point1(0) + Design.PipDiameter / 20
                 CenterPoint2(0) = Point2(0) + Design.PipDiameter / 20
                 
                 Point1(0) = Point1(0) + Design.PipDiameter / 10
                 Point2(0) = Point2(0) + Design.PipDiameter / 10
                 
                
                 
              Else
                 CenterPoint1(0) = Point1(0) + Design.HorizonBetweenPipeDistance / 20 - Design.PipDiameter / 20
                 CenterPoint2(0) = Point2(0) + Design.HorizonBetweenPipeDistance / 20 - Design.PipDiameter / 20
                 
                 Point1(0) = Point1(0) + Design.HorizonBetweenPipeDistance / 10 - Design.PipDiameter / 10
                 Point2(0) = Point2(0) + Design.HorizonBetweenPipeDistance / 10 - Design.PipDiameter / 10
                              
             End If
             
             Set lineobj = MoSpace.AddLine(CenterPoint1, CenterPoint2)
             lineobj.Linetype = "Center"
             lineobj.LinetypeScale = 5
             lineobj.Update
                 
         End If
       Next i
       
     For i = 0 To 2: Endpoint1(i) = Point1(i): Next i
     For i = 0 To 2: Endpoint2(i) = Point2(i): Next i
     HPoint2(0) = Point1(0): HPoint4(0) = Point2(0)
     CPoint2(0) = Point1(0): CPoint4(0) = Point2(0)
     
     Set lineobj = MoSpace.AddLine(HPoint1, HPoint2)
     Set lineobj = MoSpace.AddLine(HPoint3, HPoint4)
     Set lineobj = MoSpace.AddLine(CPoint1, CPoint4)
     Set lineobj = MoSpace.AddLine(CPoint2, CPoint3)
     
      If j Mod 2 = 0 Then
      
            CenterPoint1(0) = Point1(0) + Design.DistanceBetweenRoute1 / 20
            CenterPoint2(0) = Point2(0) + Design.DistanceBetweenRoute1 / 20
            
            Point1(0) = Point1(0) + Design.DistanceBetweenRoute1 / 10
            Point2(0) = Point2(0) + Design.DistanceBetweenRoute1 / 10
            
            
            
      Else
            CenterPoint1(0) = Point1(0) + Design.DistanceBetweenRoute2 / 20
            CenterPoint2(0) = Point2(0) + Design.DistanceBetweenRoute2 / 20
            
            Point1(0) = Point1(0) + Design.DistanceBetweenRoute2 / 10
            Point2(0) = Point2(0) + Design.DistanceBetweenRoute2 / 10
            
      End If
      If j <> Design.RouteNum - 1 Then
       Set lineobj = MoSpace.AddLine(CenterPoint1, CenterPoint2)
       lineobj.Linetype = "Center"
       lineobj.LinetypeScale = 5
       lineobj.Update
      End If
      
      HPoint1(0) = Point1(0): HPoint3(0) = Point2(0)
      CPoint1(0) = Point1(0): CPoint3(0) = Point2(0)
      
     Next j
    
    
End Sub
      
Private Sub OverView(Beginpoint2() As Double, _
                     Endpoint2() As Double, _
                     IndexArrange As Integer)
  Dim Beginpoint3(0 To 2) As Double, Endpoint3(0 To 2) As Double
  Dim CenterPoint1(0 To 2) As Double, CenterPoint2(0 To 2) As Double
  Dim CPoint1(0 To 2) As Double, CPoint2(0 To 2) As Double
  Dim CPoint3(0 To 2) As Double, CPoint4(0 To 2) As Double
  
  Dim i As Integer, j As Integer, k As Integer, m As Integer
  Dim CircleObj1 As Object, CircleObj2 As Object
  Dim HatchObj As Object, InnerC(0 To 0) As Object, OuterC(0 To 0) As Object
  
  For i = 0 To 2: Beginpoint3(i) = Beginpoint2(i): Next i
  For i = 0 To 2: Endpoint3(i) = Endpoint2(i): Next i
  Beginpoint3(1) = 75
  Endpoint3(1) = 75
  For i = 0 To 2: CenterPoint1(i) = Beginpoint3(i): Next i
  CenterPoint1(0) = CenterPoint1(0) + Design.PipDiameter / 20
  For i = 0 To 2: CenterPoint2(i) = CenterPoint1(i): Next i
  CenterPoint2(1) = CenterPoint1(1)
  For m = 0 To Design.RouteNum - 1
     CenterPoint1(1) = CenterPoint2(1)
     For j = 1 To Design.PipeNum
       CenterPoint1(1) = CenterPoint2(1)
       Select Case IndexArrange
         Case 0
            Set CircleObj1 = MoSpace.AddCircle(CenterPoint1, Design.PipDiameter / 20)
            Set CircleObj2 = MoSpace.AddCircle(CenterPoint1, Design.PipInDiameter / 20)
            Set HatchObj = MoSpace.AddHatch(0, "ANSI31", True)
            Set OuterC(0) = CircleObj1: Set InnerC(0) = CircleObj2
            HatchObj.AppendOuterLoop OuterC
            HatchObj.AppendInnerLoop InnerC