dddfont.cls

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

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "DDDFont"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
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]

Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit

Private sName As String
Private bInit As Boolean

Private m_logFont As LOGFONT
Private m_font As Long
Private m_iFirstChar As Integer
Private m_iLastChar As Integer
Private m_iNumberChars As Integer
Private m_iDisplayListStart As Integer
Private m_iDisplayListBase As Integer
Private agmf(0 To 127) As GLYPHMETRICSFLOAT  ' Fixed size...
 
Implements IDDDFont

Private Sub Class_Initialize()
  bInit = False
End Sub

Private Sub Class_Terminate()
  
  If m_iDisplayListStart > 0 Then
    glDeleteLists m_iDisplayListStart, m_iNumberChars
  End If
  
End Sub

Private Function IDDDFont_NumChars() As Long
  IDDDFont_NumChars = m_iNumberChars
End Function

Private Function IDDDFont_Start() As Long
  IDDDFont_Start = m_iDisplayListStart
End Function

Private Function IDDDFont_Base() As Long
  IDDDFont_Base = m_iDisplayListBase
End Function

Private Function IDDDFont_InitializeNew(sInName As String) As Boolean

  If bInit Then Exit Function

  m_logFont.lfHeight = -10
  m_logFont.lfWidth = 0
  m_logFont.lfEscapement = 0
  m_logFont.lfOrientation = 0
  m_logFont.lfWeight = FW_NORMAL
  m_logFont.lfItalic = False
  m_logFont.lfUnderline = False
  m_logFont.lfStrikeOut = False
  m_logFont.lfCharSet = ANSI_CHARSET
  m_logFont.lfOutPrecision = OUT_TT_PRECIS
  m_logFont.lfClipPrecision = CLIP_DEFAULT_PRECIS
  m_logFont.lfQuality = PROOF_QUALITY
  m_logFont.lfPitchAndFamily = VARIABLE_PITCH Or TMPF_TRUETYPE Or FF_MODERN
  
  Dim temp() As Byte
  temp = StrConv(sInName & Chr$(0), vbFromUnicode)
  Dim i As Integer
  For i = 0 To UBound(temp)
      m_logFont.lfFaceName(i) = temp(i)
  Next
  m_font = CreateFontIndirect(m_logFont)
  
  ' font display lists variables
  m_iFirstChar = 32 ' 32 = Space
  m_iLastChar = 126
  m_iNumberChars = m_iLastChar - m_iFirstChar
  
  ' create font display lists
  m_iDisplayListStart = glGenLists(m_iNumberChars)
  m_iDisplayListBase = m_iDisplayListStart - m_iFirstChar

  Dim hdc As OLE_HANDLE
  hdc = wglGetCurrentDC()

  ' Select the font
  Dim oldFont As Long
  oldFont = SelectObject(hdc, m_font)
  
  ' generate the character's display lists
  Dim bResult As Boolean
  bResult = wglUseFontOutlines(hdc, _
            m_iFirstChar, _
            m_iNumberChars, _
            m_iDisplayListStart, _
            0, _
            1, _
            WGL_FONT_POLYGONS, _
            agmf(0))
  
  IDDDFont_InitializeNew = bResult
  
  If (bResult = False) Then
    Err.Raise Err.Number, "ArcSceneText.DDDFont", "Error in wglUseFontOutlines."
    Exit Function
  End If
  If (Not oldFont = 0) Then oldFont = SelectObject(hdc, oldFont) ' restore old font
 
  bInit = True

End Function

Private Function IDDDFont_Char(sInChar As String) As Long
    IDDDFont_Char = m_iDisplayListBase + AscB(sInChar)
End Function

Private Property Get IDDDFont_Name() As String
  IDDDFont_Name = sName
End Property

Private Function IDDDFont_CenterOffset(sInMsg As String) As Double
On Error GoTo EH
  
  Dim lCharOffset As Long
  Dim dOffset As Double
  dOffset = 0#
  Dim lCharIndex As Long
  For lCharIndex = 1 To Len(sInMsg)
    lCharOffset = Asc(Mid$(sInMsg, lCharIndex, 1)) - m_iFirstChar
    dOffset = dOffset + (agmf(lCharOffset).gmfCellIncX)
  Next lCharIndex
  
  IDDDFont_CenterOffset = (dOffset / 2)

  Exit Function
EH:
  Err.Raise Err.Number, "ArcSceneText.CenterOffset", "Can't calculate CenterOffset. " & Err.Description
End Function