1.新建类模块(AFCustom.cls)
2.工程引用——》浏览AfCust20.tlb——》添加AFCutom引用
3.类模块name为CustomSymbol
4.编写如下代码,文件——>生成AFCustomSymbol.dll
Option Explicit
'Indicate that this class will implement ICustomMarker
'Remember that you must first browse for the type library
Implements AFCustom.ICustomMarker
'Internal data members
Private m_filename As String
Private m_dpi As Double
Private m_picture As IPicture
'External method which allows users to specify the
'image path and name to be rendered.
Public Sub SetFileName(fn As String)
m_filename = fn
End Sub
'The draw method. This method is called for each symbol.
Private Sub ICustomMarker_Draw(ByVal hDC As Long, ByVal x As Long, ByVal y As Long)
Dim pixWidth As Double, pixHeight As Double
'Convert the picture width (normally in HI_METRIC) to pixels
'using the previously stored dpi member.
pixWidth = m_picture.Width * m_dpi / 2540
pixHeight = m_picture.Height * m_dpi / 2540
'Always check for a valid interface before using it.
If Not m_picture Is Nothing Then
'Render the picture, centered on the given point.
m_picture.Render hDC, x - pixHeight / 2, y + pixWidth / 2, pixWidth, -pixHeight, 0, 0, m_picture.Width, m_picture.Height, Null
End If
End Sub
'This method is called once per refresh, at the completion of rendering.
Private Sub ICustomMarker_ResetDC(ByVal hDC As Long)
'Set the picture object to nothing, free all resources.
Set m_picture = Nothing
End Sub
'This method is called once per refresh, prior to rendering.
Private Sub ICustomMarker_SetupDC(ByVal hDC As Long, ByVal dpi As Double, ByVal pBaseSym As Object)
'Store the dots per inch.
m_dpi = dpi
'Try to load the specified picture.
Set m_picture = LoadPicture(m_filename)
End Sub
5.新建工程调用自定义AFCustomSymbol.dll
<1> 工程引用AFCustomSymbol.dll
<2>简单引用
Private Sub Form_Load()
Dim bmpSym As New AFCustomSymbol.CustomSymbol
bmpSym.SetFileName App.Path & "/image/1.BMP"
Set Map1.Layers(0).Symbol.Custom = bmpSym
End Sub
<3>分类使用
Dim Map_ValueMapRenderer As New MapObjects2.ValueMapRenderer
Private Sub CmdType_Click()
Call Classify_Type("type_name")
End Sub
Private Sub CmdZoomAll_Click()
Map1.Extent = Map1.FullExtent
End Sub
Private Sub Form_Load()
Dim bmpSym As New AFCustomSymbol.CustomSymbol
bmpSym.SetFileName App.Path & "/image/1.BMP"
Set Map1.Layers(0).Symbol.Custom = bmpSym
End Sub
Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Map1.Extent = Map1.TrackRectangle
End Sub
Sub Classify_Type(strfield As String)
Dim strsUniqueValues As New MapObjects2.Strings
Dim Map_RecordSet As MapObjects2.Recordset
Dim Map_Symbol_N As Integer
Dim n As Integer
Set Map_RecordSet = Map1.Layers(0).Records
Set stats = Map_RecordSet.CalculateStatistics(strfield)
Map_RecordSet.MoveFirst
Do While Not Map_RecordSet.EOF
strsUniqueValues.Add Map_RecordSet(strfield).Value
Map_RecordSet.MoveNext
Loop
'
n = strsUniqueValues.Count
' If n > Map_Symbol_Max Then
' n = Map_Symbol_Max
' End If
Map_ValueMapRenderer.Field = strfield
Map_ValueMapRenderer.ValueCount = n
Map_Symbol_N = n
For i = 0 To Map_Symbol_N - 1
Map_ValueMapRenderer.Value(i) = strsUniqueValues(i)
Next i
Dim symInt As Integer
If Map1.Layers(0).shapeType = moShapeTypeMultipoint Then
symInt = 0
Else
symInt = Map1.Layers(0).shapeType - 21
End If
Map_ValueMapRenderer.SymbolType = symInt
Dim bmpSym(0 To 3) As New AFCustomSymbol.CustomSymbol
Dim j As Integer
j = 0
For i = 0 To Map_ValueMapRenderer.ValueCount - 1
' Dim MySymbol As New MapObjects2.Symbol
' MySymbol.Color = RGB(255, 0, 0)
' MySymbol.Size = 10
' MySymbol.Style = 1
'
Dim Str_Sym_File As String
Str_Sym_File = App.Path & "/image/" & j + 1 & ".bmp"
If j > 3 Then j = 0
bmpSym(j).SetFileName Str_Sym_File
Map_ValueMapRenderer.Symbol(i).Custom = bmpSym(j)
j = j + 1
' Map_ValueMapRenderer.Symbol(i).Color = MySymbol.Color
' Map_ValueMapRenderer.Symbol(i).Font = MySymbol.Font
' Map_ValueMapRenderer.Symbol(i).Size = MySymbol.Size
' Map_ValueMapRenderer.Symbol(i).Style = i
Next i
Set Map1.Layers(0).Renderer = Map_ValueMapRenderer
'
' For i = 1 To Map_ValueMapRenderer.ValueCount - 1
' Map_Symbol(i) = Map_ValueMapRenderer.Symbol(i)
'
' Next i
Map1.Refresh
End Sub