frmprops.frm

gis地图 --- --- --文字1

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Begin VB.Form frmProps 
   ClientHeight    =   2895
   ClientLeft      =   3060
   ClientTop       =   5760
   ClientWidth     =   10905
   LinkTopic       =   "Form1"
   ScaleHeight     =   2895
   ScaleWidth      =   10905
   Begin VB.Frame frLabel1 
      BorderStyle     =   0  'None
      Height          =   375
      Left            =   990
      TabIndex        =   0
      Top             =   120
      Width           =   5445
      Begin VB.ComboBox cmbLayers 
         Height          =   288
         Left            =   588
         Style           =   2  'Dropdown List
         TabIndex        =   4
         Top             =   0
         Width           =   1695
      End
      Begin VB.ComboBox cmbLabelField 
         Height          =   315
         Left            =   2775
         Style           =   2  'Dropdown List
         TabIndex        =   2
         Top             =   -15
         Width           =   1860
      End
      Begin VB.CheckBox chkOn 
         Caption         =   "On"
         Height          =   255
         Left            =   4812
         TabIndex        =   1
         Top             =   15
         Width           =   540
      End
      Begin VB.Label Label1 
         Caption         =   "Layer:"
         Height          =   315
         Left            =   90
         TabIndex        =   5
         Top             =   45
         Width           =   495
      End
      Begin VB.Label Label2 
         Caption         =   "Field:"
         Height          =   255
         Left            =   2310
         TabIndex        =   3
         Top             =   60
         Width           =   495
      End
   End
   Begin MSComDlg.CommonDialog CD1 
      Left            =   7800
      Top             =   0
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
End
Attribute VB_Name = "frmProps"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

' 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
Public m_bAmLoading As Boolean


Private Sub chkOn_Click()
Dim p As LabelGroup

On Error GoTo SetLayerLabelVis_ERR

    If m_bAmLoading Then Exit Sub
    
'   get the current layer:
    Set p = GetCurrentLabelGroup()
    
'   toggle visibility:
    p.Visible = (frmProps.chkOn.Value = 1)

    '   todo:
'   this will currently recalculate all labels every time visibility is toggled:
    If p.Visible And Not p.CanAddLabels Then
        ReinitLayerLabels
    Else
'   need to reset all labels in collection:
        If p.ExtentNeedsInit Then
            g_pLabelEngine.UpdateExtentScale p, -1, -1, -1, True
            p.ExtentNeedsInit = False
        End If
        p.UpdateAll
    End If

    g_pDoc.Scene.SceneGraph.RefreshViewers
        

    Exit Sub
    
SetLayerLabelVis_ERR:
    MsgBox "SetLayerLabelVisibility_error: " & Err.Description
End Sub


Private Sub cmbLabelField_Click()
On Error GoTo SetLabelField_ERR
Dim bNeeds As Boolean
    
'   need to reinit if the label item has changed:
    bNeeds = Not (UCase(g_pCurrentGroup.LabelItem) = UCase(frmProps.cmbLabelField.Text))
    
'   set it:
    g_pCurrentGroup.LabelItem = frmProps.cmbLabelField.Text

    Me.MousePointer = vbHourglass

'   do the renit and refresh:
    If g_pCurrentGroup.Visible Then
        If bNeeds Then
            ReinitLayerLabels
            RefreshViewers
        End If
    End If
    Me.MousePointer = vbDefault

    Exit Sub
    
SetLabelField_ERR:
    Me.MousePointer = vbDefault
    Debug.Print "SetLabelField_ERR: " & Err.Description
End Sub


Private Sub cmbLayers_Click()
Dim i As Integer
Dim sName As String
Dim pFields As Collection
Dim pLayer As IFeatureLayer

On Error GoTo ChooseLayer_ERR
    If g_bLoading Then Exit Sub
    
    m_bAmLoading = True
    
    sName = frmProps.cmbLayers.Text
    If Len(sName) < 1 Then Exit Sub
    
    Set pLayer = GetLayer(sName)
    
    If 0 = 0 Then ' make sure the toolbar is updated- this was added
                  ' because there must have been some issue at some point...
      If g_pLabelEngine.LabelGroups.Count < 2 And g_pDoc.Scene.LayerCount > 0 Then
        modLabel3DToolbar.InitLayerLabelList True
        'g_bLoading = True
        frmProps.cmbLayers.Text = sName
        'g_bLoading = False
      End If
    End If

'   load the ITEMS cmb with usable field names:
    If Not pLayer Is Nothing Then
        Set pFields = GetUsableFieldNames(pLayer)
        
        frmProps.cmbLabelField.Clear
        For i = 0 To pFields.Count - 1
            frmProps.cmbLabelField.AddItem pFields.Item(i + 1)
        Next
    '   call this to ensure the pointer to the correct label group:
        GetCurrentLabelGroup
    Else
        'g_pApp.StatusBar.Message(0) = "Using graphics layer for labeling..."
    '   else, no need to populate the FIELD list:
        frmProps.cmbLabelField.Clear
        GetCurrentLabelGroup
        frmProps.cmbLabelField.AddItem g_pCurrentGroup.LabelItem
        frmProps.cmbLabelField.ListIndex = 0
    End If
    
'   set the proper LABEL item in the CMB:
    If Not g_pCurrentGroup Is Nothing Then

        If Len(g_pCurrentGroup.LabelItem) > 0 Then
            frmProps.cmbLabelField.Text = g_pCurrentGroup.LabelItem
        Else
            
        End If
    End If


    UpdateSlider

    m_bAmLoading = False
    
    Exit Sub
    
ChooseLayer_ERR:
    'g_pApp.StatusBar.Message(0) = g_pApp.StatusBar.Message(0) & " - " & "Label3D Debug: ChooseLayer_ERR: " & Err.Description & "-" & g_pCurrentGroup.LabelItem
    m_bAmLoading = False
    g_bLoading = False
End Sub



Public Function GetCurrentLabelGroup() As LabelGroup
'return the layerlabel class in the global collection which
'represents the one we are currently working on:

Dim i As Integer
Dim p As LabelGroup
Dim sName As String
Dim sItem As String

On Error GoTo GetCurrentLabelGroup_ERR
'get the name and item:
    sName = Me.cmbLayers.Text
    sItem = Me.cmbLabelField.Text

'make sure there is an item:
    If Len(sItem) < 1 Then
        sItem = Me.cmbLabelField.List(0)
    End If

'see if this item is in the collection yet:
    For Each p In g_pLabelEngine.LabelGroups
        If UCase(p.Name) = UCase(sName) Then
            Set g_pCurrentGroup = p
            Exit For
        End If
    Next

    'if it isn't, use the default:
    If g_pCurrentGroup Is Nothing Then
        Set g_pCurrentGroup = g_pLabelEngine.LabelGroup(0)
    End If

'now return it:
    Set GetCurrentLabelGroup = g_pCurrentGroup

    Exit Function

GetCurrentLabelGroup_ERR:
    MsgBox "GetCurrentLabelGroup_ERR: " & Err.Description
End Function
'
Public Sub UpdateSlider()
On Error GoTo UpdateSlider_ERR
    
'   visibility:
    If g_pCurrentGroup Is Nothing Then Exit Sub
    If g_pCurrentGroup.Visible Then
        frmProps.chkOn.Value = 1
    Else
        frmProps.chkOn.Value = 0
    End If
    
    
    Exit Sub
    
UpdateSlider_ERR:
    MsgBox "UpdateSlider_ERR: " & Err.Description
End Sub



Public Sub RefreshMe()
On Error Resume Next

    Me.Refresh
    Me.frLabel1.Refresh
    Me.cmbLabelField.Refresh
    Me.cmbLayers.Refresh
    Me.chkOn.Refresh

End Sub