ヤフオク!のオークション画像を一括でダウンロードするExcelVBAマクロ

ヤフオクの画像をダウンロードしたい!

こんにちは、akanekoです。

実はわたくし、職場でヤフオクストアと楽天ショップの運営をしております。
前職がSE(といってもショボイSEでしたが;)だったのもあり、ヤフオクストアや楽天ショップの運営業務をするうえで、自作のExcelVBAマクロを色々と作ってみたりしています。

本格的にコーディングを学んだわけではないのですが、まぁ半分趣味みたいなものですね。ハンドメイドが趣味なので、プログラムもハンドメイドしちゃったりしているわけです。

フツーのストア・ショップさんなどは、専門の業者に頼んで高いお金を出してプログラムを作ってもらって運営しているのがほとんどだと思います。
ですが、私の勤める職場のような中小企業ではプログラム開発に払うお金も厳しい。。
しかもSE上がりの人間(私)が在籍している。。
とくれば、まぁ上から頼まれるのは必然なワケで(^_^;)

素人に毛が生えた程度なのですが、それでも各種自作ツールで業務ではかなりの役に立っていると自負しております。
ゴリゴリのプログラムではありませんが、業務のちょっとした助けになるツールをご紹介します。

<ご注意>
ソースコードおよびExcelは無料公開しています。
利用に制限はございませんが、二次配布はご遠慮ください。
また、当コード及びExcel利用に際し何らかの不利益が発生したとしても、当方は一切の責任を負いません。ご了承いただける場合のみご利用くださいませ。
また、画像著作権の侵害となりますので、他人のオークションには利用せず、あくまでも自社(または自身)の出品商品にのみご利用ください。



使用方法

設定項目は3点のみです。

  1. 画像の保存先フォルダ(事前にフォルダは作成してください)
  2. 画像をDLしたいオークションの【オークションID】
  3. そのオークションの画像の保存名(複数画像があれば”保存名_連番.jpg”で保存されます)

ソースコード

Sub 画像保存()

Dim strURL As String
Dim picFldr As String
Dim picName As String
Dim picCount As Integer
Dim Hozon As String
Dim AucID As String
Dim picURL As String
Dim i As Integer

Dim sourceBody As String
Dim lines() As String
Dim lineNo As Integer
Dim position As Integer

Dim objIE As Object

'対象データ・設定があるか
If Cells(3, 1) = "" Then
   MsgBox "保存名が設定されておりません。終了します。"
   Exit Sub
End If

If Cells(3, 2) = "" Then
   MsgBox "オークションIDデータがありません。終了します。"
   Exit Sub
End If

If Cells(1, 2) = "" Then
   MsgBox "画像保存先が設定されていません。終了します。"
   Exit Sub
End If

'データ最終行
strEndR = [A55555].End(xlUp).Row

'画像保存フォルダ設定
picFldr = Cells(1, 2).Value

'IE の準備
Set objIE = CreateObject("InternetExplorer.Application")

'データ行を処理
For i = 3 To strEndR
    '保存名を格納
    Hozon = Cells(i, 1).Value
    'オークションIDを格納
    AucID = Cells(i, 2).Value
    'URL設定
    strURL = "https://page.auctions.yahoo.co.jp/jp/auction/" & AucID
    '画像カウントを初期化
    picCount = 1
    '画像保存名設定
    picName = picFldr & "\" & Hozon

    'URL表示
    objIE.navigate strURL
    '表示待機
    Do While objIE.Busy = True Or objIE.readyState <> 4
       DoEvents
    Loop

    'Webページへのアクセスが完了したら、BODY要素内のソースを取得する
    sourceBody = objIE.document.body.outerHTML

    '取得したソースを改行で区切って配列にする
    '改行コードを LF に揃える
    sourceBody = Replace(sourceBody, vbCrLf, vbLf)
    sourceBody = Replace(sourceBody, vbCr, vbLf)
    '改行コード LF で区切って配列にする
    sourceLines = Split(sourceBody, vbLf)

    '検索する文字列を含む行を検索
    'For lineNo = 1 To UBound(sourceLines)
    For lineNo = 200 To UBound(sourceLines) '処理高速化のためソースの前半/後半は検索対象からカット
      '検索文字列(画像が設定されている個所)を探す
      position = InStr(sourceLines(lineNo), "rsec:aimg;slk:thumb;pos:1")
      'ヒットした行
      If position > 0 Then
        'ヒットした文字列から画像URLを取得してダウンロード
        picURL = Mid$(sourceLines(lineNo), InStr(sourceLines(lineNo), "src=") + 5, InStr(sourceLines(lineNo), "jpg") - InStr(sourceLines(lineNo), "src=") - 2)
        RegDL = URLDownloadToFile(0, picURL, picName & "_" & picCount & ".jpg", 0, 0)
        picCount = picCount + 1
      End If
    Next

'次の行へ
Next

'IE終了
objIE.Quit
Set objIE = Nothing

MsgBox "完了しました。"


End Sub

Excelダウンロード

以下よりダウンロードできます。

AucGazoDL

動作確認済み環境は以下の通りです。
Windows7 SP1/Microsoft Office Excel 2007
Windows8/Microsoft Office Excel 2010

スポンサーリンク

コメントを残す

メールアドレスが公開されることはありません。

このサイトはスパムを低減するために Akismet を使っています。コメントデータの処理方法の詳細はこちらをご覧ください