I have a (x,y) coordinate which will be plotted in a scatter plot. I need a circle of radius R to be drawn around the point plotted.
Thanks and Regards,
Prabhu.C
A 'bare bones' example which may get you started. You will need to play with scaling, units and positioning etc. to suit your context.
This will draw a circle with no fill and a red circumference, with a commented-out line to give it a solid fill (change .Visible to msoTrue).
Sub drawCircle()
Dim ws As Worksheet
Dim cLeft As Long, cTop As Long
Dim cX As Long, cY As Long, cDia As Long
Dim c1 As Shape
Set ws = Sheets("Sheet1")
cX = Range("A2")
cY = Range("B2")
cDia = Range("C2").Value * 2
cLeft = cX - (cDia / 2)
cTop = cY - (cDia / 2)
With ws
Set c1 = .Shapes.AddShape(msoShapeOval, cLeft, cTop, cDia, cDia)
With c1
.Fill.Visible = msoFalse
.Line.Weight = 2
.Line.ForeColor.RGB = RGB(255, 0, 0)
'.Fill.ForeColor.RGB = RGB(255, 0, 0) 'eg Red fill
End With
End With
End Sub
Related
I am currently creating a VBA macro to change the color of the marker of a chart if the value in the chart consists of 3 continuous spikes that exceeds a baseline value of 0.7.
For example, in the picture below, I've create a macro to change all the marker colors to red if the value is higher than the baseline value, but not if there are 3 continuous values higher than baseline value.
My Code
This is what I've tried - changing the marker color to red if the value exceeds 0.7
Sub Tester()
Dim cht As Chart, s As Series, p As point
Dim vals, x As Integer
Set cht = ThisWorkbook.Worksheets("mySheet3").ChartObjects("Chart 1").Chart
Set s = cht.SeriesCollection(1)
vals = s.Values
For x = LBound(vals) To UBound(vals)
If vals(x) > 0.7 Then
With s.Points(x)
.MarkerBackgroundColor = RGB(255, 0, 0)
.MarkerForegroundColor = RGB(255, 0, 0)
End With
End If
Next x
End Sub
For that you would need to work with a window size to check always 3 dots in a row if they are above basline if the are color them and move 1 further to check the next 3 in a row.
Option Explicit
Sub Tester()
Dim cht As Chart
Set cht = ThisWorkbook.Worksheets("mySheet3").ChartObjects("Chart 1").Chart
Dim s As Series
Set s = cht.SeriesCollection(1)
Dim vals As Variant
vals = s.Values
Const WindowSize As Long = 3
Dim Colorize As Boolean
Dim x As Long
For x = LBound(vals) To UBound(vals)
If x + WindowSize - 1 <= UBound(vals) Then
Colorize = True
Dim w As Long
For w = x To x + WindowSize - 1
If Not vals(w) > 0.7 Then
Colorize = False
Exit For
End If
Next w
If Colorize Then
For w = x To x + WindowSize - 1
With s.Points(w)
.MarkerBackgroundColor = RGB(255, 0, 0)
.MarkerForegroundColor = RGB(255, 0, 0)
End With
Next w
End If
End If
Next x
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
I have a VBA function in Excel (office 365 ProPlus) generating waterfall charts, see examples below. After generating them I want to resize the plot/legend/axis areas just to adjust the looks.
But Excel doesn't let me; the edges of the areas seem to be fixed (see blue dots/circles), I can't grab them.
I can change the axis ranges but not the area sizes. If I change the chart type e.g. to stacked bars it works.
The sheet is not protected.
Is this a known problem?
Is there a workaround?
Do I have something in my code (below) that causes this behaviour, or is something missing?
Dim rngChartValues As Range
Dim rngChartXValues As Range
Dim myChart As Chart
Dim myShape As Shape
Dim dStartValue As Double
Dim dEndValue As Double
Dim dDeltaSurplus As Double
Dim dDeltaPC As Double
Dim chartTitle As String
Dim rngToplace As Range
rngChartValues.Select
Set myShape = ActiveSheet.Shapes.AddChart2(395, xlWaterfall)
Set myChart = myShape.Chart 'ActiveChart
Application.CutCopyMode = False
rngToplace.Select
With myShape
.Left = rngToplace.Left
.Top = rngToplace.Top
.Placement = xlFreeFloating
.Height = 450
End With
With myChart
.Legend.Delete
.chartTitle.Text = chartTitle
.SeriesCollection.NewSeries
.Parent.name = chartTitle
With .FullSeriesCollection(1)
.name = chartTitle
.Values = rngChartValues
.XValues = rngChartXValues
dStartValue = shtCharts.Cells(rowCapSurplusEarlr, colCA).Value
dEndValue = shtCharts.Cells(rowCapSurplusLater, colCA).Value
dDeltaSurplus = shtCharts.Cells(rowDeltaSurplus, colCA).Value
dDeltaPC = Abs(dDeltaSurplus / dStartValue)
' handle the last bar as total bar
With .Points(.Points.Count)
.IsTotal = True
If dDeltaPC < 0.1 Then ' change is smaller than 10%
If dDeltaSurplus < 0 Then ' ...but still negative
.Format.Fill.ForeColor.RGB = RGB(255, 204, 0) ' => light orange
Else ' ... and positive
If dEndValue < 0 Then ' ... but the surplus is till negative
.Format.Fill.ForeColor.RGB = RGB(255, 204, 0) ' => light orange
Else ' ... and the surplus is positive
.Format.Fill.ForeColor.RGB = RGB(153, 204, 0) ' => light green
End If
End If
ElseIf dDeltaSurplus < 0 Then ' change is >10% and negative
.Format.Fill.ForeColor.RGB = RGB(255, 153, 0) ' => orange
Else ' cange is >10$ and positive
If dEndValue < 0 Then ' ... but the surplus is till negative
.Format.Fill.ForeColor.RGB = RGB(255, 255, 0) ' => yellow
Else ' ... and the surplus is positive
.Format.Fill.ForeColor.RGB = RGB(0, 160, 0) ' => green
End If
End If
End With
End With
End With
With myChart.Parent
intTmp = .Width
intTmp = .Height
End With
I need to rotate an horizontal line about its end point in VB Excel.
I tried various solution found on internet but they don't work well.
I give you some images about what I want to do:
This is my line:
point A (72; 378)
point B (165; 378)
And I want to rotate the point A about the point B, the angle of rotation is variable. For example this is a 60 degrees rotation
The letters A and B were added after the screenshot with a photo editor
Try this.
Sub test()
Dim x As Single, y As Single
Dim nx As Single, ny As Single, l As Single
Dim i As Single, ra As Single
Dim Ws As Worksheet
Dim shp As Shape
Set Ws = ActiveSheet
For Each shp In Ws.Shapes
If shp.Type = msoLine Then
shp.Delete
End If
Next
x = 165
y = 378
l = 165 - 72
For i = 90 To 150
ra = WorksheetFunction.Radians(i)
nx = x - Sin(ra) * l
ny = y + Cos(ra) * l
Set shp = Ws.Shapes.AddLine(x, y, nx, ny)
With shp
.Line.EndArrowheadStyle = msoArrowheadTriangle
.Line.ForeColor.RGB = RGB(255, 0, 0)
.Line.Weight = 2
End With
DoEvents
Application.Wait Now + (TimeSerial(0, 0, 1) / 2)
shp.Delete
Next i
Set shp = Ws.Shapes.AddLine(x, y, nx, ny)
With shp
.Line.EndArrowheadStyle = msoArrowheadTriangle
.Line.ForeColor.RGB = RGB(255, 0, 0)
.Line.Weight = 2
End With
End Sub
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