Option Explicit
Dim rng As Range
Dim cell As Range
Dim Filename As String
Sub URLPictureInsert()
Dim theShape As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = False
' Set to the range of cells you want to change to pictures
Set rng = ActiveSheet.Range("D2:D3")
For Each cell In rng
Filename = cell
' Use Shapes instead so that we can force it to save with the document
Set theShape = ActiveSheet.Shapes.AddPicture( _
Filename:=Filename, linktofile:=msoFalse, _
savewithdocument:=msoCTrue, _
Left:=cell.Left, Top:=cell.Top, Width:=60, Height:=60)
If theShape Is Nothing Then GoTo isnill
With theShape
.LockAspectRatio = msoTrue
' Shape position and sizes stuck to cell shape
.Top = cell.Top + 1
.Left = cell.Left + 1
.Height = cell.Height - 2
.Width = cell.Width - 2
' Move with the cell (and size, though that is likely buggy)
.Placement = xlMoveAndSize
End With
' Get rid of the
cell.ClearContents
isnill:
Set theShape = Nothing
Range("D2").Select
Next
Application.ScreenUpdating = True
Debug.Print "Done " & Now
End Sub
Mostly, the stated code can help me to transfer the urls to images. But some urls won't work.
such as this link:
https://www.revolvecn888.com/images/p4/n/d/AGOL-WJ95_V1.jpg
it can not be transfered to images.
Related
Hi there I have the code below which calls "Delete_Image_Click" and deletes the shape in a specified cell range and then inserts a new image from a selected filepath into the same cell range.
I need to then delete images in other ranges (on the same worksheet and other worksheets) and then add the same image into the other cell ranges on the same worksheet and then go into another named worksheet and insert the same image into two more ranges.
Could anyone help me with how I go about this?
Sub RectangleRoundedCorners6_Click()
Call Delete_Image_Click
Dim sPicture As String, pic As Picture
sPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif; *.png), *.gif;*.png; *.jpg; *.bmp; *.tif", _
, "Select Picture to Import")
If sPicture = "False" Then Exit Sub
Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic
.ShapeRange.LockAspectRatio = msoTrue
.Height = Range("Q36:W41").Height
.Top = Range("Q36:W41").Top
.Left = Range("Q36:W41").Left
.Placement = xlMoveAndSize
End With
Set pic = Nothing
End Sub
Sub Delete_Image_Click()
Dim xPicRg As Range
Dim xPic As Picture
Dim xRg As Range
Application.ScreenUpdating = False
Set xRg = Range("Q36:W41")
For Each xPic In ActiveSheet.Pictures
Set xPicRg = Range(xPic.TopLeftCell.Address & ":" & xPic.BottomRightCell.Address)
If Not Intersect(xRg, xPicRg) Is Nothing Then xPic.Delete
Next
Application.ScreenUpdating = True
End Sub
I'm trying to insert pictures into Excel files from entering the serial number in a cell.
I get a syntax error where it is trying to insert the pictures. Specifically where it says .Shapes.AddPicture.
Sub picture_insert()
Dim picBild As Picture
Dim blnAvailable As Boolean
Dim link As String
Dim Pattern As String
Dim Serial As String
Dim t As String
Dim P1 As String
Dim P2 As String
link = "\\chimera\home\hillerbr\My Documents\Index project\"
Pattern = Range("A14")
Serial = Range("B14")
t = ".jpg"
P1 = Range("C14")
P2 = Range("D14")
With Worksheets("Data Breakdown")
For Each picBild In .Pictures
If picBild.Name = "280.1" Then
'The picture already exists
blnVorhanden = True
Exit For
End If
Next picBild
'only execute if picture does not yet exist
If blnVorhanden = False Then
With .Shapes.AddPicture Filename := link & Pattern & Serial & P1 & t
.Name = Range("C14")
.ShapeRange.LockAspectRatio = msoFalse
.Width = 450
.Height = 500
.Left = Worksheets("Data Breakdown").Range("A10").Left
.Top = Worksheets("Data Breakdown").Range("G20").Top
End With
With .Shapes.AddPicture Filename := link & Pattern & Serial & P1 & t
.Name = Range("D14")
.ShapeRange.LockAspectRatio = msoFalse
.Width = 450
.Height = 500
.Left = Worksheets("Data Breakdown").Range("E10").Left
.Top = Worksheets("Data Breakdown").Range("G20").Top
End With
End If
End With
End Sub
Sub Image_Remove()
Dim picBild As Picture
With Worksheets("Data Breakdown")
For Each picBild In .Pictures
If picBild.Name = Range("C14") Then
picBild.Delete
Exit For
End If
Next picBild
For Each picBild In .Pictures
If picBild.Name = Range("D14") Then
picBild.Delete
Exit For
End If
Next picBild
End With
End Sub
Providing your variables point to a valid image I found the below code works.
Sub Test()
Dim sht As Worksheet
Set sht = Worksheets("Data Breakdown")
With sht
With .Shapes.AddPicture(Filename:=link & Pattern & Serial & P1 & t, _
LinkToFile:=True, SaveWithDocument:=True, _
Left:=.Range("A10").Left, Top:=.Range("G20").Top, Width:=450, Height:=500)
.Name = "ABC"
.LockAspectRatio = True
End With
End With
End Sub
The Help page for AddPicture says there's 7 required parameters.
I'm using the following script to turn image links into images on Excel sheet. It works great however I have to pull about 1000 images on a spreadsheet for a catalog. When that many images are on the workbook it lags so much even though the images appear tiny (but with original quality). So I'm wondering if anyone can help me adjust my script so the image quality or resolution is reduced. So basically turn a full size image into a small thumbnail that won't take up too much to load. Please let me adjust the resolution so I can test it myself. Here's my code. Appreciate any help!
Option Explicit
Dim rng As Range
Dim cell As Range
Dim Filename As String
Sub URLPictureInsert()
Dim theShape As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = False
Set rng = ActiveSheet.Range("A1:B500")
For Each cell In rng
Filename = cell
If InStr(UCase(Filename), "JPG") > 0 Then
ActiveSheet.Pictures.Insert(Filename).Select
Set theShape = Selection.ShapeRange.Item(1)
If theShape Is Nothing Then GoTo isnill
xCol = cell.Column + 1
Set xRg = Cells(cell.Row, xCol)
With theShape
.LockAspectRatio = msoFalse
.Width = 100
.Height = cell.Height
.Top = cell.Top + 1
.Left = cell.Left + 1
End With
isnill:
Set theShape = Nothing
Range("A1").Select
End If
Next
Application.ScreenUpdating = True
Debug.Print "Done " & Now
End Sub
I am extracting a excel table as png file the extraction is ok, but the extracted file is too zoomed out and when i zoom in it is all blurr, i am going to attach the image in a mail so the data should be clear visible,Any idea where to change the code ,changed the width and height below to almost 50 no change
With ChTemp.Parent
.Width = PicTemp.Width + 8
.Height = PicTemp.Height + 8
Here is the code
Sub check(filename As String, picturename As String)
Dim myWb As Workbook
Dim ws As Worksheet
Dim i, j As Long, LastRow As Integer
'Dim filename As String, picturename As String
Set myWb = Workbooks.Open(filename:=filename)
Worksheets("Sheet1").Activate
Dim FName As String
FName = picturename
Dim pic_rng As Range
Dim ShTemp As Worksheet
Dim ChTemp As Chart
Dim PicTemp As Picture
Application.ScreenUpdating = False
Set pic_rng = ActiveSheet.Range("A2:N42")
Set ShTemp = Worksheets.Add
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name
Set ChTemp = ActiveChart
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ChTemp.Paste
Set PicTemp = Selection
With ChTemp.Parent
.Width = PicTemp.Width + 8
.Height = PicTemp.Height + 8
End With
ChTemp.Export filename:=picturename, FilterName:="jpg"
'UserForm1.Image1.Picture = LoadPicture(FName)
Kill FName
Application.DisplayAlerts = False
ShTemp.Delete
myWb.Close False
End Sub
The selection in your case is the Chart itself, and nothing will be increase n its dimensions. And the code must paste the picture in the increased chart... Otherwise, any increase does not help.
Try the next way, please:
'what you have in your code...
'.....
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With ChTemp.Parent
.Width = rng.Width + 10
.Height = rng.Height + 10
End With
ChTemp.Paste
ChTemp.Export filename:=picturename, FilterName:="jpg"
'your code...
'...
I have used some code that will allow a user to store a picture in the comments of a cell using:
Application.ActiveCell.AddComment.Shape.Fill.UserPicture (fName)
I now want to write something that iterates through the comments of a worksheet and exports all the pictures used above into separate picture files. I am not sure how to reach the right object to do this.
Thanks
Martin
I cobbled some code together from a few sources. How does this work?
Sub extractCommentImage()
'Borrowed from: https://excelribbon.tips.net/T011165_Moving_Comment_Background_Pictures_to_Cells.html
Dim cmt As Comment
Dim cel As Range
Dim bvisible As Boolean
For Each cmt In ActiveSheet.Comments
With cmt
bvisible = .Visible
.Visible = True
Set cel = .Parent.Offset(0, 1)
.Shape.CopyPicture appearance:=xlScreen, Format:=xlPicture
cel.PasteSpecial
selection.ShapeRange.LockAspectRatio = msoFalse
.Visible = bvisible
.Shape.Fill.OneColorGradient msoGradientFromCenter, 1, 1
End With 'cmt
Next cmt
ExportMyPicture
End Sub
And the "Export" sub:
Sub ExportMyPicture()
'borrowed from: https://stackoverflow.com/questions/18232987/export-pictures-from-excel-file-into-jpg-using-vba
Dim MyChart As String, MyPicture As String, pic As Object
Dim PicWidth As Long, PicHeight As Long, num As Long
Dim shtName as String
num = 1
Application.ScreenUpdating = False
shtName = ActiveSheet.Name
For Each pic In ActiveSheet.Pictures
MyPicture = pic.Name
With pic
PicHeight = .ShapeRange.Height
PicWidth = .ShapeRange.Width
End With
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=shtName
selection.Border.LineStyle = 0
MyChart = Split(ActiveChart.Name, " ")(1) & " 1"
With ActiveSheet
With .Shapes(MyChart)
.Width = PicWidth
.Height = PicHeight
End With
.Shapes(MyPicture).Copy
With ActiveChart
.ChartArea.Select
.Paste
End With
.ChartObjects(1).Chart.Export Filename:="C:\Users\[CHANGE THIS]\Desktop\MyPic " & num & ".jpg", FilterName:="jpg"
num = num + 1
.Shapes(MyChart).Cut
End With
Next pic
Application.ScreenUpdating = True
Exit Sub
End Sub