form1.frm

vb源码大全

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   2715
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   5355
   LinkTopic       =   "Form1"
   ScaleHeight     =   2715
   ScaleWidth      =   5355
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton SetFont 
      Caption         =   "设置字体"
      Height          =   495
      Left            =   1800
      TabIndex        =   4
      Top             =   1680
      Width           =   1455
   End
   Begin VB.TextBox TEXTFont 
      Height          =   375
      Left            =   1920
      TabIndex        =   3
      Text            =   "华文行楷"
      Top             =   960
      Width           =   2055
   End
   Begin VB.TextBox HTMLFont 
      Height          =   375
      Left            =   1920
      TabIndex        =   2
      Text            =   "华文行楷"
      Top             =   360
      Width           =   2055
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      Caption         =   "HTMLFont"
      Height          =   180
      Left            =   960
      TabIndex        =   1
      Top             =   480
      Width           =   720
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "TextFont"
      Height          =   180
      Left            =   960
      TabIndex        =   0
      Top             =   960
      Width           =   720
   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 SetFont_Click()
Dim ans As Boolean
'设置字体
ans = SetIEFont(HTMLFont, TEXTFont)
If ans Then
'成功
MsgBox "SetIEFontOK" & vbCr & "HTMLFONT:" & HTMLFont & vbCr & "TEXTFONT:" & TEXTFont
Else
'失败
MsgBox "SetIEFontFailure"
End If

End Sub
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

Function SetIEFont(HTMLFont As String, TEXTFont As String) As Boolean
On Error GoTo ErrorHandler
'设置文本文件字体
SetIEFont = WriteStringToRegistry(HKEY_CURRENT_USER, "Software\Microsoft\Internet Explorer\International\Scripts\3", "IEFixedFontName", TEXTFont)
'设置HTML文件字体
'SetIEFont = WriteStringToRegistry(HKEY_CURRENT_USER, "Software\Microsoft\Internet Explorer\International\Scripts\3", "IEPropFontName", HTMLFont)
SetIEFont = SetIEFont And WriteStringToRegistry(HKEY_CURRENT_USER, "Software\Microsoft\Internet Explorer\International\Scripts\3", "IEPropFontName", HTMLFont)
Exit Function
ErrorHandler:
'错误处理代码段
SetIEFont = False
End Function