module1.bas

数控自动编程系统

Attribute VB_Name = "Module1"
Option Explicit

Global Const PI = 3.1415926

'绘图模式
Public Enum GEDrawMode
    edmNormal = 1
    edmSelect = 2
    edmDelete = 3
End Enum

'线型
Public Enum LineStyle
    vbSolid = 0
    vbDash = 1
    vbDot = 2
    vbDashDot = 3
    vbDashDotDot = 4
    vbInvisible = 5
    vbInsideSolid = 6
End Enum

'命令类型
Public Enum GECommandType
    ecUnknown = 0
    ecCreatePoint = 1
    ecCreateLine = 2
    ecCreatePolyLine = 3
    ecCreateCircle = 4
    ecCreateArc = 5
    ecCreateText = 6
    
    ecSelOnebyOne = 11
    ecSelLines = 12
    ecSelPolylines = 13
    ecSelCircles = 14
    ecSelArcs = 15
    ecSelTexts = 16
    ecSelAll = 17
    ecSelNone = 18
    
    ecMove = 21
    ecRotate = 22
    ecMirror = 23
    
    ecviewzoomin = 31
    ecViewZoomOut = 32
    ecViewLocalZoomOut = 33
    ecViewPan = 34
    ecViewExtent = 35
End Enum

Public Type POINTAPI
  z As Long
  x As Long
End Type

Public Type rect
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Public sLeft As Double
Public sTopic As Double
Public sRight As Double
Public sBottom As Double
Public Scal As Double

Public ptLineBegin As New Position
Public ptLineEnd As New Position
Public ptPLPoints(1 To 100, 1 To 100) As New Position
Public PLPoints(1 To 100, 1 To 100) As New Position
Public intPLPointNum As Integer
Public ptCircleCenter As New Position
Public ptCircleR As New Position
Public ptArcCenter As New Position
Public ptArcBegin As New Position
Public ptArcEnd As New Position

Public Command As GECommandType
Public GElements As New CGElements
Public lines As New CLines
Public polylines As New CPolylines
Public circles As New CCircles
Public arcs As New CArcs
Public texts As New CTexts

Public SelLines As New CLineSel
Public SelPLines As New CPLineSel
Public SelCircles As New CCircleSel
Public SelArcs As New CArcSel
Public SelTexts As New CTexts

Public intmStep As Integer
Public PickRadius As Double

Public bolMirror As Boolean
Public intArcMirrorNum As Integer

Public ptBasePos As New Position
Public ptDesPos As New Position
Public pBasePos As New Position
Public pDesPos As New Position
Public scale1 As Double
Public sinOriginZ As Double
Public sinOriginX As Double

Public geNum As Integer
Public entCount As Integer

Public Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal z1 As Long, ByVal x1 As Long, ByVal z2 As Long, ByVal x2 As Long) As Long
Public Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As rect) As Long
Public Declare Function GetBkColor Lib "gdi32" (ByVal hdc As Long) As Long

Function distPtoP(Pos1 As Position, Pos2 As Position) As Double
  Dim disz As Double, disx As Double, dist As Double
  With Pos1
    disz = .z - Pos2.z
    disx = .x - Pos2.x
  End With
  distPtoP = Sqr(disz * disz + disx * disx)
  'distPtoP = (disz + disx + 2 * max(disz, disx)) / 3
End Function

'计算点到直线的距离
Function distPtoL(pos As Position, CLine1 As CLine) As Double
  Dim k As Double
  Dim C As Double
  Dim pz As Double, px As Double
  Dim distZ As Double, distX As Double
  With pos
    pz = .z
    px = .x
  End With
  Call CLine1.LineKX(k, C)
  If k = 0 Then
    distZ = 10000
    distX = Abs(px - CLine1.pLineBegin.x)
  ElseIf k = 10000 Then
    distZ = Abs(pz - CLine1.pLineBegin.z)
    distX = 10000
  Else
    distZ = Abs(pz - (px - C) / k)
    distX = Abs(px - (k * pz + C))
  End If
  distPtoL = min(distZ, distX)
End Function

Function GetAngle(pBegin As Position, pEnd As Position) As Double
  Dim tansita As Double
  Dim sita As Double
  Dim subEBz As Double
  subEBz = Abs(pEnd.z - pBegin.z)
  If pEnd.z = pBegin.z Then subEBz = 0.0001
  tansita = (Abs(pEnd.x - pBegin.x)) / subEBz
  sita = Atn(tansita)
  '如果终点横坐标大于起点横坐标，并且终点纵坐标大于起点纵坐标
  If pEnd.z >= pBegin.z And pEnd.x >= pBegin.x Then
    GetAngle = sita
  '如果终点横坐标小于起点横坐标，并且终点纵坐标大于起点纵坐标
  ElseIf pEnd.z <= pBegin.z And pEnd.x >= pBegin.x Then
    GetAngle = PI - sita
  '如果终点横坐标小于起点横坐标，并且终点纵坐标小于起点纵坐标
  ElseIf pEnd.z <= pBegin.z And pEnd.x <= pBegin.x Then
    GetAngle = PI + sita
  '如果终点横坐标大于起点横坐标，并且终点纵坐标小于起点纵坐标
  ElseIf pEnd.z >= pBegin.z And pEnd.x <= pBegin.x Then
    GetAngle = 2 * PI - sita
  End If
End Function

Function InBox(Box As Box, curpos As Position) As Boolean
  If curpos.z > Box.minZ And curpos.x > Box.minX _
     And curpos.z < Box.maxZ And curpos.x < Box.maxX Then
     InBox = True
  Else
    InBox = False
  End If
End Function
Function min(la As Double, lb As Double) As Double
  If la < lb Then
    min = la
  Else
    min = lb
  End If
End Function
Function max(la As Double, lb As Double) As Double
  If la > lb Then
    max = la
  Else
    max = lb
  End If
End Function

Public Sub ReDraw(dmode As GEDrawMode)
  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 i As Integer
  
  '按指定绘图模式重绘所有图元
  For Each pLine In lines
    Set pGElement = pLine
    pGElement.Draw (dmode)
  Next

  For Each pPLine In polylines
    Set pGElement = pPLine
    pGElement.Draw (dmode)
  Next
      
  For Each pCircle In circles
    Set pGElement = pCircle
    pGElement.Draw (dmode)
  Next
        
  For Each pArc In arcs
    Set pGElement = pArc
    pGElement.Draw (dmode)
  Next

  For Each pText In texts
    Set pGElement = pText
    pGElement.Draw (dmode)
  Next
End Sub

Public Sub SelDraw()
  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 i As Integer
  
  '按指定绘图模式重绘所有图元
  For Each pLine In SelLines
    Set pGElement = pLine
    pGElement.Draw (edmDelete)
    pGElement.Draw (edmSelect)
  Next

  For Each pPLine In SelPLines
    Set pGElement = pPLine
    pGElement.Draw (edmDelete)
    pGElement.Draw (edmSelect)
  Next
      
  For Each pCircle In SelCircles
    Set pGElement = pCircle
    pGElement.Draw (edmDelete)
    pGElement.Draw (edmSelect)
  Next
        
  For Each pArc In SelArcs
    Set pGElement = pArc
    pGElement.Draw (edmDelete)
    pGElement.Draw (edmSelect)
  Next

  For Each pText In SelTexts
    Set pGElement = pText
    pGElement.Draw (edmDelete)
    pGElement.Draw (edmSelect)
  Next
End Sub

Public Function SelEntityNum() As Integer
  SelEntityNum = SelLines.Count + SelPLines.Count + SelCircles.Count + SelArcs.Count
End Function

'删除所有选择集中的图元
Public Sub SelRemove()
  Dim i As Integer
  Dim intLCount As Integer
  Dim intPLCount As Integer
  Dim intCCount As Integer
  Dim intACount As Integer
  intLCount = SelLines.Count
  intPLCount = SelPLines.Count
  intCCount = SelCircles.Count
  intACount = SelArcs.Count
  With SelLines
    For i = intLCount To 1 Step -1
      .Remove (i)
    Next i
  End With
  With SelPLines
    For i = intPLCount To 1 Step -1
      .Remove (i)
    Next i
  End With
  With SelCircles
    For i = intCCount To 1 Step -1
      .Remove (i)
    Next i
  End With
  With SelArcs
    For i = intACount To 1 Step -1
      .Remove (i)
    Next i
  End With
  
End Sub

'彻底删除所有选择集中的图元
Public Sub AllSelRemove()
  Dim i As Integer
  Dim intLCount As Integer
  Dim intPLCount As Integer
  Dim intCCount As Integer
  Dim intACount As Integer
  Dim intTCount As Integer
  intLCount = SelLines.Count
  intPLCount = SelPLines.Count
  intCCount = SelCircles.Count
  intACount = SelArcs.Count
  intTCount = SelTexts.Count
  
  '删除直线图元选择集中的所有图元
  '并从直线段集合类中删除对应图元
  With SelLines
    For i = intLCount To 1 Step -1
      lines.Remove (Str(.Item(i).ID_Line))
      .Remove (i)
    Next i
  End With
  
  '删除多义线图元选择集中的所有图元
  '并从多义线集合类中删除对应图元
  With SelPLines
    For i = intPLCount To 1 Step -1
      polylines.Remove (Str(.Item(i).ID_PLine))
      .Remove (i)
    Next i
  End With
  
  '删除圆类图元选择集中的所有图元
  '并从圆集合类中删除对应图元
  With SelCircles
    For i = intCCount To 1 Step -1
      circles.Remove (Str(.Item(i).ID_Circle))
      .Remove (i)
    Next i
  End With
  
  '删除圆弧图元选择集中的所有图元
  '并从圆弧集合类中删除对应图元
  With SelArcs
    For i = intACount To 1 Step -1
      arcs.Remove (Str(.Item(i).ID_Arc))
      .Remove (i)
    Next i
  End With
  
  '删除文本图元选择集中的所有图元
  '并从文本集合类中删除对应的图元
  With SelTexts
    For i = intTCount To 1 Step -1
      texts.Remove (Str(.Item(i).ID_Text))
      .Remove (i)
    Next i
  End With
End Sub

'根据不同的选择方式选择图元
Public Sub SelectGEs(SelType As GECommandType)
  Dim pGElement As New CGElement
  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 PLPoints(1 To 100, 1 To 100) As Position
  Dim i As Integer
  
  DrawMain.picDraw.DrawMode = 13
  Select Case SelType
    Case ecSelLines
      ReDraw (edmNormal)
      SelRemove
      If lines.Count > 0 Then
        For Each pLine In lines
          Set pGElement = pLine
          With pGElement
            .Draw (edmDelete)
            .Draw (edmSelect)     '用选择模式绘图元
          End With
          '将图元添加到选择集SelLines中
          With pLine
            Call SelLines.Add(.geLineWidth, .geLineStyle, .geColor, .ID_Line, .pLineBegin, .pLineEnd)
          End With
        Next
      End If
      
    Case ecSelPolylines
      ReDraw (edmNormal)
      SelRemove
      If polylines.Count > 0 Then
        For Each pPLine In polylines
          With pPLine
            For i = 1 To .intPLinePointNum
              Set PLPoints(.ID_PLine, i) = .pPLPoints(.ID_PLine, i)
            Next i
          End With
         Set pGElement = pPLine
          With pGElement
            .Draw (edmDelete)
            .Draw (edmSelect)
          End With
          With pPLine
            Call SelPLines.Add(.intPLinePointNum, PLPoints(), .geLineWidth, .geLineStyle, .geColor, .ID_PLine)
          End With
        Next
      End If

      
    Case ecSelCircles
      ReDraw (edmNormal)
      SelRemove
      If circles.Count > 0 Then
        For Each pCircle In circles
          Set pGElement = pCircle
          With pGElement
            .Draw (edmDelete)
            .Draw (edmSelect)
          End With
          With pCircle
            Call SelCircles.Add(.geLineWidth, .geLineStyle, .geColor, .pCircleR, .pCenter, .ID_Circle)
          End With
        Next
      End If
      
    Case ecSelArcs
      ReDraw (edmNormal)
      SelRemove
      If arcs.Count > 0 Then
        For Each pArc In arcs
          Set pGElement = pArc
          With pGElement
            .Draw (edmDelete)
            .Draw (edmSelect)
          End With
          With pArc
            Call SelArcs.Add(.geLineWidth, .geLineStyle, .geColor, .pCenter, .pBegin, .pEnd, .ID_Arc)
          End With
        Next
      End If
      
    Case ecSelTexts
      ReDraw (edmNormal)
      SelRemove
      If texts.Count > 0 Then
        For Each pText In texts
          Set pGElement = pText
          With pGElement
            .Draw (edmSelect)
          End With
          With pText
            Call SelTexts.Add(.z, .x, .Height, .Wide, .Content, .geColor, .ID_Text)
          End With
        Next
      End If
    
    Case ecSelAll
      ReDraw (edmNormal)
      If GElements.Count > 0 Then
        For Each pLine In lines
          Set pGElement = pLine
          With pGElement
            .Draw (edmDelete)
            .Draw (edmSelect)     '用选择模式绘图元
          End With
          '将图元添加到选择集SelLines中
          With pLine
            Call SelLines.Add(.geLineWidth, .geLineStyle, .geColor, .ID_Line, .pLineBegin, .pLineEnd)
          End With
        Next
      End If
      
      If polylines.Count > 0 Then
        For Each pPLine In polylines
          With pPLine
            For i = 1 To .intPLinePointNum
              Set PLPoints(.ID_PLine, i) = .pPLPoints(.ID_PLine, i)
            Next i
          End With
          Set pGElement = pPLine
          With pGElement
            .Draw (edmDelete)
            .Draw (edmSelect)
          End With
          With pPLine
            Call SelPLines.Add(.intPLinePointNum, PLPoints(), .geLineWidth, .geLineStyle, .geColor, .ID_PLine)
          End With
        Next
      End If
  
      
      If circles.Count > 0 Then
        For Each pCircle In circles
          Set pGElement = pCircle
          With pGElement
            .Draw (edmDelete)
            .Draw (edmSelect)
          End With
          With pCircle
            Call SelCircles.Add(.geLineWidth, .geLineStyle, .geColor, .pCircleR, .pCenter, .ID_Circle)
          End With
        Next
      End If
      
      If arcs.Count > 0 Then
        For Each pArc In arcs
          Set pGElement = pArc
          With pGElement
            .Draw (edmDelete)
            .Draw (edmSelect)
          End With
          With pArc
            Call SelArcs.Add(.geLineWidth, .geLineStyle, .geColor, .pCenter, .pBegin, .pEnd, .ID_Arc)
          End With
        Next
      End If
      
      If texts.Count > 0 Then
        For Each pText In texts
          Set pGElement = pText
          With pGElement
            .Draw (edmSelect)
          End With
          With pText
            Call SelTexts.Add(.z, .x, .Height, .Wide, .Content, .geColor, .ID_Text)
          End With
        Next
      End If

    Case ecSelNone
      ReDraw (edmNormal)
      Call SelRemove
  End Select
End Sub

Public Sub Coordinate()
  DrawMain.picDraw.Scale (sLeft, sTopic)-(sRight, sBottom)
  DrawMain.picDraw.Refresh
End Sub