図形

張替え

余白なし

枠線

塗りつぶし

張替え

Sub 図形_張替え()
    '図形を張り替える
    Dim x As Single    Dim y As Single    Dim w As Single    Dim z As Single        Dim w_cell As Range        Set w_cell = ActiveCell
    x = Selection.Top    y = Selection.Left    w = Selection.Width
    Selection.Delete    Cells(1, 1).Select    ActiveSheet.Paste    Selection.Top = x    Selection.Left = y    Selection.Width = w    Selection.ShapeRange.ZOrder msoSendToBack        w_cell.Activate
End Sub

余白なし

Sub 図形_余白なし()
    If Selection.ShapeRange.TextFrame2.MarginLeft = 0 Then
        Selection.ShapeRange.TextFrame2.MarginLeft = Application.CentimetersToPoints(0.25)        Selection.ShapeRange.TextFrame2.MarginRight = 0        Selection.ShapeRange.TextFrame2.MarginTop = 0        Selection.ShapeRange.TextFrame2.MarginBottom = 0
    Else
        Selection.ShapeRange.TextFrame2.MarginLeft = 0        Selection.ShapeRange.TextFrame2.MarginRight = 0        Selection.ShapeRange.TextFrame2.MarginTop = 0        Selection.ShapeRange.TextFrame2.MarginBottom = 0
    End If
End Sub

枠線

Sub 図形_枠線()
'図形の枠線の表示、非表示 v1 If Selection.ShapeRange.Line.Visible = msoFalse Then Selection.ShapeRange.Line.Visible = msoTrue With Selection.ShapeRange.Line .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorText1 '黒 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = 0 .Weight = 0.25 End With With Selection.ShapeRange.Fill .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorBackground1 '白 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = 0 .Transparency = 0 .Solid End With On Error Resume Next With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill .Visible = msoTrue .ForeColor.RGB = RGB(0, 0, 0) .Transparency = 0 .Solid End With On Error GoTo 0 ElseIf Selection.ShapeRange.Line.ForeColor.RGB <> RGB(255, 0, 0) Then '赤 Selection.ShapeRange.Fill.Visible = msoFalse With Selection.ShapeRange.Line .Visible = msoTrue .ForeColor.RGB = RGB(255, 0, 0) '赤 .Transparency = 0 .Weight = 2.25 End With Else Selection.ShapeRange.Line.Visible = msoFalse End If End Sub

塗りつぶし

Sub 図形_塗りつぶし()
    '図形の塗りつぶしを自動設定        On Error Resume Next        With Selection.ShapeRange.Line        .Visible = msoTrue        .ForeColor.ObjectThemeColor = msoThemeColorText1        .ForeColor.TintAndShade = 0        .ForeColor.Brightness = 0        .Weight = 0.25    End With
    If Selection.ShapeRange.Fill.Visible <> msoTrue Then
        If Selection.ShapeRange.Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1 Then                        With Selection.ShapeRange.Fill                .Visible = msoTrue                .ForeColor.RGB = RGB(255, 255, 0) '黄                .Transparency = 0                .Solid            End With                    With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill                .Visible = msoTrue                .ForeColor.RGB = RGB(0, 0, 0) '黒                .Transparency = 0                .Solid            End With                ElseIf Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 0) Then                    With Selection.ShapeRange.Fill                .Visible = msoTrue                .ForeColor.RGB = RGB(255, 0, 0) '赤                .Transparency = 0                .Solid            End With                        With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill                .Visible = msoTrue                .ForeColor.ObjectThemeColor = msoThemeColorBackground1 '白                .ForeColor.TintAndShade = 0                .ForeColor.Brightness = 0                .Transparency = 0                .Solid            End With                    ElseIf Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0) Then                    With Selection.ShapeRange.Fill                .Visible = msoTrue                .ForeColor.RGB = RGB(0, 176, 240) '青                .Transparency = 0                .Solid            End With                        With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill                .Visible = msoTrue                .ForeColor.RGB = RGB(0, 0, 0) '黒                .Transparency = 0                .Solid            End With                    ElseIf Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 176, 240) Then                    Selection.ShapeRange.Fill.Visible = msoFalse '透明                        With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill                .Visible = msoTrue                .ForeColor.RGB = RGB(0, 0, 0) '黒                .Transparency = 0                .Solid            End With                End If            Else                With Selection.ShapeRange.Fill            .Visible = msoTrue            .ForeColor.ObjectThemeColor = msoThemeColorBackground1 '白            .ForeColor.TintAndShade = 0            .ForeColor.Brightness = 0            .Transparency = 0            .Solid        End With                With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill            .Visible = msoTrue            .ForeColor.RGB = RGB(0, 0, 0) '黒            .Transparency = 0            .Solid        End With        End If        Selection.ShapeRange.SetShapesDefaultProperties
    On Error GoTo 0
End Sub

赤矢印

Sub 図形_赤矢印()
'矢印を赤太線にする With Selection.ShapeRange.Line .Visible = msoTrue .ForeColor.RGB = RGB(255, 0, 0) .Transparency = 0 .Weight = 6 End With
Selection.ShapeRange.SetShapesDefaultProperties
End Sub

コメントのサイズ自動調整

Sub 図形_コメントのサイズ自動調整()
'選択したセルのコメントのサイズを自動調整する。
ActiveCell.Comment.Shape.TextFrame.AutoSize = True
End Sub

サイズ自動調整

Sub 図形_サイズ自動調整()
'選択した図形のサイズを自動調整する。
Selection.ShapeRange.TextFrame.AutoSize = True
End Sub

サイズ縮小

Sub 図形_サイズ縮小() '図形のサイズを75%、50%、25%にする。 Dim w_width As Single Dim w_width75 As Single Dim w_width50 As Single Dim w_width25 As Single On Error Resume Next With Selection.ShapeRange If Err.Number <> 0 Then MsgBox "図形が選択されていません。" On Error GoTo 0 Exit Sub End If w_width = .Width .LockAspectRatio = True .ScaleWidth 0.75, msoTrue, msoScaleFromTopLeft w_width75 = .Width .ScaleWidth 0.5, msoTrue, msoScaleFromTopLeft w_width50 = .Width .ScaleWidth 0.25, msoTrue, msoScaleFromTopLeft w_width25 = .Width If w_width <= w_width25 Then .ScaleWidth 1, msoTrue, msoScaleFromTopLeft ElseIf w_width <= w_width50 Then .ScaleWidth 0.25, msoTrue, msoScaleFromTopLeft ElseIf w_width <= w_width75 Then .ScaleWidth 0.5, msoTrue, msoScaleFromTopLeft Else .ScaleWidth 0.75, msoTrue, msoScaleFromTopLeft End If End With On Error GoTo 0 End Sub