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

holz

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

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

普通张贴图加图例

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

代码如下：

1. '=========================================================================
   
2. '脚本名称： CustomPostLegend.bas
   
3. '运行环境： Golden software Surfer 13.x + Scripter.exe
   
4. '作者： holz [AT] live.com
   
5. '日期： 2017.9.14
   
6. '功能： 在张贴图的下方生成对应的图例。
   
7. '用法： 用 Surfer 附带的 Scripter.exe 程序（一般在 Surfer 安装目录下的 Scripter
   
8. '       文件夹中，或者“开始 -> 程序 -> Golden Software Surfer 13 -> Scripter”）
   
9. '       打开本脚本。
   
10. '       运行 Surfer，打开或创建一个张贴图，选中要生成自定义图例的图层，
    
11. '       回到 Scripter 按 F5 运行脚本即可。
    
12. '=========================================================================
    
13. 
    
14. Option Explicit
    
15. Sub Main
    
16.     Dim gsApp As IApplication2
    
17.     Dim plot As IPlotDocument
    
18. 
    
19.     Debug.Clear
    
20.     Debug.Print "======== " & Date & " " & Time & " ========"
    
21.     On Error Resume Next
    
22.     Set gsApp = GetObject(,"Surfer.Application")
    
23.     If Err.Number <> 0 Then
    
24.         MsgBox "未发现运行中的 Surfer，" & vbCrLf & _
    
25.             "请先运行 Surfer，打开或创建一个张贴图。", _
    
26.             vbCritical + vbOkOnly, "程序终止"
    
27.         End
    
28.     End If
    
29.     on error goto 0
    
30. 
    
31.     If gsApp.Documents.Count < 1 Then
    
32.         MsgBox "未发现图形文档。" & vbCrLf & _
    
33.             "请先打开或创建一个张贴图。", _
    
34.             vbCritical + vbOkOnly, "程序终止"
    
35.         End
    
36.     End If
    
37. 
    
38.     If gsApp.ActiveDocument.Type <> srfDocPlot Then
    
39.         MsgBox "活动文档不是图形文档。" & vbCrLf & _
    
40.             "请先打开或创建一个张贴图，并设为活动文档。", _
    
41.             vbCritical + vbOkOnly, "程序终止"
    
42.         End
    
43.     End If
    
44.     Set plot = gsApp.ActiveDocument
    
45. 
    
46.     If plot.Selection.Count <> 1 Then
    
47.         MsgBox "未选中对象或选中了多个对象。" & vbCrLf & _
    
48.             "每次只能选中一个张贴图。", _
    
49.             vbCritical + vbOkOnly, "程序终止"
    
50.         End
    
51.     End If
    
52. 
    
53.     Dim layerName As String
    
54.     layerName = plot.Selection.Item(1).Name
    
55.     layerName = Right(layerName, Len(layerName)-InStr(layerName," "))
    
56.     Debug.Print "选中的图层名称：" & layerName
    
57.     If plot.Selection.Item(1).Type <> srfShapeMapFrame Then
    
58.         MsgBox "未选中张贴图对象。" & vbCrLf & _
    
59.             "请选择一个张贴图对象。", vbCritical + vbOkOnly, "程序终止"
    
60.         End
    
61.     End If
    
62. 
    
63.     Dim MapFrame As IMapFrame2
    
64.     Dim postLayer As Object
    
65.     Dim x0 As Double, y0 As Double, w0 As Double
    
66.     Dim x As Double
    
67.     Dim nNodes As Integer
    
68.     Dim txt() As IText, sym() As IRectangle
    
69.     Dim txtStr As String
    
70.     Dim customLegend As IComposite2
    
71.     Dim i As Integer
    
72. 
    
73.     Set MapFrame = plot.Selection.Item(1)
    
74.     With MapFrame
    
75.         x0 = .Left + 1.0
    
76.         y0 = .Top - .Height - 1.0
    
77.     End With
    
78.     x = x0  : w0 = 0
    
79.     plot.Selection.DeselectAll
    
80. 
    
81.     For Each postLayer In MapFrame.Overlays
    
82.         If postLayer.Type = srfShapePostmap And postLayer.Name = layerName Then
    
83.             If postLayer.SymbolColorCol > 0 Then
    
84.               With postLayer.SymbolColorMap
    
85.                 nNodes = .ColorNodes.Count
    
86.                 w0 = (MapFrame.Width - 2.0) / nNodes
    
87.                 ReDim txt(nNodes), sym(nNodes)
    
88.                 For i = 1 To nNodes
    
89.                     Set sym(i) = plot.Shapes.AddRectangle(x, y0, x+w0, y0+0.2)
    
90.                     sym(i).LineColor = srfColorBlack
    
91.                     sym(i).Fill.Pattern = "Solid"
    
92.                     sym(i).Fill.ForeColorRGBA.Red = .ColorNodes.Item(i).ColorRGBA.Red
    
93.                     sym(i).Fill.ForeColorRGBA.Green = .ColorNodes.Item(i).ColorRGBA.Green
    
94.                     sym(i).Fill.ForeColorRGBA.Blue = .ColorNodes.Item(i).ColorRGBA.Blue
    
95.                     sym(i).Name = "节点" & i & "图例"
    
96.                     sym(i).Select
    
97. 
    
98.                     txtStr = Str(Round(.PosToDat(.ColorNodes.Item(i).Position),1))
    
99.                     Set txt(i) = plot.Shapes.AddText(x+0.5*w0, y0-0.5, txtStr)
    
100.                     txt(i).Font.VAlign = srfTAVCenter
     
101.                     txt(i).Font.HAlign = srfTACenter
     
102.                     txt(i).Font.Size = 12
     
103.                     txt(i).Name = "节点" & i & "说明"
     
104.                     txt(i).Select
     
105. 
     
106.                     x = x + w0
     
107.                 Next i
     
108.               End With
     
109.               Set customLegend = plot.Selection.Combine
     
110.               customLegend.Name = "自定义图例"
     
111.               customLegend.Deselect
     
112.             End If    'postLayer.SymbolColorCol > 0
     
113.         End If    'srfShapePostmap And layerName
     
114.     Next    'postLayer
     
115. End Sub
     

复制代码

charleszhou

很是花哨的感觉哦

holz

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

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

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

Rainch

{:eb502:}{:eb502:}