Generar QR desde Api Google -

Generar QR desde Api Google

Generar QR desde VBA Excel consumiendo el Servicio de Google. Para realizar esta Acción es tener instalado Microsoft Office en su computador.

Primero Creamos un Libro de Excel y se guarda con Extensión .xlsm

Segundo Creamos el Módulo y pegamos los Códigos.

#If VBA7 And Win64 Then
    Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
      Alias "URLDownloadToFileA" ( _
        ByVal pCaller As LongPtr, _
        ByVal szURL As String, _
        ByVal szFileName As String, _
        ByVal dwReserved As LongPtr, _
        ByVal lpfnCB As LongPtr _
      ) As Long
#Else
    Private Declare Function URLDownloadToFile Lib "urlmon" _
      Alias "URLDownloadToFileA" ( _
        ByVal pCaller As Long, _
        ByVal szURL As String, _
        ByVal szFileName As String, _
        ByVal dwReserved As Long, _
        ByVal lpfnCB As Long _
      ) As Long
#End If

#If VBA7 And Win64 Then

Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _

Alias "URLDownloadToFileA" ( _

ByVal pCaller As LongPtr, _

ByVal szURL As String, _

ByVal szFileName As String, _

ByVal dwReserved As LongPtr, _

ByVal lpfnCB As LongPtr _

) As Long

#Else

Private Declare Function URLDownloadToFile Lib "urlmon" _

Alias "URLDownloadToFileA" ( _

ByVal pCaller As Long, _

ByVal szURL As String, _

ByVal szFileName As String, _

ByVal dwReserved As Long, _

ByVal lpfnCB As Long _

) As Long

#End If

Sub GenerarQR(dato As String, rango As String)
        Dim Url$, Ruta$
        Url = "https://chart.googleapis.com/chart?chs=150x150&cht=qr&chl=" & dato
        Ruta = ThisWorkbook.path & "\QR.png"
        URLDownloadToFile 0, Url, Ruta, 0, 0
        '------------------------------------------
        Call InsertarQR_Celda(Ruta, rango)
End Sub

Sub GenerarQR(dato As String, rango As String)

Dim Url$, Ruta$

Url = "https://chart.googleapis.com/chart?chs=150x150&cht=qr&chl=" & dato

Ruta = ThisWorkbook.path & "\QR.png"

URLDownloadToFile 0, Url, Ruta, 0, 0

'------------------------------------------

Call InsertarQR_Celda(Ruta, rango)

End Sub

Sub InsertarQR_Celda(ByVal path As String, ByVal rango As String)
    Call BorrarShape_QR
    
    'Aqui Colocamos la Imagen en la Celda, esta Celda es dinamica
     ActiveSheet.Range(rango).Select
    
    'Insertamos la Imagen
     ActiveSheet.Pictures.Insert (ThisWorkbook.path & "\QR.png")
    
    'Asignamos el Nombre a la Imagen de manera dinamica
     ActiveSheet.Shapes(3).Name = "qr"
         
     'Alto y ancho de la celda
     Range(rango).RowHeight = 100
     Range(rango).ColumnWidth = 20
          
End Sub

Sub InsertarQR_Celda(ByVal path As String, ByVal rango As String)

Call BorrarShape_QR

'Aqui Colocamos la Imagen en la Celda, esta Celda es dinamica

ActiveSheet.Range(rango).Select

'Insertamos la Imagen

ActiveSheet.Pictures.Insert (ThisWorkbook.path & "\QR.png")

'Asignamos el Nombre a la Imagen de manera dinamica

ActiveSheet.Shapes(3).Name = "qr"

'Alto y ancho de la celda

Range(rango).RowHeight = 100

Range(rango).ColumnWidth = 20

End Sub

Sub BorrarShape_QR()

Dim shp As Object
For Each shp In ActiveSheet.Shapes
       If shp.Name = "qr" Then
        shp.Delete
       End If
Next
End Sub

Sub BorrarShape_QR()

Dim shp As Object

For Each shp In ActiveSheet.Shapes

If shp.Name = "qr" Then

shp.Delete

End If

End Sub

Con este código podemos obtener el QR desde la web de Google, sin embargo esto dependerá de su conexión de internet para descargar el QR.

Para llamar a la Función que nos permite Crear el QR es de esta manera.

Sub RegistrarQR()
  Call GenerarQR("kMsEqDPhxXf6TaoNnCcYy270yv8FatkVh5rCm7UY0wR3yqFDceRP3M0U8bDuUXtRzCbz", "C38")
End Sub

Sub RegistrarQR()

Call GenerarQR("kMsEqDPhxXf6TaoNnCcYy270yv8FatkVh5rCm7UY0wR3yqFDceRP3M0U8bDuUXtRzCbz", "C38")

End Sub

Finalmente esta función Consta de 2 parámetros:

El texto y la celda.

VIDEO TUTORIAL CREAR QR EN EXCEL

DESCARGAR QR EN EXCEL

Conectate a WhatsApp

Generar QR desde Api Google