Access开发培训
网站公告
·Access专家课堂QQ群号:151711184    ·Access快速开发平台下载地址及教程    ·欢迎加入Access专家课堂微信群!    ·如何快速搜索本站文章|示例|资料    
您的位置: 首页 > 技术文章 > Access数据库-模块/函数/VBA

用代码修改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 


Access软件网QQ交流群 (群号:54525238)       Access源码网店

常见问答:

技术分类:

相关资源:

专栏作家

关于我们 | 服务条款 | 在线投稿 | 友情链接 | 网站统计 | 网站帮助