shapescollection.bas

经典的画图软件。破解版。不可多得。免费分享。

'ShapesCollection.bas illustrates the properties and methods
' of the Shapes Collection.
Sub Main
	Debug.Print "----- ShapesCollection.bas - ";Time;" -----"

	'Get existing Surfer instance, or create a new one If none exists.
	On Error Resume Next 'Turn off error reporting.
	Set surf = GetObject(,"Surfer.Application")
	If Err.Number<>0 Then
		Set surf = CreateObject("Surfer.Application")
		surf.Documents.Add(srfDocPlot)	
	End If
	On Error GoTo 0 'Turn on error reporting.
	
	surf.Visible = True
	surf.WindowState = srfWindowStateNormal
	surf.Width = 600
	surf.Height = 400

	Debug.Print "Surfer ";surf.Version

	Set plotdoc1 = surf.Documents(1)
	If plotdoc1.Type <> srfDocPlot Then plotdoc1 = surf.Documents.Add
 	Set plotwin1 = surf.Windows(1)

	With plotdoc1.PageSetup
		.Orientation = srfLandscape
		.Height = 8.5
		.Width = 11
	End With
	plotwin1.Zoom(srfZoomPage)
	path1 = surf.Path+"\samples\"


	'============================
	'Shapes Collection Properties
	'============================
	Set shapes1 = plotdoc1.Shapes
	If shapes1.Count >0 Then
		shapes1.SelectAll
		plotdoc1.Selection.Delete
	End If

	'-------------------------------------------------------
	'The Application Property returns the application object.
	'-------------------------------------------------------
	Debug.Print "Shapes Collection Aapplication: ";shapes1.Application

	'------------------------------------------------------------------
	'The Parent Property returns the shapes collection parent. (object)
	'------------------------------------------------------------------
	Debug.Print "Shapes Collection Parent: ";shapes1.Parent

	'--------------------------------------------------------
	'The Count Property returns the number of items in the
	' shapes collection (integer).
	'--------------------------------------------------------
	Debug.Print "The Shapes Collection has";shapes1.Count;" items."

	'========================
	'ShapesCollection Methods
	'========================---------------------------------
	'The AddBaseMap method creates a new base map.  It returns
	' a MapFrame object.
	'---------------------------------------------------------
	surf.Caption = "Surfer "+surf.Version
	AppActivate "Surfer "+surf.Version
	Debug.Print "AddBaseMap"
	shapes1.AddText(1,1,"AddBaseMap").Font.Size = 40
	Set mapframe1 = shapes1.AddBaseMap(path1+"ca.gsb")
	Set base1 = mapframe1.Overlays("Base")
	base1.Fill.ForeColor = srfColorPaleYellow
	base1.Fill.Pattern = "Solid"
	mapframe1.BackgroundFill.ForeColor = srfColorBabyBlue
	mapframe1.BackgroundFill.Pattern = "Solid"
	For Each Axis In mapframe1.Axes
		Axis.ShowLabels = False
		Axis.MajorTickType = srfTickNone
		Axis.MinorTickType = srfTickNone
	Next Axis
	With mapframe1
		.xLength = 2.5
		.yLength = 2
		.Top = 8.25
		.Left = 0.25
		.Axes("Bottom Axis").Title = "Base"
		.Axes("Bottom Axis").TitleFont.Size = 25
	End With

	Wait 1
	shapes1("Text").Delete

	'---------------------------------------------------------
	'The AddClassedPostMap method adds a new classed post map.
	' It returns a MapFrame object.
	'---------------------------------------------------------
	Debug.Print "AddClassedPostMap"
	shapes1.AddText(1,1,"AddClassedPostMap").Font.Size = 40
	Set mapframe2 = shapes1.AddClassedPostMap(path1+"demogrid.dat", _
		xCol:=1, yCol:=2, zCol:=3)
	mapframe2.BackgroundFill.ForeColor = srfColorWhite
	mapframe2.BackgroundFill.Pattern = "Solid"
	Set clpost1 = mapframe2.Overlays("Classed Post")
	clpost1.ShowLegend = False
	For i = 1 To 5
		With clpost1.BinSymbol(i)
			.Set = "GSI Default Symbols"
			.Index = 12
			.Size = 0.1
		End With
	Next i
	clpost1.BinSymbol(1).Color = srfColorPastelBlue
	clpost1.BinSymbol(2).Color = srfColorGrassGreen
	clpost1.BinSymbol(3).Color = srfColorDeepYellow
	clpost1.BinSymbol(4).Color = srfColorLightOrange
	clpost1.BinSymbol(5).Color = srfColorBrickRed
	For Each Axis In mapframe2.Axes
		Axis.ShowLabels = False
		Axis.MajorTickType = srfTickNone
		Axis.MinorTickType = srfTickNone
	Next Axis
	With mapframe2
		.xLength = 2.5
		.yLength = 2
		.Top = 8.25
		.Left = 2.9
		.Axes("Bottom Axis").Title = "Classed Post"
		.Axes("Bottom Axis").TitleFont.Size = 25
	End With

	Wait 2
	shapes1("Text").Delete

	'---------------------------------------------------------
	'The AddContourMap method adds a contour map.  It returns
	' a MapFrameObject.
	'---------------------------------------------------------
	Debug.Print "AddContourMap"
	shapes1.AddText(1,1,"AddContourMap").Font.Size = 40
	Set mapframe3 = 	shapes1.AddContourMap(path1+"demogrid.grd")
	Set contours1 = mapframe3.Overlays("Contours")
	contours1.ShowColorScale = False
	contours1.FillContours = True

	For Each Axis In mapframe3.Axes
		Axis.ShowLabels = False
		Axis.MajorTickType = srfTickNone
		Axis.MinorTickType = srfTickNone
	Next Axis
	With mapframe3
		.xLength = 2.5
		.yLength = 2
		.Top = 8.25
		.Left = 5.6
		.Axes("Bottom Axis").Title = "Contours"
		.Axes("Bottom Axis").TitleFont.Size = 25
	End With

	Wait 2
	shapes1("Text").Delete

	'-------------------------------------------------
	'The AddImageMap method creates a new image map.
	' It returns a MapFrame object.
	'-------------------------------------------------
	Debug.Print "AddImageMap"
	shapes1.AddText(1,1,"AddImageMap").Font.Size = 40
	Set mapframe4 = shapes1.AddImageMap(path1+"demogrid.grd")
	Set imagemap1 = mapframe4.Overlays("Image Map")
	imagemap1.ShowColorScale = False
	For Each Axis In mapframe4.Axes
		Axis.ShowLabels = False
		Axis.MajorTickType = srfTickNone
		Axis.MinorTickType = srfTickNone
	Next Axis
	With mapframe4
		.xLength = 2.5
		.yLength = 2
		.Top = 8.25
		.Left = 8.25
		.Axes("Bottom Axis").Title = "Image Map"
		.Axes("Bottom Axis").TitleFont.Size = 25
	End With

	Wait 2
	shapes1("Text").Delete

	'------------------------------------------
	'The AddPostMap method adds a new post map.
	' It returns a MapFrame Object.
	'------------------------------------------
	Debug.Print "AddPostMap"
	shapes1.AddText(1,1,"AddPostMap").Font.Size = 40
	Set mapframe5 = shapes1.AddPostMap(path1+"demogrid.dat")
	mapframe5.BackgroundFill.ForeColor = srfColorWhite
	mapframe5.BackgroundFill.Pattern = "Solid"
	Set postmap1 = mapframe5.Overlays("Post")

	For Each Axis In mapframe5.Axes
		Axis.ShowLabels = False
		Axis.MajorTickType = srfTickNone
		Axis.MinorTickType = srfTickNone
	Next Axis
	With mapframe5
		.xLength = 2.5
		.yLength = 2
		.Top = 5.5
		.Left = 0.25
		.Axes("Bottom Axis").Title = "Post Map"
		.Axes("Bottom Axis").TitleFont.Size = 25
	End With

	Wait 2
	shapes1("Text").Delete

	'-----------------------------------------------------
	'The AddReliefMap method adds a new shaded relief map.
	' It returns a MapFrame Object.
	'-----------------------------------------------------
	Debug.Print "AddReliefMap"
	shapes1.AddText(1,1,"AddReliefMap").Font.Size = 40
	Set mapframe6 = shapes1.AddReliefMap(path1+"helens2.grd")
	For Each Axis In mapframe6.Axes
		Axis.ShowLabels = False
		Axis.MajorTickType = srfTickNone
		Axis.MinorTickType = srfTickNone
	Next Axis
	With mapframe6
		.xLength = 2.5
		.yLength = 2
		.Top = 5.5
		.Left = 2.9
		.Axes("Bottom Axis").Title = "Shaded Relief Map"
		.Axes("Bottom Axis").TitleFont.Size = 25
	End With

	Set relief1 = mapframe6.Overlays("Shaded Relief Map")

	Wait 2
	shapes1("Text").Delete

	'----------------------------------------------
	'The AddVectorMap method adds a new vector map.
	' It returns a MapFrame Object.
	'----------------------------------------------
	Debug.Print "AddVectorMap"
	shapes1.AddText(0.5,1,"AddVectorMap").Font.Size = 40
	Set mapframe7 = shapes1.AddVectorMap(path1+"demogrid.grd")
	mapframe7.BackgroundFill.ForeColor = srfColorWhite
	mapframe7.BackgroundFill.Pattern = "Solid"
	For Each Axis In mapframe7.Axes
		Axis.ShowLabels = False
		Axis.MajorTickType = srfTickNone
		Axis.MinorTickType = srfTickNone
	Next Axis
	With mapframe7
		.xLength = 2.5
		.yLength = 2
		.Top = 5.5
		.Left = 5.6
		.Axes("Bottom Axis").Title = "Vector Map"
		.Axes("Bottom Axis").TitleFont.Size = 25
	End With

	Set vectors1 = mapframe7.Overlays("Vectors")

	Wait 2
	shapes1("Text").Delete

	'----------------------------------------------
	'The AddWireframe method adds a new wireframe map.
	' It returns a MapFrame Object.
	'----------------------------------------------
	Debug.Print "AddWireframe"
	shapes1.AddText(0.5,1,"AddWireframe").Font.Size = 40
	Set mapframe8 = shapes1.AddWireframe(path1+"demogrid.grd")
	mapframe8.BackgroundFill.ForeColor = srfColorWhite
	mapframe8.BackgroundFill.Pattern = "Solid"
	Set wireframe1 = mapframe8.Overlays("Wireframe")
	wireframe1.ShowColorScale = False
	For Each Axis In mapframe8.Axes
		Axis.ShowLabels = False
		Axis.MajorTickType = srfTickNone
		Axis.MinorTickType = srfTickNone
	Next Axis
	With mapframe8
		.xLength = 2
		.yLength = 1.5
		.zLength = .5
		.Top = 5.5
		.Left = 8.25
	End With
	mapframe8.ViewTilt = 20
	mapframe8.ViewProjection = srfOrthographic
	Set wireframetext = shapes1.AddText(8.75,3.25,"Wireframe")
	wireframetext.Font.Size = 25
	wireframetext.Name = "Wireframe Text"

	Wait 2
	shapes1("Text").Delete

	'----------------------------------------------
	'The AddSurface method adds a new surface map.
	' It returns a MapFrame Object.
	'----------------------------------------------
	If Val(Left(surf.Version,1)) >7 Then
		Debug.Print "AddSurface"
		shapes1.AddText(0.5,1,"AddSurface").Font.Size = 40
		Set mapframe9 = shapes1.AddSurface(path1+"demogrid.grd")