modlabel3dtoolbar.bas

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

On Error GoTo ResetToDefaults_ERR

    Set pFLayer = GetLayer(g_pCurrentGroup.LayerName)

    If Not pFLayer Is Nothing Then

        xD = pFLayer.AreaOfInterest.XMax - pFLayer.AreaOfInterest.XMin
        yD = pFLayer.AreaOfInterest.YMax - pFLayer.AreaOfInterest.YMin
        
    '   this should be synched to whatever we inited with:
        nXScale = xD / 20
        nYScale = yD / 20 'nXScale
        nZScale = nXScale * 0.2
    
        g_pLabelEngine.InitFeatureLayerLabels pFLayer, Nothing, p.LabelItem, False, nFont, , , , , , nXScale, nYScale, nZScale
    
    Else
    

    End If
    
    RefreshViewers
        
    Exit Sub
    
ResetToDefaults_ERR:
    Debug.Assert 0
    Debug.Print "ResetToDefaults_ERR: " & Err.Description
    
End Sub

Public Sub AddLabelToCurrentLayer(XScreen As Long, YScreen As Long)
    
Dim pLocation As IPoint
Dim sMSG As String

On Error GoTo AddLabelToCurrentLayer_ERR
    
'   get label origin:
    Set pLocation = XYToPoint2(g_pApp, XScreen, YScreen, esriScenePickAll)
    If pLocation Is Nothing Then
        Exit Sub
    End If
        
'   get message:
    sMSG = InputBox("message?")
    If Len(sMSG) < 1 Then Exit Sub
    
'   add using current label group name as index:
    Dim pGroup As LabelGroup
    Set pGroup = frmProps.GetCurrentLabelGroup()
    g_pLabelEngine.AddLabelDirect pLocation, sMSG, pGroup.Name, , , , , , , , , pGroup.m_nXScale, pGroup.m_nYScale, pGroup.m_nZScale
    
'   refresh the viewers:
    RefreshViewers
        
    Exit Sub
    
AddLabelToCurrentLayer_ERR:
    Debug.Print "AddLabelToCurrentLayer_ERR: " & Err.Description
End Sub

'
'   using the application and screen XY passed in, return an IPoint interface of the point
'
Public Function XYToPoint2(pApp As IApplication, X As Long, Y As Long, nMode As esriScenePickMode, Optional pOutLayer As ILayer, Optional pOutFeature As IFeature) As IPoint

On Error GoTo XYToPoint2_ERR

    If TypeOf pApp Is ISxApplication Then
        Dim pSxDoc As ISxDocument
        Set pSxDoc = pApp.Document
        Dim pSG As ISceneGraph
        Set pSG = pSxDoc.Scene.SceneGraph
        Dim pViewer As ISceneViewer
        Set pViewer = pSG.ActiveViewer
        Dim pOwner As stdole.IUnknown
        Dim pObject As stdole.IUnknown

        pSG.Locate pViewer, X, Y, nMode, True, XYToPoint2, pOwner, pObject

    '   optionally return the feature found:
        If Not IsMissing(pOutFeature) And Not pOutFeature Is Nothing Then
            If Not pObject Is Nothing Then
                If TypeOf pObject Is IFeature Then
                    Set pOutFeature = pObject
                End If
            End If
        End If
    
    '   optionally return the layer found:
        If Not IsMissing(pOutLayer) And Not pOutLayer Is Nothing Then
            If Not pOwner Is Nothing Then
                If TypeOf pOwner Is ILayer Then
                    Set pOutLayer = pOwner
                End If
            End If
        End If
        
    '   delete unused objects:
        Set pOwner = Nothing
        Set pObject = Nothing
  
    End If
    
    Exit Function
    
XYToPoint2_ERR:
    Debug.Print "XYToPoint2_ERR: " & Err.Description
    Resume Next
    
End Function

Public Sub UpdateGroupLayersExtent()
'   for label groups that don't derive extentscale (used for default sizes, etc)
'   update the extent scale based on the scene extent

    On Error GoTo UpdateGroupLayersExtent_ERR
    
    Dim xD As Double, yD As Double, zD As Double
    Dim xDD As Double, yDD As Double, zDD As Double
    
    Dim xOffMin As Double, yOffMin As Double, xOffMax As Double, yOffMax As Double

'   validate that we can need to be here:
    If g_pDoc Is Nothing Then Exit Sub
    If g_pDoc.Scene Is Nothing Then Exit Sub
    If Not g_pDoc.Scene.Extent.IsEmpty Then
    
    '   look at the delta of x and y's:
        If Not g_pDoc.Scene.Extent Is Nothing Then
            xD = g_pDoc.Scene.Extent.XMax - g_pDoc.Scene.Extent.XMin
            yD = g_pDoc.Scene.Extent.YMax - g_pDoc.Scene.Extent.YMin
        

            zD = g_pDoc.Scene.Extent.ZMax - g_pDoc.Scene.Extent.ZMin


        Else

        End If
    Else

        Exit Sub
    End If

'
'   for each groups in the label group, if it can add labels, set its
'   default extentscale from these numbers:
    g_pLabelEngine.UpdateExtentScale g_pLabelEngine.LabelGroup(0), xD, yD, zD, True



    
    Exit Sub
    
UpdateGroupLayersExtent_ERR:
    Debug.Assert 0
    Debug.Print "UpdateGroupLayersExtent_ERR: " & Err.Description
    Resume Next
    
End Sub

Public Sub CleanupDocStuff()


End Sub

Public Sub EditLabelFromScreenCoords(X As Double, Y As Double, bAddToSelected As Boolean)
Dim pLBL As IDDDText
Dim col As Collection
Dim pLocation As IPoint
Dim n As Integer

On Error GoTo EditLabelFromScreenCoords_ERR

'   get location passed in:
    Set pLocation = New Point
    pLocation.X = X
    pLocation.Y = Y
    
    If g_pDoc Is Nothing Then Exit Sub
    If g_pDoc.Scene.SceneGraph.IsEmpty Then Exit Sub
    
    
    Dim colNames As Collection
    Set colNames = New Collection
'   only select from current group:
    colNames.Add frmProps.GetCurrentLabelGroup().Name
    
'   get collection of labels at this location:
    Set col = g_pLabelEngine.SelectLabelsFromPoint(pLocation, colNames)
    
    If col Is Nothing Then Exit Sub
    If col.Count < 1 Then Exit Sub

'   select the label from dialog if multiple:
    If col.Count > 1 Then
        Set pLBL = frmListChoose.RunMe(col)
    Else
'   else use the only one returned:
        Set pLBL = col.Item(1)
    End If

    If pLBL Is Nothing Then Exit Sub
    
    Dim w As Long, w1 As Long
    GetCurPos w, w1, True
    
    w = w - (w * 0.1)
'   run the edit dialog:
    frmSlider.RunMe pLBL, Nothing, "ALL", w, w1, True, "LABEL: '" & pLBL.Message & "'"
    
    Exit Sub
    
EditLabelFromScreenCoords_ERR:
    Debug.Assert 0
    MsgBox "EditLabelFromScreenCoords_ERR: " & Err.Description & " ;" & n
    Debug.Print "EditLabelFromScreenCoords_ERR: " & Err.Description
    Resume Next
    
    
Exit Sub


End Sub

Public Function GetLabelFile(Optional bSaveAs As Boolean) As String
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
Dim s As String
Dim sInitFile As String
Dim sInitDir As String
Dim sFilter As String

On Error GoTo GetLabelFile_ERR

'   create the filter:
    sFilter = "Label Files (*.lbl)" & Chr(0) & "*.lbl"
    sFilter = sFilter & Chr(0) & "All File Types (*.*)" & Chr(0) & "*.*"
    
    sInitDir = app.Path
    
    OpenFile.lStructSize = Len(OpenFile)
    OpenFile.hwndOwner = CLng(frmProps.hWnd)
    OpenFile.hInstance = app.hInstance
    OpenFile.lpstrFilter = sFilter
    OpenFile.nFilterIndex = 1
    OpenFile.lpstrFile = String(257, 0)
    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
    OpenFile.lpstrFileTitle = OpenFile.lpstrFile
    OpenFile.nMaxFileTitle = OpenFile.nMaxFile
    If Len(sInitDir) > 1 Then
        OpenFile.lpstrInitialDir = sInitDir
    Else
        OpenFile.lpstrInitialDir = CurDir()
    End If
    
    OpenFile.lpstrTitle = ""

    If bSaveAs Then
        s = ""
        OpenFile.FLAGS = OFN_OVERWRITEPROMPT
        OpenFile.lpstrDefExt = ".lbl"
        
        lReturn = GetSaveFileName(OpenFile)
        
        If lReturn = 0 Then
            GetLabelFile = ""
        Else
            s = OpenFile.lpstrFile
            ReturnWOEndNull s
            GetLabelFile = s
        End If
        
        Exit Function
    Else
        OpenFile.FLAGS = OFN_FILEMUSTEXIST
        lReturn = GetOpenFileName(OpenFile)
        If lReturn = 0 Then
            GetLabelFile = ""
        Else
            s = OpenFile.lpstrFile
            ReturnWOEndNull s
            GetLabelFile = s
        End If
    
        Exit Function
    End If
    
    Exit Function
    
GetLabelFile_ERR:
    Debug.Assert 0
    Debug.Print "GetLabelFile_ERR: " & Err.Description
    Resume Next
    
    
End Function

Public Sub MoveLabelsToSurface()
Dim pSurface As ISurface
Debug.Assert 0

Set pSurface = GetSurfaceFromLayer(0)
Dim i As Integer
Dim pG As LabelGroup
Dim pT As IDDDText

For Each pG In g_pLabelEngine.LabelGroups
    For Each pT In pG.Labels
        pT.Origin.z = (pSurface.z(pT.Origin.X, pT.Origin.Y) * 2) + 1000
        pT.Enabled = True
    Next
Next

g_pLabelEngine.PersistLabels "d:\atemp\quadwork2.txt", 1


End Sub
'
'   given a layername or index return the ISurface from it;
'   optionally return the name of the layer
Public Function GetSurfaceFromLayer(sLayer, Optional ByRef sOutName As String) As ISurface

Dim pLayer As ILayer
Dim pTin As ITin
Dim pRLayer As IRasterLayer
Dim pTLayer As ITinLayer
Dim pSurf As IRasterSurface
Dim pBands As IRasterBandCollection
Dim sName As String

On Error GoTo GetSurfaceFromLayer_ERR

'   get the layer:
    Set pLayer = GetLayer(sLayer)

    If pLayer Is Nothing Then Exit Function

    If TypeOf pLayer Is IRasterLayer Then

        Set pRLayer = pLayer

        Dim p3DProp As I3DProperties
        Dim pLE As ILayerExtensions
        Set pLE = pLayer
        
        Dim i As Integer
        
    '   look for 3D properties of layer:
        For i = 0 To pLE.ExtensionCount - 1
            If TypeOf pLE.Extension(i) Is I3DProperties Then
                Set p3DProp = pLE.Extension(i)
                Exit For
            End If
        Next


    '   look first for base surface of layer:
        Set pSurf = p3DProp.BaseSurface
        
    '   if not found, try first band of raster:
        If pSurf Is Nothing Then

            If Not pRLayer.Raster Is Nothing Then
                Set pSurf = New RasterSurface
                Set pBands = pRLayer.Raster
                pSurf.RasterBand = pBands.Item(0)
                sName = pLayer.Name

            End If
        Else
        '   track the name of the layer if requested:
            sName = pLayer.Name
            If Not p3DProp.BaseName Is Nothing Then
                sName = sName & " <" & p3DProp.BaseName.NameString & ">"
            Else
                sName = sName & " <surface?>"
            End If
        End If
        
        Set GetSurfaceFromLayer = pSurf
        
    ElseIf TypeOf pLayer Is ITinLayer Then
    '   get the surface off the tin layer:
        Set pTLayer = pLayer
        Set GetSurfaceFromLayer = pTLayer.Dataset
        sName = pTLayer.Name
    Else
    
    End If

'   set return name if requested:
    If Not IsMissing(sOutName) Then sOutName = sName
    
    Exit Function
    
GetSurfaceFromLayer_ERR:
    Debug.Print "GetSurfaceFromLayer_ERR: " & vbCrLf & Err.Description
    Debug.Assert 0
    
End Function