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

creating a new layer bằng vba

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

nếu ai biết về cad thì có thể tạo một layer đơn giản như sau : la ==> alt + n  vào đó và đánh tên , hoặc giả dùng vba + lisp

B1 : tạo một dự án VBA : addtext như sau : 

Public Sub AddLayer()

Dim strLayerName As String 

Dim objLayer As AcadLayer

strLayerName = InputBox("Name of Layer to add: ") 'nhập thông báo tên newlayer

If "" = strLayerName Then Exit Sub ' thoát khi không nhập tên

On Error Resume Next 

'kiểm tra sự tồn tại của layer

Set objLayer = ThisDrawing.Layers(strLayerName)

If objLayer Is Nothing Then

Set objLayer = ThisDrawing.Layers.Add(strLayerName)

If objLayer Is Nothing Then 

MsgBox "Unable to Add '" & strLayerName & "'"

Else

MsgBox "Added Layer '" & objLayer.Name & "'"

End If

Else

MsgBox "Layer already existed"

End If

End Sub

 

tạo 1 file lisp có nội dung :(defun c:AddLayer()(command "vbarun" "AddLayer")(princ))

 như vậy lúc nào tiện ap file lisp đó thì lệnh trong lisp giống lệnh trong vba . chúc các bạn thành công .http://www.cadviet.com/upfiles/3/121145_testaddarc.lsphttp://www.cadviet.com/upfiles/3/121145_active_space__copy.rar

 

2 file 1 file là dự án độc lập vba một bên là chuyển lệnh từ vba sang lisp. còn có cách khác là khi nào mở cad là có lệnh giống như lệnh nguyên thuỷ của máy nữa sẽ trình bày sau. 

(defun c:AddLayer()(command "vbarun" "AddLayer")(princ))
 
(defun c:AddLayer()(command "vbarun" "AddLayer")(princ))
 
(defun c:AddLayer()(command "vbarun" "AddLayer")(princ))
 
(defun c:AddLayer()(command "vbarun" "AddLayer")(princ))
 
Public Sub AddLayer()
Dim strLayerName As String
Dim objLayer As AcadLayer
strLayerName = InputBox("Name of Layer to add: ")
If "" = strLayerName Then Exit Sub ' exit if no name entered
On Error Resume Next ' handle exceptions inline
'check to see if layer already exists
Set objLayer = ThisDrawing.Layers(strLayerName)
If objLayer Is Nothing Then
Set objLayer = ThisDrawing.Layers.Add(strLayerName)
If objLayer Is Nothing Then ' check if obj has been set
MsgBox "Unable to Add '" & strLayerName & "'"
Else
MsgBox "Added Layer '" & objLayer.Name & "'"
End If
Else
MsgBox "Layer already existed"
End If
End Sub
Public Sub AddLayer()
Dim strLayerName As String
Dim objLayer As AcadLayer
strLayerName = InputBox("Name of Layer to add: ")
If "" = strLayerName Then Exit Sub ' exit if no name entered
On Error Resume Next ' handle exceptions inline
'check to see if layer already exists
Set objLayer = ThisDrawing.Layers(strLayerName)
If objLayer Is Nothing Then
Set objLayer = ThisDrawing.Layers.Add(strLayerName)
If objLayer Is Nothing Then ' check if obj has been set
MsgBox "Unable to Add '" & strLayerName & "'"
Else
MsgBox "Added Layer '" & objLayer.Name & "'"
End If
Else
MsgBox "Layer already existed"
End If
End Sub
Public Sub AddLayer()
Dim strLayerName As String
Dim objLayer As AcadLayer
strLayerName = InputBox("Name of Layer to add: ")
If "" = strLayerName Then Exit Sub ' exit if no name entered
On Error Resume Next ' handle exceptions inline
'check to see if layer already exists
Set objLayer = ThisDrawing.Layers(strLayerName)
If objLayer Is Nothing Then
Set objLayer = ThisDrawing.Layers.Add(strLayerName)
If objLayer Is Nothing Then ' check if obj has been set
MsgBox "Unable to Add '" & strLayerName & "'"
Else
MsgBox "Added Layer '" & objLayer.Name & "'"
End If
Else
MsgBox "Layer already existed"
End If
End Sub

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

nếu ai biết về cad thì có thể tạo một layer đơn giản như sau : la ==> alt + n  vào đó và đánh tên , hoặc giả dùng vba + lisp

B1 : tạo một dự án VBA : addtext như sau : 

Thật ra theo mình : 

* nên viết thành 1 Funciton ExistsLayer()  hàm này sẽ kiểm tra sự tồn tại của tên Layer--> và khi ta muốn tạo 1 layer mới thì code sẽ như kiểu : If ExistsLayer("strLayer") then .......

* Thói quen của mình hạn chế dùng On Error Resume Next để bẫy lỗi đưa kết quả ( cái vụ On error này "cực chẳng đã " ta mới dùng bẫy lỗi để lập trình) vì nếu trong một Sub rất nhiều giải thuật --> đôi lúc sẽ khiến ta không kiểm soát hết được lỗi , lúc này ta phải thêm 1 câu lệnh on error goto 0

* Với bài này ta có thể dùng vòng lặp duyệt qua tất cả các tên của layer, nếu tên nào trùng với strLayer --> kết luận đã tồn tại layer này và thoát khỏi vòng lặp.

 

==> đây chỉ là ý kiến chủ quan của mình 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

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  

×