Hola a tod@s, nuevamente solicitando su tiempo y aporte para ese nuevo tema.
El siguiente codigo lo encontre en la Web.
#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 CrearQRMasivo()
Dim n&, I&
LimpiarImagenes
With wGenerador
n = .Range("H" & Rows.Count).End(xlUp).Row
For I = 2 To n
CrearQRIndividual .Range("H" & I)
Next
End With
End Sub
Sub CrearQRIndividual(Valor As Range)
Dim Link$, Ruta$, QR As Object
Dim lado&, izqui&, nTop&
'Descargo el código QR
If Valor.Value = Empty Then
Exit Sub
End If
Link = "http://chart.apis.google.com/chart?cht=qr&chs=300x300&chl=" & Valor.Value & "&chld=H|0"
Ruta = ThisWorkbook.Path & "\chart.png"
URLDownloadToFile 0, Link, Ruta, 0, 0
'-----------------
'Ingreso la imagen
Set QR = ActiveSheet.Pictures.Insert(Ruta)
Kill Ruta
With wGenerador
nTop = .Range("I" & Valor.Row).Top
lado = .Range("I" & Valor.Row).Width
izqui = .Range("I" & Valor.Row).Left
With QR
.Top = nTop
.Width = lado
.Left = izqui
End With
.Range("I" & Valor.Row).RowHeight = lado
End With
'-----------------
End Sub
Sub LimpiarTodo()
LimpiarImagenes
wGenerador.Range("H2", "H" & Rows.Count) = Empty
End Sub
Sub LimpiarImagenes()
Dim imagen As Picture
For Each imagen In ActiveSheet.Pictures
imagen.Delete
Next
wGenerador.Range("H2", "H" & Rows.Count).RowHeight = wGenerador.Range("H2").RowHeight
End Sub
Este código genera Imágenes QR; sin embargo cuando se copia la hoja completa para generar nuevas imagenes QR de otros productos; solo genera los mismo codigos de la hoja principal; se necesita que se genere imagenes QR para la nueva hoja .
Hola a tod@s, nuevamente solicitando su tiempo y aporte para ese nuevo tema.
El siguiente codigo lo encontre en la Web.
#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 CrearQRMasivo() Dim n&, I& LimpiarImagenes With wGenerador n = .Range("H" & Rows.Count).End(xlUp).Row For I = 2 To n CrearQRIndividual .Range("H" & I) Next End With End Sub Sub CrearQRIndividual(Valor As Range) Dim Link$, Ruta$, QR As Object Dim lado&, izqui&, nTop& 'Descargo el código QR If Valor.Value = Empty Then Exit Sub End If Link = "http://chart.apis.google.com/chart?cht=qr&chs=300x300&chl=" & Valor.Value & "&chld=H|0" Ruta = ThisWorkbook.Path & "\chart.png" URLDownloadToFile 0, Link, Ruta, 0, 0 '----------------- 'Ingreso la imagen Set QR = ActiveSheet.Pictures.Insert(Ruta) Kill Ruta With wGenerador nTop = .Range("I" & Valor.Row).Top lado = .Range("I" & Valor.Row).Width izqui = .Range("I" & Valor.Row).Left With QR .Top = nTop .Width = lado .Left = izqui End With .Range("I" & Valor.Row).RowHeight = lado End With '----------------- End Sub Sub LimpiarTodo() LimpiarImagenes wGenerador.Range("H2", "H" & Rows.Count) = Empty End Sub Sub LimpiarImagenes() Dim imagen As Picture For Each imagen In ActiveSheet.Pictures imagen.Delete Next wGenerador.Range("H2", "H" & Rows.Count).RowHeight = wGenerador.Range("H2").RowHeight End Sub
Este código genera Imágenes QR; sin embargo cuando se copia la hoja completa para generar nuevas imagenes QR de otros productos; solo genera los mismo codigos de la hoja principal; se necesita que se genere imagenes QR para la nueva hoja .
Espero haberme hecho entender
Saludos
pruebaQr.xlsm