Source Code Barcode Creator (Pembuat Barcode)
Ini adalah salah satu contoh aplikasi VB membuat barcode yang biasanya di tempelin di suatu produk. Download disini
Nich script dari program tsb:
Form:
Private Sub Command1_Click()
evalbar Me.Text1
End Sub
Private Sub Form_Load()
setup
End Sub
Private Sub mnuprint_Click()
Me.Text1.Visible = False
Me.Command1.Visible = False
Me.PrintForm
Me.Text1.Visible = True
Me.Command1.Visible = True
End Sub
evalbar Me.Text1
End Sub
Private Sub Form_Load()
setup
End Sub
Private Sub mnuprint_Click()
Me.Text1.Visible = False
Me.Command1.Visible = False
Me.PrintForm
Me.Text1.Visible = True
Me.Command1.Visible = True
End Sub
Module:
Public chararray(43)
Function evalbar(bchar As String)
Dim linetop As Integer 'top of the line
Dim linebottom As Integer 'bottom of the line
Dim leftside As Integer 'left side of barcode
Dim narbarwidth As Integer 'length of the narrow bars
Dim binarray As Integer 'retrievs the binary code for the current letter
Dim loop1, loop2, loop3 As Integer
Dim newbchar As String 'hold the modified string
linetop = 50
linebottom = 550
leftside = 50
narbarwidth = 20
frmbarcode.Picture1.Cls 'clears the picture box
newbchar = "*" + StrConv(bchar, vbUpperCase) + "*" 'add start and stop char changes string to uppercase
For loop1 = 1 To Len(newbchar) 'loops through each char of the string
binarray = evalchar(Mid(newbchar, loop1, 1))
For loop2 = 1 To Len(chararray(binarray)) 'loops through the binary array
For loop3 = 1 To (CInt(Mid(chararray(binarray), loop2, 1)) + 1) * narbarwidth 'checks the width 0 for narrow and 1 for wide
If loop2 Mod 2 Then 'odd char of the string are black, even are white
frmbarcode.Picture1.Line (leftside, linetop)-(leftside, linebottom), vbBlack
'Printer.Line (leftside, linetop)-(leftside, linebottom), vbBlack
Else
frmbarcode.Picture1.Line (leftside, linetop)-(leftside, linebottom), vbWhite
'Printer.Line (leftside, linetop)-(leftside, linebottom), vbWhite
End If
leftside = leftside + 1
Next loop3
Next loop2
For loop2 = 1 To narbarwidth 'adds a white space between char
frmbarcode.Picture1.Line (leftside, linetop)-(leftside, linebottom), vbWhite
'Printer.Line (leftside, linetop)-(leftside, linebottom), vbWhite
leftside = leftside + 1
Next loop2
Next loop1
'Printer.EndDoc
End Function
Function evalchar(echar As String) As Integer
Select Case echar
Case "0"
evalchar = 0
Exit Function
Case "1"
evalchar = 1
Exit Function
Case "2"
evalchar = 2
Exit Function
Case "3"
evalchar = 3
Exit Function
Case "4"
evalchar = 4
Exit Function
Case "5"
evalchar = 5
Exit Function
Case "6"
evalchar = 6
Exit Function
Case "7"
evalchar = 7
Exit Function
Case "8"
evalchar = 8
Exit Function
Case "9"
evalchar = 9
Exit Function
Case "A"
evalchar = 10
Exit Function
Case "B"
evalchar = 11
Exit Function
Case "C"
evalchar = 12
Exit Function
Case "D"
evalchar = 13
Exit Function
Case "E"
evalchar = 14
Exit Function
Case "F"
evalchar = 15
Exit Function
Case "G"
evalchar = 16
Exit Function
Case "H"
evalchar = 17
Exit Function
Case "I"
evalchar = 18
Exit Function
Case "J"
evalchar = 19
Exit Function
Case "K"
evalchar = 20
Exit Function
Case "L"
evalchar = 21
Exit Function
Case "M"
evalchar = 22
Exit Function
Case "N"
evalchar = 23
Exit Function
Case "O"
evalchar = 24
Exit Function
Case "P"
evalchar = 25
Exit Function
Case "Q"
evalchar = 26
Exit Function
Case "R"
evalchar = 27
Exit Function
Case "S"
evalchar = 28
Exit Function
Case "T"
evalchar = 29
Exit Function
Case "U"
evalchar = 30
Exit Function
Case "V"
evalchar = 31
Exit Function
Case "W"
evalchar = 32
Exit Function
Case "X"
evalchar = 33
Exit Function
Case "Y"
evalchar = 34
Exit Function
Case "Z"
evalchar = 35
Exit Function
Case "-"
evalchar = 36
Exit Function
Case "."
evalchar = 37
Exit Function
Case " "
evalchar = 38
Exit Function
Case "$"
evalchar = 39
Exit Function
Case "/"
evalchar = 40
Exit Function
Case "+"
evalchar = 41
Exit Function
Case "%"
evalchar = 42
Exit Function
Case "*"
evalchar = 43
Exit Function
End Select
End Function
Sub setup()
chararray(0) = "000110100"
chararray(1) = "100100001"
chararray(2) = "001100001"
chararray(3) = "101100000"
chararray(4) = "000110001"
chararray(5) = "100110000"
chararray(6) = "001110000"
chararray(7) = "000100101"
chararray(8) = "100100100"
chararray(9) = "001100100"
chararray(10) = "100001001"
chararray(11) = "001001001"
chararray(12) = "101001000"
chararray(13) = "000011001"
chararray(14) = "100011000"
chararray(15) = "001011000"
chararray(16) = "000001101"
chararray(17) = "100001100"
chararray(18) = "001001100"
chararray(19) = "000011100"
chararray(20) = "100000011"
chararray(21) = "001000011"
chararray(22) = "101000010"
chararray(23) = "000010011"
chararray(24) = "100010010"
chararray(25) = "001010010"
chararray(26) = "000000111"
chararray(27) = "100000110"
chararray(28) = "001000110"
chararray(29) = "000010110"
chararray(30) = "110000001"
chararray(31) = "011000001"
chararray(32) = "111000000"
chararray(33) = "010010001"
chararray(34) = "110010000"
chararray(35) = "011010000"
chararray(36) = "010000101"
chararray(37) = "110000100"
chararray(38) = "011000100"
chararray(39) = "010101000"
chararray(40) = "010100010"
chararray(41) = "010001010"
chararray(42) = "000101010"
chararray(43) = "010010100"
End Sub
Function evalbar(bchar As String)
Dim linetop As Integer 'top of the line
Dim linebottom As Integer 'bottom of the line
Dim leftside As Integer 'left side of barcode
Dim narbarwidth As Integer 'length of the narrow bars
Dim binarray As Integer 'retrievs the binary code for the current letter
Dim loop1, loop2, loop3 As Integer
Dim newbchar As String 'hold the modified string
linetop = 50
linebottom = 550
leftside = 50
narbarwidth = 20
frmbarcode.Picture1.Cls 'clears the picture box
newbchar = "*" + StrConv(bchar, vbUpperCase) + "*" 'add start and stop char changes string to uppercase
For loop1 = 1 To Len(newbchar) 'loops through each char of the string
binarray = evalchar(Mid(newbchar, loop1, 1))
For loop2 = 1 To Len(chararray(binarray)) 'loops through the binary array
For loop3 = 1 To (CInt(Mid(chararray(binarray), loop2, 1)) + 1) * narbarwidth 'checks the width 0 for narrow and 1 for wide
If loop2 Mod 2 Then 'odd char of the string are black, even are white
frmbarcode.Picture1.Line (leftside, linetop)-(leftside, linebottom), vbBlack
'Printer.Line (leftside, linetop)-(leftside, linebottom), vbBlack
Else
frmbarcode.Picture1.Line (leftside, linetop)-(leftside, linebottom), vbWhite
'Printer.Line (leftside, linetop)-(leftside, linebottom), vbWhite
End If
leftside = leftside + 1
Next loop3
Next loop2
For loop2 = 1 To narbarwidth 'adds a white space between char
frmbarcode.Picture1.Line (leftside, linetop)-(leftside, linebottom), vbWhite
'Printer.Line (leftside, linetop)-(leftside, linebottom), vbWhite
leftside = leftside + 1
Next loop2
Next loop1
'Printer.EndDoc
End Function
Function evalchar(echar As String) As Integer
Select Case echar
Case "0"
evalchar = 0
Exit Function
Case "1"
evalchar = 1
Exit Function
Case "2"
evalchar = 2
Exit Function
Case "3"
evalchar = 3
Exit Function
Case "4"
evalchar = 4
Exit Function
Case "5"
evalchar = 5
Exit Function
Case "6"
evalchar = 6
Exit Function
Case "7"
evalchar = 7
Exit Function
Case "8"
evalchar = 8
Exit Function
Case "9"
evalchar = 9
Exit Function
Case "A"
evalchar = 10
Exit Function
Case "B"
evalchar = 11
Exit Function
Case "C"
evalchar = 12
Exit Function
Case "D"
evalchar = 13
Exit Function
Case "E"
evalchar = 14
Exit Function
Case "F"
evalchar = 15
Exit Function
Case "G"
evalchar = 16
Exit Function
Case "H"
evalchar = 17
Exit Function
Case "I"
evalchar = 18
Exit Function
Case "J"
evalchar = 19
Exit Function
Case "K"
evalchar = 20
Exit Function
Case "L"
evalchar = 21
Exit Function
Case "M"
evalchar = 22
Exit Function
Case "N"
evalchar = 23
Exit Function
Case "O"
evalchar = 24
Exit Function
Case "P"
evalchar = 25
Exit Function
Case "Q"
evalchar = 26
Exit Function
Case "R"
evalchar = 27
Exit Function
Case "S"
evalchar = 28
Exit Function
Case "T"
evalchar = 29
Exit Function
Case "U"
evalchar = 30
Exit Function
Case "V"
evalchar = 31
Exit Function
Case "W"
evalchar = 32
Exit Function
Case "X"
evalchar = 33
Exit Function
Case "Y"
evalchar = 34
Exit Function
Case "Z"
evalchar = 35
Exit Function
Case "-"
evalchar = 36
Exit Function
Case "."
evalchar = 37
Exit Function
Case " "
evalchar = 38
Exit Function
Case "$"
evalchar = 39
Exit Function
Case "/"
evalchar = 40
Exit Function
Case "+"
evalchar = 41
Exit Function
Case "%"
evalchar = 42
Exit Function
Case "*"
evalchar = 43
Exit Function
End Select
End Function
Sub setup()
chararray(0) = "000110100"
chararray(1) = "100100001"
chararray(2) = "001100001"
chararray(3) = "101100000"
chararray(4) = "000110001"
chararray(5) = "100110000"
chararray(6) = "001110000"
chararray(7) = "000100101"
chararray(8) = "100100100"
chararray(9) = "001100100"
chararray(10) = "100001001"
chararray(11) = "001001001"
chararray(12) = "101001000"
chararray(13) = "000011001"
chararray(14) = "100011000"
chararray(15) = "001011000"
chararray(16) = "000001101"
chararray(17) = "100001100"
chararray(18) = "001001100"
chararray(19) = "000011100"
chararray(20) = "100000011"
chararray(21) = "001000011"
chararray(22) = "101000010"
chararray(23) = "000010011"
chararray(24) = "100010010"
chararray(25) = "001010010"
chararray(26) = "000000111"
chararray(27) = "100000110"
chararray(28) = "001000110"
chararray(29) = "000010110"
chararray(30) = "110000001"
chararray(31) = "011000001"
chararray(32) = "111000000"
chararray(33) = "010010001"
chararray(34) = "110010000"
chararray(35) = "011010000"
chararray(36) = "010000101"
chararray(37) = "110000100"
chararray(38) = "011000100"
chararray(39) = "010101000"
chararray(40) = "010100010"
chararray(41) = "010001010"
chararray(42) = "000101010"
chararray(43) = "010010100"
End Sub
Sumber : X-Code Family
2 komentar:
Reply to Source Code Barcode Creator
First, thanks so much for sharing, And I have one question that how many barcode types are supported?
en? my reply do not appear?
Posting Komentar
Kritik dan saran yang anda berikan akan sangat bermanfaat bagi kami untuk terus memberi yang terbaik. ^_^