M:\Mike (latest)\Stub Programs\Dump Tests - Doneprinter\test.frm
File saved: 4/23/2006 6:00:34 PM
Generated: 4/30/2006 4:52:17 PM
Table of Contents (Designer Object Definition) Declarations df_bin_Click pollme GetBinary df_dll_Click SendCommand df_nomral_Click status_Change
VERSION 5.00 Table of Contents Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "MSCOMM32.OCX" Begin VB.Form Form1 Caption = "Form1" ClientHeight = 4425 ClientLeft = 60 ClientTop = 345 ClientWidth = 5625 LinkTopic = "Form1" ScaleHeight = 4425 ScaleWidth = 5625 StartUpPosition = 3 'Windows Default Begin MSCommLib.MSComm Com Left = 4680 Top = 2160 _ExtentX = 1005 _ExtentY = 1005 _Version = 393216 DTREnable = -1 'True BaudRate = 115200 End Begin VB.Frame Frame3 Caption = "Status/Results" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 1815 Left = 0 TabIndex = 3 Top = 2520 Width = 5535 Begin VB.TextBox status Height = 1455 Left = 120 MultiLine = -1 'True ScrollBars = 2 'Vertical TabIndex = 4 Top = 240 Width = 5295 End End Begin VB.Frame Frame2 Caption = "Select Test" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 2295 Left = 2520 TabIndex = 2 Top = 120 Width = 3015 Begin VB.CommandButton df_bin Caption = "DF --> Binary" Height = 615 Left = 1680 TabIndex = 7 Top = 240 Width = 1215 End Begin VB.CommandButton df_nomral Caption = "DF --> Normal (RGB)" Height = 615 Left = 240 TabIndex = 6 Top = 1080 Width = 1215 End Begin VB.CommandButton df_dll Caption = "DF --> DLL (RGB)" Height = 615 Left = 240 TabIndex = 5 Top = 240 Width = 1215 End End Begin VB.Frame Frame1 Caption = "Dumped Image" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 2295 Left = 0 TabIndex = 0 Top = 120 Width = 2415 Begin VB.PictureBox Pic Height = 1815 Left = 120 ScaleHeight = 1755 ScaleWidth = 1995 TabIndex = 1 Top = 240 Width = 2055 End End End
Attribute VB_Name = "Form1" Table of Contents Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False '************************************************************************ '********************************************************* '****************************************** ' Created By: Michael Konicki ' Date: 4/19/2006 (last edit) ' 'This program is strickly for analysis purposes. More specifically 'it is used to show that the CMU.DLL is actually faster then the 'standard MSComm object VB comes with. The time it uses as measuremeants are 'CPU ticks which are recorded fro mthe Win32GetTickCounter API. ' '****************************************** '********************************************************* '************************************************************************ Private Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long) Private Declare Function Win32GetTickCounter Lib "Kernel32" Alias "GetTickCount" () As Long
Private Sub df_bin_Click() Table of Contents '************************************************* ' Dumps a frame using binary image dump + packets '************************************************* 'Display Starting Message status.Text = "Starting LineMode Test" & vbCrLf Me.Refresh 'open the comport Com.CommPort = 1 'our comport holding the CMUcam Com.InBufferSize = 32764 'input buffer size Com.PortOpen = True 'open the port for communication Sleep (100) 'Make sure the port opens fully 'Enable pollmode for the cmucam Dim ret As String 'start pollmode & error check ret = SendCommand("PM 1", 50) If ret = "-1" Then status.Text = status.Text & "Error, please retry" & vbCrLf Exit Sub End If 'Start linemode & error check ret = SendCommand("LM 1", 50) If ret = "-1" Then status.Text = status.Text & "Error, please retry" & vbCrLf Exit Sub End If 'Clear out the previous image Pic.Cls 'Call the pollme function to retrieve and process the binary image Call pollme 'Close the Comport Com.PortOpen = False End Sub
Private Sub pollme() Table of Contents '********************************************** ' This function is what retrieves and processes ' the binary packed image from the CMUcam. '********************************************** Dim ret As String 'used with sendcommand Dim str As String 'storage string Dim num As String 'used for tick totaling Dim s As String 'storage string Dim binstr As String 'binary string (8 bits) Dim temp As String 'temp variable Dim i As Integer 'counter Dim k As Integer 'counter Dim start1 As Integer 'start marker Dim col As Long 'column counter Dim row As Long 'row counter Dim cnt As Long 'counter Dim startpos As Integer 'start of image in packet Dim packet As String 'binary data Dim starttime As Long 'Tick count at start of frame retrieval Dim endtime As Long 'Tick count at end of frame retrieval Dim display_start As Long 'Tick count at start of frame display Dim display_stop As Long 'Tick count at endof frame display 'Issue the command to get one packet out Com.Output = "TW" & Chr(13) Sleep (250) 'Read the packet in before processing status.Text = status.Text & "Starting Timer" & vbCrLf starttime = Timer 'start the timer Do str = str & Com.Input Sleep (75) Loop Until Com.InBufferCount >= 0 status.Text = status.Text & "Stopping Timer" & vbCrLf endtime = Timer 'end the timer 'refresh the form so the text shows up Me.Refresh num = endtime - starttime status.Text = status.Text & "Total time to get frame: " & num & vbCrLf Me.Refresh 'Initialize are counters start1 = 0 col = 0 row = 0 cnt = 0 Pic.ScaleMode = vbPixels 'Get our startposition startpos = InStr(1, str, "ACK") If startpos = 0 Then Exit Sub End If 'start the display timer display_start = Timer For i = startpos To Len(str) - 1 temp = Mid(str, i, 1) 'read otu a char s = GetBinary(Asc(temp)) 'rip the data into binary form If s = "10101010" Then 'check for the end marker start1 = start1 + 1 If cnt = 1 Then GoTo done End If cnt = 1 Else If start1 = 0 Then 'do nothing Else cnt = 0 For k = 1 To 9 - 1 temp = Mid(s, k, 1) If temp = 1 Then Pic.PSet (col, row), RGB(0, 0, 255) Pic.PSet (col, row + 1), RGB(0, 0, 255) Else Pic.PSet (col, row), RGB(0, 0, 0) Pic.PSet (col, row + 1), RGB(0, 0, 0) End If col = col + 1 If col = 80 Then col = 0 row = row + 2 End If Next k End If End If Next i done: display_stop = Timer num = display_stop - display_start status.Text = status.Text & "Time to display frame: " & num & vbCrLf End Sub
Function GetBinary(ByVal iInput As Integer) As String Table of Contents '************************************************* ' Returns the 8-bit binary representation ' of an integer iInput where 0 <= iInput <= 255 '************************************************* Dim s As String, i As Integer If iInput < 0 Or iInput > 255 Then GetBinary = "" Exit Function End If s = "" For i = 1 To 8 s = CStr(iInput Mod 2) & s iInput = iInput \ 2 Next GetBinary = s End Function
Private Sub df_dll_Click() Table of Contents '************************************************* ' Dumps a frame from the dll using the standard ' DF which is the full RGB data '************************************************* Dim fr(40000) As Byte 'Byte array that holds the image Dim i As Integer 'catches return values from dll functions Dim started As Boolean 'image processing Dim col As Integer 'image processing Dim row As Integer 'image processing Dim x As Long 'image processing Dim start_time As Long Dim end_time As Long Dim display_start As Long Dim display_end As Long Dim total As Long Dim total2 As Long status.Text = "Starting DLL Test (RGB)" & vbCrLf status.Text = status.Text & "Connecting to COM device" & vbCrLf status.Refresh 'open and initialize the CMUCam and the Comport CAM_Init ("COM1") Sleep (400) i = CAM_Ping 'Ping the camera 'Update the text box If i = 1 Then status.Text = status.Text & "Ping....OK" & vbCrLf status.Refresh Else status.Text = status.Text & "Ping....FAILED...Trying DF anyway" & vbCrLf status.Refresh End If 'Update the textbox status.Text = status.Text & "Starting Timer & Dumping Frame...." status.Refresh start_time = Win32GetTickCounter i = CAM_DumpFrame(VarPtr(fr(0))) end_time = Win32GetTickCounter 'Update the textbox If i = 1 Then status.Text = status.Text & "OK" & vbCrLf status.Refresh Else status.Text = status.Text & "FAILED" & vbCrLf status.Refresh End If col = 0 'used for image display row = 0 'used for image display started = False Pic.ScaleMode = vbPixels display_start = Win32GetTickCounter For x = 1 To 34407 '1 = start of frame If fr(x) = 1 Then Pic.Cls started = True '2 = new col ElseIf fr(x) = 2 Then col = col + 2 row = 0 '3 = end of frame ElseIf fr(x) = 3 Then status.Text = status.Text & "Image Dump Complete" 'Exit Sub GoTo endd Else 'Make sure we started by seeing a 1 'before adding stuff to the picture box If started = True Then 'have to double up the columns Pic.PSet (col, row), RGB(fr(x), fr(x + 1), fr(x + 2)) Pic.PSet (col + 1, row), RGB(fr(x), fr(x + 1), fr(x + 2)) row = row + 1 'go to next row x = x + 2 'bump x since data is stored as rgb we ripped '3 off so 2 here one at the next x = 3 End If End If Next x endd: display_end = Win32GetTickCounter total = end_time - start_time total2 = display_end - display_start status.Text = status.Text & "Total Ticks to Get Frame: " & total & vbCrLf status.Text = status.Text & "Total Ticks to Process Frame: " & total2 & vbCrLf 'close out the comport CAM_ClosePort End Sub
Private Function SendCommand(cmd As String, sleeptime As Integer) As String Table of Contents '********************************************** ' Sends a command to the board then checks for ' the ack command '********************************************** Dim RcvBytes As String 'Stores bytes from the input buffer Dim CheckBytes As String 'used to check for an ack meaning good command Dim temp As String 'dump unused input buffer into here Dim start_time As Long Dim total As Long Dim end_time As Long On Error GoTo err1 'Send the actual command to the CMUcam Com.Output = cmd & Chr(13) 'get the frame If cmd = "DF" Then status.Text = status.Text & "Sending Command & Starting Frame Dump Timer..." & vbCrLf status.Refresh start_time = Win32GetTickCounter Do DoEvents RcvBytes = RcvBytes & Com.Input Sleep (50) Loop Until Com.InBufferCount <= 0 end_time = Win32GetTickCounter total = end_time - start_time status.Text = status.Text & "Total Time To Get Frame:" & total & vbCrLf status.Refresh Else Sleep (sleeptime) RcvBytes = Com.Input End If 'Check for ack or nck or somethign else (which is bad) CheckBytes = Left(RcvBytes, 3) If CheckBytes = "ACK" Then 'found an ack SendCommand = RcvBytes 'Didnt get and ACK from CMUcam Else 'got a nck (error) SendCommand = "-1" 'send error back to caller End If 'Turn off error handeling and exit function before getting to the error On Error GoTo 0 Exit Function err1: status.Text = status.Text & "COMPort Error Getting Frame" & vbCrLf End Function
Private Sub df_nomral_Click() Table of Contents '************************************************* ' Dumps a frame from the COMPort using the standard ' DF which is the full RGB data '************************************************* 'Send dumpframe command Dim ret As String Dim Left As Long Dim col As Integer, row As Integer Dim r As String, b As String, g As String Dim started As Boolean Dim Y As String Dim Cr As String Dim Cb As String Dim start As Long Dim ender As Long Dim total As Long 'open the comport Com.CommPort = 1 'our comport holding the CMUcam Com.InBufferSize = 32764 'input buffer size Com.PortOpen = True 'open the port for communication Sleep (100) status.Text = "Starting DF Test using direct connection (RGB)" & vbCrLf status.Text = status.Text & "Opening Comport..." & vbCrLf status.Refresh 'Send the blank command to check for status, used for ping ret = SendCommand("", 50) 'check the result and inform user If ret = "-1" Then status.Text = status.Text & "Ping....FAILED" & vbCrLf Else status.Text = status.Text & "Ping....OK" & vbCrLf End If 'Send the command to the camera ret = SendCommand("DF", 6000) 'error check the results If ret = "-1" Then status.Text = status.Text & "Error Dumping Frame" & vbCrLf Else start = Win32GetTickCounter status.Text = status.Text & "Dumping Frame..." & vbCrLf Pic.ScaleMode = vbPixels Pic.Cls 'set up our flags and coutners started = False Left = 1 row = 0 col = 0 While Left < Len(ret) DoEvents 'Check for new column If Asc(Mid(ret, Left, 1)) = 2 Then 'Frame_Status.Caption = "New Col Found" col = col + 2 Left = Left + 1 row = 0 'Check for new frame ElseIf Asc(Mid(ret, Left, 1)) = 1 Then 'Frame_Status.Caption = "New Frame Found" row = 0 started = True Left = Left + 1 col = 0 'Check for end of frame ElseIf Asc(Mid(ret, Left, 1)) = 3 Then 'Frame_Status.Caption = "End of Frame Found" started = False Else 'make sure we are in an image and then dump If started = True Then r = Mid(ret, Left, 1) g = Mid(ret, Left + 1, 1) b = Mid(ret, Left + 2, 1) Pic.PSet (col, row), RGB(Asc(r), Asc(g), Asc(b)) 'have to double each column Pic.PSet (col + 1, row), RGB(Asc(r), Asc(g), Asc(b)) row = row + 1 Left = Left + 3 End If End If 'if we havent started yet inc by 1 until we find the start If started = False Then Left = Left + 1 End If Wend ender = Win32GetTickCounter End If total = ender - start status.Text = status.Text & "Time to Process Frame: " & total & vbCrLf Com.PortOpen = False End Sub
Private Sub status_Change() Table of Contents status.SelStart = Len(status.Text) End Sub