Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0514: Proxyserver des Internet Explorer einstellen

VB 5/6-Tipp 0514: Proxyserver des Internet Explorer einstellen

 von Klaus Langbein

Schwierigkeitsgrad:

Verwendete API-Aufrufe: RegCloseKey, RegCreateKeyExA (RegCreateKeyEx), RegDeleteKeyA (RegDeleteKey), RegDeleteValueA (RegDeleteValue), RegFlushKey, RegOpenKeyExA (RegOpenKeyEx), RegQueryValueExA (RegQueryValueEx), RegSetValueExA (RegSetValueEx_DWord), RegSetValueExA (RegSetValueEx_String)

Download: Download des Beispielprojektes [6,38 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei ProxyReg.vbp -------------
' Die Komponente 'Microsoft Rich Textbox Control 6.0 (RICHTX32.OCX)' wird benötigt.
' Die Komponente 'Microsoft Tabbed Dialog Control 6.0 (TABCTL32.OCX)' wird benötigt.
' Die Komponente ' (MSINET.OCX)' wird benötigt.

'---------- Anfang Modul "Reg" alias registry.bas  ----------

'Dieser Source stammt von http://www.ActiveVB.de

'Sollten Sie Fehler entdecken oder Fragen haben, dann
'mailen Sie mir bitte unter: Reinecke@ActiveVB.de
'**************************************************************

' Registry Deklarationen
Option Explicit

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
        
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
        
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 Any) As Long
        
Declare Function RegCreateKeyEx Lib "advapi32.dll" _
        Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal _
        lpSubKey As String, ByVal Reserved As Long, ByVal _
        lpClass As String, ByVal dwOptions As Long, ByVal _
        samDesired As Long, ByVal lpSecurityAttributes As Any, _
        phkResult As Long, lpdwDisposition As Long) As Long
        
Declare Function RegFlushKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
        
Declare Function RegSetValueEx_String Lib "advapi32.dll" _
        Alias "RegSetValueExA" (ByVal hKey As Long, ByVal _
        lpValueName As String, ByVal Reserved As Long, ByVal _
        dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
        
Declare Function RegSetValueEx_DWord Lib "advapi32.dll" _
        Alias "RegSetValueExA" (ByVal hKey As Long, ByVal _
        lpValueName As String, ByVal Reserved As Long, ByVal _
        dwType As Long, lpData As Long, ByVal cbData As Long) As Long
        
Declare Function RegDeleteKey Lib "advapi32.dll" Alias _
        "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
        
Declare Function RegDeleteValue Lib "advapi32.dll" Alias _
        "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long


Global Const HKEY_CLASSES_ROOT = &H80000000
Global Const HKEY_CURRENT_USER = &H80000001
Global Const HKEY_LOCAL_MACHINE = &H80000002
Global Const HKEY_USERS = &H80000003
Global Const HKEY_PERFORMANCE_DATA = &H80000004
Global Const HKEY_CURRENT_CONFIG = &H80000005
Global Const HKEY_DYN_DATA = &H80000006

Global Const KEY_QUERY_VALUE = &H1
Global Const KEY_SET_VALUE = &H2
Global Const KEY_CReatE_SUB_KEY = &H4
Global Const KEY_ENUMERATE_SUB_KEYS = &H8
Global Const KEY_NOTIFY = &H10
Global Const KEY_CReatE_LINK = &H20
Global Const KEY_READ = KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
                 
Global Const KEY_ALL_ACCESS = _
             KEY_QUERY_VALUE Or _
             KEY_SET_VALUE Or _
             KEY_CReatE_SUB_KEY Or _
             KEY_ENUMERATE_SUB_KEYS Or _
             KEY_NOTIFY Or _
             KEY_CReatE_LINK
                       
Global Const ERROR_SUCCESS = 0&

Global Const REG_NONE = 0
Global Const REG_SZ = 1
Global Const REG_EXPAND_SZ = 2
Global Const REG_BINARY = 3
Global Const REG_DWORD = 4
Global Const REG_DWORD_LITTLE_ENDIAN = 4
Global Const REG_DWORD_BIG_ENDIAN = 5
Global Const REG_LINK = 6
Global Const REG_MULTI_SZ = 7

Global Const REG_OPTION_NON_VOLATILE = &H0





Function RegKeyExist(ByVal Root As Long, Key$) As Long

    Dim result As Long
    
    Dim hKey As Long
    'Prüfen ob ein Schlüssel existiert
    result = RegOpenKeyEx(Root, Key$, 0, KEY_READ, hKey)
    If result = ERROR_SUCCESS Then
        Call RegCloseKey(hKey)
    End If
    RegKeyExist = result
    
End Function

Function RegKeyCreate(ByVal Root As Long, Newkey$) As Long

    Dim result&, hKey&, Back&
    'Neuen Schlüssel erstellen
    
    result = RegCreateKeyEx(Root, Newkey$, 0, vbNullString, _
                            REG_OPTION_NON_VOLATILE, _
                            KEY_ALL_ACCESS, 0&, hKey, Back)
                            
    If result = ERROR_SUCCESS Then
    
        result = RegFlushKey(hKey)
        If result = ERROR_SUCCESS Then
            Call RegCloseKey(hKey)
        End If
        RegKeyCreate = Back
        
    End If
    
End Function

Private Function RegKeyDelete(Root&, Key$) As Long
  'Schlüssel erstellen
  RegKeyDelete = RegDeleteKey(Root, Key)
End Function

Private Function RegFieldDelete(ByVal Root As Long, ByVal Key$, Field$) As Long

    Dim result As Long
    Dim hKey As Long
    'Feld löschen
    result = RegOpenKeyEx(Root, Key, 0, KEY_ALL_ACCESS, hKey)
    
    If result = ERROR_SUCCESS Then
        result = RegDeleteValue(hKey, Field)
        result = RegCloseKey(hKey)
    End If
    
    RegFieldDelete = result
    
End Function

Function RegValueSet(ByVal Root As Long, Key$, Field$, Value As Variant) As Long

    Dim result&, hKey&, s$, l&
    'Wert in ein Feld der Registry schreiben
    result = RegOpenKeyEx(Root, Key, 0, KEY_ALL_ACCESS, hKey)
    
    If result = ERROR_SUCCESS Then
    
        Select Case VarType(Value)
      
        Case vbInteger, vbLong
          l = CLng(Value)
          result = RegSetValueEx_DWord(hKey, Field$, 0, REG_DWORD, l, 4)
          
        Case vbString
          s = CStr(Value)
          result = RegSetValueEx_String(hKey, Field$, 0, REG_SZ, s, Len(s) + 1)
          
        End Select
      
        result = RegCloseKey(hKey)
        
    End If
    
    RegValueSet = result
    
End Function

Function RegValueGet(ByVal Root As Long, Key$, Field$, Value As Variant) As Long
    
    ' return value is passed back in variable 'value'
    ' function return is error value
    
    Dim result&, hKey&, dwType&, Lng&, Buffer$, l&, pos
      'Wert aus einem Feld der Registry auslesen
      
    result = RegOpenKeyEx(Root, Key, 0, KEY_READ, hKey)
    ' Reg  Open creates a handle (similar to brush or font handle)
    ' field$ determines the parameter to be read
      
    If result = ERROR_SUCCESS Then
      
        result = RegQueryValueEx(hKey, Field$, 0&, dwType, ByVal 0&, l)
        ' l receives the length
        ' dwType receives 1 in case of string
        ' result is error value
        ' seems setting 0& instead of buffer is used as a dummy just to
        ' determine length before actual reading
        ' Now the value can actually be read (what a Krampf)
        
        If result = ERROR_SUCCESS Then
        
            Select Case dwType
            
            Case REG_SZ
            
                Buffer = Space$(l + 1)
                result = RegQueryValueEx(hKey, Field$, 0&, dwType, ByVal Buffer, l)
                If result = ERROR_SUCCESS Then
                    pos = InStr(1, Buffer$, Chr$(0), 1) ' this is just for safety
                    If pos Then
                        Buffer$ = Left$(Buffer$, pos - 1)
                    End If
                    Value = Buffer$
                End If
                  
            Case REG_DWORD, REG_BINARY
            
                result = RegQueryValueEx(hKey, Field$, 0&, dwType, Lng, l)
                If result = ERROR_SUCCESS Then
                    Value = Lng
                End If
                
            End Select
            
        End If
        
    End If
      
    If result = ERROR_SUCCESS Then
        result = RegCloseKey(hKey)
    End If
    
    RegValueGet = result
      
End Function


Function NextChar(Text$, char$) As String
    
    Dim pos As Long
    pos = InStr(1, Text$, char$)
    If pos = 0 Then
      NextChar = Text$
      Text$ = ""
    Else
      NextChar = Left$(Text$, pos - 1)
      Text$ = Mid$(Text, pos + Len(char$))
    End If
    
End Function



'----------- Ende Modul "Reg" alias registry.bas  -----------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Schaltfläche "cmdCancel"
' Steuerelement: Schaltfläche "cmdClear"
' Steuerelement: Schaltfläche "cmdSet"
' Steuerelement: Optionsfeld-Steuerelement "OptProxyEnable" (Index von 0 bis 1)
' Steuerelement: Schaltfläche "cmdRead"
' Steuerelement: Textfeld "TxtPort"
' Steuerelement: Textfeld "TxtProxIP"
' Steuerelement: Textfeld "txtProxy"
' Steuerelement: Beschriftungsfeld "Label1"
' Steuerelement: Beschriftungsfeld "Label11"
' Steuerelement: Beschriftungsfeld "Label10"
' Steuerelement: Beschriftungsfeld "Label9"

'Dieser Source stammt von http://www.ActiveVB.de

'Sollten Sie Fehler entdecken oder Fragen haben, dann
'mailen Sie mir bitte unter: Reinecke@ActiveVB.de
'**************************************************************

' Autor: K. Langbein Klaus@ActiveVB.de

' Beschreibung: Neben dem Internet Explorer verwenden auch andere
' MS-Komponenten, z.B. das MSInet.ocx, die Einstellungen des IE.
' Mit Hilfe dieses Programms koennen die Einträge in der Registry
' gelesen oder auch gesetzt werden, so dass sie automatisch vom
' MSInet oder Webbrowser-Control verwendet werden.
Option Explicit

Dim RegRoot As Long ' Registry Root z.B. HKEY_CURRENT_USER
Dim RegKey$         ' Der zu veraendernde Schluessel
Dim Sett As Long    ' Flag zum Unterdruecken mancher Funktionen

Dim OldProxy$
Dim OldIP$
Dim OldPort$
Dim oldEnabled As Long
Function Enable_HttpProxy(ByVal OnOff As Long) As Long

    Dim result As Long
    
    If OnOff <> 0 Then
        OnOff = 1      ' Die Registry verwendet eine 1 fuer "Wahr"
    End If
    
    result = RegValueSet(RegRoot, RegKey$, "ProxyEnable", OnOff)
    
    Enable_HttpProxy = result

End Function
Function Set_HttpProxy(ByVal prox$) As Long

    Dim result As Long
    
    prox$ = "http=" + prox$
    result = RegValueSet(RegRoot, RegKey$, "ProxyServer", prox$)
    
    Set_HttpProxy = result

End Function





Function SplitVB5(Source$, Delim$) As String

    ' Vb6 Benutzer benoetigen diese Funktion nicht
    Dim pos As Integer
    Dim LeftPart$
    pos = InStr(1, Source$, Delim$, 1)
    If pos > 0 Then
        LeftPart$ = Left$(Source$, pos - 1)
        Source$ = Mid$(Source$, pos + Len(Delim$))
    Else
        LeftPart$ = Source$
        Source$ = ""
    End If
    
    SplitVB5 = LeftPart$

End Function

Function is_ip(ByVal Source$) As Long

    ' Testet ob ein String wie eine IP-Adresse
    ' (also 4 dreistellige Zahlen, durch Punkt getrennt)
    ' aufgebaut ist.
    
    Dim test$
    Dim cnt As Long
    Dim i As Long
    
   
    For i = 1 To 3
        test$ = SplitVB5(Source$, ".")
        If IsNumeric(test$) Then
            cnt = cnt + 1
        End If
    Next i
    If IsNumeric(Source$) Then
        cnt = cnt + 1
    End If
    
    If cnt = 4 Then
        is_ip = -1
    End If
    
End Function

Function Read_HttpTimeout() As Long

    ' Hier eine weitere Funktion mit der man auslesen kann
    ' nach welcher Zeit (s), eine Seite neu geladen werden
    ' soll, anstatt aus dem Cache gelesen zu werden.

    Dim retval As Long
    Dim ret As Long
    
    ret = RegValueGet(RegRoot, RegKey$, "HttpDefaultExpiryTimeSecs", retval)
    
    Read_HttpTimeout = retval
    
End Function


Function Read_Proxy() As String

    Dim retstr$
    Dim pos As Long
    
    Dim ret
    ret = RegValueGet(RegRoot, RegKey$, "ProxyServer", retstr$)
    pos = InStr(1, retstr$, "http=", 1)
    If pos > 0 Then
        retstr$ = Mid$(retstr$, pos + 5) ' das "http:" entfernen
    End If
    pos = InStr(1, retstr$, ";", 1)
    If pos > 0 Then
        retstr$ = Left(retstr$, pos - 1)
    End If
    Read_Proxy = retstr$
    
End Function

Function Read_ProxyEnable() As Long

    Dim retval As Long
    Dim ret As Long
    
    ret = RegValueGet(RegRoot, RegKey$, "ProxyEnable", retval)
    
    Read_ProxyEnable = retval * -1
    
End Function


Sub ini_RegKeys()

    Dim result As Long

    RegRoot = HKEY_CURRENT_USER
    
    ' Dieser Schlüssel wird unter Windows 95 für MS Internet Explorer verwendet.
    ' Andere Betriebssyteme verwenden eventuell einen anderen Schüssel.
    RegKey$ = "Software\Microsoft\Windows\CurrentVersion\Internet Settings"
       
    'Testen ob Schlüssel existiert
    result = RegKeyExist(RegRoot, RegKey$)
    If result <> 0 Then
        MsgBox "Fehler!"
    End If
    
   
End Sub





Private Sub cmdCancel_Click()
    
    txtProxy.Text = OldProxy$
    TxtProxIP.Text = OldIP$
    TxtPort.Text = OldPort$
    If oldEnabled = 1 Then
        OptProxyEnable(0).Value = -1
    Else
        OptProxyEnable(1).Value = -1
    End If
    Call cmdSet_Click
        
End Sub

Private Sub cmdClear_Click()

    Sett = 1
    TxtProxIP.Text = ""
    txtProxy.Text = ""
    TxtPort.Text = ""
    Sett = 0
    
End Sub

Private Sub cmdRead_Click()

    Dim test$
    Dim result$
    Call cmdClear_Click
    Sett = 1
    test$ = Read_Proxy()
    result$ = SplitVB5(test$, ":")
    If is_ip(result$) Then
        TxtProxIP.Text = result$
    Else
        txtProxy.Text = result$
    End If
    If test$ <> "" Then
        TxtPort.Text = test$
    End If
        
    
    If Read_ProxyEnable() Then
        OptProxyEnable(0).Value = -1
    Else
        OptProxyEnable(1).Value = -1
    End If
    cmdSet.Enabled = 0
    Sett = 0
    
End Sub

Private Sub cmdSet_Click()

    Dim Proxy$
    Dim ret As Long
    
    Proxy$ = TxtProxIP.Text ' Die Ip wird bevorzugt, da hiermit kein
                            ' Nameserver aufgerufen werden muss.
    If Proxy$ = "" Then
        Proxy$ = txtProxy.Text ' Wenn das IP-Feld lerr ist,
    End If                     ' den Namen verwenden
    
    If Proxy$ = "" Then
        MsgBox "Enter a valid proxy server first !", 64
        Exit Sub
    End If
    
    If TxtPort.Text = "" Then
        MsgBox "You must supply a proxy port !"
        Exit Sub
    Else
        If Val(TxtPort.Text) <> 0 Then
            Proxy$ = Proxy$ + ":" + TxtPort.Text ' Der Port wird nach ":" angehängt.
        Else
            MsgBox "You must supply a proxy port !"
            Exit Sub
        End If
    End If
       
    ret = Set_HttpProxy(Proxy$)
    
    If OptProxyEnable(0).Value Then
        ret = Enable_HttpProxy(-1)
    Else
        ret = Enable_HttpProxy(0)
    End If
    cmdSet.Enabled = 0
    
    Call cmdRead_Click ' und wieder auslesen
    
End Sub

Private Sub Form_Load()

    Call ini_RegKeys    ' Schlüssel eintragen
    Call cmdRead_Click  ' Erstmal lesen...
    
    ' Urspruengliche Werte werden gespeichert.
    OldProxy$ = txtProxy.Text
    OldIP$ = TxtProxIP.Text
    OldPort$ = TxtPort.Text
    If OptProxyEnable(0).Value = -1 Then
        oldEnabled = 1
    End If
    
End Sub

Private Sub OptProxyEnable_Click(Index As Integer)

    If Sett = 1 Then
        Exit Sub
    End If
    cmdSet.Enabled = -1
  
End Sub


Private Sub TxtPort_Change()
    If Sett = 1 Then
        Exit Sub
    End If
    cmdSet.Enabled = -1
End Sub

Private Sub TxtProxIP_Change()
    If Sett = 1 Then
        Exit Sub
    End If
    cmdSet.Enabled = -1
End Sub

Private Sub txtProxy_Change()
    If Sett = 1 Then
        Exit Sub
    End If
    cmdSet.Enabled = -1
End Sub


'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei ProxyReg.vbp --------------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 3 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.