Attribute VB_Name = "mod_GetDataFromURL"

Option Explicit

Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const KEY_QUERY_VALUE = &H1
Private Const REG_SZ = 1
Private Const ERROR_SUCCESS = 0&
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _
  (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _
  ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
  (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
  lpType As Long, lpData As Any, lpcbData As Long) As Long

Public Function GetDataFromURL(strURL As String, Optional strMethod As String = "GET", Optional Async As Boolean = False, Optional strPostData As String = "", Optional boundary As String = "")
  Dim strUserAgentString As String
  Dim intSslErrorIgnoreFlags As Long
  Dim blnEnableRedirects As Boolean
  Dim objWinHttp
  Dim blnMultipart As Boolean
  
  strUserAgentString = "Mozilla/5.0 (Windows NT 5.1; rv:12.0) Gecko/20100101 Firefox/3.6.23"
  intSslErrorIgnoreFlags = 13056 ' 13056: ignore all err, 0: accept no err
  blnEnableRedirects = True
  blnMultipart = False
  
  If strMethod = "Multipart" Then blnMultipart = True: strMethod = "POST"
  
  Set objWinHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
  objWinHttp.Open strMethod, strURL, Async
  
  If strMethod = "POST" And blnMultipart = False Then
    objWinHttp.SetRequestHeader "Content-type", "application/x-www-form-urlencoded"
    objWinHttp.SetRequestHeader "Content-Length", Len(strPostData)
  End If
  
  If strMethod = "POST" And blnMultipart = True Then
    objWinHttp.SetRequestHeader "Content-type", "multipart/form-data; boundary=" & boundary
    objWinHttp.SetRequestHeader "Content-Length", Len(strPostData)
  End If
  
  objWinHttp.Option(0) = strUserAgentString
  objWinHttp.Option(4) = intSslErrorIgnoreFlags
  objWinHttp.Option(6) = blnEnableRedirects
  objWinHttp.Option(12) = True 'EnableHttpsToHttpRedirects

  On Error Resume Next
  Dim postBody() As Byte
  postBody = StrConv(strPostData, vbFromUnicode)

  objWinHttp.Send (postBody)
  If Async = True Then objWinHttp.WaitForResponse

  If Err.Number = 0 Then
    GetDataFromURL = objWinHttp.ResponseText
  Else
    GetDataFromURL = "Error " & Err.Number & " " & Err.Source & " " & _
      Err.Description
  End If

  Set objWinHttp = Nothing
End Function

Public Function Make_Boundary() As String
Make_Boundary = Rand(100000000, 999999999) & Rand(100000000, 999999999) & Rand(100000000, 999999999)
End Function

Public Function Add_Multipart(post_field As String, post_data As String, boundary As String, Optional file_path As String = "")
Dim data As String
Dim tmp() As String
Dim file_name As String

If file_path <> "" Then
post_data = GetFileContents(file_path)

tmp = Split(file_path, "\")
file_name = tmp(UBound(tmp))
End If

data = "--" & boundary & vbCrLf
data = data & "Content-Disposition: form-data; name=""" & post_field & """" & IIf(file_path = "", "", "; filename=""" & file_name & """") & vbCrLf
If file_name <> "" Then
data = data & "Content-Transfer-Encoding: binary" & vbCrLf
data = data & "Content-Type: " & GetContentType(file_name) & vbCrLf
End If
data = data & vbCrLf
data = data & post_data & vbCrLf

Add_Multipart = data
End Function

Private Function Rand(ByVal Low As Long, ByVal High As Long) As Long
Rand = Int((High - Low + 1) * Rnd) + Low
End Function

Public Function GetFileContents(ByVal file_name As String) As String
    Dim fNum As Integer
    fNum = FreeFile
    Dim buf As String
    Open file_name For Binary Access Read As fNum
        buf = String(LOF(fNum), Chr(0))
        Get #fNum, , buf 'Get GIF File into buffer
    Close fNum
    GetFileContents = buf
End Function

Private Function GetContentType(ByVal txtFile As String) As String
  Dim hKey As Long
  Dim lpSubKey As String
  Dim lpValueName As String
  Dim lpType As Long
  Dim lpData As String
  Dim lpcbData As Long
  Dim s As String
  
  GetContentType = "application/octet-stream"
  
  If InStr(txtFile, ".") > 0 Then
    s = Mid(txtFile, InStrRev(txtFile, "."))
  Else
    Exit Function
  End If
  
  lpSubKey = "Content Type"
  If RegOpenKeyEx(HKEY_CLASSES_ROOT, s, 0, KEY_QUERY_VALUE, hKey) = ERROR_SUCCESS Then
    RegQueryValueEx hKey, lpSubKey, 0, lpType, Chr(0), lpcbData
    If lpType = REG_SZ Then
      lpData = Space(lpcbData)
      If RegQueryValueEx(hKey, lpSubKey, 0, lpType, ByVal lpData, lpcbData) = ERROR_SUCCESS Then
        GetContentType = Left(lpData, lpcbData)
      End If
    End If
    RegCloseKey hKey
  End If
End Function