clscreategrids.cls

一个不错的插件

566:                 bOKToAdd = HasFeatures(pGridPolygon, pMx.FocusMap)
567:             End If
568:             If bOKToAdd Then
                ' Create new grid cell feature
570:                 Set pInsertFeatureBuffer.Shape = pGridPolygon
571:                 If m_StartIDType = TopLeft Then
572:                     pInsertFeatureBuffer.value(pFC.Fields.FindField(m_FldID)) = _
                            CalculateID((lRowCount - 1) - lRow, lCol, iStringLengthRow, iStringLengthCol)
574:                     If Len(m_FldRowNum) > 0 Then pInsertFeatureBuffer.value(pFC.Fields.FindField(m_FldRowNum)) = (lRowCount - lRow)
575:                 Else
576:                     pInsertFeatureBuffer.value(pFC.Fields.FindField(m_FldID)) = _
                            CalculateID(lRow, lCol, iStringLengthRow, iStringLengthCol)
578:                     If Len(m_FldRowNum) > 0 Then pInsertFeatureBuffer.value(pFC.Fields.FindField(m_FldRowNum)) = (lRow + 1)
579:                 End If
580:                 If Len(m_FldColNum) > 0 Then pInsertFeatureBuffer.value(pFC.Fields.FindField(m_FldColNum)) = (lCol + 1)
581:                 If Len(m_FldScale) > 0 Then pInsertFeatureBuffer.value(pFC.Fields.FindField(m_FldScale)) = m_dMapScale
582:                 pInsertFeatureCursor.InsertFeature pInsertFeatureBuffer
583:             End If
584:             If pProgress.ProgressBar1.value < pProgress.ProgressBar1.Max Then
585:                 pProgress.ProgressBar1.value = pProgress.ProgressBar1.value + dIncrement
586:             Else
587:                 pProgress.lblInformation.Caption = "Warning: Val > Max (" & pProgress.ProgressBar1.Max & ")"
588:             End If
589:             If ((lRow * lColCount) + lCol) Mod 20 = 0 Then
590:                 DoEvents
591:                 pInsertFeatureCursor.Flush
592:             End If
593:             pProgress.Refresh
594:             If pProgress.Cancelled Then
                Dim vUserChoice
596:                 pProgress.Cancelled = False       ' Reset the form
597:                 vUserChoice = MsgBox("Operation cancelled." _
                    & "  Save the edits made thus far?" & vbCrLf & vbCrLf _
                    & "(Click Cancel to continue processing)", _
                                vbYesNoCancel, "Generate Grids")
601:                 If vUserChoice <> vbCancel Then
602:                     GoTo CancelledGenerateGrids     'Sorry for GoTo usage - in a hurry
603:                 End If
604:             End If
605:         Next
606:     Next
607:     pInsertFeatureCursor.Flush
608:     m_pProgress.Visible = False
    
    ' Stop editing
611:     pWorkspaceEdit.StopEditOperation
612:     pWorkspaceEdit.StopEditing True
    ' ----------------------------------------------------
    
615:     Screen.MousePointer = vbDefault
616:     pMx.ActiveView.Refresh
    
    Exit Sub
    
CancelledGenerateGrids:
621:     m_pProgress.Visible = False
622:     If vUserChoice = vbYes Then
623:         pInsertFeatureCursor.Flush
624:         pWorkspaceEdit.StopEditOperation
625:         pWorkspaceEdit.StopEditing True
626:     Else
627:         pWorkspaceEdit.StopEditOperation
628:         pWorkspaceEdit.StopEditing False
629:     End If
630:     Screen.MousePointer = vbDefault
631:     pMx.ActiveView.Refresh
    Exit Sub
    
634:     Resume
eh:
636:     m_pProgress.Visible = False
637:     Screen.MousePointer = vbDefault
638:     If Not pWorkspaceEdit Is Nothing Then
639:         If pWorkspaceEdit.IsBeingEdited Then
640:             pWorkspaceEdit.StopEditOperation
641:             pWorkspaceEdit.StopEditing False
642:         End If
643:     End If
644:     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
    
654:     Set CreateGridPoly2 = New Polygon
655:     Set pPntColl = CreateGridPoly2
656:     Set pPoint = New esrigeometry.Point
657:     pPoint.PutCoords pStartPoint.X + (lCol * dGridWidth), pStartPoint.Y + (lRow * dGridHeight)
658:     pPntColl.AddPoint pPoint
659:     Set pPoint = New esrigeometry.Point
660:     pPoint.PutCoords pStartPoint.X + (lCol * dGridWidth), pStartPoint.Y + ((lRow + 1) * dGridHeight)
661:     pPntColl.AddPoint pPoint
662:     Set pPoint = New esrigeometry.Point
663:     pPoint.PutCoords pStartPoint.X + ((lCol + 1) * dGridWidth), pStartPoint.Y + ((lRow + 1) * dGridHeight)
664:     pPntColl.AddPoint pPoint
665:     Set pPoint = New esrigeometry.Point
666:     pPoint.PutCoords pStartPoint.X + ((lCol + 1) * dGridWidth), pStartPoint.Y + (lRow * dGridHeight)
667:     pPntColl.AddPoint pPoint
668:     Set pPoint = New esrigeometry.Point
669:     pPoint.PutCoords pStartPoint.X + (lCol * dGridWidth), pStartPoint.Y + (lRow * dGridHeight)
670:     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)
688:     lMultiplierX = 1
689:     dTemp = XGridWidth
690:     While dTemp < 10
691:         dTemp = dTemp * 10
692:         lMultiplierX = lMultiplierX * 10
693:     Wend
694:     lMultiplierY = 1
695:     dTemp = YGridHeight
696:     While dTemp < 10
697:         dTemp = dTemp * 10
698:         lMultiplierY = lMultiplierY * 10
699:     Wend
    
    ' Init
702:     XRange = XEnd - XStart
703:     YRange = YEnd - YStart
    'X ------------------------------------------
705:     If Not (LayerExtent Is Nothing) Then
706:         If XStart < LayerExtent.XMin Then
707:             Err.Raise vbObjectError, "CalculateRowColCounts", _
                "Starting X (" & XStart & ") is outside the valid layer extent (" & LayerExtent.XMin & ")"
709:         ElseIf XEnd > LayerExtent.XMax Then
710:             Err.Raise vbObjectError, "CalculateRowColCounts", _
                "Ending X (" & XStart & ") is outside the valid layer extent (" & LayerExtent.XMax & ")"
712:         ElseIf (XStart + XGridWidth) > LayerExtent.XMax Then
713:             Err.Raise vbObjectError, "CalculateRowColCounts", _
                "Adding a single Grid (width " & XGridWidth & ") would exceed valid X range for layer (" & LayerExtent.XMax & ")"
715:         End If
716:     End If
717:     If XRange < XGridWidth Then
718:         Err.Raise vbObjectError, "CalculateRowColCounts", _
            "Grid width " & XGridWidth & " exceeds range specified (" & XStart & " - " & XEnd & ")"
720:     ElseIf (XStart + XGridWidth) > XEnd Then
721:         Err.Raise vbObjectError, "CalculateRowColCounts", _
            "Adding a single Grid (width " & XGridWidth & ") would exceed specified X range (" & XEnd & ")"
723:     End If
724:     ReturnColCount = (XRange * lMultiplierX) \ (XGridWidth * lMultiplierX)
    'Y ------------------------------------------
726:     If Not (LayerExtent Is Nothing) Then
727:         If YStart < LayerExtent.YMin Then
728:             Err.Raise vbObjectError, "CalculateRowColCounts", _
                "Starting Y (" & YStart & ") is outside the valid layer extent (" & LayerExtent.YMin & ")"
730:         ElseIf YEnd > LayerExtent.YMax Then
731:             Err.Raise vbObjectError, "CalculateRowColCounts", _
                "Ending Y (" & YStart & ") is outside the valid layer extent (" & LayerExtent.YMax & ")"
733:         ElseIf (YStart + YGridHeight) > LayerExtent.YMax Then
734:             Err.Raise vbObjectError, "CalculateRowColCounts", _
                "Adding a single Grid (height " & YGridHeight & ") would exceed valid Y range for layer (" & LayerExtent.YMax & ")"
736:         End If
737:     End If
738:     If YRange < YGridHeight Then
739:         Err.Raise vbObjectError, "CalculateRowColCounts", _
            "Grid height " & YGridHeight & " exceeds range specified (" & YStart & " - " & YEnd & ")"
741:     ElseIf (XStart + XGridWidth) > XEnd Then
742:         Err.Raise vbObjectError, "CalculateRowColCounts", _
            "Adding a single Grid (height " & YGridHeight & ") would exceed specified Y range (" & YEnd & ")"
744:     End If
745:     ReturnRowCount = (YRange * lMultiplierY) \ (YGridHeight * lMultiplierY)
    '--------------------------------------------
    
    Exit Sub
eh:
750:     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
767:     Set pMx = pApp.Document
768:     Set pSR = pMx.FocusMap.SpatialReference
    ' If a Projected coord system
770:     If TypeOf pSR Is IProjectedCoordinateSystem Then
        ' Use meters per unit as the conversion
772:         Set pPCS = pSR
773:         dMetersPerUnit = pPCS.CoordinateUnit.MetersPerUnit
        ' Now convert this into page (ie: paper) units
775:         Set pPage = pMx.PageLayout.Page
776:         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:
783:                 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..."
786:                 CalculatePageToMapRatio = dMetersPerUnit / (1 / 12 * 0.304800609601219)
787:         End Select
    ' Otherwise
789:     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.
795:         Set pExtentEnv = pMx.ActiveView.Extent
796:         dCurrScale = pMx.FocusMap.MapScale
797:         If ((m_EndX - m_StartX) / m_dFrameWidthInPageUnits) > ((m_EndY - m_StartY) / m_dFrameHeightInPageUnits) Then
798:             CalculatePageToMapRatio = m_dFrameWidthInPageUnits / ((m_EndX - m_StartX) / dCurrScale)
799:         Else
800:             CalculatePageToMapRatio = m_dFrameHeightInPageUnits / ((m_EndY - m_StartY) / dCurrScale)
801:         End If
802:     End If
    
    Exit Function
eh:
806:     CalculatePageToMapRatio = 1
807:     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
    
817:     HasFeatures = False
818:     Set pSF = New SpatialFilter
819:     Set pSF.Geometry = pPolygon
820:     pSF.SpatialRel = esriSpatialRelIntersects
821:     For lLoop = 0 To (pMap.LayerCount - 1)
822:         If TypeOf pMap.Layer(lLoop) Is IFeatureLayer Then
823:             Set pFL = pMap.Layer(lLoop)
824:             If pFL.Name <> m_DestFL.Name And IsARequiredLayer(pFL.Name) Then
825:                 pSF.GeometryField = pFL.FeatureClass.shapeFieldName
826:                 Set pFC = pFL.Search(pSF, False)
827:                 Set pF = pFC.NextFeature
828:                 If Not pF Is Nothing Then
829:                     HasFeatures = True
830:                     Exit For
831:                 End If
832:             End If
833:         End If
834:     Next
End Function

Private Function IsARequiredLayer(sLayerName As String) As Boolean
    Dim lLoop As Long
839:     For lLoop = 1 To m_colLayerNamesForData.count
840:         If UCase(m_colLayerNamesForData.Item(lLoop)) = UCase(sLayerName) Then
841:             IsARequiredLayer = True
842:             Exit For
843:         End If
844:     Next
End Function

Private Sub Class_Terminate()
848:     Set m_DestFL = Nothing
849:     Set m_DestFC = Nothing
850:     Set m_pProgress = Nothing
End Sub