[Visual Basic 6.0]
'This Example shows two pieces. First is a Apply_Click Sub that is the
'Click event for a button called Apply in a form. The rest is the ssOp
'Class, which implements IOperation and contains the code that will
'be executed, first on this click event, and then other code that will be
'run for undo and redo operations.
Public Sub Apply_Click()
'***
'*** Important--This code run out of the
'*** SelSimOperation::Do method.
'***
Dim ssOp As IOperation
Set ssOp = New SelSimOperation
m_pMxDoc.OperationStack.Do ssOp
End Sub
'***************** Class ssOp****************
Option Explicit
Implements IOperation
Public affectsLayer As IFeatureLayer
Public startSelSet As ISelectionSet
Public resultSelSet As ISelectionSet
Private mxMap As IMap
Private mxDoc As IMxDocument
Private Property Get IOperation_CanRedo() As Boolean
IOperation_CanRedo = True
End Property
Private Property Get IOperation_CanUndo() As Boolean
IOperation_CanUndo = True
End Property
Public Sub IOperation_Do()
'For every numeric field that's checked, get the min and max
'then determine percentage range and assemble a WHERE clause
'For every string field that's checked assemble a WHERE clause
'to include that variable.
'This function is
called from the Apply button's Click Event in the form: SelSimExprDlg
SelStuff.SelSim.MousePointer = 11
Dim gfID As New UID
Dim gfLyrs As IEnumLayer
gfID = "{E156D7E5-22AF-11D3-9F99-00C04F6BC78E}" 'IGeoFeatureLayer
Set gfLyrs = SelStuff.SelSim.m_pfMap.Layers(gfID, True)
Set mxMap = SelStuff.SelSim.m_pfMap
Set mxDoc = SelStuff.SelSim.m_pMxDoc
gfLyrs.Reset
Dim pfeaLyr As IFeatureLayer
Dim pFlds As IFields
Set pfeaLyr = gfLyrs.Next
Dim k As String
k = pfeaLyr.Name
Dim kn As String
kn = SelSim.Layers.List(SelStuff.SelSim.Layers.ListIndex)
If kn = "" Then
kn = SelStuff.SelSim.Layers.List(0)
End If
Dim pflyrName As String
pflyrName = pfeaLyr.Name
While Not pflyrName = kn
Set pfeaLyr = gfLyrs.Next
pflyrName = pfeaLyr.Name
Wend
Dim pQFilt As IQueryFilter
Dim pCurs As ICursor
Dim pFCurs As IFeatureCursor
Dim pFSel As IFeatureSelection
Dim pSelSet As ISelectionSet
Set pFSel = pfeaLyr
Set pSelSet = pFSel.SelectionSet
Set pQFilt = New QueryFilter
pSelSet.Search pQFilt, False, pCurs
Set pFCurs = pCurs
'** Support UNDO/REDO
Set affectsLayer = pfeaLyr
Set startSelSet = pSelSet
Dim StrWhr As String
StrWhr = ""
Dim WhrPair
Set WhrPair = CreateObject("Scripting.Dictionary")
Set pFlds = pfeaLyr.FeatureClass.Fields
'SValsInc = 0
If SelStuff.SelSim.StrFlds.SelCount > 0 Then
Dim SC As Integer
Dim SCC As Long
Dim pFeat As IFeature
SC = SelStuff.SelSim.StrFlds.ListCount
'** Loop through the string field list
Dim WithinField As Boolean
WithinField = False
For SCC = 0 To (SC - 1)
WithinField = False
'** IF the field is selected then created an entry in the WhereClause
WhrPair.RemoveAll
If SelSim.StrFlds.Selected(SCC) Then
'** Figure out a list of unique features
Set pFeat = pFCurs.NextFeature
Dim kx As String
While Not pFeat Is Nothing
kx = pFeat.Value(pFlds.FindField(SelSim.StrFlds.List(SCC)))
'** Check to see if the value is already in the list, If not add it.
If Not WhrPair.Exists(kx) Then
WhrPair.Add kx, SelSim.StrFlds.List(SCC)
If StrWhr = "" Then
StrWhr = "[" & SelStuff.SelSim.StrFlds.List(SCC) & "] = '" & kx & "'"
WithinField = True
Else
If WithinField Then
StrWhr = StrWhr & " OR [" & SelStuff.SelSim.StrFlds.List(SCC) & "] = '" & kx & "'"
Else
StrWhr = StrWhr & " AND [" & SelStuff.SelSim.StrFlds.List(SCC) & "] = '" & kx & "'"
WithinField = True
End If
End If
End If
Set pFeat = pFCurs.NextFeature
Wend
End If
pSelSet.Search pQFilt, False, pCurs
Set pFCurs = pCurs
Next SCC
WithinField = False
End If 'If StrFlds.SelCount > 0
If SelStuff.SelSim.NumFlds.SelCount > 0 Then
'** Do Numbers
Dim NCC As Integer
For NCC = 0 To SelStuff.SelSim.NumFlds.ListCount - 1 'For each field in the field list
WithinField = False
If SelStuff.SelSim.NumFlds.Selected(NCC) Then 'If the NCCth field is selected
Set pFeat = pFCurs.NextFeature
If SelStuff.SelSim.NumVar.SelText = "0" Then
Dim ky As Variant
WhrPair.RemoveAll
While Not pFeat Is Nothing
ky = pFeat.Value(pFlds.FindField(SelStuff.SelSim.NumFlds.List(NCC)))
If Not WhrPair.Exists(ky) Then
WhrPair.Add ky, SelStuff.SelSim.NumFlds.List(NCC)
If StrWhr = "" Then
StrWhr = "[" & SelStuff.SelSim.NumFlds.List(NCC) & "] = " & ky
WithinField = True
Else
If WithinField Then
StrWhr = StrWhr & " OR [" & SelStuff.SelSim.NumFlds.List(NCC) & "] = " & ky
Else
StrWhr = StrWhr & " AND [" & SelStuff.SelSim.NumFlds.List(NCC) & "] = " & ky
WithinField = True
End If
End If
End If
Set pFeat = pFCurs.NextFeature
Wend
Else 'SelSim.NumVar.SelTExt <> "0", i.e., we have a tolerance
Dim kmin As Variant
Dim kmax As Variant
Dim kcur As Variant
If Not pFeat Is Nothing Then
kmin = pFeat.Value(pFlds.FindField(SelStuff.SelSim.NumFlds.List(NCC)))
kmax = kmin
Set pFeat = pFCurs.NextFeature
End If
While Not pFeat Is Nothing
kcur = pFeat.Value(pFlds.FindField(SelStuff.SelSim.NumFlds.List(NCC)))
If kcur < kmin Then
kmin = kcur
End If
If kcur > kmax Then
kmax = kcur
End If
Set pFeat = pFCurs.NextFeature
Wend
Dim pval As Integer
Dim pvar As Double
Dim psel As String
psel = SelSim.NumVar.Text
If psel = "" Then
psel = "3"
End If
pval = Val(psel)
If kmax = kmin Then
pvar = kmax / 100 * pval
Else
pvar = (kmax - kmin) / 100 * pval
End If
If StrWhr = "" Then
StrWhr = "[" & SelStuff.SelSim.NumFlds.List(NCC) & "] >= " & (kmin - pvar) _
& " AND [" & SelStuff.SelSim.NumFlds.List(NCC) & "] <= " & (kmax + pvar)
WithinField = True
Else
If WithinField Then
StrWhr = StrWhr & " OR [" & SelStuff.SelSim.NumFlds.List(NCC) & "] >= " & (kmin - pvar) _
& " AND [" & SelStuff.SelSim.NumFlds.List(NCC) & "] <= " & (kmax + pvar)
Else
StrWhr = StrWhr & " AND [" & SelStuff.SelSim.NumFlds.List(NCC) & "] >= " & (kmin - pvar) _
& " AND [" & SelStuff.SelSim.NumFlds.List(NCC) & "] <= " & (kmax + pvar)
WithinField = True
End If
End If
End If
End If
pSelSet.Search pQFilt, False, pCurs
Set pFCurs = pCurs
WithinField = False
Next NCC
End If
If SelStuff.SelSim.ShowQuery.Value Then
SelStuff.SelSimExprDlg.ExprText.Text = StrWhr
SelStuff.SelSimExprDlg.Label1.Caption = StrWhr
SelStuff.SelSimExprDlg.Show vbModal, SelStuff.SelSim
If SelStuff.SelSimExprDlg.Label1.Caption = "Cancel" Then
SelStuff.SelSim.MousePointer = 0
Exit Sub
End If
StrWhr = SelStuff.SelSimExprDlg.ExprText.Text
End If
'Need to Substitute "[" and "]" with
'Chr(34) for dBase (Shapefiles}
'Chr(34) for Coverage
'Nothing for PGdb
If pfeaLyr.FeatureClass.FeatureClassID = -1 Then
StrWhr = ReplaceString(StrWhr, "[", Chr(34))
StrWhr = ReplaceString(StrWhr, "]", Chr(34))
End If
Dim SimFilt As IQueryFilter
Set SimFilt = New QueryFilter
SimFilt.WhereClause = StrWhr
pFSel.SelectFeatures SimFilt, esriSelectionResultNew, False
'** THIS IS REALLY IMPORTANT FOR THIS EXAMPLE
'** Support Undo/Redo
Set resultSelSet = pFSel.SelectionSet
SelStuff.SelSim.MousePointer = 0
SelStuff.SelSim.Hide
SelStuff.SelSim.m_pMxDoc.ActiveView.Refresh
SelStuff.SelSim.m_pMxDoc.UpdateContents
SelStuff.SelSimAdv.InitStatus.Caption = "Clean"
Unload SelSim 'Unloading this messes up Undo/Redo!!
End Sub
Private Property Get IOperation_MenuString() As String
IOperation_MenuString = "Select Similar"
End Property
Private Sub IOperation_Redo()
'** Here we store an ISelection Set object (the one that
'** results from IOperation_Do) and a pointer to the layer
'** it applies to
Dim rFSel As IFeatureSelection
Set rFSel = affectsLayer 'QI
Set rFSel.SelectionSet = resultSelSet
mxDoc.ActiveView.Refresh
mxDoc.UpdateContents
End Sub
Private Sub IOperation_Undo()
'* Here we store an ISelectionSet Object and
'* a pointer to the layer we want to apply it to.
'On Error GoTo foo
Dim uFSel As IFeatureSelection
Set uFSel = affectsLayer 'QI
Set uFSel.SelectionSet = startSelSet
mxDoc.ActiveView.Refresh
mxDoc.UpdateContents
Exit Sub
'foo:
'MsgBox "Error. " & Err.Number & ": " & Err.Description
End Sub
Private Function ReplaceString(ByVal qtxt As String, ByVal from_str As String, ByVal to_str As String)
Dim new_txt As String
Dim pos As Integer
Do While Len(qtxt) > 0
pos = InStr(qtxt, from_str)
If pos = 0 Then
' No more occurrences.
new_txt = new_txt & qtxt
qtxt = ""
Else
' Found it.
new_txt = new_txt & Left$(qtxt, pos - 1) & to_str
qtxt = Mid$(qtxt, pos + Len(from_str))
End If
Loop
ReplaceString = new_txt
End Function[Visual Basic .NET, C#, C++]
No example is available for Visual Basic .NET, C#, or C++. To view a Visual Basic 6.0 example, click the Language Filter button
in the upper-left corner of the page.