rotation of an arrow created by an drawing object
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
"Joel" wrote:
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 shapes 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
------------------------------------------------------------------------------------------
Note in the expalination it says "shapes one and three". You need to have
an array of lines called "Dial" (more than one).
Also shapes have a visable property. You may want to have many dial shapes
on your worksheet and only make one of them visible at a time.
"TONY" wrote:
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
"TONY" wrote:
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
|