frmsmapsettings.frm

使用VB和ArcObject结合的程序

226:     End If
227:     SetVisibleControls m_Step
228:     SetControlsState
End Sub

Private Sub cmdClose_Click()
232:     Set m_Application = Nothing
233:     Set Me.StripMapSettings = Nothing
234:     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
244:     pCreateSMap.StripMapName = txtStripMapSeriesName.Text
245:     pCreateSMap.FlipPolyline = (chkFlipLine.Value = vbChecked)
246:     If (optScaleSource(0).Value) Then
247:         pCreateSMap.MapScale = CDbl(lblCurrentMapScale.Caption)
248:     ElseIf (optScaleSource(1).Value) Then
249:         pCreateSMap.MapScale = CDbl(txtManualMapScale.Text)
250:     End If
251:     If (optGridSize(0).Value) Then
252:         Set pFrameElement = GetDataFrameElement(GetActiveDataFrameName(m_Application), m_Application)
253:         pCreateSMap.FrameWidthInPageUnits = pFrameElement.Geometry.Envelope.Width
254:         pCreateSMap.FrameHeightInPageUnits = pFrameElement.Geometry.Envelope.Height
255:     Else
256:         pCreateSMap.FrameWidthInPageUnits = CDbl(txtManualGridWidth.Text)
257:         pCreateSMap.FrameHeightInPageUnits = CDbl(txtManualGridHeight.Text)
258:     End If
259:     If (optScaleSource(2).Value) Then
        Dim dConvertPageToMapUnits As Double, dGridToFrameRatio As Double
261:         dConvertPageToMapUnits = CalculatePageToMapRatio(m_Application) 'NATHAN FIX THIS
262:         pCreateSMap.FrameWidthInPageUnits = CDbl(txtManualGridWidth.Text)
263:         pCreateSMap.FrameHeightInPageUnits = CDbl(txtManualGridHeight.Text)
264:         If pCreateSMap.FrameWidthInPageUnits >= pCreateSMap.FrameHeightInPageUnits Then
265:             dGridToFrameRatio = CDbl(txtAbsoluteGridWidth.Text) / pCreateSMap.FrameWidthInPageUnits
266:         Else
267:             dGridToFrameRatio = CDbl(txtAbsoluteGridHeight.Text) / pCreateSMap.FrameHeightInPageUnits
268:         End If
269:         pCreateSMap.MapScale = dGridToFrameRatio * dConvertPageToMapUnits
270:     End If
271:     sDestLayerName = cmbPolygonLayers.List(cmbPolygonLayers.ListIndex)
272:     If optLayerSource(0).Value Then
273:         Set pCreateSMap.DestinationFeatureLayer = FindFeatureLayerByName(sDestLayerName, m_Application)
274:     End If
275:     pCreateSMap.FieldNameStripMapName = cmbFieldStripMapName.List(cmbFieldStripMapName.ListIndex)
276:     pCreateSMap.FieldNameMapAngle = cmbFieldGridAngle.List(cmbFieldGridAngle.ListIndex)
277:     pCreateSMap.FieldNameNumberInSeries = cmbFieldSeriesNumber.List(cmbFieldSeriesNumber.ListIndex)
278:     If cmbFieldMapScale.ListIndex > 0 Then pCreateSMap.FieldNameScale = cmbFieldMapScale.List(cmbFieldMapScale.ListIndex)
279:     pCreateSMap.RemoveCurrentGrids = (chkRemovePreviousGrids.Value = vbChecked)
280:     Set pCreateSMap.StripMapRoute = m_Polyline
    ' Place grid settings on Public form property (so calling function can use them)
282:     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
293:     m_Step = m_Step + 1
    ' If we're creating a new fclass, we can skip a the 'Set Field Roles' step
295:     If m_Step = 1 And (optLayerSource(1).Value) Then
296:         m_Step = m_Step + 1
297:     End If
    ' If FINISH
299:     If m_Step >= 4 Then
300:         Set pMx = m_Application.Document
301:         RemoveGraphicsByName pMx
302:         CollateStripMapSettings
        ' If creating a new layer
304:         If optLayerSource(1).Value Then
            ' Create the feature class
306:             Set pNewFields = CreateTheFields
            Select Case m_FileType
                Case ShapeFile
309:                     Set pOutputFClass = NewShapeFile(m_OutputLayer, pMx.FocusMap, pNewFields)
                Case AccessFeatureClass
311:                     Set pOutputFClass = NewAccessFile(m_OutputLayer, _
                            m_OutputDataset, m_OutputFClass, pNewFields)
313:             End Select
314:             If pOutputFClass Is Nothing Then
315:                 Err.Raise vbObjectError, "cmdNext", "Could not create the new output feature class."
316:             End If
            ' Create new layer
318:             Set pFeatureLayer = New FeatureLayer
319:             Set pFeatureLayer.FeatureClass = pOutputFClass
320:             pFeatureLayer.Name = pFeatureLayer.FeatureClass.AliasName
            ' Add the new layer to arcmap & reset the StripMapSettings object to point at it
322:             pMx.FocusMap.AddLayer pFeatureLayer
323:             Set StripMapSettings.DestinationFeatureLayer = pFeatureLayer
324:         End If
325:         Me.Hide
326:     Else
327:         SetVisibleControls m_Step
328:         SetControlsState
329:     End If
    
    Exit Sub
eh:
333:     MsgBox "Error: " & Err.Description, , "cmdNext_Click"
334:     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
  
342:   Set pGxFilter = New GxFilter
343:   Set pApp = m_Application
344:   Set pGXBrow = New GxDialog
345:   Set pGXBrow.ObjectFilter = pGxFilter
346:   pGXBrow.Title = "Output feature class or shapefile"
347:   bFlag = pGXBrow.DoModalSave(pApp.hwnd)
  
349:   If bFlag Then
    Dim pObj As IGxObject
351:     Set pObj = pGXBrow.FinalLocation
352:     m_bIsGeoDatabase = True
353:     If UCase(pObj.Category) = "FOLDER" Then
354:       If InStr(1, pGXBrow.Name, ".shp") > 0 Then
355:         txtNewGridLayer.Text = pObj.FullName & "\" & pGXBrow.Name
356:       Else
357:         txtNewGridLayer.Text = pObj.FullName & "\" & pGXBrow.Name & ".shp"
358:       End If
359:       m_OutputLayer = txtNewGridLayer.Text
360:       m_bIsGeoDatabase = False
361:       m_FileType = ShapeFile
362:      CheckOutputFile
363:     Else
      Dim pLen As Long
365:       pLen = Len(pObj.FullName) - Len(pObj.BaseName) - 1
366:       txtNewGridLayer.Text = Left(pObj.FullName, pLen)
367:       m_OutputLayer = Left(pObj.FullName, pLen)
368:       m_OutputDataset = pObj.BaseName
369:       m_OutputFClass = pGXBrow.Name
370:       m_bIsGeoDatabase = True
371:       If UCase(pObj.Category) = "PERSONAL GEODATABASE FEATURE DATASET" Then
372:         m_FileType = AccessFeatureClass
373:       Else
374:         m_FileType = SDEFeatureClass
375:       End If
376:     End If
377:   Else
378:     txtNewGridLayer.Text = ""
379:     m_bIsGeoDatabase = False
380:   End If
381:   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
    
391:     sErrMsg = CreateStripMapPolyline
392:     If Len(sErrMsg) > 0 Then
393:         MsgBox sErrMsg, vbCritical, "Create Map Grids"
394:         Unload Me
        Exit Sub
396:     End If
397:     Set pMx = m_Application.Document
398:     Me.Height = 5665
399:     Me.Width = 4935
400:     m_Step = 0
401:     LoadLayersComboBox
402:     LoadUnitsComboBox
403:     lblCurrFrameName.Caption = GetActiveDataFrameName(m_Application)
404:     If pMx.FocusMap.MapUnits = esriUnknownUnits Then
405:         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"
407:         Unload Me
        Exit Sub
409:     End If
410:     lblMapUnits.Caption = GetUnitsDescription(pMx.FocusMap.MapUnits)
411:     lblCurrentMapScale.Caption = Format(pMx.FocusMap.MapScale, "#,###,##0")
412:     SetVisibleControls m_Step
    
414:     SetControlsState
    
    'Make sure the wizard stays on top
417:     TopMost Me
    
    Exit Sub
eh:
421:     MsgBox "Error loading the form: " & Err.Description & vbCrLf _
        & vbCrLf & "Attempting to continue the load...", , "MapGridManager: Form_Load "
    On Error Resume Next
424:     SetVisibleControls m_Step
425:     SetControlsState
End Sub

Private Sub LoadUnitsComboBox()
    Dim pMx As IMxDocument
    Dim sPageUnitsDesc As String
    Dim pPage As IPage
    
    On Error GoTo eh
    
    ' Init
436:     Set pMx = m_Application.Document
437:     Set pPage = pMx.PageLayout.Page
438:     sPageUnitsDesc = GetUnitsDescription(pPage.Units)
439:     cmbGridSizeUnits.Clear
    ' Add
441:     cmbGridSizeUnits.AddItem sPageUnitsDesc
    'cmbGridSizeUnits.AddItem "Map Units (" & sMapUnitsDesc & ")"
    ' Set page units as default
444:     cmbGridSizeUnits.ListIndex = 0
    
    Exit Sub
eh:
448:     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
460:     Set pMx = m_Application.Document
461:     cmbPolygonLayers.Clear
462:     cmbPolygonLayers.AddItem "<Not Set>"
    ' For all layers
464:     For lLoop = 0 To pMx.FocusMap.LayerCount - 1
        ' If a feature class
466:         If TypeOf pMx.FocusMap.Layer(lLoop) Is IFeatureLayer Then
467:             Set pFL = pMx.FocusMap.Layer(lLoop)
468:             Set pFC = pFL.FeatureClass
            ' If a polygon layer
470:             If pFC.ShapeType = esriGeometryPolygon Then
                ' Add to combo box
472:                 cmbPolygonLayers.AddItem pFL.Name
473:             End If
474:         End If
475:     Next
476:     cmbPolygonLayers.ListIndex = 0
End Sub

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


Private Sub Form_Unload(Cancel As Integer)
491:     Set m_Application = Nothing
492:     Set StripMapSettings = Nothing
End Sub


Private Sub optGridSize_Click(Index As Integer)
    Dim pMx As IMxDocument
498:     Set pMx = m_Application.Document
499:     lblCurrFrameName.Caption = pMx.FocusMap.Name
500:     SetControlsState
End Sub

Private Sub optLayerSource_Click(Index As Integer)
    ' If creating a new fclass to hold the grids
505:     If Index = 1 Then
        ' Set the field names (will be created automatically)
507:         cmbFieldStripMapName.Clear
508:         cmbFieldGridAngle.Clear
509:         cmbFieldSeriesNumber.Clear
510:         cmbFieldMapScale.Clear
511:         cmbFieldStripMapName.AddItem "<None>"
512:         cmbFieldGridAngle.AddItem "<None>"
513:         cmbFieldSeriesNumber.AddItem "<None>"
514:         cmbFieldMapScale.AddItem "<None>"
515:         cmbFieldStripMapName.AddItem c_DefaultFld_StripMapName
516:         cmbFieldGridAngle.AddItem c_DefaultFld_MapAngle
517:         cmbFieldSeriesNumber.AddItem c_DefaultFld_SeriesNum
518:         cmbFieldMapScale.AddItem c_DefaultFld_MapScale
519:         cmbFieldStripMapName.ListIndex = 1
520:         cmbFieldGridAngle.ListIndex = 1
521:         cmbFieldSeriesNumber.ListIndex = 1
522:         cmbFieldMapScale.ListIndex = 1
523:     End If
524:     SetControlsState
End Sub

Private Sub optScaleSource_Click(Index As Integer)
528:     If Index = 0 Then
529:         SetCurrentMapScaleCaption
530:     ElseIf Index = 2 Then
531:         optGridSize(1).Value = True
532:     End If
533:     SetControlsState
End Sub

Private Sub txtAbsoluteGridHeight_Change()
537:     SetControlsState
End Sub

Private Sub txtAbsoluteGridHeight_KeyPress(KeyAscii As Integer)
    ' If a non-numeric (that is not a decimal point)
542:     If (KeyAscii < Asc("0") Or KeyAscii > Asc("9")) _
     And KeyAscii <> Asc(".") _
     And Chr(KeyAscii) <> vbBack Then
        ' Do not allow this button to work
546:         KeyAscii = 0
    ' If a decimal point, make sure we only ever get one of them
548:     ElseIf KeyAscii = Asc(".") Then
549:         If InStr(txtAbsoluteGridHeight.Text, ".") > 0 Then
550:             KeyAscii = 0
551:         End If
552:     End If
End Sub

Private Sub txtAbsoluteGridWidth_Change()
556:     SetControlsState
End Sub

Private Sub txtAbsoluteGridWidth_KeyPress(KeyAscii As Integer)
    ' If a non-numeric (that is not a decimal point)
561:     If (KeyAscii < Asc("0") Or KeyAscii > Asc("9")) _
     And KeyAscii <> Asc(".") _
     And Chr(KeyAscii) <> vbBack Then
        ' Do not allow this button to work
565:         KeyAscii = 0
    ' If a decimal point, make sure we only ever get one of them
567:     ElseIf KeyAscii = Asc(".") Then
568:         If InStr(txtAbsoluteGridWidth.Text, ".") > 0 Then
569:             KeyAscii = 0
570:         End If
571:     End If
End Sub

Private Sub txtManualGridHeight_Change()
575:     SetControlsState
End Sub

Private Sub txtManualGridHeight_KeyPress(KeyAscii As Integer)
    ' If a non-numeric (that is not a decimal point)
580:     If (KeyAscii < Asc("0") Or KeyAscii > Asc("9")) _
     And KeyAscii <> Asc(".") _
     And Chr(KeyAscii) <> vbBack Then
        ' Do not allow this button to work
584:         KeyAscii = 0
    ' If a decimal point, make sure we only ever get one of them
586:     ElseIf KeyAscii = Asc(".") Then
587:         If InStr(txtManualGridHeight.Text, ".") > 0 Then
588:             KeyAscii = 0
589:         End If
590:     End If
End Sub

Private Sub txtManualGridWidth_Change()
594:     If IsNumeric(txtManualGridWidth.Text) And optScaleSource(2).Value Then
        Dim dRatio As Double, dGridWidth As Double
596:         dGridWidth = CDbl(txtManualGridWidth.Text)
597:         dRatio = CDbl(txtAbsoluteGridHeight.Text) / CDbl(txtAbsoluteGridWidth.Text)
598:         txtManualGridHeight.Text = CStr(dRatio * dGridWidth)
599:     End If
600:     SetControlsState
End Sub

Private Sub txtManualGridWidth_KeyPress(KeyAscii As Integer)
    ' If a non-numeric (that is not a decimal point)
605:     If (KeyAscii < Asc("0") Or KeyAscii > Asc("9")) _
     And KeyAscii <> Asc(".") _
     And Chr(KeyAscii) <> vbBack Then
        ' Do not allow this button to work
609:         KeyAscii = 0
    ' If a decimal point, make sure we only ever get one of them
611:     ElseIf KeyAscii = Asc(".") Then
612:         If InStr(txtManualGridWidth.Text, ".") > 0 Then
613:             KeyAscii = 0
614:         End If
615:     End If
End Sub

Private Sub txtManualMapScale_Change()
619:     SetControlsState
End Sub

Private Sub txtManualMapScale_KeyPress(KeyAscii As Integer)
    ' If a non-numeric (that is not a decimal point)
624:     If (KeyAscii < Asc("0") Or KeyAscii > Asc("9")) _
     And KeyAscii <> Asc(".") _
     And Chr(KeyAscii) <> vbBack Then
        ' Do not allow this button to work
628:         KeyAscii = 0
    ' If a decimal point, make sure we only ever get one of them