Option ExplicitSub LoadImageIntoExcel() Me.Activate Dim strFileName As String Dim bmpFileHeader As BITMAPFILEHEADER Dim bmpInfoHeader As BITMAPINFOHEADER Dim ExcelPalette() As PALETTE Dim Palette24 As PALETTE24Bit Dim i As Integer Dim r As Integer, c As Integer Dim dAdjustedWidth As Double Dim Padding As Byte On Error GoTo CloseFile strFileName = Application.GetOpenFilename Open strFileName For Binary As #1 Get #1, , bmpFileHeader Get #1, , bmpInfoHeader
If bmpInfoHeader.lngWidth Mod 4 > 0 Then dAdjustedWidth = (((Int((bmpInfoHeader.lngWidth * bmpInfoHeader.intBitCount) / 32) + 1) * 4#)) / _ (bmpInfoHeader.intBitCount / 8#) If dAdjustedWidth Mod 4 <> 0 Then dAdjustedWidth = Application.RoundUp(dAdjustedWidth, 0) Else dAdjustedWidth = bmpInfoHeader.lngWidth End If If bmpInfoHeader.intBitCount <= 8 Then ReDim ExcelPalette(0 To 255) For i = 0 To UBound(ExcelPalette) Get #1, , ExcelPalette(i) Next i Dim bytPixel As Byte For r = 1 To bmpInfoHeader.lngHeight For c = 1 To dAdjustedWidth If c <= bmpInfoHeader.lngWidth Then Get #1, , bytPixel Me.Cells(bmpInfoHeader.lngHeight + 1 - r, c).Interior.Color = _ RGB(ExcelPalette(bytPixel).red, _ ExcelPalette(bytPixel).green, _ ExcelPalette(bytPixel).blue) DoEvents Else Get #1, , Padding Me.Cells(bmpInfoHeader.lngHeight + 1 - r, c).Interior.Color = _ RGB(255, 255, 255) End If
Next c Next r Else For r = 1 To bmpInfoHeader.lngHeight For c = 1 To dAdjustedWidth If c <= bmpInfoHeader.lngWidth Then Get #1, , Palette24 Me.Cells(bmpInfoHeader.lngHeight + 1 - r, c).Interior.Color = _ RGB(Palette24.red, _ Palette24.green, _ Palette24.blue) Else Get #1, , Padding Me.Cells(bmpInfoHeader.lngHeight + 1 - r, c).Interior.Color = _ RGB(255, 255, 255) End If DoEvents Next c Next r End If MsgBox "Done"CloseFile: If Len(Err.Description) > 0 Then MsgBox Err.Description Close #1End Sub
Type BITMAPFILEHEADER strFileType As String * 2 lngFileSize As Long bytReserved1 As Integer bytResrved2 As Integer lngBitmapOffset As LongEnd TypeType BITMAPINFOHEADER lngSize As Long lngWidth As Long lngHeight As Long lngPlanes As Integer intBitCount As Integer lngCompression As Long lngSizeImage As Long lngXPelsPerMeter As Long lngYPelsPerMeter As Long lngClrUsed As Long lngClrImportant As LongEnd TypeType PALETTE blue As Byte green As Byte red As Byte reserve As ByteEnd Type Type PALETTE24Bit blue As Byte green As Byte red As ByteEnd Type
