carc.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 = "CArc"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
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_pCenter As Position
Private m_pBegin As Position
Private m_pEnd As Position
Private m_ID_Arc As Integer
Private Angle1 As Double  '圆弧起始角
Private Angle2 As Double  '圆弧终止角
Private Angle As Double   '
Private ArcR As Double    '圆弧半径

'写ID_Arc属性
Public Property Let ID_Arc(ByVal vData As Integer)
    m_ID_Arc = vData
End Property

'读ID_Arc属性
Public Property Get ID_Arc() As Integer
    ID_Arc = m_ID_Arc
End Property

'写pEnd属性
Public Property Set pEnd(ByVal vData As Position)
    Set m_pEnd = vData
End Property

'读pEnd属性
Public Property Get pEnd() As Position
    Set pEnd = m_pEnd
End Property

'写pBegin属性
Public Property Set pBegin(ByVal vData As Position)
    Set m_pBegin = vData
End Property

'读pBegin属性
Public Property Get pBegin() As Position
    Set pBegin = m_pBegin
End Property

'写pCenter属性
Public Property Set pCenter(ByVal vData As Position)
    Set m_pCenter = vData
End Property

'读pCenter属性
Public Property Get pCenter() As Position
    Set pCenter = m_pCenter
End Property

'根据给定的绘图模式绘图
Private Sub CGElement_Draw(eDrawMode As GEDrawMode)
  Dim pen As Double
  Dim n As Integer
  
  '计算圆弧起始角
  Angle1 = GetAngle(m_pCenter, m_pBegin)
  '计算圆弧终止角
  Angle2 = GetAngle(m_pCenter, m_pEnd)

  '如果没有发生镜像变换，以圆心到起点的距离为半径
  '否则，以圆心到终点的距离为半径
  If bolMirror = False Then
    ArcR = distPtoP(m_pCenter, m_pBegin)
  Else
    ArcR = distPtoP(m_pCenter, m_pEnd)
  End If
  
  '设置线宽
  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
  
  '利用Circle方法绘圆弧
  DrawMain.picDraw.Circle (m_pCenter.z, m_pCenter.x), ArcR, DrawMain.picDraw.ForeColor, Angle1, Angle2
End Sub

'写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_GetBox(pBox As Box)
  Dim z1 As Double, x1 As Double
  Dim z2 As Double, x2 As Double
  Dim i As Integer
  
  '计算圆弧起点和终点的方向角
  Angle1 = GetAngle(m_pCenter, m_pBegin)
  Angle2 = GetAngle(m_pCenter, m_pEnd)
  
  '得到圆弧的起点和终点坐标的最小、最大横坐标和最小、最大纵坐标
  '并赋给变量z1,z2,x1和xy2
  With m_pBegin
    z1 = min(.z, m_pEnd.z)
    x1 = min(.x, m_pEnd.x)
    z2 = max(.z, m_pEnd.z)
    x2 = max(.x, m_pEnd.x)
  End With
  
  '计算圆弧半径
  ArcR = distPtoP(m_pCenter, m_pBegin)
 
  '通过判断圆弧所在的圆与四个坐标轴的交点是否在圆弧内
  '来得到圆弧与各坐标轴的相交关系，并根据相交关系来改
  '变z1,z2,x1和x2的值。
  For i = 0 To 3
    If InArc(Angle1, Angle2, PI / 2 * i) = True Then
      '如果圆弧与X轴正向相交
      If i = 0 Then
        z2 = m_pCenter.z + ArcR
      '如果圆弧与Y轴正向相交
      ElseIf i = 1 Then
        x2 = m_pCenter.x + ArcR
      '如果圆弧与X轴负向相交
      ElseIf i = 2 Then
        z1 = m_pCenter.z - ArcR
      '如果圆弧与Y轴负向相交
      ElseIf i = 3 Then
        x1 = m_pCenter.x - ArcR
      End If
    End If
  Next i
  
  '给圆弧的包围矩形赋属性值
  With pBox
    .minZ = z1
    .minX = x1
    .maxZ = z2
    .maxX = x2
  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_pCenter = m_pCenter.pntMirror(Pos1, Pos2)
  Set m_pBegin = m_pBegin.pntMirror(Pos1, Pos2)
  Set m_pEnd = m_pEnd.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_pCenter = m_pCenter.pntMove(zz, xx)
  Set m_pBegin = m_pBegin.pntMove(zz, xx)
  Set m_pEnd = m_pEnd.pntMove(zz, xx)
End Sub
Private Sub CGElement_Moveonly()
  Set m_pCenter = m_pCenter.pntMove(100, 0)
  Set m_pBegin = m_pBegin.pntMove(100, 0)
  Set m_pEnd = m_pEnd.pntMove(100, 0)
End Sub
'圆弧的拾取
Private Function CGElement_Pick(pos As Position, PickRadius As Double) As Boolean
  Dim sourceBox As New Box
  Dim Angle As Double
  Dim dist As Double
  
  '获取圆弧的包围矩形
  Call CGElement_GetBox(sourceBox)
  
  '如果拾取点没在包围矩形中，则该圆弧不被拾取
  If Not InBox(sourceBox, pos) Then
    CGElement_Pick = False
  '否则，进一步判断
  Else
    '计算拾取点与圆心之间的距离
    dist = distPtoP(pos, m_pCenter)
    '计算拾取点的方向角
    Angle = GetAngle(m_pCenter, pos)
    
    '如果起始角小于终止角
    If Angle1 < Angle2 Then
      '如果拾取点的方向角界于起始角和终止角之间
      '并且拾取点到圆心的距离与圆弧的半径接近，
      '则该圆弧被拾取，否则不被拾取
      If (Angle >= Angle1 And Angle <= Angle2) _
             And Abs(ArcR - dist) <= 200 * PickRadius / scale1 Then
        CGElement_Pick = True
      Else
        CGElement_Pick = False
      End If
   
    '如果起始角大于终止角
    Else
      '如果拾取点的方向角大于起始角或小于终止角
      '并且拾取点到圆心的距离与圆弧的半径接近，
      '则该圆弧被拾取，否则不被拾取
      If (Angle >= Angle1 Or Angle <= Angle2) _
           And Abs(ArcR - dist) <= 200 * PickRadius Then
        CGElement_Pick = True
      Else
        CGElement_Pick = False
      End If
     End If
  End If
End Function

'圆弧的旋转变换
Private Sub CGElement_Rotate(basePos As Position, Angle As Double)
  Set m_pCenter = m_pCenter.pntRotate(basePos, Angle)
  Set m_pBegin = m_pBegin.pntRotate(basePos, Angle)
  Set m_pEnd = m_pEnd.pntRotate(basePos, Angle)
End Sub

'圆弧的比例变换
Private Sub CGElement_ScaleTransform(scalez As Double, scalex As Double)
  Set m_pCenter = m_pCenter.pntScale(scalez, scalex)
  Set m_pBegin = m_pBegin.pntScale(scalez, scalex)
  Set m_pEnd = m_pEnd.pntScale(scalez, scalex)
End Sub

'判断某个角度对应的点是否在由给定起始角和终止角所决定的圆弧上
'返回值为boolean型，boolean值为True时，表示在，否则表示不在
Private Function InArc(Angle1 As Double, Angle2 As Double, Angle As Double) As Boolean
  '如果起始角小于终止角
  If Angle1 < Angle2 Then
    '如果方向角在起始角与终止角之间，则返回True，否则返回False
    If Angle >= Angle1 And Angle <= Angle2 Then
      InArc = True
    Else
      InArc = False
    End If
  '如果起始角小于终止角
  Else
    '如果方向角大于起始角或小于终止角，则返回True，否则返回False
    If Angle >= Angle1 Or Angle <= Angle2 Then
      InArc = True
    Else
      InArc = False
    End If
  End If
End Function