例子：改变应用程序图标和窗体背景-->tmtony转移

zhuyiwen

为了做这个例子，把我ACCESS给玩死了。



文件下载

[em26][em26][em26]

xinbao

很不错啦，但几个改背景的例子都是美眉，没有俊男，这儿女程序员也不少吧：）
看不到源码哦？

zhuyiwen

其实这个例子综合了两个方面的东西。

一、根据dca在《请教：如何用代码修改应用程序标题和应用程序图标？》贴中的回复，设置数据库应用程序的标题栏和图标。
见：http://www.office-cn.net/bbs/dispbbs.asp?boardID=2&RootID=3263&ID=3263&page=2

二、修改《设置程序背景的小例子[竹笛2]》贴中的程序，去掉了ACCESS最大化，仅留下窗体最大化。
见：http://www.office-cn.net/bbs/dispbbs.asp?boardID=2&RootID=3756&ID=3756&page=1

另：下载的例子，含源代码（请按Shift）打开。[em19]

prince

如果能加上打开查找图片和图标功能就更完美了！！

WTM1

xinbao :你要的源代码！

Option Compare Database
Public ICO

Private Sub cmdICO_Click()
    If ICO = 1 Then
        intX = AddAppProperty("AppIcon", DB_Text, CurrentProject.Path & "\FStar.ico")
        Application.RefreshTitleBar                 '//设置程序的标题,图标
        ICO = 0
    Else
        intX = AddAppProperty("AppIcon", DB_Text, CurrentProject.Path & "\MSN.ico")
        Application.RefreshTitleBar                 '//设置程序的标题,图标
        ICO = 1
    End If

End Sub

Private Sub cmdPic_Click()
    If Me.Picture = CurrentProject.Path & "\a.jpg" Then
        Me.Picture = CurrentProject.Path & "\b.jpg"
    Else
        Me.Picture = CurrentProject.Path & "\a.jpg"
    End If
End Sub

Private Sub Form_Close()
    Access.SetOption "Show Status Bar", True
End Sub

Private Sub Form_Load()
    Dim I, J As Integer
   
    ICO = 1
   
    intX = AddAppProperty("AppTitle", DB_Text, "修改背景和应用程序图标的例子")
    intX = AddAppProperty("AppIcon", DB_Text, CurrentProject.Path & "\MSN.ico")
    Application.RefreshTitleBar                 '//设置程序的标题,图标
   
    Me.Picture = CurrentProject.Path & "\b.jpg"
    Access.SetOption "Show Status Bar", False
    ' DoCmd.RunCommand acCmdAppMaximize
    DoCmd.Maximize
   
    I = Me.WindowWidth
    J = Me.WindowHeight
    DoCmd.Restore
    DoCmd.MoveSize 0, 0, I, J
End Sub
Option Compare Database
Option Explicit
Const DB_Text As Long = 10

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

作的很好！！是个典型的例子！值得学习！！

evewxs

谢谢高手！

yuankeh8

的确不错，可我感觉到有点遗憾的是在每次改变背景图片的时候，都会有出现一个“正在导入：F：\....”的消息。请问能否考虑把这一过程给做掉？

moon--star

不错，还有原码，谢谢。[em11][em11]

chaojianan

不错不错，收藏了。

岭南王子

yuankeh8 发表于 2003-7-7 22:37
的确不错，可我感觉到有点遗憾的是在每次改变背景图片的时候，都会有出现一个“正在导入：F：\....”的消息 ...

这问题好像就中文版的才会这样,英文版的则没有,这个好像要改注册表