Nhờ Các Cao Thủ Chỉ Giáo Gỡ Rối Chương Trình. Break Đường Line Lao Vào Hình Chữ Nhật

Tháng 10 20, 2016

Xin chào các cao thủ!

Tôi có 1 đoạn mã chương trình với 1 tưởng có 1 đường Line xuyên qua các đường Rectang. Bây giờ làm sao để ngắt các đoạn giao giữa đường Line với Rectang này. Tôi viết trên VBA thấy đã ổn nhưng không hiểu tại sao vẫn xảy ra lỗi khi chạy. Tôi vẫn biết là không nên dùng Command trong VBA nhưng đây là trường hợp vạn bất đắc dĩ thôi, ai có giải pháp hay hơn chỉ giúp tôi với. Chương trình này tôi mở Excel để kiểm soát cho dễ mà vẫn không tìm ra lỗi được.

Tháng 10 20, 2016

Đây là Code VBA

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

Tháng 10 21, 2016

Không có th/gian để debug nhưng hình như code chưa hoàn chỉnh khi lọc các đối tượng vào mảng tường-cột.

Tháng 10 21, 2016

cái này giống bài này, bác thử xem

http://www.cadviet.com/forum/topic/146085-ve-line-or-polyline-trim/

Tháng 10 22, 2016

Thank Gia_bach. Hiccc trên trang Web này nó không hiện "AcDbline" đấy bạn ạ. Tôi Down thử lại và kiểm tra rồi, vẫn có. Bạn cứ thử Down về kiểm tra lại xem.

Tháng 10 22, 2016

" Code đây mà

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

"

Đăng nhập

Nhờ Các Cao Thủ Chỉ Giáo Gỡ Rối Chương Trình. Break Đường Line Lao Vào Hình Chữ Nhật

Các bài được khuyến nghị

506509 1

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

506509 1

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

gia_bach 1.550

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

dinhvantrang 151

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

506509 1

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

506509 1

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

Tạo một tài khoản hoặc đăng nhập để nhận xét

Tạo tài khoản

Đăng nhập

Diễn đàn

Download

Đào tạo CADViet

Browse