Add in tạo QR code miễn phí. (1 người xem)

[LuuAnh980]

Các anh chị nào có Add in tao QR code miễn phí cho em xin với.

 

[HeSanbi]

Bạn có thể tải về tham khảo add-in này

Release v2.20.1 · yas78/QRCodeLibVBA

Full Changelog: v2.20.0...v2.20.1 ソースコードの改行コードがLFに変換されており、VBEで正常にインポートできなくなっていたためCRLFに修正しました。

github.com

 

[LuuAnh980]

Anh @HeSanbi chỉ em cách làm với!!!!!

 

[HeSanbi]

Bạn tải về cài đặt, chỉ cần gõ hàm =QR("Chuỗi") vào ô là xong rồi.

Muốn sử dụng nâng cao hơn thì sửa mã để có các mã hóa chuỗi Unicode dài hơn

 

[LuuAnh980]

Em không thấy file cài đặt anh @HeSanbi ơi.

Bài đã được tự động gộp: 9/1/25

Em tải về, giải nén ra như vầy ạ:

 

[LuuAnh980]

Sao nó có rồi, mà em gõ =QR nó không hiện ra Function QR

 

[HUONGHCKT]

Các anh chị nào có Add in tao QR code miễn phí cho em xin với.

Tham khảo code sưu tầm trên mạng.
Code tạo mã QRcode này chạy mà không cần có mạng.

Sub CRQRCODE(ByVal xContent As String, ByVal SheetName As String, ByVal xAddress As Range)
     With Documents.Add
        .Fields.Add(Range:=.Range, Type:=-1, Text:="Displaybarcode""" & xContent & """  QR", PreserveFormatting:=True).Cut
        .Shapes.AddShape(msoShapeRectangle, 2, 2, 2, 2).Select
        .Shapes(1).Fill.Visible = msoFalse
        .Shapes(1).TextFrame.TextRange.Paste
        .Shapes(1).TextFrame.AutoSize = True
        .Shapes(1).Height = .Shapes(1).Height - 10
        .Shapes(1).Width = .Shapes(1).Height + 8
        .Shapes(1).Line.Visible = msoFalse
        .Shapes(1).Select
        .Application.Selection.Copy
        .Close False
    End With
    ThisWorkbook.Sheets(SheetName).Pictures.Paste.Select
    With Selection
        If CheckErPic(SheetName, xAddress.Address) = True Then
            Sheets(SheetName).Shapes(xAddress.Address).Delete
        End If
        .Name = xAddress.Address
        ThisWorkbook.Sheets(SheetName).Activate
        If xAddress.Width > xAddress.Height Then
            .Height = xAddress.Height
            .Left = xAddress.Left + (xAddress.Width - xAddress.Height) / 2 - 5
            .Top = xAddress.Top
        Else
            .Top = xAddress.Top + (xAddress.Height - xAddress.Width) / 2 + 4
            .Left = xAddress.Left
            .Width = xAddress.Width
        End If
    End With
End Sub
    
Sub RunCrQR()
    Dim i As Integer
    i = 4
    With ActiveSheet
    Do While .Cells(i, 1) <> ""
        CRQRCODE .Cells(i, 2).Value, .Name, .Cells(i, 4)
    i = i + 1
    Loop
    End With
End Sub

Function CheckErPic(ByVal SheetName As String, ByVal xNamePic As String) As Boolean
    Dim pic As Shape
    On Error GoTo sai
    Set pic = Sheets(SheetName).Shapes(xNamePic)
    CheckErPic = True
    Exit Function
sai:
     CheckErPic = False
End Function

Hy vọng đáp ứng được yêu cầu

 

[HeSanbi]

Đọc lại mã, thì thấy mã nguồn chưa có hàm đó, bạn tải add-in tôi đã thêm hàm QREncode


Các đối số của hàm ecLevel là cấp độ sửa lỗi mã hóa của QR, mặc định là cấp H = 3
Cấp L = 0
Cấp M = 1
Cấp Q = 2
Cấp H = 3

Public Function QREncode(ByVal text As String, _
          Optional ByVal width! = 80, _
          Optional ByVal height! = 80, _
          Optional ByVal ecLevel As ErrorCorrectionLevel = ErrorCorrectionLevel.H, _
          Optional ByVal charsetName As String = "Shift_JIS") As Variant

 

[LuuAnh980]

Chạy nó làm sao Anh @HUONGHCKT ????

Bài đã được tự động gộp: 9/1/25

Được rồi anh @HeSanbi ơi, thế nếu mình quét nó ra thêm thông tin nữa thì làm cách nào anh.
Như khi quét ra:
1/ mã vật tư
2/Tên vật tư
3/ số lượng tồn.vvv

 

[HeSanbi]

Tham khảo code sưu tầm trên mạng.
Code tạo mã QRcode này chạy mà không cần có mạng.

Mã đó sử dụng Word để tạo mã QR, nên cần thêm lệnh khởi chạy Word. Hoặc thêm tham chiếu thư viện Word cho dự án Excel, chỉ hỗ trợ cho Excel 2013 trở về sau.

     Static AW As Object
     If AW Is Nothing Then Set AW = CreateObject("Word.Application")
    With AW.Documents

    End With

 

[HUONGHCKT]

Chạy nó làm sao Anh @HUONGHCKT ????

Bạn gỡ gì đó vào cột A,/Sh Active. và chạy sub RunCrQR. để được kết quả.

 

[LuuAnh980]

Chào anh @HeSanbi !!!!
Cám ơn anh đã tạo Add in QR Code, mong anh chỉnh cho Picture mặc định to thêm tí nữa ạ, và hiện thời em đang làm theo cách này, lấy giá trị của các ô C,I,J,H ghép lại xong nhấn Alt+Enter để xuống dòng trong cùng 1 cell của Sheet3,xong em dùng Function QREncode tạo QR Code, vì công thức chỉ cho =QREncode(giá trị 1 cell) có cách nào chỉnh cho như vầy không anh: =QREncode(C2, I2, J2, H2) không anh. Và xuống dòng mỗi cell. Khi quét hiện như sau:
PM05-22-72S
3X1400
23900Kg
Em gửi file,mong anh giúp.

 

[HeSanbi]

Bạn nhập như thế này

=QREncode(C2 & char(10) & I2 & char(10) & J2 & char(10) & H2, 100,100)

(Add-in đó có nguồn gốc từ Nhật) QR Code cũng do 1 người Nhật sáng kiến và tạo ra

 

[LuuAnh980]

Em cám ơn anh @HeSanbi nhiều ạ.

 

[htin1997]

Dùng tạm của mình, nó tạo QR chèn vào note:

Sub addQR()
'On Error Resume Next
'format=svg/png/jpg, bgcolor=RGB, https://goqr.me/api/doc/create-qr-code/ http://api.qrserver.com/v1/create-qr-code/?format=png&ecc=H&margin=5&bgcolor=255-255-255&data=
Application.ScreenUpdating = 1
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
For Each i In Selection
    If i <> "" Then
        pic = "https://api.qrserver.com/v1/create-qr-code/?format=png&size=350x350&data=" & i.Value
          If i.Comment Is Nothing Then i.AddComment
         i.Comment.Text vbLf
          With i.Comment.Shape
            .Left = ActiveCell.Left: .Top = ActiveCell.Top:
            .Visible = False
            .Width = 250: .Height = 250
            .Fill.UserPicture pic
            End With
    End If
Next
Application.ScreenUpdating = 1
Application.EnableEvents = 1
Application.Calculation = xlCalculationAutomatic
End Sub