Excel VBA 根据选定单元格区域生成图片文件

Question

Excel VBA 根据选定单元格区域生成图片文件 弄到图表再导出文件的方法就不要再说了,要用API函数,最好是用复制获取剪切板数据或其它方法解决,代码请附注释,如果有现成例子请发到[email protected],方法越多越好 VB源代码也行(API读写系统剪切板)

Answer 1

Option Explicit Private Sub UserForm_Initialize() Dim Charts As Chart Dim cName As String Set Charts = Sheets("Sheet2").ChartObjects(1).Chart cName = ThisWorkbook.Path & "\Temp.gif" Charts.Export Filename:=cName, FilterName:="GIF" Image1.Picture = LoadPicture(cName) End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Kill ThisWorkbook.Path & "\Temp.gif" End Sub 你要的API方法！ Option Explicit Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long Private Declare Function OleLoadPicture Lib "olepro32" (pStream As Any, ByVal lSize As Long, ByVal fRunmode As Long, riid As Any, ppvObj As Any) As Long Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pclsid As Any) 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 Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function CloseClipboard Lib "user32" () As Long Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long Private Declare Function EmptyClipboard Lib "user32" () As Long Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long Private Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long Public Function LoadShapePicture(shp As Object) As IPictureDisp Dim nClipsize As Long Dim hMem As Long Dim lpData As Long Dim sdata() As Byte Dim fmt As Long Dim fmtName As String Dim iClipBoardFormatNumber As Long Dim IID_IPicture(15) Dim istm As stdole.IUnknown If TypeName(shp) = "ChartObject" Then shp.CopyPicture xlPrinter Sheet1.Paste Selection.Cut Else shp.Copy End If OpenClipboard 0& If iClipBoardFormatNumber = 0 Then fmt = EnumClipboardFormats(0) Do While fmt <> 0 fmtName = Space(255) GetClipboardFormatName fmt, fmtName, 255 fmtName = Trim(fmtName) If fmtName <> "" Then fmtName = Left(fmtName, Len(fmtName) - 1) If fmtName = "GIF" Then iClipBoardFormatNumber = fmt Exit Do End If End If fmt = EnumClipboardFormats(fmt) Loop End If hMem = GetClipboardData(iClipBoardFormatNumber) If CBool(hMem) Then nClipsize = GlobalSize(hMem) lpData = GlobalLock(hMem) GlobalUnlock hMem If CreateStreamOnHGlobal(hMem, 1, istm) = 0 Then If CLSIDFromString(StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), IID_IPicture(0)) = 0 Then Call OleLoadPicture(ByVal ObjPtr(istm), nClipsize, 0, IID_IPicture(0), LoadShapePicture) End If End If End If EmptyClipboard CloseClipboard End Function Private Sub UserForm_Initialize() Image1.Picture = LoadShapePicture(Sheet2.ChartObjects(1)) End Sub

采纳哦本回答被提问者采纳

Answer 2

Sub 导入图片且等于选区大小()
Dim filefilter1, filennames As String
filefilter1 = ("所有图片文件 (*.jpg;*.bmp;*.png;*.gif),*.jpg;*.bmp;*.png;*.gif")
filennames = Application.GetOpenFilename(filefilter1, , "请选一个图片文件", , MultiSelect:=False)
With ActiveSheet.Pictures.Insert(filennames)
.Top = ActiveCell.Top
.ShapeRange.LockAspectRatio = msoFalse
.Width = Selection.Width
.Left = ActiveCell.Left
.Height = Selection.Height
End With
End Sub