[Chia sẻ] Hàm tạo một số loại Barcode mã nguồn thuần VBA

[Mr.hieudoanxd]

Xuất phát từ bài viết này. Trong quá trình tìm hiểu cách tạo QRCode và URL, Em cải tiến thêm và bổ sung một số mã Barcode khác.
Hôm nay em chia sẻ mọi người trong diễn đàn hàm AddBarCode để tạo các loại mã sau:
QRCode, DataMatrix, Aztec, MaxiCode, Code128, EAN-13, UPC-A, ITF-14, Code39
Công thức hàm AddBarCode ( Text , sStyle , isRes). Trong đó các tham số
+)Text: Văn bản muốn chuyển đổi sang mã Barcode tương ứng
+)sStyle: Loại Barcode muốn chuyển đổi tương ứng như sau:
QRCode = 0 (Giá trị mặc định)
DataMatrix = 1
Aztec = 2
MaxiCode = 3
Code128 = 4
EAN13 = 5
UPCA = 6
ITF = 7
Code39 = 8
+)isRes: Có trả về văn bản báo hoàn thành hay không?
Hàm trên nếu báo lỗi sẽ trả về Comment tại ô viết hàm trong comment có nội dung URL sử dụng và quy tắc của văn bản đầu vào tương ứng với loại Barcode muốn tạo

P/s: Trong bài có sử dụng hàm Uniconvert chắc của anh @huuthang_bd

Enum s_Barcode
    sQRCode = 0
    sDataMatrix = 1
    sAztec = 2
    sMaxiCode = 3
    sCode128 = 4
    sEAN13 = 5
    sUPCA = 6
    sITF = 7
    sCode39 = 8
End Enum

Function AddBarCode(Text As String, Optional ByVal sStyle As s_Barcode = sQRCode, Optional ByVal isRes As Boolean = False) As String
    Dim sURL As String, sFolderPath As String, sFilePath As String, str As String
    Dim objXML As Object, objStream As Object
    Dim rng As Range, sh As Worksheet, shp As Shape, arr
    
    On Error Resume Next
    Application.Volatile
    
    Set objXML = CreateObject("MSXML2.XMLHTTP")
    Set objStream = CreateObject("ADODB.Stream")
    Set rng = Application.Caller
    Set sh = rng.Worksheet
    arr = Array("QRCode", "DataMatrix", "Aztec", "MaxiCode", "Code128", "EAN-13", "UPC-A", "ITF-14", "Code39")
    
    If Text = "" Then Exit Function
    For Each shp In sh.Shapes
        If Not Intersect(shp.TopLeftCell, rng) Is Nothing Then shp.Delete
    Next shp
    If Not (rng.Comment Is Nothing) Then rng.Comment.Delete
    
    sFolderPath = Environ("TEMP") 'truy xuat bien moi truong cua he dieu hanh
    sFilePath = sFolderPath & "\QRCode.png"
    str = EncodeURL(Text)
    
    Select Case sStyle
Rem Case "QRCode":      sURL = "https://api.qrserver.com/v1/create-qr-code/?size=150x150&data=" & str
    Case sQRCode:       sURL = "https://bwipjs-api.metafloor.com/?bcid=qrcode&text=" & str
    Case sDataMatrix:   sURL = "https://bwipjs-api.metafloor.com/?bcid=datamatrix&text=" & str
    Case sAztec:        sURL = "https://bwipjs-api.metafloor.com/?bcid=azteccode&text=" & str
    Case sMaxiCode:     sURL = "https://bwipjs-api.metafloor.com/?bcid=maxicode&text=" & str
    Case sCode128:      sURL = "https://bwipjs-api.metafloor.com/?bcid=code128&text=" & str
    Case sEAN13:        sURL = "https://bwipjs-api.metafloor.com/?bcid=ean13&text=" & str
    Case sUPCA:         sURL = "https://bwipjs-api.metafloor.com/?bcid=upca&text=" & str
    Case sITF:          sURL = "https://bwipjs-api.metafloor.com/?bcid=itf14&text=" & str
    Case sCode39:       sURL = "https://bwipjs-api.metafloor.com/?bcid=code39&text=" & str
    Case Else:          Exit Function
    End Select
    
    objXML.Open "GET", sURL, False ' Tai hinh anh QR Code tu URL
    objXML.sEnd
    If objXML.Status = 200 Then ' Kiem tra trang thai phan hoi HTTP
        With objStream ' Luu hinh anh vao stream
            .Type = 1 ' Binary
            .Open
            .Write objXML.responseBody
            .SaveToFile sFilePath, 2 ' Luu vao tep tam thoi
            .Close
        End With
 
        With ActiveSheet.Pictures.Insert(sFilePath) ' Chen hinh anh vao trang tinh
            .Left = rng.Left
            .Top = rng.Top
            .Width = rng.Width
            .Height = rng.Height
        End With
        Kill sFilePath
        AddBarCode = IIf(isRes, "T" & ChrW(7841) & "o " & arr(sStyle) & " Xong!", "")
    Else
        AddBarCode = ""
        str = UniConvert("Khoong theer tari hifnh arnh QR Code tuwf") & "URL: " & ChrW(10) & sURL
        Select Case sStyle
        Case sQRCode:       str = str
        Case sDataMatrix:   str = str & ChrW(10) & "Mã DataMatrix " & UniConvert("laf chuooxi bao goofm casc kys tuwj") & " ASCII t" & ChrW(7915) & " 0-255"
        Case sAztec:        str = str & ChrW(10) & UniConvert("Max Aztec la chuooxi bao goofm casc kys tuwj") & " ASCII t" & ChrW(7915) & " 0-255"
        Case sMaxiCode:     str = str & ChrW(10) & "Mã MaxiCode " & UniConvert("laf chuooxi bao goofm casc kys tuwj") & " ASCII t" & ChrW(7915) & " 0-255"
        Case sCode128:      str = str & ChrW(10) & UniConvert("Max Code128 laf chuooxi bao goofm casc kys tuwj ASCII tuwf 0 ddeesn 127")
        Case sEAN13:        str = str & ChrW(10) & UniConvert("Max EAN-13 laf chuooxi 12 chuwx soos, chir chuwsa soos tuwf 0 ddeesn 9")
        Case sUPCA:         str = str & ChrW(10) & UniConvert("Max UPC-A la chuooxi 11 chuwx soos, chir chuwsa soos tuwf 0 ddeesn 9")
        Case sITF:          str = str & ChrW(10) & "Mã ITF-14 " & UniConvert("laf chuooxi cos 13 hoawjc 14 chuwx soos, chir chuwsa soos tuwf 0 ddeesn 9")
        Case sCode39:       str = str & ChrW(10) & UniConvert("Max Code39 laf chuooxi bao goofm casc kys tuwj A ddeesn Z, 0 ddeesn 9 vaf moojt soos kys tuwj ddawjc bieejt nhuw ( - , . $ / + %   ")
        End Select
        With rng
            .AddComment
            .Comment.Visible = True
            .Comment.Text Text:=cst_AddinName & ":" & ChrW(10) & " " & str
            .Comment.Shape.TextFrame.Characters.Font.Bold = False
        End With
    End If
End Function
Private Function EncodeURL(Text As String) As String
    Dim i As Long, s As String, str As String
    For i = 1 To Len(Text)
        s = Mid(Text, i, 1)
        Select Case Asc(s)
        Case 48 To 57, 65 To 90, 97 To 122  ' 0-9, A-Z, a-z
            str = str & s
        Case Else
            str = str & "%" & Right("0" & Hex(Asc(s)), 2)
        End Select
    Next i
    EncodeURL = str
End Function

 

[Hoàng Tuấn 868]

Hàm này cần kết nối internet đúng không bạn,

Đúng rồi bác.

Nếu phải thế này thì khi sử dụng cũng bất tiện quá nhỉ.