工程测量工作中因计算工程量的需要，测量地形时不会考虑什么测图比例或出图比例，对计量有利的地形变化点都需要布点。这样会导致地形点过密，在出图时需要过滤掉一部分（不在纸质地形图上显示），毕竟纸质版资料还是要按规范要求的点间距来绘图的。在南方CASS中就有点过滤命令用于出图前的图面点过滤。我们在使用Civil3D做测量资料时，在出图方面存在一定局限性，如没有相应图式，也没有点过滤等命令。好在我们可以利用VBA进行扩展。

采用的方法是在Excel（WPS兼容）或是Civil3D里用VBA对地形数据文件过滤后生成新的数据文件，在Civil3D里新建一个曲面添加这个过滤后的点数据文件，出图时隐藏用于算量的曲面，将出图曲面进行绘图。

Excel里的代码

在表格中添加一个按钮

Private Declare Function ShellExecute Lib "Shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongFunction Distance(Sx As Double, Sy As Double, Ex As Double, Ey As Double, Precision As Integer) As DoubleDim DltX As Double, DltY As DoubleDltX = Ex - SxDltY = Ey - SyDistance = Round(Sqr(DltX * DltX + DltY * DltY), Precision)End FunctionSub filter() Dim Dia1 As Object, Strr As String, PPath As String Dim filterDist As Integer '抽稀距离 Dim Datums As Variant Dim RowIndex As Long Dim rIndex As Long, rIndex2 As Long, xa As Double, ya As Double, xb As Double, yb As Double RowIndex = 1 filterDist = Sheet1.Cells(1, 6) '抽稀距离 If filterDist = 0 Then filterDist = 2 'Sheet1.Cells(1, 7) = "←F1单元格设置抽稀距离"  'Sheet1.Cells(4, 7) = "cehui@139.com" Sheet1.Range("A1:E10000").ClearContents Set Dia1 = Application.FileDialog(msoFileDialogFilePicker) Dia1.Title = "版权所有(C) QQ:61902475 Email:cehui@139.com V20160225" With Dia1 .AllowMultiSelect = False '限制只能同时选择一个文件 .Filters.Clear .Filters.Add "南方CASS格式", "*.dat", 1 '限制显示的文件类型 .Show For Each vrtSelectedItem In .SelectedItems PPath = vrtSelectedItem Next End With If Trim(PPath) <> "" Then Open PPath 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 Sheet1.Cells(RowIndex, 1) = RowIndex Sheet1.Cells(RowIndex, 2) = "" Sheet1.Cells(RowIndex, 3) = Datums(2) Sheet1.Cells(RowIndex, 4) = Datums(3) Sheet1.Cells(RowIndex, 5) = Datums(4) End If End If RowIndex = RowIndex + 1 Loop Close #1 End If'点抽稀 rIndex = 1 rIndex2 = rIndex + 1Do While Sheet1.Cells(rIndex, 1).Text <> "" If Trim(Sheet1.Cells(rIndex2, 2)) = "" Then xa = Sheet1.Cells(rIndex, 3) ya = Sheet1.Cells(rIndex, 4) rIndex2 = rIndex + 1 Do While Sheet1.Cells(rIndex2, 1).Text <> "" If (Abs(Sheet1.Cells(rIndex2, 3).Text - xa) < filterDist And Abs(Sheet1.Cells(rIndex2, 4).Text - ya) < filterDist) Then If Distance(xa, ya, Sheet1.Cells(rIndex2, 3).Text, Sheet1.Cells(rIndex2, 4).Text, 3) < filterDist And Trim(Sheet1.Cells(rIndex, 2)) = "" And Trim(Sheet1.Cells(rIndex2, 2)) = "" Then Sheet1.Cells(rIndex2, 2) = "T" End If End If rIndex2 = rIndex2 + 1 Loop  End If rIndex = rIndex + 1Loop If Trim(PPath) <> "" Then rIndex = 1 RowIndex = 1 Open Left(PPath, InStr(UCase(PPath), ".DAT") - 1) & "-抽稀(" & filterDist & "m)-" & Replace(Format(Date, "yyyy-mm-dd"), "-", "") & "-" & Replace(Time, ":", "") & ".dat" For Output As #2 Do While Trim(Sheet1.Cells(rIndex, 1)) <> "" 'Sheet1.Cells(5, 7) = rIndex & ":" & RowIndex If Trim(Sheet1.Cells(rIndex, 2)) = "" Then Print #2, RowIndex & ",," & Format(Sheet1.Cells(rIndex, 3), "0.000") & "," & Format(Sheet1.Cells(rIndex, 4), "0.000") & "," & Format(Sheet1.Cells(rIndex, 5), "0.000") RowIndex = RowIndex + 1 End If rIndex = rIndex + 1 Loop Close #2 End IfSheet1.Range("B1:B10000").ClearContentsEnd Sub

对于删除重合地形点同样有用，只要将过滤间距设为一个很小的值如0.1即可。

后续将介绍Civil3D里增加VBA点过滤功能，如下图：

点过滤对话框