modlabelengine.bas

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

Attribute VB_Name = "modLabelEngine"

' 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

Global g_colLabelGroup As Collection    '   collection of all groups
Global g_nAziAngle As Double            '   current billboarding azimuth
Global g_nIncAngle As Double            '   current billboarding inclination
Global Const PI = 3.1415926             '   const PI


'   given the string read from a label file, return label properties:
'
Public Function GetAttribsFromLine(nFormat As Integer, sLine As String, Optional ByRef outsMessage As String, _
Optional ByRef outnX As Double, Optional ByRef outnY As Double, Optional ByRef outnZ As Double, _
Optional ByRef outnXRot As Double, Optional ByRef outnYRot As Double, Optional ByRef outnZRot As Double, _
Optional ByRef outnXScale As Double, Optional ByRef outnYScale As Double, Optional ByRef outnZScale As Double, Optional ByRef outnMinDist As Double, _
Optional ByRef outbVisible As Boolean, Optional ByRef outnFont As Double, _
Optional ByRef outpColor As IRgbColor, Optional outbBillBoarding As Boolean, Optional ByRef outsFontName As String, Optional ByRef outsLayername, _
Optional ByRef outsItem As String)
'**FORMAT1 = <x,y,z,xrot,yrot,zrot,xScale,yScale,zScale,MinDisplayDistance,message,visible,fontsize,fontname,BillBoarding,fontrgbcolor>
'**FORMAT2 = <layername,item,visible,fontsize,fontrgbcolor>
Dim ic1 As Integer, ic2 As Integer, ic3 As Integer, ic4 As Integer, ic5 As Integer, ic6 As Integer, ic7 As Integer
Dim ic8 As Integer, ic9 As Integer, ic10 As Integer, ic11 As Integer, ic12 As Integer
Dim ic13 As Integer, ic14 As Integer, ic15 As Integer, ic16 As Integer, ic17 As Integer

Dim n As Double
On Error GoTo GetAttribsFromLine_ERR

    ic1 = InStr(1, sLine, ",", vbTextCompare)
    ic2 = InStr(ic1 + 1, sLine, ",", vbTextCompare)
    ic3 = InStr(ic2 + 1, sLine, ",", vbTextCompare)
    ic4 = InStr(ic3 + 1, sLine, ",", vbTextCompare)
    ic5 = InStr(ic4 + 1, sLine, ",", vbTextCompare)
    ic6 = InStr(ic5 + 1, sLine, ",", vbTextCompare)
    ic7 = InStr(ic6 + 1, sLine, ",", vbTextCompare)
    
    ic8 = InStr(ic7 + 1, sLine, ",", vbTextCompare)
    ic9 = InStr(ic8 + 1, sLine, ",", vbTextCompare)
    ic10 = InStr(ic9 + 1, sLine, ",", vbTextCompare)
    ic11 = InStr(ic10 + 1, sLine, ",", vbTextCompare)
    ic12 = InStr(ic11 + 1, sLine, ",", vbTextCompare)
    
    ic13 = InStr(ic12 + 1, sLine, ",", vbTextCompare)
    ic14 = InStr(ic13 + 1, sLine, ",", vbTextCompare)
    ic15 = InStr(ic14 + 1, sLine, ",", vbTextCompare)
    ic16 = InStr(ic15 + 1, sLine, ",", vbTextCompare)
    ic17 = InStr(ic16 + 1, sLine, ",", vbTextCompare)
    
    Select Case nFormat
    '<x,y,z,xrot,yrot,zrot,xScale,yScale,zScale,MinDisplayDistance,message,visible,fontsize,fontname,BillBoarding,fontrgbcolor>

        Case 1
            outnX = Mid(sLine, 1, ic1 - 1)
            outnY = Mid(sLine, ic1 + 1, ic2 - ic1 - 1)
            outnZ = Mid(sLine, ic2 + 1, ic3 - ic2 - 1)
            
            outnXRot = Mid(sLine, ic3 + 1, ic4 - ic3 - 1)
            outnYRot = Mid(sLine, ic4 + 1, ic5 - ic4 - 1)
            outnZRot = Mid(sLine, ic5 + 1, ic6 - ic5 - 1)
            
            outnXScale = Mid(sLine, ic6 + 1, ic7 - ic6 - 1)
            outnYScale = Mid(sLine, ic7 + 1, ic8 - ic7 - 1)
            outnZScale = Mid(sLine, ic8 + 1, ic9 - ic8 - 1)
            outnMinDist = Mid(sLine, ic9 + 1, ic10 - ic9 - 1)
            
            outsMessage = Mid(sLine, ic10 + 1, ic11 - ic10 - 1)
            outbVisible = Mid(sLine, ic11 + 1, ic12 - ic11 - 1)
            outnFont = Mid(sLine, ic12 + 1, ic13 - ic12 - 1)
            outsFontName = Mid(sLine, ic13 + 1, ic14 - ic13 - 1)
            
            outbBillBoarding = Mid(sLine, ic14 + 1, ic15 - ic14 - 1)
            
            n = Mid(sLine, ic15 + 1)
            Dim pColor As IRgbColor
            Set pColor = New RgbColor
            pColor.RGB = n
            Set outpColor = pColor
        Case 2
'FORMAT2 = <layername,item,visible,fontsize,fontname,fontrgbcolor>
            outsLayername = Mid(sLine, 1, ic1 - 1)
            outsItem = Mid(sLine, ic1 + 1, ic2 - ic1 - 1)
            outbVisible = Mid(sLine, ic2 + 1, ic3 - ic2 - 1)
            outnFont = Mid(sLine, ic3 + 1, ic4 - ic3 - 1)
            outsFontName = Mid(sLine, ic4 + 1, ic5 - ic4 - 1)

            n = 255
            Set pColor = New RgbColor
            pColor.RGB = n
            Set outpColor = pColor
            
    End Select
        
    Exit Function
    
GetAttribsFromLine_ERR:
    Debug.Assert 0
    Debug.Print "GetAttribsFromLine_ERR: " & Err.Description
    Resume Next

End Function
'   given some individual label properties, format a line to insert into text file
'
Public Function PutAttribsIntoLine(nFormat As Integer, sMessage As String, _
nX As Double, nY As Double, nZ As Double, _
nxRot As Double, nyRot As Double, nZRot As Double, _
nXScale As Double, nYScale As Double, nZScale As Double, nMinDispDist As Double, _
bVisible As Boolean, nFont As Long, _
pColor As IRgbColor, sFontName As String, bBillBoarding As Boolean) As String
'**FORMAT1 = <x,y,z,xrot,yrot,zrot,xScale,yScale,zScale,MinDisplayDistance,message,visible,fontsize,fontname,BillBoarding,fontrgbcolor>
'FORMAT2 = <layername,item,visible,fontsize,fontrgbcolor>
Dim sLine As String

On Error GoTo PutAttribs_ERR

'   no commas in message:
    sMessage = Replace(sMessage, ",", ";")
    
    Select Case nFormat
        Case 1
            sLine = nX & ","
            sLine = sLine & nY & ","
            sLine = sLine & nZ & ","
            sLine = sLine & nxRot & ","
            sLine = sLine & nyRot & ","
            sLine = sLine & nZRot & ","
            sLine = sLine & nXScale & ","
            sLine = sLine & nYScale & ","
            sLine = sLine & nZScale & ","
            sLine = sLine & nMinDispDist & ","
            sLine = sLine & sMessage & ","
            sLine = sLine & bVisible & ","
            sLine = sLine & nFont & ","
            sLine = sLine & sFontName & ","
            sLine = sLine & bBillBoarding & ","
            sLine = sLine & pColor.RGB
            
        Case 2
        
    End Select
    
    
    PutAttribsIntoLine = sLine
    
    Exit Function
    
PutAttribs_ERR:
    Debug.Assert 0
    Debug.Print "PutAttribs_ERR: " & Err.Description
    
End Function


Public Sub CalcBillboarding(ByRef pViewer As ISceneViewer)

On Error GoTo CalcBillboarding_ERR

    ' get camera params
    Dim pCamera As ICamera
    Set pCamera = pViewer.Camera
    Dim pObs As IPoint
    Dim pTar As IPoint
    Set pObs = pCamera.Observer
    Set pTar = pCamera.Target
    Dim xObs As Double
    Dim yObs As Double
    Dim zObs As Double
    Dim xTar As Double
    Dim yTar As Double
    Dim zTar As Double
    pObs.QueryCoords xObs, yObs
    zObs = pObs.z
    pTar.QueryCoords xTar, yTar
    zTar = pTar.z

    
    g_nAziAngle = Azimuth(xObs, yObs, xTar, yTar)
    
    g_nIncAngle = Inclination(xObs, yObs, zObs, xTar, yTar, zTar)

    Exit Sub
    
CalcBillboarding_ERR:
    'MsgBox "CalcBillboarding_ERR: " & err.Description
    

End Sub



Public Function Azimuth(x1 As Double, y1 As Double, x2 As Double, y2 As Double)
On Error Resume Next

  Dim angle As Double
  If (Not x1 = x2) Then
    If (x1 < x2) Then
      angle = Atn((y2 - y1) / (x2 - x1))
    Else
      angle = PI + Atn((y1 - y2) / (x1 - x2))
    End If
  Else
    If (y2 > y1) Then
          angle = 0.5 * PI
    Else: angle = -0.5 * PI
    End If
  End If
  Azimuth = angle
End Function
Public Function Inclination(x1 As Double, y1 As Double, z1 As Double, _
                          x2 As Double, y2 As Double, z2 As Double)
  Dim dx, dy, dz As Double
  dx = x2 - x1
  dy = y2 - y1
  dz = z2 - z1
  Dim d As Double
  d = Sqr(dx * dx + dy * dy)
  Inclination = Atn(dz / d)
End Function


Public Sub DoDebug()
Debug.Assert 0


End Sub