frmgridsettings.frm

使用VB和ArcObject结合的程序

299:     Else
300:         pCreateGrid.IDStartPositionType = LowerLeft
301:     End If
302:     If (optScaleSource(0).Value) Then
303:         pCreateGrid.MapScale = CDbl(lblCurrentMapScale.Caption)
304:     Else
305:         pCreateGrid.MapScale = CDbl(txtManualMapScale.Text)
306:     End If
307:     If (optGridSize(0).Value) Then
308:         Set pFrameElement = GetDataFrameElement(GetActiveDataFrameName(m_Application), m_Application)
309:         pCreateGrid.FrameWidthInPageUnits = pFrameElement.Geometry.Envelope.Width
310:         pCreateGrid.FrameHeightInPageUnits = pFrameElement.Geometry.Envelope.Height
311:     Else
312:         pCreateGrid.FrameWidthInPageUnits = CDbl(txtManualGridWidth.Text)
313:         pCreateGrid.FrameHeightInPageUnits = CDbl(txtManualGridHeight.Text)
314:     End If
315:     sDestLayerName = cmbPolygonLayers.List(cmbPolygonLayers.ListIndex)
316:     If optLayerSource(0).Value Then
317:         Set pCreateGrid.DestinationFeatureLayer = FindFeatureLayerByName(sDestLayerName, m_Application)
318:     End If
319:     pCreateGrid.StartingCoordinateLL_X = CDbl(txtStartCoordX.Text)
320:     pCreateGrid.StartingCoordinateLL_Y = CDbl(txtStartCoordY.Text)
321:     pCreateGrid.EndingCoordinateUR_X = CDbl(txtEndCoordX.Text)
322:     pCreateGrid.EndingCoordinateUR_Y = CDbl(txtEndCoordY.Text)
323:     pCreateGrid.UseUnderscore = (chkBreak.Value = vbChecked)
324:     pCreateGrid.FieldNameGridID = cmbFieldID.List(cmbFieldID.ListIndex)
325:     If cmbFieldRowNum.ListIndex > 0 Then pCreateGrid.FieldNameRowNum = cmbFieldRowNum.List(cmbFieldRowNum.ListIndex)
326:     If cmbFieldColNum.ListIndex > 0 Then pCreateGrid.FieldNameColNum = cmbFieldColNum.List(cmbFieldColNum.ListIndex)
327:     If cmbFieldMapScale.ListIndex > 0 Then pCreateGrid.FieldNameScale = cmbFieldMapScale.List(cmbFieldMapScale.ListIndex)
328:     pCreateGrid.NoEmptyGrids = (chkRemoveEmpties.Value = vbChecked)
329:     If pCreateGrid.NoEmptyGrids Then
330:         pCreateGrid.ClearRequiredDataLayers
331:         For lLoop = 0 To lstRequiredDataLayers.ListCount - 1
332:             If lstRequiredDataLayers.Selected(lLoop) Then
333:                 pCreateGrid.AddRequiredDataLayer lstRequiredDataLayers.List(lLoop)
334:             End If
335:         Next
336:     End If
337:     pCreateGrid.RemoveCurrentGrids = (chkRemovePreviousGrids.Value = vbChecked)
    ' Place grid settings on Public form property (so calling function can use them)
339:     Set Me.GridSettings = pCreateGrid
End Sub

Private Sub cmdDatasetExtentLL_Click()
    Dim pFL As IFeatureLayer
    Dim pDatasetExtent As IEnvelope
    
346:     If cmbPolygonLayers.ListIndex > 0 Then
347:         Set pFL = FindFeatureLayerByName(cmbPolygonLayers.List(cmbPolygonLayers.ListIndex), m_Application)
348:         Set pDatasetExtent = GetValidExtentForLayer(pFL)
349:         txtStartCoordX.Text = Format(pDatasetExtent.XMin, "#,###,##0.00")
350:         txtStartCoordY.Text = Format(pDatasetExtent.YMin, "#,###,##0.00")
351:         txtEndCoordX.Text = Format(pDatasetExtent.XMax - 100, "#,###,##0.00")
352:         txtEndCoordY.Text = Format(pDatasetExtent.YMax - 100, "#,###,##0.00")
353:         SetControlsState
354:     End If
End Sub

Private Sub cmdLayersExtent_Click()
    Dim pMx As IMxDocument
    Dim pEnv As IEnvelope
    Dim pElement As IElement
    Dim pMapFrame As IMapFrame
    Dim pActiveView As IActiveView
    
    On Error GoTo eh
    
366:     Set pMx = m_Application.Document
367:     Set pActiveView = pMx.ActiveView
368:     If TypeOf pActiveView Is IPageLayout Then
369:         Set pElement = GetDataFrameElement(pMx.FocusMap.Name, m_Application)
370:         Set pMapFrame = pElement
371:         Set pEnv = pMapFrame.MapBounds
372:         Set pActiveView = pMapFrame.Map
373:         Set pEnv = pActiveView.FullExtent
374:     Else
375:         Set pEnv = pActiveView.FullExtent
376:     End If
    
378:     txtStartCoordX.Text = Format(pEnv.XMin, "#,###,##0.00")
379:     txtStartCoordY.Text = Format(pEnv.YMin, "#,###,##0.00")
380:     txtEndCoordX.Text = Format(pEnv.XMax, "#,###,##0.00")
381:     txtEndCoordY.Text = Format(pEnv.YMax, "#,###,##0.00")
    
383:     SetControlsState
    
    Exit Sub
eh:
387:     MsgBox Err.Description, , "cmdLayersExtent_Click"
End Sub

Private Sub cmdMapExtentLL_Click()
    Dim pMx As IMxDocument
    Dim pEnv As IEnvelope
    Dim pElement As IElement
    Dim pMapFrame As IMapFrame
    Dim pActiveView As IActiveView
    
    On Error GoTo eh
    
399:     Set pMx = m_Application.Document
400:     Set pActiveView = pMx.ActiveView
401:     If TypeOf pActiveView Is IPageLayout Then
402:         Set pElement = GetDataFrameElement(pMx.FocusMap.Name, m_Application)
403:         Set pMapFrame = pElement
404:         Set pEnv = pMapFrame.MapBounds
405:     Else
406:         Set pEnv = pActiveView.Extent
407:     End If
    
409:     txtStartCoordX.Text = Format(pEnv.XMin, "#,###,##0.00")
410:     txtStartCoordY.Text = Format(pEnv.YMin, "#,###,##0.00")
411:     txtEndCoordX.Text = Format(pEnv.XMax, "#,###,##0.00")
412:     txtEndCoordY.Text = Format(pEnv.YMax, "#,###,##0.00")
    
414:     SetControlsState
    
    Exit Sub
eh:
418:     MsgBox Err.Description, , "cmdMapExtentLL"
End Sub

Private Sub cmdNext_Click()
    Dim pMx As IMxDocument
    Dim pFeatureLayer As IFeatureLayer
    Dim pOutputFClass As IFeatureClass
    Dim pNewFields As IFields
    
    On Error GoTo eh
    ' Step
429:     m_Step = m_Step + 1
    ' If we're creating a new fclass, we can skip a step
431:     If m_Step = 1 And (optLayerSource(1).Value) Then
432:         m_Step = m_Step + 1
433:     End If
    ' If FINISH
435:     If m_Step >= 5 Then
436:         CollateGridSettings
        ' If creating a new layer
438:         If optLayerSource(1).Value Then
            ' Create the feature class
440:             Set pMx = m_Application.Document
441:             Set pNewFields = CreateTheFields
            Select Case m_FileType
                Case ShapeFile
444:                     Set pOutputFClass = NewShapeFile(m_OutputLayer, pMx.FocusMap, pNewFields)
                Case AccessFeatureClass
446:                     Set pOutputFClass = NewAccessFile(m_OutputLayer, _
                            m_OutputDataset, m_OutputFClass, pNewFields)
448:             End Select
449:             If pOutputFClass Is Nothing Then
450:                 Err.Raise vbObjectError, "cmdNext", "Could not create the new output feature class."
451:             End If
            ' Create new layer
453:             Set pFeatureLayer = New FeatureLayer
454:             Set pFeatureLayer.FeatureClass = pOutputFClass
455:             pFeatureLayer.Name = pFeatureLayer.FeatureClass.AliasName
            ' Add the new layer to arcmap & reset the GridSettings object to point at it
457:             pMx.FocusMap.AddLayer pFeatureLayer
458:             Set GridSettings.DestinationFeatureLayer = pFeatureLayer
459:         End If
460:         Me.Hide
461:     Else
462:         SetVisibleControls m_Step
463:         SetControlsState
464:     End If
    
    Exit Sub
eh:
468:     MsgBox "cmdNext_Click - " & Erl & " - " & Err.Description
469:     m_Step = m_Step - 1
End Sub

Private Sub cmdSetNewGridLayer_Click()
On Error GoTo ErrHand:
  Dim pGxFilter As IGxObjectFilter
  Dim pGXBrow As IGxDialog, bFlag As Boolean
  Dim pSel As IEnumGxObject, pApp As IApplication
  
478:   Set pGxFilter = New GxFilter
479:   Set pApp = m_Application
480:   Set pGXBrow = New GxDialog
481:   Set pGXBrow.ObjectFilter = pGxFilter
482:   pGXBrow.Title = "Output feature class or shapefile"
483:   bFlag = pGXBrow.DoModalSave(pApp.hwnd)
  
485:   If bFlag Then
    Dim pObj As IGxObject
487:     Set pObj = pGXBrow.FinalLocation
488:     m_bIsGeoDatabase = True
489:     If UCase(pObj.Category) = "FOLDER" Then
490:       If InStr(1, pGXBrow.Name, ".shp") > 0 Then
491:         txtNewGridLayer.Text = pObj.FullName & "\" & pGXBrow.Name
492:       Else
493:         txtNewGridLayer.Text = pObj.FullName & "\" & pGXBrow.Name & ".shp"
494:       End If
495:       m_OutputLayer = txtNewGridLayer.Text
496:       m_bIsGeoDatabase = False
497:       m_FileType = ShapeFile
498:      CheckOutputFile
499:     Else
      Dim pLen As Long
501:       pLen = Len(pObj.FullName) - Len(pObj.BaseName) - 1
502:       txtNewGridLayer.Text = Left(pObj.FullName, pLen)
503:       m_OutputLayer = Left(pObj.FullName, pLen)
504:       m_OutputDataset = pObj.BaseName
505:       m_OutputFClass = pGXBrow.Name
506:       m_bIsGeoDatabase = True
507:       If UCase(pObj.Category) = "PERSONAL GEODATABASE FEATURE DATASET" Then
508:         m_FileType = AccessFeatureClass
509:       Else
510:         m_FileType = SDEFeatureClass
511:       End If
512:     End If
513:   Else
514:     txtNewGridLayer.Text = ""
515:     m_bIsGeoDatabase = False
516:   End If
517:   SetControlsState
  
  Exit Sub
ErrHand:
521:   MsgBox "cmdSetNewGridLayer_Click - " & Erl & " - " & Err.Description
End Sub

Private Sub Form_Load()
    Dim pMx As IMxDocument
    Dim bRenewCoordsX As Boolean
    Dim bRenewCoordsY As Boolean
    
    On Error GoTo eh
    
531:     Set pMx = m_Application.Document
532:     Me.Height = 5665
533:     Me.Width = 4935
534:     m_Step = 0
535:     LoadLayersComboBox
536:     LoadUnitsComboBox
537:     lblExampleID.Caption = GenerateExampleID
538:     lblCurrFrameName.Caption = GetActiveDataFrameName(m_Application)
539:     If pMx.FocusMap.MapUnits = esriUnknownUnits Then
540:         MsgBox "Error: The map has unknown units and therefore cannot calculate a Scale." _
            & vbCrLf & "Cannot create Map Grids at this time.", vbCritical, "Create Map Grids"
542:         Unload Me
        Exit Sub
544:     End If
545:     lblCurrentMapScale.Caption = Format(pMx.FocusMap.MapScale, "#,###,##0")
546:     Call cmdMapExtentLL_Click
547:     SetVisibleControls m_Step
    
549:     SetControlsState
    
    'Make sure the wizard stays on top
552:     TopMost Me
    
    Exit Sub
eh:
556:     MsgBox "Error loading the form: " & Erl & " - " & Err.Description & vbCrLf _
        & vbCrLf & "Attempting to continue the load...", , "MapGridManager: Form_Load "
    On Error Resume Next
559:     SetVisibleControls m_Step
560:     SetControlsState
End Sub

Private Sub LoadUnitsComboBox()
    Dim pMx As IMxDocument
    Dim sPageUnitsDesc As String
    Dim pPage As IPage
    
    On Error GoTo eh
    
    ' Init
571:     Set pMx = m_Application.Document
572:     Set pPage = pMx.PageLayout.Page
573:     sPageUnitsDesc = GetUnitsDescription(pPage.Units)
574:     cmbGridSizeUnits.Clear
    ' Add
576:     cmbGridSizeUnits.AddItem sPageUnitsDesc
    'cmbGridSizeUnits.AddItem "Map Units (" & sMapUnitsDesc & ")"
    ' Set page units as default
579:     cmbGridSizeUnits.ListIndex = 0
    
    Exit Sub
eh:
583:     Err.Raise vbObjectError, "LoadUnitsComboBox", "Error in LoadUnitsComboBox" & vbCrLf & Err.Description
End Sub

Private Sub LoadLayersComboBox()
    Dim pMx As IMxDocument
    Dim lLoop As Long
    Dim pFL As IFeatureLayer
    Dim pFC As IFeatureClass
    Dim sPreviousLayer  As String
    Dim lResetIndex As Long
    
    'Init
595:     Set pMx = m_Application.Document
'    If cmbPolygonLayers.ListCount > 0 Then
'        sPreviousLayer = cmbPolygonLayers.List(cmbPolygonLayers.ListIndex)
'    End If
599:     cmbPolygonLayers.Clear
600:     lstRequiredDataLayers.Clear
601:     cmbPolygonLayers.AddItem "<Not Set>"
    ' For all layers
603:     For lLoop = 0 To pMx.FocusMap.LayerCount - 1
        ' If a feature class
605:         If TypeOf pMx.FocusMap.Layer(lLoop) Is IFeatureLayer Then
606:             Set pFL = pMx.FocusMap.Layer(lLoop)
607:             Set pFC = pFL.FeatureClass
            ' If a polygon layer
609:             If pFC.ShapeType = esriGeometryPolygon Then
                ' Add to combo box
611:                 cmbPolygonLayers.AddItem pFL.Name
'                If pFL.Name = sPreviousLayer Then
'                    lResetIndex = (cmbPolygonLayers.ListCount - 1)
'                End If
615:             End If
616:             lstRequiredDataLayers.AddItem pFL.Name
617:         End If
618:     Next
    'cmbPolygonLayers.ListIndex = lResetIndex
End Sub

Private Sub SetCurrentMapScaleCaption()
    Dim pMx As IMxDocument
    On Error GoTo eh
625:     Set pMx = m_Application.Document
626:     lblCurrentMapScale.Caption = Format(pMx.FocusMap.MapScale, "#,###,##0")
    Exit Sub
eh:
629:     lblCurrentMapScale.Caption = "<Scale Unknown>"
End Sub


Private Sub Form_Unload(Cancel As Integer)
634:     Set m_Application = Nothing
635:     Set GridSettings = Nothing
End Sub


Private Sub lstRequiredDataLayers_Click()
640:     SetControlsState
End Sub

Private Sub optColIDType_Click(Index As Integer)
644:     lblExampleID.Caption = GenerateExampleID
645:     SetControlsState
End Sub

Private Sub optGridIDOrder_Click(Index As Integer)
649:     lblExampleID.Caption = GenerateExampleID
650:     SetControlsState
End Sub

Private Sub optGridSize_Click(Index As Integer)