EXCEL VBA TIPS

キーワードサーチ

▼キーワード検索

プロフィール

EXCEL VBA TIPS

フォローする

楽天カード

カレンダー

お気に入りブログ

バンの日記 バン3105さん
Ｌｅｎｏ★ROOM レノママ♪さん
ＲＳ　うけぽの独り言 うけぽさん
ＬＡＨＡＩＮＡ’ｓ … lahaina13さん
ウサといっ緒　今日… チェシゃ猫さん

コメント新着

RaymondArout@ Безопасность Впервые с начала противостояния в украи…

RaymondArout@ Сенаторы Впервые с начала противостояния в украи…

RaymondArout@ Санкции Впервые с начала операции в украинский …

Harveytoogs@ сериалы онлайн сезон Элита сериалы он-лайн шара в течение пр…

RaymondArout@ Демократы Впервые с начала спецоперации в украинс…

フリーページ

2008.07.16

Yahooオークション取引ナビのメッセージを自動表示するVBS

(4)

テーマ：パソコン講師(288)

カテゴリ：カテゴリ未分類

”Yahoo!オークション取引連絡”メールをキーにメッセージのみIEの画面に表示するシェルです

ソースは以下
Set objIE = CreateObject("InternetExplorer.application")
objIE.Visible = false
Set objIEs = CreateObject("InternetExplorer.application")
objIEs.Visible = True
Set olAPP = CreateObject("Outlook.Application")
Set olNameSPC = olAPP.GetNamespace("MAPI") ' Namespace オブジェクト

mail_folder = "取引連絡"
For nFCNT = 1 To olNameSPC.Folders(1).Folders.Count
sss = olNameSPC.Folders(1).Folders(nFCNT).name
If olNameSPC.Folders(1).Folders(nFCNT).name = mail_folder Then Exit For
Next
If nFCNT > olNameSPC.Folders(1).Folders.Count Then
MsgBox (mail_folder & "はありません")
End If
'mail_num = olNameSPC.Folders(1).Folders(nFCNT).Count
hit = 0
nf = 0

With objItem
strSubject = .Subject
End With
id = strmid(strSubject, "(", ")")
url = "http://page.auctions.yahoo.co.jp/jp/show/contact?aID=" & id & "#message"

for bb= len(strSubject) to 1 step -1
if mid(strSubject,bb,1)=" " then exit for
key=mid(strSubject,bb,1) & key
next
msg = torihiki_navi_get_f(objIE, objIEs, url,key)
objItem.FlagStatus = 2 'olFlagMarked (2)をセット参照設定時は定数で
objItem.FlagRequest = "読んだよ " & Now 'フラグ内容をセット
'objItem.FlagDueBy = Now '今回は期限はセットしない
objItem.Save
Next
set objIE=nothing
Function torihiki_navi_get_f(objIE,objIEs,url,key)
'Dim s As String, msg As String
'url = Replace(url, "/auction/", "/show/contact?aID=") & "#message"
'http://page5.auctions.yahoo.co.jp/jp/auction/e70050275
'"http://page5.auctions.yahoo.co.jp/jp/show/contact?aID=e70050275#message"
objIE.Navigate url
Call ie_wait(objIE)
msg = ""
j = 0
For i = objIE.Document.links.Length - 6 To 0 Step -1
If InStr(objIE.Document.links(i).outertext, "連絡掲示板") > 0 Then Exit For
' If objIE.Document.links(i).outertext = "送付先住所、支払い、発送などについて" Or _
' objIE.Document.links(i).outertext = "その他" Or _
' objIE.Document.links(i).outertext = "支払いが完了しました" Or _
' objIE.Document.links(i).outertext = "商品を受け取りました" _
If objIE.Document.links(i).outertext = key Then
objIEs.Navigate objIE.Document.links(i).href
Call ie_wait(objIEs)
s = objIEs.Document.body.innerhtml
s = strmid(s, "WORD-BREAK", "")
s = strmid(s, " ", " ")
s = Replace(s, "
", vbCrLf)
msg = msg & s & vbCrLf & "***以上msg" & CStr(j) & "***"
j = j + 1
'Exit For
End If
Next
msg = Replace(msg, " ", "")
msg = Replace(msg, "　", "")
s = ""
mae = ""
For i = 1 To Len(msg)
If Mid(msg, i, 1) <> vbCr And Mid(msg, i, 1) <> vbCr Then
If mae <> "" Then s = s & mae
s = s & Mid(msg, i, 1)
s = ""
Else
If mae = Mid(msg, i, 1) Then
Else
s = s & Mid(msg, i, 1)
End If
End If
Next
torihiki_navi_get_f = msg
End Function
Function strmid(org,mae,usiro)
pos = InStr(org, mae)
If pos > 0 Then
strmid = Right(org, Len(org) - pos - Len(mae) + 1)
org = strmid
pos = InStr(strmid, usiro)
If usiro = "" Then
' strmid = ""
Else
If pos > 0 Then
strmid = Left(strmid, pos - 1)
End If
End If
Else
strmid = ""
End If
End Function
Sub ie_wait (objIE)
Do While objIE.busy
Loop
Do While objIE.Document.readyState <> "complete"
Loop
End Sub

お気に入りの記事を「いいね！」で応援しよう