form1.frm

vb+cad开发

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   2010
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   2580
   LinkTopic       =   "Form1"
   ScaleHeight     =   2010
   ScaleWidth      =   2580
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command1 
      Caption         =   "投影孔"
      Height          =   855
      Left            =   360
      TabIndex        =   0
      Top             =   360
      Width           =   1575
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private acadapp As AcadApplication
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Sub Form_Load()
Form1.Show
Dim rtm
rtm = SetWindowPos(Me.hWnd, -1, 0, 0, 0, 0, 3)
Dim ww(0 To 2) As Double
On Error Resume Next
Set acadapp = GetObject(, "AutoCAD.Application")
If Err Then
Err.Clear
Set acadapp = CreateObject("AutoCAD.Application")
End If
acadapp.Visible = 1
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set acadapp = Nothing
End Sub

Private Sub Command1_Click()
AppActivate "autocad 2000"
Dim line11(0 To 2) As Double
Dim line12(0 To 2) As Double
Randomize

For i = 0 To acadapp.ActiveDocument.Linetypes.Count - 1
If acadapp.ActiveDocument.Linetypes(i).Name = "CENTER" Then
exicenter = 1
End If
Next
If exicenter = 0 Then acadapp.ActiveDocument.Linetypes.Load "CENTER", "acad.lin"

Dim pt1 As Variant: Dim sset As AcadSelectionSet: Dim kt(0 To 4) As AcadLine
Set sset = acadapp.ActiveDocument.SelectionSets.Add(Str(Rnd(55) * 4))
sset.SelectOnScreen
acadapp.ActiveDocument.Utility.GetEntity kt(0), pt1, "请选择直线"
acadapp.ActiveDocument.Utility.GetEntity kt(1), pt1, "请选择直线"
Dim entry As AcadObject
For Each entry In sset
If entry.EntityType = acCircle Or entry.EntityType = acArc Then
pt1 = entry.Center '取得圆心坐标
'选择水平线情况
If Int(kt(0).StartPoint(0)) = Int(kt(0).EndPoint(0)) And Int(kt(1).StartPoint(0)) = Int(kt(1).EndPoint(0)) Then
L = Abs(kt(0).StartPoint(0) - kt(1).StartPoint(0))
line11(0) = kt(0).StartPoint(0): line12(0) = kt(1).StartPoint(0)
line11(1) = pt1(1) + entry.Radius: line12(1) = line11(1)
Set kt(3) = acadapp.ActiveDocument.ModelSpace.AddLine(line11, line12)
line11(1) = pt1(1) - entry.Radius: line12(1) = line11(1)
Set kt(4) = acadapp.ActiveDocument.ModelSpace.AddLine(line11, line12)
line11(1) = pt1(1): line12(1) = pt1(1)
line11(0) = kt(0).StartPoint(0) + Sgn(kt(0).StartPoint(0) - kt(1).StartPoint(0)) * 3
line12(0) = kt(1).StartPoint(0) - Sgn(kt(0).StartPoint(0) - kt(1).StartPoint(0)) * 3
Set kt(2) = acadapp.ActiveDocument.ModelSpace.AddLine(line11, line12)
kt(2).Color = 2: kt(2).Linetype = "Center"
kt(2).LinetypeScale = L / 4 + 4
If entry.EntityType = acArc Then kt(2).Delete
End If
'选择垂线情况
If Int(kt(0).StartPoint(1)) = Int(kt(0).EndPoint(1)) And Int(kt(1).StartPoint(1)) = Int(kt(1).EndPoint(1)) Then
L = Abs(kt(0).StartPoint(1) - kt(1).StartPoint(1))
line11(1) = kt(0).StartPoint(1): line12(1) = kt(1).StartPoint(1)
line11(0) = pt1(0) + entry.Radius: line12(0) = line11(0)
Set kt(3) = acadapp.ActiveDocument.ModelSpace.AddLine(line11, line12)
line11(0) = pt1(0) - entry.Radius: line12(0) = line11(0)
Set kt(4) = acadapp.ActiveDocument.ModelSpace.AddLine(line11, line12)
line11(0) = pt1(0): line12(0) = pt1(0)
line11(1) = kt(0).StartPoint(1) + Sgn(kt(0).StartPoint(1) - kt(1).StartPoint(1)) * 3
line12(1) = kt(1).StartPoint(1) - Sgn(kt(0).StartPoint(1) - kt(1).StartPoint(1)) * 3
Set kt(2) = acadapp.ActiveDocument.ModelSpace.AddLine(line11, line12)
kt(2).Color = 2: kt(2).Linetype = "Center"
kt(2).LinetypeScale = L / 4 + 4
If entry.EntityType = acArc Then kt(2).Delete
End If
End If
Next entry
End Sub