frmgridsettings.frm

一个不错的插件

318:     End If
319:     If (optGridSize(0).value) Then
320:         Set pFrameElement = GetDataFrameElement(GetActiveDataFrameName(m_Application), m_Application)
321:         pCreateGrid.FrameWidthInPageUnits = pFrameElement.Geometry.Envelope.Width
322:         pCreateGrid.FrameHeightInPageUnits = pFrameElement.Geometry.Envelope.Height
323:     Else
324:         pCreateGrid.FrameWidthInPageUnits = CDbl(txtManualGridWidth.Text)
325:         pCreateGrid.FrameHeightInPageUnits = CDbl(txtManualGridHeight.Text)
326:     End If
327:     sDestLayerName = cmbPolygonLayers.List(cmbPolygonLayers.ListIndex)
328:     If optLayerSource(0).value Then
329:         Set pCreateGrid.DestinationFeatureLayer = FindFeatureLayerByName(sDestLayerName, m_Application)
330:     End If
331:     pCreateGrid.StartingCoordinateLL_X = CDbl(txtStartCoordX.Text)
332:     pCreateGrid.StartingCoordinateLL_Y = CDbl(txtStartCoordY.Text)
333:     pCreateGrid.EndingCoordinateUR_X = CDbl(txtEndCoordX.Text)
334:     pCreateGrid.EndingCoordinateUR_Y = CDbl(txtEndCoordY.Text)
335:     pCreateGrid.UseUnderscore = (chkBreak.value = vbChecked)
336:     pCreateGrid.FieldNameGridID = cmbFieldID.List(cmbFieldID.ListIndex)
337:     If cmbFieldRowNum.ListIndex > 0 Then pCreateGrid.FieldNameRowNum = cmbFieldRowNum.List(cmbFieldRowNum.ListIndex)
338:     If cmbFieldColNum.ListIndex > 0 Then pCreateGrid.FieldNameColNum = cmbFieldColNum.List(cmbFieldColNum.ListIndex)
339:     If cmbFieldMapScale.ListIndex > 0 Then pCreateGrid.FieldNameScale = cmbFieldMapScale.List(cmbFieldMapScale.ListIndex)
340:     pCreateGrid.NoEmptyGrids = (chkRemoveEmpties.value = vbChecked)
341:     If pCreateGrid.NoEmptyGrids Then
342:         pCreateGrid.ClearRequiredDataLayers
343:         For lLoop = 0 To lstRequiredDataLayers.ListCount - 1
344:             If lstRequiredDataLayers.Selected(lLoop) Then
345:                 pCreateGrid.AddRequiredDataLayer lstRequiredDataLayers.List(lLoop)
346:             End If
347:         Next
348:     End If
349:     pCreateGrid.RemoveCurrentGrids = (chkRemovePreviousGrids.value = vbChecked)
    ' Place grid settings on Public form property (so calling function can use them)
351:     Set Me.GridSettings = pCreateGrid
End Sub

Private Sub cmdDatasetExtentLL_Click()
    Dim pFL As IFeatureLayer
    Dim pDatasetExtent As IEnvelope
    
358:     If cmbPolygonLayers.ListIndex > 0 Then
359:         Set pFL = FindFeatureLayerByName(cmbPolygonLayers.List(cmbPolygonLayers.ListIndex), m_Application)
360:         Set pDatasetExtent = GetValidExtentForLayer(pFL)
361:         txtStartCoordX.Text = Format(pDatasetExtent.XMin, "#,###,##0.00")
362:         txtStartCoordY.Text = Format(pDatasetExtent.YMin, "#,###,##0.00")
363:         txtEndCoordX.Text = Format(pDatasetExtent.XMax - 100, "#,###,##0.00")
364:         txtEndCoordY.Text = Format(pDatasetExtent.YMax - 100, "#,###,##0.00")
365:         SetControlsState
366:     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
    
378:     Set pMx = m_Application.Document
379:     Set pActiveView = pMx.ActiveView
380:     If TypeOf pActiveView Is IPageLayout Then
381:         Set pElement = GetDataFrameElement(pMx.FocusMap.Name, m_Application)
382:         Set pMapFrame = pElement
383:         Set pEnv = pMapFrame.MapBounds
384:         Set pActiveView = pMapFrame.Map
385:         Set pEnv = pActiveView.FullExtent
386:     Else
387:         Set pEnv = pActiveView.FullExtent
388:     End If
    
390:     txtStartCoordX.Text = Format(pEnv.XMin, "#,###,##0.00")
391:     txtStartCoordY.Text = Format(pEnv.YMin, "#,###,##0.00")
392:     txtEndCoordX.Text = Format(pEnv.XMax, "#,###,##0.00")
393:     txtEndCoordY.Text = Format(pEnv.YMax, "#,###,##0.00")
    
395:     SetControlsState
    
    Exit Sub
eh:
399:     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
    
411:     Set pMx = m_Application.Document
412:     Set pActiveView = pMx.ActiveView
413:     If TypeOf pActiveView Is IPageLayout Then
414:         Set pElement = GetDataFrameElement(pMx.FocusMap.Name, m_Application)
415:         Set pMapFrame = pElement
416:         Set pEnv = pMapFrame.MapBounds
417:     Else
418:         Set pEnv = pActiveView.Extent
419:     End If
    
421:     txtStartCoordX.Text = Format(pEnv.XMin, "#,###,##0.00")
422:     txtStartCoordY.Text = Format(pEnv.YMin, "#,###,##0.00")
423:     txtEndCoordX.Text = Format(pEnv.XMax, "#,###,##0.00")
424:     txtEndCoordY.Text = Format(pEnv.YMax, "#,###,##0.00")
    
426:     SetControlsState
    
    Exit Sub
eh:
430:     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
441:     m_Step = m_Step + 1
    ' If we're creating a new fclass, we can skip a step
443:     If m_Step = 1 And (optLayerSource(1).value) Then
444:         m_Step = m_Step + 1
445:     End If
    ' If FINISH
447:     If m_Step >= 5 Then
448:         CollateGridSettings
        ' If creating a new layer
450:         If optLayerSource(1).value Then
            ' Create the feature class
452:             Set pMx = m_Application.Document
453:             Set pNewFields = CreateTheFields
            Select Case m_FileType
                Case ShapeFile
456:                     Set pOutputFClass = NewShapeFile(m_OutputLayer, pMx.FocusMap, pNewFields)
                Case AccessFeatureClass
458:                     Set pOutputFClass = NewAccessFile(m_OutputLayer, _
                            m_OutputDataset, m_OutputFClass, pNewFields)
460:             End Select
461:             If pOutputFClass Is Nothing Then
462:                 Err.Raise vbObjectError, "cmdNext", "Could not create the new output feature class."
463:             End If
            ' Create new layer
465:             Set pFeatureLayer = New FeatureLayer
466:             Set pFeatureLayer.FeatureClass = pOutputFClass
467:             pFeatureLayer.Name = pFeatureLayer.FeatureClass.AliasName
            ' Add the new layer to arcmap & reset the GridSettings object to point at it
469:             pMx.FocusMap.AddLayer pFeatureLayer
470:             Set GridSettings.DestinationFeatureLayer = pFeatureLayer
471:         End If
472:         Me.Hide
473:     Else
474:         SetVisibleControls m_Step
475:         SetControlsState
476:     End If
    
    Exit Sub
eh:
480:     MsgBox "cmdNext_Click - " & Erl & " - " & Err.Description
481:     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
  
490:   Set pGxFilter = New GxFilter
491:   Set pApp = m_Application
492:   Set pGXBrow = New GxDialog
493:   Set pGXBrow.ObjectFilter = pGxFilter
494:   pGXBrow.Title = "Output feature class or shapefile"
495:   bFlag = pGXBrow.DoModalSave(pApp.hwnd)
  
497:   If bFlag Then
    Dim pObj As IGxObject
499:     Set pObj = pGXBrow.FinalLocation
500:     m_bIsGeoDatabase = True
501:     If UCase(pObj.Category) = "FOLDER" Then
502:       If InStr(1, pGXBrow.Name, ".shp") > 0 Then
503:         txtNewGridLayer.Text = pObj.FullName & "\" & pGXBrow.Name
504:       Else
505:         txtNewGridLayer.Text = pObj.FullName & "\" & pGXBrow.Name & ".shp"
506:       End If
507:       m_OutputLayer = txtNewGridLayer.Text
508:       m_bIsGeoDatabase = False
509:       m_FileType = ShapeFile
510:      CheckOutputFile
511:     Else
      Dim pLen As Long
513:       pLen = Len(pObj.FullName) - Len(pObj.BaseName) - 1
514:       txtNewGridLayer.Text = Left(pObj.FullName, pLen)
515:       m_OutputLayer = Left(pObj.FullName, pLen)
516:       m_OutputDataset = pObj.BaseName
517:       m_OutputFClass = pGXBrow.Name
518:       m_bIsGeoDatabase = True
519:       If UCase(pObj.Category) = "PERSONAL GEODATABASE FEATURE DATASET" Then
520:         m_FileType = AccessFeatureClass
521:       Else
522:         m_FileType = SDEFeatureClass
523:       End If
524:     End If
525:   Else
526:     txtNewGridLayer.Text = ""
527:     m_bIsGeoDatabase = False
528:   End If
529:   SetControlsState
  
  Exit Sub
ErrHand:
533:   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
    
543:     Set pMx = m_Application.Document
544:     Me.Height = 5665
545:     Me.Width = 4935
546:     m_Step = 0
547:     LoadLayersComboBox
548:     LoadUnitsComboBox
549:     lblExampleID.Caption = GenerateExampleID
550:     lblCurrFrameName.Caption = GetActiveDataFrameName(m_Application)
551:     If pMx.FocusMap.MapUnits = esriUnknownUnits Then
552:         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"
554:         Unload Me
        Exit Sub
556:     End If
557:     lblCurrentMapScale.Caption = Format(pMx.FocusMap.MapScale, "#,###,##0")
558:     Call cmdMapExtentLL_Click
559:     SetVisibleControls m_Step
    
561:     SetControlsState
    
    'Make sure the wizard stays on top
564:     TopMost Me
    
    Exit Sub
eh:
568:     MsgBox "Error loading the form: " & Erl & " - " & Err.Description & vbCrLf _
        & vbCrLf & "Attempting to continue the load...", , "MapGridManager: Form_Load "
    On Error Resume Next
571:     SetVisibleControls m_Step
572:     SetControlsState
End Sub

Private Sub LoadUnitsComboBox()
    Dim pMx As IMxDocument
    Dim sPageUnitsDesc As String
    Dim pPage As IPage
    
    On Error GoTo eh
    
    ' Init
583:     Set pMx = m_Application.Document
584:     Set pPage = pMx.PageLayout.Page
585:     sPageUnitsDesc = GetUnitsDescription(pPage.Units)
586:     cmbGridSizeUnits.Clear
    ' Add
588:     cmbGridSizeUnits.AddItem sPageUnitsDesc
    'cmbGridSizeUnits.AddItem "Map Units (" & sMapUnitsDesc & ")"
    ' Set page units as default
591:     cmbGridSizeUnits.ListIndex = 0
    
    Exit Sub
eh:
595:     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
607:     Set pMx = m_Application.Document
'    If cmbPolygonLayers.ListCount > 0 Then
'        sPreviousLayer = cmbPolygonLayers.List(cmbPolygonLayers.ListIndex)
'    End If
611:     cmbPolygonLayers.Clear
612:     lstRequiredDataLayers.Clear
613:     cmbPolygonLayers.AddItem "<Not Set>"
    ' For all layers
615:     For lLoop = 0 To pMx.FocusMap.LayerCount - 1
        ' If a feature class
617:         If TypeOf pMx.FocusMap.Layer(lLoop) Is IFeatureLayer Then
618:             Set pFL = pMx.FocusMap.Layer(lLoop)
619:             Set pFC = pFL.FeatureClass
            ' If a polygon layer
621:             If pFC.ShapeType = esriGeometryPolygon Then
                ' Add to combo box
623:                 cmbPolygonLayers.AddItem pFL.Name
'                If pFL.Name = sPreviousLayer Then
'                    lResetIndex = (cmbPolygonLayers.ListCount - 1)
'                End If
627:             End If
628:             lstRequiredDataLayers.AddItem pFL.Name
629:         End If
630:     Next
    'cmbPolygonLayers.ListIndex = lResetIndex
End Sub

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


Private Sub Form_Unload(Cancel As Integer)
646:     Set m_Application = Nothing
647:     Set GridSettings = Nothing
End Sub


Private Sub lstRequiredDataLayers_Click()
652:     SetControlsState
End Sub

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

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

Private Sub optGridSize_Click(Index As Integer)
    Dim pMx As IMxDocument
667:     Set pMx = m_Application.Document
668:     lblCurrFrameName.Caption = pMx.FocusMap.Name
669:     SetControlsState