export2base.bas

Surfer是地学中常用的一个软件

'Export2Base.bas script exports all non-map items to DXF,
' loads the DXF as a base map and overlays it with the existing map.
' TB - 24 Jun 03
Sub Main
	Debug.Print "----- ";Time;" -----"
	On Error Resume Next
		Set surf = GetObject(,"Surfer.Application")
		If Err<>0 Then
			Debug.Print "Can't GetObject"
			GoTo errmsg
		End If
	On Error GoTo 0
	path1 = surf.Path+"\samples\"
	Set plotdoc1 = surf.ActiveDocument
	If plotdoc1.Type <> srfDocPlot Then
		Debug.Print "Active document is not a plot document"
		GoTo errmsg
	End If
	Set plotwin1 = surf.ActiveWindow
	Set shapes1 = plotdoc1.Shapes
	If shapes1.Count < 2 Then
		Debug.Print "Less than two objects in active document"
		GoTo errmsg
	End If
	If plotdoc1.Selection.Count>0 Then plotdoc1.Selection.DeselectAll
	For Each shp In plotdoc1.Shapes
		'Get mapframe name.
		If shp.Type = srfShapeMapFrame Then
			shp.Select
			mapname = shp.Name
			maptop = shp.Top
			mapleft = shp.Left
		End If
	Next 'shp

	If plotdoc1.Selection.Count > 1 Then
		Debug.Print "More than one map."
		GoTo errmsg
	End If

	'Export to save scaling info only.
	plotdoc1.Export(path1+"x1.dxf",selectiononly:=True, _
		options:="ScalingSourceApp=1, SaveScalingInfo=1")

	'Save map scale and limits
  With shapes1(mapname)
		xscale = .xMapPerPU
		yscale = .yMapPerPU
		mapxmin = .xMin
		mapxmax = .xMax
		mapymin = .yMin
		mapymax = .yMax
	End With 'shapes1(mapname)

	Debug.Print mapxmin;mapxmax;mapymin;mapymax

	'Get Top and Left of topmost and leftmost objects.
	plotdoc1.Shapes.SelectAll
	topall = plotdoc1.Selection.Top
	leftall = plotdoc1.Selection.Left

	'Select all objects except the mapframe.
	plotdoc1.Selection.DeselectAll
	For Each shp In plotdoc1.Shapes
		If shp.Type <> srfShapeMapFrame And _
			 shp.Type <> srfShapeScale And _
			 shp.Type <> srfShapeColorScale And _
			 shp.Type <> srfShapeLegend Then _
			 shp.Select
	Next

	'Export with saved scaling info.
	plotdoc1.Export(path1+"x1.dxf",selectiononly:=True, _
		options:="ScalingSourceApp=0")

	'Load non-map objects as base map.
	shapes1.AddBaseMap path1+"x1.dxf"
	plotdoc1.Selection.Delete
	shapes1.SelectAll
	Set mapframe2 = plotdoc1.Selection.OverlayMaps

	'Restore map scale, limits, and position.
	With mapframe2
		.xMapPerPU = xscale
		.yMapPerPU = yscale
		.SetLimits(xmin:=mapxmin,xmax:=mapxmax, _
			ymin:=mapymin,ymax:=mapymax)
		.Top = topall
		.Left = leftall
	End With

	'mapframe2.SetLimits(xmin:=mapxmin,xmax:=mapxmax, _
			'ymin:=mapymin,ymax:=mapymax)


	End

	errmsg:
	MsgBox("This script converts drawn objects to a base map" +vbCrLf+ _
			"using the coordinates of the map." +vbCrLf+ _
			"Open a Surfer plot document with one map and any" +vbCrLf+ _
			"number of drawn objects before running this script.",vbOkOnly, _
			"Error")

End Sub