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
Related
I need to know how to get FindNext working in my code. It finds the photo inserts it into the column where the code matches, however it does not find the next code in the worksheet, so it keeps overwriting the photos in the first find. Where I have put the comment find next photo1 is where it should be going?
Private Sub cmdInsertPhoto1_Click()
'insert the photo1 from the folder into each worksheet
Dim ws As Worksheet
Dim fso As FileSystemObject
Dim folder As folder
Dim rng As Range, cell As Range
Dim strFile As String
Dim imgFile As String
Dim localFilename As String
Dim pic As Picture
Dim findit As String
Dim finditfirst As String
Application.ScreenUpdating = True
'delete the two sheets if they still exist
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "PDFPrint" Then
Application.DisplayAlerts = False
Sheets("PDFPrint").Delete
Application.DisplayAlerts = True
End If
Next
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "DataSheet" Then
Application.DisplayAlerts = False
Sheets("DataSheet").Delete
Application.DisplayAlerts = True
End If
Next
Set fso = New FileSystemObject
Set folder = fso.GetFolder(ActiveWorkbook.Path & "\Photos1\")
'Loop through all worksheets
For Each ws In ThisWorkbook.Worksheets
ws.Select
Set rng = Range("A:A")
For Each cell In rng
If cell = "CG Code" Then
'find the next adjacent cell value of CG Code
strFile = cell.Offset(0, 1).Value 'the cg code value
imgFile = strFile & ".png" 'the png imgFile name
localFilename = folder & "\" & imgFile 'the full location
'find Photo1 cell and select the adjacent cell to insert the image
findit = Range("A:A").Find(what:="Photo1", MatchCase:=True).Offset(0, 1).Select
ActiveCell.EntireRow.RowHeight = 200 'max row height is 409.5
Set pic = ws.Pictures.Insert(localFilename)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Width = 200
.ShapeRange.Height = ActiveCell.MergeArea.Height
.ShapeRange.Top = ActiveCell.MergeArea.Top
.ShapeRange.Left = ActiveCell.MergeArea.Left
.Placement = xlMoveAndSize
End With
'find next photo1
End If
'delete photo after insert
'Kill localFilename
Next cell
Next ws
Application.ScreenUpdating = True
' let user know its been completed
MsgBox ("Worksheets created")
End Sub
Scan column A for both "Photo1" and "CG Code" values to build collections for each. Then iterate the collections to insert the images.
Option Explicit
Private Sub cmdInsertPhoto1_Click()
Dim wb As Workbook, ws As Worksheet, fso As FileSystemObject
Dim rng As Range, cell As Range, pic As Picture
Dim folder As String, imgFile As String
Dim lastrow As Long, i As Long, n As Long
Dim colImages As Collection, colPhotos As Collection
Set colImages = New Collection
Set colPhotos = New Collection
Set fso = New FileSystemObject
Set wb = ActiveWorkbook
folder = wb.Path & "\Photos1\"
Application.ScreenUpdating = False
For Each ws In wb.Sheets
'delete the two sheets if they still exist
If ws.Name = "PDFPrint" Or ws.Name = "DataSheet" Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
Else
' find images and photos
lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
For Each cell In ws.Range("A1:A" & lastrow)
If cell = "CG Code" Then
imgFile = folder & cell.Offset(0, 1) & ".png"
' check exists
If fso.FileExists(imgFile) Then
colImages.Add imgFile
Else
MsgBox imgFile & " not found", vbCritical
Exit Sub
End If
ElseIf cell = "Photo1" Then
colPhotos.Add "'" & ws.Name & "'!" & cell.Offset(0, 1).Address
End If
Next
End If
Next
' copy images to sheets
For i = 1 To colImages.Count
imgFile = colImages(i)
If i <= colPhotos.Count Then
Set cell = Range(colPhotos(i))
cell.RowHeight = 200 'max row height is 409.5
Set pic = cell.Parent.Pictures.Insert(imgFile) ' ws
With pic.ShapeRange
.LockAspectRatio = msoFalse
.Width = 200
.Height = cell.MergeArea.Height
.Top = cell.MergeArea.Top
.Left = cell.MergeArea.Left
pic.Placement = xlMoveAndSize
End With
n = n + 1
Else
MsgBox "No location for " & imgFile, vbCritical, i
Exit Sub
End If
Next
Application.ScreenUpdating = True
' let user know its been completed
MsgBox n & " images inserted ", vbInformation
End Sub
I am having an issue getting the row height to adjust in Excel to the inserted image. I have tried cell.EntireRow = pic.Height but it does not adjust the row to match image height. It loops through several worksheets to find the code then selects the next empty cell to it so the image gets inserted there. Also not sure if this is the correct way to go through the entire worksheet as the is usually more that one Photo1 in there. If I can get this figured out, I can do the photo2 and photo3 using whatever solution is found.
Here is my code
Private Sub cmdInsertPhoto1_Click()
'insert the photo1 from the folder into each worksheet
Dim ws As Worksheet
Dim fso As FileSystemObject
Dim folder As folder
Dim rng As Range, cell As Range
Dim strFile As String
Dim imgFile As String
Dim localFilename As String
Dim pic As Picture
Dim findit As String
Application.ScreenUpdating = True
'delete the two sheets if they still exist
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "PDFPrint" Then
Application.DisplayAlerts = False
Sheets("PDFPrint").Delete
Application.DisplayAlerts = True
End If
Next
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "DataSheet" Then
Application.DisplayAlerts = False
Sheets("DataSheet").Delete
Application.DisplayAlerts = True
End If
Next
Set fso = New FileSystemObject
Set folder = fso.GetFolder(ActiveWorkbook.Path & "\Photos1\")
'Loop through all worksheets
For Each ws In ThisWorkbook.Worksheets
ws.Select
Set rng = Range("A:A")
ws.Unprotect
For Each cell In rng
If cell = "CG Code" Then
'find the next adjacent cell value of CG Code
strFile = cell.Offset(0, 1).Value 'the cg code value
imgFile = strFile & ".png" 'the png imgFile name
localFilename = folder & "\" & imgFile 'the full location
'just find Photo1 cell and select the adjacent cell to insert the image
findit = Range("A:A").Find(what:="Photo1", MatchCase:=True).Offset(0, 1).Select
Set pic = ws.Pictures.Insert(localFilename)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Width = 200
.ShapeRange.Height = 200 'max row height is 409.5
.Placement = xlMoveAndSize
End With
cell.EntireRow = pic.Height
End If
'delete photo after insert
'Kill localFilename
Next cell
Next ws
Application.ScreenUpdating = True
' let user know its been completed
MsgBox ("Worksheets created")
End Sub
What it currently looks like
You have to use the rowheight property of the range object: cell.EntireRow.RowHeight= pic.Height
As you wrote it (cell.EntireRow = pic.Height) you implicitly used the default property of cell.EntireRow which is value)
Managed to solve it. for anyone else its cell was selected so, this works for me:
'just find Photo1 cell and select the adjacent cell to insert the image
findit = Range("A:A").Find(what:="Photo1", MatchCase:=True).Offset(0, 1).Select
ActiveCell.EntireRow.RowHeight = 200 'max row height is 409.5
Set pic = ws.Pictures.Insert(localFilename)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Width = 200
'.ShapeRange.Height = 200 'max row height is 409.5
.ShapeRange.Height = ActiveCell.MergeArea.Height
.ShapeRange.Top = ActiveCell.MergeArea.Top
.ShapeRange.Left = ActiveCell.MergeArea.Left
.Placement = xlMoveAndSize
End With
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.
Given a workbook like this one:
I need to add the logo from cell A2 - worksheet A, in the footer of worksheets B,C.
Here's the code I've found and modified a little bit but it is not working.
Sub Logo()
Dim printWorksheet As Worksheet
Dim logoShape As Shape
Dim tempImageFile As String
Set printWorksheet = ThisWorkbook.ActiveSheet
Set logoShape = ThisWorkbook.Sheets("A").Shapes("myLogo")
tempImageFile = Environ("temp") & Application.PathSeparator & "image.jpg"
Save_Object_As_Picture logoShape, tempImageFile
With printWorksheet.PageSetup
.RightHeaderPicture.FileName = tempImageFile
.RightHeader = "&G"
End With
I have found a solutions (http://www.vbforums.com/showthread.php?538529-Export-an-Image-from-Excel-Sheet-to-Hard-Drive), that I have adopted to this task.
The key is, that a chart object can be exported as a picture, so the original shape is copied into a chart.
The chart is created, used, and deleted.
The ShapeExportAsPicture has two arguments: the shape, that is to be exported as picture and the full path where to store it.
Sub Logo()
Dim printWorksheet As Worksheet
Dim logoShape As Shape
Dim tempImageFile As String
Set printWorksheet = ThisWorkbook.ActiveSheet
Set logoShape = ThisWorkbook.Sheets("A").Shapes("myLogo")
logoShape.Visible = True
tempImageFile = Environ("temp") & Application.PathSeparator & "image.jpg"
Call ShapeExportAsPicture(logoShape, tempImageFile)
With printWorksheet.PageSetup
.RightFooterPicture.Filename = tempImageFile
.RightFooter = "&G"
End With
logoShape.Visible = False
End Sub
Private Sub ShapeExportAsPicture(pShape As Shape, sPathImageLocation As String)
Dim sTempChart As String
Dim shTempSheet As Worksheet
Set shTempSheet = pShape.Parent
Charts.Add 'Add a temporary chart
ActiveChart.Location Where:=xlLocationAsObject, Name:=shTempSheet.Name
Selection.Border.LineStyle = 0
sTempChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
With shTempSheet
'Change the dimensions of the chart to the size of the original shape
With .Shapes(sTempChart)
.Width = pShape.Width
.Height = pShape.Height
End With
pShape.Copy 'Copy the shape
With ActiveChart 'Paste the shape into the chart
.ChartArea.Select
.Paste
End With
'export the chart
.ChartObjects(1).Chart.Export Filename:=sPathImageLocation, FilterName:="jpg"
.Shapes(sTempChart).Delete 'Delete the chart.
End With
End Sub
My problem is when I press the command button it show the image but when I press it again the command button duplicates the image being displayed.
Private Sub CommandButton1_Click()
Dim pictureNameColumn As String 'column where picture name is found
Dim picturePasteColumn As String 'column where picture is to be pasted
Dim pictureName As String 'picture name
Dim lastPictureRow As Long 'last row in use where picture names are
Dim pictureRow As Long 'current picture row to be processed
Dim pathForPicture As String 'path of pictures
pictureNameColumn = "A"
picturePasteColumn = "E"
pictureRow = 2 'starts from this row
'error handler
On Error GoTo Err_Handler
'find row of the last cell in use in the column where picture names are
lastPictureRow = Cells(Rows.Count, pictureNameColumn).End(xlUp).Row
'stop screen updates while macro is running
Application.ScreenUpdating = False
pathForPicture = "C:\Users\drawing\Desktop\pic\"
'loop till last row
Do While (pictureRow <= lastPictureRow)
pictureName = Cells(pictureRow, "A") 'This is the picture name
'if picture name is not blank then
If (pictureName <> vbNullString) Then
'check if pic is present
'Start If block with .JPG
If (Dir(pathForPicture & pictureName & ".jpg") <> vbNullString) Then
Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".jpg").Select 'Path to where pictures are stored
With Selection
.Left = Cells(pictureRow, picturePasteColumn).Left
.Top = Cells(pictureRow, picturePasteColumn).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 130#
.ShapeRange.Rotation = 0#
End With
'End If block with .JPG
'Start ElseIf block with .PNG
ElseIf (Dir(pathForPicture & pictureName & ".png") <> vbNullString) Then
Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".png").Select 'Path to where pictures are stored
With Selection
.Left = Cells(pictureRow, picturePasteColumn).Left
.Top = Cells(pictureRow, picturePasteColumn).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 130#
.ShapeRange.Rotation = 0#
End With
'End ElseIf block with .PNG
'Start ElseIf block with .BMP
ElseIf (Dir(pathForPicture & pictureName & ".bmp") <> vbNullString) Then
Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".bmp").Select 'Path to where pictures are stored
With Selection
.Left = Cells(pictureRow, picturePasteColumn).Left
.Top = Cells(pictureRow, picturePasteColumn).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 130#
.ShapeRange.Rotation = 0#
End With
'End ElseIf block with .BMP
Else
'picture name was there, but no such picture
Cells(pictureRow, picturePasteColumn) = "No Picture Found"
End If
Else
'picture name cell was blank
End If
'increment row count
pictureRow = pictureRow + 1
Loop
Exit_Sub:
Range("A10").Select
Application.ScreenUpdating = True
Exit Sub
Err_Handler:
MsgBox "Error encountered. " & Err.Description, vbCritical, "Error"
GoTo Exit_Sub
End Sub
What I want is when I press the button again the previous image will just be replaced by the new image base on the column A.
You need to locate the existing picture based on its position, then delete it, before inserting the next picture.
Loop over all the pictures in the sheet and check their position - when you find one which matches where you want to insert the new picture, delete it.
Sub tester()
DeletePicFromCell Range("I3")
End Sub
Sub DeletePicFromCell(c As Range)
Const MARGIN As Long = 10 '<< how far the picture can be out of place
Dim shp
For Each shp In c.Parent.Shapes
If Abs(shp.Left - c.Left) < MARGIN And _
Abs(shp.Top - c.Top) < MARGIN Then
shp.Delete
Exit For '<< done checking
End If
Next shp
End Sub
BTW you don't need all those blocks checking for different extensions: assuming all the potential matches are images you can do something like
Dim fName
fName = Dir(pathForPicture & pictureName & ".*") '<< match any extension
If Len(fName)>0 Then
'Have a match
'Insert image from pathForPicture & fName
End If
EDIT: your original code reworked
Private Sub CommandButton1_Click()
Const COL_PIC_NAME As Long = 1 'column where picture name is found
Const COL_PIC_PASTE As Long = 5 'column where picture is to be pasted
Const PIC_PATH As String = "C:\Users\drawing\Desktop\pic\"
Dim pictureName As String 'picture name
Dim pictureFile As String 'picture file
Dim pictureRow As Long 'current picture row to be processed
Dim sht As Worksheet
Dim picCell As Range
Set sht = ActiveSheet
For pictureRow = 2 To sht.Cells(sht.Rows.Count, COL_PIC_NAME).End(xlUp).Row
pictureName = sht.Cells(pictureRow, COL_PIC_NAME) 'This is the picture name
If Len(pictureName) > 0 Then
pictureFile = Dir(PIC_PATH & pictureName & ".*", vbNormal) 'is there a matching file?
If Len(pictureFile) > 0 Then
Set picCell = sht.Cells(pictureRow, COL_PIC_PASTE)
DeletePicFromCell picCell 'delete any previous picture
With sht.Pictures.Insert(PIC_PATH & pictureFile)
.Left = picCell.Left
.Top = picCell.Top
.ShapeRange.LockAspectRatio = msoFalse
.Height = 100
.Width = 130
End With
End If 'have picture
End If 'have picname
Next pictureRow
End Sub