modlabel3dtoolbar.bas

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

Attribute VB_Name = "modLabel3DToolbar"

' 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]


'   main module for LABEL3D Toolbar

Option Explicit

Dim m_bDontUpdateDefaults As Boolean
Global g_pLabelEngine As Label3DEngine  '   main label engine class
Global g_bDuringCommand As Boolean      '   flag to ignore certain events
Global g_bLoading As Boolean            '   ""          ""
Global m_pLblEvents As LblEvents        '   handler for scene events where we add labels to engine
Global g_pDoc As ISxDocument            '   global doc reference

Global g_pApp As IApplication


Global g_pCurrentGroup As LabelGroup    '   current label group loaded in tool
Global g_pCurrentLBL As IDDDText        '   current label in tool
                                        '   for getting current cursor position:
Type POINT_TYPE
  X As Long
  Y As Long
End Type
Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINT_TYPE) As Long

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
         "GetOpenFileNameA" (pOPENFILENAME As OPENFILENAME) As Long
         
Private Type OPENFILENAME
  lStructSize As Long
  hwndOwner As Long
  hInstance As Long
  lpstrFilter As String
  lpstrCustomFilter As String
  nMaxCustFilter As Long
  nFilterIndex As Long
  lpstrFile As String
  nMaxFile As Long
  lpstrFileTitle As String
  nMaxFileTitle As Long
  lpstrInitialDir As String
  lpstrTitle As String
  FLAGS As Long
  nFileOffset As Integer
  nFileExtension As Integer
  lpstrDefExt As String
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
End Type

Const OFN_ALLOWMULTISELECT = &H200
'Allow the user to select multiple files (Open File dialog box only).
Const OFN_CREATEPROMPT = &H2000
'Prompt if a non-existing file is chosen.
Const OFN_ENABLEHOOK = &H20
'Use the function specified by lpfnHook to process the dialog box's messages.
Const OFN_ENABLETEMPLATE = &H40
'Use the dialog box template specifed by hInstance and lpTemplateName.
Const OFN_ENABLETEMPLATEHANDLE = &H80
'Use the preloaded dialog box template specified by hInstance.
Const OFN_EXTENSIONDIFFERENT = &H400
'The function sets this flag if the user selects a file with an extension different than the one specified by lpstrDefExt.
Const OFN_FILEMUSTEXIST = &H1000
'Only allow the selection of existing files.
Const OFN_HIDEREADONLY = &H4
'Hide the Open As Read Only check box (Open File dialog box only).
Const OFN_NOCHANGEDIR = &H8
'Don 't change Windows's current directory to match the one chosen in the dialog box.
Const OFN_NODEREFERENCELINKS = &H100000
'If a shortcut file (.lnk or .pif) is chosen, return the shortcut file itself instead of the file or directory it points to.
Const OFN_NONETWORKBUTTON = &H20000
'Hide and disable the Network button in the dialog box.
Const OFN_NOREADONLYRETURN = &H8000
'The function sets this flag if the selected file is not read-only (Open File dialog box only).
Const OFN_NOVALIDATE = &H100
'Don 't check the filename for invalid characters.
Const OFN_OVERWRITEPROMPT = &H2
'Prompt the user if the chosen file already exists (Save File dialog box only).
Const OFN_PATHMUSTEXIST = &H800

Const OFN_READONLY = &H1

Const OFN_SHAREAWARE = &H4000
Const OFN_SHOWHELP = &H10


Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOPENFILENAME As OPENFILENAME) As Long

'
'   accept a layername or index and return the corresponding ILayer
'
Public Function GetLayer(sLayer) As ILayer
  Dim pSxDoc As ISxDocument
  Dim pTOCs As ISxContentsView
  Dim pTOC  As IContentsView
  Dim i As Integer
  Dim pLayers As IEnumLayer
  Dim pLayer As ILayer
  Dim pGroupLayer As ICompositeLayer
  Dim pLayer2 As ILayer
  
  On Error GoTo GetLayer_Err
  
  If IsNumeric(sLayer) Then
  '   if numeric index, this is easy:
    If TypeOf g_pApp.Document Is ISxDocument Then
      Set pSxDoc = g_pApp.Document
      Set GetLayer = pSxDoc.Scene.Layer(sLayer)
    End If
  Else
  '   iterate through document layers looking for a name match:
    If TypeOf g_pApp.Document Is ISxDocument Then
      
      Set pSxDoc = g_pApp.Document
      Set pLayers = pSxDoc.Scene.Layers

      Set pLayer = pLayers.Next
      Do While Not pLayer Is Nothing
        
        If TypeOf pLayer Is ICompositeLayer Then
          
          Set pGroupLayer = pLayer
          For i = 0 To pGroupLayer.Count - 1
            Set pLayer2 = pGroupLayer.Layer(i)
            If UCase(sLayer) = UCase(pLayer2.Name) Then
              Set GetLayer = pLayer2
              Exit Function
            End If
          Next
          
        Else
        
          If UCase(sLayer) = UCase(pLayer.Name) Then
            Set GetLayer = pLayer
            Exit Function
          End If
        
        End If
        
        Set pLayer = pLayers.Next
      Loop
      
    End If
  End If
  Exit Function
  
GetLayer_Err:

End Function

Public Sub HideUnusedForms()
On Error Resume Next
    frmSlider.Hide
    
End Sub



Public Sub ResetDocStuff()
    
    g_bLoading = True
'   init the label engine
    Set g_pLabelEngine = New Label3DEngine
    g_pLabelEngine.Init g_pDoc.Scene

'   add the default graphics layer label group to the interface:
    frmProps.cmbLayers.Clear
    frmProps.cmbLabelField.Clear
    g_bLoading = False
    
    AddToFormLayerList g_pLabelEngine.LabelGroup(0)
    UpdateGroupLayersExtent

End Sub

Public Sub UpdateLabels(pLay As LabelGroup, Optional sForWhat As String, Optional bMessageOnly As Boolean, Optional sMessage As String, Optional bNoVisibility As Boolean)

Dim n As Double
Dim pDDD As IDDDText
Dim pPt As IPoint
Dim X As Double
Dim Y As Double
Dim z As Double
Dim xRot As Double, yRot As Double, zRot As Double


On Error GoTo UpdateLabels_ERR

'   for each label in the lablegroup, set the properties from the owner group:
    For Each pDDD In pLay.Labels
        With pDDD
            
            If bMessageOnly Then
                .Message = sMessage
            ElseIf Len(Trim(sForWhat)) > 1 Then
                Select Case UCase(sForWhat)
                
                    Case "FONT SIZE", "FONT"
                        .FontSize = pLay.FontSize
                        .FontName = pLay.FontName
                        Set .Color = pLay.FontColor
                        
                    Case "X ROTATION"
                        .GetAxisRotation xRot, yRot, zRot
                        .SetAxisRotation pLay.XRotation, yRot, zRot
                    Case "Y ROTATION"
                        .GetAxisRotation xRot, yRot, zRot
                        .SetAxisRotation xRot, pLay.YRotation, zRot
                    Case "Z ROTATION"
                        .GetAxisRotation xRot, yRot, zRot
                        .SetAxisRotation xRot, yRot, pLay.ZRotation

                    Case "X OFFSET", "Y OFFSET", "Z OFFSET"
                        Set pPt = New Point
                        pPt.PutCoords .Origin.X + pLay.m_nXOff, .Origin.Y + pLay.m_nYOff
                        pPt.z = .Origin.z + pLay.m_nZOff
                        Set .Origin = pPt
                        
                    Case "BILLBOARDING"
                        pDDD.AutoAdjust = pLay.Billboarding
                End Select
            End If
            
        
            If Not bNoVisibility Then
                .Enabled = pLay.Visible
            End If
        End With
        
    Next
    
    pLay.m_nXOff = 0
    pLay.m_nYOff = 0
    pLay.m_nZOff = 0
    

    RefreshViewers

    Exit Sub
    
UpdateLabels_ERR:
    MsgBox "UpdateLabels_ERR: " & Err.Description
    Debug.Print "UpdateLabels_ERR: " & Err.Description
End Sub


Public Sub UpdateBillBoarding()


    UpdateLabels g_pCurrentGroup

     
End Sub
Public Sub InitLayerLabelList(Optional bClearFirst As Boolean)
Dim pLayer As ILayer
Dim pFLayer As IFeatureLayer
Dim pLayers As IEnumLayer
Dim pclsLayers As LabelGroup
Dim pFieldNames As Collection
Dim sItem As String
Dim i As Integer
Dim bExists As Boolean

On Error GoTo InitLayerLabelList_ERR

'   get all layers in scene:
    If g_pDoc.Scene.LayerCount > 0 Then
        Set pLayers = g_pDoc.Scene.Layers()
        Set pLayer = pLayers.Next
    End If

If bClearFirst Then
    g_bLoading = True
    frmProps.cmbLayers.Clear
    frmProps.cmbLayers.AddItem "<graphics layer>"
    frmProps.cmbLayers.ListIndex = 0
    g_bLoading = False
End If

'   for each feature layer, call the AddLayerToLabelListRouteine which will
'   get first usable field name, create new layerlabel class, add to collection:
    Do While Not pLayer Is Nothing
        If TypeOf pLayer Is IFeatureLayer Then
            Set pFLayer = pLayer
            AddLayerToLabelList pFLayer
        Else
            Debug.Print pLayer.Name & " is not an ifeaturelayer..."
        End If
        Set pLayer = pLayers.Next
    Loop

    UpdateGroupLayersExtent
    


    Exit Sub
    
InitLayerLabelList_ERR:
    'MsgBox "InitLayerLabelList_ERR: " & Err.Description

End Sub

'   main tool setup:
'
Public Sub Init3DLabelTools()
On Error GoTo Init3DLabelTools_ERR

    Set m_pLblEvents = New LblEvents      '  scene graph event handler
    Set g_pDoc = g_pApp.Document        '  global doc reference
    Set m_pLblEvents.m_pSxDoc = g_pDoc       '  pass to event handler
    Set m_pLblEvents.m_pScene = g_pDoc.Scene '  pass to event handler

'   init the label engine
    Set g_pLabelEngine = New Label3DEngine
    g_pLabelEngine.Init g_pDoc.Scene

'   add the default graphics layer label group to the interface:
    frmProps.cmbLayers.Clear
    frmProps.cmbLabelField.Clear
    AddToFormLayerList g_pLabelEngine.LabelGroup(0)
    UpdateGroupLayersExtent
    
'   refresh the main form:
    frmProps.RefreshMe

    Exit Sub
    
Init3DLabelTools_ERR:
    Debug.Print "Init3DLabelTools_ERR: " & Err.Description
    Resume Next
    
End Sub
Public Sub DoInit(ByVal hook As Object)
On Error Resume Next

    
  If (g_pApp Is Nothing) Then
    Set g_pApp = hook
    Init3DLabelTools
    InitLayerLabelList True
  Else
    'InitLayerLabelList
  End If

End Sub
Public Function GetUsableFieldNames(pLayer As IFeatureLayer) As Collection
Dim pColl As New Collection
Dim pFields As IFields
Dim i As Integer
    
On Error GoTo GetUsableFieldNames_ERR
'esriFieldTypeSmallInteger 0 Integer.
'esriFieldTypeInteger 1 Long Integer.
'esriFieldTypeSingle 2 Single-precision floating-point number.
'esriFieldTypeDouble 3 Double-precision floating-point number.
'esriFieldTypeString 4 Character string.
'esriFieldTypeDate 5 Date.

    Set pColl = New Collection
    Set pFields = pLayer.FeatureClass.Fields
    For i = 0 To pFields.FieldCount - 1
        If pFields.Field(i).Type < 5 Then
            pColl.Add pFields.Field(i).Name
        End If
    Next
    
    Set GetUsableFieldNames = pColl
        
    Exit Function
    
GetUsableFieldNames_ERR:
    Debug.Assert 0
    Debug.Print "GetUsableFieldNames_ERR: " & Err.Description
    
End Function