rotation of an arrow created by an drawing object

T

TONY

Below is a macro that first creates "cross hairs" on the spread sheet No
problem her. In addition a 3rd line is created with an arrow head no problem
here either.

I can select the arrow open the format boxx and change it's rotation with no
problem, however I can not from within the program itself. The arrow moves
to aprox 45 degrees and does not at all.

Sub Macro20()
'
' Macro20 Macro
' Macro recorded 12/24/2007 by Anthony Keefe
'
cSize = 50
Range("a1").Select

Set myHz = ActiveSheet.Shapes.AddLine(0.075, Application.UsableHeight * 0.5,
Application.UsableWidth, Application.UsableHeight * 0.5)
Set myv = ActiveSheet.Shapes.AddLine(Application.UsableWidth * 0.5, 0.075,
Application.UsableWidth * 0.5, Application.UsableHeight)


Set dial = ActiveSheet.Shapes.AddLine(Application.UsableWidth * 0.5 -
cSize, Application.UsableHeight * 0.5 + cSize, _
(Application.UsableWidth * 0.5 +
cSize), (Application.UsableHeight * 0.5) - cSize)

With dial.Line
.EndArrowheadStyle = msoArrowheadTriangle
.EndArrowheadLength = msoArrowheadLengthMedium
.EndArrowheadWidth = msoArrowheadWidthMedium

End With
With dial

.Rotation = 0# ' Reset arrow to 0
.Rotation = 1#
.Rotation = 2#
End With




myHz.delete
myv.delete
dial.delete


End Sub
 
J

Joel

You can't rotate a line like you would a shape. Setting your origins
properly you can make the rotation much easier. See the code below. You may
want to change the scale as needed.

Direction is backwards on a spreadsheet. Positive Y is in the direction of
increasing rows. To compensate, the plus and minus signs in the Start Y and
End Y are opposite from the Start X and Start Y.

Sub MacroJoel()
'
' Macro20 Macro
' Macro recorded 12/24/2007 by Anthony Keefe
'

Pi = 3.14159265358979
cSize = 50
Range("a1").Select

MarginLeft = 0.075
OriginX = (Application.UsableWidth + MarginLeft) / 2
MarginTop = 0.075
OriginY = (Application.UsableHeight + MarginTop) / 2

Set myHz = ActiveSheet.Shapes. _
AddLine(MarginLeft, OriginY, _
2 * OriginX, OriginY)
Set myv = ActiveSheet.Shapes. _
AddLine(OriginX, MarginBottom, _
OriginX, 2 * OriginY)

Angle = 45#
radian = (Angle * Pi) / 180#
StartX = OriginX - (cSize / 2 * Cos(radian))
EndX = OriginX + (cSize / 2 * Cos(radian))
'plus and minus opposite from x because positive
'y direction is backwards on spreadsheet.
StartY = OriginY + (cSize / 2 * Sin(radian))
EndY = OriginY - (cSize / 2 * Sin(radian))

Set dial = ActiveSheet.Shapes. _
AddLine(StartX, StartY, EndX, EndY)

With dial.Line
.EndArrowheadStyle = msoArrowheadTriangle
.EndArrowheadLength = msoArrowheadLengthMedium
.EndArrowheadWidth = msoArrowheadWidthMedium

End With

myHz.Delete
myv.Delete
dial.Delete


End Sub
 
T

TONY

Thanks Jole that helped.

I have come across another problem with the basicly the same code.

you see how "dial" and "tickmark" varriables are set to line objects. Below
is a snipet of code that causes the problem.

Set currentGroup = ActiveSheet.Shapes.Range(Array(Dial, tickmark)) 'no problem


With currentGroup' no problem here
.Group.Select ' no problem here
.Rotation = I 'no problem here
.Ungroup.Select BIG PROBLEM HERE
End With

The Ungroup.select executes with no problem itself, but the object
varriables "Dial", "TickMark" and "currentGroup" are set to nothing they no
longer point to the line objects created. Can you help?

One other thing. Is there a all comprehensive book that covers VBA. I have 5
books all claiming to be the "definitive" guid, they only skim the various
subjects.


Thanks Tony
 
J

Joel

Take out any ON ERROR statement yhou may have in your code while debugging.
The ON ERROR statements tend to skip around where the real problem lies. I
don't have all your code and don't think what you are doing will work

I don't know what dial or tickmark are equal to, but if dial is the same
code as before I do't think this will work

Set currentGroup = ActiveSheet.Shapes.Range(Array(Dial, tickmark)) 'no problem

You only added one Dial shape to the worksheet and it is not an array.


I found the code belowin the VBA help. I doesn't show everything
-----------------------------------------------------------------------------------------------
Use Shapes.Range(index), where index is the shape’s name or index number or
an array of shape names or index numbers, to return a ShapeRange collection
that represents a subset of the Shapes collection. The following example sets
the fill pattern for shapes one and three on myDocument.

Set myDocument = Worksheets(1)
myDocument.Shapes.Range(Array(1, 3)).Fill.Patterned _
msoPatternHorizontalBrick
 
T

TONY

I used your sugestions with sucess. The lines of code work well. Basicly it
creates a guage. One of the last objects added is a circle with the following
line of code.

Set myCircle = ActiveSheet.Ovals.Add(OriginX - (cSize \ 2), OriginY - (cSize
\ 2), _
cSize, cSize)
this works fine, but I wantt the circle to be a bit bigger than the actual
tick marks on the guage so I modify this line of code by adding the varriable
"offset" to the last to parms.

Set myCircle = ActiveSheet.Ovals.Add(OriginX - (cSize \ 2), OriginY - (cSize
\ 2), _
cSize + offset, cSize+ offset)

when this line of code is executed then the circle is bigger, hoever it is
offset from the origin by a few points and I cant figure out why. Can you
help







Sub Tick()

'you can 't rotate a line like you would a shape. Setting your origins
'properly you can make the rotation much easier. See the code below. You may
'want to change the scale as needed.

'Direction is backwards on a spreadsheet. Positive Y is in the direction of
'increasing rows. To compensate, the plus and minus signs in the Start Y and
'End Y are opposite from the Start X and Start Y.

'
' Macro20 Macro
' Macro recorded 12/24/2007 by Anthony Keefe
'

Dim TickAray(360) As Object
Dim ThisHorizontalAxis As Variant
Dim ThisVerticalAxis As Variant
Pi = 3.14159265358979


ticks = 1
TickSize = 5
stepFreq = 5
MajorTickFrequency = 45
cSize = 200
InstrumentLable = "ProtoType"
Offset = 25

Call FindOrgin(OriginX, OriginY)
Call DrawAxes(OriginX, OriginY, oThisHorizontalAxis, oThisVerticalAxis)



For I = 360 To ticks Step -stepFreq
Call DevelopVectors(I, OriginX, OriginY, StartX, EndX, StartY, EndY, cSize)


If I Mod MajorTickFrequency = 0 Then
TickType = 2#
TickSize = 10
Else
TickType = 0.025
TickSize = 5
End If



radian = (I * Pi) / 180#
StartTickX = EndX
StartTickY = EndY
EndTickX = StartTickX + (TickSize * Cos(radian))
EndTickY = StartTickY - (TickSize * Sin(radian))

Set oTick = ActiveSheet.Shapes. _
AddLine(StartTickX, StartTickY, EndTickX, EndTickY)





With oTick
.Rotation = 180
'.Name = "G_" & InstrumentLable & "Tick" & i
.Line.Weight = TickType
.Visible = msoTrue
.Line.BackColor.RGB = RGB(255, 255, 255)
.Line.BeginArrowheadStyle = msoArrowheadNone
.Line.EndArrowheadLength = msoArrowheadLengthMedium
.Line.EndArrowheadWidth = msoArrowheadWidthMedium
.Line.EndArrowheadStyle = msoArrowheadNone
End With


Set TickAray(I) = oTick

'dial.delete
Next
Set dial = ActiveSheet.Shapes. _
AddLine(StartX + 4, StartY + 4, EndX - 4, EndY - 4)
With dial
.Line.Weight = 4
.Line.EndArrowheadStyle = msoArrowheadTriangle
.Line.EndArrowheadLength = msoArrowheadLengthMedium
.Line.EndArrowheadWidth = msoArrowheadWidthMedium
End With


Set myCircle = ActiveSheet.Ovals.Add(OriginX - (cSize \ 2), OriginY - (cSize
\ 2), _
cSize, cSize)


With myCircle
..ShapeRange.ZOrder msoSendToBack
End With

'oThisHorizontalAxis.delete
'oThisVerticalAxis.delete
'ActiveSheet.Lines.Group




z = z

End Sub


Sub DevelopVectors(Angle, OriginX, OriginY, StartX, EndX, StartY, EndY, cSize)
Pi = 3.14159265358979

radian = (Angle * Pi) / 180#
StartX = OriginX - ((cSize / 2) * Cos(radian))
EndX = OriginX + (cSize / 2 * Cos(radian))
'plus and minus opposite from x because positive
'y direction is backwards on spreadsheet.
StartY = OriginY + (cSize / 2 * Sin(radian))
EndY = OriginY - (cSize / 2 * Sin(radian))


End Sub

Sub DrawAxes(OriginX As Variant, OriginY As Variant, ByRef
oThisHorizontalAxis As Variant, ByRef oThisVerticalAxis As Variant)



Set oThisHorizontalAxis = ActiveSheet.Shapes.AddLine(MarginLeft, OriginY, 2
* OriginX, OriginY) 'Draw X Axis
Set oThisVerticalAxis = ActiveSheet.Shapes.AddLine(OriginX, MarginBottom,
OriginX, 2 * OriginY) ' Draw Y Axis

End Sub

Sub FindOrgin(OriginX As Variant, OriginY As Variant)
Range("a1").Select

MarginLeft = 0.075
OriginX = (Application.UsableWidth + MarginLeft) / 2
MarginTop = 0.075
OriginY = (Application.UsableHeight + MarginTop) / 2
End Sub

Sub ObjectHitMan()


For Each ContractObject In ActiveSheet.Shapes
ContractObject.delete
Next
End Sub
 
J

Joel

Left should be the XOrigin minus 1/2 the width of the object
Top should be YOrigin plus 1/2 the height. Does this make sense?

Then if you change the height or width by an offset you need to add 1/2 the
offset to the left and top position.


Set myCircle = ActiveSheet.Ovals.Add(OriginX - ((cSize + offset)\ 2), _
OriginY - ((cSize + offset)\ 2), cSize + offset, cSize+ offset)
 
K

Ken Johnson

Below is a macro that first creates "cross hairs" on the spread sheet No
problem her. In addition a 3rd line is created with an arrow head no problem
here either.

I can select the arrow open the format boxx and change it's rotation with no
problem, however I can not from within the program itself. The arrow moves
to aprox 45 degrees and does not at all.

Sub Macro20()
'
' Macro20 Macro
' Macro recorded 12/24/2007 by Anthony Keefe
'
cSize = 50
Range("a1").Select

Set myHz = ActiveSheet.Shapes.AddLine(0.075, Application.UsableHeight * 0.5,
Application.UsableWidth, Application.UsableHeight * 0.5)
Set myv = ActiveSheet.Shapes.AddLine(Application.UsableWidth * 0.5, 0.075,
Application.UsableWidth * 0.5, Application.UsableHeight)

Set dial = ActiveSheet.Shapes.AddLine(Application.UsableWidth * 0.5 -
cSize, Application.UsableHeight * 0.5 + cSize, _
(Application.UsableWidth * 0.5 +
cSize), (Application.UsableHeight * 0.5) - cSize)

With dial.Line
.EndArrowheadStyle = msoArrowheadTriangle
.EndArrowheadLength = msoArrowheadLengthMedium
.EndArrowheadWidth = msoArrowheadWidthMedium

End With
With dial

.Rotation = 0# ' Reset arrow to 0
.Rotation = 1#
.Rotation = 2#
End With

myHz.delete
myv.delete
dial.delete

End Sub
Click to expand...

Hi Tony,

I'm not sure what it is that you're trying to do, but I'm guessing you
want to see that arrow rotate. You're original code will make the
arrow rotate, the only important thing missing is DoEvents. To
illustrate, below is your original code with a Do Loop thrown in with
an incrementing Single (K). You can alter the rotation speed by
increasing the increment size eg K = K + 2 is faster and K = K + 0.5
is slower.

All I have done is added "Dim K as Single" at the top and replaced...

..Rotation = 0# ' Reset arrow to 0
.Rotation = 1#
.Rotation = 2#

with...

Do While K < 720 'Two revolutions
K = K + 1
.Rotation = K
DoEvents
Loop

Sub Macro20()
'
' Macro20 Macro
' Macro recorded 12/24/2007 by Anthony Keefe
'
Dim K As Single
cSize = 50
Range("a1").Select

Set myHz = ActiveSheet.Shapes.AddLine(0.075, Application.UsableHeight
* 0.5, _
Application.UsableWidth, Application.UsableHeight * 0.5)
Set myv = ActiveSheet.Shapes.AddLine(Application.UsableWidth * 0.5,
0.075, _
Application.UsableWidth * 0.5, Application.UsableHeight)

Set dial = ActiveSheet.Shapes.AddLine(Application.UsableWidth * 0.5 -
_
cSize, Application.UsableHeight * 0.5 + cSize, _
(Application.UsableWidth * 0.5
+ _
cSize), (Application.UsableHeight * 0.5) - cSize)

With dial.Line
.EndArrowheadStyle = msoArrowheadTriangle
.EndArrowheadLength = msoArrowheadLengthMedium
.EndArrowheadWidth = msoArrowheadWidthMedium

End With
With dial
Do While K < 720 'Two revolutions
K = K + 1
.Rotation = K
DoEvents 'this enable visible rotation of the arrow
'Doesn't work as well on a Mac (OSX), where you have to
'continually move the mouse to achieve visible motion,
which sucks.
Loop
End With

myHz.Delete
myv.Delete
dial.Delete

End Sub

Ken Johnson
 
Top