Thấy cái mã QR cũng hay hay (ai dùng Smartphone đều biết). Tuy nhiên tôi đang thắc mắc: Nếu dùng code VBA tạo ra mã QR trên Excel thì liệu ta có thể ứng dụng nó vào việc gì?
Hỏi thế là bởi: Phải có ứng dụng thực tế và hữu ích thì mới có hứng trong việc viết code
Không biết có ai có nhu cầu này hoặc có ý tưởng hay về ứng dụng liên quan đến QR code không nhỉ?
Thấy cái mã QR cũng hay hay (ai dùng Smartphone đều biết). Tuy nhiên tôi đang thắc mắc: Nếu dùng code VBA tạo ra mã QR trên Excel thì liệu ta có thể ứng dụng nó vào việc gì?
Hỏi thế là bởi: Phải có ứng dụng thực tế và hữu ích thì mới có hứng trong việc viết code
Không biết có ai có nhu cầu này hoặc có ý tưởng hay về ứng dụng liên quan đến QR code không nhỉ?
cty tôi dùng nó trên mã sp, chương trình cân thì viết bắng SQL, thấy anh IT crack trên mạng về rồi nhúng nó vào, xài ok vài tháng nay, nhưng nó cứ hiện cái thông báo đòi mua hoìa. AnhNDU viet cho anh em xem với nh
xem ta nhận được cái gì nha
Đây chính là chìa khóa để tạo mã QR (dùng dịch vụ của google)
-----------------------------------------------------------
Tiến hành phân tích:
- Giả định rằng ta có chuỗi: Nguyen Anh Tuan
- Bằng cách nào đó ta biến đổi chuỗi trên thành:
(tạm gọi đây là biến sURL nha)
Trong đó: chỗ không tô màu là const, chỗ màu xanh có thể tùy chỉnh hoặc để mặc định (nó là size), chỗ màu đỏ chính là chuỗi đầu vào (nhớ rằng khoảng trắng phải được biến đổi thành dấu +)
- Tiếp theo thử gõ vào cửa sổ Immediate dòng code:
enter phát xem nó ra cái gì
---------------------------------
Vậy, việc chính của bạn chỉ là: làm cách nào để biến đổi chuỗi đầu vào thành sURL rồi ráp vào phương thức AddPicture là được rồi
Lưu ý:
- Chỗ màu đỏ không áp dụng cho tiếng Việt có dấu (nếu muốn thì phải cần 1 hàm convert)
- Đương nhiên phải kết nối internet mới dùng được
-------------------------------
Đã có ai nghiên cứu vụ này chưa nhỉ (một mình mình làm thì cảm giác không chắc ăn lắm)
--------------
Phát hiện ra mấy chuyện:
- Hình như là chẳng cần đổi rổng thành "+" gì ráo cũng được
- Hình như là tiếng Việt cũng chơi được luôn là không cần phải có hàm convert (UTF8)
Tôi viết sơ qua mấy code: 1> Tạo mã QR, dùng Shape
Mã:
Private Function pic_QR(ByVal QR_Value As String, ByVal Target As Range, Optional ByVal Size As Long = 150) As Shape
Dim sURL As String
On Error Resume Next
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
Set pic_QR = Target.Parent.Shapes.AddPicture(sURL, True, True, Target.Left, Target.Top, Size, Size)
End If
End Function
Sub Main()
Dim shp As Shape
Set shp = pic_QR(Range("A1").Value, ActiveCell)
End Sub
Cách dùng: Gõ gì đó vào cell A1 rồi chạy sub Main 2> Tạo mã QR, dùng Comment
Mã:
Function cmt_QR(ByVal QR_Value As String, Optional ByVal cel As Range, Optional ByVal Size As Long = 150) As String
Dim sURL As String, mRng As Range, cmt As Comment
On Error Resume Next
Application.Volatile
If cel Is Nothing Then Set cel = Application.ThisCell
cel(1, 1).Comment.Delete
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
If cel(1, 1).Comment Is Nothing Then cel(1, 1).AddComment
cel(1, 1).Comment.text vbLf
Set mRng = cel(1, 1).MergeArea
If mRng Is Nothing Then Set mRng = cel(1, 1)
Set cmt = mRng(1, 1).Comment
cmt.Visible = True
With cmt.Shape
.LockAspectRatio = msoFalse
.Placement = xlMoveAndSize
.Shadow.Visible = msoFalse
.Line.Visible = msoFalse
.AutoShapeType = msoShapeRectangle
.Left = mRng.Left: .Top = mRng.Top
.Width = mRng.Width: .Height = mRng.Height
.Fill.UserPicture sURL
End With
End If
End Function
Cách dùng: Gõ công thức =cmt_QR(A1) vào cell nào đó (với A1 là dữ liệu đầu vào)
------------------------------
Các bạn test giúp tôi: Tạo mã bằng 2 code trên rồi dùng các chương trình quét mã QR trên smartphone scan thử xem ra kết quả đúng không nha
Thầy cho em Spam một tí ah! Em đang xài con SamSung Galasy SM-G360H, mà em chả biết mã QR ở đâu và làm gì???? Em chỉ biết dùng nó để lên Face và Zalo thôi.
Thầy cho em Spam một tí ah! Em đang xài con SamSung Galasy SM-G360H, mà em chả biết mã QR ở đâu và làm gì???? Em chỉ biết dùng nó để lên Face và Zalo thôi.
Em thấy rồi, nhưng công dụng của nó để làm gì vậy Thầy.Em bật nó lên thì nó báo quét mã QR của tôi, em đưa ngón tay vào nó quét, rồi lưu vào thư viện của tôi rồi thôi. Rồi em chả biết làm sao nữa. Mong Thầy chỉ giáo!!!!
Em thấy rồi, nhưng công dụng của nó để làm gì vậy Thầy.Em bật nó lên thì nó báo quét mã QR của tôi, em đưa ngón tay vào nó quét, rồi lưu vào thư viện của tôi rồi thôi. Rồi em chả biết làm sao nữa. Mong Thầy chỉ giáo!!!!
Trời ơi ! Google đâu. Bạn lên Google mà tra: mã QR code là gì ? công dụng của mã QR code,nó dùng để làm gì? rồi hướng dẫn sử dụng các phần mềm quét mã QR code trên điện thoại thậm chí bạn còn có thể tạo ra mã QR code của riêng bạn nữa cơ. Những cái mà trên Google đã có sẵn rồi thì ta có thể tự tìm hiểu mà bạn.
Thật không ngờ dùng Zalo cũng lâu rồi mà bữa nay chú nói mới biết Zalo cũng có tiện ích quét cái mã QR code này chú ạ.
Hôm trước có vào đọc chủ đề này của chú, nay mới vào đọc lại cơ mà thấy mọi người có vẻ chưa hào hứng lắm hay là do từ qua tới giờ các thành viên trên GPE bận bịu gì mà thấy có ít người vào bình luận quá chú.
Em thấy rồi, nhưng công dụng của nó để làm gì vậy Thầy.Em bật nó lên thì nó báo quét mã QR của tôi, em đưa ngón tay vào nó quét, rồi lưu vào thư viện của tôi rồi thôi. Rồi em chả biết làm sao nữa. Mong Thầy chỉ giáo!!!!
trước đây người ta dùng mã vạch barcode để ghi mã sản phẩm (bạn vào siêu thì thấy người ta tính tiền rồi chứ!!!)
tuy nhiên barcode chỉ có thể chứ thông tin dạng số (dạng 0-1-0-1....)
người ta phát triển thệm QR code, nó có thể chứa cả thông tin dạng số lẫn thông tin dạng text, nhơ vậy khi đọc mã sản phẩm, bạn có thể biết nước nào sản xuấtm trong lượng tổng tin, làm ở đâu nhà máy nào, cn tên gì.........đại khái là rất nhiều, tuy ngừi ta đưa vào đó cái gì
lý thuyết thì bạn có thể chứa cả quyển tiểu thuyết trên một cái QR code
Ah, trong thẻ bảo hiểm y tế của em nó cũng có hình "ma trận" như khi qét mã QR vậy, nhưng khi em quét mã QR xong nó hỏi chia sẻ qua Facebook hoặc Google+ chứ không có Zalo thì làm sao hả Anh????
Đại khái, mã QR cơ bản chỉ là dòng thông tin thôi, việc quét mã QR chứa nội dung thông tin 1 Link nào đó, có thể là Web, 1 link chứa file tải về, chỉ chạy link này khi phần mềm quét mã QR tích hợp thêm chức năng nếu đọc ra thông tin là 1 Link (URL) và cho chạy luôn link đó.
Bạn có thể tải về một số ứng dụng cho smartphone để thực hiện đọc thông tin từ mã QR này. (trên App Store, Google Play... có nhiều)
-----------------------
Một dạo em cũng tìm hiểu về QR Code này, cũng có ý định thử tự tạo trên excel (dùng VBA để tự tạo các điểm ảnh trên bảng tính) nhưng nhận thấy hạn chế của VBA nên không thực hiện nữa, đặc biệt hạn chế khi tiến hành trên các version cao hơn, bộ tạo đa thức, tạo mã sửa lỗi, mẫu patterns...
Việc sử dụng "bộ máy" tạo trên google để tạo ảnh và lấy về excel như thầy Ndu là một ý tưởng rất hay
Vấn đề là code dựa trên ý tưởng trên đã ra kết quả chính xác chưa?
Chỉ cần cầm cái điện thoại lên, thử nghiệm quét 1 phát rồi báo kết quả cho mình biết, vậy mà chẳng thấy ai giúp được nhỉ?
Vấn đề là code dựa trên ý tưởng trên đã ra kết quả chính xác chưa?
Chỉ cần cầm cái điện thoại lên, thử nghiệm quét 1 phát rồi báo kết quả cho mình biết, vậy mà chẳng thấy ai giúp được nhỉ?
đã text, và cho kết quả chính xác
nhưng nếu mình liên kết nhiều cell lại, nếu tức là nội dung nằm trên nhiêu cell thì liên kết nó lại như thế nào vậy anh NDU
với lại tốc upload, download có phụ thuộc vào độ dài của nội dung không anh?
Cái này tôi cũng không biết đâu! Quá trình áp dụng vào thực tế sẽ có ngay câu trả lời. Thậm chí là chỉnh sửa, tối ưu tốc độ... gì gì đó cũng phải có file thực tế để làm chứ, đúng không?
vâng tức là nối cái chuổi lại, vì nội dung thì có thể ờ nhiều cell khác nhau, hoặc có thể trên listbox, textbox dạng như thông tin của một sản phẩm đó mà
nhưng ko sao, cái này nhiều trên diễn đàn rồi, mò mò sẻ làm được
cám ơn anh vì những chia sẻ
vâng tức là nối cái chuổi lại, vì nội dung thì có thể ờ nhiều cell khác nhau, hoặc có thể trên listbox, textbox dạng như thông tin của một sản phẩm đó mà
Ủa! Thì cứ nối bình thường mà bạn!
Ví dụ:
- Ta có A1 có giá trị Cộng hòa xã hội chủ nghĩa Việt Nam
- Ta dùng công thức =cmt_QR(A1) sẽ ra được mã QR nào đó
Giờ ta lại có các giá trị nằm trên nhiều cells:
- A5 có giá trị Cộng hòa
- A6 có giá trị xã hội
- A7 có giá trị chủ nghĩa
- A8 có giá trị Việt Nam
- Ta dùng công thức =cmt_QR(A5&" "&A6&" "&A7&" "&A8) cũng sẽ cho mã QR tương đương thôi
Đã có ai nghiên cứu vụ này chưa nhỉ (một mình mình làm thì cảm giác không chắc ăn lắm)
--------------
Phát hiện ra mấy chuyện:
- Hình như là chẳng cần đổi rổng thành "+" gì ráo cũng được
- Hình như là tiếng Việt cũng chơi được luôn là không cần phải có hàm convert (UTF8)
Tôi viết sơ qua mấy code: 1> Tạo mã QR, dùng Shape
Mã:
Private Function pic_QR(ByVal QR_Value As String, ByVal Target As Range, Optional ByVal Size As Long = 150) As Shape
Dim sURL As String
On Error Resume Next
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
Set pic_QR = Target.Parent.Shapes.AddPicture(sURL, True, True, Target.Left, Target.Top, Size, Size)
End If
End Function
Sub Main()
Dim shp As Shape
Set shp = pic_QR(Range("A1").Value, ActiveCell)
End Sub
Cách dùng: Gõ gì đó vào cell A1 rồi chạy sub Main 2> Tạo mã QR, dùng Comment
Mã:
Function cmt_QR(ByVal QR_Value As String, Optional ByVal cel As Range, Optional ByVal Size As Long = 150) As String
Dim sURL As String, mRng As Range, cmt As Comment
On Error Resume Next
Application.Volatile
If cel Is Nothing Then Set cel = Application.ThisCell
cel(1, 1).Comment.Delete
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
If cel(1, 1).Comment Is Nothing Then cel(1, 1).AddComment
cel(1, 1).Comment.text vbLf
Set mRng = cel(1, 1).MergeArea
If mRng Is Nothing Then Set mRng = cel(1, 1)
Set cmt = mRng(1, 1).Comment
cmt.Visible = True
With cmt.Shape
.LockAspectRatio = msoFalse
.Placement = xlMoveAndSize
.Shadow.Visible = msoFalse
.Line.Visible = msoFalse
.AutoShapeType = msoShapeRectangle
.Left = mRng.Left: .Top = mRng.Top
.Width = mRng.Width: .Height = mRng.Height
.Fill.UserPicture sURL
End With
End If
End Function
Cách dùng: Gõ công thức =cmt_QR(A1) vào cell nào đó (với A1 là dữ liệu đầu vào)
------------------------------
Các bạn test giúp tôi: Tạo mã bằng 2 code trên rồi dùng các chương trình quét mã QR trên smartphone scan thử xem ra kết quả đúng không nha
Thấy cái mã QR cũng hay hay (ai dùng Smartphone đều biết). Tuy nhiên tôi đang thắc mắc: Nếu dùng code VBA tạo ra mã QR trên Excel thì liệu ta có thể ứng dụng nó vào việc gì?
Hỏi thế là bởi: Phải có ứng dụng thực tế và hữu ích thì mới có hứng trong việc viết code
Không biết có ai có nhu cầu này hoặc có ý tưởng hay về ứng dụng liên quan đến QR code không nhỉ?
em có 1 kho hàng nhỏ khoảng gần 100 mặt hàng phụ tùng cơ khí. Có cách nào kết hợp QR code và thiết bị quét là smartphone, dữ liệu máy tính để quản lý kho hàng (Xuất - Nhập -Tồn - Kiểm kê) không Bác!
Xin Bác chỉ giáo!
Đã có ai nghiên cứu vụ này chưa nhỉ (một mình mình làm thì cảm giác không chắc ăn lắm)
--------------
Phát hiện ra mấy chuyện:
- Hình như là chẳng cần đổi rổng thành "+" gì ráo cũng được
- Hình như là tiếng Việt cũng chơi được luôn là không cần phải có hàm convert (UTF8)
Tôi viết sơ qua mấy code: 1> Tạo mã QR, dùng Shape
Mã:
Private Function pic_QR(ByVal QR_Value As String, ByVal Target As Range, Optional ByVal Size As Long = 150) As Shape
Dim sURL As String
On Error Resume Next
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
Set pic_QR = Target.Parent.Shapes.AddPicture(sURL, True, True, Target.Left, Target.Top, Size, Size)
End If
End Function
Sub Main()
Dim shp As Shape
Set shp = pic_QR(Range("A1").Value, ActiveCell)
End Sub
Cách dùng: Gõ gì đó vào cell A1 rồi chạy sub Main 2> Tạo mã QR, dùng Comment
Mã:
Function cmt_QR(ByVal QR_Value As String, Optional ByVal cel As Range, Optional ByVal Size As Long = 150) As String
Dim sURL As String, mRng As Range, cmt As Comment
On Error Resume Next
Application.Volatile
If cel Is Nothing Then Set cel = Application.ThisCell
cel(1, 1).Comment.Delete
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
If cel(1, 1).Comment Is Nothing Then cel(1, 1).AddComment
cel(1, 1).Comment.text vbLf
Set mRng = cel(1, 1).MergeArea
If mRng Is Nothing Then Set mRng = cel(1, 1)
Set cmt = mRng(1, 1).Comment
cmt.Visible = True
With cmt.Shape
.LockAspectRatio = msoFalse
.Placement = xlMoveAndSize
.Shadow.Visible = msoFalse
.Line.Visible = msoFalse
.AutoShapeType = msoShapeRectangle
.Left = mRng.Left: .Top = mRng.Top
.Width = mRng.Width: .Height = mRng.Height
.Fill.UserPicture sURL
End With
End If
End Function
Cách dùng: Gõ công thức =cmt_QR(A1) vào cell nào đó (với A1 là dữ liệu đầu vào)
------------------------------
Các bạn test giúp tôi: Tạo mã bằng 2 code trên rồi dùng các chương trình quét mã QR trên smartphone scan thử xem ra kết quả đúng không nha
Ở trên có một số Bạn đưa ra giải pháp sử dụng tạo QRCode nhờ vào các dịch vụ trực tuyến trên internet, song cách này có hạn chế là bắt buộc phải kết nối online với Internet mới được.
Có cách khác, không cần kết nối internet online. Các Bạn có thể dùng thư viện ZXing, là dự án mã nguồn mở, link nguồn ở đây: https://zxingnet.codeplex.com/
Với phiên bản ZXing.Net 0.16.0.0 đã có sẵn thư viện DLL của ZXing sẵn sàng cho chúng ta biên dịch file DLL này thành file TLB để chúng ta sử dụng được trong VBA.
Xin đính kèm theo đây file thư viện đã được tôi biên dịch và code VBA mẫu dựa trên hướng dẫn của ZXing.
Chú ý: Muốn sử dụng được thư viện này trong VBA, các Bạn phải:
1. Biên dịch file zxing.dll thành zxing.tlb bằng tiện ích "regasm.exe". Hoặc sử dụng file zxing.tlb tôi đã biên dich sẵn trong file đính kèm.
2. Khai báo References trong cửa sổ VBA Editor như ảnh đính kèm.
3. Code VBA tôi đã có sửa lại cho phù hợp và dễ hiểu:
Mã:
Option Explicit
Function Decode_QR_Code_From_File(FileName As String, TextVal As String)
Dim reader As IBarcodeReader
Dim res As Result
Set reader = New BarcodeReader
reader.Options.PossibleFormats.Add BarcodeFormat_QR_CODE
'Set res = reader.DecodeImageFile("D:\Barcodes\QrCodes\www.png")
Set res = reader.DecodeImageFile(FileName)
TextVal = res.Text
End Function
Function Decode_QR_Code_From_Byte_Array()
Dim reader As IBarcodeReader
Dim rawRGB(1000) As Byte
Dim res As Result
Set reader = New BarcodeReader
reader.Options.PossibleFormats.Add BarcodeFormat_QR_CODE
Rem TODO: load bitmap data to byte array rawRGB
Set res = reader.DecodeImageBytes(rawRGB, 10, 10, BitmapFormat.BitmapFormat_Gray8)
End Function
Function Encode(YourText As String, ToFileName As String)
Dim writer As IBarcodeWriter
Dim qrCodeOptions As QrCodeEncodingOptions
Dim pixelDataResult As PixelData
Set qrCodeOptions = New QrCodeEncodingOptions
Set writer = New BarcodeWriter
writer.Format = BarcodeFormat_QR_CODE
Set writer.Options = qrCodeOptions
qrCodeOptions.Height = 100
qrCodeOptions.Width = 100
qrCodeOptions.CharacterSet = "UTF-8"
qrCodeOptions.Margin = 10
qrCodeOptions.ErrorCorrection = ErrorCorrectionLevel_H
'writer.WritePngToFile "Test", "D:\interop_qrcode.png"
writer.WritePngToFile YourText, ToFileName
Set pixelDataResult = writer.Write("Test")
End Function
Function Decode_QR_Code_From_File_CreateObject(FromFileName As String)
Dim reader As IBarcodeReader
Dim res As Result
Set reader = CreateObject("ZXing.Interop.Decoding.BarcodeReader")
reader.Options.PossibleFormats.Add BarcodeFormat_QR_CODE
'Set res = reader.DecodeImageFile("D:\Barcodes\QrCodes\www.png")
Set res = reader.DecodeImageFile(FromFileName)
End Function
Ở trên có một số Bạn đưa ra giải pháp sử dụng tạo QRCode nhờ vào các dịch vụ trực tuyến trên internet, song cách này có hạn chế là bắt buộc phải kết nối online với Internet mới được.
Có cách khác, không cần kết nối internet online. Các Bạn có thể dùng thư viện ZXing, là dự án mã nguồn mở, link nguồn ở đây: https://zxingnet.codeplex.com/
Với phiên bản ZXing.Net 0.16.0.0 đã có sẵn thư viện DLL của ZXing sẵn sàng cho chúng ta biên dịch file DLL này thành file TLB để chúng ta sử dụng được trong VBA.
Xin đính kèm theo đây file thư viện đã được tôi biên dịch và code VBA mẫu dựa trên hướng dẫn của ZXing.
Chú ý: Muốn sử dụng được thư viện này trong VBA, các Bạn phải:
1. Biên dịch file zxing.dll thành zxing.tlb bằng tiện ích "regasm.exe". Hoặc sử dụng file zxing.tlb tôi đã biên dich sẵn trong file đính kèm.
2. Khai báo References trong cửa sổ VBA Editor như ảnh đính kèm.
3. Code VBA tôi đã có sửa lại cho phù hợp và dễ hiểu:
Mã:
Option Explicit
Function Decode_QR_Code_From_File(FileName As String, TextVal As String)
Dim reader As IBarcodeReader
Dim res As Result
Set reader = New BarcodeReader
reader.Options.PossibleFormats.Add BarcodeFormat_QR_CODE
'Set res = reader.DecodeImageFile("D:\Barcodes\QrCodes\www.png")
Set res = reader.DecodeImageFile(FileName)
TextVal = res.Text
End Function
Function Decode_QR_Code_From_Byte_Array()
Dim reader As IBarcodeReader
Dim rawRGB(1000) As Byte
Dim res As Result
Set reader = New BarcodeReader
reader.Options.PossibleFormats.Add BarcodeFormat_QR_CODE
Rem TODO: load bitmap data to byte array rawRGB
Set res = reader.DecodeImageBytes(rawRGB, 10, 10, BitmapFormat.BitmapFormat_Gray8)
End Function
Function Encode(YourText As String, ToFileName As String)
Dim writer As IBarcodeWriter
Dim qrCodeOptions As QrCodeEncodingOptions
Dim pixelDataResult As PixelData
Set qrCodeOptions = New QrCodeEncodingOptions
Set writer = New BarcodeWriter
writer.Format = BarcodeFormat_QR_CODE
Set writer.Options = qrCodeOptions
qrCodeOptions.Height = 100
qrCodeOptions.Width = 100
qrCodeOptions.CharacterSet = "UTF-8"
qrCodeOptions.Margin = 10
qrCodeOptions.ErrorCorrection = ErrorCorrectionLevel_H
'writer.WritePngToFile "Test", "D:\interop_qrcode.png"
writer.WritePngToFile YourText, ToFileName
Set pixelDataResult = writer.Write("Test")
End Function
Function Decode_QR_Code_From_File_CreateObject(FromFileName As String)
Dim reader As IBarcodeReader
Dim res As Result
Set reader = CreateObject("ZXing.Interop.Decoding.BarcodeReader")
reader.Options.PossibleFormats.Add BarcodeFormat_QR_CODE
'Set res = reader.DecodeImageFile("D:\Barcodes\QrCodes\www.png")
Set res = reader.DecodeImageFile(FromFileName)
End Function
Đi theo hướng này:
Để sử dụng Barcode thì thì sử dụng Font Barcode (chỉ có 3KB), sau đó dùng VBA (code cũng gọn hơn) sau đó chuyển đổi giá trị của Cell sang Barcode thì sẽ gọn gàng và dễ sử dụng.
Chào Bạn,
Bạn cần chú ý trong bài viết tôi đã hướng dẫn:
1. Bạn không thể khai báo References trực tiếp đến các file dll, mà phải khai báo đến file TLB. Xin xem lại ảnh tôi có đính kèm, ở khung bên dưới ảnh có ghi rõ đường dẫn đến thư viện là file zxing.tlb
2. Trước khi sử dụng file zxing.tlb, Bạn cần phải cho đăng ký file này với Windows bằng tiện ích "regasm.exe" của Windows, không thể dùng tiện ích Regsvr32 được. Bạn có thể tham khảo cách sử dụng "regasm.exe" và cách đăng ký 1 thư viện TLB trong Windows bằng cách dùng Google với từ khóa tương ứng.
3. Bạn cũng có thể tự mình biên dịch file "zxing.interop.dll" thành zxing.tlb và đăng ký với Windows luôn một lần bằng cách sử dụng tiện ích "regasm.exe".
Bạn không thể biên dịch file zxing.dll thành zxing.tlb được vì file dll này chưa được khai báo để sẵn sàng biên dịch thành TLB. Tác giả của ZXing đã giúp chúng ta khai báo điều này trong file "zxing.interop.dll".
Bạn có thể tham khảo hướng dẫn của Microsoft về vấn đề này ở link sau: https://msdn.microsoft.com/en-us/li...459594)(TnL5HPStwNw-XHxSQflU1SyCsiY19ui76A)()
xem ta nhận được cái gì nha
Đây chính là chìa khóa để tạo mã QR (dùng dịch vụ của google)
-----------------------------------------------------------
Tiến hành phân tích:
- Giả định rằng ta có chuỗi: Nguyen Anh Tuan
- Bằng cách nào đó ta biến đổi chuỗi trên thành:
(tạm gọi đây là biến sURL nha)
Trong đó: chỗ không tô màu là const, chỗ màu xanh có thể tùy chỉnh hoặc để mặc định (nó là size), chỗ màu đỏ chính là chuỗi đầu vào (nhớ rằng khoảng trắng phải được biến đổi thành dấu +)
- Tiếp theo thử gõ vào cửa sổ Immediate dòng code:
enter phát xem nó ra cái gì
---------------------------------
Vậy, việc chính của bạn chỉ là: làm cách nào để biến đổi chuỗi đầu vào thành sURL rồi ráp vào phương thức AddPicture là được rồi
Lưu ý:
- Chỗ màu đỏ không áp dụng cho tiếng Việt có dấu (nếu muốn thì phải cần 1 hàm convert)
- Đương nhiên phải kết nối internet mới dùng được
-------------------------------
Em tạo được mã QR theo cách Tạo mã QR, dùng Comment. Giờ em muốn link mã QR sang bên 1 trang Word để trộn thư thì làm như thế nào các bác?
Các bác hỗ trợ em với! Cảm ơn các bác.
Thấy cái mã QR cũng hay hay (ai dùng Smartphone đều biết). Tuy nhiên tôi đang thắc mắc: Nếu dùng code VBA tạo ra mã QR trên Excel thì liệu ta có thể ứng dụng nó vào việc gì?
Hỏi thế là bởi: Phải có ứng dụng thực tế và hữu ích thì mới có hứng trong việc viết code
Không biết có ai có nhu cầu này hoặc có ý tưởng hay về ứng dụng liên quan đến QR code không nhỉ?
Chào bác @ndu96081631 hiện tại bên e có nhu cầu rất lớn về qr code (sử dụng qrcode để quản trị sản xuất)
Đề bài : tạo và quản lý mã qr code chứa đựng tất cả thông tin từng sản phẩm (thông tin cứng + link file đính kèm)
Em có tham khảo 1 số qr code trên mạng hoặc phần mềm tạo qr code thì chưa có (một số trang tạo qrcode online có file đính kèm nhưng chỉ ở 1 dạng pdf).
Nếu bác có hứng thú với vấn đề này em xin bàn luận tiếp a (Form, kiểu cách quản lý, ...)
Thấy cái mã QR cũng hay hay (ai dùng Smartphone đều biết). Tuy nhiên tôi đang thắc mắc: Nếu dùng code VBA tạo ra mã QR trên Excel thì liệu ta có thể ứng dụng nó vào việc gì?
Hỏi thế là bởi: Phải có ứng dụng thực tế và hữu ích thì mới có hứng trong việc viết code
Không biết có ai có nhu cầu này hoặc có ý tưởng hay về ứng dụng liên quan đến QR code không nhỉ?
Em xin nói tiếp : Nhờ bác @ndu96081631 xem mẫu form như dưới
Cái này e lấy trên GPE, và e muốn xây dựng thông tin 2 chiều, chiều thuận là tạo ra code chứa các nội dung ở sheet "ND", chiều ngược là quét mã qr code sẽ cho ta được thông tin thống kê trên sheet "Cheat" (không chỉ hiển thị trên smartphone)
Trong phần tạo mã qr : những thông tin file đính kèm (chủ yếu 4 định dạng word, excel, pdf, powerpoint) có thể mở trực tiếp trên điện thoại thông minh (quét qua zalo hoặc facebook) và khi quét ngược lên excel cũng mở được file đính kèm???
Ủa! Thì cứ nối bình thường mà bạn!
Ví dụ:
- Ta có A1 có giá trị Cộng hòa xã hội chủ nghĩa Việt Nam
- Ta dùng công thức =cmt_QR(A1) sẽ ra được mã QR nào đó
Giờ ta lại có các giá trị nằm trên nhiều cells:
- A5 có giá trị Cộng hòa
- A6 có giá trị xã hội
- A7 có giá trị chủ nghĩa
- A8 có giá trị Việt Nam
- Ta dùng công thức =cmt_QR(A5&" "&A6&" "&A7&" "&A8) cũng sẽ cho mã QR tương đương thôi
Đã có ai nghiên cứu vụ này chưa nhỉ (một mình mình làm thì cảm giác không chắc ăn lắm)
--------------
Phát hiện ra mấy chuyện:
- Hình như là chẳng cần đổi rổng thành "+" gì ráo cũng được
- Hình như là tiếng Việt cũng chơi được luôn là không cần phải có hàm convert (UTF8)
Tôi viết sơ qua mấy code: 1> Tạo mã QR, dùng Shape
Mã:
Private Function pic_QR(ByVal QR_Value As String, ByVal Target As Range, Optional ByVal Size As Long = 150) As Shape
Dim sURL As String
On Error Resume Next
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
Set pic_QR = Target.Parent.Shapes.AddPicture(sURL, True, True, Target.Left, Target.Top, Size, Size)
End If
End Function
Sub Main()
Dim shp As Shape
Set shp = pic_QR(Range("A1").Value, ActiveCell)
End Sub
Cách dùng: Gõ gì đó vào cell A1 rồi chạy sub Main 2> Tạo mã QR, dùng Comment
Mã:
Function cmt_QR(ByVal QR_Value As String, Optional ByVal cel As Range, Optional ByVal Size As Long = 150) As String
Dim sURL As String, mRng As Range, cmt As Comment
On Error Resume Next
Application.Volatile
If cel Is Nothing Then Set cel = Application.ThisCell
cel(1, 1).Comment.Delete
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
If cel(1, 1).Comment Is Nothing Then cel(1, 1).AddComment
cel(1, 1).Comment.text vbLf
Set mRng = cel(1, 1).MergeArea
If mRng Is Nothing Then Set mRng = cel(1, 1)
Set cmt = mRng(1, 1).Comment
cmt.Visible = True
With cmt.Shape
.LockAspectRatio = msoFalse
.Placement = xlMoveAndSize
.Shadow.Visible = msoFalse
.Line.Visible = msoFalse
.AutoShapeType = msoShapeRectangle
.Left = mRng.Left: .Top = mRng.Top
.Width = mRng.Width: .Height = mRng.Height
.Fill.UserPicture sURL
End With
End If
End Function
Cách dùng: Gõ công thức =cmt_QR(A1) vào cell nào đó (với A1 là dữ liệu đầu vào)
------------------------------
Các bạn test giúp tôi: Tạo mã bằng 2 code trên rồi dùng các chương trình quét mã QR trên smartphone scan thử xem ra kết quả đúng không nha
Đối với cách 1:
Thầy cho em hỏi để giảm bớt khoảng trắng xung quanh phần QR code màu đen thì làm thế nào, vì em đặt vào ô excell nó bao trùm phần border. Em phải vào format và crop phần trắng đi.
Đã có ai nghiên cứu vụ này chưa nhỉ (một mình mình làm thì cảm giác không chắc ăn lắm)
--------------
Phát hiện ra mấy chuyện:
- Hình như là chẳng cần đổi rổng thành "+" gì ráo cũng được
- Hình như là tiếng Việt cũng chơi được luôn là không cần phải có hàm convert (UTF8)
Tôi viết sơ qua mấy code: 1> Tạo mã QR, dùng Shape
Mã:
Private Function pic_QR(ByVal QR_Value As String, ByVal Target As Range, Optional ByVal Size As Long = 150) As Shape
Dim sURL As String
On Error Resume Next
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
Set pic_QR = Target.Parent.Shapes.AddPicture(sURL, True, True, Target.Left, Target.Top, Size, Size)
End If
End Function
Sub Main()
Dim shp As Shape
Set shp = pic_QR(Range("A1").Value, ActiveCell)
End Sub
Cách dùng: Gõ gì đó vào cell A1 rồi chạy sub Main 2> Tạo mã QR, dùng Comment
Mã:
Function cmt_QR(ByVal QR_Value As String, Optional ByVal cel As Range, Optional ByVal Size As Long = 150) As String
Dim sURL As String, mRng As Range, cmt As Comment
On Error Resume Next
Application.Volatile
If cel Is Nothing Then Set cel = Application.ThisCell
cel(1, 1).Comment.Delete
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
If cel(1, 1).Comment Is Nothing Then cel(1, 1).AddComment
cel(1, 1).Comment.text vbLf
Set mRng = cel(1, 1).MergeArea
If mRng Is Nothing Then Set mRng = cel(1, 1)
Set cmt = mRng(1, 1).Comment
cmt.Visible = True
With cmt.Shape
.LockAspectRatio = msoFalse
.Placement = xlMoveAndSize
.Shadow.Visible = msoFalse
.Line.Visible = msoFalse
.AutoShapeType = msoShapeRectangle
.Left = mRng.Left: .Top = mRng.Top
.Width = mRng.Width: .Height = mRng.Height
.Fill.UserPicture sURL
End With
End If
End Function
Cách dùng: Gõ công thức =cmt_QR(A1) vào cell nào đó (với A1 là dữ liệu đầu vào)
------------------------------
Các bạn test giúp tôi: Tạo mã bằng 2 code trên rồi dùng các chương trình quét mã QR trên smartphone scan thử xem ra kết quả đúng không nha
đã text, và cho kết quả chính xác
nhưng nếu mình liên kết nhiều cell lại, nếu tức là nội dung nằm trên nhiêu cell thì liên kết nó lại như thế nào vậy anh NDU
với lại tốc upload, download có phụ thuộc vào độ dài của nội dung không anh?
Vấn đề là code dựa trên ý tưởng trên đã ra kết quả chính xác chưa?
Chỉ cần cầm cái điện thoại lên, thử nghiệm quét 1 phát rồi báo kết quả cho mình biết, vậy mà chẳng thấy ai giúp được nhỉ?
Sư phụ ơi, chính xác ạ! Em chân thành cảm ơn sư phụ vì đây là cái em đang cần để xác minh hợp đồng và thông tin hợp đồng có phải do bên công ty em phát hành ra hay không! Quá đã sư phụ ơi.
Hic, ý tưởng này rất hay, nhưng do mạng cơ quan là mạng lan nên ko áp dụng được, e để file addin này vào thì máy bị treo (chắc do nó cố gắng connect với google)
Đã có ai nghiên cứu vụ này chưa nhỉ (một mình mình làm thì cảm giác không chắc ăn lắm)
--------------
Phát hiện ra mấy chuyện:
- Hình như là chẳng cần đổi rổng thành "+" gì ráo cũng được
- Hình như là tiếng Việt cũng chơi được luôn là không cần phải có hàm convert (UTF8)
Tôi viết sơ qua mấy code: 1> Tạo mã QR, dùng Shape
Mã:
Private Function pic_QR(ByVal QR_Value As String, ByVal Target As Range, Optional ByVal Size As Long = 150) As Shape
Dim sURL As String
On Error Resume Next
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
Set pic_QR = Target.Parent.Shapes.AddPicture(sURL, True, True, Target.Left, Target.Top, Size, Size)
End If
End Function
Sub Main()
Dim shp As Shape
Set shp = pic_QR(Range("A1").Value, ActiveCell)
End Sub
Cách dùng: Gõ gì đó vào cell A1 rồi chạy sub Main 2> Tạo mã QR, dùng Comment
Mã:
Function cmt_QR(ByVal QR_Value As String, Optional ByVal cel As Range, Optional ByVal Size As Long = 150) As String
Dim sURL As String, mRng As Range, cmt As Comment
On Error Resume Next
Application.Volatile
If cel Is Nothing Then Set cel = Application.ThisCell
cel(1, 1).Comment.Delete
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
If cel(1, 1).Comment Is Nothing Then cel(1, 1).AddComment
cel(1, 1).Comment.text vbLf
Set mRng = cel(1, 1).MergeArea
If mRng Is Nothing Then Set mRng = cel(1, 1)
Set cmt = mRng(1, 1).Comment
cmt.Visible = True
With cmt.Shape
.LockAspectRatio = msoFalse
.Placement = xlMoveAndSize
.Shadow.Visible = msoFalse
.Line.Visible = msoFalse
.AutoShapeType = msoShapeRectangle
.Left = mRng.Left: .Top = mRng.Top
.Width = mRng.Width: .Height = mRng.Height
.Fill.UserPicture sURL
End With
End If
End Function
Cách dùng: Gõ công thức =cmt_QR(A1) vào cell nào đó (với A1 là dữ liệu đầu vào)
------------------------------
Các bạn test giúp tôi: Tạo mã bằng 2 code trên rồi dùng các chương trình quét mã QR trên smartphone scan thử xem ra kết quả đúng không nha
Đã có ai nghiên cứu vụ này chưa nhỉ (một mình mình làm thì cảm giác không chắc ăn lắm)
--------------
Phát hiện ra mấy chuyện:
- Hình như là chẳng cần đổi rổng thành "+" gì ráo cũng được
- Hình như là tiếng Việt cũng chơi được luôn là không cần phải có hàm convert (UTF8)
Tôi viết sơ qua mấy code: 1> Tạo mã QR, dùng Shape
Mã:
Private Function pic_QR(ByVal QR_Value As String, ByVal Target As Range, Optional ByVal Size As Long = 150) As Shape
Dim sURL As String
On Error Resume Next
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
Set pic_QR = Target.Parent.Shapes.AddPicture(sURL, True, True, Target.Left, Target.Top, Size, Size)
End If
End Function
Sub Main()
Dim shp As Shape
Set shp = pic_QR(Range("A1").Value, ActiveCell)
End Sub
Cách dùng: Gõ gì đó vào cell A1 rồi chạy sub Main 2> Tạo mã QR, dùng Comment
Mã:
Function cmt_QR(ByVal QR_Value As String, Optional ByVal cel As Range, Optional ByVal Size As Long = 150) As String
Dim sURL As String, mRng As Range, cmt As Comment
On Error Resume Next
Application.Volatile
If cel Is Nothing Then Set cel = Application.ThisCell
cel(1, 1).Comment.Delete
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
If cel(1, 1).Comment Is Nothing Then cel(1, 1).AddComment
cel(1, 1).Comment.text vbLf
Set mRng = cel(1, 1).MergeArea
If mRng Is Nothing Then Set mRng = cel(1, 1)
Set cmt = mRng(1, 1).Comment
cmt.Visible = True
With cmt.Shape
.LockAspectRatio = msoFalse
.Placement = xlMoveAndSize
.Shadow.Visible = msoFalse
.Line.Visible = msoFalse
.AutoShapeType = msoShapeRectangle
.Left = mRng.Left: .Top = mRng.Top
.Width = mRng.Width: .Height = mRng.Height
.Fill.UserPicture sURL
End With
End If
End Function
Cách dùng: Gõ công thức =cmt_QR(A1) vào cell nào đó (với A1 là dữ liệu đầu vào)
------------------------------
Các bạn test giúp tôi: Tạo mã bằng 2 code trên rồi dùng các chương trình quét mã QR trên smartphone scan thử xem ra kết quả đúng không nha
Đã có ai nghiên cứu vụ này chưa nhỉ (một mình mình làm thì cảm giác không chắc ăn lắm)
--------------
Phát hiện ra mấy chuyện:
- Hình như là chẳng cần đổi rổng thành "+" gì ráo cũng được
- Hình như là tiếng Việt cũng chơi được luôn là không cần phải có hàm convert (UTF8)
Tôi viết sơ qua mấy code: 1> Tạo mã QR, dùng Shape
Mã:
Private Function pic_QR(ByVal QR_Value As String, ByVal Target As Range, Optional ByVal Size As Long = 150) As Shape
Dim sURL As String
On Error Resume Next
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
Set pic_QR = Target.Parent.Shapes.AddPicture(sURL, True, True, Target.Left, Target.Top, Size, Size)
End If
End Function
Sub Main()
Dim shp As Shape
Set shp = pic_QR(Range("A1").Value, ActiveCell)
End Sub
Cách dùng: Gõ gì đó vào cell A1 rồi chạy sub Main 2> Tạo mã QR, dùng Comment
Mã:
Function cmt_QR(ByVal QR_Value As String, Optional ByVal cel As Range, Optional ByVal Size As Long = 150) As String
Dim sURL As String, mRng As Range, cmt As Comment
On Error Resume Next
Application.Volatile
If cel Is Nothing Then Set cel = Application.ThisCell
cel(1, 1).Comment.Delete
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
If cel(1, 1).Comment Is Nothing Then cel(1, 1).AddComment
cel(1, 1).Comment.text vbLf
Set mRng = cel(1, 1).MergeArea
If mRng Is Nothing Then Set mRng = cel(1, 1)
Set cmt = mRng(1, 1).Comment
cmt.Visible = True
With cmt.Shape
.LockAspectRatio = msoFalse
.Placement = xlMoveAndSize
.Shadow.Visible = msoFalse
.Line.Visible = msoFalse
.AutoShapeType = msoShapeRectangle
.Left = mRng.Left: .Top = mRng.Top
.Width = mRng.Width: .Height = mRng.Height
.Fill.UserPicture sURL
End With
End If
End Function
Cách dùng: Gõ công thức =cmt_QR(A1) vào cell nào đó (với A1 là dữ liệu đầu vào)
------------------------------
Các bạn test giúp tôi: Tạo mã bằng 2 code trên rồi dùng các chương trình quét mã QR trên smartphone scan thử xem ra kết quả đúng không nha
Em chào Thầy,
Với code đầu tiên em muốn chỏ QR code về 1 cell cố định mà không phải là active cell thì làm như thế nào ạ (em chưa biết về VBA)
E cám ơn ạ !
em có 1 kho hàng nhỏ khoảng gần 100 mặt hàng phụ tùng cơ khí. Có cách nào kết hợp QR code và thiết bị quét là smartphone, dữ liệu máy tính để quản lý kho hàng (Xuất - Nhập -Tồn - Kiểm kê) không Bác!
Xin Bác chỉ giáo!
Chào thầy NDU96081631, em thấy subject này rất thiết thực cho công việc.
Thầy có thể bớt chút thời gian nghiên cứu và chỉ giáo được ko ạ.
Em rất muốn sử dụng QR Code quản lý file xuất nhập cho kho nhà em. quét bằng Smartphone và dữ liệu cập nhật vào máy tính theo file excel cập nhật vào bảng data.
Ủa! Thì cứ nối bình thường mà bạn!
Ví dụ:
- Ta có A1 có giá trị Cộng hòa xã hội chủ nghĩa Việt Nam
- Ta dùng công thức =cmt_QR(A1) sẽ ra được mã QR nào đó
Giờ ta lại có các giá trị nằm trên nhiều cells:
- A5 có giá trị Cộng hòa
- A6 có giá trị xã hội
- A7 có giá trị chủ nghĩa
- A8 có giá trị Việt Nam
- Ta dùng công thức =cmt_QR(A5&" "&A6&" "&A7&" "&A8) cũng sẽ cho mã QR tương đương thôi
Thưa bác, em không biết về VBA, bác có thể viết thêm code để dùng được trong trường hợp này không ạ.
Ví dụ nếu em có A1 có giá trị = CTY TNHH .... , B1 có giá trị = SA-650G.
Dùng công thức (ví dụ viết thế này) =cmt_QR(A1,B1), thì lúc này sẽ tạo mã QR cho text trong ô A1, còn text trong ô B1 sẽ thành dòng chữ nằm dưới mã QR (như hình đính kèm). Cám ơn
Chào thầy NDU96081631, em thấy subject này rất thiết thực cho công việc.
Thầy có thể bớt chút thời gian nghiên cứu và chỉ giáo được ko ạ.
Em rất muốn sử dụng QR Code quản lý file xuất nhập cho kho nhà em. quét bằng Smartphone và dữ liệu cập nhật vào máy tính theo file excel cập nhật vào bảng data.
Mình cũng muốn áp dụng cái này: Hàng đóng túi dán tem "trên tem có qr code", khi nhập kho sẽ quét qr code bằng máy quét và cập nhật trên excel. Bác làm chưa chia sẻ đi
Ở trên có một số Bạn đưa ra giải pháp sử dụng tạo QRCode nhờ vào các dịch vụ trực tuyến trên internet, song cách này có hạn chế là bắt buộc phải kết nối online với Internet mới được.
Có cách khác, không cần kết nối internet online. Các Bạn có thể dùng thư viện ZXing, là dự án mã nguồn mở, link nguồn ở đây: https://zxingnet.codeplex.com/
Với phiên bản ZXing.Net 0.16.0.0 đã có sẵn thư viện DLL của ZXing sẵn sàng cho chúng ta biên dịch file DLL này thành file TLB để chúng ta sử dụng được trong VBA.
Xin đính kèm theo đây file thư viện đã được tôi biên dịch và code VBA mẫu dựa trên hướng dẫn của ZXing.
Chú ý: Muốn sử dụng được thư viện này trong VBA, các Bạn phải:
1. Biên dịch file zxing.dll thành zxing.tlb bằng tiện ích "regasm.exe". Hoặc sử dụng file zxing.tlb tôi đã biên dich sẵn trong file đính kèm.
2. Khai báo References trong cửa sổ VBA Editor như ảnh đính kèm.
3. Code VBA tôi đã có sửa lại cho phù hợp và dễ hiểu:
Mã:
Option Explicit
Function Decode_QR_Code_From_File(FileName As String, TextVal As String)
Dim reader As IBarcodeReader
Dim res As Result
Set reader = New BarcodeReader
reader.Options.PossibleFormats.Add BarcodeFormat_QR_CODE
'Set res = reader.DecodeImageFile("D:\Barcodes\QrCodes\www.png")
Set res = reader.DecodeImageFile(FileName)
TextVal = res.Text
End Function
Function Decode_QR_Code_From_Byte_Array()
Dim reader As IBarcodeReader
Dim rawRGB(1000) As Byte
Dim res As Result
Set reader = New BarcodeReader
reader.Options.PossibleFormats.Add BarcodeFormat_QR_CODE
Rem TODO: load bitmap data to byte array rawRGB
Set res = reader.DecodeImageBytes(rawRGB, 10, 10, BitmapFormat.BitmapFormat_Gray8)
End Function
Function Encode(YourText As String, ToFileName As String)
Dim writer As IBarcodeWriter
Dim qrCodeOptions As QrCodeEncodingOptions
Dim pixelDataResult As PixelData
Set qrCodeOptions = New QrCodeEncodingOptions
Set writer = New BarcodeWriter
writer.Format = BarcodeFormat_QR_CODE
Set writer.Options = qrCodeOptions
qrCodeOptions.Height = 100
qrCodeOptions.Width = 100
qrCodeOptions.CharacterSet = "UTF-8"
qrCodeOptions.Margin = 10
qrCodeOptions.ErrorCorrection = ErrorCorrectionLevel_H
'writer.WritePngToFile "Test", "D:\interop_qrcode.png"
writer.WritePngToFile YourText, ToFileName
Set pixelDataResult = writer.Write("Test")
End Function
Function Decode_QR_Code_From_File_CreateObject(FromFileName As String)
Dim reader As IBarcodeReader
Dim res As Result
Set reader = CreateObject("ZXing.Interop.Decoding.BarcodeReader")
reader.Options.PossibleFormats.Add BarcodeFormat_QR_CODE
'Set res = reader.DecodeImageFile("D:\Barcodes\QrCodes\www.png")
Set res = reader.DecodeImageFile(FromFileName)
End Function
Chào các bác,
1) QR Code.
Em đang dùng Google Sheet để tạo thấy dùng ok.
2) Gửi nội dung lên máy tính.
Em đang dùng Add in Scan it to Office, app này có trên điện thoại nên dùng khá thuận tiện chỉ có điều lâu lâu có quảng cáo thôi!!
Mã QR chỉ là công cụ, còn bạn muốn ứng dụng nó thế nào thì tùy bạn thôi. Ví dụ: Bạn tạo ra mã QR gồm Tên máy, ngày mua, kích thước, .... rồi chuyển qua mã QR đến khi di dời hay kiểm kê tài sản cuối nắm cứ quét mã là có thông tin.
Tôi thực sự chưa biết code của bạn hoạt động như thế nào để cho ra kết quả tốt như thế?
Nhưng giải pháp của bạn thực sự là rất gọn gàng, hiệu quả, đủ dùng cho cái tôi đang cần.
Chia sẻ thêm:
Bạn biết đấy, hiện phương thức thanh toán QR code rất tiện dụng, nó đang dần trở nên phổ biến và thông dụng. (Thấy bạn cũng đã MoMo)
Đối với các trang thương mại điện tử thì khỏi phải nói, họ có sẵn các giải pháp cho việc này.
Nhưng với người dùng cá nhân như các tiểu thương thì cũng còn ít nhiều hạn chế cần khắc phục.
VD tôi đang cần tạo ra các mã QR thanh toán có điền sẵn số tiền, nội dung thanh toán. Các phương thức thanh toán có hỗ trợ việc này, nhưng chỉ 1 cái 1, hàng loạt thì chưa. Vì thế tôi đang tự làm. Nếu bạn, các thành viên khác quan tâm, sẽ share tiếp
Quay lại giải pháp của bạn, hiện có 1 tồn tại nhỏ là chưa mã hóa được Tiếng Việt (có dấu) - nhưng chắc sẽ có giải pháp thôi.
Đã có ai nghiên cứu vụ này chưa nhỉ (một mình mình làm thì cảm giác không chắc ăn lắm)
--------------
Phát hiện ra mấy chuyện:
- Hình như là chẳng cần đổi rổng thành "+" gì ráo cũng được
- Hình như là tiếng Việt cũng chơi được luôn là không cần phải có hàm convert (UTF8)
Tôi viết sơ qua mấy code: 1> Tạo mã QR, dùng Shape
Mã:
Private Function pic_QR(ByVal QR_Value As String, ByVal Target As Range, Optional ByVal Size As Long = 150) As Shape
Dim sURL As String
On Error Resume Next
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
Set pic_QR = Target.Parent.Shapes.AddPicture(sURL, True, True, Target.Left, Target.Top, Size, Size)
End If
End Function
Sub Main()
Dim shp As Shape
Set shp = pic_QR(Range("A1").Value, ActiveCell)
End Sub
Cách dùng: Gõ gì đó vào cell A1 rồi chạy sub Main 2> Tạo mã QR, dùng Comment
Mã:
Function cmt_QR(ByVal QR_Value As String, Optional ByVal cel As Range, Optional ByVal Size As Long = 150) As String
Dim sURL As String, mRng As Range, cmt As Comment
On Error Resume Next
Application.Volatile
If cel Is Nothing Then Set cel = Application.ThisCell
cel(1, 1).Comment.Delete
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
If cel(1, 1).Comment Is Nothing Then cel(1, 1).AddComment
cel(1, 1).Comment.text vbLf
Set mRng = cel(1, 1).MergeArea
If mRng Is Nothing Then Set mRng = cel(1, 1)
Set cmt = mRng(1, 1).Comment
cmt.Visible = True
With cmt.Shape
.LockAspectRatio = msoFalse
.Placement = xlMoveAndSize
.Shadow.Visible = msoFalse
.Line.Visible = msoFalse
.AutoShapeType = msoShapeRectangle
.Left = mRng.Left: .Top = mRng.Top
.Width = mRng.Width: .Height = mRng.Height
.Fill.UserPicture sURL
End With
End If
End Function
Cách dùng: Gõ công thức =cmt_QR(A1) vào cell nào đó (với A1 là dữ liệu đầu vào)
------------------------------
Các bạn test giúp tôi: Tạo mã bằng 2 code trên rồi dùng các chương trình quét mã QR trên smartphone scan thử xem ra kết quả đúng không nha
Em đang dùng code này được 1 thời gian. Nhưng nay không hiểu do đường link hay do vẫn đề gì đó mà không tạo được RQ code nữa.
Nhờ các thầy chỉ dạy với ạ
Đã có ai nghiên cứu vụ này chưa nhỉ (một mình mình làm thì cảm giác không chắc ăn lắm)
--------------
Phát hiện ra mấy chuyện:
- Hình như là chẳng cần đổi rổng thành "+" gì ráo cũng được
- Hình như là tiếng Việt cũng chơi được luôn là không cần phải có hàm convert (UTF8)
Tôi viết sơ qua mấy code: 1> Tạo mã QR, dùng Shape
Mã:
Private Function pic_QR(ByVal QR_Value As String, ByVal Target As Range, Optional ByVal Size As Long = 150) As Shape
Dim sURL As String
On Error Resume Next
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
Set pic_QR = Target.Parent.Shapes.AddPicture(sURL, True, True, Target.Left, Target.Top, Size, Size)
End If
End Function
Sub Main()
Dim shp As Shape
Set shp = pic_QR(Range("A1").Value, ActiveCell)
End Sub
Cách dùng: Gõ gì đó vào cell A1 rồi chạy sub Main 2> Tạo mã QR, dùng Comment
Mã:
Function cmt_QR(ByVal QR_Value As String, Optional ByVal cel As Range, Optional ByVal Size As Long = 150) As String
Dim sURL As String, mRng As Range, cmt As Comment
On Error Resume Next
Application.Volatile
If cel Is Nothing Then Set cel = Application.ThisCell
cel(1, 1).Comment.Delete
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
If cel(1, 1).Comment Is Nothing Then cel(1, 1).AddComment
cel(1, 1).Comment.text vbLf
Set mRng = cel(1, 1).MergeArea
If mRng Is Nothing Then Set mRng = cel(1, 1)
Set cmt = mRng(1, 1).Comment
cmt.Visible = True
With cmt.Shape
.LockAspectRatio = msoFalse
.Placement = xlMoveAndSize
.Shadow.Visible = msoFalse
.Line.Visible = msoFalse
.AutoShapeType = msoShapeRectangle
.Left = mRng.Left: .Top = mRng.Top
.Width = mRng.Width: .Height = mRng.Height
.Fill.UserPicture sURL
End With
End If
End Function
Cách dùng: Gõ công thức =cmt_QR(A1) vào cell nào đó (với A1 là dữ liệu đầu vào)
------------------------------
Các bạn test giúp tôi: Tạo mã bằng 2 code trên rồi dùng các chương trình quét mã QR trên smartphone scan thử xem ra kết quả đúng không nha
Em đang dùng code này được 1 thời gian. Nhưng nay không hiểu do đường link hay do vẫn đề gì đó mà không tạo được RQ code nữa.
Nhờ các thầy chỉ dạy với ạ
Đã có ai nghiên cứu vụ này chưa nhỉ (một mình mình làm thì cảm giác không chắc ăn lắm)
--------------
Phát hiện ra mấy chuyện:
- Hình như là chẳng cần đổi rổng thành "+" gì ráo cũng được
- Hình như là tiếng Việt cũng chơi được luôn là không cần phải có hàm convert (UTF8)
Tôi viết sơ qua mấy code: 1> Tạo mã QR, dùng Shape
Mã:
Private Function pic_QR(ByVal QR_Value As String, ByVal Target As Range, Optional ByVal Size As Long = 150) As Shape
Dim sURL As String
On Error Resume Next
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
Set pic_QR = Target.Parent.Shapes.AddPicture(sURL, True, True, Target.Left, Target.Top, Size, Size)
End If
End Function
Sub Main()
Dim shp As Shape
Set shp = pic_QR(Range("A1").Value, ActiveCell)
End Sub
Cách dùng: Gõ gì đó vào cell A1 rồi chạy sub Main 2> Tạo mã QR, dùng Comment
Mã:
Function cmt_QR(ByVal QR_Value As String, Optional ByVal cel As Range, Optional ByVal Size As Long = 150) As String
Dim sURL As String, mRng As Range, cmt As Comment
On Error Resume Next
Application.Volatile
If cel Is Nothing Then Set cel = Application.ThisCell
cel(1, 1).Comment.Delete
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
If cel(1, 1).Comment Is Nothing Then cel(1, 1).AddComment
cel(1, 1).Comment.text vbLf
Set mRng = cel(1, 1).MergeArea
If mRng Is Nothing Then Set mRng = cel(1, 1)
Set cmt = mRng(1, 1).Comment
cmt.Visible = True
With cmt.Shape
.LockAspectRatio = msoFalse
.Placement = xlMoveAndSize
.Shadow.Visible = msoFalse
.Line.Visible = msoFalse
.AutoShapeType = msoShapeRectangle
.Left = mRng.Left: .Top = mRng.Top
.Width = mRng.Width: .Height = mRng.Height
.Fill.UserPicture sURL
End With
End If
End Function
Cách dùng: Gõ công thức =cmt_QR(A1) vào cell nào đó (với A1 là dữ liệu đầu vào)
------------------------------
Các bạn test giúp tôi: Tạo mã bằng 2 code trên rồi dùng các chương trình quét mã QR trên smartphone scan thử xem ra kết quả đúng không nha
Em đang dùng code này được 1 thời gian. Nhưng nay không hiểu do đường link hay do vẫn đề gì đó mà không tạo được RQ code nữa.
Nhờ các thầy chỉ dạy với ạ
Đã có ai nghiên cứu vụ này chưa nhỉ (một mình mình làm thì cảm giác không chắc ăn lắm)
--------------
Phát hiện ra mấy chuyện:
- Hình như là chẳng cần đổi rổng thành "+" gì ráo cũng được
- Hình như là tiếng Việt cũng chơi được luôn là không cần phải có hàm convert (UTF8)
Tôi viết sơ qua mấy code: 1> Tạo mã QR, dùng Shape
Mã:
Private Function pic_QR(ByVal QR_Value As String, ByVal Target As Range, Optional ByVal Size As Long = 150) As Shape
Dim sURL As String
On Error Resume Next
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
Set pic_QR = Target.Parent.Shapes.AddPicture(sURL, True, True, Target.Left, Target.Top, Size, Size)
End If
End Function
Sub Main()
Dim shp As Shape
Set shp = pic_QR(Range("A1").Value, ActiveCell)
End Sub
Cách dùng: Gõ gì đó vào cell A1 rồi chạy sub Main 2> Tạo mã QR, dùng Comment
Mã:
Function cmt_QR(ByVal QR_Value As String, Optional ByVal cel As Range, Optional ByVal Size As Long = 150) As String
Dim sURL As String, mRng As Range, cmt As Comment
On Error Resume Next
Application.Volatile
If cel Is Nothing Then Set cel = Application.ThisCell
cel(1, 1).Comment.Delete
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
If cel(1, 1).Comment Is Nothing Then cel(1, 1).AddComment
cel(1, 1).Comment.text vbLf
Set mRng = cel(1, 1).MergeArea
If mRng Is Nothing Then Set mRng = cel(1, 1)
Set cmt = mRng(1, 1).Comment
cmt.Visible = True
With cmt.Shape
.LockAspectRatio = msoFalse
.Placement = xlMoveAndSize
.Shadow.Visible = msoFalse
.Line.Visible = msoFalse
.AutoShapeType = msoShapeRectangle
.Left = mRng.Left: .Top = mRng.Top
.Width = mRng.Width: .Height = mRng.Height
.Fill.UserPicture sURL
End With
End If
End Function
Cách dùng: Gõ công thức =cmt_QR(A1) vào cell nào đó (với A1 là dữ liệu đầu vào)
------------------------------
Các bạn test giúp tôi: Tạo mã bằng 2 code trên rồi dùng các chương trình quét mã QR trên smartphone scan thử xem ra kết quả đúng không nha
Em đang dùng code này được 1 thời gian. Nhưng nay không hiểu do đường link hay do vẫn đề gì đó mà không tạo được RQ code nữa.
Nhờ các thầy chỉ dạy với ạ
Đã có ai nghiên cứu vụ này chưa nhỉ (một mình mình làm thì cảm giác không chắc ăn lắm)
--------------
Phát hiện ra mấy chuyện:
- Hình như là chẳng cần đổi rổng thành "+" gì ráo cũng được
- Hình như là tiếng Việt cũng chơi được luôn là không cần phải có hàm convert (UTF8)
Tôi viết sơ qua mấy code: 1> Tạo mã QR, dùng Shape
Mã:
Private Function pic_QR(ByVal QR_Value As String, ByVal Target As Range, Optional ByVal Size As Long = 150) As Shape
Dim sURL As String
On Error Resume Next
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
Set pic_QR = Target.Parent.Shapes.AddPicture(sURL, True, True, Target.Left, Target.Top, Size, Size)
End If
End Function
Sub Main()
Dim shp As Shape
Set shp = pic_QR(Range("A1").Value, ActiveCell)
End Sub
Cách dùng: Gõ gì đó vào cell A1 rồi chạy sub Main 2> Tạo mã QR, dùng Comment
Mã:
Function cmt_QR(ByVal QR_Value As String, Optional ByVal cel As Range, Optional ByVal Size As Long = 150) As String
Dim sURL As String, mRng As Range, cmt As Comment
On Error Resume Next
Application.Volatile
If cel Is Nothing Then Set cel = Application.ThisCell
cel(1, 1).Comment.Delete
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
If cel(1, 1).Comment Is Nothing Then cel(1, 1).AddComment
cel(1, 1).Comment.text vbLf
Set mRng = cel(1, 1).MergeArea
If mRng Is Nothing Then Set mRng = cel(1, 1)
Set cmt = mRng(1, 1).Comment
cmt.Visible = True
With cmt.Shape
.LockAspectRatio = msoFalse
.Placement = xlMoveAndSize
.Shadow.Visible = msoFalse
.Line.Visible = msoFalse
.AutoShapeType = msoShapeRectangle
.Left = mRng.Left: .Top = mRng.Top
.Width = mRng.Width: .Height = mRng.Height
.Fill.UserPicture sURL
End With
End If
End Function
Cách dùng: Gõ công thức =cmt_QR(A1) vào cell nào đó (với A1 là dữ liệu đầu vào)
------------------------------
Các bạn test giúp tôi: Tạo mã bằng 2 code trên rồi dùng các chương trình quét mã QR trên smartphone scan thử xem ra kết quả đúng không nha
Em đang dùng code này được 1 thời gian. Nhưng nay không hiểu do đường link hay do vẫn đề gì đó mà không tạo được RQ code nữa.
Nhờ các thầy chỉ dạy với ạ
Đã có ai nghiên cứu vụ này chưa nhỉ (một mình mình làm thì cảm giác không chắc ăn lắm)
--------------
Phát hiện ra mấy chuyện:
- Hình như là chẳng cần đổi rổng thành "+" gì ráo cũng được
- Hình như là tiếng Việt cũng chơi được luôn là không cần phải có hàm convert (UTF8)
Tôi viết sơ qua mấy code: 1> Tạo mã QR, dùng Shape
Mã:
Private Function pic_QR(ByVal QR_Value As String, ByVal Target As Range, Optional ByVal Size As Long = 150) As Shape
Dim sURL As String
On Error Resume Next
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
Set pic_QR = Target.Parent.Shapes.AddPicture(sURL, True, True, Target.Left, Target.Top, Size, Size)
End If
End Function
Sub Main()
Dim shp As Shape
Set shp = pic_QR(Range("A1").Value, ActiveCell)
End Sub
Cách dùng: Gõ gì đó vào cell A1 rồi chạy sub Main 2> Tạo mã QR, dùng Comment
Mã:
Function cmt_QR(ByVal QR_Value As String, Optional ByVal cel As Range, Optional ByVal Size As Long = 150) As String
Dim sURL As String, mRng As Range, cmt As Comment
On Error Resume Next
Application.Volatile
If cel Is Nothing Then Set cel = Application.ThisCell
cel(1, 1).Comment.Delete
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
If cel(1, 1).Comment Is Nothing Then cel(1, 1).AddComment
cel(1, 1).Comment.text vbLf
Set mRng = cel(1, 1).MergeArea
If mRng Is Nothing Then Set mRng = cel(1, 1)
Set cmt = mRng(1, 1).Comment
cmt.Visible = True
With cmt.Shape
.LockAspectRatio = msoFalse
.Placement = xlMoveAndSize
.Shadow.Visible = msoFalse
.Line.Visible = msoFalse
.AutoShapeType = msoShapeRectangle
.Left = mRng.Left: .Top = mRng.Top
.Width = mRng.Width: .Height = mRng.Height
.Fill.UserPicture sURL
End With
End If
End Function
Cách dùng: Gõ công thức =cmt_QR(A1) vào cell nào đó (với A1 là dữ liệu đầu vào)
------------------------------
Các bạn test giúp tôi: Tạo mã bằng 2 code trên rồi dùng các chương trình quét mã QR trên smartphone scan thử xem ra kết quả đúng không nha
Em đang dùng code này được 1 thời gian. Nhưng nay không hiểu do đường link hay do vẫn đề gì đó mà không tạo được RQ code nữa.
Nhờ các thầy chỉ dạy với ạ
Đã có ai nghiên cứu vụ này chưa nhỉ (một mình mình làm thì cảm giác không chắc ăn lắm)
--------------
Phát hiện ra mấy chuyện:
- Hình như là chẳng cần đổi rổng thành "+" gì ráo cũng được
- Hình như là tiếng Việt cũng chơi được luôn là không cần phải có hàm convert (UTF8)
Tôi viết sơ qua mấy code: 1> Tạo mã QR, dùng Shape
Mã:
Private Function pic_QR(ByVal QR_Value As String, ByVal Target As Range, Optional ByVal Size As Long = 150) As Shape
Dim sURL As String
On Error Resume Next
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
Set pic_QR = Target.Parent.Shapes.AddPicture(sURL, True, True, Target.Left, Target.Top, Size, Size)
End If
End Function
Sub Main()
Dim shp As Shape
Set shp = pic_QR(Range("A1").Value, ActiveCell)
End Sub
Cách dùng: Gõ gì đó vào cell A1 rồi chạy sub Main 2> Tạo mã QR, dùng Comment
Mã:
Function cmt_QR(ByVal QR_Value As String, Optional ByVal cel As Range, Optional ByVal Size As Long = 150) As String
Dim sURL As String, mRng As Range, cmt As Comment
On Error Resume Next
Application.Volatile
If cel Is Nothing Then Set cel = Application.ThisCell
cel(1, 1).Comment.Delete
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
If cel(1, 1).Comment Is Nothing Then cel(1, 1).AddComment
cel(1, 1).Comment.text vbLf
Set mRng = cel(1, 1).MergeArea
If mRng Is Nothing Then Set mRng = cel(1, 1)
Set cmt = mRng(1, 1).Comment
cmt.Visible = True
With cmt.Shape
.LockAspectRatio = msoFalse
.Placement = xlMoveAndSize
.Shadow.Visible = msoFalse
.Line.Visible = msoFalse
.AutoShapeType = msoShapeRectangle
.Left = mRng.Left: .Top = mRng.Top
.Width = mRng.Width: .Height = mRng.Height
.Fill.UserPicture sURL
End With
End If
End Function
Cách dùng: Gõ công thức =cmt_QR(A1) vào cell nào đó (với A1 là dữ liệu đầu vào)
------------------------------
Các bạn test giúp tôi: Tạo mã bằng 2 code trên rồi dùng các chương trình quét mã QR trên smartphone scan thử xem ra kết quả đúng không nha
Em đang dùng code này được 1 thời gian. Nhưng nay không hiểu do đường link hay do vẫn đề gì đó mà không tạo được RQ code nữa.
Nhờ các thầy chỉ dạy với ạ
Đã có ai nghiên cứu vụ này chưa nhỉ (một mình mình làm thì cảm giác không chắc ăn lắm)
--------------
Phát hiện ra mấy chuyện:
- Hình như là chẳng cần đổi rổng thành "+" gì ráo cũng được
- Hình như là tiếng Việt cũng chơi được luôn là không cần phải có hàm convert (UTF8)
Tôi viết sơ qua mấy code: 1> Tạo mã QR, dùng Shape
Mã:
Private Function pic_QR(ByVal QR_Value As String, ByVal Target As Range, Optional ByVal Size As Long = 150) As Shape
Dim sURL As String
On Error Resume Next
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
Set pic_QR = Target.Parent.Shapes.AddPicture(sURL, True, True, Target.Left, Target.Top, Size, Size)
End If
End Function
Sub Main()
Dim shp As Shape
Set shp = pic_QR(Range("A1").Value, ActiveCell)
End Sub
Cách dùng: Gõ gì đó vào cell A1 rồi chạy sub Main 2> Tạo mã QR, dùng Comment
Mã:
Function cmt_QR(ByVal QR_Value As String, Optional ByVal cel As Range, Optional ByVal Size As Long = 150) As String
Dim sURL As String, mRng As Range, cmt As Comment
On Error Resume Next
Application.Volatile
If cel Is Nothing Then Set cel = Application.ThisCell
cel(1, 1).Comment.Delete
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
If cel(1, 1).Comment Is Nothing Then cel(1, 1).AddComment
cel(1, 1).Comment.text vbLf
Set mRng = cel(1, 1).MergeArea
If mRng Is Nothing Then Set mRng = cel(1, 1)
Set cmt = mRng(1, 1).Comment
cmt.Visible = True
With cmt.Shape
.LockAspectRatio = msoFalse
.Placement = xlMoveAndSize
.Shadow.Visible = msoFalse
.Line.Visible = msoFalse
.AutoShapeType = msoShapeRectangle
.Left = mRng.Left: .Top = mRng.Top
.Width = mRng.Width: .Height = mRng.Height
.Fill.UserPicture sURL
End With
End If
End Function
Cách dùng: Gõ công thức =cmt_QR(A1) vào cell nào đó (với A1 là dữ liệu đầu vào)
------------------------------
Các bạn test giúp tôi: Tạo mã bằng 2 code trên rồi dùng các chương trình quét mã QR trên smartphone scan thử xem ra kết quả đúng không nha
Em đang dùng code này được 1 thời gian. Nhưng nay không hiểu do đường link hay do vẫn đề gì đó mà không tạo được RQ code nữa.
Nhờ các thầy chỉ dạy với ạ
Đã có ai nghiên cứu vụ này chưa nhỉ (một mình mình làm thì cảm giác không chắc ăn lắm)
--------------
Phát hiện ra mấy chuyện:
- Hình như là chẳng cần đổi rổng thành "+" gì ráo cũng được
- Hình như là tiếng Việt cũng chơi được luôn là không cần phải có hàm convert (UTF8)
Tôi viết sơ qua mấy code: 1> Tạo mã QR, dùng Shape
Mã:
Private Function pic_QR(ByVal QR_Value As String, ByVal Target As Range, Optional ByVal Size As Long = 150) As Shape
Dim sURL As String
On Error Resume Next
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
Set pic_QR = Target.Parent.Shapes.AddPicture(sURL, True, True, Target.Left, Target.Top, Size, Size)
End If
End Function
Sub Main()
Dim shp As Shape
Set shp = pic_QR(Range("A1").Value, ActiveCell)
End Sub
Cách dùng: Gõ gì đó vào cell A1 rồi chạy sub Main 2> Tạo mã QR, dùng Comment
Mã:
Function cmt_QR(ByVal QR_Value As String, Optional ByVal cel As Range, Optional ByVal Size As Long = 150) As String
Dim sURL As String, mRng As Range, cmt As Comment
On Error Resume Next
Application.Volatile
If cel Is Nothing Then Set cel = Application.ThisCell
cel(1, 1).Comment.Delete
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
If cel(1, 1).Comment Is Nothing Then cel(1, 1).AddComment
cel(1, 1).Comment.text vbLf
Set mRng = cel(1, 1).MergeArea
If mRng Is Nothing Then Set mRng = cel(1, 1)
Set cmt = mRng(1, 1).Comment
cmt.Visible = True
With cmt.Shape
.LockAspectRatio = msoFalse
.Placement = xlMoveAndSize
.Shadow.Visible = msoFalse
.Line.Visible = msoFalse
.AutoShapeType = msoShapeRectangle
.Left = mRng.Left: .Top = mRng.Top
.Width = mRng.Width: .Height = mRng.Height
.Fill.UserPicture sURL
End With
End If
End Function
Cách dùng: Gõ công thức =cmt_QR(A1) vào cell nào đó (với A1 là dữ liệu đầu vào)
------------------------------
Các bạn test giúp tôi: Tạo mã bằng 2 code trên rồi dùng các chương trình quét mã QR trên smartphone scan thử xem ra kết quả đúng không nha
Em đang dùng code này được 1 thời gian. Nhưng nay không hiểu do đường link hay do vẫn đề gì đó mà không tạo được RQ code nữa.
Nhờ các thầy chỉ dạy với ạ
Em đang dùng code này được 1 thời gian. Nhưng nay không hiểu do đường link hay do vẫn đề gì đó mà không tạo được RQ code nữa.
Nhờ các thầy chỉ dạy với ạ
Bài đã được tự động gộp:
Em đang dùng code này được 1 thời gian. Nhưng nay không hiểu do đường link hay do vẫn đề gì đó mà không tạo được RQ code nữa.
Nhờ các thầy chỉ dạy với ạ
Bài đã được tự động gộp:
Em đang dùng code này được 1 thời gian. Nhưng nay không hiểu do đường link hay do vẫn đề gì đó mà không tạo được RQ code nữa.
Nhờ các thầy chỉ dạy với ạ
Bài đã được tự động gộp:
Em đang dùng code này được 1 thời gian. Nhưng nay không hiểu do đường link hay do vẫn đề gì đó mà không tạo được RQ code nữa.
Nhờ các thầy chỉ dạy với ạ
Đã có ai nghiên cứu vụ này chưa nhỉ (một mình mình làm thì cảm giác không chắc ăn lắm)
--------------
Phát hiện ra mấy chuyện:
- Hình như là chẳng cần đổi rổng thành "+" gì ráo cũng được
- Hình như là tiếng Việt cũng chơi được luôn là không cần phải có hàm convert (UTF8)
Tôi viết sơ qua mấy code: 1> Tạo mã QR, dùng Shape
Mã:
Private Function pic_QR(ByVal QR_Value As String, ByVal Target As Range, Optional ByVal Size As Long = 150) As Shape
Dim sURL As String
On Error Resume Next
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
Set pic_QR = Target.Parent.Shapes.AddPicture(sURL, True, True, Target.Left, Target.Top, Size, Size)
End If
End Function
Sub Main()
Dim shp As Shape
Set shp = pic_QR(Range("A1").Value, ActiveCell)
End Sub
Cách dùng: Gõ gì đó vào cell A1 rồi chạy sub Main 2> Tạo mã QR, dùng Comment
Mã:
Function cmt_QR(ByVal QR_Value As String, Optional ByVal cel As Range, Optional ByVal Size As Long = 150) As String
Dim sURL As String, mRng As Range, cmt As Comment
On Error Resume Next
Application.Volatile
If cel Is Nothing Then Set cel = Application.ThisCell
cel(1, 1).Comment.Delete
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
If cel(1, 1).Comment Is Nothing Then cel(1, 1).AddComment
cel(1, 1).Comment.text vbLf
Set mRng = cel(1, 1).MergeArea
If mRng Is Nothing Then Set mRng = cel(1, 1)
Set cmt = mRng(1, 1).Comment
cmt.Visible = True
With cmt.Shape
.LockAspectRatio = msoFalse
.Placement = xlMoveAndSize
.Shadow.Visible = msoFalse
.Line.Visible = msoFalse
.AutoShapeType = msoShapeRectangle
.Left = mRng.Left: .Top = mRng.Top
.Width = mRng.Width: .Height = mRng.Height
.Fill.UserPicture sURL
End With
End If
End Function
Cách dùng: Gõ công thức =cmt_QR(A1) vào cell nào đó (với A1 là dữ liệu đầu vào)
------------------------------
Các bạn test giúp tôi: Tạo mã bằng 2 code trên rồi dùng các chương trình quét mã QR trên smartphone scan thử xem ra kết quả đúng không nha
Em đang dùng code này được 1 thời gian. Nhưng nay không hiểu do đường link hay do vẫn đề gì đó mà không tạo được RQ code nữa.
Nhờ các thầy chỉ dạy với ạ
Đã có ai nghiên cứu vụ này chưa nhỉ (một mình mình làm thì cảm giác không chắc ăn lắm)
--------------
Phát hiện ra mấy chuyện:
- Hình như là chẳng cần đổi rổng thành "+" gì ráo cũng được
- Hình như là tiếng Việt cũng chơi được luôn là không cần phải có hàm convert (UTF8)
Tôi viết sơ qua mấy code: 1> Tạo mã QR, dùng Shape
Mã:
Private Function pic_QR(ByVal QR_Value As String, ByVal Target As Range, Optional ByVal Size As Long = 150) As Shape
Dim sURL As String
On Error Resume Next
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
Set pic_QR = Target.Parent.Shapes.AddPicture(sURL, True, True, Target.Left, Target.Top, Size, Size)
End If
End Function
Sub Main()
Dim shp As Shape
Set shp = pic_QR(Range("A1").Value, ActiveCell)
End Sub
Cách dùng: Gõ gì đó vào cell A1 rồi chạy sub Main 2> Tạo mã QR, dùng Comment
Mã:
Function cmt_QR(ByVal QR_Value As String, Optional ByVal cel As Range, Optional ByVal Size As Long = 150) As String
Dim sURL As String, mRng As Range, cmt As Comment
On Error Resume Next
Application.Volatile
If cel Is Nothing Then Set cel = Application.ThisCell
cel(1, 1).Comment.Delete
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
If cel(1, 1).Comment Is Nothing Then cel(1, 1).AddComment
cel(1, 1).Comment.text vbLf
Set mRng = cel(1, 1).MergeArea
If mRng Is Nothing Then Set mRng = cel(1, 1)
Set cmt = mRng(1, 1).Comment
cmt.Visible = True
With cmt.Shape
.LockAspectRatio = msoFalse
.Placement = xlMoveAndSize
.Shadow.Visible = msoFalse
.Line.Visible = msoFalse
.AutoShapeType = msoShapeRectangle
.Left = mRng.Left: .Top = mRng.Top
.Width = mRng.Width: .Height = mRng.Height
.Fill.UserPicture sURL
End With
End If
End Function
Cách dùng: Gõ công thức =cmt_QR(A1) vào cell nào đó (với A1 là dữ liệu đầu vào)
------------------------------
Các bạn test giúp tôi: Tạo mã bằng 2 code trên rồi dùng các chương trình quét mã QR trên smartphone scan thử xem ra kết quả đúng không nha
Đã có ai nghiên cứu vụ này chưa nhỉ (một mình mình làm thì cảm giác không chắc ăn lắm)
--------------
Phát hiện ra mấy chuyện:
- Hình như là chẳng cần đổi rổng thành "+" gì ráo cũng được
- Hình như là tiếng Việt cũng chơi được luôn là không cần phải có hàm convert (UTF8)
Tôi viết sơ qua mấy code: 1> Tạo mã QR, dùng Shape
Mã:
Private Function pic_QR(ByVal QR_Value As String, ByVal Target As Range, Optional ByVal Size As Long = 150) As Shape
Dim sURL As String
On Error Resume Next
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
Set pic_QR = Target.Parent.Shapes.AddPicture(sURL, True, True, Target.Left, Target.Top, Size, Size)
End If
End Function
Sub Main()
Dim shp As Shape
Set shp = pic_QR(Range("A1").Value, ActiveCell)
End Sub
Cách dùng: Gõ gì đó vào cell A1 rồi chạy sub Main 2> Tạo mã QR, dùng Comment
Mã:
Function cmt_QR(ByVal QR_Value As String, Optional ByVal cel As Range, Optional ByVal Size As Long = 150) As String
Dim sURL As String, mRng As Range, cmt As Comment
On Error Resume Next
Application.Volatile
If cel Is Nothing Then Set cel = Application.ThisCell
cel(1, 1).Comment.Delete
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
If cel(1, 1).Comment Is Nothing Then cel(1, 1).AddComment
cel(1, 1).Comment.text vbLf
Set mRng = cel(1, 1).MergeArea
If mRng Is Nothing Then Set mRng = cel(1, 1)
Set cmt = mRng(1, 1).Comment
cmt.Visible = True
With cmt.Shape
.LockAspectRatio = msoFalse
.Placement = xlMoveAndSize
.Shadow.Visible = msoFalse
.Line.Visible = msoFalse
.AutoShapeType = msoShapeRectangle
.Left = mRng.Left: .Top = mRng.Top
.Width = mRng.Width: .Height = mRng.Height
.Fill.UserPicture sURL
End With
End If
End Function
Cách dùng: Gõ công thức =cmt_QR(A1) vào cell nào đó (với A1 là dữ liệu đầu vào)
------------------------------
Các bạn test giúp tôi: Tạo mã bằng 2 code trên rồi dùng các chương trình quét mã QR trên smartphone scan thử xem ra kết quả đúng không nha
Đã có ai nghiên cứu vụ này chưa nhỉ (một mình mình làm thì cảm giác không chắc ăn lắm)
--------------
Phát hiện ra mấy chuyện:
- Hình như là chẳng cần đổi rổng thành "+" gì ráo cũng được
- Hình như là tiếng Việt cũng chơi được luôn là không cần phải có hàm convert (UTF8)
Tôi viết sơ qua mấy code: 1> Tạo mã QR, dùng Shape
Mã:
Private Function pic_QR(ByVal QR_Value As String, ByVal Target As Range, Optional ByVal Size As Long = 150) As Shape
Dim sURL As String
On Error Resume Next
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
Set pic_QR = Target.Parent.Shapes.AddPicture(sURL, True, True, Target.Left, Target.Top, Size, Size)
End If
End Function
Sub Main()
Dim shp As Shape
Set shp = pic_QR(Range("A1").Value, ActiveCell)
End Sub
Cách dùng: Gõ gì đó vào cell A1 rồi chạy sub Main 2> Tạo mã QR, dùng Comment
Mã:
Function cmt_QR(ByVal QR_Value As String, Optional ByVal cel As Range, Optional ByVal Size As Long = 150) As String
Dim sURL As String, mRng As Range, cmt As Comment
On Error Resume Next
Application.Volatile
If cel Is Nothing Then Set cel = Application.ThisCell
cel(1, 1).Comment.Delete
If Len(QR_Value) Then
sURL = "https://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl="
sURL = sURL & QR_Value
If cel(1, 1).Comment Is Nothing Then cel(1, 1).AddComment
cel(1, 1).Comment.text vbLf
Set mRng = cel(1, 1).MergeArea
If mRng Is Nothing Then Set mRng = cel(1, 1)
Set cmt = mRng(1, 1).Comment
cmt.Visible = True
With cmt.Shape
.LockAspectRatio = msoFalse
.Placement = xlMoveAndSize
.Shadow.Visible = msoFalse
.Line.Visible = msoFalse
.AutoShapeType = msoShapeRectangle
.Left = mRng.Left: .Top = mRng.Top
.Width = mRng.Width: .Height = mRng.Height
.Fill.UserPicture sURL
End With
End If
End Function
Cách dùng: Gõ công thức =cmt_QR(A1) vào cell nào đó (với A1 là dữ liệu đầu vào)
------------------------------
Các bạn test giúp tôi: Tạo mã bằng 2 code trên rồi dùng các chương trình quét mã QR trên smartphone scan thử xem ra kết quả đúng không nha
