田草博客

互联网田草博客


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

微信 公众号:ByCAD

邮箱:tiancao1001x126.com
ByCAD,微信公众号
首页 | 普通 | 电脑 | AutoCAD | VB/VB.NET | FLash | 结构 | 建筑 | 电影 | BIM | 规范 | 软件 | ID

评论列表

tiancao1001
所发表的评论
[26] [27] [28] [29] [30] [31] [32] [33] [34] [35]  ... [37]  
tiancao1001 于 2008-11-05 11:09 AM 发表评论:
上面的程序有个小问题,遇到直线的起点设终点是同一点就麻烦了,直线是可以重合的而样条曲线是不可以的。
因此要吧终点加上那么一点点,
'直线转化为样条曲线
Sub LineToSPline()
    Dim E  As AcadEntity
    Dim L  As AcadLine
    Dim StartTan(0 To 2) As Double '指定样条曲线的起点切向。
    Dim FitPoints(0 To 8) As Double '指定样条曲线的所有拟合点?
    Dim CenterP As Variant '直线中点
    Dim a(0 To 2) As Double '拟合样条曲线的端点和终点的方向
    Dim n As Long
    Dim i As Long
    Dim Sp As AcadSpline
    n = ThisDrawing.ModelSpace.Count
    For Each E In ThisDrawing.ModelSpace
        i = i + 1
        ThisDrawing.Utility.Prompt Int(i / n * 100) & "%" & vbCrLf
        DoEvents
        'ThisDrawing.Utility.Prompt L.ObjectName
        'If e.ObjectName = "AcDbLine" Then
        If TypeOf E Is AcadLine Then
            Set L = E
            
            CenterP = centerPoint(L.StartPoint, L.EndPoint)
            
            a(0) = L.StartPoint(0) - L.EndPoint(0)
            a(1) = L.StartPoint(1) - L.EndPoint(1)
            a(2) = L.StartPoint(1) - L.EndPoint(1)
            
            FitPoints(0) = L.StartPoint(0):     FitPoints(1) = L.StartPoint(1):     FitPoints(2) = L.StartPoint(2)
            FitPoints(3) = CenterP(0):          FitPoints(4) = CenterP(1):          FitPoints(5) = CenterP(2)
            FitPoints(6) = L.EndPoint(0) + 0.001:   FitPoints(7) = L.EndPoint(1) + 0.001:   FitPoints(8) = L.EndPoint(2)
            
            StartTan(0) = -a(0):      StartTan(1) = -a(1):      StartTan(2) = -a(2)
            
            Set Sp = ThisDrawing.ModelSpace.AddSpline(FitPoints, StartTan, StartTan)
            Sp.Layer = L.Layer
            Sp.color = L.color
            L.Delete
        End If
    Next E
End Sub
查看所评论的日志:VBA将所有的直线转换成样条曲线
tiancao1001 于 2008-11-03 09:18 PM 发表评论:
还原天正轴线字体

Sub HYTZZT()
    Dim T As AcadTextStyle
    Set T = ThisDrawing.TextStyles("_TCH_AXIS")
    T.fontFile = "complex.shx"
    T.BigFontFile = "gbcbig.shx"
    ThisDrawing.Regen acAllViewports
End Sub
查看所评论的日志:CAD VBA 统一标注样式中的字体
tiancao1001 于 2008-11-03 09:53 AM 发表评论:
国家和房地产是一伙的,黑着呢。
查看所评论的日志:阳台建筑面?
tiancao1001 于 2008-11-01 02:46 PM 发表评论:
网友交流QQ群:11740834 
查看所评论的日志:田草日志
tiancao1001 于 2008-10-31 02:47 PM 发表评论:
实现Flash中一次随机打开15个连接:
http://tiancao.net/qita/webwithinflash2/1.html
查看所评论的日志:田草日志
tiancao1001 于 2008-10-28 10:47 PM 发表评论:
来自晓东CAD的一个方法
也许并不是一个Bug,而是我们没发现罢了

代码:

Sub Example_PickfirstSelectionSet()
    ' This example lists all the objects in the pickfirst selection set.
    ' Before running this example, create some objects in the active
    ' drawing and select those objects. The objects currently selected
    ' in the active drawing will be returned in the pickfirst selection set.
            
    Dim pfSS As AcadSelectionSet
    Dim ssobject As AcadEntity
    Dim msg As String
    msg = vbCrLf
    
    Set pfSS = ThisDrawing.PickfirstSelectionSet
    For Each ssobject In pfSS
        msg = msg & vbCrLf & ssobject.ObjectName
    Next ssobject
    MsgBox "The Pickfirst selection set contains: " & msg
    
End Sub


以上的例子在IDE窗口中运行没问题
调用-vbarun命令运行时不能正确运行
可以用下列方法j解决
定义Lisp函数:

代码:

(defun tls-sub2cmd(filename subname cmdname)
 (eval
  (list 'defun
   (read (strcat "c:" cmdname))
   nil
   '(if (cadr(ssgetfirst)) (sssetfirst nil (ssget)))
   (list 'vla-RunMacro
         '(vlax-get-acad-object)
          (strcat filename "!" subname)
   )
   '(sssetfirst nil nil)
   '(princ)
  )
 )
 (vlax-add-cmd cmdname (strcat "C:" cmdname))
 (princ)
)


调用格式为:
(tls-sub2cmd "文件名" "宏名" "命令名") 
查看所评论的日志:CAD VBA 先选择后操作 PickfirstSelectionSet
tiancao1001 于 2008-10-13 02:55 PM 发表评论:
隐藏日志的评论
查看所评论的日志:CAD VBA 也能画出这样的样条曲线
tiancao1001 于 2008-10-10 05:58 PM 发表评论:
珊瑚虫论坛开放,但是要邀请注册:http://bbs.coralqq.com/
查看所评论的日志:田草日志
[26] [27] [28] [29] [30] [31] [32] [33] [34] [35]  ... [37]  
Tiancao Blog All Rights Reserved 田草博客 版权所有
Copyright ©