平铺与拉伸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 St

[1] [2]  下一页

Copyright ＠ 2007-2012 敏韬网(敏而好学，文韬武略--MinTao.Net)（学习笔记） Inc All Rights Reserved.
闵涛 E_mail:admin@mintao.net(欢迎提供学习资源)

鄂公网安备 42011102001154号

站长：MinTao ICP备案号：鄂ICP备11006601号-18