Excel VBA Copying Pic/Chart to another workbook

Question

I currently have code written to take the fields of one workbook and copy into another workbook. I currently take a range and 'snapshot' it then save that as a separate .bmp file.

I also would like to take this snapshot and attach it into a cell of the workbook I'm copying everything over into. Anybody have any advice, or see here i can add code for this?

Sub Macro4()

' ' Record and File report

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

Try this out :

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

It will paste a copy of the "snapshot" of Range("A1:D4") at the cell A6.

---

EDIT : Since you have already set an object of that "target" workbook, you can use it to easily paste into it. Try this :

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