Chuyển đến nội dung
Diễn đàn CADViet
Đăng nhập để thực hiện theo  
nvson

Hỏi cách thay đổi chiều dài của POLYLINE bằng VBA?

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

Tôi có 1 Polyline (gồm nhiều đoạn thẳng và nhiều cung).

Xin hỏi các bác là trong VBA có cách nào thay đổi chiều dài (Length) của Polyline đó theo một giá trị cho trước không ạ? (Giống như lệnh Lengthen của Autocad đấy).

 

Xin cảm ơn các bá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

Khi thay đổi Length:

- nếu dài hơn thì thêm vào đoạn cuối: tính ra và thay đổi đỉnh cuối cùng của PL

 

- nếu ngắn hơn thì

+ cho đoạn cuối ngắn lại

+ hoặc có thể phải xóa bớt các đoạn và đỉnh ở cuối

 

Triển khai code chi tiết hơi mệt một tí thô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

 

Khi thay đổi Length:

- nếu dài hơn thì thêm vào đoạn cuối: tính ra và thay đổi đỉnh cuối cùng của PL

 

- nếu ngắn hơn thì

+ cho đoạn cuối ngắn lại

+ hoặc có thể phải xóa bớt các đoạn và đỉnh ở cuối

 

Triển khai code chi tiết hơi mệt một tí thôi.

 

Dùng code thì tôi đang bí ở chỗ nếu chiều dài cần thay đổi lại đúng vào chỗ cung tròn thì rất khó...

 

 

 

 

Có. Sendcommand lengthen đó bạn :">

 

 

Dùng sendcommand thì có cái bất tiện là phải chọn lại PLine bằng con trỏ chuột, mà trong code của mình thì: Pline được tạo ra từ code (nối các điểm..., có cả cung nữa).

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ại sao lại phải chọn Pline lại bạn nhỉ ?? Pline tạo ra từ code thì bạn cũng phải gắn tên cho nó đặng mà nắm đầu thao tác về sau chứ ?

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ại sao lại phải chọn Pline lại bạn nhỉ ?? Pline tạo ra từ code thì bạn cũng phải gắn tên cho nó đặng mà nắm đầu thao tác về sau chứ ?

Hi hi, OK.

Tôi đã làm được rồi, thanks các bác 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

Chào anh Hướng!

Mục đích của em là Insert hàng loạt vị trí của các lỗ khoan theo tim tuyến (các công trình dạng tuyến), còn kiểu insert theo tọa độ thì đơn giản rồi. Hi hi.

Các bác xem giúp nhé:

 


Sub station_LK()
On Error Resume Next
Dim station_origin, station, Km() As String
Dim i, x, caodo, dosau, tenlk
Dim Hscale 'As Double
Dim traloi
Dim pre As Integer
Dim ptC(0 To 2) As Double
Dim pointVertex
Dim pointVertex_Copy
Dim varAtts() As AcadBlockReference
Dim blockRefObj As AcadBlockReference
Dim symbolblockRefObj As AcadBlockReference
Dim objPL 'As AcadPolyline
Dim objPL_Copy
Dim ssObject As AcadSelectionSet
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
traloi = MsgBox("Truoc khi chay phai zoom doan cuoi cua polyline (Zoom/ Extend)", vbOKCancel, "Nguyen Van Son")
If traloi <> 1 Then GoTo thoat2
'Chon PolyLine
Set ssObject = ThisDrawing.SelectionSets.Add("Pline")
FilterType(0) = 0
FilterData(0) = "LWPOLYLINE"
ssObject.SelectOnScreen FilterType, FilterData
pre = ThisDrawing.GetVariable("LUPREC")
If ssObject.Count = 0 Then
MsgBox "No selected Polyline", , "Nguyen Van Son"
GoTo thoat
End If
station_origin = InputBox("Nhap Ly trinh goc", "Nguyen Van Son", 0)
If Len(station_origin) = 0 Then GoTo thoat
Hscale = (InputBox("Nhap Ty le ban ve", "Nguyen Van Son", 1000))
If Len(Hscale) = 0 Then GoTo thoat
station = InputBox("Nhap Ly trinh cua lo khoan", "Nguyen Van Son", 100)
If Len(station) = 0 Then GoTo thoat
tenlk = InputBox("Nhap ten lo khoan:", , "LK")
If Len(tenlk) = 0 Then GoTo thoat
caodo = AcadApplication.ActiveDocument.Utility.RealToString(InputBox("Nhap Cao do lo khoan:", , 0), acDecimal, pre)
If Len(caodo) = 0 Then GoTo thoat
dosau = AcadApplication.ActiveDocument.Utility.RealToString(InputBox("Nhap Do sau lo khoan:", , 10), acDecimal, pre)
If Len(dosau) = 0 Then GoTo thoat
If InStr(1, station_origin, "+", 1) Then station_origin = strStation2Number(station_origin)
If InStr(1, station, "+", 1) Then station = strStation2Number(station)
station_origin = CDbl(station_origin)
station = CDbl(station)
'Lay dai dien 1 duong Polyline
Set objPL = ssObject.Item(0)
Set objPL_Copy = objPL.Copy
pointVertex = objPL.Coordinates
If station = station_origin Then
pointVertex_Copy = objPL.Coordinate(0)
ptC(0) = pointVertex_Copy(0)
ptC(1) = pointVertex_Copy(1)
Else
AutoCAD.ActiveDocument.SendCommand "Lengthen" & vbCr & "T" & vbCr & (station - station_origin) * 1000 / Hscale & vbCr & pointVertex(UBound(pointVertex) - 1) & "," & pointVertex(UBound(pointVertex)) & vbCr & vbCr
pointVertex_Copy = objPL_Copy.Coordinates

ptC(0) = pointVertex_Copy(UBound(pointVertex_Copy) - 1)
ptC(1) = pointVertex_Copy(UBound(pointVertex_Copy))
End If
Set blockRefObj = AcadApplication.ActiveDocument.ModelSpace.InsertBlock(ptC, "lokhoan.dwg", 1#, 1#, 1#, 0)
varAtts = blockRefObj.GetAttributes
For x = LBound(varAtts) To UBound(varAtts)
Select Case varAtts(x).TagString
   	Case "LK"
       	varAtts(x).TextString = tenlk
   	Case "CAO-DO"
       	varAtts(x).TextString = Format$(caodo, "0.00")
   	Case "DO-SAU"
       	varAtts(x).TextString = Format$(dosau, "0.00")
End Select
Next x
Set symbolblockRefObj = AcadApplication.ActiveDocument.ModelSpace.InsertBlock(ptC, "symbol.dwg", 1#, 1#, 1#, 0)
blockRefObj.Update
MsgBox "No error"
thoat2:
objPL_Copy.Delete
Set objPL = Nothing
Set objPL_Copy = Nothing
Set blockRefObj = Nothing
Set symbolblockRefObj = Nothing

thoat:
ssObject.Delete
End Sub
'Chuyen doi ly trinh tu dang Km..+.. sang dang so
Public Function strStation2Number(station) As Double
Dim Km() As String
If InStr(1, station, "+", 1) > 0 Then
Km = Split(UCase$(station), "+")
Km(LBound(Km)) = Replace(Km(LBound(Km)), "KM", "")
If UBound(Km) > 0 Then
   	Km(LBound(Km)) = Val(Km(LBound(Km))) * 1000
   	Km(UBound(Km)) = Val(Km(UBound(Km)))
   	strStation2Number = CDbl(Km(UBound(Km))) + CDbl(Km(LBound(Km)))
Else
   	strStation2Number = CDbl(Val(Km(LBound(Km)))) * 1000
End If
End If
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

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  

×