modgeneralfunctions.bas

使用VB和ArcObject结合的程序

    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 pFeatureWorkspace As IFeatureWorkspace
    Dim pDataset As IFeatureDataset
    Dim shapeFieldName As String
    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
  
265:     Set pOutShpWspName = New WorkspaceName

267:     pOutShpWspName.PathName = pDatabase
268:     pOutShpWspName.WorkspaceFactoryProgID = "esriDataSourcesGDB.AccessWorkspaceFactory"
269:     Set pName = pOutShpWspName
270:     Set pShapeWorkspace = pName.Open
271: i = 1
    'Open the dataset
273:     Set pFeatureWorkspace = pShapeWorkspace
274:     Set pDataset = pFeatureWorkspace.OpenFeatureDataset(pNewDataSet)
275: i = 2
    ' Add the SHAPE field (based on the dataset)
277:     Set pFieldsEdit = pMoreFields
278:     Set pField = New Field
279:     Set newFieldEdit = pField
280:     With newFieldEdit
281:         .Name = c_DefaultFld_Shape
282:         .Type = esriFieldTypeGeometry
283:         .IsNullable = True
284:         .Editable = True
285:     End With
286:     Set pGeomDef = New GeometryDef
287:     Set pGeomDefEdit = pGeomDef
288:     With pGeomDefEdit
289:         .GeometryType = esriGeometryPolygon
290:         If TypeOf pDataset Is IGeoDataset Then
291:             Set pGeoDataset = pDataset
292:             Set .SpatialReference = pGeoDataset.SpatialReference
293:         Else
294:             Set .SpatialReference = New UnknownCoordinateSystem
295:         End If
296:         .GridCount = 1
297:         .GridSize(0) = 200
298:         .HasM = False
299:         .HasZ = False
300:         .AvgNumPoints = 4
301:     End With
302:     Set newFieldEdit.GeometryDef = pGeomDef
303:     pFieldsEdit.AddField pField
    ' Check the fields
305:     Set pFieldChecker = New FieldChecker
306:     Set pFieldChecker.ValidateWorkspace = pShapeWorkspace
307:     Set pNewFields = pMoreFields
308: i = 3
309:     Set pClone = pNewFields
310:     Set pCloneFields = pClone.Clone
311:     pFieldChecker.Validate pCloneFields, pErrorEnum, pOutputFields
      
  ' Create the output featureclass
  Dim pUID As New UID
315:   pUID = "{52353152-891A-11D0-BEC6-00805F7C4268}"
316:     shapeFieldName = c_DefaultFld_Shape
317: i = 4
318:     Set pNewFeatClass = pDataset.CreateFeatureClass(pNewFile, pOutputFields, pUID, Nothing, esriFTSimple, shapeFieldName, "")
319: i = 5
320:     Set NewAccessFile = pNewFeatClass
  
    Exit Function
  
ErrorHandler:
325:     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
350:     Set pOutShpWspName = New WorkspaceName
351:     pOutShpWspName.PathName = EntryName(pNewFile)
352:     pOutShpWspName.WorkspaceFactoryProgID = "esriDataSourcesFile.ShapefileWorkspaceFactory.1"
353:     Set pName = pOutShpWspName
354:     Set pShapeWorkspace = pName.Open
    ' Add the SHAPE field (based on the Map)
356:     Set pFieldsEdit = pMoreFields
357:     Set pField = New Field
358:     Set newFieldEdit = pField
359:     newFieldEdit.Name = c_DefaultFld_Shape
360:     newFieldEdit.Type = esriFieldTypeGeometry
361:     Set pGeomDef = New GeometryDef
362:     Set pGeomDefEdit = pGeomDef
363:     With pGeomDefEdit
364:         .GeometryType = esriGeometryPolygon
365:         Set .SpatialReference = pMap.SpatialReference
366:     End With
367:     Set newFieldEdit.GeometryDef = pGeomDef
368:     pFieldsEdit.AddField pField
    ' Validate field names
370:     Set pFieldChecker = New FieldChecker
371:     Set pFieldChecker.ValidateWorkspace = pShapeWorkspace
372:     Set pNewFields = pMoreFields
373:     Set pClone = pNewFields
374:     Set pCloneFields = pClone.Clone
375:     pFieldChecker.Validate pCloneFields, pErrorEnum, pOutputFields
    ' Create the output featureclass
377:     shapeFieldName = c_DefaultFld_Shape
378:     featureclassName = Mid(pNewFile, Len(pOutShpWspName.PathName) + 2)
379:     Set pFeatureWorkspace = pShapeWorkspace
380:     Set pNewFeatClass = pFeatureWorkspace.CreateFeatureClass(featureclassName, pOutputFields, _
                            Nothing, Nothing, esriFTSimple, shapeFieldName, "")
    ' Return
383:     Set NewShapeFile = pNewFeatClass
  
    Exit Function
  
ErrorHandler:
388:     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
395:   iLength = Len(sFile)
  Dim iCounter As Integer
  Dim sDelim As String
398:   sDelim = "\"
  Dim sRight As String
  
401:   For iCounter = iLength To 0 Step -1
    
403:     If Mid$(sFile, iCounter, 1) = sDelim Then
404:       EntryName = Mid$(sFile, 1, (iCounter - 1))
405:       Exit For
406:     End If
  
408:   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
416:   Set pDoc = pApp.Document
417:   Set pMap = FindDataFrame(pDoc, pSeriesProps.DataFrameName)
  If pMap Is Nothing Then Exit Sub
  
420:   pMap.ClipGeometry = Nothing

  Exit Sub
ErrHand:
424:   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
432:   Set pDoc = pApp.Document
433:   Set pPage = pDoc.PageLayout
434:   Set pDelColl = New Collection
435:   Set pGraphCont = pPage
436:   pGraphCont.Reset
437:   Set pElem = pGraphCont.Next
438:   Do While Not pElem Is Nothing
439:     If TypeOf pElem Is IMapFrame Then
440:       Set pMapFrame = pElem
441:       If pMapFrame.Map.Name = "Local Indicator" Or _
       pMapFrame.Map.Name = "Global Indicator" Then
443:         pDelColl.Add pMapFrame
444:       End If
445:     End If
    
447:     Set pElem = pGraphCont.Next
448:   Loop
  
450:   For lLoop = 1 To pDelColl.count
451:     pGraphCont.DeleteElement pDelColl.Item(lLoop)
452:   Next lLoop

  Exit Sub
ErrHand:
456:   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.
464:   Set pGraphicsCont = pDoc.PageLayout
465:   pGraphicsCont.Reset
466:   Set pTempColl = New Collection
467:   Set pElemProps = pGraphicsCont.Next
468:   Do While Not pElemProps Is Nothing
469:     If pElemProps.Name = "DSMAPBOOK TEXT" Then
470:       pTempColl.Add pElemProps
471:     End If
472:     Set pElemProps = pGraphicsCont.Next
473:   Loop
474:   For lLoop = 1 To pTempColl.count
475:     pGraphicsCont.DeleteElement pTempColl.Item(lLoop)
476:   Next lLoop
477:   Set pTempColl = Nothing

  Exit Sub
ErrHand:
481:   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
487:   Set pMapBookExt = pApp.FindExtensionByName("DevSample_MapBook")
488:   If pMapBookExt Is Nothing Then
489:     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!!!"
491:     Set GetMapBookExtension = Nothing
    Exit Function
493:   End If
  
495:   Set GetMapBookExtension = pMapBookExt.MapBook

  Exit Function
ErrHand:
499:   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
507:   Set pGraphs = pDoc.FocusMap
508:   pGraphs.Reset
509:   Set pElemProps = pGraphs.Next
510:   Do While Not pElemProps Is Nothing
511:     If TypeOf pElemProps Is IPolygonElement Then
512:       If UCase(pElemProps.Name) = "DSMAPBOOK CLIP ELEMENT" Then
513:         pGraphs.DeleteElement pElemProps
514:         Exit Do
515:       End If
516:     End If
517:     Set pElemProps = pGraphs.Next
518:   Loop
519:   pDoc.ActiveView.PartialRefresh esriViewGraphics, Nothing, Nothing

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