mpaintmdibackground.bas

一个功能强大、程序条理分明的学生学籍管理系统

Attribute VB_Name = "MPaintMDIBackground"
 Option Explicit
 '这里的代码是关于如何在MDI窗体上显示一个背景位图。
 '该背景位图可以随着MDI窗体进行缩放。
 '在此，调用了一些操作位图以及内存设备DC的API函数，也使用操作窗体及其
 '工作区（客户区）的函数，以实现操作。

 '由于这里运用了子类化MDI窗体客户区的技术，因此不能在VB的IDE环境中区
 '单步执行，否则将会导致不可预测的结果。
 
 '预定义位图的高度和宽度
 Private Const BITMAP_WIDTH As Long = 280&
 Private Const BITMAP_HEIGHT As Long = 161&
 
 '定义常量，用来定义空的指针和Long型的0值
 Private Const API_FALSE As Long = 0&
 '正确返回API函数，定义其为long型的非零值1
 Private Const API_TRUE As Long = 1&
 
 '定义回调函数Windows Proc的地址
 Private addBackgroundProcOld As Long

 '将要子类化的多文档客户区窗口的句柄
 Private m_hSubclassedhWnd As Long
 
 '用户自己设置图片的句柄以及预先存放于设备环境中的位图句柄
 Private hBackgroundBmp As Long
 Private hPrevBmp As Long
 Private hPrevStretchBmp As Long

 '定义用来存放位图的内存设备
 Private hMemoryDC As Long
 Private hStretchDC As Long
 
 '定义Windows消息，分别是大小改变、背景檫除以及窗体绘制消息
 Public Const WM_SIZE As Long = &H5&
 Public Const WM_ERASEBKGND As Long = &H14&
 Public Const WM_PAINT As Long = &HF&
 
 '第一个子窗口的句柄，常用于API函数GetWindow 中。
 Public Const GW_CHILD As Long = 5&
 '想要使用回调函数，定义该常量。常用于API函数SetWindowLong中。
 Public Const GWL_WNDPROC As Long = (-4&)
 
 '按位复制到目的
 Public Const SRCCOPY As Long = &HCC0020  ' (DWORD) dest = source
 
 '定义矩形区域的结构
 Public Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
 End Type

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
   (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long


 Public Declare Function GetClientRect& Lib "user32" (ByVal hwnd&, lpRect As RECT)
 
 Public Declare Function GetUpdateRect& Lib "user32" (ByVal hwnd&, lpRect As RECT, _
   ByVal bErase&)
 
 Public Declare Function GetDC& Lib "user32" (ByVal hwnd&)
 
 Public Declare Function SaveDC& Lib "gdi32" (ByVal hDC&)
 
 Public Declare Function ReleaseDC& Lib "user32" (ByVal hwnd&, ByVal hDC&)
 
 Public Declare Function RestoreDC& Lib "gdi32" (ByVal hDC&, ByVal nSavedDC&)
 
 Public Declare Function DeleteDC& Lib "gdi32" (ByVal hDC&)

 Public Declare Function SelectObject& Lib "gdi32" (ByVal hDC&, ByVal hObject&)
 
 Public Declare Function DeleteObject& Lib "gdi32" (ByVal hObject&)
 
 Public Declare Function CreateCompatibleDC& Lib "gdi32" (ByVal hDC&)
 
 Public Declare Function SetWindowLong& Lib "user32" Alias "SetWindowLongA" _
   (ByVal hwnd&, ByVal nIndex&, ByVal dwNewLong&)
 
 Public Declare Function CallWindowProc& Lib "user32" Alias "CallWindowProcA" _
   (ByVal lpPrevWndFunc&, ByVal hwnd&, ByVal Msg&, ByVal wParam&, ByVal lParam&)

 Public Declare Function LoadBitmapBynum& Lib "user32" Alias "LoadBitmapA" _
   (ByVal hInstance&, ByVal lpBitmapName&)
   
 Public Declare Function LoadBitmap Lib "user32" Alias "LoadBitmapA" _
   (ByVal hInstance As Long, ByVal lpBitmapName As String) As Long

                                                                               
 Public Declare Function CreateCompatibleBitmap& Lib "gdi32" _
   (ByVal hDC&, ByVal nWidth&, ByVal nHeight&)
 
 Public Declare Function BitBlt& Lib "gdi32" (ByVal hDestDC&, ByVal X&, ByVal Y&, _
   ByVal nWidth&, ByVal nHeight&, ByVal hSrcDC&, ByVal xSrc&, ByVal ySrc&, ByVal dwRop&)
 
 Public Declare Function StretchBlt& Lib "gdi32" (ByVal hDC&, ByVal X&, ByVal Y&, _
   ByVal nWidth&, ByVal nHeight&, ByVal hSrcDC&, ByVal xSrc&, ByVal ySrc&, _
   ByVal nSrcWidth&, ByVal nSrcHeight&, ByVal dwRop&)

 Public Declare Function GetWindow& Lib "user32" (ByVal hwnd&, ByVal wCmd&)
 
 '用来判断该程序是否运行于IDE环境中
 Private Declare Function GetClassName& Lib "user32" Alias "GetClassNameA" _
   (ByVal hwnd&, ByVal lpClassName$, ByVal nMaxCount&)

Public Function BackgroundProc(ByVal hwnd As Long, ByVal iMsg As Long, _
                                   ByVal wParam As Long, ByVal lParam As Long) As Long
    'MDI窗体所获得的Windows消息
    Select Case iMsg '系统所获取得消息
        Case WM_SIZE
            Dim hClientDC&, lStretchRect As RECT
    
            '获取窗体的客户区域
            Call GetClientRect(hwnd, lStretchRect)
    
            '创建一个新的位图文件，并且放入可以缩放的设备环境
            DeleteObject SelectObject(hStretchDC, CreateCompatibleBitmap(hMemoryDC, _
                                        lStretchRect.Right, lStretchRect.Bottom))
    
            '对设备中的位图文件进行适当地缩放
            Call StretchBlt(hStretchDC, lStretchRect.Left, lStretchRect.Top, lStretchRect.Right, _
                lStretchRect.Bottom, hMemoryDC, API_FALSE, API_FALSE, BITMAP_WIDTH, BITMAP_HEIGHT, SRCCOPY)
    
            '获取要绘图的区域
            hClientDC = GetDC(hwnd)
    
            '将位图文件复制到绘图区域，绘制位图
            Call BitBlt(hClientDC, lStretchRect.Left, lStretchRect.Top, lStretchRect.Right, _
                            lStretchRect.Bottom, hStretchDC, API_FALSE, API_FALSE, SRCCOPY)
            '释放设备
            ReleaseDC hwnd, hClientDC
      
      
        Case WM_ERASEBKGND, WM_PAINT '背景被檫除或是发生窗体绘制事件
    
            Dim hDC&, lRect As RECT, nRetVal&
    
            '获取要更新的区域
            Call GetUpdateRect(hwnd, lRect, API_FALSE)
            
             '如果是窗体绘制消息，则执行默认得VB窗体过程，并且执行位图填充窗体背景过程
            If iMsg = WM_PAINT Then
              Call CallWindowProc(addBackgroundProcOld, hwnd, iMsg, wParam, lParam)
            Else
              nRetVal = API_TRUE
            End If
           
            '获取绘图设备
            hDC = GetDC(hwnd)
        
            '复制位图到绘图设备
            Call BitBlt(hDC, lRect.Left, lRect.Top, lRect.Right, lRect.Bottom, hStretchDC, _
                                                                lRect.Left, lRect.Top, SRCCOPY)
            '释放绘图设备
            ReleaseDC hwnd, hDC
        
            '返回API函数执行结果，回到窗体
            BackgroundProc = nRetVal
        
            Exit Function
    
    End Select
    
    '处理其他所有的消息
    BackgroundProc = CallWindowProc(addBackgroundProcOld, hwnd, iMsg, wParam, lParam)

End Function

Public Sub InitializePaintBackground(ByVal hwnd&, ByVal temMdiForm As MDIForm)
    '初始化子类化过程
    
    '获取MDI客户区窗体的句柄
    m_hSubclassedhWnd = GetWindow(hwnd, GW_CHILD)
    
    '创建两个内存设备环境来容纳位图
    Dim hOwnerDC&
    
    hOwnerDC = GetDC(m_hSubclassedhWnd)
    hMemoryDC = CreateCompatibleDC(hOwnerDC)
    hStretchDC = CreateCompatibleDC(hOwnerDC)
    ReleaseDC m_hSubclassedhWnd, hOwnerDC
    SaveDC hMemoryDC
    SaveDC hStretchDC
    
    '注意：如果使用资源文件中的位图，则需要有位图的ID，例如载入资源ID
    '为101的位图，用API函数LoadBitmapBynum(App.hInstance, 101&),
    '从资源文件中读取图片。从资源文件中读取文图文件，需要经过编译后
    '才能执行；因为当在IDE中执行的时候，Windows不知道从何处找到资源文件。
    
    '因此，考虑到不用资源文件的方式。而是直接传递MDI Form中
    'Picture属性中指定的图片
    '通过为该过程增加参数temMdiForm，在程序中即可传递位图图片。
    hBackgroundBmp = temMdiForm.Picture
    
    '当选一个新的位图文件到设备中去时，保存预先设置的位图
    hPrevBmp = SelectObject(hMemoryDC, hBackgroundBmp)
    
    Dim lStretchRect As RECT
        
    '获取Windows客户区域
    Call GetClientRect(m_hSubclassedhWnd, lStretchRect)
    
    '创建新的位图，并选入设备环境
    hPrevStretchBmp = SelectObject(hStretchDC, CreateCompatibleBitmap(hMemoryDC, _
                                        lStretchRect.Right, lStretchRect.Bottom))
    
    ' 子类化MDI客户窗口
    addBackgroundProcOld = SetWindowLong(m_hSubclassedhWnd, GWL_WNDPROC, AddressOf BackgroundProc)

End Sub

Public Sub TerminatePaintMDIBackground()
    '中止过程
    
    '返回VB
    Call SetWindowLong(m_hSubclassedhWnd, GWL_WNDPROC, addBackgroundProcOld)
    
    '删除用来容纳背景位图的内存设备
    DeleteObject SelectObject(hMemoryDC, hPrevBmp)
    RestoreDC hMemoryDC, True
    DeleteDC hMemoryDC
    hMemoryDC = API_FALSE
    
    DeleteObject SelectObject(hStretchDC, hPrevStretchBmp)
    RestoreDC hStretchDC, True
    DeleteDC hStretchDC
    hStretchDC = API_FALSE
 
End Sub

Public Function RunningInIde(ByVal hwnd&) As Boolean
    
      Dim sClassName$, nStrLen&
      '检查是否在VB的IDE环境中使用，如果背景图片来自资源文件，则不能在VB的IDE中正确工作
      
      sClassName = String$(260, vbNullChar)
      nStrLen = GetClassName(hwnd, sClassName, Len(sClassName))
      If nStrLen Then sClassName = Left$(sClassName, nStrLen)
      
      If sClassName = "ThunderMDIForm" Then RunningInIde = True

End Function