Új hozzászólás Aktív témák

• sztanozs veterán

  #3142

  #3140 Papa100

  2020-05-21 16:05:19

  Új Válasz

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  

  sztanozs

  veterán

  #3140 Papa100

  #3140 Papa100

  Kedves Fórumozók!
  Nem boldogulok az alábbi feladattal. Egy QR kódot szeretnék excel táblába menteni.
  A QR kódot Internet Explorerrel online generálom, és az IE oldalról kellene átmásolni a munkalapra. A QR megjelenik az Explorer oldalon, de nem tudom átmásolni.
  Sub FillInternet2()
Dim IE As Object
Dim adat As String
adat = "https://chart.googleapis.com/chart?chs=200x200&cht=qr&chl=BEGIN:VCARD%0AN:Teszt%20Elek%0AEND:VCARD"
Set IE = CreateObject("InternetExplorer.Application")
IE.navigate adat
While IE.ReadyState <> 4
DoEvents
Wend
IE.Visible = True
    For Each itm In IE.document.all
            n = n + 1
             Cells(20 + n, 1) = itm
                If itm = "[object HTMLImageElement]" Then
                'Cells(2, 27) = Img.getAttribute("src")
                End If
     Next
IE.Quit
End Sub
Segítségeteket előre is nagyon köszönöm.
  

  Option Explicit

'Használata:
'GenerateQR Range("B2"), "https://chart.googleapis.com/chart?chs=200x200&cht=qr&chl=BEGIN:VCARD%0AN:Teszt%20Elek%0AEND:VCARD"
'
Public Sub GenerateQR(R As Range, Url As String)
Dim im As Object
Set im = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, DisplayAsIcon:=False, Left:=R.Left, Top:=R.Top + 2, Width:=1, Height:=1)
im.Object.AutoSize = True
im.Object.BorderStyle = 0
im.Object.PictureAlignment = 0
Set im.Object.Picture = GetPicture(Url)
R.ColumnWidth = im.Width * 0.141 * 1.333
R.RowHeight = im.Height + 4
End Sub

Private Function GetPicture(Url As String) As StdPicture
Dim wv As Object
Set wv = CreateObject("WIA.Vector")
wv.BinaryData = GetWebData(Url)
Set GetPicture = wv.Picture
Set wv = Nothing
End Function

Private Function GetWebData(Url As String) As Byte()
Dim objHTTP
Set objHTTP = CreateObject("Microsoft.XMLHTTP")
objHTTP.Open "GET", Url, False
objHTTP.Send
If objHTTP.statusText = "OK" Then
GetWebData = objHTTP.ResponseBody
End If
Set objHTTP = Nothing
End Function

Új hozzászólás Aktív témák