VB语言

本类阅读TOP10

·Visual Basic 安装程序的制作!!
·VB中使用EXCEL输出
·一个简单的MP3播放器
·VB程序实现WindowsXP效果的界面!!
·VB打造超酷个性化菜单(六)
·透明位图
·平铺与拉伸MDI窗口的背景图 ~!~
·对《VB程序实现WindowsXP效果的界面》一文的补遗
·从Windows资源管理器中拖动文件
·VB打造超酷个性化菜单(一)

分类导航
VC语言Delphi
VB语言ASP
PerlJava
Script数据库
其他语言游戏开发
文件格式网站制作
软件工程.NET开发
平铺与拉伸MDI窗口的背景图 ~!~

作者:未知 来源:月光软件站 加入时间:2005-2-28 月光软件站

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

 




相关文章

相关软件




月光软件源码下载编程文档电脑教程网站优化网址导航网络文学游戏天地生活休闲写作范文安妮宝贝站内搜索
电脑技术编程开发网络专区谈天说地情感世界游戏元素分类游戏热门游戏体育运动手机专区业余爱好影视沙龙
音乐天地数码广场教育园地科学大观古今纵横谈股论金人文艺术医学保健动漫图酷二手专区地方风情各行各业

月光软件站·版权所有