| |
'====================
' Perform attribute query of selected field and attribute
' The attribute is the value entered in the textbox
'=====================
Dim mxDoc As IMxDocument
Set mxDoc = ThisDocument
Dim pActiveView As IActiveView
Dim pFeatureLayer As IFeatureLayer
Dim pFeatureSelection As IFeatureSelection
Dim pMap As IMap
Set pMap = mxDoc.FocusMap
Set pActiveView = pMap
'======================
'For simplicity sake let's use the first layer in the map
'=====================
If Not TypeOf pMap.Layer(0) Is IFeatureLayer Then Exit Sub
Set pFeatureLayer = pMap.Layer(0)
Set pFeatureSelection = pFeatureLayer 'QI
'===============
'Create the query filter
'===============
LicenseID = DatabaseConnection.LicenseBox.Value
CP = DatabaseConnection.CPBox.Value
Dim pFieldname As String
Dim pQFilter As IQueryFilter
Set pQFilter = New QueryFilter
' If UserForm1.ListBox1.Value <> "" Then
' pFieldname = UserForm1.ListBox1.Value
' Else
' MsgBox ("Please Enter a Field.")
' End If
'==================
' If user entered text then contiue
'==================
If LicenseID <> "" And CP <> "" Then
pQFilter.WhereClause = "KHGIS.VWM_LIC_CP_BLK.LICN_LICENCE_ID = '" & LicenseID & "'" _
& " And " & "KHGIS.VWM_LIC_CP_BLK.PERM_PERMIT_ID = '" & CP & "'"
'MsgBox pQFilter.WhereClause
'====================
'Invalidate only the selection cache
'Flag the original selection
'====================
pActiveView.PartialRefresh esriViewGeoSelection, Nothing, Nothing
'==================
'Perform the selection
'==================
pFeatureSelection.SelectFeatures pQFilter, esriSelectionResultNew, False
'=================
'Flag the new selection
'=================
pActiveView.PartialRefresh esriViewGeoSelection, Nothing, Nothing
'========================
' Get the selected features
'========================
Dim pSelSet As ISelectionSet
Set pSelSet = pFeatureSelection.SelectionSet
Dim pEnumGeom As IEnumGeometry
Dim pEnumGeomBind As IEnumGeometryBind
Set pEnumGeom = New EnumFeatureGeometry
Set pEnumGeomBind = pEnumGeom
pEnumGeomBind.BindGeometrySource Nothing, pSelSet
Dim pGeomFactory As IGeometryFactory
Set pGeomFactory = New GeometryEnvironment
Dim pGeom As IGeometry
Set pGeom = pGeomFactory.CreateGeometryFromEnumerator(pEnumGeom)
'===================
'Zoom in to selected feature
'==================
mxDoc.ActiveView.Extent = pGeom.Envelope
mxDoc.ActiveView.Refresh
Dim pFLayer As IFeatureLayer
Dim pDataset As IDataset
Dim pDSName As IDatasetName
Dim pDispTable As IDisplayTable
Dim pShapeFCName As IDatasetName
Dim pShapeWSF As IWorkspaceFactory
Dim pShapeWS As IDataset
Dim pShapeWSName As IWorkspaceName
Dim pExportOp As IExportOperation
Set pFLayer = mxDoc.FocusMap.Layer(0)
Set pDispTable = pFLayer
Set pDataset = pDispTable.DisplayTable
Set pDSName = pDataset.FullName
Set pShapeWSF = New ShapefileWorkspaceFactory
Set pShapeWS = pShapeWSF.OpenFromFile("G:\kamloops\analysis\Cruise_Model_Test", 0)
Set pShapeWSName = pShapeWS.FullName
Set pShapeFCName = New FeatureClassName
pShapeFCName.Name = "Export_test"
Set pShapeFCName.WorkspaceName = pShapeWSName
' Set up query sub fields: a comma-delimited list of the fields you want
' Or "*" for all fields in the joined feature class
'Dim strFld As String
'strFld = "*"
'Set pQFilter = New QueryFilter
'pQFilter.SubFields = strFld
Set pExportOp = New ExportOperation
pExportOp.ExportFeatureClass pDSName, pQFilter, Nothing, Nothing, pShapeFCName, 0
'pMap.AddLayer pShapeFCName.WorkspaceName
Dim pWorkspaceFactory As IWorkspaceFactory
Dim pFeatureWorkspace As IFeatureWorkspace
'Dim pFeatureLayer As IFeatureLayer
'=========================================================================
'Create a new ShapefileWorkspaceFactory object and open a shapefile folder
'=========================================================================
Set pWorkspaceFactory = New ShapefileWorkspaceFactory
Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile("G:\kamloops\analysis\Cruise_Model_Test", 0)
'======================================================
'Create a new FeatureLayer and assign a shapefile to it
'======================================================
Set pFLayer = New FeatureLayer
Set pFLayer.FeatureClass = pFeatureWorkspace.OpenFeatureClass("Export_test")
pFLayer.Name = pFeatureLayer.FeatureClass.AliasName
'=====================================
'Add the FeatureLayer to the focus map
'=====================================
Set mxDoc = Application.Document
Set pMap = mxDoc.FocusMap
pMap.AddLayer pFLayer |