www.pudn.com > mapxoracle.zip > MDIForm.frm
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.MDIForm MDIForm1
BackColor = &H8000000C&
Caption = "MapX "
ClientHeight = 3195
ClientLeft = 165
ClientTop = 735
ClientWidth = 6345
LinkTopic = "MDIForm1"
ScrollBars = 0 'False
StartUpPosition = 3 '窗口缺省
WindowState = 2 'Maximized
Begin MSComctlLib.StatusBar StatusBar1
Align = 2 'Align Bottom
Height = 330
Left = 0
TabIndex = 0
Top = 2865
Width = 6345
_ExtentX = 11192
_ExtentY = 582
_Version = 393216
BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
NumPanels = 2
BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
Object.Width = 6175
MinWidth = 6175
Object.ToolTipText = "坐标点"
EndProperty
BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628}
Object.Width = 4304
MinWidth = 4304
Object.ToolTipText = "编辑图层"
EndProperty
EndProperty
End
Begin MSComDlg.CommonDialog CM1
Left = 480
Top = 960
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.Menu Openfile
Caption = "文件"
Begin VB.Menu LinkOracle
Caption = "打开Oracle数据源"
End
Begin VB.Menu Exit
Caption = "退出"
End
End
Begin VB.Menu FeatureDraw
Caption = "对象绘制"
Begin VB.Menu DrawFeature
Caption = "创建符号"
Index = 1
End
Begin VB.Menu DrawFeature
Caption = "创建文本"
Index = 2
End
Begin VB.Menu DrawFeature
Caption = "创建线段"
Index = 4
End
Begin VB.Menu DrawFeature
Caption = "创建折线"
Index = 5
End
Begin VB.Menu DrawFeature
Caption = "创建多边形"
Index = 12
End
End
Begin VB.Menu View
Caption = "视图"
Begin VB.Menu ControlLayer
Caption = "图层控制"
End
Begin VB.Menu ChangeView
Caption = "改变视野..."
Enabled = 0 'False
Visible = 0 'False
End
Begin VB.Menu Entirelayer
Caption = "全层显示"
End
Begin VB.Menu CreateLegend
Caption = "显示图例"
Enabled = 0 'False
Visible = 0 'False
End
End
Begin VB.Menu MapOption
Caption = "地图"
Begin VB.Menu SelectAll
Caption = "全选"
End
Begin VB.Menu PointSelect
Caption = "单点选择"
End
Begin VB.Menu RectSelect
Caption = "矩形选择"
End
Begin VB.Menu CircleSelect
Caption = "圆形选择"
End
Begin VB.Menu IrregularSelect
Caption = "不规则选择"
End
Begin VB.Menu PolygonSelect
Caption = "多边形选择"
Visible = 0 'False
End
Begin VB.Menu BufferSelect
Caption = "缓冲区选择"
Visible = 0 'False
End
Begin VB.Menu menu32
Caption = "-"
End
Begin VB.Menu UnselectAll
Caption = "全不选"
End
Begin VB.Menu menu33
Caption = "-"
End
Begin VB.Menu MapOpt
Caption = "地图选项"
Enabled = 0 'False
Visible = 0 'False
End
End
Begin VB.Menu Browser
Caption = "浏览"
Begin VB.Menu OpenBroswer
Caption = "打开浏览"
End
End
Begin VB.Menu Options
Caption = "选项"
Begin VB.Menu linestyle
Caption = "线样式..."
End
Begin VB.Menu regionstyle
Caption = "区域样式..."
End
Begin VB.Menu symbolstyle
Caption = "符号样式..."
End
Begin VB.Menu textstyle
Caption = "文本样式..."
End
Begin VB.Menu Option
Caption = "选项..."
End
End
End
Attribute VB_Name = "MDIForm1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub AddToGeoset_Click()
Dim lyrinfo As New MapXLib.LayerInfo
lyrinfo.Type = miLayerInfoTypeGeodictUserName
lyrinfo.AddParameter "name", Formmain.Map1.Layers.Item(1).name
Formmain.Map1.Layers.Add lyrinfo
End Sub
Private Sub ADOType_Click()
Dim bindlayer As New bindlayer
Dim conn As New ADODB.Connection
Dim cmd As New ADODB.Command
Dim rs As New ADODB.Recordset
'引用中加入Microsoft ActiveX Data Objects 2.0 Library
bindlayer.LayerName = "us_cust2"
bindlayer.LayerType = miBindLayerTypeXY
bindlayer.RefColumn1 = "x"
bindlayer.RefColumn2 = "y"
conn.Open "dsn=mapstats"
Set cmd.ActiveConnection = conn
cmd.CommandText = "select * from us_cust"
rs.CursorLocation = adUseClient
rs.Open cmd, , adOpenDynamic, adLockBatchOptimistic
Formmain.Map1.Datasets.Add miDataSetADO, rs, "us_cust2", "company", , bindlayer
'****不能使用ADODC控件作为其数据源.
'***Formmain.Map1.Datasets.Add miDataSetADO, Formmain.Ado1.Recordset, "us_cust1", "company", , bindlayer
ChangeCombo
Set bindlayer = Nothing
Set conn = Nothing
Set cmd = Nothing
Set rs = Nothing
End Sub
Private Sub bandus_Click()
Dim bindlayer As New bindlayer
Dim ds As MapXLib.Dataset
Dim lyr As MapXLib.layer
'绑定层字段要作索引。
'(1)
Set lyr = Formmain.Map1.Layers.Item("us_cust1")
Set ds = Formmain.Map1.Datasets.Add(miDataSetDAO, Formmain.Data1.Recordset, "us_cust21", "city", "state", lyr)
'(2)
'bindlayer.LayerName = "usa"
'bindlayer.LayerType = miBindLayerTypeNormal
'Set ds = Formmain.Map1.Datasets.Add(miDataSetDAO, Formmain.Data1.Recordset, "us_cust1", "state", , bindlayer)
Formmain.Map1.MatchThreshold = 1
'Set ds = Formmain.Map1.Datasets.Add(miDataSetDAO, Formmain.Data1.Recordset, "us_cust21", "state")
ds.Themes.Add 5
ChangeCombo
Set bindlayer = Nothing
End Sub
Private Sub CircleSelect_Click()
Formmain.Map1.CurrentTool = miRadiusSelectTool
End Sub
Private Sub CloseGeoset_Click()
Formmain.Map1.Geoset = ""
End Sub
Private Sub CloseTable_Click()
End Sub
Private Sub CloseTables_Click()
CloseTable.Show 1
End Sub
Private Sub ControlLayer_Click()
On Error Resume Next
Formmain.Map1.Layers.LayersDlg
ChangeCombo
End Sub
Private Sub copy_Click()
Dim lyr As MapXLib.layer
For Each lyr In Formmain.Map1.Layers
If lyr.Selection.Count > 0 Then
Set CopyFtrs = lyr.NoFeatures
CopyFtrs.Add lyr.Selection.Clone
Exit For
End If
Next
End Sub
Private Sub CreateTheme_Click()
Dim ds As MapXLib.Dataset
If Trim(ToolBars.Combo2.Text) <> "" Then
ThemeDlg.Show 1
Else
MsgBox "请先选择数据集.", , "错误提示"
End If
End Sub
Private Sub DAOType_Click()
Dim bindlayer As New bindlayer
Dim ds As New MapXLib.Dataset
bindlayer.LayerName = "us_cust1"
bindlayer.LayerType = miBindLayerTypeXY
bindlayer.RefColumn1 = "x"
bindlayer.RefColumn2 = "y"
Set ds = Formmain.Map1.Datasets.Add(miDataSetDAO, Formmain.Data1.Recordset, "us_cust1", "state", , bindlayer)
ChangeCombo
Set bindlayer = Nothing
End Sub
Private Sub DeleteAllAnnotation_Click()
Formmain.Map1.Annotations.RemoveAll
End Sub
Private Sub DispPRJ_Click()
Formmain.Map1.DisplayCoordSys.PickCoordSys
End Sub
Private Sub DrawFeature_Click(Index As Integer)
Dim lyr As MapXLib.layer
Dim i As Integer
For i = 1 To ToolBars.Toolbar1.Buttons.Count
ToolBars.Toolbar1.Buttons.Item(i).Value = tbrUnpressed
Next i
If Trim(ToolBars.Combo1.Text) = "" Then
MsgBox "请选择编辑图层.", , "警告"
Else
Set lyr = Formmain.Map1.Layers(ToolBars.Combo1.Text)
If lyr.Editable = False Then MsgBox "图层不可编辑", , "警告"
End If
Select Case Index
Case 1 '创建符号
Set Formmain.Map1.Layers.InsertionLayer = lyr
Formmain.Map1.CurrentTool = miAddPointTool
'Formmain.Map1.CurrentTool = CreateSymbolTool
Case 2 '创建文本
Formmain.Map1.CurrentTool = CreateTextTool
Case 4 '创建线段
' Formmain.Map1.CurrentTool = CreateLineTool
Set Formmain.Map1.Layers.InsertionLayer = lyr
Formmain.Map1.CurrentTool = miAddLineTool
Case 5 '创建折线
' Formmain.Map1.CurrentTool = CreatePolyLineTool
Set Formmain.Map1.Layers.InsertionLayer = lyr
Formmain.Map1.CurrentTool = miAddPolylineTool
Case 6 '创建弧段
Formmain.Map1.CurrentTool = CreateArcTool
Case 7 '创建矩形
Formmain.Map1.CurrentTool = CreateRectTool
Case 9 '创建矩形区域
Formmain.Map1.CurrentTool = CreateRectRegionTool
Case 10 '创建圆形区域
Formmain.Map1.CurrentTool = CreateCircleRegionTool
Case 11 '创建椭圆区域
Formmain.Map1.CurrentTool = CreateEllipseRegionTool
Case 12 '创建多边形
' Formmain.Map1.CurrentTool = CreatePolygonTool
Set Formmain.Map1.Layers.InsertionLayer = lyr
Formmain.Map1.CurrentTool = miAddRegionTool
End Select
End Sub
Private Sub DrawUserLayer_Click()
Dim LayerInfo As MapXLib.LayerInfo
LayerInfo.Type = miLayerInfoTypeUserDraw
LayerInfo.AddParameter "name", UserDraw
Formmain.Map1.Layers.Add LayerInfo, 1
End Sub
Private Sub Entirelayer_Click()
FrmEntireLayer.Show
End Sub
Private Sub Exit_Click()
End
End Sub
Private Sub GlobalHandleType_Click()
Dim fileData As String, lineData As String, filepath As String
Dim flds As New MapXLib.Fields
Dim MemoryBlockId As Long
Dim MemoryBlockAddress As Long
Dim bindlayer As New MapXLib.bindlayer
'对文本文件的要求: 以TAB制表符作为分隔.(因为用line input语句读入)
'出错处: 1.文本文件中数据格式.经验: 先以其中少量数据试验,已排出数据问题
' 2.用bindlayer时一定要设置GeoField参数.
'Open the data file
Open App.Path & "\us_cust.txt" For Input Access Read As #1
'Loop through the file
Do While Not EOF(1)
'Read the current line of tab-delimited dat
Line Input #1, lineData
'Add it to the string and add a carriage return line feed
'vbCrLf = Chr(13) & Chr(10)
fileData = fileData & lineData & vbCrLf
Loop
'Allocate the memory for our data (length + 1 for NULL char)
MemoryBlockId = GlobalAlloc(GMEM_MOVEABLE, Len(fileData) + 1)
'Lock the memory
MemoryBlockAddress = GlobalLock(MemoryBlockId)
'Copy the string into memory
lstrcpy MemoryBlockAddress, fileData
'Unlock the memory
GlobalUnlock MemoryBlockId
'Build a fields collection to use with the tab-delimited data
'This is the only way to give the data field-names
flds.Add 1, "LNAME", , miTypeString
flds.Add 2, "FNAME", , miTypeString
flds.Add 3, "TERR", , miTypeString
flds.Add 4, "COMPANY", , miTypeString
flds.Add 5, "CITY", , miTypeString
flds.Add 6, "STATE", , miTypeString
flds.Add 7, "ZIP", , miTypeString
flds.Add 8, "ORDER_AMT", , miTypeNumeric
flds.Add 9, "X", , miTypeNumeric
flds.Add 10, "Y", , miTypeNumeric
flds.Add 11, "ID", , miTypeNumeric
bindlayer.LayerName = "us_cust5"
bindlayer.LayerType = miBindLayerTypeXY
bindlayer.RefColumn1 = "x"
bindlayer.RefColumn2 = "y"
'Add the data set using the fields collection
Formmain.Map1.Datasets.Add miDataSetGlobalHandle, MemoryBlockId, "US_cust5", "company", , bindlayer, flds
'Close the input file
Close 1
ChangeCombo
Set flds = Nothing
Set bindlayer = Nothing
End Sub
Private Sub infotip_Click()
Dim ds As New MapXLib.Dataset
Formmain.Map1.InfotipSupport = False
Set ds = Formmain.Map1.Datasets.Item(1)
Set Formmain.Map1.Layers.Item(1).LabelProperties.Dataset = ds
Set Formmain.Map1.Layers.Item(1).LabelProperties.DataField = ds.Fields.Item(2)
Formmain.Map1.InfotipSupport = True
End Sub
Private Sub IrregularSelect_Click()
Formmain.Map1.CurrentTool = miPolygonSelectTool
End Sub
Private Sub LabelAtpoint_Click()
Dim ftrs As New MapXLib.Features
Dim X As Double
Dim Y As Double
Dim i As Integer
Set ftrs = Formmain.Map1.Layers.Item(1).AllFeatures
MsgBox Str(ftrs.Count)
For i = 1 To ftrs.Count
X = ftrs.Item(i).CenterX
Y = ftrs.Item(i).CenterY
MsgBox Str(X) + "," + Str(Y)
Formmain.Map1.Layers.Item(1).LabelAtPoint X, Y
Next
End Sub
Private Sub LayerType_Click()
FrmAddDsLayer.Show 1
ChangeCombo
End Sub
Private Sub linestyle_Click()
Formmain.Map1.DefaultStyle.PickLine
End Sub
Private Sub LinkODBC_Click()
Dim LayerInfo As New MapXLib.LayerInfo
Dim lyrinfo As New MapXLib.LayerInfo
Dim lyr As MapXLib.layer
Dim ds As MapXLib.Dataset
IsOracle = False
ODBCLayer.Show 1
If ODBCFlag = True Then
LayerInfo.Type = miLayerInfoTypeServer
LayerInfo.AddParameter "name", ODBCLayer.Text1
LayerInfo.AddParameter "connectstring", ODBCLayer.Text2
LayerInfo.AddParameter "query", ODBCLayer.Text3
LayerInfo.AddParameter "cache", ODBCLayer.Text4
LayerInfo.AddParameter "MBRSearch", ODBCLayer.Text6
LayerInfo.AddParameter "toolkit", "ODBC" 'ODBCLayer.Text5
If Option_AddToDataset = True Then
LayerInfo.AddParameter "AutoCreateDataset", 1
LayerInfo.AddParameter "datasetname", ODBCLayer.Text1
End If
Set lyr = Formmain.Map1.Layers.Add(LayerInfo, 1)
Unload ODBCLayer
ChangeCombo
End If
End Sub
Private Sub LinkOracle_Click()
Dim LayerInfo As New MapXLib.LayerInfo
Dim lyr As MapXLib.layer
Dim ds As MapXLib.Dataset
IsOracle = True
ODBCLayer.Show 1
If ODBCFlag = True Then
LayerInfo.Type = miLayerInfoTypeServer
LayerInfo.AddParameter "name", ODBCLayer.Text1
LayerInfo.AddParameter "connectstring", ODBCLayer.Text2
LayerInfo.AddParameter "query", ODBCLayer.Text3
LayerInfo.AddParameter "cache", ODBCLayer.Text4
LayerInfo.AddParameter "MBRSearch", ODBCLayer.Text6
LayerInfo.AddParameter "toolkit", "ORAINET" 'ODBCLayer.Text5
'Problem -- Why can't I link Spatialware data
If Option_AddToDataset = True Then
LayerInfo.AddParameter "AutoCreateDataset", 1
LayerInfo.AddParameter "datasetname", ODBCLayer.Text1
End If
Set lyr = Formmain.Map1.Layers.Add(LayerInfo, 1)
Unload ODBCLayer
ChangeCombo
End If
End Sub
Private Sub MapOpt_Click()
MapOptions.Show 1
End Sub
Private Sub MDIForm_Load()
Me.Top = 0
Me.Left = 0
Me.Width = Screen.Width
Me.Height = Screen.Height
Me.WindowState = 2
ToolBars.Show
' Formmain.Show
FormIndex = 1
End Sub
Private Sub ModifyAnnotation_Click()
If Formmain.Map1.Annotations.ActiveAnnotation.Type = miSymbolAnnotation Then
FrmAnnoSymbol.Show
ElseIf Formmain.Map1.Annotations.ActiveAnnotation.Type = miTextAnnotation Then
FrmAnnoText.Show
End If
End Sub
Private Sub ModifyLegend_Click()
Dim ds As MapXLib.Dataset
If Trim(ToolBars.Combo2.Text) <> "" Then
Set ds = Formmain.Map1.Datasets.Item(ToolBars.Combo2.Text)
ds.Themes.Item(1).Legend.LegendDlg
Else
MsgBox "请先选择数据集.", , "错误提示"
End If
End Sub
Private Sub ModifyTheme_Click()
Dim ds As MapXLib.Dataset
If Trim(ToolBars.Combo2.Text) <> "" Then
Set ds = Formmain.Map1.Datasets.Item(ToolBars.Combo2.Text)
ds.Themes.Item(1).ThemeDlg
Else
MsgBox "请先选择数据集.", , "错误提示"
End If
End Sub
Private Sub MoveFeature_Click()
'MoveFtr.Show 1
Dim ftr As New MapXLib.Feature
Formmain.Map1.AutoRedraw = False
For Each ftr In Formmain.Map1.Layers.Item(ToolBars.Combo1.Text).AllFeatures
Formmain.Map1.Layers.Item(ToolBars.Combo1.Text).Selection.Add ftr
Next
Formmain.Map1.AutoRedraw = True
Formmain.Map1.Refresh
Formmain.Map1.CurrentTool = MoveFeatures
End Sub
Private Sub NewTable_Click()
'注意：新建的图层若投影为“非地球坐标系”，仍存在坐标系范围问题。
'要求在新建图层前要先设numericcoordsys的坐标范围。这样才不会出现问题。
FormNewTable.Show 1
End Sub
Private Sub Nonearth_Click()
Dim csys As New MapXLib.CoordSys
Formmain.Map1.NumericCoordSys.PickCoordSys
Set csys = Formmain.Map1.NumericCoordSys
'Formmain.Map1.NumericCoordSys.Bounds = Formmain.Map1.Layers.Bounds
csys.Set 0, , 5, , , , , , , , , , Formmain.Map1.Layers.Bounds
Set Formmain.Map1.NumericCoordSys = csys
End Sub
Private Sub Normalbinding_Click()
'创建新层newlayer，与MApstats.mdb的soil表进行绑定
'要求：新层中画三个图元，值分别为a1,a2,a3
Dim OdbcQueryInfo As New OdbcQueryInfo
Dim lyr As New MapXLib.layer
Dim ds As New MapXLib.Dataset
OdbcQueryInfo.connectstring = "odbc;"
OdbcQueryInfo.DataSource = "mapstats"
OdbcQueryInfo.SqlQuery = "select * from soil"
Set lyr = Formmain.Map1.Layers("newlayer")
Set ds = Formmain.Map1.Datasets.Add(miDataSetODBC, OdbcQueryInfo, "soil", "name", , lyr)
ds.Themes.Add 5
End Sub
Private Sub NumPRJ_Click()
Formmain.Map1.NumericCoordSys.PickCoordSys
End Sub
Private Sub ODBCType_Click()
Dim bindlayer As New bindlayer
Dim OdbcQueryInfo As New OdbcQueryInfo
OdbcQueryInfo.connectstring = "odbc;"
OdbcQueryInfo.DataSource = "mapstats"
OdbcQueryInfo.SqlQuery = "select * from us_cust"
bindlayer.LayerName = "us_cust4"
' bindlayer.CoordSys.PickCoordSys
'bindlayer.FileSpec = "C:\TEMP\US_CUST4.TAB"
bindlayer.LayerType = miBindLayerTypeXY
bindlayer.RefColumn1 = "x"
bindlayer.RefColumn2 = "y"
Formmain.Map1.Datasets.Add miDataSetODBC, OdbcQueryInfo, "us_cust4", "company", , bindlayer
ChangeCombo
Set bindlayer = Nothing
Set OdbcQueryInfo = Nothing
End Sub
Private Sub OpenBroswer_Click()
FrmBrowser.Show
End Sub
Private Sub OpenGeoset_Click()
Dim filepath As String
Dim filename As String
On Error Resume Next
CM1.DialogTitle = "打开文件"
CM1.DefaultExt = "gst"
CM1.Filter = "GeoSet(*.gst)|*.gst"
CM1.CancelError = True
CM1.Action = 1
If Err.Number = 32755 Then Exit Sub
Formmain.Map1.Geoset = CM1.filename
Dim csys As New MapXLib.CoordSys
csys.Set 0, , 5, , , , , , , , , , Formmain.Map1.Layers.Bounds
Set Formmain.Map1.NumericCoordSys = csys
ChangeCombo
Dim i As Integer
For i = 1 To Formmain.Map1.Layers.Count
MsgBox Formmain.Map1.Layers.Item(i).name
Next i
End Sub
Private Sub OpenTable_Click()
'LayerInfo 的Type 属性
'0 - .tab
'1 - User Draw
'2 - self-registering Raster
'3 - Shape
'4 - Server (remote database)
'5 - Geodictionary username
' Type 0:
'"FileSpec", Yes, String
'"Name", No, String
'ex: AddParameter("FileSpec", "c:\data\states.tab")
'AddParameter("Name", "MyStatesLayer")
'
'Type 1:
'"Name", Yes, String
'ex: AddParameter("Name", "MyUserDraw")
'
'Type 2:
'"FileSpec", Yes, String
'"Name", No, String
'ex: AddParameter("FileSpec", "c:\raster\rainfall.tif")
'
'Type 3:
'"FileSpec", Yes, String
'"Name", No, String
'"CoordSys", Yes, Object (mapxlib.coordsys; mapx.coordsys.4)
'"Style", No, Object (mapxlib.style; mapx.style.4)
'
'Type 4:
'"Name", Yes, String
'"ConnectString", Yes, String
'"Query", Yes, String
'LayerOptions , No, Numeric
'(Probably in the next Beta refresh, "ToolKit", Yes, String will be recognized to differentiate between ODBC and ORAINET i.e. OCI for Oracle 8i connectivity)
'ex: AddParameter("Name", "RDBMSStates")
'AddParameter("ConnectString", "DSN=MyODBCDataSource")
'AddParameter("Query", "SELECT * FROM STATES")
'AddParameter("ToolKit", "ODBC")
'
'Type 5:
'"Name", Yes, String
'ex: AddParameter("Name", "US Places")
Dim filename As String
Dim filepath As String
Dim LayerName As String
Dim lyr As MapXLib.layer
Dim LayerInfo As New MapXLib.LayerInfo
Dim FilterIndex As Integer
Dim ftrs As New MapXLib.Features
Dim csys As New MapXLib.CoordSys
On Error Resume Next
CM1.DialogTitle = "打开文件"
CM1.DefaultExt = "Tab|*.tab"
CM1.Filter = "表(*.tab)|*.tab|GeoTiff file(*.tif)|*.tif|shapefile(*.tab)|*.tab|ServerLayer(spatialware)"
CM1.CancelError = True
CM1.Action = 1
If Err.Number = 32755 Then Exit Sub
filename = CM1.FileTitle
filepath = CM1.filename
filepath = Left(filepath, InStr(filepath, filename) - 1)
LayerName = Left(filename, InStr(filename, ".") - 1)
FilterIndex = CM1.FilterIndex
Select Case FilterIndex
Case 1: '*.tab
LayerInfo.Type = miLayerInfoTypeTab
LayerInfo.AddParameter "FileSpec", filepath + filename
LayerInfo.AddParameter "Name", LayerName
Case 2: 'You must use Geotiff file.
'GeoTiff and Tiff:GeoTiff is a raster TIFF file that has stored the geographical coordinates
'of where it belongs on the earth. A TIFF is a regular raster file that need to
'be registered in Mi Pro.
LayerInfo.Type = miLayerInfoTypeRaster
LayerInfo.AddParameter "FileSpec", filepath + filename
LayerInfo.AddParameter "Name", LayerName
Case 3: '*.shp --- Failed
'csys.PickCoordSys
csys.Set 1, 0
'Set Formmain.Map1.DisplayCoordSys = csys
'Set Formmain.Map1.NumericCoordSys = csys
'Formmain.Map1.NumericCoordSys.PickCoordSys
'Formmain.Map1.DisplayCoordSys.PickCoordSys
'Formmain.Map1.DisplayCoordSys.PickCoordSys
LayerInfo.Type = miLayerInfoTypeShape
LayerInfo.AddParameter "FileSpec", filepath + filename
LayerInfo.AddParameter "CoordSys", csys
End Select
'将新建图层加入到数据集
If Option_AddToDataset = True Then
LayerInfo.AddParameter "AutoCreateDataset", 1
LayerInfo.AddParameter "datasetname", LayerName
End If
Set lyr = Formmain.Map1.Layers.Add(LayerInfo, 1)
' '将新建图层加入到数据字典
' If Option_AddToGeoDict = True Then
' LayerInfo.Type = miLayerInfoTypeGeodictUserName
' LayerInfo.AddParameter "Name", LayerName
' Formmain.Map1.Layers.Add LayerInfo
' End If
ChangeCombo
End Sub
Private Sub Option_Click()
FormOptionLayer.Show 1
End Sub
Private Sub paste_Click()
Dim lyr As MapXLib.layer
Dim ftr As New MapXLib.Feature
Set lyr = Formmain.Map1.Layers(ToolBars.Combo1.Text)
For Each ftr In CopyFtrs
lyr.AddFeature ftr
Next
End Sub
Private Sub PointSelect_Click()
Formmain.Map1.CurrentTool = miSelectTool
End Sub
Private Sub ProjectCoord_Click()
Dim csys As New MapXLib.CoordSys
Set csys = Formmain.Map1.NumericCoordSys.PickCoordSys
Set csys.Bounds = Formmain.Map1.Layers.Bounds
Set Formmain.Map1.NumericCoordSys = csys
End Sub
Private Sub RDOType_Click()
'用对象和控件两种方式实现
'使用控件时,需在属性框填写Connect;DataSourceName;SQL三项.
Dim bindlayer As New bindlayer
bindlayer.LayerName = "us_cust3"
bindlayer.LayerType = miBindLayerTypeXY
bindlayer.RefColumn1 = "x"
bindlayer.RefColumn2 = "y"
Formmain.Map1.Datasets.Add miDataSetRDO, Formmain.MSRDC1.Resultset, "us_cust3", "company", , bindlayer
ChangeCombo
Set bindlayer = Nothing
End Sub
Private Sub RectSelect_Click()
Formmain.Map1.CurrentTool = miRectSelectTool
End Sub
Private Sub regionstyle_Click()
Formmain.Map1.DefaultStyle.PickRegion
End Sub
Private Sub rot_Click()
Dim ftr As New MapXLib.Feature
Dim lyr As MapXLib.layer
Dim t As Integer
Dim ftrs As New MapXLib.Features
Set lyr = Formmain.Map1.Layers.Item(1)
lyr.Selection.SelectAll 0
Set ftrs = lyr.NoFeatures
Set ftr = lyr.Selection.Item(1)
t = Val(InputBox("shuru", ""))
ftr.Style.TextFontRotation = t
ftr.Update
ftrs.Add ftr
End Sub
Private Sub SafeArrayType_Click()
Dim objBindLayer As New MapXLib.bindlayer
'Dim fldFieldsToAdd As New MapXLib.Fields
Dim bZipcodeLayer As Boolean
Dim zipdata(1 To 5, 1 To 5) As Variant
zipdata(1, 1) = "12054"
zipdata(1, 2) = 27391
zipdata(1, 3) = "Jim"
zipdata(1, 4) = -118.111
zipdata(1, 5) = 33.82
zipdata(2, 1) = "12304"
zipdata(2, 2) = 38943
zipdata(2, 3) = "John"
zipdata(2, 4) = -104.86
zipdata(2, 5) = 38.76
zipdata(3, 1) = "12210"
zipdata(3, 2) = 45663
zipdata(3, 3) = "Tanya"
zipdata(3, 4) = -107.07
zipdata(3, 5) = 38.49
zipdata(4, 1) = "12180"
zipdata(4, 2) = 22447
zipdata(4, 3) = "Carlene"
zipdata(4, 4) = -71.79
zipdata(4, 5) = 40.04
zipdata(5, 1) = "12012"
zipdata(5, 2) = 66152
zipdata(5, 3) = "Jeff"
zipdata(5, 4) = -111.89
zipdata(5, 5) = 40.71
'Create the fields collection to bring in
' fldFieldsToAdd.Add "Zip", "Zip", miAggregationIndividual, miTypeString
' fldFieldsToAdd.Add "Sales", "Sales", miAggregationSum, miTypeNumeric
' fldFieldsToAdd.Add "SalesRep", "SalesRep", miAggregationIndividual, miTypeString
'Set up the BindLayerObject
With objBindLayer
.LayerName = "Zip Data1" 'The name of the new layer
.LayerType = miBindLayerTypeXY 'Match up my data against a map layer
.RefColumn1 = 4
.RefColumn2 = 5
End With
'Add the dataset
Formmain.Map1.Datasets.Add miDataSetSafeArray, zipdata, "Zip Data1", 1, , objBindLayer
'出错原因:1.使用fldFieldsToAdd作为Add方法的Fields参数.
' 2.用bindlayer时一定要设置GeoField参数.这里须设为列号.
'错误用法: Formmain.Map1.Datasets.Add miDataSetSafeArray, zipdata, "Zip Data1", 1, , objBindLayer , fldFieldsToAdd
ChangeCombo
Set objBindLayer = Nothing
End Sub
Private Sub SaveGeoset_Click()
Dim filepath As String
Dim filename As String
On Error Resume Next
CM1.DialogTitle = "保存地图集"
CM1.DefaultExt = "gst"
CM1.Filter = "GeoSet(*.gst)|*.gst"
CM1.CancelError = True
CM1.Flags = &H2
CM1.Action = 2
If Err.Number = 32755 Then Exit Sub
filename = CM1.FileTitle
filepath = CM1.filename
filename = Left(filename, InStr(filename, ".") - 1)
Formmain.Map1.SaveMapAsGeoset filename, filepath
End Sub
Private Sub SelectAll_Click()
Dim lyr As MapXLib.layer
If Trim(ToolBars.Combo1.Text) <> "" Then
Set lyr = Formmain.Map1.Layers.Item(ToolBars.Combo1.Text)
lyr.Selection.SelectAll 0
Else
MsgBox "请先选择数据集.", , "错误提示"
End If
Set lyr = Nothing
End Sub
Private Sub SelectAnnotation_Click()
Formmain.Map1.CurrentTool = miArrowTool
End Sub
Private Sub showctr_Click()
Dim layer As MapXLib.layer
For Each layer In Formmain.Map1.Layers
layer.ShowCentroids = True
Next
End Sub
Private Sub SQLQuery_Click()
FrmSQL.Show 1
End Sub
Private Sub ssa_Click()
Dim queryodbc As New OdbcQueryInfo
Dim bindlayer As New MapXLib.bindlayer
Formmain.Map1.Layers.AddServerLayer "ssa", "DSN=Spatial;HOST=spw;UUID=mapzk;UPWD=mapzk;UID=mapzk;PWD=mapzk;OSID=map", "select * from ""sloil"""
queryodbc.connectstring = "odbc;"
queryodbc.DataSource = "spatial"
queryodbc.SqlQuery = "select * from ""MAPZK"".""sloil2"""
bindlayer.LayerType = miBindLayerTypePointRef
bindlayer.RefColumn1 = "Jh"
'bindlayer.RefColumn2 = "country"
bindlayer.ReferenceLayer = "ssa"
bindlayer.Filespec = "c:\sloil8.tab"
Set ds = Formmain.Map1.Datasets.Add(miDataSetODBC, queryodbc, "oil", "sl", , bindlayer)
End Sub
Private Sub SymbolAnnotation_Click()
Formmain.Map1.CurrentTool = miSymbolTool
End Sub
Private Sub symbolrotate_Click()
Dim angle As Integer
Dim ftr As New MapXLib.Feature
angle = Val(InputBox("请输入旋转角度", "输入"))
Set ftr = Formmain.Map1.Layers(ToolBars.Combo1.Text).Selection.Item(1)
ftr.Style.SymbolType = miSymbolTypeTrueTypeFont
ftr.Style.SymbolFont.name = "Map Symbols"
ftr.Style.SymbolFont.Size = 48
ftr.Style.SymbolCharacter = 66
ftr.Style.SymbolFontRotation = angle
Formmain.Map1.Layers(ToolBars.Combo1.Text).AddFeature ftr
End Sub
Private Sub symbolstyle_Click()
Formmain.Map1.DefaultStyle.PickSymbol
End Sub
Private Sub TextAnnotation_Click()
Formmain.Map1.CurrentTool = miTextTool
End Sub
Private Sub textstyle_Click()
Formmain.Map1.DefaultStyle.PickText
End Sub
Private Sub UnboundType_Click()
Dim lyr As MapXLib.layer
Dim objBindLayer As New MapXLib.bindlayer
Dim fldFieldsToAdd As New MapXLib.Fields
Dim bZipcodeLayer As Boolean
Dim zipdata(10, 3) As String
'zip code points layer
'You may have to change the path, if you installed MapX somewhere else
bZipcodeLayer = False
For Each lyr In Map1.Layers
If lyr.name = "US 5 Digit Zipcode Centers" Then
bZipcodeLayer = True
Exit For
End If
Next
If bZipcodeLayer = False Then
Set lyr = Map1.Layers.Add("ZipCodes.tab", 1)
lyr.Visible = False
End If
'Set up an array of data
'Each zipcode has a numeric field associated with it
'(Zipcodes need to be string fields [for zips like 00123, if stored as a number, it would erase leading zeros and be '123']
zipdata(1, 1) = "12054"
zipdata(1, 2) = 27391
zipdata(1, 3) = "Jim"
zipdata(2, 1) = "12304"
zipdata(2, 2) = 38943
zipdata(2, 3) = "John"
zipdata(3, 1) = "12210"
zipdata(3, 2) = 45663
zipdata(3, 3) = "Tanya"
zipdata(4, 1) = "12180"
zipdata(4, 2) = 22447
zipdata(4, 3) = "Carlene"
zipdata(5, 1) = "12012"
zipdata(5, 2) = 66152
zipdata(5, 3) = "Jeff"
zipdata(6, 1) = "10116"
zipdata(6, 2) = 444534
zipdata(6, 3) = "Guy"
zipdata(7, 1) = "22514"
zipdata(7, 2) = 65690
zipdata(7, 3) = "Christine"
zipdata(8, 1) = "48109"
zipdata(8, 2) = 45663
zipdata(8, 3) = "Andy"
zipdata(9, 1) = "92180"
zipdata(9, 2) = 98454
zipdata(9, 3) = "Brother"
zipdata(10, 1) = "90210"
zipdata(10, 2) = 58945
zipdata(10, 3) = "Dick"
'Create the fields collection to bring in
fldFieldsToAdd.Add "Zip", "Zip", miAggregationIndividual, miTypeString
fldFieldsToAdd.Add "Sales", "Sales", miAggregationSum, miTypeNumeric
fldFieldsToAdd.Add "SalesRep", "SalesRep", miAggregationIndividual, miTypeString
'Set up the BindLayerObject
With objBindLayer
.LayerName = "Zip Data" 'The name of the new layer
.LayerType = miBindLayerTypePointRef 'Match up my data against a map layer
.RefColumn1 = 1 'The column in my data that contains matchable field (zipcode)
.ReferenceLayer = "US 5 Digit Zipcode Centers" 'The map layer to bind to
End With
'Add the dataset
Map1.Datasets.Add miDataSetUnbound, Nothing, "Zip Data", "Zip", , objBindLayer, fldFieldsToAdd
'Change the symbol style
'Call ChangeSymbol(Map1.Layers("Zip Data"), "Courier", 88, 255, 22)
End Sub
Private Sub UnselectAll_Click()
Dim lyr As MapXLib.layer
If Trim(ToolBars.Combo1.Text) <> "" Then
Set lyr = Formmain.Map1.Layers.Item(ToolBars.Combo1.Text)
lyr.Selection.ClearSelection
Else
MsgBox "请先选择数据集.", , "错误提示"
End If
Set lyr = Nothing
End Sub