GFMDIBackGround/GFMDIBackGround.frm

VERSION 5.00
Begin VB.MDIForm Testfrm
   BackColor       =   &H8000000C&
   Caption         =   "MDIForm1"
   ClientHeight    =   4995
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   7245
   LinkTopic       =   "MDIForm1"
   StartUpPosition =   3 'Windows‑Standard
   Begin VB.PictureBox Picture1
      Align           =   1 'Oben ausrichten
      BorderStyle     =   0 'Kein
      Enabled         =   0 'False
      Height          =   285
      Left            =   0
      ScaleHeight     =   285
      ScaleWidth      =   7245
      TabIndex        =   0
      Top             =   0
      Visible         =   0 'False
      Width           =   7245
      Begin VB.PictureBox GFMDIBackGroundPicture
         Enabled         =   0 'False
         Height          =   255
         Left            =   0
         ScaleHeight     =   195
         ScaleWidth      =   135
         TabIndex        =   1
         Top             =   0
         Visible         =   0 'False
         Width           =   195
      End
   End
End
Attribute VB_Name = "Testfrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001 by Louis (stolen from Matt Hart).
'GFMDIBackGroundPicture
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal lDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal lDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal lDC As Long, ByVal hObject As Long) As Long
'GFMDIBackGroundPicture
Dim GFMDIBackGroundPicture_PictureHeight As Long
Dim GFMDIBackGroundPicture_PictureWidth As Long
Dim GFMDIBackGroundPicture_hMemDC As Long
Dim GFMDIBackGroundPicture_Picture As StdPicture

Private Sub MDIForm_Load()
    'on error resume next
    Dim ProgramDirectory As String
    ProgramDirectory = App.Path
    If Not (Right$(ProgramDirectory, 1) = "\") Then ProgramDirectory = ProgramDirectory + "\"
    Call GFMDIBackGround_LoadPicture(ProgramDirectory + "claw.bmp")
End Sub

Private Sub MDIForm_Resize()
    'on error resume next
    Call GFMDIBackGround_Resize
End Sub

'***GFMDIBACKGROUNDPICTURE***

Private Sub GFMDIBackGround_LoadPicture(ByVal PictureName As String)
    'on error resume next 'load picture that is to be displayed centered within MDI window
    If Not ((Dir(PictureName) = "") Or (Right$(PictureName, 1) = "\") Or (PictureName = "")) Then 'verify
        'load picture
        GFMDIBackGroundPicture.Visible = False
        GFMDIBackGroundPicture.Enabled = False
        GFMDIBackGroundPicture.Picture = LoadPicture(PictureName)
        GFMDIBackGroundPicture.AutoRedraw = True
        GFMDIBackGroundPicture.AutoSize = True
        GFMDIBackGroundPicture.Refresh
        'transfer values
        GFMDIBackGroundPicture_PictureHeight = GFMDIBackGroundPicture.Height
        GFMDIBackGroundPicture_PictureWidth = GFMDIBackGroundPicture.Width
        Set GFMDIBackGroundPicture_Picture = GFMDIBackGroundPicture.Picture
        Set GFMDIBackGroundPicture.Picture = LoadPicture("") 'reset
        GFMDIBackGroundPicture.AutoSize = False 'reset
        GFMDIBackGroundPicture_hMemDC = CreateCompatibleDC(GFMDIBackGroundPicture.hDC)
        Call SelectObject(GFMDIBackGroundPicture_hMemDC, GFMDIBackGroundPicture_Picture.Handle)
        Call GFMDIBackGround_Resize 'display picture
    Else
        MsgBox "internal error in GFMDIBackGround_LoadPicture(): file not found !", vbOKOnly + vbExclamation
    End If
End Sub

Private Sub GFMDIBackGround_Resize()
    'on error resume next 'call when MDI form is resized
    Dim X As Long, Y As Long
    'begin
    If Not (WindowState = vbMinimized) Then 'verify
        'transfer values
        GFMDIBackGroundPicture.BackColor = Me.BackColor
        GFMDIBackGroundPicture.Width = Me.ScaleWidth + (4 * Screen.TwipsPerPixelX)
        GFMDIBackGroundPicture.Height = Me.ScaleHeight + (4 * Screen.TwipsPerPixelY)
        'BitBlt picture
        X = ((Me.ScaleWidth ‑ GFMDIBackGroundPicture_PictureWidth) \ 2) \ Screen.TwipsPerPixelX
        Y = ((Me.ScaleHeight ‑ GFMDIBackGroundPicture_PictureHeight) \ 2) \ Screen.TwipsPerPixelY
        Call BitBlt(GFMDIBackGroundPicture.hDC, X, Y, GFMDIBackGroundPicture_PictureWidth \ Screen.TwipsPerPixelX, GFMDIBackGroundPicture_PictureHeight \ Screen.TwipsPerPixelY, GFMDIBackGroundPicture_hMemDC, 0, 0, vbSrcCopy)
        Set Me.Picture = GFMDIBackGroundPicture.Image
    Else
        'do nothing
    End If
End Sub

Private Sub GFMDIBackGround_UnloadPicture()
    'on error resume next
    Set GFMDIBackGroundPicture_Picture = LoadPicture("") 'reset
    Call DeleteDC(GFMDIBackGroundPicture_hMemDC) 'reset
End Sub

'***END OF GFMDIBACKGROUNDPICTURE***

Private Sub MDIForm_Unload(Cancel As Integer)
    'on error resume next
    Call GFMDIBackGround_UnloadPicture
End Sub


[END OF FILE]