Đến nội dung


Hình ảnh
- - - - -

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


  • Please log in to reply
16 replies to this topic

#1 garupro

garupro

    biết vẽ circle

  • Members
  • PipPip
  • 34 Bài viết
Điểm đánh giá: 7 (bình thường)

Đã gửi 28 September 2010 - 11:11 PM

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á
  • 0

#2 Jin Yong

Jin Yong

    biết lệnh group

  • Vip
  • PipPipPipPipPipPip
  • 498 Bài viết
Điểm đánh giá: 334 (khá)

Đã gửi 28 September 2010 - 11:27 PM

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


  • 0

Phát triển phần mềm thiết kế Kết cấu Việt Nam - http://www.ketcausoft.com


#3 garupro

garupro

    biết vẽ circle

  • Members
  • PipPip
  • 34 Bài viết
Điểm đánh giá: 7 (bình thường)

Đã gửi 29 September 2010 - 12:02 AM

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
  • 0

#4 garupro

garupro

    biết vẽ circle

  • Members
  • PipPip
  • 34 Bài viết
Điểm đánh giá: 7 (bình thường)

Đã gửi 29 September 2010 - 07:14 PM

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

#5 ndtnv

ndtnv

    biết lệnh minsert

  • Members
  • PipPipPipPipPipPip
  • 437 Bài viết
Điểm đánh giá: 384 (khá)

Đã gửi 30 September 2010 - 10:32 AM

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ữ
  • 1

#6 garupro

garupro

    biết vẽ circle

  • Members
  • PipPip
  • 34 Bài viết
Điểm đánh giá: 7 (bình thường)

Đã gửi 30 September 2010 - 12:52 PM

Được rùi cảm ơn bạn nhiều
  • 0

#7 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 995 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 30 September 2010 - 02:48 PM

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.
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#8 ndtnv

ndtnv

    biết lệnh minsert

  • Members
  • PipPipPipPipPipPip
  • 437 Bài viết
Điểm đánh giá: 384 (khá)

Đã gửi 30 September 2010 - 03:21 PM

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.
  • 0

#9 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 995 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 30 September 2010 - 04:02 PM

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é.
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#10 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 995 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 02 October 2010 - 10:14 AM

Không có ai giúp mình sao ? Hix.
Các bác giúp em với nhé.
  • 1



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#11 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 995 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 13 October 2010 - 10:22 PM

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
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#12 garupro

garupro

    biết vẽ circle

  • Members
  • PipPip
  • 34 Bài viết
Điểm đánh giá: 7 (bình thường)

Đã gửi 14 October 2010 - 02:35 AM

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
  • 0

#13 ndtnv

ndtnv

    biết lệnh minsert

  • Members
  • PipPipPipPipPipPip
  • 437 Bài viết
Điểm đánh giá: 384 (khá)

Đã gửi 14 October 2010 - 11:25 AM

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

  • 0

#14 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 995 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 14 October 2010 - 06:30 PM

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
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#15 anhcos

anhcos

    biết lệnh hatchedit

  • Advance Member
  • PipPipPipPip
  • 260 Bài viết
Điểm đánh giá: 170 (tàm tạm)

Đã gửi 14 October 2010 - 08:04 PM

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

  • 0
Clear sky!

MF Rock collection.

#16 garupro

garupro

    biết vẽ circle

  • Members
  • PipPip
  • 34 Bài viết
Điểm đánh giá: 7 (bình thường)

Đã gửi 14 October 2010 - 09:12 PM

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
  • 0

#17 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 995 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 15 October 2010 - 07:26 AM

Cảm ơn anh anhcos. Cảm ơn: garupro. Cảm ơn: ndtnv
Em đã test và duyệt thành công rồi. Một lần nữa cảm ơn các bác
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn