一个Excel范围截图的vb脚本问题记录

以下是源代码：

Sub SaveRngToJpg(imagePath As String, sheetName As String, rangeInfo As String)
                            Dim rng As Range
                            Dim ad$, m&, mc$, shp As Shape
                            Dim n&, myFolder$
                            Sheet1.Activate
                            n = 0
                            ThisWorkbook.Sheets(sheetName).Select
                            Set rng = ThisWorkbook.Sheets(sheetName).Range(rangeInfo)
    
                            rng.Select
                            Selection.Copy
                            ActiveSheet.Pictures.Paste
                            For Each shp In ActiveSheet.Shapes
                                If shp.Type = 13 Then
                                    'If Len(Dir(myFolder, vbDirectory)) = 0 Then
                                        'MkDir myFolder
                                    'End If
                                    n = n + 1
                                    ad = shp.TopLeftCell.Address
                                    m = shp.TopLeftCell.Row
                                    shp.CopyPicture
                                    With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart
                                        .Parent.Select
                                        .Paste
                                        .Export imagePath
                                        .Parent.Delete
                                    End With
                                    shp.Delete
                                End If
                            Next
                        End Sub

以上代码中存在一个问题，在执行Selection.Copy到 ActiveSheet.Pictures.Paste 时，可能会存在Excel指定的范围还没复制到剪切板的情况，导致剪切板无对应的图片数据，故可能会存在无法粘贴或者粘贴的是原来剪切板的图片数据，导致异常，所以需要在这里加个延时，等待复制到剪切板再执行ActiveSheet.Pictures.Paste。

以下是优化的代码：

Sub SaveRngToJpg(imagePath As String, sheetName As String, rangeInfo As String)
                            Dim rng As Range
                            Dim ad$, m&, mc$, shp As Shape
                            Dim n&, myFolder$
                            Sheet1.Activate
                            n = 0
                            ThisWorkbook.Sheets(sheetName).Select
                            Set rng = ThisWorkbook.Sheets(sheetName).Range(rangeInfo)
    
                            rng.Select
                            Selection.Copy
                            Application.Wait Now + TimeValue("00:00:01") '等待1秒
                            ActiveSheet.Pictures.Paste
                            For Each shp In ActiveSheet.Shapes
                                If shp.Type = 13 Then
                                    'If Len(Dir(myFolder, vbDirectory)) = 0 Then
                                        'MkDir myFolder
                                    'End If
                                    n = n + 1
                                    ad = shp.TopLeftCell.Address
                                    m = shp.TopLeftCell.Row
                                    shp.CopyPicture
                                    With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart
                                        .Parent.Select
                                        .Paste
                                        .Export imagePath
                                        .Parent.Delete
                                    End With
                                    shp.Delete
                                End If
                            Next
                        End Sub

再试下就好了，具体加的延时，可以根据Excel需要截图范围大小和Excel处理性能决定，可以进行调整。