[分享]vb+mo实现新建,打开,保存图层的功能

<P>'新建图层<br>Dim gs As New GeoDataset<br>Dim dc As New MapObjects2.DataConnection<br>'打开图层</P>
<P>Public lar As New MapObjects2.MapLayer '定义了全局图层变量<br>Public selpnt As MapObjects2.Point   '定义了一个点对象<br>Public recs As MapObjects2.Recordset '定义了一个记录集<br>Public lars As MapObjects2.Layers '定义一个图层集<br>Public strcondition As String '定义了一个全局的字符串</P>
<P><br>'<br>'新建图层<br>'<br></P>
<P>Private Sub mue_newline_Click()<br>Dim name As String<br>On Error Resume Next<br>'定义一个通用对话框commondg1 ，并邻接数据库<br>CommonDg2.Filter = "shape|*.shp"<br>CommonDg2.ShowSave<br>CommonDg2.InitDir = Left$(CommonDg2.fileName, Len(CommonDg2.fileName) - Len(CommonDg2.FileTitle) - 1)<br>'Me.newlarpath.Text = CommonDg1.fileName<br>dc.Database = Left$(CommonDg2.fileName, Len(CommonDg2.fileName) - Len(CommonDg2.FileTitle) - 1)<br>name = Left$(CommonDg2.FileTitle, Len(CommonDg2.FileTitle) - 4)<br></P>
<P>Dim shaptype As MapObjects2.ShapeTypeConstants<br>Dim tdese As New TableDesc<br>tdese.FieldCount = 2<br>tdese.FieldName(0) = "ID"<br>tdese.FieldName(1) = "name"<br>tdese.FieldType(0) = moDouble<br>tdese.FieldType(1) = moString<br>tdese.FieldLength(0) = 15<br>tdese.FieldLength(1) = 10<br>Set gs = dc.AddGeoDataset(name, moShapeTypeLine, tdese)<br>If gs Is Nothing Then Exit Sub<br>Dim ly As New MapLayer<br>ly.Symbol.Color = moRed<br>ly.GeoDataset = gs<br>ly.name = name<br>Map1.Layers.Add ly<br>Map2.Layers.Add ly<br>Me.legend1.setMapSource Map1<br>Me.legend1.LoadLegend True<br>Map1.Refresh<br>Map2.Refresh<br>End Sub</P>
<P>Private Sub mue_newpoint_Click()<br>Dim name As String<br>On Error Resume Next<br>'定义一个通用对话框commondg1 ，并邻接数据库<br>CommonDg2.Filter = "shape|*.shp"<br>CommonDg2.ShowOpen<br>CommonDg2.InitDir = Left$(CommonDg2.fileName, Len(CommonDg2.fileName) - Len(CommonDg2.FileTitle) - 1)<br>'Me.newlarpath.Text = CommonDg1.fileName<br>dc.Database = Left$(CommonDg2.fileName, Len(CommonDg2.fileName) - Len(CommonDg2.FileTitle) - 1)<br>name = Left$(CommonDg2.FileTitle, Len(CommonDg2.FileTitle) - 4)<br></P>
<P>Dim shaptype As MapObjects2.ShapeTypeConstants<br>Dim tdese As New TableDesc<br>tdese.FieldCount = 2<br>tdese.FieldName(0) = "ID"<br>tdese.FieldName(1) = "name"<br>tdese.FieldType(0) = moDouble<br>tdese.FieldType(1) = moString<br>tdese.FieldLength(0) = 15<br>tdese.FieldLength(1) = 10</P>
<P>Set gs = dc.AddGeoDataset(name, moShapeTypePoint, tdese)<br>If gs Is Nothing Then Exit Sub<br>Dim ly As New MapLayer<br>ly.Symbol.Color = moRed<br>ly.GeoDataset = gs<br>ly.name = name<br>Map1.Layers.Add ly<br>Map2.Layers.Add ly<br>Me.legend1.setMapSource Map1<br>Me.legend1.LoadLegend True<br>Map1.Refresh<br>Map2.Refresh<br>End Sub</P>
<P>Private Sub mue_newpolygen_Click()<br>Dim name As String<br>On Error Resume Next<br>'定义一个通用对话框commondg1 ，并邻接数据库<br>CommonDg2.Filter = "shape|*.shp"<br>CommonDg2.ShowSave<br>CommonDg2.InitDir = Left$(CommonDg2.fileName, Len(CommonDg2.fileName) - Len(CommonDg2.FileTitle) - 1)<br>'Me.newlarpath.Text = CommonDg1.fileName<br>dc.Database = Left$(CommonDg2.fileName, Len(CommonDg2.fileName) - Len(CommonDg2.FileTitle) - 1)<br>name = Left$(CommonDg2.FileTitle, Len(CommonDg2.FileTitle) - 4)<br></P>
<P>Dim shaptype As MapObjects2.ShapeTypeConstants<br>Dim tdese As New TableDesc<br>tdese.FieldCount = 2<br>tdese.FieldName(0) = "ID"<br>tdese.FieldName(1) = "name"<br>tdese.FieldType(0) = moDouble<br>tdese.FieldType(1) = moString<br>tdese.FieldLength(0) = 15<br>tdese.FieldLength(1) = 10</P>
<P>Set gs = dc.AddGeoDataset(name, moShapeTypePolygon, tdese)<br>If gs Is Nothing Then Exit Sub</P>
<P>Dim ly As New MapLayer<br>ly.Symbol.Color = moRed<br>ly.GeoDataset = dc.FindGeoDataset(name)<br>ly.name = name<br>Map1.Layers.Add ly<br>Map2.Layers.Add ly<br>Me.legend1.setMapSource Map1<br>Me.legend1.LoadLegend True<br>Map1.Refresh<br>Map2.Refresh<br>End Sub<br></P>
<P>'<br>'<br>'打开图层<br>'<br>'<br>Private Sub mue_fileopen_Click()<br>Dim fileName As String '定义文件名字<br>Dim filepath As String '定义文件路径<br><br>On Error Resume Next<br>'定义一个通用对话框commondg1 ，并邻接数据库<br>CommonDg1.Filter = "(shape)*.shp|*.shp|(all files)|*.*"<br>CommonDg1.ShowOpen<br>CommonDg1.InitDir = Left$(CommonDg1.fileName, Len(CommonDg1.fileName) - Len(CommonDg1.FileTitle) - 1)<br>dbconnction.Database = Left$(CommonDg1.fileName, Len(CommonDg1.fileName) - Len(CommonDg1.FileTitle) - 1)<br>dbconnction.Connect<br>Set lar.GeoDataset = dbconnction.FindGeoDataset(Left$(CommonDg1.FileTitle, Len(CommonDg1.FileTitle) - 4))<br>'lar.Symbol.Color = moMagenta<br>'将图层添加到map1,map2中<br>Map1.Layers.Add lar<br>Map2.Layers.Add lar</P>
<P>Set lar = Nothing<br>'将map1,map2 刷新<br>Map1.Refresh<br>Map2.Refresh<br>'设置图例的源为map1,加载图例<br>legend1.setMapSource Map1<br>legend1.LoadLegend True<br>Set lars = Map1.Layers<br>'设置列表框list1 的初始值<br>Dim ofiled As MapObjects2.Field<br>If Not lars Is Nothing Then<br>For Each ofiled In Map1.Layers(0).Records.Fields<br>List1.AddItem ofiled.name</P>
<P>Next<br>End If<br>'begin with id num<br>List1.ListIndex = 0<br>End Sub</P>
<P>'<br>'保存图层<br>'<br>Private Sub mue_filesave_Click()<br>  CommonDialog1.Filter = "ESRI Shapefiles (*.shp)|*.shp"<br>  CommonDialog1.DefaultExt = ".shp"<br>  CommonDialog1.ShowSave<br>  If Len(CommonDialog1.fileName) = 0 Then Exit Sub<br>  <br>  Screen.MousePointer = vbHourglass<br>  ExportToShapefile CommonDialog1.fileName<br>  Screen.MousePointer = vbDefault<br>End Sub</P>
<P>'''''</P>
<P>Sub ExportToShapefile(pathName As String)<br>  Dim fileName As String, dirName As String<br>  SplitPath pathName, dirName, fileName<br>  Dim dc As New MapObjects2.DataConnection<br>  dc.Database = dirName<br>  If Not dc.Connect Then Exit Sub   'bogus dataConnection<br>  <br>  Dim tDesc As New MapObjects2.TableDesc<br>  Dim gs As GeoDataset<br>  Set gs = dc.AddGeoDataset(fileName, moPolygon, tDesc)<br>  If gs Is Nothing Then Exit Sub    'invalid file<br>   <br>  Dim layer As New MapObjects2.MapLayer<br>  Set layer.GeoDataset = gs<br>  Set recs = layer.Records<br>  Set shpFld = recs.Fields("Shape")<br>  <br>  ' write out the polygons<br>  For i = 0 To UBound(m_polys) - 1<br>    recs.AddNew<br>    shpFld.Value = m_polys(i)<br>    recs.Update<br>  Next i<br>End Sub</P>

<P>'''少了一个函数!</P>
<P>Sub SplitPath(pathName As String, dirName As String, fileName As String)<BR>  ' find the last occurance of a file separator<BR>  ' in the path<BR>  Dim nCurPos As Integer, nLastPos As Integer<BR>  Do<BR>    nLastPos = nCurPos<BR>    nCurPos = InStr(nCurPos + 1, pathName, "\")<BR>  Loop Until nCurPos = 0</P>
<P>  If nLastPos = 0 Then Exit Sub</P>
<P>  Dim fname As String<BR>  dirName = Left(pathName, nLastPos - 1)<BR>  fname = Right(pathName, Len(pathName) - nLastPos)<BR>  fileName = Left(fname, Len(fname) - 4)<BR>End Sub</P>

<P>需要</P>
<P>顶住</P>

顶住,谢谢楼主<img src="images/post/smile/dvbbs/em01.gif" /><img src="images/post/smile/dvbbs/em02.gif" />

菜鸟谢LZ

<TABLE fixed; WORD-BREAK: break-all" height="85%" width="95%" align=center border=0>

<TR>
<TD 9pt; LINE-HEIGHT: 12pt" vAlign=top width=* height="100%"><IMG src="http://www.gisempire.com/bbs/Skins/Default/topicface/face1.gif"> <B></B><BR>菜鸟谢LZ</TD></TR></TABLE><img src="images/post/smile/dvbbs/em05.gif" />

xiexie  

呵呵，谢谢楼主，正好有用