现在的位置: 首页 > 综合 > 正文

vb MDI背景自动拉伸

2013年10月18日 ⁄ 综合 ⁄ 共 6523字 ⁄ 字号 评论关闭

今天上网看到一个很好的例子 ,引用过来大家共享,如果有朋友引用,请写上作者名字!

作者:崔占民

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
    '//***************************************************************************************************
   ' //经过实践,这里应该加一句刷新MDI窗体的语句,因为MDI没有REFLASH方法,所以***************
   '//REFLASH fRM   与frmBack.SetBack此同时涵数里的                                                                       *
   '//frmMain.BackColor = frmMain.BackColor - 1 对应                                                                           *
    Me.BackColor = Me.BackColor + 1  'Zou_seafarer add 20070521
   '//***************************************************************************************************
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 

抱歉!评论已关闭.