MO程序汇总.docx
- 文档编号:28366154
- 上传时间:2023-07-10
- 格式:DOCX
- 页数:29
- 大小:74.24KB
MO程序汇总.docx
《MO程序汇总.docx》由会员分享,可在线阅读,更多相关《MO程序汇总.docx(29页珍藏版)》请在冰豆网上搜索。
MO程序汇总
Legend
Map
StatusBar
通用—声明:
OptionExplicit '强制声明
DimfullPathAsString
DimfileNameAsString
DimwrkdirAsString
DimdbconAsNewMapObjects2.DataConnection
DimcurLayerAsNewMapObjects2.MapLayer
DimptAsNewMapObjects2.Point
DimlnAsNewMapObjects2.Line
PublicselectPtAsNewMapObjects2.Point
DimtabledesAsNewMapObjects2.TableDesc
'返回一个数据表描述对象(TableDesc),这个对象描述一个记录集的字段特征
DimisMapEditingAsBoolean
DimrstAsNewMapObjects2.Recordset
DimchooseMethodAsInteger
DimselectObjAsMapObjects2.Recordset
DimtoleranceAsSingle
Form_Load:
PrivateSubForm_Load()
lgdmap.setMapSourceMap1 '使用图例控件的setMapSource方法将控件和一个地图对象关联
lgdmap.LoadLegendTrue '激活图例的显示
isMapEditing=False
lgdmap.ShowAllLegend
Map1.TrackingLayer.SymbolCount=6
WithMap1.TrackingLayer.Symbol(0) 'with使得后面直接使用"."
.SymbolType=moPointSymbol
.Style=moTriangleMarker '0 点
.Color=moRed '1 画线
.Size=8 '2 线的结果
EndWith '3 画面
'4 面的结果
WithMap1.TrackingLayer.Symbol
(1)
.SymbolType=moLineSymbol
.Color=moRed
.Size=3
EndWith
WithMap1.TrackingLayer.Symbol
(2)
.SymbolType=moLineSymbol
.Style=moSolidLine
.Color=moBlue
.Size=4
EndWith
WithMap1.TrackingLayer.Symbol(3)
.SymbolType=moFillSymbol
.Style=moDiagonalCrossFill
.Color=moRed
.OutlineColor=moLightYellow
EndWith
WithMap1.TrackingLayer.Symbol(4)
.SymbolType=moFillSymbol
.Style=moGrayFill
.Color=moGreen
.OutlineColor=moRed
EndWith
EndSub
PrivateSublgdmap_AfterSetLayerVisible(IndexAsInteger,isVisibleAsBoolean)
Map1.Refresh ‘刷新地图
EndSub
PrivateSubMap1_MouseMove(ButtonAsInteger,ShiftAsInteger,XAsSingle,YAsSingle)
Setpt=Map1.ToMapPoint(X,Y)
' sbr1.Panels
(1)=pt.X
' sbr1.Panels
(2)=pt.Y
DimcurXAsDouble
DimcurYAsDouble
curX=pt.X
curY=pt.Y
curX=Left(curX,InStr(curX,".")+3)
curY=Left(curY,InStr(curY,".")+3)
sbr1.Panels
(1)=curX
sbr1.Panels
(2)=curY
EndSub
添加文件:
PrivateSubcmdopenfile_Click()
CmnDlg.Filter="esrishapfile(*.shp)|*.shp"
CmnDlg.ShowOpen
fullPath=CmnDlg.fileName
DimiAsInteger
IffullPath<>""Then
i=InStrRev(fullPath,"\")
wrkdir=Left(fullPath,i-1)
fileName=Right(fullPath,Len(fullPath)-i)
dbcon.Database=wrkdir
curLayer.GeoDataset=dbcon.FindGeoDataset(fileName)
Map1.Layers.AddcurLayer
SetcurLayer=Nothing
Map1.Refresh
lgdmap.LoadLegend
Else
MsgBox"请选择图层"
EndIf
EndSub
添加多文件:
PrivateSubcmdopenmultifile_Click()
DimworkDirAsString
DimdbconAsNewMapObjects2.DataConnection
DimfullPathAsString
DimfileNameAsString
DimcurlyrAsNewMapObjects2.MapLayer
CmnDlg.Filter="ESRIshapefile(*.shp)|*.shp|CADfile(*.dwg)|*.dwg"
'cmnDlg.Flags=&H200Or&H1000Or&H80000
CmnDlg.Flags=cdlOFNAllowMultiselectOrcdlOFNExplorer
CmnDlg.ShowOpen
fullPath=CmnDlg.fileName
Dims()AsString
DimiAsInteger
DimjAsInteger
s=Split(fullPath,Chr$(0)) 'Chr$(0)是一个空位字符,表示字符串的结束
workDir=s(0)
IfworkDir<>""Then
dbcon.Database=workDir
EndIf
IffullPath<>""Then
j=UBound(s)
Fori=1Toj
Ifs(i)<>""Then
curlyr.GeoDataset=dbcon.FindGeoDataset(s(i))
Map1.Layers.Addcurlyr
Setcurlyr=Nothing
Else
MsgBox"找不到文件",vbCritical
EndIf
Next
lgdmap.LoadLegend
Map1.Refresh
Else
MsgBox"找不到文件",vbCritical
EndIf
EndSub
放大:
PrivateSubcmdZoomIn_Click()
Map1.MousePointer=moZoomIn
EndSub
PrivateSubMap1_MouseDown(ButtonAsInteger,ShiftAsInteger,XAsSingle,YAsSingle) ‘加黑部分为以下case语句部分公有程序段
IfButton=vbLeftButtonThen
DimrecAsNewMapObjects2.Rectangle
SelectCaseMap1.MousePointer
CasemoZoomIn
Setrec=Map1.Extent
rec.ScaleRectangle0.8
Map1.Extent=rec
EndSelect
EndIf
EndSub
缩小:
PrivateSubcmdZoonOut_Click()
Map1.MousePointer=moZoomOut
EndSub
CasemoZoomOut
Setrec=Map1.Extent
rec.ScaleRectangle1.2
Map1.Extent=rec
漫游:
PrivateSubcmdPan_Click()
Map1.MousePointer=moPan
EndSub
CasemoPan
Map1.Pan
放缩:
PrivateSubcmdfangsuo_Click()
Map1.MousePointer=moZoom
EndSub
CasemoZoom
Map1.Extent=Map1.TrackRectangle
显示全图:
PrivateSubcmdfull_Click()
Map1.Extent=Map1.FullExtent
EndSub
打开图像文件:
PrivateSubcmdopenimg_Click()
DimimglayerAsNewMapObjects2.ImageLayer
DimdbconAsNewMapObjects2.DataConnection
CmnDlg.Filter="图像文件(*.img)|*.img|Tiff文件(*.tiff)|*.tif|图片文件(*.bmp)|*.bmp"
CmnDlg.ShowOpen
fullPath=CmnDlg.fileName
IffullPath<>""Then
imglayer.File=fullPath
Map1.Layers.Addimglayer
Setimglayer=Nothing
lgdmap.LoadLegend
Else
MsgBox"请选择文件"
EndIf
EndSub
移除图层:
PrivateSubCmdRemovelyr_Click()
Iflgdmap.getActiveLayer<>-1Then
IfMap1.Layers.Count>0Then
Map1.Layers.Remove(lgdmap.getActiveLayer)
lgdmap.LoadLegend
EndIf
Else
MsgBox"请选择移除的图层!
"
EndIf
EndSub
移除所有图层:
PrivateSubCmdRemoveAll_Click()
Map1.Layers.Clear
lgdmap.LoadLegend
EndSub
测距:
PrivateSubRuler_Click()
Map1.MousePointer=moCross
EndSub
CasemoCross
Setln=Map1.TrackLine
sbr1.Panels(3)=ln.Length
点选择和多边形选择:
PrivateSubCmdSelect_Click() '点选择
chooseMethod=1
Map1.MousePointer=moArrow
EndSub
PrivateSubcmdSelectPolygon_Click() '多边形选择
chooseMethod=2
Map1.MousePointer=moArrow
EndSub
CasemoArrow
SelectCasechooseMethod
DimrGvtAsNewMapObjects2.GeoEvent
Case1 '点选择
SetselectPt=Map1.ToMapPoint(X,Y)
tolerance=Map1.ToMapDistance(50#)
SetcurLayer=Map1.Layers(lgdmap.getActiveLayer)
SetselectObj=curLayer.SearchByDistance(pt,tolerance,"")
Map1.TrackingLayer.ClearEvents
DimicountAsInteger
selectObj.MoveFirst
Foricount=0ToselectObj.Count-1
IfNotselectObj.EOFThen
IfcurLayer.shapeType=moShapeTypeLineThen
SetrGvt=Map1.TrackingLayer.AddEvent(selectObj("shape").Value,4)
EndIf
IfcurLayer.shapeType=moShapeTypePointThen
SetrGvt=Map1.TrackingLayer.AddEvent(selectObj("shape").Value,3)
EndIf
IfcurLayer.shapeType=moShapeTypePolygonThen
SetrGvt=Map1.TrackingLayer.AddEvent(selectObj("shape").Value,5)
EndIf
EndIf
Next
selectObj.MoveNext
Case2 '多边形选择
DimselectPlgAsNewMapObjects2.Polygon
SetselectPlg=Map1.TrackPolygon
SetcurLayer=Map1.Layers(lgdmap.getActiveLayer)
SetselectObj=curLayer.SearchShape(selectPlg,moAreaIntersect,"") '""空串
selectObj.MoveFirst
Map1.TrackingLayer.RefreshTrue
EndSelect
'hdc句柄
PrivateSubMap1_AfterTrackingLayerDraw(ByValhDCAsstdole.OLE_HANDLE)
IfNotselectObjIsNothingThen
DimobsysAsNewMapObjects2.Symbol
Withobsys
.Color=moRed
.Size=3
EndWith
Map1.DrawShapeselectObj,obsys
EndIf
EndSub
简单查询:
PrivateSubCmdIdentify_Click()
Map1.MousePointer=moIdentify
EndSub
CasemoIdentify
SetselectPt=Map1.ToMapPoint(X,Y)
'ToMapPoint转换为一个(X、Y)位置的坐标设备
FrmIdentify.Show
MSFlexGrid
FrmIdentify 程序
OptionExplicit
DimcurLayerAsNewMapObjects2.MapLayer
DimtolAsDouble
DimrstAsMapObjects2.Recordset
PrivateSubForm_Load()
SetcurLayer=Form1.Map1.Layers(Form1.lgdmap.getActiveLayer)
tol=Form1.Map1.ToMapDistance(50#) '容差
Setrst=curLayer.SearchByDistance(Form1.selectPt,tol,"")
rst.MoveFirst
DoWhileNotrst.EOF
Form1.Map1.FlashShaperst("shape").Value,3 '闪烁指定地物3下
rst.MoveNext
Loop
DimtabledesAsNewMapObjects2.TableDesc
Settabledes=rst.TableDesc
MSFlexGrid1.Cols=rst.Fields.Count-2
MSFlexGrid1.Rows=rst.Count+1
MSFlexGrid1.Row=0
DimiAsInteger
DimjAsLong
rst.MoveFirst
Fori=0ToMSFlexGrid1.Cols-1
MSFlexGrid1.Col=i
IfNotIsNull(tabledes.FieldName(i))Then
MSFlexGrid1.Text=tabledes.FieldName(i)
EndIf
Next
Forj=1Torst.Count
MSFlexGrid1.Row=j
Fori=0ToMSFlexGrid1.Cols-1
MSFlexGrid1.Col=i
IfNotIsNull(rst.Fields(tabledes.FieldName(i)).ValueAsString)Then
MSFlexGrid1.Text=rst.Fields(tabledes.FieldName(i)).ValueAsString
EndIf
Next
rst.MoveNext
Next
EndSub
打开属性表:
PrivateSubCmdOpenAttribute_Click()
Frmattribute.Show
EndSub
MSFlexGrid
Frmattribute 程序:
FormLoad:
OptionEx
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- MO 程序 汇总