vba怎么实现修改指定图层的线宽和文字高度

a280881620 · 发表于 2013-6-16 21:40:49

我想用vba遍历我的当前文件的所有层，然后对指定的层进行线宽和文字高度的设置怎么实现，我的代码如下，但无法达到功能，求高手指点。
Sub zongtu()
On Error Resume Next
Dim I As Integer
Dim msg As String
msg = ""
Dim a As Double
a = ThisDrawing.Layers.Count - 1
For I = 0 To a
If ThisDrawing.Layers.Item(I).Name = "DLSS" Then
msg = ThisDrawing.Layers.Item(I).Name
ThisDrawing.Layers(I).Lineweight = 0

Next
'遍历图层，对dlss层的线宽设置为0，文字高度设置为1.25
End Sub

yshf · 发表于 2013-6-17 19:06:39

本帖最后由 yshf 于 2013-6-17 22:01 编辑

试试这个

Sub zongtu()
On Error Resume Next
Dim LayObj As AcadLayer
For Each LayObj In ThisDrawing.Layers
If LayObj.Name = "DLSS" Then
LayObj.Lineweight = 0
End If
Next
Dim Ssd As AcadSelectionSet
Dim FType(0 To 4) As Integer
Dim FData(0 To 4) As Variant
Dim TeObj As Object
FType(0) = -4
FType(1) = 0
FType(2) = 0
FType(3) = -4
FType(4) = 8
FData(0) = "<or"
FData(1) = "text"
FData(2) = "mtext"
FData(3) = "or>"
FData(4) = "DLSS"
ThisDrawing.SelectionSets("Ssd").Delete
'创建选择集(选择图层为DLSS,图元实体为文字的选择集)
Set Ssd = ThisDrawing.SelectionSets.Add("Ssd")
Ssd.Select acSelectionSetAll, , , FType, FData
For Each TeObj In Ssd
TeObj.Height = 1.25
Next
End Sub

Sub zongtu() 
    On Error Resume Next 
    
    Dim LayObj As AcadLayer 
    For Each LayObj In ThisDrawing.Layers 
        If LayObj.Name = "DLSS" Then 
           LayObj.Lineweight = 0 
        End If 
    Next 
    
    Dim Ssd As AcadSelectionSet 
    Dim FType(0 To 4) As Integer 
    Dim FData(0 To 4) As Variant 
    Dim TeObj As Object 
    
    FType(0) = -4 
    FType(1) = 0 
    FType(2) = 0 
    FType(3) = -4 
    FType(4) = 8 
    
    FData(0) = "<or" 
    FData(1) = "text" 
    FData(2) = "mtext" 
    FData(3) = "or>" 
    FData(4) = "DLSS" 
    
    ThisDrawing.SelectionSets("Ssd").Delete 
    
    '创建选择集(选择图层为DLSS,图元实体为文字的选择集) 
    Set Ssd = ThisDrawing.SelectionSets.Add("Ssd") 
    Ssd.Select acSelectionSetAll, , , FType, FData 
    For Each TeObj In Ssd 
        TeObj.Height = 1.25 
    Next 
    
End Sub

yshf · 发表于 2013-6-17 21:51:48

相应的lisp

(defun c:cc()
(setq tcm "DLSS"
Tcobj (vlax-ename->vla-object (tblobjname "layer" tcm))
)
(vlax-put Tcobj "Lineweight" 0)
(if (setq Ssd (ssget "x" (list '(0 . "*text") (cons 8 tcm))))
(progn
(setq n (sslength Ssd) i 0)
(repeat n
(setq dxf (entget (ssname Ssd i))
dxf (subst (cons 40 1.25) (assoc 40 dxf) dxf)
i (1+ i)
)
(entmod dxf)
)
)
)
(princ)
)

a280881620 · 发表于 2013-6-21 22:01:26

yshf 发表于 2013-6-17 21:51
相应的lisp

谢谢，认真学习了

俺就一粗人 · 发表于 2014-3-7 12:04:10

这个对于学lisp的人来说很有用啊

树櫴希德 · 发表于 2014-3-7 21:23:39

楼主大公无私

a280881620 · 发表于 2014-4-8 13:15:33

yshf 发表于 2013-6-17 21:51
相应的lisp

谢谢，你这个不错

a280881620 · 发表于 2014-4-8 13:17:49

yshf 发表于 2013-6-17 21:51
相应的lisp

你那里有关于lisp编程的书推荐没啊，我只会vba，想学lisp

yshf · 发表于 2014-4-8 20:19:43

1、《Auto LISP & DCL基础篇》吴永进林美樱编著
2、《Visual LISP程序设计——技巧与范例》陈伯雄冯伟编著

a280881620 · 发表于 2014-4-9 12:13:24

yshf 发表于 2013-6-17 19:06
试试这个

追问一下，你这个vba改线宽的，我想改dlss层的多段线的全局宽度为0怎么弄

账号		自动登录	找回密码
密码			注册

vba怎么实现修改指定图层的线宽和文字高度

相关帖子