form1.frm

vb源码大全

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4965
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4965
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton SetColor 
      Caption         =   "设置IE颜色"
      Height          =   375
      Left            =   1800
      TabIndex        =   8
      Top             =   2400
      Width           =   1695
   End
   Begin VB.TextBox BackGround 
      Height          =   375
      Left            =   2040
      TabIndex        =   7
      Text            =   "192,192,192"
      Top             =   1200
      Width           =   1935
   End
   Begin VB.TextBox TextColor 
      Height          =   375
      Left            =   2040
      TabIndex        =   6
      Text            =   "0,0,0"
      Top             =   1680
      Width           =   1935
   End
   Begin VB.TextBox AnchorVisited 
      Height          =   375
      Left            =   2040
      TabIndex        =   5
      Text            =   "128,0,128"
      Top             =   720
      Width           =   1935
   End
   Begin VB.TextBox Anchor 
      Height          =   375
      Left            =   2040
      TabIndex        =   4
      Text            =   "0,0,255"
      Top             =   240
      Width           =   1935
   End
   Begin VB.Label Label4 
      AutoSize        =   -1  'True
      Caption         =   "TextColor"
      Height          =   180
      Left            =   900
      TabIndex        =   3
      Top             =   1800
      Width           =   810
   End
   Begin VB.Label Label3 
      AutoSize        =   -1  'True
      Caption         =   "BackgroundColor"
      Height          =   180
      Left            =   360
      TabIndex        =   2
      Top             =   1320
      Width           =   1350
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      Caption         =   "AnchorColorVisited"
      Height          =   180
      Left            =   90
      TabIndex        =   1
      Top             =   840
      Width           =   1620
   End
   Begin VB.Label AnchorColor 
      AutoSize        =   -1  'True
      Caption         =   "AnchorColor"
      Height          =   180
      Left            =   720
      TabIndex        =   0
      Top             =   360
      Width           =   990
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit
'枚举，设置注册表中的根目录
Public Enum REG_TOPLEVEL_KEYS
HKEY_CLASSES_ROOT = &H80000000
'HKEY_CLASSES_ROOT根目录
HKEY_CURRENT_CONFIG = &H80000005
HKEY_CURRENT_USER = &H80000001
HKEY_DYN_DATA = &H80000006
HKEY_LOCAL_MACHINE = &H80000002
HKEY_PERFORMANCE_DATA = &H80000004
HKEY_USERS = &H80000003
End Enum
'建立键
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (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 Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal Hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
'自定义常数
Private Const REG_SZ = 1
Private Sub SetColor_Click()
Dim ans As Boolean
ans = SetIEColor(Anchor.Text, AnchorVisited.Text, BackGround.Text, TextColor.Text)
If ans Then
MsgBox "SetIEColorOK" & vbCr & _
"AnchorColor:" & Anchor & vbCr & _
"AnchorVisited:" & AnchorVisited & vbCr & _
"BackgroundColor:" & BackGround & vbCr & _
"TextColor:" & TextColor
Else
MsgBox "SetIEColorFailure"
End If
End Sub

Function SetIEColor(AnchorColor As String, AnchorColorVisited As String, BackgroundColor As String, TextColor As String) As Boolean
Dim bAns As Boolean
'返回值
On Error GoTo ErrorHandler
bAns = True
'写入超链接颜色
bAns = bAns And WriteStringToRegistry(HKEY_CURRENT_USER, "Software\Microsoft\Internet Explorer\Settings", "AnchorColor", AnchorColor)
'设置已经连接过的超链接颜色
bAns = bAns And WriteStringToRegistry(HKEY_CURRENT_USER, "Software\Microsoft\Internet Explorer\Settings", "AnchorColorVisited", AnchorColorVisited)
'设置背景颜色
bAns = bAns And WriteStringToRegistry(HKEY_CURRENT_USER, "Software\Microsoft\Internet Explorer\Settings", "BackgroundColor", BackgroundColor)
'设置文字颜色
bAns = bAns And WriteStringToRegistry(HKEY_CURRENT_USER, _
"Software\Microsoft\InternetExplorer\Settings", _
"TextColor", TextColor)
'设置返回值
SetIEColor = bAns
Exit Function
ErrorHandler:
'错误处理代码段
SetIEColor = False
End Function
Private Function WriteStringToRegistry(Hkey As REG_TOPLEVEL_KEYS, strPath As String, _
strValue As String, strdata As String) As Boolean
On Error GoTo ErrorHandler
'运行错误转到ErrorHandler
Dim keyhand As Long
Dim r As Long
'建立键
r = RegCreateKey(Hkey, strPath, keyhand)
If r = 0 Then
'建立成功
'设置键值
r = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata))
'关闭键
r = RegCloseKey(keyhand)
End If
'设置返回值
WriteStringToRegistry = (r = 0)
Exit Function
ErrorHandler:
'错误处理代码段
WriteStringToRegistry = False
MsgBox Err.Description
End Function