田草博客

互联网田草博客


网友交流QQ群:11740834 需注明申请加入原因

微信 公众号:ByCAD

邮箱:tiancao1001x126.com
ByCAD,微信公众号
首页 | 普通 | 电脑 | AutoCAD | VB/VB.NET | FLash | 结构 | 建筑 | 电影 | BIM | 规范 | 软件 | ID
-随机-|-分布-
-博客论坛-|-﨣﨤﨧﨨-
-网站导航-|-规范下载-
-BelovedFLash欣赏-

用户登陆
用户:
密码:
 

站点日历
73 2024 - 3 48
     12
3456789
10111213141516
17181920212223
24252627282930
31


站点统计

最新评论



plt 打印问题 AutoCAD vba 合并文字
未知 PKPM 转到CAD中的字体修改   [ 日期:2007-05-16 ]   [ 来自:本站原创 ]  HTML
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 编辑]


引用这个评论 田草 于 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

发表评论 - 不要忘了输入验证码哦!
作者: 用户:  密码:   注册? 验证:  防止恶意留言请输入问题答案:3*3=?  
评论:

禁止表情
禁止UBB
禁止图片
识别链接
识别关键字

字体样式 文字大小 文字颜色
插入粗体文本 插入斜体文本 插入下划线
左对齐 居中对齐 右对齐
插入超级链接 插入邮件地址 插入图像
插入 Flash 插入代码 插入引用
插入列表 插入音频文件 插入视频文件
插入缩进符合
点击下载按钮 下标 上标
水平线 简介分割标记
表  情
 
Tiancao Blog All Rights Reserved 田草博客 版权所有
Copyright ©