背景：

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 dbs = CurrentDb
    On Error GoTo AddProp_Err
    dbs.Properties(strName) = varvalue
    AddAppProperty = True
AddProp_Bye:
    Exit Function
AddProp_Err:
    If ERR = conPropNotFoundError Then
        Set prp = dbs.CreateProperty(strName, varType, varvalue)
        dbs.Properties.Append prp
        Resume
    Else
        AddAppProperty = False
        Resume AddProp_Bye
    End If
End Function