In diesem Tutorial werden die Zugriffe auf Systemeinstellungen verschiedenster Art behandelt. Alle Werte, Einstellungen und Pfade betreffen in erster Linie Windows 9x. User von Windows NT, 2000 und XP müssen (zumindest was die Registry betrifft) andere Schlüssel verwenden.

Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MemoryStatus)

Public Type MemoryStatus 
    dwLength As Long
    dwMemoryLoad As Long
    dwTotalPhys As Long
    dwAvailPhys As Long
    dwTotalPageFile As Long
    dwAvailPageFile As Long
    dwTotalVirtual As Long
    dwAvailVirtual As Long
End Type

Dim yourmemory As MemoryStatus
yourmemory.dwLength = Len(yourmemory)
GlobalMemoryStatus yourmemory
ProgressBar1.Min = "0"
ProgressBar1.Max = (yourmemory.dwTotalPhys / 1024)
ProgressBar2.Min = "0"
ProgressBar2.Max = (yourmemory.dwTotalPhys / 1024)
ProgressBar2.value = (yourmemory.dwTotalPhys / 1024)
Label1.Caption = "" & (yourmemory.dwTotalPhys / 1024) & " KB"
Label2.Caption = "" & (yourmemory.dwAvailPhys / 1024) & " KB"
ProgressBar3.Min = "0"
ProgressBar3.Max = (yourmemory.dwTotalPageFile / 1024)
ProgressBar3.value = (yourmemory.dwTotalPageFile / 1024)
ProgressBar4.Min = "0"
ProgressBar4.Max = (yourmemory.dwTotalPageFile / 1024)
ProgressBar4.value = (yourmemory.dwAvailPageFile / 1024)
Label3.Caption = "" & (yourmemory.dwTotalPageFile / 1024) & " KB"
Label4.Caption = "" & (yourmemory.dwAvailPageFile / 1024) & " KB"

Dim yourmemory As MemoryStatus
yourmemory.dwLength = Len(yourmemory)
GlobalMemoryStatus yourmemory

Label2.Caption = "" & (yourmemory.dwAvailPhys / 1024) & " KB"
ProgressBar1.value = (yourmemory.dwAvailPhys / 1024)

[vcache]
MinFileCache=16384   ' gibt das Minimum an
MaxFileCache=16384   ' für Maximum
ChunkSize=1024       ' Blockgröße, empfohlen 512 oder 1024

Declare Function WritePrivateProfileString Lib "kernel32" Alias _
"WritePrivateProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) _
As Long

Declare Function GetPrivateProfileString Lib "kernel32" Alias _
"GetPrivateProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString 
As String, ByVal nSize As Long, ByVal lpFileName As String) As Long

Dim n&, a&, c&, d& 
n = WritePrivateProfileString("VCache", "MinFileCache", _
  Text1.Text, "System.ini")
a = WritePrivateProfileString("VCache", "MaxFileCache", _
  Text2.Text, "System.ini")
c = WritePrivateProfileString("VCache", "ChunkSize", _
  Text3.Text, "System.ini")
d = WritePrivateProfileString("386Enh", "ConservativeSwapFileUsage", _
  "1", "System.ini")

Dim l&, s$
Dim a&, s1$
Dim b&, s2$
s = Space$(200)
s1 = Space$(200)
s2 = Space$(200)
l = GetPrivateProfileString("VCache", "Minfilecache", "", _
s, 200, "System.ini")
a = GetPrivateProfileString("VCache", "Maxfilecache", "", _
s1, 200, "System.ini")
b = GetPrivateProfileString("VCache", "ChunkSize", "", _
s2, 200, "System.ini")

s1 = Left$(s1, a)
s = Left$(s, l)
s2 = Left$(s2, b)

Text1.Text = s
Text2.Text = s1
Text3.Text = s2

Const REG_DWORD = 4
Const HKEY_DYN_DATA = &H80000006

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
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias _
"RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, _
phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long

Private m_intPercent As Single

Private Function GetCPUStatus() As Integer
Dim lngData As Long, lnghKey As Long, lngRet As Long
lngRet = RegOpenKey(HKEY_DYN_DATA, "PerfStats\StatData", lnghKey)
  If lngRet <> 0 Then 
      MsgBox "Fehler beim Lesen aus der Registrierdatenbank."
      Unload Me
  End If

lngRet = RegQueryValueEx(lnghKey, "KERNEL\CPUUsage", 0, _
REG_DWORD, lngData, 4)
GetCPUStatus = Trim(Str(Int(lngData)))
lngRet = RegCloseKey(lnghKey)
End Function

Dim lngData As Long, lnghKey As Long, lngRet As Long
lngRet = RegOpenKey(HKEY_DYN_DATA, "PerfStats\StartStat", lnghKey)
  If lngRet <> 0 Then  
    MsgBox "Fehler beim Lesen aus der Registrierdatenbank."
    Unload Me
  End If

lngRet = RegQueryValueEx(lnghKey, "KERNEL\CPUUsage", 0, _
REG_DWORD, lngData, 4)
lngRet = RegCloseKey(lnghKey)

m_intPercent = GetCPUStatus
Label1.Caption = CStr(m_intPercent) & " %"

Const SR = 0
Const GDI = 1
Const USR = 2
Private Declare Function pBGetFreeSystemResources Lib "rsrc32.dll" _
Alias "_MyGetFreeSystemResources32@4" (ByVal iResType As Integer)_
As Integer

lblGDI.Caption = (pBGetFreeSystemResources(GDI)) & " %"

lblUSER.Caption = (pBGetFreeSystemResources(USR)) & " %"

lblSYSTEM.Caption = (pBGetFreeSystemResources(SR)) & " %"

Dim ComNam as Variant
If GetValue(HKEY_LOCAL_MACHINE, "System\CurrentControlSet\Control_
  \ComputerName\ComputerName", "ComputerName", ComNam) Then
  Label1.caption = "Computername: " + CStr(ComNam)
End If

Dim großB&
Dim kleinB&

großB = "1"
kleinB = "0"
  If Check1.value = 1 Then
    SetValue HKEY_CURRENT_USER, "Software\Microsoft\Windows\_
    CurrentVersion\Explorer\Advanced", "DontPrettyPath", großB
  Else
    SetValue HKEY_CURRENT_USER, "Software\Microsoft\Windows\_
    CurrentVersion\Explorer\Advanced", "DontPrettyPath", kleinB
  End If

Dim strQuickView As String
strQuickView = "*"
  If Check2.value = 1 Then
    CreateKey HKEY_CLASSES_ROOT, "*\Quickview", ""
    SetValue HKEY_CLASSES_ROOT, "*\Quickview", "", strQuickView
  Else
    DeleteKey HKEY_CLASSES_ROOT, "*\Quickview"
  End If

Dim BmPP$
Dim StandRd$
BmPP = "%1"
StandRd = ""

If Option1.value = True Then
  SetValue HKEY_CLASSES_ROOT, "Paint.Picture\DefaultIcon", _
  "", StandRd
End If

If Option2.value = True Then
  SetValue HKEY_CLASSES_ROOT, "Paint.Picture\DefaultIcon", _
  "", BmPP
End If

abcdeF = "" 
  If Check4.value = 1 Then
    SetValue HKEY_CLASSES_ROOT, "lnkfile", "IsShortcut", abcdeF
  Else
    ' Lösche den Schlüssel
    DeleteValue HKEY_CLASSES_ROOT, "lnkfile", "IsShortcut"
  End If

Dim s$
s = Text1.Text (der Wert kann von 10 bis 400 reichen)
SetValue HKEY_CURRENT_USER, "Control Panel\Desktop", "MenuShowDelay", s)

Dim mOeff$
mOeff = "rundll32.exe Shell32.dll,OpenAs_RunDLL %1"
  If Check10.value = 1 Then
    CreateKey HKEY_CLASSES_ROOT, "Unknown\Shell\OpenAs\_
    command", ""
    SetValue HKEY_CLASSES_ROOT, "Unknown\Shell\OpenAs\_
    command", "", mOeff
  Else
    DeleteKey HKEY_CLASSES_ROOT, "Unknown\Shell\OpenAs"
  End If

CreateKey HKEY_LOCAL_MACHINE, _
"Software\Microsoft\Windows\CurrentVersion\explorer\_
Desktop\NameSpace\{645FF040-5081-101B-9F08-00AA002F954E}", ""

Me.MousePointer = vbHourglass
Dim nResult As Long
Dim nOldSize As Long
Dim lSize As String
lSize = "32"
Dim uSize As String

uSize = "31"'Änderung der Icongröße auf 31 pixel
nOldSize = SetValue(HKEY_CURRENT_USER, _
"Control Panel\Desktop\WindowMetrics", "Shell Icon Size", uSize)
'System von der Änderung benachrichtigen
SendMessageTimeout HWND_BROADCAST, WM_SETTINGCHANGE, 0, 0, _
SMTO_ABORTIFHUNG, 3, nResult
'Zeit zum Ändern...
Sleep 1000
'Änderung wieder rückgängig machen
nOldSize = SetValue(HKEY_CURRENT_USER, _
"Control Panel\Desktop\WindowMetrics", "Shell Icon Size", lSize)
'System wieder benachrichtigen.
SendMessageTimeout HWND_BROADCAST, WM_SETTINGCHANGE, 0, 0, _
SMTO_ABORTIFHUNG, 3, nResult
Me.MousePointer = vbNormal

Private Declare Function SendMessageTimeout Lib "user32" _
Alias "SendMessageTimeoutA" (ByVal hwnd As Long, _
ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long, _
ByVal fuFlags As Long, ByVal uTimeout As Long, _
lpdwResult As Long)As Long
Private Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)

Private Const WM_SETTINGCHANGE = &H1A
Private Const SMTO_ABORTIFHUNG = &H2
Private Const HWND_BROADCAST = &HFFFF&

' Hier der Code für die Änderung (zB OK_Click)
Me.MousePointer = vbHourglass
Dim nResult As Long
SendMessageTimeout HWND_BROADCAST, WM_SETTINGCHANGE, 0, 0, _
SMTO_ABORTIFHUNG, 3, nResult
'Zeit zum Ändern...
  Sleep 500
Me.MousePointer = vbNormal

Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, _
ByVal nIndex As Long) As Long

Declare Function CreateCaret Lib "user32" _
(ByVal hwnd As Long, ByVal hBitmap As Long, _
ByVal nWidth As Long, ByVal nHeight As Long) As Long
Declare Function HideCaret Lib "user32" _
(ByVal hwnd As Long) As Long

Declare Function SetCaretBlinkTime Lib "user32" _
(ByVal wMSeconds As Long) As Long
Declare Function ShowCaret Lib "user32" _
(ByVal hwnd As Long) As Long

Declare Function GetWindowsDirectory Lib "kernel32" _
Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, _
ByVal nSize As Long) As Long

Declare Function GetSystemDirectory Lib "kernel32" Alias _
"GetSystemDirectoryA" (ByVal lpBuffer As String, _
ByVal nSize As Long) As Long