surfer自动化

Sub Main
'定义
Dim SurferApp As Object
Dim Wks As Object
Dim Wks1 As Object
Dim Wks2 As Object
Dim Doc As Object
Dim Plotwindow As Object
Dim Map As Object
Dim MapTitle As Object
Dim Axis As Object
Dim Line1 As Object
Dim Line2 As Object
Dim File As String
Dim Title As String
Dim retValue As Boolean
Dim MapNumber As Integer
'启动 Surfer 并最大化
Set SurferApp = CreateObject("Surfer.Application")
SurferApp.Visible = True
SurferApp.WindowState = srfWindowStateMaximized
'指定工作文件
File = SurferApp.Path + "\TWTURKEY\data"
'打开文件 (要求用户自己选择表格)
Set Wks = SurferApp.Documents.Open(File+".xls")
'指定第二个文件并打开
Set Wks1 = SurferApp.Documents.Open(SurferApp.Path + "\TWTURKEY\Baraj.xls")
Wait 1
'删除第一列
Wks1.Columns(1).Delete
Wait 1
'删除第三列
Wks1.Columns(3).Delete
'保存修改后的文件为 .bln
Wks1.SaveAs(FileName:=SurferApp.Path + "\TWTURKEY\baraj.bln")
'指定第三个文件并打开
Set Wks2 = SurferApp.Documents.Open(SurferApp.Path + "\TWTURKEY\Baraj.xls")
Wait 1
'删除第一列
Wks2.Columns(1).Delete
Wait 1
'删除第三列
Wks2.Columns(2).Delete
'保存修改后的文件为 .bln
Wks2.SaveAs(FileName:=SurferApp.Path + "\TWTURKEY\barajsu.bln")
'开始循环 (有 13 个 z 列)
For MapNumber = 0 To 12 Step 1
'打开一个图形文档
Set Doc = SurferApp.Documents.Add()
'设置标题
Title = Wks.Cells (1,MapNumber + 4)
'网格化数据，每次循环改变 zCol
retValue = SurferApp.GridData(DataFile:=File + ".xls", xCol:=2, _
yCol:=3, zCol:=MapNumber + 4, xMin:= 0, xMax:= 52, yMin:= 100, yMax:= 160,Algorithm:=srfTriangulation, _
ShowReport:=False, OutGrid:=File + ".grd")
'建立一个等值线图
Set Map = Doc.Shapes.AddContourMap(File)
'等值线图属性
Map.Width = 20
Map.Height = 16
Map.Left = 3
Map.Top = 18
'修改坐标属性
For Each Axis In Map.Axes
If Axis.AxisType = srfATBottom Then
With Axis
.ShowMajorGridLines = True
.SetScale(0,52,1,1,52,100,0)
End With
End If
If Axis.AxisType = srfATLeft Then
With Axis
.ShowMajorGridLines = True
.SetScale(100,170,5,100,170,0,0)
End With
End If
If Axis.AxisType = srfATTop Or Axis.AxisType = srfATRight Then
With Axis
.Visible = False
End With
End If
Next
'用 zCol 文件头建立地图标题
Set MapTitle = Doc.Shapes.AddText(Map.Left + Map.Width/2 - 1, _
Map.Top - Map.Height - 1,"Plot of " + Title)
'打开覆盖
Set Map = Map.Overlays("Contours")
'填充等值线
Map.FillContours = True
'设置等级颜色
Set levels = Map.Levels
'颜色填充循环
n = levels.Count
ColorInc = 255.0 / (n-1)
For i=1 To n
ColorInc = 255.0 * (i-1) / (n-1)
levels(i).Fill.ForeColor = RGB(255-ColorInc,0,ColorInc)
Next i
'比例尺
Map.ShowColorScale = True
Map.ColorScale.Top = Map.Top
Map.ColorScale.Left = Map.Left + Map.Width + 0.01
Map.ColorScale.Height = 15
Map.ColorScale.Width = 1
'添加基面图
Set Map1 = Doc.Shapes.AddBaseMap(SurferApp.Path + "\TWTURKEY\baraj.bln")
'基面图属性
Map1.Width = 20
Map1.Height = 16
Map1.Left = 3
Map1.Top = 18
'基面图线条属性
Set Line1 = Map1.Overlays("Base")
Line1.Fill.Pattern = "none"
Line1.Line.Style = "Solid"
Line1.Line.Width = "0.200"
Line1.Line.ForeColor = srfColorBlue
'基面图坐标属性
For Each Axis In Map1.Axes
With Axis
.Visible = False
End With
Next
'添加第二个基面图
Set Map2 = Doc.Shapes.AddBaseMap(SurferApp.Path + "\TWTURKEY\barajsu.bln")
'设置基面图属性
Map2.Width = 20
Map2.Height = 16
Map2.Left = 3
Map2.Top = 18
'设置基面图线条属性
Set Line2 = Map2.Overlays("Base")
Line2.Fill.Pattern = "none"
Line2.Line.Style = "Solid"
Line2.Line.Width = "0.200"
Line2.Line.ForeColor = srfColorRed
'设置基面图坐标属性
For Each Axis In Map2.Axes
With Axis
.Visible = False
End With
Next
'覆盖三个图形为一个
Doc.Shapes.SelectAll
Set MapAll = Doc.Selection.OverlayMaps
'保存图形文档
Doc.SaveAs(FileName:=SurferApp.Path +"\TWTURKEY\" + Title + ".srf")
Next
End Sub