modgeneralfunctions.bas

使用VB和ArcObject结合的程序

Attribute VB_Name = "modGeneralFunctions"

' Copyright 1995-2004 ESRI

' All rights reserved under the copyright laws of the United States.

' You may freely redistribute and use this sample code, with or without modification.

' Disclaimer: THE SAMPLE CODE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED 
' WARRANTIES, INCLUDING THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 
' FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ESRI OR 
' CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, 
' OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 
' SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
' INTERRUPTION) SUSTAINED BY YOU OR A THIRD PARTY, HOWEVER CAUSED AND ON ANY 
' THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ARISING IN ANY 
' WAY OUT OF THE USE OF THIS SAMPLE CODE, EVEN IF ADVISED OF THE POSSIBILITY OF 
' SUCH DAMAGE.

' For additional information contact: Environmental Systems Research Institute, Inc.

' Attn: Contracts Dept.

' 380 New York Street

' Redlands, California, U.S.A. 92373 

' Email: [e-mail]


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"
22:     End Select
End Function

Public Function GetActiveDataFrameName(pApp As IApplication) As String
    Dim pMx As IMxDocument
    Dim pFocusMap As IMap
    
29:     Set pMx = pApp.Document
30:     Set pFocusMap = pMx.FocusMap
    
32:     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
47:     Set pMx = pApp.Document
    ' Loop through the elements (in the layout)
49:     Set pGraphicsContainer = pMx.PageLayout
50:     pGraphicsContainer.Reset
51:     Set pElement = pGraphicsContainer.Next
52:     While Not pElement Is Nothing
        ' If type of element is an IFrameElement
54:         If TypeOf pElement Is IFrameElement Then
55:             Set pElProps = pElement
            ' If Name matches
57:             If UCase(pElProps.Name) = UCase(sDataFramName) Then
                ' Return element
59:                 Set GetDataFrameElement = pElement
60:                 Set pElement = Nothing
61:             Else
62:                 Set pElement = pGraphicsContainer.Next
63:             End If
64:         Else
65:             Set pElement = pGraphicsContainer.Next
66:         End If
67:     Wend
    
    Exit Function
ErrorHandler:
71:     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
    
85:     Set pMxDoc = pApp.Document
86:     Set pMap = pMxDoc.FocusMap
  
88:     With pMap
89:         For i = 0 To .LayerCount - 1
90:             If TypeOf .Layer(i) Is IFeatureLayer Then
91:                 Set pFeatureLayer = .Layer(i)
92:                 Set pDataset = pFeatureLayer.FeatureClass
93:                 If UCase(pDataset.Name) = UCase(DatasetName) Then
94:                     Set FindFeatureLayerByDS = pFeatureLayer
95:                     Exit For
96:                 End If
97:             End If
98:         Next i
99:     End With
  
101:     If pFeatureLayer Is Nothing Then
102:         Err.Raise vbObjectError, "FindFeatureLayerByDS", "Error in " _
            & "FindFeatureLayerByDS:" & vbCrLf & "Could not locate " _
            & "layer with a dataset name of '" & DatasetName & "'."
105:     End If
  
    Exit Function
ErrorHandler:
109:     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
    
123:     Set pMxDoc = pApp.Document
124:     Set pMap = pMxDoc.FocusMap
  
126:     With pMap
127:         For i = 0 To .LayerCount - 1
128:             If TypeOf .Layer(i) Is IFeatureLayer Then
129:                 Set pFeatureLayer = .Layer(i)
130:                 If UCase(pFeatureLayer.Name) = UCase(FLName) Then
131:                     Set FindFeatureLayerByName = pFeatureLayer
132:                     Exit For
133:                 End If
134:             End If
135:         Next i
136:     End With
  
138:     If pFeatureLayer Is Nothing Then
139:         Err.Raise vbObjectError, "FindFeatureLayerByName", "Error in " _
            & "FindFeatureLayerByName:" & vbCrLf & "Could not locate " _
            & "layer with a Name of '" & FLName & "'."
142:     End If
  
    Exit Function
ErrorHandler:
146:     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
    
161:     If Not pFL Is Nothing Then
162:         If Not pFL.FeatureClass Is Nothing Then
163:             If TypeOf pFL.FeatureClass Is IGeoDataset Then
164:                 If pFL.FeatureClass.FeatureDataset Is Nothing Then
165:                     dX1 = -1000000000
166:                     dY1 = -1000000000
167:                     dX2 = 1000000000
168:                     dY2 = 1000000000
169:                 Else
170:                     Set pW = pFL.FeatureClass.FeatureDataset.Workspace
171:                     Set pWSR = pW
172:                     Set pEnumSRI = pWSR.SpatialReferenceInfo
173:                     Set pSR = pEnumSRI.Next(0)
174:                     pSR.GetDomain dX1, dX2, dY1, dY2
175:                 End If
176:                 Set pP = New esrigeometry.Point
177:                 Set GetValidExtentForLayer = New Envelope
178:                 pP.PutCoords dX1, dY1
179:                 GetValidExtentForLayer.LowerLeft = pP
180:                 pP.PutCoords dX2, dY2
181:                 GetValidExtentForLayer.UpperRight = pP
182:             Else
183:                 Err.Raise vbObjectError, "GetValidExtentForLayer", _
                    "The 'FeatureClass' property for the IFeatureLayer parameter is not an IGeoDataset"
185:             End If
186:         Else
187:             Err.Raise vbObjectError, "GetValidExtentForLayer", _
                "The IFeatureLayer parameter does not have a valid FeatureClass property"
189:         End If
190:     Else
191:         Err.Raise vbObjectError, "GetValidExtentForLayer", _
            "The IFeatureLayer parameter is set to Nothing"
193:     End If
End Function

Public Function DoesShapeFileExist(pPath As String) As Boolean
  Dim pTruncPath As String
198:   If InStr(1, pPath, ".shp") > 0 Then
199:     pTruncPath = Left(pPath, InStr(1, pPath, ".shp") - 1)
200:   Else
201:     pTruncPath = pPath
202:   End If
      
  'Make sure the specified file does not exist
  Dim fs As Object
206:   Set fs = CreateObject("Scripting.FileSystemObject")
207:   If fs.fileexists(pTruncPath & ".shp") Or fs.fileexists(pTruncPath & ".dbf") Or _
   fs.fileexists(pTruncPath & ".shx") Then
209:     DoesShapeFileExist = True
210:   Else
211:     DoesShapeFileExist = False
212:   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
219:   Set pFeatDataset = location
  Dim pFeatClassCont As IFeatureClassContainer, pData As IFeatureDataset
221:   Set pData = pFeatDataset.Dataset
222:   Set pFeatClassCont = pData
  Dim pEnumClass As IEnumFeatureClass, pDataset As IDataset
224:   Set pEnumClass = pFeatClassCont.Classes
225:   Set pFeatClass = pEnumClass.Next
226:   While Not pFeatClass Is Nothing
227:     Set pDataset = pFeatClass
228:     If UCase(pDataset.Name) = UCase(newObjectName) Then
229:       DoesFeatureClassExist = True
      Exit Function
231:     End If
      
233:     Set pFeatClass = pEnumClass.Next
234:   Wend
235:   DoesFeatureClassExist = False
  
  Exit Function
ErrHand:
239:   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