Mã QR sẽ dùng vào việc gì nếu tạo nó trên Excel?

[Trung Kien Phan]

Đã 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

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

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 ạ

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

Đã 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

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

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 ạ

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

Đã 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

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

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 ạ

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

Đã 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

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

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 ạ

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

Đã 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

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

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 ạ

 

[Trung Kien Phan]

Đã 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

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

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 ạ

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

Đã 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

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

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 ạ

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

Đã 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

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

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 ạ

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

Đã 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

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

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 ạ

 

[cantl]

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: 4/1/24

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: 4/1/24

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: 4/1/24

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 ạ

Vừa nghịch thấy vẫn được. Nghi là phải cài lại win + office.

 

[Trung Kien Phan]

Đã 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

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

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 ạ

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

Đã 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

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

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

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

Đã 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

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

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

Vừa nghịch thấy vẫn được. Nghi là phải cài lại win + office.

đã cài lại. Nhưng các máy khác em sử dụng cũng không được

 

[htin1997]

không tạo được RQ code nữa

Google chưa phản hồi vụ API QRCode này, trong thời gian chờ đợi bạn dùng tạm API khác xem sao.
https://zxing.org/w/chart?chs=200x200&cht=qr&chl=HelloGPE

 

[HeSanbi]

Dùng Add-in VBA từ nguồn này vẫn tạo được QRCode bạn nhé, không cần đến phản hồi trực tuyến

GitHub - yas78/QRCodeLibVBA: QR Code generator library in VBA

QR Code generator library in VBA. Contribute to yas78/QRCodeLibVBA development by creating an account on GitHub.

github.com

 

[htin1997]

Dùng Add-in VBA từ nguồn này vẫn tạo được QRCode bạn nhé, không cần đến phản hồi trực tuyến

GitHub - yas78/QRCodeLibVBA: QR Code generator library in VBA

QR Code generator library in VBA. Contribute to yas78/QRCodeLibVBA development by creating an account on GitHub.

github.com

Anh @HeSanbi có lập trình Python không?

 

[cantl]

sử dụng

. . . . . . . .

 

[thanhtrungsmile]

Đã 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

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

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 có test thử nhưng nó không hiện QR mà lại là như thế này thì fix sao ạ