tiaoxingma.txt

这是一个完整的条形码设计原程序

Public Function PrintBarCode( _
    ByVal strBarCode As String, _
    Optional ByVal intXPos As Integer = 70, _
    Optional ByVal intYPos As Integer = 20, _
    Optional ByVal intPrintHeight As Integer = 15, _
    Optional ByVal bolPrintText As Boolean = False _
)
Dim intOldScaleMode As ScaleModeConstants
Dim intOldDrawWidth As Integer
Dim fntOldFont As StdFont
Dim strBC As String
Dim x As Integer
Dim y As Integer
Dim intHeight As Integer
Dim intIndex As Integer
Dim I As Integer, j As Integer, K As Integer


' 参数说明:
' intXPos, intYPos  - 条形码的左上角坐标(缺省为(0,0)，坐标刻度为:毫米)
' intHeight         - 高度(缺省为一厘米,坐标刻度为:毫米)


' "0"-"9","A-Z","-","%","$"和"*" 的条码编码格式,总共 40 个字符
Static strBarTable(39) As String

' 初始化条码编码格式表


    strBarTable(0) = "000110100"     ' 0
    strBarTable(1) = "100100001"     ' 1
    strBarTable(2) = "001100001"     ' 2
    strBarTable(3) = "101100000"     ' 3
    strBarTable(4) = "000110001"     ' 4
    strBarTable(5) = "100110000"     ' 5
    strBarTable(6) = "001110000"     ' 6
    strBarTable(7) = "000100101"     ' 7
    strBarTable(8) = "100100100"     ' 8
    strBarTable(9) = "001100100"     ' 9
    strBarTable(10) = "100001001"    ' A
    strBarTable(11) = "001001001"    ' B
    strBarTable(12) = "101001000"    ' C
    strBarTable(13) = "000011001"    ' D
    strBarTable(14) = "100011000"    ' E
    strBarTable(15) = "001011000"    ' F
    strBarTable(16) = "000001101"    ' G
    strBarTable(17) = "100001100"    ' H
    strBarTable(18) = "001001100"    ' I
    strBarTable(19) = "000011100"    ' J
    strBarTable(20) = "100000011"    ' K
    strBarTable(21) = "001000011"    ' L
    strBarTable(22) = "101000010"    ' M
    strBarTable(23) = "000010011"    ' N
    strBarTable(24) = "100010010"    ' O
    strBarTable(25) = "001010010"    ' P
    strBarTable(26) = "000000111"    ' Q
    strBarTable(27) = "100000110"    ' R
    strBarTable(28) = "001000110"    ' S
    strBarTable(29) = "000010110"    ' T
    strBarTable(30) = "110000001"    ' U
    strBarTable(31) = "011000001"    ' V
    strBarTable(32) = "111000000"    ' W
    strBarTable(33) = "010010001"    ' X
    strBarTable(34) = "110010000"    ' Y
    strBarTable(35) = "011010000"    ' Z
    strBarTable(36) = "000111000"    ' -
    strBarTable(37) = "100101000"    ' %
    strBarTable(38) = "010101000"    ' $
    strBarTable(39) = "010010100"    ' *

    If strBarCode = "" Then Exit Function
   

' 设置坐标刻度为缇(twip=1)
  Me.DrawWidth = 1
  ' 线宽为 1
  
    
    
  
    strBC = UCase(strBarCode)
    ' 将以毫米表示的 X 坐标转换为以缇表示
    
    x = Me.ScaleX(intXPos, vbMillimeters, vbTwips)
    ' 将以毫米表示的 Y 坐标转换为以缇表示
    
    y = Me.ScaleY(intYPos, vbMillimeters, vbTwips)
    ' 将以毫米表示的高度转换为以缇表示
    
    intHeight = Me.ScaleY(intPrintHeight, vbMillimeters, vbTwips)
    
    
    If bolPrintText = True Then
        ' 条码高度要减去下面的字符显示高度
        intHeight = intHeight - Me.TextHeight(strBC)
    End If
    
    Const intWidthCU As Integer = 36
  ' 粗线和宽间隙宽度
    Const intWidthXI As Integer = 12
  ' 细线和窄间隙宽度
    
  

    ' 添加起始字符
    If Left(strBC, 1) <> "*" Then
        strBC = "*" & strBC
    End If
    ' 添加结束字符
    If Right(strBC, 1) <> "*" Then
        strBC = strBC & "*"
    End If
    
    ' 循环处理每个要显示的条码字符
    For I = 1 To Len(strBC)
        ' 确定当前字符在 strBarTable 中的索引
        Select Case Mid(strBC, I, 1)
        Case "*"
            intIndex = 39
        Case "$"
            intIndex = 38
        Case "%"
            intIndex = 37
        Case "-"
            intIndex = 36
        Case "0" To "9"
            intIndex = CInt(Mid(strBC, I, 1))
        Case "A" To "Z"
            intIndex = Asc(Mid(strBC, I, 1)) - Asc("A") + 10
        Case Else
            Exit Function
            
      '当前版本只支持字符
      '0\'-\'9\',\'A\'-\'Z\',\'-\',\'%\',\'$\'和\'*\'"
        End Select
        
        
        If bolPrintText = True Then
            Me.CurrentX = x
           Me.CurrentY = y + intHeight
            Print Mid(strBC, I, 1)
        End If

        For j = 1 To 5
            ' 画细线
            If Mid(strBarTable(intIndex), j, 1) = "0" Then
                For K = 0 To intWidthXI - 1
                   Line (x + K, y)-Step(0, intHeight)
                Next K
                x = x + intWidthXI
            ' 画宽线
            Else
                For K = 0 To intWidthCU - 1
                    Line (x + K, y)-Step(0, intHeight)
                Next K
                x = x + intWidthCU
            End If

            ' 每个字符条码之间为窄间隙
            If j = 5 Then
                x = x + intWidthXI * 4 - 10
                Exit For
            End If
            
            ' 窄间隙
            If Mid(strBarTable(intIndex), j + 5, 1) = "0" Then
                x = x + intWidthXI * 4 - 10
            ' 宽间隙
            Else
                x = x + intWidthCU * 2 - 20
            End If
        Next j
    Next I

   
    
End Function
Private Sub Command1_Click()
PrintBarCode (Text1.Text)
Label1.Caption = Text1.Text

End Sub
Private Sub Command2_Click()
Unload Me
End Sub
Private Sub Command3_Click()
SavePicture Form1.Image, "d:\libing.bmp"
End Sub