Get proxy server with VBA without using API calls

[Deutz]

Hi and thanks in advance,

I have a VBA URL checker in Excel that needs to provide our organisation's proxy server address to the WinHttp.WinHttpRequest.5.1 object.

I used an API to achieve that in the past but am unable to use API calls any longer due to changes to security within our organisation.

I just need some VBA to obtain the address in case it changes over time. Have searched for this code for a while now but can only find API ways to do this.

Kind regards
Deutz

 

[bobsan42]

You have not provided much information so I am not too sure what you're after.
Your previous code could have been of some help.
BTW, if security settings have been changed you may not be able to obtain this information. But without more knowledge of your system one can only guess.
See if this works for you:

Option Explicit

Enum CMDModeOptions
    optDirectCMD = 1
    optClipboard = 2
    optTempFile = 3
End Enum

Sub getProxyPowerShell()
    Dim cmd As String
    Dim result As String
    cmd = "(Get-ItemProperty -Path 'HKCU:\Software\Microsoft\Windows\CurrentVersion\Internet Settings').proxyServer"
    result = cliCmdExecute(cmd, True, optDirectCMD)
    ActiveCell.Value = result
    ActiveCell.Offset(1).Select
    Debug.Print "proxy: " & Trim(Replace(Replace(result, Chr(10), ""), Chr(13), ""))
    cmd = "(Get-ItemProperty -Path 'HKCU:\Software\Microsoft\Windows\CurrentVersion\Internet Settings').proxyEnable"
    result = cliCmdExecute(cmd, True, optDirectCMD)
    ActiveCell.Value = result
    ActiveCell.Offset(1).Select
    Debug.Print "status: " & Trim(Replace(Replace(result, Chr(10), ""), Chr(13), ""))
End Sub


Function cliCmdExecute(ByVal cli_command As String, Optional usePowerShell As Boolean = False, Optional ByVal Mode As CMDModeOptions = CMDModeOptions.optTempFile) As String
   
    If cli_command = "" Then Exit Function
    Dim shell_prefix As String, shell_suffix As String
    Dim Results As String, objShell As Object
    Dim fullCommand As String
   
    If usePowerShell Then
        shell_prefix = "PowerShell  -ExecutionPolicy Bypass -Outputformat Text -Command """
        shell_suffix = """"
    Else
        shell_prefix = "cmd /C "
        shell_suffix = ""
    End If
   
    fullCommand = shell_prefix & cli_command
   
    Set objShell = CreateObject("Wscript.Shell")
   
    Select Case Mode
        Case optDirectCMD
            Results = objShell.Exec(fullCommand).StdOut.ReadAll()
       
        Case optClipboard
            fullCommand = fullCommand & " | clip" & shell_suffix
            objShell.Run fullCommand, 0, True
            'Stop
            On Error Resume Next
            With CreateObject("htmlfile")
                Results = .ParentWindow.ClipboardData.GetData("text")
                .ParentWindow.ClipboardData.clearData ("text")
            End With
            On Error Resume Next
        Case optTempFile
            Dim tmpfile As String: tmpfile = generateTempFileName
'            fullCommand = fullCommand & " > """ & tmpfile & "" & shell_suffix
            fullCommand = fullCommand & " *> " & tmpfile & shell_suffix
            objShell.Run fullCommand, 0, True
           
            On Error Resume Next
            With CreateObject("Scripting.FileSystemObject")
                If .GetFile(tmpfile).Size > 0 Then
                    Results = .OpenTextFile(tmpfile).ReadAll()
                End If
                .DeleteFile tmpfile
            End With
            On Error GoTo 0
        Case Else
            Exit Function
    End Select
    If Len(Results) = 0 Then Exit Function
   
    cliCmdExecute = Results
    'Debug.Print "CMD results ready:", fullCommand

    Set objShell = Nothing
End Function

Function generateTempFileName(Optional str1 As String, Optional strSeparator As String = "_") As String
    On Error Resume Next
    str1 = Trim(str1)
    If Len(str1) = 0 Then str1 = "tmpOut"
    generateTempFileName = TrailingSlash(Environ("temp")) & _
                    str1 & strSeparator & _
                    Format(Now, "yyyymmdd" & strSeparator & "hhnnss") & strSeparator & _
                    Int(Rnd * 100000) & ".txt"
End Function

Public Function TrailingSlash(varIn As Variant) As String
'The TrailingSlash() function just ensures that the folder names we are processing _
end with the slash character.
    If Len(varIn) > 0& Then
        If Right(varIn, 1&) = Application.PathSeparator Then TrailingSlash = varIn Else TrailingSlash = varIn & Application.PathSeparator
    End If
End Function

If it works at all some things can be fine-tuned later.

 

[bobsan42]

I don't know why I took the long and winding road, but try this as well:

Sub getProxyRegRead()
    Dim regKey As String
    Dim result As String
    regKey = "HKCU\Software\Microsoft\Windows\CurrentVersion\Internet Settings\proxyServer"
    result = CreateObject("WScript.Shell").RegRead(regKey)
    Debug.Print "proxy: " & result
    regKey = "HKCU\Software\Microsoft\Windows\CurrentVersion\Internet Settings\proxyEnable"
    result = CreateObject("WScript.Shell").RegRead(regKey)
    Debug.Print "status: " & result
End Sub

Results show up in the Immediate window of VBE

 

[Deutz]

I don't know why I took the long and winding road, but try this as well:

Sub getProxyRegRead()
    Dim regKey As String
    Dim result As String
    regKey = "HKCU\Software\Microsoft\Windows\CurrentVersion\Internet Settings\proxyServer"
    result = CreateObject("WScript.Shell").RegRead(regKey)
    Debug.Print "proxy: " & result
    regKey = "HKCU\Software\Microsoft\Windows\CurrentVersion\Internet Settings\proxyEnable"
    result = CreateObject("WScript.Shell").RegRead(regKey)
    Debug.Print "status: " & result
End Sub

Results show up in the Immediate window of VBE

Hi bobsan42,

Thanks for your code. I just tried this smaller sub and I get an error, unable to open the registry key for reading on this line:

result = CreateObject("WScript.Shell").RegRead(regKey)

 

[patricktoulon1]

hello
maybe read the proxyenable key before

Sub getProxyRegRead()
    Dim regKey As String
    Dim result As String
    regKey = "HKCU\Software\Microsoft\Windows\CurrentVersion\Internet Settings\proxyEnable"
    result = CreateObject("WScript.Shell").RegRead(regKey)
    Debug.Print "status: " & result
    If result <> 0 Then
        regKey = "HKCU\Software\Microsoft\Windows\CurrentVersion\Internet Settings\proxyServer"
        result = CreateObject("WScript.Shell").RegRead(regKey)
        Debug.Print "proxy: " & result
    Else
        Debug.Print "proxy not working"
    End If
End Sub

 

[Deutz]

hello
maybe read the proxyenable key before

Sub getProxyRegRead()
    Dim regKey As String
    Dim result As String
    regKey = "HKCU\Software\Microsoft\Windows\CurrentVersion\Internet Settings\proxyEnable"
    result = CreateObject("WScript.Shell").RegRead(regKey)
    Debug.Print "status: " & result
    If result <> 0 Then
        regKey = "HKCU\Software\Microsoft\Windows\CurrentVersion\Internet Settings\proxyServer"
        result = CreateObject("WScript.Shell").RegRead(regKey)
        Debug.Print "proxy: " & result
    Else
        Debug.Print "proxy not working"
    End If
End Sub

Hey Patrick,

Thanks for your reply. When I run this sub i get from Debug.print ...

status: 0
proxy not working

Is proving to be more difficult than I thought it would be.

 

[patricktoulon1]

re
Well, that means your proxy isn't configured correctly and isn't working properly
and/or the proxyserver key doesn't exist. Just explore the directory tree for that key in REGEDIT and you'll see for yourself.

 

[Deutz]

re
Well, that means your proxy isn't configured correctly and isn't working properly
and/or the proxyserver key doesn't exist. Just explore the directory tree for that key in REGEDIT and you'll see for yourself.

Ok, thanks for your efforts, much appreciated.