PKPM 转到CAD中的字体修改

又是关于CAD字体的问题，最麻烦了，这方面的问题最多。

PKPM中的文字到CAD中不能更改高度后字体的宽度不会改变，而宽高的比例变大了，字体好像是被压扁了是的。

原因就是字体的对齐属性是调整。

我们把这个属性改成其他属性，就可以了。（不知道为什么手动调她就会变方向）

下面是我写的一个批量修改CAD字体宽度比例的 VBA 程序。

'PKPM字体调整
Sub PKPM_Text()

    Dim objSelected As Object
    Dim strPrompt As String
    Dim acText As AcadText
    Dim ssText As AcadSelectionSet
    On Error Resume Next

    Set ssText = ThisDrawing.SelectionSets.Add("Text")

    '定义过滤机制
    Dim filterType(0) As Integer
    Dim filterData(0) As Variant
    filterType(0) = 0
    filterData(0) = "TEXT"

    ssText.SelectOnScreen filterType, filterData

    '对选择集中的文字对象进行操作
    For Each objSelected In ssText
        If TypeOf objSelected Is AcadText Then
            Set acText = objSelected

            acText.Alignment = acAlignmentLeft
            acText.ScaleFactor = 0.7

        Else
            '删除选择集
            ThisDrawing.SelectionSets.item("Text").Delete
        End If
    Next

    ThisDrawing.SelectionSets.item("Text").Delete
    ThisDrawing.Application.Update

    Exit Sub

ErrControl:
    MsgBox Err.Description
End Sub

值得注意的就是在更改文字样式的时候宽度比例对应的是 width，而在调整单个文字的时候宽度比例对应的确实scalefactor.

[本日志由田草于 2008-01-08 03:58 PM 编辑]

分享到： QQ空间新浪微博腾讯微博微信更多

田草于 2008-01-08 03:59 PM 发表评论：

程序修改后可保持文字中心位置不变

'PKPM字体调整
Sub PKPM_Text1()

    Dim objSelected As Object
    Dim strPrompt As String
    Dim acText As AcadText
    Dim ssText As AcadSelectionSet

    Dim Pmax As Variant
    Dim Pmin As Variant
    Dim PCenter As Variant
    On Error Resume Next

    Set ssText = ThisDrawing.SelectionSets.Add("Text")

    '定义过滤机制
    Dim filterType(0) As Integer
    Dim filterData(0) As Variant
    filterType(0) = 0
    filterData(0) = "TEXT"

    ssText.SelectOnScreen filterType, filterData

    '对选择集中的文字对象进行操作
    For Each objSelected In ssText
        If TypeOf objSelected Is AcadText Then
            Set acText = objSelected
            acText.GetBoundingBox Pmin, Pmax
            PCenter = CenterPoint(Pmin, Pmax)

            acText.Alignment = acAlignmentMiddleCenter
            acText.Move acText.TextAlignmentPoint, PCenter
            acText.ScaleFactor = 0.7

        Else
            '删除选择集
            ThisDrawing.SelectionSets.item("Text").Delete
        End If
    Next

    ThisDrawing.SelectionSets.item("Text").Delete
    ThisDrawing.Application.Update

    Exit Sub

ErrControl:
    MsgBox Err.Description
End Sub

发表评论 - 不要忘了输入验证码哦！

作者：

用户：密码：注册？验证：