Url to Picture in Cell Problem

[SamuelS]

My end goal is to have a system where I can apply tags with QR codes on parts of large machines so that it is easier to identify a part if it needs to be replaced.
I have a lot of spreadsheets with different layouts that I have to draw from so I am currently taking some user inputs.
There are three things per part I want generated from my spreadsheets. The tag to put on the part, the html file for the web server, and the qr code in .png format.
In excel I have already written equations to generate the html for the tags and the information file. I also have equations that link the Google's Qr generator.
I have gotten my code to generate the html file from my excel spreadsheet and I don't think I will have too much trouble with the part tags once I get the QR picture.
My code generates them, but they are not in any cells. They are just placed on the sheet itself. If I could just take the picture and generate .png files without even putting them in the cell that is fine too.
I'm sorry if this isn't very straight forward. If you have questions I will do my best to answer them for you.

Here is an example of one of the QR links
https://chart.googleapis.com/chart?...l=http://172.28.5.67/Pilot Gas Solenoid Valve

I have tried so many different ways to do this, I cannot remember which code gave me the best results

With this code I had trouble accommodating the different excel templates by having a variable range.

When I set the range for a test case it generated the right pictures in excel, but just on the sheet and not in the cell I wanted.

I also don't have any clue how I will save the pictures to individual files if it isn't the same way as I did for text.


Sub CreateFiles()

Dim Pic As Picture

Row = Application.InputBox("What Row Does the Data Start on?", "Input Box Text", Type:=2)
Name = Application.InputBox("What Column Letter Are the Part Names On?", "Input Box Text", Type:=2)
HTML = Application.InputBox("What Column Letter Are the HTML codes on?", "Input Box Text", Type:=2)
Link = Application.InputBox("What Column Letter Are the QR links on?", "Input Box Text", Type:=2)
Jump1 = ActiveSheet.Range("" & HTML & Row).Column - ActiveSheet.Range("" & Name & Row).Column
Jump2 = ActiveSheet.Range("" & Link & Row).Column - ActiveSheet.Range("" & Name & Row).Column



Range("" & Name & Row).Activate
Do While Not IsEmpty(ActiveCell.Offset(0, 1))
MyFile = ActiveCell.Value & ".txt"
fnum = FreeFile()
Open MyFile For Output As fnum
Print #fnum, ActiveCell(0, Jump1)
Close #fnum


Application.ScreenUpdating = False
With ActiveSheet.Range("ActiveCell(0,Jump2")
Set Pic = .Parent.Pictures.Insert(.Value)
With .Offset(, 1)
Pic.Top = .Top
Pic.Left = .Left
Pic.Height = .Height
Pic.Width = .Width
End With
End With

Application.ScreenUpdating = True
ActiveCell.Offset(1, 0).Select
Loop

MsgBox "finished"
End Sub

 

[SamuelS]

I've decided to build all the functions before Putting them together and I've finished all but the picture one. Here is the function I have right now. Any tips/ideas how to get it to work? It doesn't give me any errors but it isn't doing what I want still.

 Sub GetPicBeta()

Dim Pic As Picture
Application.ScreenUpdating = False
    Range("O2").Activate
    Do While Not IsEmpty(ActiveCell.Offset(0, 1))
        With Cell
            Set Pic = .Parent.Pictures.Insert(.Value)
            With .Offset(, 1)
                Pic.Top = .Top
                Pic.Left = .Left
                Pic.Height = .Height
                Pic.Width = .Widt
            End With
        End With
    ActiveCell.Offset(1, 0).Select
    Loop
    
    Application.ScreenUpdating = True
    MsgBox "finished"
End Sub

 

[SamuelS]

Okay, I now have the names of the parts stored in the B column and the urls I want to get pictures from located on the O Column, but I cannot seem to find a way to save them to a .png file.
As a test I sucessfully taken the image from the url and put the image in the P column, but that doesn't really help me since I haven't been able to find a way to save the images as individual files. I also noticed that when I put the image in the cell it resized it to fit the cell area. Does that mean if I try to save it from excel rather than the url alone it will be in really bad resolution?

Here is the code I am using the get the cell out of the URL into excel if it helps.

Sub UrlPic()


Dim pic As String
Dim MyPicture As Picture
Dim rng As Range
Dim ct As Range


Row = Application.InputBox("What Row Does the Data Start on?", "Input Box Text", Type:=2)
Name = Application.InputBox("What Column Letter Are the Part Names On?", "Input Box Text", Type:=2)
Jump = ActiveSheet.Range("" & HTML & Row).Column - ActiveSheet.Range("" & Name & Row).Column


Do While Not IsEmpty(ActiveCell.Offset(0, 1))
    pic = ct.Offset(0, -1)

        Set MyPicture = ActiveSheet.Pictures.Insert(pic)
        '
        With MyPicture
            .ShapeRange.LockAspectRatio = msoFalse
            .Width = ct.Width
            .Height = ct.Height
            .Top = Rows(ct.Row).Top
            .Left = Columns(ct.Column).Left
        End With
        '

Loop

End Sub

I will say this is more of a frankenstein monster of code I found online rather than something I just wrote entirely on my own.

 

[SamuelS]

Option Explicit
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
Dim Ret As Long
'~~> This is where the images will be saved. Change as applicable
Const FolderName As String = "C:\"



Sub FinalV2()


Dim rng As Range
Dim ws As Worksheet
Dim LastRow As Long, i As Long
Dim strPath As String
Dim Row As Integer
Dim Name As String
Dim HTML As String
Dim Tag As String
Dim Link As String
Dim Jump As Integer
Dim Jump2 As Integer
Dim Jump3 As Integer
Dim Cell As Range
Dim Pic As Picture
Dim MyFile As String
Dim fnum As String


Row = Application.InputBox("What Row Does the Data Start on?", "Input Box Text", Type:=2)
Name = Application.InputBox("What Column Letter Are the Part Names On?", "Input Box Text", Type:=2)
Tag = Application.InputBox("What Column Letter Are the Tag codes on?", "Input Box Text", Type:=2)
HTML = Application.InputBox("What Column Letter Are the HTML codes on?", "Input Box Text", Type:=2)
Jump2 = ActiveSheet.Range("" & HTML & Row).Column - ActiveSheet.Range("" & Name & Row).Column
Jump = ActiveSheet.Range("" & Tag & Row).Column - ActiveSheet.Range("" & Name & Row).Column

Set rng = Application.InputBox("Select the Range of the URLs.", "Range Select", Type:=8)
Jump3 = rng.Column - ActiveSheet.Range("" & Name & Row).Column
Application.ScreenUpdating = False
    For Each Cell In rng
        With Cell
            Set Pic = .Parent.Pictures.Insert(.Value)
            With .Offset(, 1)
                Pic.Top = .Top
                Pic.Left = .Left
                Pic.Height = 250
                Pic.Width = 250
            End With
        End With
    Next Cell
    
    Set ws = ActiveSheet
    LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
    For i = Row To LastRow '<~~ 2 because row 1 has headers
        strPath = FolderName & (ws.Range("" & Name & i).Value) & "QR.png"
        Ret = URLDownloadToFile(0, ws.Range("B" & i).Value, strPath, 0, 0)
    Next i
Range("" & Name & Row).Activate
Do While Not IsEmpty(ActiveCell.Offset(0, 1))
    MyFile = ActiveCell.Value & " Tag.html"
    fnum = FreeFile()
    Open MyFile For Output As fnum
    Print #fnum, ActiveCell(1, Jump + 1)
Close #fnum
ActiveCell.Offset(1, 0).Select
Loop
Range("" & Name & Row).Activate
Do While Not IsEmpty(ActiveCell.Offset(0, 1))
    MyFile = ActiveCell.Value & ".html"
    fnum = FreeFile()
    Open MyFile For Output As fnum
    Print #fnum, ActiveCell(1, Jump + 1)
Close #fnum
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
MsgBox "Done"
End Sub

It runs through the whole code, can anyone tell me why it doesn't save any .png files?

 

[SamuelS]

Can anyone help me with this? I'm starting to get tunnel vision on the project and could use some different opinions.