请选择 进入手机版 | 继续访问电脑版
爱气象,爱气象家园! 

气象家园

 找回密码
 立即注册

QQ登录

只需一步,快速开始

新浪微博登陆

只需一步, 快速开始

搜索
查看: 13996|回复: 15

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

[复制链接]

新浪微博达人勋

发表于 2017-1-12 16:08:23 | 显示全部楼层 |阅读模式

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

您需要 登录 才可以下载或查看,没有帐号?立即注册 新浪微博登陆

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


7、代码,可保存为 bas 文件,也可直接复制到 Scripter。
  1. '=========================================================================
  2. '脚本名称: CustomContourLegend.bas
  3. '运行环境: Golden software Surfer 13.x + Scripter.exe
  4. '作者: holz [AT] live.com
  5. '日期: 2017.1.12
  6. '功能: 在填充等值线图的下方生成对应的图例。
  7. '用法: 用 Surfer 附带的 Scripter.exe 程序(一般在 Surfer 安装目录下的 Scripter
  8. '                文件夹中,或者“开始 -> 程序 -> Golden Software Surfer 13 -> Scripter”)
  9. '                打开本脚本。
  10. '                运行 Surfer,打开或创建一个填充等值线图,选中要生成自定义图例的图层,
  11. '                回到 Scripter 按 F5 运行脚本即可。
  12. '=========================================================================

  13. Option Explicit
  14. Sub Main
  15.         Dim gsApp As IApplication2
  16.         Dim plt As IPlotDocument

  17.         On Error Resume Next
  18.         Set gsApp = GetObject(,"Surfer.Application")
  19.         If Err.Number <> 0 Then
  20.                 MsgBox "未发现运行中的 Surfer," & vbCrLf & _
  21.                         "请先运行 Surfer,打开或创建一个填充等值线图。", _
  22.                         vbCritical + vbOkOnly, "程序终止"
  23.                 End
  24.         End If

  25.         If gsApp.Documents.Count < 1 Then
  26.                 MsgBox "未发现图形文档。" & vbCrLf & _
  27.                         "请先打开或创建一个分类张贴图。", _
  28.                         vbCritical + vbOkOnly, "程序终止"
  29.                 End
  30.         End If
  31.         If gsApp.ActiveDocument.Type <> srfDocPlot Then
  32.                 MsgBox "活动文档不是图形文档。" & vbCrLf & _
  33.                         "请先打开或创建一个填充等值线图,并设为活动文档。", _
  34.                         vbCritical + vbOkOnly, "程序终止"
  35.                 End
  36.         End If
  37.         Set plt = gsApp.ActiveDocument

  38.         If plt.Selection.Count <> 1 Then
  39.                 MsgBox "未选中对象或选中了多个对象。" & vbCrLf & _
  40.                         "每次只能选中一个填充等值线图。", _
  41.                         vbCritical + vbOkOnly, "程序终止"
  42.                 End
  43.         End If

  44.         Debug.Clear
  45.         Dim layerName As String
  46.         '取得选中的对象名,由于要求选中等值线图层,那么名称的形式就是
  47.         '<容器名><逗号><空格><图层名>
  48.         '我们只需要图层名,所以把前面的部分去掉。
  49.         layerName = plt.Selection.Item(1).Name
  50.         layerName = Right(layerName,Len(layerName)-InStr(layerName," "))
  51.         If plt.Selection.Item(1).Type <> srfShapeMapFrame Then
  52.                 MsgBox "未选中填充等值线图对象。" & vbCrLf & _
  53.                         "请选中一个填充等值线图。", _
  54.                         vbCritical + vbOkOnly, "程序终止"
  55.                 End
  56.         End If

  57.         Dim MapFrame As IMapFrame2
  58.         Dim ContourLayer As Object
  59.         Dim x0 As Double, y0 As Double, w0 As Double
  60.         Dim x As Double, y As Double
  61.         Dim nLevels As Integer, i As Integer
  62.         Dim nLegend As Integer
  63.         Dim txt() As IText, sym() As IRectangle
  64.         Dim txtStr As String
  65.         Dim CustomLegend As IComposite2

  66.         '把选中的容器提取出来。
  67.         Set MapFrame = plt.Selection.Item(1)
  68.         '给一些变量设定初始值。
  69.         With MapFrame
  70.                 x0 = .Left + 0.5
  71.                 y0 = .Top - .Height - 0.5
  72.         End With
  73.         x = 0
  74.         w0 = 0
  75.         '取消选择以免影响后续操作。
  76.         plt.Selection.DeselectAll

  77.         '一个容器中可能有多个等值线图层,所以用遍历的方法。
  78.         For Each ContourLayer In MapFrame.Overlays
  79.                 '如果遍历到的图层是刚才选中的图层。
  80.                 If ContourLayer.Type = srfShapeContourMap And _
  81.                         ContourLayer.Name = layerName Then

  82.                         '取得等值线等级数。
  83.                         nLevels = ContourLayer.Levels.Count
  84.                         '确定自定义图例数组的大小。
  85.                         ReDim txt(nLevels), sym(nLevels)

  86.                         '循环处理每个等值线等级。
  87.                         For i = 1 To nLevels
  88.                                 '用矩形来表示填充等值线的图例符号。
  89.                                 '要调整图例符号的大小,请修改 1.0 和 0.6 这两个数值。
  90.                                 Set sym(i) = plt.Shapes.AddRectangle(x0, y0, x0+1.0, y0+0.6)
  91.                                 sym(i).LineColor = srfColorBlack
  92.                                 With ContourLayer.Levels.Item(i).Fill
  93.                                         sym(i).Fill.Pattern = .Pattern
  94.                                         sym(i).Fill.ForeColor = .ForeColor
  95.                                 End With
  96.                                 sym(i).Name = "等级" & i & "图例"


  97.                                 '根据等值线等级的对应数值来确定图例说明。
  98.                                 If i = 1 Then
  99.                                         txtStr = "< " & ContourLayer.Levels.Item(i+1)
  100.                                 ElseIf i = nLevels Then
  101.                                         txtStr = "> " & ContourLayer.Levels.Item(i)
  102.                                 Else
  103.                                         txtStr = ContourLayer.Levels.Item(i).Value & " - " & _
  104.                                                 ContourLayer.Levels.Item(i+1).Value
  105.                                 End If
  106.                                 Set txt(i) = plt.Shapes.AddText(x0+0.5, y0, txtStr)
  107.                                 txt(i).Font.VAlign = srfTAVCenter
  108.                                 '要调整图例说明文本的大小,请修改 12 这个数值。
  109.                                 txt(i).Font.Size = 12
  110.                                 txt(i).Name = "等级" & i & "说明"

  111.                                 '确定单个图例及其说明的最大宽度。
  112.                                 x = sym(i).Width + 0.35 + txt(i).Width
  113.                                 If x > w0 Then w0 = x
  114.                         Next

  115.                         '确定每一行的图例个数。
  116.                         nLegend = Int(MapFrame.Width / w0) - 1
  117.                         '确定图例的起始位置。
  118.                         x0 = MapFrame.Left + 0.5 * (MapFrame.Width - nLegend * w0)
  119.                         x = x0 : y = y0
  120.                         '逐个摆放图例及其说明。
  121.                         For i = 1 To nLevels
  122.                                 sym(i).Left = x
  123.                                 sym(i).Top = y
  124.                                 sym(i).Select
  125.                                 txt(i).Left = sym(i).Left + sym(i).Width + 0.25
  126.                                 txt(i).Top = y
  127.                                 txt(i).Select
  128.                                 x = x + w0
  129.                                 If i Mod nLegend = 0 Then
  130.                                         x = x0 : y = y - sym(i).Height - 0.25
  131.                                 End If
  132.                         Next
  133.                         '将所有图例及其说明组合为一个复合对象。
  134.                         Set CustomLegend = plt.Selection.Combine
  135.                         CustomLegend.Name = "自定义图例"
  136.                         CustomLegend.Deselect
  137.                 End If
  138.         Next

  139.         MsgBox "处理完毕,请转到 Surfer 主界面查看效果。", vbInformation + vbOkOnly, "程序结束"
  140. End Sub
复制代码


CustomContourLegend.BAS

4.72 KB, 下载次数: 16, 下载积分: 金钱 -5

评分

参与人数 3金钱 +70 贡献 +18 收起 理由
mofangbao + 20 + 5
言深深 + 20 + 5
chengxf + 30 + 8 很给力!

查看全部评分

密码修改失败请联系微信:mofangbao

新浪微博达人勋

发表于 2017-1-12 16:55:56 | 显示全部楼层
不错喔,学习了
密码修改失败请联系微信:mofangbao

新浪微博达人勋

发表于 2017-1-15 19:24:03 | 显示全部楼层
感谢楼主的分享,学习了~
密码修改失败请联系微信:mofangbao

新浪微博达人勋

发表于 2017-1-28 16:48:48 | 显示全部楼层
好牛逼,呵呵
密码修改失败请联系微信:mofangbao

新浪微博达人勋

发表于 2017-1-30 00:03:26 | 显示全部楼层
用 Surfer 自带的 Scripter 打开脚本——请教:这个步骤在哪儿?
密码修改失败请联系微信:mofangbao

新浪微博达人勋

发表于 2017-2-26 10:58:57 | 显示全部楼层
谢谢楼主 楼主辛苦了
密码修改失败请联系微信:mofangbao

新浪微博达人勋

发表于 2017-4-14 09:00:16 | 显示全部楼层
请教一下你的图例是怎么制作的,如何做成如25-30这样
密码修改失败请联系微信:mofangbao

新浪微博达人勋

发表于 2017-4-14 23:35:56 | 显示全部楼层
请问:“填充颜色”的改变——在哪儿修改才可以实现呢?
密码修改失败请联系微信:mofangbao

新浪微博达人勋

发表于 2017-4-15 00:12:41 | 显示全部楼层
等值线间隔——如何修改?
密码修改失败请联系微信:mofangbao

新浪微博达人勋

发表于 2017-4-15 08:03:17 | 显示全部楼层
学习了,谢谢分享,{:eb502:}{:eb502:}{:eb502:}{:eb502:}
密码修改失败请联系微信:mofangbao
您需要登录后才可以回帖 登录 | 立即注册 新浪微博登陆

本版积分规则

Copyright ©2011-2014 bbs.06climate.com All Rights Reserved.  Powered by Discuz! (京ICP-10201084)

本站信息均由会员发表,不代表气象家园立场,禁止在本站发表与国家法律相抵触言论

快速回复 返回顶部 返回列表