I want to position picture in center of range, but it just doesn't work for me. Maybe anybody knows how to do it?
Here is my code:
Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
Dim p As Object, t As Double, l As Double, r As Double, b As Double
Dim aspect
Dim w, h
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
l = 1: r = 22 ' co-ordinates of top-left cell
t = 47: b = 88 ' co-ordinates of bottom-right cell
Set TargetCells = Range("A47:V88")
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
With p
With .ShapeRange
.LockAspectRatio = msoTrue ' lock the aspect ratio (do not distort picture)
aspect = .Width / .Height ' calculate aspect ratio of picture
.Left = Cells(t, l).Left ' left placement of picture
.Top = Cells(t, l).Top ' top left placement of picture
End With
w = (Cells(b, r).Left + Cells(b, r).Width - Cells(t, l).Left) ' width of cell range
h = Cells(b, r).Top + Cells(b, r).Height - Cells(t, l).Top ' height of cell range
If (w / h < aspect) Then
.ShapeRange.Width = w ' scale picture to available width
Else
.ShapeRange.Height = h ' scale picture to available height
End If
.Placement = 1
End With
Set p = Nothing
End Sub
Found out answer:
Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
Dim p As Object, t As Double, l As Double, r As Double, b As Double
Dim aspect
Dim w, h
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
l = 1: r = 22 ' co-ordinates of top-left cell
t = 47: b = 88 ' co-ordinates of bottom-right cell
Set TargetCells = Range("A47:V88")
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
With p
With .ShapeRange
.LockAspectRatio = msoTrue ' lock the aspect ratio (do not distort picture)
aspect = .Width / .Height ' calculate aspect ratio of picture
.Left = Cells(t, l).Left + TargetCells.Width / 2 - p.Width / 2 ' left placement of picture
.Top = Cells(t, l).Top ' top left placement of picture
End With
w = (Cells(b, r).Left + Cells(b, r).Width - Cells(t, l).Left) ' width of cell range
h = Cells(b, r).Top + Cells(b, r).Height - Cells(t, l).Top ' height of cell range
If (w / h < aspect) Then
.ShapeRange.Width = w ' scale picture to available width
Else
.ShapeRange.Height = h ' scale picture to available height
End If
.Placement = 1
End With
Set p = Nothing
End Sub
Related
I want to populate my shape according to time range value in 1st Range and 2nd Range cell as shown in the image. Thank you. Your help is much appreciated
https://i.stack.imgur.com/XNNy2.jpg
I've tried this code but it won't work.
Dim z As Range
For Each z In Range("a4:a19").Rows
If z.Value >= Range("F4") Then Exit For
Next z
Dim x As Range
For Each x In Range("a4:a19").Rows
If x.Value >= Range("G4") Then Exit For
Next x
'MsgBox z & x
Dim c
Dim rnrn
c = Rows(3).Find(DateValue("12/11/2022")).Column
'Application.InchesToPoints(10)
Dim LLL As Single, TTT As Single, WWW As Single, HHH As Single
Set rnrn = Range(z.Address, x.Address).Offset(0, c - 1)
LLL = rnrn.Left
TTT = rnrn.Top
WWW = rnrn.Width
HHH = rnrn.Height
With ActiveSheet.Shapes
' .LockAspectRatio = msoFalse
.AddTextbox(msoTextOrientationHorizontal, LLL, TTT + Application.InchesToPoints(Range("F4").Value), WWW, Application.InchesToPoints(Range("F4").Value) + Application.InchesToPoints(Range("G4").Value)).Select
' .Placement = xlMove
' .LockAspectRatio = msoTrue
End With
Dim r1 As Byte, r2 As Byte, r3 As Byte
r1 = WorksheetFunction.RandBetween(0, 255)
r2 = WorksheetFunction.RandBetween(0, 255)
r3 = WorksheetFunction.RandBetween(0, 255)
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(r1, r2, r3)
.Transparency = 0
.Solid
End With
Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
With Selection.ShapeRange.TextFrame2.TextRange.Characters.ParagraphFormat
.FirstLineIndent = 0
.Alignment = msoAlignCenter
End With
Selection.ShapeRange.TextFrame2.TextRange.Characters.Font.Size = 15
Selection.ShapeRange.TextFrame2.TextRange.Characters.Text = Range("F3").Text & " - " & Range("G3").Text
If I understand you correctly....
Below image is an example before running the sub
The expected result after running the sub :
If the image both is similar with your case, then maybe you want to have a look the code below then modify it according to your need. The code don't do any "fancy stuffs", such as coloring, font type, font size, etc.
Sub test()
Dim rg As Range: Dim sTxt As String: Dim eTxt As String
Dim dur: Dim pos
Dim h As Integer: Dim w As Integer
Dim L As Integer: Dim T As Integer
With ActiveSheet
For Each shp In .Shapes: shp.Delete: Next
End With
Set rg = Range("F2", Range("F" & Rows.Count).End(xlUp))
For Each cell In rg
sTxt = Format(cell.Value, "hh:mm AM/PM")
eTxt = Format(cell.Offset(0, 1).Value, "hh:mm AM/PM")
dur = Format(cell.Offset(0, 1).Value - cell.Value, "h:m")
dur = Split(dur, ":")(0) & "." & Application.RoundUp(Split(dur, ":")(1) * 1.666, 0)
pos = Format(cell.Value, "h:m")
pos = Split(pos, ":")(0) & "." & Application.RoundUp(Split(pos, ":")(1) * 1.666, 0)
With Range("D4")
h = dur * .Height: w = .Width
L = .Left: T = .Top + ((pos - 7) * .Height)
End With
With ActiveSheet.Shapes
.AddTextbox(msoTextOrientationHorizontal, L, T, w, h) _
.TextFrame.Characters.Text = sTxt & " - " & eTxt
End With
Next
End Sub
For the textbox size,
the height is coming from subtracting the end time with start time, split the value by ":", then add decimal point ".", then multiply the value after the decimal point with 1.666, so the approx value can be divided by 100, not 60, then multiply by the row height of row 4. The width is coming from column D width.
For the textbox position,
The top position is coming from the start time, then it
s the same process like for the height of the box. The left position is coming from the left position value of column D.
I need to embed an image to a spreadsheet via Excel VBA, such that whenever I relocate my excel file, the image will still show up. How can I do this?
This code will insert an image on the current sheet and position it at at cell E10:
Set oPic = Application.ActiveSheet.Shapes.AddPicture("d:\temp\mypic.jpg", False, True, 1, 1, 1, 1)
oPic.ScaleHeight 1, True
oPic.ScaleWidth 1, True
oPic.Top = Range("E10").Top
oPic.Left = Range("E10").Left
Did you try using the macro recorder?
This is what it produced for me:
Sub Macro1()
ActiveSheet.Pictures.Insert ("C:\mypicture.jpg")
End Sub
Also tons of info using google search terms: "Insert Picture Using VBA Excel". The below code is taken from ExcelTip all credit to the original author Erlandsen Data Consulting.
With the macro below you can insert pictures at any range in a worksheet and they will remain as long as the picture itself remains in its original location.
The picture can be centered horizontally and/or vertically.
Sub TestInsertPicture()
InsertPicture "C:\FolderName\PictureFileName.gif", _
Range("D10"), True, True
End Sub
Sub InsertPicture(PictureFileName As String, TargetCell As Range, _
CenterH As Boolean, CenterV As Boolean)
' inserts a picture at the top left position of TargetCell
' the picture can be centered horizontally and/or vertically
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' determine positions
With TargetCell
t = .Top
l = .Left
If CenterH Then
w = .Offset(0, 1).Left - .Left
l = l + w / 2 - p.Width / 2
If l < 1 Then l = 1
End If
If CenterV Then
h = .Offset(1, 0).Top - .Top
t = t + h / 2 - p.Height / 2
If t < 1 Then t = 1
End If
End With
' position picture
With p
.Top = t
.Left = l
End With
Set p = Nothing
End Sub
With the macro below you can insert pictures and fit them to any range in a worksheet.
Sub TestInsertPictureInRange()
InsertPictureInRange "C:\FolderName\PictureFileName.gif", _
Range("B5:D10")
End Sub
Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' determine positions
With TargetCells
t = .Top
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
End With
' position picture
With p
.Top = t
.Left = l
.Width = w
.Height = h
End With
Set p = Nothing
End Sub
I need help locking the aspect ratio of images in a VBA code which pastes into an excel file images from links using information in specific cells.
What I would like to know is how to lock the aspect ratio of these pasted images.
I have tried to change things but haven't been able to succeed in keeping the aspect ratio.
Any help would be greatly appreciated! Thanks,
Peter
ActiveWindow.Zoom = 100
On Error Resume Next
Dim Plage As Range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
Set Plage = Selection
lig = Plage.Cells(1).Row
col = Plage.Cells(1).Column
nbcel = 0
For Each cell In Plage
If cell.Value <> "" Then nbcel = nbcel + 1
Next cell
posColstr = InputBox("En quelle colonne voulez-vous inserer vos photos (1, 2, 3...)?", "Colonne", 1)
posCol = CInt(posColstr)
If posCol = 0 Then posCol = 1
For i = 0 To nbcel - 1
Matiere = Cells(i + lig, col).Value
Cells(i + lig, posCol).Activate
With Cells(i + lig, posCol)
t = .Top
l = .Left
w = .Width
h = .Height
End With
ActiveSheet.Shapes.AddPicture Filename:="https://websiteimagelink.com/" & Matiere & ".null.null.null.null.null.jpg", linktofile:=msoFalse, savewithdocument:=msoCTrue, Top:=t, Left:=l, Width:=70, Height:=50
ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Placement = xlMoveAndSize
Next i
Here's an example of how you can do it.
Edited to show how it fits in your code.
Sub InsertPics()
Const MAX_WIDTH As Long = 100 'max picture width
Const MAX_HEIGHT As Long = 100 'max height
Dim Plage As Range, url, rngPic As Range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
Set Plage = Selection
ActiveWindow.Zoom = 100
On Error Resume Next
posColstr = InputBox("En quelle colonne voulez-vous inserer vos photos (1, 2, 3...)?", "Colonne", 1)
posCol = CInt(posColstr)
If posCol = 0 Then posCol = 1
For Each c In Plage.Cells 'loop over user selection
Matiere = Trim(c.Value)
If Len(Matiere) > 0 Then 'if cell has a value...
url = "https://websiteimagelink.com/" & Matiere & ".null.null.null.null.null.jpg"
Set rngPic = c.EntireRow.Cells(posCol)
InsertResizePic rngPic, url, MAX_WIDTH, MAX_HEIGHT 'or rngpic.Width, rngpic.Height
End If
Next i
End Sub
'Insert a shape from path `pth`, positioned at cell `c`: resize so dimensions do
' not exceed `maxWidth` or `maxHeight`
Sub InsertResizePic(c As Range, pth As String, maxWidth As Long, maxHeight As Long)
Dim fW, fH, shp
Set shp = c.Parent.Pictures.Insert(Filename:=pth)
With shp
.ShapeRange.LockAspectRatio = msoTrue 'lock relative h/w
.Placement = xlMoveAndSize
.Top = c.Top
.Left = c.Left
fW = .Width / maxWidth 'dimensions relative to max allowed
fH = .Height / maxHeight
If fW > 1 Or fH > 1 Then 'is it too wide or too tall?
If fW >= fH Then
.Width = .Width / fW 'more too wide than too tall: shrink width
Else
.Height = .Height / fH 'shrink height
End If
End If
End With
End Sub
First time using this site. Borrowing an idea from the SpreadSheetGuru, I am copy and pasting bunch of drawn shapes into a temporary chart such that I can save them as a PNG image. I copy and paste different shapes, one by one, and then move them using Top and Left properties so they look like the original arrangement. It works great for rectangles and textboxes but gives me an error for lines (straight connectors). It says “the item with specified name wasn’t found” but I do not use anything different. I appreciate your help to solve this problem. Here is that part of the code below. The lines are copied and pasted, as I can see them when I step through the code, but cannot be "addressed" to be moved to their correct location on the chart
k = 0
For Each sh In ActiveSheet.Shapes ' ---------------------------------------- select one shape at a time
a1 = InStr(1, Trim(sh.Name), "TextBox", 1)
A2 = InStr(1, Trim(sh.Name), "Rectangle", 1)
a3 = InStr(1, Trim(sh.Name), "Straight", 1)
a4 = InStr(1, Trim(sh.Name), "Line", 1)
If a1 > 0 Or A2 > 0 Or a3 > 0 Or a4 > 0 Then
sh.Select
k = k + 1
Else: GoTo NextShape:
End If
sh.Name = sh.Name & k
'Copy/Paste Shape inside temporary chart
ActiveShape.Copy
cht.Activate
ActiveChart.Paste
ActiveChart.Shapes(UserSelection.Name).Top = ActiveShape.Top - Top0 ' === ERROR IS HERE
ActiveChart.Shapes(UserSelection.Name).Left = ActiveShape.Left - Left0
NextShape:
Next sh ' ----------------------------------------------------------------------
Here's a couple of different approaches. Both are pasting the shapes into a chart inserted on the worksheet (ie. I'm not using a chart sheet)
Sub CopyShapesToChart()
Dim sh, cht As Chart, e, shp, col As New Collection
Dim minY, minX, maxY, maxX, v
Set cht = ActiveSheet.ChartObjects(1).Chart
minY = 1000000# 'set starting points (random high number)
minX = 1000000#
'First collect all of the shapes we're interested in,
' and figure out the "bounding box" for them
For Each shp In ActiveSheet.Shapes
For Each e In Array("TextBox", "Rectangle", "Straight", "Line")
If InStr(1, shp.Name, e) > 0 Then
'tracking bounding box for all shapes
If shp.Top < minY Then minY = shp.Top
If shp.Left < minX Then minX = shp.Left
v = shp.Top + shp.Height
If v > maxY Then maxY = v
v = shp.Left + shp.Width
If v > maxX Then maxX = v
col.Add shp
Exit For
End If
Next e
Next shp
'resize the chartobject to fit the collection of shapes
cht.Parent.Height = maxY - minY
cht.Parent.Width = maxX - minX
'copy each shape into the chart
For Each shp In col
shp.Copy
cht.Paste
With cht.Shapes(cht.Shapes.Count)
.Top = shp.Top - minY
.Left = shp.Left - minX
End With
Next shp
'now export the chart...
End Sub
EDIT: a second approach with a little less work - instead of copying shapes one-by-one group all of them and copy them in one operation
Sub CopyShapesToChart2()
Dim sh, cht As Chart, e, shp
Dim arr(), ws As Worksheet, i As Long, rng
Set ws = ActiveSheet
Set cht = ws.ChartObjects(1).Chart
ReDim arr(0 To ws.Shapes.Count)
For Each shp In ws.Shapes
For Each e In Array("TextBox", "Rectangle", "Straight", "Line")
If InStr(1, shp.Name, e) > 0 Then
arr(i) = shp.Name
i = i + 1
Exit For
End If
Next e
Next shp
If i > 0 Then 'matched any shapes?
If i > 1 Then 'matched>1 shape?
ReDim Preserve arr(0 To i - 1)
Set rng = ws.Shapes.Range(arr).Group() 'group the matched shapes
Else
Set rng = ws.Shapes(arr(0)) 'just matched a single shape
End If
'resize the chartobject to fit the [collection of] shape[s]
cht.Parent.Height = rng.Height
cht.Parent.Width = rng.Width
rng.Copy 'copy the shape or group
cht.Paste
If i > 1 Then rng.Ungroup 'ungroup if we grouped anything
End If
End Sub
A friend of mine (Ray Hayes) provided the answer off line. To make the original code work, all is needed is to change "UserSelection.Name" to "Selection.Name".
I'm trying to insert an image at a specific range, I want that image to be inserted with its original dimensions.
The following code works fine, but the image is resized:
Sub InsertPictureInRangeAntes(path As String, PictureFileName As String, TargetCells As Range)
'inserts a picture and resizes it to fit the TargetCells range
Dim p As Shape, t As Double, l As Double, w As Double, h As Double
If dir(path, vbDirectory) = "" Then
MsgBox "Doesn't exists an image in this path", vbInformation
Exit Sub
Else:
path = path & PictureFileName
End If
'import picture
Set p = ActiveSheet.Shapes.AddPicture(Filename:=path, linktofile:=msoFalse, _
savewithdocument:=msoCTrue, Left:=l, Top:=t, Width:=w, Height:=h)
'determine positions
With TargetCells
t = .Top
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
End With
'position picture
With p
.Top = t
.Left = l
.Width = w'I dont know how to take the original dimensions
.Height = h
End With
Set p = Nothing
End Sub
Any question post on comments!
Instead of AddPicture use Pictures.Insert
Sub addPicture()
Dim pct
Set pct = Worksheets("Sheet1").Pictures.Insert("H:\My Documents\My Pictures\abc.jpg")
'/ Set Top,Left etc if required.
pct.Top = 1
pct.Left = 10
End Sub