Sub 図形1_1()
Dim zusuu As Integer
Dim zu As Object
    ThisWorkbook.Sheets("図形").Select
        For Each zu In ActiveSheet.Shapes
            zu.Delete
            zusuu = zusuu + 1
        Next
DoEvents
MsgBox "図形を「" & zusuu & "」個削除しました。"
End Sub

Sub 図形1_2()
Dim zusuu As Integer
    ThisWorkbook.Sheets("図形").Select
    zusuu = ActiveSheet.Shapes.Count
        ActiveSheet.Shapes.SelectAll
        Selection.Delete
DoEvents
MsgBox "図形を「" & zusuu & "」個削除しました。"
End Sub

Sub 図形1_3()
Dim zusuu As Integer
Dim zu As Object
    ThisWorkbook.Sheets("図形").Select
    zusuu = ActiveSheet.Pictures.Count
        For Each zu In ActiveSheet.Pictures
            zu.Delete
        Next
MsgBox "図形を「" & zusuu & "」個削除しました。"
End Sub

Sub 図形1_4()
Dim zu As Object
ThisWorkbook.Sheets("図形").Select
    For Each zu In ActiveSheet.Shapes
       shname = zu.Name
       If InStr(1, shname, "Button", 1) = 0 Then
          zu.Delete
       End If
    Next
End Sub

Sub 画面形1_5()
Dim obg(2, 50) As String, msg As String
ThisWorkbook.Sheets("図形").Select
i = 0
For Each ex In ActiveSheet.Shapes
    obg(0, i) = ex.Name
    obg(1, i) = ex.TopLeftCell.Row
    obg(2, i) = ex.TopLeftCell.Column
        msg = "オブジェクト名 " & obg(0, i) & _
            ": Cells(" & obg(1, i) & "," & obg(2, i) & ")"
    celad = MsgBox(msg, 1, "セル位置")
        If celad = 2 Then
             Exit Sub
        End If
    i = i + 1
Next
End Sub

Sub ハイパーリンク削除()
    Dim myobj As Hyperlink
    For Each myobj In ActiveSheet.Hyperlinks
        With myobj
            myobj.Delete
        End With
    Next
End Sub

Sub 図形2()
    For Each sheet_name In Worksheets
        If sheet_name.Name = "コピー例" Then
            Sheets("コピー例").Select
            Application.DisplayAlerts = False
                ActiveWindow.SelectedSheets.Delete
            Application.DisplayAlerts = True
            Exit For
         End If
    Next
    Sheets.Add.Name = "コピー例"
 コピ−
    Application.CopyObjectsWithCells = False
        ThisWorkbook.Sheets("図形").Select
        Range(Cells(1, 1), Cells(20, 20)).Copy
 貼り付け
    ThisWorkbook.Sheets("コピー例").Select
    Cells(1, 1).Select
        ActiveSheet.Paste
    Application.CopyObjectsWithCells = True
    Cells(1, 1).Select
End Sub

Sub 図形3_1()
Dim i As Integer, obg(20) As String, phn As String
phn = ActiveWorkbook.Path
 
i = 1
For Each ex In ActiveSheet.ChartObjects
    obg(i) = ex.Name
   gifname = "Chart" & i & ".gif"
   ActiveSheet.ChartObjects(i).Chart.Export phn & "\" & gifname
    i = i + 1
Next
MsgBox "グラフを「" & i - 1 & "」個gifファイルで保存しました。"
End Sub

Sub フォルダ指定()
phn = ThisWorkbook.Path
dai = ThisWorkbook.Name
    msg = "保存場所は" & dai & "と同じファルダで宜しいですか？"
    yn = MsgBox(msg, 4, "保存場所確認")
    If yn = 7 Then
フォルダ指定
        Set myPath = CreateObject("Shell.Application") _
            .BrowseForFolder(0, "フォルダを選択してください", &H1)
        If myPath Is Nothing Then
            Exit Sub
        End If
            phn = myPath.Self.Path
        Set myPath = Nothing
    End If
End Sub

Sub 図形3_2()
Dim msg As String, hei As Single, wid As Single
Dim scel As Range, grf As Chart, pnam2 As String
 
    msg = "JPGで保存するセル範囲を指定して下さい。" & Chr(10) _
    & "(セル範囲をシ−トから指定して下さい)"
On Error Resume Next
    Set scel = Application.InputBox(msg, "セル指定", Type:=8)
    If TypeName(scel) = "Nothing" Then
        MsgBox "セル範囲をシ−トから指定して下さい"
        Exit Sub
    End If
On Error GoTo 0
 
  scel.Select
  Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
  ActiveSheet.Paste
  ActiveSheet.Pictures.Select
  pnam2 = Selection.Name
 
  ActiveSheet.Shapes(pnam2).Select
    hei = Selection.ShapeRange.Height
    wid = Selection.ShapeRange.Width
 
  Set grf = ActiveSheet.ChartObjects.Add(0, 0, wid + 8, hei + 8).Chart
        For Each zu In ActiveSheet.ChartObjects
             cname = zu.Name
        Next
        ActiveSheet.ChartObjects(cname).Activate
        ActiveChart.Paste
gif保存
   grf.Export ActiveWorkbook.Path & "\" & "Myjpg.jpg"
 
   grf.Parent.Delete
   ActiveSheet.Shapes(cname).Delete
Range("A1").Select
   MsgBox ActiveWorkbook.Path & "へ「Myjpg.jpg」名で保存しました"
End Sub