frmsmapsettings.frm

一个不错的插件

246:     Me.Hide
End Sub

Private Sub CollateStripMapSettings()
    Dim pMx As IMxDocument
    Dim pCreateSMap As New clsCreateStripMap
    Dim pFrameElement As IElement
    Dim sDestLayerName As String
    Dim lLoop As Long
    ' Populate class
256:     pCreateSMap.StripMapName = txtStripMapSeriesName.Text
257:     pCreateSMap.FlipPolyline = (chkFlipLine.value = vbChecked)
258:     If (optScaleSource(0).value) Then
259:         pCreateSMap.MapScale = CDbl(lblCurrentMapScale.Caption)
260:     ElseIf (optScaleSource(1).value) Then
261:         pCreateSMap.MapScale = CDbl(txtManualMapScale.Text)
262:     End If
263:     If (optGridSize(0).value) Then
264:         Set pFrameElement = GetDataFrameElement(GetActiveDataFrameName(m_Application), m_Application)
265:         pCreateSMap.FrameWidthInPageUnits = pFrameElement.Geometry.Envelope.Width
266:         pCreateSMap.FrameHeightInPageUnits = pFrameElement.Geometry.Envelope.Height
267:     Else
268:         pCreateSMap.FrameWidthInPageUnits = CDbl(txtManualGridWidth.Text)
269:         pCreateSMap.FrameHeightInPageUnits = CDbl(txtManualGridHeight.Text)
270:     End If
271:     If (optScaleSource(2).value) Then
        Dim dConvertPageToMapUnits As Double, dGridToFrameRatio As Double
273:         dConvertPageToMapUnits = CalculatePageToMapRatio(m_Application) 'NATHAN FIX THIS
274:         pCreateSMap.FrameWidthInPageUnits = CDbl(txtManualGridWidth.Text)
275:         pCreateSMap.FrameHeightInPageUnits = CDbl(txtManualGridHeight.Text)
276:         If pCreateSMap.FrameWidthInPageUnits >= pCreateSMap.FrameHeightInPageUnits Then
277:             dGridToFrameRatio = CDbl(txtAbsoluteGridWidth.Text) / pCreateSMap.FrameWidthInPageUnits
278:         Else
279:             dGridToFrameRatio = CDbl(txtAbsoluteGridHeight.Text) / pCreateSMap.FrameHeightInPageUnits
280:         End If
281:         pCreateSMap.MapScale = dGridToFrameRatio * dConvertPageToMapUnits
282:     End If
283:     sDestLayerName = cmbPolygonLayers.List(cmbPolygonLayers.ListIndex)
284:     If optLayerSource(0).value Then
285:         Set pCreateSMap.DestinationFeatureLayer = FindFeatureLayerByName(sDestLayerName, m_Application)
286:     End If
287:     pCreateSMap.FieldNameStripMapName = cmbFieldStripMapName.List(cmbFieldStripMapName.ListIndex)
288:     pCreateSMap.FieldNameMapAngle = cmbFieldGridAngle.List(cmbFieldGridAngle.ListIndex)
289:     pCreateSMap.FieldNameNumberInSeries = cmbFieldSeriesNumber.List(cmbFieldSeriesNumber.ListIndex)
290:     If cmbFieldMapScale.ListIndex > 0 Then pCreateSMap.FieldNameScale = cmbFieldMapScale.List(cmbFieldMapScale.ListIndex)
291:     pCreateSMap.RemoveCurrentGrids = (chkRemovePreviousGrids.value = vbChecked)
292:     Set pCreateSMap.StripMapRoute = m_Polyline
    ' Place grid settings on Public form property (so calling function can use them)
294:     Set Me.StripMapSettings = pCreateSMap
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
305:     m_Step = m_Step + 1
    ' If we're creating a new fclass, we can skip a the 'Set Field Roles' step
307:     If m_Step = 1 And (optLayerSource(1).value) Then
308:         m_Step = m_Step + 1
309:     End If
    ' If FINISH
311:     If m_Step >= 4 Then
312:         Set pMx = m_Application.Document
313:         RemoveGraphicsByName pMx
314:         CollateStripMapSettings
        ' If creating a new layer
316:         If optLayerSource(1).value Then
            ' Create the feature class
318:             Set pNewFields = CreateTheFields
            Select Case m_FileType
                Case ShapeFile
321:                     Set pOutputFClass = NewShapeFile(m_OutputLayer, pMx.FocusMap, pNewFields)
                Case AccessFeatureClass
323:                     Set pOutputFClass = NewAccessFile(m_OutputLayer, _
                            m_OutputDataset, m_OutputFClass, pNewFields)
325:             End Select
326:             If pOutputFClass Is Nothing Then
327:                 Err.Raise vbObjectError, "cmdNext", "Could not create the new output feature class."
328:             End If
            ' Create new layer
330:             Set pFeatureLayer = New FeatureLayer
331:             Set pFeatureLayer.FeatureClass = pOutputFClass
332:             pFeatureLayer.Name = pFeatureLayer.FeatureClass.AliasName
            ' Add the new layer to arcmap & reset the StripMapSettings object to point at it
334:             pMx.FocusMap.AddLayer pFeatureLayer
335:             Set StripMapSettings.DestinationFeatureLayer = pFeatureLayer
336:         End If
337:         Me.Hide
338:     Else
339:         SetVisibleControls m_Step
340:         SetControlsState
341:     End If
    
    Exit Sub
eh:
345:     MsgBox "Error: " & Err.Description, , "cmdNext_Click"
346:     m_Step = m_Step - 1
End Sub

Private Sub cmdSetNewGridLayer_Click()
  Dim pGxFilter As IGxObjectFilter
  Dim pGXBrow As IGxDialog, bFlag As Boolean
  Dim pSel As IEnumGxObject, pApp As IApplication
  
354:   Set pGxFilter = New GxFilter
355:   Set pApp = m_Application
356:   Set pGXBrow = New GxDialog
357:   Set pGXBrow.ObjectFilter = pGxFilter
358:   pGXBrow.Title = "Output feature class or shapefile"
359:   bFlag = pGXBrow.DoModalSave(pApp.hwnd)
  
361:   If bFlag Then
    Dim pObj As IGxObject
363:     Set pObj = pGXBrow.FinalLocation
364:     m_bIsGeoDatabase = True
365:     If UCase(pObj.Category) = "FOLDER" Then
366:       If InStr(1, pGXBrow.Name, ".shp") > 0 Then
367:         txtNewGridLayer.Text = pObj.FullName & "\" & pGXBrow.Name
368:       Else
369:         txtNewGridLayer.Text = pObj.FullName & "\" & pGXBrow.Name & ".shp"
370:       End If
371:       m_OutputLayer = txtNewGridLayer.Text
372:       m_bIsGeoDatabase = False
373:       m_FileType = ShapeFile
374:      CheckOutputFile
375:     Else
      Dim pLen As Long
377:       pLen = Len(pObj.FullName) - Len(pObj.BaseName) - 1
378:       txtNewGridLayer.Text = Left(pObj.FullName, pLen)
379:       m_OutputLayer = Left(pObj.FullName, pLen)
380:       m_OutputDataset = pObj.BaseName
381:       m_OutputFClass = pGXBrow.Name
382:       m_bIsGeoDatabase = True
383:       If UCase(pObj.Category) = "PERSONAL GEODATABASE FEATURE DATASET" Then
384:         m_FileType = AccessFeatureClass
385:       Else
386:         m_FileType = SDEFeatureClass
387:       End If
388:     End If
389:   Else
390:     txtNewGridLayer.Text = ""
391:     m_bIsGeoDatabase = False
392:   End If
393:   SetControlsState
End Sub

Private Sub Form_Load()
    Dim pMx As IMxDocument
    Dim bRenewCoordsX As Boolean
    Dim bRenewCoordsY As Boolean
    Dim sErrMsg As String
    On Error GoTo eh
    
403:     sErrMsg = CreateStripMapPolyline
404:     If Len(sErrMsg) > 0 Then
405:         MsgBox sErrMsg, vbCritical, "Create Map Grids"
406:         Unload Me
        Exit Sub
408:     End If
409:     Set pMx = m_Application.Document
410:     Me.Height = 5665
411:     Me.Width = 4935
412:     m_Step = 0
413:     LoadLayersComboBox
414:     LoadUnitsComboBox
415:     lblCurrFrameName.Caption = GetActiveDataFrameName(m_Application)
416:     If pMx.FocusMap.MapUnits = esriUnknownUnits Then
417:         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"
419:         Unload Me
        Exit Sub
421:     End If
422:     lblMapUnits.Caption = GetUnitsDescription(pMx.FocusMap.MapUnits)
423:     lblCurrentMapScale.Caption = Format(pMx.FocusMap.MapScale, "#,###,##0")
424:     SetVisibleControls m_Step
    
426:     SetControlsState
    
    'Make sure the wizard stays on top
429:     TopMost Me
    
    Exit Sub
eh:
433:     MsgBox "Error loading the form: " & Err.Description & vbCrLf _
        & vbCrLf & "Attempting to continue the load...", , "MapGridManager: Form_Load "
    On Error Resume Next
436:     SetVisibleControls m_Step
437:     SetControlsState
End Sub

Private Sub LoadUnitsComboBox()
    Dim pMx As IMxDocument
    Dim sPageUnitsDesc As String
    Dim pPage As IPage
    
    On Error GoTo eh
    
    ' Init
448:     Set pMx = m_Application.Document
449:     Set pPage = pMx.PageLayout.Page
450:     sPageUnitsDesc = GetUnitsDescription(pPage.Units)
451:     cmbGridSizeUnits.Clear
    ' Add
453:     cmbGridSizeUnits.AddItem sPageUnitsDesc
    'cmbGridSizeUnits.AddItem "Map Units (" & sMapUnitsDesc & ")"
    ' Set page units as default
456:     cmbGridSizeUnits.ListIndex = 0
    
    Exit Sub
eh:
460:     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
472:     Set pMx = m_Application.Document
473:     cmbPolygonLayers.Clear
474:     cmbPolygonLayers.AddItem "<Not Set>"
    ' For all layers
476:     For lLoop = 0 To pMx.FocusMap.LayerCount - 1
        ' If a feature class
478:         If TypeOf pMx.FocusMap.Layer(lLoop) Is IFeatureLayer Then
479:             Set pFL = pMx.FocusMap.Layer(lLoop)
480:             Set pFC = pFL.FeatureClass
            ' If a polygon layer
482:             If pFC.ShapeType = esriGeometryPolygon Then
                ' Add to combo box
484:                 cmbPolygonLayers.AddItem pFL.Name
485:             End If
486:         End If
487:     Next
488:     cmbPolygonLayers.ListIndex = 0
End Sub

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


Private Sub Form_Unload(Cancel As Integer)
503:     Set m_Application = Nothing
504:     Set StripMapSettings = Nothing
End Sub


Private Sub optGridSize_Click(Index As Integer)
    Dim pMx As IMxDocument
510:     Set pMx = m_Application.Document
511:     lblCurrFrameName.Caption = pMx.FocusMap.Name
512:     SetControlsState
End Sub

Private Sub optLayerSource_Click(Index As Integer)
    ' If creating a new fclass to hold the grids
517:     If Index = 1 Then
        ' Set the field names (will be created automatically)
519:         cmbFieldStripMapName.Clear
520:         cmbFieldGridAngle.Clear
521:         cmbFieldSeriesNumber.Clear
522:         cmbFieldMapScale.Clear
523:         cmbFieldStripMapName.AddItem "<None>"
524:         cmbFieldGridAngle.AddItem "<None>"
525:         cmbFieldSeriesNumber.AddItem "<None>"
526:         cmbFieldMapScale.AddItem "<None>"
527:         cmbFieldStripMapName.AddItem c_DefaultFld_StripMapName
528:         cmbFieldGridAngle.AddItem c_DefaultFld_MapAngle
529:         cmbFieldSeriesNumber.AddItem c_DefaultFld_SeriesNum
530:         cmbFieldMapScale.AddItem c_DefaultFld_MapScale
531:         cmbFieldStripMapName.ListIndex = 1
532:         cmbFieldGridAngle.ListIndex = 1
533:         cmbFieldSeriesNumber.ListIndex = 1
534:         cmbFieldMapScale.ListIndex = 1
535:     End If
536:     SetControlsState
End Sub

Private Sub optScaleSource_Click(Index As Integer)
540:     If Index = 0 Then
541:         SetCurrentMapScaleCaption
542:     ElseIf Index = 2 Then
543:         optGridSize(1).value = True
544:     End If
545:     SetControlsState
End Sub

Private Sub txtAbsoluteGridHeight_Change()
549:     SetControlsState
End Sub

Private Sub txtAbsoluteGridHeight_KeyPress(KeyAscii As Integer)
    ' If a non-numeric (that is not a decimal point)
554:     If (KeyAscii < Asc("0") Or KeyAscii > Asc("9")) _
     And KeyAscii <> Asc(".") _
     And Chr(KeyAscii) <> vbBack Then
        ' Do not allow this button to work
558:         KeyAscii = 0
    ' If a decimal point, make sure we only ever get one of them
560:     ElseIf KeyAscii = Asc(".") Then
561:         If InStr(txtAbsoluteGridHeight.Text, ".") > 0 Then
562:             KeyAscii = 0
563:         End If
564:     End If
End Sub

Private Sub txtAbsoluteGridWidth_Change()
568:     SetControlsState
End Sub

Private Sub txtAbsoluteGridWidth_KeyPress(KeyAscii As Integer)
    ' If a non-numeric (that is not a decimal point)
573:     If (KeyAscii < Asc("0") Or KeyAscii > Asc("9")) _
     And KeyAscii <> Asc(".") _
     And Chr(KeyAscii) <> vbBack Then
        ' Do not allow this button to work
577:         KeyAscii = 0
    ' If a decimal point, make sure we only ever get one of them
579:     ElseIf KeyAscii = Asc(".") Then
580:         If InStr(txtAbsoluteGridWidth.Text, ".") > 0 Then
581:             KeyAscii = 0
582:         End If
583:     End If
End Sub

Private Sub txtManualGridHeight_Change()
587:     SetControlsState
End Sub

Private Sub txtManualGridHeight_KeyPress(KeyAscii As Integer)
    ' If a non-numeric (that is not a decimal point)
592:     If (KeyAscii < Asc("0") Or KeyAscii > Asc("9")) _
     And KeyAscii <> Asc(".") _
     And Chr(KeyAscii) <> vbBack Then
        ' Do not allow this button to work
596:         KeyAscii = 0
    ' If a decimal point, make sure we only ever get one of them
598:     ElseIf KeyAscii = Asc(".") Then
599:         If InStr(txtManualGridHeight.Text, ".") > 0 Then
600:             KeyAscii = 0
601:         End If
602:     End If
End Sub

Private Sub txtManualGridWidth_Change()
606:     If IsNumeric(txtManualGridWidth.Text) And optScaleSource(2).value Then
        Dim dRatio As Double, dGridWidth As Double
608:         dGridWidth = CDbl(txtManualGridWidth.Text)
609:         dRatio = CDbl(txtAbsoluteGridHeight.Text) / CDbl(txtAbsoluteGridWidth.Text)
610:         txtManualGridHeight.Text = CStr(dRatio * dGridWidth)
611:     End If
612:     SetControlsState
End Sub

Private Sub txtManualGridWidth_KeyPress(KeyAscii As Integer)
    ' If a non-numeric (that is not a decimal point)
617:     If (KeyAscii < Asc("0") Or KeyAscii > Asc("9")) _
     And KeyAscii <> Asc(".") _
     And Chr(KeyAscii) <> vbBack Then
        ' Do not allow this button to work
621:         KeyAscii = 0
    ' If a decimal point, make sure we only ever get one of them
623:     ElseIf KeyAscii = Asc(".") Then
624:         If InStr(txtManualGridWidth.Text, ".") > 0 Then
625:             KeyAscii = 0
626:         End If
627:     End If
End Sub

Private Sub txtManualMapScale_Change()
631:     SetControlsState
End Sub

Private Sub txtManualMapScale_KeyPress(KeyAscii As Integer)
    ' If a non-numeric (that is not a decimal point)
636:     If (KeyAscii < Asc("0") Or KeyAscii > Asc("9")) _
     And KeyAscii <> Asc(".") _
     And Chr(KeyAscii) <> vbBack Then
        ' Do not allow this button to work
640:         KeyAscii = 0
    ' If a decimal point, make sure we only ever get one of them
642:     ElseIf KeyAscii = Asc(".") Then
643:         If InStr(txtManualMapScale.Text, ".") > 0 Then
644:             KeyAscii = 0
645:         End If