Chuyển đến nội dung
Diễn đàn CADViet
  • Thông báo

    • Nguyen Hoanh

      CADViet đã hoàn tất nâng cấp   14/09/2017

      Chào các bạn, CADViet đã hoàn tất việc nâng cấp lên phiên bản mới. Tất cả các chức năng đã hoạt động theo kỳ vọng của ban quản trị. Nếu có vấn đề gì cần phản hồi, các bản post ở đây nhé: Trân trọng, Nguyễn Hoành.
Đăng nhập để thực hiện theo  
506509

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ị

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.

 

 

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

Đâ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

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

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.

BreakLine.png

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

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. 

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
" 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

"

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

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay

Đăng nhập để thực hiện theo  

×