[原创]VB中实现平铺与拉伸MDI窗口的背景图

[原创]VB中实现平铺与拉伸MDI窗口的背景图 Microsoft Visual Basic 的MDI窗口虽然可以通过窗口的PICTURE属性设置窗口的背景图，使程序美化了不少。但是图片加载之后当窗口在不同的分辨率下，会出现缺口的现象，比如在800*600下 设计 领导形象设计圆作业设计ao工艺污水处理厂设计附属工程施工组织设计清扫机器人结构设计 的图片，到了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 '从注册 表 关于同志近三年现实表现材料材料类招标技术评分表图表与交易pdf视力表打印pdf用图表说话 pdf 中读取背景图片路径 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