Excel和WPS表格下CASS格式测量地形文件点按距离过滤抽稀

文件名：CASS格式地形文件点抽稀(Excel).rar Excel下的VBA程序，在WPS下也可以使用，打开此表格后点击表中按钮，选择CASS格式测量地形点文件，指定抽稀间距即可按距离进行点抽稀过滤。表格见下载中心。

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 Double
Dim DltX As Double, DltY As Double
DltX = Ex - Sx
DltY = Ey - Sy
Distance = Round(Sqr(DltX * DltX + DltY * DltY), Precision)
End FunctionSub filter()Dim Dia1 As Object, Strr As String, PPath As StringDim filterDist As Integer '抽稀距离Dim Datums As VariantDim RowIndex As LongDim rIndex As Long, rIndex2 As Long, xa As Double, ya As Double, xb As Double, yb As DoubleRowIndex = 1filterDist = Sheet1.Cells(1, 6) '抽稀距离If filterDist = 0 Then filterDist = 2'Sheet1.Cells(1, 7) = "←F1单元格设置抽稀距离"'Sheet1.Cells(2, 7) = "（C)中国电建一二·五联合体测量队"'Sheet1.Cells(3, 7) = "雅砻江两河口水电站大坝工程"'Sheet1.Cells(4, 7) = "覃东 cehui@139.com"Sheet1.Range("A1:E10000").ClearContentsSet 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 '限制显示的文件类型.ShowFor Each vrtSelectedItem In .SelectedItemsPPath = vrtSelectedItemNextEnd WithIf Trim(PPath) <> "" ThenOpen PPath For Input As #1Do While Not EOF(1)Line Input #1, StrrIf Trim(Strr) <> "" ThenDatums = Split(Strr, ",")If UBound(Datums) = 4 ThenSheet1.Cells(RowIndex, 1) = RowIndexSheet1.Cells(RowIndex, 2) = ""Sheet1.Cells(RowIndex, 3) = Datums(2)Sheet1.Cells(RowIndex, 4) = Datums(3)Sheet1.Cells(RowIndex, 5) = Datums(4)End IfEnd IfRowIndex = RowIndex + 1LoopClose #1End If'点抽稀rIndex = 1rIndex2 = rIndex + 1
Do While Sheet1.Cells(rIndex, 1).Text <> ""If Trim(Sheet1.Cells(rIndex2, 2)) = "" Thenxa = Sheet1.Cells(rIndex, 3)ya = Sheet1.Cells(rIndex, 4)rIndex2 = rIndex + 1Do While Sheet1.Cells(rIndex2, 1).Text <> ""If (Abs(Sheet1.Cells(rIndex2, 3).Text - xa) < filterDist And Abs(Sheet1.Cells(rIndex2, 4).Text - ya) < filterDist) ThenIf 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)) = "" ThenSheet1.Cells(rIndex2, 2) = "T"End IfEnd IfrIndex2 = rIndex2 + 1LoopEnd IfrIndex = rIndex + 1
LoopIf Trim(PPath) <> "" ThenrIndex = 1RowIndex = 1Open Left(PPath, InStr(UCase(PPath), ".DAT") - 1) & "-抽稀(" & filterDist & "m)-" & Replace(Format(Date, "yyyy-mm-dd"), "-", "") & "-" & Replace(Time, ":", "") & ".dat" For Output As #2Do While Trim(Sheet1.Cells(rIndex, 1)) <> ""'Sheet1.Cells(5, 7) = rIndex & ":" & RowIndexIf Trim(Sheet1.Cells(rIndex, 2)) = "" ThenPrint #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 + 1End IfrIndex = rIndex + 1LoopClose #2End IfSheet1.Range("B1:B10000").ClearContentsEnd Sub

在表格中添加一个按钮

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