POST
|
Hello, I'm using some VBA code that I found on here that will convert selected graphics on a map to features and then add those new features to an existing dataset. Once an edit session is open, the code gets the selected graphics, starts an edit operation, adds the new features, and then stops the edit operation. The code works well and does exactly what I need it to do, but there is a problem. Every time I go and manually save new features that were added to the dataset, the Save Edits process gets slower and slower every time the command it run. Eventually, the save process slows to such a crawl that I have to end the process by shutting down the Mx document. I wonder if this is some kind of memory issue because when I open up the map document again then saving edits starts out fast, but then the process starts to slow again after saving a few times. I've tried to free up some of the objects after executing the code, but to no avail. Does anyone have ideas why it's doing this? I've attached the code below. Thanks,
Private Sub UIButtonControl1_Click()
Dim pMxApp As IMxApplication
Dim pMxDoc As IMxDocument
Dim pID As New UID
Dim pEditor As IEditor
Dim pGraphicsContainer As IGraphicsContainer
Dim pGraphContSel As IGraphicsContainerSelect
Set pMxApp = Application
Set pMxDoc = ThisDocument
pID = "esriEditor.Editor" 'version 9.0 compatible. Previously: PID = "esriCore.Editor"
Set pEditor = Application.FindExtensionByCLSID(pID)
Set pGraphicsContainer = pMxDoc.FocusMap
Set pGraphContSel = pGraphicsContainer
Dim pEditLayers As IEditLayers
Dim pFeatureLayer As IFeatureLayer
Set pEditLayers = pEditor
Set pFeatureLayer = pEditLayers.CurrentLayer
Dim pGraphicElementEnum As IEnumElement
Set pGraphicElementEnum = pGraphContSel.SelectedElements 'get selected graphics
pGraphicElementEnum.Reset
Dim pElement As IElement
Set pElement = pGraphicElementEnum.Next
'check if edit session is present
If Not pEditor.EditState = esriStateEditing Then
MsgBox "You must start an edit session before using this tool.", vbExclamation, "Editing must be enabled"
Exit Sub
End If
'check if graphics are selected
If pElement Is Nothing Then
MsgBox "Please select a graphic to save", vbExclamation, "Select graphic(s) to save"
Exit Sub
End If
pEditor.StartOperation
On Error GoTo Error_Handler
Do While Not pElement Is Nothing 'loop through the graphics
Dim pGeom As IGeometry
Set pGeom = pElement.Geometry
If pGeom.GeometryType = pFeatureLayer.FeatureClass.ShapeType Then
'geometry types of graphic and output feature layer are the same
Dim pFeature As IFeature
Set pFeature = pFeatureLayer.FeatureClass.CreateFeature 'create new output feature
Dim pGeoDef As IGeometryDef
Dim pZAw As IZAware
Dim pMAw As IMAware
Dim pFld As Long
pFld = pFeatureLayer.FeatureClass.FindField(pFeatureLayer.FeatureClass.ShapeFieldName)
'find Geometry field
Set pGeoDef = pFeatureLayer.FeatureClass.Fields.Field(pFld).GeometryDef
Set pZAw = pGeom
If pGeoDef.HasZ Then 'Test if output layer is Z aware.
'The Z values of points and polyline/polygon vertices need to be set to zero,
'or an error will result when feature is saved to the output feature class
pZAw.ZAware = True 'make feature Z aware
If pGeom.GeometryType <> esriGeometryPoint Then
'problem: Points do not implement the IZ interface and must be treated differently
Dim pZ As IZ
Set pZ = pGeom
pZ.SetConstantZ 0 'set all Z values of vertices to zero
Else
'point features need to have their Z values set to zero
Dim pPt As esriGeometry.IPoint 'changed from version 8.3, previously esriCore.IPoint
Set pPt = pGeom
pPt.Z = 0
End If
End If
Set pMAw = pGeom
If pGeoDef.HasM Then 'test if output feature class has M values
Set pMAw = pGeom
pMAw.MAware = True 'make new feature M aware
End If
'store new feature
Set pFeature.Shape = pGeom
pFeature.Store
'delete the graphic element after it has been converted to a feature
pGraphicsContainer.DeleteElement pElement
End If
Set pElement = pGraphicElementEnum.Next
Loop
pEditor.StopOperation "Convert Features from Graphics" 'allows ability to "undo" edits
pMxDoc.ActiveView.Refresh
Exit Sub
Error_Handler:
pEditor.AbortOperation
MsgBox Err.Description
End Sub
... View more
08-24-2010
04:59 AM
|
0
|
0
|
1849
|
Online Status |
Offline
|
Date Last Visited |
11-11-2020
02:23 AM
|