VB调用SURFER绘制雨量等值线图的方法和技巧

Forcast

    来到这个论坛，发现了很多大家分享的好东东，不久前把VB读取GRADS数据的代码分享出来，得到站长的鼓励。看到SURFER版块贴子较少，我把几年前做的东东分享出来。2005年写材料需要，第一次从别人手里接过SURFER绘制的雨量图感觉很漂亮，当时已开始有少量自动站。开始是用SURFER手工操作出图，手工操作出来的图，可能某个数据错了或者领导看了不满意，要重来那是很烦的事（尽管操作很熟悉）。所以花了好长时间去研究程序绘图的事，特别是色标的事费了我很大劲，后来不断改进，程序一直用到现在。有兴趣的可以参考和交流。
    绘制雨量图首先要生成雨量数据，在此不讨论，在此讨论的是用VB调用ＳＵＲＦＥＲ的方法和技巧。前不久有位广元的坛友发了一段相似的VB代码，他的做法是直接调用VB操作完所有步骤的办法。其实对程序用户来说就仅是1个日期变了（文本标题），雨量值变了（等值线，色标），地图和图的大小、格式个一般是不变的。熟悉SURFER的都知道有.SRF文件，其实已有的SRF文件就是1个模板，人工操作时打开1个模板文件，先把雨量数据文件格点化，把里面的“文本标题，雨量，色标”更新一下是不是很快就可以出图了。用模板有个好处是人工操作，不满意随时改到满意为止，需要改图时基本不用动程序。
   注意：要想VB调用SURFER，需要在VB菜单-工程-引用-浏览-找到SURFER.EXE。这是VB新手往往不懂的地方。
Sub Main()
        Dim SurferApp As Object
        Dim Doc As Object
        Dim Plotwindow As Object
        Dim ContourMapFrame As Object
        Dim ContourMap As Object
        Dim Base1 As Object
        Dim Map As Object, MapTitle1 As Object
        Dim MethodLabel As Variant
        Dim retValue As Boolean, Method As Integer  
        Dim Data As String, Grid As String, Bmap As String '白化用地图文件名变量
     Data = Path & "Town.dat"   '原始数据存放，第一列经度、第二列纬度、第三列高度（降水）、第四列站点名
     Grid = Path & "Town.grd"   '格点化后的输出文件
     Bmap = Path & "hainan.bln"  '海南省边界地图文件
     OutBlank = Path & "Out.grd"  '白化后输出文件
     OutBmp = Path & "Town.BMP"  '位图输出文件
     OutEmf = Path & "Town.emf"  '输出emf，图象字节小又清楚，但是模板.srf里右轴需内移0.05，在WORD里才显示右边框
Set SurferApp = CreateObject("Surfer.Application")  '调用SURFER程序
Method = 2   '一般都采用克里格法，进行数据格点化分析操作，加入了限制边界数值
retValue = SurferApp.GridData(DataFile:=Data, Algorithm:=Method, xMin:=108.6, xMax:=111#, yMin:=18.2, yMax:=20.1, ShowReport:=False, OutGrid:=Grid)
retValue = SurferApp.GridBlank(Grid, Bmap, OutGrid:=OutBlank, OutFmt:=3) '白化操作，格点输入文件，地图文件，格点输出文件，输出格式
Select Case CP  '根据不同的分类产品调用不同的等值线色块文件.LVL
   Case 0: lvl = "12小时降水量.lvl"
  Case 1: lvl = "test.lvl"
   Case 2: lvl = "过程降水量.lvl"
   End Select: lvl = Path & lvl
  '根据项目总数的多少判别是否有乡镇资料，选用不同的字号模板 输出为（BMP图，1100*800，不保留比例）
If Form1.List2.ListCount < 40 Then FF = "小图大字_半页直排模板.SRF": obj = 4 Else FF = "大图小字_单页横排模板.SRF": obj = 6
    FF1 = "_" & Form1.Text(18).Text & Format(Time, "_HHMM") & ".SRF": FileCopy Path & FF, Path & FF1
    Set Doc = SurferApp.Documents.Open(Path & FF1, Options:=""):  SurferApp.Visible = True  '打开图形文件并显示
'Debug.Print Doc.Shapes(3).Overlays(4)   'shapes 1-色标，2-文本，3-图形主体；Overlays 1-等值线，2--站名，3-地图，4-雨量
For i = 1 To 3   'Shapes里一般有3项。  ID顺序会随着图形的改变而不同，所以用筛选匹配的办法实现
  If Doc.Shapes(i) = "文本" Then
     Set Base1 = Doc.Shapes(i): Base1.Text = Form1.Text(18).Text '更新标题
  ElseIf Doc.Shapes(i) = "Map" Then  '图形主体-Map 里一般共有4项
     For j = 1 To obj  '根据不同的模板,图形要素不同
Debug.Print Doc.Shapes(i).Overlays(j)
       If Doc.Shapes(i).Overlays(j) = "市县名称" Or Doc.Shapes(i).Overlays(j) = "市县雨量" Or Doc.Shapes(i).Overlays(j) = "乡镇名称" Or Doc.Shapes(i).Overlays(j) = "乡镇雨量" Then
          Set Base1 = Doc.Shapes(i).Overlays(j): Base1.DataFile = Data '更新站名和雨量
       ElseIf Doc.Shapes(i).Overlays(j) = "等值线" Then
          Set Base1 = Doc.Shapes(i).Overlays(j)
          Base1.GridFile = OutBlank: Base1.Levels.LoadFile (lvl) '更新等值线；并载入.lvl文件形成色标
       End If:
       Next
  End If: Next
Set Base1 = SurferApp.Documents(1): x = Base1.Save '存盘   '输出BMP图,(1150*800，256色，不保留比例)从Surfer帮助中得
x = Base1.Export(OutEmf)  '输出emf格式没有参数可选
If Form1.Che图形.Value = 1 Then     '缺省情况下自动关闭SURFER程序
   Set Base1 = SurferApp: x = Base1.Quit
End If
End Sub

传说中的谁

感谢楼主无私的分享，写代码都不容易。个人有点点建议，不知道合不合适，就是配色方案是不是可以考虑用国家局下发的方案，我记得有这么一个文件的，不同雨量等级对应的RGB值。

风行浪尖

发现这么多人还是用的VB

mofangbao

今天出去买东西了，回来发现这么好的帖子！赞！

Forcast

传说中的谁 发表于 2011-12-17 19:36

                               
登录/注册后可看大图

感谢楼主无私的分享，写代码都不容易。个人有点点建议，不知道合不合适，就是配色方案是不是可以考虑用国家 ...

中国局05年出过色标规定，我们领导最后让改成现在这个，前两年中央台会商又出了个色标规定，现在色标都不知道用谁好。

xycams

不错  好东东

山水美不美

这个好啊，收藏了，下来试试效果，不懂得地方再来向你请教，谢谢分享！

tsinghuayoung

十分感谢，赞一个

sxxydick

还是这个号啊

liujimin025

楼主  顶一个！