graphics.bas

老外用VB写的CNC仿真程序源码

Attribute VB_Name = "Graphics"
Option Explicit

Public Declare Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function TransparentBlt Lib "msimg32.dll" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
'Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
'Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
'Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long

Private ToolArray(2) As Long, MainMemory As Long
Public PrvX As Integer, PrvY As Integer
Private CenterLine As Integer
Public ShiftX, ShiftZ As Double
Public ToolHeight As Integer, ToolWidth As Integer
Public Frequency As Integer

  Private Declare Function sndPlaySound& Lib "winmm.dll" Alias _
"sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long)
Const SND_SYNC = &H0

    Const SND_ASYNC = &H1

    Const SND_NODEFAULT = &H2

    Const SND_LOOP = &H8

    Const SND_NOSTOP = &H10
Dim Wav As Boolean

Public Sub ClearMainMemory()
 Dim mBitmap As Long, WP As Long

    WP = CreateCompatibleDC(GetDC(0))
    mBitmap = CreateCompatibleBitmap(GetDC(0), 1, 1)
    SelectObject WP, mBitmap
    SetPixel WP, 0, 0, SimWindow.BackColor
    SetPixel WP, 0, 1, SimWindow.BackColor
    SetPixel WP, 1, 0, SimWindow.BackColor
    SetPixel WP, 1, 1, SimWindow.BackColor
    StretchBlt MainMemory, 0, 0, PicWidth, PicHeight, WP, 0, 0, 1, 1, vbSrcCopy
        
End Sub

Private Sub DeleteMainMemory()
    ReleaseDC 0, MainMemory
End Sub

Public Sub PlayWav(SoundName As String)
  Dim tmpSoundName As String
  Dim wFlags%, X%
  tmpSoundName = SoundName
  wFlags% = SND_ASYNC Or SND_LOOP

  X% = sndPlaySound(tmpSoundName, wFlags%)
 
End Sub

Public Sub Run()

Dim i As Integer
    For i = LBound(XYArray) To UBound(XYArray)
Wait:
        If StopSimulation = True Then Exit Sub
        If frmMain.Toolbar.Buttons.Item("Pause").Enabled = False And _
           frmMain.Toolbar.Buttons.Item("Stop").Enabled = True Then
           DoEvents
           GoTo Wait
        End If
        DrawTool XYArray(i).X + ShiftZ, XYArray(i).Y + ShiftX
        
        If RunToCursor = True Then GoTo Nextline
            
        If frmMain.Slider.Value <= 0 Then
            Call Sleep(Abs(frmMain.Slider.Value) * 5)
            Call DrawPicture
            DoEvents
        Else
            If i Mod frmMain.Slider.Value = 0 Then
                Call DrawPicture
                DoEvents
            End If
        End If
        
        
            
        If FastSpeed = True Then
            i = i + 5
            If Wav = False And frmMain.mnuToolsPlaySound.Checked Then
                PlayWav App.path & "\sound\fast.wav"
                Wav = True
            End If
        Else
            If Wav And frmMain.mnuToolsPlaySound.Checked Then
                PlayWav App.path & "\sound\SLOW.wav"
                Wav = False
            End If
        End If
Nextline:
    Next i
End Sub

Public Sub DeleteToolMemory()
    DeleteDC ToolArray(0)
    DeleteDC ToolArray(1)
    DeleteDC ToolArray(2)
End Sub

'allocates space for simulation window & temp memory
Public Sub SetMainMemory()
On Error GoTo EH
'If MainMemory <> 0 Then DeleteMainMemory
    Dim mBitmap As Long, WP As Long

    MainMemory = CreateCompatibleDC(GetDC(0))
    mBitmap = CreateCompatibleBitmap(GetDC(0), PicWidth, PicHeight)
    SelectObject MainMemory, mBitmap
   ' DeleteObject mBitmap
    
    CenterLine = IIf(PicHeight Mod 2 = 0, PicHeight / 2, (PicHeight - 1) / 2)
    
    'set background color of main memory = backcolor
    WP = CreateCompatibleDC(GetDC(0))
    mBitmap = CreateCompatibleBitmap(GetDC(0), 1, 1)
    SelectObject WP, mBitmap
    SetPixel WP, 0, 0, SimWindow.BackColor
    SetPixel WP, 0, 1, SimWindow.BackColor
    SetPixel WP, 1, 0, SimWindow.BackColor
    SetPixel WP, 1, 1, SimWindow.BackColor
    StretchBlt MainMemory, 0, 0, PicWidth, PicHeight, WP, 0, 0, 1, 1, vbSrcCopy
    
EH:
    'ReleaseDC 0, WP
   ' DeleteObject mBitmap
    
    If Err.Number <> 0 Then _
        MsgBox Err.Description
End Sub


'allocates memory for tool
Public Sub SetToolMemory(ByVal ToolFilePath$, ByVal LocalToolWidth%, ByVal LocalToolHeight%)
On Error GoTo EH
'If ToolArray(0) <> 0 Then DeleteToolMemory
    Dim temp As Long
    Dim i As Integer, j As Integer
        
    ToolWidth = LocalToolWidth
    ToolHeight = LocalToolHeight
    
    ToolArray(0) = CreateCompatibleDC(GetDC(0))
    SelectObject ToolArray(0), LoadPicture(ToolFilePath)
    
    
    ToolArray(1) = CreateCompatibleDC(GetDC(0))
    SelectObject ToolArray(1), LoadPicture(ToolFilePath)
    
    
    ToolArray(2) = CreateCompatibleDC(GetDC(0))
    SelectObject ToolArray(2), LoadPicture(ToolFilePath)
    
    
    temp = CreateCompatibleDC(GetDC(0))
    SelectObject temp, LoadPicture(ToolFilePath)
    
    
    'Sets tool mask, to create following tool blanks
    'tool is white
    For i = 0 To ToolHeight - 1
        For j = 0 To ToolWidth - 1
            If GetPixel(temp, j, i) = RGB(255, 0, 255) Then
                SetPixel temp, j, i, vbBlack
            Else
                SetPixel temp, j, i, vbWhite
            End If
        Next j
    Next i
          
    'Sets upper tool blank
    For i = 0 To ToolHeight - 1
        For j = 0 To ToolWidth - 1
            If GetPixel(temp, j, i) = vbWhite Then
                SetPixel ToolArray(1), j, i, SimWindow.BackColor
            Else
                SetPixel ToolArray(1), j, i, vbBlack
            End If
        Next j
    Next i
            
    'Sets lower tool blank
     For i = 0 To ToolHeight - 1
        For j = 0 To ToolWidth - 1
            SetPixel ToolArray(2), j, i, GetPixel(ToolArray(1), j, ToolHeight - 1 - i)
        Next j
    Next i
    
    'ReleaseDC 0, temp
    'DeleteObject temp
EH:
    If Err.Number <> 0 Then _
        MsgBox Err.Description
End Sub


Public Sub DrawWorkPiece(ByVal length As Integer, ByVal Diameter As Integer)
On Error GoTo EH
    Dim i As Integer
    Dim mBitmap As Long, WP As Long
    
    'set global variable
    WorkPieceLength = length
    
        'set array for 3d view
    ReDim ThreeDArray(length, 1)
    For i = 0 To UBound(ThreeDArray)
        ThreeDArray(i, 0) = CInt(Diameter / 2#)
    Next i
    
    WP = CreateCompatibleDC(GetDC(0))
    mBitmap = CreateCompatibleBitmap(GetDC(0), 1, 1)
    SelectObject WP, mBitmap
    
    SetPixel WP, 0, 0, SimWindow.WPColor
    SetPixel WP, 0, 1, SimWindow.WPColor
    SetPixel WP, 1, 0, SimWindow.WPColor
    SetPixel WP, 1, 1, SimWindow.WPColor
    
    Diameter = CInt(Diameter / 2)
    
    StretchBlt MainMemory, 0, CenterLine - Diameter, length, Diameter * 2, WP, 0, 0, 1, 1, vbSrcCopy
    
    'ReleaseDC 0, WP
    'DeleteObject mBitmap
EH:
    If Err.Number <> 0 Then _
        MsgBox Err.Description
End Sub

'copy from memory to picture box
Public Sub DrawPicture()
   BitBlt frmMain.picSim.hdc, 0, 0, PicWidth, PicHeight, MainMemory, 0, 0, vbSrcCopy
End Sub

'draws tool at machine's x and y values, not absolute
Public Sub DrawTool(ByVal AtX As Integer, ByVal AtY As Integer)
    
    'frmMain.StatusBar.Panels("ToolPosition").Text = "X: " & AtX & ", Y: " & AtY
    
    'get absolute x, y positions
    Dim TempY, MainToolY As Integer
    
    '3D Object{
    If -AtX >= 0 And -AtX <= UBound(ThreeDArray) Then
        If ThreeDArray(-AtX, 0) > Abs(AtY) Then
            If TAPER = 1 Then ThreeDArray(-AtX, 1) = 1
                ThreeDArray(-AtX, 0) = Abs(AtY)
        End If
    End If '}
    
    
    TempY = AtY
    AtX = AtX + WorkPieceLength
    AtY = CenterLine - AtY - ToolHeight
    
    'upper side main blank tool draw karo
    TransparentBlt MainMemory, PrvX, PrvY, ToolWidth, ToolHeight, ToolArray(1), 0, 0, ToolWidth, ToolHeight, vbBlack
    MainToolY = AtY
    PrvX = AtX
    PrvY = AtY
    
    AtY = CenterLine - (-TempY)
    
    TransparentBlt MainMemory, AtX, AtY, ToolWidth, ToolHeight, ToolArray(2), 0, 0, ToolWidth, ToolHeight, vbBlack
    TransparentBlt MainMemory, AtX, MainToolY, ToolWidth, ToolHeight, ToolArray(0), 0, 0, ToolWidth, ToolHeight, RGB(255, 0, 255)
End Sub


Public Function FindBilletSize() As Boolean
Dim i As Integer, j As Integer
Dim txt$

i = frmMain.TextEditor.Find("[BILLET")
If i = -1 Then
    MsgBox "Billet Size Not Found", vbCritical + vbOKOnly
    FindBilletSize = False
    Exit Function
End If
For i = 0 To frmMain.DebugWindow.Rows - 1
    j = InStr(frmMain.DebugWindow.TextMatrix(i, 2), "[BILLET")
    If j > 0 Then Exit For
Next i
txt = Trim(frmMain.DebugWindow.TextMatrix(i, 2))
txt = Right(txt, Len(txt) - 7)
Dim s() As String
s = Split(Trim(txt))
s(0) = Trim(s(0))
s(1) = Trim(s(1))
For i = 0 To 1
    Select Case Left(s(i), 1)
        Case "X":
            WorkPieceDiameter = Right(s(i), Len(s(i)) - 1) * 10
        Case "Z":
            WorkPieceLength = Right(s(i), Len(s(i)) - 1) * 10
    End Select
Next i
FindBilletSize = True
End Function

Public Sub Effects()
    Dim i, j As Integer
    Dim CurrentColor, RightColor As OLE_COLOR
    
    For i = 0 To WorkPieceLength 'frmMain.picCNC.ScaleWidth
        For j = 0 To CenterLine 'frmMain.picCNC.ScaleHeight - 1
            CurrentColor = GetPixel(MainMemory, i, j)
            If CurrentColor = SimWindow.WPColor Then
                RightColor = GetPixel(MainMemory, i + 1, j)
                If RightColor = SimWindow.BackColor Then
                    Dim k As Integer
                    For k = j To PicHeight - j + 2
                        If GetPixel(MainMemory, i, k) = SimWindow.WPColor Then
                                SetPixel MainMemory, i, k, SimWindow.EffectColor
                        End If
                    Next k
                End If
            End If
        Next j
    Next i
    
    Call DrawPicture
End Sub

Public Sub DisplayInfoForm(Mode As Integer, TimeInMilliSeconds As Integer)
    frmInfo.Timer4.Interval = TimeInMilliSeconds
    frmInfo.Show Mode, frmMain
End Sub