平铺与拉伸MDI窗口的背景图 ~!~2006-10-28 8:23:16平铺与拉伸MDI窗口的背景图 ~!~2006-10-28 8:23:16平铺与拉伸MDI窗口的背景图 ~!~
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 Step picBack.ScaleHeight
For i = 0 To frmMain.ScaleWidth Step picBack.ScaleWidth
Me.PaintPicture picBack.Picture, i, j
Next
Next
End If
Me.Font.Name = "楷体_GB2312"
Me.ForeColor = vbBlue
Me.Font.Size = 24
Me.FontBold = True
Me.CurrentX = frmMain.ScaleWidth - 3500
Me.CurrentY = frmMain.ScaleHeight - 1000
Me.Print "咨询管理系统"
frmMain.Picture = Me.Image
frmMain.BackColor = frmMain.BackColor - 1 '为了刷MDI窗口,否则背景不会改变
End Sub
Private Sub Form_Load()
On Error Resume Next
Me.AutoRedraw = True
picBack.AutoSize = True
End Sub
Option Explicit
'模块代码
Public Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Public Const OFN_LONGNAMES = &H200000
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_FILEMUSTEXIST = &H1000
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_EXPLORER = &H80000
Public Const OFN_OVERWRITEPROMPT = &H2
Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Public Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
平铺与拉伸MDI窗口的背景图 ~!~2006-10-28 8:23:16平铺与拉伸MDI窗口的背景图 ~!~2006-10-28 8:23:16平铺与拉伸MDI窗口的背景图 ~!~
