Magnetic strip reader and barcode scanner visual basic 6 form source code.
'File Main.frm
VERSION 5.00
Begin VB.Form Main
Caption = "Chad Card Reader"
ClientHeight = 2550
ClientLeft = 60
ClientTop = 345
ClientWidth = 4710
Icon = "Main.frx":0000
LinkTopic = "Form1"
ScaleHeight = 2550
ScaleWidth = 4710
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton Command1
Caption = "Barcode Scanner"
Height = 615
Left = 240
TabIndex = 2
Top = 1680
Width = 3015
End
Begin VB.CommandButton BtnAbout
Caption = "About..."
Height = 375
Left = 3480
TabIndex = 1
Top = 240
Width = 975
End
Begin VB.CommandButton BtnReadCards
Caption = "Magnetic Card Reader"
Height = 615
Left = 240
TabIndex = 0
Top = 840
Width = 3015
End
End
Attribute VB_Name =
"Main"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Sub BtnAbout_Click()
FrmAbout.Show vbModal, Me
End Sub
Private Sub BtnReadCards_Click()
FrmReadCards.Show vbModal, Me
End Sub
Private Sub Command1_Click()
Barcode_Dialog.Show vbModal, Me
End Sub
'File FrmReadCards.frm
VERSION 5.00
Begin VB.Form FrmReadCards
BorderStyle = 3 'Fixed Dialog
Caption = "Read Cards"
ClientHeight = 5835
ClientLeft = 2760
ClientTop = 3750
ClientWidth = 8130
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 5835
ScaleWidth = 8130
ShowInTaskbar = 0 'False
Begin VB.ComboBox Combo3
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 360
Left = 4200
Style = 2 'Dropdown List
TabIndex = 3
Top = 3600
Width = 3735
End
Begin VB.ComboBox Combo2
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 360
Left = 2400
Style = 2 'Dropdown List
TabIndex = 2
Top = 3600
Width = 1695
End
Begin VB.ComboBox Combo1
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 360
Left = 120
Style = 2 'Dropdown List
TabIndex = 1
Top = 3600
Width = 2175
End
Begin VB.CommandButton Command2
Caption = "Next"
BeginProperty Font
Name = "Arial"
Size = 14.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 615
Left = 120
TabIndex = 5
Top = 5040
Width = 2055
End
Begin VB.TextBox Text1
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 360
Left = 120
TabIndex = 4
Top = 4560
Width = 7695
End
Begin VB.CommandButton Command1
Caption = "Export"
BeginProperty Font
Name = "Arial"
Size = 14.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 615
Left = 6000
TabIndex = 6
Top = 5040
Width = 1815
End
Begin VB.Timer TmrMain
Enabled = 0 'False
Interval = 200
Left = 3720
Top = 5160
End
Begin VB.Label LblStatus
BeginProperty Font
Name = "Arial"
Size = 14.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 240
TabIndex = 11
Top = 240
Width = 7575
End
Begin VB.Label Label4
Caption = "Product:"
BeginProperty Font
Name = "Arial"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 4200
TabIndex = 10
Top = 3240
Width = 975
End
Begin VB.Label Label3
Caption = "Call Back:"
BeginProperty Font
Name = "Arial"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 2400
TabIndex = 9
Top = 3240
Width = 1215
End
Begin VB.Label Label2
Caption
= "Sale Rep:"
BeginProperty Font
Name = "Arial"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 120
TabIndex = 8
Top = 3240
Width = 1215
End
Begin VB.Label Label1
Caption = "Note:"
BeginProperty Font
Name = "Arial"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 120
TabIndex = 7
Top = 4200
Width = 735
End
Begin VB.Label LblResult
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 2055
Left = 240
TabIndex = 0
Top = 960
Width = 7575
End
End
Attribute VB_Name =
"FrmReadCards"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Sub Command1_Click()
' Note:
' You must have a reference
to the Excel Object Library.
'
Dim i As Long
Dim j As Long
Dim lRowCount As Long
Dim lPasteCount As Long
Dim sLtr As String
Dim sStart As String
Dim sEnd As String
Dim sRowData As String
Dim sSelData As String
Dim excel_error As String
Dim oExcelApp As excel.Application
Dim oWs As excel.Worksheet
Dim oWb As excel.Workbook
Const cNUMCOLS = 6
Const cNUMROWS = 700
Const cFIXEDROWS = 6
Const cCLIPROWS = 500
If (scans1 = "") Then
MsgBox "No Data to Export", vbInformation, "Swipe something first."
Exit Sub
End If
If TmrMain.Enabled = False Then
MsgBox "Click Next", vbInformation, "Click
Next First."
Exit Sub
End If
On Error GoTo ErrorHandler
Screen.MousePointer = vbHourglass
If Dir(sNewXlsFile) <> "" Then Kill sNewXlsFile
'
' Create an invisible Excel
instance.
'
' Open a previously created
worksheet that has most
' of the desired
formatting already. Save this template
' as a new file so as not
to destroy it.
'
Set oExcelApp = CreateObject("EXCEL.APPLICATION")
oExcelApp.Visible = True
oExcelApp.Workbooks.Open FileName:=sXlsTemplate, ReadOnly:=True, ignoreReadOnlyRecommended:=True
Set oWs = oExcelApp.ActiveSheet
Set oWb = oExcelApp.ActiveWorkbook
'
' Populate the header
information by writting
' directly to specific cells.
'
' Note:
' Strings are prefixed with a
quote mark.
'
'With oWs
' .Cells(1, 4).Value = "'Value1"
' .Cells(2, 4).Value = "'Value2"
' .Cells(3, 4).Value = "'Value3"
' .Cells(4, 4).Value = "'Value4 Value4 Value4 Value4 Value4 Value4"
' .Cells(5, 5).Value = "'Value5"
' .Cells(5, 6).Value = "'Value6"
' .Cells(5, 7).Value = "'Value7"
'End With
'
' Now lets populate the "body" of the spreadsheet.
' Determine the range of cells to
be populated
' and change their format
to numeric.
'
'sStart = "A" & CStr(cFIXEDROWS + 1)
'sLtr = Mid$("ABCDEFGHIJKLMNOPQRSTUVWXYZ", cNUMCOLS + 1, 1)
'sEnd = sLtr & CStr(cFIXEDROWS + cNUMROWS + 1)
'oWs.Range(sStart, sEnd).Select
'oWs.Range(sStart, sEnd).Activate
'oWs.Range(sStart, sEnd).NumberFormat = "#,##0.00"
'
' Populate the body of the
spreadsheet.
'
'sSelData =
""
'lRowCount = 0
'lPasteCount = 0
' For i = 0 To cNUMROWS
' sRowData = ""
'
' Create the rows to send to Excel. Each row
' is a tab delimited string of values terminated
' by a carriage return and line feed. Data can
' come from a grid or other source.
'
' For j = 0 To cNUMCOLS
' sRowData = sRowData & CStr(j) & vbTab
' Next
' sRowData = Left$(sRowData, Len(sRowData) - 1)
'
' Rows are accumulated into blocks then stored in
' the clipboard and pasted into Excel in one shot.
'
' They can be written one at a time but this is
' faster since the data is kept in memory and
' there are fewer calls to Excel.
'
' sSelData = sSelData + sRowData + vbCrLf
' lRowCount = lRowCount + 1
' If lRowCount = cCLIPROWS Then
' Clipboard.Clear
' Clipboard.SetText sSelData
' sSelData = ""
' With oWs
' .Range("A" & CStr(lPasteCount * cCLIPROWS + cFIXEDROWS)).Select
' .Paste
' .Range("A1").Select
' End With
' lRowCount = 0
' lPasteCount = lPasteCount + 1
' End If
'Next
'
' Paste the last block of
data into the worksheet.
'
Clipboard.Clear
Clipboard.SetText scans1
With oWs
.Range("A2").Select
.Paste
.Range("A2").Select
End With
'
' Change the formatting on a
few cells.
'
' Select and highlight a cell.
Change the font
' style and color on certain
parts of its contents.
'
'oWs.Range("D4").Select
'oWs.Range("D4").Activate
'With oExcelApp.ActiveCell.Characters(Start:=1,
Length:=10).Font
' .FontStyle = "Regular"
' .Size = 11
' .ColorIndex = 5
'End With
'With oExcelApp.ActiveCell.Characters(Start:=20,
Length:=30).Font
' .FontStyle = "Italic"
' .Size = 11
' .ColorIndex = xlAutomatic
'End With
'
' Just for fun, change the
color of
' the first column to Red.
'
'sStart = "A" & CStr(cFIXEDROWS + 1)
'sEnd = "A" & CStr(cFIXEDROWS + cNUMROWS + 1)
'oWs.Range(sStart, sEnd).Select
'oWs.Range(sStart, sEnd).Activate
'oWs.Range(sStart, sEnd).Font.ColorIndex = 3
'
' Change the border and color
of the last row.
'
'j = (lPasteCount * cCLIPROWS) + cFIXEDROWS + lRowCount
'For i = 1 To cNUMCOLS + 1
' With oWs.Cells(j, i)
' .Borders(xlTop).LineStyle = xlDouble
' .Font.Bold = True
' .Font.ColorIndex = 3
' End With
'Next
'
' Make the last row a total
line. Build and insert
' a formula into its
first cell. Then copy the
' formula to the remaining
cells. When it is copied
' Excel will update the cell
references for you.
'
'oWs.Cells(j, 1).Value =
"=SUM(A" & CStr(cFIXEDROWS + 1) & ":A" & CStr(j - 1) &
")"
'For i = 1 To cNUMCOLS
' oWs.Cells(j, 1).Copy
' oWs.Cells(j, i + 1).Select
' oWs.Paste
'Next
'
' Save the changed
worksheet.
'
'oWb.Save
'oWb.Saved =
True
'
' Terminate and release the Excel
objects.
'
'oExcelApp.Quit
'oWs.SaveAs FileName:=sNewXlsFile, FileFormat:=xlNormal
Set oWs = Nothing
Set oWb = Nothing
Set oExcelApp = Nothing
Screen.MousePointer = vbDefault
Exit Sub
ErrorHandler:
Screen.MousePointer = vbDefault
excel_error = Err.Description & " (" & CStr(Err.Number) & ")"
If excel_error = "Permission denied (70)" Then
MsgBox "Rename and Save
Temp.xls first", vbExclamation, "Excel Export"
End If
MsgBox Err.Description & " (" & CStr(Err.Number) & ")", vbExclamation, "Excel Export"
On Error Resume Next
' oExcelApp.Quit
Set oWs = Nothing
Set oWb = Nothing
Set oExcelApp = Nothing
End Sub
Private Sub Command2_Click()
If Combo1.listindex <> -1 And Combo2.listindex <> -1 And Combo3.listindex <> -1 Then
scans1 = scans1 & vbTab & Combo1.List(Combo1.listindex) & vbTab & Combo2.List(Combo2.listindex) & vbTab &
Combo3.List(Combo3.listindex) & vbTab &
Text1.Text & vbCrLf
TmrMain.Enabled = True
Command2.Enabled = False
Command1.Enabled = True
Combo1.Enabled = False
Combo1.listindex = -1
Combo2.Enabled = False
Combo2.listindex = -1
Combo3.Enabled = False
Combo3.listindex = -1
Text1.Enabled = False
Text1.Text = ""
LblResult.Caption = ""
Else
LblStatus.Caption = "Select
Contact Information......"
End If
End Sub
Private Sub Form_Load()
sXlsTemplate = App.Path & "\card_reads.xls"
sNewXlsFile = App.Path & "\temp.xls"
InitUSB
TmrMain.Enabled = True
Command2.Enabled = False
Combo1.Enabled = False
Combo2.Enabled = False
Combo3.Enabled = False
Text1.Enabled = False
LoadTradeShow
End Sub
Private Sub Form_Unload(Cancel As Integer)
If MsgBox("Did you need to
export?", vbYesNo) = vbYes Then
Cancel = True
Else
TmrMain.Enabled = False
CloseDevice
CloseUSB
End If
End Sub
Private Sub TmrMain_Timer()
'This timer coordinates the card
reading and data displaying
Dim StartTime As Date
'Check if any fatal errors have occured
If FatalError <> "" Then
LblStatus.Caption = "Fatal
Error - " & FatalError
Exit Sub
End If
If HidDevice =
INVALID_HANDLE_VALUE Then
'The device hasn't been detected yet
LblStatus.Caption = "Attach
device..."
'Attempt to detect device
DetectDevice
If HidDevice <>
INVALID_HANDLE_VALUE Then
'A Mag-Tek device has been detected
If DeviceAttributes.ProductID = HIDMSRVendDefProdID Or _
DeviceAttributes.ProductID = InsertRdrProdID Then
'The correct USB swipe reader for this
application has been detected so
'start the
card reading process.
InitRead
Else
'The wrong Mag-Tek device has been detected.
FatalError = "Incompatible
device attached"
If DeviceAttributes.ProductID = HIDMSRKeyBoardEmulProdID Then
'A Mag-Tek keyboard emulation MSR has been detected.
MsgBox ("Incompatible device. Use Notepad
application to read cards for this device.")
Else
MsgBox ("Incompatible device.")
End If
End If
End If
Else
'The correct device has been detected.
LblStatus.Caption = "Swipe
card..."
'See if a card has been swiped.
If ReadInputRpt() = True Then
'A card has been swiped.
'Clear any old card data from the
display.
LblStatus.Caption = "Processing
data..."
LblResult.Caption = ""
StartTime = Timer
Do While Timer < StartTime + 0.1 ' wait 100ms for
data clear to take affect
DoEvents
Loop
'Extract the card data from the HID
report
If GetMSRResults() = True Then
'Display the card data
DisplayMSRResults
End If
End If
End If
End Sub
Public Sub DisplayMSRResults()
'Displays magnetic stripe read results
Dim SwipeDirStr, track1, track2,
track3 As String
If DeviceAttributes.ProductID = InsertRdrProdID Then
If (CardSts And CS_CARD_INSERTED) =
CS_CARD_INSERTED Then
SwipeDirStr = ", Swipe
Direction = Insert"
Else
SwipeDirStr = ", Swipe
Direction = Withdrawal"
End If
Else
SwipeDirStr = ""
End If
If (Tk1DcdSts And DS_ERROR) = DS_ERROR Then
Tk1DataStr = "Error"
End If
If (Tk2DcdSts And DS_ERROR) = DS_ERROR Then
Tk2DataStr = "Error"
End If
If (Tk3DcdSts And DS_ERROR) = DS_ERROR Then
Tk3DataStr = "Error"
End If
Tk1DataStr = Replace(Tk1DataStr, vbTab, ",")
Tk1DataStr = Replace(Tk1DataStr, vbCrLf, ";")
Tk2DataStr = Replace(Tk2DataStr, vbTab, ",")
Tk2DataStr = Replace(Tk2DataStr, vbCrLf, ";")
Tk3DataStr = Replace(Tk3DataStr, vbTab, ",")
Tk3DataStr = Replace(Tk3DataStr, vbCrLf, ";")
If Tk1Len > 55 Then
track1 = Left(Tk1DataStr, 55) & vbCrLf & Mid(Tk1DataStr, 56)
End If
If Tk2Len > 55 Then
track2 = Left(Tk2DataStr, 55) & vbCrLf & Mid(Tk2DataStr, 56)
End If
If Tk3Len > 55 Then
track3 = Left(Tk3DataStr, 55) & vbCrLf & Mid(Tk3DataStr, 56)
End If
LblResult.Caption = _
"Card Encode Type = " & GetCardEncodeTypeStr(CrdEcdTyp) & SwipeDirStr & vbCrLf & vbCrLf & _
"Track 1 = " & Tk1DataStr & vbCrLf & vbCrLf & _
"Track 2 = " & Tk2DataStr & vbCrLf & vbCrLf & _
"Track 3 = " & Tk3DataStr
scans1 =
scans1 & Tk1DataStr & vbTab & Tk2DataStr
& vbTab & Tk3DataStr
TmrMain.Enabled = False
Combo1.Enabled = True
Combo2.Enabled = True
Combo3.Enabled = True
Text1.Enabled = True
Command2.Enabled = True
Command1.Enabled = False
Combo1.SetFocus
End Sub
Private Sub LoadTradeShow()
Dim excel_error As String
Dim listindex, counter As Integer
Dim oExcelApp As excel.Application
Dim oWs As excel.Worksheet
Dim oWb As excel.Workbook
On Error GoTo ErrorHandler
'
' Create an invisible Excel
instance.
'
' Open a previously created
worksheet that has most
' of the desired
formatting already. Save this template
' as a new file so as not
to destroy it.
'
Set oExcelApp = CreateObject("EXCEL.APPLICATION")
oExcelApp.Visible = False
oExcelApp.Workbooks.Open FileName:=App.Path & "\tradeshow.xls", ReadOnly:=True, ignoreReadOnlyRecommended:=True
Set oWs = oExcelApp.ActiveSheet
Set oWb = oExcelApp.ActiveWorkbook
counter = 2
Do While oWs.Cells(counter,
1).Value <> "" Or oWs.Cells(counter,
2).Value <> "" Or oWs.Cells(counter,
3).Value <> ""
If oWs.Cells(counter, 1).Value <> "" Then
Combo1.AddItem (oWs.Cells(counter, 1).Value)
End If
If oWs.Cells(counter, 2).Value <> "" Then
Combo2.AddItem (oWs.Cells(counter, 2).Value)
End If
If oWs.Cells(counter, 3).Value <> "" Then
Combo3.AddItem (oWs.Cells(counter, 3).Value)
End If
counter = counter + 1
Loop
Set oWs = Nothing
Set oWb = Nothing
oExcelApp.Workbooks.Close
Set oExcelApp = Nothing
Screen.MousePointer = vbDefault
Exit Sub
ErrorHandler:
Screen.MousePointer = vbDefault
excel_error = Err.Description & " (" & CStr(Err.Number) & ")"
If excel_error = "Permission denied (70)" Then
MsgBox "Rename and Save
Temp.xls first", vbExclamation, "Excel Export"
End If
MsgBox Err.Description & " (" & CStr(Err.Number) & ")", vbExclamation, "Excel Export"
On Error Resume Next
' oExcelApp.Quit
Set oWs = Nothing
Set oWb = Nothing
Set oExcelApp = Nothing
End Sub
'File FrmAbout.frm
VERSION 5.00
Begin VB.Form FrmAbout
Caption = "About"
ClientHeight = 1710
ClientLeft = 60
ClientTop = 345
ClientWidth = 4965
LinkTopic = "Form1"
ScaleHeight = 1710
ScaleWidth = 4965
StartUpPosition = 3 'Windows Default
Begin VB.Label LblVersion
BeginProperty Font
Name = "Arial"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 120
TabIndex = 1
Top = 960
Width = 3015
End
Begin VB.Label LblTitle
BeginProperty Font
Name = "Arial"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 120
TabIndex = 0
Top = 240
Width = 3015
End
End
Attribute VB_Name =
"FrmAbout"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Sub Form_Load()
Me.Caption = "About " & App.Title
LblVersion.Caption = "Version " & App.Major & "." & App.Minor & "." & App.Revision
LblTitle.Caption = App.Title
End Sub
'File Barcode_Dialog.frm
VERSION 5.00
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "MSCOMM32.OCX"
Begin VB.Form Barcode_Dialog
BorderStyle = 3 'Fixed Dialog
Caption = "Barcode Reader"
ClientHeight = 6615
ClientLeft = 2760
ClientTop = 3750
ClientWidth = 8070
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 6615
ScaleWidth = 8070
ShowInTaskbar = 0 'False
Begin VB.ComboBox Combo3
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 360
Left = 4200
Style = 2 'Dropdown List
TabIndex = 3
Top = 3720
Width = 3735
End
Begin VB.ComboBox Combo2
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 360
Left = 2400
Style = 2 'Dropdown List
TabIndex = 2
Top = 3720
Width = 1695
End
Begin VB.ComboBox Combo1
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 360
Left = 120
Style = 2 'Dropdown List
TabIndex = 1
Top = 3720
Width = 2175
End
Begin VB.TextBox Text2
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 360
Left = 120
TabIndex = 4
Top = 4680
Width = 7815
End
Begin VB.CommandButton Command3
Caption = "Export"
BeginProperty Font
Name = "Arial"
Size = 14.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 615
Left = 6000
TabIndex = 7
Top = 5760
Width = 1695
End
Begin VB.CommandButton Command2
Caption = "Stop"
BeginProperty Font
Name = "Arial"
Size = 14.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 615
Left = 3120
TabIndex = 6
Top = 5760
Width = 1695
End
Begin VB.CommandButton Command1
Caption = "Start"
BeginProperty Font
Name = "Arial"
Size = 14.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 615
Left = 120
TabIndex = 5
Top = 5760
Width = 1695
End
Begin VB.TextBox Text1
Alignment = 1 'Right Justify
BeginProperty DataFormat
Type = 1
Format = "0"
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 1033
SubFormatType = 1
EndProperty
BeginProperty Font
Name = "Arial"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 360
Left = 1080
MaxLength = 2
TabIndex = 8
Text = "1"
Top = 5160
Width = 375
End
Begin MSCommLib.MSComm MSComm1
Left = 5040
Top = 5760
_ExtentX = 1005
_ExtentY = 1005
_Version = 393216
DTREnable = -1 'True
RThreshold = 1
End
Begin VB.Label Label7
Caption = "Product:"
BeginProperty Font
Name = "Arial"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 4200
TabIndex = 14
Top = 3360
Width = 1095
End
Begin VB.Label Label6
Caption = "Call Back:"
BeginProperty Font
Name = "Arial"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 2400
TabIndex = 13
Top = 3360
Width = 1215
End
Begin VB.Label Label5
Caption = "Sales Rep:"
BeginProperty Font
Name = "Arial"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 120
TabIndex = 12
Top = 3360
Width = 1335
End
Begin VB.Label Label4
BeginProperty Font
Name = "Arial"
Size = 14.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 240
TabIndex = 11
Top = 240
Width = 7575
End
Begin VB.Label Label3
Caption = "Notes:"
BeginProperty Font
Name = "Arial"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 120
TabIndex = 10
Top = 4320
Width = 975
End
Begin VB.Label Label2
Caption = "Com #:"
BeginProperty Font
Name = "Arial"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 120
TabIndex = 9
Top = 5280
Width = 855
End
Begin VB.Label Label1
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 2055
Left = 240
TabIndex = 0
Top = 1080
Width = 7620
End
End
Attribute VB_Name =
"Barcode_Dialog"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim started As Boolean
Private Sub Command1_Click()
If started = False Then
MSComm1.CommPort = Text1.Text
MSComm1.Settings = "9600,N,8,1"
MSComm1.PortOpen = True
Text1.Enabled = False
Command1.Enabled = False
Label4.Caption = "Running"
Command1.Enabled = False
Command1.Caption = "Next"
Command2.Enabled = True
Text2.Enabled = False
started = True
Else
If Combo1.listindex <> -1 And Combo2.listindex <> -1 And Combo3.listindex <> -1 Then
scans2 = scans2 & vbTab & Combo1.List(Combo1.listindex) & vbTab & Combo2.List(Combo2.listindex) & vbTab &
Combo3.List(Combo3.listindex) & vbTab &
Text2.Text & vbCrLf
Combo1.listindex = -1
Combo1.Enabled = False
Combo2.listindex = -1
Combo2.Enabled = False
Combo3.listindex = -1
Combo3.Enabled = False
Label1.Caption = ""
Label4.Caption = "Running"
Text2.Text = ""
Text2.Enabled = False
If MSComm1.PortOpen = False Then
MSComm1.PortOpen = True
Command2.Enabled = True
End If
Command3.Enabled = True
Command1.Enabled = False
End If
End If
End Sub
Private Sub Command2_Click()
If MSComm1.PortOpen = True Then
MSComm1.PortOpen
= False
End If
Text1.Enabled = True
Text2.Enabled = False
Text2.Text = ""
Command1.Enabled = True
Command1.Caption = "Start"
Label4.Caption = "Stopped"
Command2.Enabled = False
Command3.Enabled = True
Combo1.Enabled = False
Combo2.Enabled = False
Combo3.Enabled = False
started = False
End Sub
Private Sub Command3_Click()
Dim oExcelApp As excel.Application
Dim oWs As excel.Worksheet
Dim oWb As excel.Workbook
Dim excel_error As String
If (scans2 = "") Then
MsgBox "No Data to
Export", vbInformation, "Scan a something first."
Exit Sub
End If
On Error GoTo ErrorHandler
Screen.MousePointer = vbHourglass
Set oExcelApp = CreateObject("EXCEL.APPLICATION")
oExcelApp.Visible = True
oExcelApp.Workbooks.Open FileName:=sXlsTemplate, ReadOnly:=True, ignoreReadOnlyRecommended:=True
Set oWs = oExcelApp.ActiveSheet
Set oWb = oExcelApp.ActiveWorkbook
Clipboard.Clear
Clipboard.SetText scans2
With oWs
.Range("A2").Select
.Paste
.Range("A2").Select
End With
Set oWs = Nothing
Set oWb = Nothing
Set oExcelApp = Nothing
Screen.MousePointer = vbDefault
Command2_Click
Exit Sub
ErrorHandler:
Screen.MousePointer = vbDefault
excel_error = Err.Description & " (" & CStr(Err.Number) & ")"
If excel_error = "Permission denied (70)" Then
MsgBox "Rename and Save
Temp.xls first", vbExclamation, "Excel Export"
End If
MsgBox Err.Description & " (" & CStr(Err.Number) & ")", vbExclamation, "Excel Export"
On Error Resume Next
' oExcelApp.Quit
Set oWs = Nothing
Set oWb = Nothing
Set oExcelApp = Nothing
End Sub
Private Sub Form_Load()
sXlsTemplate = App.Path & "\barcode_reads.xls"
Label4.Caption = "Press Start"
Command2.Enabled = False
Text2.Enabled = False
Combo1.Enabled = False
Combo2.Enabled = False
Combo3.Enabled = False
started = False
LoadTradeShow
End Sub
Private Sub Form_Unload(Cancel As Integer)
If MsgBox("Did you need to
export?", vbYesNo) = vbYes Then
Cancel = True
Else
If MSComm1.PortOpen = True Then
MSComm1.PortOpen = False
End If
End If
End Sub
Private Sub MSComm1_OnComm()
Dim StartTime As Date
StartTime = Timer
Do While Timer < StartTime + 0.1 ' wait 100ms for
data clear to take affect
DoEvents
Loop
If MSComm1.PortOpen = True Then
scan = MSComm1.Input
End If
If scan <> "" Then
If MSComm1.PortOpen = True Then
MSComm1.PortOpen = False
End If
scan = Replace(scan, vbTab, ",")
scan = Replace(scan, vbCrLf, ";")
scans2 = scans2 & scan
Label1.Caption = scan
scan
= ""
Command2.Enabled = False
Command3.Enabled = False
Command1.Enabled = True
Combo1.Enabled = True
Combo2.Enabled = True
Combo3.Enabled = True
Text2.Enabled = True
Label4.Caption = "Select Contact
Information"
Combo1.SetFocus
End If
End Sub
Private Sub LoadTradeShow()
Dim excel_error As String
Dim listindex, counter As Integer
Dim oExcelApp As excel.Application
Dim oWs As excel.Worksheet
Dim oWb As excel.Workbook
On Error GoTo ErrorHandler
'
' Create an invisible Excel
instance.
'
' Open a previously created
worksheet that has most
' of the desired
formatting already. Save this template
' as a new file so as not
to destroy it.
'
Set oExcelApp = CreateObject("EXCEL.APPLICATION")
oExcelApp.Visible = False
oExcelApp.Workbooks.Open FileName:=App.Path & "\tradeshow.xls", ReadOnly:=True, ignoreReadOnlyRecommended:=True
Set oWs = oExcelApp.ActiveSheet
Set oWb = oExcelApp.ActiveWorkbook
counter = 2
Do While oWs.Cells(counter,
1).Value <> "" Or oWs.Cells(counter,
2).Value <> "" Or oWs.Cells(counter,
3).Value <> ""
If oWs.Cells(counter, 1).Value <> "" Then
Combo1.AddItem (oWs.Cells(counter, 1).Value)
End If
If oWs.Cells(counter, 2).Value <> "" Then
Combo2.AddItem (oWs.Cells(counter, 2).Value)
End If
If oWs.Cells(counter, 3).Value <> "" Then
Combo3.AddItem (oWs.Cells(counter, 3).Value)
End If
counter = counter + 1
Loop
Set oWs = Nothing
Set oWb = Nothing
oExcelApp.Workbooks.Close
Set oExcelApp = Nothing
Screen.MousePointer = vbDefault
Exit Sub
ErrorHandler:
Screen.MousePointer = vbDefault
excel_error = Err.Description & " (" & CStr(Err.Number) & ")"
If excel_error = "Permission denied (70)" Then
MsgBox "Rename and Save
Temp.xls first", vbExclamation, "Excel Export"
End If
MsgBox Err.Description & " (" & CStr(Err.Number) & ")", vbExclamation, "Excel Export"
On Error Resume Next
' oExcelApp.Quit
Set oWs = Nothing
Set oWb = Nothing
Set oExcelApp = Nothing
End Sub