'CROSS-SECTION SCRIPT
'Use with Surfer 7 at your own risk
'Please make sure \Samples\ exists in your Surfer directory, and your files will not be overwritten
'REAL color-filled(!) cross-section as BLN basemap, NOT post map points finally
'SCALES X measure to fit the MAP

'Removes "out of map limit" part of the cross-section line on the plot
'this is simple element possibly useful to you in complex cross-sections of several grids either
'if you need those, loop the script (hints in MANAGER SERIE ) to overlay cross-sections
'Or add inner loop to get package of EW SN set of cross-sections

'Now you need to involve GRD (or GRD and BLN of the line) only and relax

'cross-section lines overlay the contour map created from the same GRD
'cross-section itself is located below
'blanked value = 0
'Z  exaggeration (X axis length 1:10) or change where is marked
'random gradual color-fill of the contour map
'****************************************
'Aleksey Amantov, aaman63@comset.net, St.Petersburg, Russia, http://home.comset.net/geolmap/
'Welcome to read more about implication of Golden Software products in geology!
'Thanks Golden Software gang for the soft, code examples used, and help
'****************************************
Option Explicit
Sub Main

	Dim SurferApp As Object
	Dim Data As String
	Dim Path As String   
	Dim Doc As Object
	Dim Plotwindow As Object
	Dim contourmap1 As Object
	Dim contourframe1 As Object
	Dim axes As Object
	Dim axes2 As Object
	Dim cross1 As Object
	Dim basemap1 As Object
	Dim selection1 As Object
	Dim mapframe1 As Object
	Dim mapframe2 As Object
	Dim Levels As Object
	Dim lvl As Object
	Dim shapes As Object
	Dim Grid As String
	Dim Grd1 As Object
	Dim ZMin 
	Dim ZMax 
	Dim Zm
	Dim XMin 
	Dim XMax 
	Dim xm
	Dim YMin 
	Dim YMax 
	Dim Ym
	Dim f
	Dim u
   Dim sngk 
   Dim sngl 
   Dim sngm

	Begin Dialog UserDialog 170,203 ' %GRID:10,7,1,1
		GroupBox 0,0,160,203,"Create Cross-Section:",.GroupBox1
		OptionGroup .Group1
			OptionButton 20,21,130,21,"     NW-SE",.OptionButton1
			OptionButton 20,49,120,21,"     NE-SW",.OptionButton2
			OptionButton 20,77,130,21,"      N-S",.OptionButton3
			OptionButton 20,105,130,21,"      E-W",.OptionButton4
			OptionButton 20,133,130,21,"From BLN line",.OptionButton5
		OKButton 10,170,60,21
		CancelButton 90,170,60,21
	End Dialog
	Dim dlg As UserDialog
	
If Dialog(dlg)=0 Then End

   Grid=GetFilePath("*.grd")
	If Grid ="" Then End
	
	If dlg.group1 =4 Then 
	Dim cross As String
	cross=GetFilePath("*.bln","Involve profile line")
	End If
	
	Set SurferApp = CreateObject("Surfer.Application")
	SurferApp.Visible = True
	SurferApp.WindowState = srfWindowStateMaximized
	
	path=SurferApp.Path+"\Samples\"
	
	Set Doc = SurferApp.Documents.Add
	Set Plotwindow = Doc.Windows(1)
   Plotwindow.AutoRedraw = False		
	'*********************************
	
	Set Grd1 = SurferApp.NewGrid
	
	Grd1.LoadFile (Grid, False)
	ZMin=Grd1.zMin
	ZMax=Grd1.zMax
	XMin=Grd1.xMin
	XMax=Grd1.xMax
	YMin=Grd1.yMin
	YMax=Grd1.yMax
	Zm=(ZMin+(ZMax-ZMin)*0.5)
	Xm=(Xmin+(XMax-XMin)*0.5)
	Ym=(Ymin+(YMax-YMin)*0.5)
	Debug.Print "=====Z=======================Z=========="
	 Debug.Print "=============="+ZMin +"================="
	  Debug.Print "=============="+ZMax+"=================="
	   Debug.Print "=============="+(ZMax-ZMin)+"========="
	    Debug.Print "=============="+Zm+"========="
	    Debug.Print "=====X========================X========="
	    Debug.Print "==XMin--------"+XMin+"-----------XMin=="
	   Debug.Print "==XMax--------"+XMax+"-----------XMax=="
	   Debug.Print "==Xmid--------"+Xm+"-----------Xmid=="
	  Debug.Print "=====Y========================Y========" 
	 Debug.Print "==YMin-------"+YMin+"-----------YMin==="
	Debug.Print "==YMax-------"+YMax+"-----------YMax===="
	Debug.Print "==Ymid--------"+Ym+"-----------Ymid=="
	'*********************************
		
	Set contourframe1 = Doc.Shapes.AddContourMap(GridFileName:=Grid)
	Set contourmap1 = contourframe1.Overlays(1)
	contourmap1.Name ="plan contours"
	contourframe1.Name ="contour map 1"
	contourmap1.FillContours = True
	Set Levels = contourmap1.Levels
	Dim i As Single
	Dim n As Single
	Dim b
	Dim p
	Dim C
	Dim clr
	p=Int (100+Rnd*100)
	n = Levels.Count
	b=255/n
	
	For i=1 To n 
	'Randomize
	c= i*b
	Levels(i).Fill.ForeColor = RGB(255-c,p,255-c)
	
	Next i
	Contourmap1.ShowColorScale = True
	Dim Scale As Object
	Set Scale = Contourmap1.ColorScale
	Set Shapes = Doc.Shapes
		
	
	'*********************************
	Dim doc2 As Object
	Dim Shapes2 As Object
	Dim PolyLine As Object
	Dim Polyvert(3) As Double
	
		
	If dlg.group1 <>4 Then 
	Set doc2 = SurferApp.Documents.Add
	Set Shapes2 = doc2.Shapes
	        If dlg.group1 =0 Then
	        Polyvert(0) = XMin : Polyvert(1) = YMax
	        Polyvert(2) = XMax : Polyvert(3) = YMin
	        End If
	        If dlg.group1 =1 Then
	        Polyvert(0) = XMin : Polyvert(1) = YMin
	        Polyvert(2) = XMax : Polyvert(3) = YMax
	        End If
	        If dlg.group1 =2 Then
	        Polyvert(0) = Xm : Polyvert(1) = YMax
	        Polyvert(2) = Xm : Polyvert(3) = YMin
	        End If
	        If dlg.group1 =3 Then
	        Polyvert(0) = XMin : Polyvert(1) = Ym
	        Polyvert(2) = XMax : Polyvert(3) = Ym
	        End If
	Set PolyLine = Shapes2.AddPolyLine(Polyvert)
	doc2.Export(FileName:=path +"temp_cross_line.bln",Options:="ScalingSourceApp=0")
	cross = path +"temp_cross_line.bln"
	doc2.Close(SaveChanges:=srfSaveChangesNo)
	End If
	'*********************************
	SurferApp.GridSlice(InGrid:=Grid, BlankFile:=cross, _
 OutDataFile:=path +"cross_line.dat",  BlankVal:=Zm) 'Change blank value here!
	
Dim Wks As Object
Set Wks = SurferApp.Documents.Open(FileName:=path +"cross_line.dat")
   Dim WksRange As Object
	Set WksRange = Wks.Columns(Col1:=1, Col2:=2)
	WksRange.Delete
	Dim WksRange2 As Object
	Set WksRange2 = Wks.Columns(Col1:=3)
	WksRange2.Delete
	Dim WksRange3 As Object
	Set WksRange3 = Wks.Columns(Col1:=1)
	WksRange3.Cut
	Dim WksRange4 As Object
	Set WksRange4 = Wks.Columns(Col1:=1)
	WksRange4.Delete
	Dim WksRange5 As Object
	Set WksRange5 = Wks.Columns(Col1:=2)
	WksRange5.Paste
	Dim s
	s=WksRange5.Count
	Debug.Print "section as line  vertices---------"+s
	Debug.Print "section as area  vertices---------"+(s+3)
	
	Dim WksRange6 As Object
	Set WksRange6 = Wks.Rows(Row1:=1)
	WksRange6.Insert
	
	Dim WksRange7 As Object
	Set WksRange7 = Wks.Cells("A1")
	 WksRange7.Value = 0
	
  Dim WksRange8 As Object
  Set WksRange8 = Wks.Cells("B1")
  WksRange8.Value = ZMin
  WksRange6.Insert
  WksRange8.Value = 0
  WksRange7.Value = s+3
  Dim WksRange9 As Object
 Set WksRange9 = Wks.Rows(Row1:=s+2)
 WksRange9.Copy
 Dim WksRange10 As Object
 Set WksRange10 = Wks.Rows(Row1:=s+3)
 WksRange10.Paste
  Dim WksRange11 As Object
 Set WksRange11 = Wks.Cells(Row:=s+3,Col:=2)
 WksRange11.Value=Zmin
  Dim WksRange12 As Object
 Set WksRange12 = Wks.Rows(Row1:=2)
 WksRange12.Copy
  Dim WksRange13 As Object
 Set WksRange13 = Wks.Rows(Row1:=s+4)
 WksRange13.Paste

  Wks.SaveAs(FileName:=path +"cross_main.bln")
  Wks.Close(SaveChanges:=srfSaveChangesNo)
'*********************************


	Set mapframe1 = Shapes.AddBaseMap(cross)
	Set basemap1 = mapframe1.Overlays(1)
	basemap1.Name ="Cross section line 1"
	basemap1.Line.Width =0.05
	basemap1.Line.ForeColor = RGB(100,50,0)
	
 mapframe1.Name ="map 1
	Shapes.SelectAll   
	Set selection1 = Doc.Selection
	
	
	selection1.OverlayMaps
	Dim x1
	Dim y1
	Dim pr1
	x1= contourframe1.xLength
	y1= contourframe1.yLength
	pr1= Sqr(x1^2 +y1^2)
	Debug.Print "===map X length ==="+x1
   Debug.Print "===map Y length ==="+y1
   
   Set axes = contourframe1.Axes
   Debug.Print "===axis 1 ==="+axes.Item(Index:=1).Cross1
      
   Debug.Print "===axis 2 ==="+axes.Item(Index:=2).Cross1
   
   Debug.Print "===axis 3 ==="+axes.Item(Index:=3).Cross1
    
   Debug.Print "===axis 4 ==="+axes.Item(Index:=4).Cross1
   
	If axes.Item(Index:=1).Cross1<YMin Or axes.Item(Index:=2).Cross1>YMax _
	Or axes.Item(Index:=3).Cross1<XMin Or axes.Item(Index:=4).Cross1>XMax Then
	contourframe1.SetLimits(xMin:=xMin, xMax:=xMax, yMin:=yMin, yMax:=yMax)
	End If
	'****************************
	
	Dim top1
	top1=contourframe1.Top
	Debug.Print "===map X/PageUn ==="+contourframe1.xMapPerPU
	Debug.Print "===map Y/PageUn==="+contourframe1.yMapPerPU
	Debug.Print "===map top==="+top1

Dim x2
  x2=contourframe1.xMapPerPU
contourframe1.Selected=False
Scale.Selected=False
'*********************************


Set mapframe2 = Shapes.AddBaseMap(path +"cross_main.bln")
	Set cross1 = mapframe2.Overlays(1)
	mapframe2.xMapPerPU = x2
	
	mapframe2.yLength = 0.1*pr1 'Change vertical scale of the cross-section here!
	mapframe2.Name ="Cross section"
	cross1.Name ="Cross section"
	cross1.Line.Width =0.05
	cross1.Line.ForeColor = RGB(100,50,0)
	cross1.Fill.Pattern = "solid"
	cross1.Fill.ForeColor = RGB(200,150,50)
	
	mapframe2.BackgroundFill.Pattern = "solid"
	mapframe2.BackgroundFill.ForeColor = RGB(230,255,255)	
	
'*********************************
Set axes2 = mapframe2.Axes
	axes2.Item(Index:=2).Visible=False

	mapframe2.Top=(top1 - 1.1*y1)
	  Plotwindow.AutoRedraw = True	
	
End Sub