cline.cls

数控自动编程系统

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CLine"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Description = "直线类"
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit
Implements CGElement

Private m_geColor As Double
Private m_geLineStyle As LineStyle
Private m_geLineWidth As Double
Private m_ID_Line As Integer
Private m_pLineBegin As Position
Private m_pLineEnd As Position

'写pLineEnd属性
Public Property Set pLineEnd(ByVal vData As Position)
    Set m_pLineEnd = vData
End Property

'读pLineEnd属性
Public Property Get pLineEnd() As Position
    Set pLineEnd = m_pLineEnd
End Property

'写pLineBegin属性
Public Property Set pLineBegin(ByVal vData As Position)
    Set m_pLineBegin = vData
End Property

'读pLineBegin属性
Public Property Get pLineBegin() As Position
    Set pLineBegin = m_pLineBegin
End Property

'写ID_Line属性
Public Property Let ID_Line(ByVal vData As Integer)
    m_ID_Line = vData
End Property

'读ID_Line属性
Public Property Get ID_Line() As Integer
    ID_Line = m_ID_Line
End Property

'写geColor属性
Public Property Let geColor(ByVal RHS As Double)
  m_geColor = RHS
End Property

'读geColor属性
Public Property Get geColor() As Double
  geColor = m_geColor
End Property

'写geLineStyle属性
Public Property Let geLineStyle(ByVal RHS As LineStyle)
  m_geLineStyle = RHS
End Property

'读geLineStyle属性
Public Property Get geLineStyle() As LineStyle
  geLineStyle = m_geLineStyle
End Property

'写geLineWidth属性
Public Property Let geLineWidth(ByVal RHS As Double)
  m_geLineWidth = RHS
End Property

'读geLineWidth属性
Public Property Get geLineWidth() As Double
  geLineWidth = m_geLineWidth
End Property

'用指定的绘图模式绘直线段
Private Sub CGElement_Draw(eDrawMode As GEDrawMode)
  Dim n As Integer
  
  '设置线型、线宽
  m_geLineWidth = 1
  '根据绘图模式的不同设置直线段的颜色
  Select Case eDrawMode
    Case edmNormal
      m_geLineStyle = vbSolid
      m_geColor = RGB(0, 0, 0)     '正常模式下，黑色
    Case edmSelect
      m_geLineStyle = vbDash
      m_geColor = RGB(255, 0, 0)   '选择模式下，红色
    Case edmDelete                    '删除模式下，用绘图环境的底色重画
      m_geLineStyle = vbSolid
      m_geColor = GetBkColor(DrawMain.picDraw.hdc)
  End Select

  '设置图片框的绘图属性
  With DrawMain.picDraw
    .DrawStyle = m_geLineStyle
    .DrawWidth = m_geLineWidth
    .ForeColor = m_geColor
  End With
  
  '用Line方法绘直线段
  DrawMain.picDraw.Line (m_pLineBegin.z, m_pLineBegin.x)-(m_pLineEnd.z, m_pLineEnd.x)
  
End Sub

'获取直线段的包围矩形
Private Sub CGElement_GetBox(pBox As Box)
With m_pLineBegin
  '如果为水平直线段或垂直直线段
  If .z = m_pLineEnd.z Or .x = m_pLineEnd.x Then
    pBox.minZ = min(.z, m_pLineEnd.z) - PickRadius * 1000
    pBox.minX = min(.x, m_pLineEnd.x) - PickRadius * 1000
    pBox.maxZ = max(.z, m_pLineEnd.z) + PickRadius * 1000
    pBox.maxX = max(.x, m_pLineEnd.x) + PickRadius * 1000
  '如果为斜线
  Else
    pBox.minZ = min(.z, m_pLineEnd.z) - PickRadius
    pBox.minX = min(.x, m_pLineEnd.x) - PickRadius
    pBox.maxZ = max(.z, m_pLineEnd.z) + PickRadius
    pBox.maxX = max(.x, m_pLineEnd.x) + PickRadius
  End If
End With
End Sub


Private Property Let CGElement_ID(ByVal RHS As Integer)

End Property

Private Property Get CGElement_ID() As Integer

End Property

'直线段的镜像变换
Private Sub CGElement_Mirror(Pos1 As Position, Pos2 As Position)
  '对直线段的端点进行镜像变换
  Set m_pLineBegin = m_pLineBegin.pntMirror(Pos1, Pos2)
  Set m_pLineEnd = m_pLineEnd.pntMirror(Pos1, Pos2)
End Sub

'直线段的平移变换
Private Sub CGElement_Move(basePos As Position, desPos As Position)
  Dim zz As Double, xx As Double
  '计算横向移动的距离和纵向移动的距离
  zz = desPos.z - basePos.z
  xx = desPos.x - basePos.x
  Set m_pLineBegin = m_pLineBegin.pntMove(zz, xx)
  Set m_pLineEnd = m_pLineEnd.pntMove(zz, xx)
End Sub
  '向上偏移100单位
Private Sub CGElement_Moveonly()
  Set m_pLineBegin = m_pLineBegin.pntMove(100, 0)
  Set m_pLineEnd = m_pLineEnd.pntMove(100, 0)
End Sub
'拾取直线段
Private Function CGElement_Pick(pos As Position, PickRadius As Double) As Boolean
  Dim objPos As New Position
  Dim line As New CLine
  Dim sourceBox As New Box
  
  With objPos
    .z = pos.z
    .x = pos.x
  End With
  With line
    Set .pLineBegin = m_pLineBegin
    Set .pLineEnd = m_pLineEnd
  End With
  '得到直线段的包围矩形
  Call CGElement_GetBox(sourceBox)
  '判断拾取点是否在测试包围矩形中，若不是，则未被选中
  If (Not InBox(sourceBox, objPos)) Then
    CGElement_Pick = False
  Else
    If distPtoL(objPos, line) <= PickRadius * 1000 / scale1 Then
      CGElement_Pick = True
    Else
      CGElement_Pick = False
    End If
  End If
End Function

'直线段的旋转变换
Private Sub CGElement_Rotate(basePos As Position, Angle As Double)
  Set m_pLineBegin = m_pLineBegin.pntRotate(basePos, Angle)
  Set m_pLineEnd = m_pLineEnd.pntRotate(basePos, Angle)
End Sub

'直线段的比例变换
Private Sub CGElement_ScaleTransform(scalez As Double, scalex As Double)
  Set m_pLineBegin = m_pLineBegin.pntScale(scalez, scalex)
  Set m_pLineEnd = m_pLineEnd.pntScale(scalez, scalex)
End Sub

'初始化属性参数
Private Sub Class_Initialize()
  m_geLineStyle = vbSolid      '实线
  m_geLineWidth = 1            '线宽为1
  m_geColor = RGB(0, 0, 0)     '黑色
End Sub

'直线段的截距式方程
Public Sub LineKX(k As Double, C As Double)
  If m_pLineBegin.z <> m_pLineEnd.z Then
    k = (m_pLineEnd.x - m_pLineBegin.x) / (m_pLineEnd.z - m_pLineBegin.z)
  Else
    k = 10000
  End If
  C = m_pLineBegin.x - k * m_pLineBegin.z
End Sub