田草博客
日志搜索


 标题   内容 评论


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

微信 公众号:ByCAD

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

用户登陆
用户:
密码:
 

站点日历
73 2018 - 12 48
      1
2345678
9101112131415
16171819202122
23242526272829
3031


站点统计

最新评论



vb编写的图片浏览器可以自动缩放 数码照片批处理程序(VB2005)
未知 CAD VBA 文字下划线   [ 日期:2007-01-21 ]   [ 来自:本站原创 ]  HTML


CAD VBA 文字下划线 

'**********************************************************************************************
'文字双下划线************************************************************************************
'   调 BuildFilter
Sub Text_SXHX()

    Dim M1  As Variant, M2  As Variant, M3(0 To 2) As Double
    Dim A As Double
    Dim SelectedObj As AcadSelectionSet
    
    On Error Resume Next
    
    Set SelectedObj = CreateSelectionSet("xxx")
    Dim FType, FData
    
    BuildFilter FType, FData, 0, "text"

    SelectedObj.SelectOnScreen FType, FData

    ActiveDocument.Utility.Prompt "共选择文本:" & SelectedObj.Count & "个" & vbCrLf
    
    For i = 0 To SelectedObj.Count - 1
        
        Dim TEXT As AcadText
        Set TEXT = SelectedObj.item(i)
        A = TEXT.Rotation                                                   '现获得文字角度
        TEXT.Rotate TEXT.insertionPoint, -A                          '将文字旋转到水平方向
        
        TEXT.GetBoundingBox M1, M2                                  '得到文字两角点的坐标
        
        M3(0) = M2(0): M3(1) = M1(1): M3(2) = 0                 '计算矩形右下角点坐标
        
        TEXT.Rotate M1, A                                                  '将文字转回原位
        Dim L1 As AcadLine, L2 As AcadLine                           '文字双下划线
        
        Dim H As Double
        H = TEXT.height                                                     '返回文字高度,下划线间距参照此值
        M1(1) = M1(1) - 0.05 * H                                         '第一道下划线距文字最下端0.05H
        M3(1) = M1(1)

        Set L1 = ThisDrawing.ModelSpace.AddLine(M1, M3)      '水平方向的下划线
        L1.Rotate M1, A                                                       '将单下划线旋转到文字下方。
        L1.color = acGreen
        L1.Lineweight = acLnWt050                                      '第一道线宽为0.5mm
        
        M1(1) = M1(1) - 0.15 * H                                          '第二道线和第一道线间距0.15H
        M3(1) = M1(1)

        Set L2 = ThisDrawing.ModelSpace.AddLine(M1, M3)
        L2.Rotate M1, A                                                      '将下划线旋转到文字下方。
        L2.color = acGreen
   
    Next i
    SelectedObj.Delete
End Sub

'***********************************************************************************************
'选择集过滤器************************************************************************************
'       这个过滤器也是引用别人的,说实话我也没有看懂。
Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes())
    '用数组方式填充一对变量以用作为选择集过滤器使用
    Dim FType() As Integer, FData()
    Dim Index As Long, i As Long

    Index = LBound(gCodes) - 1

    For i = LBound(gCodes) To UBound(gCodes) Step 2
        Index = Index + 1
        ReDim Preserve FType(0 To Index) '改变数组上线,用可选参数preserve保持原数组不变。
        ReDim Preserve FData(0 To Index)
        FType(Index) = CInt(gCodes(i))
        FData(Index) = gCodes(i + 1)
    Next
    typeArray = FType: dataArray = FData
    
End Sub




[本日志由 田草 于 2007-01-21 05:01 PM 编辑]


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

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

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