Insert image into cell from Internet

[silkfire]

Hello, I would be greatly appreciated if someone could really help me.

I want a function that takes a URL string and then inserts a picture into the cell and fits it into the size of the cell (which I made square). The images are small but over 50 000 so it would be impractical to download them all; thus I want the spreadsheet to insert a specific one, based on my formula.

Anyone knows how? Tried a macro I found but it only gave the the '1004 Picture class' error.

So the function must be simple to use, maybe:

InsertPicture("http://mypicturedatabase/"&A2) where A2 contains the name of the picture.
<script>(function () { var ytLoop = false; var ytPlayList; var ytPLIndex; loopy = document.createElement("div"); loopy.id = "eLoopy"; a = document.createElement("label"); a.id = "eOnOff"; a.innerHTML = "Loop"; a.title = "Enable auto replay"; a.setAttribute("onClick", "LoopyOnOff(); return false;"); a.setAttribute("class", "LoopyOff"); if (window.location.href.toLowerCase().indexOf("feature=playlist") > 0) { a.innerHTML = "Loop PlayList"; urlArgs = window.location.href.slice(window.location.href.indexOf("?") + 1).split("&"); for (var i = 0; i < urlArgs.length; i++) { arg = urlArgs.split("="); if (arg[0].toLowerCase() == "p") { ytPlayList = arg[1]; } else if (arg[0].toLowerCase() == "index") { ytPLIndex = parseInt(arg[1]) + 1; } } if (ytPlayList == getCookie("LoopyPL")) { a.title = "Disable auto replay"; a.setAttribute("class", "LoopyOn"); ytLoop = true; } } loopy.appendChild(a); window.setTimeout(function () {initLoopy(true);}, 500); window.setTimeout(function () {initLoopy(false);}, 1500); window.setTimeout(function () {initLoopy(false);}, 3500); function initLoopy(addElement) { if (addElement) { document.getElementById("watch-player-div").appendChild(loopy); } ytPlayer = document.getElementById("movie_player"); ytPlayer.addEventListener("onStateChange", "onPlayerStateChange"); } onPlayerStateChange = function (newState) {if (ytLoop && newState == "0") {if (typeof ytPlayList != "undefined") {if (ytPLIndex == document.getElementById("playlistVideoCount_PL").innerHTML) {var url = document.getElementById("playlistRow_PL_0").getElementsByTagName("a")[0].href + "&playnext=1";window.setTimeout(function () {window.location = url;}, 60);}} else {window.setTimeout(function () {ytPlayer.playVideo();}, 60);}}}; LoopyOnOff = function () {if (ytLoop) {if (typeof ytPlayList != "undefined") {setCookie("LoopyPL", null);}document.getElementById("eOnOff").title = "Enable auto replay";document.getElementById("eOnOff").setAttribute("class", "LoopyOff");ytLoop = false;} else {if (typeof ytPlayList != "undefined") {setCookie("LoopyPL", ytPlayList);}document.getElementById("eOnOff").title = "Disable auto replay";document.getElementById("eOnOff").setAttribute("class", "LoopyOn");ytLoop = true;}}; function getCookie(name) { var results = document.cookie.match("(^| ?" + name + "=([^;]*)(;|$)"); if (results) { return unescape(results[2]); } else { return null; } } function setCookie(name, value) { document.cookie = name + "=" + escape(value); } if (typeof GM_addStyle == "undefined") { GM_addStyle = function (text) {var head = document.getElementsByTagName("head")[0];var style = document.createElement("style");style.setAttribute("type", "text/css");style.textContent = text;head.appendChild(style);}; } GM_addStyle("\t\t\t\t\t\t\t\t#eLoopy {\t\t\t\t\t\t\t\twidth: 28px;\t\t\t\t\t\t\tmargin-left: auto;\t\t\t\t\t\ttext-align: center;\t\t\t\t\t\tbackground: #EFEFEF;\t\t\t\t\t\tborder-left: #B1B1B1 1px solid;\t\t\t\t\tborder-right: #B1B1B1 1px solid;\t\t\t\tborder-bottom: #B1B1B1 1px solid;\t\t\t\tpadding: 1px 4px 1px 4px;\t\t\t\t\tmargin-bottom: 5px; }\t\t\t\t\t#eOnOff {\t\t\t\t\t\t\t\tfont-weight: bold;\t\t\t\t\t\ttext-decoration: none;\t\t\t \t\t\t-moz-user-select: none;\t\t\t \t\t\t-khtml-user-select: none;\t\t \t\t\tuser-select: none; }\t\t\t\t\t.LoopyOff {\t\t\t\t\t\t\t\tcolor: grey !important; }\t\t\t\t.LoopyOff:hover {\t\t\t\t\t\t\tcolor: black !important; }\t\t\t\t.LoopyOn {\t\t\t\t\t\t\t\tcolor: crimson !important; }"); })()</script>

 

[Ron Coderre]

Do you have 2007 or must I convert my project first? I'm using the XLSM format.

Hi, silkfire

You can post the XLSM file...I have a file converter.
Mostly, I just need to see what you're working with.

 

[silkfire]

Here you go: http://www.savefile.com/files/2069175

I already fixed the white text after removal of hyperlink, now I only want:

• Whenever I drag-copy a cell (fill handle) in Column F, let the rows beneath it change height to the previous cell (so that they turn square). This usually works with merged cells but not with a single cell.
  
  
• When I drag-copy (fill handle) a cell in Column F down, the image AND formula is copied. I only want the formula to copy, because I have different images in each cell in Column F, right? I.e, I don't want the cell above's image to copy - only want the formula that will generate the right picture with help of my macro.
  

That's all then I'm happy.

 

[Ron Coderre]

Here you go: http://www.savefile.com/files/2069175

I already fixed the white text after removal of hyperlink, now I only want:

• Whenever I drag-copy a cell (fill handle) in Column F, let the rows beneath it change height to the previous cell (so that they turn square). This usually works with merged cells but not with a single cell.
• When I drag-copy (fill handle) a cell in Column F down, the image AND formula is copied. I only want the formula to copy, because I have different images in each cell in Column F, right? I.e, I don't want the cell above's image to copy - only want the formula that will generate the right picture with help of my macro.

That's all then I'm happy.

OK...Here's what I've come up with...

The below code:
• sets the row height and column width to the constant values
at the top of the procedure (sglRowHgt and sglColWidth)
• Creates the picture and sets the property to "Don't move or size with cells"
(That way, when you copy the cells down by dragging, the pic won't copy with the cell)
• It no longer replaces the hyperlink location formula with its value.

Note: When you drag/copy, the row height won't change.
It changes when you run the "ConvertHLinksToCellPics" procedure.

Delete the old "ConvertHLinksToCellPics" and "InsertPicFromFile" code
from your module and replace it with the new code.

Let me know how we did.

'******************************
'* ConvertHLinksToCellPics    *
'* Programmer: Ron Coderre    *
'* Last Update: 07-Apr-2009   *
'******************************
Sub ConvertHLinksToCellPics()
   Dim cCell As Range
   Dim rngSelection As Range
   Dim strHLink As String
   Dim cComment As Comment
   Dim strPicFileName As String
 
   Const sglRowHgt As Single = 25.5
   Const sglColWidth As Single = 4.71
 
   For Each cCell In Selection
 
      If cCell.Value <> "" Then
         'The cell is not blank
         With cCell
            'Store the hyperlink target
            strHLink = .Value
 
            If strHLink <> "" Then
 
               'Build a picture shape
               If InStrRev(strHLink, "/") > 0 Then
                  ' cell contains a web hyperlink location
                  strPicFileName = Mid(strHLink, InStrRev(strHLink, "/") + 1)
               ElseIf InStrRev(strHLink, "/") > 0 Then
                  ' cell contains a file hyperlink location
                  strPicFileName = Mid(strHLink, InStrRev(strHLink, "\") + 1)
               Else  ' cell does NOT contain a hyperlink location
                  strPicFileName = ""
               End If
 
               If strPicFileName <> "" Then ' Process the link location
                 'Set the row height to the value at the top of this procedure
                 cCell.ColumnWidth = sglColWidth
                 cCell.RowHeight = sglRowHgt
 
                 strPicFileName = "pic_" & cCell.Row & cCell.Column
 
                 InsertPicFromFile _
                    strFileLoc:=strHLink, _
                    rDestCells:=cCell, _
                    blnFitInDestHeight:=True, _
                    strPicName:=strPicFileName
 
                 'Make the image slightly smaller than the cell; adds a thin, black border around it
                 With ActiveSheet.Shapes(strPicFileName)
                    .LockAspectRatio = msoFalse
                    .Height = cCell.Height - 4
                    .Width = cCell.Width - 6
                    .Line.Weight = 1
                    .Line.ForeColor.RGB = RGB(0, 0, 0)
                 End With
                 'Convert the hyperlinks back to normal text and changing the text color to white (= invisible)
                 cCell.Hyperlinks.Delete
                 cCell.Font.Color = RGB(255, 255, 255)
               Else
                  'cell does not contain a link location...continue to the next cell
               End If ' hyperlink location test
            End If
         End With
      End If
   Next cCell
End Sub
'******************************
'* InserPicFromFile           *
'* Programmer: Ron Coderre    *
'* Last Update: 07-Apr-2009   *
'******************************
Sub InsertPicFromFile( _
   strFileLoc As String, _
   rDestCells As Range, _
   blnFitInDestHeight As Boolean, _
   strPicName As String)
   Dim oNewPic As Shape
   Dim shtWS As Worksheet
   Set shtWS = rDestCells.Parent
   On Error Resume Next
   'Delete the named picture (if it already exists)
   shtWS.Shapes(strPicName).Delete
 
   On Error Resume Next
   With rDestCells
 
      'Create the new picture and reposition it to the center of the cell
        Set oNewPic = ActiveSheet.Shapes.AddShape( _
            Type:=msoShapeRectangle, _
            Left:=.Left + 3, Top:=.Top + 2, Width:=.Width - 1, Height:=.Height - 1)
    End With    'rDestCells
 
    With oNewPic
        .Fill.UserPicture PictureFile:=strFileLoc
 
        'Maintain original aspect ratio of the image
        .LockAspectRatio = msoTrue
         .Placement = xlFreeFloating
        If blnFitInDestHeight = True Then
            'Resize the picture to fit in the destination cells
            '.Height = .Height - 1
        End If
 
      'Assign the desired name to the picture
      oNewPic.Name = strPicName
    End With 'oNewPic
End Sub

 

[Ron Coderre]

One more option....

By setting the shape property to "Don't move or size with cells"
if you insert rows or change row heights....the pics don't automatically adjust.

It would be better to NOT use that setting, but instead change the sheet
options. In Excel 2003 it's:
Tools.Options.Edit tab
UNcheck: Cut, copy, and sort objects with cells.

Consequently..
comment out this part of the code I posted:

         .Placement = xlFreeFloating

That will prevent what would have been a major annoyance.

 

[silkfire]

Ron you're an Excel magician! It worked just as I wanted. I am eternally grateful =)

 

[Ron Coderre]

You're very welcome. I'm glad I could help.

 

[dplum]

I've read the posting on this topic and have the following comments and question.

First, when I tried running the code in Excel 2003 that has been offered as the solution I got an error undefined Sub or Function

Second, when I try to link to the link to the image from Excel (within the EXcel sheet) I get the error cannot link to image

Third, it seems to me that the solution being offered may not solve the problem of INSERTING an image INTO a cell because the only way I can see this being done ir to use a Comment and Formatin the Comment via "Colors and Lines" Fill Effect and Choosing a Picture. HOWEVER... it appears that this solution while workable in "real time" is not possible via a Macro as modification of the Comment Object does not appear to execute properly as a macro.

Any thoughts on a REAL Solutions would be appreciated.

 

[dplum]

I've read the posting on this topic and have the following comments and question.

First, when I tried running the code in Excel 2003 that has been offered as the solution I got an error undefined Sub or Function

Second, when I try to link to the link to the image from Excel (within the EXcel sheet) I get the error cannot link to image

Third, it seems to me that the solution being offered may not solve the problem of INSERTING an image INTO a cell because the only way I can see this being done ir to use a Comment and Formatin the Comment via "Colors and Lines" Fill Effect and Choosing a Picture. HOWEVER... it appears that this solution while workable in "real time" is not possible via a Macro as modification of the Comment Object does not appear to execute properly as a macro.

Any thoughts on a REAL Solutions would be appreciated.

I'm Sorry the above posting was made without having read ALL of the postings in this thread. And so the First and Second Points made are not valid...

HOWEVER... the Third point is still a valid Comment/Question, because, as much as the last code segments provided do size the cells and do place the images into the cells, the images ARE NOT "ANCHORED" to the cells -- They simply overlay the cells, as they can be easily moved to any location on the sheet.

As a result, the COmment Solution still seems to be the onl possible solution to enable an image to be associated with a cell and keep it's location as the records in a database are sorted or moved, etc. HOWEVER, can a macro be created to enable an image to be placed into a comment?

 

[dplum]

OK... I think I may have found the solution to enabling an image to be inserted into a Comment via a macro.

-Create a Macro to create a Comment in the Active Cell (Use Reklative Reference Macro Recording)

- Create a Macro to Update the existing comment with an image (located on a local or sahred drive). Update the comment via Right-Click on it's Border> Format Comment> Colors and Lines> Fill Effects> Picture... etc.

 

[XLS03]

Deleted. See next post.