Sub SP_8500GazPast(obj作成シート As Object, strGazouFullPath As String, strA1 As String, strName As String, sngWidth As Single)

'*************************************************************************************************

'@  エクセルシートに画像を貼り付ける

'* [INPUT]  obj作成シート as Object        '==対象のexcelシート

'*          strGazouFullPath AS STRING     '==画像ファイルのフルパス 例) d:\test\data.jpeg

'*          strA1 AS STRING                '==画像を貼り付けるセル  例) "H10"

'*          strName as STRING              '==貼り付けた画像につける名前  ""なら名前は付けない

'*          sngWidth as SINGLE             '==横幅    縦は自動計算し行高さを調整している  ここが０ならstrA1の巾に

'*************************************************************************************************

Dim objShape As Object

Dim sngTop As Single

Dim sngLEFT As Single

Dim sngHT As Single

Dim sngWD As Single

Dim sngSetWidth As Single

Dim sngHEIGHT As Single

Dim sngWIDT As Single

Dim sngW1 As Single

'

'***挿入

    obj作成シート.Activate

    sngTop = obj作成シート.Range(strA1).Top

    sngLEFT = obj作成シート.Range(strA1).Left

    Set objShape = obj作成シート.Shapes.AddPicture(FileName:=strGazouFullPath, LinkToFile:=False, SaveWithDocument:=True, Left:=sngLEFT, Top:=sngTop, Width:=0#, Height:=0#)

'

'***図形に名前を付ける

    If strName <> "" Then

       objShape.Name = strName

    End If

'

'***図の大きさ調整(元のサイズを知る)

    With objShape

        .ScaleHeight 1, True

        .ScaleWidth 1, True

    End With

    sngHT = objShape.Height

    sngWD = objShape.Width

'

'***横幅決定

    If sngWidth = 0 Then

       sngSetWidth = obj作成シート.Range(strA1).Width

    Else

       sngSetWidth = sngWidth

    End If

'

'***割合を計算（指定は横なので縦を計算する)

    sngHEIGHT = sngSetWidth * sngHT / sngWD

'

'***行高さは409以内

    If sngHEIGHT >= 400 Then

       sngHEIGHT = 400

    End If

'

'***縦が収まら無ければ行高さを調整

    sngW1 = obj作成シート.Range(strA1).Height

    If sngW1 < sngHEIGHT Then

       obj作成シート.Range(strA1).EntireRow.RowHeight = sngHEIGHT

    End If

'

'***割合を計算（指定は横なので縦を計算する)

    objShape.Height = sngHEIGHT

    objShape.Width = sngSetWidth

'

'***後始末

    Set objShape = Nothing

  

'***EXIT

    Exit Sub

End Sub

Sub TestMain()

'*****************************************************

'@ SP_8500GazPastのテスト用メイン

'*****************************************************

Dim strBookPath As String

Dim obj対象ブック As Object      '==ブックオブジェクト

Dim obj作成シート As Object      '==対象のexcelシート

Dim strGazouFullPath As String   '==画像ファイルのフルパス 例) d:\test\data.jpeg

Dim strA1 As String              '==画像を貼り付けるセル 例) "H10"

Dim strName As String            '==貼り付けた画像につける名前 ""なら名前は付けない

Dim sngWidth As Single           '==横幅    縦は自動計算し行高さを調整している ここが０ならstrA1の巾に

  

'

'***TEST用データブック

    strBookPath = ThisWorkbook.Sheets(1).Range("DataPath")

    If strBookPath = "" Then

       MSGBOX "TEST用データブックを指定して下さい"

       Exit Sub

    End If

'

'***TEST用画像

    strGazouFullPath = ThisWorkbook.Sheets(1).Range("DataPath2")

    If strGazouFullPath = "" Then

       MSGBOX "TEST用画像を指定して下さい"

       Exit Sub

    End If

'

'***TEST用ブックOPEN

    Set obj対象ブック = Workbooks.Open(FileName:=strBookPath)

    Set obj作成シート = obj対象ブック.worksheets(1)

'

'***CALL

    strA1 = "B2"                 '==画像を貼り付けるセル 例) "H10"

    strName = "画像の名前"       '==貼り付けた画像につける名前 ""なら名前は付けない

    sngWidth = 80                '==横幅    縦は自動計算し行高さを調整している ここが０ならstrA1の巾に

    Call SP_8500GazPast(obj作成シート, strGazouFullPath, strA1, strName, sngWidth)  '==エクセルシートに画像を貼り付ける

'

'***後始末

    Set obj作成シート = Nothing

    Set obj対象ブック = Nothing

'

'*** EXIT

    Exit Sub

  

End Sub