Đến nội dung


Hình ảnh
- - - - -

creating a new layer bằng vba


  • Please log in to reply
2 replies to this topic

#1 nguyendinhlinh_xd

nguyendinhlinh_xd

    Chưa sử dụng CAD

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

Đã gửi 21 July 2013 - 08:17 PM

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.c..._testaddarc.lsphttp://www.cadviet.c...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

  • 0

#2 HungDHXD

HungDHXD

    biết vẽ ellipse

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

Đã gửi 22 July 2013 - 10:51 AM

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 !


  • 0

#3 nguyendinhlinh_xd

nguyendinhlinh_xd

    Chưa sử dụng CAD

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

Đã gửi 23 July 2013 - 07:02 PM

cảm ơn ý kiến của anh.


  • 0