sliverrenderer.frm

ArcEngine 这是基于AE组件的源代码

VERSION 5.00
Begin VB.Form frmSliverRenderer 
   Caption         =   "Form1"
   ClientHeight    =   5265
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   7740
   LinkTopic       =   "Form1"
   ScaleHeight     =   5265
   ScaleWidth      =   7740
   StartUpPosition =   3  '窗口缺省
   Begin VB.PictureBox picPreview 
      Height          =   1335
      Left            =   6120
      ScaleHeight     =   1275
      ScaleWidth      =   1515
      TabIndex        =   2
      Top             =   0
      Width           =   1575
   End
   Begin VB.PictureBox picRenderer 
      Appearance      =   0  'Flat
      BackColor       =   &H80000004&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   5055
      Left            =   0
      ScaleHeight     =   5055
      ScaleWidth      =   6135
      TabIndex        =   0
      Top             =   0
      Width           =   6135
      Begin VB.CommandButton cmdCalculate 
         Caption         =   "Calculate Area..."
         Height          =   375
         Left            =   960
         TabIndex        =   11
         Top             =   2040
         Width           =   1935
      End
      Begin VB.TextBox txtDistance 
         Height          =   285
         Left            =   3720
         TabIndex        =   9
         Text            =   "0.00"
         Top             =   1680
         Width           =   855
      End
      Begin VB.CheckBox chkShowAll 
         Alignment       =   1  'Right Justify
         Caption         =   "Draw only sliver polygons when rendering "
         Height          =   495
         Left            =   480
         TabIndex        =   8
         Top             =   3840
         Width           =   3975
      End
      Begin VB.CommandButton cmdFill 
         Caption         =   "Fill Symbol..."
         Height          =   495
         Left            =   3480
         TabIndex        =   5
         Top             =   3240
         Width           =   1575
      End
      Begin VB.CommandButton cmdSymbol 
         Caption         =   "Sliver Symbol..."
         Height          =   495
         Left            =   3480
         TabIndex        =   4
         Top             =   2520
         Width           =   1575
      End
      Begin VB.Label Label3 
         Caption         =   "Minumum area measurement value"
         Height          =   255
         Left            =   120
         TabIndex        =   10
         Top             =   1680
         Width           =   3255
      End
      Begin VB.Label Label4 
         Caption         =   "Change the polygon symbol used"
         Height          =   375
         Left            =   480
         TabIndex        =   7
         Top             =   3240
         Width           =   2895
      End
      Begin VB.Label Label2 
         Caption         =   "Change the sliver symbol used"
         Height          =   255
         Left            =   480
         TabIndex        =   6
         Top             =   2640
         Width           =   2775
      End
      Begin VB.Label Label1 
         Height          =   735
         Left            =   120
         TabIndex        =   3
         Top             =   840
         Width           =   6015
      End
      Begin VB.Label lblTitle 
         Height          =   735
         Left            =   120
         TabIndex        =   1
         Top             =   120
         Width           =   6135
      End
   End
End
Attribute VB_Name = "frmSliverRenderer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit
Private m_pSite As IComPropertyPageSite
Private m_pFillSymbol As IFillSymbol
Private m_pMarkerSymbol As IMarkerSymbol
Private m_bOnlySlivers As Boolean
Private m_dArea As Double
Public pFeatureClass As IFeatureClass
Private m_PageIsDirty As Boolean

Public Sub InitControls(pRend As ISliverPolygonRenderer)
  txtDistance.Text = pRend.SliverArea
  If pRend.OnlyDrawSlivers = True Then
    m_bOnlySlivers = True
    chkShowAll.Value = 1
  Else
    m_bOnlySlivers = False
    chkShowAll.Value = 0
  End If
  Set m_pFillSymbol = pRend.SliverFillSymbol
  Set m_pMarkerSymbol = pRend.SliverSymbol
  
  m_PageIsDirty = False
End Sub

Public Function SetPageSite(ByVal RHS As esriFramework.IComPropertyPageSite)
    Set m_pSite = RHS
End Function

Public Sub InitRenderer(pInRend As ISliverPolygonRenderer)
  pInRend.SliverArea = m_dArea
  pInRend.SliverFillSymbol = m_pFillSymbol
  pInRend.SliverSymbol = m_pMarkerSymbol
  
  If m_bOnlySlivers = True Then
    pInRend.OnlyDrawSlivers = True
  Else
    pInRend.OnlyDrawSlivers = False
  End If
    
  
End Sub

Private Sub chkShowAll_Click()
  'Notify of an update
  If chkShowAll.Value = 1 Then
    m_bOnlySlivers = True
  Else
    m_bOnlySlivers = False
  End If
  
  If Not m_pSite Is Nothing Then m_pSite.PageChanged
  m_PageIsDirty = True
End Sub

Private Sub cmdCalculate_Click()
On Error GoTo eh:
  'Calculate area
  Dim tempFeatureLayer As IGeoFeatureLayer
  
  Set tempFeatureLayer = m_pCurrentLayer
  Set pFeatureClass = tempFeatureLayer.FeatureClass
  If pFeatureClass Is Nothing Then
    MsgBox "FeatureClass is not set!"
    Exit Sub
  End If
  Dim pFc As IFeatureCursor
  Set pFc = pFeatureClass.Search(Nothing, False)
  
  Dim pFeature As iFeature
  Set pFeature = pFc.NextFeature
  
  Dim pArea As IArea, pPoly As IPolygon, dSmallestArea As Double, dLargestArea As Double
  Dim lsOID As Long, llOID As Long
  Set pPoly = pFeature.Shape
  Set pArea = pPoly
  dSmallestArea = pArea.Area
  dLargestArea = pArea.Area
  Do Until pFeature Is Nothing
    Set pPoly = pFeature.Shape
    Set pArea = pPoly
    If pArea.Area < dSmallestArea Then
      dSmallestArea = pArea.Area
      lsOID = pFeature.OID
    End If
    
    If pArea.Area > dLargestArea Then
      dLargestArea = pArea.Area
      llOID = pFeature.OID
    End If
    
    Set pFeature = pFc.NextFeature
  Loop
  frmMDIMap.MapControl.Refresh
  lblTitle.Caption = "Feature " & lsOID & " has the smallest area with a value of " & Round(dSmallestArea, 4) & " units." & _
  Chr(13) & "Feature " & llOID & " has the largest area with a value of " & Round(dLargestArea, 4) & " units."
Exit Sub
eh:
MsgBox "cmdCalculate_Click: " & Err.Description
End Sub

Private Sub cmdFill_Click()
  On Error GoTo eh:
  Dim pFillSym As IFillSymbol
  Set pFillSym = GetSymbol(False)
  If pFillSym Is Nothing Then Exit Sub
  Set m_pFillSymbol = pFillSym
  
  If Not m_pSite Is Nothing Then m_pSite.PageChanged
  m_PageIsDirty = True
  frmMDIMap.MapControl.Refresh
  Exit Sub
eh:
  MsgBox "cmdSymbol_Click: " & Err.Description
End Sub

Private Sub cmdSymbol_Click()
  On Error GoTo eh:
  Dim pMarker As IMarkerSymbol
  Set pMarker = GetSymbol(True)
  Set m_pMarkerSymbol = pMarker
  If pMarker Is Nothing Then Exit Sub 'Not passing any symbol so the renderer has to deal with it
  If Not m_pSite Is Nothing Then m_pSite.PageChanged
  m_PageIsDirty = True
  Exit Sub
eh:
  MsgBox "cmdSymbol_Click: " & Err.Description
End Sub

Private Sub txtDistance_Change()
  If Not IsNumeric(txtDistance) Then
    MsgBox "Numeric values only!", vbExclamation
    txtDistance = "0.0001"
  End If
  
  m_dArea = CDbl(txtDistance.Text)
  If Not m_pSite Is Nothing Then m_pSite.PageChanged
  m_PageIsDirty = True
End Sub

Private Sub txtDistance_LostFocus()
  If Not IsNumeric(txtDistance) Then
    MsgBox "Numeric values only!", vbExclamation
    txtDistance = "0.0001"
  End If
  
  m_dArea = CDbl(txtDistance.Text)
  If Not m_pSite Is Nothing Then m_pSite.PageChanged
  m_PageIsDirty = True

End Sub

Private Function GetSymbol(bIsMarker As Boolean) As ISymbol
On Error GoTo eh:

  Dim pSymbol As ISymbol
  If bIsMarker = True Then
    Set pSymbol = New SimpleMarkerSymbol
  Else
    Set pSymbol = New SimpleFillSymbol
  End If
  Dim pSymbolIdentifier As ISymbolSelector
  Set pSymbolIdentifier = New SymbolSelector
  
  pSymbolIdentifier.AddSymbol pSymbol
  Dim bSelected As Boolean
  bSelected = pSymbolIdentifier.SelectSymbol(0)
  If bSelected = True Then
    Set GetSymbol = pSymbolIdentifier.GetSymbolAt(0)
  Else
    Set GetSymbol = Nothing
  End If
    
  Exit Function
eh:
  MsgBox "GetSymbol: " & Err.Description
  Exit Function
End Function