|
Microsoft Visual Basic 的MDI窗口虽然可以通过窗口的PICTURE属性设置窗口的背景图，使程序美化了不少。但是图片加载之后当窗口在不同的分辨率下，会出现缺口的现象，比如在800*600下设计的图片，到了1024*768下右边和下边就会出现一块空余（背景色露了出来，非常难看）。并且当窗口的大小被用户改变的时候，图片也会被载断，使原本设计的很漂亮的图片变的“惨不妨睹”；笔者在开发项目的过程中经过摸索，写出了跟 WINDOWS 的设置桌面背景比较类似的功能。好东西不敢独享，写出来与大家共同提高。
作者：崔占民
EMAIL：CUIZM@163.COM
2004.6.8
以下是程序代码:
Option Explicit
''''MDI窗口代码
''''/============================================================================\
''''| 作者:崔占民 2003.6.21 |
''''| EMAIL:CUIZM@163.COM |
''''| 添加一个MDI主窗口,一个普通的窗口,设置为MDI的子窗口(MDIChild属性设置为TRUE) |
''''| 添加一个模块,用于设置打开文件对话框的API函数及结构 |
''''| 在MDI主窗口中加一个菜单,菜单名为背景,其下添加四项子菜单,分别为:选择背景图, |
''''| 默认背景,拉伸与平铺,其代码如下所示 |
''''| |
''''\============================================================================/
Private Sub MDIForm_Load()
On Error Resume Next
Dim ls_tmp As String
''''读取注册的设置,是拉伸还是平铺,然后设置菜单项
ls_tmp = GetSetting("OrientZiXun", "BackGround", "LaShen")
If ls_tmp = "True" Then
mnuPull.Checked = True
mnuLay.Checked = False
Else
mnuPull.Checked = False
mnuLay.Checked = True
End If
End Sub
Private Sub MDIForm_Resize()
On Error Resume Next
frmBack.SetBack
frmBack.Hide
End Sub
''''设置缺省图片
Private Sub mnuDefault_Click()
If MsgBox("您确定要清除当前背景，而选用默认背景吗？", vbQuestion + vbYesNo) = vbNo Then Exit Sub
Screen.MousePointer = 11
DoEvents
SaveSetting "OrientZiXun", "BackGround", "PathValue", ""
frmBack.SetBack
frmBack.Hide
Screen.MousePointer = 0
End Sub
''''平铺背景
Private Sub mnuLay_Click()
mnuPull.Checked = False
mnuLay.Checked = True
SaveSetting "OrientZiXun", "BackGround", "LaShen", "False"
frmBack.SetBack
frmBack.Hide
End Sub
''''拉伸背景
Private Sub mnuPull_Click()
mnuPull.Checked = True
mnuLay.Checked = False
SaveSetting "OrientZiXun", "BackGround", "LaShen", "True"
frmBack.SetBack
frmBack.Hide
End Sub
''''选择背景图片
Private Sub mnuSelBack_Click()
On Error GoTo Errhandle
Dim fName As String, sName As String, OfName As OPENFILENAME
OfName.lStructSize = Len(OfName)
OfName.hwndOwner = hWnd
OfName.hInstance = App.hInstance
OfName.lpstrFilter = "图片文件" & Chr(0) & "*.Bmp;*.jpg;*.jpeg;*.gif;*.ico"
OfName.lpstrFile = Space(255) & Chr(0)
OfName.nMaxFile = 256
OfName.lpstrFileTitle = Space(255) & Chr(0)
OfName.nMaxFileTitle = 256
OfName.lpstrTitle = "选择图片..."
OfName.flags = OFN_LONGNAMES + OFN_PATHMUSTEXIST + OFN_FILEMUSTEXIST + OFN_HIDEREADONLY
If GetOpenFileName(OfName) Then
Screen.MousePointer = 11
DoEvents
SaveSetting "OrientZiXun", "BackGround", "PathValue", OfName.lpstrFile
frmBack.SetBack
frmBack.Hide
Screen.MousePointer = 0
End If
Exit Sub
Errhandle:
Screen.MousePointer = 0
MsgBox Err.Description
End Sub
Option Explicit
''''背景子窗口代码
''''/============================================================================\
''''| 作者:崔占民 2003.6.21 |
''''| EMAIL:CUIZM@163.COM |
''''| 在窗口中分别添加一个PICTUREBOX控件和一个IMAGE控件,名称分别为:picBack和 |
''''| imgDefault |
''''| |
''''| |
''''| |
''''\============================================================================/
''''设置背景函数
Public Sub SetBack()
On Error Resume Next
Dim i As Long, j As Long, ls_Path As String
''''从注册表中读取背景图片路径
ls_Path = GetSetting("OrientZiXun", "BackGround", "PathValue")
If Trim(ls_Path) <> "" Then
If Dir(ls_Path) <> "" Then
picBack.Picture = LoadPicture(ls_Path) ''''图片存在,将图片显示在缓冲区中
Else
picBack.Picture = imgDefault.Picture ''''图片不存在,用默认的图片
End If
Else
picBack.Picture = imgDefault.Picture ''''路径为空,用默认的图片
End If
If frmMain.mnuPull.Checked Then ''''如果为拉伸
Me.PaintPicture picBack.Picture, 0, 0, frmMain.Width, frmMain.Height
Else ''''如果为平铺
For j = 0 To frmMain.ScaleHeight St [1] [2] 下一页 | 
