'***************************************************************************************************
' Web上からデータファイルをダウンロードしてシートに読み込むサンプル Module1(Module)
'
' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
' [参照設定]
' ・Microsoft Scripting Runtime
'***************************************************************************************************
'変更日付 Rev 変更履歴内容------------------------------------------------------------------------>
'04/06/27(1.00)新規作成
'20/03/21(1.10)*.xlsm化、コード整理他
'21/10/21(1.10)データ取得URLの暗号化(https)に変更
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsTitle As String = "Webからダウンロード"
Private Const g_cnsSh1 As String = "Sheet1"
Private Const g_cnsURL As String = "https://www.asahi-net.or.jp/~ef2o-inue/download/URIAGE.dat"
Private Const g_cnsSaveFile As String = "RCVDATA.dat"
'***************************************************************************************************
' ■■■ ワークシート側からの呼び出し処理 ■■■
'***************************************************************************************************
'* 処理名 :Auto_Open
'* 機能 :開く時に自動で実行される処理
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年06月27日
'* 作成者 :井上 治
'* 更新日 :2020年03月21日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:※スクリプトから制御する場合は不要
'***************************************************************************************************
Private Sub Auto_Open()
'-----------------------------------------------------------------------------------------------
If MsgBox(g_cnsURL & vbCr & "からデータを読み込みます。よろしいですね?", _
vbInformation + vbYesNo, g_cnsTitle) <> vbYes Then Exit Sub
' メイン処理を呼び出す
Call GET_DAT_FILE(g_cnsURL, 0)
End Sub
'***************************************************************************************************
' ■■■ 公開プロシージャ ■■■
'***************************************************************************************************
'* 処理名 :GET_DAT_FILE
'* 機能 :Web上のTab区切りデータを受取りシートに読み込むサンプル
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :Arg1 = ダウンロード元のURL(String)
'* Arg2 = vntNewBook : 0=新規ブックを作らない、1=編集後に新規ブックに転出
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年06月27日
'* 作成者 :井上 治
'* 更新日 :2020年03月21日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Public Sub GET_DAT_FILE(ByVal vntURL As Variant, ByVal vntNewBook As Variant)
'-----------------------------------------------------------------------------------------------
Dim objFso As FileSystemObject ' FileSystemObject
Dim objTs As TextStream ' TextStream
Dim objWbk As Workbook ' 本ブック
Dim objSh1 As Worksheet ' 本ブックのシート
Dim strFilename As String ' ファイル名(フルパス)
Dim lngRow As Long ' 行INDEX
Dim lngCol As Long ' カラムINDEX
Dim lngIx As Long ' テーブルINDEX
Dim strRec As String ' レコード内容
Dim vntRec As Variant ' レコード内容(Tab区切り分解後)
Dim strMSG As String ' メッセージWORK
Dim strErrMSG As String ' エラーメッセージ
Set objWbk = ThisWorkbook
Set objSh1 = objWbk.Worksheets(g_cnsSh1)
Set objFso = New FileSystemObject
strFilename = objFso.BuildPath(modWinInetDownLoad.FP_GetTempPath, g_cnsSaveFile)
' 画面描画更新停止
Call GP_Stop_SCUPD
' URL受信処理→[TEMPDIR]\RCVDATA.dat
If Not modWinInetDownLoad.DownLoadFile(CStr(vntURL), strFilename, strErrMSG) Then
GoTo GET_CSV_FILE_EXIT
End If
On Error GoTo GET_CSV_FILE_ERROR
strMSG = "受信ファイル内容異常"
lngRow = 0
' ファイルOPEN
Set objTs = objFso.OpenTextFile(strFilename, ForReading, False)
' 最終レコードまで繰り返す
Do Until objTs.AtEndOfStream
' レコード読み込み
strRec = objTs.ReadLine
' Tab(&H09)をセパレータとして分解
vntRec = Split(strRec, vbTab, -1, vbTextCompare)
' セルに展開
lngRow = lngRow + 1
Application.StatusBar = lngRow
For lngIx = 0 To UBound(vntRec)
lngCol = lngIx + 1
objSh1.Cells(lngRow, lngCol).Value = vntRec(lngIx)
Next lngIx
Loop
' ファイルCLOSE
objTs.Close
Set objTs = Nothing
' データを貼ったシートを新規ブックに転出
If vntNewBook = "1" Then objSh1.Copy
GoTo GET_CSV_FILE_EXIT
'===================================================================================================
' エラートラップ
GET_CSV_FILE_ERROR:
If Err.Number <> 0 Then strMSG = strMSG & " ( " & Err.Description & " )"
strErrMSG = strMSG
'===================================================================================================
' 終了
GET_CSV_FILE_EXIT:
Set objFso = Nothing
On Error GoTo 0
' 画面描画更新復帰
Call GP_Start_SCUPD
' エラー表示
If strErrMSG <> "" Then
MsgBox strErrMSG, vbCritical, g_cnsTitle
End If
objWbk.Saved = True
End Sub
'***************************************************************************************************
' ■■■ サブ処理(Private) ■■■
'***************************************************************************************************
'* 処理名 :GP_Stop_SCUPD
'* 機能 :画面描画更新停止
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年06月27日
'* 作成者 :井上 治
'* 更新日 :2004年06月27日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_Stop_SCUPD()
'-----------------------------------------------------------------------------------------------
With Application
.ScreenUpdating = False
' .EnableCancelKey = xlDisabled
.Calculation = xlCalculationManual
.Cursor = xlWait
.EnableEvents = False
End With
End Sub
'***************************************************************************************************
'* 処理名 :GP_Start_SCUPD
'* 機能 :画面描画更新再開
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年06月27日
'* 作成者 :井上 治
'* 更新日 :2004年06月27日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_Start_SCUPD()
'-----------------------------------------------------------------------------------------------
With Application
.Calculation = xlCalculationAutomatic
.Cursor = xlDefault
.EnableCancelKey = xlInterrupt
.EnableEvents = True
.StatusBar = False
.ScreenUpdating = True
End With
End Sub
'----------------------------------------<< End of Source >>----------------------------------------
![]() |
←WinInetDownLoad.zip (48KB) |
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<HTML>
<HEAD>
<META http-equiv="Content-Type" content="text/html; charset=Shift_JIS">
<META name="author" content="井上治">
<META name="keywords" content="Excel,VBA,マクロ,計算式,コンピュータ">
<META http-equiv="Content-Style-Type" content="text/css">
<TITLE>Excelでお仕事!(Excelダウンロードサンプル)</TITLE>
<LINK rel="stylesheet" href="../_styles/Excel_t08.css" type="text/css">
<SCRIPT language="VBScript">
Sub Window_OnLoad()
Const cnsURL = "https://www.asahi-net.or.jp/~ef2o-inue/download/"
Const cnsBook = "WinInetDownLoad.xlsm"
Const cnsData = "URIAGE.dat"
' Excel展開
Dim objExcelApp, objExcelBook
Set objExcelApp = CreateObject("Excel.Application")
' URL指定のワークブックを開く
Set objExcelBook = objExcelApp.Workbooks.Open(cnsURL & "Excel/" & cnsBook, , True)
objExcelApp.Visible = True
' URL指定のデータファイルをExcel側マクロに通知して開かせる
objExcelApp.Run "'" & cnsBook & "'!GET_DAT_FILE", cnsURL & cnsData, 1
' マクロが終了したブックは閉じる
objExcelBook.Saved = True
objExcelBook.Close False
Set objExcelBook = Nothing
Set objExcelApp = Nothing
window.close()
End Sub
</SCRIPT>
</HEAD>
<BODY>
<P>ダウンロード中です。</P>
</BODY>
</HTML>