Thành Công WRU
-
Số lượng nội dung
22 -
Đã tham gia
-
Lần ghé thăm cuối
-
Ngày trúng
2
Bài đăng được đăng bởi Thành Công WRU
-
-
[Xin lisp] Bo vỉa hè
trong AutoLisp
thôi thì em tự mò cop nhặt trên mạng và tự chế thêm chút ít cũng phần nào giải quyết được bài toán rồi ạ
code em đây
QuoteOption Explicit
Public radQ As Double
Public lengthL As Double
Sub GetBulgeRadius()Dim lastA As String
lastA = radQ
Dim radA As String
On Error GoTo check
radA = ThisDrawing.Utility.GetString(0, vbCrLf & "Nhap ban kinh toi da: " & "< " & radQ & " > __")
check:
On Error Resume Next
If radA <> "" Then radQ = radA
' lengthL = ThisDrawing.Utility.GetString(1, vbCrLf & "Nhap chieu dai toi da: " & "< " & lengthL & " > __")
On Error GoTo 0
Dim plineObj As AcadPolyline
Dim points(0 To 5) As Double
Dim oent As AcadEntity
Dim varpt
Dim opoly As AcadLWPolyline
Dim rad As Double, ang As Double, b As Double, d As Double
Dim c As Double, i As Long, j As Long, bulge As Double, pi As Double
Dim coors As Variant, p1 As Variant, p2 As Variant, cpt(2) As Double
Dim Pt1(2) As Double, Pt2(2) As Double, s As String
pi = 3.14159265358979: s = ""
On Error Resume NextDim newVertex(0 To 1) As Double
Dim tapXuLy As AcadSelectionSet
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
Dim doiTuong As Variant
FilterType(0) = 0
FilterData(0) = "LWPOLYLINE"
Set tapXuLy = ThisDrawing.SelectionSets("MySS")
If Err Then
Err.Clear
Set tapXuLy = ThisDrawing.SelectionSets.Add("MySS")
Else
tapXuLy.Clear
End If
tapXuLy.SelectOnScreen FilterType, FilterData
For Each doiTuong In tapXuLy
'ThisDrawing.Utility.GetEntity oent, varpt, "Chon doi tuong"
Set opoly = doiTuongcoors = doiTuong.Coordinates
newVertex(0) = coors(0)
newVertex(1) = coors(1)
doiTuong.AddVertex (UBound(coors) + 1) / 2, newVertex
doiTuong.AddVertex (UBound(coors) + 3) / 2, newVertex
doiTuong.Update
Set opoly = doiTuong
coors = opoly.Coordinates
'MsgBox UBound(coors)
j = 0
For i = 0 To (UBound(coors) / 2 - 1) - 1'bulge : do phinh ra ARC
bulge = opoly.GetBulge(j)
If bulge <> 0 Then
p1 = opoly.Coordinate(i)
p2 = opoly.Coordinate(i + 1)Pt1(0) = p1(0): Pt1(1) = p1(1): Pt1(2) = opoly.Elevation
Pt2(0) = p2(0): Pt2(1) = p2(1): Pt2(2) = opoly.Elevation
'ang : goc giua 2 diem pt1 va pt2
ang = ThisDrawing.Utility.AngleFromXAxis(Pt1, Pt2)
'b ArcTan cua goc Bulge
b = Atn(bulge) * 2'd Tinh khoang cach giua 2 dau mut cua ARC
d = Get_Distance(p1, p2) / 2
If bulge > 0 Then
c = ang + pi / 2 - b
Else
c = ang - pi / 2 - b
End If'Ban kinh
rad = Abs(d / Sin(b))'tam cung tron
cpt(0) = p1(0) + Cos(c) * rad
cpt(1) = p1(1) + Sin(c) * rad
cpt(2) = 0If rad <= radQ Then
'them cung tron
points(0) = Pt1(0)
points(1) = Pt1(1)
points(2) = Pt1(2)
points(3) = Pt2(0)
points(4) = Pt2(1)
points(5) = Pt2(2)
Set plineObj = ThisDrawing.ModelSpace.AddPolyline(points)
plineObj.SetBulge 0, bulge
opoly.SetBulge j, 0
End If
End If
j = j + 1
Next i
Next doiTuongkt:
Exit Sub
End Sub
Public Function Get_Distance(fPoint As Variant, sPoint As Variant) As DoubleDim x1 As Double, x2 As Double
Dim y1 As Double, y2 As Double
Dim z1 As Double, z2 As Double
Dim cDist As Doublex1 = fPoint(0): y1 = fPoint(1)
If UBound(fPoint) = 2 Then z1 = fPoint(2) Else z1 = 0#
x2 = sPoint(0): y2 = sPoint(1)
If UBound(sPoint) = 2 Then z2 = sPoint(2) Else z2 = 0#cDist = Sqr(((x2 - x1) ^ 2) + ((y2 - y1) ^ 2) + ((z2 - z1) ^ 2))
Get_Distance = cDistEnd Function
-
[Xin lisp] Bo vỉa hè
trong AutoLisp
7 giờ trước, quocmanh04tt đã nói:không được anh ạ
Command: (LOAD "C:/Users/Administrator/Desktop/bvs.vlx")
Dung lenh: BVS. @quocmanh04tt-catviet.comnilCommand:
Command:
Command: _propertiesclose
Command: BVS ; error: bad argument type: stringp nil -
[Xin lisp] Bo vỉa hè
trong AutoLisp
không biết do đề bài chưa rõ ràng hay mọi người bận hết rồi :((
- 1
-
[Xin lisp] Bo vỉa hè
trong AutoLisp
Chào mọi người, em đang có một bài toán lặp đi lặp lại như sau và mong có được giải pháp bằng lisp (*.lsp để có thể tùy chỉnh bán kính được ) :
- Ban đầu có layer 1 và 2 như ở hình bên trái, biết rằng chúng đều là các polyline tạo bởi line + arc
- Sau đó tại 2 đầu của ARC có R<=[40] thì nối 2 điểm đó lại , break đối tượng layer 2 cũ tại 2 điểm đó và tạo được polyline mới như hình bên phải, đoạn ARC sẽ là layer 0
Xin cảm ơn mọi người đã giành thời gian đọc post này, rất mong nhận được sự góp ý phản hồi từ mọi người. Chúc mọi người sức khỏe !
-
Cảm ơn bạn cuongtk2 rất nhiều, chúc bạn những điều tốt đẹp nhất !
-
Cảm ơn cuongtk2 rất nhiều ạ, tuy nhiên có thể sửa thành click đúp vào trong ô đó thay vì bấm các điểm endpoint không ạ ?
-
Chào các anh chị, em đang làm việc về thiết kế cải tạo nền cho các công trình, hiện tại em gặp bài toán lặp đi lặp lại với yêu cầu như sau :
1. Đã có các line là đường trung trực thể hiện bằng màu đỏ ở file đính kèm
2. Cần Fillet các đường trung trực trong 1 ô , sao cho không bị trùng chéo lên nhau
3. Nối các giao điểm lại bằng line để tạo ra kết quả như file đính kèm
Vậy em xin nhờ các anh chị nếu có thể hãy giúp đỡ em ạ. Em xin cảm ơn anh chị, chúc anh chị thành công trong cuộc sống !
-
xin chào các bác, em có tải về dùng thử thì bị tình trạng như sau :
+ Nếu vẽ vu vơ các đường LINE thì lisp rất ngon lành
+ Nếu vẽ bắt điểm vào đâu đó thì không còn dùng được lisp nữa
+ chỉ dùng được với LINE, PLINE thì không ?
Mong các bác sửa lại cho ứng dụng được nhiều hơn ạ.
-
Xin chào các bác, hiện tại em đang gặp vấn đề như sau, nếu làm thủ công thì cũng được nhưng làm hơi lâu và mang tính chất lặp lại nên giờ lên đây xin được mạn phép nhờ các bác viết lisp ạ ^^.
-
-
lệnh tắt là gì ấy bác nhỉ ?
-
Bác học khóa nào ở WRU thế ạ?
-
Public Sub UserForm_Initialize() Dim s1, s As String s = "B" & ChrW(7855) & "t " & ChrW(273) & ChrW(7847) & "u v" & ChrW(7869) s1 = "Thoát" HCN.Caption = "v" & ChrW(7869) & " hình ch" & ChrW(7919) & " nh" & ChrW(7853) & "t" btnVe.Caption = s btnThoat.Caption = s1 End Sub
code của em đây anh
-
-
-
cảm ơn anh, em đã hiểu ra vấn đề rồi, và vbCr là thay cho phím cách phải không anh ?
-
chào các anh chị trong diễn đàn, em đang tập tành món vba cho autocad , nay gặp phải vấn đề này mong anh chị giúp đỡ ạ
ví dụ em khai báo biến a có giá trị 0,
làm sao để truyền biến a vào dòng lệnh ThisDrawing.SendCommand " "
mong các anh chị chỉ giáo ạ
-
không Join được ư? hãy vẽ thêm một đoạn nối 2 đầu của đường bạn muốn Join , sau đó dùng lệnh "BO" và đóng bao các đối tượng đó lại. Như vậy ta được 1 đường nối giống như Join, rồi ta Trim phần thừa đi. Đơn giản phải không ?
- 1
Nhờ vả - lisp chỉ chọn text trong vùng đối tượng
trong AutoLisp
Đã đăng · Trả lời báo cáo
Lệnh SBT chỉ chọn text trong vùng chọn
SB Chỉ chọn Block trong vùng chọn
SHA chỉ chọn hatch trong vùng chọn
SD chỉ chọn Dim trong vùng chọn
SBL chỉ chọn đối tượng mang layer theo đối tượng mẫu
SBO chỉ chọn đối tượng giống đối tượng mẫu
SBN chỉ chọn block có tên giống với block mẫu
SGN chỉ chọn các text có nội dung giống với text mẫu
SBC chỉ chọn đối tượng có color giống đối tượng mẫu
Code theo anh Ketxu trên diễn đàn.
QuickSelect.lsp