Macro for Sprocket

[quarkqq]

Thanks for text improve AlwMVMO. It is much better now.

Inches for Williamj, but doesn't work propely, i have no idea why. I hope AlwMVMO will help.

Code:

''-------WRITE BY QUARKQ ,  AlwMVMO, Williamj -------------------------------------
Sub Main()
Begin Dialog SPROCKETDIALOG 50,47, 182, 114, "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
  Text 4,74,97,12, "Centre Hole_D"
  TextBox 68,74,49,12, .IDD_j
  Text 4,90,97,12, "mm=1   inch=2"
  TextBox 68,90,49,12, .IDD_k


  OKButton 136,15,37,12
  CancelButton 136,40,37,12
End Dialog

Dim dlg As SprocketDialog
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 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 xt56 As Double
Dim yt56 As Double
Dim xt78 As Double
Dim yt78 As Double


dcSetLineParms dcBLACK, dcSOLID, dcNORMAL
dcSetCircleParms dcBLACK, dcSOLID, dcNORMAL
dcSetPointParms dcRED, False

dlg.IDD_Tn = "18"                     'Teetch number
dlg.IDD_P = "9.525"                 'Pitch
dlg.IDD_Rd = "6.5"                     'Roler circle
dlg.IDD_Backlash = "0.1"
dlg.IDD_j = "10"
dlg.IDD_k = "1"
Button = Dialog(dlg)
If Button = -1 Then
Sprock  dlg.IDD_Tn,dlg.IDD_P,dlg.IDD_Rd,dlg.IDD_Backlash,dlg.IDD_j,dlg.IDD_k,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 j As Double,ByVal k As Double, ByVal cx As Double, ByVal cy As Double)
                    
Pi=3.1415926535897932384626433832795028841971
Pr =(P/Sin((180/Tn)*pi/180))/2      '(((P * Tn) / Pi) / 2 )                     'Pitch Diameter
W=(Pr+(Rd*0.5))-(Pr+(Rd*0.25))    

If(dcSelectAll) Then dcEraseSelObjs

dcSetDrawingScale 1.0
If k=1 Then
dcSetDrawingUnits dcMillimeters
ElseIf k=2 Then
dcSetDrawingUnits dcInches
ElseIf k>2 Then
k=1
End If

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.1
'dcCreateCircle 0, W/2+(Pr+(Rd*0.25)) ,W/2                             'Little circle
'dcCreateCircleEx 0, W/2+(Pr+(Rd*0.25)), 90, -90, 0, 90, w/2, w/2, 0, 0         '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
dcMirrorSelObjs 0, 0, 0, 2
dcUnSelectAll

    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
      

'little circle end point 2
      m=0
    n=Pr+(Rd*0.5)
    mi=m*Cos(((360/Tn/2)*Pi)/180)-n*Sin(((360/Tn/2)*Pi)/180)               'X smal circle center
    ni=m*Sin(((360/Tn/2)*Pi)/180)+n*Cos(((360/Tn/2)*Pi)/180)                  'Y smal circle center

'circle big one
      a=0                                                  'x1 =
    b=Pr                                               'y1 =
    r0=((Rd+Backlash)/2)                                      'r1 =
'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                                     'mirror line
dcUnSelectAll
                                                    'proba duzego na promien
dcCreateCircleEx 0, Pr, -xt56, yt56, xt56, yt56, (Rd+Backlash)/2, (Rd+Backlash)/2, 0, 0

dcCreateCircleEx si, ti, -xt78, yt78, mi, ni, W/2, W/2, 0, 0

dcSelectObjInBox si+0.1, ti, si+0.2,ti+30
dcSetSelCopyMode True
dcMirrorSelObjs 0, 0, 0, 2
dcUnSelectAll

dcSelectObjInBox -1, -1, 1, 1
dcEraseSelObjs
dcUnSelectAll

dcSelectAll
dcSetSelectBase 0, 0

For z=0 to Tn-1
dcRotateSelObjs 360/Tn
dcSetSelCopyMode True

Next z
dcUnSelectAll
dcCreateCircle 0, 0, j/2

dcSetTextParms dcRED, “Arial”, “Normalny”, 0,2,0, 0.1, 0
NL$ = Chr$(13) + Chr$(10)
   SprText$ = "Teeth=" + Str$(Tn) + NL$
   SprText$ = SprText$ + "Pitch=" + Str$(P) + NL$
   SprText$ = SprText$ + "Roller_D=" + Str$(Rd) + NL$
   SprText$ = SprText$ + "Pitch_D=" + Str$(Pr*2) + NL$
   SprText$ = SprText$ + "Max_D=" + Str$((Pr+(Rd*0.35))*2)
   dcCreateText 0, -5, 0, SprText$

End Sub