cviewzoom.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 = "CViewLocalZoomOut"
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 rcLB As New Position, rcRT As New Position
  Dim minZ As Double, minX As Double
  Dim maxZ As Double, maxX As Double
  Dim pos As New Position, bp As New Position, dp As New Position
  intmStep = intmStep + 1
  Select Case intmStep
    Case 1
      DrawMain.picDraw.DrawMode = 6
      Set pBasePos = pPos
      Set pDesPos = pPos
      '"请输入缩放矩形的对角点："
      
    Case 2
      '在绘图环境中绘矩形
      DrawMain.picDraw.Line (bp.z, bp.x)-(pos.z, pos.x), vbBlue, B
      DrawMain.picDraw.DrawMode = 13
      Call ReDraw(edmDelete)
      Set pDesPos = pPos
      Dim rc As rect
      Call GetClientRect(DrawMain.picDraw.hwnd, rc)
      
      With rcLB
        .z = rc.Left * Screen.TwipsPerPixelX
        .x = rc.Bottom * Screen.TwipsPerPixelY
      End With
      With rcRT
        .z = rc.Right * Screen.TwipsPerPixelX
        .x = rc.Top * Screen.TwipsPerPixelY
      End With
            
      '计算新坐标系与逻辑坐标的比例因子
      Dim scalez As Double, scalex As Double
      minZ = min(pBasePos.z, pDesPos.z)
      maxZ = max(pBasePos.z, pDesPos.z)
      minX = min(pBasePos.x, pDesPos.x)
      maxX = max(pBasePos.x, pDesPos.x)
      scalez = Abs((rcRT.z - rcLB.z) / (maxZ - minZ))
      scalex = Abs((rcRT.x - rcLB.x) / (maxX - minX))
      scale1 = min(scalez, scalex)
      
      '重新设置视口大小
      sLeft = minZ
      sTopic = maxX
      If scalez < scalex Then
        minX = maxX - (maxZ - minZ) * Scal
      Else
        maxZ = minZ + (maxX - minX) / Scal
      End If
      sRight = maxZ
      sBottom = minX
     
      Call Coordinate
    DrawMain.picDraw.DrawMode = 6
    intmStep = 0
  End Select
 End Sub

Private Sub CCommand_MouseMove(pPos As Position)
  Dim prepos As New Position, curpos As New Position
  Select Case intmStep
      Case 1
        Set prepos = pDesPos
        Set curpos = pPos
        '用Line方法绘矩形
        DrawMain.picDraw.DrawStyle = vbSolid
        DrawMain.picDraw.Line (pBasePos.z, pBasePos.x)-(prepos.z, prepos.x), vbBlue, B
        DrawMain.picDraw.Line (pBasePos.z, pBasePos.x)-(curpos.z, curpos.x), vbBlue, B
        Set pDesPos = pPos
  End Select
End Sub

Private Sub CCommand_RButtonDown(pPos As Position)
  intmStep = 0
End Sub