Chuyển đến nội dung
Diễn đàn CADViet
garupro

Bạn nào giúp mình với VBA

Bởi garupro , trong Lập trình khác

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

garupro    7

garupro
Đã đăng

Vấn đề là thế này :

Mình có 1 module tên là "Duongthang"

 

Sub duongthang(a As Double, b As Double, c As Double, d As Double)
Dim point1(0 To 2) As Double
Dim point2(0 To 2) As Double
point1(0) = a
point1(1) = b
point1(2) = 0
point2(0) = c
point2(1) = d
point2(2) = 0
Dim line As AcadLine
Set line = ThisDrawing.ModelSpace.AddLine(point1, point2)
End Sub

 

Sau đó mình gọi cái sub "duongthang" trong module đó ra để vẻ 3 đường thẳng khác nhau

 

các bạn cho mình hỏi sau khi vẽ xong thì làm sao để có thể chỉnh sửa (Xoay,lấy đối xứng, copy, xóa...) được 1 trong 3 đường thẳng đó ....

 

Các bạn giúp mình với ...chỗ này bí quá

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

Jin Yong    337

Jin Yong
Đã đăng

Jin có một giải pháp thế này:

Bạn biết rằng các đối tượng đều có sẵn các method như Copy...

Nếu đó là một Sub, khi bạn gọi 3 lần Sub đó để vẽ 3 đường thẳng, thì bạn đã chưa có biến nào để gán cho 3 đoạn thẳng đó,

Nhưng nếu đó là một Function, bạn sẽ làm được 2 việc:

1. Vẽ được đoạn thẳng,

2. Bằng lệnh gán objLine1 = duongthang(X1,Y1,X2,Y2) và objLine2 = duongthang(...). Bạn đã có "tóc để mà nắm", mọi việc bây giờ chỉ còn là objLine1.Copy...

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

ndtnv    481

ndtnv
Đã đăng
Bạn nói rõ hơn được không hay viết cho mình cái ví dụ . Mình ko hiểu nắm

Function duongthang(a As Double, b As Double, c As Double, d As Double)
Dim point1(0 To 2) As Double
Dim point2(0 To 2) As Double
point1(0) = a
point1(1) = b
point1(2) = 0
point2(0) = c
point2(1) = d
point2(2) = 0
Dim line As AcadLine
Set line = ThisDrawing.ModelSpace.AddLine(point1, point2)
Set duongthang = line
End Function

Sub test()
Dim l As AcadLine, l2  As AcadLine, l3  As AcadLine
Dim point1(0 To 2) As Double
Dim point2(0 To 2) As Double
Set l = duongthang(0, 0, 100, 200)
point1(0) = 100
 point1(1) = 100
 point2(0) = 500
 point2(1) = 200
 Set l2 = l.Copy()
 l2.Move point1, point2
 Set l3 = l.Mirror(point1, point2)

End Sub

Bạn vào Help, phần

ActiveX and VBA Reference => Code Example copy các VD về thữ

  • Vote tăng 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

thanhduan2407    272

thanhduan2407
Đã đăng

Tiện thể mình nhờ bạn ndtnv giúp mình xoá các đối tượng trùng nhau (chỉ để lại 1 đối tượng) giống như lệnh overkill trong autocad nhưng chưa làm được. Mong bạn giúp đỡ. Mình đang gặp vấn đề về các line trùng lên nhau. Bạn có thể viết mã Code giúp mình được ko ? Cảm ơn bạn rất nhiều.

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

ndtnv    481

ndtnv
Đã đăng
Tiện thể mình nhờ bạn ndtnv giúp mình xoá các đối tượng trùng nhau (chỉ để lại 1 đối tượng) giống như lệnh overkill trong autocad nhưng chưa làm được. Mong bạn giúp đỡ. Mình đang gặp vấn đề về các line trùng lên nhau. Bạn có thể viết mã Code giúp mình được ko ? Cảm ơn bạn rất nhiều.

Lệnh overkill là lệnh của Express, do Autodesk viết trong 2 file overkill.lsp và overkillsup.lsp.

Dòng lệnh trong 2 file lên đến trên 1400, trừ các dòng comment thì cũng còn trên 1000 dòng nên để viết được cho VBA thì chi phí bỏ ra quá lớn mà chưa chắc đã chính xác bằng. Ngoài ra VBA lại ít hàm thư viện VD như các hàm sắp xếp, vì vậy mình nghĩ là khó có cá nhân nào làm nổi.

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

thanhduan2407    272

thanhduan2407
Đã đăng
Lệnh overkill là lệnh của Express, do Autodesk viết trong 2 file overkill.lsp và overkillsup.lsp.

Dòng lệnh trong 2 file lên đến trên 1400, trừ các dòng comment thì cũng còn trên 1000 dòng nên để viết được cho VBA thì chi phí bỏ ra quá lớn mà chưa chắc đã chính xác bằng. Ngoài ra VBA lại ít hàm thư viện VD như các hàm sắp xếp, vì vậy mình nghĩ là khó có cá nhân nào làm nổi.

Cảm ơn bạn đã reply mình.Con số mà bạn đưa ra thật đáng nể. Đối với câu lệnh overkill thì thật quá khó như bạn nói đó. Nhưng mình đang gặp trường hợp các line trùng đè lên nhau và mình chỉ muốn để lại 1 đối tượng. Mình cũng đã viết Code đó nhưng vẫn chưa được. Bạn tham khảo và cho mình ý kiến nhé:

Type Point_3D
rX As Double
rY As Double
rZ As Double
Layer1 As String
Color1 As Long
Flag As Boolean
End Type
Public DS_Points() As Point_3D, PointsCount As Long
Type Line_3D
P1 As Point_3D
P2 As Point_3D
TenLayer As String
Mausac As Long
End Type
Public DS_Lines() As Line_3D, LinesCount As Long
===============
Function AddPoint(ByVal rX As Double, ByVal rY As Double, ByVal rZ As Double, TenLayer As String, Mausac As Long)
Dim PointObj As AcadPoint
Dim Location(0 To 2) As Double
Dim LayerObj As AcadLayer
Set LayerObj = ThisDrawing.Layers.Add(TenLayer)
PointsCount = PointsCount + 1
ReDim Preserve DS_Points(PointsCount)
DS_Points(PointsCount).Flag = True
DS_Points(PointsCount).rX = rX
DS_Points(PointsCount).rY = rY
DS_Points(PointsCount).rZ = rZ
Location(0) = rX: Location(1) = rY: Location(2) = rZ
Set PointObj = ThisDrawing.ModelSpace.AddPoint(Location)
PointObj.layer = TenLayer
LayerObj.color = Mausac
End Function
=========================
Function AddLine(ByVal rX1#, ByVal rY1#, ByVal rZ1#, ByVal rX2#, ByVal rY2#, ByVal rZ2#, TenLayer As String, Mausac As Long)
Dim LineObj As AcadLine
Dim point1(0 To 2) As Double
Dim point2(0 To 2) As Double
Dim LayerObj As AcadLayer
Set LayerObj = ThisDrawing.Layers.Add(TenLayer)
LinesCount = LinesCount + 1
ReDim Preserve DS_Lines(LinesCount)
DS_Lines(LinesCount).P1.rX = rX1
DS_Lines(LinesCount).P1.rY = rY1
DS_Lines(LinesCount).P1.rZ = rZ1
DS_Lines(LinesCount).P2.rX = rX2
DS_Lines(LinesCount).P2.rY = rY2
DS_Lines(LinesCount).P2.rZ = rZ2
point1(0) = rX1: point1(1) = rY1: point1(2) = rZ1
point2(0) = rX2: point2(1) = rY2: point2(2) = rZ2
Set LineObj = ThisDrawing.ModelSpace.AddLine(point1, point2)
LineObj.layer = TenLayer
LayerObj.color = Mausac
End Function
===========================
Function Diemtrungnhau(P1 As Point_3D, P2 As Point_3D) As Boolean
If P1.rX = P2.rX And P1.rY = P2.rY Then
	Diemtrungnhau = True
Else
	Diemtrungnhau = False
End If
End Function
===============
Function Canhtrungnhau(L1 As Line_3D, l2 As Line_3D) As Boolean
If ((Diemtrungnhau(L1.P1, l2.P1) = True) And (Diemtrungnhau(L1.P2, l2.P2) = True)) Or ((Diemtrungnhau(L1.P1, l2.P2) = True) And (Diemtrungnhau(L1.P2, l2.P1) = True)) Then
	Canhtrungnhau = True
Else
	Canhtrungnhau = False
End If
End Function
================
Function LoaiCanhTrung()
Dim i As Long, j As Long
i = 0
Do Until i = LinesCount - 1
	i = i + 1
			For j = 1 To LinesCount - 1
				If Canhtrungnhau(DS_Lines(i), DS_Lines(j)) = True Then
					DS_Lines(i) = DS_Lines(j)
					LinesCount = LinesCount - 1
				End If
			Next
		i = i - 1
Loop
End Function

Bạn tham khảo và cho mình ý kiến nhé.

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

thanhduan2407    272

thanhduan2407
Đã đăng

Xin hỏi các bác một chút.

Các bác có thể cho em biết được phương thức hoặc lập hàm xóa tất cả các line trong bản vẽ được không ạ. Em cảm ơn các bác rất nhiều.

Kính mong các bác quan tâm

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

garupro    7

garupro
Đã đăng

Cái này mình cũng ko giám chắc .Bạn thử theo hướng này xem

Tạo SelectionSet

sau đó dùng phương thức Select với mode=5 để chọn toàn bộ đối tượng bản vẽ két hợp với bộ lọc để chọn ra các đối tượng line để xóa

bạn thử xem

 

Sub tt()
Dim sset As AcadSelectionSet
On Error Resume Next
Set sset = ThisDrawing.SelectionSets("FF")
If Err <> 0 Then
Err.Clear
Set sset = ThisDrawing.SelectionSets.Add("FF")
Else
sset.Clear
End If
Dim mode As Double
mode = 5
Dim fttype As Double
Dim fdata As String
ftype = 0
fdata = "LINE"
sset.Select mode, , ftype, fdata
Dim Enty As AcadEntity
For Each Enty In sset
  Enty.Delete
 Next Enty
 Application.Update

End Sub

 

Có gì ko đúng các bác đừng cười em nhe

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

ndtnv    481

ndtnv
Đã đăng
Cảm ơn bạn đã reply mình.Con số mà bạn đưa ra thật đáng nể. Đối với câu lệnh overkill thì thật quá khó như bạn nói đó. Nhưng mình đang gặp trường hợp các line trùng đè lên nhau và mình chỉ muốn để lại 1 đối tượng. Mình cũng đã viết Code đó nhưng vẫn chưa được. Bạn tham khảo và cho mình ý kiến nhé:

Bạn thử code này xem

Function Diemtrungnhau(P1 As Variant, P2 As Variant) As Boolean
If P1(0) = P2(0) And P1(1) = P2(1) Then
	Diemtrungnhau = True
Else
	Diemtrungnhau = False
End If
End Function

Function Canhtrungnhau(L1 As AcadLine, L2 As AcadLine) As Boolean
If ((Diemtrungnhau(L1.StartPoint, L2.StartPoint) = True) And (Diemtrungnhau(L1.EndPoint, L2.EndPoint) = True)) Or _
   ((Diemtrungnhau(L1.StartPoint, L2.EndPoint) = True) And (Diemtrungnhau(L1.EndPoint, L2.StartPoint) = True)) Then
	Canhtrungnhau = True
Else
	Canhtrungnhau = False
End If
End Function


Sub LoaiCanhTrung()
 Dim i As Long, j As Long
 Dim Li As AcadLine, Lj As AcadLine
 Dim ssLine As AcadSelectionSet
 Dim FilterType(0) As Integer
 Dim FilterData(0) As Variant
 Dim removeObjects(0) As AcadEntity

 Set ssLine = ThisDrawing.SelectionSets.Add("ssLine")
 FilterType(0) = 0
 FilterData(0) = "Line"
 ssLine.SelectOnScreen FilterType, FilterData
i = 0
Do Until i >= ssLine.Count - 1
  Set Li = ssLine.Item(i)
  For j = ssLine.Count - 1 To i + 1 Step -1
	Set Lj = ssLine.Item(j)
	  If Canhtrungnhau(Li, Lj) = True Then
		  Set removeObjects(0) = Lj
		  ssLine.RemoveItems (removeObjects)
		  Lj.Delete
	  End If
  Next
  i = i + 1
Loop
ssLine.Delete
End Sub

Chú ý là trong SelectionSets nếu Delete đối tượng cuối cùng thì không sao, nhưng muốn Delete đối tượng khác thì phải xóa trong SelectionSets trước.

Xin hỏi các bác một chút.

Các bác có thể cho em biết được phương thức hoặc lập hàm xóa tất cả các line trong bản vẽ được không ạ. Em cảm ơn các bác rất nhiều.

Kính mong các bác quan tâm

 

Sub DelLines()
 Dim i As Long
 Dim FilterType(0) As Integer
 Dim FilterData(0) As Variant

 Set ssLine = ThisDrawing.SelectionSets.Add("ssLine")
 FilterType(0) = 0
 FilterData(0) = "Line"
 ssLine.Select acSelectionSetAll, FilterType, FilterData
 For i = ssLine.Count - 1 To 0 Step -1
ssLine(i).Delete
 Next
 ssLine.Delete
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

thanhduan2407    272

thanhduan2407
Đã đăng

To ndtnv Cảm ơn bạn rất nhiều. Nhưng sau khi mình đưa vào sử dụng, nó xóa tất cả luôn. ko đ lại bất cứ đối tượng nào. rất cám ơn bạn nhiều. Bạn có thể xem lại giúp mình nha. Cảm ơn bạn

To garupro : xin cảm ơn bạn đã đóng góp nhưng mình sử dụng ko thành công bạn à. bạn có thể test ngay mà. Rất cảm ơn bạn

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

anhcos    196

anhcos
Đã đăng
To ndtnv Cảm ơn bạn rất nhiều. Nhưng sau khi mình đưa vào sử dụng, nó xóa tất cả luôn. ko đ lại bất cứ đối tượng nào. rất cám ơn bạn nhiều. Bạn có thể xem lại giúp mình nha. Cảm ơn bạn

To garupro : xin cảm ơn bạn đã đóng góp nhưng mình sử dụng ko thành công bạn à. bạn có thể test ngay mà. Rất cảm ơn bạn

 

Dùng theo mẫu của ndtnv nhưng chỉnh lại cái hàm sau xem như thế nào:

Function Diemtrungnhau(P1 As Variant, P2 As Variant) As Boolean
Diemtrungnhau =  Round(P1(0),3) = Round(P2(0),3) And Round(P1(1),3) = Round(P2(1),3)
End Function

Function Canhtrungnhau(L1 As AcadLine, L2 As AcadLine) As Boolean
 Canhtrungnhau = (Diemtrungnhau(L1.StartPoint, L2.StartPoint) And Diemtrungnhau(L1.EndPoint, L2.EndPoint)) OR_
  (Diemtrungnhau(L1.StartPoint, L2.EndPoint)  And Diemtrungnhau(L1.EndPoint, L2.StartPoint))
End Function

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

garupro    7

garupro
Đã đăng

Bạn làm theo mẫu của bạn ndtnv nhưng sửa lại 1 tý : Khai báo ssline và thêm 2 dấu , vào đoạn này ssline.Select acSelectionSetAll, FilterType, FilterData là oke (Vì ko có dấu , nên nó xóa tất cả các đối tượng)

 

Dim ssline As AcadSelectionSet
 Dim i As Long
 Dim FilterType(0) As Integer
 Dim FilterData(0) As Variant
 Set ssline = ThisDrawing.SelectionSets.Add("ssLine")
 FilterType(0) = 0
 FilterData(0) = "Line"
 ssline.Select acSelectionSetAll, , , FilterType, FilterData
 For i = ssline.Count - 1 To 0 Step -1
ssline(i).Delete
 Next
 ssline.Delete
 Application.Update

 

 

 

Mình đã test rồi

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
Về Đầu Trang Lập trình khác
×