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
[ 本帖最后由 joy0708 于 2008-8-6 19:42 编辑 ]作者: 咱家是猫 时间: 2008-8-6 20:20
更改ACC窗体图标这么麻烦?
intx = AddAppProperty("AppIcon", DB_Text, CurrentProject.Path & "\Ico.ico")
Application.RefreshTitleBar
更改窗体个性化图标的,论坛上也发的有,你搜索下.作者: joy0708 时间: 2008-8-6 21:04
帖子发的代码不能改变自己做的窗体的图标，您能帮俺修改一下吗，我觉得应该是该这一行（'更改窗体图标
SetFormIcon Me.hWnd, CurrentProject.Path & "\ico.ico"），先谢谢您了，大虾！！作者: 咱家是猫 时间: 2008-8-6 21:20
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_SETICON = &H80
Const IMAGE_ICON = 1
Const LR_LOADFROMFILE = &H10
'hwnd为窗体句柄 iconpath為ico文件路径
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作者: 咱家是猫 时间: 2008-8-6 21:21
以上是Grant发的代码,让你搜,你又不搜.作者: andymark 时间: 2008-8-6 22:15
如果是2003版本的, 在启动里设置一个就OK啦作者: joy0708 时间: 2008-8-6 22:38
谢谢，问题解决啦