Micky

路人甲

注册日期2006-02-27
发帖数18
QQ
铜币158枚
威望0点
贡献值0点
银元0个

加关注写私信

阅读：1944回复：9

[灌水]mo

楼主^#

更多发布于：2006-07-05 22:02

DBGRID

 Dim selection As New MapObjects2.Recordset Dim result As New MapObjects2.Polygon
 Dim i As Variant
Dim str As String Dim str1 As String Dim os As String Dim lastresult As MapObjects2.Polygon
Dim pt As New MapObjects2.Point
Dim poly As New MapObjects2.Polygon
Dim sel As MapObjects2.Recordset
 Private Sub Command1_Click()
 For Each i In Me.DBGrid1.SelBookmarks Data1.Recordset.Bookmark = i str1 = Me.Data1.Recordset.Fields(3).Name ; "=" ; Me.Data1.Recordset.Fields(3).Value str = str ; " " ; os ; " " ; str1 os = "Or" Next Set selection = Map1.Layers("states").SearchExpression(str) ' Dim rs As New GeoEvent 'While Not selection.EOF ' Set result = selection.Fields("shape").Value ' If Not lastresult Is Nothing Then ' Set lastresult = result.Union(lastresult) ' Else ' Set lastresult = result ' End If ' selection.MoveNext 'Wend
 Do While Not selection.EOF Set result = selection.Fields("shape").Value If lastresult Is Nothing Then Set lastresult = result Else Set lastresult = result.Union(lastresult) End If selection.MoveNext Loop '
 Map1.FlashShape lastresult, 2 Set lastresult = Nothing str = "" os = "" End Sub
Private Sub Form_Load() Me.Data1.DatabaseName = App.Path + "\..\" + "数据\MEXICO" Me.Data1.RecordSource = "States" str = "" End Sub
Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim str2 As Single Data1.Recordset.MoveFirst Set pt = Map1.ToMapPoint(X, Y) Set sel = Map1.Layers("states").SearchByDistance(pt, 0.01, "") If sel.EOF Then MsgBox ("没有点击到要素，请重新选择") Else Set poly = sel.Fields("shape").Value Map1.FlashShape poly, 3 
 str2 = sel.Fields("state_id").Value Do While Not Data1.Recordset.EOF If str2 <> Data1.Recordset.Fields(3).Value Then Data1.Recordset.MoveNext Else Exit Do End If Loop
 End If End Sub

喜欢0 评分0

举报回复

Micky

路人甲

注册日期2006-02-27
发帖数18
QQ
铜币158枚
威望0点
贡献值0点
银元0个

加关注写私信

1楼^#

发布于：2006-07-05 22:05

chapter 5 AddEvent

Dim pt As MapObjects2.Point 'Dim sym As MapObjects2.Symbol Dim shp As Object Dim rect As MapObjects2.Rectangle

Private Sub Form_Load() Map1.TrackingLayer.SymbolCount = 4 With Map1.TrackingLayer.Symbol(0) .SymbolType = moPointSymbol .Color = moRed .Size = 20 .Style = moTrueTypeMarker .Font = "esri transportation ; municipal" End With End Sub
Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) If Option1 Then Set pt = Map1.ToMapPoint(X, Y) Map1.TrackingLayer.Symbol(0).CharacterIndex = 102 Map1.TrackingLayer.AddEvent pt, 0 ElseIf Option2 Then Set shp = trackshape1 ElseIf Option3 Then Set shp = trackshape2 ElseIf Option4 Then Set shp = trackshape3 End If End Sub

Private Function trackshape1() As Object Dim evPoly As New MapObjects2.GeoEvent Dim poly As New MapObjects2.Ellipse With Map1.TrackingLayer.Symbol(1) .SymbolType = moFillSymbol .Color = moYellow .Style = moGrayFill End With Set poly = Map1.TrackCircle Set trackshape1 = poly Set evPoly = Map1.TrackingLayer.AddEvent(poly, 1) 
End Function
 Private Function trackshape2() As Object Dim evPoly As New MapObjects2.GeoEvent Dim poly As New MapObjects2.Polygon With Map1.TrackingLayer.Symbol(2) .SymbolType = moFillSymbol ' .Color = moGreen '.Style = moGrayFill End With Set poly = Map1.TrackPolygon Set trackshape2 = poly Set evPoly = Map1.TrackingLayer.AddEvent(poly, 2) 
End Function
 Private Function trackshape3() As Object Dim evPoly As New MapObjects2.GeoEvent Dim poly As New MapObjects2.Rectangle With Map1.TrackingLayer.Symbol(3) .SymbolType = moFillSymbol .Color = moBlue .Style = moGrayFill End With Set poly = Map1.TrackRectangle Set trackshape3 = poly Set evPoly = Map1.TrackingLayer.AddEvent(poly, 3) 
End Function

举报回复喜欢评分

Micky

路人甲

注册日期2006-02-27
发帖数18
QQ
铜币158枚
威望0点
贡献值0点
银元0个

加关注写私信

2楼^#

发布于：2006-07-05 22:08

chapter 6 

Dim rect As New MapObjects2.Rectangle Dim lyr As New MapObjects2.MapLayer Dim interShape As New MapObjects2.Polygon Dim resultpoly As New MapObjects2.Polygon Dim Rec As MapObjects2.Recordset Dim poly As New MapObjects2.Polygon Dim target As Object Dim str1 As String Dim str2 As String Dim lr As String Dim ud As String Dim hei As String Dim wid As String Dim r As MapObjects2.Rectangle Dim area As Single Const A = 10000
 Private Sub Command1_Click() Set lyr = Map1.Layers("states") Set Rec = lyr.SearchExpression(str1) Set interShape = Rec.Fields("Shape").Value Map1.FlashShape interShape, 3 End Sub
Private Sub Command2_Click() Map1.TrackingLayer.RemoveEvent List1.ListIndex List1.RemoveItem List1.ListIndex End Sub
Private Sub Command3_Click() Map1.TrackingLayer.ClearEvents List1.Clear End Sub
Private Sub Command4_Click() Map1.TrackingLayer.ClearEvents Set poly = target.Buffer(str2) Map1.TrackingLayer.AddEvent poly, 4 Set r = poly.Extent End Sub
Private Sub Command5_Click() poly.Offset lr, ud Map1.TrackingLayer.ClearEvents Map1.TrackingLayer.AddEvent poly, 4 End Sub
Private Sub Command6_Click() r.Inset hei, wid Map1.TrackingLayer.AddEvent r, 4 End Sub
Private Sub Form_Load() Label1.Caption = "请输入你要找的图形的ID(1-32)：" legend1.setMapSource Map1 legend1.LoadLegend True Map1.TrackingLayer.SymbolCount = 5 With Map1.TrackingLayer.Symbol(0) .SymbolType = moFillSymbol .Color = moRed .Style = 0 End With With Map1.TrackingLayer.Symbol(1) .SymbolType = 2 .Style = 0 .Color = moBlue End With With Map1.TrackingLayer.Symbol(2) .SymbolType = 2 .Style = 0 .Color = moYellow End With With Map1.TrackingLayer.Symbol(3) .SymbolType = 2 .Style = 0 .Color = moPurple End With With Map1.TrackingLayer.Symbol(4) .SymbolType = 2 .Style = 7 .Color = moPurple End With End Sub
Private Sub legend1_AfterSetLayerVisible(Index As Integer, isVisible As Boolean) Map1.Refresh End Sub
Private Sub List1_Click() Dim foundEvt As MapObjects2.GeoEvent Set foundEvt = Map1.TrackingLayer.FindEvent(List1.List(List1.ListIndex)) If Not foundEvt Is Nothing Then Map1.FlashShape foundEvt.Shape, 2 ' foundEvt.SymbolIndex = 1 Else MsgBox "Event not found" End If End Sub
Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim Geopoly As MapObjects2.GeoEvent Set rect = Map1.TrackRectangle If Option1 Then Set resultpoly = rect.Intersect(interShape) area = Format(resultpoly.area * A, "0.00") Set Geopoly = Map1.TrackingLayer.AddEvent(resultpoly, 0) Geopoly.Tag = "交对象" ; " 面积是" ; area ; "平方公里" List1.AddItem Geopoly.Tag Map1.FlashShape resultpoly, 2 ElseIf Option2 Then Set resultpoly = rect.Union(interShape) area = Format(resultpoly.area * A, "0.00") Set Geopoly = Map1.TrackingLayer.AddEvent(resultpoly, 1) Geopoly.Tag = "并对象" ; " 面积是" ; area ; "平方公里" List1.AddItem Geopoly.Tag Map1.FlashShape resultpoly, 2 ElseIf Option3 Then Set resultpoly = rect.Difference(interShape) area = Format(resultpoly.area * A, "0.00") Set Geopoly = Map1.TrackingLayer.AddEvent(resultpoly, 2) Geopoly.Tag = "差对象" ; " 面积是" ; area ; "平方公里" List1.AddItem Geopoly.Tag Map1.FlashShape resultpoly, 2 ElseIf Option4 Then Set resultpoly = rect.Xor(interShape) area = Format(resultpoly.area * A, "0.00") Set Geopoly = Map1.TrackingLayer.AddEvent(resultpoly, 3) Geopoly.Tag = "异或对象" ; " 面积是" ; area ; "平方公里" List1.AddItem Geopoly.Tag Map1.FlashShape resultpoly, 2 End If Dim pt As MapObjects2.Point Set lyr = Map1.Layers(0) Option1 = False Option2 = False Option3 = False Option4 = False Set pt = Map1.ToMapPoint(X, Y) Set Rec = lyr.SearchByDistance(pt, 0.2, "") If Not Rec.EOF Then Set target = Rec.Fields("shape").Value Map1.FlashShape target, 3 End If End Sub
Private Sub Text1_Change() str1 = "STATE_ID=" ; Text1.Text End Sub
Private Sub Text2_Change() str2 = Val(Text2.Text) End Sub
Private Sub Text3_Change() lr = Val(Text3.Text) End Sub
Private Sub Text4_Change() ud = Val(Text4.Text) End Sub
Private Sub Text5_Change() hei = Val(Text5.Text) End Sub
Private Sub Text6_Change() wid = Val(Text6.Text) End Sub

举报回复喜欢评分

Micky

路人甲

注册日期2006-02-27
发帖数18
QQ
铜币158枚
威望0点
贡献值0点
银元0个

加关注写私信

3楼^#

发布于：2006-07-05 22:08

drawshape

Dim p As MapObjects2.Point Dim pts As MapObjects2.Points Dim pts2 As MapObjects2.Points Dim g_line As MapObjects2.Line Dim eli As MapObjects2.Ellipse Dim rect As MapObjects2.Rectangle Dim poly As MapObjects2.Polygon Dim sym As New Symbol Dim sym2 As New Symbol Dim sym3 As New Symbol Dim tsym As New TextSymbol Dim str As Integer

Private Sub Map1_AfterTrackingLayerDraw(ByVal hDC As stdole.OLE_HANDLE) If Option1 Then If Not pts Is Nothing Then With sym .Style = moCircleMarker .Color = moRed .SymbolType = moPointSymbol .Size = 5 End With Map1.DrawShape pts, sym If Check1 Then Map1.DrawText Text2.Text, pts, tsym End If End If ElseIf Option2 Then If Not g_line Is Nothing Then sym2.Color = moGreen Map1.DrawShape pts2, sym2 If pts2.Count > 1 Then Map1.DrawShape g_line, sym2 If Check1 Then Map1.DrawText Text2.Text, g_line, tsym End If End If End If ElseIf Option3 Then With sym3 .SymbolType = moFillSymbol .Color = moYellow .Style = moDiagonalCrossFill End With If Not eli Is Nothing Then Map1.DrawShape eli, sym3 End If ElseIf Option4 Then With sym3 .SymbolType = moFillSymbol .Color = moPurple .Style = moDiagonalCrossFill End With If Not rect Is Nothing Then Map1.DrawShape rect, sym3 If Check1 Then Map1.DrawText Text2.Text, rect, tsym End If End If ElseIf Option5 Then With sym3 .SymbolType = moFillSymbol .Color = moOlive .Style = moDiagonalCrossFill End With If Not poly Is Nothing Then Map1.DrawShape poly, sym3 End If ElseIf Option6 Then If Not pts Is Nothing Then With sym .Color = moRed .SymbolType = moPointSymbol .Size = 20 .Font = fnt .Style = moTrueTypeMarker .CharacterIndex = str End With Map1.DrawShape pts, sym If Check1 Then Map1.DrawText Text2.Text, pts, tsym End If End If End If End Sub
Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) If Option1 Then Set pts = New MapObjects2.Points Set p = Map1.ToMapPoint(X, Y) pts.Add p ElseIf Option6 Then Set pts = New MapObjects2.Points Set p = Map1.ToMapPoint(X, Y) pts.Add p ElseIf Option2 Then Dim p1 As MapObjects2.Point If g_line Is Nothing Then Set g_line = New MapObjects2.Line End If If pts2 Is Nothing Then Set pts2 = New MapObjects2.Points End If Set p1 = Map1.ToMapPoint(X, Y) pts2.Add p1 If pts2.Count = 1 Then g_line.Parts.Add pts2 Set pts2 = g_line.Parts(0) End If Map1.TrackingLayer.Refresh True ElseIf Option3 Then Set eli = Map1.TrackCircle ElseIf Option4 Then Set rect = Map1.TrackRectangle ElseIf Option5 Then Set poly = Map1.TrackPolygon End If If Not Option2 Then Set pts2 = Nothing Set g_line = Nothing End If Map1.TrackingLayer.Refresh True End Sub
Private Sub Text1_Change() str = Val(Text1.Text) End Sub

举报回复喜欢评分

Micky

路人甲

注册日期2006-02-27
发帖数18
QQ
铜币158枚
威望0点
贡献值0点
银元0个

加关注写私信

4楼^#

发布于：2006-07-05 22:39

Private Sub refreshscale() '显示比例尺函数 ScaleBar1.MapExtent.MaxX = Map1.Extent.Right ScaleBar1.MapExtent.MinX = Map1.Extent.Left ScaleBar1.MapExtent.MaxY = Map1.Extent.Bottom ScaleBar1.MapExtent.MinY = Map1.Extent.Top ScaleBar1.PageExtent.MinX = Map1.Left / Screen.TwipsPerPixelX ScaleBar1.PageExtent.MinY = Map1.Top / Screen.TwipsPerPixelY ScaleBar1.PageExtent.MaxX = (Map1.Left + Map1.Width) / Screen.TwipsPerPixelX ScaleBar1.PageExtent.MaxY = (Map1.Top + Map1.Height) / Screen.TwipsPerPixelY ScaleBar1.Refresh StatusBar1.Panels(1).Text = "比例 1 : " ; Format$(ScaleBar1.RFScale, "###,###,###,###,###") End Sub

举报回复喜欢评分

Micky 路人甲注册日期2006-02-27 发帖数18 QQ 铜币158枚威望0点贡献值0点银元0个加关注写私信	5楼^# 发布于：2006-07-05 22:42 Private Sub Map1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)<BR> '当在map1上移动鼠标,statusbar中的x,y值随之改变<BR> Dim pt As New MapObjects2.Point<BR> Set pt = Map1.ToMapPoint(x, y)<BR> StatusBar1.Panels(2).Text = "x=" ; pt.x<BR> StatusBar1.Panels(3).Text = "y=" ; pt.y<BR>End Sub
	举报回复(0) 喜欢(0) 评分

Micky

路人甲

注册日期2006-02-27
发帖数18
QQ
铜币158枚
威望0点
贡献值0点
银元0个

加关注写私信

6楼^#

发布于：2006-07-05 23:11

eagleye
'使Map2和Map1联动； Private Sub Map1_AfterLayerDraw(ByVal Index As Integer, ByVal canceled As Boolean, ByVal hdc As stdole.OLE_HANDLE) If Index = 0 Then Map2.TrackingLayer.Refresh True End If End Sub
'在Map2上画红色指示框； Private Sub Map2_AfterTrackingLayerDraw(ByVal hdc As stdole.OLE_HANDLE) Dim sym As New Symbol sym.OutlineColor = moRed sym.Size = 2 sym.Style = moTransparentFill Map2.DrawShape Map1.Extent, sym End Sub
'实现用Map2改变Map1的功能； Private Sub Map2_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) Dim curRectangle As MapObjects2.Rectangle Dim pt As New MapObjects2.Point '画方框改变Map1窗口 Set curRectangle = Map2.TrackRectangle Set Map1.Extent = curRectangle '点击改变Map1位置 Set pt = Map2.ToMapPoint(x, y) Map1.CenterAt pt.x, pt.y End Sub

举报回复喜欢评分

Micky

路人甲

注册日期2006-02-27
发帖数18
QQ
铜币158枚
威望0点
贡献值0点
银元0个

加关注写私信

7楼^#

发布于：2006-07-05 23:12

eagle 2
Option Explicit Dim g_feedback As DragFeedback
Private Sub Map2_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) '将点击转换为Map2上的点对象； Dim p As Point Set p = Map2.ToMapPoint(x, y) '如果点击发生在方框内，开始拖动； If Map1.Extent.IsPointIn(p) Then Set g_feedback = New DragFeedback g_feedback.DragStart Map1.Extent, Map2, x, y End If End Sub
'开始拖动方框 Private Sub Map2_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) If Not g_feedback Is Nothing Then g_feedback.DragMove x, y End If End Sub
'拖动完成，并在Map1中显示新位置； Private Sub Map2_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) If Not g_feedback Is Nothing Then Map1.Extent = g_feedback.DragFinish(x, y) Set g_feedback = Nothing End If End Sub
'左键放大，右键缩小； Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) Dim r As MapObjects2.Rectangle If Button = vbLeftButton Then Set Map1.Extent = Map1.TrackRectangle ElseIf Button = vbRightButton Then Set r = Map1.Extent r.ScaleRectangle 2 Map1.Extent = r End If End Sub
'使Map2和Map1联动； Private Sub Map1_AfterLayerDraw(ByVal Index As Integer, ByVal canceled As Boolean, ByVal hdc As stdole.OLE_HANDLE) If Index = 0 Then Map2.TrackingLayer.Refresh True End If End Sub
'在Map2上画红色指示框； Private Sub Map2_AfterTrackingLayerDraw(ByVal hdc As stdole.OLE_HANDLE) Dim sym As New Symbol sym.OutlineColor = moRed sym.Size = 2 sym.Style = moTransparentFill Map2.DrawShape Map1.Extent, sym End Sub

举报回复喜欢评分

Micky

路人甲

注册日期2006-02-27
发帖数18
QQ
铜币158枚
威望0点
贡献值0点
银元0个

加关注写私信

8楼^#

发布于：2006-07-05 23:17

Jiang
map1_mousedown事件
dim p as point
set p=map2.tomappoint(x,y)
if map1.extent.ispointin(p) then
 set g_freeback=new dragfeedback
 g_freeback.dragstart map1.extent,map2,x,y
end if
map2_mousemove
if not g_freeback is nothing then
 g_freeback.dragmove x,y
end if

map2_mouseup
if not g_freeback is nothing then
 map1.extent= g_freeback.dragfinish(x,y)
 set g_freeback=nothing
end if

set resultshape=object.intersect(shape [,extent])
set rec=map1.layer(0).searchexpression(expression)
set rec=map1.layer(0).searchbydistance(shape,误差，SQL)
set rec=layer.searchshape(shape,查找方法,SQL)

shape=rec.fields("shape").value

 
Private Sub Form_Load() Dim dc As New DataConnection Dim layer As MapLayer dc.Database = App.Path If Not dc.Connect Then MsgBox "在指定的文件夹下没找到图层数据文件！" End End If Set layer = New MapLayer Set layer.GeoDataset = dc.FindGeoDataset("States") Map1.Layers.Add layer Set layer = New MapLayer Set layer.GeoDataset = dc.FindGeoDataset("Rivers") Map1.Layers.Add layer Map1.Refresh End Sub

set layer.renderer=new labelrenderer
layer.renderer.field="NAME"
layer.renderer.allowduplicates=true
layer.renderer.symbol(0).height=0.5
map1.layers.add layer

form_load事件
legend1.setmapsource map1
legend1.loadlegend true
legend1_aftersetlayervisible()事件
map1.refresh

举报回复喜欢评分

Micky

路人甲

注册日期2006-02-27
发帖数18
QQ
铜币158枚
威望0点
贡献值0点
银元0个

加关注写私信

9楼^#

发布于：2006-07-06 09:24

<DIV v:shape="_x0000_s3074">
<DIV class=O1 style="mso-line-spacing: '110 20 0'; mso-margin-left-alt: 468; mso-char-wrap: 1; mso-kinsoku-overflow: 1">MO除了支持Shapefile外，还有Coverage、CAD、SDE等格式。 </DIV>
<DIV class=O1 style="mso-line-spacing: '110 20 0'; mso-margin-left-alt: 468; mso-char-wrap: 1; mso-kinsoku-overflow: 1"> 1 Coverage </DIV>
<DIV class=O1 style="mso-line-spacing: '110 20 0'; mso-margin-left-alt: 468; mso-char-wrap: 1; mso-kinsoku-overflow: 1"> 和加载Shapefile类似，但要在DataConnection对象的Database属性前加上限定词“[arc]”； </DIV>
<DIV class=O1 style="mso-line-spacing: '110 20 0'; mso-margin-left-alt: 468; mso-char-wrap: 1; mso-kinsoku-overflow: 1"> 点、线、面、标注类型的要素加载时，应在FindGeoDataset方法的name参数中分别加上“.Pat” 、“.Aat”、 “.Pat” 、“.Txt” 后缀。 </DIV>
<DIV class=O style="mso-line-spacing: '100 50 0'; mso-margin-left-alt: 216"> </DIV>
<DIV class=O style="mso-line-spacing: '100 50 0'; mso-margin-left-alt: 216">
<DIV v:shape="_x0000_s3074">
<DIV class=O1 style="mso-line-spacing: '110 20 0'; mso-margin-left-alt: 468; mso-char-wrap: 1; mso-kinsoku-overflow: 1"> 2 CAD </DIV>
<DIV class=O1 style="mso-line-spacing: '110 20 0'; mso-margin-left-alt: 468; mso-char-wrap: 1; mso-kinsoku-overflow: 1"> 常用的CAD文件有DXF、DWG、DGN等。和加载Shapefile类似，加载点、线、面、标注的要素类型，在DataConnection对象的Database属性前加上限定词“[CADPoint]”、 “[CADLine]”、 “[CADArea]”、 “[CADText]”； </DIV>
<DIV class=O1 style="mso-line-spacing: '110 20 0'; mso-margin-left-alt: 468; mso-char-wrap: 1; mso-kinsoku-overflow: 1"> 在FindGeoDataset方法的name参数中指明文件格式后缀，如“.Dxf”、 “.Dwg” 、“.Dgn” 。 </DIV>
<DIV class=O style="mso-line-spacing: '100 50 0'; mso-margin-left-alt: 216"></DIV></DIV></DIV></DIV>

举报回复喜欢评分

您需要登录后才可以回帖，登录或者注册

[灌水]mo

最新喜欢：