clscreatestripmap.cls

使用VB和ArcObject结合的程序

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsCreateStripMap"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True

' Copyright 1995-2004 ESRI

' All rights reserved under the copyright laws of the United States.

' You may freely redistribute and use this sample code, with or without modification.

' Disclaimer: THE SAMPLE CODE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED 
' WARRANTIES, INCLUDING THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 
' FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ESRI OR 
' CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, 
' OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 
' SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
' INTERRUPTION) SUSTAINED BY YOU OR A THIRD PARTY, HOWEVER CAUSED AND ON ANY 
' THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ARISING IN ANY 
' WAY OUT OF THE USE OF THIS SAMPLE CODE, EVEN IF ADVISED OF THE POSSIBILITY OF 
' SUCH DAMAGE.

' For additional information contact: Environmental Systems Research Institute, Inc.

' Attn: Contracts Dept.

' 380 New York Street

' Redlands, California, U.S.A. 92373 

' Email: [e-mail]

Option Explicit

'----------------------------------------------
' Properties
' - DestinationFeatureClass (IFeatureClass, r/w)
' - MapScale (Double, r/w)
' - FrameWidthInPageUnits (Double, r/w)
' - FrameHeightInPageUnits (Double, r/w)
' - StripMapRoute (IPolyline, r/w)
'----------------------------------------------
' Methods
' - GenerateGrids(pApp as IApplication)
'    : Generates the grids using the values added.
' - RunStandardGUI(pApp as IApplication)
'    : To open the form without having the button
'      added to ArcMap's GUI.
'----------------------------------------------
' Local Global Declarations
Private m_DestFL As IFeatureLayer
Private m_DestFC As IFeatureClass
Private m_Polyline As IPolyline
Private m_dMapScale As Double
Private m_dFrameWidthInPageUnits As Double
Private m_dFrameHeightInPageUnits As Double
Private m_FldStripName As String
Private m_FldNumInSeries As String
Private m_FldMapAngle As String
Private m_FldScale As String
Private m_RemoveGrids As Boolean
Private m_Flip As Boolean
Private m_GridWidth As Double
Private m_GridHeight As Double
Private m_StripMapName As String
Private m_pProgress As IModelessFrame
'----------------------------------------------
' API call to keep form top most
Private Const GWL_HWNDPARENT = -8
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
  (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Public Property Set DestinationFeatureLayer(pFL As IFeatureLayer)
42:     If pFL.FeatureClass.ShapeType = esriGeometryPolygon Then
43:         Set m_DestFL = pFL
44:         Set m_DestFC = pFL.FeatureClass
45:     Else
46:         Err.Raise vbObjectError, "MapGridManager_Set_DestinationFeatureLayer", _
            "Not a polygon feature layer"
48:     End If
End Property

Public Property Get DestinationFeatureLayer() As IFeatureLayer
52:     Set DestinationFeatureLayer = m_DestFL
End Property

Public Property Set StripMapRoute(RoutePolyline As IPolyline)
56:     Set m_Polyline = RoutePolyline
End Property

Public Property Get StripMapRoute() As IPolyline
60:     Set StripMapRoute = m_Polyline
End Property

Public Property Let FrameWidthInPageUnits(dWidth As Double)
64:     m_dFrameWidthInPageUnits = dWidth
End Property

Public Property Get FrameWidthInPageUnits() As Double
68:     FrameWidthInPageUnits = m_dFrameWidthInPageUnits
End Property

Public Property Let FrameHeightInPageUnits(dHeight As Double)
72:     m_dFrameHeightInPageUnits = dHeight
End Property

Public Property Get FrameHeightInPageUnits() As Double
76:     FrameHeightInPageUnits = m_dFrameHeightInPageUnits
End Property

Public Property Let MapScale(dScale As Double)
80:     m_dMapScale = dScale
End Property

Public Property Get MapScale() As Double
84:     MapScale = m_dMapScale
End Property

Public Property Let StripMapName(MapName As String)
88:     m_StripMapName = MapName
End Property

Public Property Get StripMapName() As String
92:     StripMapName = m_StripMapName
End Property


Public Property Let FieldNameStripMapName(FieldName As String)
97:     m_FldStripName = FieldName
End Property

Public Property Get FieldNameStripMapName() As String
101:     FieldNameStripMapName = m_FldStripName
End Property

Public Property Let FieldNameNumberInSeries(FieldName As String)
105:     m_FldNumInSeries = FieldName
End Property

Public Property Get FieldNameNumberInSeries() As String
109:     FieldNameNumberInSeries = m_FldNumInSeries
End Property

Public Property Let FieldNameMapAngle(FieldName As String)
113:     m_FldMapAngle = FieldName
End Property

Public Property Get FieldNameMapAngle() As String
117:     FieldNameMapAngle = m_FldMapAngle
End Property

Public Property Let FieldNameScale(FieldName As String)
121:     m_FldScale = FieldName
End Property

Public Property Get FieldNameScale() As String
125:     FieldNameScale = m_FldScale
End Property

Public Property Let RemoveCurrentGrids(RemoveGrids As Boolean)
129:     m_RemoveGrids = RemoveGrids
End Property

Public Property Get RemoveCurrentGrids() As Boolean
133:     RemoveCurrentGrids = m_RemoveGrids
End Property

Public Property Let FlipPolyline(Flip As Boolean)
137:     m_Flip = Flip
End Property

Public Property Get FlipPolyline() As Boolean
141:     FlipPolyline = m_Flip
End Property

Private Sub Class_Initialize()
    ' Set the defaults
146:     Set m_pProgress = New ModelessFrame
End Sub

Public Sub RunStandardGUI(pApp As IApplication)
150:     Set frmSMapSettings.m_Application = pApp
151:     frmSMapSettings.Tickle
152:     SetWindowLong frmSMapSettings.hwnd, GWL_HWNDPARENT, pApp.hwnd
153:     frmSMapSettings.Show vbModeless
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
    Dim dEndX As Double, dEndY As Double
    Dim dStartX As Double, dStartY As Double
    
    On Error GoTo eh
    
    ' Init
172:     Set pMx = pApp.Document
173:     Set pSR = pMx.FocusMap.SpatialReference
    ' If a Projected coord system
175:     If TypeOf pSR Is IProjectedCoordinateSystem Then
        ' Use meters per unit as the conversion
177:         Set pPCS = pSR
178:         dMetersPerUnit = pPCS.CoordinateUnit.MetersPerUnit
        ' Now convert this into page (ie: paper) units
180:         Set pPage = pMx.PageLayout.Page
181:         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:
188:                 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..."
191:                 CalculatePageToMapRatio = dMetersPerUnit / (1 / 12 * 0.304800609601219)
192:         End Select
    ' Otherwise
194:     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.
200:         Set pExtentEnv = pMx.ActiveView.Extent
201:         dStartX = pExtentEnv.XMin
202:         dStartY = pExtentEnv.YMin
203:         dEndX = pExtentEnv.XMax
204:         dEndY = pExtentEnv.YMax
        
206:         dCurrScale = pMx.FocusMap.MapScale
207:         If ((dEndX - dStartX) / m_dFrameWidthInPageUnits) > ((dEndY - dStartY) / m_dFrameHeightInPageUnits) Then
208:             CalculatePageToMapRatio = m_dFrameWidthInPageUnits / ((dEndX - dStartX) / dCurrScale)
209:         Else
210:             CalculatePageToMapRatio = m_dFrameHeightInPageUnits / ((dEndY - dStartY) / dCurrScale)
211:         End If
212:     End If
    
    Exit Function
eh:
216:     CalculatePageToMapRatio = 1
217:     MsgBox "Error in CalculatePageToMapRatio" & vbCrLf & Err.Description
End Function

Private Sub Class_Terminate()
221:     Set m_DestFL = Nothing
222:     Set m_DestFC = Nothing
223:     Set m_pProgress = New ModelessFrame
End Sub

Public Sub GenerateStripMap(Application As IApplication)
    Dim pMx As IMxDocument
    Dim pPolyline As IPolyline
    Dim pCenterPoint As IPoint
    Dim pCirclePoly As IPolygon
    Dim pGridPoly As IPolygon
    Dim pCircularArc As IConstructCircularArc
    Dim pSegmentCollection As ISegmentCollection
    Dim pTopoOpt As ITopologicalOperator
    Dim pGeoCol As IGeometryCollection
    Dim pIntersectPoint As IPoint
    Dim pArc As ICurve
    Dim pIntersectPointPrev As IPoint
    Dim bFirstRun As Boolean
    Dim lLoop2 As Long
    Dim dHighest As Double, lHighestRef As Long
    Dim dHighestPrev As Double
    Dim pCurve As ICurve, pLine As ILine
    Dim pPLine As IPolyline
    Dim bContinue As Boolean
    Dim dGridAngle As Double
    Dim bReducedRadius As Boolean
    Dim lCounter As Long
    Dim dHighestThisTurn As Double
    
    Dim pWorkspaceEdit As IWorkspaceEdit
    Dim lLoop As Long
    Dim pFeatDataset As IFeatureDataset
    Dim pFeature As IFeature
    Dim pFeatCur As IFeatureCursor
    Dim pSourcePolygon As IPolygon
    'Dim pGridPolygon As IPolygon
    Dim pPointColl As IPointCollection
    Dim pStartingCoord As IPoint
    Dim pPoint As IPoint
    Dim lRow As Long
    Dim lCol As Long
    Dim lRowCount As Long
    Dim lColCount As Long
    Dim pClone As IClone
    Dim dGridSizeW As Double
    Dim dGridSizeH As Double
    Dim pTransform As ITransform2D
    Dim bOKToAdd As Boolean
    Dim iStringLengthRow As Integer
    Dim iStringLengthCol As Integer
    Dim pDataset As IDataset
    Dim lBase As Long
    Dim dDataFrameWidth As Double