|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
我以前也是研究过这个问题，觉得很有用就保存了下来。方法其实很简单，就时仿写excel本身把单元格复制为位图的功能。先把使用的单元格复制到内存剪贴板中，然后用OleCreatePictureIndirect函数创建图片并保存。
当然如果把range换成Shape也可以把单元格的图形换成位图，实现单元格图片导出的功能。
代码如下：
Option Explicit
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
Private Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1
Public Sub RangeToBMP(Range As Range, FilePath As String)
Dim IID_IDispatch As GUID, shp As Shape
Dim uPicinfo As uPicDesc, IPic As IPicture
Dim hPtr As Long
Range.Copy
OpenClipboard 0
hPtr = GetClipboardData(CF_BITMAP)
CloseClipboard
With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
With uPicinfo
.Size = Len(uPicinfo)
.Type = PICTYPE_BITMAP
.hPic = hPtr
.hPal = 0
End With
OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic
SavePicture IPic, FilePath
End Sub
调用：
RangeToBMP thisworkbook.worksheets(1).usedrange ,thisworkbook.path & "\rtb.bmp" |
评分
-
1
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-1-22 21:11
楼主
发表于 2024-1-23 12:05
