InputPictureCell

'InputPictureCell・・・元場所：IkiAddin.ModShape
'GetShapeByName  ・・・元場所：IkiAddin.ModShape

'宣言セクション※※※※※※※※※※※※※※※※※※※※※※※※※※※
'-----------------------------------
'元場所:IkiAddin.ModShape.EnumPicturePosition
Public Enum EnumPicturePosition
    vb00中央 = 0
    vb01左上 = 1
    vb02左中央 = 2
    vb03左下 = 3
    vb04下中央 = 4
    vb05右下 = 5
    vb06右中央 = 6
    vb07右上 = 7
    vb08上中央 = 8
End Enum
'宣言セクション終了※※※※※※※※※※※※※※※※※※※※※※※※※※※

Public Function InputPictureCell(ByRef PicturePath As String, _
                                        ByRef Cell As Range, _
                           Optional ByRef Position As EnumPicturePosition = EnumPicturePosition.vb00中央, _
                             Optional ByRef Margin As Double = 0, _
                          Optional ByRef ShapeName As String = "") _
                                                   As Shape
'指定パスの画像ファイルをセル範囲に貼り付ける
'20220301
'20221227 Marginを設定可能に
'20240530 画像のShape名設定ともともと画像がある場合はそれを消去する機能
'紹介予定

'引数
'PicturePath・・・画像ファイルのパス
'Cell       ・・・貼り付けるセル範囲
'[Position] ・・・セル範囲内での9点画像位置
'[Margin]   ・・・余白(パーセンテージ) Margin x セルの幅or高さの余白が追加される
'[ShapeName]・・・表示する画像のシェイプ名
    
    '対象シート設定
    Dim Sheet As Worksheet: Set Sheet = Cell.Worksheet
    
    'すでに表示済みの画像がある場合は消去する
    Dim ExistShape As Shape
    If ShapeName <> "" Then
        Set ExistShape = GetShapeByName(Sheet, ShapeName)
        If Not ExistShape Is Nothing Then
            ExistShape.Delete
        End If
    End If
    
    '画像ファイルを読み込んでシェイプオブジェクトとして格納
    Dim Picture As Picture: Set Picture = Sheet.Pictures.Insert(PicturePath) '画像読込
    Dim Shape   As Shape:   Set Shape = Sheet.Shapes(Picture.Name) 'シェイプオブジェクトとして格納
    
    'セルのサイズ、画像のサイズを取得
    Dim CellHeight As Double: CellHeight = Cell.Height
    Dim CellWidth  As Double: CellWidth = Cell.Width
    Dim PicHeight  As Double: PicHeight = Shape.Height
    Dim PicWidth   As Double: PicWidth = Shape.Width
    
    '縦横比を比較してセル範囲に入るようにサイズ変更
    If CellHeight / CellWidth > PicHeight / PicWidth Then 'セルのほうが縦長
'        Shape.Width = CellWidth '画像の幅をセルの幅に合わせる
        Shape.Width = CellWidth - CellWidth * Margin * 2 '画像の幅をセルの幅に合わせる
    Else
'        Shape.Height = CellHeight
        Shape.Height = CellHeight - CellHeight * Margin * 2
    End If
    
    '9点の位置設定から左右、上下の位置を設定
    Dim PositionLR As String
    Dim PositionUD As String
    Select Case Position
        Case EnumPicturePosition.vb00中央
            PositionLR = "中央"
            PositionUD = "中央"
        Case EnumPicturePosition.vb01左上
            PositionLR = "左"
            PositionUD = "上"
        Case EnumPicturePosition.vb02左中央
            PositionLR = "左"
            PositionUD = "中央"
        Case EnumPicturePosition.vb03左下
            PositionLR = "左"
            PositionUD = "下"
        Case EnumPicturePosition.vb04下中央
            PositionLR = "中央"
            PositionUD = "下"
        Case EnumPicturePosition.vb05右下
            PositionLR = "右"
            PositionUD = "下"
        Case EnumPicturePosition.vb06右中央
            PositionLR = "右"
            PositionUD = "中央"
        Case EnumPicturePosition.vb07右上
            PositionLR = "右"
            PositionUD = "上"
        Case EnumPicturePosition.vb08上中央
            PositionLR = "中央"
            PositionUD = "上"
    End Select
    
    '上下、左右のオフセット量計算
    Dim OffsetLR As Double
    Dim OffsetUD As Double
    Select Case PositionLR
        Case "左"
'            OffsetLR = 0
            OffsetLR = CellWidth * Margin
        Case "中央"
'            OffsetLR = CellWidth / 2 - Shape.Width / 2
            OffsetLR = CellWidth / 2 - Shape.Width / 2
        Case "右"
'            OffsetLR = CellWidth - Shape.Width
            OffsetLR = CellWidth - Shape.Width - CellWidth * Margin
    End Select
    
    Select Case PositionUD
        Case "上"
'            OffsetUD = 0
            OffsetUD = CellHeight * Margin
        Case "中央"
'            OffsetUD = CellHeight / 2 - Shape.Height / 2
            OffsetUD = CellHeight / 2 - Shape.Height / 2
        Case "下"
'            OffsetUD = CellHeight - Shape.Height
            OffsetUD = CellHeight - Shape.Height - CellHeight * Margin
    End Select
    
    '画像の位置設定
    With Shape
        .Top = Cell.Top + OffsetUD
        .Left = Cell.Left + OffsetLR
    End With
    
    '画像のShape名設定
    If ShapeName <> "" Then
        Shape.Name = ShapeName
    End If
    
    '出力
    Set InputPictureCell = Shape
    
End Function

Private Function GetShapeByName(ByRef Sheet As Worksheet, _
                           ByRef ShapeName As String) _
                                           As Shape
'指定シート内の指定名のシェイプを取得する
'指定名のシェイプが無かった場合はNothingを返す
'20221124
    
'引数
'Sheet    ・・・指定シート
'ShapeName・・・指定シェイプの名前
    
    On Error Resume Next
    Dim Output As Shape: Set Output = Sheet.Shapes(ShapeName)
    On Error GoTo 0
    Set GetShapeByName = Output
    
End Function