How to ask xl to download from web from access
Paul Fitzsimmons
a web page, download it and then open it up?
Thanks
--
Paul Fitzsimmons
Dev Ashish
Are you trying to download from a HTTP server or an FTP one? If it's an FTP
site, you can use MS FTP along with a script file to save the file locally.
If it's HTTP, then the only way I know of is to use WinInet (IE) API
functions.
The WinInet code I have was originally written for Access, but should work
fine with Excel. Post back if you need it.
HTH
--
Dev Ashish (Just my $.001)
---------------
The Access Web ( http://home.att.net/~dashish )
---------------
Paul Fitzsimmons wrote in message <369D8CBD...@shaw.wave.ca>...
:I know how to open excel up from access but how do I get excel to go to
Paul Fitzsimmons
non-tabular, non-delimited info into tables so I can compare the info to
other linked tables. Do you know the best way to do this? The address
is http://www.assembly.ab.ca/conlist/Mla.htm#amery
this is kinda a make work project as I am a student. Any help wiil be
greatly appreciated.
Thanks
Paul
Lydia Gomeral
Please post it here so that I can look at/use it too. TIA.
---
Lydia
Paul Fitzsimmons wrote in message <369E8459...@shaw.wave.ca>...
Dev Ashish
1) This code was written in VB 6 (dll) originally. The VB specific code
has been commented out.
2) The object(s) are still in test mode. Once finished, they'll be
available along with source code at my website.
3) Your comments or bug reports would be highly appreciated (see 2 :-) ) on
the emails in the comments.
4) There are two identical methods, WriteHTTPDataToString and
WriteHTTPDataToFile. While the former returns the entire HTML code or fiile
as a string (for you to parse out), the latter writes the same as a binary
local file. Therefore, only one should be used at one time.
5) The functions being used are installed as part of Internet Explorer. As
far as we know, all functions are IE 3.x based and 4.x compatible, but the
testing is not complete yet.
6) Because of the Err.Raise convention used, it's recommended that the
"Error Trapping" option under Tools/Options be set to "Break on Unhandled
Errors". You can include this in Class_Initialize and Class_Terminate subs
to handle it automatically.
7) Watch out for line wraps. :-)
Usage example:
'************* Usage Example Start *************
Sub TestHTTP()
On Error GoTo ErrHandler
Dim objHTTP as HTTP
Const conTARGET = "http://home.att.net/~dashish/acknowledge.htm"
Set objHTTP = New HTTP
With objHTTP
.HttpURL = conTARGET
.DestinationFile = "j:\temp\test.htm"
If .FileExists Then .OverwriteTarget = True
'.PromptWithCommonDialog = True
If Not .IsConnected Then .DialDefaultNumber
.ConnectToHTTPHost
'Call SysCmd(acSysCmdInitMeter, "Downloading '" & _
conTARGET & "'", 100)
.WriteHTTPDataToFile
End With
ExitHere:
On Error Resume Next
Set objHTTP = Nothing
'Call SysCmd(acSysCmdRemoveMeter)
Exit Sub
ErrHandler:
MsgBox Err.Number & vbCrLf & Err.Description, vbCritical + vbOKOnly,
Err.Source
Resume ExitHere
End Sub
'************* Usage Example End *************
Stuff which will go in a standard module
'************* Module modMain Start ***********
' Comments and bug reports can be emailed to us
' Terry Kreft (terry...@mps.co.uk); Dev Ashish (das...@hotmail.com)
'
'
Public Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Public Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * 260
cAlternate As String * 16
End Type
Public Type URL_COMPONENTS
dwStructSize As Long
lpszScheme As String
dwSchemeLength As Long
nScheme As Long
lpszHostName As String
dwHostNameLength As Long
nPort As Long
lpszUserName As String
dwUserNameLength As Long
lpszPassword As String
dwPasswordLength As Long
lpszUrlPath As String
dwUrlPathLength As Long
lpszExtraInfo As String
dwExtraInfoLength As Long
End Type
Public Declare Function apiInetGetConnectedState Lib "wininet.dll" _
Alias "InternetGetConnectedState" _
(ByVal lpdwFlags As Long, ByVal dwReserved As Long) As Long
Public Declare Function apiInetReadFile Lib "wininet.dll" _
Alias "InternetReadFile" _
(ByVal hFile As Long, lpBuffer As Any, _
ByVal dwBytesToRead As Long, lpBytesRead As Long) As Long
Public Declare Function apiInetReadFileStr Lib "wininet.dll" _
Alias "InternetReadFile" _
(ByVal hFile As Long, ByVal lpBuffer As String, _
ByVal dwBytesToRead As Long, lpBytesRead As Long) As Long
Public Declare Function apiInetOpenURL Lib "wininet.dll" _
Alias "InternetOpenUrlA" _
(ByVal hInternet As Long, ByVal lpszUrl As String, _
ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, _
ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Public Declare Function apiInetOpen Lib "wininet.dll" _
Alias "InternetOpenA" _
(ByVal lpszAgent As String, ByVal dwAccessType As Long, _
ByVal lpszProxy As String, ByVal lpszProxyBypass As String, _
ByVal dwFlags As Long) As Long
Public Declare Function apiInetCloseHandle Lib "wininet.dll" _
Alias "InternetCloseHandle" _
(ByVal hInet As Long) As Long
Public Declare Function apiInetQueryDataAvailable Lib "wininet.dll" _
Alias "InternetQueryDataAvailable" _
(ByVal hFile As Long, lpdwNumberOfBytesAvailable As Long, _
ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Public Declare Function apiInetQueryOption Lib "wininet.dll" _
Alias "InternetQueryOptionA" _
(ByVal hInternet As Long, ByVal dwOption As Long, _
lpBuffer As Any, ByRef lpdwBufferLength As Long) _
As Long
Public Declare Function apiInetCrackUrl Lib "wininet.dll" _
Alias "InternetCrackUrlA" _
(ByVal lpszUrl As String, ByVal dwUrlLength As Long, _
ByVal dwFlags As Long, _
lpUrlComponents As URL_COMPONENTS) As Long
Public Declare Function apiInetCanonicalizeUrl Lib "wininet.dll" _
Alias "InternetCanonicalizeUrlA" _
(ByVal lpszUrl As String, ByVal lpszBuffer As String, _
lpdwBufferLength As Long, ByVal dwFlags As Long) As Long
Public Declare Function apiInetGetLastResponse Lib "wininet.dll" _
Alias "InternetGetLastResponseInfoA" _
(lpdwError As Long, ByVal lpszBuffer As String, _
lpdwBufferLength As Long) As Long
Public Declare Function apiInetWriteFile Lib "wininet.dll" _
Alias "InternetWriteFile" _
(ByVal hFile As Long, lpBuffer As Any, _
ByVal dwNumberOfBytesToWrite As Long, _
ByVal lpdwNumberOfBytesWritten As Long) As Long
Public Declare Function apiHttpQueryInfoStr Lib "wininet.dll" _
Alias "HttpQueryInfoA" _
(ByVal hHttpRequest As Long, ByVal dwInfoLevel As Long, _
ByVal lpvBuffer As String, lpdwBufferLength As Long, _
lpdwIndex As Long) As Long
Public Declare Function apiFtpOpenFile Lib "wininet.dll" _
Alias "FtpOpenFileA" _
(ByVal hFtpSession As Long, ByVal lpszFileName As String, _
ByVal fdwAccess As Long, ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Public Declare Function apiFtpGetFile Lib "wininet.dll" _
Alias "FtpGetFileA" _
(ByVal hFtpSession As Long, ByVal lpszRemoteFile As String, _
ByVal lpszNewFile As String, ByVal fFailIfExists As Long, _
ByVal dwLocalFlagsAndAttributes As Long, ByVal dwInternetFlags As Long, _
ByVal dwContext As Long) As Long
Public Declare Function apiFtpFindFirstFile Lib "wininet" _
Alias "FtpFindFirstFileA" _
(ByVal hFtpSession As Long, ByVal lpszSearchFile As String, _
lpFindFileData As WIN32_FIND_DATA, _
ByVal dwContext As Long) As Long
Public Declare Function apiFtpCreateDir Lib "wininet" _
Alias "FtpCreateDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszDirectory As String) _
As Long
Public Declare Function apiFtpRemoveDir Lib "wininet" _
Alias "FtpRemoveDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszDirectory As String) _
As Long
Public Declare Function apiFtpSetCurrentDir Lib "wininet" _
Alias "FtpSetCurrentDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Long
Public Declare Function apiFtpGetCurrentDir Lib "wininet" _
Alias "FtpGetCurrentDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszCurrentDirectory As String, _
lpdwCurrentDirectory As Long) As Long
Public Declare Function apiFTPPutFile Lib "wininet.dll" _
Alias "FtpPutFileA" _
(ByVal hFtpSession As Long, ByVal lpszLocalFile As String, _
ByVal lpszNewRemoteFile As String, ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Public Declare Function apiInetSetStatusCallback Lib "wininet.dll" _
Alias "InternetSetStatusCallback" _
(ByVal hInternet As Long, _
ByVal lpfnInternetCallback As Long) _
As Long
Public Declare Function apiInetConnect Lib "wininet.dll" _
Alias "InternetConnectA" _
(ByVal hInternet As Long, ByVal lpszServerName As String, _
ByVal nServerPort As Integer, ByVal lpszUserName As String, _
ByVal lpszPassword As String, ByVal dwService As Long, _
ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Public Declare Function apiInetAutodial Lib "wininet.dll" _
Alias "InternetAutodial" _
(ByVal dwFlags As Long, ByVal dwReserved As Long) _
As Long
Public Declare Function apiInetGoOnline Lib "wininet.dll" _
Alias "InternetGoOnline" _
(ByVal lpszUrl As String, ByVal hwndParent As Long, _
ByVal dwReserved As Long) _
As Long
Public Declare Function apiInetAutodialHangup Lib "wininet.dll" _
Alias "InternetAutodialHangup" _
(ByVal dwReserved As Long) As Long
Public Declare Function apiCreateFile Lib "kernel32.dll" _
Alias "CreateFileA" _
(ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, _
ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) As Long
Public Declare Function apiWriteFile Lib "kernel32.dll" _
Alias "WriteFile" _
(ByVal hFile As Long, lpBuffer As Any, _
ByVal nNumberOfBytesToWrite As Long, _
lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) _
As Long
Public Declare Function apiReadFile Lib "kernel32" _
Alias "ReadFile" (ByVal hFile As Long, _
lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, _
lpNumberOfBytesRead As Long, ByVal lpOverlapped As Long) As Long
Public Declare Function apiFlushFileBuffers Lib "kernel32.dll" _
Alias "FlushFileBuffers" _
(ByVal hFile As Long) As Long
Public Declare Function apiCloseHandle Lib "kernel32.dll" _
Alias "CloseHandle" (ByVal hObject As Long) As Long
Public Const INTERNET_SCHEME_UNKNOWN = -1
Public Const INTERNET_OPEN_TYPE_PRECONFIG = 0&
Public Const INTERNET_OPEN_TYPE_DIRECT = 1&
Public Const INTERNET_OPEN_TYPE_PROXY = 3&
Public Const INTERNET_DEFAULT_FTP_PORT = 21
Public Const INTERNET_INVALID_PORT_NUMBER = 0
Public Const INTERNET_SERVICE_FTP = 1
Public Const INTERNET_SERVICE_GOPHER = 2
Public Const INTERNET_SERVICE_HTTP = 3
Public Const FTP_TRANSFER_TYPE_ASCII = &H1
Public Const FTP_TRANSFER_TYPE_BINARY = &H2
Public Const FTP_TRANSFER_TYPE_MASK = FTP_TRANSFER_TYPE_ASCII _
Or FTP_TRANSFER_TYPE_BINARY
Public Const INTERNET_FLAG_ASYNC = &H10000000
Public Const INTERNET_FLAG_EXISTING_CONNECT = &H20000000
Public Const INTERNET_FLAG_RAW_DATA = &H40000000
Public Const INTERNET_FLAG_RELOAD = &H80000000
Public Const INTERNET_FLAG_DONT_CACHE = &H4000000
Public Const INTERNET_FLAG_MAKE_PERSISTENT = &H2000000
Public Const INTERNET_FLAG_PASSIVE = &H8000000
Public Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000
Public Const INTERNET_FLAG_TRANSFER_BINARY = &H2
Public Const INTERNET_CONNECTION_MODEM = 1
Public Const INTERNET_CONNECTION_LAN = 2
Public Const INTERNET_CONNECTION_PROXY = 4
Public Const INTERNET_CONNECTION_MODEM_BUSY = 8
Public Const INTERNET_AUTODIAL_FORCE_ONLINE = 1
Public Const INTERNET_AUTODIAL_FORCE_UNATTENDED = 2
Public Const HTTP_QUERY_FLAG_REQUEST_HEADERS = &H80000000
Public Const HTTP_QUERY_STATUS_CODE = 19
Public Const HTTP_QUERY_STATUS_TEXT = 20
Public Const HTTP_STATUS_CONTINUE = 100 ' OK to continue with
request
Public Const HTTP_STATUS_SWITCH_PROTOCOLS = 101 ' server has switched
protocols in upgrade header
Public Const HTTP_STATUS_OK = 200 ' request completed
Public Const HTTP_STATUS_CREATED = 201 ' object created, reason
= new URI
Public Const HTTP_STATUS_ACCEPTED = 202 ' async completion (TBS)
Public Const HTTP_STATUS_PARTIAL = 203 ' partial completion
Public Const HTTP_STATUS_NO_CONTENT = 204 ' no info to return
Public Const HTTP_STATUS_RESET_CONTENT = 205 ' request completed, but
clear form
Public Const HTTP_STATUS_PARTIAL_CONTENT = 206 ' partial GET furfilled
Public Const HTTP_STATUS_AMBIGUOUS = 300 ' server couldn't decide
what to return
Public Const HTTP_STATUS_MOVED = 301 ' object permanently
moved
Public Const HTTP_STATUS_REDIRECT = 302 ' object temporarily
moved
Public Const HTTP_STATUS_REDIRECT_METHOD = 303 ' redirection w/ new
access method
Public Const HTTP_STATUS_NOT_MODIFIED = 304 ' if-modified-since was
not modified
Public Const HTTP_STATUS_USE_PROXY = 305 ' redirection to proxy,
location header specifies proxy to use
Public Const HTTP_STATUS_REDIRECT_KEEP_VERB = 307 ' HTTP/1.1: keep same
verb
Public Const HTTP_STATUS_BAD_REQUEST = 400 ' invalid syntax
Public Const HTTP_STATUS_DENIED = 401 ' access denied
Public Const HTTP_STATUS_PAYMENT_REQ = 402 ' payment required
Public Const HTTP_STATUS_FORBIDDEN = 403 ' request forbidden
Public Const HTTP_STATUS_NOT_FOUND = 404 ' object not found
Public Const HTTP_STATUS_BAD_METHOD = 405 ' method is not allowed
Public Const HTTP_STATUS_NONE_ACCEPTABLE = 406 ' no response acceptable
to client found
Public Const HTTP_STATUS_PROXY_AUTH_REQ = 407 ' proxy authentication
required
Public Const HTTP_STATUS_REQUEST_TIMEOUT = 408 ' server timed out
waiting for request
Public Const HTTP_STATUS_CONFLICT = 409 ' user should resubmit
with more info
Public Const HTTP_STATUS_GONE = 410 ' the resource is no
longer available
Public Const HTTP_STATUS_LENGTH_REQUIRED = 411 ' the server refused to
accept request w/o a length
Public Const HTTP_STATUS_PRECOND_FAILED = 412 ' precondition given in
request failed
Public Const HTTP_STATUS_REQUEST_TOO_LARGE = 413 ' request entity was too
large
Public Const HTTP_STATUS_URI_TOO_LONG = 414 ' request URI too long
Public Const HTTP_STATUS_UNSUPPORTED_MEDIA = 415 ' unsupported media type
Public Const HTTP_STATUS_SERVER_ERROR = 500 ' internal server error
Public Const HTTP_STATUS_NOT_SUPPORTED = 501 ' required not supported
Public Const HTTP_STATUS_BAD_GATEWAY = 502 ' error response received
from gateway
Public Const HTTP_STATUS_SERVICE_UNAVAIL = 503 ' temporarily overloaded
Public Const HTTP_STATUS_GATEWAY_TIMEOUT = 504 ' timed out waiting for
gateway
Public Const HTTP_STATUS_VERSION_NOT_SUP = 505 ' HTTP version not
supported
Public Const ICU_NO_ENCODE = &H20000000 '// Don't convert unsafe
characters to escape sequence
Public Const ICU_DECODE = &H10000000 '//Convert %XX escape sequences to
characters
Public Const ICU_NO_META = &H8000000 '//Don't convert .. etc. meta path
sequences
Public Const ICU_ENCODE_SPACES_ONLY = &H4000000 '// Encode spaces only
Public Const ICU_BROWSER_MODE = &H2000000
Public Const ICU_ESCAPE = &H80000000 '// (un)escape URL characters
Public Const INTERNET_ERROR_BASE = 12000
Public Const ERROR_BAD_PATHNAME = 161
Public Const ERROR_INVALID_PARAMETER = &H87
Public Const ERROR_INTERNET_INVALID_URL = (INTERNET_ERROR_BASE + 5)
Public Const ERROR_INSUFFICIENT_BUFFER = 122
Public Const GENERIC_READ = &H80000000
Public Const GENERIC_WRITE = &H40000000
Public Const OPEN_EXISTING = 3
Public Const CREATE_ALWAYS = 2
Public Const INVALID_HANDLE_VALUE = -1
Public Const FILE_ATTRIBUTE_NORMAL = &H80
Public Const MAX_CHUNK = 4096
Public Const MAX_PATH = 260
Public Const MAX_BUFFER = 1024
Private Declare Function apiFormatMsgLong Lib "kernel32" _
Alias "FormatMessageA" _
(ByVal dwFlags As Long, _
ByVal lpSource As Long, _
ByVal dwMessageId As Long, _
ByVal dwLanguageId As Long, _
ByVal lpBuffer As String, _
ByVal nSize As Long, _
Arguments As Long) _
As Long
Public Declare Function apiGetActiveWindow Lib "user32" _
Alias "GetActiveWindow" () As Long
Public Const ERROR_NO_MORE_FILES = 18
Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
Function fAPIErr(ByVal lngErr As Long) As String
'Original Idea obtained from
'Hardcode Visual Basic 5
'by Bruce McKinney
'
Dim strMsg As String
Dim lngRet As Long
strMsg = String$(1024, 0)
lngRet = apiFormatMsgLong(FORMAT_MESSAGE_FROM_SYSTEM, 0&, _
lngErr, 0&, strMsg, Len(strMsg), ByVal 0&)
If Not lngRet = 0 Then
fAPIErr = left$(strMsg, lngRet)
End If
End Function
Function fInetError(ByVal lngErrCode As Long) As String
Dim lngLen As Long, strBuffer As String
Call apiInetGetLastResponse(lngErrCode, vbNullString, lngLen)
strBuffer = String$(lngLen + 1, 0)
Call apiInetGetLastResponse(lngErrCode, strBuffer, lngLen)
fInetError = strBuffer
End Function
Function fTrimNull(ByVal strIn As String) As String
fTrimNull = left$(strIn, InStr(strIn, vbNullChar) - 1)
End Function
Function fGetHTTPErrCode(ByVal strError As String) As String
Dim strOut As String
Select Case CInt(strError)
Case 101: strOut = "Server has switched protocols in upgrade header."
Case 204: strOut = "No info to return."
Case 300: strOut = "Server couldn't decide what to return."
Case 301: strOut = "Object permanently moved"
Case 302: strOut = "Object temporarily moved"
Case 303: strOut = "Redirection with new access method."
Case 304: strOut = "If-modified-since was not modified."
Case 305: strOut = "Redirection to proxy, location header specifies
proxy to use."
Case 307: strOut = "HTTP/1.1: keep same verb"
Case 400: strOut = "Invalid syntax."
Case 401: strOut = "Access denied."
Case 402: strOut = "Payment required."
Case 403: strOut = "Request forbidden."
Case 404: strOut = "Object not found. Bad URL."
Case 405: strOut = "Method is not allowed."
Case 406: strOut = "No response acceptable to client found."
Case 407: strOut = "Proxy authentication required."
Case 408: strOut = "Server timed out waiting for request."
Case 409: strOut = "User should resubmit with more info."
Case 410: strOut = "The resource is no longer available."
Case 411: strOut = "The server refused to accept request without a
length."
Case 412: strOut = "Precondition given in request failed."
Case 413: strOut = "Request entity was too large."
Case 414: strOut = "Request URI too long."
Case 415: strOut = "Unsupported media type."
Case 500: strOut = "Internal server error."
Case 501: strOut = "Required not supported."
Case 502: strOut = "Error response received from gateway."
Case 503: strOut = "Temporarily overloaded."
Case 504: strOut = "Timed out waiting for gateway."
Case 505: strOut = "HTTP version not supported."
End Select
fGetHTTPErrCode = strOut
End Function
Function fGetNewFileName(strMsg As String, hWnd As Long, blnOpen As Boolean)
As String
Dim clsDialog As cDialog
Set clsDialog = New cDialog
With clsDialog
.Title = strMsg
.hWnd = hWnd
.ModeOpen = blnOpen
.StartDir = CurDir()
fGetNewFileName = .Action
End With
Set clsDialog = Nothing
End Function
Function fParseURL(tURLInfo As URL_COMPONENTS, ByVal strURL As String) As
Boolean
Dim lngLen As Long, strBuffer As String
Dim lngRet As Long, strURLLocal As String
strBuffer = String$(MAX_BUFFER, 0)
lngLen = Len(strBuffer)
lngRet = apiInetCanonicalizeUrl(strURL, strBuffer, lngLen,
ICU_BROWSER_MODE)
If Not lngRet = 0 Then
strURLLocal = left$(strBuffer, lngLen)
With tURLInfo
.lpszScheme = String$(MAX_BUFFER, 0)
.dwSchemeLength = MAX_BUFFER
.nScheme = INTERNET_SCHEME_UNKNOWN
.lpszHostName = String$(MAX_BUFFER, 0)
.dwHostNameLength = MAX_BUFFER
.dwStructSize = Len(tURLInfo)
.nPort = 0
.lpszUserName = String$(MAX_BUFFER, 0)
.dwUserNameLength = MAX_BUFFER
.lpszPassword = String$(MAX_BUFFER, 0)
.dwPasswordLength = MAX_BUFFER
.lpszUrlPath = String$(MAX_BUFFER, 0)
.dwUrlPathLength = MAX_BUFFER
.lpszExtraInfo = String$(MAX_BUFFER, 0)
.dwExtraInfoLength = MAX_BUFFER
End With
lngRet = apiInetCrackUrl(strURLLocal, Len(strURLLocal), _
ICU_ESCAPE, tURLInfo)
If lngRet = 0 Then
fParseURL = False
Else
fParseURL = True
With tURLInfo
.lpszExtraInfo = fTrimNull(.lpszExtraInfo)
.lpszHostName = fTrimNull(.lpszHostName)
.lpszPassword = fTrimNull(.lpszPassword)
.lpszScheme = fTrimNull(.lpszScheme)
.lpszUrlPath = fTrimNull(.lpszUrlPath)
.lpszUserName = fTrimNull(.lpszUserName)
End With
End If
End If
End Function
Function fCountWords(ByVal S As String, ByVal strDelim As String) As Integer
' Counts the words in a string that are separated by commas.
'Modified from MS KB
'
Dim WC As Integer, Pos As Integer
WC = 1
Pos = InStr(S, strDelim)
Do While Pos > 0
WC = WC + 1
Pos = InStr(Pos + 1, S, strDelim)
Loop
fCountWords = WC
End Function
Function fGetWord(ByVal S As String, Indx As Integer, strDelim As String)
' Returns the nth word in a specific field.
'Modified from MS KB
'
Dim WC As Integer, Count As Integer, SPos As Integer, EPos As Integer
WC = fCountWords(S, strDelim)
If Indx < 1 Or Indx > WC Then
fGetWord = vbNullString
Exit Function
End If
Count = 1
SPos = 1
For Count = 2 To Indx
SPos = InStr(SPos, S, strDelim) + 1
Next Count
EPos = InStr(SPos, S, strDelim) - 1
If EPos <= 0 Then EPos = Len(S)
fGetWord = Trim(Mid(S, SPos, EPos - SPos + 1))
End Function
'************* Module modMain End ***********
And finally the class module, HTTP.
'************* Class Module: HTTP Start *************
'
' Comments and bug reports can be emailed to us
' Terry Kreft (terry...@mps.co.uk); Dev Ashish (das...@hotmail.com)
'
'
'Public Event FileProgress(intPercentDone As Integer)
'Attribute FileProgress.VB_Description = "Download Percentage notification
messages."
'Public Event Status(strMessage As String)
'Attribute Status.VB_Description = "Operation status notification messages"
Private mstrURL As String
Private mstrDestination As String
Private mblnConnectState As Boolean
Private mblnOverWrite As Boolean
Private hFile As Long
Private hSession As Long
Private lnghWnd As Long
Private hInet As Long
Private hURL As Long
Private mlngSize As Long
Private mblnPromptForFile As Boolean
Private mtURLInfo As URL_COMPONENTS
Private Const mconERR_BAD_URL As Long = vbObjectError + 1000
Private Const mconERR_REQ_FAILED As Long = vbObjectError + 2000
Private Const mconERR_UNKNOWN = vbObjectError + 3000
Private Const mconERR_CONNECTION_FAIL = vbObjectError + 4001
Private Const mconERR_CANNOT_START_TRANSFER = vbObjectError + 5000
Private Sub Class_Initialize()
Dim lngFlags As Long
mblnConnectState = CBool(apiInetGetConnectedState(lngFlags, 0&))
End Sub
Private Sub Class_Terminate()
On Error Resume Next
Call apiFlushFileBuffers(hFile)
Call apiCloseHandle(hFile)
Call apiInetCloseHandle(hURL)
Call apiInetCloseHandle(hInet)
mlngSize = 0
End Sub
Public Property Let HttpURL(ByVal strURL As String)
'Attribute HttpURL.VB_Description = "URL to the HTTP Host server."
mstrURL = strURL
End Property
Public Property Let hWnd(ByVal SourcehWnd As Long)
'Attribute hWnd.VB_Description = "Handle of owner window for CommonDialog.
If not set, uses active window's handle"
lnghWnd = SourcehWnd
End Property
Public Property Get FileExists() As Boolean
'Attribute FileExists.VB_Description = "True if local DestinationFile
exists."
FileExists = Not (Dir(mstrDestination) = vbNullString)
End Property
Public Property Let OverwriteTarget(ByVal blnOverWrite As Boolean)
'Attribute OverwriteTarget.VB_Description = "If true, overwrite the local
DestinationFile without any prompts."
mblnOverWrite = blnOverWrite
End Property
Public Property Let DestinationFile(ByVal strFilePath As String)
'Attribute DestinationFile.VB_Description = "Local path and file name of an
existant file for downloads"
mstrDestination = strFilePath
End Property
Public Property Get SpecifiedURL() As String
'Attribute SpecifiedURL.VB_Description = "Returns the value specified for
HTTPUrl"
SpecifiedURL = mstrURL
End Property
Public Property Let PromptWithCommonDialog(blnYesNo As Boolean)
'Attribute PromptWithCommonDialog.VB_Description = "If true, prompt the user
with CommonDialog to specify a SaveAs filename for downloads.\r\nSetting
hWnd to a valid handle is recommended, but not required"
mblnPromptForFile = blnYesNo
End Property
Public Property Get SizeOfFile() As Long
'Attribute SizeOfFile.VB_Description = "Size of the remote file in bytes."
SizeOfFile = mlngSize
End Property
Public Property Get IsConnected() As Boolean
'Attribute IsConnected.VB_Description = " True if there is a valid
connection to the internet"
IsConnected = mblnConnectState
End Property
Public Sub ConnectToHTTPHost()
'Attribute ConnectToHTTPHost.VB_Description = "Establish a connection to the
server."
Dim lngRet As Long
Dim lngLen As Long
Dim strStatus As String
Dim strTmp As String
On Error GoTo ErrHandler
If Not fParseURL(mtURLInfo, mstrURL) = False Then
If mtURLInfo.lpszHostName = vbNullString Then Err.Raise mconERR_BAD_URL
Else
Err.Raise mconERR_UNKNOWN
End If
hInet = apiInetOpen("WinInet-FileTransferObjects", _
INTERNET_OPEN_TYPE_PRECONFIG, _
vbNullChar, vbNullChar, 0&)
'RaiseEvent Status("Connecting to web server '" & mtURLInfo.lpszHostName &
"'...")
hURL = apiInetOpenURL(hInet, mstrURL, _
vbNullString, 0&, _
INTERNET_FLAG_EXISTING_CONNECT, 0&)
'RaiseEvent Status("Requesting download information from server...")
strStatus = String$(MAX_BUFFER, 0)
lngLen = Len(strStatus)
lngRet = apiHttpQueryInfoStr(hURL, HTTP_QUERY_STATUS_CODE, _
strStatus, lngLen, 0&)
strStatus = left$(strStatus, lngLen)
If IsNumeric(strStatus) Then
If CInt(strStatus) <> HTTP_STATUS_OK Then
strTmp = fGetHTTPErrCode(strStatus)
If strTmp <> vbNullString Then Err.Raise mconERR_REQ_FAILED
End If
End If
lngRet = apiInetQueryDataAvailable(hURL, mlngSize, 0&, 0&)
If mlngSize = 0 Then mlngSize = 1
ExitHere:
Exit Sub
ErrHandler:
Select Case Err.Number
Case mconERR_REQ_FAILED:
Err.Raise mconERR_REQ_FAILED, "HTTP::ConnectToHTTPHost", strTmp
Case mconERR_CANNOT_START_TRANSFER:
Err.Raise mconERR_CANNOT_START_TRANSFER, "HTTP::ConnectToHTTPHost", _
"Cannot start file transfer from '" & mtURLInfo.lpszHostName & "'."
Case mconERR_CONNECTION_FAIL:
Err.Raise mconERR_CONNECTION_FAIL, "HTTP::ConnectToHTTPHost", _
"Couldn't connect to server '" & mtURLInfo.lpszHostName & "'."
Case mconERR_BAD_URL:
Err.Raise mconERR_BAD_URL, "HTTP::ConnectToHTTPHost", _
"Bad URL. " & vbCrLf & mstrURL & vbCrLf & _
"Please verify the hyperlink and try again."
Case mconERR_UNKNOWN:
Err.Raise mconERR_UNKNOWN, "HTTP::ConnectToHTTPHost", _
"An unknown error occurred."
Case Else:
Err.Raise Err.Number, Err.Source, Err.Description
End Select
Resume ExitHere
End Sub
Public Sub DialDefaultNumber()
'Attribute DialDefaultNumber.VB_Description = "Attempts to dial out the
default phone number to ISP from Dial Up Networking settings and establish a
connection."
Dim lngFlags As Long
Dim lngRet As Long
lngRet = apiInetGetConnectedState(lngFlags, 0&)
If lngRet = 0 Then
If (lngFlags And INTERNET_CONNECTION_MODEM) Then
'Try a connect
lngRet = apiInetAutodial(INTERNET_AUTODIAL_FORCE_UNATTENDED, 0&)
mblnConnectState = Not (lngRet = 0)
End If
End If
End Sub
Public Function WriteHTTPDataToString() As String
'Attribute WriteHTTPDataToString.VB_Description = "Returns the HTML contents
in a string, including all HTML tags."
On Error GoTo ErrHandler
Dim lngRet As Long
Dim lngBytesRead As Long
Dim lngTotalByesRead As Long
Dim strRead As String
Dim strOut As String
Const conERR_GENERIC = vbObjectError + 100
lngTotalByesRead = 0
'Read in MAX_CHUNK Chunk
Do
strRead = String$(MAX_CHUNK, 0)
lngRet = apiInetReadFileStr(hURL, _
strRead, _
MAX_CHUNK, _
lngBytesRead)
strOut = strOut & left$(strRead, lngBytesRead)
lngTotalByesRead = lngTotalByesRead + lngBytesRead
'RaiseEvent FileProgress(CInt(lngTotalByesRead / mlngSize * 100))
Loop Until lngRet <> 0 And lngBytesRead = 0
WriteHTTPDataToString = strOut
ExitHere:
Exit Function
ErrHandler:
WriteHTTPDataToString = vbNullString
Select Case Err.Number
Case conERR_GENERIC:
'Do Nothing
Case Else:
Err.Raise Err.Number, Err.Source, Err.Description
End Select
Resume ExitHere
End Function
Public Function WriteHTTPDataToFile() As Boolean
'Attribute WriteHTTPDataToFile.VB_Description = "Writes the HTML or binary
file from the HTTP host server to a local file, DestinationFile"
On Error GoTo ErrHandler
Dim lngRet As Long
Dim lngBytesRead As Long
Dim lngFlags As Long
Dim lngBytesWritten As Long
Dim lngTotalBytesWritten As Long
Dim abytData() As Byte
Const conERR_GENERIC = vbObjectError + 100
If (Me.FileExists And Not mblnOverWrite) Or mblnPromptForFile Then
If lnghWnd = 0 Then lnghWnd = apiGetActiveWindow()
mstrDestination = fGetNewFileName("Please select a" _
& " new name for the destination file.", lnghWnd, True)
If mstrDestination = vbNullString Then Err.Raise _
conERR_GENERIC
End If
'Create the destination file
hFile = apiCreateFile(mstrDestination, _
GENERIC_READ Or GENERIC_WRITE, _
0&, 0&, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0&)
If hFile = INVALID_HANDLE_VALUE Then Err.Raise conERR_GENERIC
lngTotalBytesWritten = 0
'Read in MAX_CHUNK Chunk
Do
ReDim abytData(MAX_CHUNK)
lngRet = apiInetReadFile(hURL, _
abytData(0), _
MAX_CHUNK, _
lngBytesRead)
Call apiWriteFile(hFile, abytData(0), MAX_CHUNK, _
lngBytesWritten, 0&)
lngTotalBytesWritten = lngTotalBytesWritten + lngBytesWritten
'RaiseEvent FileProgress(CInt(lngTotalBytesWritten / mlngSize))
Loop Until lngRet <> 0 And lngBytesRead = 0
WriteHTTPDataToFile = True
ExitHere:
Exit Function
ErrHandler:
WriteHTTPDataToFile = False
Select Case Err.Number
Case conERR_GENERIC:
'Do Nothing
Case Else:
Err.Raise Err.Number, "HTTP::WriteHTTPDataToFile", Err.Description
End Select
Resume ExitHere
End Function
'************* Class Module: HTTP End *************