crotate.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 = "CRotate"
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 CCommand
Dim pGElement As New CGElement

'单击鼠标左键时发生
Private Sub CCommand_LButtonDown(pPos As Position)
  Dim i As Integer ''
  Dim Angle As Double
  Dim pLine As New CLine
  Dim pPLine As New CPolyLine
  Dim pCircle As New CCircle
  Dim pArc As New CArc
  Dim pGElement As CGElement
  
  DrawMain.picDraw.DrawMode = 6
  'intmStep变量记录单击鼠标左键的次数
  intmStep = intmStep + 1
  Select Case intmStep
    Case 1
      Set ptBasePos = pPos
      Set ptDesPos = pPos
      '请输入第二点：
      
    Case 2
      Set ptDesPos = pPos
      Dim pTempLine As CLine
      Set pTempLine = New CLine
      '清除鼠标移动时留下的橡皮线
      Set ptLineBegin = ptBasePos
      Set ptLineEnd = ptDesPos
      With pTempLine
        Set .pLineBegin = ptLineBegin
        Set .pLineEnd = ptLineEnd
      End With
      Set pGElement = pTempLine
      pGElement.Draw (edmNormal)
      Set pTempLine = Nothing
      '设置绘图模式为13
      DrawMain.picDraw.DrawMode = 13
      '如果选择集不为空，将选择集中的图元旋转到目标位置并进行绘制
      If SelEntityNum() > 0 Then
        For Each pLine In SelLines
          Set pGElement = pLine
          With pGElement
            .Draw (edmDelete)                '清除原来位置上的图元
             Angle = GetAngle(ptBasePos, ptDesPos)
            Call .Rotate(ptBasePos, Angle)   '将图元旋转到目标位置
            .Draw (edmSelect)
          End With
          With pLine
            lines.Remove (Str(.ID_Line))
            Call lines.Add(.geLineWidth, .geLineStyle, .geColor, .ID_Line, .pLineBegin, .pLineEnd, Str(.ID_Line))
          End With
        Next
        
        For Each pPLine In SelPLines
          Set pGElement = pPLine
          With pGElement
            .Draw (edmDelete)
             Angle = GetAngle(ptBasePos, ptDesPos)
            Call .Rotate(ptBasePos, Angle)   '将图元移到目标位置
            .Draw (edmSelect)
          End With
          With pPLine
            Dim PLPoints(1 To 100, 1 To 100) As Position
            For i = 1 To .intPLinePointNum
              Set PLPoints(.ID_PLine, i) = .pPLPoints(.ID_PLine, i)
            Next i
            polylines.Remove (Str(.ID_PLine))
            Call polylines.Add(.intPLinePointNum, PLPoints, .geLineWidth, .geLineStyle, .geColor, .ID_PLine, Str(.ID_PLine))
          End With
        Next
        
        For Each pCircle In SelCircles
          Set pGElement = pCircle
          With pGElement
            .Draw (edmDelete)
             Angle = GetAngle(ptBasePos, ptDesPos)
            Call .Rotate(ptBasePos, Angle)   '将图元移到目标位置
            .Draw (edmSelect)
          End With
          With pCircle
            circles.Remove (Str(.ID_Circle))
            Call circles.Add(.geLineWidth, .geLineStyle, .geColor, .pCircleR, .pCenter, .ID_Circle, Str(.ID_Circle))
          End With
        Next
        
        For Each pArc In SelArcs
          Set pGElement = pArc
          With pGElement
            .Draw (edmDelete)
             Angle = GetAngle(ptBasePos, ptDesPos)
            Call .Rotate(ptBasePos, Angle)   '将图元移到目标位置
            .Draw (edmSelect)
          End With
          With pArc
            arcs.Remove (Str(.ID_Arc))
            Call arcs.Add(.geLineWidth, .geLineStyle, .geColor, .pCenter, .pBegin, .pEnd, .ID_Arc, Str(.ID_Arc))
          End With
        Next
      End If
      DrawMain.picDraw.DrawMode = 6
      intmStep = 0
  End Select
      
End Sub

Private Sub CCommand_MouseMove(pPos As Position)
  Dim i As Integer
  Dim pGElement As CGElement
  
  Select Case intmStep
    Case 0
      '请输入旋转的基点：
    Case 1
      Dim prepos As New Position
      Dim curpos As New Position
      Dim pTempLine1 As CLine
      Dim pTempLine2 As CLine
      Set pTempLine1 = New CLine
      Set pTempLine2 = New CLine
      
      Set prepos = ptDesPos
      Set curpos = pPos
      
      '清除上一次绘制的橡皮线
      Set ptLineBegin = ptBasePos
      Set ptLineEnd = prepos
      With pTempLine1
        Set .pLineBegin = ptLineBegin
        Set .pLineEnd = ptLineEnd
      End With
      Set pGElement = pTempLine1
      pGElement.Draw (edmNormal)
      Set pTempLine1 = Nothing
      
      '在当前位置绘制橡皮线
      Set ptLineBegin = ptBasePos
      Set ptLineEnd = curpos
      With pTempLine2
        Set .pLineBegin = ptLineBegin
        Set .pLineEnd = ptLineEnd
      End With
      Set pGElement = pTempLine2
      pGElement.Draw (edmNormal)
      Set pTempLine2 = Nothing
      
      '设置橡皮线的终点为当前点
      Set ptDesPos = pPos
    End Select
End Sub

'右击鼠标时发生
Private Sub CCommand_RButtonDown(pPos As Position)
  Dim i As Integer
  Dim pGElement As CGElement
  Dim prepos As Position
  Set prepos = New Position
  Set prepos = ptDesPos
  If intmStep = 1 Then
    Dim pTempLine As CLine
    Set pTempLine = New CLine
    '清除上一个绘制的橡皮线
    Set ptLineBegin = ptBasePos
    Set ptLineEnd = prepos
    With pTempLine
      Set .pLineBegin = ptLineBegin
      Set .pLineEnd = ptLineEnd
    End With
    Set pGElement = pTempLine
    pGElement.Draw (edmNormal)
    Set pTempLine = Nothing
  End If
  intmStep = 0     '将鼠标左击次数置0
  '请输入移动的起始点:
  
End Sub