cmirror.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 = "CMirror"
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

'单击鼠标左键时发生
Private Sub CCommand_LButtonDown(pPos As Position)
  Dim i As Integer
  Dim pGElement As CGElement
  Dim pLine As New CLine
  Dim pPLine As New CPolyLine
  Dim pCircle As New CCircle
  Dim pArc As New CArc
  
  '设置绘图环境的绘图模式为6
  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)        '清除原来位置上的图元
            Call .Mirror(ptBasePos, ptDesPos)   '将图元移到目标位置
            .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)
            Call .Mirror(ptBasePos, ptDesPos)
            .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)
            Call .Mirror(ptBasePos, ptDesPos)
            .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
        
        '圆弧的镜像比较特殊，需要交换起点和终点
        Dim point As Position
        Dim intMod As Integer
        '记录圆弧发生镜像的次数
        intArcMirrorNum = intArcMirrorNum + 1
        intMod = intArcMirrorNum Mod 2
        For Each pArc In SelArcs
          Set pGElement = pArc
          With pGElement
            Select Case intMod
              Case 0
                bolMirror = True
              Case 1
                bolMirror = False
            End Select
            .Draw (edmDelete)
            Select Case intMod
              Case 0
                bolMirror = False
              Case 1
                bolMirror = True
            End Select
            Call .Mirror(ptBasePos, ptDesPos)
            '交换圆弧的起点和终点
            With pArc
              Set point = .pBegin
              Set .pBegin = .pEnd
              Set .pEnd = point
            End With
            Set pGElement = pArc
            pGElement.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
      '将绘图环境的绘图模式设置为6
      DrawMain.picDraw.DrawMode = 6
    intmStep = 0   '鼠标左键单击次数置0
  End Select
End Sub

'鼠标移动时发生
Private Sub CCommand_MouseMove(pPos As Position)
  Dim i As Integer
  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
      Dim pGElement As CGElement
      
      '记录当前橡皮线的终点，下次移动鼠标时删除橡皮线用
      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)
  If intmStep = 1 Then
    Dim pTempLine As CLine
    Set pTempLine = New CLine
    Dim pGElement As CGElement
    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