用代码修改access应用程序或者窗体的图标；相对路径用vba代码更改Access应用程序图标；通过VBA代码设置任务栏相对路径下Access应用程序图标的方法

时　间:2022-11-19 08:30:11
作　者:杨雪   ID：42182  城市：南京
摘　要:分享一个用代码修改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, "我是修改的窗体名称！！！")
    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