坐标1.bas

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

Attribute VB_Name = "Module1"
Dim Excel As Object
Dim ExcelWorkbook As Object
Dim ExcelSheet As Object
Sub dk(str As Variant, dirs As Variant)
Dim FileNp1, FileNp2, n, i, msg
On Error Resume Next
Set Excel = GetObject(, "Excel.application")
Set ExcelWorkbook = Excel.Workbooks
Set ExcelSheet = Excel.ActiveSheet
If Err Then
Err.Clear
msg = "请打开要读入数据的excel!"
MsgBox msg
End If
Dim myrange As Variant
Set myrange = ExcelSheet.Range("A2:A10000")
n = Excel.WorksheetFunction.Count(myrange)
FileNp1 = dirs
FileNp2 = FileNp1 & "\" & "dk" & "." & str
Open FileNp2 For Output As #1
For i = 1 To n
Print #1, ExcelSheet.Cells(i + 1, 1) & "," & ExcelSheet.Cells(i + 1, 4) & "," & ExcelSheet.Cells(i + 1, 5) & "," & "," & "," & "," & "," & ExcelSheet.Cells(i + 1, 2) & "," & ExcelSheet.Cells(i + 1, 3) & "," & "," & 1
Next i
Print #1, "END,END,END,END,END,END,END,END,END,END,END"
Close #1
End Sub
Sub bdwy(acadDoc As Variant, 圆半径 As Variant) '变点为圆
Dim pts As Variant
Dim z As Variant
Dim pl As Variant
Dim p(0 To 2) As Double '定义坐标变量
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
Dim PLSet As Object
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) = "POINT"
    PLSet.SelectOnScreen FilterType, FilterData
    
For Each pl In PLSet
pts = pl.Coordinates
p(0) = pts(0)
p(1) = pts(1)
p(2) = 0
z = 圆半径
Set txtobj = acadDoc.ModelSpace.AddCircle(p, z)
pl.Delete
Next pl
PLSet.Delete
End Sub
Sub dyzb(acadDoc As Variant) '点圆坐标到excel
On Error Resume Next
Set Excel = GetObject(, "Excel.application")
If Err Then
Set Excel = New Excel.Application '启动EXCEL
Set ExcelWorkbook = Excel.Workbooks.Add
Err.Clear
End If
If ExcelSheet.Cells(1, 1) = "孔号" And ExcelSheet.Cells(1, 2) = "X" And ExcelSheet.Cells(1, 3) = "Y" Then
Set Excel = GetObject(, "Excel.application")
Else
Set Excel = New Excel.Application '启动EXCEL
Set ExcelWorkbook = Excel.Workbooks.Add
End If
Set ExcelSheet = Excel.ActiveSheet
 Excel.Visible = True
 j = 0
 Dim FilterType(0) As Integer
Dim FilterData(0) As Variant

Dim pts As Variant
Dim pl As Variant
Dim PLSet As Object
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
For Each pl In PLSet
pts = pl.center
  ExcelSheet.Cells(1, 1) = "孔号"
  ExcelSheet.Cells(1, 2) = "X"
  ExcelSheet.Cells(1, 3) = "Y"
  ExcelSheet.Cells(1, 4) = "钻孔标高"
  ExcelSheet.Cells(1, 5) = "钻孔深度"
  ExcelSheet.Cells(1, 6) = "标贯"
  ExcelSheet.Cells(1, 7) = "取土"
  ExcelSheet.Cells(1, 8) = "取水"
  ExcelSheet.Cells(1, 9) = "静力触探"
  ExcelSheet.Cells(1, 10) = "动力触探"
  ExcelSheet.Cells(1, 11) = "机钻孔"
  ExcelSheet.Cells(1, 12) = "波速测试"
 ExcelSheet.Cells(j + 2, 3) = pts(0) / 1000
 ExcelSheet.Cells(j + 2, 2) = pts(1) / 1000
 ExcelSheet.Cells(j + 2, 1) = j + 1
j = j + 1
Next pl
PLSet.Delete
End Sub
Sub zkxzb(acadDoc As Variant, bg As Variant, qu As Variant, zksd As Variant, zkbg As Variant, 圆半径 As Variant, 旋转角度 As Variant) '钻孔性质
Dim j As Integer
 Dim hatchObj1 As AcadHatch
 Dim hatchObj2 As AcadHatch
      Dim patternName As String
      Dim PatternType As Long
      Dim bAssociativity As Boolean
      On Error Resume Next
Set Excel = GetObject(, "Excel.application")
Set ExcelWorkbook = Excel.Workbooks
Set ExcelSheet = Excel.ActiveSheet
      ' 定义图案填充
      patternName = "SOLID"
      PatternType = 0
      bAssociativity = True
      
     Dim outerLoop1(1) As AcadEntity
      Dim outerLoop2(2) As AcadEntity
      Dim center(0 To 2) As Double
      Dim radius As Double
      Dim startAngle As Double
      Dim endAngle As Double
        Dim center1(0 To 2) As Double
      Dim center2(0 To 2) As Double
      Dim center3(0 To 2) As Double
      Dim pl As Variant
      Dim PLSet As Object
       Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
Dim max As Variant
Dim myrange As Variant

      startAngle = -3.141592 / 2
      endAngle = 3.141592 / 2
      
     
   Set myrange = ExcelSheet.Range("A2:A10000")
     max = Excel.WorksheetFunction.Count(myrange)
     radius = CDbl(圆半径)

'------------------------------------------------------------------------------------------------------------------------------'
     '以下为钻孔取土
   If qu.Value = 1 Then
   n = 2
    For j = 1 To max
      center(0) = ExcelSheet.Cells(n, 3) * 1000: center(1) = ExcelSheet.Cells(n, 2) * 1000: center(2) = 0
      center1(0) = center(0) - 1.732 * radius / 2: center1(1) = center(1) + radius / 2: center1(2) = 0
      center2(0) = center(0) + 1.732 * radius / 2: center2(1) = center(1) + radius / 2: center2(2) = 0
      center3(0) = center(0): center3(1) = center(1) - radius: center3(2) = 0
      If ExcelSheet.Cells(n, 7) = 1 Then
      Set hatchObj1 = acadDoc.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)
      Set outerLoop1(0) = acadDoc.ModelSpace.AddArc(center, radius, startAngle, endAngle)
      Set outerLoop1(1) = acadDoc.ModelSpace.AddLine(outerLoop1(0).StartPoint, outerLoop1(0).EndPoint)
          hatchObj1.AppendOuterLoop (outerLoop1)
      outerLoop1(0).Delete
      outerLoop1(1).Delete
      hatchObj1.HatchStyle = acHatchStyleIgnore
      hatchObj1.Evaluate
      End If
      n = n + 1
       Next j
      End If
     
'------------------------------------------------------------------------------------------------------------------------------'
     '以下为钻孔标贯
    If bg.Value = 1 Then
    n = 2
     For j = 1 To max
      center(0) = ExcelSheet.Cells(n, 3) * 1000: center(1) = ExcelSheet.Cells(n, 2) * 1000: center(2) = 0
      center1(0) = center(0) - 1.732 * radius / 2: center1(1) = center(1) + radius / 2: center1(2) = 0
      center2(0) = center(0) + 1.732 * radius / 2: center2(1) = center(1) + radius / 2: center2(2) = 0
      center3(0) = center(0): center3(1) = center(1) - radius: center3(2) = 0
     If ExcelSheet.Cells(n, 6) = 1 Then
      Set hatchObj2 = acadDoc.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)
      Set outerLoop2(0) = acadDoc.ModelSpace.AddLine(center1, center2)
      Set outerLoop2(1) = acadDoc.ModelSpace.AddLine(center1, center3)
      Set outerLoop2(2) = acadDoc.ModelSpace.AddLine(center2, center3)
      hatchObj2.AppendOuterLoop (outerLoop2)
      outerLoop2(0).Delete
      outerLoop2(1).Delete
      outerLoop2(2).Delete
      hatchObj2.HatchStyle = acHatchStyleIgnore
      hatchObj2.Evaluate
      End If
      n = n + 1
      Next j
      End If
    acadDoc.Regen True
'------------------------------------------------------------------------------------------------------------------------------'
    '以下为钻孔深度
If zksd.Value = 1 Then
n = 2
Dim txtzk(2) As Double
Dim txtsd(2) As Double
Dim zk As Variant
Dim z As Integer
For j = 1 To max
txtzk(0) = ExcelSheet.Cells(n, 3) * 1000 - radius * 4
txtzk(1) = ExcelSheet.Cells(n, 2) * 1000 - radius * 0.25
txtzk(2) = 0
If ExcelSheet.Cells(n, 5) < 10 Then
zk = Format(ExcelSheet.Cells(n, 5), "0.0")
Else
zk = Format(ExcelSheet.Cells(n, 5), "00.0")
End If
Set txtobj = acadDoc.ModelSpace.AddMText(txtzk, radius * 3, zk)
txtobj.StyleName = "mytxt"
txtobj.Height = radius * 1.4
txtobj.AttachmentPoint = acAttachmentPointMiddleCenter
txtobj.Rotate pts, CDbl(旋转角度 * 3.14159265742655 / 180)
n = n + 1
Next j
End If
'------------------------------------------------------------------------------------------------------------------------------'
    '以下为钻孔高程
If zkbg.Value = 1 Then
n = 2
Dim txtobj1 As Object
Dim lst(2) As Double
Dim lend(2) As Double
For j = 1 To max
txtzk(0) = ExcelSheet.Cells(n, 3) * 1000 + radius * 1.2
txtzk(1) = ExcelSheet.Cells(n, 2) * 1000 + radius * 0.25 + radius * 1.6
txtzk(2) = 0
zk = Format(ExcelSheet.Cells(n, 4), "000.00")
Set txtobj1 = acadDoc.ModelSpace.AddMText(txtzk, radius * 3, zk)
txtobj1.StyleName = "mytxt"
txtobj1.Height = radius * 1.4
txtobj1.AttachmentPoint = acAttachmentPointMiddleLeft
txtobj1.Rotate pts, CDbl(旋转角度 * 3.14159265742655 / 180)

lst(0) = ExcelSheet.Cells(n, 3) * 1000 + radius
lst(1) = ExcelSheet.Cells(n, 2) * 1000
lst(2) = 0
lend(0) = ExcelSheet.Cells(n, 3) * 1000 + radius * 5.2
lend(1) = ExcelSheet.Cells(n, 2) * 1000
lend(2) = 0
Set txtline = acadDoc.ModelSpace.AddLine(lst, lend)
n = n + 1
Next j
End If
End Sub