自定义文字标注类vb+mo

       该类可实现文字的复杂表现形式，能解决一个图层多字段定义多种字体、大小等等，大家看看代码就明白了，还可解决地质方面上下标问题.

Option Explicit

Option Compare Text

Implements AFCustom.ICustomRenderer

Private Declare Function ExtCreatePen Lib "gdi32" (ByVal dwPenStyle As Long, ByVal dwWidth As Long, lplb As LOGBRUSH, ByVal dwStyleCount As Long, lpStyle As Long) As Long

Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function GdiRectangle Lib "gdi32" Alias "Rectangle" (ByVal hDC As Long, ByVal x1 As Long, ByVal Y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long

Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hDC As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As size) As Long

Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long

Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long

Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As rect, ByVal wFormat As Long) As Long

Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function SetTextCharacterExtra Lib "gdi32" (ByVal hDC As Long, ByVal nCharExtra As Long) As Long

Private Declare Function SetROP2 Lib "gdi32" (ByVal hDC As Long, ByVal nDrawMode As Long) As Long

Private Type LOGBRUSH

        lbStyle As Long

        lbColor As Long

        lbHatch As Long

End Type

Private Const R2_NOTXORPEN = 10

Private Const LF_FACESIZE = 32

Private Const DT_TOP = &H0

Private Const DT_WORDBREAK = &H10

Private Const DT_CALCRECT = &H400

Private Const DT_LEFT = &H0

Private Const DT_BOTTOM = &H8

Private Const DT_longLINE = &H20

Private Const DT_CENTER = &H1

Private Const DT_VCENTER = &H4

Private Const DT_SINGLELINE = &H20

Private Const DT_NOCLIP = &H100

Private Const OUT_DEFAULT_PRECIS = 0

Private Const OUT_STRING_PRECIS = 1

Private Const OUT_CHARACTER_PRECIS = 2

Private Const OUT_STROKE_PRECIS = 3

Private Const OUT_TT_PRECIS = 4

Private Const OUT_DEVICE_PRECIS = 5

Private Const OUT_RASTER_PRECIS = 6

Private Const OUT_TT_ONLY_PRECIS = 7

Private Const CLIP_DEFAULT_PRECIS = 0

Private Const CLIP_CHARACTER_PRECIS = 1

Private Const CLIP_STROKE_PRECIS = 2

Private Const CLIP_LH_ANGLES = &H10

Private Const CLIP_TT_ALWAYS = &H20

Private Const CLIP_EMBEDDED = &H80

Private Const DEFAULT_QUALITY = 0

Private Const DRAFT_QUALITY = 1

Private Const PROOF_QUALITY = 2

Private Const DEFAULT_PITCH = 0

Private Const FIXED_PITCH = 1

Private Const VARIABLE_PITCH = 2

Private Const TMPF_FIXED_PITCH = 1

Private Const TMPF_VECTOR = 2

Private Const TMPF_DEVICE = 8

Private Const TMPF_TRUETYPE = 4

Private Const ANSI_CHARSET = 0

Private Const DEFAULT_CHARSET = 1

Private Const SYMBOL_CHARSET = 2

Private Const SHIFTJIS_CHARSET = 128

Private Const OEM_CHARSET = 255

Private Const NTM_REGULAR = &H40&

Private Const NTM_BOLD = &H20&

Private Const NTM_ITALIC = &H1&

Private Const LF_FULLFACESIZE = 64

Private Const RASTER_FONTTYPE = 1

Private Const DEVICE_FONTTYPE = 2

Private Const TRUETYPE_FONTTYPE = 4

Private Const FF_DONTCARE = 0

Private Const FF_ROMAN = 16

Private Const FF_SWISS = 32

Private Const FF_MODERN = 48

Private Const FF_SCRIPT = 64

Private Const FF_DECORATIVE = 80

Private Const FW_DONTCARE = 0

Private Const FW_THIN = 100

Private Const FW_EXTRALIGHT = 200

Private Const FW_LIGHT = 300

Private Const FW_NORMAL = 400

Private Const FW_MEDIUM = 500

Private Const FW_SEMIBOLD = 600

Private Const FW_BOLD = 700

Private Const FW_EXTRABOLD = 800

Private Const FW_HEAVY = 900

Private Const FW_ULTRALIGHT = FW_EXTRALIGHT

Private Const FW_REGULAR = FW_NORMAL

Private Const FW_DEMIBOLD = FW_SEMIBOLD

Private Const FW_ULTRABOLD = FW_EXTRABOLD

Private Const FW_BLACK = FW_HEAVY

Private Const GCP_DBCS = &H1

Private Const GCP_REORDER = &H2

Private Const GCP_USEKERNING = &H8

Private Const GCP_GLYPHSHAPE = &H10

Private Const GCP_LIGATE = &H20

Private Const GCP_DIACRITIC = &H100

Private Const GCP_KASHIDA = &H400

Private Const GCP_ERROR = &H8000

Private Const FLI_MASK = &H103B

Private Const GCP_JUSTIFY = &H10000

Private Const GCP_NODIACRITICS = &H20000

Private Const FLI_GLYPHS = &H40000

Private Type size

        cx As Long

        cy As Long

End Type

Private Type rect

        left As Long

        top As Long

        Right As Long

        bottom As Long

End Type

Private Type LOGFONT

        lfHeight As Long

        lfWidth As Long

        lfEscapement As Long

        lfOrientation As Long

        lfWeight As Long

        lfItalic As Byte

        lfUnderline As Byte

        lfStrikeOut As Byte

        lfCharSet As Byte

        lfOutPrecision As Byte

        lfClipPrecision As Byte

        lfQuality As Byte

        lfPitchAndFamily As Byte

        lfFaceName(0 To LF_FACESIZE) As Byte

End Type

Private m_map As MapObjects2.map

Private m_Fld_Wznr As String '文字内容

Private m_Fld_Color As String '颜色

Private m_Fld_Zt As String '字体

Private m_Fld_Zx As String '字型

Private m_Fld_Zg As String '字高

Private m_Fld_Zk As String '字宽

Private m_Fld_Jd As String '角度

Private m_Fld_Jj As String '间距

Private m_sym As New MapObjects2.Symbol

Private m_hWnd As Long

Private m_hDC As Long

Public TRectCol As Collection

Private m_oldrt As MapObjects2.Rectangle

Property Get 文字内容字段() As String

         文字内容字段 = m_Fld_Wznr

End Property

Property Let 文字内容字段(str As String)

        m_Fld_Wznr = str

End Property

 

Property Get 字体字段() As String

         字体字段 = m_Fld_Zt

End Property

Property Let 字体字段(str As String)

        m_Fld_Zt = str

End Property

Property Get 字型字段() As String

         字型字段 = m_Fld_Zx

End Property

Property Let 字型字段(str As String)

        m_Fld_Zx = str

End Property

 

Property Get 颜色字段() As String

         颜色字段 = m_Fld_Color

End Property

Property Let 颜色字段(str As String)

        m_Fld_Color = str

End Property

 

Property Get 间距字段() As String

         间距字段 = m_Fld_Jj

End Property

Property Let 间距字段(str As String)

        m_Fld_Jj = str

End Property

Property Get 角度字段() As String

         角度字段 = m_Fld_Jd

End Property

Property Let 角度字段(str As String)

        m_Fld_Jd = str

End Property

Property Get 字宽字段() As String

         字宽字段 = m_Fld_Zk

End Property

Property Let 字宽字段(str As String)

        m_Fld_Zk = str

End Property

Property Get 字高字段() As String

         字高字段 = m_Fld_Zg

End Property

Property Let 字高字段(str As String)

        m_Fld_Zg = str

End Property

Property Get 地图控件()

  Set 地图控件 = m_map

End Property

Property Set 地图控件(地图控件 As MapObjects2.map)

  Set m_map = 地图控件

  m_hWnd = m_map.hwnd

  m_hDC = GetDC(m_hWnd)

  SetROP2 m_hDC, R2_NOTXORPEN

End Property

Private Sub Class_Initialize()

 

m_sym.Style = moCircleMarker

m_sym.size = 2

m_sym.color = vbRed

End Sub

Private Sub Class_Terminate()

ReleaseDC m_hWnd, m_hDC

End Sub

Private Sub ICustomRenderer_Draw(ByVal pMapLayer As Object, ByVal hDC As Long)

  Dim tmpRect As rect

  If m_map Is Nothing Or m_Fld_Wznr = "" Then

    Exit Sub

  End If

  Dim tfont As LOGFONT

  Dim pRecs As MapObjects2.Recordset

  Set pRecs = pMapLayer.Records

  SetBkMode hDC, 1 '0透明输出,1非

  If pRecs(m_Fld_Wznr) Is Nothing Then Exit Sub

  pRecs.MoveFirst

  Set TRectCol = New Collection

  Screen.MousePointer = vbHourglass

  Do While Not pRecs.EOF

     DrawTxt pMapLayer, pRecs, hDC

     pRecs.MoveNext

  Loop

Screen.MousePointer = vbDefault

End Sub

Private Function GetGldValue(trd As MapObjects2.Recordset, tfldstr As String) As String '获取字体值

    If tfldstr = "" Then Exit Function

    Dim tfld As MapObjects2.Field

    Set tfld = trd.Fields(tfldstr)

    If tfld Is Nothing Then Exit Function

    GetGldValue = tfld.Value

End Function

Sub DrawTxt(lyr As MapObjects2.maplayer, trd As MapObjects2.Recordset, hDC As Long)    '画文字

Dim tzx As String

Dim trt As New MapObjects2.Rectangle

Dim w As Long, H As Long

Dim tshp As MapObjects2.Point

Dim X As Single, Y As Single

Dim lz As size

Dim i As Long

Dim TempByteArray() As Byte

Dim ByteArrayLimit As Long

Dim color As Long

Dim tzt As String '字体

Dim tzg As String '字高

Dim tzk As String  '字宽

Dim tjd As String '角度

Dim tjj As String '间距

Dim tsize As Double

Dim oldfont As Long

Dim newfont As Long

Dim tfont As LOGFONT

Dim tcolor As String

Dim tmpRect As rect

Dim oldcolor As Long

Dim twznr As String

   

   

   

    Set tshp = trd.Fields("shape").Value

    Set tshp = Projected(m_map, tshp, lyr)

    m_map.FromMapPoint tshp, X, Y

    X = m_map.Parent.ScaleX(X, m_map.Parent.ScaleMode, 3)

    Y = m_map.Parent.ScaleX(Y, m_map.Parent.ScaleMode, 3)

    Set m_oldrt = Nothing

tsize = GMapextentHeight / m_map.extent.Height

On Error Resume Next

twznr = GetGldValue(trd, m_Fld_Wznr)

tzg = GetGldValue(trd, m_Fld_Zg)

tzk = GetGldValue(trd, m_Fld_Zk)

tjd = GetGldValue(trd, m_Fld_Jd)

tzt = GetGldValue(trd, m_Fld_Zt)

tjj = GetGldValue(trd, m_Fld_Jj)

tzx = GetGldValue(trd, m_Fld_Zx)

tcolor = GetGldValue(trd, m_Fld_Color)

If tjd = "" Then tjd = 0

If tjj = "" Then tjj = 0

If tzg = "" Then tzg = 1

If tzk = "" Then tzk = tzg

If tzt = "" Then tzg = "宋体"

If tcolor = "" Then tcolor = 0

  With tfont

     .lfHeight = tzg * tsize

     .lfWidth = tzk * tsize

     If .lfHeight < 1 Then .lfHeight = 1

     If .lfWidth < 1 Then .lfWidth = 1

        If tzx = "左斜" Then

            .lfItalic = True

        Else

            .lfItalic = False

        End If

     .lfUnderline = False

     .lfEscapement = tjd

     .lfOutPrecision = OUT_DEFAULT_PRECIS

     .lfClipPrecision = OUT_DEFAULT_PRECIS

     .lfQuality = DEFAULT_QUALITY

     .lfPitchAndFamily = DEFAULT_PITCH Or FF_DONTCARE

     .lfCharSet = DEFAULT_CHARSET

     TempByteArray = StrConv(tzt & Chr$(0), vbFromUnicode)

     ByteArrayLimit = UBound(TempByteArray)

     For i = 0 To ByteArrayLimit

      .lfFaceName(i) = TempByteArray(i)

     Next i

End With

   oldcolor = SetTextColor(hDC, tcolor)

   newfont = CreateFontIndirect(tfont)

   oldfont = SelectObject(hDC, newfont)

    SetTextCharacterExtra hDC, tjj * tsize

   

    GetTextExtentPoint32 hDC, twznr, ReturnByte(twznr), lz

    With tmpRect

        .left = X - lz.cx / 2

        .Right = X + lz.cx / 2

        .bottom = Y + lz.cy / 2

        .top = Y - lz.cy / 2

    End With

   

DrawText hDC, twznr, ReturnByte(twznr), tmpRect, DT_NOCLIP Or DT_CENTER

With trt

        .left = X - lz.cx / 2

        .Right = X + lz.cx / 2

        .bottom = Y - lz.cy / 2

        .top = Y + lz.cy / 2

        w = m_map.Parent.ScaleX(m_map.Width, vbTwips, vbPixels)

        H = m_map.Parent.ScaleY(m_map.Height, vbTwips, vbPixels)

        If .left < w And .Right > 0 And .top > 0 And .bottom < H Then

            TRectCol.Add PixelsRectToMap(trt)

        End If

End With

 

DeleteObject newfont

End Sub

Private Sub ICustomRenderer_DrawBackground(result As Long)

  result = 0

End Sub

Private Function ReturnByte(string1 As String) As Long '获得文字长度

      Dim i As Long, t As Long

      Dim strByte As Long

      string1 = string1

      For i = 1 To Len(string1)

          t = Asc(Mid$(string1, i, 1))

          If t >= 0 Then

            strByte = strByte + 1

          Else

            strByte = strByte + 2

          End If

      Next

        ReturnByte = strByte

End Function

Private Function MapRectToPixels(R As Object) As MapObjects2.Rectangle '地图坐标----->像素坐标

  Dim p As New Point

  Dim xc As Single, yc As Single

  Set MapRectToPixels = New MapObjects2.Rectangle

  p.X = R.left

  p.Y = R.top

  m_map.FromMapPoint p, xc, yc

  With MapRectToPixels

  ' convert to pixels

      .left = m_map.Parent.ScaleX(xc, vbTwips, vbPixels)

      .bottom = m_map.Parent.ScaleY(yc, vbTwips, vbPixels)

   

      p.X = R.Right

      p.Y = R.bottom

      m_map.FromMapPoint p, xc, yc

     

      ' convert to pixels

      .Right = m_map.Parent.ScaleX(xc, vbTwips, vbPixels)

      .top = m_map.Parent.ScaleY(yc, vbTwips, vbPixels)

  End With

End Function

Function PixelsRectToMap(tPiec As Object) As MapObjects2.Rectangle '像素坐标----->地图坐标

  Dim xc As Single, yc As Single

  Set PixelsRectToMap = New MapObjects2.Rectangle

  Dim p As MapObjects2.Point

    With tPiec

      xc = m_map.Parent.ScaleX(.left, vbPixels, vbTwips)

      yc = m_map.Parent.ScaleY(.bottom, vbPixels, vbTwips)

     

      Set p = m_map.ToMapPoint(xc, yc)

      PixelsRectToMap.left = p.X

      PixelsRectToMap.top = p.Y

      xc = m_map.Parent.ScaleX(.Right, vbPixels, vbTwips)

      yc = m_map.Parent.ScaleY(.top, vbPixels, vbTwips)

      Set p = m_map.ToMapPoint(xc, yc)

      PixelsRectToMap.Right = p.X

      PixelsRectToMap.bottom = p.Y

    End With

End Function

Public Function draw(trt As MapObjects2.Rectangle) As Boolean '画选择文字

    Dim tmpRt As MapObjects2.Rectangle

  Dim newpen As Long, oldpen As Long

  Dim peninfo As LOGBRUSH

  peninfo.lbStyle = 0

  peninfo.lbHatch = 4

  peninfo.lbColor = vbRed

  newpen = ExtCreatePen(66048, 1, peninfo, 0, ByVal 0&)

  oldpen = SelectObject(m_hDC, newpen)

 

   If Not m_oldrt Is Nothing Then

        With m_oldrt

            GdiRectangle m_hDC, .left, .bottom, .Right, .top

        End With

    End If

    If Not trt Is Nothing Then

        Set tmpRt = MapRectToPixels(trt)

        With tmpRt

            GdiRectangle m_hDC, .left, .bottom, .Right, .top

        End With

    End If

    Set m_oldrt = tmpRt

   

  DeleteObject newpen

   

End Function