ヤフオクをExcelで

ヤフエクのソースコードを掲載します。

少しずつ更新していきます。

'ヤフエク 商品検索処理
Sub Search_product()
    'HTTP/XML処理のオブジェクト
    Dim httpObj As Object
    Dim DomDoc As Object

    Dim api_url As String
    
    Dim op_search As String
    Dim op_jyogai As String
    Dim op_category As String
    Dim op_kubun As String
    Dim op_uprice As String
    Dim op_lprice As String
    Dim op_udecide As String
    Dim op_ldecide As String
    Dim op_newold As String
    Dim op_sort As String
    Dim tmp As Variant
    
    
    '検索文字列の取得
    If KSK.Range("B2") = "" Then
      MsgBox "検索文字列が入力されていません"
      Exit Sub
    Else
      op_search = KSK.Range("B2")
    End If
    
    '検索除外文字列の取得
    If KSK.Range("B3") <> "" Then
      For Each tmp In Split(KSK.Range("B3"), " ")
        op_search = op_search & " -" & tmp
      Next tmp
    End If
    
    '検索カテゴリの取得
    If KSK.Range("B4") <> "" Then
      op_category = "&category=" & Split(KSK.Range("B4"), ":")(1)
    End If
    
    '出品区分の取得
    If KSK.Range("B5") <> "" Then
      op_kubun = "&shop=" & Split(KSK.Range("B5"), ":")(0)
    End If
    
    '上限価格の取得
    If KSK.Range("B6") <> "" Then
      op_uprice = "&aucmaxprice=" & KSK.Range("B6")
    End If
    
    '下限価格の取得
    If KSK.Range("B7") <> "" Then
      op_lprice = "&aucminprice=" & KSK.Range("B7")
    End If
    
    '即決上限価格の取得
    If KSK.Range("B8") <> "" Then
      op_udecide = "&aucmax_bidorbuy_price=" & KSK.Range("B8")
    End If
    
    '即決下限価格の取得
    If KSK.Range("B9") <> "" Then
      op_lprice = "&aucmin_bidorbuy_price=" & KSK.Range("B9")
    End If
    
    '商品状態価格の取得
    If KSK.Range("B10") <> "" Then
      op_newold = "&item_status=" & Split(KSK.Range("B10"), ":")(0)
    End If
    
    
    api_url = SEARCHURL & "?appid=" & MYID & "&query=" & urlEncode(op_search) & _
             op_category & op_kubun & op_lprice & op_uprice & op_ldecide & op_udecide & op_newold
    
    '数を取得
    Dim result_total As Long
    Dim result_page As Long
    Dim objtmp As Object
    
    Set httpObj = CreateObject("Microsoft.XMLHTTP")
    Call httpObj.Open("GET", api_url, False)
    Call httpObj.setRequestHeader("Content-Type", "text/xml")
    Call httpObj.Send(Null)
    
    '  'DOM形式に変換 これだとGet***が使える 'responseXML自体はいろんなメソッドを使えない
    Set DomDoc = CreateObject("MSXML2.DOMDocument")
    Call DomDoc.LoadXML(httpObj.responseText)
    result_total = DomDoc.SelectSingleNode("//ResultSet/@totalResultsAvailable").Value
    result_page = DomDoc.SelectSingleNode("//ResultSet/@totalResultsReturned").Value
    
    Dim all_page As Long
    all_page = result_total \ result_page
  
    '全結果取得する処理
    'ワークシートを作成
    Dim ws_new As Worksheet
    Worksheets.Add after:=Worksheets(Worksheets.Count)
    Set ws_new = Worksheets(Worksheets.Count)
    Dim ws_name As String
    ws_name = Year(Now) & keta2(Month(Now)) & keta2(Day(Now)) & "_" & keta2(Hour(Now)) & keta2(Minute(Now)) & keta2(Second(Now))
    ws_new.Name = ws_name
    
    Dim I As Long
    Dim J As Long
    Dim c_row As Long
    Dim page_rep As Long
    
    Dim auc_id As Object
    Dim auc_title As Object
    Dim auc_price As Object
    Dim auc_url As Object
    Dim auc_etime As Object
    
    '1ページ毎に情報を取得してシートに追加する
    c_row = 2
    For I = 0 To all_page
      Call httpObj.Open("GET", api_url & "&page=" & I + 1, False)
      Call httpObj.setRequestHeader("Content-Type", "text/xml")
      Call httpObj.Send(Null)
      Set DomDoc = CreateObject("MSXML2.DOMDocument")
      DomDoc.LoadXML (httpObj.responseText)
    
      Set auc_id = DomDoc.getElementsbytagName("AuctionID")
      Set auc_title = DomDoc.getElementsbytagName("Title")
      Set auc_price = DomDoc.getElementsbytagName("CurrentPrice")
      Set auc_url = DomDoc.getElementsbytagName("AuctionItemUrl") 'ItemUrl
      Set auc_etime = DomDoc.getElementsbytagName("EndTime")
      
'      If I = all_page Then
'        page_rep = result_total - 20 * I
'      Else
'        page_rep = 20
'      End If
      For J = 1 To auc_id.Length
        ws_new.Cells(c_row, 1).NumberFormatLocal = "@" 'Formatを文字列に変更
        ws_new.Cells(c_row, 1) = auc_id.Item(J - 1).Text
        ws_new.Hyperlinks.Add Anchor:=ws_new.Cells(c_row, 1), Address:=auc_url.Item(J - 1).Text '商品ID部分にLINK追加
        ws_new.Cells(c_row, 2) = auc_title.Item(J - 1).Text
        ws_new.Cells(c_row, 3) = auc_price.Item(J - 1).Text
        ws_new.Cells(c_row, 4) = time_format_change(auc_etime.Item(J - 1).Text)
        'ws_new.Cells(c_row, 5) = auc_url.Item(J - 1).Text
        c_row = c_row + 1
      Next J
    Next I
  
    '見た目の処理
    '説明列追加
    ws_new.Cells(1, 1) = "ID"
    ws_new.Cells(1, 2) = "TITLE"
    ws_new.Cells(1, 3) = "PRICE"
    ws_new.Cells(1, 4) = "終了日時"
    ws_new.Range("A1:D1").Interior.ColorIndex = 6
    
    '幅調整
    ws_new.Columns("A:D").AutoFit
    
    '履歴作成 (行をどんどん追加する)
    '最終行から番号を取得
    Dim row_max As Long
    Dim rrk_num As Long
    
    row_max = RRK.Range("A10000").End(xlUp).Row
    If RRK.Cells(row_max, 1) = "番号" Then
      rrk_num = 1
    Else
      rrk_num = RRK.Cells(row_max, 1) + 1
    End If
    
    '情報追記
    RRK.Cells(row_max + 1, 1) = rrk_num
    RRK.Cells(row_max + 1, 2) = ws_name
    RRK.Hyperlinks.Add Anchor:=RRK.Cells(row_max + 1, 2), Address:="", SubAddress:="'" & ws_name & "'!A1"
    RRK.Cells(row_max + 1, 3) = result_total
    RRK.Cells(row_max + 1, 4) = KSK.Range("B2")
    RRK.Cells(row_max + 1, 5) = KSK.Range("B3")
    RRK.Cells(row_max + 1, 6) = KSK.Range("B4")
    RRK.Cells(row_max + 1, 7) = KSK.Range("B5")
    RRK.Cells(row_max + 1, 8) = KSK.Range("B6")
    RRK.Cells(row_max + 1, 9) = KSK.Range("B7")
    RRK.Cells(row_max + 1, 10) = KSK.Range("B8")
    RRK.Cells(row_max + 1, 11) = KSK.Range("B9")
    RRK.Cells(row_max + 1, 12) = KSK.Range("B10")
    RRK.Cells(row_max + 1, 13) = KSK.Range("B11")
    
End Sub

Sub History_Apply()


End Sub

'文字コードをURLエンコードする%形式
'Private Function urlEncode(str As String) As String
'  Dim sc As Object
'  Dim js As Object
'  Set sc = CreateObject("ScriptControl")
'  sc.Language = "Jscript"
'  Set js = sc.CodeObject
'  urlEncode = js.encodeURIComponent(str)
'End Function

Private Function urlEncode(ByVal sWord As String) As String
  Dim d As Object
  Dim elm As Object
  
  sWord = Replace(sWord, "\", "\\")
  sWord = Replace(sWord, "'", "\'")
  Set d = CreateObject("htmlfile")
  Set elm = d.createElement("span")
  elm.setAttribute "id", "result"
  d.appendChild elm
  d.parentWindow.execScript "document.getElementById('result').innerText = encodeURIComponent('" & sWord & "');", "JScript"
  urlEncode = elm.innerText
End Function

Private Function keta2(ByVal dval As String) As String
  If Len(dval) = 1 Then
    keta2 = "0" & dval
  Else
    keta2 = dval
  End If
End Function

Private Function time_format_change(ByVal str1 As String) As String
  Dim tmp_day As String
  tmp_day = Replace(Split(str1, "T")(0), "/", "")
  
  Dim tmp_time As String
  tmp_time = Replace(Split(str1, "T")(1), "+09:00", "")
  
  time_format_change = tmp_day & " " & tmp_time

End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

'ヤフエク商品検索処理

Sub Search_product()

'HTTP/XML処理のオブジェクト

Dim httpObj As Object

Dim DomDoc As Object

Dim api_url As String

Dim op_search As String

Dim op_jyogai As String

Dim op_category As String

Dim op_kubun As String

Dim op_uprice As String

Dim op_lprice As String

Dim op_udecide As String

Dim op_ldecide As String

Dim op_newold As String

Dim op_sort As String

Dim tmp As Variant

'検索文字列の取得

If KSK.Range("B2") = "" Then

MsgBox "検索文字列が入力されていません"

Exit Sub

Else

op_search = KSK.Range("B2")

End If

'検索除外文字列の取得

If KSK.Range("B3") <> "" Then

For Each tmp In Split(KSK.Range("B3"), " ")

op_search = op_search & " -" & tmp

Next tmp

End If

'検索カテゴリの取得

If KSK.Range("B4") <> "" Then

op_category = "&category=" & Split(KSK.Range("B4"), ":")(1)

End If

'出品区分の取得

If KSK.Range("B5") <> "" Then

op_kubun = "&shop=" & Split(KSK.Range("B5"), ":")(0)

End If

'上限価格の取得

If KSK.Range("B6") <> "" Then

op_uprice = "&aucmaxprice=" & KSK.Range("B6")

End If

'下限価格の取得

If KSK.Range("B7") <> "" Then

op_lprice = "&aucminprice=" & KSK.Range("B7")

End If

'即決上限価格の取得

If KSK.Range("B8") <> "" Then

op_udecide = "&aucmax_bidorbuy_price=" & KSK.Range("B8")

End If

'即決下限価格の取得

If KSK.Range("B9") <> "" Then

op_lprice = "&aucmin_bidorbuy_price=" & KSK.Range("B9")

End If

'商品状態価格の取得

If KSK.Range("B10") <> "" Then

op_newold = "&item_status=" & Split(KSK.Range("B10"), ":")(0)

End If

api_url = SEARCHURL & "?appid=" & MYID & "&query=" & urlEncode(op_search) & _

op_category & op_kubun & op_lprice & op_uprice & op_ldecide & op_udecide & op_newold

'数を取得

Dim result_total As Long

Dim result_page As Long

Dim objtmp As Object

Set httpObj = CreateObject("Microsoft.XMLHTTP")

Call httpObj.Open("GET", api_url, False)

Call httpObj.setRequestHeader("Content-Type", "text/xml")

Call httpObj.Send(Null)

' 'DOM形式に変換これだとGet***が使える 'responseXML自体はいろんなメソッドを使えない

Set DomDoc = CreateObject("MSXML2.DOMDocument")

Call DomDoc.LoadXML(httpObj.responseText)

result_total = DomDoc.SelectSingleNode("//ResultSet/@totalResultsAvailable").Value

result_page = DomDoc.SelectSingleNode("//ResultSet/@totalResultsReturned").Value

Dim all_page As Long

all_page = result_total \ result_page

'全結果取得する処理

'ワークシートを作成

Dim ws_new As Worksheet

Worksheets.Add after:=Worksheets(Worksheets.Count)

Set ws_new = Worksheets(Worksheets.Count)

Dim ws_name As String

ws_name = Year(Now) & keta2(Month(Now)) & keta2(Day(Now)) & "_" & keta2(Hour(Now)) & keta2(Minute(Now)) & keta2(Second(Now))

ws_new.Name = ws_name

Dim I As Long

Dim J As Long

Dim c_row As Long

Dim page_rep As Long

Dim auc_id As Object

Dim auc_title As Object

Dim auc_price As Object

Dim auc_url As Object

Dim auc_etime As Object

'1ページ毎に情報を取得してシートに追加する

c_row = 2

For I = 0 To all_page

Call httpObj.Open("GET", api_url & "&page=" & I + 1, False)

Call httpObj.setRequestHeader("Content-Type", "text/xml")

Call httpObj.Send(Null)

Set DomDoc = CreateObject("MSXML2.DOMDocument")

DomDoc.LoadXML (httpObj.responseText)

Set auc_id = DomDoc.getElementsbytagName("AuctionID")

Set auc_title = DomDoc.getElementsbytagName("Title")

Set auc_price = DomDoc.getElementsbytagName("CurrentPrice")

Set auc_url = DomDoc.getElementsbytagName("AuctionItemUrl") 'ItemUrl

Set auc_etime = DomDoc.getElementsbytagName("EndTime")

' If I = all_page Then

' page_rep = result_total - 20 * I

' Else

' page_rep = 20

' End If

For J = 1 To auc_id.Length

ws_new.Cells(c_row, 1).NumberFormatLocal = "@" 'Formatを文字列に変更

ws_new.Cells(c_row, 1) = auc_id.Item(J - 1).Text

ws_new.Hyperlinks.Add Anchor:=ws_new.Cells(c_row, 1), Address:=auc_url.Item(J - 1).Text '商品ID部分にLINK追加

ws_new.Cells(c_row, 2) = auc_title.Item(J - 1).Text

ws_new.Cells(c_row, 3) = auc_price.Item(J - 1).Text

ws_new.Cells(c_row, 4) = time_format_change(auc_etime.Item(J - 1).Text)

'ws_new.Cells(c_row, 5) = auc_url.Item(J - 1).Text

c_row = c_row + 1

Next J

Next I

'見た目の処理

'説明列追加

ws_new.Cells(1, 1) = "ID"

ws_new.Cells(1, 2) = "TITLE"

ws_new.Cells(1, 3) = "PRICE"

ws_new.Cells(1, 4) = "終了日時"

ws_new.Range("A1:D1").Interior.ColorIndex = 6

'幅調整

ws_new.Columns("A:D").AutoFit

'履歴作成 (行をどんどん追加する)

'最終行から番号を取得

Dim row_max As Long

Dim rrk_num As Long

row_max = RRK.Range("A10000").End(xlUp).Row

If RRK.Cells(row_max, 1) = "番号" Then

rrk_num = 1

Else

rrk_num = RRK.Cells(row_max, 1) + 1

End If

'情報追記

RRK.Cells(row_max + 1, 1) = rrk_num

RRK.Cells(row_max + 1, 2) = ws_name

RRK.Hyperlinks.Add Anchor:=RRK.Cells(row_max + 1, 2), Address:="", SubAddress:="'" & ws_name & "'!A1"

RRK.Cells(row_max + 1, 3) = result_total

RRK.Cells(row_max + 1, 4) = KSK.Range("B2")

RRK.Cells(row_max + 1, 5) = KSK.Range("B3")

RRK.Cells(row_max + 1, 6) = KSK.Range("B4")

RRK.Cells(row_max + 1, 7) = KSK.Range("B5")

RRK.Cells(row_max + 1, 8) = KSK.Range("B6")

RRK.Cells(row_max + 1, 9) = KSK.Range("B7")

RRK.Cells(row_max + 1, 10) = KSK.Range("B8")

RRK.Cells(row_max + 1, 11) = KSK.Range("B9")

RRK.Cells(row_max + 1, 12) = KSK.Range("B10")

RRK.Cells(row_max + 1, 13) = KSK.Range("B11")

End Sub

Sub History_Apply()

End Sub

'文字コードをURLエンコードする%形式

'Private Function urlEncode(str As String) As String

' Dim sc As Object

' Dim js As Object

' Set sc = CreateObject("ScriptControl")

' sc.Language = "Jscript"

' Set js = sc.CodeObject

' urlEncode = js.encodeURIComponent(str)

'End Function

Private Function urlEncode(ByVal sWord As String) As String

Dim d As Object

Dim elm As Object

sWord = Replace(sWord, "\", "\\")

sWord = Replace(sWord, "'", "\'")

Set d = CreateObject("htmlfile")

Set elm = d.createElement("span")

elm.setAttribute "id", "result"

d.appendChild elm

d.parentWindow.execScript "document.getElementById('result').innerText = encodeURIComponent('" & sWord & "');", "JScript"

urlEncode = elm.innerText

End Function

Private Function keta2(ByVal dval As String) As String

If Len(dval) = 1 Then

keta2 = "0" & dval

Else

keta2 = dval

End If

End Function

Private Function time_format_change(ByVal str1 As String) As String

Dim tmp_day As String

tmp_day = Replace(Split(str1, "T")(0), "/", "")

Dim tmp_time As String

tmp_time = Replace(Split(str1, "T")(1), "+09:00", "")

time_format_change = tmp_day & " " & tmp_time

End Function

MENU

VBA関連

VBA関連