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
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 am creating shapes on a PowerPoint slide from Excel but it is incredibly slow because each shape is drawn and the screen is updating very slowly. I'm using office 365.
I have seen various posts pointing to the link below - but it appears to be for older versions. Even adding in another line for version 16 isn't doing anything
Case "16"
hWnd = FindWindow("PPTFrameClass", 0&)
PowerPoint VBA Equivalent of Application.ScreenUpdating
Has anyone managed to get this working so I can run Excel VBA, updating PowerPoint without any screen flicker and fast speeds.
Hope there is a solution to this.
Edit: Here is some sample code to run that shows the sort of thing I'm doing. Just need to add reference to Microsoft PowerPoint 16.0 Object Library
Option Explicit
Public PPT As PowerPoint.Application
Public PRES As PowerPoint.presentation
Public SLIDE As PowerPoint.SLIDE
Public CANV As PowerPoint.Shape
Public SHP As PowerPoint.Shape
Sub OpenPowerPoint()
Set PPT = CreateObject("Powerpoint.Application")
Set PRES = PPT.Presentations.Add
PPT.Visible = True
Set SLIDE = PRES.Slides.Add(PPT.ActivePresentation.Slides.Count + 1, ppLayoutText)
End Sub
Sub CreatePPTShapes()
If PRES Is Nothing Then OpenPowerPoint
Dim l As Long, t As Long, w As Long, h As Long, x As Long
Dim size As Long, m As Long, nm As String
Dim startDate As Long
startDate = DateSerial(2021, 4, 1)
l = 5
t = 70
w = PRES.PageSetup.SlideWidth - 10
h = PRES.PageSetup.SlideHeight - 75
Set CANV = SLIDE.Shapes.AddShape(msoShapeRectangle, l, t, w, h)
With CANV
.Name = "ta_canvas"
With .Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(240, 240, 240)
.Transparency = 0
.Solid
End With
With .Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.Transparency = 0.5
.Weight = 0.25
End With
End With
t = t + 5
w = (w) / 12
h = 20
For x = 0 To 2
For m = 0 To 11
nm = MonthName(Month(DateAdd("m", m, startDate)), True)
t = 70 + 7 + (x * 25)
l = 10 + (w * m)
Dim newPos As Long
Set SHP = SLIDE.Shapes.AddShape(msoShapeRoundedRectangle, l, t, w, h)
With SHP
.Name = "ta_" & nm
.Adjustments(1) = 0.25
.Line.Visible = msoFalse
.Fill.Visible = True
.Fill.ForeColor.RGB = RGB(0, 0, 0)
With .TextFrame2
.TextRange.Characters.Text = nm
.MarginLeft = 2.8346456693
.MarginRight = 2.8346456693
.MarginTop = 0
.MarginBottom = 0
.WordWrap = msoFalse
.AutoSize = msoAutoSizeShapeToFitText
With .TextRange.ParagraphFormat
.FirstLineIndent = 0
.Alignment = msoAlignCenter
End With
.VerticalAnchor = msoAnchorMiddle
With .TextRange.Font
.size = 12
With .Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 255, 255)
End With
End With
End With
End With
Next m
Next x
End Sub
I've found that if I switch the view in code to the handout master then the code runs much much quicker. It looks like the screen updating is suspended.
ppt.activewindow.viewtype = ppviewhandoutmaster
then switch it back at the end to ppViewNormal or whichever your preferred default view.
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 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
Is there a method for accessing the coordinates of the start and end point of an msoLine shape object? I am working with legacy files in Excel 2010 (from Excel 2003 I think).
Given an msoFreeform object I can access the various coordinates in turn using something like:
With myDocument.Shapes(i)
If .Type = msoFreeform Then
nodeCount = .Nodes.Count
For k = 1 To nodeCount
pointsArray = .Nodes.Item(k).Points
X1 = pointsArray(1, 1)
Y1 = pointsArray(1, 2)
Next k
End If
End With
But this method fails for msoLine objects with the .Nodes.Item(k).Points returning nothing, even though .Nodes.Count returns 2 for a start point and an end point.
Am I missing something?
This works:
'The "flips" helps to work out which pair of corners of an imaginary rectangle surrounding the line represents the correct diagonal.
Sub testLineCoords()
Dim bHflip As Boolean
Dim bVflip As Boolean
Dim nBegin As Long
Dim nEnd As Long
Dim oShape As Shape
Dim aC(1 To 4, 1 To 2) As Double
Set oShape = ShTmp.Shapes("MyLine")
With oShape
aC(1, 1) = .Left: aC(1, 2) = .Top
aC(2, 1) = .Left + .Width: aC(2, 2) = .Top
aC(3, 1) = .Left: aC(3, 2) = .Top + .Height
aC(4, 1) = .Left + .Width: aC(4, 2) = .Top + .Height
bHflip = .HorizontalFlip
bVflip = .VerticalFlip
End With
If bHflip = bVflip Then
If bVflip = False Then
' down to right
nBegin = 1: nEnd = 4
Else
' up to left
nBegin = 4: nEnd = 1
End If
ElseIf bHflip = False Then
' up to right
nBegin = 3: nEnd = 2
Else
' down to left
nBegin = 2: nEnd = 3
End If
Debug.Print "---------------------------------"
Debug.Print "Begin X:Y"
Debug.Print aC(nBegin, 1); aC(nBegin, 2)
Debug.Print "End X:Y"
Debug.Print aC(nEnd, 1); aC(nEnd, 2)
End Sub
Unfortunately I can't take credit for it:
Original solution
Regards,
Emiel
If you want to get X/Y starting and ending points for msoLine do the followings:
Dim myMsoLine As Shape
Set myMsoLine = ActiveSheet.Shapes(3)
Dim X1, X2, Y1, Y2
'points of msoLine
With myMsoLine
X1 = .Left
Y1 = .Top
X2 = .Width + .Left
Y2 = .Height + .Top
End With
Debug.Print X1, Y1, X2, Y2
Generally, there are no nodes in msoLine shapes in this situation.
(Tested for Excel 2010)