AutoCAD VBA点抽稀程序

本文提及的程序acad.dvb可以在CSDN下载中心下载。

在AutoCAD中使用VBA开发只需在命令行输入“vbaide”即可打开自带的VBA编辑器。

打开VBAIDE后添加一个窗体，如图添加以下控件：

窗体控件对应代码：

Option ExplicitPrivate Declare PtrSafe Function ts_apiGetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (tsFN As tsFileName) As Boolean
Private Declare PtrSafe Function ts_apiGetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (tsFN As tsFileName) As Boolean
Private Declare PtrSafe Function CommDlgExtendedError Lib "comdlg32.dll" () As LongPrivate Type tsFileNamelStructSize As LonghwndOwner As LongPtrhInstance As LongPtrstrFilter As StringstrCustomFilter As StringnMaxCustFilter As LongnFilterIndex As LongstrFile As StringnMaxFile As LongstrFileTitle As StringnMaxFileTitle As LongstrInitialDir As StringstrTitle As Stringflags As LongnFileOffset As IntegernFileExtension As IntegerstrDefExt As StringlCustData As LonglpfnHook As LongPtrlpTemplateName As String
End Type' Flag Constants
Private Const tscFNAllowMultiSelect = &H200
Private Const tscFNCreatePrompt = &H2000
Private Const tscFNExplorer = &H80000
Private Const tscFNExtensionDifferent = &H400
Private Const tscFNFileMustExist = &H1000
Private Const tscFNPathMustExist = &H800
Private Const tscFNNoValidate = &H100
Private Const tscFNHelpButton = &H10
Private Const tscFNHideReadOnly = &H4
Private Const tscFNLongNames = &H200000
Private Const tscFNNoLongNames = &H40000
Private Const tscFNNoChangeDir = &H8
Private Const tscFNReadOnly = &H1
Private Const tscFNOverwritePrompt = &H2
Private Const tscFNShareAware = &H4000
Private Const tscFNNoReadOnlyReturn = &H8000
Private Const tscFNNoDereferenceLinks = &H100000Public Function tsGetFileFromUser( _Optional ByRef rlngflags As Long = 0&, _Optional ByVal strInitialDir As String = "", _Optional ByVal strFilter As String = "All Files (*.*)" & vbNullChar & "*.*", _Optional ByVal lngFilterIndex As Long = 1, _Optional ByVal strDefaultExt As String = "", _Optional ByVal strFileName As String = "", _Optional ByVal strDialogTitle As String = "", _Optional ByVal fOpenFile As Boolean = True) As Variant
'On Error GoTo tsGetFileFromUser_ErrDim tsFN As tsFileNameDim strFileTitle As StringDim fResult As Boolean' Allocate string space for the returned strings.strFileName = Left(strFileName & String(256, 0), 256)strFileTitle = String(256, 0)' Set up the data structure before you call the functionWith tsFN.lStructSize = LenB(tsFN)'.hwndOwner = Application.hWndAccessApp.strFilter = strFilter.nFilterIndex = lngFilterIndex.strFile = strFileName.nMaxFile = Len(strFileName).strFileTitle = strFileTitle.nMaxFileTitle = Len(strFileTitle).strTitle = strDialogTitle.flags = rlngflags.strDefExt = strDefaultExt.strInitialDir = strInitialDir.hInstance = 0.strCustomFilter = String(255, 0).nMaxCustFilter = 255.lpfnHook = 0End With' Call the function in the windows APIIf fOpenFile ThenfResult = ts_apiGetOpenFileName(tsFN)ElsefResult = ts_apiGetSaveFileName(tsFN)End IfIf fResult Thenrlngflags = tsFN.flagstsGetFileFromUser = tsTrimNull(tsFN.strFile)ElsetsGetFileFromUser = NullEnd IfEnd FunctionPrivate Function tsTrimNull(ByVal strItem As String) As String
On Error GoTo tsTrimNull_ErrDim I As IntegerI = InStr(strItem, vbNullChar)If I > 0 ThentsTrimNull = Left(strItem, I - 1)ElsetsTrimNull = strItemEnd IftsTrimNull_End:On Error GoTo 0Exit FunctiontsTrimNull_Err:BeepMsgBox Err.Description, , "Error: " & Err.Number _& " in function basBrowseFiles.tsTrimNull"Resume tsTrimNull_EndEnd FunctionPublic Sub tsGetFileFromUserTest()
On Error GoTo tsGetFileFromUserTest_ErrDim strFilter As StringDim lngFlags As LongDim varFileName As Variant'   strFilter = "Access (*.mdb)" & vbNullChar & "*.mdb" _
'    & vbNullChar & "All Files (*.*)" & vbNullChar & "*.*"strFilter = "All Files (*.*)" & vbNullChar & "*.*"lngFlags = tscFNPathMustExist Or tscFNFileMustExist Or tscFNHideReadOnlyvarFileName = tsGetFileFromUser( _fOpenFile:=True, _strFilter:=strFilter, _rlngflags:=lngFlags, _strDialogTitle:="GetFileFromUser Test (Please choose a file)")If IsNull(varFileName) ThenDebug.Print "User pressed 'Cancel'."ElseDebug.Print varFileName'Forms![Form1]![Text1] = varFileNameEnd IfIf varFileName <> "" Then MsgBox "You selected the '" & varFileName & "' file.", vbInformationtsGetFileFromUserTest_End:On Error GoTo 0Exit SubtsGetFileFromUserTest_Err:BeepMsgBox Err.Description, , "Error: " & Err.Number _& " in sub basBrowseFiles.tsGetFileFromUserTest"Resume tsGetFileFromUserTest_End
End SubFunction Distance(Sx As Double, Sy As Double, Ex As Double, Ey As Double, Precision As Integer) As Double
Dim DltX As Double, DltY As Double
DltX = Ex - Sx
DltY = Ey - Sy
Distance = Round(Sqr(DltX * DltX + DltY * DltY), Precision)
End FunctionPrivate Sub btn_Filter_Click()Dim filterDist As Single '抽稀距离Dim pNum() As Long, pSign() As String, pX() As Double, pY() As Double, pH() As DoubleDim Datums As Variant, startTime As String, endTime As StringDim RowIndex As Long, strr As StringDim rIndex As Long, rIndex2 As Long, xa As Double, ya As Double, xb As Double, yb As DoubleDim strFilter As StringDim lngFlags As LongDim varFileName As VariantDim totalPoints As Long, effPoints As Long, delPoints As Long '总点数，有效点数RowIndex = 1If IsNumeric(Trim(txt_FilterDist.Text)) ThenIf Trim(txt_FilterDist.Text) > 0 ThenfilterDist = Trim(txt_FilterDist.Text)ElsefilterDist = 2End IfElsefilterDist = 2End Iflbl_points = ""lbl_filtered = ""lbl_epoints = ""lbl_time = "用时：秒"
'   strFilter = "Access (*.mdb)" & vbNullChar & "*.mdb" _
'    & vbNullChar & "All Files (*.*)" & vbNullChar & "*.*"strFilter = "CASS格式数据(*.dat)" & vbNullChar & "*.dat"lngFlags = tscFNPathMustExist Or tscFNFileMustExist Or tscFNHideReadOnlyvarFileName = tsGetFileFromUser( _fOpenFile:=True, _strFilter:=strFilter, _rlngflags:=lngFlags, _strDialogTitle:="打开文件 中国电建两河口水电站 覃东")If varFileName <> "" ThenstartTime = Time() '运行计时器txt_DatFileName.Text = varFileNameOpen varFileName For Input As #1Do While Not EOF(1)Line Input #1, strrIf Trim(strr) <> "" ThenDatums = Split(strr, ",")If UBound(Datums) = 4 ThenReDim Preserve pNum(RowIndex)ReDim Preserve pSign(RowIndex)ReDim Preserve pX(RowIndex)ReDim Preserve pY(RowIndex)ReDim Preserve pH(RowIndex)pNum(RowIndex - 1) = RowIndexpSign(RowIndex - 1) = ""pX(RowIndex - 1) = Datums(2)pY(RowIndex - 1) = Datums(3)pH(RowIndex - 1) = Datums(4)End IfEnd IfRowIndex = RowIndex + 1If RowIndex Mod 1000 = 0 Thenlbl_points.Text = totalPointsfrm_CassDatFilter.RepaintEnd IfLoopClose #1totalPoints = RowIndex - 1lbl_points.Text = totalPointsfrm_CassDatFilter.Repaint'点抽稀rIndex = 1rIndex2 = rIndex + 1delPoints = 0lbl_time.Text = "—"lbl_time.TextAlign = fmTextAlignCenterDo While pNum(rIndex - 1) <> 0 'And rIndex <= UBound(pNum)If Trim(pSign(rIndex2 - 1)) = "" Thenxa = pX(rIndex - 1)ya = pY(rIndex - 1)rIndex2 = rIndex + 1Do While pNum(rIndex2 - 1) <> 0If (Abs(pX(rIndex2 - 1) - xa) < filterDist And Abs(pY(rIndex2 - 1) - ya) < filterDist) ThenIf Distance(xa, ya, pX(rIndex2 - 1), pY(rIndex2 - 1), 3) < filterDist And Trim(pSign(rIndex - 1)) = "" And Trim(pSign(rIndex2 - 1)) = "" ThenpSign(rIndex2 - 1) = "T"delPoints = delPoints + 1End IfEnd IfrIndex2 = rIndex2 + 1LoopEnd IfrIndex = rIndex + 1If rIndex Mod 200 = 0 Thenlbl_filtered.Text = totalPoints & "/" & delPointsfrm_CassDatFilter.RepaintIf lbl_time.Text = "—" Thenlbl_time.Text = "\"ElseIf lbl_time.Text = "\" Thenlbl_time.Text = "|"ElseIf lbl_time.Text = "|" Thenlbl_time.Text = "/"Elselbl_time.Text = "—"End IfEnd IfLooplbl_filtered.Text = totalPoints & "/" & delPointsfrm_CassDatFilter.Repaint'保存If Trim(varFileName) <> "" ThenrIndex = 1RowIndex = 1Open Left(varFileName, InStr(UCase(varFileName), ".DAT") - 1) & "-抽稀(" & filterDist & "m)-" & Replace(Format(Date, "yyyy-mm-dd"), "-", "") & "-" & Replace(Time, ":", "") & ".dat" For Output As #2Do While Trim(pNum(rIndex - 1)) <> 0If Trim(pSign(rIndex - 1)) = "" ThenPrint #2, RowIndex & ",," & Format(pX(rIndex - 1), "0.000") & "," & Format(pY(rIndex - 1), "0.000") & "," & Format(pH(rIndex - 1), "0.000")RowIndex = RowIndex + 1End IfrIndex = rIndex + 1If rIndex Mod 500 = 0 Thenlbl_epoints.Text = effPointsfrm_CassDatFilter.RepaintEnd IfLoopClose #2End IfeffPoints = RowIndex - 1lbl_epoints.Text = effPoints'清除数组ReDim pNum(1)ReDim pSign(1)ReDim pX(1)ReDim pY(1)ReDim pH(1)endTime = Time()lbl_time.TextAlign = fmTextAlignRightlbl_time.Text = "用时：" & (Minute(TimeValue(endTime)) - Minute(TimeValue(startTime))) * 60 + Second(TimeValue(endTime)) - Second(TimeValue(startTime)) & "秒"
End IfEnd Sub

如果需要添加菜单，则添加一个模块文件，拷入以下代码：

Public Sub vba_zzDcx()
frm_CassDatFilter.show
End SubSub CreateMenu()
'创建菜单组
Dim mnuGroup As AcadMenuGroup
Set mnuGroup = ThisDrawing.Application.MenuGroups.Item(0)'创建新菜单
Dim mnuQinDong As AcadPopupMenu
Set mnuQinDong = mnuGroup.Menus.Add("测量工具箱(&T)")'创建下拉菜单，执行自编的VBA程序点抽稀过滤vba_zzDCX
Dim mnuDCX As AcadPopupMenuItem
Dim macDCX As String
macDCX = Chr(3) & Chr(3) & Chr(95) & "-vbarun" & Chr(32) & "vba_zzDCX" & Chr(32)
Set mnuDCX = mnuQinDong.AddMenuItem(mnuQinDong.Count + 1, "地形点过滤(&G)", macDCX)'创建分隔线
Dim mnuSeparator As AcadPopupMenuItem
Set mnuSeparator = mnuQinDong.AddSeparator("")'创建下拉菜单，执行AutoCAD内部命令
'Dim mnuCopy As AcadPopupMenuItem
'Dim macCopy As String
'macCopy = Chr(3) & Chr(3) & Chr(95) & "copy" & Chr(32)
'Set mnuCopy = mnuQinDong.AddMenuItem(mnuQinDong.Count + 1, "&Copy", macCopy)'创建子菜单
'Dim mnuFather As AcadPopupMenu
'Set mnuFather = mnuQinDong.AddSubMenu(mnuQinDong.Count + 1, "父菜单")
'Dim mnuChild As AcadPopupMenuItem
'Dim macChild As String
'macChild = Chr(3) & Chr(3) & Chr(95) & "export" & Chr(32)
'Set mnuChild = mnuFather.AddMenuItem(mnuQinDong.Count + 1, "子菜单-导出其它格式", macChild)'在菜单条上显示菜单
mnuQinDong.InsertInMenuBar ThisDrawing.Application.MenuBar.Count + 1'删除菜单
'If MsgBox("是否删除 COPY 菜单?", vbYesNo, "AutoCAD提示") = vbYes Then
'mnuCopy.Delete
'End If
End Sub'Public Sub AcadStartUp()
'Call CreateToolbarExample
'End Sub
'
''添加工具栏
'Public Sub CreateToolbarExample()
'Dim mnuGroup As AcadMenuGroup
'Dim tbTest As AcadToolbar
'Dim tbCopy As AcadToolbarItem
'Dim tbPaste As AcadToolbarItem
'Dim tbSeparator As AcadToolbarItem
'Dim macCopy As String
'Dim macPasteclip As String
'Dim strPath1 As String
'Dim strPath2 As String
'Set mnuGroup = ThisDrawing.Application.MenuGroups.Item(0)
'Set tbTest = mnuGroup.Toolbars.Add("抽稀")
'macCopy = Chr(3) & Chr(3) & Chr(95) & "zzDCX" & Chr(32)
'macPaste = Chr(3) & Chr(3) & Chr(95) & "pasteclip" & Chr(32)
'Set tbCopy = tbTest.AddToolbarButton _
'(tbTest.Count + 1, "复制", "复制", macCopy, False)
'Set tbPaste = tbTest.AddToolbarButton _
'(tbTest.Count + 1, "粘贴 ", "粘贴", macPaste, False)
'Set tbSeparator = tbTest.AddSeparator(tbTest.Count + 1)
'strPath1 = "f:\4.bmp"
'strPath2 = "f:\4.bmp"
'tbCopy.SetBitmaps strPath1, strPath2
''strPath1 = "G:\VBA\paste.bmp"
''strPath2 = "G:\VBA\paste.bmp"
''tbPaste.SetBitmaps strPath1, strPath2
''MsgBox "左"
'tbTest.Dock acToolbarDockLeft
''MsgBox "右"
''tbTest.Float 550, 300, 1
'End Sub

程序运行效果：

注意：以上源码中的声明部分是适应64位操作系统的声明方法，如不能运行只需要改为普通声明方法替换即可，只是调用打开文件对话框功能。

AutoCAD VBA点抽稀程序相关推荐

AutoCAD VBA 离散高程点应用
江苏省地质测绘院姜法明离散高程点应用很广,本文介绍AutoCAD VBA进行二资开发,利用离散高程点创建TIN三角形,进而绘制等高线.高程网格.地表曲面图的方法. 1.创建TIN三角形 1.1第 ...
Autocad VBA初级教程
转载自CAD世界论坛普天同庆老师的作品.深表感谢!! Autocad VBA初级教程(第一课:入门) 1.为什么要写这个教程市面上ACAD VBA的书不多,它的帮助是英文版的,很多人看不懂.其实我转 ...
lisp自动生成界址点表_基于AutoCAD VBA增减挂钩报备坐标文件自动生成.doc
基于AutoCAD VBA增减挂钩报备坐标文件自动生成基于AutoCAD VBA增减挂钩报备坐标文件自动生成摘要:生成增减挂钩报备坐标文件是一项非常繁琐的工作,会占用大量工作时间.如果利用VBA对 ...
AutoCAD VBA对齐对象
AutoCAD VBA对齐对象,代码如下. Sub AlignEnt() Dim ss As AcadSelectionSet Set ss = CreateSelectionSet ss.Selec ...
AutoCAD VBA基于对象的分层
AutoCAD VBA基于对象的分层,讲不同对象根据特性分层,代码如下. Dim Value As Variant Value = ThisDrawing.GetVariable("cmde ...
AutoCAD VBA 通过选择集删除图层上所有对象和图层
AutoCAD VBA 通过选择集删除图层上所有对象和图层 '删除图层上所有对象 Function DelAllInLayer(ByVal LName As String) 'On Erro ...
lisp 梯形展开图_利用AutoCAD平台的Autolisp程序语言做复杂建模
利用 AutoCAD 平台的 Autolisp 程序语言做复杂建模 * 齐颖 1 ,盛传玲 2 [摘要] 在三维实体的创建.显示.控制和编辑方面,巧妙地利用 AutoCAD 平台的 Autolis ...
AutoCAD VBA单行文字转换为多行文字
AutoCAD VBA单行文字转换为多行文字,多行文字便于编辑,代码如下. Public Sub TextToMtext() On Error Resume Next Dim ptInsert As ...
AutoCAD VBA enabler 2010-2017
官方说法是VBA6的发布授权已经结束,AutoDesk 只能继续发布AutoCAD 2014及以后的支持VBA7.1的版本. 搜了下,之前的虽然不公开,但是链接仍然能找到. AutoCad VBA 2 ...

AutoCAD VBA点抽稀程序

AutoCAD VBA点抽稀程序相关推荐

最新文章

热门文章