坐标.frm

一个勘察用的小软件,和华宁配套用. 一个勘察用的小软件,和华宁配套用.

            Strikethrough   =   0   'False
         EndProperty
         Height          =   255
         Left            =   120
         TabIndex        =   17
         Top             =   2040
         Width           =   1095
      End
   End
   Begin MSForms.CommandButton CommandButton1 
      Height          =   405
      Index           =   7
      Left            =   0
      TabIndex        =   7
      Top             =   2730
      Width           =   1095
      Caption         =   "excel-->DK"
      Size            =   "1931;706"
      FontName        =   "楷体_GB2312"
      FontHeight      =   180
      FontCharSet     =   134
      FontPitchAndFamily=   34
      ParagraphAlign  =   3
   End
   Begin MSForms.CommandButton CommandButton1 
      Height          =   405
      Index           =   6
      Left            =   0
      TabIndex        =   6
      Top             =   2340
      Width           =   1095
      Caption         =   "改变数字"
      Size            =   "1931;706"
      FontName        =   "楷体_GB2312"
      FontHeight      =   210
      FontCharSet     =   134
      FontPitchAndFamily=   34
      ParagraphAlign  =   3
   End
   Begin MSForms.CommandButton CommandButton1 
      Height          =   405
      Index           =   5
      Left            =   0
      TabIndex        =   5
      Top             =   1950
      Width           =   1095
      Caption         =   "N120分层"
      Size            =   "1931;706"
      FontName        =   "楷体_GB2312"
      FontHeight      =   210
      FontCharSet     =   134
      FontPitchAndFamily=   34
      ParagraphAlign  =   3
   End
   Begin MSForms.CommandButton CommandButton1 
      Height          =   405
      Index           =   4
      Left            =   0
      TabIndex        =   4
      Top             =   1560
      Width           =   1095
      Caption         =   "工作目录"
      Size            =   "1931;706"
      FontName        =   "楷体_GB2312"
      FontHeight      =   210
      FontCharSet     =   134
      FontPitchAndFamily=   34
      ParagraphAlign  =   3
   End
   Begin MSForms.CommandButton CommandButton1 
      Height          =   405
      Index           =   3
      Left            =   0
      TabIndex        =   3
      Top             =   1170
      Width           =   1095
      Caption         =   "钻孔性质"
      Size            =   "1931;706"
      FontName        =   "楷体_GB2312"
      FontHeight      =   210
      FontCharSet     =   134
      FontPitchAndFamily=   34
      ParagraphAlign  =   3
   End
   Begin MSForms.CommandButton CommandButton1 
      Height          =   405
      Index           =   2
      Left            =   0
      TabIndex        =   2
      Top             =   780
      Width           =   1095
      Caption         =   "点圆坐标"
      Size            =   "1931;706"
      FontName        =   "楷体_GB2312"
      FontHeight      =   210
      FontCharSet     =   134
      FontPitchAndFamily=   34
      ParagraphAlign  =   3
   End
   Begin MSForms.CommandButton CommandButton1 
      Height          =   405
      Index           =   1
      Left            =   0
      TabIndex        =   1
      Top             =   390
      Width           =   1095
      Caption         =   "钻孔编号"
      Size            =   "1931;706"
      FontName        =   "楷体_GB2312"
      FontHeight      =   210
      FontCharSet     =   134
      FontPitchAndFamily=   34
      ParagraphAlign  =   3
   End
   Begin MSForms.CommandButton CommandButton1 
      Height          =   405
      Index           =   0
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   1095
      ForeColor       =   12583104
      Caption         =   "变点为圆"
      Size            =   "1931;706"
      FontName        =   "楷体_GB2312"
      FontHeight      =   210
      FontCharSet     =   134
      FontPitchAndFamily=   34
      ParagraphAlign  =   3
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim acadApp As Object '’定义Autocad程序对象
Dim acadDoc As Object '’定义DWG文件对象
Dim Mospace As Object
Dim h As Integer
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Option Explicit


Private Type BROWSEINFO
hOwner As Long '当前窗口的句柄
pidlRoot As Long
pszDisplayName As String
lpszTitle As String '提示窗口标题
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type


Const BIF_RETURNONLYFSDIRS = &H1


Private pidl As Long


Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long


Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long


Private Sub command6_Click()
Dim bi As BROWSEINFO
Dim r As Long
Dim pidl As Long
Dim path As String
Dim pos As Integer
bi.hOwner = Me.hWnd '本窗体句柄
bi.pidlRoot = 0& '从展开根目录
bi.lpszTitle = "请选择工作目录：" '提示窗标题
bi.ulFlags = BIF_RETURNONLYFSDIRS '仅能选择文件夹（子目录）
pidl = SHBrowseForFolder(bi) '打开选择文件夹窗口
path = Space$(512)
r = SHGetPathFromIDList(ByVal pidl&, ByVal path) '获得选择的文件夹
If r Then
pos = InStr(path, Chr$(0))
Text7 = Left(path, pos - 1)
form2.工程目录.Text = Text7.Text
Else
Text7 = ""
End If
End Sub


Private Sub bh_Click(Index As Integer)
If bh(Index) = 1 Then
If Index = 0 Then
bh(1).Value = 0
Else
bh(0).Value = 0
End If
End If
End Sub

Private Sub Check2_Click(Index As Integer)
Dim i As Integer
If Index <= 4 Then
If check2(Index).Value = 1 Then
If Index = 0 Then
For i = 1 To 4
check2(i).Value = 0
Next i
ElseIf Index = 4 Then
For i = 0 To 3
check2(i).Value = 0
Next i
Else
For i = 0 To Index - 1
check2(i).Value = 0
Next i
For i = Index + 1 To 4
check2(i).Value = 0
Next i
End If
End If
End If
End Sub

Private Sub command1_Click()
dyzb acadDoc
End Sub

Private Sub Command2_Click()
Call dk(Text2.Text, Text7.Text)
End Sub
Private Sub Command3_Click()
bdwy acadDoc, Text4(1)
End Sub

Private Sub Command4_Click()
zkbh Text5(0)
End Sub

Private Sub Command5_Click()
zkxzb acadDoc, zkxz(0), zkxz(1), zkxz(2), zkxz(3), Text1(0).Text, Text1(1).Text
End Sub

Private Sub Command8_Click()
form2.Show
End Sub

Private Sub CommandButton1_Click(Index As Integer)
Dim i As Integer
For i = 0 To 7
With CommandButton1(i)
.ForeColor = -2147483640
End With
Next i
If Index <= 7 Then
With CommandButton1(Index)
.ForeColor = 12583104
End With
With Picture1(Index)
.ZOrder 0
End With
End If
End Sub
Private Sub Form_Load()
Dim i
Dim mytxt As Variant
With Picture1(0)
.Left = 1080
.Width = 5000
.Height = 3500
.Top = CommandButton1(0).Top
.ZOrder 0
End With
With Form1
.Width = 6250
.Height = 4000
End With
For i = 1 To 7
Picture1(i).Left = 1080
Picture1(i).Width = 5000
Picture1(i).Height = 3500
Picture1(i).Top = CommandButton1(0).Top
Next i
On Error Resume Next
Set acadApp = GetObject(, "Autocad.application.16")
If Err Then
Err.Clear
Set acadApp = GetObject(, "Autocad.application.15")
End If
If Err Then
Err.Clear
Set acadApp = GetObject(, "Autocad.application.14")
End If
Set acadDoc = acadApp.ActiveDocument
Set Mospace = acadDoc.ModelSpace '设Mospace为当前图形文件的模型空间
Set mytxt = acadDoc.TextStyles.Add("mytxt")
mytxt.Width = 0.6
End Sub
Sub zkbh(号数 As Integer) '给钻孔编号
Dim pts As Variant
Dim z As Variant, n As Integer
Dim pl As Variant
Dim lst(2) As Double
Dim lend(2) As Double
Dim txtzk(2) As Double
Dim txtsd(2) As Double
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
Dim bhs As Integer, j As Integer
Dim PLSet As Object, mytxt As Variant, txtline As Variant, txtobj As Variant
For n = 0 To 4
If check2(n).Value = 1 Then
bhs = n
End If
Next n


If bh(0).Value = 1 Then
'逐个编号
   If bhs = 0 Then
 '中
  On Error Resume Next
 If Not IsNull(acadDoc.SelectionSets.Item("pl")) Then
    Set PLSet = acadDoc.SelectionSets.Item("pl")
    PLSet.Delete   '如果选择集已存在，则删除
    End If
Set PLSet = acadDoc.SelectionSets.Add("pl")
  FilterType(0) = 0
  FilterData(0) = "CIRCLE"
    PLSet.SelectOnScreen FilterType, FilterData
   acadApp.Visible = True   '’使AutoCAD可见
j = 1
n = PLSet.Count
For Each pl In PLSet
pts = pl.center
z = pl.radius   'z为圆的半径
lst(0) = pts(0) - z '下划线
lst(1) = pts(1) - 0.8 * z
lst(2) = 0
lend(0) = pts(0) + z
lend(1) = pts(1) - 0.8 * z
lend(2) = 0
If check2(5).Value = 1 Then
Set txtline = acadDoc.ModelSpace.AddLine(lst, lend)
End If
txtzk(0) = pts(0) - z   '编号
txtzk(1) = pts(1) + 0.75 * z
txtzk(2) = 0
Set txtobj = acadDoc.ModelSpace.AddMText(txtzk, z * 2, 号数 + j - 1)
txtobj.StyleName = "mytxt"
txtobj.Height = z * 1.4
txtobj.AttachmentPoint = acAttachmentPointMiddleCenter
txtline.Rotate pts, CDbl(Text5(2) * 3.14159265742655 / 180)
txtobj.Rotate pts, CDbl(Text5(2) * 3.14159265742655 / 180)
j = j + 1
Next pl
PLSet.Delete
 ElseIf bhs = 1 Then
 '上
  On Error Resume Next
 If Not IsNull(acadDoc.SelectionSets.Item("pl")) Then
    Set PLSet = acadDoc.SelectionSets.Item("pl")
    PLSet.Delete   '如果选择集已存在，则删除
    End If
Set PLSet = acadDoc.SelectionSets.Add("pl")
  FilterType(0) = 0
  FilterData(0) = "CIRCLE"
    PLSet.SelectOnScreen FilterType, FilterData