-
UID:157795
-
- 注册时间2010-07-25
- 最后登录2018-06-22
- 在线时间59小时
-
- 发帖116
- 搜Ta的帖子
- 精华0
- 土币2150
- 威望31
- 原创币0
-
访问TA的空间加好友用道具
|
今天发现去年发的那个帖子《 CAD二次开发的一点体会》http://www.yantubbs.com/read.php?tid=127972居然这两天好多网友点击,当时没火现在火了,真是很欣慰又惊奇。看到有网友建议贴几个例子,回去翻了一下电脑确实有很少自己做的小工具,不过因为是临时做的用完也没管,所以程序都没什么注释,变量命名图方便。现在挑几个典型的贴出来算是对新手学习想放弃时的鼓励,这几个小例子中你会发现原来这么简单的几句话这么多用途。1、替换选中集合中的字符串 这个是之前做高速公路的勘察,中间区域很长一段的桩号要改,用CAD自带的编辑-替换不够灵活容易全局都替换了,就写了这个小东西。点击按钮,去CAD界面选中要替换的那些文字,点击回车或右键,选中部分就全部替换,比如“左线”替换成“右线”。主要的功能代码就一个过程: Dim APP As AcadApplicationDim SSet As AcadSelection SetPrivate Sub cmd替换_Click()On Error Resume NextSet APP = GetObject(, "AutoCAD.Application")Me.HideAPP.WindowState = acMinAPP.WindowState = acMaxAPP.ActiveDocument.ActivateDim a As AcadEntityDim o, n As Stringo = Text1.Textn = Text2.TextIf Not IsNull(APP.ActiveDocument.Selection Sets.Item("Example")) ThenAPP.ActiveDocument.Selection Sets.Item("Example").Delete '及时删除不用的选择集非常重要End If Dim SSet As AcadSelection Set 'Set SSet = ADO.Selection Sets.Add("Example")Set SSet = APP.ActiveDocument.Selection Sets.Add("Example")SSet.SelectOn Screen For Each a In SSetIf TypeOf a Is AcadText or AcadMText Thena.TextString = Replace(a.TextString, o, n)End IfNext SSet.DeleteMe.ShowMsgBox "OK搞定", , "提示"APP.ActiveDocument.ActivateEnd Sub代码很短很简单吧
2、柱状图辅助工具 这是上次做竖井的时候编的工具,因为当时的那个项目就一个深孔,手头上也没有现成的辅助软件,包括水位曲线、采取率曲线等五条曲线几千个数据,要是自己手画估计几天都完不成,还不一定准确,就写了这个东西。最后的效果还是蛮好,如下:全部内容,较多看不清楚,但能发现确实很多数据。另外也能独立使用《按坐标写文字》的功能,这在很多不同类型图纸中都用的到。局部放大后: 这个工具能实现按照数据区内容,按照预定深度和相关值,添加层位信息,岩性描述,绘制采取率、水位、RQD、块度、裂隙率等曲线。虽然不是很规范,但达到生产实际要求了。另外通过加上之前写的一个填充函数,就可以自动填充岩心花纹了。主要的代码为:添加OWC控件、AutoCAD 2004\2006\2008中某一个的引用,里面那个按钮是XPCMD风格控件(百度就有)。里面变量命名多为中文拼音首字母,SP=Starpoint,EP=EndPoint等缩写,有兴趣的人看了差不多就懂。 Dim AutoCADapp As AutoCAD.AcadApplicationDim AutoCADdoc As AutoCAD.AcadDocumentDim AutoCADspace As AutoCAD.AcadModelSpaceDim Acadly As AcadLayerDim Sp0 As VariantDim Ep0 As VariantDim SP(0 To 2) As DoubleDim EP(0 To 2) As Double Dim SpMS(0 To 2) As DoubleDim EpMS(0 To 2) As DoubleDim Spx As DoubleDim Spy As Double Dim Bili As DoubleDim PreSp(0 To 2) As DoubleDim PreEp(0 To 2) As DoubleDim Miaoshu As StringDim Cisu As IntegerDim Mtxt As AcadMTextDim Stxt As AcadTextDim aCadline As aCadlineDim Msxd As DoubleDim Shujuliang As IntegerDim Cqlkd As DoubleDim Cqlmax As DoubleDim Lxlkd As DoubleDim Lxlmax As DoubleDim Kdkd As DoubleDim Kdmax As DoubleDim Swkd As DoubleDim Swmax As DoubleDim Rqdkd As DoubleDim Rqdmax As Double
Private Sub CADDraw_Click()On Error GoTo errhandle Bili = Val(txtbili.Text)Dim Qidian As VariantDim Zhongdian As Variant SP(0) = Val(txtx.Text)SP(1) = Val(txty.Text)SP(2) = 0EP(0) = Val(txtex.Text)EP(1) = Val(txtey.Text)EP(2) = 0 Cisu = Val(txtcisu.Text)
'Me.Hide'AutoCADapp.WindowState = acMax'AutoCADdoc.SendCommand "zoom_a "'Sp0 = AutoCADdoc.Utility.GetPoint(, "点击直线起点")'Ep0 = AutoCADdoc.Utility.GetPoint(, "点击直线终点")'MsgBox Qidian(0)Dim Tmp As DoubleDim Changdu As DoubleDim Hanggao As DoubleDim hd As Double Dim i As IntegerFor i = 1 To CisuMiaoshu = sht1.Sheets(1).Cells(i, 2).Value + ":" + sht1.Sheets(1).Cells(i, 3).ValuePreSp(0) = 68PreSp(1) = SP(1) - 3 SP(0) = 0SP(1) = -Val(sht1.Cells(i, 1).Value) * 1000 / BiliEP(1) = -Val(sht1.Cells(i, 1).Value) * 1000 / BiliSet Cadline = AutoCADspace.AddLine(SP, EP) '添加左边的线Cadline.Layer = "分割线"
SP(0) = 152: EP(0) = 277Set Cadline = AutoCADspace.AddLine(SP, EP) '添加右边的线Cadline.Layer = "分割线"SP(0) = 0: EP(0) = Val(txtex.Text)
'If Msxd < PreSp(1) Then PreSp(1) = Msxd'Set Mtxt = AutoCADspace.AddMText(PreSp, 30, Miaoshu) '添加描述'Mtxt.Height = 2.5'Mtxt.Width = 83'Mtxt.Layer = "描述"
Set Stxt = AutoCADspace.AddText(Str(i), SP, 2)Stxt.Layer = "数据内容"SP(0) = 14Set Stxt = AutoCADspace.AddText(Format(sht1.Cells(i, 1).Value, "##.00"), SP, 2)Stxt.Layer = "数据内容"
SP(0) = 24If i = 1 Thenhd = Val(sht1.Cells(i, 1).Value)Elsehd = Val(sht1.Cells(i, 1).Value) - Val(sht1.Cells(i - 1, 1).Value)End IfSet Stxt = AutoCADspace.AddText(Format(Str(hd), "##.00"), SP, 2)Stxt.Layer = "数据内容"
SP(0) = 34 hd = 1210 - Val(sht1.Cells(i, 1).Value)Set Stxt = AutoCADspace.AddText(Format(Str(hd), "##.00"), SP, 2)Stxt.Layer = "数据内容"
SP(0) = 152Set Stxt = AutoCADspace.AddText(Format(sht1.Cells(i, 1).Value, "##.00"), SP, 2)Stxt.Layer = "数据内容" 'Changdu = LenB(StrConv(Miaoshu, vbFromUnicode)) / 2'Hanggao = Int(Changdu / 84) * 2.5'Msxd = Msxd - Hanggao 'SpMS(0) = 67: SpMS(1) = Sp(1)'EpMS(0) = 70: EpMS(1) = Msxd'Set Cadline = AutoCADspace.AddLine(Sp, Ep) '添加右边连接的线'Cadline.Layer = "a" 'SpMS(0) = 152: SpMS(1) = Sp(1)'EpMS(0) = 149: EpMS(1) = Msxd'Set Cadline = AutoCADspace.AddLine(Sp, Ep) '添加右边连接的线'Cadline.Layer = "a" 'SpMS(0) = 67: SpMS(1) = Msxd'EpMS(0) = 149: EpMS(1) = Msxd'Set Cadline = AutoCADspace.AddLine(Sp, Ep) '添加右边连接的线'Cadline.Layer = "a"
zt.Caption = iMe.RefreshNextMe.ShowExit Suberrhandle:MsgBox Err.DescriptionEnd Sub ‘*****************此处省略很多类似下面的函数,只是改了参数而已,仅供示例‘*****************此处省略很多类似下面的函数,只是改了参数而已,仅供示例Private Sub DrawRQD_Click() Dim RQD As Double '采取率Dim Ccount As Integer ' 循环控制次数Dim i As IntegerSP(0) = Spx + 200: SP(1) = Spy: SP(2) = 0: EP(0) = Spx + 500: EP(1) = Spy: EP(2) = 0Ccount = Val(txtcisu.Text)Bili = Val(txtbili.Text) For i = 2 To CcountRQD = Val(sht1.Cells(i, 5).Value) * Rqdkd / 100SP(0) = 500 + RQD: SP(1) = Spy - Val(sht1.Cells(i - 1, 1).Value) * 1000 / BiliSet aCadline = AutoCADspace.AddLine(EP, SP)aCadline.Layer = "RQD"EP(0) = SP(0): EP(1) = Spy - Val(sht1.Cells(i, 1).Value) * 1000 / BiliSet aCadline = AutoCADspace.AddLine(SP, EP)aCadline.Layer = "RQD"zt.Caption = iMe.RefreshNext End Sub Private Sub DrawSW_Click()确认参数_ClickDim Sd As DoubleDim SW As Double ' Dim Ccount As Integer ' 循环控制次数Ccount = ShujuliangSP(0) = 0SP(1) = 0
'Dim i As Integer'SP(0) = Spx + 200: SP(1) = Spy: SP(2) = 0: EP(0) = Spx + 600: EP(1) = Spy: EP(2) = 0'Ccount = Val(txtcisu.Text)'Bili = Val(txtbili.Text)
For i = 2 To Ccount + 1Sd = -Val(sht1.Cells(i, 1).Value)SW = Val(sht1.Cells(i, 8).Value)EP(0) = SW: EP(1) = SdSet aCadline = AutoCADspace.AddLine(SP, EP)aCadline.Layer = "简易水文观测"
SP(0) = EP(0): SP(1) = EP(1)zt.Caption = iMe.Refresh NextEnd Sub
Private Sub Form_Resize()On Error Resume NextFrame2.Top = Form1.Height - Frame2.Height - 550sht1.Height = Form1.Height - Frame2.Height - 800sht1.Width = Form1.Width - 3000End Sub Private Sub GetCAD_Click() On Error Resume NextSet AutoCADapp = GetObject(, "AutoCAD.Application")If Err Thenzt.Caption = "CAD没打开,打开中。。。"Set AutoCADapp = New AcadApplicationAutoCADapp.Documents.AddEnd IfAutoCADapp.Visible = TrueAutoCADapp.WindowState = acMaxzt.Caption = "获取CAD成功"Set AutoCADdoc = AutoCADapp.ActiveDocumentSet AutoCADspace = AutoCADdoc.ModelSpaceSet Acadly = AutoCADdoc.Layers.Add("分割线")Acadly.Color = acWhite Set Acadly = AutoCADdoc.Layers.Add("简易水文观测") Set Acadly = AutoCADdoc.Layers.Add("RQD")Acadly.Color = acRed AutoCADdoc.Layers.Add "数据内容" Set Acadly = AutoCADdoc.Layers.Add("采取率线")Acadly.Color = acBlue Set Acadly = AutoCADdoc.Layers.Add("裂隙率")Acadly.Color = acGreen
AutoCADdoc.Layers.Add "块度"'zt.Caption = "获取CAD"End Sub Private Sub GetExcel_Click()On Error Resume NextSet ExlcelApp = GetObject(, "Excel.Application")If Err ThenMsgBox Err.DescriptionSet ExcelApp = New Excel.ApplicationEnd IfExcelApp.Visible = TrueExcelApp.WindowState = xlMaximizedEnd Sub
Private Sub sht1_LostFocus()Dim i As Integeri = 2DoIf sht1.Cells(i, 1).Value <> "" Theni = i + 1ElseExit DoEnd If LoopShujuliang = i - 2txtcisu.Text = ShujuliangEnd Sub Private Sub sht1_SelectionChange()If sht1.ActiveCell.Row = 1 Then sht1.Cells(sht1.ActiveCell.Row + 1, sht1.ActiveCell.Column).Select End Sub
Private Sub xpcmdbutton1_Click()TIANJIAMIAOSHUEnd Sub Private Sub Form_Load()On Error Resume NextMe.ShowIf Err ThenMsgBox Err.DescriptionMsgBox "程序载入失败,如果提示某某组件未注册,就将目录下的三个.dll文件复制到C:/windows/system32下面"End IfGetCAD_Click End Sub
Function TIANJIAMIAOSHU()Dim SP As VariantDim EP As Variant
Set AutoCADdoc = AutoCADapp.ActiveDocumentSet AutoCADspace = AutoCADdoc.ModelSpaceAutoCADapp.WindowState = acMaxAutoCADdoc.SendCommand "zoom_a " SP = AutoCADdoc.Utility.GetPoint(, "点击直线起点")EP = AutoCADdoc.Utility.GetPoint(, "点击直线终点")Dim i As Integer For i = 1 To CisuMiaoshu = sht1.Sheets(1).Cells(i, 2).Value + ":" + sht1.Sheets(1).Cells(i, 3).ValuePreSp(0) = SP(0) + 3PreEp(0) = EP(0) - 3PreSp(1) = SP(1) - Val(sht1.Cells(i, 1).Value) * 1000 / Bili - 2PreEp(1) = EP(1) - Val(sht1.Cells(i, 1).Value) * 1000 / Bili - 2Set Mtxt = AutoCADspace.AddMText(PreSp, 30, Miaoshu)Mtxt.Height = 2.5Mtxt.Width = 84Mtxt.Layer = "a"NextEnd Function Private Sub xpcmdbutton2_Click()MsgBox "第一列数据为深度,第二列为统计值。默认竖向比例500。"End Sub Private Sub 获取CAD_Click() End Sub Private Sub 按照坐标写文字_Click()'Dim mytxt As AcadTextStyle'mytxt.Name = "数据字体Arial" 'mytxt.fontFile = "c:/windows/font/Arial.ttf"
确认参数_ClickDim txt As AcadTextDim i As IntegerDim wenzi As StringFor i = 2 To ShujuliangSP(0) = Val(sht1.Cells(i, 9).Value)SP(1) = -Val(sht1.Cells(i, 10).Value)wenzi = sht1.Cells(i, 11).ValueAutoCADspace.AddText wenzi, SP, 2.5zt.Caption = iMe.RefreshNextEnd Sub Private Sub 确认参数_Click()Bili = Val(txtbili.Text)Spx = Val(txtx.Text)Spy = Val(txty.Text) Cqlkd = Val(txtcql.Text) Lxlkd = Val(txtlxl.Text) Lxlmax = Val(txtlxlmax.Text) Kdkd = Val(txtkd.Text) Kdmax = Val(txtkdmax.Text) Swkd = Val(txtsw.Text) Swmax = Val(txtswmax.Text) Rqdkd = Val(txtrqd.Text)sht1_LostFocus End SubOK今天写弄到这吧,时间有限,以后有空慢慢完成此帖,自认为还是有一点参考意义的,看到了功能才能激起新人的热情,我当年就是看到别人做的很NB就自己吓琢磨,现在工作中遇到的有些需要编程的问题也算是能信手拈来,熟能生巧吧
|