clscreategrids.cls

使用VB和ArcObject结合的程序

548:     For lRow = 0 To lRowCount - 1
549:         For lCol = 0 To lColCount - 1
            ' Create the source polygon
551:             Set pGridPolygon = CreateGridPoly2(pStartingCoord, lRow, lCol, dGridSizeW, dGridSizeH)
            ' If required, check for containing features
553:             If m_NoEmptyGrids Then
554:                 bOKToAdd = HasFeatures(pGridPolygon, pMx.FocusMap)
555:             End If
556:             If bOKToAdd Then
                ' Create new grid cell feature
558:                 Set pInsertFeatureBuffer.Shape = pGridPolygon
559:                 If m_StartIDType = TopLeft Then
560:                     pInsertFeatureBuffer.Value(pFC.Fields.FindField(m_FldID)) = _
                            CalculateID((lRowCount - 1) - lRow, lCol, iStringLengthRow, iStringLengthCol)
562:                     If Len(m_FldRowNum) > 0 Then pInsertFeatureBuffer.Value(pFC.Fields.FindField(m_FldRowNum)) = (lRowCount - lRow)
563:                 Else
564:                     pInsertFeatureBuffer.Value(pFC.Fields.FindField(m_FldID)) = _
                            CalculateID(lRow, lCol, iStringLengthRow, iStringLengthCol)
566:                     If Len(m_FldRowNum) > 0 Then pInsertFeatureBuffer.Value(pFC.Fields.FindField(m_FldRowNum)) = (lRow + 1)
567:                 End If
568:                 If Len(m_FldColNum) > 0 Then pInsertFeatureBuffer.Value(pFC.Fields.FindField(m_FldColNum)) = (lCol + 1)
569:                 If Len(m_FldScale) > 0 Then pInsertFeatureBuffer.Value(pFC.Fields.FindField(m_FldScale)) = m_dMapScale
570:                 pInsertFeatureCursor.InsertFeature pInsertFeatureBuffer
571:             End If
572:             If pProgress.ProgressBar1.Value < pProgress.ProgressBar1.Max Then
573:                 pProgress.ProgressBar1.Value = pProgress.ProgressBar1.Value + dIncrement
574:             Else
575:                 pProgress.lblInformation.Caption = "Warning: Val > Max (" & pProgress.ProgressBar1.Max & ")"
576:             End If
577:             If ((lRow * lColCount) + lCol) Mod 20 = 0 Then
578:                 DoEvents
579:                 pInsertFeatureCursor.Flush
580:             End If
581:             pProgress.Refresh
582:             If pProgress.Cancelled Then
                Dim vUserChoice
584:                 pProgress.Cancelled = False       ' Reset the form
585:                 vUserChoice = MsgBox("Operation cancelled." _
                    & "  Save the edits made thus far?" & vbCrLf & vbCrLf _
                    & "(Click Cancel to continue processing)", _
                                vbYesNoCancel, "Generate Grids")
589:                 If vUserChoice <> vbCancel Then
590:                     GoTo CancelledGenerateGrids     'Sorry for GoTo usage - in a hurry
591:                 End If
592:             End If
593:         Next
594:     Next
595:     pInsertFeatureCursor.Flush
596:     m_pProgress.Visible = False
    
    ' Stop editing
599:     pWorkspaceEdit.StopEditOperation
600:     pWorkspaceEdit.StopEditing True
    ' ----------------------------------------------------
    
603:     Screen.MousePointer = vbDefault
604:     pMx.ActiveView.Refresh
    
    Exit Sub
    
CancelledGenerateGrids:
609:     m_pProgress.Visible = False
610:     If vUserChoice = vbYes Then
611:         pInsertFeatureCursor.Flush
612:         pWorkspaceEdit.StopEditOperation
613:         pWorkspaceEdit.StopEditing True
614:     Else
615:         pWorkspaceEdit.StopEditOperation
616:         pWorkspaceEdit.StopEditing False
617:     End If
618:     Screen.MousePointer = vbDefault
619:     pMx.ActiveView.Refresh
    Exit Sub
    
622:     Resume
eh:
624:     m_pProgress.Visible = False
625:     Screen.MousePointer = vbDefault
626:     If Not pWorkspaceEdit Is Nothing Then
627:         If pWorkspaceEdit.IsBeingEdited Then
628:             pWorkspaceEdit.StopEditOperation
629:             pWorkspaceEdit.StopEditing False
630:         End If
631:     End If
632:     MsgBox "GenerateGrids - " & Erl & " - " & Err.Description
End Sub


Private Function CreateGridPoly2(pStartPoint As IPoint, lRow As Long, lCol As Long, _
                                dGridWidth As Double, dGridHeight As Double) As IPolygon
    Dim pPntColl As IPointCollection
    Dim pPoint As IPoint
    Dim dX As Double, dY As Double
    
642:     Set CreateGridPoly2 = New Polygon
643:     Set pPntColl = CreateGridPoly2
644:     Set pPoint = New esrigeometry.Point
645:     pPoint.PutCoords pStartPoint.X + (lCol * dGridWidth), pStartPoint.Y + (lRow * dGridHeight)
646:     pPntColl.AddPoint pPoint
647:     Set pPoint = New esrigeometry.Point
648:     pPoint.PutCoords pStartPoint.X + (lCol * dGridWidth), pStartPoint.Y + ((lRow + 1) * dGridHeight)
649:     pPntColl.AddPoint pPoint
650:     Set pPoint = New esrigeometry.Point
651:     pPoint.PutCoords pStartPoint.X + ((lCol + 1) * dGridWidth), pStartPoint.Y + ((lRow + 1) * dGridHeight)
652:     pPntColl.AddPoint pPoint
653:     Set pPoint = New esrigeometry.Point
654:     pPoint.PutCoords pStartPoint.X + ((lCol + 1) * dGridWidth), pStartPoint.Y + (lRow * dGridHeight)
655:     pPntColl.AddPoint pPoint
656:     Set pPoint = New esrigeometry.Point
657:     pPoint.PutCoords pStartPoint.X + (lCol * dGridWidth), pStartPoint.Y + (lRow * dGridHeight)
658:     pPntColl.AddPoint pPoint
    
End Function

Private Sub CalculateRowColCounts(ByVal XStart As Double, ByVal YStart As Double, _
                                  ByVal XEnd As Double, ByVal YEnd As Double, _
                                  ByVal XGridWidth As Double, ByVal YGridHeight As Double, _
                                  ByVal LayerExtent As IEnvelope, _
                                  ByRef ReturnColCount As Long, ByRef ReturnRowCount As Long)
    Dim XRange As Double
    Dim YRange As Double
    Dim dTemp As Double
    Dim lMultiplierX As Long
    Dim lMultiplierY As Long
    
    On Error GoTo eh
    
    ' Protect against div by zero (where the grid width/height is less than 0.5 => ie: with Geographic Data)
676:     lMultiplierX = 1
677:     dTemp = XGridWidth
678:     While dTemp < 10
679:         dTemp = dTemp * 10
680:         lMultiplierX = lMultiplierX * 10
681:     Wend
682:     lMultiplierY = 1
683:     dTemp = YGridHeight
684:     While dTemp < 10
685:         dTemp = dTemp * 10
686:         lMultiplierY = lMultiplierY * 10
687:     Wend
    
    ' Init
690:     XRange = XEnd - XStart
691:     YRange = YEnd - YStart
    'X ------------------------------------------
693:     If Not (LayerExtent Is Nothing) Then
694:         If XStart < LayerExtent.XMin Then
695:             Err.Raise vbObjectError, "CalculateRowColCounts", _
                "Starting X (" & XStart & ") is outside the valid layer extent (" & LayerExtent.XMin & ")"
697:         ElseIf XEnd > LayerExtent.XMax Then
698:             Err.Raise vbObjectError, "CalculateRowColCounts", _
                "Ending X (" & XStart & ") is outside the valid layer extent (" & LayerExtent.XMax & ")"
700:         ElseIf (XStart + XGridWidth) > LayerExtent.XMax Then
701:             Err.Raise vbObjectError, "CalculateRowColCounts", _
                "Adding a single Grid (width " & XGridWidth & ") would exceed valid X range for layer (" & LayerExtent.XMax & ")"
703:         End If
704:     End If
705:     If XRange < XGridWidth Then
706:         Err.Raise vbObjectError, "CalculateRowColCounts", _
            "Grid width " & XGridWidth & " exceeds range specified (" & XStart & " - " & XEnd & ")"
708:     ElseIf (XStart + XGridWidth) > XEnd Then
709:         Err.Raise vbObjectError, "CalculateRowColCounts", _
            "Adding a single Grid (width " & XGridWidth & ") would exceed specified X range (" & XEnd & ")"
711:     End If
712:     ReturnColCount = (XRange * lMultiplierX) \ (XGridWidth * lMultiplierX)
    'Y ------------------------------------------
714:     If Not (LayerExtent Is Nothing) Then
715:         If YStart < LayerExtent.YMin Then
716:             Err.Raise vbObjectError, "CalculateRowColCounts", _
                "Starting Y (" & YStart & ") is outside the valid layer extent (" & LayerExtent.YMin & ")"
718:         ElseIf YEnd > LayerExtent.YMax Then
719:             Err.Raise vbObjectError, "CalculateRowColCounts", _
                "Ending Y (" & YStart & ") is outside the valid layer extent (" & LayerExtent.YMax & ")"
721:         ElseIf (YStart + YGridHeight) > LayerExtent.YMax Then
722:             Err.Raise vbObjectError, "CalculateRowColCounts", _
                "Adding a single Grid (height " & YGridHeight & ") would exceed valid Y range for layer (" & LayerExtent.YMax & ")"
724:         End If
725:     End If
726:     If YRange < YGridHeight Then
727:         Err.Raise vbObjectError, "CalculateRowColCounts", _
            "Grid height " & YGridHeight & " exceeds range specified (" & YStart & " - " & YEnd & ")"
729:     ElseIf (XStart + XGridWidth) > XEnd Then
730:         Err.Raise vbObjectError, "CalculateRowColCounts", _
            "Adding a single Grid (height " & YGridHeight & ") would exceed specified Y range (" & YEnd & ")"
732:     End If
733:     ReturnRowCount = (YRange * lMultiplierY) \ (YGridHeight * lMultiplierY)
    '--------------------------------------------
    
    Exit Sub
eh:
738:     Err.Raise Err.Number, Err.Source, "Error in CalculateRowColCounts: " & Err.Description
End Sub

Private Function CalculatePageToMapRatio(pApp As IApplication) As Double
    Dim pMx As IMxDocument
    Dim pPage As IPage
    Dim pPageUnits As esriUnits
    Dim pSR As ISpatialReference
    Dim pSRI As ISpatialReferenceInfo
    Dim pPCS As IProjectedCoordinateSystem
    Dim dMetersPerUnit As Double
    Dim dCurrScale As Double
    Dim pExtentEnv As IEnvelope
    
    On Error GoTo eh
    
    ' Init
755:     Set pMx = pApp.Document
756:     Set pSR = pMx.FocusMap.SpatialReference
    ' If a Projected coord system
758:     If TypeOf pSR Is IProjectedCoordinateSystem Then
        ' Use meters per unit as the conversion
760:         Set pPCS = pSR
761:         dMetersPerUnit = pPCS.CoordinateUnit.MetersPerUnit
        ' Now convert this into page (ie: paper) units
763:         Set pPage = pMx.PageLayout.Page
764:         pPageUnits = pPage.Units
        Select Case pPageUnits
            Case esriInches: CalculatePageToMapRatio = dMetersPerUnit / (1 / 12 * 0.304800609601219)
            Case esriFeet: CalculatePageToMapRatio = dMetersPerUnit / (0.304800609601219)
            Case esriCentimeters: CalculatePageToMapRatio = dMetersPerUnit / (1 / 100)
            Case esriMeters: CalculatePageToMapRatio = dMetersPerUnit / (1)
            Case Else:
771:                 MsgBox "Warning: Only the following Page (Layout) Units are supported by this tool:" _
                    & vbCrLf & " - Inches, Feet, Centimeters, Meters" _
                    & vbCrLf & vbCrLf & "Calculating as though Page Units are in Inches..."
774:                 CalculatePageToMapRatio = dMetersPerUnit / (1 / 12 * 0.304800609601219)
775:         End Select
    ' Otherwise
777:     Else
        ' If not projected, we can only do a "flat" conversion -> that is, use the current scale and extent
        '  as a ratio to be applied to the map grid scale.
        ' NOTE: We MUST be in Layout mode to make this calculation, as the scale in Map View and Layout View
        '  are not the same (as the extent envelope and data frame envelope can be different shapes).  The
        '  test for being in Layout Mode is made in the clsMapGridButton.ICommand_Enabled property.
783:         Set pExtentEnv = pMx.ActiveView.Extent
784:         dCurrScale = pMx.FocusMap.MapScale
785:         If ((m_EndX - m_StartX) / m_dFrameWidthInPageUnits) > ((m_EndY - m_StartY) / m_dFrameHeightInPageUnits) Then
786:             CalculatePageToMapRatio = m_dFrameWidthInPageUnits / ((m_EndX - m_StartX) / dCurrScale)
787:         Else
788:             CalculatePageToMapRatio = m_dFrameHeightInPageUnits / ((m_EndY - m_StartY) / dCurrScale)
789:         End If
790:     End If
    
    Exit Function
eh:
794:     CalculatePageToMapRatio = 1
795:     MsgBox "Error in CalculatePageToMapRatio" & vbCrLf & Err.Description
End Function

Private Function HasFeatures(pPolygon As IPolygon, pMap As IMap) As Boolean
    Dim lLoop As Long
    Dim pFL As IFeatureLayer
    Dim pSF As ISpatialFilter
    Dim pFC As IFeatureCursor
    Dim pF As IFeature
    
805:     HasFeatures = False
806:     Set pSF = New SpatialFilter
807:     Set pSF.Geometry = pPolygon
808:     pSF.SpatialRel = esriSpatialRelIntersects
809:     For lLoop = 0 To (pMap.LayerCount - 1)
810:         If TypeOf pMap.Layer(lLoop) Is IFeatureLayer Then
811:             Set pFL = pMap.Layer(lLoop)
812:             If pFL.Name <> m_DestFL.Name And IsARequiredLayer(pFL.Name) Then
813:                 pSF.GeometryField = pFL.FeatureClass.shapeFieldName
814:                 Set pFC = pFL.Search(pSF, False)
815:                 Set pF = pFC.NextFeature
816:                 If Not pF Is Nothing Then
817:                     HasFeatures = True
818:                     Exit For
819:                 End If
820:             End If
821:         End If
822:     Next
End Function

Private Function IsARequiredLayer(sLayerName As String) As Boolean
    Dim lLoop As Long
827:     For lLoop = 1 To m_colLayerNamesForData.count
828:         If UCase(m_colLayerNamesForData.Item(lLoop)) = UCase(sLayerName) Then
829:             IsARequiredLayer = True
830:             Exit For
831:         End If
832:     Next
End Function

Private Sub Class_Terminate()
836:     Set m_DestFL = Nothing
837:     Set m_DestFC = Nothing
838:     Set m_pProgress = Nothing
End Sub