frmmain.frm

128位二维条码生成器,经测试是完全能应用于实际中的

VERSION 5.00
Begin VB.Form frmMain 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "128位二维条码"
   ClientHeight    =   1650
   ClientLeft      =   45
   ClientTop       =   435
   ClientWidth     =   5235
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1650
   ScaleWidth      =   5235
   StartUpPosition =   2  '屏幕中心
   Begin VB.PictureBox picBarcode 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      BackColor       =   &H00FFFFFF&
      ForeColor       =   &H80000008&
      Height          =   210
      Left            =   3480
      ScaleHeight     =   12
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   11
      TabIndex        =   4
      Top             =   900
      Width           =   195
   End
   Begin VB.PictureBox picBarcodeLarge 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      BackColor       =   &H00FFFFFF&
      ForeColor       =   &H80000008&
      Height          =   1080
      Left            =   3990
      ScaleHeight     =   70
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   64
      TabIndex        =   2
      Top             =   150
      Width           =   990
   End
   Begin VB.TextBox txtInput 
      Height          =   360
      Left            =   900
      MultiLine       =   -1  'True
      TabIndex        =   1
      Top             =   180
      Width           =   2700
   End
   Begin VB.Label Label2 
      Caption         =   "金诺VB园收藏整理  www.vbget.com"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   14.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   315
      Left            =   210
      TabIndex        =   5
      Top             =   1320
      Width           =   4605
   End
   Begin VB.Label Label1 
      Caption         =   "结果:             -->"
      Height          =   255
      Index           =   1
      Left            =   2850
      TabIndex        =   3
      Top             =   870
      Width           =   495
   End
   Begin VB.Label Label1 
      Alignment       =   1  'Right Justify
      Caption         =   "输入条码:"
      Height          =   225
      Index           =   0
      Left            =   30
      TabIndex        =   0
      Top             =   240
      Width           =   855
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit

Private Type RECT
    Left   As Long
    Top    As Long
    Right  As Long
    Bottom As Long
End Type

Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function FillRect Lib "user32.dll" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function SetPixel Lib "gdi32.dll" Alias "SetPixelV" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long

Dim Bits(7) As Long

Private Sub Encode()
    Dim cMD5              As clsMD5
    Dim sMD5Hash          As String
    Dim blBitArray(127)   As Boolean
    Dim a, b, iX, iY      As Integer
    Dim tRect             As RECT
    Dim lBrush            As Long
    Dim iSize             As Integer
    
    If txtInput.Text <> "" Then
        Set cMD5 = New clsMD5
        sMD5Hash = cMD5.MD5(txtInput.Text)
        Set cMD5 = Nothing
        
        For a = 0 To 15
            For b = 0 To 7
                blBitArray((a * 8) + b) = CByte("&H" & Mid$(sMD5Hash, ((a + 1) * 2), 2)) And Bits(b)
            Next b
        Next a
        
        iX = 0: iY = 0
        iSize = 6
        
        picBarcode.Cls: picBarcodeLarge.Cls
        
        lBrush = CreateSolidBrush(&H0&)
        For iY = 0 To 11
            For iX = 1 To 11
                If blBitArray((iY * 10) + iX) Then Call SetPixel(picBarcode.hDC, iX - 1, iY, &H0&)
                
                With tRect
                    .Left = (iX * iSize) - iSize
                    .Top = (iY * iSize)
                    .Right = (.Left + iSize)
                    .Bottom = (.Top + iSize)
                End With
                If blBitArray((iY * 10) + iX) Then Call FillRect(picBarcodeLarge.hDC, tRect, lBrush)
            Next iX
        Next iY
        Call DeleteObject(lBrush)
    Else
        picBarcode.Cls: picBarcodeLarge.Cls
    End If
End Sub

Private Sub Form_Load()
    Dim I As Integer
    
    For I = 0 To 7
        Bits(I) = (2 ^ I): DoEvents
    Next I
End Sub

Private Sub txtInput_Change()
    Call Encode
End Sub