将24位位图文件按像素转存单元格

lcluck2002

先说明一下，代码是网上“借鉴”来的。附件里的两段代码，其实是一模一样的。
问题：我在XPSP3+office2007下运行正常，可以在工作表里显示出图像来。
但在换了win10（64位）+office2013下，最后一句显示到单元格的这一句，提示下标越界。
烦请坛里老师帮忙看看，此题何解。感谢！

（已补充上传附件）

tspliu

我想问问你，用的图片像素和当年用的一样吗？
初步估计，没有进行补零就换行了，最后多换了几次行导致aa值多累加了次数。

905738810

最好有附件测试，你这个代码截图太抠了，获取像素点方法太多了不同方法不同代码，你的获取像素代码都没看到，而且下标越界肯定是变量超出数组界限，调试窗口一看就看出来

lcluck2002

905738810 发表于 2021-12-17 11:25
最好有附件测试，你这个代码截图太抠了，获取像素点方法太多了不同方法不同代码，你的获取像素代码都没看到 ...

谢谢你的提醒，原来附件没有上传成功，刚已经重新补充上传了。

morpheus126

应该是以下这段，
其中一些参数没太看懂，不知道有没大神讲解一下，谢谢！
4,18,22,53

1. Sub draw()
   
2. Const photo As String = "图片地址"
   
3. Dim phby() As Byte
   
4. Dim pxc As Long
   
5. Dim pxr As Long
   
6. Dim cc As Long
   
7. Dim cr As Long
   
8. Dim i As Long
   
9. Dim j As Long
   
10. Dim aa As Long
    
11. Dim bb As Long
    
12. 
    
13. Open photo For Binary As #1
    
14. ReDim phby(LOF(1) - 1)
    
15. Get #1, , phby
    
16. Close #1
    
17. For i = 0 To 3
    
18. pxc = pxc + phby(i + 18) * 256 ^ i
    
19. Next
    
20. For i = 0 To 3
    
21. pxr = pxr + phby(i + 22) * 256 ^ i
    
22. Next
    
23. If pxc Mod 4 <> 0 Then
    
24. bb = pxc Mod 4
    
25. Sheet1.Cells.Clear
    
26. For i = pxr To 1 Step -1
    
27. cr = cr + 1
    
28. cc = 0
    
29. For j = 1 To pxc * 3 Step 3
    
30. cc = cc + 1
    
31. aa = 53 + j + (i - 1) * (pxc * 3 + bb)
    
32. Sheet1.Cells(cr, cc).Interior.Color = RGB(phby(aa + 2), phby(aa + 1), phby(aa))
    
33. Next
    
34. Next
    
35. End If

复制代码

905738810

代码看了，bmp结构不是很懂，如果是研究bmp结构我不懂了，如果只是提取像素点可以用别的方法试试，举一个WIA.ImageFile方法例子

1. Sub 转坐标()
   
2.     Application.ScreenUpdating = False
   
3.     Set Thumb = CreateObject("WIA.ImageFile")
   
4.     Thumb.LoadFile "C:\2.bmp"
   
5.     kuan = Thumb.Width
   
6.     For Each k In Thumb.ARGBData
   
7.         i = i + 1
   
8.         h = Int((i - 1) / kuan) + 1
   
9.         w = ((i - 1) Mod kuan) + 1
   
10.         bColor& = k And 16777215
    
11.         b& = bColor And 255
    
12.         g& = (bColor And 65280) / 256
    
13.         r& = (bColor And 16711680) / 65536
    
14.         Cells(h, w).Interior.Color = RGB(r, g, b)
    
15.     Next
    
16.     Application.ScreenUpdating = True
    
17. End Sub

复制代码

morpheus126

905738810 发表于 2021-12-17 15:21
代码看了，bmp结构不是很懂，如果是研究bmp结构我不懂了，如果只是提取像素点可以用别的方法试试，举一个WI ...

然后我又想问，您代码中的65280,16711680又是代表什么。。。

905738810

morpheus126 发表于 2021-12-17 21:25
然后我又想问，您代码中的65280,16711680又是代表什么。。。

用了二进制的位运算

morpheus126

905738810 发表于 2021-12-17 21:39
用了二进制的位运算

我试了下可以用，虽然参数没搞懂
不过还想问问透明色如何识别呢，我读PNG或者ICO读出来是黑底的
感谢感谢

zopey

1. Sub 按钮1_Click()
   
2. Dim fn, f
   
3. Dim arr() As Byte, H, i
   
4. Range("a:a").Clear
   
5. fn = Application.GetOpenFilename("图像文件,*.bmp", , "请选文件", , MultiSelect:=True)
   
6. If Not IsArray(fn) Then Exit Sub
   
7. For Each f In fn
   
8.     Open f For Binary As #1
   
9.     H = LOF(1)
   
10.     ReDim arr(1 To H)
    
11.     Get #1, , arr
    
12.     Close #1
    
13.     For i = 1 To 54
    
14.         Cells(i, 1) = arr(i)
    
15.     Next
    
16. 
    
17.     'Open ThisWorkbook.Path & "\1.jpg" For Binary As #1
    
18.     'Put #1, , arr
    
19.     'Close #1
    
20. 
    
21.     For i = 0 To 3
    
22.         PixelCol = PixelCol + arr(i + 19) * 256 ^ i
    
23.     Next
    
24.     For i = 0 To 3
    
25.         PixelRow = PixelRow + arr(i + 23) * 256 ^ i
    
26.     Next
    
27.     '获取图片的像素高和宽。宽度不是4的倍数时需补零
    
28.     If PixelCol Mod 4 <> 0 Then Zeroize = PixelCol Mod 4
    
29. 
    
30.     Worksheets("sheet1").Activate
    
31.     Cells.Clear
    
32.     With Worksheets("sheet1")
    
33.     For i = PixelRow To 1 Step -1
    
34.         CellRow = CellRow + 1
    
35.         CellCol = 0
    
36.         For j = 1 To PixelCol * 3 Step 3
    
37.             CellCol = CellCol + 1
    
38.             lngPos = arr(11) + j + (i - 1) * (PixelCol * 3 + Zeroize)
    
39.             .Cells(CellRow, CellCol).Interior.Color = RGB(arr(lngPos + 2), arr(lngPos + 1), arr(lngPos))
    
40.         Next
    
41.     Next
    
42.     End With
    
43. Next
    
44. End Sub
    

复制代码