Excel VBA复制图片/图表到另一个工作簿

我目前有编写的代码将一个工作簿的字段复制到另一个工作簿。 我现在采取一个范围和'快照'，然后将其另存为一个单独的.bmp文件。

我也想采取这个快照，并将其附加到工作簿的单元格，我正在复制一切。 任何人有任何build议，或看到我可以在这里添加代码？

Sub Macro4() 

“logging和文件”报告

 Dim Model As String Dim IssueDate As String Dim ConcernNo As String Dim IssuedBy As String Dim FollowedSEC As String Dim FollowedBy As String Dim RespSEC As String Dim RespBy As String Dim Timing As String Dim Title As String Dim PartNo As String Dim Block As String Dim Supplier As String Dim Other As String Dim Detail As String Dim CounterTemp As String Dim CounterPerm As String Dim VehicleNo As String Dim OperationNo As String Dim Line As String Dim Remarks As String Dim ConcernMemosMaster As Workbook Dim LogData As String Dim newFile As String Dim fName As String Dim Filepath As String Dim DTAddress As String Dim pic_rng As Range Dim ShTemp As Worksheet Dim ChTemp As Chart Dim PicTemp As Picture 'Determines if any required cells are empty and stops process if there are. displays error message. If IsEmpty(Range("c2")) Or IsEmpty(Range("AT3")) Or IsEmpty(Range("BI2")) Or IsEmpty(Range("M7")) Or IsEmpty(Range("C10")) Or IsEmpty(Range("AP14")) Or IsEmpty(Range("C14")) Or IsEmpty(Range("C23")) Or IsEmpty(Range("C37")) Or IsEmpty(Range("J51")) Or IsEmpty(Range("AA51")) Or IsEmpty(Range("C55")) Or IsEmpty(Range("AR51")) Then MsgBox "Please fill out all required fields and retry.", vbOKOnly Exit Sub End If If Dir("N:\") = "" Then '"N" drive not found, abort sub MsgBox "Error: Drive, path or file not found. Please email copy of file to: " Exit Sub End If 'assigns fields Worksheets("ConcernMemo").Select Model = Range("c2") IssueDate = Range("AT3") ConcernNo = Range("BC3") IssuedBy = Range("BI2") FollowedSEC = Range("BA9") FollowedBy = Range("BD9") RespSEC = Range("BG9") RespBy = Range("BJ9") Timing = Range("M7") Title = Range("C10") PartNo = Range("AP14") Block = Range("AP16") Supplier = Range("AP18") Other = Range("AZ14") Detail = Range("C14") CounterTemp = Range("C23") CounterPerm = Range("C37") VehicleNo = Range("J51") OperationNo = Range("AA51") Remarks = Range("C55") Line = Range("AR51") LogData = Format(Now(), "mm_dd_yyyy_hh_mmAMPM") fName = Range("BC3").Value newFile = fName & "_" & Format(Now(), "mmddyyyy_hhmmAMPM") Filepath = "N:\Newell K\Concern_Memo\Concern_Memo_File_Drop\Concern_Memo_Records\" & fName & "_" & Format(Now(), "mmddyyyy_hhmmAMPM") DTAddress = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator 'asks user is they are ready to send to database If MsgBox("Are you ready to send record to database?", vbYesNo) = vbNo Then Exit Sub Application.ScreenUpdating = False Application.DisplayAlerts = False Set pic_rng = Worksheets("ConcernMemo").Range("AK22:BK49") Set ShTemp = Worksheets.Add 'Takes snapshot of image/sketch and saves to sharedrive Charts.Add ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name Set ChTemp = ActiveChart pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture ChTemp.Paste Set PicTemp = Selection With ChTemp.Parent .Width = PicTemp.Width + 8 .Height = PicTemp.Height + 8 End With ChTemp.Export fileName:="N:\Newell K\Concern_Memo\Concern_Memo_File_Drop\Concern_Memo_Images\" & newFile & ".bmp", FilterName:="bmp" ShTemp.Delete 'opens db file on sharedrive and copies fields over Set ConcernMemosMaster = Workbooks.Open("N:\Newell K\Concern_Memo\concern_memos_DBMASTER.xlsx") Worksheets("sheet1").Select Worksheets("sheet1").Range("a1").Select RowCount = Worksheets("sheet1").Range("a1").CurrentRegion.Rows.Count With Worksheets("sheet1") .Range("a1").Offset(RowCount, 0) = Model .Range("b1").Offset(RowCount, 0) = IssueDate .Range("c1").Offset(RowCount, 0) = ConcernNo .Range("d1").Offset(RowCount, 0) = IssuedBy .Range("e1").Offset(RowCount, 0) = FollowedSEC .Range("f1").Offset(RowCount, 0) = FollowedBy .Range("g1").Offset(RowCount, 0) = RespSEC .Range("h1").Offset(RowCount, 0) = RespBy .Range("i1").Offset(RowCount, 0) = Timing .Range("j1").Offset(RowCount, 0) = Title .Range("k1").Offset(RowCount, 0) = PartNo .Range("l1").Offset(RowCount, 0) = Block .Range("m1").Offset(RowCount, 0) = Supplier .Range("n1").Offset(RowCount, 0) = Other .Range("o1").Offset(RowCount, 0) = Detail .Range("p1").Offset(RowCount, 0) = CounterTemp .Range("q1").Offset(RowCount, 0) = CounterPerm .Range("r1").Offset(RowCount, 0) = VehicleNo .Range("s1").Offset(RowCount, 0) = OperationNo .Range("t1").Offset(RowCount, 0) = Remarks .Range("U1").Offset(RowCount, 0) = PicTemp .Range("V1").Offset(RowCount, 0) = LogData .Range("w1").Offset(RowCount, 0) = Filepath .Range("x1").Offset(RowCount, 0) = Line 'saves a copy to of entire file to sharedrive ThisWorkbook.SaveCopyAs fileName:="N:\Newell K\Concern_Memo\Concern_Memo_File_Drop\Concern_Memo_Records\" & newFile & ".xlsm" 'Saves copy to desktop Application.DisplayAlerts = True ThisWorkbook.SaveCopyAs DTAddress & newFile & ".xlsm" MsgBox "A copy has been saved to your desktop" ThisWorkbook.SendMail Recipients:="[e-mail]", _ Subject:="New Concern Memo" End With ConcernMemosMaster.Save ConcernMemosMaster.Close Application.DisplayAlerts = True MsgBox "Please close out file without saving" End Sub 

Answer 1

试试这个：

 Range("A1:D4").CopyPicture Appearance:=xlScreen, Format:=xlBitmap Range("A6").PasteSpecial 

它将在单元格A6粘贴Range("A1:D4")的“快照”副本。

---

编辑：由于您已经设置了该“目标”工作簿的对象，您可以使用它轻松地粘贴到它。 尝试这个 ：

 ConcernMemosMaster.Worksheets("sheet1").Range("A1:X1").CopyPicture Appearance:=xlScreen, Format:=xlBitmap ConcernMemosMaster.Worksheets("sheet1").Range("B1").PasteSpecial