VBA Detect Proxy Settings

Option Compare Database
Option Explicit
 
'Stephen Sulzer
'11/02/2004
'http://www.tech-archive.net/Archive/VB/microsoft.public.vb.winapi.networks/2004-11/0005.html
'Usage: GetProxyInfoForUrl("http://www.google.com")
 
' My app proxy information type
Public Type ProxyInfo
   active As Boolean
   proxy As String
   proxyBypass As String
End Type
 
' Structure to receive IE proxy settings
Private Type WINHTTP_CURRENT_USER_IE_PROXY_CONFIG
   fAutoDetect As Long
   lpszAutoConfigURL As Long
   lpszProxy As Long
   lpszProxyByPass As Long
End Type
 
' Need CopyMemory to copy BSTR pointers around
Private Declare Sub CopyMemory Lib "kernel32" _
         Alias "RtlMoveMemory" (ByVal lpDest As Long, _
         ByVal lpSource As Long, ByVal cbCopy As Long)
 
' SysAllocString creates a UNICODE BSTR string based on a UNICODE string
Private Declare Function SysAllocString Lib "oleaut32" (ByVal pwsz As Long) As Long
 
' Need GlobalFree to free the pointers in the CURRENT_USER_IE_PROXY_CONFIG
' structure returned from WinHttpGetIEProxyConfigForCurrentUser,
' per the documentation
Private Declare Function GlobalFree Lib "kernel32" (ByVal p As Long) As Long
 
' WinHttpGetIEProxyConfigForCurrentUser declaration
Private Declare Function WinHttpGetIEProxyConfigForCurrentUser _
   Lib "WinHTTP.dll" _
   (ByRef proxyConfig As WINHTTP_CURRENT_USER_IE_PROXY_CONFIG) As Long
 
Private Type WINHTTP_AUTOPROXY_OPTIONS
   dwFlags As Long
   dwAutoDetectFlags As Long
   lpszAutoConfigURL As Long
   lpvReserved As Long
   dwReserved As Long
   fAutoLogonIfChallenged As Long
End Type
 
Private Type WINHTTP_PROXY_INFO
   dwAccessType As Long
   lpszProxy As Long
   lpszProxyByPass As Long
End Type
 
' Constants for dwFlags of WINHTTP_AUTOPROXY_OPTIONS
Const WINHTTP_AUTOPROXY_AUTO_DETECT = 1
Const WINHTTP_AUTOPROXY_CONFIG_URL = 2
 
' Constants for dwAutoDetectFlags
Const WINHTTP_AUTO_DETECT_TYPE_DHCP = 1
Const WINHTTP_AUTO_DETECT_TYPE_DNS = 2
 
Private Declare Function WinHttpGetProxyForUrl Lib "WinHTTP.dll" _
   (ByVal hSession As Long, _
    ByVal pszUrl As Long, _
    ByRef pAutoProxyOptions As WINHTTP_AUTOPROXY_OPTIONS, _
    ByRef pProxyInfo As WINHTTP_PROXY_INFO) As Long
 
Private Declare Function WinHttpOpen Lib "WinHTTP.dll" _
   (ByVal pszUserAgent As Long, _
    ByVal dwAccessType As Long, _
    ByVal pszProxyName As Long, _
    ByVal pszProxyBypass As Long, _
    ByVal dwFlags As Long) As Long
 
Private Declare Function WinHttpCloseHandle Lib "WinHTTP.dll" _
   (ByVal hInternet As Long) As Long
 
Public Function GetProxyInfoForUrl(URL As String) As ProxyInfo
 
   Dim IEProxyConfig As WINHTTP_CURRENT_USER_IE_PROXY_CONFIG
   Dim AutoProxyOptions As WINHTTP_AUTOPROXY_OPTIONS
   Dim WinHttpProxyInfo As WINHTTP_PROXY_INFO
   Dim ProxyInfo As ProxyInfo
   Dim fDoAutoProxy As Boolean
   Dim ProxyStringPtr As Long
   Dim ptr As Long
   Dim error As Long
 
   AutoProxyOptions.dwFlags = 0
   AutoProxyOptions.dwAutoDetectFlags = 0
   AutoProxyOptions.lpszAutoConfigURL = 0
   AutoProxyOptions.dwReserved = 0
   AutoProxyOptions.lpvReserved = 0
   AutoProxyOptions.fAutoLogonIfChallenged = 1
 
   IEProxyConfig.fAutoDetect = 0
   IEProxyConfig.lpszAutoConfigURL = 0
   IEProxyConfig.lpszProxy = 0
   IEProxyConfig.lpszProxyByPass = 0
 
   WinHttpProxyInfo.dwAccessType = 0
   WinHttpProxyInfo.lpszProxy = 0
   WinHttpProxyInfo.lpszProxyByPass = 0
 
   ProxyInfo.active = False
   ProxyInfo.proxy = vbNullString
   ProxyInfo.proxyBypass = vbNullString
 
   fDoAutoProxy = False
   ProxyStringPtr = 0
   ptr = 0
 
   ' Check IE's proxy configuration
   If (WinHttpGetIEProxyConfigForCurrentUser(IEProxyConfig) > 0) Then
       ' If IE is configured to auto-detect, then we will too.
       If (IEProxyConfig.fAutoDetect <> 0) Then
           AutoProxyOptions.dwFlags = WINHTTP_AUTOPROXY_AUTO_DETECT
           AutoProxyOptions.dwAutoDetectFlags = _
                       WINHTTP_AUTO_DETECT_TYPE_DHCP + _
                       WINHTTP_AUTO_DETECT_TYPE_DNS
           fDoAutoProxy = True
       End If
 
       ' If IE is configured to use an auto-config script, then
       ' we will use it too
       If (IEProxyConfig.lpszAutoConfigURL <> 0) Then
           AutoProxyOptions.dwFlags = AutoProxyOptions.dwFlags + _
                       WINHTTP_AUTOPROXY_CONFIG_URL
           AutoProxyOptions.lpszAutoConfigURL = IEProxyConfig.lpszAutoConfigURL
           fDoAutoProxy = True
       End If
   Else
       ' if the IE proxy config is not available, then
       ' we will try auto-detection
       AutoProxyOptions.dwFlags = WINHTTP_AUTOPROXY_AUTO_DETECT
       AutoProxyOptions.dwAutoDetectFlags = _
                       WINHTTP_AUTO_DETECT_TYPE_DHCP + _
                       WINHTTP_AUTO_DETECT_TYPE_DNS
       fDoAutoProxy = True
   End If
 
   If fDoAutoProxy Then
       Dim hSession As Long
 
       ' Need to create a temporary WinHttp session handle
       '  Note: performance of this GetProxyInfoForUrl function can be
       '   improved by saving this hSession handle across calls
       '   instead of creating a new handle each time
       hSession = WinHttpOpen(0, 1, 0, 0, 0)
 
       If (WinHttpGetProxyForUrl(hSession, StrPtr(URL), AutoProxyOptions, _
               WinHttpProxyInfo) > 0) Then
           ProxyStringPtr = WinHttpProxyInfo.lpszProxy
           ' ignore WinHttpProxyInfo.lpszProxyBypass, it will not be set
       Else
           error = Err.LastDllError
           ' some possibly autoproxy errors:
           '   12166 - error in proxy auto-config script code
           '   12167 - unable to download proxy auto-config script
           '   12180 - WPAD detection failed
       End If
 
       WinHttpCloseHandle (hSession)
   End If
 
   ' If we don't have a proxy server from WinHttpGetProxyForUrl,
   ' then pick one up from the IE proxy config (if given)
   If (ProxyStringPtr = 0) Then
       ProxyStringPtr = IEProxyConfig.lpszProxy
   End If
 
   ' If there's a proxy string, convert it to a Basic string
   If (ProxyStringPtr <> 0) Then
       ptr = SysAllocString(ProxyStringPtr)
       CopyMemory VarPtr(ProxyInfo.proxy), VarPtr(ptr), 4
       ProxyInfo.active = True
   End If
 
   ' Pick up any bypass string from the IEProxyConfig
   If (IEProxyConfig.lpszProxyByPass <> 0) Then
       ptr = SysAllocString(IEProxyConfig.lpszProxyByPass)
       CopyMemory VarPtr(ProxyInfo.proxyBypass), VarPtr(ptr), 4
   End If
 
   ' Free any strings received from WinHttp APIs
   If (IEProxyConfig.lpszAutoConfigURL <> 0) Then
       GlobalFree (IEProxyConfig.lpszAutoConfigURL)
   End If
   If (IEProxyConfig.lpszProxy <> 0) Then
       GlobalFree (IEProxyConfig.lpszProxy)
   End If
   If (IEProxyConfig.lpszProxyByPass <> 0) Then
       GlobalFree (IEProxyConfig.lpszProxyByPass)
   End If
   If (WinHttpProxyInfo.lpszProxy <> 0) Then
       GlobalFree (WinHttpProxyInfo.lpszProxy)
   End If
   If (WinHttpProxyInfo.lpszProxyByPass <> 0) Then
       GlobalFree (WinHttpProxyInfo.lpszProxyByPass)
   End If
 
   ' return the ProxyInfo struct
   GetProxyInfoForUrl = ProxyInfo
 
End Function

                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:

Public Function CallWebService(Optional strClientId As String = "1") As String
    On Error GoTo Error_Handle
 
		Const URL As String = "http:\\localhost"
 
    Dim strSOAPResponse As String
    Dim strSOAPServiceURL As String
 
    'Requires Microsoft SOAP Toolkit 3
    Dim objSOAPClient As Object
    Set objSOAPClient = CreateObject("MSSOAP.SoapClient30")
 
    objSOAPClient.ClientProperty("ServerHTTPRequest") = True
    strSOAPServiceURL = URL & "CallWebService.cfc?wsdl"
    
    'Get Internet Explorer's Proxy Settings
    Dim proxyDetails As ProxyInfo
    proxyDetails = GetProxyInfoForUrl(strSOAPServiceURL)
    
    objSOAPClient.MSSoapInit strSOAPServiceURL
    
    'If using a proxy set objSOAPClient to use too.
    If proxyDetails.active Then
        objSOAPClient.ConnectorProperty("ProxyServer") = proxyDetails.proxy
    End If
    
    'Make SOAP Request
    strSOAPResponse = objSOAPClient.CallWebService(strClientId)
 
    'If empty error occurred
    If IsNull(strSOAPResponse) Or strSOAPResponse = vbNullString Then
        CallWebService = "ERROR"
    Else
        'Return String Response
        CallWebService = strSOAPResponse
    End If
 
    Set objSOAPClient = Nothing
    
Exit_Function:
    Exit Function
 
Error_Handle:
    Select Case Err.number
    Case 429:    'SOAP Toolkit 3 not installed
        Err.Clear
        MsgBox "Please install the Microsoft SOAP Toolkit 3.", vbInformation
      	Resume Exit_Function
    Case 5406, 438: 'If Web Service is unreachable or returns empty string
        Err.Clear
        Resume Next
    Case -2147352567: 'Web Service Error
        Err.number = GetLastError
        Resume Next
    Case Else:
        Resume Exit_Function
    End Select
End Function

                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:

'Current Code:
objSOAPClient.ConnectorProperty("ProxyServer") = localhost:8080
 
'Code Listed in Real World XML Web Services for VB and VB.Net Developers
'Throws error on 2nd and 3rd line
objSOAPClient.ConnectorProperty("ProxyServer") = localhost
objSOAPClient.ConnectorProperty("ProxyPort") = 8080
objSOAPClient.ConnectorProperty("UseProxy") = True
 
'ObjectMix Post
objSOAPClient.ConnectorProperty("ProxyServer") = "<CURRENT_USER>"
objSOAPClient.ConnectorProperty("EnableAutoProxy") = True

                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12: