Skip to content

Commit 4923801

Browse files
mrchimpmrchimp
committed
added constraint overlap tool
1 parent 504efbc commit 4923801

15 files changed

+546
-274
lines changed

‎.gitignore‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,12 @@
11
*.mbx
22
*.mbo
33
*.png
4+
*.tab
5+
*.dat
6+
*.tda
7+
*.tin
48
/screenshots/*
59
/compiled/*
10+
/backup/*
611
*.swp
712
*Thumbs.db

‎AreaUpdater.mb‎

Lines changed: 19 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -9,25 +9,30 @@ Include "globals.def"
99
Sub SiteAreaUpdate 'Blockstart
1010
OnError goto AreaError
1111

12-
Dim SiteAreaNum, TableNum as Integer
13-
Dim TableName, AreaUnits as String
14-
Dim SiteAreaCol as Alias
15-
Dim ColumnListVar(10) as String
12+
If NumTables() < 1 Then
13+
Exit Sub
14+
End If
1615

17-
Dim TableNums(1) As String
16+
Dim SiteAreaNum as Integer ' Site area column number
17+
Dim SiteAreaCol as Alias ' Area column name
18+
Dim TableNum as Integer
19+
Dim TableName, AreaUnits as String
20+
Dim TableNames(1) as String ' List of open table names.
21+
Dim ColumnListVar(10) as String ' array of selected table's columns
1822

19-
Call GetTableList(TableNums)
20-
Call ColumnList(TableNums(1),ColumnListVar)
23+
' Populate lists
24+
Call GetTableList(TableNames)
25+
Call ColumnList(TableNames(1),ColumnListVar)
2126

2227
Dialog
23-
Title "Update Area Column"
28+
Title "Update Area Column"
2429
Control StaticText
2530
Title "This tool updates the area column of a table."
2631
Control StaticText
2732
Title "Table"
2833
Position 10, 24
2934
Control PopupMenu
30-
Title From Variable TableNums
35+
Title From Variable TableNames
3136
Position 40, 20
3237
ID 51
3338
Calling TableSelectHandler
@@ -53,14 +58,18 @@ Sub SiteAreaUpdate 'Blockstart
5358

5459
If CommandInfo(CMD_INFO_DLG_OK) Then
5560
TableName = TableInfo(TableNum, TAB_INFO_NAME)
61+
5662
If IsTableOpen(TableName) Then
5763
SiteAreaCol = ColumnInfo(TableName, "COL"&SiteAreaNum, COL_INFO_NAME)
64+
5865
Select * From TableName Where Obj Into AreaTable Noselect
66+
5967
Update AreaTable
6068
Set SiteAreaCol = Area(obj, AreaUnitsArray(AreaUnits))
69+
6170
Close Table AreaTable
6271
Else
63-
Note "The table " + TableName + " isn't open. What have you done?!"
72+
Note "The table " & TableName & " isn't open. What have you done?!"
6473
End If
6574
End If
6675

‎Constraints.mb‎

Lines changed: 262 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,262 @@
1+
'*********************************
2+
'* Jake's Constraint Checker *
3+
'* 2009-2011 All Rights Reserved *
4+
'*********************************
5+
6+
Include "mapbasic.def"
7+
Include "globals.def"
8+
9+
Define RES_PERCENT 1
10+
Define RES_AREA 2
11+
Define RES_BOOL 3
12+
13+
Declare Sub OKHandler
14+
Declare Sub ResultTypeHandler
15+
Declare Sub ConstraintsHelp
16+
17+
Global ConstraintsSelArray() as Integer
18+
Global NumConstraints as Integer
19+
20+
Sub CheckConstraints
21+
OnError Goto ThatDidntWork
22+
23+
If NumTables() < 1 Then
24+
Exit Sub
25+
End If
26+
27+
Dim TableList(1) as String
28+
Dim SiteTableNum, SiteRefColNum as Integer
29+
Dim SiteTableName, SiteRefColName, ConstraintName as String
30+
Dim SiteRefAlias, SiteObjAlias, ConstraintObjAlias as Alias
31+
Dim SiteObj, ConstraintObj as Object
32+
Dim ColumnListVar() as String
33+
Dim OverlapArea as Float
34+
Dim ResultType as Integer
35+
Dim AreaUnitsNum as Integer
36+
Dim AreaUnitsStr as String
37+
38+
Call GetTableList(TableList)
39+
Call ColumnList(TableList(1),ColumnListVar)
40+
41+
Dialog
42+
Title "Select layers..."
43+
44+
Control GroupBox
45+
Title "Sites Table"
46+
Width 50dW
47+
Height 7dH
48+
Position 1dW, 1dH
49+
Control PopupMenu
50+
Title From Variable TableList
51+
Into SiteTableNum
52+
ID 51
53+
Calling TableSelectHandler
54+
Position 4dW, 3dH
55+
Width 43dW
56+
Control PopupMenu
57+
Title From Variable ColumnListVar
58+
Into SiteRefColNum
59+
Id 52
60+
Position 4dW, 5dH
61+
Width 43dW
62+
63+
Control GroupBox
64+
Title "Constraints"
65+
Width 50dW
66+
Height 12dH
67+
Position 1dW, 9dH
68+
Control MultiListBox
69+
Title From Variable TableList
70+
ID 1
71+
Position 4dW, 11dH
72+
Width 43dW
73+
Value 2
74+
75+
Control GroupBox
76+
Title "Result Type"
77+
Position 1dW, 22dH
78+
Width 50dW
79+
Height 5dH
80+
Control PopupMenu
81+
Title "Percentage;Area;Yes/No"
82+
Into ResultType
83+
Position 4dW, 24dH
84+
Calling ResultTypeHandler
85+
ID 4
86+
Control PopupMenu
87+
Title From Variable AreaUnitsArray
88+
Into AreaUnitsNum
89+
Position 21dW, 24dH
90+
Hide
91+
ID 5
92+
93+
Control Button
94+
Title "Help"
95+
Calling ConstraintsHelp
96+
Control CancelButton
97+
Control OkButton Calling OKHandler
98+
99+
If CommandInfo(CMD_INFO_DLG_OK) Then
100+
Dim NumSites, NumConstraintRows as Integer
101+
Dim x, y, z, i as Integer
102+
Dim ConstraintNum as Integer
103+
Dim ExecStr, SiteRefVal, OverlapResult as String
104+
Dim Resultsbasename, ResultsTableName as String
105+
Dim OverlapPercent as Float
106+
Dim SiteArea as Float
107+
Dim ConstraintResult as Alias
108+
Dim OverlapSum, OverlapObj as Object
109+
110+
AreaUnitsStr = AreaUnitsArray(AreaUnitsNum)
111+
SiteTableName = TableInfo(SiteTableNum, TAB_INFO_NAME)
112+
SiteRefColName = ColumnInfo(SiteTableName, "COL"&SiteRefColNum, COL_INFO_NAME)
113+
114+
Set Area Units AreaUnitsStr
115+
Set Coordsys Table SiteTableName
116+
117+
' See this: http://gis.stackexchange.com/questions/18176/select-only-records-with-region-objects-in-mapbasic
118+
ExecStr = "SELECT " & SiteRefColname & ", Obj FROM " & SiteTableName & " WHERE str$(OBJ) IN (""Region"",""Rectangle"",""Ellipse"",""Rounded Rectangle"") INTO SiteTable NOSELECT"
119+
Run Command ExecStr
120+
121+
NumSites = TableInfo(SiteTable, TAB_INFO_NROWS)
122+
SiteRefAlias = "SiteTable." & SiteRefColName
123+
SiteObjAlias = "SiteTable.Obj"
124+
125+
' Check table name
126+
ResultsBasename = "Constraints_" + SiteTableName
127+
ResultsTableName = ResultsBasename
128+
i = 1
129+
Do While IsTableOpen(ResultsTableName) = True
130+
i = i + 1
131+
ResultsTableName = ResultsBasename & i
132+
Loop
133+
134+
' Make results table
135+
ExecStr = "Create Table " & ResultsTableName & " ( SiteRef Char(30), "
136+
For x = 1 to UBound(ConstraintsSelArray)
137+
ConstraintNum = ConstraintsSelArray(x)
138+
ConstraintName = TableInfo(ConstraintNum, TAB_INFO_NAME)
139+
140+
If TableInfo(ConstraintName, TAB_INFO_MAPPABLE) = True Then
141+
ExecStr = ExecStr & " " & TableInfo(ConstraintName, TAB_INFO_NAME) & " Char(30) "
142+
If x <> UBound(ConstraintsSelArray) Then
143+
ExecStr = ExecStr + ", "
144+
End If
145+
Else
146+
Print ConstraintName & " is not a mappable table. Ignoring!"
147+
End If
148+
Next
149+
ExecStr = ExecStr & " ) "
150+
Run Command ExecStr
151+
152+
For x = 1 To NumSites '=====================================================
153+
154+
Fetch Rec x From SiteTable
155+
156+
SiteObj = SiteObjAlias
157+
SiteRefVal = SiteRefAlias
158+
SiteArea = Area(SiteObj, AreaUnitsStr)
159+
160+
INSERT INTO ResultsTableName ( SiteRef ) VALUES ( SiteRefVal )
161+
162+
For y = 1 To NumConstraints '=============================================
163+
OverlapPercent = 0
164+
ConstraintNum = ConstraintsSelArray(y)
165+
ConstraintName = TableInfo(ConstraintNum, TAB_INFO_NAME)
166+
167+
If TableInfo(ConstraintName, TAB_INFO_MAPPABLE) = True Then
168+
OverlapSum = CreateCircle(1, 1, 0)
169+
Print x & "/" & NumSites & " - checking " & SiteRefVal & " against " & ConstraintName & "..."
170+
171+
SELECT * FROM ConstraintName WHERE OBJ AND str$(OBJ) IN ("Region","Rectangle","Ellipse","Rounded Rectangle") Into ConstTab
172+
NumConstraintRows = TableInfo(ConstTab, TAB_INFO_NROWS)
173+
ConstraintObjAlias = "ConstTab.Obj"
174+
175+
For z = 1 To NumConstraintRows '======================================
176+
Fetch Rec z From ConstTab
177+
178+
ConstraintObj = ConstraintObjAlias
179+
OverlapArea = AreaOverlap(ConstraintObj, SiteObj)
180+
181+
If OverlapArea > 0 Then
182+
OverlapObj = overlap(ConstraintObj, SiteObj)
183+
OverlapSum = combine(OverlapObj, OverlapSum)
184+
End If
185+
Next '================================================================
186+
187+
' check overlap
188+
OverlapArea = Area(OverlapSum, AreaUnitsStr)
189+
190+
If ResultType = RES_AREA Then
191+
OverlapResult = Str$(OverlapArea) & " " & AreaUnitsStr
192+
ElseIf ResultType = RES_PERCENT Then
193+
OverlapPercent = (OverlapArea / SiteArea) * 100
194+
OverlapResult = Str$(OverlapPercent) & " %"
195+
Else ' BOOL
196+
If OverlapArea > 0 Then
197+
OverlapResult = "Yes"
198+
Else
199+
OverlapResult = "No"
200+
End If
201+
End If
202+
203+
ExecStr = "UPDATE " & ResultsTableName & " SET " & ConstraintName & " = """ & OverlapResult & """ WHERE RowID = " & x
204+
Run Command ExecStr
205+
206+
If OverlapArea > 0 Then
207+
Print "Overlap of " & OverlapResult
208+
End If
209+
210+
Close Table ConstTab
211+
End If
212+
Next '==================================================================
213+
214+
Next '======================================================================
215+
216+
Drop Table SiteTable
217+
Browse * From ResultsTableName
218+
End If
219+
220+
Exit Sub
221+
222+
ThatDidntWork:
223+
Note "Error: "+ Error$()
224+
End Sub
225+
226+
227+
Sub OKHandler 'Blockstart
228+
Print Chr$(12)
229+
Dim TableSelection as Integer
230+
231+
TableSelection = ReadControlValue(1)
232+
233+
If TableSelection = 0 Then
234+
Note "Please select at least one constraints table."
235+
Dialog Preserve
236+
End If
237+
238+
NumConstraints = 0
239+
Do until TableSelection = 0
240+
NumConstraints = NumConstraints + 1
241+
Redim ConstraintsSelArray(NumConstraints)
242+
ConstraintsSelArray(NumConstraints) = TableSelection
243+
TableSelection = ReadControlValue(1)
244+
Loop
245+
End Sub 'Blockend
246+
247+
Sub ResultTypeHandler 'Blockstart
248+
Dim ResultType as Integer
249+
250+
ResultType = ReadControlValue(4)
251+
If ResultType = RES_AREA Then
252+
Alter Control 5 Show
253+
Else
254+
Alter Control 5 Hide
255+
End If
256+
End Sub 'Blockend
257+
258+
Sub ConstraintsHelp 'Blockstart
259+
Note "Compares one table to multiple other tables and tries to find overlaps." & Chr$(13) &
260+
"Designed for use with constraints layers." & Chr$(13) & Chr$(13) &
261+
"Non-region objects and records without objects will be ignored."
262+
End Sub 'Blockend

0 commit comments

Comments
 (0)