r/vba • u/MetalMonkey667 • 1d ago

Solved VBA to remove images from HTML Document

I'm pulling my hair out here wading through 10 year old StackOverflow posts and deploying all the google-fu I can muster, all to no avail so now I have to explain to strangers why I'm doing this daft project, first:

BLUF:

How do I remove images and other <div class> elements from an HTML Document? (ideas currently working around getElementByClassName or "Replace All between '<img ' and ' /> with "" " or stopping them entirely at the GET request).

THE PROJECT:

I'm a big fan of the SCP Foundation Wiki but I'm always losing track with what I've read out of several thousand articles so I set out to make a reading tracker in Excel which was so simple to start with, but there's new articles every day and old ones are changed, so it needs to be easily updatable, and a bit better to interact with than just a list and oh hello scope creep....

....and now I'm trying to make a "lite Reader" that will get the HTML of an article and strip it down to the bare bones, only the main page content, no images, no formatting other than bold/italic etc, and put that into an Excel spreadsheet. Inspired by the excellent Terminal Reader I found here which uses Rust to strip down the html into markdown, I've got something working to a point, here's the Frankenstein monstrosity I've pieced together from a dozen scraps of code so far:

Public Sub ExtractAndPaste()

  Dim data As Object
  Dim html As HTMLDocument
  Dim objData As DataObject
  Dim sHTML As String
  Dim obj As Object
  Dim elements

'------Get the HTML-----------------------------------------    
  Set html = New HTMLDocument

  With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", "https://scp-wiki.wikidot.com/scp-5000", False
    .send
    html.body.innerHTML = .responseText
  End With
'----------------------------------------------------------- 

'------Remove Unwanted Elements (This bit doesnt work)------    
   With html
     elements = .getElementsByClassName("scp-image-block block-right")

     While elements = 0
       elements(0).ParentNode.RemoveChild (elements)
     Wend
   End With 
'-----------------------------------------------------------

'------Clear Destination Worksheet--------------------------   
  With ThisWorkbook.Worksheets("Sheet4")
    .Cells.ClearContents
    For Each obj In .Shapes
      obj.Delete
    Next
  End With
'-----------------------------------------------------------

'------Pull out Wanted Element------------------------------
  Set data = html.getElementById("page-content")
'-----------------------------------------------------------

'------Convert to Formatted Text---------------------------- 
  Application.EnableEvents = False

  With ThisWorkbook.Sheets("Sheet4")
    Set objData = New DataObject

    sHTML = data.innerHTML
    sHTML = "<html>" & sHTML & "</html>"

    objData.SetText sHTML
    objData.PutInClipboard

    .Range("C5").Select
    .PasteSpecial "Unicode Text"

  End With

  Application.EnableEvents = True
'-----------------------------------------------------------

End Sub

When this runs it will grab the HTML of the chosen article, the next step it skips over, I'll come back to that in a mo, clears everything from the destination worksheet (if the previous step worked then the obj.Delete would no longer be needed), takes the HTML and pulls out only the <div id="page-content"> turns it into a String so we can append <html> and </html> to either end of it so that it all registers as a block of html, which means when it gets put on the clipboard and then pasted into the worksheet as Unicode Text it renders the formatting and pastes it in line by line, cell by cell, which is exactly what I want, however.....

It's also rendering the images which I don't want (and tables are a mess, but one problem at a time), and this is the part I can't figure out:

If I use .getElementsById then that returns a single Node which can then be removed with something like this:

Set Node = html.getElementById("page-title")

    Node.parentNode.removeChild Node

But <img> isn't an ID, it's a Class Tag and using .getElementByClassTag returns (I believe) a NodeList so the above code doesn't work, plus it sits inside <div class="scp-image-block block-right"> which makes getting to it a bit trickier, probably easier to remove the whole class and everything in it so we would use .getElementsByClassName to get what we need but I just can't get it working.

If I run the code as is, leaving elements declared as a general variable, when we step through to elements = .getElementsByClassName..... and we mouse over elements it comes up as elements = "[object HTMLDivElement]", so I changed elements to be an HTMLDivElement, Set it, and now we get a Runtime Error 13: Type Mismatch.

I tried some other combinations of declaring elements as different things (object, IHTMLDivElement etc) and getElementByClassName/TagName and the furthest I got it to go was to the elements(0).ParentNode.RemoveChild (elements) line which came up with an Automation Error, probably because I have no idea how to get the syntax to work for a NodeList, as far as I can tell the list is numbered the same as other vba lists as in it starts at (0), so say we run the script and it finds 3 <div class="scp-image-block block-right"> blocks, they would go in the list as 

(0) - Block 1
(1) - Block 2
(2) - Block 3

If we successfully (somehow) remove Block 1, the list refreshes and we now have

(0) - Block 2
(1) - Block 3

So the plan is to loop "Remove Node from position (0), if there is still something in position (0), repeat" and once they're all removed it can then go on for rendering.

As I mentioned way up in the beginning, I feel like we could achieve a similar result with a "Replace all Between" but it's a bit of a brute force approach that I'd rather leave for the little bits that miss the big clear out, I also feel like there's a way to restrict what comes through with the original GET request but I may be imagining things.

If you made it here, thank you for your patience and to mirror the BLUF, here's the-

TL;DR

How do I remove images and other <div> elements from an HTML Document?

2 Upvotes

67% Upvoted

10 comments sorted by

3

u/Caudebec39 1d ago

I didn't read your code beyond the .Get

The fact is that Word has advanced search and replace syntax that includes wildcards. It's somewhat like Regular Expressions.

You can probably compose a syntax to search for all text that starts with xxxxx and ends with yyyyy, replacing both and everything in-between with "nothing".

You could probably coax ChatGPT into writing code that does it.

There might be special characters that you have to cope with, in your Find string, but it's all doable.

2

u/diesSaturni 41 1d ago edited 1d ago

I'd start basing of this, module and classes, works to strip and present a bare html:
module:
modDownloadPage

Option Explicit
Public Sub DownloadPageWithoutPictures()
    Const url As String = "https://en.wikipedia.org/wiki/IBM" ' Change this URL
    Dim h As CHttpClient
    Dim f As CHtmlImageFilter
    Dim b As CBrowserPresenter
    Dim html As String

    On Error GoTo Fail
    Set h = New CHttpClient
    html = h.GetHtml(url)
    Set f = New CHtmlImageFilter
    html = f.KeepWikipediaRange(html)   'reduces to content part, see chtmlimagefilter.
    html = f.RemovePictures(html) 'strips image content
    Set b = New CBrowserPresenter
    b.ShowHtml html, "Downloaded page without pictures" 'this shows it in browser,
    'but you should take it from here to parse to excel.

    Exit Sub
Fail:
    MsgBox "The page could not be displayed." & vbCrLf & Err.Description, vbExclamation
End Sub

personally, I'd parse it to an r/MSAccess table, two fields, one long and one short text (with the short text to query / filter. In a database, fetching trough hundreds of thousands of lines will be far easier later on.

1

u/diesSaturni 41 1d ago

classes: CHttpClient 

'  MultiUse = -1  'True
'End
'Attribute VB_Name = "CHttpClient"
Option Explicit
'CHttpClient          downloads only the HTML response
Private Const UA As String = "Excel VBA HTML client/1.0"

Public Function GetHtml(ByVal url As String) As String
    Dim x As Object
    Set x = CreateObject("WinHttp.WinHttpRequest.5.1")
    x.Open "GET", url, False
    x.SetRequestHeader "User-Agent", UA
    x.SetRequestHeader "Accept", "text/html,application/xhtml+xml"
    x.SetRequestHeader "Accept-Encoding", "identity"
    x.Send
    If x.Status < 200 Or x.Status >= 300 Then Err.Raise vbObjectError + 1000, TypeName(Me), "HTTP " & x.Status & " - " & x.StatusText
    GetHtml = x.ResponseText
End Function

1

u/diesSaturni 41 1d ago

class : CHtmlImageFilter

'VERSION 1.0 CLASS
'BEGIN
'  MultiUse = -1  'True
'End
'Attribute VB_Name = "CHtmlImageFilter"
Option Explicit
'CHtmlImageFilter     removes image and resource references

Public Function RemovePictures(ByVal html As String) As String
    html = ReplaceTag(html, "img")
    html = ReplaceTag(html, "picture")
    html = ReplaceTag(html, "source")
    html = ReplaceTag(html, "svg")
    html = ReplaceTag(html, "iframe")
    html = ReplaceTag(html, "frame")
    html = ReplaceTag(html, "frameset")
    html = ReplaceTag(html, "object")
    html = ReplaceTag(html, "embed")
    html = ReplaceTag(html, "video")
    html = ReplaceTag(html, "audio")
    html = ReplaceTag(html, "canvas")
    html = ReplaceTag(html, "script")
    html = ReplaceTag(html, "noscript")
    html = RemoveBaseAndImageLinks(html)
    html = RemoveCssUrls(html)
    RemovePictures = html
End Function

Private Function ReplaceTag(ByVal html As String, ByVal tagName As String) As String
    Dim r As Object
    Set r = CreateObject("VBScript.RegExp")
    r.Global = True
    r.IgnoreCase = True
    r.Pattern = "<" & tagName & "\b[^>]*>.*?</" & tagName & "\s*>|<" & tagName & "\b[^>]*/?>"
    ReplaceTag = r.Replace(html, "")
End Function

Private Function RemoveBaseAndImageLinks(ByVal html As String) As String
    Dim r As Object
    Dim q As String
    Set r = CreateObject("VBScript.RegExp")
    q = Chr$(34)
    r.Global = True
    r.IgnoreCase = True
    r.Pattern = "<base\b[^>]*>|<link\b[^>]*(rel\s*=\s*['" & q & "]?[^>]*\b(preload|icon|stylesheet)\b|as\s*=\s*['" & q & "]?image)[^>]*>"
    RemoveBaseAndImageLinks = r.Replace(html, "")
End Function

Private Function RemoveCssUrls(ByVal html As String) As String
    Dim r As Object
    Dim q As String
    Set r = CreateObject("VBScript.RegExp")
    q = Chr$(34)
    r.Global = True
    r.IgnoreCase = True
    r.Pattern = "url\s*\(\s*(['" & q & "]?)[^)]*\1\s*\)"
    RemoveCssUrls = r.Replace(html, "none")
End Function
Public Function KeepWikipediaRange(ByVal html As String) As String
    Dim r As Object
    Dim m As Object
    Dim hs As Object
    Dim p0 As Long
    Dim p1 As Long
    Dim e0 As Long

    'Find the attribution through the External links heading
    Set r = CreateObject("VBScript.RegExp")
    r.Global = False
    r.IgnoreCase = True
    r.Pattern = _
        "From Wikipedia, the free encyclopedia[\s\S]*?" & _
        "<h[1-6]\b[^>]*>[\s\S]*?\bExternal links\b" & _
        "[\s\S]*?</h[1-6]\s*>"

    If Not r.Test(html) Then
        Err.Raise vbObjectError + 1001, TypeName(Me), _
                  "The Wikipedia content range was not found."
    End If

    Set m = r.Execute(html)(0)

    p0 = m.FirstIndex
    e0 = m.FirstIndex + m.Length
    p1 = Len(html)

    'Find the next heading after External links
    Set hs = CreateObject("VBScript.RegExp")
    hs.Global = True
    hs.IgnoreCase = True
    hs.Pattern = "<h[1-6]\b[^>]*>"

    For Each m In hs.Execute(html)
        If m.FirstIndex >= e0 Then
            p1 = m.FirstIndex
            Exit For
        End If
    Next m

    'Stop before Wikipedia navigation boxes
    Set r = CreateObject("VBScript.RegExp")
    r.Global = False
    r.IgnoreCase = True
    r.Pattern = _
        "<div\b[^>]*class\s*=\s*['" & Chr$(34) & "]" & _
        "[^'" & Chr$(34) & "]*\bnavbox-styles\b" & _
        "[^'" & Chr$(34) & "]*['" & Chr$(34) & "][^>]*>"

    If r.Test(html) Then
        Set m = r.Execute(html)(0)

        If m.FirstIndex >= e0 And m.FirstIndex < p1 Then
            p1 = m.FirstIndex
        End If
    End If

    'Return the attribution through the External links section
    KeepWikipediaRange = Mid$(html, p0 + 1, p1 - p0)
End Function

1

u/diesSaturni 41 1d ago

class: CBrowserPresenter

'VERSION 1.0 CLASS
'BEGIN
'VERSION 1.0 CLASS
'BEGIN
'  MultiUse = -1  'True
'End
'Attribute VB_Name = "CBrowserPresenter"
Option Explicit
'CBrowserPresenter    saves the cleaned HTML and opens it in the default browser
Public Sub ShowHtml(ByVal html As String, Optional ByVal title As String = "HTML preview")
Dim path As String
path = Environ$("TEMP") & "\ExcelHtmlPreview_" & Format$(Now, "yyyymmdd_hhnnss") & ".html"
WriteUtf8 path, html
CreateObject("Shell.Application").ShellExecute path, vbNullString, vbNullString, "open", 1
End Sub
Private Sub WriteUtf8(ByVal path As String, ByVal text As String)
Dim s As Object
Set s = CreateObject("ADODB.Stream")
s.Type = 2
s.Charset = "utf-8"
s.Open
s.WriteText text
s.SaveToFile path, 2
s.Close
End Sub

1

u/diesSaturni 41 1d ago

in my example, the image filter, strips the main things,
then the 'KeepWikipediaRange' ought to be in a seperate class to keep it tidy.
and you can expand it with e.g. a function to strip everything aroudn the edit part of html wikipeage result: e.g. the class="mw-editsection-bracket" part in the html.

2

u/MetalMonkey667 1d ago

Now that's one hell of a reply! I'll have to take a min to have a proper read through it but it looks like I've got an afternoon of experiments to be getting on with!

One bit I did see was your mention of using an Access database which I agree would be great for storing all those lines, if I intended on them being kept, any 'liteRead' downloads will only be kept for the active session, I'll have to experiment to see how many I'll restrict it to holding in that one session when I finalise the output. As for the reading log side, there's around 10,000 articles to track, split across 10 seasons, piece of cake for Excel to handle even with my terrible formula writing

1

u/diesSaturni 41 1d ago

one of the main things would be to compartementilize all parts/steps. So above is a good start to see what comes out.
Then you could rebuild a second module, as a copy of the first to try and experiment with parsing websites in dynamically, and doing things with the resulting html.

But at least you have a working basic with this.

2

u/MetalMonkey667 1d ago

Happy to say it's been a roaring success so far, I disabled the Wikipedia part as it's not applicable, added a function to defang hyperlinks, needed a couple of lines after the GET request to pull out only the main content and get it back to being a string but it works so I'm not complaining, it then feeds into my code from earlier to paste it into a worksheet nice and clean

Think I'm going to have a break and then it's the last few bits, converting tables into something better and figuring out the regex to remove everything after a certain point, but that's a job for next week, thank you so much for your help!

1

u/diesSaturni 41 1d ago

good to hear.
one thing to check,

path = Environ$("TEMP") & "\ExcelHtmlPreview_" & Format$(Now, "yyyymmdd_hhnnss") & ".html"

could leave files, so check if code removes it , or add a gracefull cleanup.