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

Liên hệ QC
Đã 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 ạ
Bài đã được tự động gộp:

Đã 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 ạ
Bài đã được tự động gộp:

Đã 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 ạ
Bài đã được tự động gộp:

Đã 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 ạ
Bài đã được tự động gộp:

Đã 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 ạ
 
Lần chỉnh sửa cuố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 ạ
Bài đã được tự động gộp:

Đã 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 ạ
Bài đã được tự động gộp:

Đã 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 ạ
Bài đã được tự động gộp:

Đã 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 ạ
Vừa nghịch thấy vẫn được. Nghi là phải cài lại win + office.
 
Đã 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 ạ
Bài đã được tự động gộp:

Đã 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
Bài đã được tự động gộp:

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

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

Bài viết mới nhất

Back
Top Bottom