PC & Mediji 1997 January/PCM_9701.iso/programi/minicad/minicad.1/SPURGEAR.MPC

Text File | 1996-04-30 | 5.5 KB | 222 lines

Procedure SpurGear;
{
(Windows version)
⌐1996, Diehl Graphsoft, Inc.
Developed by Tom Urie

This procedure draws a spur gear.
}
LABEL 20,98,99;
CONST
    f1=0.3966;  {These five constants are used to modify the six points}
    fx1=0.935;    {that define the tooth profile so that the bezier curve}
    fy1=0.5;      {approximates an involute curve.}
    fx2=1.105;
    fy2=1.25;
VAR
    Alpha,A1,Beta,PDia:REAL;
    a,b,OD,RD,DPitch,r: REAL;
    x0,y0,x0t,y0t : REAL;
    x,y,xt,yt : ARRAY[1..6] OF REAL;
    Theta1,Theta2 : REAL;
    j,k,NTeeth:INTEGER;
    Curves,Abort:BOOLEAN;

Procedure GearDialog;
{
This procedure defines the dialog box.
}
VAR
    Width,x1,y1,x2,y2,px1,px2,px3,px4,py1,py2 : INTEGER;

Procedure AlignScr(Width:INTEGER; VAR x1,x2:INTEGER);
VAR
    scrx1,scry1,scrx2,scry2:INTEGER;
BEGIN
    GetScreen(scrx1,scry1,scrx2,scry2);
    x1:=((scrx1+scrx2) div 2)-(Width div 2);
    x2:=x1+Width;
END;

Procedure MakeDialog;
CONST
    y1=100;
    scnh=180; scnw=280;
    h=30;
BEGIN
    AlignScr(scnw,x1,x2);
    y2:=y1+scnh;
    px1:=scnw-160;
    px2:=scnw-100;
    px3:=scnw-80;
    px4:=scnw-20;
    py1:=scnh-40;
    py2:=scnh-20;

    BeginDialog(1,1,x1,y1,x2,y2);
        AddButton('OK',1,1,px1,py1,px2,py2);
        AddButton('Cancel',2,1,px3,py1,px4,py2);
        AddField('No. of Teeth:',4,1,20,45-h,145,60-h);
        AddField('0',5,2,150,45-h,245,60-h);
        AddField('Pitch Diameter:',6,1,20,70-h,145,85-h);
        AddField('0',7,2,150,70-h,245,85-h);
        AddField('Diametral Pitch:',8,1,20,95-h,145,110-h);
        AddField('0',9,2,150,95-h,245,110-h);
        AddButton('Curved Teeth',10,2,20,120-h,135,135-h);
    EndDialog;
END;

BEGIN
    MakeDialog;
END;

Procedure GetInfo;
{
This procedure displays the dialog box and retrieves the information.
}
VAR
    Done,Go,Select10,OK : BOOLEAN;
    Item : INTEGER;
BEGIN
    Done:=FALSE;
    Abort:=FALSE;
    NTeeth:=24;
    PDia:=3;
    DPitch:=8;
    GetDialog(1);
    SetTitle('Spur Gears');
    Curves:=FALSE;
    SetField(5,Num2Str(0,NTeeth));
    SetField(7,Num2Str(4,PDia));
    SetField(9,Num2Str(2,DPitch));
    SelField(5);
    Select10:=FALSE;
    REPEAT
        DialogEvent(Item);
        IF Item=1 THEN
            Done:=TRUE;
        IF Item=2 then BEGIN
            Done:=TRUE;
            Abort:=TRUE;
        END;
        IF Item=5 THEN BEGIN
            OK:=ValidNumStr(getfield(5),NTeeth);
            IF NOT OK THEN BEGIN
                Sysbeep;
                SetField(5,Num2Str(0,NTeeth));
                SelField(5);
            END;
            IF DPitch <> 0 THEN
                PDia:=NTeeth/DPitch;
            SetField(7,Num2Str(4,PDia));
        END;
        IF Item=7 THEN BEGIN
            Go:=ValidNumStr(getfield(7),PDia);
            IF PDia <> 0 THEN
                DPitch:=NTeeth/PDia;
            SetField(9,num2str(2,DPitch));
        END;
        IF Item=9 THEN BEGIN
            Go:=ValidNumStr(GetField(9),DPitch);
            IF DPitch <> 0 THEN
                PDia:=NTeeth/DPitch;
            SetField(7,Num2Str(4,PDia));
        END;
        IF Item=10 THEN BEGIN
            SetItem(10, NOT ItemSel(10));
            Curves:= ItemSel(10);
        END;
    UNTIL DONE;
    ClrDialog;
END;

{
Main program.
}
BEGIN
{
Display the dialog box and get the info.
}
    GearDialog;
    SetCursor(ArrowC);
    GetInfo;
    IF Abort THEN GOTO 99;
    DSelectAll;
{
Get location of the gear.
}
    GetPt(x0,y0);
{
Calculate gear parameters.
}
    a:=1/DPitch;                        {Addendum}
    b:=1.157/DPitch;        {Dedendum}
    OD:=PDia+2*a;                {Outside diameter}
    RD:=PDia-2*b;              {Root diameter}
    r:=1.5*(b-a);                    {Root fillet}
    Alpha:=Deg2Rad(360/NTeeth);        {Angle between teeth}
    Beta:=Alpha/4;
    y0:=y0+RD/2;  {Point on the root diameter at Alpha=0}
{
Calculate the six points (x[1],y[1]...x[6],y[6]) that define the tooth profile.
}
    x[1]:=-PDia*Sin(Beta)/2;
    Theta1:=ArcSin(2*x[1]/RD);
    y[1]:=-RD*(1-Cos(Theta1))/2;
    x[2]:=x[1];
    y[2]:=(PDia*cos(Beta)-RD)/2;
    x[3]:=-f1*OD*Sin(Beta)/2;
    Theta2:=ArcSin(x[3]/PDia);
    y[3]:=(OD*Cos(Theta2)-RD)/2;
    IF Curves THEN BEGIN
        x[1]:=fx1*x[1];
        y[1]:=fy1*y[1];
        x[2]:=fx2*x[2];
        y[2]:=fy2*y[2];
        y[3]:=Sqrt((OD/2)^2-x[3]^2)-RD/2;
    END;
    x[4]:=-x[3]; y[4]:=y[3];
    x[5]:=-x[2]; y[5]:=y[2];
    x[6]:=-x[1]; y[6]:=y[1];
    A1:=Alpha;
    ClosePoly;
    Absolute;
{
Draw the gear.
}
    BeginPoly;
    FOR k:= 1 TO NTeeth DO BEGIN
        A1:=A1-Alpha;
{
Calculate the coordinates of the point on the root diameter at angle A1.
}
        x0t:=x0+RD*sin(-A1)/2;
        y0t:=y0-RD*(1-cos(-A1))/2;
{
Transpose the 6 defining points of the tooth profile to angle A1.
}
        FOR j:=1 TO 6 DO BEGIN
            xt[j]:=x[j]*Cos(A1)-y[j]*Sin(A1);
            yt[j]:=x[j]*Sin(A1)+y[j]*Cos(A1);
{
Draw straight teeth.
}
            IF NOT Curves THEN
                LineTo((x0t+xt[j]),(y0t+yt[j]));
        END;
        IF NOT Curves THEN GOTO 98;
{
Draw curved teeth.
}
        ArcTo((x0t+xt[1]),(y0t+yt[1]),r);
        CurveTo((x0t+xt[2]),(y0t+yt[2]));
        LineTo((x0t+xt[3]),(y0t+yt[3]));
        LineTo((x0t+xt[4]),(y0t+yt[4]));
        CurveTo((x0t+xt[5]),(y0t+yt[5]));
        ArcTo((x0t+xt[6]),(y0t+yt[6]),r);
    98:END;
    EndPoly;
99:END;

Run(SpurGear);