| tiancao1001 于 2008-11-17 11:55 AM 发表评论： |
Function TC(e As AcadEntity)
On Error Resume Next
'填充面域
Dim TC_Entity(0 To 0) As AcadEntity
Dim TC1 As AcadHatch
Dim TC_Name As String
Dim TC_Type As Long
Dim TC_Associativity As Boolean
TC_Name = "SOLID"
TC_Type = 0
TC_Associativity = True
Set TC1 = ThisDrawing.ModelSpace.AddHatch(TC_Type, TC_Name, TC_Associativity)
Set TC_Entity(0) = e
TC1.AppendInnerLoop (TC_Entity)
TC1.Evaluate
'ThisDrawing.SetVariable "HPDRAWORDER", 1
End Function |
|
| 查看所评论的日志：将Solid实体转换成图案填充 |
| tiancao1001 于 2008-11-14 01:23 PM 发表评论： |
|
| 查看所评论的日志：解决笔记本没有数字键盘的软件办法 |
| tiancao1001 于 2008-11-07 04:14 PM 发表评论： |
彻底隐藏文件：
REG DELETE "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\SHOWALL" /v CheckedValue /f
REG ADD "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\SHOWALL" /v CheckedValue /t REG_SZ /d 1 /f
|
|
| 查看所评论的日志：“显示所有文件和文件夹” 和 “不显示隐藏的文件和文件夹” |
| 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 发表评论： |
|
| 查看所评论的日志：田草日志 |
| tiancao1001 于 2008-10-31 02:47 PM 发表评论： |
|
| 查看所评论的日志：田草日志 |
[26] [27] [28] [29] [30] [31] [32] [33] [34] [35] ... [37] 
