>> StructDesignPro

structdesignpro · Site Admin

'**********************************
'chon mot doi tuong la duong thang.
'array chung thang 6 doi tuong
'voi deltax=0, deltay=L/2
'(L la chieu dai doan thang
'doi mau 7 doi tuong noi tren thanh
'cac doi tuong co mau 1 den mau 7
'**********************************
Sub BT2()
Dim Deltax As Double
Dim Deltay As Double
Dim L As Double
Dim Entt As AcadEntity
Dim VarPick As Variant
Dim EntityType As String
Dim EntLine As AcadLine
Dim ObjArray As Variant
Dim i As Integer
'Get entity
EntityType = "Line"
'On Error Resume Next
ThisDrawing.Utility.GetEntity Entt, VarPick, vbCr & "CHON DOI TUONG: "
If Entt Is Nothing Then Exit Sub
If Entt.ObjectName <> "AcDb" & EntityType Then
ThisDrawing.Utility.Prompt vbCrLf & "CHON LAI DOI TUONG"
Exit Sub
End If

Set EntLine = Entt

'tinh chieu dai L
L = Sqr((EntLine.StartPoint(0) - EntLine.EndPoint(0)) ^ 2 + (EntLine.StartPoint(1) - EntLine.EndPoint(1)) ^ 2 + (EntLine.StartPoint(2) - EntLine.EndPoint(2)) ^ 2)

'bat dau array
Deltax = 0
Deltay = L / 2
ObjArray = EntLine.ArrayRectangular(7, 1, 1, Deltay, Deltax, 0)

'Doi mau doi tuong
EntLine.color = 1
For i = 1 To 6
ObjArray(i - 1).color = i + 1
ObjArray(i - 1).Update
Next
End Sub
_________________
Mời bạn đến với bách khoa toàn thư về kết cấu:.
http://vi.ketcau.wikia.com

structdesignpro · Site Admin

Tạo một file Lisp định nghĩa lệnh BT2 như sau
;*******************************************************************************
(DEFUN C:BT2(/)
(COMMAND "VBARUN" "BT2" " ")
)
;*******************************************************************************

Sau đó tải file sau vào để tạo một menu

'*************************************************************
' TAO MOT MENU CO TEN LA Test DE GOI LISP O VIDU1 VA VBA O VD2
'*************************************************************
Sub CreatMenu()
Dim Mngr As AcadMenuGroup
Dim Mnus As AcadPopupMenus
Dim Mnu As AcadPopupMenu
Dim MnuItem As AcadPopupMenuItem

Set Mngr = ThisDrawing.Application.MenuGroups(0) 'Menu Groups Custom
Set Mnus = Mngr.Menus
On Error GoTo Exitt
Set Mnu = Mnus.Add("&Test") 'Creat a menu bar
Set Mnu = Mnus("&Test")
Set MnuItem = Mnu.AddMenuItem(0, "BT &Lisp", Chr(3) + Chr(3) + "BT1 ")
Set MnuItem = Mnu.AddSeparator(1)
Set MnuItem = Mnu.AddMenuItem(2, "BT &VBA", Chr(3) + Chr(3) + "BT2 ")
Mnu.InsertInMenuBar (0)
Exitt:
Err.Clear
ThisDrawing.Utility.Prompt (vbCrLf & "Co loi xay ra")
Resume Next
End Sub
_________________
Mời bạn đến với bách khoa toàn thư về kết cấu:.
http://vi.ketcau.wikia.com