Inserting an Online Picture to Excel with VBA - vba

I'm currently working on a project and need to fill in cells with pictures via URLs. All URLs are in one column, and I'd like to load the images in an adjacent column. I'm no VBA expert, but I found some code that worked, but for some reason I get an error (usually 5 images in) that says:
Run-time error '1004':
Unable to get the Insert property of the Pictures Class
Again, I'm using a system where URLs are in one column i.e.:
xxxx.com/xxxx1.jpg
xxxx.com/xxxx2.jpg
xxxx.com/xxxx3.jpg
xxxx.com/xxxx4.jpg
Through some searching, I found that it could be linked to my Excel version (using 2010), though I'm not completely sure.
Here's the current code I'm using:
Sub URLPictureInsert()
Dim cell, shp As Shape, target As Range
Set Rng = ActiveSheet.Range("a5:a50") ' range with URLs
For Each cell In Rng
filenam = cell
ActiveSheet.Pictures.Insert(filenam).Select
Set shp = Selection.ShapeRange.Item(1)
With shp
.LockAspectRatio = msoTrue
.Width = 100
.Height = 100
.Cut
End With
Cells(cell.Row, cell.Column + 1).PasteSpecial
Next
End Sub
Any help would be much appreciated!
Original code source: http://www.mrexcel.com/forum/excel-questions/659968-insert-image-into-cell-url-macro.html

This is an almost identical solution that I posted about a month ago:
Excel VBA Insert Images From Image Name in Column
Sub InsertPic()
Dim pic As String 'file path of pic
Dim myPicture As Picture 'embedded pic
Dim rng As Range 'range over which we will iterate
Dim cl As Range 'iterator
Set rng = Range("B1:B7") '<~~ Modify this range as needed. Assumes image link URL in column A.
For Each cl In rng
pic = cl.Offset(0, -1)
Set myPicture = ActiveSheet.Pictures.Insert(pic)
'
'you can play with this to manipulate the size & position of the picture.
' currently this shrinks the picture to fit inside the cell.
With myPicture
.ShapeRange.LockAspectRatio = msoFalse
.Width = cl.Width
.Height = cl.Height
.Top = Rows(cl.Row).Top
.Left = Columns(cl.Column).Left
End With
'
Next
End Sub

I know this thread is 5 years old but just wanted to say it really helped me with a project.
I'm using VBA to bring in data from an orders database. When I click on an order from those results it brings in more details about the orders including an image URL.
The problem I had was that the code above was designed to add the image in place of the URL. I wanted to replace the image from a previous query with the image from the new query. After some tweaks I got it working but it was just laying a new image on top of the old image. In time my Excel file could get really big so here's my solution. The only problem I have right now is that it deletes my company's logo that I put on the sheet. There may be a way to be more selective, or I could just change the procedure to insert the logo from another sheet in the workbook every time it deletes pictures but that seems a bit cheesy.
Sub InsertPic()
Dim productImageUrl As String
Dim productImage As Picture 'Declare image picture object
Dim productImageUrlRng As Range 'Declare range object to contain image URL
Dim productImageRng As Range 'Location image will be placed
'Delete any existing pictures:
Set productImageRng = ActiveSheet.Range("J1:J15") 'Where I want to put the image
Set productImageUrlRng = Range("BA2") 'Cell containing image URL
productImageUrl = productImageUrlRng
productImageRng.Select
'productImageRng.Delete --Does not delete pictures in range
ActiveSheet.Pictures.Delete 'Delete existing images
Set productImage = ActiveSheet.Pictures.Insert(productImageUrl)
With productImage
.ShapeRange.LockAspectRatio = msoTrue
'.Width = productImageRng.Width
.Height = productImageRng.Height
' .Top = Rows(cl.Row).Top
' .Left = Columns(cl.Column).Left
End With
End Sub

Related

Align (distribute) images horizontally in Word with VBA macro

This is my first time writing macro in VBA. My goal is to write a VBA macro that will automatically align (distribute) all images in a Word document horizontally (next to each other) with a small margin on each side of every image. If there is not enough space to fit another image, I need it to go to the next row(just below previous images) and continue with the horizontal alignment of images.
I have searched a lot on the internet, but I haven't found a way to achieve this...
NOTE: My macro already contains code for making all images have the same height(while keeping the same aspect ratio), so I think dimensions shouldn't be a problem...
Here is a small example of what I want to achieve:
I tried using code for Horizontal alignment from this link: https://www.excelcampus.com/vba/align-space-distribute-shapes/
But I got the following result:
Margins are weird and shapes are aligned infinitely instead of going into the next row...
My Code:
Dim lCnt As Long
Dim dTop As Double
Dim dLeft As Double
Dim dWidth As Double
Const dSPACE As Double = 8 'Set space between shapes in points
lCnt = 1
Dim image As Shape
If ActiveDocument.Shapes.Count > 0 Then
For Each image In ActiveDocument.Shapes
With image
.WrapFormat.Type = wdWrapSquare
.LockAspectRatio = msoTrue
.Height = InchesToPoints(3)
If lCnt > 1 Then
.Top = dTop
.Left = dLeft + dWidth + dSPACE
End If
dTop = .Top
dLeft = .Left
dWidth = .Width
End With
lCnt = lCnt + 1
Next
End If
End Sub
Thanks in advance!
Inserting your images into a table with fixed cell dimensions won't achieve what you say you want, since the images clearly don't have the same aspect ratio. What you need to do is to convert them to inlineshapes so that Word can handle the line wrapping. For example:
Sub Demo()
Application.ScreenUpdating = False
Dim iShp As InlineShape
With ActiveDocument
Do While .Shapes.Count > 0
.Shapes(1).ConvertToInlineShape
Loop
For Each iShp In .InlineShapes
With iShp
.LockAspectRatio = True
.Height = InchesToPoints(3)
If .Range.Characters.Last.Next <> " " Then .Range.InsertAfter " "
End With
Next
End With
Application.ScreenUpdating = True
End Sub
You can adjust the vertical spacing between the images by changing the paragraph line spacing. Note too, that the horizontal alignment can be played around with by switching between left, centered and justified paragraph formats.
Since you are new to VBA I wanted to share a bit of code if you were to pursue a Table approach. The code below creates a single-row table that is fixed in width and will not expand width-wise unless you alter the individual cells. For demo purposes only, I insert the same picture into each cell to demonstrate that the image resizes automatically based on cell width.
Sub TableOfPictures()
Dim doc As Word.Document, rng As Word.Range
Dim Tbl As Word.Table, C As Long
Set doc = ActiveDocument
Set rng = Selection.Range
Set Tbl = rng.Tables.Add(rng, 1, 2, Word.WdDefaultTableBehavior.wdWord8TableBehavior)
Tbl.rows(1).Cells(1).Width = InchesToPoints(2)
Tbl.rows(1).Cells(2).Width = InchesToPoints(4.5)
For C = 1 To 2
Tbl.rows(1).Cells(C).Range.InlineShapes.AddPicture ("Y:\Pictures\Mk45 Gun Proj_Blast.jpg")
Next
End Sub

Excel Macro Adjustment - Want to insert a picture at a specific point

This code inserts a picture into my excel worksheet, from a specific folder, by entering the name of the picture into a cell. For example, if I was to enter a1.jpg into cell J4, I would then get an output of the image that I want from the folder to a cell that is one space to the right of J4.
The dilemma I'm having is that my excel template has various sized cells and I am trying to place the picture in a specific location but having a hard time. This is because the current code moves the picture by cells so if the cell is too long, the picture will be moved the whole length of the cell. I was wondering if this could be changed such that the image can be placed directly at a certain point and not designated by cells.
code credit goes to pokemon_Man
The code is as follows:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim imagePath, fileName, fullImagePath, newImageLoc As String
imagePath = "C:\YourFileLocationPath\"
If Target.Address = "$J$4" Then
fullImagePath = imagePath & Target.Value
newImageLoc = Target.Offset(, 1).Address
With ActiveSheet.Pictures.Insert(fullImagePath)
.Left = ActiveSheet.Range(newImageLoc).Left
.Top = ActiveSheet.Range(newImageLoc).Top
.Placement = 1
.PrintObject = True
End With
End
End If
End Sub
Try:
.Left = Target.Left + Target.Width / 2
.Top = Target.Top + Target.Height / 2

VBA Center picture in merged cells

I've been trying to fix this problem for a while. The following code inserts a picture from your choose to my excel document. It places the picture in cell B10 and resizes it to the height of one of my merged cells. Now the problem is that I can't get it centerd.
.Left = 35#
With the line above i can manually center one picture, but i want every other picture with other width's to be centerd aswell. Can anyone help me with this problem? The code below is what i've been using. Thanks in advance!
Sub Insert_Pic_Section_One()
Dim fileName1 As Variant
fileName1 = Application.GetOpenFilename(filefilter:="Tiff Files(*.tif;*.tiff),*.tif;*.tiff,JPEG Files (*.jpg;*.jpeg;*.jfif;*.jpe),*.jpg;*.jpeg;*.jfif;*.jpe,Bitmap Files(*.bmp),*.bmp", FilterIndex:=2, Title:="Choose picture", MultiSelect:=False)
If fileName1 = False Then
Exit Sub
Else
ActiveWorkbook.ActiveSheet.Select
Range("B10").Select
Dim picture1 As Object
Set picture1 = ActiveWorkbook.ActiveSheet.Pictures.Insert(fileName1)
With picture1
.Top = .Top
.Left = 35#
.Width = .Width
.Height = 233#
End With
End If
End Sub
No need to select anything. Because you use a merged cell you need to use .MergeArea otherwise it will only give you the height and width of the unmerged row and column.
Dim ws As Worksheet
Dim targetCell As Range
Dim picture1 As Picture
Set ws = ActiveSheet 'replace with actual worksheet if possible
Set targetCell = ws.Range("B10")
Set picture1 = ws.Pictures.Insert(fileName1)
With picture1
.Height = targetCell.MergeArea.Height 'set height first because width will change
.Top = targetCell.Top
.Left = targetCell.Left + (targetCell.MergeArea.Width - .Width) / 2
End With

Excel VBA to replace image, create PDF, move to next image in folder and repeat

I have an Excel worksheet that i use as a printable single page PDF report that contains an image with some text. In a column to the side I have a list of all the images in a specific folder and i would like to use VBA to cycle through the list replacing the image in the worksheet and creating a PDF to be stored in the same folder. I currently do this manually which is a pain and would like to automate it with VBA.
Any help would be greatly appreciated.
Thanks in advance.
The code i use manualy by changing the full path of the image to be replaced is as follows>
Sub AddPicturesFULL()
Dim myPic As Picture
Dim wkSheet As Worksheet
Dim myRng As Range
Dim myCell As Range
Dim rowCount As Long
Dim rowCount2 As Long
Dim Pic As Object
Set wkSheet = Sheets("REPORT(FULL)") ' -- Change to your sheet
For Each Pic In wkSheet.Pictures
Pic.Delete
Next Pic
'-- The usual way of finding used row count for specific column
rowCount2 = wkSheet.Cells(wkSheet.Rows.Count, "N").End(xlUp).Row
If rowCount2 <> 0 Then
Set myRng = wkSheet.Range("N2", wkSheet.Cells(wkSheet.Rows.Count, "N").End(xlUp))
For Each myCell In myRng.Cells
If Trim(myCell.Value) = "" Then
'MsgBox "No file path"
ElseIf Dir(CStr(myCell.Value)) = "" Then
MsgBox myCell.Value & " Doesn't exist!"
Else
'myCell.Offset(0, 1).Parent.Pictures.Insert (myCell.Value)
Set myPic = myCell.Parent.Pictures.Insert(myCell.Value)
With myCell.Offset(0, -13) '1 columns to the right of C ( is D)
'-- resize image here to fit into the size of your cell
myPic.Top = .Top
myPic.Width = .Width
myPic.Height = 640
myPic.Left = .Left
myPic.Placement = xlMoveAndSize
myPic.SendToBack
End With
End If
Next myCell
Else
MsgBox "There is no file paths in your column"
End If
End Sub
Create an ActiveX Image on the Sheet instead of using drawing Pictures
Then you can use
Dim i As Integer
For i = 1 To 20 Step 1
imgTest.Picture = LoadPicture(Sheets("Sheet1").Cells(i, COLUMN).Value)
Sheets("Sheets1").ExportAsFixedFormat Type:=xlTypePDF, Filename:="C:\test" & i & ".pdf", Quality:=xlQualityStandard
Next i
To loop through the column with imagepaths and set the image for each of them. Then just export it as a PDF.
Of course you have to adjust the i values and COLUMN to your needs.

pasting a picture in a specified range with vba

I have this following code. I want to paste this copied Picture to a range which i select in Destinationsheet. However i only know how to set the Location by selecting .top , .left , .width , .height . Is there a way to paste this Picture in a selected range such as G30:J:30 ?
Windows(osman).Activate
Sheets("Overview").Range("A30:D37").CopyPicture
Dim DestinationSheet As Worksheet
Set DestinationSheet = Workbooks(anan).Sheets("Eingabefeld")
DestinationSheet.Paste
Dim pastedPic As Shape
Set pastedPic = DestinationSheet.Shapes(1)
With pastedPic
.Top = DestinationSheet.Cells(17, 2).Top
'Rest of positioning code here
End With
this code is very close to what I want,
I want to copy a range, as an image and insert it in a different sheet and size it to the outer boundries of a cell range.
All is well, apart from one ghlitch, when the routine runs the
"Set pastedPic = DestinationSheet.Shapes(1)" it picks up the last selected and the one before that object, ending in sizing the inserted picture and the shape before last...
the way I manage to get some consistant results, was to change (1) to (2) the one before that, which apparently seens to be the copied entity...
go figure...
I tested this and it worked for me. If you have a multicell range object you can get the width and height. If you don't change the .LockAspectRatio = msoFalse your picture may adjust itself.
Dim r As Range
Set r = Me.Range("G30:J30")
With pastedPic
.LockAspectRatio = msoFalse
.Top = r.Top
.Left = r.Left
.Width = r.Width
.Height = r.Height
End With
I tried you code this is what I came up with. For the copy picture line I actually copy a picture of the cells not a particular picture within those cells. Is that what you expected?
One other change was I used ThisWorkbook instead of your workbook index. Adjust as necessary
Sub test()
Dim pastedPic As Shape
Dim DestinationSheet As Worksheet
Dim desitinationRange As Range
Set DestinationSheet = ThisWorkbook.Sheets("Eingabefeld")
Sheets("Overview").Range("A30:D37").CopyPicture
DestinationSheet.Paste
Set pastedPic = DestinationSheet.Shapes(1)
Set desitinationRange = Me.Range("G30:J30")
With pastedPic
.LockAspectRatio = msoFalse
.Top = desitinationRange.Top
.Left = desitinationRange.Left
.Width = desitinationRange.Width
.Height = desitinationRange.Height
End With
End Sub
once copying the chart, can do this way:
Sheets("Sheet1").Select
Range("A1:H14").Select
ActiveSheet.Paste
ActiveChart.Parent.Width = Range("A1:H14").Width
ActiveChart.Parent.Height = Range("A1:H14").Height