Excel VBA將圖片/圖表複製到另一個工作簿

Question

我目前編寫的代碼是將一個工作簿的字段複製到另一個工作簿中。我現在採取一個範圍和'快照'，然後將其另存爲一個單獨的.bmp文件。

我也想把這個快照附加到工作簿的一個單元格中，我正在將所有東西都拷貝進去。任何人有任何建議，或看到我可以在這裏添加代碼？

Sub Macro4() 

' ' 記錄和文件報告

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:="kaitlin.newell@nissan-usa.com", _ 
          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