home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2002 March / PCWMAR02.iso / software / turbocad / v8trial / TurboCADv8ProfessionalNoReg.exe / Data.Cab / F41883_modRRect.bas < prev    next >
Encoding:
BASIC Source File  |  2001-10-16  |  7.0 KB  |  137 lines
  1. Attribute VB_Name = "modRRect"
  2. '******************************************************************'
  3. '*                                                                *'
  4. '*                      TurboCAD for Windows                      *'
  5. '*                   Copyright (c) 1993 - 2001                    *'
  6. '*             International Microcomputer Software, Inc.         *'
  7. '*                            (IMSI)                              *'
  8. '*                      All rights reserved.                      *'
  9. '*                                                                *'
  10. '******************************************************************'
  11.  
  12. Public Sub RoundRectangle()
  13. ' Create 2D-RoundRectangle with holes
  14.     Dim App As Application
  15.     Dim ActDr As Drawing
  16.     Dim Grs As Graphics
  17.     Dim Gr As Graphic
  18.     Dim a#, b#, R#, r1#
  19.     Dim X0#, y0#
  20.     Dim Pi#
  21.     Pi = 3.14159
  22.     X0 = 5
  23.     y0 = 5
  24.     frmRRect.Show
  25.     a = CDbl(frmRRect.TextBox1.Text)
  26.     b = CDbl(frmRRect.TextBox2.Text)
  27.     R = CDbl(frmRRect.TextBox3.Text)
  28.     r1 = CDbl(frmRRect.TextBox4.Text) / 2
  29.     If R <= 0 Then R = 0
  30.     If r1 > R Then r1 = 0
  31.     Set App = IMSIGX.Application    'Returns an Application object - TurboCAD
  32.     Set ActDr = App.ActiveDrawing   'Returns the active Drawing object
  33.     Set Grs = ActDr.Graphics    'Returns the Graphics collection for active Drawing object
  34.     If R = 0 Then
  35.         'Creates and adds a rectangle to the Graphics collection.
  36.         Set Gr = Grs.AddLineRectangle(X0 - a / 2, y0 - b / 2, 0, X0 + a / 2, y0 + b / 2, 0)
  37.         Gr.Properties("PenWidth") = 0.03 'Changes the Graphic Property - "PenWidth"
  38.     Else
  39.         ' Add Line segments
  40.         Set Gr = Grs.AddLineSingle(X0 - a / 2 + R, y0 - b / 2, 0, X0 + a / 2 - R, y0 - b / 2, 0)
  41.         Gr.Properties("PenWidth") = 0.03
  42.         Set Gr = Grs.AddLineSingle(X0 + a / 2, y0 - b / 2 + R, 0, X0 + a / 2, y0 + b / 2 - R, 0)
  43.         Gr.Properties("PenWidth") = 0.03
  44.         Set Gr = Grs.AddLineSingle(X0 - a / 2 + R, y0 + b / 2, 0, X0 + a / 2 - R, y0 + b / 2, 0)
  45.         Gr.Properties("PenWidth") = 0.03
  46.         Set Gr = Grs.AddLineSingle(X0 - a / 2, y0 - b / 2 + R, 0, X0 - a / 2, y0 + b / 2 - R, 0)
  47.         Gr.Properties("PenWidth") = 0.03
  48.         ' Add Arcs
  49.         Set Gr = Grs.AddArcCenterAndPoint(X0 - a / 2 + R, y0 - b / 2 + R, 0, X0 - a / 2 + R, y0 - b / 2, 0, Pi, 3 * Pi / 2)
  50.         Gr.Properties("PenWidth") = 0.03
  51.         Set Gr = Grs.AddArcCenterAndPoint(X0 + a / 2 - R, y0 - b / 2 + R, 0, X0 + a / 2 - R, y0 - b / 2, 0, 3 * Pi / 2, 2 * Pi)
  52.         Gr.Properties("PenWidth") = 0.03
  53.         Set Gr = Grs.AddArcCenterAndPoint(X0 + a / 2 - R, y0 + b / 2 - R, 0, X0 + a / 2 - R, y0 + b / 2, 0, 0, Pi / 2)
  54.         Gr.Properties("PenWidth") = 0.03
  55.         Set Gr = Grs.AddArcCenterAndPoint(X0 - a / 2 + R, y0 + b / 2 - R, 0, X0 - a / 2 + R, y0 + b / 2, 0, Pi / 2, Pi)
  56.         Gr.Properties("PenWidth") = 0.03
  57.         ' Add Circles
  58.         If r1 > 0 Then
  59.             Set Gr = Grs.AddCircleCenterAndPoint(X0 - a / 2 + R, y0 - b / 2 + R, 0, X0 - a / 2 + R, y0 - b / 2 + R + r1, 0)
  60.             Gr.Properties("PenWidth") = 0.03
  61.             Gr.Properties("PenColor") = RGB(0, 255, 0)
  62.             Set Gr = Grs.AddCircleCenterAndPoint(X0 + a / 2 - R, y0 - b / 2 + R, 0, X0 + a / 2 - R, y0 - b / 2 + R + r1, 0)
  63.             Gr.Properties("PenWidth") = 0.03
  64.             Gr.Properties("PenColor") = RGB(0, 255, 0)
  65.             Set Gr = Grs.AddCircleCenterAndPoint(X0 + a / 2 - R, y0 + b / 2 - R, 0, X0 + a / 2 - R, y0 + b / 2 - R + r1, 0)
  66.             Gr.Properties("PenWidth") = 0.03
  67.             Gr.Properties("PenColor") = RGB(0, 255, 0)
  68.             Set Gr = Grs.AddCircleCenterAndPoint(X0 - a / 2 + R, y0 + b / 2 - R, 0, X0 - a / 2 + R, y0 + b / 2 - R + r1, 0)
  69.             Gr.Properties("PenWidth") = 0.03
  70.             Gr.Properties("PenColor") = RGB(0, 255, 0)
  71.         End If
  72.     End If
  73. End Sub
  74.  
  75. Public Sub RRectWithThick()
  76. ' Create 3D-RoundRectangle with holes as surface
  77.     Dim App As Application
  78.     Dim ActDr As Drawing
  79.     Set App = IMSIGX.Application
  80.     Set ActDr = App.ActiveDrawing
  81. Dim Space%
  82.     Space = ActDr.Properties("TileMode")
  83.     If Space <> 1 Then
  84.         MsgBox ("This macros works only in Model Space")
  85.         Exit Sub
  86.     End If
  87.     Dim Grs As Graphics
  88.     Dim Gr As Graphic
  89.     Dim GrChild As Graphic
  90.     Dim a#, b#, R#, r1#, Thick#
  91.     Dim X0#, y0#
  92.     Dim Pi#
  93.     Pi = 3.14159
  94.     X0 = 5
  95.     y0 = 5
  96.     frmRRect.Show
  97.     a = CDbl(frmRRect.TextBox1.Text)
  98.     b = CDbl(frmRRect.TextBox2.Text)
  99.     R = CDbl(frmRRect.TextBox3.Text)
  100.     r1 = CDbl(frmRRect.TextBox4.Text) / 2
  101.     Thick = CDbl(frmRRect.TextBox5.Text)
  102.     If R <= 0 Then R = 0
  103.     If r1 > R Then r1 = 0
  104.     Set Grs = ActDr.Graphics
  105.     Set Gr = Grs.Add(7) ' graphic of Group type
  106.     If R = 0 Then
  107.         Set Gr = Grs.AddLineRectangle(X0 - a / 2, y0 - b / 2, 0, X0 + a / 2, y0 + b / 2, 0)
  108.     Else
  109.         ' Add Line segments
  110.         Set GrChild = Gr.Graphics.AddLineSingle(X0 - a / 2 + R, y0 - b / 2, 0, X0 + a / 2 - R, y0 - b / 2, 0)
  111.         Set GrChild = Gr.Graphics.AddLineSingle(X0 + a / 2, y0 - b / 2 + R, 0, X0 + a / 2, y0 + b / 2 - R, 0)
  112.         Set GrChild = Gr.Graphics.AddLineSingle(X0 - a / 2 + R, y0 + b / 2, 0, X0 + a / 2 - R, y0 + b / 2, 0)
  113.         Set GrChild = Gr.Graphics.AddLineSingle(X0 - a / 2, y0 - b / 2 + R, 0, X0 - a / 2, y0 + b / 2 - R, 0)
  114.         ' Add Arcs
  115.         Set GrChild = Gr.Graphics.AddArcCenterAndPoint(X0 - a / 2 + R, y0 - b / 2 + R, 0, X0 - a / 2 + R, y0 - b / 2, 0, Pi, 3 * Pi / 2)
  116.         Set GrChild = Gr.Graphics.AddArcCenterAndPoint(X0 + a / 2 - R, y0 - b / 2 + R, 0, X0 + a / 2 - R, y0 - b / 2, 0, 3 * Pi / 2, 2 * Pi)
  117.         Set GrChild = Gr.Graphics.AddArcCenterAndPoint(X0 + a / 2 - R, y0 + b / 2 - R, 0, X0 + a / 2 - R, y0 + b / 2, 0, 0, Pi / 2)
  118.         Set GrChild = Gr.Graphics.AddArcCenterAndPoint(X0 - a / 2 + R, y0 + b / 2 - R, 0, X0 - a / 2 + R, y0 + b / 2, 0, Pi / 2, Pi)
  119.         ' Add Circles
  120.         If r1 > 0 Then
  121.             Set GrChild = Gr.Graphics.AddCircleCenterAndPoint(X0 - a / 2 + R, y0 - b / 2 + R, 0, X0 - a / 2 + R, y0 - b / 2 + R + r1, 0)
  122.             Set GrChild = Gr.Graphics.AddCircleCenterAndPoint(X0 + a / 2 - R, y0 - b / 2 + R, 0, X0 + a / 2 - R, y0 - b / 2 + R + r1, 0)
  123.             Set GrChild = Gr.Graphics.AddCircleCenterAndPoint(X0 + a / 2 - R, y0 + b / 2 - R, 0, X0 + a / 2 - R, y0 + b / 2 - R + r1, 0)
  124.             Set GrChild = Gr.Graphics.AddCircleCenterAndPoint(X0 - a / 2 + R, y0 + b / 2 - R, 0, X0 - a / 2 + R, y0 + b / 2 - R + r1, 0)
  125.         End If
  126.     End If
  127. Dim GrHatch As Graphic
  128.         Gr.Closed = True
  129.         Set GrHatch = Gr.Graphics.AddHatch 'Adds a hatch pattern to the collection from the Graphic objects in the collection.
  130.         GrHatch.Properties("PenColor") = RGB(255, 0, 0) 'Changes color of the hatch-object
  131.         If Thick > 0 Then
  132.             GrHatch.Properties("Thickness") = Thick 'Changes the property - "Thickness"
  133.             GrHatch.Properties("Solid") = 0 ' Resulting object is Surface
  134.         End If
  135. End Sub
  136.  
  137.