form1.frm

UPC-EA 类型条形码生成和读取示例

                        bar.Line (3 * size + (7 * size * (i - 1)) + prevPatWid + ofset, 0)-(3 * size + (7 * size * (i - 1)) + prevPatWid + patWid + ofset, h2), vbBlack, BF
                    Else
                        bar.Line (3 * size + (7 * size * (i - 1)) + prevPatWid + ofset, 0)-(3 * size + (7 * size * (i - 1)) + prevPatWid + patWid + ofset, h2), vbWhite, BF
                    End If
                    prevPatWid = prevPatWid + patWid + 1

                Next
            End If
            prevPatWid = 0
            For j = 1 To 4
                If i >= 4 Then
                    patWid = (Mid$(pattern(num), j, 1) * size) - 1
                    If j = 2 Or j = 4 Then
                        bar.Line (8 * size + (7 * size * (i - 1)) + prevPatWid + ofset, 0)-(8 * size + (7 * size * (i - 1)) + prevPatWid + patWid + ofset, h2), vbWhite, BF
                    Else
                        bar.Line (8 * size + (7 * size * (i - 1)) + prevPatWid + ofset, 0)-(8 * size + (7 * size * (i - 1)) + prevPatWid + patWid + ofset, h2), vbBlack, BF
                    End If
                    prevPatWid = prevPatWid + patWid + 1
                Else
                    patWid = (Mid$(pattern(num), j, 1) * size) - 1
                    If j = 1 Or j = 3 Then
                        bar.Line (3 * size + (7 * size * (i - 1)) + prevPatWid + ofset, 0)-(3 * size + (7 * size * (i - 1)) + prevPatWid + patWid + ofset, h2), vbWhite, BF
                    Else
                        bar.Line (3 * size + (7 * size * (i - 1)) + prevPatWid + ofset, 0)-(3 * size + (7 * size * (i - 1)) + prevPatWid + patWid + ofset, h2), vbBlack, BF
                    End If
                    prevPatWid = prevPatWid + patWid + 1
                End If
            Next
        Next

        '结束
        prevPatWid = 0
        For j = 1 To 3
            patWid = size - 1
            If j = 2 Then
                bar.Line (8 * size + (7 * size * (i - 1)) + prevPatWid + ofset, 0)-(8 * size + (7 * size * (i - 1)) + prevPatWid + patWid + ofset, h1), vbWhite, BF
            Else
                bar.Line (8 * size + (7 * size * (i - 1)) + prevPatWid + ofset, 0)-(8 * size + (7 * size * (i - 1)) + prevPatWid + patWid + ofset, h1), vbBlack, BF
            End If
            prevPatWid = prevPatWid + patWid + 1
        Next

        '绘制数字
        prevPatWid = size

        For i = 1 To 3
            bar.CurrentX = 3 * size + (7 * size * (i - 1)) + prevPatWid + ofset
            bar.CurrentY = h2 + 5
            bar.Print Mid$(Text1, i, 1)
            prevPatWid = prevPatWid + (size) - 1
        Next
        prevPatWid = 0

        For i = 4 To 6
            bar.CurrentX = 8 * size + (7 * size * (i - 1)) + prevPatWid + ofset
            bar.CurrentY = h2 + 5
            bar.Print Mid$(Text1, i, 1)
            prevPatWid = prevPatWid + size - 1
        Next
    Else
        For i = 1 To 12
            num = Mid$(numbr, i, 1)
            prevPatWid = 0

            If i = 7 Then
                For j = 1 To 5
                    patWid = size - 1
                    If j = 2 Or j = 4 Then
                        bar.Line (3 * size + (7 * size * (i - 1)) + prevPatWid + ofset, 0)-(3 * size + (7 * size * (i - 1)) + prevPatWid + patWid + ofset, h2), vbBlack, BF
                    Else
                        bar.Line (3 * size + (7 * size * (i - 1)) + prevPatWid + ofset, 0)-(3 * size + (7 * size * (i - 1)) + prevPatWid + patWid + ofset, h2), vbWhite, BF
                    End If
                    prevPatWid = prevPatWid + patWid + 1

                Next
            End If
            prevPatWid = 0
            For j = 1 To 4
                If i >= 7 Then
                    patWid = (Mid$(pattern(num), j, 1) * size) - 1
                    If j = 2 Or j = 4 Then
                        bar.Line (8 * size + (7 * size * (i - 1)) + prevPatWid + ofset, 0)-(8 * size + (7 * size * (i - 1)) + prevPatWid + patWid + ofset, h2), vbWhite, BF
                    Else
                        bar.Line (8 * size + (7 * size * (i - 1)) + prevPatWid + ofset, 0)-(8 * size + (7 * size * (i - 1)) + prevPatWid + patWid + ofset, h2), vbBlack, BF
                    End If
                    prevPatWid = prevPatWid + patWid + 1
                Else
                    patWid = (Mid$(pattern(num), j, 1) * size) - 1
                    If j = 1 Or j = 3 Then
                        bar.Line (3 * size + (7 * size * (i - 1)) + prevPatWid + ofset, 0)-(3 * size + (7 * size * (i - 1)) + prevPatWid + patWid + ofset, h2), vbWhite, BF
                    Else
                        bar.Line (3 * size + (7 * size * (i - 1)) + prevPatWid + ofset, 0)-(3 * size + (7 * size * (i - 1)) + prevPatWid + patWid + ofset, h2), vbBlack, BF
                    End If
                    prevPatWid = prevPatWid + patWid + 1
                End If
            Next
        Next

        '结束
        prevPatWid = 0
        For j = 1 To 3
            patWid = size - 1
            If j = 2 Then
                bar.Line (8 * size + (7 * size * (i - 1)) + prevPatWid + ofset, 0)-(8 * size + (7 * size * (i - 1)) + prevPatWid + patWid + ofset, h1), vbWhite, BF
            Else
                bar.Line (8 * size + (7 * size * (i - 1)) + prevPatWid + ofset, 0)-(8 * size + (7 * size * (i - 1)) + prevPatWid + patWid + ofset, h1), vbBlack, BF
            End If
            prevPatWid = prevPatWid + patWid + 1
        Next

        '绘制数字
        prevPatWid = size

        For i = 1 To 6
            bar.CurrentX = 3 * size + (7 * size * (i - 1)) + prevPatWid + ofset
            bar.CurrentY = h2 + 5
            bar.Print Mid$(Text1, i, 1)
            prevPatWid = prevPatWid + (size) - 1
        Next
        prevPatWid = 0

        For i = 7 To 12
            bar.CurrentX = 8 * size + (7 * size * (i - 1)) + prevPatWid + ofset
            bar.CurrentY = h2 + 5
            bar.Print Mid$(Text1, i, 1)
            prevPatWid = prevPatWid + size - 1
        Next
    End If
    bar.Picture = bar.Image

End Sub

Private Sub Command2_Click()
    If bar.Picture = 0 Then
        MsgBox "所选图片不是生成的条形码图片", vbCritical, "提示"
        GoTo skipsave
    End If
    Cdlg.Filter = "*.jpg|*.jpg"
    Cdlg.ShowSave

    If Cdlg.filename = "" Then
        GoTo skipsave
    End If

    SavePicture bar.Picture, Cdlg.filename
skipsave:
End Sub

Private Sub Command3_Click()
    Dialog.Show , Me
    Me.Enabled = False
End Sub

Private Sub Command4_Click()
    Dim dib As New cDIB
    Dim imarray() As Byte
    Cdlg.Filter = "*.jpg,*.bmp|*.jpg;*.bmp"
    Cdlg.ShowOpen
    If Cdlg.filename <> "" Then
        If Dir(Cdlg.filename) <> "" Then
            Picture3.Picture = LoadPicture(Cdlg.filename)
            dib.BW Picture3, Picture3, imarray(), 100
            Picture3.Top = 0
            Picture3.Left = 0
            If Picture3.ScaleHeight <= Picture2.ScaleHeight Then
                VScroll1.Enabled = False
                VScroll1.Value = 0
            Else
                VScroll1.Enabled = True
                VScroll1.Max = (Picture3.ScaleHeight - Picture2.ScaleHeight + HScroll1.Height) / 10
            End If

            If Picture3.ScaleWidth <= Picture2.ScaleWidth Then
                HScroll1.Enabled = False
                HScroll1.Value = 0
            Else
                HScroll1.Enabled = True
                HScroll1.Max = (Picture3.ScaleWidth - Picture2.ScaleWidth + VScroll1.Width) / 10
            End If
        End If
    End If

End Sub

Public Sub scrollV(pict As PictureBox, src As VScrollBar)
    Dim y As Long
    y = src.Value
    pict.Top = -y * 10
End Sub

Public Sub scrollH(pict As PictureBox, src As HScrollBar)
    Dim x As Long
    x = src.Value
    pict.Left = -x * 10

End Sub

Private Sub Command5_Click()
    Picture3.Top = 0
    Picture3.Left = 0
    VScroll1.Value = 0
    HScroll1.Value = 0
End Sub

Private Sub Form_Load()
    VScroll1.Enabled = False
    HScroll1.Enabled = False
End Sub

Private Sub HScroll1_Change()
    scrollH Picture3, HScroll1
End Sub

Private Sub Picture3_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Label6.Caption = "条码识别内容: " & bread(Picture3, x, y)

End Sub

Private Sub VScroll1_Change()
    scrollV Picture3, VScroll1
End Sub

Private Function bread(pb As PictureBox, ByVal x As Long, ByVal y As Long) As String
    Dim i As Long
    Dim read As String

    For i = 1 To 5
        read = bscan(pb, x, y)
        If Left$(read, 5) = "出错" Then
            x = x + 1
            read = bscan(pb, x, y)
        Else
            Exit For
        End If
    Next
    bread = read

End Function

Private Function bscan(pb As PictureBox, ByVal x As Long, ByVal y As Long) As String
    Dim xstart As Long
    Dim sample As Long
    Dim nSpace As Long
    Dim wSpace As Long
    Dim nBar As Long
    Dim wBar As Long
    Dim i, j As Long
    Dim ptn(10) As String
    ptn(0) = "3211"
    ptn(1) = "2221"
    ptn(2) = "2122"
    ptn(3) = "1411"
    ptn(4) = "1132"
    ptn(5) = "1231"
    ptn(6) = "1114"
    ptn(7) = "1312"
    ptn(8) = "1213"
    ptn(9) = "3112"
    xstart = x
    Do
        xstart = xstart + 1
        sample = pb.Point(xstart, y)
        If xstart > x + 75 Then
            bscan = "出错"
            Exit Function
        End If
    Loop While sample

    nSpace = 100
    wSpace = 0
    nBar = 100
    wBar = 0
    x = xstart

    Do
        sample = pb.Point(x, y)
        i = 0
        Do While pb.Point(x + i, y) = sample
            i = i + 1
            If i > 22 Then Exit Do
        Loop

        If i > 22 Or pb.Point(x + i, y) = -1 Then Exit Do

        If sample Then
            If i < nSpace Then nSpace = i
            If i > wSpace Then wSpace = i
        Else
            If i < nBar Then nBar = i
            If i > wBar Then wBar = i
        End If

        x = x + i
    Loop

    Dim tmpStr As String
    Dim dSpace, dBar As Long
    dSpace = nSpace / 2
    dBar = nBar / 2

    x = xstart
    Do
        sample = pb.Point(x, y)
        i = 0
        Do While pb.Point(x + i, y) = sample
            i = i + 1
            If i > wSpace * 2 Then Exit Do
        Loop

        If i > wSpace * 2 Then Exit Do

        If sample Then
            If i >= nSpace - dSpace And i < nSpace * 2 - dSpace Then
                tmpStr = tmpStr & "1"
            ElseIf i >= nSpace * 2 - dSpace And i < nSpace * 3 - dSpace Then
                tmpStr = tmpStr & "2"
            ElseIf i >= nSpace * 3 - dSpace And i < nSpace * 4 - dSpace Then
                tmpStr = tmpStr & "3"
            Else
                tmpStr = tmpStr & "4"
            End If
        Else
            If i >= nBar - dBar And i < nBar * 2 - dBar Then
                tmpStr = tmpStr & "1"
            ElseIf i >= nBar * 2 - dBar And i < nBar * 3 - dBar Then
                tmpStr = tmpStr & "2"
            ElseIf i >= nBar * 3 - dBar And i < nBar * 4 - dBar Then
                tmpStr = tmpStr & "3"
            Else
                tmpStr = tmpStr & "4"
            End If
        End If

        x = x + i
        'If Len(tmpStr) = 35 Then Exit Do
    Loop

    If Len(tmpStr) < 35 Or (Len(tmpStr) > 40 And Len(tmpStr) < 59) Then
        bscan = "出错"
        Exit Function
    End If

    If Len(tmpStr) < 40 Then '// 防止条码线不准确
        If Left$(tmpStr, 3) = "111" And Mid$(tmpStr, 33, 3) = "111" And Mid$(tmpStr, 16, 5) = "11111" Then
        Else

            bscan = "错误: 起始 , 结束和中间标记没找到!"
            Exit Function
        End If
        tmpStr = Mid$(tmpStr, 4, 12) & Mid$(tmpStr, 21, 12)
    Else
        If Left$(tmpStr, 3) = "111" And Mid$(tmpStr, 57, 3) = "111" And Mid$(tmpStr, 28, 5) = "11111" Then
        Else

            bscan = "错误: 起始 , 结束和中间标记没找到!"
            Exit Function
        End If
        tmpStr = Mid$(tmpStr, 4, 24) & Mid$(tmpStr, 33, 24)
    End If

    For i = 0 To Len(tmpStr) / 4 - 1
        For j = 0 To 9
            If Mid$(tmpStr, 1 + i * 4, 4) = ptn(j) Then
                bscan = bscan & Mid$("0123456789", j + 1, 1)
                Exit For
            End If
        Next
    Next
    'bscan = Left$(bscan, 3) & " " & Right$(bscan, 3)

End Function