' 發展單位：風禹科技驗證有限公司
' 撰寫人：鄭子璉(Tzu-Lien, Cheng, 璉璉) ，成大水博肄，微軟最有價值專家
' Web: http://tlcheng.twbbs.org/TLCheng/ E-Mail: qvb3377@ms5.hinet.net
' --------------------------------------------------------------------------------------

Private Declare Function InternetAttemptConnect Lib "wininet.dll" (ByVal dwReserved As Long) As Long
Private Declare Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Boolean
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInternetHandle As Long) As Boolean
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal lpszServerName As String, ByVal nProxyPort As Long, ByVal lpszUsername As String, ByVal lpszPassword As String, ByVal dwService As enuInternet_Service, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" (ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long
Private Declare Function InternetGetConnectedState Lib "wininet.dll" (lpdwFlags As Long, ByVal dwReserved As Long) As Boolean
Private Declare Function InternetGetConnectedStateEx Lib "wininet.dll" Alias "InternetGetConnectedStateExA" (lpdwFlags As Long, ByVal lpszConnectionName As String, ByVal dwNameLen As Long, ByVal dwReserved As Long) As Boolean
Private Declare Function InternetGoOnline Lib "wininet.dll" Alias "InternetGoOnlineA" (ByVal lpszUrl As String, ByVal hWndParent As Long, ByVal dwReserved As Long) As Boolean
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal lpszCallerName As String, ByVal dwAccessType As enuInternetOpen, ByVal lpszProxyName As String, ByVal lpszProxyBypass As String, ByVal dwFlags As Long) As Long
Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal hOpen As Long, ByVal sUrl As String, ByVal sHeaders As String, ByVal lLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetQueryDataAvailable Lib "wininet.dll" (ByVal hFile As Long, lpdwNumberOfBytesAvailable As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function InternetReadFileByte Lib "wininet.dll" Alias "InternetReadFile" (ByVal hFile As Long, ByVal AddOfBuffer As Long, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetSetFilePointer Lib "wininet.dll" (ByVal hFile As Long, ByVal lDistanceToMove As Long, ByVal pReserved As Long, ByVal dwMoveMethod As enuMoveMethod, ByVal dwContext As Long) As Long

Private Declare Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" (ByVal hFtpSession As Long, ByVal lpszSearchFile As String, lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As enuInternetFlag, ByVal dwContent As Long) As Long
Private Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" (ByVal hFtpSession As Long, ByVal lpszRemoteFile As String, ByVal lpszNewFile As String, ByVal fFailIfExists As Boolean, ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As enuInternetFlag, ByVal dwContext As Long) As Long
Private Declare Function FtpGetFileSize Lib "wininet.dll" (ByVal hFile As Long, lpdwFileSizeHigh As Long) As Long
Private Declare Function FtpOpenFile Lib "wininet.dll" Alias "FtpOpenFileA" (ByVal hFtpSession As Long, ByVal sFilename As String, ByVal lAccess As enuGenericRights, ByVal lFlags As enuInternetFlag, ByVal lContext As Long) As Long
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Long

Private Enum enuInternetOpen
   INTERNET_OPEN_TYPE_PRECONFIG = 0
   INTERNET_OPEN_TYPE_DIRECT = 1
   INTERNET_OPEN_TYPE_PROXY = 3
   INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY = 4
End Enum

Public Enum enuInternet_Connection
   Internet_Connection_Modem = 1
   Internet_Connection_Lan = 2
   Internet_Connection_Proxy = 4
   Internet_Connection_Modem_Busy = 8
   Internet_RAS_Installed = &H10&
   Internet_Connection_Offline = &H20&
   Internet_Connection_Configured = &H40&
End Enum

Private Enum enuMoveMethod
   FILE_BEGIN = 0
   FILE_CURRENT = 1
   FILE_END = 2
End Enum

Private Enum enuInternet_Port 'port numbers
   INTERNET_DEFAULT_FTP_PORT = 21
   INTERNET_DEFAULT_GOPHER_PORT = 70
   INTERNET_DEFAULT_HTTP_PORT = 80
   INTERNET_DEFAULT_HTTPS_PORT = 443
   INTERNET_DEFAULT_SOCKS_PORT = 1080
End Enum

'// FTP flags/Internet Flags
Public Enum enuInternetFlag
' flags common to open functions (not InternetOpen()):
   INTERNET_FLAG_MULTIPART = &H200000
   
   FTP_TRANSFER_TYPE_UNKNOWN = 0
   FTP_TRANSFER_TYPE_ASCII = &H1
   FTP_TRANSFER_TYPE_BINARY = &H2
   FTP_TRANSFER_TYPE_MASK = FTP_TRANSFER_TYPE_ASCII Or FTP_TRANSFER_TYPE_BINARY
   
   INTERNET_FLAG_PASSIVE = &H8000000
   INTERNET_FLAG_RELOAD = &H80000000
   INTERNET_FLAG_RAW_DATA = &H40000000
   INTERNET_FLAG_EXISTING_CONNECT = &H20000000
   INTERNET_FLAG_ASYNC = &H10000000
   
   INTERNET_FLAG_NO_CACHE_WRITE = &H4000000     ' don't write this item to the cache
   INTERNET_FLAG_DONT_CACHE = INTERNET_FLAG_NO_CACHE_WRITE
   INTERNET_FLAG_MAKE_PERSISTENT = &H2000000    ' make this item persistent in cache
   INTERNET_FLAG_FROM_CACHE = &H1000000         ' use offline semantics
   INTERNET_FLAG_OFFLINE = INTERNET_FLAG_FROM_CACHE

' additional flags
   INTERNET_FLAG_SECURE = &H800000              ' use PCT/SSL if applicable (HTTP)
   INTERNET_FLAG_KEEP_CONNECTION = &H400000     ' use keep-alive semantics
   INTERNET_FLAG_NO_AUTO_REDIRECT = &H200000    ' don't handle redirections automatically
   INTERNET_FLAG_READ_PREFETCH = &H100000       ' do background read prefetch
   INTERNET_FLAG_NO_COOKIES = &H80000           ' no automatic cookie handling
   INTERNET_FLAG_NO_AUTH = &H40000              'no automatic authentication handling
   INTERNET_FLAG_RESTRICTED_ZONE = &H20000      ' apply restricted zone policies for cookies, auth
   INTERNET_FLAG_CACHE_IF_NET_FAIL = &H10000    ' return cache file if net request fails

' Security Ignore Flags, Allow HttpOpenRequest to overide Secure Channel (SSL/PCT) failures of the following types.
   INTERNET_FLAG_IGNORE_REDIRECT_TO_HTTP = &H8000      ' ex: https:// to http://
   INTERNET_FLAG_IGNORE_REDIRECT_TO_HTTPS = &H4000     ' ex: http:// to https://
   INTERNET_FLAG_IGNORE_CERT_DATE_INVALID = &H2000     ' expired X509 Cert.
   INTERNET_FLAG_IGNORE_CERT_CN_INVALID = &H1000       ' bad common name in X509 Cert.

' more caching flags
   INTERNET_FLAG_RESYNCHRONIZE = &H800          ' asking wininet to update an item if it is newer
   INTERNET_FLAG_HYPERLINK = &H400              ' asking wininet to do hyperlinking semantic which works right for scripts
   INTERNET_FLAG_NO_UI = &H200                  ' no cookie popup
   INTERNET_FLAG_PRAGMA_NOCACHE = &H100         ' asking wininet to add "pragma: no-cache"
   INTERNET_FLAG_CACHE_ASYNC = &H80             ' ok to perform lazy cache-write
   INTERNET_FLAG_FORMS_SUBMIT = &H40            ' this is a forms submit
   INTERNET_FLAG_FWD_BACK = &H20                ' fwd-back button op
   INTERNET_FLAG_NEED_FILE = &H10               ' need a file for this request
   INTERNET_FLAG_MUST_CACHE_REQUEST = INTERNET_FLAG_NEED_FILE

' flags for FTP
   INTERNET_FLAG_TRANSFER_ASCII = FTP_TRANSFER_TYPE_ASCII       ' &H00000001
   INTERNET_FLAG_TRANSFER_BINARY = FTP_TRANSFER_TYPE_BINARY     ' &H00000002

' flags field masks
   SECURITY_INTERNET_MASK = INTERNET_FLAG_IGNORE_CERT_CN_INVALID Or INTERNET_FLAG_IGNORE_CERT_DATE_INVALID Or INTERNET_FLAG_IGNORE_REDIRECT_TO_HTTPS Or INTERNET_FLAG_IGNORE_REDIRECT_TO_HTTP
'   INTERNET_FLAGS_MASK = INTERNET_FLAG_RELOAD Or INTERNET_FLAG_RAW_DATA Or INTERNET_FLAG_EXISTING_CONNECT Or INTERNET_FLAG_ASYNC Or INTERNET_FLAG_PASSIVE Or INTERNET_FLAG_NO_CACHE_WRITE Or INTERNET_FLAG_MAKE_PERSISTENT Or INTERNET_FLAG_FROM_CACHE Or INTERNET_FLAG_SECURE Or INTERNET_FLAG_KEEP_CONNECTION Or INTERNET_FLAG_NO_AUTO_REDIRECT Or INTERNET_FLAG_READ_PREFETCH Or INTERNET_FLAG_NO_COOKIES Or INTERNET_FLAG_NO_AUTH Or INTERNET_FLAG_CACHE_IF_NET_FAIL Or SECURITY_INTERNET_MASK Or INTERNET_FLAG_RESYNCHRONIZE Or INTERNET_FLAG_HYPERLINK Or INTERNET_FLAG_NO_UI Or INTERNET_FLAG_PRAGMA_NOCACHE Or INTERNET_FLAG_CACHE_ASYNC Or INTERNET_FLAG_FORMS_SUBMIT Or INTERNET_FLAG_NEED_FILE Or INTERNET_FLAG_RESTRICTED_ZONE Or INTERNET_FLAG_TRANSFER_BINARY Or INTERNET_FLAG_TRANSFER_ASCII Or INTERNET_FLAG_FWD_BACK Or INTERNET_FLAG_BGUPDATE
End Enum

' Internet Connect
Private Enum enuInternet_Service
   INTERNET_SERVICE_FTP = 1
   INTERNET_SERVICE_GOPHER = 2
   INTERNET_SERVICE_HTTP = 3
End Enum

Private Enum enuGenericRights
   GENERIC_READ = &H80000000
   GENERIC_WRITE = &H40000000
   GENERIC_EXECUTE = &H20000000
   GENERIC_ALL = &H10000000
End Enum

Private Const FLAG_ICC_FORCE_CONNECTION = 1
Private Const BufferString = 512

Public Function myFtpDir(ByVal sUrl, Optional ByVal lpszTitle As String, Optional ByVal dwFlags As enuWin32FindData = WFD_FileName)
' 需引用 FileTool.bas

Dim sWFD As WIN32_FIND_DATA

If lpszTitle = "" Then
   lpszTitle = App.Title
End If

hInternetSession = InternetOpen(lpszTitle, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
hFtpSession = myFtpInternetConnect(hInternetSession, sUrl)

sPath = Replace(Mid(sUrl, 7), "\", "/") ' 去除 ftp://
sPath = Mid(sPath, InStr(sPath, "/") + 1)

If Right(sPath, 1) = "/" Then
   strPath = sPath
   strFileName = "*.*"
Else
   nLoc = InStrRev(sPath, "/")
   strPath = Left(sPath, nLoc)
   strFileName = Mid(sPath, nLoc + 1)
End If

summy = FtpSetCurrentDirectory(hFtpSession, strPath)

hFileConnection = FtpFindFirstFile(hFtpSession, strFileName, sWFD, 0, 0)
If hFileConnection = 0 Then
   hFileConnection = FtpFindFirstFile(hFtpSession, strFileName, sWFD, INTERNET_FLAG_RELOAD, 0)
End If

If hFileConnection > 0 Then
   ReDim arrDir(0)
   
   arrDir(0) = GetWin32FindDataValue(sWFD, dwFlags)
   
   Select Case dwFlags
   Case WFD_FileName
      sFindFile = arrDir(0)
   Case WFD_All
      sFindFile = arrDir(0)(WFD_FileName)
   End Select
      
   If InStr(LCase(sFindFile), " not found") > 0 Then
      Erase arrDir
      nFile = -1
   Else
      nFile = 0
      Do
         bResult = InternetFindNextFile(hFileConnection, sWFD)
         If bResult Then
            nFile = nFile + 1
            ReDim Preserve arrDir(nFile)
            arrDir(nFile) = GetWin32FindDataValue(sWFD, dwFlags)
         End If
      Loop While bResult
   End If
End If

If hFileConnection <> 0 Then InternetCloseHandle hFileConnection
If hFtpSession <> 0 Then InternetCloseHandle hFtpSession
If hInternetSession <> 0 Then InternetCloseHandle hInternetSession

If nFile < 0 Or IsEmpty(nFile) Then
   myFtpDir = Empty
Else
   myFtpDir = arrDir
End If

End Function

Private Function GetFtpUrlServerName(ByVal sUrl)

If LCase(Left(sUrl, 6)) = "ftp://" Then
   sUrl = Replace(sUrl, "\", "/") ' 替換 \ -> /
   sPath = Split(Mid(sUrl, 7), "/")
   sUrl = Left(sUrl, 6) & sPath(0) & "/"
   
   GetFtpUrlServerName = sUrl
End If

End Function

Private Function myFtpInternetConnect(ByVal hInternetSession, ByVal sUrl)

urlServerName = GetFtpUrlServerName(sUrl)

If Len(urlServerName) > 0 Then
   sUrl = Replace(Mid(urlServerName, 7), "\", "/") ' 去除 ftp://
   
   sPath = Split(sUrl, "/")
   ubp = UBound(sPath)
   sServer = Split(sPath(0), "@")
   ubs = UBound(sServer)
   
' 設定使用者帳號密碼
   If ubs > 0 Then ' 有使用者帳號密碼
      sTemp = Split(sServer(0), ":")
      strUsername = sTemp(0)
      If UBound(sTemp) > 0 Then
         strPassword = sTemp(1)
      End If
   Else
      strUsername = vbNullString
      strPassword = vbNullString
      sServer = Split("@" & sServer(0), "@")
   End If
   
' 設定 Server Name/IP
   sTemp = Split(sServer(1), ":")
   strServerName = sTemp(0)
' 設定 Server Port
   If UBound(sTemp) > 0 Then
      nServerPort = CLng(sTemp(1))
   Else
      nServerPort = INTERNET_DEFAULT_FTP_PORT
   End If
   
   myFtpInternetConnect = InternetConnect(hInternetSession, strServerName, nServerPort, strUsername, strPassword, INTERNET_SERVICE_FTP, 0, 0)
Else
End If

End Function

Public Function myFtpGetFile(ByVal sUrl, ByVal sFullFile, Optional ByVal lpszTitle As String, Optional ByVal TransferFlags As enuInternetFlag = FTP_TRANSFER_TYPE_BINARY)
'Public Const ERROR_INTERNET_EXTENDED_ERROR = 12003
' 需引用 FileTool.bas

Dim sWFD As WIN32_FIND_DATA

If lpszTitle = "" Then
   lpszTitle = App.Title
End If

sPath = Replace(Mid(sUrl, 7), "\", "/") ' 去除 ftp://
sPath = Mid(sPath, InStr(sPath, "/") + 1)

If Right(sPath, 1) = "/" Then
   strPath = sPath
   strFileName = "*.*"
Else
   nLoc = InStrRev(sPath, "/")
   strPath = Left(sPath, nLoc)
   strFileName = Mid(sPath, nLoc + 1)
End If

hInternetSession = InternetOpen(lpszTitle, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
hFtpConnect = myFtpInternetConnect(hInternetSession, sUrl)

summy = FtpSetCurrentDirectory(hFtpConnect, strPath)

hFileConnection = FtpFindFirstFile(hFtpConnect, strFileName, sWFD, 0, 0)

If hFileConnection > 0 Then
   fTime = GetWin32FindDataValue(sWFD, WFD_LastWriteTime)

   myFtpGetFile = FtpGetFile(hFtpConnect, strFileName, sFullFile, False, INTERNET_FLAG_RELOAD, TransferFlags, AddressOf myInternetSetStatusCallback)
   
   mySetFileTime sFullFile, CDate(myLocalTimeToSystemTime(fTime))
End If

If hFileConnection <> 0 Then InternetCloseHandle hFileConnection
If hFtpConnect <> 0 Then InternetCloseHandle hFtpConnect
If hInternetSession <> 0 Then InternetCloseHandle hInternetSession

End Function

Public Function myInternetReadFile(ByVal lpszUrl As String, Optional ByVal lpszFileName As String, Optional ByVal lpszTitle As String, Optional FilePointer, Optional GetSize, Optional nFileSize, Optional bStop)

Dim hOpen As Long, hOpenUrl As Long, lNumberOfBytesRead As Long, bRet As Boolean
Dim nLen As Long, nStart As Long, tBufferString As Long
Dim tByte() As Byte
Dim lpvFindData As WIN32_FIND_DATA

If lpszTitle = "" Then
   lpszTitle = App.Title
End If

hOpen = InternetOpen(lpszTitle, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
hOpenUrl = InternetOpenUrl(hOpen, lpszUrl, vbNullString, 0, INTERNET_FLAG_RELOAD, 0)

tBufferString = myInternetQueryDataAvailable(hOpenUrl)

If Not IsMissing(nFileSize) Then
   nFileSize = myInternetGetFileSize(hOpenUrl)
End If

If IsMissing(FilePointer) Then
   nStart = 1
Else
   nStart = myInternetSetFilePointer(hOpenUrl, FilePointer) + 1
End If

nLen = 0

If tBufferString Then
   If lpszFileName <> "" Then
      hdFile = FreeFile
      Open lpszFileName For Binary As hdFile
      
      ReDim Preserve tByte(1 To tBufferString) As Byte
      
      Do
         bRet = InternetReadFileByte(hOpenUrl, VarPtr(tByte(1)), tBufferString, lNumberOfBytesRead)
          
         If lNumberOfBytesRead > 0 Then
            If lNumberOfBytesRead < tBufferString Then
               GetSize = nFileSize
               ReDim Preserve tByte(1 To lNumberOfBytesRead) As Byte
            Else
               GetSize = nStart + lNumberOfBytesRead - 1
            End If
            Put #1, nStart, tByte
            nStart = nStart + lNumberOfBytesRead
         End If
         
         DoEvents
         If Not IsMissing(bStop) Then
            If bStop <> Empty Then
               Exit Do
            End If
         End If
      Loop Until lNumberOfBytesRead < tBufferString
      Close hdFile
      myInternetReadFile = nFileSize
   Else
      Do
         ReDim Preserve tByte(1 To nLen + tBufferString + 1) As Byte
         bRet = InternetReadFileByte(hOpenUrl, VarPtr(tByte(nLen + 1)), tBufferString, lNumberOfBytesRead)
          
         If lNumberOfBytesRead > 0 Then
            nLen = nLen + lNumberOfBytesRead
            GetSize = nStart + nLen - 1
         Else
            GetSize = nFileSize
         End If
          
         DoEvents
         If Not IsMissing(bStop) Then
            If bStop <> Empty Then
               Exit Do
            End If
         End If
      Loop Until lNumberOfBytesRead = 0
      
      ReDim Preserve tByte(1 To nLen) As Byte
      myInternetReadFile = tByte
   End If
End If

If hOpenUrl <> 0 Then InternetCloseHandle (hOpenUrl)
If hOpen <> 0 Then InternetCloseHandle (hOpen)

End Function

Public Function myInternetQueryDataAvailable(ByVal hFile As Long) As Long

Dim tLong As Long

summyb = InternetQueryDataAvailable(hFile, tLong, 0, 0)

myInternetQueryDataAvailable = tLong

End Function

Private Function myInternetSetFilePointer(ByVal hFile As Long, ByVal hPointer As Long) As Long

myInternetSetFilePointer = InternetSetFilePointer(hFile, hPointer, 0, FILE_CURRENT, 0)

End Function

Private Function myInternetGetFileSize(ByVal hFile As Long) As Long

myInternetGetFileSize = InternetSetFilePointer(hFile, 0, 0, FILE_END, 0)
InternetSetFilePointer hFile, 0, 0, FILE_BEGIN, 0

End Function

Public Function myInternetCheckConnection(Optional ByVal lpszUrl As String, Optional ByVal wFlags As Long = FLAG_ICC_FORCE_CONNECTION) As Boolean

myInternetCheckConnection = InternetCheckConnection(lpszUrl, wFlags, 0)

End Function

Public Function myInternetGetConnectedState() As enuInternet_Connection

Dim lpdwFlags As enuInternet_Connection

summy = InternetGetConnectedState(lpdwFlags, 0)
myInternetGetConnectedState = lpdwFlags

End Function

Public Function myInternetGetConnectedStateEx() As String

Dim lpdwFlags As enuInternet_Connection
Dim lpString As String
lpString = String(BufferString, 0)

summy = InternetGetConnectedStateEx(lpdwFlags, lpString, BufferString, 0)

myInternetGetConnectedStateEx = Left(lpString, InStr(lpString, Chr(0) & Chr(0)) - 1)

End Function

Public Function myInternetGoOnline(ByVal lpszUrl) As Boolean

myInternetGoOnline = InternetGoOnline(lpszUrl, 0, 0)

End Function

Public Function myInternetAttemptConnect()

myInternetAttemptConnect = InternetAttemptConnect(0)

End Function