Excel VBA Копирование Pic/Chart в другую книгу

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 

Это будет вставить копию "снимок" Range("A1:D4") в ячейке A6.

---

EDIT: Поскольку вы уже установили объект этого «целевой» книги, вы можете использовать его, чтобы легко вставить в него. Попробуйте следующее:

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