clscreategrids.cls

使用VB和ArcObject结合的程序

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsCreateGrids"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True

' 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

'----------------------------------------------
' Properties
' - DestinationFeatureClass (IFeatureClass, r/w)
' - MapScale (Double, r/w)
' - FrameWidthInPageUnits (Double, r/w)
' - FrameHeightInPageUnits (Double, r/w)
' - IdentifierOrder (mgGridIdentifierOrderType, r/w)
' - RowIDType (mgGridIdentifierValueType, r/w)
' - ColIDType (mgGridIdentifierValueType, r/w)
' - StartingCoordinateLL_X (Double, r/w)
' - StartingCoordinateLL_Y (Double, r/w)
' - EndingCoordinateUR_X (Double, r/w)
' - EndingCoordinateUR_Y (Double, r/w)
' - UseUnderscore (Boolean, r/w)
'----------------------------------------------
' Methods
' - GenerateGrids(pApp as IApplication)
'    : Generates the grids using the values added.
' - RunStandardGUI(pApp as IApplication)
'    : To open the form without having the button
'      added to ArcMap's GUI.
'----------------------------------------------
' Enumerated Types
Public Enum mgGridIdentifierOrderType
    Row_Column = 0
    Column_Row = 1
End Enum
Public Enum mgGridIdentifierValueType
    Alphabetical = 0
    Numerical = 1
End Enum
Public Enum mgGridIdentifierStartPositionType
    TopLeft = 0
    LowerLeft = 1
End Enum
'----------------------------------------------
' Local Global Declarations
Private m_DestFL As IFeatureLayer
Private m_DestFC As IFeatureClass
Private m_dMapScale As Double
Private m_dFrameWidthInPageUnits As Double
Private m_dFrameHeightInPageUnits As Double
Private m_IDOrderType As mgGridIdentifierOrderType
Private m_RowIDType As mgGridIdentifierValueType
Private m_ColIDType As mgGridIdentifierValueType
Private m_StartIDType As mgGridIdentifierStartPositionType
Private m_StartX As Double
Private m_StartY As Double
Private m_EndX As Double
Private m_EndY As Double
Private m_UseUnderscore As Boolean
Private m_colLayerNamesForData As Collection
Private m_FldID As String
Private m_FldRowNum As String
Private m_FldColNum As String
Private m_FldScale As String
Private m_RemoveGrids As Boolean
Private m_NoEmptyGrids As Boolean
Private m_pProgress As IModelessFrame

'----------------------------------------------
' API call to keep form top most
Private Const GWL_HWNDPARENT = -8
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
  (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Public Property Set DestinationFeatureLayer(pFL As IFeatureLayer)
70:     If pFL.FeatureClass.ShapeType = esriGeometryPolygon Then
71:         Set m_DestFL = pFL
72:         Set m_DestFC = pFL.FeatureClass
73:     Else
74:         Err.Raise vbObjectError, "MapGridManager_Set_DestinationFeatureLayer", _
            "Not a polygon feature layer"
76:     End If
End Property

Public Property Get DestinationFeatureLayer() As IFeatureLayer
80:     Set DestinationFeatureLayer = m_DestFL
End Property

Public Property Let FrameWidthInPageUnits(dWidth As Double)
84:     m_dFrameWidthInPageUnits = dWidth
End Property

Public Property Get FrameWidthInPageUnits() As Double
88:     FrameWidthInPageUnits = m_dFrameWidthInPageUnits
End Property

Public Property Let FrameHeightInPageUnits(dHeight As Double)
92:     m_dFrameHeightInPageUnits = dHeight
End Property

Public Property Get FrameHeightInPageUnits() As Double
96:     FrameHeightInPageUnits = m_dFrameHeightInPageUnits
End Property

Public Property Let MapScale(dScale As Double)
100:     m_dMapScale = dScale
End Property

Public Property Get MapScale() As Double
104:     MapScale = m_dMapScale
End Property

Public Property Let IdentifierOrder(mgType As mgGridIdentifierOrderType)
108:     m_IDOrderType = mgType
End Property

Public Property Get IdentifierOrder() As mgGridIdentifierOrderType
112:     IdentifierOrder = m_IDOrderType
End Property

Public Property Let RowIDType(mgIDStyle As mgGridIdentifierValueType)
116:     m_RowIDType = mgIDStyle
End Property

Public Property Get RowIDType() As mgGridIdentifierValueType
120:     RowIDType = m_RowIDType
End Property

Public Property Let ColIDType(mgIDStyle As mgGridIdentifierValueType)
124:     m_ColIDType = mgIDStyle
End Property

Public Property Get ColIDType() As mgGridIdentifierValueType
128:     ColIDType = m_ColIDType
End Property

Public Property Let IDStartPositionType(mgStartPos As mgGridIdentifierStartPositionType)
132:     m_StartIDType = mgStartPos
End Property

Public Property Get IDStartPositionType() As mgGridIdentifierStartPositionType
136:     IDStartPositionType = m_StartIDType
End Property

Public Property Let StartingCoordinateLL_X(X As Double)
140:     m_StartX = X
End Property

Public Property Get StartingCoordinateLL_X() As Double
144:     StartingCoordinateLL_X = m_StartX
End Property

Public Property Let StartingCoordinateLL_Y(Y As Double)
148:     m_StartY = Y
End Property

Public Property Get StartingCoordinateLL_Y() As Double
152:     StartingCoordinateLL_Y = m_StartY
End Property

Public Property Let EndingCoordinateUR_X(X As Double)
156:     m_EndX = X
End Property

Public Property Get EndingCoordinateUR_X() As Double
160:     EndingCoordinateUR_X = m_EndX
End Property

Public Property Let EndingCoordinateUR_Y(Y As Double)
164:     m_EndY = Y
End Property

Public Property Get EndingCoordinateUR_Y() As Double
168:     EndingCoordinateUR_Y = m_EndY
End Property

Public Property Let FieldNameGridID(FieldName As String)
172:     m_FldID = FieldName
End Property

Public Property Let FieldNameRowNum(FieldName As String)
176:     m_FldRowNum = FieldName
End Property

Public Property Let FieldNameColNum(FieldName As String)
180:     m_FldColNum = FieldName
End Property

Public Property Let FieldNameScale(FieldName As String)
184:     m_FldScale = FieldName
End Property

Public Property Let UseUnderscore(UseUnderscoreInID As Boolean)
188:     m_UseUnderscore = UseUnderscoreInID
End Property

Public Property Get UseUnderscore() As Boolean
192:     UseUnderscore = m_UseUnderscore
End Property

Public Property Let RemoveCurrentGrids(RemoveGrids As Boolean)
196:     m_RemoveGrids = RemoveGrids
End Property

Public Property Get RemoveCurrentGrids() As Boolean
200:     RemoveCurrentGrids = m_RemoveGrids
End Property

Public Property Let NoEmptyGrids(NoEmptyGridPolygons As Boolean)
204:     m_NoEmptyGrids = NoEmptyGridPolygons
End Property

Public Property Get NoEmptyGrids() As Boolean
208:     NoEmptyGrids = m_NoEmptyGrids
End Property

Public Sub AddRequiredDataLayer(sLayerName As String)
212:     m_colLayerNamesForData.Add sLayerName
End Sub

Public Property Get RequiredDataLayer(LayerNumber As Long) As String
216:     If LayerNumber <= m_colLayerNamesForData.count Then
217:         RequiredDataLayer = m_colLayerNamesForData.Item(LayerNumber - 1)
218:     Else
219:         If m_colLayerNamesForData.count = 0 Then
220:             RequiredDataLayer = "There are no Required Data Layers."
221:         Else
222:             RequiredDataLayer = "Invalid layer number.  Valid range: 0 - " & (m_colLayerNamesForData.count - 1)
223:         End If
224:     End If
End Property

Public Property Get RequiredDataLayerCount() As Long
228:     RequiredDataLayerCount = m_colLayerNamesForData.count
End Property

Public Sub ClearRequiredDataLayers()
232:     Set m_colLayerNamesForData = New Collection
End Sub

Private Sub Class_Initialize()
    ' Set the default grid identifier (row-col, alpha/numeric => eg: "B02")
237:     m_IDOrderType = Row_Column
238:     m_RowIDType = Alphabetical
239:     m_ColIDType = Numerical
240:     Set m_colLayerNamesForData = New Collection
241:     Set m_pProgress = New ModelessFrame
End Sub

Private Function CalculateID(ByVal lRow As Long, ByVal lCol As Long, _
                             ByVal iRowIDLen As Integer, ByVal iColIDLen As Integer) As String
    Dim sRowID As String
    Dim sColID As String
    Dim sNumericFormat As String
    Dim lLoop As Long
    Dim lTmp As Long, lCalc As Long, lTmp2 As Long

    ' Row ---------------------------------------------
253:     sNumericFormat = ""