modgeneralfunctions.bas

一个不错的插件

    Dim pNewFeatClass As IFeatureClass
    Dim pFieldsEdit As IFieldsEdit
    Dim newFieldEdit As IFieldEdit
    Dim pGeomDef As IGeometryDef
    Dim pGeomDefEdit As IGeometryDefEdit
    Dim pGeoDataset As IGeoDataset
    Dim i As Integer
  
278:     Set pOutShpWspName = New WorkspaceName

280:     pOutShpWspName.PathName = pDatabase
281:     pOutShpWspName.WorkspaceFactoryProgID = "esriDataSourcesGDB.AccessWorkspaceFactory"
282:     Set pName = pOutShpWspName
283:     Set pShapeWorkspace = pName.Open
284: i = 1
    'Open the dataset
286:     Set pFeatureWorkspace = pShapeWorkspace
287:     Set pDataset = pFeatureWorkspace.OpenFeatureDataset(pNewDataSet)
288: i = 2
    ' Add the SHAPE field (based on the dataset)
290:     Set pFieldsEdit = pMoreFields
291:     Set pField = New Field
292:     Set newFieldEdit = pField
293:     With newFieldEdit
294:         .Name = c_DefaultFld_Shape
295:         .Type = esriFieldTypeGeometry
296:         .IsNullable = True
297:         .Editable = True
298:     End With
299:     Set pGeomDef = New GeometryDef
300:     Set pGeomDefEdit = pGeomDef
301:     With pGeomDefEdit
302:         .GeometryType = esriGeometryPolygon
303:         If TypeOf pDataset Is IGeoDataset Then
304:             Set pGeoDataset = pDataset
305:             Set .SpatialReference = pGeoDataset.SpatialReference
306:         Else
307:             Set .SpatialReference = New UnknownCoordinateSystem
308:         End If
309:         .GridCount = 1
310:         .GridSize(0) = 200
311:         .HasM = False
312:         .HasZ = False
313:         .AvgNumPoints = 4
314:     End With
315:     Set newFieldEdit.GeometryDef = pGeomDef
316:     pFieldsEdit.AddField pField
    ' Check the fields
318:     Set pFieldChecker = New FieldChecker
319:     Set pFieldChecker.ValidateWorkspace = pShapeWorkspace
320:     Set pNewFields = pMoreFields
321: i = 3
322:     Set pClone = pNewFields
323:     Set pCloneFields = pClone.Clone
324:     pFieldChecker.Validate pCloneFields, pErrorEnum, pOutputFields
      
  ' Create the output featureclass
  Dim pUID As New UID
328:   pUID = "{52353152-891A-11D0-BEC6-00805F7C4268}"
329:     shapeFieldName = c_DefaultFld_Shape
330: i = 4
331:     Set pNewFeatClass = pDataset.CreateFeatureClass(pNewFile, pOutputFields, pUID, Nothing, esriFTSimple, shapeFieldName, "")
332: i = 5
333:     Set NewAccessFile = pNewFeatClass
  
    Exit Function
  
ErrorHandler:
338:     MsgBox Err.Number & " " & Err.Description, vbCritical, "Error in NewAccessFile " & i
End Function

Public Function NewShapeFile(pNewFile As String, pMap As IMap, _
            Optional pMoreFields As IFields) As IFeatureClass
    On Error GoTo ErrorHandler

    Dim pOutShpWspName As IWorkspaceName
    Dim pName As IName
    Dim pShapeWorkspace As IWorkspace
    Dim pOutputFields As IFields
    Dim pFieldChecker As IFieldChecker
    Dim pErrorEnum As IEnumFieldError
    Dim pNewFields As IFields, pField As IField
    Dim pClone As IClone, pCloneFields As IFields
    Dim featureclassName As String, pNewFeatClass As IFeatureClass
    Dim pFeatureWorkspace As IFeatureWorkspace
    Dim pUID As IUID
    Dim shapeFieldName As String
    Dim pFieldsEdit As IFieldsEdit
    Dim newFieldEdit As IFieldEdit
    Dim pGeomDef As IGeometryDef
    Dim pGeomDefEdit As IGeometryDefEdit
    
    ' Open the workspace for the new shapefile
363:     Set pOutShpWspName = New WorkspaceName
364:     pOutShpWspName.PathName = EntryName(pNewFile)
365:     pOutShpWspName.WorkspaceFactoryProgID = "esriDataSourcesFile.ShapefileWorkspaceFactory.1"
366:     Set pName = pOutShpWspName
367:     Set pShapeWorkspace = pName.Open
    ' Add the SHAPE field (based on the Map)
369:     Set pFieldsEdit = pMoreFields
370:     Set pField = New Field
371:     Set newFieldEdit = pField
372:     newFieldEdit.Name = c_DefaultFld_Shape
373:     newFieldEdit.Type = esriFieldTypeGeometry
374:     Set pGeomDef = New GeometryDef
375:     Set pGeomDefEdit = pGeomDef
376:     With pGeomDefEdit
377:         .GeometryType = esriGeometryPolygon
378:         Set .SpatialReference = pMap.SpatialReference
379:     End With
380:     Set newFieldEdit.GeometryDef = pGeomDef
381:     pFieldsEdit.AddField pField
    ' Validate field names
383:     Set pFieldChecker = New FieldChecker
384:     Set pFieldChecker.ValidateWorkspace = pShapeWorkspace
385:     Set pNewFields = pMoreFields
386:     Set pClone = pNewFields
387:     Set pCloneFields = pClone.Clone
388:     pFieldChecker.Validate pCloneFields, pErrorEnum, pOutputFields
    ' Create the output featureclass
390:     shapeFieldName = c_DefaultFld_Shape
391:     featureclassName = Mid(pNewFile, Len(pOutShpWspName.PathName) + 2)
392:     Set pFeatureWorkspace = pShapeWorkspace
393:     Set pNewFeatClass = pFeatureWorkspace.CreateFeatureClass(featureclassName, pOutputFields, _
                            Nothing, Nothing, esriFTSimple, shapeFieldName, "")
    ' Return
396:     Set NewShapeFile = pNewFeatClass
  
    Exit Function
  
ErrorHandler:
401:     MsgBox "Error creating " & pNewFile & vbCrLf & Err.Number & ": " & Err.Description, _
        vbCritical, "Error in NewShapefile"
End Function

Public Function EntryName(sFile As String) As String
  ' work from the right side to the first file delimeter
  Dim iLength As Integer
408:   iLength = Len(sFile)
  Dim iCounter As Integer
  Dim sDelim As String
411:   sDelim = "\"
  Dim sRight As String
  
414:   For iCounter = iLength To 0 Step -1
    
416:     If Mid$(sFile, iCounter, 1) = sDelim Then
417:       EntryName = Mid$(sFile, 1, (iCounter - 1))
418:       Exit For
419:     End If
  
421:   Next
  
End Function

Public Sub TurnOffClipping(pSeriesProps As IDSMapSeriesProps, pApp As IApplication)
On Error GoTo ErrHand:
  Dim pMap As IMap, pDoc As IMxDocument
  'Find the data frame
429:   Set pDoc = pApp.Document
430:   Set pMap = FindDataFrame(pDoc, pSeriesProps.DataFrameName)
  If pMap Is Nothing Then Exit Sub
  
433:   pMap.ClipGeometry = Nothing

  Exit Sub
ErrHand:
437:   MsgBox "TurnOffClipping - " & Err.Description
End Sub

Public Sub RemoveIndicators(pApp As IApplication)
On Error GoTo ErrHand:
  Dim lLoop As Long, pDoc As IMxDocument, pDelColl As Collection
  Dim pPage As IPageLayout, pGraphCont As IGraphicsContainer
  Dim pElem As IElement, pMapFrame As IMapFrame
445:   Set pDoc = pApp.Document
446:   Set pPage = pDoc.PageLayout
447:   Set pDelColl = New Collection
448:   Set pGraphCont = pPage
449:   pGraphCont.Reset
450:   Set pElem = pGraphCont.Next
451:   Do While Not pElem Is Nothing
452:     If TypeOf pElem Is IMapFrame Then
453:       Set pMapFrame = pElem
454:       If pMapFrame.Map.Name = "Local Indicator" Or _
       pMapFrame.Map.Name = "Global Indicator" Then
456:         pDelColl.Add pMapFrame
457:       End If
458:     End If
    
460:     Set pElem = pGraphCont.Next
461:   Loop
  
463:   For lLoop = 1 To pDelColl.count
464:     pGraphCont.DeleteElement pDelColl.Item(lLoop)
465:   Next lLoop

  Exit Sub
ErrHand:
469:   MsgBox "RemoveIndicators - " & Err.Description
End Sub

Public Sub RemoveLabels(pDoc As IMxDocument)
On Error GoTo ErrHand:
  Dim pGraphicsCont As IGraphicsContainer
  Dim pTempColl As Collection, pElemProps As IElementProperties, lLoop As Long
  'Remove any previous neighbor labels.
477:   Set pGraphicsCont = pDoc.PageLayout
478:   pGraphicsCont.Reset
479:   Set pTempColl = New Collection
480:   Set pElemProps = pGraphicsCont.Next
481:   Do While Not pElemProps Is Nothing
482:     If pElemProps.Name = "DSMAPBOOK TEXT" Then
483:       pTempColl.Add pElemProps
484:     End If
485:     Set pElemProps = pGraphicsCont.Next
486:   Loop
487:   For lLoop = 1 To pTempColl.count
488:     pGraphicsCont.DeleteElement pTempColl.Item(lLoop)
489:   Next lLoop
490:   Set pTempColl = Nothing

  Exit Sub
ErrHand:
494:   MsgBox "RemoveLabels - " & Err.Description
End Sub

Public Function GetMapBookExtension(pApp As IApplication) As IDSMapBook
On Error GoTo ErrHand:
  Dim pMapBookExt As DSMapBookExt, pMapBook As IDSMapBook
500:   Set pMapBookExt = pApp.FindExtensionByName("DevSample_MapBook")
501:   If pMapBookExt Is Nothing Then
502:     MsgBox "Map Book code not installed properly!!  Make sure you can access the regsvr32 command" & vbCrLf & _
     "and rerun the _Install.bat batch file!!", , "Map Book Extension Not Found!!!"
504:     Set GetMapBookExtension = Nothing
    Exit Function
506:   End If
  
508:   Set GetMapBookExtension = pMapBookExt.MapBook

  Exit Function
ErrHand:
512:   MsgBox "GetMapBookExtension - " & Err.Description
End Function

Public Sub RemoveClipElement(pDoc As IMxDocument)
On Error GoTo ErrHand:
  Dim pGraphs As IGraphicsContainer, pElemProps As IElementProperties
  
  'Search for an existing clip element and delete it when found
520:   Set pGraphs = pDoc.FocusMap
521:   pGraphs.Reset
522:   Set pElemProps = pGraphs.Next
523:   Do While Not pElemProps Is Nothing
524:     If TypeOf pElemProps Is IPolygonElement Then
525:       If UCase(pElemProps.Name) = "DSMAPBOOK CLIP ELEMENT" Then
526:         pGraphs.DeleteElement pElemProps
527:         Exit Do
528:       End If
529:     End If
530:     Set pElemProps = pGraphs.Next
531:   Loop
532:   pDoc.ActiveView.PartialRefresh esriViewGraphics, Nothing, Nothing

  Exit Sub
ErrHand:
536:   MsgBox "RemoveClipElement - " & Erl & " - " & Err.Description
End Sub