Đến nội dung


Hình ảnh
- - - - -

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


  • Please log in to reply
7 replies to this topic

#1 nvson

nvson

    biết vẽ ellipse

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

Đã gửi 26 October 2011 - 09:11 AM

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

#2 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5685 Bài viết
Điểm đánh giá: 2606 (tuyệt vời)

Đã gửi 26 October 2011 - 09:50 AM

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

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#3 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 26 October 2011 - 09:55 AM

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.
  • 0
Clear sky!

MF Rock collection.

#4 nvson

nvson

    biết vẽ ellipse

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

Đã gửi 26 October 2011 - 11:00 AM


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

#5 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5685 Bài viết
Điểm đánh giá: 2606 (tuyệt vời)

Đã gửi 26 October 2011 - 11:20 AM

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

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#6 nvson

nvson

    biết vẽ ellipse

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

Đã gửi 26 October 2011 - 12:51 PM

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

#7 phantuhuong

phantuhuong

    biết dimstyle

  • Moderator
  • PipPipPipPipPip
  • 383 Bài viết
Điểm đánh giá: 200 (khá)

Đã gửi 29 October 2011 - 05:24 PM

Hi hi, OK.
Tôi đã làm được rồi, thanks các bác nhiều.


Cậu làm được thì share đi chứ!
  • 0
Bồi dưỡng Excel & VBA cho các đơn vị ở Hà Nội và khu vực lân cận

Từng bước loại đồ Tàu ra khỏi cuộc sống!


#8 nvson

nvson

    biết vẽ ellipse

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

Đã gửi 31 October 2011 - 09:02 AM

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


  • 0