[Visual Basic] 纯文本查看 复制代码
Sub A_TrimTuongCot()
On Error Resume Next
Dim ExcelApp As Object
Set ExcelApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Err.Clear
Set ExcelApp = CreateObject("Excel.Application")
End If
ExcelApp.Visible = False
AppActivate ExcelApp.Caption
'ExcelApp.Workbooks.Add ' MO FILE TRANG"
ExcelApp.Workbooks.Add.SaveAs "e:\THO1.XLS"
'ExcelApp.Workbooks.Open "e:\THO.XLSX"
ExcelApp.worksheets("sheet1").Activate
'ExcelApp.range("a2").Value = "aaa"
'ExcelApp.cells(1, k).Value = "aaa"
ExcelApp.Visible = True
Dim MangTuong(0 To 100000) As Variant
Dim MangCot(0 To 100000) As Variant
Dim TapGiao As Variant
Dim MangGiao(0 To 10000000) As Variant
Set objmien = ThisDrawing.SelectionSets.Add("TenMien")
i = -1
j = -1
objmien.SelectOnScreen
' Lay Mang tuong
For Each tt In objmien
If tt.ObjectName = "AcDbLine" Then
i = i + 1
Set MangTuong(i) = tt
End If
Next tt
n = i
'Lay Mang cot
For Each tt In objmien
If tt.ObjectName <> "AcDbLine" Then
j = j + 1
Set MangCot(j) = tt
End If
Next tt
m = j
ThisDrawing.SelectionSets.Item("TenMien").Delete
'============================= TIM TOA DO GIAO DIEM==================================
Dim pa(0 To 2) As Double
Dim TapGiaotb(0 To 2) As Double
Dim diem1(1000000) As String
Dim diem2(1000000) As String
Dim diemtb(1000000) As String
Dim cmd(1000000) As String
nn = 0
sogiao = 0
For ii = 0 To n
stp = MangTuong(ii).StartPoint
EnP = MangTuong(ii).EndPoint
startp1 = stp(0) & "," & stp(1) & "," & stp(2)
For jj = 0 To m
TapGiao = MangTuong(ii).IntersectWith(MangCot(jj), acExtendNone)
Dim iii As Integer, kkk As Integer
iii = 0
'MsgBox nn
If VarType(TapGiao) <> vbEmpty Then
For iii = LBound(TapGiao) To UBound(TapGiao)
'MsgBox sogiao
MangGiao(nn) = Round(TapGiao(iii), 8)
MangGiao(nn + 1) = Round(TapGiao(iii + 1), 8)
MangGiao(nn + 2) = Round(TapGiao(iii + 2), 8)
ExcelApp.cells(sogiao + 1, 1).Value = MangGiao(nn)
ExcelApp.cells(sogiao + 1, 2).Value = MangGiao(nn + 1)
ExcelApp.cells(sogiao + 1, 3).Value = MangGiao(nn + 2)
ExcelApp.cells(sogiao + 1, 4).Value = sogiao
pa(0) = TapGiao(iii)
pa(1) = TapGiao(iii + 1)
pa(2) = TapGiao(iii + 2)
Set gg = ThisDrawing.ModelSpace.AddMText(pa, 500, sogiao)
gg.Height = 50
sogiao = sogiao + 1
iii = iii + 2
nn = nn + 3
Next iii
End If
TapGiaotb(0) = Round((MangGiao(nn - 6) + MangGiao(nn - 3)) / 2, 8)
TapGiaotb(1) = Round((MangGiao(nn - 5) + MangGiao(nn - 2)) / 2, 8)
TapGiaotb(2) = Round((MangGiao(nn - 4) + MangGiao(nn - 1)) / 2, 8)
diem1(sogiao) = MangGiao(nn - 6) & "," & MangGiao(nn - 5) & "," & MangGiao(nn - 4)
diemtb(sogiao) = TapGiaotb(0) & "," & TapGiaotb(1) & "," & TapGiaotb(2)
diem2(sogiao) = MangGiao(nn - 3) & "," & MangGiao(nn - 2) & "," & MangGiao(nn - 1)
ExcelApp.cells(sogiao, 5).Value = TapGiaotb(0)
ExcelApp.cells(sogiao, 6).Value = diemtb(sogiao)
'MsgBox DIEM1
'MsgBox DIEM2
'MsgBox diemtb
cmd(nn / 2) = ".break" & Chr(10) & diemtb(sogiao) & vbCr & "f" & vbCr & diem1(sogiao) & vbCr & diem2(sogiao) & vbCr
'MsgBox cmd
'ThisDrawing.SendCommand cmd
Next jj
'===================BREAK DOI TUONG========================================
Next ii
' =============== HET LAY TOA DO GIAO=============================
ExcelApp.cells(1, 50).Value = sogiao
For y = 1 To nn / 2
If cmd(y) <> "" Then
ThisDrawing.SendCommand cmd(y)
End If
Next y
Set ExcelApp = Nothing
End Sub