Chuyển Function thành Sub trong VBA để tạo QRcode

Liên hệ QC

andythuy

Thành viên mới
Tham gia
24/8/10
Bài viết
41
Được thích
2
Em tình cờ thấy được đoạn code này dùng để tạo QR code trên Excel (em cảm ơn tác giả nhiều lắm ạ)
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

Nhưng giờ em muốn chuyển nó thành Sub - để khi chạy thì nó tạo qrcode cho cell đang được chọn, thì làm như thế nào ạ, nhờ các anh chị giúp em. Em đã thử nhưng ra toàn comment trắng - không có qrcode. Cảm ơn các anh chị ạ.

Sub cmt_QR()
Dim cel as Range
Dim size as Long
Dim sURL As String, mRng As Range, cmt As Comment
On Error Resume Next
...'phần này giống code cũ, chỉ thay width và height = 100
.Width = 100
.Height = 100
.Fill.UserPicture sURL
End With
End If
End Sub
 
Lần chỉnh sửa cuối:
Theo tôi thì khỏi cần chuyển thành sub làm gì cho mệt người, mà bạn hãy viết 1 sub gọi cái hàm kia ra là xong.
 
Theo tôi thì khỏi cần chuyển thành sub làm gì cho mệt người, mà bạn hãy viết 1 sub gọi cái hàm kia ra là xong.
Cái function ấy nó nhận tham số, đâu phải muốn gọi thì gọi.
Ngưới viết khong chú thích nhiệm vụ của tham số cho nên hơi khó đọc.
Ở đây có nhiều người chịu khó đọc code không có chú thích. Nhưng số ấy không có tôi.
 
Em tình cờ thấy được đoạn code này (em cảm ơn tác giả nhiều lắm ạ)
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

Nhưng giờ em muốn chuyển nó thành Sub - để khi chạy thì nó tạo qrcode cho cell đang được chọn, thì làm như thế nào ạ, nhờ các anh chị giúp em. Em đã thử nhưng ra toàn comment trắng - không có qrcode. Cảm ơn các anh chị ạ.

Sub cmt_QR()
Dim cel as Range
Dim size as Long
Dim sURL As String, mRng As Range, cmt As Comment
On Error Resume Next
...'phần này giống code cũ, chỉ thay width và height = 100
.Width = 100
.Height = 100
.Fill.UserPicture sURL
End With
End If
End Sub
Cái hàm này làm gì đó anh oi?
 
Chắc chắn chứ?
Tôi thì không nhớ là mình có trong số đó không. Trí nhớ thì cực tốt, chỉ mỗi tội quá ngắn. :D
Cái từ "chịu khó" nó dẫn đường cho ý tương đối.
Không chịu khó: ngày vợ cho ăn ngon thì sẽ đọc, gặp bữa vợ bắt ăn kiêng thì không.
Chịu khó: đọc bất kể nghịch cảnh.
 
Em đã xử lý được rồi. Cảm ơn các bác đã quan tâm ạ.
 
Nhược điểm code này là phải có internet (do xài của google), xài thử máy nội bộ treo luôn @@
 
Web KT
Back
Top Bottom