用自动化脚本给张贴图加个色标

holz · 发表于 2017-9-15 09:59:51

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

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

x

在 Surfer 中，分类张贴图有图例选项，但是普通的张贴图是没有图例选项的。
这很好理解，非分类的张贴图，都使用同一个符号，哪里有图例可言？

但是张贴图可以根据某列数据按比例显示符号大小，还可以用 clr 色谱文件按数据值进行着色，那加个色标也是可以的，效果如下：

普通张贴图加图例

可惜的是，目前只做到按 clr 节点提取色标，不能完美匹配张贴图。

代码如下：

'=========================================================================
'脚本名称： CustomPostLegend.bas
'运行环境： Golden software Surfer 13.x + Scripter.exe
'作者： holz [AT] live.com
'日期： 2017.9.14
'功能：在张贴图的下方生成对应的图例。
'用法：用 Surfer 附带的 Scripter.exe 程序（一般在 Surfer 安装目录下的 Scripter
' 文件夹中，或者“开始 -> 程序 -> Golden Software Surfer 13 -> Scripter”）
' 打开本脚本。
' 运行 Surfer，打开或创建一个张贴图，选中要生成自定义图例的图层，
' 回到 Scripter 按 F5 运行脚本即可。
'=========================================================================
Option Explicit
Sub Main
Dim gsApp As IApplication2
Dim plot As IPlotDocument
Debug.Clear
Debug.Print "======== " & Date & " " & Time & " ========"
On Error Resume Next
Set gsApp = GetObject(,"Surfer.Application")
If Err.Number <> 0 Then
MsgBox "未发现运行中的 Surfer，" & vbCrLf & _
"请先运行 Surfer，打开或创建一个张贴图。", _
vbCritical + vbOkOnly, "程序终止"
End
End If
on error goto 0
If gsApp.Documents.Count < 1 Then
MsgBox "未发现图形文档。" & vbCrLf & _
"请先打开或创建一个张贴图。", _
vbCritical + vbOkOnly, "程序终止"
End
End If
If gsApp.ActiveDocument.Type <> srfDocPlot Then
MsgBox "活动文档不是图形文档。" & vbCrLf & _
"请先打开或创建一个张贴图，并设为活动文档。", _
vbCritical + vbOkOnly, "程序终止"
End
End If
Set plot = gsApp.ActiveDocument
If plot.Selection.Count <> 1 Then
MsgBox "未选中对象或选中了多个对象。" & vbCrLf & _
"每次只能选中一个张贴图。", _
vbCritical + vbOkOnly, "程序终止"
End
End If
Dim layerName As String
layerName = plot.Selection.Item(1).Name
layerName = Right(layerName, Len(layerName)-InStr(layerName," "))
Debug.Print "选中的图层名称：" & layerName
If plot.Selection.Item(1).Type <> srfShapeMapFrame Then
MsgBox "未选中张贴图对象。" & vbCrLf & _
"请选择一个张贴图对象。", vbCritical + vbOkOnly, "程序终止"
End
End If
Dim MapFrame As IMapFrame2
Dim postLayer As Object
Dim x0 As Double, y0 As Double, w0 As Double
Dim x As Double
Dim nNodes As Integer
Dim txt() As IText, sym() As IRectangle
Dim txtStr As String
Dim customLegend As IComposite2
Dim i As Integer
Set MapFrame = plot.Selection.Item(1)
With MapFrame
x0 = .Left + 1.0
y0 = .Top - .Height - 1.0
End With
x = x0 : w0 = 0
plot.Selection.DeselectAll
For Each postLayer In MapFrame.Overlays
If postLayer.Type = srfShapePostmap And postLayer.Name = layerName Then
If postLayer.SymbolColorCol > 0 Then
With postLayer.SymbolColorMap
nNodes = .ColorNodes.Count
w0 = (MapFrame.Width - 2.0) / nNodes
ReDim txt(nNodes), sym(nNodes)
For i = 1 To nNodes
Set sym(i) = plot.Shapes.AddRectangle(x, y0, x+w0, y0+0.2)
sym(i).LineColor = srfColorBlack
sym(i).Fill.Pattern = "Solid"
sym(i).Fill.ForeColorRGBA.Red = .ColorNodes.Item(i).ColorRGBA.Red
sym(i).Fill.ForeColorRGBA.Green = .ColorNodes.Item(i).ColorRGBA.Green
sym(i).Fill.ForeColorRGBA.Blue = .ColorNodes.Item(i).ColorRGBA.Blue
sym(i).Name = "节点" & i & "图例"
sym(i).Select
txtStr = Str(Round(.PosToDat(.ColorNodes.Item(i).Position),1))
Set txt(i) = plot.Shapes.AddText(x+0.5*w0, y0-0.5, txtStr)
txt(i).Font.VAlign = srfTAVCenter
txt(i).Font.HAlign = srfTACenter
txt(i).Font.Size = 12
txt(i).Name = "节点" & i & "说明"
txt(i).Select
x = x + w0
Next i
End With
Set customLegend = plot.Selection.Combine
customLegend.Name = "自定义图例"
customLegend.Deselect
End If 'postLayer.SymbolColorCol > 0
End If 'srfShapePostmap And layerName
Next 'postLayer
End Sub

复制代码

charleszhou · 发表于 2017-9-18 19:17:26

很是花哨的感觉哦

holz · 发表于 2017-9-19 04:57:52

charleszhou 发表于 2017-9-18 19:17
很是花哨的感觉哦

是吧，我也觉得没有什么实际意义。

不过人生也不能要求事事都有意义。

Rainch · 发表于 2021-2-8 13:29:21

{:eb502:}{:eb502:}

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

[vbscript] 用自动化脚本给张贴图加个色标

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

评分