ESRI ArcGIS应用与开发 [分享]DBA的VB+AO的开发总结zz||做专业的GIS技术交流论坛

gis

管理员

注册日期2003-07-16
发帖数15951
QQ
铜币25345枚
威望15368点
贡献值0点
银元0个

10楼^#

发布于：2005-06-01 17:50

工具条的功能是在一个Layer上面画方框，并保存方框到刚才创建的那个Polygon表里面，提供 ZoomIn/ZoomOut/FullExtent/DrawRectangle/SelectTool功能。 该工具条在Dialog中与AO一起使用。 画方框的功能是从例子RasterEditor中摘抄的
 
Option Explicit
"Windows API functions to capture mouse and keyboard "input to a window when the mouse is outside the window Private Declare Function SetCapture Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function GetCapture Lib "user32" () As Long Private Declare Function ReleaseCapture Lib "user32" () As Long
Private m_pHook As New Hook Private WithEvents ActiveViewEvents As Map Private m_bInUse As Boolean Private m_pBitmap As IPictureDisp Private m_pEnvFeedback As INewEnvelopeFeedback
Private Const VK_CONTROL = ;H11 Private Const VK_SHIFT = ;H10 Private Declare Function GetKeyState% Lib "user32" (ByVal nKey%)
Implements ICommand Implements ITool
" Constant used by the Error handler function - DO NOT REMOVE Const c_ModuleFileName = "clsDrawRectangle.cls" " Package Name Const MeName = "DrawRectagle Command"
Private Sub Class_Initialize() On Error GoTo Error_h 　　Set m_pBitmap = LoadResPicture("DrawRectangle", vbResBitmap) 　　Exit Sub Error_h: 　　HandleError True, "Class_Initialize " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Sub
Private Sub Class_Terminate() On Error GoTo Error_h 　　Set m_pHook = Nothing 　　Exit Sub Error_h: 　　HandleError True, "Class_Terminate " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Sub
Private Property Get ICommand_Enabled() As Boolean 　　ICommand_Enabled = True End Property
Private Property Get ICommand_Checked() As Boolean 　　ICommand_Checked = False End Property Private Property Get ICommand_Name() As String 　　ICommand_Name = "Draw Rectangle" End Property
Private Property Get ICommand_Caption() As String 　　ICommand_Caption = "Draw Rectangle" End Property
Private Property Get ICommand_Tooltip() As String 　　ICommand_Tooltip = "Draw Rectangle" End Property Private Property Get ICommand_Message() As String 　　ICommand_Message = "Draw Rectangle" End Property
Private Property Get ICommand_HelpFile() As String
End Property Private Property Get ICommand_HelpContextID() As Long
End Property Private Property Get ICommand_Bitmap() As esriCore.OLE_HANDLE On Error GoTo Error_h 　　ICommand_Bitmap = m_pBitmap 　　Exit Property Error_h: 　　HandleError True, "ICommand_Bitmap " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Property
Private Property Get ICommand_Category() As String On Error GoTo Error_h 　　ICommand_Category = "Rectangle Tools" 　　Exit Property Error_h: 　　HandleError True, "ICommand_Category " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Property
Private Sub ICommand_OnCreate(ByVal Hook As Object) On Error GoTo Error_h 　　m_pHook.Hook = Hook 　　Exit Sub Error_h: 　　HandleError True, "ICommand_OnCreate " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Sub
Private Sub ICommand_OnClick()
End Sub
Private Property Get ITool_Cursor() As esriCore.OLE_HANDLE On Error GoTo Error_h 　　ITool_Cursor = LoadResPicture("Digitize", vbResCursor) 　　Exit Property Error_h: 　　HandleError True, "ITool_Cursor " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Property
Private Function ITool_Deactivate() As Boolean
End Function
Private Function ITool_OnContextMenu(ByVal X As Long, ByVal Y As Long) As Boolean
End Function
Private Sub ITool_OnDblClick()
End Sub
Private Sub ITool_OnKeyDown(ByVal keyCode As Long, ByVal Shift As Long) 　　" Delete Rectangle when Delete Key pressed 　　If keyCode = vbKeyDelete Then 　　　　Dim pGC As IGraphicsContainer 　　　　Set pGC = m_pHook.FocusMap 　　　　pGC.DeleteAllElements 　　 　　　　Dim pActiveView As esriCore.IActiveView 　　　　Set pActiveView = GetMap(m_pHook) 　　　　pActiveView.Refresh 　　End If End Sub
Private Sub ITool_OnKeyUp(ByVal keyCode As Long, ByVal Shift As Long) 　　Exit Sub End Sub
Private Sub ITool_OnMouseDown(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long) On Error GoTo Error_h 　　" Get ActiveView 　　Dim pActiveView As esriCore.IActiveView 　　Set pActiveView = GetMap(m_pHook) 　　" Clear the old one 　　Dim pGC As IGraphicsContainer 　　Set pGC = m_pHook.FocusMap 　　pGC.DeleteAllElements 　　" Create FeedBack Rectangle 　　Set m_pEnvFeedback = New NewEnvelopeFeedback 　　Set m_pEnvFeedback.Display = pActiveView.ScreenDisplay 　　m_pEnvFeedback.Start pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(X, Y) 　　m_bInUse = True 　　Exit Sub Error_h: 　　HandleError True, "ITool_OnMouseDown " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Sub
Private Sub ITool_OnMouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long) On Error GoTo Error_h 　　Dim pActiveView As esriCore.IActiveView 　　Set pActiveView = GetMap(m_pHook) 　　 　　If (m_bInUse And Not m_pEnvFeedback Is Nothing) Then 　　　　m_pEnvFeedback.MoveTo pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(X, Y) 　　End If 　　Exit Sub Error_h: 　　HandleError True, "ITool_OnMouseMove " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Sub
Private Sub ITool_OnMouseUp(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long) On Error GoTo Error_h 　　If (Not m_bInUse) Then Exit Sub 　　 　　Dim pGeom As IGeometry 　　Dim pAv As IActiveView 　　Dim pElement As IElement 　　Dim pGC As IGraphicsContainer 　　Dim pGCSelect As IGraphicsContainerSelect 　　 　　Set pAv = m_pHook.FocusMap 　　Set pGeom = m_pEnvFeedback.Stop 　　　　　　 　　Dim pActiveView As esriCore.IActiveView 　　Set pActiveView = GetMap(m_pHook) 　　　　　　　 　　If (pGeom.IsEmpty) Then 　　　　　　Set pGeom = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(X, Y) 　　　　　　Exit Sub 　　End If 　　　　　　 　　Set pElement = CreateSelectionBox(pGeom) 　　Set pGC = pAv 　　pGC.AddElement pElement, 0 　　 　　Set pGCSelect = pGC 　　pGCSelect.UnselectAllElements 　　pGCSelect.SelectElement pElement 　　pAv.Refresh 　　　　　　 　　Set m_pEnvFeedback = Nothing 　　m_bInUse = False 　　Exit Sub Error_h: 　　HandleError True, "ITool_OnMouseUp " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Sub
Private Sub ITool_Refresh(ByVal hDC As esriCore.OLE_HANDLE)
End Sub
Public Function CreateSelectionBox(pGeom As IGeometry) As IElement On Error GoTo Error_h 　　Dim pElement As IElement 　　Set pElement = New RectangleElement 　　" Set Symbology 　　Dim pSymbol As ISimpleFillSymbol 　　Set pSymbol = New SimpleFillSymbol 　　 　　Dim pLineSymbol As ISimpleLineSymbol 　　Set pLineSymbol = New SimpleLineSymbol 　　" Set Line Color and Width , Can be changed as need 　　Dim pLineColor As IColor 　　Set pLineColor = New RgbColor 　　pLineColor.RGB = RGB(255, 255, 255) 　　pLineColor.Transparency = 255 　　 　　pLineSymbol.Color = pLineColor 　　pLineSymbol.Width = 2 　　pLineSymbol.Style = esriSLSSolid 　　　　　　　　 　　pSymbol.Outline = pLineSymbol 　　pSymbol.Style = esriSFSNull 　　" Create Box enclosed the rectangle you draw 　　Dim pFillShapeElement As IFillShapeElement 　　Set pFillShapeElement = pElement 　　pFillShapeElement.Symbol = pSymbol 　　pElement.Geometry = pGeom 　　Set CreateSelectionBox = pElement 　　Exit Function Error_h: 　　HandleError True, "CreateSelectionBox " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Function

GIS麦田守望者，期待与您交流。

举报回复喜欢评分

chenyongfeng

路人甲

注册日期2004-08-31
发帖数29
QQ
铜币184枚
威望0点
贡献值0点
银元0个

加关注写私信

11楼^#

发布于：2005-06-08 19:35

赶卸<img src="images/post/smile/dvbbs/em01.gif" /><img src="images/post/smile/dvbbs/em02.gif" /><img src="images/post/smile/dvbbs/em04.gif" /><img src="images/post/smile/dvbbs/em08.gif" /><img src="images/post/smile/dvbbs/em05.gif" />

眼小聚光

举报回复喜欢评分

wrbwf 路人甲注册日期2003-12-01 发帖数944 QQ 铜币2516枚威望0点贡献值0点银元0个加关注写私信	12楼^# 发布于：2005-06-14 15:29 <img src="images/post/smile/dvbbs/em01.gif" />
	举报回复(0) 喜欢(0) 评分

wfoegl 路人甲注册日期2004-12-31 发帖数360 QQ 铜币4枚威望0点贡献值0点银元0个加关注写私信	13楼^# 发布于：2005-06-15 13:23 <img src="images/post/smile/dvbbs/em02.gif" /><img src="images/post/smile/dvbbs/em02.gif" /><img src="images/post/smile/dvbbs/em02.gif" /><img src="images/post/smile/dvbbs/em02.gif" /><img src="images/post/smile/dvbbs/em02.gif" />
	举报回复(0) 喜欢(0) 评分

wfoegl 路人甲注册日期2004-12-31 发帖数360 QQ 铜币4枚威望0点贡献值0点银元0个加关注写私信	14楼^# 发布于：2005-06-27 23:36 <img src="images/post/smile/dvbbs/em01.gif" /><img src="images/post/smile/dvbbs/em01.gif" /><img src="images/post/smile/dvbbs/em01.gif" />
	举报回复(0) 喜欢(0) 评分

wrbwf 路人甲注册日期2003-12-01 发帖数944 QQ 铜币2516枚威望0点贡献值0点银元0个加关注写私信	15楼^# 发布于：2005-06-29 14:53 <img src="images/post/smile/dvbbs/em06.gif" />
	举报回复(0) 喜欢(0) 评分

chrisliu1105

路人甲

注册日期2005-06-25
发帖数1
QQ
铜币105枚
威望0点
贡献值0点
银元0个

加关注写私信

16楼^#

发布于：2005-06-30 21:12

举报回复喜欢评分

suppergg 路人甲注册日期2004-10-25 发帖数60 QQ 铜币256枚威望0点贡献值0点银元0个加关注写私信	17楼^# 发布于：2005-07-08 15:20 <P>辛苦了</P><img src="images/post/smile/dvbbs/em05.gif" />
	举报回复(0) 喜欢(0) 评分

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