I am trying to create a custom shape with a hotkey. I want it to automatically go to a specific cell I am currently on instead of the same area every single time I run it with my hotkey.
Sub RedSquareShapeNoFill()
'
' RedSquareShapeNoFill Macro
'
' Keyboard Shortcut: Ctrl+q
'
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 197.25, 44.25, 96.75, 26.25). _
Select
Selection.ShapeRange.Fill.Visible = msoFalse
With Selection.ShapeRange.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
End With
With Selection.ShapeRange.Line
.Visible = msoTrue
.Weight = 1.5
End With
End Sub
The current selection could be assigned to a range variable. Then, working with that range, one may use the .Left, .Top, .Width and .Height properties of the range.
Another good idea is to declare the shape as a variable and work with it and not with the Selection, because it is a bad practice - the selection can be a Range or a Shape object:
Sub RedSquareShapeNoFill()
Dim myShape As Shape
Dim wks As Worksheet: Set wks = ActiveSheet
Dim selectionRange As Range
Set selectionRange = Selection
Set myShape = wks.Shapes.AddShape(msoShapeRectangle, _
selectionRange.Left, _
selectionRange.Top, _
selectionRange.Width, _
selectionRange.Height)
With myShape.Line
myShape.Fill.Visible = msoFalse
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
.Visible = msoTrue
.Weight = 1.5
End With
End Sub
You need the top and left of the current cell and plug that into the AddShape parameters
Dim myTop As Double
Dim myLeft As Double
myTop = Selection.Top
myLeft = Selection.Left
ActiveSheet.Shapes.AddShape(msoShapeRectangle, myLeft, myTop, 96.75, 26.25). _
Select
Related
scenario is i have an array of shapes on my worksheet and i want to set a loop running through each shape setting the colour accordingly.
what i've come up with so far:
Dim yFilter(1 To 5) As String
yFilter(1) = "BD_P"
yFilter(2) = "FIN_P"
yFilter(3) = "PM_P"
yFilter(4) = "IPS_P"
yFilter(5) = "ENG_P"
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
For i = 1 To 5
If sh = yFilter(i) Then
sh.Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 255, 255)
End With
End If
Next i
Next
the issue with the above is it's not matching sh.name it's just matching against the group shape
however if i use ActiveSheet.Shapes.Range(Array("BD_P")).Select it works fine ....i'd just rather not have to do this for every single item i'd rather have it run through as an array for example.
any ideas how i can resolve this would be appreciated.
Loop Through Shapes From List
Dim yFilter(1 To 5) As String
yFilter(1) = "BD_P"
yFilter(2) = "FIN_P"
yFilter(3) = "PM_P"
yFilter(4) = "IPS_P"
yFilter(5) = "ENG_P"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim shp As Shape, i As Long
For i = LBound(yFilter) To UBound(yFilter)
On Error Resume Next
Set shp = ws.Shapes(yFilter(i))
On Error GoTo 0
If Not shp Is Nothing Then
shp.Fill.ForeColor.RGB = RGB(255, 255, 255)
Set shp = Nothing
End If
Next i
after countless attempts i finally found a way to make it work
incase anyone else ever stumbles upon a similar issue:
yFilter = Array("BD_P", "FIN_P", "PM_P", "IPS_P", "ENG_P")
For Each Item In yFilter
ActiveSheet.Shapes.Range(Array(Item)).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 255, 255)
End With
Next
Good afternoon,
I have the problem.
By using the following function:
Private Sub SizeToRange(ByVal targetShape As Shape, ByVal Target As Range)
' Adjust picture properties
With targetShape
' Check if next line is required...
.LockAspectRatio = msoFalse
.Left = Target.Left + 15
.Top = Target.Top - 4
.Width = Target.Width - 30
.Height = Target.Height
.ZOrder msoSendToBack
'.IncrementRotation Deg
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 = 1
End With
End Sub
and the code:
Public Sub ResizeChambers()
Dim targetSheet As Worksheet
Dim targetRange As Range
Dim targetShape As Shape
' Define the sheet that has the pictures
Set targetSheet = ThisWorkbook.ActiveSheet
' Define the range the images is going to fit
Set targetRange = targetSheet.Range("E3:I16")
' 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
targetShape.Flip msoFlipHorizontal
End If
Next targetShape
End Sub
I am trying to set all my images on horizontal way.
As you can see I used both options:
1. targetShape.Flip msoFlipHorizontal for the code
2. .IncrementRotation Deg for function
In both cases doesn't work, because one images are horizontal and another ones are vertical and another way round.
How can I make all of them in horizontal alignment?
You can accomplish this in different ways, by using Shape Range Collection Object, and either use Shepes.SelectAll, or Select each type of shape object, without using the Replace argument, or select a specific Range. Change the type of shape and range as needed. If you have any questions, please ask.
Example 1: Use Shape Range collection Object
Dim shprng As ShapeRange
ActiveSheet.Shapes.SelectAll
Set shprng = Selection.ShapeRange
shprng.Align 3, 0 '3 is the enumeration for msoPicture, and 0 is the enumeration for msoFalse
Example 2: Select the type of shape
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
If shp.Type = 13 Then shp.Select False '13 is the enumeration for msoPicture
Next shp
With Selection.ShapeRange
.Align 3, 0 '3 is the enumeration for msoALignTops, and 0 is the enumeration for msoFalse
End With
Example 3: Use a specific Range
Dim shp As Shape, rng As Range
Set rng = ActiveSheet.Range("D4:O20")
For Each shp In ActiveSheet.Shapes
If Not Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), rng) Is Nothing And shp.Type = 13 Then shp.Select False '13 is the enumeration for msoPicture
Next shp
With Selection.ShapeRange
.Align 3, 0 '3 is the enumeration for msoALignTops, and 0 is the enumeration for msoFalse
End With
This function loops through all the textboxes in the workbook to find and highlight text + textbox that contain the result.
The problem is: if I trigger it from a specific sheet, all the textboxes in that sheet that contain the result will NOT be highlighted (text is found though, so it works halfway).
If I trigger it from a worksheet that does not contain a textbox with a result, then everything works.
Dim shp As Shape
Dim Color As String
Dim ColorIndexobj As String
Dim Sizeobj As Integer
Dim sFind As String
Dim sFind2 As String
Dim sTemp As String
Dim iPos As Integer
Dim sTemp2 As String
Dim iPos2 As Integer
Dim Response
Dim sourceSheet As Worksheet
Set sourceSheet = ActiveSheet
sFind = InputBox("Search for?")
If Trim(sFind) = "" Then
MsgBox "Nothing entered"
Exit Sub
End If
For Each ws In ActiveWorkbook.Worksheets
ws.Select
For Each shp In ws.Shapes
If shp.Type = msoTextBox Then
sTemp = shp.TextFrame.Characters.Text
If InStr(LCase(sTemp), LCase(sFind)) <> 0 Then
shp.Select
With shp.Line
Color = shp.Line.ForeColor.RGB
Weight = shp.Line.Weight
.ForeColor.RGB = vbRed
.Weight = 5
End With
sFind2 = LCase(sFind)
sTemp2 = LCase(shp.TextFrame.Characters.Text)
iPos2 = InStr(sTemp2, sFind2)
If iPos2 > 0 Then
With shp.TextFrame.Characters(Start:=iPos2, _
Length:=Len(sFind2)).Font
Sizeobj = .Size
.Size = 35
End With
End If
Set sourceSheet = ActiveSheet
Response = MsgBox( _
"Do you want to continue?", _
Buttons:=vbYesNo, Title:="Continue?")
If Response = vbYes Then
With shp.Line
.ForeColor.RGB = Color
.Weight = Weight
End With
With shp.TextFrame.Characters(Start:=iPos2, _
Length:=Len(sFind2)).Font
.Size = Sizeobj
End With
End If
If Response = vbNo Then
With shp.Line
.ForeColor.RGB = Color
.Weight = Weight
End With
With shp.TextFrame.Characters(Start:=iPos2, _
Length:=Len(sFind2)).Font
.Size = Sizeobj
End With
Exit Sub
End If
End If
End If
Next
Next
Call sourceSheet.Activate
End Sub
The problem is that the change that you are doing is undone before the window is ever repainted.
Here is a kludge (from this answer):
Immediately after
With shp.Line
Color = shp.Line.ForeColor.RGB
Weight = shp.Line.weight
.ForeColor.RGB = vbRed
.weight = 5
End With
Put the line:
ActiveWindow.SmallScroll 0
Exactly what causes a window to repaint during a running macro isn't clearly documented. The rules are evidently different as they apply to the active sheet, which would explain the behavior that you are observing. There isn't any simple RePaint method of a worksheet, hence the kludge, which works since scrolling triggers a repaint, even if the distance scrolled is zero.
From some reason, using DoEvents rather than this kludge doesn't seem to work.
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 this code to create a chart:
Sub CreateChart()
Dim rng As Range
Dim cht As Object
Set rng = ActiveSheet.Range("A4:C8")
Set cht = ActiveSheet.Shapes.AddChart2
cht.Chart.SetSourceData Source:=rng, PlotBy:=xlColumns
cht.Chart.ChartType = xlBarStacked
cht.SeriesCollection(1).Interior.Color = RGB(255, 255, 255)
End Sub
But the series 1 bars are not changing the color.
Can you help?
Thanks!
See answer below, it implements what you wanted in your post, in a different method, allowing you more flexibility in the future:
Option Explicit
Sub CreateChart()
Dim rng As Range
Dim cht As ChartObject
Dim cht_Series As Series
Set rng = ActiveSheet.Range("A4:C8")
' in brackets (Left, Width, Top, Height) >> modify according to your needs
Set cht = ActiveSheet.ChartObjects.Add(100, 100, 100, 100)
With cht
.Chart.SetSourceData Source:=rng
.Chart.PlotBy = xlColumns
.Chart.ChartType = xlBarStacked
End With
Set cht_Series = cht.Chart.SeriesCollection(1)
' this will result to white (by your post) >> modify to your desired color
cht_Series.Format.Fill.ForeColor.RGB = RGB(255, 255, 255)
End Sub
Try this :
Sub CreateChart()
Dim rng As Range
Set rng = ActiveSheet.Range("A4:C8")
ActiveSheet.Shapes.AddChart.Select
With ActiveChart
.SetSourceData Source:=Range("Feuil1!$A$4:$B$8")
.SeriesCollection.NewSeries
.SetSourceData Source:=rng, PlotBy:=xlColumns
.ChartType = xlBarStacked
.SeriesCollection(1).Interior.ColorIndex = 5 'Change value to change color
End With
End Sub
and choose the value in the color index table. 5 correspond to blue. You can get the color index table here .