tiancao1001 于 2008-07-17 09:03 PM 发表评论: |
Private Sub CommandButton2_Click() Dim i As Long Dim n As Integer Dim Pi As Double Pi = 4# * Atn(1#) Dim R As Long Randomize R = Int(Rnd * 100) Dim R1 As Long R1 = (0.5 - Rnd) * 199 Dim L As Long L = Int(Rnd * 200) Dim S As Long S = Int(Rnd * 50) Dim M As Long M = Int(Rnd * 100) Dim A1 As Double Dim A2 As Double Dim P(2) As Double Dim P0(2) As Double Dim x As Double Dim y As Double Dim Fit() As Double Dim Sp As AcadSpline ReDim Fit(2) i = i + 1 n = n + 1 A1 = i * Pi / 180 A2 = (R1 / R) * A1 x = (-(R1 - R) * Cos(A1) - S * Cos(A2 - A1) + 100) * M y = ((R1 - R) * Sin(A1) - S * Sin(A2 - A1) + 100) * M P0(0) = x: P0(1) = y Fit(0) = x: Fit(1) = y: Fit(2) = 0 'ThisDrawing.ModelSpace.AddPoint P0 Do DoEvents i = i + 1 n = n + 1 ReDim Preserve Fit(n * 3 - 1) A1 = i * Pi / 180 A2 = (R1 / R) * A1 x = (-(R1 - R) * Cos(A1) - S * Cos(A2 - A1) + 100) * M y = ((R1 - R) * Sin(A1) - S * Sin(A2 - A1) + 100) * M P(0) = x: P(1) = y Fit(n * 3 - 3) = x: Fit(n * 3 - 2) = y: Fit(n * 3 - 1) = 0 If n = 359 Then Set Sp = ThisDrawing.ModelSpace.AddSpline(Fit, Point3D(0, 0, 0), Point3D(0, 0, 0)) Randomize 'Sp.color = Int(Rnd * 255) n = 0 End If If Abs(P(0) - P0(0)) < 10 ^ -2 And Abs(P(1) - P0(1)) < 10 ^ -2 Then Exit Do 'If i > 10 ^ 4 Then Exit Do Loop MsgBox "R=" & R & "/ R1=" & R1 & "/ L=" & L Prompt "R=" & R & "/ R1=" & R1 & "/ L=" & L & "/ S=" & S & vbCrLf End End Sub |
|
查看所评论的日志:CAD VBA 也能画出这样的样条曲线spirograph万花尺螺旋曲线 |
tiancao1001 于 2008-07-16 02:58 PM 发表评论: |
Sub DeleteMenu() '读取有那些菜单 Dim i As Integer Dim i1 As Integer Dim i2 As Integer Dim index() As Long Dim DataString As String Set FSO = CreateObject("Scripting.FileSystemObject") Set FSO_File = FSO.OpenTextFile(GetPath & "menu.txt", ForReading, True) Do While Not FSO_File.AtEndOfStream DataString = FSO_File.ReadLine i = inStr_n(DataString, ",", index) If i = 0 Then i1 = Val(DataString) ElseIf i = 1 Then DataString = Left(DataString, Len(DataString) - 1) For Each TG In ThisDrawing.Application.MenuGroups For Each T In TG.Toolbars If T.Name = DataString Then T.Delete i2 = i2 + 1 If i2 = i1 Then Exit Do End If Next Next End If Loop FSO_File.Close End Sub |
|
查看所评论的日志:ACAD vba CreateMenu2.0 自动生成CAD工具栏 |
tiancao1001 于 2008-07-15 05:31 PM 发表评论: |
'样条曲线转化为直线(针对上面函数转化后的样条曲线) Sub SPlineToLine() Dim E As AcadEntity Dim L As AcadLine Dim SP As AcadSpline Dim StartP As Variant Dim EndP As Variant For Each E In ThisDrawing.ModelSpace 'DoEvents 'ThisDrawing.Utility.Prompt E.ObjectName If E.ObjectName = "AcDbSpline" Then Set SP = E StartP = SP.GetFitPoint(0) EndP = SP.GetFitPoint(2) Set L = ThisDrawing.ModelSpace.AddLine(StartP, EndP) L.Layer = SP.Layer L.color = SP.color SP.Delete End If Next E End Sub |
|
查看所评论的日志:VBA将所有的直线转换成样条曲线 |
tiancao1001 于 2008-07-11 11:38 PM 发表评论: |
Sub Delete_HyperLinks() On Error Resume Next Dim Hyperlinks As AcadHyperlinks Dim Hyperlink As AcadHyperlink Dim Obj As AcadEntity Dim i As Integer Dim j As Long For Each Obj In ThisDrawing.ModelSpace DoEvents Set Hyperlinks = Obj.Hyperlinks MsgBox Hyperlinks.Count i = Hyperlinks.Count For j = 0 To i - 1 Hyperlinks.item(j).Delete Next j Next
End Sub |
|
查看所评论的日志:CAD 对象加上超链接 |
tiancao1001 于 2008-07-04 09:27 PM 发表评论: |
|
查看所评论的日志:田草日志 |
tiancao1001 于 2008-06-26 09:34 PM 发表评论: |
直接修改主页的地址可以被很多软件检测到,可以直接修改windows快捷方式的参数, |
|
查看所评论的日志:田草日志 |
tiancao1001 于 2008-06-26 08:59 PM 发表评论: |
中望cad 2007 和2008i的破解方法是一样的,都是搜素16进制FFD7595950,找到后将50改为51保存退出.然后运行中望CAD,点击注册,随便填入数字,点击注册即可成功!!, |
|
查看所评论的日志:田草日志 |
tiancao1001 于 2008-06-22 08:35 PM 发表评论: |
修行功德圆满,要到到猴年马月,现在不靠坑蒙拐骗,生活的很难保证 |
|
查看所评论的日志:田草日志 |