การดาวน์โหลดไฟล์จาก อินเทอร์เน็ต ด้วย Access 2010 VBA

ก่อนการใช้ MS Access 2010 ดาวน์โหลดไฟล์จากอินเทอร์เน็ต ต้องตรวจสอบเสียก่อนว่า ขณะนี้สามารถเข้าอินเทอร์เน็ตได้หรือไม่ โดยใช้ฟังก์ชันต่อไปนี้

Function checkInternetConnection() As Integer
'code to check for internet connection
'by Daniel Isoje
On Error Resume Next
 checkInternetConnection = False
 Dim objSvrHTTP As ServerXMLHTTP
 Dim varProjectID, varCatID, strT As String
 Set objSvrHTTP = New ServerXMLHTTP
 objSvrHTTP.Open "GET", "http://www.google.com"
 objSvrHTTP.setRequestHeader "Accept", "application/xml"
 objSvrHTTP.setRequestHeader "Content-Type", "application/xml"
 objSvrHTTP.send strT
 If Err = 0 Then
 checkInternetConnection = True
 Else
  MsgBox "Internet connection not estableshed: " & Err.Description & "", 64, "Additt !"
 End If
End Function

ฟังก์ชันนี้ ต้องอ้างอิงถึง Microsoft XML, v6.0 เสียก่อน จึงจะใช้งานได้ โดยที่หน้าจอเขียนโค้ด ไปที่ Tool > References... และเลือก Microsoft XML, v6.0

เรียกใช้ฟังก์ชันข้างต้น เพื่อตรวจสอบ ดังนี้

Private Sub Form_Load()
Dim isConnection As Boolean
isConnection = checkInternetConnection()
If isConnection = True Then
    MsgBox "ตรวจสอบการต่อเชื่อมอินเทอร์เน็ต" & vbCrLf & "ขณะนี้สามารถติดต่อกับอินเทอร์เน็ตได้", vbOKOnly, "การต่อเชื่อมอินเทอร์เน็ต"
End If
End Sub

ถ้ามีการต่อเชื่อม จะมีหน้าจอปรากฏ ดังนี้

เมื่อตรวจสอบการต่อเชื่อมแล้วจึงทำการดาวน์โหลด

การดาวน์โหลด ใช้ฟังก์ชันต่อไปนี้

Public 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
Private Declare Function DeleteUrlCacheEntry Lib "wininet.dll" Alias _
    "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
Function DownloadFile()
On Error GoTo err_1
Dim lngPCallerParam As Long
Dim strURLParam As String
Dim strFilenameParam As String
Dim returnValue As Long
On Error GoTo err_1
    strURLParam = "http://www.yourdomain.com/yourfile.txt"
    strFilenameParam = "C:\Temp\yourfile.txt"
    DeleteUrlCacheEntry strURLParam
    returnValue = URLDownloadToFile(0, strURLParam, strFilenameParam, 0, 0)

Err_Exit:
    Exit Function
   
err_1:
    MsgBox Err.Description
    Resume Err_Exit
End Function

โค้ดข้างต้น ดาวน์โหลดไฟล์ที่ระบุ และนำมาเก็บไว้ที่ C:\Temp\yourfile.txt โดยต้องมีห้องนั้นอยู่แล้ว ถ้ามีไฟล์เดิมไฟล์ที่ดาวน์โหลดจะปรับข้อมูลเป็นของใหม่ตามที่ดาวน์โหลดลงมา

ในกรณีที่ยังไม่มีห้อง ไม่มีไฟล์ ต้องสร้างเสียก่อน โดยใช้ VBA ดังนี้

Sub CreateTextFile()
Dim fs, TextFile
Set fso = New FileSystemObject
If Not fso.FolderExists("c:\temp") Then
    fso.CreateFolder "c:\temp"
End If
Set fs = CreateObject("Scripting.FileSystemObject")
Set TextFile = fs.CreateTextFile("c:\Temp\yourfile.txt", True)
TextFile.WriteLine (" ")
TextFile.Close
End Sub

โค้ดข้างบนต้องอ้างอิง Microsoft Scripting Runtime โดยไปที่ Tool > References และเลือก Microsoft Scripting Runtime

จากภาพ จะสังเกตว่า เรามีการเรียกใช้ ทั้ง Microsoft XML, v6.0 และ Microsoft Scripting Runtime

การเรียกใช้งานการดาวน์โหลด สามารถเรียกใช้งาน โดยเรียกที่ On load Event ของฟอร์ม หรือจะสร้างเป็นปุ่ม และวางโค้ดที่ On Click ก็ได้

Private Sub Form_Load()
Dim isConnection As Boolean
isConnection = checkInternetConnection()
If isConnection = True Then
    CreateTextFile 'ถ้ายังไม่มีห้อง สร้างห้องและไฟล์เสียก่อน
    DownloadFile
End If
   
End Sub

ที่มา
http://stackoverflow.com/questions/551613/check-for-active-internet-connection
http://www.experts-exchange.com/Microsoft/Development/MS_Access/Q_27835821.html
http://www.wiseowl.co.uk/blog/s210/filesystemobject.htm