Đến nội dung


Hình ảnh

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


  • Please log in to reply
5 replies to this topic

#1 506509

506509

    biết zoom

  • Members
  • Pip
  • 16 Bài viết
Điểm đánh giá: -1 (bình thường)

Đã gửi 20 October 2016 - 07:44 PM

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.

 

 


  • 0

#2 506509

506509

    biết zoom

  • Members
  • Pip
  • 16 Bài viết
Điểm đánh giá: -1 (bình thường)

Đã gửi 20 October 2016 - 07:50 PM

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


  • 0

#3 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1431 Bài viết
Điểm đánh giá: 1425 (rất tốt)

Đã gửi 21 October 2016 - 10:24 AM

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


  • 0

#4 dinhvantrang

dinhvantrang

    biết lệnh copy

  • Members
  • PipPipPip
  • 117 Bài viết
Điểm đánh giá: 26 (tàm tạm)

Đã gửi 21 October 2016 - 02:21 PM

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

http://www.cadviet.c...-polyline-trim/


  • 0

Thanks and Best Regards

Skype : dinhvantrang73


#5 506509

506509

    biết zoom

  • Members
  • Pip
  • 16 Bài viết
Điểm đánh giá: -1 (bình thường)

Đã gửi 22 October 2016 - 04:12 PM

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. 


  • 0

#6 506509

506509

    biết zoom

  • Members
  • Pip
  • 16 Bài viết
Điểm đánh giá: -1 (bình thường)

Đã gửi 22 October 2016 - 04:16 PM

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

  • 0