Скрипт ContourMapJapan.bas. (C) 2006 В.В.Суханов
ТИНРО-центр, 690950,Владивосток, пер. Шевченко,4.  E-mail: oliv at tinro.ru
ИБМ ДВО РАН, 690041,Владивосток,у.Пальчевского,17. E-mail: bbc at imb.dvo.ru

Автоматический расчет карт для российской+корейской экономзон Японского моря
Работает в среде интерпретатора Scripter программы Surfer-8 (Golden Software Inc.)
Версия 1.2 от 12.03.2009.

Sub Main
 
Dim Bln1,Bln2,OutA,OutB,Path,Bna1,Bna2,OutF,T1,T2,TH,LvlF As String
Dim FD,F1,F2,F3,F4,WF,RF,QF As String
Dim i,j,T,Ncol,Nrow,Nc,Rz,Npas,Xnum,Ynum As Integer
Dim xMi,xMa,yMi,yMa,zMi,zMa,dx,dy,U,zBL As Single
Dim X1,Y1,X2,Y2,XH,YH As Single
 
'ОТСЮДА НАЧИНАЮТСЯ НАСТРОЙКИ ПОЛЬЗОВАТЕЛЯ:----------------------------------------
 
Path = "C:\MapMakeJap\"  'Путь к папке с проектом. По умолчанию - в корень диска С
Bln1 = "JapCatch.bln"    'Бланкирующий файл - промысловая зона
Bln2 = "JapTerra.bln"    'Бланкирующий файл - суша
Bna1 = "JapCatch.bln"    'Декоративный файл границ - промысловая зона
Bna2 = "JapTerra.bln"    'Декоративный файл границ - суша
 
DatF = "Bsummer.dat"     'Файл с табличными данными, находится в папке Dat
Xnum =   1               'Номер столбца для X в таблице из файла datF (долгота, градусы)
Ynum =   2               'Номер столбца для Y в таблице из файла datF (широта, градусы)
 
        'Пример: летнее распределение уловов дальневосточной сардины
 
TH = "Summer,Sardinops melanostictus,ton/km2"   'Строка текста для заглавия
XH =   3.5  'Позиция начала текста заглавия TH от левого  края листа в см.
YH =  23.0  'Позиция начала текста заглавия TH от нижнего края листа в см.
 
Znum =  5            'Номер столбца для Z в таблице из файла datF (сейчас- для сардины)
LvlF = "sardine.lvl"  'Файл LVL2 с уровнями и их атрибутами, находится в папке Maps
 
zMi = 0.001       'Нижняя  граница вариаций для Z
zMa = 60000       'Верхняя граница вариаций для Z
Rz  = 1           'Если сетку ограничить zMi < Z < zMa, то Rz = 1, иначе = 0
 
xMi =  127.37840  'Левая   граница сетки Японского моря
xMa =  142.5      'Правая  граница сетки Японского моря
yMi =   38.61324  'Нижняя  граница сетки Японского моря
yMa =   52.22439  'Верхняя граница сетки Японского моря
dx  =    0.10     'Шаг сетки по оси X
dy  =    0.10     'Шаг сетки по оси Y
Npas=   25        'Число проходов при фильтрации сетки, должно быть > 0, хотя бы = 1
 
T1 =  ""   'Строка опционального текста T1. Если = "", то текст отсутствует
X1 =  3.0  'Позиция начала опционального текста T1 от левого  края листа в см.
Y1 =  5.0  'Позиция начала опционального текста T1 от нижнего края листа в см.
 
T2 =  ""   'Строка опционального текста T2 (если = "", то текст отсутствует)
X2 =  4.0  'Позиция начала опционального текста T2 от левого  края листа в см.
Y2 = 24.0  'Позиция начала опционального текста T2 от нижнего края листа в см.
 
'ЗДЕСЬ КОНЧАЮТСЯ НАСТРОЙКИ ПОЛЬЗОВАТЕЛЯ-------------------------------------------
 
Dim SurferApp As Object
Set SurferApp = CreateObject("Surfer.Application")
SurferApp.Visible = True
SurferApp.WindowState = srfWindowStateMaximized
Dim Grid As Object
Set Grid = SurferApp.NewGrid
 
RF = Path + "r.grd"
QF = Path + "q.grd"
F1 = "c=max(a," + Trim(Str(zMi)) + ")"
F2 = "c=min(a," + Trim(Str(zMa)) + ")"
Ncol = Round((xMa-xMi)/dx)+1
Nrow = Round((yMa-yMi)/dy)+1
 
  OutA = Path + "f.grd"
  OutB = Path + "b.grd"
  FD = Path + "Dat\" + DatF
 
  'Рассчитываем очередную базовую сетку:
  SurferApp.GridData(DataFile:=FD,Xcol:=Xnum,Ycol:=Ynum,zCol:=Znum, _
    ExclusionFilter:="z<0",DupMethod:=srfDupAvg,NumCols:=Ncol, _
    NumRows:=Nrow,xMin:=xMi,xMax:=xMa,yMin:=yMi,yMax:=yMa, _
    Algorithm:=srfKriging,ShowReport:=False,OutGrid:=RF, _
    OutFmt:=srfGridFmtS7)
  'Ограничиваем сетку сверху и снизу по Z:
  If Rz > 0 Then
    SurferApp.GridMath(Function:=F1,InGridA:=RF, _
      OutGridC:=QF,OutFmt:=srfGridFmtS7)
    SurferApp.GridMath(Function:=F2,InGridA:=QF, _
      OutGridC:=RF,OutFmt:=srfGridFmtS7)
  End If
  'Фильтруем сетку NPas раз стандартным гауссовским фильтром 3x3
  SurferApp.GridFilter(InGrid:=RF,Filter:=srfFilterGaussian, _
    EdgeOp:=srfFltEdgeReplicate,BlankOp:=srfFltBlankLeave, _
    NumPasses:=Npas,OutGrid:=OutA,OutFmt:=srfGridFmtS7)
  'Бланкируем сетку 1 раз:
  If Bln1 <> "" Then _
  SurferApp.GridBlank(inGrid:=OutA,BlankFile:=Path+Bln1, _
    OutGrid:=OutB,OutFmt:=srfGridFmtS7)
  'Бланкируем сетку 2 раз:
  If Bln2 <> "" Then _
  SurferApp.GridBlank(inGrid:=OutB,BlankFile:=Path+Bln2, _
    OutGrid:=OutA,OutFmt:=srfGridFmtS7)
  'Исправляем небланкированные краевые линии узлов:
  Grid.LoadFile(FileName:=OutA,HeaderOnly:=False)
  For j = 1 To Ncol
    Grid.BlankNode(Row:=1,Col:=j)
    Grid.BlankNode(Row:=Nrow,Col:=j)
  Next j
  For j = 1 To Nrow
    Grid.BlankNode(Row:=j,Col:=1)
    Grid.BlankNode(Row:=j,Col:=Ncol)
  Next j
 
Dim Docs As Object
Set Docs = SurferApp.Documents.Add(srfDocPlot) 'Графич.окно Docs
Dim MapFrame As Object
Dim BaseMap As Object
 
  SurferApp.ScreenUpdating = False    'Выключили автоперерисовку
  WF = OutA
  'Создаем конт.карту,назначаем коорд.систему переменной MapFrame
  Set MapFrame = Docs.Shapes.AddContourMap(GridFileName:=WF)
  MapFrame.Overlays(1).FillContours = True  'Закрасили карту
  MapFrame.xMapPerPU = 1.0
  MapFrame.yMapPerPU = 0.704 'Растянули широту на контурной карте
 
  Dim MProp As Object  'Свойства забланкированных областей
  Set MProp = MapFrame.Overlays(1)
  MProp.BlankFill.Pattern   = "Solid"
  MProp.BlankFill.ForeColor = srfColorWhite
  MProp.BlankFill.BackColor = srfColorYellow
  MProp.BlankLine.ForeColor = srfColorBlack
 
  Dim Levels As Object
  'Назначаем Levels collection переменной Levels:
  Set Levels = MProp.Levels
 
  'Строим линии уровней:
  Levels.LoadFile(Path + "Maps\" + LvlF) 'Загрузили уровни и их атрибуты
 
  Set BaseMap1 = Docs.Shapes.AddBaseMap(ImportFileName:=Path+Bna1)
  BaseMap1.xMapPerPU = 1.0
  BaseMap1.yMapPerPU = 0.704      'Растянули широту на базовой карте
  For Each axis In BaseMap1.Axes  'Задаем свойства всех 4 осей
    axis.ShowLabels = False
    axis.MajorTickType = srfTickNone
    axis.MinorTickType = srfTickNone
    axis.AxisLine.Style="Invisible"
  Next axis
 
  Set BaseMap2 = Docs.Shapes.AddBaseMap(ImportFileName:=Path+Bna2)
  BaseMap2.xMapPerPU = 1.0
  BaseMap2.yMapPerPU = 0.704      'Растянули широту на базовой карте
  For Each axis In BaseMap2.Axes  'Задаем свойства всех 4 осей
    axis.ShowLabels = False
    axis.MajorTickType = srfTickIn
    axis.MinorTickType = srfTickNone
    axis.AxisLine.Style="Invisible"
  Next axis
 
  Set BaseMap3 = Docs.Shapes.AddBaseMap(ImportFileName:=Path+"Line500.bna")
  BaseMap3.xMapPerPU = 1.0
  BaseMap3.yMapPerPU = 0.704      'Растянули широту на базовой карте
  For Each axis In BaseMap2.Axes  'Задаем свойства всех 4 осей
    axis.ShowLabels = False
    axis.MajorTickType = srfTickIn
    axis.MinorTickType = srfTickNone
    axis.AxisLine.Style="Invisible"
  Next axis
 
Set TeT = Docs.Shapes.AddText(x:=11.0,y:=5.7,Text:="500 km")
Set TeH =Docs.Shapes.AddText(x:=XH,y:=YH,Text:=TH) 'Текст титула
Set Te1 =Docs.Shapes.AddText(x:=X1,y:=Y1,Text:=T1)    'Текст T1
Set Te2 =Docs.Shapes.AddText(x:=X2,y:=Y2,Text:=T2)    'Текст T2
 
  SurferApp.ScreenUpdating = True    'Включили автоперерисовку
  MProp.ShowColorScale = True        'Показали цветовую шкалу
 
End Sub
 

Вложения:

Файл	Описание	Авторство	Размер файла
MapMakeJap.zip	Автоматизированное построение карт	Суханов В.В.	315 Kb