ayame的个人博客分享 http://blog.sciencenet.cn/u/ayame

博文

surfer绘制等值线代码

已有 1857 次阅读 2022-9-25 15:05 |系统分类:科研笔记

surfer我不常用,所以这段代码比较简陋,但批量出图的基本功能还是有的。代码见附件ContourMap_aya.bas,具体如下:

Sub aya_contourmap
Debug.Clear
'基本知识:Dim开头的语句为定义语句,Set语句为建立语句,这两种语句大概明白就可以了
'
'
'打开surfer软件,并显示
Dim SurferApp As Object
Set SurferApp = CreateObject("Surfer.Application")
SurferApp.Visible = True     'false则为不显示
'新建绘图文档
Dim Plot As Object
Set Plot = SurferApp.Documents.Add
'定义循环数i,并将其转化为字符,以便下文使用
Dim i As Integer
Dim Name() As Variant
Name()=Array("gc1","gc2","gc3")     '数据文件名
For i = 1 To 2   '设置循环
'生成网格,数据文件与白化轮廓文件时必须的
DataFile = SurferApp.Path + "\data\1\"+Name(i-1)+".xyz"     '数据文件
InGrid = SurferApp.Path + "\data\1\"+Name(i-1)+".grd"      '生成的网格文件
BlankFile = SurferApp.Path + "\data\20bj.bln"            '白化轮廓文件
BlankedGrid = SurferApp.Path + "\data\1\"+"blanked"+Name(i-1)+".grd"  '白化后的网格文件
'用最小曲率法划分网格,并显示在surfer里(需要修改的是xsize与ysize)
SurferApp.GridData3 (DataFile:=DataFile, Algorithm:= srfMinCurvature, _
xSize:=100, ySize:=100, ShowReport:=False,  OutGrid:=InGrid)
'生成白化后的网格文件
SurferApp.GridBlank (InGrid:=InGrid, BlankFile:=BlankFile, Outgrid:=BlankedGrid)
'利用白化后的网格绘制等值线图
Set MapFrame = Plot.Shapes.AddContourMap(GridFileName:=BlankedGrid)
'MapFrame.SetLimits (xMin:=0.5, xMax:=4.5, yMin:=0.5, yMax:=3.5)
'定义图框上的四个坐标轴,并隐藏显示
Dim Axes As Object
 Set Axes = MapFrame.Axes
 Set BottomAxis = Axes("Bottom axis")
 Set LeftAxis = Axes("Left axis")
 Set RightAxis = Axes("Right axis")
 Set TopAxis = Axes("Top axis")
LeftAxis.Visible=False    '隐藏左坐标轴
BottomAxis.Visible=False
RightAxis.Visible=False
TopAxis.Visible=False
'设定等值线图的相关参数
Dim ContourLayer As Object
Set ContourLayer = MapFrame.Overlays(1)
ContourLayer.Name = "contourmap_"+Name(i-1)      '重命名
ContourLayer.SmoothContours = srfConSmoothHigh
ContourLayer.FillContours = True              '显示colormap
'ContourLayer.FillForegroundColorMap.LoadPreset("Rainbow")
ContourLayer.FillForegroundColorMap.SetDataLimits (DataMin:=0, DataMax:=25)    'colormap中的最大最小值
'自定义配色方案
Dim Positions(4) As Double
Positions(0)=0.0
Positions(1)=0.25
Positions(2)=0.5
Positions(3)=0.75
Positions(4)=1.0
Dim Colors(4) As Long
Colors(0)=RGB(0,0,255)
Colors(1)=RGB(0,255,255)
Colors(2)=RGB(0,255,0)
Colors(3)=RGB(255,255,0)
Colors(4)=RGB(255,0,0)
ContourLayer.FillForegroundColorMap.SetNodes(Positions:=Positions, Colors:=Colors)
'ContourLayer.FillForegroundColorMap.Reverse    'Reverses the colormap
'等值线图level层级的相关设置
ContourLayer.LevelMethod = SrfConLevelMethodSimple
ContourLayer.SetSimpleLevels(Min:=0, Max:=25, Interval:=0.5)
ContourLayer.LevelMajorInterval = 1
ContourLayer.MajorLine.ForeColorRGBA.Opacity = 0
ContourLayer.ShowMajorLabels = False
ContourLayer.MinorLine.ForeColorRGBA.Opacity = 0
ContourLayer.ShowMinorLabels = False
'等值线图输出dxf
'ContourLayer.ExportContours(FileName:=SurferApp.Path+"\data\Contours.dxf", Format:=srfConFormatDXF)
'等值线图的位置与大小
MapFrame.Top=3          '图框的y方向
MapFrame.Left=-25       '图框的x方向
MapFrame.xLength = 60   '图框的x方向大小
MapFrame.yLength = 25    '图框的y方向大小
'等值线图输出为jpg
'Plot.Export(FileName:= SurferApp.Path+"\data\demogrid.jpg", SelectionOnly:=False ,Options:="Width=6560, Height=2920")
'打印pdf
'Plot.PrintOut
MapFrame.Visible=False
Next
End Sub

祝各位生活愉快



https://blog.sciencenet.cn/blog-3503582-1356774.html

上一篇:双Y绘图的VBA代码
下一篇:定间距断面插值的matlab代码
收藏 IP: 58.213.140.*| 热度|

0

该博文允许注册用户评论 请点击登录 评论 (0 个评论)

数据加载中...
扫一扫,分享此博文

Archiver|手机版|科学网 ( 京ICP备07017567号-12 )

GMT+8, 2024-3-19 10:04

Powered by ScienceNet.cn

Copyright © 2007- 中国科学报社

返回顶部