How to create a raster pixel measure tool

This tool lets you measure distances on your map, in raster pixels. As you draw a line with this tool, the length of the line is shown in the status bar. You can draw a line with multiple segments. Click once to start a new segment. Double-click or press ESC to finish.

The code related to NewLineFeedback is from INewLineFeedback Example.

How to use

Run ArcMap and add raster data in ArcMap
Add a custom UIToolControl onto the toolbar and make sure the names of the control match the code. This sample assumes the control is called UIToolControl1.
Paste the code into VBA.
Make sure to add reference to ESRI ArcScan Object Library.
Completely shut down VBA so mouse events will fire.
Select the tool and then left click to create the line.

[VBA]


        Option Explicit

Private geoProc2 As IRasterGeometryProc2
Private m_pDoc As IMxDocument
Private m_pAV As IActiveView
Private m_pScrD As IScreenDisplay
Private m_pNewLineFeedback As INewLineFeedback
Private m_MidPt As WKSPoint
Private m_dbTot As Double
Private m_dbSubTot As Double

Private Function UIToolControl1_CursorID() As Variant
    'use the cross cursor
    UIToolControl1_CursorID = 3
End Function

Private Sub UIToolControl1_DblClick()
    Dim pGeomLn As IGeometry
    
    'Get the geometry (Line) returned from the feedback
    Set pGeomLn = m_pNewLineFeedback.Stop
    
    ' Set the feedback to nothing for the next use
    Set m_pNewLineFeedback = Nothing
    m_dbTot = 0
    m_dbSubTot = 0
End Sub

Private Sub UIToolControl1_MouseDown(ByVal button As Long, _
                                     ByVal shift As Long, ByVal x As Long, ByVal y As Long)
    
    Dim pPnt As IPoint
    
    ' Get the current mouse location
    Set pPnt = m_pDoc.CurrentLocation
    
    ' Check that user is not using an existing feedback
    If m_pNewLineFeedback Is Nothing Then
        ' Create a symbol (and color) to use for the Feedback
        ' this is optional - a default symbol is used if none is given
        Dim pSLnSym As ISimpleLineSymbol
        Dim pRGB As IRgbColor
        
        Set m_pNewLineFeedback = New NewLineFeedback
        ' Get the new Feedback's symbol by reference
        Set pSLnSym = m_pNewLineFeedback.Symbol
        
        Set pRGB = New RgbColor
        ' Make a color
        With pRGB
            .Red = 150
            .Green = 150
            .Blue = 150
        End With
        
        ' Setup the symbol with color and style
        pSLnSym.Color = pRGB
        pSLnSym.Style = esriSLSSolid
        pSLnSym.Width = 2
        
        'Set the new Feedback's Display and StartPoint
        Set m_pNewLineFeedback.Display = m_pScrD
        m_pNewLineFeedback.Start pPnt
        
        m_dbSubTot = 0
    Else ' Otherwise use the current mouse location to add a vertex to the current feedback
        m_pNewLineFeedback.AddPoint pPnt
        m_dbSubTot = m_dbTot
    End If
    
    'get the start point of each segment in pixel
    m_MidPt = RasterPt(pPnt)
End Sub

Private Sub UIToolControl1_MouseMove(ByVal button As Long, _
                                     ByVal shift As Long, ByVal x As Long, ByVal y As Long)
    
    ' Check if the user is currently using the feedback
    If Not m_pNewLineFeedback Is Nothing Then
        Dim pPnt As IPoint
        'Move the Feedback to the current mouse location
        Set pPnt = m_pDoc.CurrentLocation
        
        m_pNewLineFeedback.MoveTo pPnt
        
        Dim pCurPnt As WKSPoint
        pCurPnt = RasterPt(pPnt)
        
        Dim Str As String
        Dim dbSeg As Double
        Dim lgMidX As Long
        Dim lgMidY As Long
        
        'get the x, y of the current position
        x = pCurPnt.x
        y = pCurPnt.y
        
        'get the x, y of the starting point of each segment
        lgMidX = m_MidPt.x
        lgMidY = m_MidPt.y
        
        'calculate the distance of each segment
        dbSeg = Sqr((x - lgMidX) * (x - lgMidX) + (y - lgMidY) * (y - lgMidY))
        
        'get the total length of the line
        m_dbTot = m_dbSubTot + dbSeg
        
        Str = "Segment: " + Format(dbSeg, "##,##0.0") + _
              " Total: " + Format(m_dbTot, "##,##0.0") + " Raster Pixels"
        
        ThisDocument.Parent.StatusBar.Message(0) = Str
    End If
End Sub

Private Sub UIToolControl1_Refresh(ByVal hDC As Long)
    'Get a reference to the ActiveView and ScreenDisplay
    Set m_pDoc = Application.Document
    Set m_pAV = m_pDoc.ActiveView
    Set m_pScrD = m_pAV.ScreenDisplay
End Sub

Private Sub UIToolControl1_Select()
    'Get a reference to the ActiveView and ScreenDisplay
    Set m_pDoc = Application.Document
    Set m_pAV = m_pDoc.ActiveView
    Set m_pScrD = m_pAV.ScreenDisplay
    
End Sub

Private Function RasterPt(ByVal pt As IPoint) As WKSPoint
    'This function convert the point in map units to raster pixels
    
    If geoProc2 Is Nothing Then
        Set geoProc2 = New RasterGeometryProc
    End If
    
    Dim mapPt As WKSPoint
    pt.QueryCoords mapPt.x, mapPt.y
    
    Dim vl As IVectorizationLayers
    Set vl = ThisDocument.Parent.FindExtensionByName("ESRI ArcScan Tools")
    
    geoProc2.WKSPointsMap2PixelTransform 1, mapPt, True, vl.CurrentLayer.Raster, RasterPt
    
End Function

Additional Requirements

ArcScan extension