VBAからIEの画像を画像URLを用いずにダウンロードする方法 http://www.moug.net/faq/viewtopic.php?t=68257

Module1.bas

Option Explicit

' 参照設定
' Microsoft WinHTTP Services, version 5.1
' Microsoft VBScript Regular Expressions 5.5
' Microsoft ActiveX Data Objects 2.x Library

Private reg As New VBScript_RegExp_55.RegExp

Sub test()
    Dim HtmlUrl As String
    Dim SavePath As String
    Dim html As String
    Dim ImageFileName As String
    Dim ImagePath As String
    Dim ImageUrl As String
    Dim ImageBin() As Byte
    
    HtmlUrl = "http://www.matrixscience.com/cgi/peptide_view.pl?file=..%2Fdata%2FF981123.dat&query=11&hit=1&index=CH60_HUMAN&db_idx=1&px=1&section=5&ave_thresh=38&_ignoreionsscorebelow=0&report=0&_sigthreshold=0.05&_msresflags=1025&_msresflags2=2&percolate=-1&percolate_rt=0&_minpeplen=7&sessionID=guest_guestsession"
    SavePath = "C:\test.gif"
    
    ' HTMLを取得
    html = httpGetText(HtmlUrl)
    
    ' HTMLから画像のファイル名以降を抜き出す
    ImageFileName = getImageFileName(html)
    ' 画像を含むURLからファイル名の手前までを抜き出す
    ImagePath = getImagePath(HtmlUrl)
    ImageUrl = ImagePath & ImageFileName
    
    ' 画像のバイナリデータを取得
    ImageBin = httpGetBin(ImageUrl)
    ' バイナリデータをファイルに保存
    saveBin ImageBin, SavePath
    
End Sub

Function httpGetText(url As String) As String
    httpGetText = httpGet(url, True)
End Function

Function httpGetBin(url As String) As Byte()
    httpGetBin = httpGet(url, False)
End Function

Function httpGet(url As String, Optional isText As Boolean = True) As Variant
    Const HTTP_STATUS_OK As Long = 200
    Dim http As WinHttp.WinHttpRequest
    
    Set http = New WinHttp.WinHttpRequest
    http.Open "GET", url, False
    http.Send
    
    If http.Status = HTTP_STATUS_OK Then
        If isText Then
            httpGet = http.ResponseText
        Else
            httpGet = http.ResponseBody
        End If
    Else
        Err.Raise http.Status, , http.StatusText
    End If
End Function

Function getImageFileName(html) As String
    Dim matches As VBScript_RegExp_55.MatchCollection
    
    reg.Global = False
    reg.IgnoreCase = True
    reg.Pattern = "SRC=""\./([^""]+gif_\d+)""" ' SRC="\./([^"]+gif_\d+)"
    Set matches = reg.Execute(html)
    getImageFileName = matches(0).SubMatches(0)
End Function

Function getImagePath(HtmlUrl) As String
    Dim matches As VBScript_RegExp_55.MatchCollection
    
    reg.Global = False
    reg.Pattern = ".+/"
    Set matches = reg.Execute(HtmlUrl)
    getImagePath = matches(0).Value
End Function

Sub saveBin(bin() As Byte _
    , path _
    , Optional SaveOption As ADODB.SaveOptionsEnum = adSaveCreateNotExist)
    
    Dim stream As ADODB.stream
    
    Set stream = New ADODB.stream
    stream.Type = adTypeBinary
    stream.Open
    stream.Position = 0
    stream.Write bin
    stream.SaveToFile path, SaveOption
    stream.Close
End Sub