爱气象,爱气象家园! 

气象家园

 找回密码
 立即注册

QQ登录

只需一步,快速开始

新浪微博登陆

只需一步, 快速开始

搜索
楼主: 大老鹰

[vbscript] Surfer13自带脚本库中文标注

[复制链接]

新浪微博达人勋

 楼主| 发表于 2017-4-9 18:22:20 | 显示全部楼层
本帖最后由 大老鹰 于 2017-4-9 18:25 编辑
  1. Sub Main
  2. Debug.Clear

  3. '源代码来自Surfer13自带样本库,老鹰进行了中文标注。边译边学,毗漏难免,欢迎交流指正。
  4. '设置Surfer程序为创建对象。声明文档为对象。设置Surfer程序可见。
  5.         Dim SurferApp As Object
  6.         Set SurferApp = CreateObject("Surfer.Application")
  7.         SurferApp.Visible = True

  8. '声明场景为对象。新建场景文件。
  9.         Dim Plot As Object
  10.         Set Plot = SurferApp.Documents.Add

  11. '设置输入、输出文件路径。输入数据文件DataFile,输出格网文件OutGrid。
  12. '输入断层线文件Faultfile,白化文件BlankFile,输出空白格网文件BlankedGrid 。
  13.         DataFile = SurferApp.Path + "\samples\demogrid.dat"
  14.         OutGrid = SurferApp.Path + "\samples\demofault.grd"
  15.         Faultfile = SurferApp.Path + "\samples\demoslice.bln"
  16.         BlankFile = SurferApp.Path + "\samples\demorect.bln"
  17.         BlankedGrid = SurferApp.Path + "\samples\demoblanked.grd"

  18. '数据化算法:最小曲率法。行=200,列=200。不显示网格报告。断层文件名"Faultfile",输出文件名"OutGrid"。
  19.         SurferApp.GridData (DataFile:=DataFile, Algorithm:= srfMinCurvature, _
  20.         NumRows:=200, NumCols:=200, ShowReport:=False, FaultFileName:=Faultfile, OutGrid:=OutGrid)

  21. '白化格网文件。(输入格网文件名"OutGrid",白化文件名"BlankFile",输出白化网格文件名"BlankedGrid")。
  22.         SurferApp.GridBlank (InGrid:=OutGrid, BlankFile:=BlankFile, Outgrid:=BlankedGrid)

  23. '声明图像为对象。设置等高线图为图形,输入格网文件"BlankedGrid"。
  24.         Dim MapFrame As Object
  25.         Set MapFrame = Plot.Shapes.AddContourMap(GridFileName:=BlankedGrid)

  26. '改变图形范围(X极小、极大值;Y极小、极大值)。图形比例尺,X长度6,Y长度4。)
  27.         MapFrame.SetLimits (xMin:=0.5, xMax:=4.5, yMin:=0.5, yMax:=3.5)
  28.         MapFrame.xLength=6
  29.         MapFrame.yLength=4

  30. '声明等值线图为对象,将其设为图形第1图层,更名为"Topography Contour Map"。
  31.         Dim ContourLayer As Object
  32.         Set ContourLayer = MapFrame.Overlays(1)
  33.         ContourLayer.Name = "Topography Contour Map"

  34. '高平滑处理。
  35.         ContourLayer.SmoothContours = srfConSmoothHigh

  36. '断层线(Red)红色,线宽0.05。<font color="Red">线型"Dash Dot Dot"(线型参数不可用,删除)</font>。
  37.         ContourLayer.FaultLine.ForeColorRGBA.Color = srfColorRed
  38.         ContourLayer.FaultLine.Width = 0.05


  39. '白化区域填充青色(Cyan),不透明度20%,纯色。
  40.         ContourLayer.BlankFill.ForeColorRGBA.Color = srfColorCyan
  41.         ContourLayer.BlankFill.ForeColorRGBA.Opacity = 20
  42.         ContourLayer.BlankFill.Pattern = "Solid"
  43. '白化区线条(Brown)棕色,纯色,线宽0.02。
  44.         ContourLayer.BlankLine.ForeColorRGBA.Color = srfColorBrown
  45.         ContourLayer.BlankLine.Style = "Solid"
  46.         ContourLayer.BlankLine.Width = 0.02

  47. '高级分层方法。
  48.                 ContourLayer.LevelMethod = SrfConLevelMethodAdvanced(1)

  49. '填充等值线。加载色谱预设颜色"Rainbow"。
  50.         ContourLayer.FillContours = True
  51.         ContourLayer.FillForegroundColorMap.LoadPreset("Rainbow")

  52. '颜色数据限制范围(40~100)。
  53.                 ContourLayer.FillForegroundColorMap.SetDataLimits (DataMin:=40, DataMax:=100)

  54.         '设置锚点比例位置。设置锚点颜色。
  55.                 Dim Positions(3) As Double
  56.                 Positions(0)=0.0
  57.                 Positions(1)=0.3
  58.                 Positions(2)=0.6
  59.                 Positions(3)=1.0

  60.                 Dim Colors(3) As Long
  61.                 Colors(0)=srfColorBlack
  62.                 Colors(1)=srfColorOrange
  63.                 Colors(2)=srfColorCyan
  64.                 Colors(3)=srfColorYellow

  65.                 ContourLayer.FillForegroundColorMap.SetNodes(Positions:=Positions, Colors:=Colors)

  66.         '色谱颠倒、逆转。
  67.                 ContourLayer.FillForegroundColorMap.Reverse


  68. '设置标注属性。曲率公差8,标注到标注间距0.25,标注到边界距离1.5。
  69. '标注格式固定型,保留小数点后2位。标注方向向上,字体"Arial",字号8。
  70.         ContourLayer.LabelTolerance = 8
  71.         ContourLayer.LabelLabelDist = 0.25
  72.         ContourLayer.LabelEdgeDist = 1.5
  73.         ContourLayer.LabelFormat.Type=srfLabFixed
  74.         ContourLayer.LabelFormat.NumDigits = 2
  75.         ContourLayer.OrientLabelsUphill = True
  76.         ContourLayer.LabelFont.Face = "Arial"
  77.         ContourLayer.LabelFont.Size = 8

  78. '显示比色刻度尺。
  79.         ContourLayer.ShowColorScale=True

  80. '声明比色刻度尺为对象,标题"Contours Elevation"。
  81.         Dim DiscreteColorScale As Object
  82.         Set DiscreteColorScale = ContourLayer.ColorScale
  83.         DiscreteColorScale.Title = "Contours Elevation"

  84. '等高线输出为DXF文件,路径:SurferApp.Path+"\Samples\Contours.dxf"。
  85.         ContourLayer.ExportContours(FileName:=SurferApp.Path+"\Samples\Contours.dxf", Format:=srfConFormatDXF)

  86. '等值线左上角图纸坐标(7,0.5)。图层不透明度50%。
  87.         MapFrame.Top=7
  88.         MapFrame.Left=0.5
  89.         ContourLayer.Opacity = 50

  90. End Sub
复制代码


等值线地图.ContourMap.bas

4.12 KB, 下载次数: 2, 下载积分: 金钱 -5

密码修改失败请联系微信:mofangbao

新浪微博达人勋

 楼主| 发表于 2017-4-11 11:03:42 | 显示全部楼层
本帖最后由 大老鹰 于 2017-4-11 11:55 编辑
  1. Sub Main
  2. Debug.Clear

  3. '源代码来自Surfer13自带样本库,老鹰进行了中文标注。边译边学,毗漏难免,欢迎交流指正。
  4. '设置Surfer程序为创建对象。声明文档为对象。设置Surfer程序可见。
  5.         Dim SurferApp As Object
  6.         Set SurferApp = CreateObject("Surfer.Application")
  7.         SurferApp.Visible = True

  8. '声明场景为对象。新建场景文件。
  9.         Dim Plot As Object
  10.         Set Plot = SurferApp.Documents.Add

  11. '声明图形为对象。
  12.         Dim MapFrame As Object

  13. '创建等值线地图,文件路径:SurferApp.Path + "\samples\demogrid.grd。
  14.         Set MapFrame = Plot.Shapes.AddContourMap(GridFileName:=SurferApp.Path + "\samples\demogrid.grd")

  15. '声明等值线图为对象,将其设为图形第1图层。
  16.         Dim ContourLayer As Object
  17.         Set ContourLayer = MapFrame.Overlays(1)

  18. '分层方法:高级设置。
  19.         ContourLayer.LevelMethod = SrfConLevelMethodAdvanced

  20. '填充等值线。
  21.         ContourLayer.FillContours = True

  22.     '预设色谱"Terrain"填充等值线。纯色。填充透明。
  23.                 ContourLayer.FillForegroundColorMap.LoadPreset("Terrain")
  24.                 ContourLayer.FillPattern = "Solid"
  25.                 ContourLayer.FillTransparent = True

  26.         '声明锚点为双精度数值,设定锚点比例位置为:0,0.3,0.6,1.0。
  27.                 Dim Positions(3) As Double
  28.                 Positions(0)=0.0
  29.                 Positions(1)=0.3
  30.                 Positions(2)=0.6
  31.                 Positions(3)=1.0
  32.     '声明颜色为长整型,设定对应锚点颜色为:Orange,Cyan,Green,Black。
  33.                 Dim Colors(3) As Long
  34.                 Colors(0)=srfColorOrange
  35.                 Colors(1)=srfColorCyan
  36.                 Colors(2)=srfColorGreen
  37.                 Colors(3)=srfColorBlack

  38.                 ContourLayer.FillForegroundColorMap.SetNodes(Positions:=Positions, Colors:=Colors)

  39.         '等值线层级填充参数解释。ContourMap.ApplyFillToLevels(1, 1, 0),
  40.     '第1个数"1"表示第1层就开始彩色填充,数值可修改;
  41.     '第2个数"1"表示开启彩色连续填充,"0"表示关闭;
  42.     '第3个数"1"表示开启相间填充,"0"表示关闭。
  43.                 ContourLayer.ApplyFillToLevels(1, 1, 0)

  44. '设置层级属性。
  45.         '第4层等值线(Magenta)品红,宽0.03;该层色带填充(Green)绿色。
  46.                 ContourLayer.Levels(4).Line.ForeColorRGBA.Color = srfColorMagenta
  47.                 ContourLayer.Levels(4).Line.Width = 0.03
  48.                 ContourLayer.Levels(4).Fill.ForeColorRGBA.Color = srfColorGreen
  49.     '第8层等值线(Pink)粉红,宽0.05;该层色带填充(Yellow)黄色。
  50.                 ContourLayer.Levels(8).Line.ForeColorRGBA.Color = srfColorPink
  51.                 ContourLayer.Levels(8).Line.Width = 0.05
  52.                 ContourLayer.Levels(8).Fill.ForeColorRGBA.Color = srfColorYellow

  53. '设置标注属性。
  54.         '第1层开始显示,连续相间标注。
  55.                 ContourLayer.Levels.SetLabelFrequency(FirstIndex:=1, NumberToSet:=1, NumberToSkip:=1)

  56. '设置刻线。
  57.         '第1层开始显示,连续相间设置。
  58.                 ContourLayer.Levels.SetHachFrequency(FirstIndex:=1, NumberToSet:=1, NumberToSkip:=1)

  59.         '关闭"仅封闭等值线设置刻线",刻线朝山下(示坡线),刻线长0.05。
  60.                 ContourLayer.HachClosedOnly = False
  61.                 ContourLayer.HachDirection = srfConHachDownhill
  62.                 ContourLayer.HachLength = 0.05

  63. '保存设置为层级线文件,路径:SurferApp.Path+"\Samples\Example1.lvl"。
  64.         ContourLayer.Levels.SaveFile(FileName:=SurferApp.Path+"\Samples\Example1.lvl")

  65. '显示比色刻度尺。
  66.         ContourLayer.ShowColorScale=True

  67. End Sub
复制代码


等值线地图高级模式.ContourMap_Advanced.BAS

2.93 KB, 下载次数: 2, 下载积分: 金钱 -5

密码修改失败请联系微信:mofangbao

新浪微博达人勋

 楼主| 发表于 2017-4-11 13:25:19 | 显示全部楼层
  1. Sub Main
  2. Debug.Clear

  3. '源代码来自Surfer13自带样本库,老鹰进行了中文标注。边译边学,毗漏难免,欢迎交流指正。
  4. '设置Surfer程序为创建对象。声明文档为对象。设置Surfer程序可见。
  5.         Dim SurferApp As Object
  6.         Set SurferApp = CreateObject("Surfer.Application")
  7.         SurferApp.Visible = True

  8. '声明场景为对象。新建场景文件。
  9.         Dim Plot As Object
  10.         Set Plot = SurferApp.Documents.Add

  11. '声明图形为对象。
  12.         Dim MapFrame As Object

  13. '添加等值线图,文件路径:SurferApp.Path + "\samples\VOC_Concentration_LogAsLinear.grd"。
  14.         Set MapFrame = Plot.Shapes.AddContourMap(GridFileName:=SurferApp.Path + "\samples\VOC_Concentration_LogAsLinear.grd")

  15. '声明等值线图为对象,将其设为图形第1图层。
  16.         Dim ContourLayer As Object
  17.         Set ContourLayer = MapFrame.Overlays(1)

  18. '分层方法:对数设置。
  19.         ContourLayer.LevelMethod = SrfConLevelMethodLogarithmic

  20. '显示并设置等值线极值,十倍率辅助层次。
  21.         Debug.Print ContourLayer.LevelMinimum
  22.         Debug.Print ContourLayer.LevelMaximum
  23.         Debug.Print ContourLayer.LevelsInDecade

  24.         ContourLayer.SetLogarithmicLevels(Min:=ContourLayer.LevelMinimum, Max:=ContourLayer.LevelMaximum, LevelsInDecade:=9)

  25. '填充等值线。加载预设色谱"Rainbow3"。
  26.         ContourLayer.FillContours = True
  27.         ContourLayer.FillForegroundColorMap.LoadPreset("Rainbow3")

  28. '使用数据限制。
  29.         Zmin = ContourLayer.Grid.zMin
  30.         Zmax = ContourLayer.Grid.zMax
  31.         ContourLayer.FillForegroundColorMap.SetDataLimits(zMin, zMax)

  32. '设置对数显示比色刻度尺。
  33.          ContourLayer.FillForegroundColorMap.ScalingMethod = srfColorScalingLog

  34. '显示比色刻度尺颜色。
  35.         ContourLayer.ShowColorScale=True

  36. '主要等值线(Red)红色。次要等值线(Pink)粉色。
  37.         ContourLayer.MajorLine.ForeColorRGBA.Color = srfColorRed
  38.         ContourLayer.MinorLine.ForeColorRGBA.Color = srfColorPink

  39. '不显示主要等值线标注。显示次要等值线标注
  40.         ContourLayer.ShowMajorLabels = False
  41.         ContourLayer.ShowMinorLabels = True

  42. '标注字体"Times New Roman"。
  43.         ContourLayer.LabelFont.Face = "Times New Roman"

  44. '5位标注有效显示数字。
  45.         ContourLayer.LabelFormat.NumDigits = 5

  46. '字头向上。
  47.         ContourLayer.OrientLabelsUphill = True

  48. End Sub
复制代码


等值线地图对数模式.ContourMap_Logarithmic.BAS

2.06 KB, 下载次数: 2, 下载积分: 金钱 -5

密码修改失败请联系微信:mofangbao

新浪微博达人勋

 楼主| 发表于 2017-4-11 13:36:25 | 显示全部楼层
  1. Sub Main
  2. Debug.Clear

  3. '源代码来自Surfer13自带样本库,老鹰进行了中文标注。边译边学,毗漏难免,欢迎交流指正。
  4. '设置Surfer程序为创建对象。声明文档为对象。设置Surfer程序可见。
  5.         Dim SurferApp As Object
  6.         Set SurferApp = CreateObject("Surfer.Application")
  7.         SurferApp.Visible = True

  8. '声明场景为对象。新建场景文件。
  9.         Dim Plot As Object
  10.         Set Plot = SurferApp.Documents.Add

  11. '声明图形为对象。
  12.         Dim MapFrame As Object

  13. '创建等值线地图,文件路径:SurferApp.Path + "\samples\demogrid.grd。
  14.         Set MapFrame = Plot.Shapes.AddContourMap(GridFileName:=SurferApp.Path + "\samples\demogrid.grd")

  15. '声明等值线图为对象,将其设为图形第1图层。
  16.         Dim ContourLayer As Object
  17.         Set ContourLayer = MapFrame.Overlays(1)

  18. '分层方法:简单设置。
  19.         ContourLayer.LevelMethod = SrfConLevelMethodSimple

  20. '显示设定等值线极值(25,100),等值距4。
  21.         Debug.Print ContourLayer.LevelMinimum
  22.         Debug.Print ContourLayer.LevelMaximum
  23.         Debug.Print ContourLayer.LevelInterval

  24.     ContourLayer.SetSimpleLevels(Min:=25, Max:=100, Interval:=4)

  25. '主要等值线间距2。填充等值线。
  26.         ContourLayer.LevelMajorInterval = 2
  27.         ContourLayer.FillContours = True

  28. '填充预设色谱模式"Rainbow3"。
  29.         ContourLayer.FillForegroundColorMap.LoadPreset("Rainbow3")

  30. '显示比色刻度尺。
  31.         ContourLayer.ShowColorScale=True

  32. '主要等值线(Red)红色,次要等值线粉色(Pink)。
  33.         ContourLayer.MajorLine.ForeColorRGBA.Color = srfColorRed
  34.         ContourLayer.MinorLine.ForeColorRGBA.Color = srfColorPink

  35. '不显示主要等值线标注,显示次要等值线标注。
  36.         ContourLayer.ShowMajorLabels = False
  37.         ContourLayer.ShowMinorLabels = True

  38. '标注字体"Times New Roman"。
  39.         ContourLayer.LabelFont.Face = "Times New Roman"

  40. '标注保留5位有效数字。
  41.         ContourLayer.LabelFormat.NumDigits = 5

  42. '字头朝上。
  43.         ContourLayer.OrientLabelsUphill = True

  44. End Sub
复制代码


等值线地图简单模式.ContourMap_Simple.BAS

1.78 KB, 下载次数: 2, 下载积分: 金钱 -5

密码修改失败请联系微信:mofangbao

新浪微博达人勋

 楼主| 发表于 2017-4-11 15:55:59 | 显示全部楼层
  1. Sub Main

  2. '源代码来自Surfer13自带样本库,老鹰进行了中文标注。边译边学,毗漏难免,欢迎交流指正。
  3. '设置Surfer程序为创建对象。声明文档为对象。设置Surfer程序可见。
  4. '声明场景为对象。
  5.         Dim SurferApp As Object
  6.         Set SurferApp = CreateObject("Surfer.Application")
  7.         SurferApp.Visible = True
  8.         Dim Plot As Object

  9. '光达文件路径:"C:\libLAS_1.2.las"
  10.         LASFile = "C:\libLAS_1.2.las"

  11. '设置工作表打开光达数据。
  12. '空间过滤选项,X最小1440000,X最大1444999。清除其它分类,只导入第1类。
  13.         Set Wks = SurferApp.Documents.Open (FileName:= LASFile, _
  14.         Options:="AcceptXMin=1440000, AcceptXMax=1444999, AcceptNthPoint = 5, AcceptNoClasses =0, AcceptClass[1]=1" )

  15. End Sub
复制代码
注意:将文件 libLAS_1.2.las 放到C盘下

导入光达数据.DataOpen_LiDAR.BAS

700 Bytes, 下载次数: 2, 下载积分: 金钱 -5

libLAS_1.2.las

9.49 MB, 下载次数: 2, 下载积分: 金钱 -5

密码修改失败请联系微信:mofangbao

新浪微博达人勋

 楼主| 发表于 2017-4-11 15:57:12 | 显示全部楼层
  1. Sub Main

  2. '源代码来自Surfer13自带样本库,老鹰进行了中文标注。边译边学,毗漏难免,欢迎交流指正。
  3. '设置Surfer程序为创建对象。声明文档为对象。设置Surfer程序可见。
  4.         Dim SurferApp As Object
  5.         Set SurferApp = CreateObject("Surfer.Application")
  6.         SurferApp.Visible = True

  7. '声明场景为对象。新建场景文件。
  8.         Dim Plot As Object
  9.         Set Plot = SurferApp.Documents.Add

  10. '声明图形为对象。
  11.         Dim MapFrame As Object

  12. '创建等值线地图,文件路径:SurferApp.Path+"\samples\Helens2.grd"。
  13.         Set MapFrame = Plot.Shapes.AddContourMap(GridFileName:=SurferApp.Path+"\samples\Helens2.grd")

  14. '声明等值线图为对象,将其设为图形第1图层。
  15.         Dim ContourLayer As Object
  16.         Set ContourLayer = MapFrame.Overlays(1)

  17. '显示图形原坐标系统。
  18.         Debug.Print "Original Coordinate System: " + MapFrame.CoordinateSystem

  19. '设定图层坐标系统为"North America NAD27 UTM zone 10N"。
  20.         ContourLayer.CoordinateSystem = "North America NAD27 UTM zone 10N"

  21. '改变图形坐标系统为"World Geodetic System 1984"。
  22.         MapFrame.CoordinateSystem = "World Geodetic System 1984"

  23. '加载整个新格网文件,若设置为"True"则只加载引导文件。路径:SurferApp.Path+"\samples\colorado.grd"。
  24.         Set grid = SurferApp.NewGrid
  25.         grid.LoadFile(SurferApp.Path+"\samples\colorado.grd", False)

  26.         '设定格网坐标系统"World Geodetic System 1984"。
  27.         '保存路径:SurferApp.Path+"\samples\colorado_wgs_84.grd",格式Surfer7网格。
  28.         grid.CoordinateSystem = "World Geodetic System 1984"
  29.         grid.SaveFile(FileName:=SurferApp.Path+"\samples\colorado_wgs_84.grd", Format:=srfGridFmtS7)

  30. End Sub
复制代码


坐标系统.CoordinateSystems.bas

1.52 KB, 下载次数: 2, 下载积分: 金钱 -5

密码修改失败请联系微信:mofangbao

新浪微博达人勋

发表于 2017-4-13 10:54:45 | 显示全部楼层
好东西,感谢楼主
密码修改失败请联系微信:mofangbao

新浪微博达人勋

 楼主| 发表于 2017-4-13 12:52:26 | 显示全部楼层
  1. Sub Main

  2. '源代码来自Surfer13自带样本库,老鹰进行了中文标注。边译边学,毗漏难免,欢迎交流指正。
  3. '设置Surfer程序为创建对象。声明文档为对象。设置Surfer程序可见。
  4.         Dim SurferApp As Object
  5.         Set SurferApp = CreateObject("Surfer.Application")
  6.         SurferApp.Visible = True

  7. '声明场景为对象。新建场景文件。
  8.         Dim Plot As Object
  9.         Set Plot = SurferApp.Documents.Add

  10. '创建影像图为图形,文件路径:SurferApp.Path+"\samples\demogrid.grd"
  11.         Set MapFrame = Plot.Shapes.AddImageMap(SurferApp.Path+"\samples\demogrid.grd")

  12. '声明影像图层为对象,将其设为图形第1图层。
  13.         Dim ImageLayer As Object
  14.         Set ImageLayer = MapFrame.Overlays(1)

  15. '填充等值线。加载预设色谱"Rainbow"。
  16.         ContourLayer.FillContours = True
  17.         ContourLayer.FillForegroundColorMap.LoadPreset("Rainbow")

  18. '显示比色刻度尺。声明比色刻度尺为对象。
  19.         ContourLayer.ShowColorScale=True
  20.          Dim DiscreteColorScale As Object

  21. '设置离散刻度尺。
  22.         Set DiscreteColorScale = ContourLayer.ColorScale

  23. '刻度尺线框(NavyBlue)海军蓝,字号12,加粗。
  24.         DiscreteColorScale.FrameLine.ForeColorRGBA.Color = srfColorNavyBlue
  25.         DiscreteColorScale.LabelFont.Size = 12
  26.         DiscreteColorScale.LabelFont.Bold = True

  27. '标注格式固定型,保留小数点后2位,首行1,频率2。
  28.         DiscreteColorScale.LabelFormat.Type=srfLabFixed
  29.         DiscreteColorScale.LabelFormat.NumDigits = 2
  30.         DiscreteColorScale.FirstLabel = 1
  31.         DiscreteColorScale.LabelFrequency = 2

  32. '标注标题"Contours Elevation"。字体(Red)红色。左侧。
  33.                 DiscreteColorScale.Title = "Contours Elevation"
  34.                 DiscreteColorScale.TitleFont.ForeColorRGBA.Color = srfColorRed
  35.                 DiscreteColorScale.TitlePosition = srfColorScaleTitlePositionLeft

  36.         '水平偏移0.13,垂直偏移1.22。旋转90。
  37.                 DiscreteColorScale.TitleOffsetHorizontal = 0.13
  38.                 DiscreteColorScale.TitleOffsetVertical = 1.22
  39.                 DiscreteColorScale.TitleAngle = 90

  40. '比色刻度尺左上角页面坐标(7.5,7.5)。
  41.         DiscreteColorScale.Left = 7.5
  42.         DiscreteColorScale.Top = 7.5

  43. End Sub
复制代码


单色刻度尺.DiscreteColorScale.bas

1.9 KB, 下载次数: 2, 下载积分: 金钱 -5

密码修改失败请联系微信:mofangbao

新浪微博达人勋

 楼主| 发表于 2017-4-13 12:53:20 | 显示全部楼层
  1. Sub Main

  2. '源代码来自Surfer13自带样本库,老鹰进行了中文标注。边译边学,毗漏难免,欢迎交流指正。
  3. '设置Surfer程序为创建对象。声明文档为对象。设置Surfer程序可见。
  4.         Dim SurferApp As Object
  5.         Set SurferApp = CreateObject("Surfer.Application")
  6.         SurferApp.Visible = True

  7. '声明场景为对象。新建场景文件。
  8.         Dim Plot As Object
  9.         Set Plot = SurferApp.Documents.Add

  10. '声明文本为对象。
  11.     Dim Text As Object
  12. '创建文本1"This is my text",坐标(0.5,3)。字号18,加粗,字体"Italic"。
  13.         Set Text1 = Plot.Shapes.AddText(x:=0.5, y:=3, Text:="This is my text")
  14.         Text1.Font.Size = 18
  15.         Text1.Font.Bold = True
  16.         Text1.Font.Italic = True
  17. '创建文本2"This is my text"回车符与换行符连接在一起"This is my text on the second line",坐标(2,0.5)。
  18. '文本水平居中,垂直居中。字号16。(Green)绿色。
  19.     Set Text2 = Plot.Shapes.AddText(x:=2, y:=0.5, Text:="This is my text"& vbCrLf & "This is my text on the second line")
  20.         Text2.Font.HAlign = srfTACenter
  21.         Text2.Font.VAlign = srfTAVCenter
  22.         Text2.Font.Size=16
  23.         Text2.Font.ForeColorRGBA.Color=srfColorGreen

  24. '声明符号为对象。创建符号,坐标(2,2),第12号符,大小0.4,填充(Magenta)品红,线框(Magenta)品红。
  25.         Dim Symbol As Object
  26.         Set Symbol = Plot.Shapes.AddSymbol(x:=2, y:=2)
  27.         Symbol.Marker.Index = 12
  28.         Symbol.Marker.Size = 0.4
  29.         Symbol.Marker.FillColorRGBA.Color=srfColorMagenta
  30.         Symbol.Marker.LineColorRGBA.Color = srfColorMagenta

  31. '创建矩形,四边坐标(0.5,7.5,1.5,10.5)。线框(Purple)紫色,线宽0.015。
  32. '纯色填充,背景(LightYellow)浅黄,前景(Green)绿。
  33.         Set Rectangle=Plot.Shapes.AddRectangle(Left:=0.5, Bottom:=7.5, Right:=1.5, Top:=10.5)
  34.         Rectangle.Line.ForeColorRGBA.Color=srfColorPurple
  35.         Rectangle.Line.Width = 0.015
  36.         Rectangle.Fill.Pattern="Solid"
  37.         Rectangle.Fill.BackColorRGBA.Color = srfColorLightYellow
  38.         Rectangle.Fill.ForeColorRGBA.Color = srfColorGreen

  39. '创建圆角矩形。四边坐标(7,9,8,10.5),圆角X半径0.3,Y半径0.3。
  40. '线框(Magenta)品红,线宽0.03。填充图案(Swamp)沼泽,(Green)绿色。
  41.         Set RoundedRectangle = Plot.Shapes.AddRectangle(Left:=7, Bottom:=9, Right:=8, Top:=10.5, xRadius:=0.3, yRadius:=0.3)
  42.         RoundedRectangle.Line.ForeColorRGBA.Color = srfColorMagenta
  43.         RoundedRectangle.Line.Width = 0.03
  44.         RoundedRectangle.Fill.Pattern = "Swamp"
  45.         RoundedRectangle.Fill.ForeColorRGBA.Color = srfColorForestGreen

  46. '创建椭圆,四至坐标(6.5,5.5,8,8),填充(Solid)纯色,(Blue)蓝色。
  47.     Set Ellipse = Plot.Shapes.AddEllipse(Left:=6.5, Bottom:=5.5, Right:=8, Top:=8)
  48.     Ellipse.Fill.Pattern = "Solid"
  49.         Ellipse.Fill.ForeColorRGBA.Color = srfColorBlue

  50. '创建单段线,起点(2,8.5),终点(3.5,10.5)。紫色,线宽0.04,连续线段。
  51.     Set Polyline = Plot.Shapes.AddLine(xBeg:=2, yBeg:=8.5, xEnd:=3.5, yEnd:=10.5)
  52.     Polyline.Line.ForeColorRGBA.Color = srfColorPurple
  53.     Polyline.Line.Width = 0.04
  54.     Polyline.Line.Style = "Solid"

  55. '声明多段线拐点坐标组为双精度数值。坐标(4,10.5)(6.5,10)(5,9)(6,8.5)。
  56.         Dim PolyLineArray(7) As Double
  57.         PolyLineArray(0) = 4:        PolyLineArray(1) = 10.5
  58.         PolyLineArray(2) = 6.5:        PolyLineArray(3) = 10
  59.         PolyLineArray(4) = 5:        PolyLineArray(5) = 9
  60.         PolyLineArray(6) = 6:        PolyLineArray(7) = 8.5

  61.         '创建贝叶斯曲线,红色,0.03,连续线段。
  62.         Set Spline = Plot.Shapes.AddPolyLine2(PolyLineArray, srfPTBezier)
  63.         Spline.Line.ForeColorRGBA.Color = srfColorRed
  64.         Spline.Line.Width = 0.03
  65.         Spline.Line.Style = "Solid"
  66.     '声明曲线顶点坐标为双精度数值。
  67.         Dim Vertices() As Double
  68.         Vertices() = Spline.Vertices

  69.         '创建多段线,蓝色。声明多段线顶点坐标为双精度数值。
  70.         Set PolyLine = Plot.Shapes.AddPolyLine2(PolyLineArray, srfPTPolyline)
  71.         PolyLine.Line.ForeColorRGBA.Color = srfColorBlue
  72.         Dim Vertices2() As Double
  73.         Vertices2() = PolyLine.Vertices

  74.    '声明坐标数组为双精度数值。(4,4)(8,1)(5.5,0.5)。
  75.         Dim Coordinates(5) As Double
  76.         Coordinates(0) = 4: Coordinates(1) = 4
  77.         Coordinates(2) = 8: Coordinates(3) = 1
  78.         Coordinates(4) = 5.5: Coordinates(5) = 0.5
  79.    '根据上述坐标创立多边形。现框(Blue)蓝色,线宽0.05。纯色填充,透明,(Orange)橘黄。
  80.         Set Polygon = Plot.Shapes.AddPolygon(Coordinates)
  81.         Polygon.Line.ForeColorRGBA.Color = srfColorBlue
  82.         Polygon.Line.Width = 0.05
  83.         Polygon.Fill.Pattern = "Solid"
  84.         Polygon.Fill.Transparent = True
  85.         Polygon.Fill.ForeColorRGBA.Color = srfColorOrange

  86. '声明多边形顶点坐标为双精度数值。12个拐点坐标如下。
  87.         Dim PgonCoordinates(23) As Double
  88.         PgonCoordinates(0) = 3.44: PgonCoordinates(1) = 4.06
  89.         PgonCoordinates(2) = 1.10: PgonCoordinates(3) = 6.39
  90.         PgonCoordinates(4) = 3.44: PgonCoordinates(5) = 8.73
  91.         PgonCoordinates(6) = 5.75: PgonCoordinates(7) = 6.39
  92.         PgonCoordinates(8) = 3.36: PgonCoordinates(9) = 8.07
  93.         PgonCoordinates(10) = 5.01: PgonCoordinates(11) = 6.42
  94.         PgonCoordinates(12) = 3.36: PgonCoordinates(13) = 4.75
  95.         PgonCoordinates(14) = 1.71: PgonCoordinates(15) = 6.42
  96.         PgonCoordinates(16) = 1.71: PgonCoordinates(17) = 8.07
  97.         PgonCoordinates(18) = 5.01: PgonCoordinates(19) = 8.07
  98.         PgonCoordinates(20) = 5.01: PgonCoordinates(21) = 4.75
  99.         PgonCoordinates(22) = 1.71: PgonCoordinates(23) = 4.75
  100.     '多边形0由前面四点坐标构成,多边形1由中间四点坐标构成,多边形2由最后四点坐标构成。
  101.         Dim NumPolygons(2) As Long
  102.         NumPolygons(0) = 4
  103.         NumPolygons(1) = 4
  104.         NumPolygons(2) = 4
  105.     '设置组合多边形(顶点坐标=PgonCoordinates,多边形计数=NumPolygons)。
  106.     '(Brown)棕线,线宽0.05,纯色填充。
  107.         Set ComplexPolygon = Plot.Shapes.AddComplexPolygon(Vertices:=PgonCoordinates, PolyCounts:=NumPolygons)
  108.         ComplexPolygon.Line.ForeColorRGBA.Color = srfColorBrown
  109.         ComplexPolygon.Line.Width = 0.05
  110.         ComplexPolygon.Fill.Pattern="Solid"


  111. '创建组合对象。显示"Composite Object"。
  112.         '文本2,坐标(6.25,3.75),内容"Composite Object"。
  113.         '创建矩形,四边坐标(6,3.25,8,4.25)。
  114.         '两者选中,组合。
  115.         Debug.Print "Composite Object"
  116.         Set Text2 = Plot.Shapes.AddText(x:=6.25, y:=3.75, Text:="Composite Object")
  117.         Set Rectangle2=Plot.Shapes.AddRectangle(Left:=6, Bottom:=3.25, Right:=8, Top:=4.25)
  118.         Text2.Select
  119.         Rectangle2.Select
  120.         Set Composite = Plot.Selection.Combine

  121.         '打散组合。
  122.         Composite.BreakApart

  123. End Sub
复制代码


画图.DrawingObjects.bas

5.86 KB, 下载次数: 2, 下载积分: 金钱 -5

密码修改失败请联系微信:mofangbao

新浪微博达人勋

发表于 2017-6-24 15:45:42 | 显示全部楼层
很强大!学习了
密码修改失败请联系微信:mofangbao
您需要登录后才可以回帖 登录 | 立即注册 新浪微博登陆

本版积分规则

Copyright ©2011-2014 bbs.06climate.com All Rights Reserved.  Powered by Discuz! (京ICP-10201084)

本站信息均由会员发表,不代表气象家园立场,禁止在本站发表与国家法律相抵触言论

快速回复 返回顶部 返回列表