CAD复制到excel后自动裁剪空白底

Sub 自动裁剪()
Range("A1:O38").Select ''选择单元格
ActiveSheet.Paste ''粘贴内容
'Application.Wait (Now() + TimeValue("00:00:1"))
'Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With ActiveSheet.Shapes
Dim objCount As Integer
objCount = .Count
If objCount > 0 Then
Dim i As Integer
Dim objArr() As Variant
ReDim objArr(1 To objCount)
For i = 1 To objCount
objArr(i) = .Item(i).Name
Next i
.Range(objArr).Select
With Selection.ShapeRange.PictureFormat
.CropLeft = 185 '向左裁剪
.CropTop = 0
.CropRight = 185 '向右裁剪
.CropBottom = 0
'.ColorType = msoPictureAutomatic
'.Brightness = 0.5
'.Contrast = 0.5
End With
Selection.ShapeRange.IncrementLeft -186 '图片向左移动距离，跟向左裁剪保持一致
Selection.ShapeRange.ScaleWidth 1.53, msoFalse, msoScaleFromTopLeft '水平缩放为原大小的1.54倍
Selection.ShapeRange.ScaleHeight 1.43, msoFalse, msoScaleFromTopLeft '垂直缩放为原大小的1.43倍，一般不改
End If
End With
End Sub