access更改系统和窗体的图标

时　间:2007-10-26 08:37:07
作　者:xuewuyuan   ID：240  城市：常州
摘　要:用于ACCESS更改系统和窗体的图标、系统标题的代码
正　文:

背景：

1.在MDB文件的相同文件夹下放上一个图片文件,假定文件名为ico.ico。

2.有一个窗体frmOpen，并设为启动窗体。

在窗体frmOpen的打开事件中写代码：

Private Sub Form_Open(Cancel As Integer)
'更改窗体图标
    SetFormIcon Me.hWnd, CurrentProject.Path & "\ico.ico"
    '更改系统标题及图标
    Dim intX As Integer
    Const DB_Text As Long = 10
    intX = AddAppProperty("AppTitle", DB_Text, "XXX系统")
    intX = AddAppProperty("AppIcon", DB_Text, CurrentProject.Path & "\ico.ico")
    Application.RefreshTitleBar
End Sub

在模块中写代码：

Option Explicit

Declare Function LoadImage Lib "User32" Alias "LoadImageA" (ByVal hInst As Long, _
                                                            ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, _
                                                            ByVal un2 As Long) As Long
Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, _
                                                                ByVal wMsg As Long, ByVal wparam As Long, lparam As Any) As Long

Const WM_GETICON = &H7F
Const WM_SETICON = &H80
Const ICON_SMALL = 0
Const ICON_BIG = 1
Const IMAGE_BITMAP = 0
Const IMAGE_ICON = 1
Const IMAGE_CURSOR = 2
Const IMAGE_ENHMETAFILE = 3
Const LR_DEFAULTCOLOR = &H0
Const LR_MONOCHROME = &H1
Const LR_COLOR = &H2
Const LR_COPYRETURNORG = &H4
Const LR_COPYDeleteORG = &H8
Const LR_LOADFROMFILE = &H10
Const LR_LOADTRANSPARENT = &H20
Const LR_DEFAULTSIZE = &H40
Const LR_LOADMAP3DCOLORS = &H1000
Const LR_CreateDIBHeader = &H2000
Const LR_COPYFROMRESOURCE = &H4000
Const LR_SHARED = &H8000

Function SetFormIcon(hWnd As Long, IconPath As String) As Boolean
    On Error GoTo Exit_err
    Dim hIcon As Long
    If Dir(IconPath) = "" Then Exit Function
    hIcon = LoadImage(0&, IconPath, IMAGE_ICON, 16, 16, LR_LOADFROMFILE)
    If hIcon <> 0 Then
        Call SendMessage(hWnd, WM_SETICON, 0, ByVal hIcon)
        SetFormIcon = True
    Else
        End
    End If
Exit_err:
    Exit Function
End Function

Function AddAppProperty(strName As String, varType As Variant, varvalue As Variant) As Integer
    Dim dbs As Object, prp As Variant
    Const conPropNotFoundError = 3270
    Set

Access软件网官方交流QQ群 (群号:483923997) 　　　　　　Access源码网店