arealengthbln.bas

surfer开发脚本

'-----------------------------------------------------------------------
'Area.bas calculates the area of polygons and the length of polylines
' and polygons in a BLN file. TB - 24 Mar 00.
'-----------------------------------------------------------------------
'Changes:
' - Create a base map with pattern fill, display file name, length, area.
' - Round to 4 decimal places.
' - Display only length if area=0. 
' - Display "gas gauge" (a period for every 10 vertices) and number of 
'   vertices for each boundary.
'Known problems: 
' - AddText extends beyond 32" limit with Windows 98 and a large number 
'   of boundary objects in a single BLN file.  (Actually -11" is the limit
'   on my machine.)  Script does not fail, but can't see text until it wraps
'   around from the top.
'Wishlist:
' - Label object number on map. min + ((max-min)/2) + label to DAT Post Map.
' - Label along line.
' - Add Object Number or ID,length, area to BLN file.
' - Write report file.
' - Move text To Back.
' - Turn off length if object is a point.
' - Display initial information about file, number of polygons, lines,
'   points, number of rows in file.
' 
'   TB - 15 Nov 00.
'-----------------------------------------------------------------------
Sub Main
	'Debug.Print "----- ";Time;" -----"
	
  Set Surf = CreateObject("Surfer.Application")
  surf.Documents.Add(srfDocPlot)	
  
	'Debug.Print surf.Version
  surf.Visible = True
	
  Set plotdoc1 = surf.Documents("Plot1")
	Set plotwin1 = surf.Windows("Plot1:1")
	path1 = surf.Path+"\samples\"
	path2 = "d:\incoming\"
	'plotwin1.AutoRedraw=False
	
	Set shapes1 = plotdoc1.Shapes
	
	'Default file name, ext, path, title, option 0 = only existing files.
	File1 = GetFilePath ( , _
		"bln", _
		path1, _
		"Open BLN File", _
		0 )  
	
	'Debug.Print Mid(file1,InStrRev(file1,"\")+1)
	With shapes1.AddBaseMap(file1).Overlays("base")
		.Name = "Base - "+Mid(file1,InStrRev(file1,"\")+1)
		.Fill.ForeColor=srfColorBlue
		.Fill.Pattern = "Diagonal Cross"
		.Fill.Transparent = True
	End With
	
	file1name = ""
	For g = 1 To Len(file1)
		file1name = file1name + Mid(file1,g,1)
		If Mid(file1,g,1) = "\" Then file1name = file1name +"\"
	Next g
	'Debug.Print file1name
	With shapes1.AddText(1,1,file1name)
		.Font.Size=20
		.Name = "Text - "+Mid(file1,InStrRev(file1,"\")+1)
	End With
	
	Set wks1 = Surf.Documents.Open(file1)
	plotdoc1.Activate
	Set wksrange = Wks1.UsedRange
	If wksrange.LastRow > wks1.Cells("a1").Value + 1 Then MultiLine = True
	rownum = 1
	objectnum = 1
	While rownum < wksrange.LastRow
		NumVerts = Wks1.Cells(rownum,1).Value '"A1"
		If numverts <1 Then End
		'Test for polygon closure.
		x1 = wks1.Cells(RowNum+1,1).Value
		y1 = Wks1.Cells(RowNum+1,2).Value
		xn = Wks1.Cells(RowNum+NumVerts,1).Value
		yn = Wks1.Cells(RowNum+NumVerts,2).Value
		ispolygon = Abs(x1-xn)<1e-5 And Abs(y1-yn)<1e-5
		
		'Begin area and length calculation.
		Area = 0
		Length = 0
		'Debug.Print wks1.Cells(1,3);" Boundary";objectnum;":";numverts;" vertices"
		For i = 1 To NumVerts-1
			x1 = wks1.Cells(RowNum+i,1).Value
			y1 = Wks1.Cells(RowNum+i,2).Value
			x2 = Wks1.Cells(RowNum+i+1,1).Value
			y2 = Wks1.Cells(RowNum+i+1,2).Value
			length = length + Sqr( (x2-x1)^2 + (y2-y1)^2 )
			If ispolygon Then area = area + ( (x2*y1) - (x1*y2) ) / 2
			If i Mod 10 = 0 Then Debug.Print ".";
			If i Mod 500 = 0 Then Debug.Print " ";i;" vertices processed"
		Next i
		'Debug.Print i;" = Number of vertices"
		area = Round(Abs(area),4)
		length=Round(length,4)
		lenarea = "Boundary "+Trim(Str(objectnum))+ _
			": length: "+Trim(Str(length))+IIf(area=0,"",", area: "+Trim(Str(area)))+ _
			", vertices: "+Trim(Str(numverts))
		Debug.Print lenarea
		shapes1.AddText(1,objectnum*-0.25,lenarea).Name = "Text - "+Trim(Str(objectnum))
		rownum = rownum+numverts+1
		objectnum = objectnum+1
	Wend

	wks1.Close
	plotwin1.Activate
	shapes1.SelectAll
	plotwin1.Zoom (srfZoomFitToWindow)
End Sub