Drawing a 4-bar linkage diagram?

[emmcee]

Hey guys, I'm trying to draw this 4 bar-linkage diagram in this link: http://s1113.photobucket.com/albums/k511/Emmcee1/?action=view&current=Untitled.jpg

This is the outline that I want from it:
' Create a new bar between (x1,y1) and (x2,y2) with a coupling at either end.
' Specify bar and coupling colours using Long constants or RGB(...) calls.
' You must save the result in a Shape variable if you want to move it later.

Function NewBar(ByVal x1 As Double, ByVal y1 As Double, ByVal x2 As Double, ByVal y2 As Double, _ ByVal lngBarColour As Long, ByVal lngCouplingColour As Long) As Shape

End Function


Somehow I tried doing this, but it wouldn't work like nothing pops up in the drawing when I click run. This is what i coded:

Option Explicit

'
' Main subprogram is DrawFigure
' The first part (adding a sheet and removing grid and margin labels) is done for you
' The rest requires you to pick up parameters from named cells,
' to draw 4-bar linkage at specified location, and
' apply fills according to the parameter sheet.

' Cell names. Use wksParams.Range(NAME_CX) etc to obtain cell contents.

Const NAME_CX = "CentreX"
Const NAME_CY = "CentreY"

Sub DrawFigure()
' Local variables
Dim wksParams As Worksheet
Dim shp As Shape
Dim cx As Single, cy As Single

' Identify parameters sheet. Use wksParams.Range(...) rather than ActiveSheet
Set wksParams = Sheets("FigParams")

' Create new clean sheet, this becomes the active sheet
Sheets.Add

With ActiveWindow
.DisplayGridlines = False
.DisplayHeadings = False
End With

' Obtain positional parameters from the active sheet

cx = wksParams.Range(NAME_CX).Value
cy = wksParams.Range(NAME_CY).Value

End Sub

Function Aline(x As Single, y As Single) As Shape

Set Aline = ActiveSheet.Shapes.AddShape(msoShapeline… x, y)

End Function

Can anyone help me with another code that might work with this figure?

 

[bertie]

I had a wee look at your problem and I though I would give it a try. Most of the code was obtained using the macro recorder. It will not be the most efficient way of doing this but, hopefully, it will give you something to play around with.

As we are working with two shapes, line and oval, I have added a ShapeType argument to your function, 1=line, 2=oval.

The function uses an If statement to determine which shape to draw.

  [COLOR=darkblue]If[/COLOR] ShapeType = 1 [COLOR=darkblue]Then[/COLOR] [COLOR=green]'line[/COLOR]
    [COLOR=darkblue]Set[/COLOR] tmpShape = ws.Shapes.AddLine(x1, y1, x2, y2)
    [COLOR=darkblue]With[/COLOR] tmpShape
        .Line.Weight = 2
        .Line.ForeColor.SchemeColor = lngBarColour
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
  [COLOR=darkblue]Else[/COLOR]  [COLOR=green]'oval[/COLOR]
    [COLOR=darkblue]Set[/COLOR] tmpShape = ws.Shapes.AddShape(msoShapeOval, x1, y1, x2, y2)
    [COLOR=darkblue]With[/COLOR] tmpShape
        .Line.Weight = 1
        .Line.ForeColor.SchemeColor = lngCouplingColour
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
  [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]

I assume you have accurate coordinates to send to the function, but if you are doing this manually you should note the relationship where the lines stop and starts. i.e.,

  [COLOR=green]'draw lines[/COLOR]
  [COLOR=darkblue]Set[/COLOR] lineTop = NewBar([COLOR=red]100, 50[/COLOR], [COLOR=blue]250, 40[/COLOR], 18, 0, 1)      [COLOR=seagreen]'maroon line[/COLOR]
  [COLOR=darkblue]Set[/COLOR] lineRight = NewBar([COLOR=blue]250, 40[/COLOR], [COLOR=seagreen]300, 150[/COLOR], 11, 0, 1)   [COLOR=green]'dark blue[/COLOR]
  [COLOR=darkblue]Set[/COLOR] lineBottom = NewBar([COLOR=seagreen]300, 150[/COLOR], [COLOR=darkorchid]90, 150[/COLOR], 16, 0, 1)  [COLOR=seagreen]'dark grey[/COLOR]
  [COLOR=darkblue]Set[/COLOR] lineLeft = NewBar([COLOR=darkorchid]90, 150[/COLOR], [COLOR=red]100, 50[/COLOR], 10, 0, 1)     [COLOR=green]'dark green[/COLOR]

You will also need to play about the the line colours, my attempt didn't turn out right.

The full code goes into the ThisWorkbook module and the drawing is inserted into sheet1.
Try it out on a new workbook.

To get a better understanding of the code step through it, press F8, rather than running it.

[COLOR=darkblue]Sub[/COLOR] DrawShape()
  [COLOR=green]'lines[/COLOR]
  [COLOR=darkblue]Dim[/COLOR] lineTop [COLOR=darkblue]As[/COLOR] Shape
  [COLOR=darkblue]Dim[/COLOR] lineRight [COLOR=darkblue]As[/COLOR] Shape
  [COLOR=darkblue]Dim[/COLOR] lineBottom [COLOR=darkblue]As[/COLOR] Shape
  [COLOR=darkblue]Dim[/COLOR] lineLeft [COLOR=darkblue]As[/COLOR] Shape
  [COLOR=green]'couplings[/COLOR]
  [COLOR=darkblue]Dim[/COLOR] coupTopRight [COLOR=darkblue]As[/COLOR] Shape
  [COLOR=darkblue]Dim[/COLOR] coupBottomRight [COLOR=darkblue]As[/COLOR] Shape
  [COLOR=darkblue]Dim[/COLOR] coupBottomLeft [COLOR=darkblue]As[/COLOR] Shape
  [COLOR=darkblue]Dim[/COLOR] coupTopLeft [COLOR=darkblue]As[/COLOR] Shape
 
  [COLOR=green]'draw lines[/COLOR]
  [COLOR=darkblue]Set[/COLOR] lineTop = NewBar(100, 50, 250, 40, 18, 0, 1)      'maroon line
  [COLOR=darkblue]Set[/COLOR] lineRight = NewBar(250, 40, 300, 150, 11, 0, 1)   [COLOR=green]'dark blue[/COLOR]
  [COLOR=darkblue]Set[/COLOR] lineBottom = NewBar(300, 150, 90, 150, 16, 0, 1)  'dark grey
  [COLOR=darkblue]Set[/COLOR] lineLeft = NewBar(90, 150, 100, 50, 10, 0, 1)     [COLOR=green]'dark green[/COLOR]
 
  [COLOR=green]'draw couplings[/COLOR]
  [COLOR=darkblue]Set[/COLOR] coupTopRight = NewBar(244.5, 35.25, 8.25, 9#, 0, 16, 2)
  [COLOR=darkblue]Set[/COLOR] coupBottomRight = NewBar(294.75, 145.5, 8.25, 9#, 0, 16, 2)
  [COLOR=darkblue]Set[/COLOR] coupBottomLeft = NewBar(86.25, 144.75, 9#, 9#, 0, 16, 2)
  [COLOR=darkblue]Set[/COLOR] coupTopLeft = NewBar(94.5, 45.75, 9#, 9.75, 0, 16, 2)
 
  [COLOR=green]'group the shape[/COLOR]
  Sheets("Sheet1").Shapes.SelectAll
  Selection.ShapeRange.Group.Select
  Selection.Name = "Bertie"
 
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]
 
[COLOR=darkblue]Function[/COLOR] NewBar([COLOR=darkblue]ByVal[/COLOR] x1 [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Double[/COLOR], _
                [COLOR=darkblue]ByVal[/COLOR] y1 [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Double[/COLOR], _
                [COLOR=darkblue]ByVal[/COLOR] x2 [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Double[/COLOR], _
                [COLOR=darkblue]ByVal[/COLOR] y2 [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Double[/COLOR], _
                [COLOR=darkblue]ByVal[/COLOR] lngBarColour [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR], _
                [COLOR=darkblue]ByVal[/COLOR] lngCouplingColour [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR], _
                [COLOR=darkblue]ByVal[/COLOR] ShapeType [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]) [COLOR=darkblue]As[/COLOR] Shape
 
  [COLOR=darkblue]Dim[/COLOR] tmpShape [COLOR=darkblue]As[/COLOR] Shape
  [COLOR=darkblue]Dim[/COLOR] ws [COLOR=darkblue]As[/COLOR] Worksheet
  [COLOR=darkblue]Set[/COLOR] ws = Sheets("Sheet1")
 
  [COLOR=darkblue]If[/COLOR] ShapeType = 1 [COLOR=darkblue]Then[/COLOR] [COLOR=green]'line[/COLOR]
    [COLOR=darkblue]Set[/COLOR] tmpShape = ws.Shapes.AddLine(x1, y1, x2, y2)
    [COLOR=darkblue]With[/COLOR] tmpShape
        .Line.Weight = 2
        .Line.ForeColor.SchemeColor = lngBarColour
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
  [COLOR=darkblue]Else[/COLOR]  [COLOR=green]'oval[/COLOR]
    [COLOR=darkblue]Set[/COLOR] tmpShape = ws.Shapes.AddShape(msoShapeOval, x1, y1, x2, y2)
    [COLOR=darkblue]With[/COLOR] tmpShape
        .Line.Weight = 1
        .Line.ForeColor.SchemeColor = lngCouplingColour
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
  [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
 
  [COLOR=darkblue]Set[/COLOR] NewBar = tmpShape
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Function[/COLOR]

As I said earlier, most of this code was generated by the macro recorder. All I have done is tidy it up.

If you want to colour in the interior of finished shape you may want to use the macro recorder to draw an enclosed free form shape. Or you may be able to do this after the shapes are grouped together.

Hope this helps,
Bertie

 

[emmcee]

Heys, thanks for your help, I tried it and it worked just that I need to change the colours a little.

Just wanted to ask Do you think if I wanted to animate it like allow the bars to move around clockwise for instance, Would I be able to do that? Where all the 4 bars including the coupling moves around together?

Thanks.

 

[bertie]

After the code runs all the shapes you added will be grouped, i.e., act as one shape.

Record a macro and rotate it any way you wish.

You will find the code the recorder generates in a standard module, e.g., Module1

 

[emmcee]

Ok, since it is grouped now does that mean if i wished to just leave the bottom bar as it is (fixed) and allow the other bars to move clockwise around the left coupler does that mean I cannot do that? If i want a simulation of the 3 other bars around one fixed bar (the coupler)?

 

[bertie]

I am not quite sure what you mean.

Ungrouped you have eight objects, 4 lines and 4 ovals (couplers). These can be manipulated independently.

When they are grouped they behave as one object.

i.e., If you run the code and rotate the resultant object you will see it rotates as if it is one object.

 

[emmcee]

I'm saying that If i wanted to leave one bar fixed whilst the others rotate, can that happen? or is it the whole parallelogram can only rotate?

I'm still not sure how you used marco to move the bars around, i tried recording it but it wouldn't work.

 

[bertie]

The position of a line is determined by its x and y coordinates.

Consider the bottom and right hand side lines. After the initial run we would have:

  [COLOR=darkblue]Set[/COLOR] lineRight = NewBar([COLOR=red]250[/COLOR], [COLOR=blue]40[/COLOR], [COLOR=red]300[/COLOR], [COLOR=blue]150[/COLOR], 11, 0, 1)   [COLOR=green]'dark blue[/COLOR]
  [COLOR=darkblue]Set[/COLOR] lineBottom = NewBar(300, 150, 90, 150, 16, 0, 1) [COLOR=seagreen]'dark grey[/COLOR]

If you wanted to leave the bottom line fixed its coordinates would remain as is, but lineRight would need new x, y coordinates.

The same applies for the other two lines.

EDIT: If you group the objects you can flip it over on its axis, or rotate it. The macro recorder wll give you the code for this.

 

[bertie]

ps

Here is code I got using the recorder to rotate the shape after it had been grouped.

The Pause routine slows it down so you can see what is happening.

[COLOR=darkblue]Sub[/COLOR] Rotate()
    Sheets("Sheet1").Shapes("Bertie").Select
    Selection.ShapeRange.IncrementRotation 5
    Pause
    Selection.ShapeRange.IncrementRotation 5
    Pause
    Selection.ShapeRange.IncrementRotation 5
    Pause
    Selection.ShapeRange.IncrementRotation 5
    Pause
    Selection.ShapeRange.IncrementRotation 5
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]
[COLOR=#00008b][/COLOR] 
 
[COLOR=darkblue]Private[/COLOR] [COLOR=darkblue]Sub[/COLOR] Pause()
  [COLOR=darkblue]Dim[/COLOR] start [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Single[/COLOR]
  [COLOR=darkblue]Dim[/COLOR] t [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Single[/COLOR]
 
  t = 0.5
  start = Timer
  [COLOR=darkblue]Do[/COLOR] [COLOR=darkblue]While[/COLOR] Timer < start + t
    DoEvents
  [COLOR=darkblue]Loop[/COLOR]
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]

 

[emmcee]

heys bernie,

I tried that and yes the whole group rotates around 360 degrees but I'm trying to find a way to keep the bottom bar fixed as the others rotate such as seen in this link: http://www.mekanizmalar.com/fourbar01.html

I've tried your method of keeping the bottom line fixed and its coordinates would remain as is whilst the lineright would have new x and y coordinated but each time i change the coordinates the bars go out of shape or get longer like it doesn't stay in the same position.