「VBA(全般)」カテゴリーアーカイブ

VBA : WEB(http)先からファイル一括ダウンロード

投稿日時: 投稿者:

あるネットワーク上のファイル(今回はZIP)を一括ダウンロードする
前提:

  • 対象のファイルは同一URL配下に保管されている
  • 対象のファイルは複数ある
  • ダウンロード先(格納先)は固定で決まっている
  • 結果レポートも出力する

手順:

  • ソースに下記の修正を加える
  • コピー元のURLを指定(末尾は/で終わること)
  • コピー先のフォルダを指定(末尾は\で終わること)

下記説明:

  • 対象のファイル名リストを”_copy_list.txt”に格納し、そのファイルを”c:\temp\download\”に格納
  • 実行結果は、同フォルダ内に”_report.txt”として作成される(各行の1文字目が0なら成功)
  • 上記ファイル群が格納されているURLを準備”http://~~~~~~/~~~~~/”
  • あとは実行するだけ
'URLDownloadToFile API.
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
	"URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal _
	szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Sub batch()

	Dim strFNAME As String, strSRC_FILE As String
	Dim strRET As Variant
	strFNAME = "c:\temp\download\"
	
	Open strFNAME & "_copy_list.txt" For Input As #1
	Open strFNAME & "_report.txt" For Output As #2
	
	Do While Not EOF(1)
		Line Input #1, strSRC_FILE
		
		strRET = download(strSRC_FILE, strFNAME & strSRC_FILE)
		Print #2, strRET & vbTab; strSRC_FILE
		Debug.Print strSRC_FILE
		DoEvents
	Loop
	
	Close
	MsgBox "done!"
	
End Sub

'strURL:ダウンロード元URL(ファイル名のみ)
'strFNAME:格納先フルパス+ファイル名
Function download(strURL As String, strFNAME As String) As Variant
	Dim base_url As String
	base_url = "http://~~~~~~/~~~~~/" & strURL
	download = URLDownloadToFile(0, base_url, strFNAME, 0, 0)

End Function

IE:frame処理

投稿日時: 投稿者:

参照設定にて下記の２つを有効にする
MS Internet Controls :IEのため
MS HTML Object Library :フレーム処理

該当のURLを開いて、左フレーム内のURLをクリック
上フレームのTEXTBOXに値をセットしてSUBMIT
右フレームに出てきた値(結果)を取り出す

Private Sub html_go()
	Dim IE As InternetExplorer
	Dim objFRAME As FramesCollection
	Dim objDOC As HTMLDocument

	Set IE = CreateObject("internetExplorer.application")

	IE.Navigate "http://~~~/"
	IE.Visible = True
	Do While IE.Busy = True: DoEvents: Loop

	Set objFRAME = IE.Document.frames
	'NAME=lview　のフレーム内処理
	Set objDOC = objFRAME("F_left").Document
	objDOC.all.Item(23).Click 'HWInfo click
	Do While IE.Busy = True: DoEvents: Loop

	Set objFRAME = IE.Document.frames
	'NAME=tview　のフレーム内処理
	Set objDOC = objFRAME("F_top").Document

	objDOC.all("text box").Value = "値"
	objDOC.forms(0).submit
	Do While IE.Busy = True: DoEvents: Loop

	'NAME=rview　のフレーム内処理
	Set objDOC = objFRAME("F_right").Document
	strHTML = objDOC.all(0).innerText

	Debug.Print strHTML
	Set IE = Nothing
	MsgBox "done!"
End Sub

Outlookを呼び出してMail作成

投稿日時: 投稿者: 
'Outlookを呼び出してMail作成
Sub OUTLOOK()
	Dim objOutlook As OUTLOOK.Application
	Dim objOutlookMsg As OUTLOOK.MailItem
	Dim objOutlookRecip As OUTLOOK.Recipient
	Dim objOutlookAttach As OUTLOOK.Attachment
	
	Set objOutlook = CreateObject(“Outlook.Application")
	Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
	'メイン
	With objOutlookMsg
		.Subject = “title"
		.Body = “本文"
		'宛先準備
		Set objOutlookRecip = .Recipients.Add(“xxx@bbb.com")
		objOutlookRecip.Type = olTo
		Set objOutlookRecip = .Recipients.Add(“zzz@bbb.com")
		objOutlookRecip.Type = olCC
		'完成Mailを表示
		.Display
		'いきなり送付させる場合は下記を使用
		'.SEND
	End With
	
	Set objOutlookMsg = Nothing
	Set objOutlook = Nothing
	
	MsgBox “送付完了！"

End Sub

IEを呼び出し＆URL指定で開く

投稿日時: 投稿者: 
'FIELDをWクリックしたら、IE呼び出し
Private Sub FIELD_DblClick(Cancel As Integer)
	'
	Dim IE As Object
	'IE準備
	Set IE = CreateObject(“internetExplorer.application")
	'IE起動＆URL開く
	IE.Navigate “http://~~~~?xxx=" & ZZZ.Value
	'IE表示
	IE.Visible = True
	'表示終わるまで待機
	Do While IE.Busy = True: DoEvents: Loop
	'リソース開放
	Set IE = Nothing
	'
End Sub

APIを使ってログイン名を取得

投稿日時: 投稿者: 
'Windowsログイン名取得API
Private Declare Function GetUserName Lib “ADVAPI32.dll" _
	Alias “GetUserNameA" _
	(ByVal lpBuffer As String, nSize As Long) As Long

Sub test()
	Dim strBuffer As String
	Dim lngLngs As Long
	Dim lngRet As Long
	Dim Get_User As String
	'
	' Bufferを確保
	strBuffer = String(256, Chr(0))
	lngLngs = Len(strBuffer)
	'
	' ログインユーザー名取得
	lngRet = GetUserName(strBuffer, lngLngs)
	Get_User = UCase(Left$(strBuffer, InStr(1, strBuffer, Chr(0)) – 1))
	'
	MsgBox Get_User
	'
End Sub