将BMP图像导入Excel的程序

楼主 amulee	研究了一天BMP图像格式，了解了一些基本信息。尝试着将BMP图片画入Excel工作簿，效果如图：由于16位和32位图过于复杂，目前还不支持导入。代码参考如下： '定义位图文件头信息类型 Type BMPHeader Header As String '头信息 Size As Long '文件大小 DataOffset As Long '数据偏移 Width As Long '宽 Height As Long '高 Bit As Long '图像位数 InfLen As Long '信息头总长度 ColoPanLen As Long '调色板长度 End Type Sub Main() Dim FS As Integer Dim Temp As Byte Dim FName As String Dim BMPHd As BMPHeader Dim ArrColor Dim arrPoints Dim i As Long FName = ThisWorkbook.Path & "\ET 24BIT.BMP" BMPHd = GetBmpHeader(FName) Select Case BMPHd.Bit Case 1 MsgBox "暂不支持" Exit Sub Case Is < 16 ArrColor = GetBmpRGBColor(FName, BMPHd.InfLen, BMPHd.ColoPanLen) arrPoints = GetBmpPoints(FName, BMPHd.Width, BMPHd.Height, BMPHd.Bit, BMPHd.DataOffset, ArrColor) Case 24 arrPoints = GetBmpPoints(FName, BMPHd.Width, BMPHd.Height, BMPHd.Bit, BMPHd.DataOffset) Case Else MsgBox "暂不支持" Exit Sub End Select With Sheet4 .Cells.Interior.Color = xlNone For i = 1 To UBound(arrPoints) For j = 1 To UBound(arrPoints, 2) .Cells(j, i).Interior.Color = arrPoints(i, j) Next j Next i End With End Sub '获取BMP头信息 Function GetBmpHeader(ByVal FName As String) As BMPHeader Dim Temp() As Byte Dim FS As Integer FS = FreeFile '打开文件 Open FName For Binary Access Read As #FS '文件头 GetFS Temp, 2, FS, 1 GetBmpHeader.Header = Chr(Temp(1)) & Chr(Temp(2)) '文件大小 GetFS Temp, 4, FS, 3 GetBmpHeader.Size = GetNumber(Temp) '图像数据偏移量 GetFS Temp, 4, FS, 11 GetBmpHeader.DataOffset = GetNumber(Temp) '图像宽度 GetFS Temp, 4, FS, 19 GetBmpHeader.Width = GetNumber(Temp) '图像高度 GetFS Temp, 4, FS, 23 GetBmpHeader.Height = GetNumber(Temp) '图像位数 GetFS Temp, 2, FS, 29 GetBmpHeader.Bit = GetNumber(Temp) '信息头长度 GetFS Temp, 4, FS, 15 GetBmpHeader.InfLen = GetNumber(Temp) + 14 GetBmpHeader.ColoPanLen = GetBmpHeader.DataOffset - GetBmpHeader.InfLen Close #FS End Function '获取调色板信息 Function GetBmpRGBColor(ByVal FName As String, ByVal ColorOffset As Long, ByVal ColorLen As Long) Dim Temp() As Byte Dim ArrJG() Dim Pos As Long Dim EndPos As Long Dim K As Long Dim FS As Integer ReDim ArrJG(ColorLen / 4 - 1) '终点位置 EndPos = ColorOffset + ColorLen FS = FreeFile Open FName For Binary Access Read As #FS '开始循环获取颜色 For Pos = ColorOffset + 1 To EndPos Step 4 '获取一个颜色数组 GetFS Temp, 4, FS, Pos '添加颜色，并转换成RGB颜色 ArrJG(K) = RGB(Temp(3), Temp(2), Temp(1)) '计数累积 K = K + 1 Next Close #FS '结果输出 GetBmpRGBColor = ArrJG End Function Function GetBmpPoints(ByVal FName As String, ByVal FWidth As Long, ByVal FHeight As Long, _ ByVal Bit As Long, ByVal DataOffset As Long, Optional ByVal ArrColor) Dim ArrJG() As Long Dim Pos As Long Dim Temp() As Byte Dim TempHex Dim TempColor As Long Dim FS As Integer Dim Bln As Boolean '定义数组大小 ReDim ArrJG(1 To FWidth, 1 To FHeight) FS = FreeFile Select Case Bit '处理16色图 Case 4 Open FName For Binary Access Read As #FS '初始位置 Pos = DataOffset + 1 For j = FHeight To 1 Step -1 For i = 1 To FWidth '如果未读取则执行读取 If Not Bln Then '读取一个数据 GetFS Temp, 1, FS, Pos '该数据包含两个点。读取第一个点 TempHex = WorksheetFunction.Dec2Hex(Temp(1), 2) TempColor = ArrColor(WorksheetFunction.Hex2Dec(Left(TempHex, 1))) Bln = True Else TempColor = ArrColor(WorksheetFunction.Hex2Dec(Right(TempHex, 1))) Bln = False '下移一个位置 Pos = Pos + 1 End If ArrJG(i, j) = TempColor Next i Next j Close #FS '处理256色图 Case 8 Open FName For Binary Access Read As #FS '初始位置 Pos = DataOffset + 1 For j = FHeight To 1 Step -1 For i = 1 To FWidth '读取一个数据，一个字节表示一个点 GetFS Temp, 1, FS, Pos ArrJG(i, j) = ArrColor(Temp(1)) '下移一个位置 Pos = Pos + 1 Next i Next j Close #FS '处理24位 Case 24 Open FName For Binary Access Read As #FS '初始位置 Pos = DataOffset + 1 For j = FHeight To 1 Step -1 For i = 1 To FWidth '读取一个数据，三个字节表示一个点 GetFS Temp, 3, FS, Pos ArrJG(i, j) = RGB(Temp(3), Temp(2), Temp(1)) '下移一个位置，3字节 Pos = Pos + 3 Next i Next j Close #FS End Select '结果输出 GetBmpPoints = ArrJG End Function '数字计算 Function GetNumber(ByVal Temp) Dim StrA As String Dim StrB As String For i = UBound(Temp) To LBound(Temp) Step -1 StrB = Hex(Temp(i)) If Len(StrB) = 1 Then StrB = 0 & StrB StrA = StrA & StrB Next GetNumber = WorksheetFunction.Hex2Dec(StrA) End Function '读取文件 Sub GetFS(ByRef Temp() As Byte, ByVal Length As Long, ByVal FileNumber As Integer, Optional Pos) ReDim Temp(1 To Length) If IsMissing(Pos) Then Get FileNumber, , Temp Else Get FileNumber, Pos, Temp End If End Sub BMP Reader.xlsm.rar
2楼 biaotiger1	阿木就是牛，果然厉害。
3楼水星钓鱼	这个要逆天啊看来要赶上学长路还很常啊