I want to add an image to Cell B1,
and then put the same images to B15, B29, B43, ......B57 (which are increasing by 14) at once
I searched for the ways to do this, but couldn't find how to.
Could someone please tell me how to do this?
Option 1 based on this solution
Option Explicit
Sub TiragePictures()
Const PicPath = "c:\PPP\AAA.png" ' your own path to the image
Dim ws As Worksheet, r As Long, cell As Range
Set ws = ActiveSheet
For r = 15 To 57 Step 14
Set cell = ws.Cells(r, "B")
With ws.Pictures.Insert(PicPath)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = 70
.Height = 50
End With
.Left = cell.Left
.Top = cell.Top
.Placement = 1
.PrintObject = True
End With
Next
End Sub
Option2 with Shapes.AddPicture method
Sub TiragePictures2()
Const PicPath = "c:\PPP\AAA.png" ' your own path to the image
Dim ws As Worksheet, r As Long, cell As Range, sh As Shape
Set ws = ActiveSheet
For r = 15 To 57 Step 14
Set cell = ws.Cells(r, "B")
With ws.Shapes.AddPicture(Filename:=PicPath, LinkToFile:=False, _
SaveWithDocument:=True, Left:=cell.Left, _
Top:=cell.Top, Width:=-1, Height:=-1) '-1 retains the width/height of the existing file
.LockAspectRatio = True 'before resizing, set the proportions to keep
.Width = 70
.Height = 50
End With
Next
End Sub
Related
I'm trying to create the following template:
The user creates a table in a "Data Entry" worksheet that lists the following:
File path ie: P:\Phone Camera Dump\20121224_111617.jpg
Range where the picture is to be placed in the "PICS" worksheet.
Once the list is finalized, the user executes and images are placed within the ranges specified on the "PICS" worksheet and dynamically re-sized.
Presently the range has a set width of 624px and a height of 374px, but ideally, I would like the image to resize (aspect ratio not locked) dynamically in the width and height change.
I've used the following code as a base but am struggling with how to incorporate the cell ranges instead of the static row updates:
Sub InsertSeveralImages()
Dim pic_Path As String 'File path of the picture
Dim cl As Range, Rng As Range
Dim WS_Templte As Worksheet
Set WS_Templte = Worksheets("PICS")
Set Rng = Worksheets("Data Entry").Range("C13:C42")
pastingRow = 2
For Each cl In Rng
pic_Path = cl.Value
Set InsertingPicture = WS_Templte.Pictures.Insert(pic_Path)
'Setting of the picture
With InsertingPicture
.ShapeRange.LockAspectRatio = msoTrue
.Height = 100
.Top = WS_Templte.Rows(pastingRow).Top
.Left = WS_Templte.Columns(3).Left
End With
pastingRow = pastingRow + 5
Next cl
Set myPicture = Nothing
WS_Templte.Activate
End Sub
Any thoughts?
I figured it out. Here is the code in case anyone wants to use it:
Public Sub InsertPictures()
Dim vntFilePath As Variant
Dim rngFilePath As Range
Dim vntPastePath As Variant
Dim rngPastePath As Range
Dim lngCounter As Long
Dim pic As Picture
Set WS_Templte = Worksheets("PICS")
On Error GoTo ErrHandler
With ThisWorkbook.Sheets("PICS") '<-- Change sheet name accordingly
' Set first cell containing a row number
Set rngFilePath = .Range("BJ7")
vntFilePath = rngFilePath.Value
' Set first cell containing a paste range
Set rngPastePath = .Range("BK7")
vntPastePath = rngPastePath.Value
Do Until IsEmpty(vntFilePath)
If Dir(vntFilePath) = "" Then vntFilePath = strNOT_FOUND_PATH
Set pic = .Pictures.Insert(vntFilePath)
lngCounter = lngCounter + 1
With pic
.ShapeRange.LockAspectRatio = msoFalse
If .ShapeRange.Rotation = 90! Or .ShapeRange.Rotation = 270! Then
.Height = Application.CentimetersToPoints(16.3)
.Width = Application.CentimetersToPoints(10.03)
.Top = WS_Templte.Rows(rngPastePath).Top - (.Height - .Width) / 2#
.Left = WS_Templte.Columns(4).Left + (.Height - .Width) / 2#
Else
.Width = Application.CentimetersToPoints(10.03)
.Height = Application.CentimetersToPoints(16.3)
.Top = WS_Templte.Rows(rngPastePath).Top
.Left = WS_Templte.Columns(4).Left
End If
End With
Set rngFilePath = rngFilePath.Offset(1)
vntFilePath = rngFilePath.Value
Set rngPastePath = rngPastePath.Offset(1)
vntPastePath = rngPastePath.Value
Loop
End With
MsgBox lngCounter & " pictures were inserted.", vbInformation
ExitProc:
Set rngFilePath = Nothing
Set pic = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitProc
End Sub
I have a table that contains the file path, when the button is clicked the macro will display an image according to the url path. Here is my code (sourch : Link)
Sub Macro_1()
Dim cShape As Shape
Dim cRange As Range
Dim cColumn As Long
On Error Resume Next
Application.ScreenUpdating = False
Set xRange = ActiveSheet.Range("C5:D6, G5:H6, C8:D9, G8:H9")
For Each cell In xRange
cName = cell
ActiveSheet.Pictures.insert(cName).Select
Set cShape = Selection.ShapeRange.Item(1)
If cShape Is Nothing Then GoTo line22
cColumn = cell.Column
Set cRange = Cells(cell.Row, cColumn)
With cShape
.LockAspectRatio = msoFalse
.Height = cRange.Height - 5
.Width = cRange.Width - 5
.Top = cRange.Top + 2
.Left = cRange.Left + 2
.Placement = xlMoveAndSize
End With
line22:
Set cShape = Nothing
Next
Application.ScreenUpdating = True
End Sub
The code works as shown in the following illustration.
But I want the image to be in all merged cells. As shown in the following picture
Please let me know if you see anything that will fix this! I'm sure it's something simple, but I've been stuck for a while on this one.
You can use the MergeArea property of the Range object to return the merged range. Your macro can amended as follows (untested) . . .
Sub Macro_1()
Dim cShape As Shape
Dim cRange As Range
Dim cColumn As Long
On Error Resume Next
Application.ScreenUpdating = False
Set xRange = ActiveSheet.Range("C5, G5, C8, G8")
For Each cell In xRange
cName = cell
ActiveSheet.Pictures.Insert(cName).Select
Set cShape = Selection.ShapeRange.Item(1)
If cShape Is Nothing Then GoTo line22
cColumn = cell.Column
Set cRange = cell.MergeArea
With cShape
.LockAspectRatio = msoFalse
.Height = cRange.Height - 5
.Width = cRange.Width - 5
.Top = cRange.Top + 2
.Left = cRange.Left + 2
.Placement = xlMoveAndSize
End With
line22:
Set cShape = Nothing
Next
Application.ScreenUpdating = True
End Sub
I have this code to convert a set of URLs in column B to images in column C, but i get the error :
Unable to get the Insert property of the Pictures class. My code :
Private Sub Insert_Pic()
Dim pic As String
Dim myPicture As Picture
Dim rng As Range
Dim item As Range
lRow = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
Set rng = Range("B3:B" & lRow)
For Each item In rng
pic = item.Offset(0, -1)
If pic = "" Then Exit Sub
Set myPicture = ActiveSheet.Pictures.Insert(pic)
With myPicture
.ShapeRange.LockAspectRatio = msoFalse
.Width = item.Width
.Height = item.Height
.Top = Rows(item.Row).Top
.Left = Columns(item.Column).Left
.Placement = xlMoveAndSize
End With
Next
End Sub
Thanks for your help
The algorithm in debugging is to start with something tiny, that works and then to continue.
For a beginning - take this 4 lines only and run them:
Sub TestMe()
Dim myPicAddress As String
myPicAddress = "https://www.vitoshacademy.com/wp-content/uploads/2016/02/va2.png"
Dim myPic As Picture
Set myPic = ActiveSheet.Pictures.Insert(myPicAddress)
End Sub
Then, start working on your code, putting the With-End With part to the code, that already works:
Sub TestMe2()
Dim myPicAddress As String
myPicAddress = "https://www.vitoshacademy.com/wp-content/uploads/2016/02/va2.png"
Dim myPicture As Picture
Set myPicture = ActiveSheet.Pictures.Insert(myPicAddress)
Dim item As Range
Set item = ActiveSheet.Cells(5, 5)
With myPicture
.ShapeRange.LockAspectRatio = msoFalse
.Width = item.Width
.Height = item.Height
.Top = Rows(item.Row).Top
.Left = Columns(item.Column).Left
.Placement = xlMoveAndSize
End With
End Sub
At the end, take a look at the loop and what is passed by as a picture string. Probably the error is hidden somewhere there.
I would like to have my image properly resized and bordered with the black line, thickness 1.
My situation looks like this:
and when I used this code:
Sub ResizeCivilsA()
SizeToRange Sheets("Civils 1").Pictures("Picture 29"), Range("B3:L46")
End Sub
Function SizeToRange(s, Target As Range)
s.Left = Target.Left + 10
s.Top = Target.Top - 5
s.Width = Target.Width
s.Height = Target.Height
End Function
, everything was adjusted fine, but:
It have been done only for the specified shape id, which is "Picture 29"
It was without the borders
So I tried then:
Sub ResizeCivilsA()
Dim shp As Shape
For Each shp In ThisWorkbook.Worksheets
If shp.Name Like "*Picture*" Then
SizeToRange shp, Range("B3:L46")
End If
Next
and finally I am getting error:
Type mismatch, with debugger pointing the line:
For Each shp In ThisWorkbook.Worksheets
Regarding the border around the image I found the common solution here:
https://learn.microsoft.com/en-us/office/vba/api/Excel.Range.BorderAround
However after appliance into my work:
Worksheets("Civils 1").Shape("Picture 29").BorderAround _
ColorIndex:=3, Weight:=xlThick
it wasn't enough since I had to remove the _ and got nothing afterward.
Is there some way to have the possibility for instant resizing the image and making the border around it for ANY attached image, which as default is called "Picture..."?
Try this code.
Read code's comments and adjust it to fit your needs
EDIT: The code checks if picture is within target range ad then adjusts its properties.
Code:
Option Explicit
Public Sub ResizeAllShapesInSheet()
Dim targetSheet As Worksheet
Dim targetRange As Range
Dim targetShape As Shape
' Define the sheet that has the pictures
Set targetSheet = ThisWorkbook.Worksheets("Civils 1")
' Define the range the images is going to fit
Set targetRange = targetSheet.Range("B3:L46")
' Loop through each Shape in Sheet
For Each targetShape In targetSheet.Shapes
' Check "picture" word in name
If targetShape.Name Like "*Picture*" Then
' Call the resize function
SizeToRange targetShape, targetRange
End If
Next targetShape
End Sub
Private Sub SizeToRange(ByVal targetShape As Shape, ByVal Target As Range)
If Not (targetShape.Left >= Target.Left And _
targetShape.Top >= Target.Top And _
targetShape.Left + targetShape.Width <= Target.Left + Target.Width And _
targetShape.Top + targetShape.Height <= Target.Top + Target.Height) Then Exit Sub
' Adjust picture properties
With targetShape
' Check if next line is required...
.LockAspectRatio = msoFalse
.Left = Target.Left + 10
.Top = Target.Top - 5
.Width = Target.Width
.Height = Target.Height
End With
' Adjust picture border properties
With targetShape.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Visible = msoTrue
.Weight = 6
End With
End Sub
Let me know if it works
Initial read looks like your For Each is looking for Shape objects, but you are giving it a collection of Sheet objects.
For Each sht In ThisWorkbook.Worksheets
For Each shp In sht.Shapes
If shp.Name Like "*Picture*" Then
Set r1 = shp.TopLeftCell
Set r2 = r1.Offset(10, 43)
SizeToRange shp, Range(r1.Address & ":" & r2.Address)
End If
Next shp
Next sht
Hope that helps!
EDIT: Updated with relative address.
I have a userform with a textbox and a listbox with the following plan:
Users input text in Textbox1.
Every time Textbox1.Text changes, a search with the following features is performed:
Textbox1.Text is searched in a specific range in a worksheet.
Textbox1.Text can be found more than once.
Listbox1 is populated with the results of the search.
So far so good. Due to having large set of data, the list can get many items. In this case the list reaches out of the screen and I had to limit Listbox1.Height. This is the code for the above:
Private Sub TextBox1_Change()
Dim srchWord As String, firstAddress As String
Dim srchRng As Range, cell As Range
Dim maxRow As Integer
ListBox1.Clear
If TextBox1.Value = "" Then
ListBox1.Height = 0
Else
With ThisWorkbook.Worksheets(1)
maxRow = .Cells(.Rows.Count, 2).End(xlUp).Row
Set srchRng = .Range("A2:A" & maxRow)
End With
srchWord = TextBox1.Value
Set cell = srchRng.Find(srchWord, LookIn:=xlValues, lookat:=xlPart)
With ListBox1
If Not cell Is Nothing Then
firstAddress = cell.Address
Do
If Not cell.Value Like "*(*" Then
.AddItem (cell.Value)
Select Case .ListCount
Case Is < 2
.Height = 17
Case Is < 21
.Height = 15 * .ListCount
Case Else
.Height = 272.5
End Select
Me.Height = 500
End If
Set cell = srchRng.FindNext(cell)
Loop While Not cell.Address = firstAddress
End If
End With
End If
End Sub
The problem was in Case Else when scroll was enabled I couldn't reach the last item of the list. By searching on the net I found some potential solutions:
set Listbox1.IntegralHeight = False set the height and then set again Listbox1.IntegralHeight = True
set Listbox1.MultiSelect = fmMultiSelectSingle and then set again Listbox1.MultiSelect = fmMultiSelectExtended.
do both of the above.
Application.Wait (Now + TimeValue("0:00:01") * 0.5) and then set the height.
None of these worked.
To be able to scroll to the last item, this worked:
Listbox1.IntegralHeight = False
Listbox1.Height= x
Listbox1.IntegralHeight = False
Listbox1.Height= x
but this also set the Listbox1.Height to this of one single item. (with arrows at the right)
Does anybody know how on earth am I going to control the Listbox1.Height without all this unwanted behaviour? Also if somebody can suggest another structure that could follow the plan mentioned at first, I 'm willing to discard the listbox.
This seems to be a not completely explored behaviour.
In my experience just redefine some listbox arguments.
Try the recommended sets of .IntegralHeight to False and True.
Another possible measure can help in some cases: try to choose heights for your listbox that come close to the following multiplication:
listbox height = (font size + 2 pts) * (maximum items per page)
Insert the following code after With ListBox1:
With ListBox1
.Top = 18 ' << redefine your starting Point
.Font.Size = 10 ' << redefine your font size
.IntegralHeight = False ' << try the cited recommendation :-)
Insert the following code before End With:
.Height = .Height + .Font.Size + 2
.IntegralHeight = True
End With
Hope that helps.
Link
See another faster approach to filter listboxes at How to speed up filling of listbox values on userform excel
#T.M.: Thank you for your quick response and for your time. Your answer gave me exactly what I wanted and that's why I'm marking it as such. I'm posting this just for future reference.
What I finaly did to implement the plan.
First of all I inserted:
this
With ListBox1
.Top = 18
.Font.Size = 10
.IntegralHeight = False
and this
.Height = .Height + .Font.Size + 2
.IntegralHeight = True
End With
and I linked .Height with .Font.Size as you suggested. As long as there was no need to assign absolute values to the height, there was no need to have a Select Case statement in my code.
Moreover I realized that there was no need to change the height every time an item was added but only at the end of the process, so I took it out of the loop.
Finally I added a piece of code that would make the list invisible when Textbox1 was empty. The code is now like this:
Final Userform code:
Option Compare Text
Option Explicit
Private bsdel As Boolean 'indicates if backspace or delete keys have been hit.
Private Sub ListBox1_Click()
Dim cell As Range
Dim maxRow As Integer
With ThisWorkbook.Worksheets(1)
maxRow = .Cells(.Rows.Count, 2).End(xlUp).Row
Set cell = .Range("A1:A" & maxRow).Find(UserForm11.ListBox1.Text, LookIn:=xlValues, lookat:=xlWhole)
If Not cell Is Nothing Then
cell.Select
'do other stuff also.
End If
End With
End Sub
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
bsdel = False
If KeyCode = 8 Or KeyCode = 46 Then _
bsdel = True
End Sub
Private Sub TextBox1_Change()
Dim srchWord As String, firstAddress As String
Dim srchRng As Range, cell As Range
Dim maxRow As Integer
ListBox1.Clear
ListBox1.Visible = True
If bsdel And TextBox1.Value = "" Then
ListBox1.Visible = False
Me.Height = 130
Else
With ThisWorkbook.Worksheets(1)
maxRow = .Cells(.Rows.Count, 2).End(xlUp).Row
Set srchRng = .Range("A1:A" & maxRow)
End With
srchWord = TextBox1.Value
Set cell = srchRng.Find(srchWord, LookIn:=xlValues, lookat:=xlPart)
With ListBox1
'.Top = 84 'test made: deleting this made no difference.
'.Font.Size = 10 'test made: deleting this made no difference.
.IntegralHeight = False
If Not cell Is Nothing Then
firstAddress = cell.Address
Do
If Not cell.Value Like "*(*" Then 'this range includes notes within parenthesis and I didn't need them.
.AddItem (cell.Value)
End If
Set cell = srchRng.FindNext(cell)
Loop While Not cell.Address = firstAddress
If .ListCount < 21 Then 'the size is adjusted.
.Height = (.Font.Size + 2) * .ListCount
Else 'the size stays fixed at maximum.
.Height = (.Font.Size + 2) * 20
End If
End If
Me.Height = .Height + 130
.Height = .Height + .Font.Size + 2
.IntegralHeight = True
End With
End If
bsdel = False
End Sub
Private Sub UserForm_Activate()
TextBox1.SetFocus
End Sub
Private Sub UserForm_Initialize()
ListBox1.Visible = False
End Sub