#12999 by Alexander Ross (Alexander)

Theme:
Attribute VB_Name = "ImageMapWorker"
Public Sub ExportImage(dir As String, base As String, Dpi As Double, imgformat As String)
    LoggerForm.appendLog ("Exporting image...")
    Dim pMxDoc As IMxDocument
    Set pMxDoc = ThisDocument
    
    Dim pActiveView As IActiveView
    Dim pExporter As IExport
    Dim pEnv As IEnvelope
    
    Set pActiveView = pMxDoc.ActiveView
    If imgformat = "PNG" Then Set pExporter = New ExportPNG
    If imgformat = "JPEG" Then Set pExporter = New ExportJPEG
    Set pEnv = New Envelope
    
    'Setup the exporter
    Dim screenDpi As Double
    Dim exportFrame As tagRECT
    screenDpi = 92
    With exportFrame
        .Right = 0
        .Top = 0
        .Right = pActiveView.exportFrame.Right * (Dpi / screenDpi)
        .bottom = pActiveView.exportFrame.bottom * (Dpi / screenDpi)
    End With
    pEnv.PutCoords exportFrame.Left, exportFrame.Top, exportFrame.Right, exportFrame.bottom
    With pExporter
        .PixelBounds = pEnv
        .ExportFileName = PathCombine(dir, base & "." & LCase(imgformat))
    End With
    Dim hdc As Long
    hdc = pExporter.StartExporting
    pActiveView.Output hdc, Dpi, exportFrame, Nothing, Nothing
    pExporter.FinishExporting
    LoggerForm.appendLog ("Done exporting image.")
End Sub
Public Sub ExportImageMap(dir As String, base As String, Dpi As Integer, simpliFact As Double, _
          iHref As String, iTitle As String, iName As String, iId As String, _
          lyrIndices As Collection, imgformat As String)

    LoggerForm.appendLog ("Exporting image map...")
    Dim pMxDoc As IMxDocument
    
    Set pMxDoc = ThisDocument
    
    ' get device extent (ie. image resolution)
    Dim devEnv As IEnvelope
    Dim exportFrame As tagRECT
    exportFrame = pMxDoc.ActiveView.exportFrame
    Set devEnv = New Envelope
    With exportFrame
        .Left = 0
        .Top = 0
        .Right = CInt(pMxDoc.ActiveView.exportFrame.Right * (Dpi / 92))
        .bottom = CInt(pMxDoc.ActiveView.exportFrame.bottom * (Dpi / 92))
    End With
    devEnv.PutCoords exportFrame.Left, exportFrame.Top, _
          exportFrame.Right, exportFrame.bottom
    ' get visible MapExtent
    ' It's really important to use MapBounds here, you won't get proper map extent using
    ' the extent properties of the PageLayout
    Dim pMapFrame As IMapFrame
    Dim pGC As IGraphicsContainer
    Dim mapEnv As IEnvelope
    
    Set pGC = pMxDoc.ActiveView
    Set pMapFrame = pGC.FindFrame(pMxDoc.FocusMap)
    Set mapEnv = pMapFrame.MapBounds
    
    ' create/open html-File
    Dim txtimapStart As String
    Dim txtimapEnd As String
    
    foreHTML = "<html><body><map name='arcmap'>"
    tailHTML = "</map><img src='" & base & "." & LCase(imgformat) & "' border='0' alt='Map' usemap='#arcmap'></body></html>"
    
    Dim fnum As Integer
    Dim path As String
    
    fnum = FreeFile
    path = PathCombine(dir, base & ".html")
    
    Open path For Output As #fnum
    Print #fnum, foreHTML ' print html headers
    
    Dim layerSet As ISet
    Dim piLayer As IFeatureSelection
    Dim piFLayer As IFeatureLayer
    Dim pFeatureSelection As IFeatureSelection
    Dim pSelectionSet As ISelectionSet
    Dim pFeatureCursor As IFeatureCursor
    Dim pFeature As IFeature
    
    Dim index As Variant
    
    ' loop on selected layers
    For Each index In lyrIndices
        
        Set piLayer = pMxDoc.ActiveView.FocusMap.Layer(index)
        Set piFLayer = piLayer

        Set pFeatureSelection = piLayer
        Set pSelectionSet = pFeatureSelection.SelectionSet
        
        pSelectionSet.Search Nothing, False, pFeatureCursor
        
        If pSelectionSet.Count = 0 Then
            Set pFeatureCursor = piFLayer.FeatureClass.Search(Nothing, False)
        End If
        
        Set pFeature = pFeatureCursor.NextFeature
        
        ' Vars used in the loop
        Dim tmpEnv As IEnvelope
        Dim trPoints As IPointCollection
        Dim areaTag As String
        Dim txtCoord As String
        
        ' finally doing work
        Do Until pFeature Is Nothing
            Set tmpEnv = mapEnv.Envelope
            pFeature.Shape.Project tmpEnv.SpatialReference
            ' Is current feature visible
            tmpEnv.Intersect pFeature.Extent
            If Not (tmpEnv.IsEmpty) Then
                Dim pGeomColl As IGeometryCollection
                Dim GeometryCount As Integer
                Set pGeomColl = pFeature.Shape
                For GeometryCount = 0 To pGeomColl.GeometryCount - 1
                    ' transform coordinates to device frame.
                    Set trPoints = transformPC(pGeomColl.Geometry(GeometryCount), mapEnv, devEnv)
                    ' Simplify the point collection.
                    Set trPoints = simplifyPC(trPoints, simpliFact)
                    ' Don't render a tag for anything less than four points.
                    If trPoints.PointCount >= 6 Then
                        ' render the point collection as a string
                        txtCoord = PointCollAsString(trPoints, 0)
                        ' build the area tag
                        areaTag = "<area shape='poly'"
                        If iHref <> "" Then
                            If pFeature.Table.FindField(iHref) <> -1 Then
                                areaTag = areaTag & " href='" & _
                                pFeature.Value(pFeature.Table.FindField(iHref)) & "'"
                            End If
                        End If
                        If iTitle <> "" Then
                            If pFeature.Table.FindField(iTitle) <> -1 Then
                                areaTag = areaTag & " title='" & _
                                    pFeature.Value(pFeature.Table.FindField(iTitle)) & "' alt='" & _
                                    pFeature.Value(pFeature.Table.FindField(iTitle)) & "'"
                            End If
                        End If
                        If iName <> "" Then
                            If pFeature.Table.FindField(iName) <> -1 Then
                                areaTag = areaTag & " name='" & _
                                    pFeature.Value(pFeature.Table.FindField(iName)) & "'"
                            End If
                        End If
                        If iId <> "" Then
                            If pFeature.Table.FindField(iId) <> -1 Then
                                areaTag = areaTag & " id='" & _
                                    pFeature.Value(pFeature.Table.FindField(iId)) & "'"
                            End If
                        End If
                        areaTag = areaTag & " coords='" & txtCoord & "'"
                        areaTag = areaTag & "/>"
                        ' print the tag
                        Print #fnum, areaTag
                    End If
                    DoEvents
                Next GeometryCount
            End If
            Set pFeature = pFeatureCursor.NextFeature
        Loop
    Next index
    Print #fnum, tailHTML
    Close #fnum
    LoggerForm.appendLog ("Done exporting image map.")
    End Sub
Private Function transformPC(points As IPointCollection, mapEnv As IEnvelope, devEnv As IEnvelope) As IPointCollection
    ' transform a point collection from the Envelope mapEnv to the envelope devEnv
    ' clamps all points to the devEnv Envelope and tosses out any duplicate points that
    ' appear as a result of the transformation
    Dim parsedPoints As Scripting.Dictionary
    Dim trPoints As IPointCollection
    Dim pPt As IPoint
    Dim X As Long, Y As Long
    Dim i As Integer
    Dim hash As Double
    Set parsedPoints = New Scripting.Dictionary
    Set trPoints = New esriCore.Polygon
    For i = 0 To points.PointCount - 1
        ' transform coordinates
        X = devEnv.width * ((points.Point(i).X - mapEnv.xMin) / mapEnv.width)
        Y = devEnv.height * ((mapEnv.yMax - points.Point(i).Y) / mapEnv.height)
        'clamp x and y to the device frame
        If X < devEnv.xMin Then X = devEnv.xMin
        If X > devEnv.xMax Then X = devEnv.xMax
        If Y < devEnv.yMin Then Y = devEnv.yMin
        If Y > devEnv.yMax Then Y = devEnv.yMax
        hash = 18269 * X + 10061 * Y
        ' check if we've seen this point already
        If Not parsedPoints.Exists(hash) = True Then
            Set pPt = New esriCore.Point
            pPt.X = X
            pPt.Y = Y
            trPoints.AddPoint pPt
            parsedPoints.Add hash, True
        End If
        'Debug.Print "Pixel " & pPt.Y & ", " & pPt.X
    Next i
    Set transformPC = trPoints
End Function
Private Function simplifyPC(points As IPointCollection, simpliFact As Double) As IPointCollection
    ' simplifyPC
    ' simplifies a point collection using an distance based method.
    If points.PointCount < 5 Then
        Set simplifyPC = points
        Exit Function
    End If
    Dim pt As IPoint
    Dim ii As Long

    Dim dist As Double
    Dim minDist As Double

    ' tag the first points onto the end, so an dist is computed
    ' for the last point in the collection
    points.AddPoint points.Point(0)
    dist = 0
    ' sum distances between adjacent points
    For ii = 0 To points.PointCount - 2
        dist = Sqr((points.Point(ii + 1).X - points.Point(ii).X) ^ 2 + _
            (points.Point(ii + 1).Y - points.Point(ii).Y) ^ 2)
    Next ii
    ' average dist
    minDist = simpliFact / 10 / log(5 + dist / (points.PointCount - 2))
    Dim jj As Long
    ii = 0
    dist = 0
    Do
        jj = ii + 1
        If jj >= points.PointCount - 1 Then Exit Do
        Do
            dist = Sqr((points.Point(jj).X - points.Point(ii).X) ^ 2 + _
                (points.Point(jj).Y - points.Point(ii).Y) ^ 2)
            If dist < minDist Then
                points.RemovePoints jj, 1 ' remove intermediate point
            Else
                Exit Do
            End If
            If jj >= points.PointCount - 1 Then Exit Do
            DoEvents
        Loop
        ii = ii + 1
        DoEvents
    Loop
    points.RemovePoints points.PointCount - 1, 1 ' remove those two points we tacked on
    Set simplifyPC = points
End Function
Private Function calcArea(p1 As IPoint, p2 As IPoint, p3 As IPoint) As Double
    calcArea = 1 / 2 * (-p2.X * p1.Y + p3.X * p1.Y + _
        p1.X * p2.Y - p3.X * p2.Y - p1.X * p3.Y + p2.X + p3.Y)
End Function
Private Function PointCollAsString(pPC As IPointCollection, lFormatNum As Long) As String
    Dim pPt As IPoint
    Dim strCollection As String, strPoint As String
    Dim i As Long
    For i = 0 To pPC.PointCount - 1
        Set pPt = pPC.Point(i)
        strPoint = PointAsString(pPt, 0)
        If strCollection <> "" Then
            strCollection = strCollection & ", " & strPoint
        Else
            strCollection = strCollection & strPoint
        End If
        Set pPt = Nothing
    Next i
    PointCollAsString = strCollection
End Function
Private Function PointAsString(pPt As IPoint, lFormatNum As Long) As String
    Dim strFormat As String
    Dim strXCoord As String, strYCoord As String
    If lFormatNum = 0 Then
        strFormat = "#0"
    Else
        strFormat = "#0."
        Dim i As Long
        For i = 0 To lFormatNum - 1
         strFormat = strFormat & "0"
        Next i
    End If
    strXCoord = Format(CStr(Round(pPt.X, lFormatNum)), strFormat)
    strYCoord = Format(CStr(Round(pPt.Y, lFormatNum)), strFormat)
    PointAsString = strXCoord & "," & strYCoord
End Function
Private Function PathCombine(path1 As String, path2 As String) As String
    If Right(path1, 1) <> "\" And Left(path2, 1) <> "\" Then
        PathCombinePath = path1 & "\" & path2
        Exit Function
    End If
    If Right(path1, 1) = "\" And Left(path2, 1) = "\" Then
        PathCombinePath = Left(path1, Len(path1) - 1) & _
            "\" & Right(path2, Len(path2) - 1)
        Exit Function
    End If
    PathCombine = path1 & path2
End Function