AutoCAD VBA点抽稀程序

最新推荐文章于 2024-02-24 14:35:10 发布

测量老覃

最新推荐文章于 2024-02-24 14:35:10 发布

阅读量1.5k

点赞数 1

分类专栏： AutoCAD Civil 3D 文章标签： AutoCAD

本文链接：https://blog.csdn.net/hjpqindong/article/details/91353497

版权

AutoCAD Civil 3D 专栏收录该内容

71 篇文章 62 订阅

订阅专栏

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

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

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

窗体控件对应代码：

Option Explicit

Private 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 Long

Private Type tsFileName
   lStructSize As Long
   hwndOwner As LongPtr
   hInstance As LongPtr
   strFilter As String
   strCustomFilter As String
   nMaxCustFilter As Long
   nFilterIndex As Long
   strFile As String
   nMaxFile As Long
   strFileTitle As String
   nMaxFileTitle As Long
   strInitialDir As String
   strTitle As String
   flags As Long
   nFileOffset As Integer
   nFileExtension As Integer
   strDefExt As String
   lCustData As Long
   lpfnHook As LongPtr
   lpTemplateName 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 = &H100000

Public 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_Err
    
    Dim tsFN As tsFileName
    Dim strFileTitle As String
    Dim 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 function
    With 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 = 0
    End With
   
    ' Call the function in the windows API
    If fOpenFile Then
        fResult = ts_apiGetOpenFileName(tsFN)
    Else
        fResult = ts_apiGetSaveFileName(tsFN)
    End If

    If fResult Then
        rlngflags = tsFN.flags
        tsGetFileFromUser = tsTrimNull(tsFN.strFile)
    Else
        tsGetFileFromUser = Null
    End If

End Function

Private Function tsTrimNull(ByVal strItem As String) As String
On Error GoTo tsTrimNull_Err
    Dim I As Integer
   
    I = InStr(strItem, vbNullChar)
    If I > 0 Then
        tsTrimNull = Left(strItem, I - 1)
    Else
        tsTrimNull = strItem
    End If
    
tsTrimNull_End:
    On Error GoTo 0
    Exit Function


tsTrimNull_Err:
    Beep
    MsgBox Err.Description, , "Error: " & Err.Number _
    & " in function basBrowseFiles.tsTrimNull"
    Resume tsTrimNull_End

End Function

Public Sub tsGetFileFromUserTest()
On Error GoTo tsGetFileFromUserTest_Err
   
    Dim strFilter As String
    Dim lngFlags As Long
    Dim varFileName As Variant


'   strFilter = "Access (*.mdb)" & vbNullChar & "*.mdb" _
'    & vbNullChar & "All Files (*.*)" & vbNullChar & "*.*"
    strFilter = "All Files (*.*)" & vbNullChar & "*.*"


    lngFlags = tscFNPathMustExist Or tscFNFileMustExist Or tscFNHideReadOnly
   
    varFileName = tsGetFileFromUser( _
    fOpenFile:=True, _
    strFilter:=strFilter, _
    rlngflags:=lngFlags, _
    strDialogTitle:="GetFileFromUser Test (Please choose a file)")
   
    If IsNull(varFileName) Then
        Debug.Print "User pressed 'Cancel'."
    Else
        Debug.Print varFileName
        'Forms![Form1]![Text1] = varFileName
    End If


    If varFileName <> "" Then MsgBox "You selected the '" & varFileName & "' file.", vbInformation


tsGetFileFromUserTest_End:
    On Error GoTo 0
    Exit Sub


tsGetFileFromUserTest_Err:
    Beep
    MsgBox Err.Description, , "Error: " & Err.Number _
     & " in sub basBrowseFiles.tsGetFileFromUserTest"
    Resume tsGetFileFromUserTest_End
End Sub


Function 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 Function

Private Sub btn_Filter_Click()
    Dim filterDist As Single '抽稀距离
    Dim pNum() As Long, pSign() As String, pX() As Double, pY() As Double, pH() As Double
    Dim Datums As Variant, startTime As String, endTime As String
    Dim RowIndex As Long, strr As String
    Dim rIndex As Long, rIndex2 As Long, xa As Double, ya As Double, xb As Double, yb As Double
    Dim strFilter As String
    Dim lngFlags As Long
    Dim varFileName As Variant
    Dim totalPoints As Long, effPoints As Long, delPoints As Long '总点数，有效点数
    RowIndex = 1
    If IsNumeric(Trim(txt_FilterDist.Text)) Then
        If Trim(txt_FilterDist.Text) > 0 Then
             filterDist = Trim(txt_FilterDist.Text)
        Else
            filterDist = 2
        End If
    Else
        filterDist = 2
    End If
    lbl_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 tscFNHideReadOnly
   
    varFileName = tsGetFileFromUser( _
    fOpenFile:=True, _
    strFilter:=strFilter, _
    rlngflags:=lngFlags, _
    strDialogTitle:="打开文件 中国电建两河口水电站 覃东")
   
If varFileName <> "" Then
            startTime = Time() '运行计时器
            txt_DatFileName.Text = varFileName
                    Open varFileName For Input As #1
                    Do While Not EOF(1)
                        Line Input #1, strr
                        If Trim(strr) <> "" Then
                        Datums = Split(strr, ",")
                                If UBound(Datums) = 4 Then
                                ReDim Preserve pNum(RowIndex)
                                ReDim Preserve pSign(RowIndex)
                                ReDim Preserve pX(RowIndex)
                                ReDim Preserve pY(RowIndex)
                                ReDim Preserve pH(RowIndex)
                                pNum(RowIndex - 1) = RowIndex
                                pSign(RowIndex - 1) = ""
                                pX(RowIndex - 1) = Datums(2)
                                pY(RowIndex - 1) = Datums(3)
                                pH(RowIndex - 1) = Datums(4)
                            End If
                        End If
                       RowIndex = RowIndex + 1
                         If RowIndex Mod 1000 = 0 Then
                              lbl_points.Text = totalPoints
                              frm_CassDatFilter.Repaint
                         End If
                   Loop
                   Close #1
        
                    totalPoints = RowIndex - 1
                    lbl_points.Text = totalPoints
                    frm_CassDatFilter.Repaint
        '点抽稀
            rIndex = 1
            rIndex2 = rIndex + 1
            delPoints = 0
            lbl_time.Text = "—"
            lbl_time.TextAlign = fmTextAlignCenter
        Do While pNum(rIndex - 1) <> 0 'And rIndex <= UBound(pNum)
                If Trim(pSign(rIndex2 - 1)) = "" Then
                    xa = pX(rIndex - 1)
                    ya = pY(rIndex - 1)
                    rIndex2 = rIndex + 1
                        Do While pNum(rIndex2 - 1) <> 0
                                If (Abs(pX(rIndex2 - 1) - xa) < filterDist And Abs(pY(rIndex2 - 1) - ya) < filterDist) Then
                                   If Distance(xa, ya, pX(rIndex2 - 1), pY(rIndex2 - 1), 3) < filterDist And Trim(pSign(rIndex - 1)) = "" And Trim(pSign(rIndex2 - 1)) = "" Then
                                   pSign(rIndex2 - 1) = "T"
                                   delPoints = delPoints + 1
                                   End If
                                End If
                            rIndex2 = rIndex2 + 1
                        Loop
                End If
                rIndex = rIndex + 1
                If rIndex Mod 200 = 0 Then
                    lbl_filtered.Text = totalPoints & "/" & delPoints
                    frm_CassDatFilter.Repaint
                    If lbl_time.Text = "—" Then
                    lbl_time.Text = "\"
                    ElseIf lbl_time.Text = "\" Then
                    lbl_time.Text = "|"
                    ElseIf lbl_time.Text = "|" Then
                    lbl_time.Text = "/"
                    Else
                    lbl_time.Text = "—"
                    End If
                End If
        Loop
        
                lbl_filtered.Text = totalPoints & "/" & delPoints
                frm_CassDatFilter.Repaint
        
        '保存
            If Trim(varFileName) <> "" Then
                rIndex = 1
                RowIndex = 1
                Open Left(varFileName, InStr(UCase(varFileName), ".DAT") - 1) & "-抽稀(" & filterDist & "m)-" & Replace(Format(Date, "yyyy-mm-dd"), "-", "") & "-" & Replace(Time, ":", "") & ".dat" For Output As #2
                    Do While Trim(pNum(rIndex - 1)) <> 0
                         If Trim(pSign(rIndex - 1)) = "" Then
                         Print #2, RowIndex & ",," & Format(pX(rIndex - 1), "0.000") & "," & Format(pY(rIndex - 1), "0.000") & "," & Format(pH(rIndex - 1), "0.000")
                         RowIndex = RowIndex + 1
                         End If
                          rIndex = rIndex + 1
                         If rIndex Mod 500 = 0 Then
                              lbl_epoints.Text = effPoints
                              frm_CassDatFilter.Repaint
                         End If
                   Loop
                   Close #2
            End If
                       effPoints = RowIndex - 1
                       lbl_epoints.Text = effPoints
        '清除数组
        ReDim pNum(1)
        ReDim pSign(1)
        ReDim pX(1)
        ReDim pY(1)
        ReDim pH(1)
        
        endTime = Time()
        lbl_time.TextAlign = fmTextAlignRight
        lbl_time.Text = "用时：" & (Minute(TimeValue(endTime)) - Minute(TimeValue(startTime))) * 60 + Second(TimeValue(endTime)) - Second(TimeValue(startTime)) & "秒"
End If

End Sub

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

Public Sub vba_zzDcx()
frm_CassDatFilter.show
End Sub

Sub 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

程序运行效果：