点击下载此附件
效果图:
制作过程:
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, "我是修改的窗体名称!!!")
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 ICO_BIG = 1
Const IMAGE_BITMAP = 0
Const IMAGE_ICON = 1
Const IMAGECURSOR = 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