- 阿啵呲嘚
-
MapObjects环境下地图符号化是通过地图显示对象来完成的。地图显示对象是一组用来进行地图显示的对象集合,这组对象集合提供了简单的符号化方法,并能实现专题地图的制作。通过它们,开发人员不仅能够显示矢量数据,还可将栅格数据作为背景进行显示,同时能够显示动态数据(如GPS)数据。
MapObjects为用户提供了十多种缺省的符号样式(SymbolStyle),但在很多情下用户需要大量其他的符号,这种方式显然不能满足需求。因此用户进行二次开发时,要利用MapObjects提供的接口实现图元的自定义符号化。
自定义符号的实现可采用TrueType技术和GDI技术,最后通过MoSymbol提供的客户化接口来实现的。采用TrueType字体简单、灵活,但TrueType字库只能对点状符号进行自定义符号化,对于一些特殊的符号如文字的上下标尤其线、面状符号自定义符号化就无能为力。同时TrueType字库是以文件方式存放的,较难实现符号资源的多用户共享。
(一)使用TrueType字体实现自定义点符号
1.TrueType技术与字库
PostScript是美国Adobe于1985年发表的文件描述技术,Adobe利用该技术,创造著名合乎PostScript技术的字型,从而改变整个印刷工业。为打破Adobe公司在该领域的垄断地位,Apple Computer公司和Microsoft公司在1991年联合提出的一种新型数学字形描述技术——TrueType。它用数学函数描述字体轮廓外形,含有字形构造、颜色填充、数字描述函数、流程条件控制、栅格处理控制、附加提示控制等指令。TrueType字体:是由直线、曲线等图形数据来描述文字的轮廓,采用二次曲线,一套字体即可用于屏幕显示又可作为打印字体。是使用最为广泛的字体。
TrueType字体具有如下优势。
1)真正的所见即所得字体。由于TrueType字体支持几乎所有输出设备,因而无论在屏幕、激光打印机、激光照排机上,还是在彩色喷墨打印机上,均能以设备的分辨率输出,因而输出很光滑。
2)支持字体嵌入技术。存盘时可将文件中使用的所有TrueType字体采用嵌入方式一并存入文件之中,使整个文件中所有字体可方便地传递到其他计算机中使用。嵌入技术可保证未安装相应字体的计算机能以原格式使用原字体打印。
3)操作系统的兼容性。MAC和PC机均支持TrueType字体,都可以在同名软件中直接打开应用文件而不需要替换字体。
地球化学点状符号可用CorelDraw完成字符绘制,CorelDraw是Corel公司出品的矢量绘图软件。图形绘制功能非常强大,而且在同类软件中是唯一一款直接支持 TrueType(.ttf)输出的。
2.实现思路
首先创建一个新的Symbol对象,并将它的SetSymbolType的属性设置成0(表示为点状符号),将SetStyle属性设置成4(表示用TrueType字体作点状符号);然后创建一新的StdFont对象,将该对象的SetName 属性设置为要调用的TrueType 点状符号库;最后将Symbol对象的SetFont属性设置为上面定义好的StdFont对象,在TrueType点状符号库中利用SetCharacterIndex属性设置函数设置需要的TrueType点状符号。
3.关键代码
Private Sub Form_Load()
Dim fnt As New StdFont
Dim dc As New DataConnection
dc.Database=ReturnDataPath("data")
If Not dc.Connect Then End
'略
Dim layer As MapLayer
Set layer=New MapLayer
layer.GeoDataset=dc.FindGeoDataset("示例点")'加载点文件
layer.Symbol.Color=moBlue
layer.Symbol.Style=moTrueTypeMarker
fnt.Name ="chinaHT symbol mo"'自创字体名
fnt.Bold=False
layer.Symbol.Font=fnt
layer.Symbol.CharacterIndex=64
layer.Symbol.Size=20
Map1.Layers.Add layer
'略
End Sub
(二)基于GDI的自定义符号的实现
1.实现思路
MapObjects 环境下地图符号化是通过地图显示对象来完成的。地图显示对象是一组用来进行地图显示的对象集合,这组对象总共包含17个对象,它们分别是CMap(Map控制对应的对象)、CMoLayers(要素层集合对象)、CMoMapLayer(矢量图层对象)、CMoImageLayer(栅格图层对象)、CMoTracku2043ingLayer(动探数据对象)、CMoGeoEvent(空间目标对象)、CMoEventRenderer、CMoGroupRenu2043derer、CMoSymbol、CMoTextSymbol(文本符号对象)、CMoChartRenderer、CMoClassBreaksRenu2043derer、CMoDotDensityRenderer、CMoValueMapRenderer、CMoZRenderer、CMoLabelPlacer、CMou2043LabelRenderer。其中MoSymbol用于确定几何符号的各种属性,如颜色、大小、类型等,MoSymbol对象预留了名为Custom的Idispitch接口,使得定制符号成为可能。要实现自定义符号绘制,至少要实现3个基本函数。
(1)SetupDC()
该函数用来建立绘制符号的设备上下文(Device Context)和设置一些绘制所需要的参数,如符号大小、旋转角度等。
(2)Draw()
这个函数是自定义符号中最重要的一个函数,其主要是通过利用Windows GDI函数绘制农业地质专业符号,包括文本符号(如带上下标的地质代号)、几何图形等。
(3)ResetDC()
该函数清除当前设备上下文并恢复原始的设备上下文,用来为下一次绘制提供一个初始设备上下文。
自定义面状符号绘制过程如图8-5所示。
图8-5 自定义面状符号实现流程
2.程序实现——以面状符号为例
先准备一个面状形文件数据如States.shp,建议存储在D盘的Data文件夹中。然后以Visual Basic 6.0为开发环境,新建一工程,在部件中添加MO组件(图8-6),建立一个名为Testfill类模块,添加Draw()等函数。再在Form1窗体中添加一名为Map1的Mau2043pObjects控件。实际效果(将代码粘贴到相应工程下,运行即可)如图8-7所示,具体代码如下:
图8-6 加入MO控件
图8-7 面状花纹效果图
(1)定义面状符号类——Testfill
1)定义数据结构
Option Explicit
Option Compare Text
Option Explicit
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
left As Long
top As Long
right As Long
bottom As Long
End Type
Private Declare Function GetClipBox Lib"gdi32"(ByVal hdc As Long,lpRect As RECT)As Long
Private Declare Function Arc Lib "gdi32"(ByVal hdc As Long,ByVal X1 As Long,ByVal Y1 As Long,ByVal X2 As Long,ByVal Y2 As Long,ByVal X3 As Long,ByVal Y3 As Long,ByVal X4 As Long,ByVal Y4 As Long)As Long
Private Declare Function PolyPolygonP Lib "gdi32"Alias"PolyPolygon"(ByVal hdc As Long,lpPoint As Long,lpPolyCounts As Long,ByVal nCount As Long)As Long
Private Declare Function SelectClipRgn Lib"gdi32"(ByVal hdc As Long,ByVal hRgn As Long)As Long
Private Declare Function PolyPolygon Lib"gdi32"(ByVal hdc As Long,lppt As Long,lpdwPolyPoints As Long,ByVal cCount As Long)As Long
Private Declare Function CreatePen Lib"gdi32"(ByVal nPenStyle As Long,ByVal nWidth As Long,ByVal crColor As Long)As Long
Private Declare Function CreateSolidBrush Lib"gdi32"(ByVal crColor As Long)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 PolyPolyline Lib"gdi32"(ByVal hdc As Long,lppt As Long,lpdwPolyPoints As Long,ByVal cCount As Long)As Long
Private Declare Function EndPath Lib"gdi32"(ByVal hdc As Long)As Long
Private Declare Function BeginPath Lib"gdi32"(ByVal hdc As Long)As Long
Private Declare Function Rectangle Lib"gdi32"(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 SelectClipPath Lib"gdi32"(ByVal hdc As Long,ByVal iMode As Long)As Long
Dim Rectfull As RECT
Dim Rectextent As RECT
Dim NEWRECT As RECT
Dim size As Double
Public map As MapObjects2.map
Public color As Long'符号的颜色
Public backcolor As Long'区域的背景颜色
Public xi As Double
Public outline As Boolean
Public filltype As String
B、取得设备描述表的句柄
Public Sub SetupDC(hdc As Long,dpi As Double,baseSym As Object)
End Sub
2)利用API函数绘制苗圃面状花纹
Public Sub Draw(hdc As Long,points As Long,partCounts As Long,numparts As Long)
If filltype=NULL Then Exit Sub 不画
Dim newbrush As Long,oldbrush As Long,newpen As Long,oldpen As Long
Dim pointt As New MapObjects2.point
Dim ps(0 To 3)As POINTAPI
Dim xxx As Single,yyy As Single
If backcolor <>0 Then
newbrush=CreateSolidBrush(backcolor)
oldbrush=SelectObject(hdc,newbrush)
newpen=CreatePen(0,1,backcolor)
oldpen=SelectObject(hdc,newpen)
PolyPolygonP hdc,points,partCounts,numparts
SelectObject hdc,oldpen
SelectObject hdc,oldbrush
DeleteObject newpen
DeleteObject newbrush
End If
If outline=True Then
newpen=CreatePen(0,1,0)
oldpen=SelectObject(hdc,newpen)
PolyPolyline hdc,points,partCounts,numparts
SelectObject hdc,oldpen
DeleteObject newpen
End If
If filltype=Then Exit Sub 只画背景
If map Is Nothing Then
Exit Sub
Else
size=map.FullExtent.Height/map.Extent.Height
If size>1000 Or size < 0.00001 Then Exit Sub
End If
If xi=0 Then xi=0.1
BeginPath hdc
PolyPolygonP hdc,points,partCounts,numparts
EndPath hdc
SelectClipPath hdc,5
GetClipBox hdc,NEWRECT
pointt.x=map.FullExtent.left
pointt.y=map.FullExtent.top
map.FromMapPoint pointt,xxx,yyy
Rectfull.left=map.Parent.ScaleX(xxx,vbTwips,vbPixels)
Rectfull.top=map.Parent.ScaleY(yyy,vbTwips,vbPixels)
pointt.x=map.FullExtent.right
pointt.y=map.FullExtent.bottom
map.FromMapPoint pointt,xxx,yyy
Rectfull.right=map.Parent.ScaleX(xxx,vbTwips,vbPixels)
Rectfull.bottom=map.Parent.ScaleY(yyy,vbTwips,vbPixels)
pointt.x=map.Extent.left
pointt.y=map.Extent.top
map.FromMapPoint pointt,xxx,yyy
Rectextent.left=map.Parent.ScaleX(xxx,vbTwips,vbPixels)
Rectextent.top=map.Parent.ScaleY(yyy,vbTwips,vbPixels)
pointt.x=map.Extent.right
pointt.y=map.Extent.bottom
map.FromMapPoint pointt,xxx,yyy
Rectextent.right=map.Parent.ScaleX(xxx,vbTwips,vbPixels)
Rectextent.bottom=map.Parent.ScaleY(yyy,vbTwips,vbPixels)
drawsym83050 hdc,color,xi,size
BeginPath hdc
Rectangle hdc,99999,99999,99999,99999
EndPath hdc
SelectClipPath hdc,5
End Sub
'********************苗圃花纹*******************
Private Sub drawsym83050(hdc As Long,color As Long,xi As Double,size As Double)
Dim XX As Long,YY As Long,heicounty,widcountx,rleft,rtop,mwid As Double,mheiAs Double
Dim oldpen,newpen As Long
Dim centerx As Double,centery As Double,R As Double
R=4*xi*size
mwid=100*xi*size
mhei=100*xi*size
RectToRect NEWRECT,Rectfull,mhei,mwid
heicounty=Int((NEWRECT.bottomu2043NEWRECT.top)/mhei)+ 1
widcountx=Int((NEWRECT.rightu2043NEWRECT.left)/mwid)+ 1
rleft=NEWRECT.left
rtop=NEWRECT.top
newpen=CreatePen(0,1.2*xi*size,color)
oldpen=SelectObject(hdc,newpen)
For YY=0 To heicounty-1
For XX=0 To widcountx-1
centerx=25/100*mwid
centery=25/100*mhei
Arc hdc,centerxu2043R +(rleft + XX*mwid),centeryu2043R +(rtop + YY*mhei),centerx + R +(rleft + XX*mwid),centery + R +(rtop + YY*mhei),centerxu2043R +(rleft + XX*mwid),centeryu2043R +(rtop + YY*mhei),centerxu2043R +(rleft + XX*mwid),centeryu2043R +(rtop + YY*mhei)
centerx=75/100*mwid
centery=75/100*mhei
Arc hdc,centerxu2043R +(rleft + XX*mwid),centeryu2043R +(rtop + YY*mhei),centerx + R +(rleft + XX*mwid),centery + R +(rtop + YY*mhei),centerxu2043R +(rleft + XX*mwid),centeryu2043R +(rtop + YY*mhei),centerxu2043R +(rleft + XX*mwid),centeryu2043R +(rtop + YY*mhei)
Next
Next
SelectObject hdc,oldpen
DeleteObject newpen
End Sub
Private Sub RectToRect(RECTS As RECT,Rectfull As RECT,mhei As Double,mwid As Double)
If Rectfull.bottom=0 And Rectfull.top=0 Then Exit Sub
If Rectextent.top>RECTS.top Then RECTS.top=Rectextent.top
If Rectextent.left>RECTS.left Then RECTS.left=Rectextent.left
If Rectextent.bottom < RECTS.bottom Then RECTS.bottom=Rectextent.bottom
If Rectextent.right < RECTS.right Then RECTS.right=Rectextent.right
Dim tmptop,tmpright,tmpleft,tmpbottom As Long
tmptop=Int((RECTS.topu2043Rectfull.top)/mhei)*mhei
tmpleft=Int((RECTS.leftu2043Rectfull.left)/mwid)*mwid
tmpright=Int((Rectfull.rightu2043RECTS.right)/mwid)*mwid
tmpbottom=Int((Rectfull.bottomu2043RECTS.bottom)/mhei)*mhei
With RECTS
.top=Rectfull.top + tmptop
.bottom=Rectfull.bottomu2043tmpbottom
.left=Rectfull.left + tmpleft
.right=Rectfull.rightu2043tmpright
End With
End Sub
3)释放设备描述表的句柄
Public Sub ResetDC(hdc As Long)
End Sub
(2)面状符号调用
Dim custfill As New testfill
Private Sub Form_Load()
Dim dc As New DataConnection
dc.Database ="D:\Data"
If Not dc.Connect Then End
Dim layer As New MapLayer
Set layer.GeoDataset=dc.FindGeoDataset("States")
layer.Symbol.color=moPaleYellow
Map1.Layers.Add layer
With custfill
.filltype ="83050"
Set .map=Map1
.xi=0.3
.color=moRed
.backcolor=RGB(255,255,0)
.outline=True
End With
Set layer.Symbol.Custom=custfill
Map1.Refresh
End Sub