|
阅读：1696回复：3
关于AO+VB的例子
<P>我是刚学AE的,想实现个基本的放大功能,想法是在VB中调用事先做好的DLL,做好后是CLS格式的.</P>
<P>现在想在VB下调用这个功能.想整合进来.</P> <P>但是VB里的代码不知道怎么写,VB中就是一个MAPCONTROL和COMMAND,单击COMMAND实现放大功能.</P> <P>DLL里的代码我已经给出,请问VB 中的COMMAND_CLICK代码怎么写.</P> <P>还请个位大侠帮帮忙.</P> <P>Option Explicit</P> <P>Implements ICommand<BR>Implements ITool</P> <P>Private m_pApp As IApplication<BR>Private m_pFeedbackEnv As INewEnvelopeFeedback<BR>Private m_pPoint As IPoint<BR>Private m_bIsMouseDown As Boolean<BR>Private m_pActiveView As IActiveView<BR> </P> <P>Private Property Get ICommand_Bitmap() As esriSystem.OLE_HANDLE</P> <P> ICommand_Bitmap = frmResources.imlBitmaps.ListImages(1).Picture</P> <P>End Property</P> <P>Private Property Get ICommand_Caption() As String</P> <P> ICommand_Caption = "Zoom In"</P> <P>End Property</P> <P>Private Property Get ICommand_Category() As String</P> <P> ICommand_Category = "Developer Samples"</P> <P>End Property</P> <P>Private Property Get ICommand_Checked() As Boolean</P> <P> ICommand_Checked = False</P> <P>End Property</P> <P>Private Property Get ICommand_Enabled() As Boolean</P> <P> ICommand_Enabled = True</P> <P>End Property</P> <P>Private Property Get ICommand_HelpContextID() As Long</P> <P> ' No help implemented for this tool</P> <P>End Property</P> <P>Private Property Get ICommand_HelpFile() As String</P> <P> ' No help implemented for this tool</P> <P>End Property</P> <P>Private Property Get ICommand_Message() As String</P> <P> ICommand_Message = "Zooms the dislay to area selected by user"</P> <P>End Property</P> <P>Private Property Get ICommand_Name() As String</P> <P> ICommand_Name = "Developer Samples_Zoom In"</P> <P>End Property</P> <P>Private Sub ICommand_OnClick()</P> <P>End Sub</P> <P>Private Sub ICommand_OnCreate(ByVal hook As Object)</P> <P> Set m_pApp = hook</P> <P>End Sub</P> <P>Private Property Get ICommand_Tooltip() As String</P> <P> ICommand_Tooltip = "Zoom In"</P> <P>End Property</P> <P>Private Property Get ITool_Cursor() As esriSystem.OLE_HANDLE</P> <P> If Not m_bIsMouseDown Then '(m_pFeedbackEnv Is Nothing) Then ' not in the middle of rubber banding<BR> ITool_Cursor = frmResources.imlIcons.ListImages(1).Picture<BR> Else<BR> ITool_Cursor = frmResources.imlIcons.ListImages(2).Picture<BR> End If</P> <P>End Property</P> <P>Private Function ITool_Deactivate() As Boolean</P> <P> ITool_Deactivate = True</P> <P>End Function</P> <P>Private Function ITool_OnContextMenu(ByVal X As Long, ByVal Y As Long) As Boolean</P> <P>End Function</P> <P>Private Sub ITool_OnDblClick()</P> <P>End Sub</P> <P>Private Sub ITool_OnKeyDown(ByVal keyCode As Long, ByVal Shift As Long)</P> <P>End Sub</P> <P>Private Sub ITool_OnKeyUp(ByVal keyCode As Long, ByVal Shift As Long)</P> <P>End Sub</P> <P>Private Sub ITool_OnMouseDown(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)</P> <P> ' Get the ActiveView from the document<BR> Dim pMxDoc As IMxDocument<BR> Set pMxDoc = m_pApp.Document<BR> Set m_pActiveView = pMxDoc.FocusMap<BR> <BR> 'Store current point, set mousedown flag<BR> Set m_pPoint = m_pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(X, Y)<BR> m_bIsMouseDown = True</P> <P>End Sub</P> <P>Private Sub ITool_OnMouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)<BR> <BR> If Not m_bIsMouseDown Then Exit Sub<BR> <BR> ' Create a rubber banding box, if it hasn't been created already<BR> If (m_pFeedbackEnv Is Nothing) Then<BR> Set m_pFeedbackEnv = New NewEnvelopeFeedback<BR> Set m_pFeedbackEnv.Display = m_pActiveView.ScreenDisplay<BR> m_pFeedbackEnv.Start m_pPoint<BR> End If<BR> <BR> 'Store current point, and use to move rubberband<BR> Set m_pPoint = m_pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(X, Y)<BR> m_pFeedbackEnv.MoveTo m_pPoint</P> <P>End Sub</P> <P>Private Sub ITool_OnMouseUp(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)</P> <P> Dim pPrevExt As IEnvelope<BR> Set pPrevExt = m_pActiveView.Extent<BR> <BR> ' If user did not drag an envelope,<BR> ' calculate extent as 0.5 times current<BR> Dim pNewExt As IEnvelope<BR> If (m_pFeedbackEnv Is Nothing) Then<BR> 'Zoom in on clicked point<BR> Dim pPrevClone As IClone, pNewClone As IClone<BR> Set pPrevClone = pPrevExt<BR> Set pNewClone = pPrevClone.Clone<BR> <BR> Set pNewExt = pNewClone<BR> pNewExt.Expand 0.5, 0.5, True<BR> Else<BR> 'Get the rubberbanded envelope<BR> Set pNewExt = m_pFeedbackEnv.Stop<BR> Set m_pFeedbackEnv = Nothing<BR> End If<BR> <BR> ' Ensure that the Envelope created by the user is sensible, if<BR> ' it is set the map extents to be that envelope<BR> If Not (pNewExt Is Nothing) Then<BR> 'Weed out ridiculous zoom requests<BR> 'Check for zero width or height<BR> Dim dNewWidth As Double, dNewHeight As Double<BR> dNewWidth = pNewExt.Width<BR> dNewHeight = pNewExt.Height<BR> If ((dNewWidth > 0) And (dNewHeight > 0)) Then<BR> Dim pFullExt As IEnvelope<BR> Set pFullExt = m_pActiveView.FullExtent<BR> Dim dFullWidth As Double, dFullHeight As Double<BR> dFullWidth = pFullExt.Width<BR> dFullHeight = pFullExt.Height<BR> ' apply ZoomIn only within 1 millionth of the full extent<BR> Dim xzoomLimit As Double<BR> xzoomLimit = dFullWidth / 1000000<BR> Dim yzoomLimit As Double<BR> yzoomLimit = dFullHeight / 1000000<BR> If ((xzoomLimit < dNewWidth) And (yzoomLimit < dNewHeight)) Then<BR> m_pActiveView.Extent = pNewExt<BR> m_pActiveView.Refresh<BR> End If<BR> End If<BR> End If<BR> <BR> 'reset rubberband and mousedown state<BR> Set m_pFeedbackEnv = Nothing<BR> m_bIsMouseDown = False</P> <P>End Sub</P> <P>Private Sub ITool_Refresh(ByVal hDC As esriSystem.OLE_HANDLE)</P> <P>End Sub<BR></P> |
|
|
1楼#
发布于：2007-04-06 17:55
好像不是我要的结果啊
|
|
|
2楼#
发布于：2007-04-06 12:30
<P>' Copyright 2006 ESRI<BR>'<BR>' All rights reserved under the copyright laws of the United States<BR>' and applicable international laws, treaties, and conventions.<BR>'<BR>' You may freely redistribute and use this sample code, with or<BR>' without modification, provided you include the original copyright<BR>' notice and use restrictions.<BR>'<BR>' See use restrictions at /arcgis/developerkit/userestrictions.</P>
<P>Imports ESRI.ArcGIS.Carto<BR>Imports ESRI.ArcGIS.GeomeTry<BR>Imports ESRI.ArcGIS.Controls<BR>Imports ESRI.ArcGIS.Display<BR>Imports ESRI.ArcGIS.ADF.BaseClasses<BR>Imports ESRI.ArcGIS.ADF.CATIDs<BR>Imports System.Runtime.InteropServices</P> <P><ComClass(ZoomIn.ClassId, ZoomIn.InterfaceId, ZoomIn.EventsId)> _<BR>Public NotInheritable Class ZoomIn<BR> Inherits BaseTool</P> <P>#Region "COM GUIDs"<BR> ' These GUIDs provide the COM identity for this class <BR> ' and its COM interfaces. If you change them, existing <BR> ' clients will no longer be able to access the class.<BR> Public Const ClassId As String = "DAEDFD5C-7CFE-4EB2-AC50-E62CFEB0EABA"<BR> Public Const InterfaceId As String = "2EA141CC-94C4-48C7-912F-4786422D362A"<BR> Public Const EventsId As String = "1582A9D9-AE09-432F-8DB2-9BE2A0030B96"<BR>#End Region<BR>#Region "COM Registration Function(s)"<BR> <ComRegisterFunction(), ComVisibleAttribute(False)> _<BR> Public Shared Sub RegisterFunction(ByVal registerType As Type)<BR> ' Required for ArcGIS Component Category Registrar support<BR> ArcGISCategoryRegistration(registerType)</P> <P> 'Add any COM registration code after the ArcGISCategoryRegistration() call</P> <P> End Sub</P> <P> <ComUnregisterFunction(), ComVisibleAttribute(False)> _<BR> Public Shared Sub UnregisterFunction(ByVal registerType As Type)<BR> ' Required for ArcGIS Component Category Registrar support<BR> ArcGISCategoryUnregistration(registerType)</P> <P> 'Add any COM unregistration code after the ArcGISCategoryUnregistration() call</P> <P> End Sub</P> <P>#Region "ArcGIS Component Category Registrar generated code"<BR> ''' <summary><BR> ''' Required method for ArcGIS Component Category registration -<BR> ''' Do not modify the contents of this method with the code editor.<BR> ''' </summary><BR> Private Shared Sub ArcGISCategoryRegistration(ByVal registerType As Type)<BR> Dim regKey As String = String.Format("HKEY_CLASSES_ROOT\CLSID\{{{0}}}", registerType.GUID)<BR> ControlsCommands.Register(regKey)</P> <P> End Sub<BR> ''' <summary><BR> ''' Required method for ArcGIS Component Category unregistration -<BR> ''' Do not modify the contents of this method with the code editor.<BR> ''' </summary><BR> Private Shared Sub ArcGISCategoryUnregistration(ByVal registerType As Type)<BR> Dim regKey As String = String.Format("HKEY_CLASSES_ROOT\CLSID\{{{0}}}", registerType.GUID)<BR> ControlsCommands.Unregister(regKey)</P> <P> End Sub</P> <P>#End Region<BR>#End Region</P> <P> Private m_pHookHelper As IHookHelper<BR> Private m_feedBack As INewEnvelopeFeedback<BR> Private m_point As IPoint<BR> Private m_isMouseDown As Boolean<BR> Private m_zoomInCur As System.Windows.Forms.Cursor<BR> Private m_moveZoomInCur As System.Windows.Forms.Cursor</P> <P> ' A creatable COM class must have a Public Sub New() <BR> ' with no parameters, otherwise, the class will not be <BR> ' registered in the COM registry and cannot be created <BR> ' via CreateObject.<BR> Public Sub New()<BR> MyBase.New()</P> <P> MyBase.m_category = "Sample_Pan_VBNET/Zoom"<BR> MyBase.m_caption = "Zoom In"<BR> MyBase.m_message = "Zooms the Display In By Rectangle or Single Click"<BR> MyBase.m_toolTip = "Zoom In"<BR> MyBase.m_name = "Sample_Pan/Zoom_Zoom In"</P> <P> Dim res() As String = GetType(ZoomIn).Assembly.GetManifestResourceNames()<BR> If res.GetLength(0) > 0 Then<BR> MyBase.m_bitmap = New System.Drawing.Bitmap(GetType(ZoomIn).Assembly.GetManifestResourceStream("PanZoomVBNET.ZoomIn.bmp"))<BR> End If<BR> m_pHookHelper = New HookHelperClass<BR> End Sub</P> <P> Public Overrides Sub OnCreate(ByVal hook As Object)<BR> m_pHookHelper.Hook = hook<BR> m_zoomInCur = New System.Windows.Forms.Cursor(GetType(ZoomIn).Assembly.GetManifestResourceStream("PanZoomVBNET.ZoomIn.cur"))<BR> m_moveZoomInCur = New System.Windows.Forms.Cursor(GetType(ZoomIn).Assembly.GetManifestResourceStream("PanZoomVBNET.MoveZoomIn.cur"))<BR> End Sub</P> <P> Public Overrides ReadOnly Property Enabled() As Boolean<BR> Get<BR> If m_pHookHelper.FocusMap Is Nothing Then<BR> Return False<BR> End If</P> <P> Return True<BR> End Get<BR> End Property</P> <P> Public Overrides Sub OnMouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Integer, ByVal Y As Integer)</P> <P> If m_pHookHelper.ActiveView Is Nothing Then<BR> Return<BR> End If</P> <P> 'If the active view is a page layout<BR> If TypeOf m_pHookHelper.ActiveView Is IPageLayout Then<BR> 'Create a point in map coordinates<BR> Dim pPoint As IPoint = CType(m_pHookHelper.ActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(X, Y), IPoint)</P> <P> 'Get the map if the point is within a data frame<BR> Dim pMap As IMap = m_pHookHelper.ActiveView.HitTestMap(pPoint)</P> <P> If pMap Is Nothing Then<BR> Return<BR> End If</P> <P> 'Set the map to be the page layout's focus map<BR> If Not pMap Is m_pHookHelper.FocusMap Then<BR> m_pHookHelper.ActiveView.FocusMap = pMap<BR> m_pHookHelper.ActiveView.PartialRefresh(esriViewDrawPhase.esriViewGraphics, Nothing, Nothing)<BR> End If<BR> End If<BR> 'Create a point in map coordinates<BR> Dim pActiveView As IActiveView = CType(m_pHookHelper.FocusMap, IActiveView)<BR> m_point = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(X, Y)</P> <P> m_isMouseDown = True<BR> End Sub</P> <P> Public Overrides Sub OnMouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Integer, ByVal Y As Integer)<BR> If Not m_isMouseDown Then<BR> Return<BR> End If</P> <P> 'Get the focus map<BR> Dim pActiveView As IActiveView = CType(m_pHookHelper.FocusMap, IActiveView)</P> <P> 'Start an envelope feedback<BR> If m_feedBack Is Nothing Then<BR> m_feedBack = New NewEnvelopeFeedbackClass<BR> m_feedBack.Display = pActiveView.ScreenDisplay<BR> m_feedBack.Start(m_point)<BR> End If</P> <P> 'Move the envelope feedback<BR> m_feedBack.MoveTo(pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(X, Y))<BR> End Sub</P> <P> Public Overrides Sub OnMouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Integer, ByVal Y As Integer)</P> <P> If Not m_isMouseDown Then<BR> Return<BR> End If</P> <P> 'Get the focus map<BR> Dim pActiveView As IActiveView = CType(m_pHookHelper.FocusMap, IActiveView)</P> <P> 'If an envelope has not been tracked<BR> Dim pEnvelope As IEnvelope</P> <P> If m_feedBack Is Nothing Then<BR> 'Zoom in from mouse click<BR> pEnvelope = pActiveView.Extent<BR> pEnvelope.Expand(0.5, 0.5, True)<BR> pEnvelope.CenterAt(m_point)<BR> Else<BR> 'Stop the envelope feedback<BR> pEnvelope = m_feedBack.Stop()</P> <P> 'Exit if the envelope height or width is 0<BR> If pEnvelope.Width = 0 Or pEnvelope.Height = 0 Then<BR> m_feedBack = Nothing<BR> m_isMouseDown = False<BR> End If<BR> End If</P> <P> 'Set the new extent<BR> pActiveView.Extent = pEnvelope</P> <P> 'Refresh the active view<BR> pActiveView.Refresh()<BR> m_feedBack = Nothing<BR> m_isMouseDown = False<BR> End Sub</P> <P> Public Overrides Sub OnKeyDown(ByVal keyCode As Integer, ByVal Shift As Integer)<BR> If (m_isMouseDown) Then<BR> If (keyCode = 27) Then<BR> m_isMouseDown = False<BR> m_feedBack = Nothing<BR> m_pHookHelper.ActiveView.PartialRefresh(esriViewDrawPhase.esriViewForeground, Nothing, Nothing)<BR> End If<BR> End If<BR> End Sub</P> <P> Public Overrides ReadOnly Property Cursor() As Integer<BR> Get<BR> If (m_isMouseDown) Then<BR> Return m_moveZoomInCur.Handle.ToInt32()<BR> Else<BR> Return m_zoomInCur.Handle.ToInt32()<BR> End If<BR> End Get<BR> End Property<BR>End Class</P> <P><BR> </P> |
|
|
3楼#
发布于：2007-04-06 10:49
<P>我在COMMAND的里面这么写,可是有错误,大家帮我改下还行.谢谢帮忙了.</P>
<P>Private Sub Command1_Click()<BR>Dim a As ICommand<BR>Dim b As ITool<BR>Set a = New ZoomInTool.clsZoomIn<BR>a.OnCreate MapControl1.Object'它提示这个地方有错说类型不匹配.<BR>Set b = a<BR>Set MapControl1.CurrentTool = b<BR>Set a = Nothing<BR>Set b = Nothing<BR>End Sub<BR></P> |
|