《CAD二次开发的一点体会》贴几个之前用的简单代码 [复制链接]

上一主题下一主题查看指定楼层

离线小瘦子工程师

助理工程师

发帖: 116

土币: 2150

威望: 31

原创币: 0

只看楼主倒序阅读使用道具楼主发表于: 2012-04-02

今天发现去年发的那个帖子《CAD二次开发的一点体会》http://www.yantubbs.com/read.php?tid=127972居然这两天好多网友点击，当时没火现在火了，真是很欣慰又惊奇。看到有网友建议贴几个例子，回去翻了一下电脑确实有很少自己做的小工具，不过因为是临时做的用完也没管，所以程序都没什么注释，变量命名图方便。现在挑几个典型的贴出来算是对新手学习想放弃时的鼓励，这几个小例子中你会发现原来这么简单的几句话这么多用途。
1、替换选中集合中的字符串

这个是之前做高速公路的勘察，中间区域很长一段的桩号要改，用CAD自带的编辑-替换不够灵活容易全局都替换了，就写了这个小东西。点击按钮，去CAD界面选中要替换的那些文字，点击回车或右键，选中部分就全部替换，比如“左线”替换成“右线”。
主要的功能代码就一个过程：

Dim APP As AcadApplication
Dim SSet As AcadSelection Set
Private Sub cmd替换_Click()
On Error Resume Next
Set APP = GetObject(, "AutoCAD.Application")
Me.Hide
APP.WindowState = acMin
APP.WindowState = acMax
APP.ActiveDocument.Activate
Dim a As AcadEntity
Dim o, n As String
o = Text1.Text
n = Text2.Text
If Not IsNull(APP.ActiveDocument.Selection Sets.Item("Example")) Then
APP.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 SSet
If TypeOf a Is AcadText or AcadMText Then
a.TextString = Replace(a.TextString, o, n)
End If
Next

  SSet.Delete
Me.Show
MsgBox "OK搞定", , "提示"
APP.ActiveDocument.Activate
End Sub
代码很短很简单吧

2、柱状图辅助工具

这是上次做竖井的时候编的工具，因为当时的那个项目就一个深孔，手头上也没有现成的辅助软件，包括水位曲线、采取率曲线等五条曲线几千个数据，要是自己手画估计几天都完不成，还不一定准确，就写了这个东西。最后的效果还是蛮好，如下：
全部内容，较多看不清楚，但能发现确实很多数据。
另外也能独立使用《按坐标写文字》的功能，这在很多不同类型图纸中都用的到。

局部放大后：

这个工具能实现按照数据区内容，按照预定深度和相关值，添加层位信息，岩性描述，绘制采取率、水位、RQD、块度、裂隙率等曲线。虽然不是很规范，但达到生产实际要求了。另外通过加上之前写的一个填充函数，就可以自动填充岩心花纹了。
主要的代码为：
添加OWC控件、AutoCAD 2004\2006\2008中某一个的引用，里面那个按钮是XPCMD风格控件（百度就有）。里面变量命名多为中文拼音首字母，SP=Starpoint，EP=EndPoint等缩写，有兴趣的人看了差不多就懂。

Dim AutoCADapp As AutoCAD.AcadApplication
Dim AutoCADdoc As AutoCAD.AcadDocument
Dim AutoCADspace As AutoCAD.AcadModelSpace
Dim Acadly As AcadLayer
Dim Sp0 As Variant
Dim Ep0 As Variant
Dim SP(0 To 2) As Double
Dim EP(0 To 2) As Double

Dim SpMS(0 To 2) As Double
Dim EpMS(0 To 2) As Double
Dim Spx As Double
Dim Spy As Double

Dim Bili As Double
Dim PreSp(0 To 2) As Double
Dim PreEp(0 To 2) As Double
Dim Miaoshu As String
Dim Cisu As Integer
Dim Mtxt As AcadMText
Dim Stxt As AcadText
Dim aCadline As aCadline
Dim Msxd As Double
Dim Shujuliang As Integer
Dim Cqlkd As Double
Dim Cqlmax As Double
Dim Lxlkd As Double
Dim Lxlmax As Double
Dim Kdkd As Double
Dim Kdmax As Double
Dim Swkd As Double
Dim Swmax As Double
Dim Rqdkd As Double
Dim Rqdmax As Double

Private Sub CADDraw_Click()
On Error GoTo errhandle

Bili = Val(txtbili.Text)
Dim Qidian As Variant
Dim Zhongdian As Variant

SP(0) = Val(txtx.Text)
SP(1) = Val(txty.Text)
SP(2) = 0
EP(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 Double
Dim Changdu As Double
Dim Hanggao As Double
Dim hd As Double

Dim i As Integer
For i = 1 To Cisu
Miaoshu = sht1.Sheets(1).Cells(i, 2).Value + ":" + sht1.Sheets(1).Cells(i, 3).Value
PreSp(0) = 68
PreSp(1) = SP(1) - 3

SP(0) = 0
SP(1) = -Val(sht1.Cells(i, 1).Value) * 1000 / Bili
EP(1) = -Val(sht1.Cells(i, 1).Value) * 1000 / Bili
Set Cadline = AutoCADspace.AddLine(SP, EP) '添加左边的线
Cadline.Layer = "分割线"

SP(0) = 152: EP(0) = 277
Set 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) = 14
Set Stxt = AutoCADspace.AddText(Format(sht1.Cells(i, 1).Value, "##.00"), SP, 2)
Stxt.Layer = "数据内容"

SP(0) = 24
If i = 1 Then
hd = Val(sht1.Cells(i, 1).Value)
Else
hd = Val(sht1.Cells(i, 1).Value) - Val(sht1.Cells(i - 1, 1).Value)
End If
Set 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) = 152
Set 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 = i
Me.Refresh
Next
Me.Show
Exit Sub
errhandle:
MsgBox Err.Description
End Sub

‘*****************此处省略很多类似下面的函数，只是改了参数而已，仅供示例
‘*****************此处省略很多类似下面的函数，只是改了参数而已，仅供示例
Private Sub DrawRQD_Click()

Dim RQD As Double '采取率
Dim Ccount As Integer ' 循环控制次数
Dim i As Integer
SP(0) = Spx + 200: SP(1) = Spy: SP(2) = 0: EP(0) = Spx + 500: EP(1) = Spy: EP(2) = 0
Ccount = Val(txtcisu.Text)
Bili = Val(txtbili.Text)

For i = 2 To Ccount
RQD = Val(sht1.Cells(i, 5).Value) * Rqdkd / 100
SP(0) = 500 + RQD: SP(1) = Spy - Val(sht1.Cells(i - 1, 1).Value) * 1000 / Bili
Set aCadline = AutoCADspace.AddLine(EP, SP)
aCadline.Layer = "RQD"
EP(0) = SP(0): EP(1) = Spy - Val(sht1.Cells(i, 1).Value) * 1000 / Bili
Set aCadline = AutoCADspace.AddLine(SP, EP)
aCadline.Layer = "RQD"
zt.Caption = i
Me.Refresh
Next

End Sub

Private Sub DrawSW_Click()
确认参数_Click
Dim Sd As Double
Dim SW As Double '

Dim Ccount As Integer ' 循环控制次数
Ccount = Shujuliang
SP(0) = 0
SP(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 + 1
Sd = -Val(sht1.Cells(i, 1).Value)
SW = Val(sht1.Cells(i, 8).Value)
EP(0) = SW: EP(1) = Sd
Set aCadline = AutoCADspace.AddLine(SP, EP)
aCadline.Layer = "简易水文观测"

SP(0) = EP(0): SP(1) = EP(1)
zt.Caption = i
Me.Refresh

Next
End Sub

Private Sub Form_Resize()
On Error Resume Next
Frame2.Top = Form1.Height - Frame2.Height - 550
sht1.Height = Form1.Height - Frame2.Height - 800
sht1.Width = Form1.Width - 3000
End Sub

Private Sub GetCAD_Click()

On Error Resume Next
Set AutoCADapp = GetObject(, "AutoCAD.Application")
If Err Then
zt.Caption = "CAD没打开，打开中。。。"
Set AutoCADapp = New AcadApplication
AutoCADapp.Documents.Add
End If
AutoCADapp.Visible = True
AutoCADapp.WindowState = acMax
zt.Caption = "获取CAD成功"
Set AutoCADdoc = AutoCADapp.ActiveDocument
Set AutoCADspace = AutoCADdoc.ModelSpace
Set 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 Next
Set ExlcelApp = GetObject(, "Excel.Application")
If Err Then
MsgBox Err.Description
Set ExcelApp = New Excel.Application
End If
ExcelApp.Visible = True
ExcelApp.WindowState = xlMaximized
End Sub

Private Sub sht1_LostFocus()
Dim i As Integer
i = 2
Do
If sht1.Cells(i, 1).Value <> "" Then
i = i + 1
Else
Exit Do
End If

Loop
Shujuliang = i - 2
txtcisu.Text = Shujuliang
End 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()
TIANJIAMIAOSHU
End Sub

Private Sub Form_Load()
On Error Resume Next
Me.Show
If Err Then
MsgBox Err.Description
MsgBox "程序载入失败，如果提示某某组件未注册，就将目录下的三个.dll文件复制到C:/windows/system32下面"
End If
GetCAD_Click

End Sub

Function TIANJIAMIAOSHU()
Dim SP As Variant
Dim EP As Variant

Set AutoCADdoc = AutoCADapp.ActiveDocument
Set AutoCADspace = AutoCADdoc.ModelSpace
AutoCADapp.WindowState = acMax
AutoCADdoc.SendCommand "zoom_a "

SP = AutoCADdoc.Utility.GetPoint(, "点击直线起点")
EP = AutoCADdoc.Utility.GetPoint(, "点击直线终点")
Dim i As Integer

For i = 1 To Cisu
Miaoshu = sht1.Sheets(1).Cells(i, 2).Value + ":" + sht1.Sheets(1).Cells(i, 3).Value
PreSp(0) = SP(0) + 3
PreEp(0) = EP(0) - 3
PreSp(1) = SP(1) - Val(sht1.Cells(i, 1).Value) * 1000 / Bili - 2
PreEp(1) = EP(1) - Val(sht1.Cells(i, 1).Value) * 1000 / Bili - 2
Set Mtxt = AutoCADspace.AddMText(PreSp, 30, Miaoshu)
Mtxt.Height = 2.5
Mtxt.Width = 84
Mtxt.Layer = "a"
Next
End 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"

确认参数_Click
Dim txt As AcadText
Dim i As Integer
Dim wenzi As String
For i = 2 To Shujuliang
SP(0) = Val(sht1.Cells(i, 9).Value)
SP(1) = -Val(sht1.Cells(i, 10).Value)
wenzi = sht1.Cells(i, 11).Value
AutoCADspace.AddText wenzi, SP, 2.5
zt.Caption = i
Me.Refresh
Next
End 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 Sub
OK今天写弄到这吧，时间有限，以后有空慢慢完成此帖，自认为还是有一点参考意义的，看到了功能才能激起新人的热情，我当年就是看到别人做的很NB就自己吓琢磨，现在工作中遇到的有些需要编程的问题也算是能信手拈来，熟能生巧吧

共1条评分，土币+51

geofem

土币 +51

优秀文章，支持！

2012-04-13

分享到 淘江湖新浪 QQ微博 QQ空间开心人人豆瓣网易微博百度鲜果白社会飞信

发帖回复

返回列表


	https://bbs.yantuchina.com 访问内容超出本站范围，不能确定是否安全


	关闭选中1篇全选