关于activex dll编写(独立程序，脱离ArcMap.exe)

我改写了一个例程(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

请帮忙分析一下，谢谢

这个好像是量算距离的。记得好像看过这么个例子。现贴上我所使用的代码：

Option Explicit

Implements ICommand
Implements ITool

Private m_pApp As New hook
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 m_pCursor As IPictureDisp
Private m_pBitmap As IPictureDisp
Private m_LengthArea  As String

Private Function GetMap() As esriCarto.IMap

  On Error GoTo ErrorHandler

  Set GetMap = m_pApp.FocusMap

  Exit Function
ErrorHandler:
  '  ', "GetMap " ; c_ModuleFileName ; " " ; GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1

End Function

Private Sub Class_Initialize()

  Set m_pCursor = LoadResPicture("MEASURE", vbResCursor)
  '   Set m_pCursor = LoadResPicture("SELECT", vbResCursor)

End Sub

Private Sub Class_Terminate()
 
  Set m_pApp = Nothing
 
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 = "测量工具"

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 = "测量距离工具"

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)

  m_pApp.hook = hook

End Sub

Private Property Get ICommand_Tooltip() As String

  ICommand_Tooltip = "测量工具"

End Property

Private Property Get ITool_Cursor() As esriSystem.OLE_HANDLE

  ITool_Cursor = m_pCursor '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)

  m_bInUse = True
  '  Dim pMXDoc As IMxDocument
  Dim pActiveView As IActiveView
  '  Set pMXDoc = m_pApp.Document
  Set pActiveView = GetMap() 'pMXDoc.FocusMap
 
  'Get point to measure distance from
  Set m_pStartPoint = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)

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 IActiveView
  '  Set pMXDoc = m_pApp.Document
  Set pActiveView = GetMap() 'pMXDoc.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

'      Dim myColor As IRgbColor
'      Set myColor = New RgbColor
'      myColor.Red = 255
'      myColor.blue = 0
'      myColor.Green = 0

     'Text Symbol
     Set m_pTextSymbol = New TextSymbol
     m_pTextSymbol.HorizontalAlignment = esriTHACenter
     m_pTextSymbol.VerticalAlignment = esriTVACenter
     m_pTextSymbol.Size = 15
'      m_pTextSymbol.Color = GetRGBColor(255, 0, 0)
     Set pSymbol = m_pTextSymbol
     
     Set pFont = m_pTextSymbol.Font
     pFont.name = "宋体"
'      m_pTextSymbol.Color = myColor
     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

  Dim pLenth 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)
  On Error GoTo hErr

  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
  'Draw text
  pActiveView.ScreenDisplay.SetSymbol m_pTextSymbol
  pActiveView.ScreenDisplay.DrawText m_pTextPoint, m_pTextSymbol.Text
'   m_pTextSymbol.Color = GetRGBColor(255, 0, 0)

  '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
'   m_pLineSymbol.Color = GetRGBColor(255, 255, 255)
  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
  m_LengthArea = "两地距离为：" ; pLenth ; "千米"
 
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
 
  '  Dim pMXDoc As IMxDocument
  Dim pActiveView As IActiveView
  '  Set pMXDoc = m_pApp.Document
  Set pActiveView = GetMap() 'pMXDoc.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

我还以为你真的脱离arcmap些的 不过是用在arcmap中的dll而已

斑竹在不在？

怎么人这么少？