0

Is there a way to call a macro in Excel that converts specified cells values to separate QR-codes and places them on specific locations?

Following code has worked until today. I guess the api.qrserver.com doesn't allow several calls as an anti-spam filter, or it's just trouble for today. One single call by the URL works fine.

I would like a local solution if possible that doesn't rely on up/downtime for api.qrserver.com.

Sub addQR()

    For Each pic In ActiveSheet.Pictures
        pic.Delete
    Next pic

    filepath = "https://api.qrserver.com/v1/create-qr-code/?size=150x150&data=" & Cells(3, 18).Value
    
    With ActiveSheet.Pictures.Insert(filepath)
        .ShapeRange.ScaleWidth 0.8, msoFalse, msoScaleFromTopLeft
        .ShapeRange.ScaleHeight 0.8, msoFalse, msoScaleFromTopLeft
        .Left = ActiveSheet.Range("I1").Left
        .Top = ActiveSheet.Range("C4").Top
        .Width = ActiveSheet.Range("A1:B1").Width
        .Height = ActiveSheet.Range("A1:A5").Height
        .Placement = 1
    End With
    
    filepath2 = "https://api.qrserver.com/v1/create-qr-code/?size=150x150&data=" & Cells(5, 18).Value
    
    With ActiveSheet.Pictures.Insert(filepath2)
    .ShapeRange.ScaleWidth 0.8, msoFalse, msoScaleFromTopLeft
    .ShapeRange.ScaleHeight 0.8, msoFalse, msoScaleFromTopLeft
    .Left = ActiveSheet.Range("G11").Left
    .Top = ActiveSheet.Range("G11").Top
    .Width = ActiveSheet.Range("A1:B1").Width
    .Height = ActiveSheet.Range("A1:A5").Height
    .Placement = 1
    End With
    
        filepath3 = "https://api.qrserver.com/v1/create-qr-code/?size=150x150&data=" & Cells(7, 18).Value
    
    With ActiveSheet.Pictures.Insert(filepath3)
    .ShapeRange.ScaleWidth 0.8, msoFalse, msoScaleFromTopLeft
    .ShapeRange.ScaleHeight 0.8, msoFalse, msoScaleFromTopLeft
    .Left = ActiveSheet.Range("E21").Left
    .Top = ActiveSheet.Range("E21").Top
    .Width = ActiveSheet.Range("A1:B1").Width
    .Height = ActiveSheet.Range("A1:A5").Height
    .Placement = 1
    End With
    
        filepath4 = "https://api.qrserver.com/v1/create-qr-code/?size=150x150&data=" & Cells(9, 18).Value
    
    With ActiveSheet.Pictures.Insert(filepath4)
    .ShapeRange.ScaleWidth 0.8, msoFalse, msoScaleFromTopLeft
    .ShapeRange.ScaleHeight 0.8, msoFalse, msoScaleFromTopLeft
    .Left = ActiveSheet.Range("L21").Left
    .Top = ActiveSheet.Range("L21").Top
    .Width = ActiveSheet.Range("A1:B1").Width
    .Height = ActiveSheet.Range("A1:A5").Height
    .Placement = 1
    End With
    
    picPath = "O:\Robin\Dokument\logga.jpg"
    
With ActiveSheet.Pictures.Insert(picPath)
    .ShapeRange.LockAspectRatio = msoFalse
    .ShapeRange.ScaleWidth 1.78, msoFalse, msoScaleFromTopLeft
    .ShapeRange.ScaleHeight 1.24, msoFalse, msoScaleFromTopLeft
    .Left = ActiveSheet.Range("B3").Left
    .Top = ActiveSheet.Range("B3").Top
    .Placement = 1
  End With
    
End Sub
RobinJakobsson
  • 31
  • 3
  • 1
    A very quick and dirty Google search gave me [this](https://www.extendoffice.com/documents/excel/5404-excel-create-qr-code.html) – JvdV Mar 28 '23 at 10:59
  • Does this answer your question? [Generating 2D (PDF417 or QR) barcodes using Excel VBA](https://stackoverflow.com/questions/16143331/generating-2d-pdf417-or-qr-barcodes-using-excel-vba) – Foxfire And Burns And Burns Mar 28 '23 at 11:10
  • This solved my problem. https://www.extendoffice.com/documents/excel/5404-excel-create-qr-code.html https://download.extendoffice.com/downloads/other/Controls/MSBCODE.zip However, there is a border around the generated QR-code that I can't get rid of. `code` Dim xObjOLE As OLEObject On Error Resume Next Application.ScreenUpdating = False Set xObjOLE = ActiveSheet.OLEObjects.Add("BARCODE.BarCodeCtrl.1") `code` – RobinJakobsson Mar 31 '23 at 05:08

0 Answers0