modicon.bas

VB+MO城市公共交通管理信息系统。直接运行工程文件可以实现。

Attribute VB_Name = "modIcon"
Public Function fnGenerateIcon(strKey As String, LayerX As MapLayer) As Boolean

Dim lpointer As Long
Dim ImageX As ListImage

'清除Picture控件中已有的图像
frmMain.Picture1.Cls
'清除ImageList空间中已有的图标
For Each ImageX In frmLayer.LayerIcon.ListImages
    If ImageX.Key = strKey Then
        frmLayer.LayerIcon.ListImages.Remove ImageX.Index
        Exit For
    End If
Next

Select Case LayerX.shapeType
    Case moShapeTypeLine
        '线状地理对象
        Call DrawLine(LayerX.Symbol.Color)
    Case moShapeTypePoint
        '点状地理对象
        Call DrawCircle(LayerX.Symbol.Color)
    Case moshapetypePoints
        '点状地理对象
        Call DrawCircle(LayerX.Symbol.Color)
    Case Else
        '多边形地理对象
        If LayerX.Renderer Is Nothing Then
            '无任何Renderer，显示单一颜色矩形作为图标
            Call DrawRect(LayerX.Symbol.Color)
        Else
            If TypeOf LayerX.Renderer Is MapObjects2.ClassBreaksRenderer Then
                'ClassBreak Renderer，使用颜色渐变的矩形作为图标
                Dim ClassBreakX As ClassBreaksRenderer
                Set ClassBreakX = LayerX.Renderer
                Dim lp As Long
                For lp = 0 To 15
                    frmMain.Picture1.Line (lp, 0)-(lp, 15), RGB(lp * 16, 64 + lp * 12, 128 + lp * 8)
                Next lp
            ElseIf TypeOf LayerX.Renderer Is MapObjects2.LabelRenderer Then
                'Label Renderer，使用带有文字“A”的矩形作为图标
                Dim LabelX As LabelRenderer
                Set LabelX = LayerX.Renderer
                Call DrawRect(LayerX.Symbol.Color)
                frmMain.Picture1.Line (8, 3)-(5, 11), lcolor
                frmMain.Picture1.Line (8, 3)-(11, 11), lcolor
                frmMain.Picture1.Line (7, 8)-(10, 8), lcolor
            ElseIf TypeOf LayerX.Renderer Is MapObjects2.ValueMapRenderer Then
                'ValueMap Renderer，使用四个不同色块组成的矩形作为图标
                frmMain.Picture1.FillStyle = 0
                frmMain.Picture1.Line (2, 3)-(13, 11), RGB(0, 0, 0), B
                frmMain.Picture1.Line (3, 4)-(4, 10), RGB(255, 255, 255), BF
                frmMain.Picture1.Line (5, 4)-(6, 10), RGB(255, 0, 0), BF
                frmMain.Picture1.Line (7, 4)-(8, 10), RGB(0, 0, 255), BF
                frmMain.Picture1.Line (9, 4)-(10, 10), RGB(0, 255, 0), BF
                frmMain.Picture1.Line (11, 4)-(12, 10), RGB(255, 255, 0), BF
            Else
                '其它，显示单一颜色矩形作为图标
                Call DrawRect(LayerX.Symbol.Color)
            End If
        End If
End Select

'保存PictureBox中图标到临时文件
SavePicture frmMain.Picture1.Image, App.Path & "\Point.bmp"
'将文件中图标存放在ImageList中等待调用
frmLayer.LayerIcon.ListImages.Add , strKey, LoadPicture(App.Path & "\Point.bmp")
'删除临时文件
Kill App.Path & "\Point.bmp"

End Function
Private Sub DrawLine(lcolor As Long)
    '画线
    frmMain.Picture1.Line (0, 0)-(6, 12), lcolor
    frmMain.Picture1.Line (6, 12)-(8, 3), lcolor
    frmMain.Picture1.Line (8, 3)-(15, 15), lcolor
End Sub
Private Sub DrawCircle(lcolor As Long)
    '画圆点
    frmMain.Picture1.FillColor = lcolor
    frmMain.Picture1.FillStyle = 0
    frmMain.Picture1.Circle (8, 8), 3, lcolor
End Sub
Private Sub DrawRect(lcolor As Long)
    '画矩形
    frmMain.Picture1.FillColor = lcolor
    frmMain.Picture1.FillStyle = 0
    frmMain.Picture1.Line (2, 3)-(13, 11), RGB(0, 0, 0), B
End Sub