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