📄 坐标.frm

📁 一个勘察用的小软件,和华宁配套用. 一个勘察用的小软件,和华宁配套用.
💻 FRM
📖 第 1 页 / 共 4 页
字号:
上一页 1 2 34
   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 * 1.6 '下划线
lst(1) = pts(1) + 1.2 * z
lst(2) = 0
lend(0) = pts(0) + z * 1.6
lend(1) = pts(1) + 1.2 * z
lend(2) = 0
If check2(5).Value = 1 Then
Set txtline = acadDoc.ModelSpace.AddLine(lst, lend)
End If
txtzk(0) = pts(0) - z * 1.6   '编号
txtzk(1) = pts(1) + z * 1.3 + z * 1.6
txtzk(2) = 0
Set txtobj = acadDoc.ModelSpace.AddMText(txtzk, z * 3.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 = 2 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 * 1.6 '下划线
lst(1) = pts(1) - z * 1.3 - z * 1.6
lst(2) = 0
lend(0) = pts(0) + z * 1.6
lend(1) = pts(1) - z * 1.3 - 1.6 * z
lend(2) = 0
If check2(5).Value = 1 Then
Set txtline = acadDoc.ModelSpace.AddLine(lst, lend)
End If
txtzk(0) = pts(0) - z * 1.6  '编号
txtzk(1) = pts(1) - z * 1.25
txtzk(2) = 0
Set txtobj = acadDoc.ModelSpace.AddMText(txtzk, z * 3.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 = 3 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)
lst(2) = 0
lend(0) = pts(0) - z * 4
lend(1) = pts(1)
lend(2) = 0
If check2(5).Value = 1 Then
Set txtline = acadDoc.ModelSpace.AddLine(lst, lend)
End If
txtzk(0) = pts(0) - z * 4   '编号
txtzk(1) = pts(1) + z * 0.25 + z * 1.6
txtzk(2) = 0
Set txtobj = acadDoc.ModelSpace.AddMText(txtzk, z * 3, 号数 + 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 = 4 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)
lst(2) = 0
lend(0) = pts(0) + z * 4
lend(1) = pts(1)
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) + z * 0.25 + z * 1.6
txtzk(2) = 0
Set txtobj = acadDoc.ModelSpace.AddMText(txtzk, z * 3, 号数 + 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
 End If
ElseIf bh(1).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, n + 号数 - j)
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
   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 * 1.6 '下划线
lst(1) = pts(1) + 1.2 * z
lst(2) = 0
lend(0) = pts(0) + z * 1.6
lend(1) = pts(1) + 1.2 * z
lend(2) = 0
If check2(5).Value = 1 Then
Set txtline = acadDoc.ModelSpace.AddLine(lst, lend)
End If
txtzk(0) = pts(0) - z * 1.6   '编号
txtzk(1) = pts(1) + z * 1.3 + z * 1.6
txtzk(2) = 0
Set txtobj = acadDoc.ModelSpace.AddMText(txtzk, z * 3.2, n + 号数 - j)
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 = 2 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 * 1.6 '下划线
lst(1) = pts(1) - z * 1.3 - z * 1.6
lst(2) = 0
lend(0) = pts(0) + z * 1.6
lend(1) = pts(1) - z * 1.3 - 1.6 * z
lend(2) = 0
If check2(5).Value = 1 Then
Set txtline = acadDoc.ModelSpace.AddLine(lst, lend)
End If
txtzk(0) = pts(0) - z * 1.6  '编号
txtzk(1) = pts(1) - z * 1.25
txtzk(2) = 0
Set txtobj = acadDoc.ModelSpace.AddMText(txtzk, z * 3.2, n + 号数 - j)
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 = 3 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)
lst(2) = 0
lend(0) = pts(0) - z * 4
lend(1) = pts(1)
lend(2) = 0
If check2(5).Value = 1 Then
Set txtline = acadDoc.ModelSpace.AddLine(lst, lend)
End If
txtzk(0) = pts(0) - z * 4   '编号
txtzk(1) = pts(1) + z * 0.25 + z * 1.6
txtzk(2) = 0
Set txtobj = acadDoc.ModelSpace.AddMText(txtzk, z * 3, n + 号数 - j)
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 = 4 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)
lst(2) = 0
lend(0) = pts(0) + z * 4
lend(1) = pts(1)
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) + z * 0.25 + z * 1.6
txtzk(2) = 0
Set txtobj = acadDoc.ModelSpace.AddMText(txtzk, z * 3, n + 号数 - j)
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
 End If
End If
End Sub
Private Sub Command7_Click()
Dim dimAliObj As AcadEntity
Dim PickPnt As Variant
Dim aj
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为当前图形文件的模型空间
While aj = 0
h = GetKeyState(vbKeyEscape)
If GetKeyState(vbKeyEscape) < 0 Then
Exit Sub
End If
On Error Resume Next
acadDoc.Utility.GetEntity dimAliObj, PickPnt, "选择对象："
If dimAliObj.ObjectName = "AcDbMText" Then
dimAliObj.TextString = Text6.Text
End If
If Err Then
Exit Sub
End If
Wend
End Sub
上一页 1 2 34
💿 文件大小 39 K
👤 上传用户 jaysdy1117
📂 所属分类其他行业
🏷️ 相关标签

#勘察 #软件
⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -