frmgridsettings.frm

使用VB和ArcObject结合的程序

         Height          =   495
         Left            =   120
         TabIndex        =   47
         Top             =   720
         Width           =   4575
      End
      Begin VB.Label Label13 
         Caption         =   "Assign roles to field names."
         Height          =   255
         Left            =   120
         TabIndex        =   46
         Top             =   240
         Width           =   4575
      End
   End
   Begin VB.CommandButton cmdClose 
      Caption         =   "Cancel"
      Height          =   375
      Left            =   3720
      TabIndex        =   0
      Top             =   4800
      Width           =   1095
   End
End
Attribute VB_Name = "frmGridSettings"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

' 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 m_Application As IApplication
Public GridSettings As clsCreateGrids

Public Enum intersectFileType
  ShapeFile = 0
  AccessFeatureClass = 1
  SDEFeatureClass = 2
End Enum

Private m_bIsGeoDatabase As Boolean
Private m_FileType As intersectFileType
Private m_OutputLayer As String
Private m_OutputDataset As String
Private m_OutputFClass As String
Private m_Step As Integer

Private Const c_DefaultFld_GridID = "GRID_ID"
Private Const c_DefaultFld_ColNum = "COL_NUM"
Private Const c_DefaultFld_RowNum = "ROW_NUM"
Private Const c_DefaultFld_Scale = "PLOTSCALE"

Private Sub SetControlsState()
    Dim dScale As Double
    Dim dGHeight As Double
    Dim dGWidth As Double
    Dim dStartX As Double
    Dim dStartY As Double
    Dim dEndX As Double
    Dim dEndY As Double
    Dim bValidScale As Boolean
    Dim bValidSize As Boolean
    Dim bValidTarget As Boolean
    Dim bValidIDField As Boolean
    Dim bNewFClassSet As Boolean
    Dim bValidReqdLayers As Boolean
    Dim bValidStart As Boolean
    Dim bValidEnd As Boolean
    Dim bCreatingNewFClass As Boolean
    Dim bDuplicateFieldsSelected As Boolean
    Dim pFL As IFeatureLayer
    Dim pDatasetExtent As IEnvelope
    Dim i As Integer
    
    On Error GoTo eh
    
    ' Protect against zero length string_to_double conversions
49:     If Len(lblCurrentMapScale.Caption) = 0 Then lblCurrentMapScale.Caption = "0"
50:     If Len(txtManualMapScale.Text) = 0 Then
51:         dScale = 0
52:     Else
53:         dScale = CDbl(txtManualMapScale.Text)
54:     End If
55:     If Len(txtManualGridHeight.Text) = 0 Then
56:         dGHeight = 0
57:     Else
58:         dGHeight = CDbl(txtManualGridHeight.Text)
59:     End If
60:     If Len(txtManualGridWidth.Text) = 0 Then
61:         dGWidth = 0
62:     Else
63:         dGWidth = CDbl(txtManualGridWidth.Text)
64:     End If
65:     If Len(txtStartCoordX.Text) = 0 Then
66:         dStartX = 0
67:     Else
68:         dStartX = CDbl(txtStartCoordX.Text)
69:     End If
70:     If Len(txtStartCoordY.Text) = 0 Then
71:         dStartY = 0
72:     Else
73:         dStartY = CDbl(txtStartCoordY.Text)
74:     End If
75:     If Len(txtEndCoordX.Text) = 0 Then
76:         dEndX = 0
77:     Else
78:         dEndX = CDbl(txtEndCoordX.Text)
79:     End If
80:     If Len(txtEndCoordY.Text) = 0 Then
81:         dEndY = 0
82:     Else
83:         dEndY = CDbl(txtEndCoordY.Text)
84:     End If
85: i = 1

    ' Calc values
88:     bValidScale = (optScaleSource(0).Value And CDbl(lblCurrentMapScale.Caption) > 0) Or _
                  (optScaleSource(1).Value And dScale > 0)
90:     bValidSize = (optGridSize(0).Value) Or _
                 (optGridSize(1).Value And dGHeight > 0 And dGWidth > 0)
92:     bCreatingNewFClass = optLayerSource(1).Value
93:     bNewFClassSet = (Len(txtNewGridLayer.Text) > 0)
94:     bValidTarget = (cmbPolygonLayers.ListIndex > 0) Or (bCreatingNewFClass And bNewFClassSet)
95:     bValidIDField = (cmbFieldID.ListIndex >= 0)
96:     bValidReqdLayers = (chkRemoveEmpties.Value = vbUnchecked) Or _
                       (chkRemoveEmpties.Value = vbChecked And lstRequiredDataLayers.SelCount > 0)
98: i = 2
99:     If bValidTarget And (Not bCreatingNewFClass) Then
100:         Set pFL = FindFeatureLayerByName(cmbPolygonLayers.List(cmbPolygonLayers.ListIndex), m_Application)
101:         If pFL.FeatureClass.FeatureDataset Is Nothing Then
102:             bValidStart = True
103:             bValidEnd = True
104:         Else
105:             Set pDatasetExtent = GetValidExtentForLayer(pFL)
106:             bValidStart = ((dStartX >= pDatasetExtent.XMin) And (dStartX <= pDatasetExtent.XMax)) _
                            And _
                          ((dStartY >= pDatasetExtent.YMin) And (dStartY <= pDatasetExtent.YMax))
109:             bValidEnd = ((dEndX >= pDatasetExtent.XMin) And (dEndX <= pDatasetExtent.XMax)) _
                            And _
                        ((dEndY >= pDatasetExtent.YMin) And (dEndY <= pDatasetExtent.YMax)) _
                            And _
                        ((dEndX > dStartX) And (dEndY > dStartY))
114:         End If
115:     ElseIf bValidTarget And bCreatingNewFClass Then
116:         bValidStart = True
117:         bValidEnd = True
118:     End If
119:     bDuplicateFieldsSelected = (cmbFieldRowNum.ListIndex > 0 And cmbFieldRowNum.ListIndex = cmbFieldColNum.ListIndex) _
                            Or (cmbFieldRowNum.ListIndex > 0 And cmbFieldRowNum.ListIndex = cmbFieldMapScale.ListIndex) _
                            Or (cmbFieldColNum.ListIndex > 0 And cmbFieldColNum.ListIndex = cmbFieldMapScale.ListIndex)
122: i = 3
    
    ' Set states
    Select Case m_Step
        Case 0:     ' Set the target feature layer
127:             cmdBack.Enabled = False
128:             cmdNext.Enabled = bValidTarget And bValidReqdLayers
129:             cmdNext.Caption = "Next >"
130:             cmbPolygonLayers.Enabled = Not bCreatingNewFClass
        Case 1:     ' Set the fields to populate
132:             cmdBack.Enabled = True
133:             cmdNext.Enabled = (bValidIDField And Not bDuplicateFieldsSelected)
134:             cmbFieldID.Enabled = Not bCreatingNewFClass
135:             cmbFieldRowNum.Enabled = Not bCreatingNewFClass
136:             cmbFieldColNum.Enabled = Not bCreatingNewFClass
137:             cmbFieldMapScale.Enabled = Not bCreatingNewFClass
        Case 2:     ' Set the scale / starting_coords
139:             cmdBack.Enabled = True
140:             cmdNext.Enabled = bValidScale And bValidStart And bValidEnd
141:             If Not bCreatingNewFClass Then
142:                 cmdDatasetExtentLL.Enabled = Not (pFL.FeatureClass.FeatureDataset Is Nothing)
143:             Else
144:                 cmdDatasetExtentLL.Enabled = False
145:             End If
        Case 3:     ' Set the dataframe properties
147:             cmdBack.Enabled = True
148:             cmdNext.Enabled = bValidSize
149:             cmdNext.Caption = "Next >"
        Case 4:     ' Set the ID values
151:             cmdBack.Enabled = True
152:             cmdNext.Enabled = True
153:             cmdNext.Caption = "Finish"
        Case Else:
155:             cmdBack.Enabled = False
156:             cmdNext.Enabled = False
157:     End Select
158: i = 4
    
160:     txtManualMapScale.Enabled = optScaleSource(1).Value
161:     txtManualGridWidth.Enabled = optGridSize(1).Value
162:     txtManualGridHeight.Enabled = optGridSize(1).Value
163:     cmbGridSizeUnits.Enabled = optGridSize(1).Value
    ' Set display
165:     If bValidStart Then
166:         txtStartCoordX.ForeColor = (&H0)    ' Black
167:         txtStartCoordY.ForeColor = (&H0)
168:     Else
169:         txtStartCoordX.ForeColor = (&HFF)   ' Red
170:         txtStartCoordY.ForeColor = (&HFF)
171:     End If
172:     If bValidEnd Then
173:         txtEndCoordX.ForeColor = (&H0)      ' Black
174:         txtEndCoordY.ForeColor = (&H0)
175:     Else
176:         txtEndCoordX.ForeColor = (&HFF)     ' Red
177:         txtEndCoordY.ForeColor = (&HFF)
178:     End If
179:     If optScaleSource(1).Value Then
180:         If bValidScale Then
181:             txtManualMapScale.ForeColor = (&H0)      ' Black
182:         Else
183:             txtManualMapScale.ForeColor = (&HFF)     ' Red
184:         End If
185:     End If
186:     If optGridSize(1).Value Then
187:         If bValidSize Then
188:             txtManualGridWidth.ForeColor = (&H0)      ' Black
189:             txtManualGridHeight.ForeColor = (&H0)
190:         Else
191:             txtManualGridWidth.ForeColor = (&HFF)     ' Red
192:             txtManualGridHeight.ForeColor = (&HFF)
193:         End If
194:     End If
    
    Exit Sub
197:     Resume
eh:
199:     MsgBox Err.Description, vbExclamation, "SetControlsState " & i
End Sub

Private Sub chkBreak_Click()
203:     lblExampleID.Caption = GenerateExampleID
End Sub

Private Sub chkRemoveEmpties_Click()
207:     SetControlsState
End Sub

Private Sub cmbFieldColNum_Click()
211:     SetControlsState
End Sub

Private Sub cmbFieldID_Click()
215:     SetControlsState
End Sub

Private Sub cmbFieldMapScale_Click()
219:     SetControlsState
End Sub

Private Sub cmbFieldRowNum_Click()
223:     SetControlsState
End Sub

Private Sub cmbPolygonLayers_Click()
    Dim pFL As IFeatureLayer
    Dim pFields As IFields
    Dim lLoop As Long
    ' Populate the fields combo boxes
231:     If cmbPolygonLayers.ListIndex > 0 Then
232:         Set pFL = FindFeatureLayerByName(cmbPolygonLayers.List(cmbPolygonLayers.ListIndex), m_Application)
233:         Set pFields = pFL.FeatureClass.Fields
234:         cmbFieldColNum.Clear
235:         cmbFieldID.Clear
236:         cmbFieldMapScale.Clear
237:         cmbFieldRowNum.Clear
238:         cmbFieldRowNum.AddItem "<None>"
239:         cmbFieldColNum.AddItem "<None>"
240:         cmbFieldMapScale.AddItem "<None>"
241:         For lLoop = 0 To pFields.FieldCount - 1
242:             If pFields.Field(lLoop).Type = esriFieldTypeString Then
243:                 cmbFieldID.AddItem pFields.Field(lLoop).Name
244:             ElseIf pFields.Field(lLoop).Type = esriFieldTypeDouble Or _
                   pFields.Field(lLoop).Type = esriFieldTypeInteger Or _
                   pFields.Field(lLoop).Type = esriFieldTypeSmallInteger Or _
                   pFields.Field(lLoop).Type = esriFieldTypeSingle Then
248:                 cmbFieldColNum.AddItem pFields.Field(lLoop).Name
249:                 cmbFieldRowNum.AddItem pFields.Field(lLoop).Name
250:                 cmbFieldMapScale.AddItem pFields.Field(lLoop).Name
251:             End If
252:         Next
253:         cmbFieldRowNum.ListIndex = 0
254:         cmbFieldColNum.ListIndex = 0
255:         cmbFieldMapScale.ListIndex = 0
256:     End If
257:     SetControlsState
End Sub

Private Sub cmdBack_Click()
261:     m_Step = m_Step - 1
262:     If m_Step < 0 Then
263:         m_Step = 0
264:     End If
265:     SetVisibleControls m_Step
266:     SetControlsState
End Sub

Private Sub cmdClose_Click()
270:     Set m_Application = Nothing
271:     Set Me.GridSettings = Nothing
272:     Me.Hide
End Sub

Private Sub CollateGridSettings()
    Dim pMx As IMxDocument
    Dim pCreateGrid As New clsCreateGrids
    Dim pFrameElement As IElement
    Dim sDestLayerName As String
    Dim lLoop As Long
    ' Populate class
282:     If (optGridIDOrder(0).Value) Then
283:         pCreateGrid.IdentifierOrder = Row_Column
284:     Else
285:         pCreateGrid.IdentifierOrder = Column_Row
286:     End If
287:     If (optRowIDType(0).Value) Then
288:         pCreateGrid.RowIDType = Alphabetical
289:     Else
290:         pCreateGrid.RowIDType = Numerical
291:     End If
292:     If (optColIDType(0).Value) Then
293:         pCreateGrid.ColIDType = Alphabetical
294:     Else
295:         pCreateGrid.ColIDType = Numerical
296:     End If
297:     If (optStartingIDPosition(0).Value) Then
298:         pCreateGrid.IDStartPositionType = TopLeft