自定义文字标注类vb+mo
该类可实现文字的复杂表现形式,能解决一个图层多字段定义多种字体、大小等等,大家看看代码就明白了,还可解决地质方面上下标问题. Option ExplicitOption Compare TextImplements AFCustom.ICustomRendererPrivate Declare Function ExtCreatePen Lib "...
- 作者:未知来源:GIS空间站|2006年07月03日
该类可实现文字的复杂表现形式,能解决一个图层多字段定义多种字体、大小等等,大家看看代码就明白了,还可解决地质方面上下标问题.
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
上一篇:MapObjects相关资料整理