VBA Picture Copy&Paste

Sub pictureCV()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim FileName$, Path$, AK As Workbook
Dim ShtName$ ,pictureID$  'band$, col$
Dim wb As Workbook

Arr1 = ThisWorkbook.Worksheets("Sheet1").Range("D12:D" & 12 + bm)
Arr2 = ThisWorkbook.Worksheets("Sheet1").Range("H13:H" & 13 + cm)
Arr3 = ThisWorkbook.Worksheets("Sheet1").Range("E13:E19")
'Arr1 = Array("*band_1", "*band_2", "*band_3", "*band_4", "*band_6", "*band_7", "*band_9", "*band_10")
'Arr2 = Array("_TW.csv", "_TR.csv", "_TG.csv", "_TB.csv")
s = 3
Path = ThisWorkbook.Path + "\"  

FileName = Dir(Path & "*.xlsx")
c = 2
Do While FileName <> ""
    Set wb = GetObject(Path & FileName)
    ThisWorkbook.Worksheets("Sheet3").Cells(2, c) = FileName
    
    s = 3
    
    For i = 0 To 6
        ShtName = ThisWorkbook.Worksheets("Sheet1").Range("E" & 13 + i)
        With wb.Worksheets(ShtName)
            pictureID= ThisWorkbook.Worksheets("Sheet1").Range("B13" )
            'For Each myshapes In .Shapes
            Set myshapes = .Shapes(pictureID)
            'ThisWorkbook.Worksheets("Sheet3").Cells(s, 2) = myshapes.Name
            ThisWorkbook.Worksheets("Sheet3").Cells(s, c) = ShtName
            '.Shapes(myshapes.Name).Copy
            myshapes.Copy
             myshapes.CopyPicture Appearance:=xlScreen, Format:=xlPicture
             'ThisWorkbook.Worksheets("Sheet3").Cells(s, c).Select
            ThisWorkbook.Worksheets("Sheet3").Paste _
            Destination:=ThisWorkbook.Worksheets("Sheet3").Cells(s, c)
             
            
            s = s + 30
            
            'Next

        End With
        
    Next
    wb.Close False
    FileName = Dir

    c = c + 14
Loop



Application.ScreenUpdating = True
Application.DisplayAlerts = True


End Sub

Sub Export4() ''选区中各图片按粘贴首图位置对应粘贴
    Sheets("图片").Activate
    Dim rng As Range, cel As Range, m&, n&, r&, c&, p As Shape
    Dim ar(), br(), rh#, cw#
    For Each p In ActiveSheet.Shapes ''这一循环是删除原粘贴的图片（不删除时，这循环不用）
        p.Cut
    Next
    For Each cel In Sheets("原图").Range("b2:c3")
        rh = cel.RowHeight
        cw = cel.ColumnWidth
        m = m + 1
        If m = 1 Then: r = cel.Row: c = cel.Column
        ReDim Preserve ar(1 To m)
        ReDim Preserve br(1 To m)
        ar(m) = cel.Row - r
        br(m) = cel.Column - c
        cel.CopyPicture Appearance:=xlScreen, Format:=xlPicture
        If m = 1 Then
            Set rng = Application.InputBox("请选择单元格", "系统提示!", Type:=8)
            rng.Select
        Else
            rng.Offset(ar(m), br(m)).Select
        End If
        Selection.RowHeight = rh
        Selection.ColumnWidth = cw
        ActiveSheet.Paste
    Next
End Sub