通过脚本摆放颜色标尺

holz · 发表于 2015-10-27 11:50:29

登录后查看更多精彩内容~

您需要登录才可以下载或查看，没有帐号？立即注册

x

本帖最后由 holz 于 2015-10-27 11:53 编辑

颜色标尺的摆放位置，手工操作当然只管用鼠标拖就是了，所见即所得么。

要通过 Automation 接口来摆放标尺，就要关注几个参数：
1、参照物，可以是页面边界、拐角、中心甚至是任意一个点，也可以是文档中的任一个对象。本例用标尺对应的原图作为参照。
2、XY坐标，在 Surfer 中，要换为 Left 和 Top 参数。
3、旋转角度，因为定位标尺可能要用到标尺本身的宽高值，而对象旋转后其本身的宽高值会改变，所以必须首先按要求设置标尺的旋转。

'======================================================================
'功能：演示颜色刻度尺的定位，通过对话框选定参数，
' 可以将颜色刻度尺放到原图的方位上。
'环境：在 Scripter 5 + Surfer 13 下测试通过。
'作者：Holz (holz@21cn.com)
'日期：2015年10月27日
'免责：有写注释的习惯。一些注释因为在编写代码过程懒得切换中文输入法，
' 直接用烂到爆的英文写了，不喜勿喷。
' Use on your own risk!
'======================================================================
Sub Main
Dim SurferApp As Object
' Run Surfer and get the handle
Set SurferApp=CreateObject("Surfer.Application")
' Make Surfer visible to check the demo on the fly
SurferApp.Visible=True
Dim Plot As Object
' Add an empty Plot window
Set Plot=SurferApp.Documents.Add
Dim MapFrame As Object
' Use the sample file for demo
Set MapFrame=Plot.Shapes.AddContourMap(SurferApp.Path+"\Samples\demogrid.grd")
Dim ContourLayer As Object
Set ContourLayer=MapFrame.Overlays(1)
' Set FillContours option to True then you can treat the fill
ContourLayer.FillContours=True
' The default level method in Surfer 13 is Advanced
' i.e. LevelMethod = srfConLevelMethodAdvanced
' set to srfConLevelMethodLogarithmic to use logarithmic scaling
ContourLayer.LevelMethod=SrfConLevelMethodSimple
' Use LoadFile(FileName) to load a Specified CLR or LVL file.
ContourLayer.FillForegroundColorMap.LoadPreset ("Rainbow")
' Show the Color scale
ContourLayer.ShowColorScale=True
Dim ConScale As Object
Set ConScale=ContourLayer.ColorScale
Dim ScalePos(7) As String
ScalePos(0)="东"
ScalePos(1)="北东"
ScalePos(2)="北"
ScalePos(3)="北西"
ScalePos(4)="西"
ScalePos(5)="南西"
ScalePos(6)="南"
ScalePos(7)="南东"
While(1)
Begin Dialog UserDialog 400,126,"设置颜色标尺参数" ' %GRID:10,7,1,1
ListBox 10,7,160,112,ScalePos(),.ListBox1
Text 200,7,160,14,"标尺与原图的距离：",.Text1
TextBox 200,28,110,14,.TextBox1
OKButton 190,91,90,21
CancelButton 310,91,70,21
End Dialog
Dim dlg As UserDialog
dlg.textbox1="0.985"
dlg.listbox1=0
' User click Cancel to exit the while loop and end this script
If Dialog(dlg)=0 Then Exit While
Dim OffPos As Single
OffPos=Val(dlg.textbox1)
' Position the color scale, 8 direction
PosScale(MapFrame, ConScale, ScalePos(dlg.listbox1),OffPos)
Wend
End Sub
Sub PosScale(MF As Object, CS As Object, O As String, A As Single)
Dim x0 As Double, y0 As Double
Dim h0 As Double, w0 As Double
Dim h1 As Double, w1 As Double
Debug.Print "将把颜色标尺放到原图的" & O & "向。自行转到 Surfer 主窗口看效果。"
Select Case O
Case "东" 'E
CS.Rotation=0
x0=MF.Left
y0=MF.Top
h0=MF.Height
w0=MF.Width
h1=CS.Height
w1=CS.Width
CS.Left=x0+w0+A
CS.Top=y0-0.5*(h0-h1)
Case "北东" 'NE
CS.Rotation=45
x0=MF.Left
y0=MF.Top
h0=MF.Height
w0=MF.Width
h1=CS.Height
w1=CS.Width
CS.Left=x0+w0-0.5*w1+A
CS.Top=y0+0.5*h1+A
Case "北" 'N
CS.Rotation=90
x0=MF.Left
y0=MF.Top
h0=MF.Height
w0=MF.Width
h1=CS.Height
w1=CS.Width
CS.Left=x0+0.5*(w0-w1)
CS.Top=y0+2.0*A
Case "北西" 'NW
CS.Rotation=135
x0=MF.Left
y0=MF.Top
h0=MF.Height
w0=MF.Width
h1=CS.Height
w1=CS.Width
CS.Left=x0-0.5*w1-A
CS.Top=y0+0.5*h1+A
Case "西" 'W
CS.Rotation=0
x0=MF.Left
y0=MF.Top
h0=MF.Height
w0=MF.Width
h1=CS.Height
w1=CS.Width
CS.Left=x0-w1-A
CS.Top=y0-0.5*(h0-h1)
Case "南西" 'SW
CS.Rotation=225
x0=MF.Left
y0=MF.Top
h0=MF.Height
w0=MF.Width
h1=CS.Height
w1=CS.Width
CS.Left=x0-0.5*w1-A
CS.Top=y0-h0+0.5*h1-A
Case "南" 'S
CS.Rotation=90
x0=MF.Left
y0=MF.Top
h0=MF.Height
w0=MF.Width
h1=CS.Height
w1=CS.Width
CS.Left=x0+0.5*(w0-w1)
CS.Top=y0-h0-A
Case "南东" 'SE
CS.Rotation=315
x0=MF.Left
y0=MF.Top
h0=MF.Height
w0=MF.Width
h1=CS.Height
w1=CS.Width
CS.Left=x0+w0-0.5*w1+A
CS.Top=y0-h0+0.5*h1-A
End Select
End Sub

'====================================================================== 
'功能：演示颜色刻度尺的定位，通过对话框选定参数， 
'      可以将颜色刻度尺放到原图的方位上。 
'环境：在 Scripter 5 + Surfer 13 下测试通过。 
'作者：Holz (<a href=\"mailto:holz@21cn.com\">holz@21cn.com</a>) 
'日期：2015年10月27日 
'免责：有写注释的习惯。一些注释因为在编写代码过程懒得切换中文输入法， 
'      直接用烂到爆的英文写了，不喜勿喷。 
'      Use on your own risk! 
'====================================================================== 
Sub Main 
        Dim SurferApp As Object 
        ' Run Surfer and get the handle 
        Set SurferApp=CreateObject("Surfer.Application") 
        ' Make Surfer visible to check the demo on the fly 
        SurferApp.Visible=True 
 
        Dim Plot As Object 
        ' Add an empty Plot window 
        Set Plot=SurferApp.Documents.Add 
 
        Dim MapFrame As Object 
        ' Use the sample file for demo 
        Set MapFrame=Plot.Shapes.AddContourMap(SurferApp.Path+"\Samples\demogrid.grd") 
        Dim ContourLayer As Object 
        Set ContourLayer=MapFrame.Overlays(1) 
        ' Set FillContours option to True then you can treat the fill 
        ContourLayer.FillContours=True 
 
        ' The default level method in Surfer 13 is Advanced 
        ' i.e. LevelMethod = srfConLevelMethodAdvanced 
        ' set to srfConLevelMethodLogarithmic to use logarithmic scaling 
        ContourLayer.LevelMethod=SrfConLevelMethodSimple 
 
        ' Use LoadFile(FileName) to load a Specified CLR or LVL file. 
        ContourLayer.FillForegroundColorMap.LoadPreset ("Rainbow") 
 
        ' Show the Color scale 
        ContourLayer.ShowColorScale=True 
        Dim ConScale As Object 
        Set ConScale=ContourLayer.ColorScale 
 
        Dim ScalePos(7) As String 
        ScalePos(0)="东" 
        ScalePos(1)="北东" 
        ScalePos(2)="北" 
        ScalePos(3)="北西" 
        ScalePos(4)="西" 
        ScalePos(5)="南西" 
        ScalePos(6)="南" 
        ScalePos(7)="南东" 
        While(1) 
                Begin Dialog UserDialog 400,126,"设置颜色标尺参数" ' %GRID:10,7,1,1 
                        ListBox 10,7,160,112,ScalePos(),.ListBox1 
                        Text 200,7,160,14,"标尺与原图的距离：",.Text1 
                        TextBox 200,28,110,14,.TextBox1 
                        OKButton 190,91,90,21 
                        CancelButton 310,91,70,21 
                End Dialog 
                Dim dlg As UserDialog 
                dlg.textbox1="0.985" 
                dlg.listbox1=0 
                ' User click Cancel to exit the while loop and end this script 
                If Dialog(dlg)=0 Then Exit While 
 
                Dim OffPos As Single 
                OffPos=Val(dlg.textbox1) 
                ' Position the color scale, 8 direction 
                PosScale(MapFrame, ConScale, ScalePos(dlg.listbox1),OffPos) 
        Wend 
End Sub 
 
Sub PosScale(MF As Object, CS As Object, O As String, A As Single) 
        Dim x0 As Double, y0 As Double 
        Dim h0 As Double, w0 As Double 
        Dim h1 As Double, w1 As Double 
 
        Debug.Print "将把颜色标尺放到原图的" & O & "向。 自行转到 Surfer 主窗口看效果。" 
 
        Select Case O 
                Case "东" 'E 
                        CS.Rotation=0 
                        x0=MF.Left 
                        y0=MF.Top 
                        h0=MF.Height 
                        w0=MF.Width 
                        h1=CS.Height 
                        w1=CS.Width 
                        CS.Left=x0+w0+A 
                        CS.Top=y0-0.5*(h0-h1) 
                Case "北东" 'NE 
                        CS.Rotation=45 
                        x0=MF.Left 
                        y0=MF.Top 
                        h0=MF.Height 
                        w0=MF.Width 
                        h1=CS.Height 
                        w1=CS.Width 
                        CS.Left=x0+w0-0.5*w1+A 
                        CS.Top=y0+0.5*h1+A 
                Case "北" 'N 
                        CS.Rotation=90 
                        x0=MF.Left 
                        y0=MF.Top 
                        h0=MF.Height 
                        w0=MF.Width 
                        h1=CS.Height 
                        w1=CS.Width 
                        CS.Left=x0+0.5*(w0-w1) 
                        CS.Top=y0+2.0*A 
                Case "北西" 'NW 
                        CS.Rotation=135 
                        x0=MF.Left 
                        y0=MF.Top 
                        h0=MF.Height 
                        w0=MF.Width 
                        h1=CS.Height 
                        w1=CS.Width 
                        CS.Left=x0-0.5*w1-A 
                        CS.Top=y0+0.5*h1+A 
                Case "西" 'W 
                        CS.Rotation=0 
                        x0=MF.Left 
                        y0=MF.Top 
                        h0=MF.Height 
                        w0=MF.Width 
                        h1=CS.Height 
                        w1=CS.Width 
                        CS.Left=x0-w1-A 
                        CS.Top=y0-0.5*(h0-h1) 
                Case "南西" 'SW 
                        CS.Rotation=225 
                        x0=MF.Left 
                        y0=MF.Top 
                        h0=MF.Height 
                        w0=MF.Width 
                        h1=CS.Height 
                        w1=CS.Width 
                        CS.Left=x0-0.5*w1-A 
                        CS.Top=y0-h0+0.5*h1-A 
                Case "南" 'S 
                        CS.Rotation=90 
                        x0=MF.Left 
                        y0=MF.Top 
                        h0=MF.Height 
                        w0=MF.Width 
                        h1=CS.Height 
                        w1=CS.Width 
                        CS.Left=x0+0.5*(w0-w1) 
                        CS.Top=y0-h0-A 
                Case "南东" 'SE 
                        CS.Rotation=315 
                        x0=MF.Left 
                        y0=MF.Top 
                        h0=MF.Height 
                        w0=MF.Width 
                        h1=CS.Height 
                        w1=CS.Width 
                        CS.Left=x0+w0-0.5*w1+A 
                        CS.Top=y0-h0+0.5*h1-A 
        End Select 
End Sub

WRNM2012 · 发表于 2015-10-28 08:43:37

学习、学习，再学习　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　

啦啦啦179 · 发表于 2015-10-29 20:56:24

习、学习，再学习　　

lp333asd · 发表于 2015-12-10 12:32:09

学习了~~路过~

vicioustars01 · 发表于 2019-1-28 14:56:33

学习了····努力中····

		自动登录	找回密码
密码			立即注册

[vbscript] 通过脚本摆放颜色标尺

登录后查看更多精彩内容~

评分