Help về toạ độ 3D sang 2D bằng VBA

[conghoangxd037 0]

Hiện trên bản vẽ em các đường line có toạ độ 3D X,Y,Z( mà Z thì không phải bằng 0) làm thế nào chuyển tất cả các đường line trên bản vẽ về toạ độ 2D X, Y(như cũ) nhưng Z=0.

[Mọt Sách 3]

Bạn tìm lisp là phẳng đối tượng là OK đấy mà

[conghoangxd037 0]

đúng là có lệnh chuyển đối tượng về z=0 nhưng sau khi sử dụng lệnh Flatten thì các đối tượng line sẽ thay đổi về thứ tự trong selection.Giống như em lập trình vba vẽ các đối tượng sẽ sử dụng lấy điểm endpoint, startpoint và cho z=0 thì cũng giống như lệnh flatten. Em muốn là mình chỉ chỉnh trong property thôi để trật tự vị trí xuất hiện đối tượng đầu và đối tượng cuối trong bản vẽ là cố định.Nếu dùng tay chỉ trong property thì hơi lâu, em thì muốn biết trong vba có phương pháp nào chỉ trong property không

[gia_bach 1.549]

đúng là có lệnh chuyển đối tượng về z=0 nhưng sau khi sử dụng lệnh Flatten thì các đối tượng line sẽ thay đổi về thứ tự trong selection.Giống như em lập trình vba vẽ các đối tượng sẽ sử dụng lấy điểm endpoint, startpoint và cho z=0 thì cũng giống như lệnh flatten. Em muốn là mình chỉ chỉnh trong property thôi để trật tự vị trí xuất hiện đối tượng đầu và đối tượng cuối trong bản vẽ là cố định.Nếu dùng tay chỉ trong property thì hơi lâu, em thì muốn biết trong vba có phương pháp nào chỉ trong property không

Tham khảo :

Sub LineTo2D()

 

Dim entry As AcadObject

Dim PickedPoint As Variant

 

ThisDrawing.Utility.GetEntity entry, PickedPoint, "(Select Line : )"

 

' Neu la doi tuong Line

If entry.ObjectName = "AcDbLine" Then

Dim line As AcadLine

Dim staPt As Variant

Dim endPt As Variant

Set line = entry

' Get StartPoint and EndPoint

staPt = line.StartPoint

endPt = line.EndPoint

 

' Set Z = 0

staPt(2) = 0

endPt(2) = 0

 

' Update Line with Z = 0

line.StartPoint = staPt

line.EndPoint = endPt

 

End If

 

End Sub

[Mọt Sách 3]

đúng là có lệnh chuyển đối tượng về z=0 nhưng sau khi sử dụng lệnh Flatten thì các đối tượng line sẽ thay đổi về thứ tự trong selection.Giống như em lập trình vba vẽ các đối tượng sẽ sử dụng lấy điểm endpoint, startpoint và cho z=0 thì cũng giống như lệnh flatten. Em muốn là mình chỉ chỉnh trong property thôi để trật tự vị trí xuất hiện đối tượng đầu và đối tượng cuối trong bản vẽ là cố định.Nếu dùng tay chỉ trong property thì hơi lâu, em thì muốn biết trong vba có phương pháp nào chỉ trong property không

 

Bạn tham khảo nhé :

Private sset As AcadSelectionSet
Private returnObj As ACADObject
Private elem As Object
Private color As Variant
Private Elv As Double
Private Layer As String
'--------------------------------
Private Sub cmdCancelM_Click()
On Error Resume Next
sset.Clear
Unload Me
End Sub
'--------------------------------
Private Sub Cmd_Select_Click()
Dim basePnt As Variant
Dim Elv As Double
Frm_UtilitiesPL.Hide

On Error Resume Next
ThisDrawing.Utility.GetEntity returnObj, basePnt, "Select a polyline"

If (StrComp(returnObj.EntityName, "AcDbPolyline", 1) <> 0 And (StrComp(returnObj.EntityName, "AcDb2DPolyline", 1) <> 0)) Then
   	MsgBox "You did not select a polyline"
   	GoTo 1:
End If

Elv = returnObj.Elevation
Text_ELVcurent.Text = CStr(Elv)
TxT_LayerCurent.Text = returnObj.Layer
1:
Frm_UtilitiesPL.show

End Sub
'--------------------------------
Private Sub cmdApply_Click()
Dim Msbox
Dim elem1 As Object
Dim color1 As Variant
Dim ELV1 As Double
Dim Layer1 As String
Sub Gangiatri()
   	On Error Resume Next
   	'Thay doi cao doi
   	If Check_ELV.value = True Then
       	If Op_Change.value = True Then
           	elem.Elevation = elem.Elevation + Elv
       	End If
       	If Op_Fix.value = True Then
           	elem.Elevation = Elv
       	End If
   	End If
ELV1 = 0
If Check_ELV2.value = True Then
   	On Error Resume Next
   	ELV1 = CDbl(Txt_ELV2.Text)
End If
If Cbb_Layer2.value <> "Select Layer" Then
   	Layer1 = Cbb_Layer2.value
End If

' Gan cao do moi cho doi tuong
If Check_ELV2.value = True Then
   	If Op_Change2.value = True Then
       	returnObj.Elevation = returnObj.Elevation + ELV1
   	End If
   	If Op_Fix2.value = True Then
       	returnObj.Elevation = ELV1
   	End If
End If