modgeneralfunctions.bas

一个不错的插件

Attribute VB_Name = "modGeneralFunctions"

' Copyright 2006 ESRI
'
' All rights reserved under the copyright laws of the United States
' and applicable international laws, treaties, and conventions.
'
' You may freely redistribute and use this sample code, with or
' without modification, provided you include the original copyright
' notice and use restrictions.
'
' See use restrictions at /arcgis/developerkit/userestrictions.


Option Explicit

Public Const c_DefaultFld_Shape = "SHAPE"
Public Const cPI = 3.14159265358979

Public Function GetUnitsDescription(pUnits As esriUnits) As String
    Select Case pUnits
        Case esriInches: GetUnitsDescription = "Inches"
        Case esriPoints: GetUnitsDescription = "Points"
        Case esriFeet: GetUnitsDescription = "Feet"
        Case esriYards: GetUnitsDescription = "Yards"
        Case esriMiles: GetUnitsDescription = "Miles"
        Case esriNauticalMiles: GetUnitsDescription = "Nautical miles"
        Case esriMillimeters: GetUnitsDescription = "Millimeters"
        Case esriCentimeters: GetUnitsDescription = "Centimeters"
        Case esriMeters: GetUnitsDescription = "Meters"
        Case esriKilometers: GetUnitsDescription = "Kilometers"
        Case esriDecimalDegrees: GetUnitsDescription = "Decimal degrees"
        Case esriDecimeters: GetUnitsDescription = "Decimeters"
        Case esriUnknownUnits: GetUnitsDescription = "Unknown"
        Case Else: GetUnitsDescription = "Unknown"
35:     End Select
End Function

Public Function GetActiveDataFrameName(pApp As IApplication) As String
    Dim pMx As IMxDocument
    Dim pFocusMap As IMap
    
42:     Set pMx = pApp.Document
43:     Set pFocusMap = pMx.FocusMap
    
45:     GetActiveDataFrameName = pFocusMap.Name
End Function

Public Function GetDataFrameElement(sDataFramName As String, pApp As IApplication) As IElement
' Get the data frame element by name
    Dim pGraphicsContainer As IGraphicsContainer
    Dim pElementProperties As IElementProperties
    Dim pElement As IElement
    Dim pMx As IMxDocument
    Dim pFE As IFrameElement
    Dim pElProps As IElementProperties
    
    On Error GoTo ErrorHandler
    
    ' Init
60:     Set pMx = pApp.Document
    ' Loop through the elements (in the layout)
62:     Set pGraphicsContainer = pMx.PageLayout
63:     pGraphicsContainer.Reset
64:     Set pElement = pGraphicsContainer.Next
65:     While Not pElement Is Nothing
        ' If type of element is an IFrameElement
67:         If TypeOf pElement Is IFrameElement Then
68:             Set pElProps = pElement
            ' If Name matches
70:             If UCase(pElProps.Name) = UCase(sDataFramName) Then
                ' Return element
72:                 Set GetDataFrameElement = pElement
73:                 Set pElement = Nothing
74:             Else
75:                 Set pElement = pGraphicsContainer.Next
76:             End If
77:         Else
78:             Set pElement = pGraphicsContainer.Next
79:         End If
80:     Wend
    
    Exit Function
ErrorHandler:
84:     Err.Raise Err.Number, Err.source, "Error in GetDataFrameElement:" _
        & vbCrLf & Err.Description
End Function

Public Function FindFeatureLayerByDS(DatasetName As String, pApp As IApplication) As IFeatureLayer
  
    On Error GoTo ErrorHandler
  
    Dim pMxDoc As IMxDocument
    Dim pMap As IMap
    Dim pFeatureLayer As IFeatureLayer
    Dim pDataset As IDataset
    Dim i As Integer
    
98:     Set pMxDoc = pApp.Document
99:     Set pMap = pMxDoc.FocusMap
  
101:     With pMap
102:         For i = 0 To .LayerCount - 1
103:             If TypeOf .Layer(i) Is IFeatureLayer Then
104:                 Set pFeatureLayer = .Layer(i)
105:                 Set pDataset = pFeatureLayer.FeatureClass
106:                 If UCase(pDataset.Name) = UCase(DatasetName) Then
107:                     Set FindFeatureLayerByDS = pFeatureLayer
108:                     Exit For
109:                 End If
110:             End If
111:         Next i
112:     End With
  
114:     If pFeatureLayer Is Nothing Then
115:         Err.Raise vbObjectError, "FindFeatureLayerByDS", "Error in " _
            & "FindFeatureLayerByDS:" & vbCrLf & "Could not locate " _
            & "layer with a dataset name of '" & DatasetName & "'."
118:     End If
  
    Exit Function
ErrorHandler:
122:     Err.Raise Err.Number, Err.source, "Error in routine: FindFeatureLayerByDS" _
        & vbCrLf & Err.Description
End Function

Public Function FindFeatureLayerByName(FLName As String, pApp As IApplication) As IFeatureLayer
  
    On Error GoTo ErrorHandler
  
    Dim pMxDoc As IMxDocument
    Dim pMap As IMap
    Dim pFeatureLayer As IFeatureLayer
    Dim pDataset As IDataset
    Dim i As Integer
    
136:     Set pMxDoc = pApp.Document
137:     Set pMap = pMxDoc.FocusMap
  
139:     With pMap
140:         For i = 0 To .LayerCount - 1
141:             If TypeOf .Layer(i) Is IFeatureLayer Then
142:                 Set pFeatureLayer = .Layer(i)
143:                 If UCase(pFeatureLayer.Name) = UCase(FLName) Then
144:                     Set FindFeatureLayerByName = pFeatureLayer
145:                     Exit For
146:                 End If
147:             End If
148:         Next i
149:     End With
  
151:     If pFeatureLayer Is Nothing Then
152:         Err.Raise vbObjectError, "FindFeatureLayerByName", "Error in " _
            & "FindFeatureLayerByName:" & vbCrLf & "Could not locate " _
            & "layer with a Name of '" & FLName & "'."
155:     End If
  
    Exit Function
ErrorHandler:
159:     Err.Raise Err.Number, Err.source, "Error in routine: FindFeatureLayerByName" _
        & vbCrLf & Err.Description
End Function

Public Function GetValidExtentForLayer(pFL As IFeatureLayer) As IEnvelope
    Dim pGeoDataset As IGeoDataset
    Dim pMx As IMxDocument
    Dim pW As IWorkspace
    Dim pWSR As IWorkspaceSpatialReferenceInfo
    Dim pEnumSRI As IEnumSpatialReferenceInfo
    Dim pSR As ISpatialReference
    Dim dX1 As Double, dY1 As Double
    Dim dX2 As Double, dY2 As Double
    Dim pP As IPoint
    
174:     If Not pFL Is Nothing Then
175:         If Not pFL.FeatureClass Is Nothing Then
176:             If TypeOf pFL.FeatureClass Is IGeoDataset Then
177:                 If pFL.FeatureClass.FeatureDataset Is Nothing Then
178:                     dX1 = -1000000000
179:                     dY1 = -1000000000
180:                     dX2 = 1000000000
181:                     dY2 = 1000000000
182:                 Else
183:                     Set pW = pFL.FeatureClass.FeatureDataset.Workspace
184:                     Set pWSR = pW
185:                     Set pEnumSRI = pWSR.SpatialReferenceInfo
186:                     Set pSR = pEnumSRI.Next(0)
187:                     pSR.GetDomain dX1, dX2, dY1, dY2
188:                 End If
189:                 Set pP = New esrigeometry.Point
190:                 Set GetValidExtentForLayer = New Envelope
191:                 pP.PutCoords dX1, dY1
192:                 GetValidExtentForLayer.LowerLeft = pP
193:                 pP.PutCoords dX2, dY2
194:                 GetValidExtentForLayer.UpperRight = pP
195:             Else
196:                 Err.Raise vbObjectError, "GetValidExtentForLayer", _
                    "The 'FeatureClass' property for the IFeatureLayer parameter is not an IGeoDataset"
198:             End If
199:         Else
200:             Err.Raise vbObjectError, "GetValidExtentForLayer", _
                "The IFeatureLayer parameter does not have a valid FeatureClass property"
202:         End If
203:     Else
204:         Err.Raise vbObjectError, "GetValidExtentForLayer", _
            "The IFeatureLayer parameter is set to Nothing"
206:     End If
End Function

Public Function DoesShapeFileExist(pPath As String) As Boolean
  Dim pTruncPath As String
211:   If InStr(1, pPath, ".shp") > 0 Then
212:     pTruncPath = Left(pPath, InStr(1, pPath, ".shp") - 1)
213:   Else
214:     pTruncPath = pPath
215:   End If
      
  'Make sure the specified file does not exist
  Dim fs As Object
219:   Set fs = CreateObject("Scripting.FileSystemObject")
220:   If fs.fileexists(pTruncPath & ".shp") Or fs.fileexists(pTruncPath & ".dbf") Or _
   fs.fileexists(pTruncPath & ".shx") Then
222:     DoesShapeFileExist = True
223:   Else
224:     DoesShapeFileExist = False
225:   End If
End Function

Private Function DoesFeatureClassExist(location As IGxObject, newObjectName As String) As Boolean
On Error GoTo ErrHand:
  Dim pFeatClass As IFeatureClass
  Dim pFeatDataset As IGxDataset
232:   Set pFeatDataset = location
  Dim pFeatClassCont As IFeatureClassContainer, pData As IFeatureDataset
234:   Set pData = pFeatDataset.Dataset
235:   Set pFeatClassCont = pData
  Dim pEnumClass As IEnumFeatureClass, pDataset As IDataset
237:   Set pEnumClass = pFeatClassCont.Classes
238:   Set pFeatClass = pEnumClass.Next
239:   While Not pFeatClass Is Nothing
240:     Set pDataset = pFeatClass
241:     If UCase(pDataset.Name) = UCase(newObjectName) Then
242:       DoesFeatureClassExist = True
      Exit Function
244:     End If
      
246:     Set pFeatClass = pEnumClass.Next
247:   Wend
248:   DoesFeatureClassExist = False
  
  Exit Function
ErrHand:
252:   MsgBox Err.Description
End Function

Public Function NewAccessFile(pDatabase As String, _
 pNewDataSet As String, pNewFile As String, Optional pMoreFields As IFields) As IFeatureClass
On Error GoTo ErrorHandler

    Dim pName As IName
    Dim pOutShpWspName As IWorkspaceName
    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 pFeatureWorkspace As IFeatureWorkspace
    Dim pDataset As IFeatureDataset
    Dim shapeFieldName As String