TToolBarControl导入activex dll无效

楼主^#

更多发布于：2005-11-16 16:03

arcGis开发包中带了例程，我将其中ZoomIn例程编译成ZoomInTool.dll。 然后新建工程，加入TToolBarControl,在TToolBarControl中导入ZoomInTool.dll，在TPageLayOutControl上使用时，只有光标变成 放大镜，但是却没有放大效果，这是为什么（TToolBarControl自己带的ZoomIn功能可以正常使用）？还有一点，将ZoomInTool.dll导入ArcMap.exe中却可以正常使用。

喜欢0 评分0

举报回复

mfchuke

路人甲

注册日期2005-11-16
发帖数21
QQ
铜币214枚
威望0点
贡献值0点
银元0个

加关注写私信

1楼^#

发布于：2005-11-22 10:54

求教猪头总统：我改写了一个例程(activex dll),想用于TToolBarControl,但调试是报“实时错误”，代码如下：
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
Implements ICommand Implements ITool
Private m_pHookHelper As IHookHelper 'Private m_pApp As IApplication Private m_bInUse As Boolean Private m_pLineSymbol As ILineSymbol Private m_pLinePolyline As IPolyline Private m_pTextSymbol As ITextSymbol Private m_pStartPoint As IPoint Private m_pTextPoint As IPoint
Private Sub Class_Initialize() Set m_pHookHelper = New HookHelper End Sub
Private Property Get ICommand_Bitmap() As esriSystem.OLE_HANDLE ICommand_Bitmap = frmResources.imlBitmaps.ListImages(1).Picture End Property
Private Property Get ICommand_Caption() As String ICommand_Caption = "Measure Tool" End Property
Private Property Get ICommand_Category() As String ICommand_Category = "Developer Samples" End Property
Private Property Get ICommand_Checked() As Boolean
End Property
Private Property Get ICommand_Enabled() As Boolean ICommand_Enabled = True End Property
Private Property Get ICommand_HelpContextID() As Long
End Property
Private Property Get ICommand_HelpFile() As String
End Property
Private Property Get ICommand_Message() As String ICommand_Message = "Measure Distance Tool" End Property
Private Property Get ICommand_Name() As String ICommand_Name = "Developer Samples_Measure Tool" End Property
Private Sub ICommand_OnClick()
End Sub
Private Sub ICommand_OnCreate(ByVal hook As Object) 'Set m_pApp = hook Set m_pHookHelper.hook = hook 'Set m_pApp = m_pHookHelper.hook End Sub
Private Property Get ICommand_Tooltip() As String ICommand_Tooltip = "Measure Tool" End Property
Private Property Get ITool_Cursor() As esriSystem.OLE_HANDLE ITool_Cursor = frmResources.imlBitmaps.ListImages(2).Picture End Property
Private Function ITool_Deactivate() As Boolean ' stop doing operation Set m_pTextSymbol = Nothing Set m_pTextPoint = Nothing Set m_pLinePolyline = Nothing Set m_pLineSymbol = Nothing m_bInUse = False
 ITool_Deactivate = True 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)
End Sub
Private Sub ITool_OnKeyUp(ByVal keyCode As Long, ByVal Shift As Long)
End Sub
Private Sub ITool_OnMouseDown(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long) If (m_pHookHelper.ActiveView Is Nothing) Then Exit Sub
 m_bInUse = True 'Dim pMxDoc As IMxDocument Dim pActiveView As esriCarto.IActiveView 'Set pMxDoc = m_pApp.Document 'Set pActiveView = pMxDoc.FocusMap Set pActiveView = m_pHookHelper.FocusMap 'Get point to measure distance from Set m_pStartPoint = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(X, Y) 'Start capturing mouse events SetCapture m_pHookHelper.ActiveView.ScreenDisplay.hWnd End Sub
Private Sub ITool_OnMouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long) If (Not m_bInUse) Then Exit Sub 'Dim pMxDoc As IMxDocument Dim pActiveView As esriCarto.IActiveView 'Set pMxDoc = m_pApp.Document 'Set pActiveView = pMxDoc.FocusMap Set pActiveView = m_pHookHelper.FocusMap Dim bfirstTime As Boolean If (m_pLineSymbol Is Nothing) Then bfirstTime = True 'Get current point Dim pPoint As IPoint Set pPoint = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(X, Y) pActiveView.ScreenDisplay.StartDrawing pActiveView.ScreenDisplay.hDC, -1 If bfirstTime Then Dim pRGBColor As IRgbColor Dim pSymbol As ISymbol Dim pFont As IFontDisp 'Line Symbol Set m_pLineSymbol = New SimpleLineSymbol m_pLineSymbol.Width = 2 Set pRGBColor = New RgbColor With pRGBColor .Red = 223 .Green = 223 .Blue = 223 End With m_pLineSymbol.Color = pRGBColor Set pSymbol = m_pLineSymbol pSymbol.ROP2 = esriROPXOrPen 'Text Symbol Set m_pTextSymbol = New TextSymbol m_pTextSymbol.HorizontalAlignment = esriTHACenter m_pTextSymbol.VerticalAlignment = esriTVACenter m_pTextSymbol.Size = 16 Set pSymbol = m_pTextSymbol Set pFont = m_pTextSymbol.Font pFont.Name = "Arial" pSymbol.ROP2 = esriROPXOrPen 'Create point to draw text in Set m_pTextPoint = New Point Else 'Use existing symbols and draw existing text and polyline pActiveView.ScreenDisplay.SetSymbol m_pTextSymbol pActiveView.ScreenDisplay.DrawText m_pTextPoint, m_pTextSymbol.Text pActiveView.ScreenDisplay.SetSymbol m_pLineSymbol If (m_pLinePolyline.Length > 0) Then _ pActiveView.ScreenDisplay.DrawPolyline m_pLinePolyline End If
 'Get line between from and to points, and angle for text Dim pLine As ILine Set pLine = New esriGeometry.Line pLine.PutCoords m_pStartPoint, pPoint Dim angle As Double angle = pLine.angle angle = angle * (180# / 3.14159) If ((angle > 90#) And (angle < 180#)) Then angle = angle + 180# ElseIf ((angle < 0#) And (angle < -90#)) Then angle = angle - 180# ElseIf ((angle < -90#) And (angle > -180)) Then angle = angle - 180# ElseIf (angle > 180) Then angle = angle - 180# End If
 'For drawing text, get text(distance), angle, and point Dim deltaX As Double Dim deltaY As Double Dim distance As Double deltaX = pPoint.X - m_pStartPoint.X deltaY = pPoint.Y - m_pStartPoint.Y m_pTextPoint.X = m_pStartPoint.X + deltaX / 2# m_pTextPoint.Y = m_pStartPoint.Y + deltaY / 2# m_pTextSymbol.angle = angle distance = Round(Sqr((deltaX * deltaX) + (deltaY * deltaY)), 3) m_pTextSymbol.Text = "[" ; distance ; "]" 'Draw text pActiveView.ScreenDisplay.SetSymbol m_pTextSymbol pActiveView.ScreenDisplay.DrawText m_pTextPoint, m_pTextSymbol.Text 'Get polyline with blank space for text Dim pPolyLine As IPolyline Set pPolyLine = New Polyline Dim pSegColl As ISegmentCollection Set pSegColl = pPolyLine pSegColl.AddSegment pLine Set m_pLinePolyline = GetSmashedLine(pActiveView.ScreenDisplay, m_pTextSymbol, m_pTextPoint, pPolyLine) 'Draw polyline pActiveView.ScreenDisplay.SetSymbol m_pLineSymbol If (m_pLinePolyline.Length > 0) Then _ pActiveView.ScreenDisplay.DrawPolyline m_pLinePolyline pActiveView.ScreenDisplay.FinishDrawing
End Sub
Private Sub ITool_OnMouseUp(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long) If (Not m_bInUse) Then Exit Sub m_bInUse = False If (m_pLineSymbol Is Nothing) Then Exit Sub 'Stop capturing mouse events If GetCapture = m_pHookHelper.ActiveView.ScreenDisplay.hWnd Then ReleaseCapture End If
 'Dim pMxDoc As IMxDocument Dim pActiveView As esriCarto.IActiveView 'Set pMxDoc = m_pApp.Document 'Set pActiveView = pMxDoc.FocusMap Set pActiveView = m_pHookHelper.FocusMap 'Draw measure line and text pActiveView.ScreenDisplay.StartDrawing pActiveView.ScreenDisplay.hDC, -1 pActiveView.ScreenDisplay.SetSymbol m_pTextSymbol pActiveView.ScreenDisplay.DrawText m_pTextPoint, m_pTextSymbol.Text pActiveView.ScreenDisplay.SetSymbol m_pLineSymbol If (m_pLinePolyline.Length > 0) Then pActiveView.ScreenDisplay.DrawPolyline m_pLinePolyline pActiveView.ScreenDisplay.FinishDrawing Set m_pTextSymbol = Nothing Set m_pTextPoint = Nothing Set m_pLinePolyline = Nothing Set m_pLineSymbol = Nothing End Sub
Private Sub ITool_Refresh(ByVal hDC As esriSystem.OLE_HANDLE)
End Sub
Private Function GetSmashedLine(pDisplay As IScreenDisplay, pTextSymbol As ISymbol, pPoint As IPoint, pPolyLine As IPolyline) As IPolyline 'Returns a Polyline with a blank space for the text to go in Dim pSmashed As IPolyline Dim pBoundary As IPolygon Set pBoundary = New Polygon pTextSymbol.QueryBoundary pDisplay.hDC, pDisplay.DisplayTransformation, pPoint, pBoundary Dim pTopo As ITopologicalOperator Set pTopo = pBoundary Dim pIntersect As IPolyline
 '下面这个函数报错 Set pIntersect = pTopo.Intersect(pPolyLine, esriGeometry1Dimension) 
 Set pTopo = pPolyLine Set GetSmashedLine = pTopo.Difference(pIntersect) End Function

请猪头总统帮忙分析一下，谢谢

举报回复喜欢评分

gis

管理员

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

加关注写私信

2楼^#

发布于：2005-11-17 14:25

<DIV class=quote>以下是引用mfchuke在2005-11-17 13:50:14的发言： 
谢谢猪头总统，我根据你的提示在例程中找到了相关代码，现在问题解决了。
另外我用的是delphi，代码转换时有点麻烦。主程序用delphi+AO,activex dll还是用vb。</DIV>
调用基本上是没什么问题的，只是vb的编译方式你得好好看看哦：）

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

举报回复喜欢评分

mfchuke 路人甲注册日期2005-11-16 发帖数21 QQ 铜币214枚威望0点贡献值0点银元0个加关注写私信	3楼^# 发布于：2005-11-17 13:50 <P>谢谢猪头总统，我根据你的提示在例程中找到了相关代码，现在问题解决了。</P> <P>另外我用的是delphi，代码转换时有点麻烦。主程序用delphi+AO,activex dll还是用vb。</P>
	举报回复(0) 喜欢(0) 评分

gis

管理员

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

加关注写私信

4楼^#

发布于：2005-11-17 11:25

下面这个可以用在toolbarcontrol上，只是一个类，其他的自己想象了
Option Explicit
 Private m_pHookHelper As IHookHelper
Private m_frmLayer As frmLayer Private m_pBitmap As IPictureDisp Private WithEvents m_pActiveViewEvents As Map
Implements ICommand ' Constant used by the Error handler function - DO NOT REMOVE Const c_ModuleFileName = "clsLayers.cls"

Private Function GetMap() As esriCarto.IMap On Error GoTo ErrorHandler
 Set GetMap = m_pHookHelper.FocusMap
 Exit Function ErrorHandler: HandleError False, "GetMap " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Function
Private Sub Class_Initialize() On Error GoTo ErrorHandler
 Set m_frmLayer = New frmLayer Set m_pHookHelper = New HookHelper Set m_pBitmap = LoadResPicture("Layers", vbResBitmap)
 Exit Sub ErrorHandler: HandleError True, "Class_Initialize " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Sub
Private Sub Class_Terminate() On Error GoTo ErrorHandler
 Set m_frmLayer.Map = Nothing Unload m_frmLayer Set m_frmLayer = Nothing Set m_pBitmap = Nothing Set m_pHookHelper = Nothing 
 Exit Sub ErrorHandler: HandleError True, "Class_Terminate " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Sub
Private Property Get ICommand_Enabled() As Boolean On Error GoTo ErrorHandler
 If (GetMap Is Nothing) Then Exit Property ICommand_Enabled = (GetMap.LayerCount > 0)
 Exit Property ErrorHandler: HandleError True, "ICommand_Enabled " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Property Private Property Get ICommand_Checked() As Boolean On Error GoTo ErrorHandler
 ICommand_Checked = False
 Exit Property ErrorHandler: HandleError True, "ICommand_Checked " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Property Private Property Get ICommand_Name() As String On Error GoTo ErrorHandler
 ICommand_Name = "Sample_Layer_Layers"
 Exit Property ErrorHandler: HandleError True, "ICommand_Name " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Property
Private Property Get ICommand_Caption() As String On Error GoTo ErrorHandler
 ICommand_Caption = "Layers"
 Exit Property ErrorHandler: HandleError True, "ICommand_Caption " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Property Private Property Get ICommand_Tooltip() As String On Error GoTo ErrorHandler
 ICommand_Tooltip = "图层显示设置"
 Exit Property ErrorHandler: HandleError True, "ICommand_Tooltip " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Property Private Property Get ICommand_Message() As String On Error GoTo ErrorHandler
 ICommand_Message = "图层显示设置"
 Exit Property ErrorHandler: HandleError True, "ICommand_Message " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Property Private Property Get ICommand_HelpFile() As String On Error GoTo ErrorHandler
 ' TOD Add your implementation here
 Exit Property ErrorHandler: HandleError True, "ICommand_HelpFile " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Property Private Property Get ICommand_HelpContextID() As Long On Error GoTo ErrorHandler
 ' TOD Add your implementation here
 Exit Property ErrorHandler: HandleError True, "ICommand_HelpContextID " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Property Private Property Get ICommand_Bitmap() As esriSystem.OLE_HANDLE On Error GoTo ErrorHandler
 ICommand_Bitmap = m_pBitmap
 Exit Property ErrorHandler: HandleError True, "ICommand_Bitmap " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Property Private Property Get ICommand_Category() As String ICommand_Category = "fhl_Layer" End Property Private Sub ICommand_OnCreate(ByVal hook As Object) On Error GoTo ErrorHandler
 Set m_pHookHelper.hook = hook SetupList
 Exit Sub ErrorHandler: HandleError True, "ICommand_OnCreate " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Sub Private Sub ICommand_OnClick() On Error GoTo ErrorHandler
 m_frmLayer.PopulateList m_pHookHelper.FocusMap m_frmLayer.Show vbModal
 Exit Sub ErrorHandler: HandleError True, "ICommand_OnClick " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Sub
Private Sub m_pActiveViewEvents_FocusMapChanged() SetupList End Sub
Private Sub m_pActiveViewEvents_ItemAdded(ByVal Item As Variant) On Error GoTo ErrorHandler m_frmLayer.PopulateList m_pHookHelper.FocusMap Exit Sub ErrorHandler: HandleError True, "m_pActiveViewEvents_ItemAdded " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Sub
Private Sub m_pActiveViewEvents_ItemDeleted(ByVal Item As Variant) On Error GoTo ErrorHandler m_frmLayer.PopulateList m_pHookHelper.FocusMap Exit Sub ErrorHandler: HandleError True, "m_pActiveViewEvents_ItemDeleted " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Sub
Private Sub m_pActiveViewEvents_ItemReordered(ByVal Item As Variant, ByVal toIndex As Long) On Error GoTo ErrorHandler m_frmLayer.PopulateList m_pHookHelper.FocusMap Exit Sub ErrorHandler: HandleError True, "m_pActiveViewEvents_ItemReordered " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Sub
Private Sub SetupList() On Error GoTo ErrorHandler Set m_pActiveViewEvents = m_pHookHelper.FocusMap m_frmLayer.PopulateList m_pHookHelper.FocusMap Exit Sub ErrorHandler: HandleError True, "SetupList " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1 End Sub

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

举报回复喜欢评分

mfchuke 路人甲注册日期2005-11-16 发帖数21 QQ 铜币214枚威望0点贡献值0点银元0个加关注写私信	5楼^# 发布于：2005-11-16 23:17 有没有人帮帮我？
	举报回复(0) 喜欢(0) 评分

mfchuke 路人甲注册日期2005-11-16 发帖数21 QQ 铜币214枚威望0点贡献值0点银元0个加关注写私信	6楼^# 发布于：2005-11-16 20:02 <P>gis:能不能给个实例，谢谢</P>
	举报回复(0) 喜欢(0) 评分

gis

管理员

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

加关注写私信

7楼^#

发布于：2005-11-16 17:02

编写arcmap和mapcontrol中使用的dll的方法是不同的，你可以拿两个能使用的例子对比下

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

举报回复喜欢评分

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

TToolBarControl导入activex dll无效

最新喜欢：