bytes 数据转换成 bitmap 数据及数组如何赋值到剪切板

aman1516 · 发表于 2021-10-13 18:38

缘起：另类写入单元格区域的方法https://club.excelhome.net/thread-698873-1-1.html

Public Sub XieRu(a, R As Range)
'a：待写入数组；R：写入起始位置
Dim d As Object
Set d = New DataObject
d.SetText Join(a, vbLf)
d.PutInClipboard
R.Select
ActiveSheet.Paste
Set d = Nothing
End Sub

复制代码

很奇特的方法，那么请教老师，能否实现如下功能：

Sub Byt2Clip()
Const file As String = ThisWorkbook.path & "\3.bmp"
Dim arr() As Byte
Dim width, height
Open file For Binary As #1
ReDim arr(LOF(1) - 1)
Get #1, , arr
Close #1
'此处：如何将 arr j里的二进制数据转换成 bitmap 格式数据
'然后将转换后的 bitmap 格式数据赋给剪切板？
Dim d As Object
Set d = New DataObject
d.SetText Join(arr, vbLf)
d.PutInClipboard
'.......
'此时剪切板里的内容应是一幅可直接粘贴的 "图片"
End Sub

复制代码

aman1516 · 发表于 2021-10-14 18:07

找到一个函数：

Function ApiGetClipBmp() As IPicture
On Error Resume Next
Dim Pic As PicBmp, IID_IDispatch As Guid
OpenClipboard 0 'OpenClipboard
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With Pic
.Size = Len(Pic)
.Type = 1
.hBmp = GetClipboardData(CF_BITMAP)
End With
OleCreatePictureIndirect Pic, IID_IDispatch, 1, ApiGetClipBmp
'stdole.SavePicture ApiGetClipBmp, ThisWorkbook.Path & "\Scr.bmp"
CloseClipboard
End Function

复制代码

但不知怎样整合起来

aman1516 · 发表于 2021-10-16 16:41

再顶起，好多其他语文都有代码，就是不知用VBA怎么写
private Bitmap[] m_pBitmaps = new Bitmap[15];
      private int m_nCurrBitmapIdx = -1;
      public Bitmap ToColorBitmap2(byte[] rawValues, int width, int height)
      {
         // 申请目标位图的变量，并将其内存区域锁定
         //初始化Bitmap数组
         if (m_bFrmSizeChange || m_nCurrBitmapIdx < 0)
         {
            for (int i = 0; i < 15; i++)
            {
                  m_pBitmaps[i] = new Bitmap(width, height, PixelFormat.Format24bppRgb);
            }
            m_nCurrBitmapIdx = 0;
            m_bFrmSizeChange = false;
         }
         Bitmap bmp = m_pBitmaps[m_nCurrBitmapIdx];
         m_nCurrBitmapIdx++;
         if (m_nCurrBitmapIdx >= 15)
            m_nCurrBitmapIdx = 0;

         try
         {
            //Bitmap bmp = new Bitmap(width, height, PixelFormat.Format24bppRgb);
            BitmapData bmpData = bmp.LockBits(new Rectangle(0, 0, width, height), ImageLockMode.WriteOnly, PixelFormat.Format24bppRgb); //// 获取图像参数
            //int stride = bmpData.Stride;  // 扫描线的宽度
            IntPtr iptr = bmpData.Scan0;  // 获取bmpData的内存起始位置
            //int scanBytes = stride * height;// 用stride宽度，表示这是内存区域的大小                //// 用Marshal的Copy方法，将刚才得到的内存字节数组复制到BitmapData中
            System.Runtime.InteropServices.Marshal.Copy(rawValues, 0, iptr, width * height * 3);
            bmp.UnlockBits(bmpData);  // 解锁内存区域
            //// 算法到此结束，返回结果
            return bmp;
         }
         catch (System.Exception e)
         {
            //Tools.m_CreateLogTxt("ToColorBitmap2", e.ToString(), Index);
            return null;
         }
      }

aman1516 · 发表于 2021-10-16 16:47

网上看到的解决思路：
------解决方案--------------------
图片也是用数组表示的，每3*sizeof(unsigned char)个字节存储一个像素点的RGB颜色。
------解决方案--------------------
用 CreateBitmap 函数
------解决方案--------------------
CreateDIBitmap()
------解决方案--------------------
填充BITMAPINFO，调用CreateDIBSection创建HBITMAP，最后调用StretchDIBits显示
------解决方案--------------------
CreateDIBitmap()
------解决方案--------------------
cximage

哪个高手能做个VBA示例

wodewan · 发表于 2021-10-17 22:02

Option Explicit
Const LR_LOADFROMFILE = &H10
Const LR_DEFAULTSIZE = &H40
Const LR_DEFAULTCOLOR = &H0
Const IMAGE_BITMAP = 0
Const CF_BITMAP = 2
#If Win64 And VBA7 Then
Private Declare PtrSafe Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As LongPtr, ByVal lpsz As String, ByVal dwImageType As LongPtr, ByVal dwDesiredWidth As LongPtr, ByVal dwDesiredHeight As LongPtr, ByVal dwFlags As LongPtr) As LongPtr
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As LongPtr
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As LongPtr
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As LongPtr, ByVal hMem As LongPtr) As LongPtr
#Else
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal dwImageType As Long, ByVal dwDesiredWidth As Long, ByVal dwDesiredHeight As Long, ByVal dwFlags As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
#End If

Sub LoadBmpToClipBoard()
Dim FilePath As String
FilePath = ThisWorkbook.Path & "\3.bmp"
OpenClipboard (0)
EmptyClipboard
SetClipboardData CF_BITMAP, LoadImage(0, FilePath, IMAGE_BITMAP, 0, 0, LR_DEFAULTSIZE Or LR_DEFAULTCOLOR Or LR_LOADFROMFILE)
CloseClipboard
End Sub

aman1516 · 发表于 2021-10-17 23:54

wodewan 发表于 2021-10-17 22:02
Option Explicit
Const LR_LOADFROMFILE = &H10
Const LR_DEFAULTSIZE = &H40

太利害了！一直弄不清楚过程各数据类型之间的变化与剪切板格式的关系，
另外想问下，类似于一楼的代码，但如果我的 “图片” 数据源不是本地图片文件，
而是一个内存的 arr() As Byte 数组，
例如从数据库的长二进制数据获取、或其他程式中生成的一个图片 Byte 数组，或接收到的图片二进制数据流等，那么，怎样改才能实现：
arr（）——>（转换处理）——> 剪切板中可直接粘贴的 "图片"
请老师帮忙再修订完善，十分感谢！

wodewan · 发表于 2021-10-18 15:10

aman1516 发表于 2021-10-17 23:54
太利害了！一直弄不清楚过程各数据类型之间的变化与剪切板格式的关系，
另外想问下，类似于一楼的代码， ...

简单点，一楼的过程反过来不就可以了？如果你想用GlobalAlloc，Copymemory这些API函数来操作内存, 那个不敢搞。。。

aman1516 · 发表于 2021-10-18 17:17

wodewan 发表于 2021-10-18 15:10
简单点，一楼的过程反过来不就可以了？如果你想用GlobalAlloc，Copymemory这些API函数来操作内存, 那个 ...

这个先输出再导入本来就是个简单的辅助过程，也算是较快捷的方法，包括行入工作表后复制再删除等等，
但我就是不想“中间商赚差价”，另外就是想要确认直接内存中生成是可行的，
例如：论坛中就有 "纯代码生在二维码“ 的示例就是直接生成二维码图片后粘贴到剪切板（再粘贴到工作表）的......
正在研究中，看能否整合成一个通用的过程。

GlobalAlloc CopyMemory 方法么，也有一个很好的例子：
图片控件里怎样调用网络图片（3 楼）
https://club.excelhome.net/thread-1257381-1-1.html
小fisher 大师的代码：

Option Explicit
'内存函数
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
'OLE函数
Public Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pclsid As Any) As Long
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As Any, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
'GDIplus函数
Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, ByVal outputbuf As Long) As Long
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
Private Declare Function GdipLoadImageFromStream Lib "GDIPlus" (ByVal stream As IUnknown, Image As Long) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal bitmap As Long, hbmReturn As Long, ByVal background As Long) As Long
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Const GMEM_MOVEABLE = &H2
Public Function LoadWebImage(url As String) As StdPicture
Dim hMem As Long
Dim nSize As Long
Dim lpData As Long
Dim bufferBytes() As Byte
Dim istm As stdole.IUnknown
Dim lToken As Long
Dim lGSI As GdiplusStartupInput
Dim IID_IDispatch(15) As Byte
Dim pic As PicBmp
Dim lImage As Long, hBmp As Long
Dim httpRequest
Set httpRequest = CreateObject("WinHttp.WinHttpRequest.5.1") '创建WinHttpRequest对象
With httpRequest
.Open "get", url, False '获取URL内容
.Send
If Left(.GetResponseHeader("Content-Type"), 6) = "image/" Then '如果URL为图片
'############nSize = .GetResponseHeader("Content-Length") '获取网络图片的字节长度
'##########ReDim bufferBytes(nSize - 1)
bufferBytes = .ResponseBody '将图片文件存储到字节数组中
nSize = UBound(bufferBytes) + 1 '获取网络图片的字节长度###########
hMem = GlobalAlloc(GMEM_MOVEABLE, nSize) '分配一块全局内存
lpData = GlobalLock(hMem) '获取内存句柄
CopyMemory lpData, VarPtr(bufferBytes(0)), nSize '将图片文件的字节复制到全局内存中
lGSI.GdiplusVersion = 1
If GdiplusStartup(lToken, lGSI, 0) = 0 Then '初始化GDI+
If CreateStreamOnHGlobal(hMem, 1, istm) = 0 Then '从全局内存创建流
GdipLoadImageFromStream istm, lImage '将流中内容加载为GDI+ Image图形对象
GdipCreateHBITMAPFromBitmap lImage, hBmp, &HFFFFFF '从Image获取Bitmap句柄
GdipDisposeImage lImage '释放Image对象
'以下代码从Bitmap句柄生成一个StdPicture对象
CLSIDFromString StrPtr("{00020400-0000-0000-C000-000000000046}"), IID_IDispatch(0)
With pic
.Size = Len(pic)
.Type = 1
.hBmp = hBmp
.hPal = 0
End With
OleCreatePictureIndirect pic, IID_IDispatch(0), 1, LoadWebImage
End If
GdiplusShutdown lToken '关闭GDI+
End If
GlobalUnlock hMem
GlobalFree hMem '释放全局内存
End If
End With
End Function

复制代码

无奈水平有限，未做出个成功的通用模板。

joforn · 发表于 2021-10-18 20:33

第一步：取得图片文件的Byte数组，如果是文件是以二进制存在数据库中，那么直接取得Byte数组，如果是文件，那么打开文件取得数组，如果是URL，那么XMLHTTP.responseBody返回的就是Byte数组。
第二步：使用GlobalAlloc创建一个内存块，把Byte数组内容复制到内存块中；
第三步：使用CreateStreamOnHGlobal将第二步中生成的内存块创建一个Stream；
第四步：使用GdipLoadImageFromStream函数从Stream流中获取一个新的Bitmap;
第五步：将Bitmap转换成HBitmap；
第六步：将HBitmap写入剪切板或是转换成StdPicture(VBA中的Picture对象)；

aman1516 · 发表于 2021-10-19 09:45

joforn 发表于 2021-10-18 20:33
第一步：取得图片文件的Byte数组，如果是文件是以二进制存在数据库中，那么直接取得Byte数组，如果是文件， ...

谢谢热心指导，那么就一步一步去学习编写代码了
搜尽主题三百篇，不会写来也会抄

		自动登录	找回密码
密码			免费注册

[求助] bytes 数据转换成 bitmap 数据及数组如何赋值到剪切板

评分

评分

评分

[求助] bytes 数据转换成 bitmap 数据 及数组如何赋值到剪切板

评分

评分

评分

[求助] bytes 数据转换成 bitmap 数据及数组如何赋值到剪切板