'ビットマップファイルを一時的に表示するマクロ(Excel95)

'TestマクロのsFileNameに、表示させるBMPファイル名を設定し、実行してください。

Option Explicit

Const OF_READ = &h0

Type Byte
    Value As String * 1
End Type

Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function GetWindowRect Lib "user32" ( _
    ByVal hWnd As Long, lpRect As RECT) As Long
Declare Function GetClientRect Lib "user32" ( _
    ByVal hWnd As Long, lpRect As RECT) As Long
Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function ReleaseDC Lib "user32" ( _
    ByVal hWnd As Long, ByVal hDC As Long) As Long
Declare Function SetDIBitsToDevice Lib "gdi32" ( _
    ByVal hDC As Long, ByVal x As Long, ByVal y As Long, _
    ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, _
    ByVal Scan As Long, ByVal NumScans As Long, ByRef Bits As Any, _
    ByRef BitsInfo As Any, ByVal wUsage As Long) As Long
Declare Sub MoveMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
    ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Declare Function lopen Lib "kernel32" Alias "_lopen" ( _
    ByVal lpPathName As String, ByVal iReadWrite As Long) As Long
Declare Function lclose Lib "kernel32" Alias "_lclose" ( _
    ByVal hFile As Long) As Long
Declare Function lread Lib "kernel32" Alias "_lread" ( _
    ByVal hFile As Long, ByRef lpBuffer As Any, ByVal wBytes As Long) As Long


Function BitmapFileShow(sFileName As String) As Long
    Dim ifno As Long
    Dim iLength As Long, iOffBits As Long, iBitmapInfoSize As Long
    Dim sBitmapFileInfo(0 To 13) As Byte, sBitmapInfo() As Byte, sBitmap() As Byte
    Dim iWidth As Long, iHeight As Long
    Dim hWnd As Long, hDC As Long
    Dim iRet As Long
    Dim rc As RECT, rc2 As RECT

    On Error GoTo err_1
    BitmapFileShow = 1

    'ビットマップファイルのオープン
    iLength = FileLen(sFileName)
    ifno = lopen(sFileName, 0)
    If ifno = -1 Then
        Exit Function
    End If

    'BitmapFileInfoの読み込み
    iRet = lread(ifno, sBitmapFileInfo(0), 14)
    If iRet <> 14 Then
        lclose ifno
        Exit Function
    End If

    '先頭2バイトをチェック
    iRet = 0
    MoveMemory iRet, sBitmapFileInfo(0), 2
    If iRet <> &h4d42 Then
        Close #ifno
        Exit Function
    End If

    'ビットマップビットのファイルの先頭からのオフセットを取得
    MoveMemory iOffBits, sBitmapFileInfo(10), 4
    If iOffBits >= iLength Then
        Close #ifno
        Exit Function
    End If

    'BitmapInfoの読み込み
    iBitmapInfoSize = iOffBits - 14
    ReDim sBitmapInfo(0 To iBitmapInfoSize - 1)
    iRet = lread(ifno, sBitmapInfo(0), iBitmapInfoSize)
    If iRet <> iBitmapInfoSize Then
        lclose ifno
        Exit Function
    End If

    'BitmapInfoをバイト配列にコピーし、ビットマップのサイズを取得
    MoveMemory iWidth, sBitmapInfo(4), 4
    MoveMemory iHeight, sBitmapInfo(8), 4

    'ビットマップの読み込み
    ReDim sBitmap(0 To (iLength - iOffBits - 1) - 1)
    iRet = lread(ifno, sBitmap(0), iLength - iOffBits)
    If iRet <> iLength - iOffBits Then
        lclose ifno
        Exit Function
    End If

    'ビットマップファイルのクローズ
    lclose ifno

    'Excelウィンドウへビットマップを表示
    hWnd = FindWindow("XLMAIN", Application.Caption)
    iRet = GetWindowRect(hWnd, rc)
    iRet = GetClientRect(hWnd, rc2)
    hDC = GetDC(hWnd)
    iRet = SetDIBitsToDevice(hDC, _
        (rc.Right - rc.Left - iWidth) \ 2 - (rc.Right - rc.Left - rc2.Right), _
        (rc.Bottom - rc.Top - iHeight) \ 2 - (rc.Bottom - rc.Top - rc2.Bottom), _
        iWidth, iHeight, 0, 0, 0, iHeight, sBitmap(0), sBitmapInfo(0), 0)
    iRet = ReleaseDC(hWnd, hDC)
    BitmapFileShow = 0
    Exit Function
err_1:
    If ifno <> 0 Then lclose ifno
    If hDC <> 0 Then iRet = ReleaseDC(hWnd, hDC)
End Function

Sub Test()
    Dim sFileName As String
    sFileName = "d:\logo.bmp"
    If BitmapFileShow(sFileName) <> 0 Then
        MsgBox "ビットマップファイルの表示でエラーが発生しました。", vbExclamation
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Application.Wait Now + TimeSerial(0, 0, 3)
    Application.ScreenUpdating = True
End Sub