vb+surfer绘制自动站监测图形

bekaku

Private Sub drawapic(strinfile As String)
Dim objSurfer As Application
Dim objPlot As Surfer.IDocument
Dim objMapFrame As Surfer.IMapFrame
Dim temp As Boolean
'Dim strinfile As String
Dim strGridFile As String
strGridFile = Left(strinfile, Val(InStrRev(strinfile, ".")) - 1) + ".grd"   '把扩展名改为.grd
Set objSurfer = CreateObject("Surfer.Application") '创建surfer对象
Set objPlot = objSurfer.Documents.Add(1)
With objSurfer
.GridData DataFile:=App.Path + "\" + strinfile, Algorithm:=srfKriging, dupmethod:=2, showreport:=False, SearchEnable:=True, OutGrid:=App.Path + "\" + strGridFile, xMin:=119.1, xMax:=121.2, yMin:=28.3, yMax:=29.8, NumCols:=301, NumRows:=301
.Visible = False
End With
'创建对象（CreateObject）是Vb提供的一个方法，它表示CreateObject方法在系统注册表里查找"Surfer.APPhcafion"项并自动激活Surfer服务
'objSurfer.Visible = False   'surfer软件本身不在前台显示
'temp = objSurfer.GridData(xCol:=1, yCol:=2, zCol:=3, DataFile:=strinfile, dupmethod:=srfDupNone, xMin:=119.1, xMax:=121.2, yMin:=28.3, yMax:=29.8, NumCols:=301, NumRows:=301, Algorithm:=srfKriging, OutGrid:=strGridFile, OutFmt:=srfGridFmtAscii, showreport:=False) ' OutFmt:=srfGridFmtAscii,
'用Kriging法将资料内插到网格点上，并确定网格点的最大（小）经纬度，等值线图边界大小。outgrid为数据插值之后输出的文件名。
Dim ContourMap As Surfer.IContourMap
Dim levels As ILevels
    temp = objSurfer.GridBlank(Ingrid:=App.Path + "\" + strGridFile, blankfile:=App.Path + "\bln\jinhout.bln", OutGrid:=App.Path + "\out" + ".grd")
    '用闭合区域底图bz1.bln文件去掉边界外的插值后的数据，为绘制区域等值线做准备。
    Set objMapFrame = objPlot.Shapes.AddContourMap(App.Path + "\out" + ".grd")  '绘制等值线图，并添加到文档
'生成一个等值线图，并指定其文件名为ContourMapFrame。
   Set ContourMap = objMapFrame.Overlays(1)
  
  ContourMap.SmoothContours = 4 '平滑等值线
  ContourMap.FillContours = True '设置等值线填充
  
Set levels = ContourMap.levels
levels.LoadFile (App.Path + "\aa.lvl")
objMapFrame.Axes(1).Visible = False
objMapFrame.Axes(3).Visible = False
objMapFrame.Axes(2).Visible = False
objMapFrame.Axes(4).Visible = False
ContourMap.ShowColorScale = True   '显示色标
ContourMap.ColorScale.FrameLine.Width = 0#
ContourMap.ColorScale.Left = ContourMap.Width + ContourMap.Left - 0.9
ContourMap.ColorScale.Width = 0.3
ContourMap.ColorScale.Height = 2
ContourMap.ColorScale.Top = ContourMap.Top - (ContourMap.Height - ContourMap.ColorScale.Height) / 2
ContourMap.ColorScale.LabelFont.Size = 8
'等值线数值标注的字体和大小
ContourMap.LabelFont.Size = 5

'加载地名标注
Dim Shapes As Object
Dim MapFrame As IMapFrame
Dim PostMap As IPostMap
Set Shapes = objPlot.Shapes
Set MapFrame = Shapes.AddPostMap(DataFileName:=App.Path + "\站点信息.ini", xCol:=2, yCol:=3, LabCol:=4, SymCol:=4)
Set PostMap = MapFrame.Overlays(1)
'对张贴图的属性进行设置
  PostMap.Symbol.Size = 0.02
PostMap.Symbol.Index = 12
'设置站点符号的大小和形状
PostMap.LabelFont.Face = "宋体"
PostMap.LabelFont.Size = 4
'设置站点名称的字体和大小
'显示等值线色标，并给a、b、c、d赋值。
'Dim ContourMap As Surfer.IContourMap
Dim mybasemap1 As Surfer.IMapFrame
   Set mybasemap1 = objPlot.Shapes.AddBaseMap(ImportFileName:=App.Path + "\bln\jinh.bln") '添加底图
Dim mybasemap2 As Surfer.IMapFrame
   Set mybasemap2 = objPlot.Shapes.AddBaseMap(ImportFileName:=App.Path + "\bln\jinhout.bln") '添加底图
  mybasemap2.BackgroundLine.Width = 0.2
''基面图属性
'For Each Axis In myBasemap1.Axes
'With Axis
'.Visible = False
'End With
'Next

   objPlot.Shapes.SelectAll
   
   '合并图形
   objPlot.Selection.OverlayMaps

'坐标轴相关属性
objPlot.Export FileName:=App.Path + "\" + Left(strinfile, Val(InStrRev(strinfile, ".")) - 1) + ".bmp", Options:="width=3200,height=2000" '输出bmp
'Picture1.Picture = LoadPicture(Left(strinfile, Val(InStrRev(strinfile, ".")) - 1) + ".bmp")         '显示bmp
'Next p
   objPlot.Close savechanges:=srfSaveChangesNo
   objSurfer.Quit
Set objSurfer = Nothing
End Sub

bekaku

初学vb，对环境下surfer的精细化设置还不是很清楚，如缺测值、图层叠加顺序如何设置等，请高手指点

bekaku

bekaku 发表于 2011-8-31 08:44

                               
登录/注册后可看大图

初学vb，对环境下surfer的精细化设置还不是很清楚，如缺测值、图层叠加顺序如何设置等，请高手指点

D:\my&vb\vbsurfer\110617zcd查询及绘图\resultdata.bmp

mofangbao

借用射月楼主的一句话，最好的帮助文件是软件的使用手册

木青+

要是能把出来的图也一起拿出来就好了

传说中的谁

我想请教一下，VB调用surfer时需要添加引用吗？另外就是有没有将BMP转成GIF的插件，因为位图太占存储空间了？谢谢楼主无私的分享！

思考

很好，支持一下

cycle

很好，支持一下

bekaku

做了一个比较简单的中尺度站评估程序，能自动生成评估图形及描述文字d:\zcdpg.jpg

douding1027

努力学习中，不知道能成不