frmdrawmain.frm

数控自动编程系统

  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
End Sub

Private Sub Form_Load()
  '显示启动窗口
  frmFlash.Show
  SetWindowPos frmFlash.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
  
  DrawMain.picDraw.DrawMode = 6
  PickRadius = 0.05
  Command = 0
  intArcMirrorNum = 0
  bolMirror = False
  scale1 = 1
  
  With picDraw
    Scal = .ScaleHeight / .ScaleWidth
    .ScaleWidth = 640 * 15
    .ScaleHeight = .ScaleWidth * Scal
  End With
  sLeft = -320 * 15
  sTopic = picDraw.ScaleHeight / 2
  sRight = -320 * 15 + picDraw.ScaleWidth
  sBottom = -picDraw.ScaleHeight / 2
  Call Coordinate
  
End Sub

Private Sub picDraw_Paint()
  ReDraw (edmNormal)
  SelDraw
End Sub

Private Sub Form_Resize()
  picDraw.Refresh
End Sub

Private Sub Line_Click()
  Command = ecCreateLine
End Sub

Private Sub localEnlarge_Click()
  Command = ecViewZoomOut
End Sub

Private Sub localZoomOut_Click()
  Command = ecViewLocalZoomOut
End Sub

Private Sub Mirror_Click()
  Command = ecMirror
End Sub

Private Sub Move_Click()
  Command = ecMove
End Sub

Private Sub SelNone_Click()
  SelectGEs (ecSelNone)
End Sub

Private Sub picDraw_MouseDown(Button As Integer, Shift As Integer, z As Single, x As Single)
  Dim pPos As New Position
  Dim lpPoint As New Position
  Dim pCommand As CCommand
  Dim pCreateLine As New CCreateLine
  Dim pCreatePolyline As New CCreatePolyLine
  Dim pCreateCircle As New CCreateCirce
  Dim pCreateArc As New CCreateArc
  Dim pCreateText As New CCreateText
  Dim pSelect As New CSelect
  Dim pMove As New CMove
  Dim pRotate As New CRotate
  Dim pMirror As New CMirror
  Dim pViewLocalZoomOut As New CViewLocalZoomOut
  Dim pViewPan As New CviewPan

  On Error Resume Next
   With pPos
     .z = z
     .x = x
   End With
  
  If Button = vbLeftButton Then
      Select Case Command
        Case ecCreateLine
          Set pCommand = pCreateLine
        Case ecCreatePolyLine
          Set pCommand = pCreatePolyline
        Case ecCreateCircle
          Set pCommand = pCreateCircle
        Case ecCreateArc
          Set pCommand = pCreateArc
        Case ecCreateText
          Set pCommand = pCreateText
        Case ecSelOnebyOne
          Set pCommand = pSelect
        Case ecMove
          Set pCommand = pMove
        Case ecRotate
          Set pCommand = pRotate
        Case ecMirror
          Set pCommand = pMirror
        Case ecViewLocalZoomOut
          Set pCommand = pViewLocalZoomOut
        Case ecViewPan
          Set pCommand = pViewPan
      End Select
      Call pCommand.LButtonDown(pPos)
  ElseIf Button = vbRightButton Then
      Select Case Command
        Case ecCreateLine
          Set pCommand = pCreateLine
        Case ecCreatePolyLine
          Set pCommand = pCreatePolyline
        Case ecCreateCircle
          Set pCommand = pCreateCircle
        Case ecCreateArc
          Set pCommand = pCreateArc
        Case ecCreateText
          Set pCommand = pCreateText
        Case ecMove
          Set pCommand = pMove
        Case ecRotate
          Set pCommand = pRotate
        Case ecMirror
          Set pCommand = pMirror
        Case ecViewLocalZoomOut
          Set pCommand = pViewLocalZoomOut
        Case ecViewPan
          Set pCommand = pViewPan
      End Select
      Call pCommand.RButtonDown(pPos)
  End If
End Sub

Private Sub picDraw_MouseMove(Button As Integer, Shift As Integer, z As Single, x As Single)
  Dim pPos As New Position
  Dim lpPoint As New Position
  Dim pCreateLine As New CCreateLine
  Dim pCreatePolyline As New CCreatePolyLine
  Dim pCreateCircle As New CCreateCirce
  Dim pCreateArc As New CCreateArc
  Dim pCreateText As New CCreateText
  Dim pSelect As New CSelect
  Dim pMove As New CMove
  Dim pRotate As New CRotate
  Dim pMirror As New CMirror
  Dim pCommand As New CCommand
  Dim pViewLocalZoomOut As New CViewLocalZoomOut
  Dim pViewPan As New CviewPan
  
  StatusBar1.Panels(1).Text = "Z=" & Str(z) & "  X=" & Str(x)
  
  With pPos
    .z = z
    .x = x
  End With
  
      Select Case Command
        Case ecCreateLine
          Set pCommand = pCreateLine
        Case ecCreatePolyLine
          Set pCommand = pCreatePolyline
        Case ecCreateCircle
          Set pCommand = pCreateCircle
        Case ecCreateArc
          Set pCommand = pCreateArc
        Case ecCreateText
          Set pCommand = pCreateText
        Case ecMove
          Set pCommand = pMove
        Case ecRotate
          Set pCommand = pRotate
        Case ecMirror
          Set pCommand = pMirror
        Case ecViewLocalZoomOut
          Set pCommand = pViewLocalZoomOut
        Case ecViewPan
          Set pCommand = pViewPan
      End Select
    Call pCommand.MouseMove(pPos)
End Sub

Private Sub SelAll_Click()
  SelectGEs (ecSelAll)
End Sub

Private Sub SelArc_Click()
  SelectGEs (ecSelArcs)
End Sub

Private Sub SelCircle_Click()
  SelectGEs (ecSelCircles)
End Sub

Private Sub SelLine_Click()
  SelectGEs (ecSelLines)
End Sub

Private Sub SelOnebyOne_Click()
  Command = ecSelOnebyOne
End Sub

Private Sub SelPolyline_Click()
  SelectGEs (ecSelPolylines)
End Sub

Private Sub SelText_Click()
  SelectGEs (ecSelTexts)
End Sub

Private Sub PolyLine_Click()
  Command = ecCreatePolyLine
End Sub

Private Sub Rotate_Click()
  Command = ecRotate
End Sub

Private Sub ScaleZoomIn_Click()
  Call ScaleZoom(0.8, 0.8)
End Sub

Private Sub ScaleZoomOut_Click()
  Call ScaleZoom(1.2, 1.2)
End Sub



Private Sub Text_Click()
  Command = ecCreateText
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
  Select Case Button.Key
    Case "Select"
      SelOnebyOne_Click
    Case "Line"
      Line_Click
    Case "Polyline"
      PolyLine_Click
    Case "Circle"
      Circle_Click
    Case "Arc"
      Arc_Click
    Case "Text"
      Text_Click
    Case "Move"
      Move_Click
    Case "Rotate"
      Rotate_Click
    Case "Mirror"
      Mirror_Click
    Case "ZoomO"
      ScaleZoomOut_Click
    Case "ZoomI"
      ScaleZoomIn_Click
    Case "ZoomOut"
      ZoomOut_Click
    Case "ZoomIn"
      ZoomIn_Click
    Case "ZoomLocal"
      localZoomOut_Click
    Case "Extent"
      Extent_Click
    Case "GMove"
      ViewPan_Click
  End Select
End Sub

Private Sub ViewPan_Click()
  Command = ecViewPan
End Sub

Private Sub ZoomIn_Click()
  sLeft = sLeft * 1.2
  sRight = sRight * 1.2
  sTopic = sTopic * 1.2
  sBottom = sBottom * 1.2
  Call Coordinate
End Sub

Private Sub ScaleZoom(scalez As Double, scalex As Double)
  Dim i As Integer
  Dim pLine As New CLine
  Dim pPLine As New CPolyLine
  Dim pCircle As New CCircle
  Dim pArc As New CArc
  Dim pGElement As New CGElement
     DrawMain.picDraw.DrawMode = 13
      If SelEntityNum() > 0 Then
        For Each pLine In SelLines
          Set pGElement = pLine
          With pGElement
            .Draw (edmDelete) '清除原来位置上的图元
            Call .ScaleTransform(scalez, scalex)
            .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 .ScaleTransform(scalez, scalex)
            .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 .ScaleTransform(scalez, scalex)
            .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)
            Call .ScaleTransform(scalez, scalex)
            .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
End Sub

Private Sub ZoomOut_Click()
  sLeft = sLeft * 0.8
  sRight = sRight * 0.8
  sTopic = sTopic * 0.8
  sBottom = sBottom * 0.8
  Call Coordinate
End Sub

Private Sub GetExtentBox(minZ As Double, minX As Double, maxZ As Double, maxX As Double)
  Dim pLine As New CLine
  Dim pPLine As New CPolyLine
  Dim pCircle As New CCircle
  Dim pArc As New CArc
  Dim pText As New CText
  Dim pGElement As CGElement
  Dim sourceBox As New Box
  Dim i As Integer
  
  '给矩形对角顶点的坐标赋初值
  minZ = 0
  minX = 0
  maxZ = 0
  maxX = 0
  '按指定绘图模式重绘所有图元
  For Each pLine In lines
    With pLine
      Set ptLineBegin = .pLineBegin
      Set ptLineEnd = .pLineEnd
    End With
    Set pGElement = pLine
    Call pGElement.GetBox(sourceBox)
    With sourceBox
      minZ = min(minZ, .minZ)
      minX = min(minX, .minX)
      maxZ = max(maxZ, .maxZ)
      maxX = max(maxX, .maxX)
    End With
  Next

  For Each pPLine In polylines
    With pPLine
      intPLPointNum = .intPLinePointNum
      For i = 1 To intPLPointNum
        Set ptPLPoints(.ID_PLine, i) = .pPLPoints(.ID_PLine, i)
      Next i
    End With
    Set pGElement = pPLine
    Call pGElement.GetBox(sourceBox)
    With sourceBox
      minZ = min(minZ, .minZ)
      minX = min(minX, .minX)
      maxZ = max(maxZ, .maxZ)
      maxX = max(maxX, .maxX)
    End With
  Next
      
  For Each pCircle In circles
    With pCircle
      Set ptCircleCenter = .pCenter
      Set ptCircleR = .pCircleR
    End With
    Set pGElement = pCircle
    Call pGElement.GetBox(sourceBox)
    With sourceBox
      minZ = min(minZ, .minZ)
      minX = min(minX, .minX)
      maxZ = max(maxZ, .maxZ)
      maxX = max(maxX, .maxX)
    End With
  Next
        
  For Each pArc In arcs
    With pArc
      Set ptArcCenter = .pCenter
      Set ptArcBegin = .pBegin
      Set ptArcEnd = .pEnd
    End With
    Set pGElement = pArc
    Call pGElement.GetBox(sourceBox)
    With sourceBox
      minZ = min(minZ, .minZ)
      minX = min(minX, .minX)
      maxZ = max(maxZ, .maxZ)
      maxX = max(maxX, .maxX)
    End With
  Next

  For Each pText In texts
    Set pGElement = pText
    Call pGElement.GetBox(sourceBox)
    With sourceBox
      minZ = min(minZ, .minZ)
      minX = min(minX, .minX)
      maxZ = max(maxZ, .maxZ)
      maxX = max(maxX, .maxX)
    End With
  Next
End Sub