计算多边形内的等值线均值

holz · 发表于 2017-1-17 09:59:48

登录后查看更多精彩内容~

您需要登录才可以下载或查看，没有帐号？立即注册

x

假设有一个等值线图，上面有一些多边形区域，想要计算每个多边形区域内的等值线平均值。

要求有一个 grd 文件，一个含有封闭多边形对象的 bln 文件。

效果如下：

代码如下：

'============================================================
'用途：计算多边形区域内的等值线平均值。
'输入：一个用来绘制等值线图的网格文件，一个包含多边形的边界文件。
'不足：会生成垃圾文件 temp.bln 和 temp.dat
'holz [AT] live.com
'2017-1-16
'Golden Software Surfer 13.x + Scripter
'Use on your own risk!
'============================================================
Option Explicit
Sub Main
Dim gsApp As IApplication2
Dim wks As IWksDocument
Dim grd As String
Dim bln As String
Dim dat As String
Debug.Clear
Debug.Print "======== " & Date & " " & Time & " ========"
'grd = GetFilePath(,"grd",,"Select grid file",4)
grd = "D:\gmt5ex\demogrid.grd"
If grd = "" Then End
'bln = GetFilePath(,"bln",,"Select bln file",4)
bln = "D:\gmt5ex\demogrid_township_range.bln"
If bln = "" Then End
dat = Left(bln,Len(bln)-4) & "_Vc.dat"
On Error Resume Next
Set gsApp = CreateObject("Surfer.Application")
If Err.Number <> 0 Then End
On Error GoTo 0
Set wks = gsApp.Documents.Open2(bln)
Dim nBLN As Integer
Dim blnHeader As Integer, blnFlag As Integer
Dim tmpBln As String, tmpDat As String
Dim tmpWks As IWksDocument
Dim stats As IWksStatistics
Dim i As Integer
Dim r As Integer
Dim zMean As Double
Dim Xc As Double, Yc As Double
nBLN = 0
blnFlag = 0 '白化标志值， 0 表示白化外部， 1 表示白化内部
r = 1
Open dat For Output As #1
Print #1, "Xc, Yc, Zmean"
Debug.Print "正在处理 BLN 文件 " & bln
Debug.Print "该文件内含 " & wks.Columns("A").RowCount & " 行数据。"
While r < wks.Columns("A").RowCount
blnHeader = wks.Cells(r, 1).Value
blnFlag = wks.Cells(r, 2).Value
'只有第一点坐标与最后一点坐标重合才算封闭多边形
If Abs(wks.Cells(r+1, 1).Value - wks.Cells(r+blnHeader, 1).Value) < 1e-5 And _
Abs(wks.Cells(r+1, 2).Value - wks.Cells(r+blnHeader, 2).Value) < 1e-5 Then
nBLN = nBLN + 1 '计算封闭多边形对象个数
tmpBln = "Temp.bln" '产生的垃圾文件名
tmpDat = "Temp.dat" '产生的另一个垃圾文件名
'新增一个空白工作表文档
Set tmpWks = gsApp.Documents.Add(srfDocWks)
'把当前要处理的多边形数据复制到剪贴板
wks.Cells(r, 1, r+blnHeader, 2).Copy
'从剪贴板把数据粘贴到新工作表
tmpWks.Cells("A1").Paste
'设置白化标志值
tmpWks.Cells("B1").Value = blnFlag
'以下 3 行计算多边形中心坐标
Set stats = tmpWks.Cells(2,1,blnHeader+1,2).Statistics(Flags:=wksStatsSum)
Xc = stats.Sum(1) / blnHeader
Yc = stats.Sum(2) / blnHeader
'把新工作表保存为 bln 文件并关闭，此文件有且仅有一个多边形对象
tmpWks.SaveAs(FileName:=tmpBln, FileFormat:=srfSaveFormatBln)
tmpWks.Close(srfSaveChangesNo)
'用刚生成的 bln 文件白化 grd 文件，得到一个数据文件
gsApp.GridBlank(grd, tmpBln, tmpDat, srfGridFmtXYZ)
'打开白化结果
Set tmpWks = gsApp.Documents.Open2(tmpDat)
'对数据按 C 列进行升序排序
tmpWks.Columns(1, 3).Sort(Col1:=3, Order1:=wksSortAscending)
'发现白化值 1.70141e+38 即把后续行一次性删除，剩下即为有效数值
For i = 1 To tmpWks.Columns(1).RowCount
If tmpWks.Cells(i, 3).Value = 1.70141e+38 Then
tmpWks.Rows(i, tmpWks.Columns(1).RowCount).Delete(wksDeleteRows)
Exit For
End If
Next
'计算均值后关闭
Set stats = tmpWks.Columns(3).Statistics(Flags:=wksStatsMean)
zMean = stats.Mean
tmpWks.Close(srfSaveChangesNo)
'显示计算得到的多边形中心和均值，并写入磁盘文件
Debug.Print Xc; ", "; Yc; ", "; zMean
Print #1, Xc; ", "; Yc; ", "; zMean
End If
r = r + blnHeader + 1
Wend
Close #1
Debug.Print "其中发现 " & nBLN & " 个多边形对象。"
wks.Close(srfSaveChangesNo)
Debug.Print "开始绘制示意图，使用以下文件："
Debug.Print " 1. " & grd
Debug.Print " 2. " & bln
Debug.Print " 3. " & dat
Dim Plot As IPlotDocument
Set Plot = gsApp.Documents.Add(srfDocPlot)
Debug.Print "绘制等值线图。"
Dim MapFrame As IMapFrame2
Set MapFrame = Plot.Shapes.AddContourMap(grd)
Dim Axis As IAxis2
For Each Axis In MapFrame.Axes
Axis.MajorTickType = srfTickNone
Axis.MinorTickType = srfTickNone
Axis.ShowLabels = False
Next
Dim ContourLayer As IContourLayer
Set ContourLayer = MapFrame.Overlays(1)
With ContourLayer
.LevelMethod = SrfConLevelMethodSimple
.FillForegroundColorMap.LoadFile(gsApp.Path & "\ColorScales\Rainbow.clr")
.FillContours = True
'.ApplyFillToLevels(1,2,1)
.ShowMajorLabels = False
.ShowMinorLabels = False
End With
Debug.Print "添加基底图层，对多边形对象做填充。"
Dim BaseLayer As IBaseLayer
Set BaseLayer = Plot.Shapes.AddBaseLayer(MapFrame, bln)
With BaseLayer.Fill
.Transparent = True
.Pattern = "Diagonal Cross"
.ForeColorRGBA.Color = srfColorNavyBlue
.ForeColorRGBA.Opacity = 90
.BackColorRGBA.Color = srfColorBabyBlue
.BackColorRGBA.Opacity = 45
End With
BaseLayer.Line.ForeColor = srfColorRed
BaseLayer.Line.Width = 0.05
Debug.Print "添加张贴图层，显示多边形内等值线均值。"
Dim PostLayer As IPostLayer
Set PostLayer = Plot.Shapes.AddPostLayer(MapFrame, dat, 1, 2, 3)
With PostLayer
.LabelFormat.Type = srfLabFixed
.LabelFormat.NumDigits = 2
.LabelFont.Color = srfColorYellow
.LabelFont.Size = 16
.LabelFont.Bold = True
.Symbol.Set = "GSI Default Symbols"
.Symbol.Index = 33
.Symbol.Size = 0.75
.Symbol.FillColor = srfColorYellow
.Symbol.LineColor = srfColorBlack
End With
gsApp.Visible = True
gsApp.ActiveWindow.Zoom(srfZoomFitToWindow)
End Sub

复制代码

kiwilee · 发表于 2017-1-24 19:48:31

学习了。能不能随时手动一圈就能显示其均值？

		自动登录	找回密码
密码			立即注册

[vbscript] 计算多边形内的等值线均值

登录后查看更多精彩内容~

评分