Mr.hieudoanxd
Thành viên thường trực
- Tham gia
- 25/10/19
- Bài viết
- 292
- Được thích
- 132
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
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
Mã:
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
.
