dddtext.cls

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

End Property
Private Property Let IDDDText_MinDisplayDist(dInMinDist As Double)
  dMinDisplayDist = dInMinDist
End Property

Private Property Get IDDDText_DisplayList() As Long
  IDDDText_DisplayList = lDisplayList
End Property

Private Sub Class_Initialize()
    
  Set pOrigin = New esriGeometry.Point
  pOrigin.PutCoords 0#, 0#
  pOrigin.z = 0#
  bUseDefaultColor = False
  Set pDefaultColor = New RgbColor
  pDefaultColor.RGB = vbBlack
  Set pColor = New RgbColor
  pColor.RGB = vbBlack
  pAlign = alignLeft
  dMinDisplayDist = -1
  
  IDDDText_Initialize "Empty String", pOrigin, _
                                   10#, 1#, 1#, 0.5, _
                                   pColor, 90#, 0#, 0#, _
                                   "Arial", "Unknown", False
                                   
End Sub

Private Sub Class_Terminate()
  If lDisplayList > 0 Then
    glDeleteLists lDisplayList, 1
  End If
End Sub

Private Sub IDDDText_Initialize(sInMessage As String, _
                                                  pInOrigin As IPoint, _
                                                  dInFontSize As Double, _
                                                  dInXScale As Double, _
                                                  dInYScale As Double, _
                                                  dInZScale As Double, _
                                                  pInColor As IRgbColor, _
                                                  dInXRot As Double, _
                                                  dInYRot As Double, _
                                                  dInZRot As Double, _
                                                  sInFontName As String, _
                                                  sInType As String, bBillBoarding As Boolean, Optional dInMinDispDist As Double = -1)
  On Error GoTo EH
  
  sMessage = sInMessage
  Set pOrigin = pInOrigin
  
    IDDDText_AutoAdjust = bBillBoarding
    
  
  dFontSize = dInFontSize
  dXScale = dInXScale
  dYScale = dInYScale
  dZScale = dInZScale
  pDefaultColor.RGB = pInColor.RGB
  Set pColor = pInColor
  dXRot = dInXRot
  dYRot = dInYRot
  dZRot = dInZRot
  sFontName = sInFontName
  sType = sInType
  bEnabled = True
  bNeedsGeomUpdate = True
  bNeedsFontUpdate = True
  dMinDisplayDist = dInMinDispDist
  Exit Sub
EH:
  Err.Raise Err.Number, "IDDDText.Initialize", Err.Description
End Sub

Private Sub IDDDText_SetTextScale(dInXScale As Double, dInYScale As Double, dInZScale As Double)
  dXScale = dInXScale
  dYScale = dInYScale
  dZScale = dInZScale
  bNeedsGeomUpdate = True
End Sub
Private Sub IDDDText_GetTextScale(dOutXScale As Double, dOutYScale As Double, dOutZScale As Double)
  dOutXScale = dXScale
  dOutYScale = dYScale
  dOutZScale = dZScale
End Sub

Private Sub IDDDText_SetAxisRotation(Optional dInXRot As Double = 0#, _
                                                            Optional dInYRot As Double = 0#, _
                                                            Optional dInZRot As Double = 0#)
  dXRot = dInXRot
  dYRot = dInYRot
  dZRot = dInZRot
  bNeedsGeomUpdate = True
End Sub

Private Sub IDDDText_GetAxisRotation(dOutXRot As Double, _
                                                            dOutYRot As Double, _
                                                            dOutZRot As Double)
  dOutXRot = dXRot
  dOutYRot = dYRot
  dOutZRot = dZRot
End Sub

Private Sub InitializeFont()
On Error GoTo EH

  If dictFonts Is Nothing Then
    Set dictFonts = New Dictionary
  End If

  If dictFonts.Exists(sFontName) Then
     Set pDDDFont = dictFonts.Item(sFontName)
  Else
    Set pDDDFont = New DDDFont
    If pDDDFont.InitializeNew(sFontName) Then
      dictFonts.Add sFontName, pDDDFont
    Else
      pDDDFont.InitializeNew "Arial"
    End If
  End If
  
  Exit Sub
EH:
  Err.Raise Err.Number, "DDDText.InitializeFont", Err.Description
End Sub

Private Sub DefineDisplayList()
On Error GoTo EH

  If lDisplayList > 0 Then
    glDeleteLists lDisplayList, 1
  End If

  lDisplayList = glGenLists(1)
  glNewList lDisplayList, GL_COMPILE
    glListBase pDDDFont.Base
    glPushMatrix
      
      ' TRANSALTE
      glTranslated pOrigin.x, pOrigin.y, pOrigin.z
      
      ' ROTATE
      ' ROTATE
      If bAutoAdjust Then
        If (bAziBillboard) Then
          glRotated (dAziAngle * 180 / PI - 90), 0#, 0#, 1#
          If (bIncBillboard) Then
            glRotated (dIncAngle * 180 / PI + 90), 1#, 0#, 0#
          End If
        End If
      Else
        glRotated dXRot, 1#, 0#, 0#
        glRotated dYRot, 0#, 1#, 0#
        glRotated dZRot, 0#, 0#, 1#
      End If
      
      ' ALIGN/JUSTIFY
      Dim dCenterOffset As Double
      dCenterOffset = pDDDFont.CenterOffset(sMessage) * (dFontSize * (dXScale / 100))
      glTranslated -(dCenterOffset * pAlign), 0#, 0#
                      
      ' SCALE
      glScalef dFontSize * (dXScale / 100), _
                   dFontSize * (dYScale / 100), _
                   dFontSize * (dZScale / 100)
                   
      Dim iIndex As Integer
      For iIndex = 1 To Len(sMessage)
        glCallList pDDDFont.Char(Mid(sMessage, iIndex, 1))
      Next iIndex
    glPopMatrix
  glEndList
  
  Exit Sub
EH:
  Err.Raise Err.Number, "DDDText.DefineDisplayList", Err.Description
End Sub

Private Sub IDDDText_Draw(ByVal pViewer As esri3DAnalyst.ISceneViewer)
On Error GoTo EH

'   do not draw if not enabled:
    If Not bEnabled Then Exit Sub
    
'   do font update if necessary:
    If bNeedsFontUpdate Then
      InitializeFont
      bNeedsFontUpdate = False
    End If

'   do geometry update if necessary:
    If bNeedsGeomUpdate Or bAutoAdjust Then
      If bAutoAdjust Then
        dAziAngle = GetAzimuth(pViewer.Camera)
        dIncAngle = GetInclination(pViewer.Camera)
      End If
      DefineDisplayList
      bNeedsGeomUpdate = False
    End If
    
'   decide if we should draw:
    Dim pProxOp As IProximityOperator
    Set pProxOp = pOrigin
    Dim dDistToObserver As Double
    dDistToObserver = pProxOp.ReturnDistance(pViewer.Camera.Observer)
    
    If (dMinDisplayDist = -1#) Or (dDistToObserver < dMinDisplayDist) Then
    
    '   call the display list:
        glPushMatrix
          glEnable glcLighting
          If bUseDefaultColor Then
            glColor3f CDbl(pDefaultColor.Red / 255), CDbl(pDefaultColor.Green / 255), CDbl(pDefaultColor.Blue / 255)
          Else
            glColor3f CDbl(pColor.Red / 255), CDbl(pColor.Green / 255), CDbl(pColor.Blue / 255)
          End If
          glCallList lDisplayList
        glPopMatrix
    
    End If
    
  Exit Sub
EH:
  Err.Raise Err.Number, "DDDText.Draw", Err.Description
End Sub
Private Function GetAzimuth(pCamera As ICamera) As Double
On Error GoTo EH

  Dim x1 As Double
  x1 = pCamera.Observer.x
  Dim y1 As Double
  y1 = pCamera.Observer.y
  Dim x2 As Double
  x2 = pCamera.Target.x
  Dim y2 As Double
  y2 = pCamera.Target.y
  
  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
  GetAzimuth = angle
  
  Exit Function
EH:
  Err.Raise Err.Number, "DDDText.GetAzimuth", Err.Description
End Function

Private Function GetInclination(pCamera As ICamera) As Double
On Error GoTo EH

  Dim x1 As Double
  x1 = pCamera.Observer.x
  Dim y1 As Double
  y1 = pCamera.Observer.y
  Dim z1 As Double
  z1 = pCamera.Observer.z
  Dim x2 As Double
  x2 = pCamera.Target.x
  Dim y2 As Double
  y2 = pCamera.Target.y
  Dim z2 As Double
  z2 = pCamera.Target.z
  
  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)
  GetInclination = Atn(dz / d)
  
  Exit Function
EH:
  Err.Raise Err.Number, "DDDText.GetInclination", Err.Description
End Function