Excel图片放大工具

Private Sub Workbook_Open()    Dim ws As Worksheet    Dim cName$    Dim a As Shape    On Error Resume Next    '遍历全部工作表    For Each ws In ThisWorkbook.Worksheets        For Each a In ws.Shapes            If a.Type = 1 Or a.Type = 13 Then                a.OnAction = "test"                cName = a.TopLeftCell.Address(0, 0)                Do                    Err.Clear                    a.Name = cName                    If Err = 0 Then Exit Do                    cName = cName & "_0"                Loop            End If        Next a    Next wsEnd Sub

Sub test()    On Error Resume Next    Dim a As Shape    For Each a In ActiveSheet.Shapes        If a.Type = 1 Or a.Type = 13 Then            If a.Name = Application.Caller And a.AlternativeText = Empty Then                '保存原图宽高                a.AlternativeText = a.Height & Chr(28) & a.Width                '锁定纵横比，等比例放大                a.LockAspectRatio = msoTrue                a.ScaleHeight 5, msoFalse                a.ZOrder msoBringToFront            Else                '恢复原始尺寸                Dim arr                arr = Split(a.AlternativeText, Chr(28))                a.LockAspectRatio = msoTrue                a.Height = arr(0)                a.Width = arr(1)                a.AlternativeText = Empty            End If            Err.Clear        End If    Next aEnd SubSub RefreshAllPicBind()    Dim ws As Worksheet    Dim cName$    Dim a As Shape    On Error Resume Next    For Each ws In ThisWorkbook.Worksheets        For Each a In ws.Shapes            If a.Type = 1 Or a.Type = 13 Then                a.OnAction = "test"                cName = a.TopLeftCell.Address(0, 0)                Do                    Err.Clear                    a.Name = cName                    If Err = 0 Then Exit Do                    cName = cName & "_0"                Loop            End If        Next a    Next ws    MsgBox "全局图片绑定刷新完成！所有工作表图片已生效"End Sub

a.ScaleHeight 5, msoFalse