~~如何更改系统和窗体的图标~~

joy0708

下面做的只能改变系统和数据库窗体的图标，我自己做的窗体的图标并没有改，请问大家可以更改一下实现所有窗体的图标都改变吗？或是什么新方法解决如题问题？



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 编辑 ]

咱家是猫

更改ACC窗体图标这么麻烦?
intx = AddAppProperty("AppIcon", DB_Text, CurrentProject.Path & "\Ico.ico")
Application.RefreshTitleBar
更改窗体个性化图标的,论坛上也发的有,你搜索下.

joy0708

帖子发的代码不能改变自己做的窗体的图标，您能帮俺修改一下吗，我觉得应该是该这一行（'更改窗体图标
    SetFormIcon Me.hWnd, CurrentProject.Path & "\ico.ico"），先谢谢您了，大虾！！

咱家是猫

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

咱家是猫

以上是Grant发的代码,让你搜,你又不搜.

andymark

如果是2003版本的, 在启动里设置一个就OK啦

joy0708

谢谢，问题解决啦