Hi, I have done some progress.
Try this. I have problem to trim circles, i can't find dctrim... or something..
Code:
'-------WRITE BY QUARKQ PAWEL S.-------------------------------------------
Sub Main()
Begin Dialog SPROCKETDIALOG 50,47, 182, 74, "Sprocket Maker"
Text 4,10,65,12, "Number of Teetch"
TextBox 68,8,49,12, .IDD_Tn
Text 4,26,65,12, "Pitch of Chain"
TextBox 68,24,49,12, .IDD_P
Text 4,42,97,12, "Roler Diameter"
TextBox 68,40,49,12, .IDD_Rd
Text 4,58,97,12, "Roller Clearance"
TextBox 68,56,49,12, .IDD_Backlash
OKButton 136,15,37,12
CancelButton 136,40,37,12
End Dialog
Dim dlg As SprocketDialog
Dim ot As Double
Dim si As Double
Dim ti As Double
Dim s As Double
Dim t As Double
Dim x As Double
Dim y As Double
Dim K As Double
Dim d As Double
Dim xp As Double
Dim yp As Double
Dim a As Double
Dim b As Double
Dim c As Double
Dim r0 As Double
Dim r1 As Double
Dim xt12 As Double
Dim yt12 As Double
Dim xt34 As Double
Dim yt34 As Double
Dim xt56 As Double
Dim yt56 As Double
Dim xt78 As Double
Dim yt78 As Double
dcSetDrawingScale 1.0
dcSetDrawingUnits dcMillimeters
dcSetLineParms dcBLACK, dcSOLID, dcNORMAL
dcSetCircleParms dcBLACK, dcSOLID, dcNORMAL
dcSetPointParms dcRED, False
dlg.IDD_Tn = "18" 'Teetch number
dlg.IDD_P = "12.7" 'Pitch
dlg.IDD_Rd = "8.5" 'Roler circle
dlg.IDD_Backlash = "0.1"
Button = Dialog(dlg)
If Button = -1 Then
Sprock dlg.IDD_Tn,dlg.IDD_P,dlg.IDD_Rd,dlg.IDD_Backlash,0,0
dcViewAll
End If
End Sub
Sub Sprock(ByVal Tn As Double,ByVal P As Double,ByVal Rd As Double,ByVal BACKLASH As Double, ByVal cx As Double, ByVal cy As Double)
Pi=3.1415926535897932384626433832795028841971
Pr =(((P * Tn) / Pi) / 2 ) 'Pitch Diameter
W=(Pr+(Rd*0.5))-(Pr+(Rd*0.25))
dcSelectAll
dcEraseSelObjs
dcCreateLine 0, 0, 0, Pr+(Rd*0.5)
'dcCreateCircle 0, 0, Pr 'Pitch Diameter
'dcCreateCircle 0, 0, Pr+(Rd*0.25) 'Pitch Circumferen ce 25% of Roller Diameter
dcCreateCircle 0, Pr, (Rd+Backlash)/2 'Roler circle plus 0.15
dcCreateCircle 0, W/2+(Pr+(Rd*0.25)) ,W/2 'Little circle
dcSelectObjInBox -1, Pr+(Rd*0.25), 1,W/2+(Pr+(Rd*0.25))
dcSetSelectBase 0, 0
dcRotateSelObjs 360/Tn/2
dcSetSelCopyMode True
dcRotateSelObjs (360/Tn/2)*(Tn-1)*2
dcUnSelectAll
'circle big one
a=0 'x1 =
b=Pr 'y1 =
r0=((Rd+Backlash)/2) 'r1 =
s=0
t=(W/2)+(Pr+(Rd*0.25))
si=s*Cos(((360/Tn/2)*Pi)/180)-t*Sin(((360/Tn/2)*Pi)/180) 'X smaller circle center
ti=s*Sin(((360/Tn/2)*Pi)/180)+t*Cos(((360/Tn/2)*Pi)/180) 'Y smaller circle center
'dcCreatePoint si,ti
' circle 2 little one right
c=si *-1 'x2 =
d=ti 'y2 =
r1=(W/2) 'r0
xp=((c*r0)+(a*r1))/r0+r1
yp=((d*r0)+(b*r1))/r0+r1
xt56=(((r0^2*(xp-a))+r0*(yp-b)*Sqr((xp-a)^2+(yp-b)^2-r0^2))/((xp-a)^2+(yp-b)^2))+a
yt56=(((r0^2*(yp-b))-r0*(xp-a)*Sqr((xp-a)^2+(yp-b)^2-r0^2))/((xp-a)^2+(yp-b)^2))+b
xt78=(((r1^2*(xp-c))-r1*(yp-d)*Sqr((xp-c)^2+(yp-d)^2-r1^2))/((xp-c)^2+(yp-d)^2))+c
yt78=(((r1^2*(yp-d))+r1*(xp-c)*Sqr((xp-c)^2+(yp-d)^2-r1^2))/((xp-c)^2+(yp-d)^2))+d
dcCreateLine xt56,yt56,xt78,yt78 ' tangent line on right
dcSelectObjInBox xt56+0.2,yt56+0.2,xt78-0.2,yt78-0.2
dcSetSelCopyMode True
dcMirrorSelObjs 0, 0, 0, 2
dcUnSelectAll
dcCreateText -20, -5, 3, "Teeth="
dcCreateText -5, -5, 3, Tn
dcCreateText -20, -10, 3, "Pitch="
dcCreateText -7, -10, 3, P
dcCreateText -20, -15, 3, "Roller_D="
dcCreateText 1, -15, 3, Rd
End SubTry this. I have problem to trim circles, i can't find dctrim... or something..