自定义文字标注类vb+mo-GIS空间站|地理信息系统|GPS

欢迎光临GIS空间站！　网站地图

专栏导航：| ArcGIS | MapInfo | TopMap | 地理信息 | 遥感 | GPS | 测绘 | WebGIS | LBS | 前沿 | 数据库 | 开发 | 行业应用

您现在的位置： GIS空间站 >> 技术专栏 >> ArcGIS >> 文章正文

自定义文字标注类vb+mo

作者：未知文章来源：GIS空间站点击数：更新时间：2006-7-3

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

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

文章录入：gissky 责任编辑：gissky

【发表评论】【加入收藏】【告诉好友】【打印此文】【关闭窗口】

■■相关图书：

■■相关文章：

国外超强ecognition(definiens)软件论坛

ArcSDE栅格数据存储模型及命令行管理举例

ArcGIS Online Services简介

TopMap GIS平台携手GIS空间站金秋送礼

ArcGIS数据生产管理和地图生产解决方案—PLTS

ArcGIS以工作流的方式处理GIS到CAD格式的数据转换

ArcGIS 9.2中时态GIS的应用

上一篇文章： ArcSDE服务不能启动的原因与处理方法

下一篇文章： Arcgis中topolopy说明

GIS博客精华

热点文章

热门资源

关于我们 \| 联系我们 \| 广告服务 \| 友情链接 \| 申请链接 \| 合作联盟 \| 诚聘英才
	GIS空间站(GISSky.Net)版权所有站长：兔八哥