Autoshape creating in Excel

[davefish]

I am trying to control and or create Autoshapes in Excel. I can load a standard shape very easily using the following code :-

Sub Draw_Auto()
'
ActiveSheet.Shapes.AddShape(msoShapeTrapezoid, 308.25, 173.25, 76.5, 63.75). _
Select
End Sub

What I can't find is the location/source for the msoShape library to create a new shape similar to an sinusoid. Can anyone help??


DaveFish

 

[SkipVought]

Hi, davefish,

I don't believe that there is a shape called a sinusoid.

You can use the Object Browser and search for msoShape. You get quite a list.

Skip,
Skip@TheOfficeExperts.com

http://www.TheOfficeExperts.com

 

[SkipVought]

There is a msoShapeWave???

Skip,
Skip@TheOfficeExperts.com

http://www.TheOfficeExperts.com

 

[davefish]

Hi Skip,

Thanks for the lead, but it turned out to be more of a Design graphic, rather than an electrical symbol. I have managed to draw this though, but the script isn't that elegant. It goes like this:-

Sub Sinusoid()

With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, 528#, 280.5)
.AddNodes msoSegmentCurve, msoEditingAuto, 555#, 204#
.AddNodes msoSegmentCurve, msoEditingAuto, 576#, 184.5
.AddNodes msoSegmentCurve, msoEditingAuto, 590.25, 206.25
.AddNodes msoSegmentCurve, msoEditingAuto, 613.5, 282#
.AddNodes msoSegmentCurve, msoEditingAuto, 635.25, 353.25
.AddNodes msoSegmentCurve, msoEditingAuto, 654#, 368.25
.AddNodes msoSegmentCurve, msoEditingAuto, 671.25, 343.5
.AddNodes msoSegmentCurve, msoEditingAuto, 682.5, 303.75
.AddNodes msoSegmentCurve, msoEditingAuto, 691.5, 264#
.ConvertToShape.Name = "Curve"

End With
ActiveSheet.Shapes("Curve&quot.Select
Selection.ShapeRange.ScaleWidth 0.12, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 0.14, msoFalse, msoScaleFromBottomRight
End Sub


Is there anyway to simplify this that you know?

Regards

Dave

 

[SkipVought]

Try this...

Sub Sinusoid1()
    Dim xStart As Single, yStart As Single, xValue As Single, yValue As Single
    xStart = 0
    yStart = 10
    With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, xStart, yStart)
        For Each c In [X]
            xValue = xStart + Cells(c.Row, [X].Column).Value * 50
            yValue = Cells(c.Row, [Y].Column).Value * 50
            .AddNodes msoSegmentCurve, msoEditingAuto, xValue, yValue
        Next
        .ConvertToShape.Name = "Curve"
        With Shapes(1).DrawingObject.ShapeRange
            .Nodes.Delete 1
            .ScaleWidth 0.12, msoFalse, msoScaleFromTopLeft
            .ScaleHeight 0.14, msoFalse, msoScaleFromBottomRight
        End With
    End With
End Sub

Skip,
Skip@TheOfficeExperts.com

http://www.TheOfficeExperts.com

 

[SkipVought]

oops...

I forgot to add that I am driving this sub with 2 columns of data...
X - starts with 0 in A2, and then in A3...

=A2+Interval

Y - starts B2...

=SIN(PI()*A2)

I have named the 2 ranges X & Y respectively.



Skip,
Skip@TheOfficeExperts.com

http://www.TheOfficeExperts.com

 

[SkipVought]

Dave,

This seems to run more reliably. I moved the statement assigning the Name property of the shape. This will allow for multiple curve shapes...

Sub Sinusoid1()
    Dim xStart As Single, yStart As Single, xValue As Single, yValue As Single
    xStart = 0
    yStart = 10
    With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, xStart, yStart)
        For Each c In [X]
            xValue = xStart + Cells(c.Row, [X].Column).Value * 50
            yValue = Cells(c.Row, [Y].Column).Value * 500
            .AddNodes msoSegmentCurve, msoEditingAuto, xValue, yValue
        Next
        .ConvertToShape
        With Shapes(Shapes.Count).DrawingObject.ShapeRange
            .Name = "Curve" & Shapes.Count
            .Nodes.Delete 1
            .ScaleWidth 0.8, msoFalse, msoScaleFromBottomRight
            .ScaleHeight 0.2, msoFalse, msoScaleFromTopLeft
        End With
    End With
End Sub

Skip,
Skip@TheOfficeExperts.com

http://www.TheOfficeExperts.com

 

[IvanMoala]

You could also just Copy / Paste into a grahics program and save as a gif file.
Then when ever you need it just load it in.

ActiveSheet.Pictures.Insert( _
"C:\Documents and Settings\ivan\My Documents\My Pictures\Consultancy.gif&quot

 

[davefish]

Hi Skip,
Many thanks for the code this does seem to work more efficiently than mine. Keep up the good work

 

[davefish]

Hi Ivan,


That is where I started, but found that the quality of the lines when converting to GIF in either Corel or Visio left me wanting. The line quality by programmatically (English?)creating the shape gives a more solid line.

Regards

DaveFish