Slice multiple maps to create a profile of non-adjacent layers (like a coal seam) in Surfer automation

Surfer's profile tool can be used to generate a multi-layer cross section of continuous or adjacent subsurface formations.  If the formations you're studying are not adjacent, a coal seam for example, then the grid slice command and a base map must be used to model the results. 

The sample script below slices formation tops and bottoms with a single BLN file and overlays them  in one map to create a discontinuous cross section. To run the script, you must have grid files for the tops and bottoms of various formations.

To run this script:

1. Copy the script below, or download the attached BAS file: SliceNonAdjacentFormations.BAS.
2. In a Windows Explorer window, navigate to C:\Program Files\Golden Software\Surfer.
3. Double click on Scripter.exe to launch Scripter.
4. Press Ctrl+A to select all of the existing lines then press Delete.
5. If you copied this script, press Ctrl+V to paste it into Scripter. If you downloaded it, click File | Open, select the BAS file from your downloads directory, and click Open.
6. In the User-defined variables section of the script, near the top, adjust the NumForm value to the number of formations you have top/bottom grid files for, and adjust the path1 as the input and output directory.
7. Click Script | Run to run the script.

Sub Main
'Initialize Surfer
	Dim SurferApp, Plot As Object
	Set SurferApp = CreateObject("Surfer.Application")
	SurferApp.Visible = True
	Set Plot = SurferApp.Documents.Add

'Print the Surfer version number and then delete it from the Immediate pane
	Debug.Print SurferApp.Version
	Wait(3)
	Debug.Clear

'===============================
'User-defined variables
'===============================
	path1 = "C:\surfer\"     'Input and output file path
	NumForm = 2     'Number of desired slice formations
'===============================
'Prompt user  for BLN file
	BLN$ = GetFilePath( , "bln",path1, "BLN for slice")
	If BLN$ ="" Then End

'Loop through number of slice formations
For i=1 To NumForm
	'Prompt user for top grid
	Top$ = GetFilePath( , "grd;dem;ddf",path1, "Top of Grid of Formation"+Format(i))
	If Top$ ="" Then End

	'Prompt user for bottom grid
	Bottom$ = GetFilePath( , "grd;dem;ddf",path1, "Bottom of Grid of Formation"+Format(i))
	If Bottom$ ="" Then End

        'Slice GRD files
	SurferApp.GridSlice(InGrid:=Top$, BlankFile:=BLN$, OutDataFile:= Top$+i+".dat")
	SurferApp.GridSlice(InGrid:=Bottom$, BlankFile:=BLN$, OutDataFile:= Bottom$+i+".dat")

	'======================================
	'Rearrange DAT and saves for Top
	'======================================
	Dim Wks, WksRange, WksRange2, WksRange3, WksRange4, WksRange5 As Object
	Set Wks = SurferApp.Documents.Open(FileName:=Top$+i+".dat")
	Set WksRange = Wks.Columns(Col1:=1, Col2:=2)
	WksRange.Clear

	'Cut column C and pastes it into column B
	Set WksRange2 = Wks.Columns(Col1:=3)
	WksRange2.Cut
	Set WksRange3 = Wks.Columns(Col1:=2)
	WksRange3.Paste

	'Cut column D and pastes it into column A
	Set WksRange4 = Wks.Columns(Col1:=4)
	WksRange4.Cut
	Set WksRange5 = Wks.Columns(Col1:=1)
	WksRange5.Paste

	'Save the file
	Wks.SaveAs(FileName:=Top$+i+".dat")

	'======================================
	'Rearrange DAT and saves for Bottom
	'======================================
	Dim Wks1, WksRange6, WksRange7, WksRange8, WksRange9, WksRange10 As Object
	Set Wks1 = SurferApp.Documents.Open(FileName:=Bottom$+i+".dat")
	Set WksRange6 = Wks1.Columns(Col1:=1, Col2:=2)

	'Cut column C and pastes it into column B
	Set WksRange7 = Wks1.Columns(Col1:=3)
	WksRange7.Cut
	Set WksRange8 = Wks1.Columns(Col1:=2)
	WksRange8.Paste

        'Cut column D and pastes it into column A
	Set WksRange9 = Wks1.Columns(Col1:=4)
	WksRange9.Cut
	Set WksRange10 = Wks1.Columns(Col1:=1)
	WksRange10.Paste

	'Save the file as a BLN
  	Wks1.SaveAs(FileName:=Bottom$+i+".dat")

	'======================================
	'Combine the DATs into a single BLN
	'======================================
	Dim WksRange11, WksRange12, WksRange13, WksRange14, WksRange15, WksRange16 As Object

	'Add a new column with the row number
        Wks1.Transform3 (RangeMin:=1, RangeMax:= WksRange10.Count, Equation:="C=row()")

	'Sort descending by new column C to invert the data
	Set WksRange11 = Wks1.Columns(Col1:=1,Col2:=3)
        WksRange11.Sort(Col1:=3, Order1:=wksSortDescending, Header:=False, MatchCase:=False)

	'Copy all data
	Set WksRange12 = Wks1.Cells(Col:=1, LastCol:=2, Row:=1, LastRow:=WksRange10.Count)
	WksRange12.Copy

	'Paste in the bottom data into the top bln
	Wks.Activate
	Set WksRange13 = Wks.Cells(Col:=1, Row:=WksRange5.Count+1)
	WksRange13.Paste(ClipToRange:=False)

	'Copy row 1
	Set WksRange14 = Wks.Rows(Row1:=1)
	WksRange14.Copy

	'Paste into the first empty row to close the polygon
	Set WksRange15 = Wks.Cells(Col:=1, Row:=WksRange5.Count+1)
	WksRange15.Paste(ClipToRange:=False)

	'Count the number of rows and puts that into an empty row at the top of the file
	'This is the BLN header row
        nrows = WksRange5.Count
	WksRange14.Insert
	Set WksRange16 = Wks.Cells("A1")
	WksRange16.Value = nrows

	'Save the file and close the worksheet windows
  	Wks.SaveAs(FileName:=Top$+i+"Combined.bln")
  	Wks.Close(SaveChanges:=srfSaveChangesNo)
  	Wks1.Close(SaveChanges:=srfSaveChangesNo)

	'Create Base Map
	Set MapFrame = Plot.Shapes.AddBaseMap(ImportFileName:=Top$+i+"Combined.bln")
	Set BaseLayer = MapFrame.Overlays(1)
Next i

'Select all maps and overlays them into one map frame
Plot.Shapes.SelectAll
Set NewMapFrame = Plot.Selection.OverlayMaps

'Update the scale of the map in the y direction to be visible
NewMapFrame.yLength = 2

'Fill each layer with a different color
r=0
g=0
b=0
Interval=Int(255/NumForm)
For j=1 To NumForm
	NewMapFrame.Overlays(j).Fill.Pattern = "Solid"
	NewMapFrame.Overlays(j).Fill.ForeColorRGBA.Red = r+((j-1)*Interval)
	NewMapFrame.Overlays(j).Fill.ForeColorRGBA.Green = g+((j-1)*Interval)
	NewMapFrame.Overlays(j).Fill.ForeColorRGBA.Blue = b+((j-1)*Interval)
	r=r+((j-1)*Interval)
	g=g+((j-1)*Interval)
	b=b+((j-1)*Interval)
Next j
End Sub

Updated December 2021