为填充等值线图生成自定义图例

holz · 发表于 2017-1-12 16:08:23

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

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

x

1、用 Surfer 自带的 Scripter 打开脚本，
2、运行 Surfer，打开或创建填充等值线图，
3、选中要创建自定义图例的填充等值线图层，注意是“图层”，
4、回到 Scripter，按 F5 运行脚本。
5、再到 Surfer 看结果。
6、效果如下两图所示：

7、代码，可保存为 bas 文件，也可直接复制到 Scripter。

'=========================================================================
'脚本名称： CustomContourLegend.bas
'运行环境： Golden software Surfer 13.x + Scripter.exe
'作者： holz [AT] live.com
'日期： 2017.1.12
'功能：在填充等值线图的下方生成对应的图例。
'用法：用 Surfer 附带的 Scripter.exe 程序（一般在 Surfer 安装目录下的 Scripter
' 文件夹中，或者“开始 -> 程序 -> Golden Software Surfer 13 -> Scripter”）
' 打开本脚本。
' 运行 Surfer，打开或创建一个填充等值线图，选中要生成自定义图例的图层，
' 回到 Scripter 按 F5 运行脚本即可。
'=========================================================================
Option Explicit
Sub Main
Dim gsApp As IApplication2
Dim plt As IPlotDocument
On Error Resume Next
Set gsApp = GetObject(,"Surfer.Application")
If Err.Number <> 0 Then
MsgBox "未发现运行中的 Surfer，" & vbCrLf & _
"请先运行 Surfer，打开或创建一个填充等值线图。", _
vbCritical + vbOkOnly, "程序终止"
End
End If
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 plt = gsApp.ActiveDocument
If plt.Selection.Count <> 1 Then
MsgBox "未选中对象或选中了多个对象。" & vbCrLf & _
"每次只能选中一个填充等值线图。", _
vbCritical + vbOkOnly, "程序终止"
End
End If
Debug.Clear
Dim layerName As String
'取得选中的对象名，由于要求选中等值线图层，那么名称的形式就是
'<容器名><逗号><空格><图层名>
'我们只需要图层名，所以把前面的部分去掉。
layerName = plt.Selection.Item(1).Name
layerName = Right(layerName,Len(layerName)-InStr(layerName," "))
If plt.Selection.Item(1).Type <> srfShapeMapFrame Then
MsgBox "未选中填充等值线图对象。" & vbCrLf & _
"请选中一个填充等值线图。", _
vbCritical + vbOkOnly, "程序终止"
End
End If
Dim MapFrame As IMapFrame2
Dim ContourLayer As Object
Dim x0 As Double, y0 As Double, w0 As Double
Dim x As Double, y As Double
Dim nLevels As Integer, i As Integer
Dim nLegend As Integer
Dim txt() As IText, sym() As IRectangle
Dim txtStr As String
Dim CustomLegend As IComposite2
'把选中的容器提取出来。
Set MapFrame = plt.Selection.Item(1)
'给一些变量设定初始值。
With MapFrame
x0 = .Left + 0.5
y0 = .Top - .Height - 0.5
End With
x = 0
w0 = 0
'取消选择以免影响后续操作。
plt.Selection.DeselectAll
'一个容器中可能有多个等值线图层，所以用遍历的方法。
For Each ContourLayer In MapFrame.Overlays
'如果遍历到的图层是刚才选中的图层。
If ContourLayer.Type = srfShapeContourMap And _
ContourLayer.Name = layerName Then
'取得等值线等级数。
nLevels = ContourLayer.Levels.Count
'确定自定义图例数组的大小。
ReDim txt(nLevels), sym(nLevels)
'循环处理每个等值线等级。
For i = 1 To nLevels
'用矩形来表示填充等值线的图例符号。
'要调整图例符号的大小，请修改 1.0 和 0.6 这两个数值。
Set sym(i) = plt.Shapes.AddRectangle(x0, y0, x0+1.0, y0+0.6)
sym(i).LineColor = srfColorBlack
With ContourLayer.Levels.Item(i).Fill
sym(i).Fill.Pattern = .Pattern
sym(i).Fill.ForeColor = .ForeColor
End With
sym(i).Name = "等级" & i & "图例"
'根据等值线等级的对应数值来确定图例说明。
If i = 1 Then
txtStr = "< " & ContourLayer.Levels.Item(i+1)
ElseIf i = nLevels Then
txtStr = "> " & ContourLayer.Levels.Item(i)
Else
txtStr = ContourLayer.Levels.Item(i).Value & " - " & _
ContourLayer.Levels.Item(i+1).Value
End If
Set txt(i) = plt.Shapes.AddText(x0+0.5, y0, txtStr)
txt(i).Font.VAlign = srfTAVCenter
'要调整图例说明文本的大小，请修改 12 这个数值。
txt(i).Font.Size = 12
txt(i).Name = "等级" & i & "说明"
'确定单个图例及其说明的最大宽度。
x = sym(i).Width + 0.35 + txt(i).Width
If x > w0 Then w0 = x
Next
'确定每一行的图例个数。
nLegend = Int(MapFrame.Width / w0) - 1
'确定图例的起始位置。
x0 = MapFrame.Left + 0.5 * (MapFrame.Width - nLegend * w0)
x = x0 : y = y0
'逐个摆放图例及其说明。
For i = 1 To nLevels
sym(i).Left = x
sym(i).Top = y
sym(i).Select
txt(i).Left = sym(i).Left + sym(i).Width + 0.25
txt(i).Top = y
txt(i).Select
x = x + w0
If i Mod nLegend = 0 Then
x = x0 : y = y - sym(i).Height - 0.25
End If
Next
'将所有图例及其说明组合为一个复合对象。
Set CustomLegend = plt.Selection.Combine
CustomLegend.Name = "自定义图例"
CustomLegend.Deselect
End If
Next
MsgBox "处理完毕，请转到 Surfer 主界面查看效果。", vbInformation + vbOkOnly, "程序结束"
End Sub

复制代码

ahzyzsj · 发表于 2017-1-12 16:55:56

不错喔，学习了

黯隐琉璃 · 发表于 2017-1-15 19:24:03

感谢楼主的分享，学习了~

zhanshao · 发表于 2017-1-28 16:48:48

好牛逼，呵呵

张爱气象 · 发表于 2017-1-30 00:03:26

用 Surfer 自带的 Scripter 打开脚本——请教：这个步骤在哪儿？

cheer899 · 发表于 2017-2-26 10:58:57

谢谢楼主楼主辛苦了

736541051 · 发表于 2017-4-14 09:00:16

请教一下你的图例是怎么制作的，如何做成如25-30这样

张爱气象 · 发表于 2017-4-14 23:35:56

请问：“填充颜色”的改变——在哪儿修改才可以实现呢？

张爱气象 · 发表于 2017-4-15 00:12:41

等值线间隔——如何修改？

wsjqxjy · 发表于 2017-4-15 08:03:17

学习了，谢谢分享，

{:eb502:}{:eb502:}{:eb502:}{:eb502:}

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

[vbscript] 为填充等值线图生成自定义图例

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

评分

浏览过的版块