★ 指定した画像ファイルを取り込んでリサイズするサンプルプログラム（Excelの場合、Wordの場合）

★ 指定した画像ファイルを取り込んでリサイズするサンプルプログラム（Excelの場合、Wordの場合）
　　
※まだ書きかけです。すみません。
※間違ってたらすみません。
※メモ書きなので、自分でも意味不明な箇所も多いです。ごめんなさい。
　　

★ Excelの場合

「Sheet1」の「D列」の行のうち、「C列」に画像のフルパスが記載されている場合「のみ」、
D列に画像を縦横比を維持しながら、かつ、画像の縦の高さ（行高＝70）を一定にしながら、
吸い込みます。

'
'

Option Explicit

Sub PicImp_n_Resize01()

    Dim o_WS_01         As Worksheet
    Dim o_Cel_01        As Range
    Dim o_Rngs_01       As Range
    Dim l_RowHgt        As Long
    Dim s_Colmn_01      As String
    Dim v_PicFulPath    As Variant
   
    
    On Error Resume Next
    'もし入力されたフルパスの画像ファイルが、存在しないか、
    'パスやファイル名に誤りがあるとエラーになるのですが、
    'もしそうなっても最後のフルパスまで処理を続ける。
    '（※いい加減なエラー処理なので改善が必要。）
    
    
'    Application.ScreenUpdating = False
'    '画面の描画を止める
    
    

    '●各種設定。
    
    Set o_WS_01 = ActiveWorkbook.Worksheets("Sheet1")
    '目的のシートをオブジェクト変数に代入（シートに短い仮名をつける感じ。）
    
    
    Set o_Rngs_01 = o_WS_01.Range("D1:D4")
    'For Eachのループによって画像ファイルをセットするセル範囲を指定。
    '（一番上の行が列名になっているなら、"D2:D4" みたいな感じに変える。）
        
    
    l_RowHgt = 70
    '行の高さと画像ファイルの高さをこの高さに設定。
    
    
    s_Colmn_01 = "C"
    '画像ファイルのフルパスの入力されている列を指定。
    



    
    '●メインループ処理
    '指定したフルパスの画像ファイルを、各セルの位置に挿入して大きさを合わせる。
    
    For Each o_Cel_01 In o_Rngs_01
    '指定したセル範囲のすべてのセルに以下の処理。

        o_Cel_01.Select
        'まずセルを選択。これをすることで、画像ファイルの挿入位置を決定。
        '選択したセルの位置に、画像ファイルが挿入されます。
        '（また、For Eachのループによって、自動的に一番上のセルから順番に選択されます。）
        

        Rows(o_Cel_01.Row).RowHeight = l_RowHgt
        '選択したセルの行の高さを、前段階で設定した高さに変更。
        
        
        v_PicFulPath = o_WS_01.Range(s_Colmn_01 & o_Cel_01.Row)
        '画像ファイルのフルパスの取得（C列より）
        
        
        o_WS_01.Pictures.Insert(v_PicFulPath).Select
        '「C列に入力されたフルパス」の画像ファイルを挿入してそれを選択。
        

        Selection.ShapeRange.ScaleHeight l_RowHgt / _
            Selection.ShapeRange.Height, _
            msoFalse, _
            msoScaleFromTopLeft
        '挿入・選択した画像ファイルを、その行の高さに合わせる。
        '※縦横比が保持されるので、自動的に横も合わさります。
        
    Next o_Cel_01




    '●後始末。

'    Application.ScreenUpdating = True
    
    MsgBox "完了。　　※存在しないか、パスやファイル名に誤りがある画像は抜けています。"
        
End Sub


'
'

Option Explicit

Sub PicImp_n_Resize01()

Dim o_WS_01 As Worksheet

Dim o_Cel_01 As Range

Dim o_Rngs_01 As Range

Dim l_RowHgt As Long

Dim s_Colmn_01 As String

Dim v_PicFulPath As Variant

On Error Resume Next

'もし入力されたフルパスの画像ファイルが、存在しないか、

'パスやファイル名に誤りがあるとエラーになるのですが、

'もしそうなっても最後のフルパスまで処理を続ける。

'（※いい加減なエラー処理なので改善が必要。）

' Application.ScreenUpdating = False

' '画面の描画を止める

'●各種設定。

Set o_WS_01 = ActiveWorkbook.Worksheets("Sheet1")

'目的のシートをオブジェクト変数に代入（シートに短い仮名をつける感じ。）

Set o_Rngs_01 = o_WS_01.Range("D1:D4")

'For Eachのループによって画像ファイルをセットするセル範囲を指定。

'（一番上の行が列名になっているなら、"D2:D4" みたいな感じに変える。）

l_RowHgt = 70

'行の高さと画像ファイルの高さをこの高さに設定。

s_Colmn_01 = "C"

'画像ファイルのフルパスの入力されている列を指定。

'●メインループ処理

'指定したフルパスの画像ファイルを、各セルの位置に挿入して大きさを合わせる。

For Each o_Cel_01 In o_Rngs_01

'指定したセル範囲のすべてのセルに以下の処理。

o_Cel_01.Select

'まずセルを選択。これをすることで、画像ファイルの挿入位置を決定。

'選択したセルの位置に、画像ファイルが挿入されます。

'（また、For Eachのループによって、自動的に一番上のセルから順番に選択されます。）

Rows(o_Cel_01.Row).RowHeight = l_RowHgt

'選択したセルの行の高さを、前段階で設定した高さに変更。

v_PicFulPath = o_WS_01.Range(s_Colmn_01 & o_Cel_01.Row)

'画像ファイルのフルパスの取得（C列より）

o_WS_01.Pictures.Insert(v_PicFulPath).Select

'「C列に入力されたフルパス」の画像ファイルを挿入してそれを選択。

Selection.ShapeRange.ScaleHeight l_RowHgt / _

Selection.ShapeRange.Height, _

msoFalse, _

msoScaleFromTopLeft

'挿入・選択した画像ファイルを、その行の高さに合わせる。

'※縦横比が保持されるので、自動的に横も合わさります。

Next o_Cel_01

'●後始末。

' Application.ScreenUpdating = True

MsgBox "完了。　　※存在しないか、パスやファイル名に誤りがある画像は抜けています。"

End Sub

★ Word の場合

'
'

Option Explicit

Sub test01()

 Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:="1"
 '↑1ページ目に移動（もし他のページに居たならこのコードもいちおう必要。）

Call PicturSet("D:\Picts\2019-11-08---00-05-26.jpg", 3, 5)
 '↑１つめの画像を上から3センチ左から5㎝の位置に挿入。

Call PicturSet("D:\Picts\2019-11-08---00-05-26.jpg", 10, 15)
 '↑２つめの画像を上から10センチ左から15㎝の位置に。



Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:="2"
 '↑2ページ目に移動

Call PicturSet("D:\Picts\2019-11-08---00-05-26.jpg", 3, 5)
 '↑３つめの画像を上から3センチ左から5㎝の位置に挿入。

Call PicturSet("D:\Picts\2019-11-08---00-05-26.jpg", 10, 15)
 '↑４つめの画像を上から10センチ左から15㎝の位置に。


End Sub


'####################################################################
'指定した画像ファイルを指定した位置（センチ単位）に挿入するプログラム
'####################################################################

Sub PicturSet(s_PicPath01 As String, d_TopCanti01 As Double, d_LeftCenti As Double)

Dim o_Shp01 As Shape


Set o_Shp01 = ActiveDocument.Shapes.AddPicture( _
FileName:=s_PicPath01, _
LinkToFile:=False, _
SaveWithDocument:=True)
'↑指定された画像を、アクティブなページに挿入




With o_Shp01

.RelativeVerticalPosition = wdRelativeHorizontalPositionPage
'↑画像の垂直方向の配置の基準（＝アンカー）を紙（＝ページ自体）の上端に変更

.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
'↑画像の水平方向の配置の基準（＝アンカー）を紙（＝ページ自体）の左端に変更

.Top = CentimetersToPoints(d_TopCanti01)
'変更したアンカーを基準に、その左端から指定したセンチ、移動。

.Left = CentimetersToPoints(d_LeftCenti)
'変更したアンカーを基準に、その上端から指定したセンチ、移動。

.ZOrder msoSendBehindText
'画像をテキストの背面に移動。

End With



End Sub

'
'＝＝＝＝＝＝＝＝＝＝
'
'なお、最後の方の、「.ZOrder msoSendBehindText」は、画像をテキストの背面にするのでなければ、以下の値を参考に書き換えてみてください。
' （英単語か数値のいずれかで指定します。）
'
'MsoZOrderCmd 列挙
' 他の図形を基準として、図形を移動する位置を Z オーダーで指定します。
'
' 名前 数値 説明
'msoBringForward 2 図形を前面に移動します。
'msoBringInFrontOfText 4 図形をテキストの前に移動します。
'msoBringToFront 0 図形を最前面に移動します。
'msoSendBackward 3 図形を背面に移動します。
'msoSendBehindText 5 図形をテキストの後ろに移動します。
'msoSendToBack 1 図形を最背面に移動します
'
'
'
'同様に､アンカーの設定変更も､以下をご参考に｡
'
'
'WdRelativeVerticalPosition 列挙
'レイアウト枠､図形､または行のグループの垂直方向の位置を決めるときの基準を指定します｡
'
' 名前 数値 説明
'wdRelativeVerticalPositionLine 3 行を基準にする
'wdRelativeVerticalPositionMargin 0 余白を基準にする
'wdRelativeVerticalPositionPage 1 ページを基準にする
'wdRelativeVerticalPositionParagraph 2 段落を基準にする
'wdRelativeVerticalPositionBottomMarginArea 5 下余白を基準にする
'wdRelativeVerticalPositionInnerMarginArea 6 内側の余白領域を基準にする
'wdRelativeVerticalPositionOuterMarginArea 7 外側の余白領域を基準にする
'wdRelativeVerticalPositionTopMarginArea 4 上余白を基準にする
'


'
'

100

101

102

103

104

105

106

107

108

109

110

111

Option Explicit

Sub test01()

Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:="1"

'↑1ページ目に移動（もし他のページに居たならこのコードもいちおう必要。）

Call PicturSet("D:\Picts\2019-11-08---00-05-26.jpg", 3, 5)

'↑１つめの画像を上から3センチ左から5㎝の位置に挿入。

Call PicturSet("D:\Picts\2019-11-08---00-05-26.jpg", 10, 15)

'↑２つめの画像を上から10センチ左から15㎝の位置に。

Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:="2"

'↑2ページ目に移動

Call PicturSet("D:\Picts\2019-11-08---00-05-26.jpg", 3, 5)

'↑３つめの画像を上から3センチ左から5㎝の位置に挿入。

Call PicturSet("D:\Picts\2019-11-08---00-05-26.jpg", 10, 15)

'↑４つめの画像を上から10センチ左から15㎝の位置に。

End Sub

'####################################################################

'指定した画像ファイルを指定した位置（センチ単位）に挿入するプログラム

'####################################################################

Sub PicturSet(s_PicPath01 As String, d_TopCanti01 As Double, d_LeftCenti As Double)

Dim o_Shp01 As Shape

Set o_Shp01 = ActiveDocument.Shapes.AddPicture( _

FileName:=s_PicPath01, _

LinkToFile:=False, _

SaveWithDocument:=True)

'↑指定された画像を、アクティブなページに挿入

With o_Shp01

.RelativeVerticalPosition = wdRelativeHorizontalPositionPage

'↑画像の垂直方向の配置の基準（＝アンカー）を紙（＝ページ自体）の上端に変更

.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage

'↑画像の水平方向の配置の基準（＝アンカー）を紙（＝ページ自体）の左端に変更

.Top = CentimetersToPoints(d_TopCanti01)

'変更したアンカーを基準に、その左端から指定したセンチ、移動。

.Left = CentimetersToPoints(d_LeftCenti)

'変更したアンカーを基準に、その上端から指定したセンチ、移動。

.ZOrder msoSendBehindText

'画像をテキストの背面に移動。

End With

End Sub

'＝＝＝＝＝＝＝＝＝＝

'なお、最後の方の、「.ZOrder msoSendBehindText」は、画像をテキストの背面にするのでなければ、以下の値を参考に書き換えてみてください。

' （英単語か数値のいずれかで指定します。）

'MsoZOrderCmd 列挙

' 他の図形を基準として、図形を移動する位置を Z オーダーで指定します。

' 名前数値説明

'msoBringForward 2 図形を前面に移動します。

'msoBringInFrontOfText 4 図形をテキストの前に移動します。

'msoBringToFront 0 図形を最前面に移動します。

'msoSendBackward 3 図形を背面に移動します。

'msoSendBehindText 5 図形をテキストの後ろに移動します。

'msoSendToBack 1 図形を最背面に移動します

'同様に､アンカーの設定変更も､以下をご参考に｡

'WdRelativeVerticalPosition 列挙

'レイアウト枠､図形､または行のグループの垂直方向の位置を決めるときの基準を指定します｡

' 名前数値説明

'wdRelativeVerticalPositionLine 3 行を基準にする

'wdRelativeVerticalPositionMargin 0 余白を基準にする

'wdRelativeVerticalPositionPage 1 ページを基準にする

'wdRelativeVerticalPositionParagraph 2 段落を基準にする

'wdRelativeVerticalPositionBottomMarginArea 5 下余白を基準にする

'wdRelativeVerticalPositionInnerMarginArea 6 内側の余白領域を基準にする

'wdRelativeVerticalPositionOuterMarginArea 7 外側の余白領域を基準にする

'wdRelativeVerticalPositionTopMarginArea 4 上余白を基準にする

★ Excelの場合のおまけ０１

選択したセルの位置から、選択した画像ファイル数分、順番に下のセルに画像を貼り付け。
セルの高さ１００、横は、モト画像の縦横比を維持。

'
'
'#############################################
'選択したセルから下へ、
'ファイルダイアログで選んだ画像ファイル数だけ、
'指定したセルの高さで縦横比を維持して吸い込み。
'ボタンにするなら
'「フォームコントロール」のほうの
'コマンドボタンで。
'じゃないとセルの選択が無効にされてしまうので。
'#############################################

Sub PicImp_n_Resize02()

    Dim o_WS_01         As Worksheet
    Dim o_Cel_01        As Range
    Dim o_Rngs_01       As Range
    Dim l_RowHgt        As Long
'    Dim s_Colmn_01      As String
    Dim v_PicFulPath    As Variant
   
    Dim o_AnswFDialg    As FileDialog
    Dim s_PickFldPath   As Variant
    Dim i               As Integer
    
    '    s_FoldPath = "D:\1"
    Set o_AnswFDialg = Application. _
                        FileDialog(msoFileDialogFilePicker)
    '↑ファイル選択ダイアログを使えるように準備。

    If Not o_AnswFDialg.Show Then
        Exit Sub
        '↑キャンセルされたときは終わる。
    Else
        s_PickFldPath = Array(o_AnswFDialg.SelectedItems)
'        s_PickFldPath = o_AnswFDialg.SelectedItems(1)
        '↑フォルダが選択されたら、
        '　ファイル選択ダイアログのオブジェクトの
        '「SelectedItems プロパティ」にフォルダパスが
        '自動的にゲットされるので、
        '　一時的な処理として、いったん適当な変数に
        'それをメモ代入。
    End If
    '↑ファイル選択ダイアログを実際に開き、
    '　フォルダが選択されたら（＝フォルダパスがゲットできたら）
    '　そのパスを一時保管して次へ行き、
    '　キャンセルされたらプログラムを終わる。




    On Error Resume Next
    'もし入力されたフルパスの画像ファイルが、存在しないか、
    'パスやファイル名に誤りがあるとエラーになるのですが、
    'もしそうなっても最後のフルパスまで処理を続ける。
    '（※いい加減なエラー処理なので改善が必要。）
    
    
'    Application.ScreenUpdating = False
'    '画面の描画を止める
    
    

    '●各種設定。
    
'    Set o_WS_01 = ActiveWorkbook.Worksheets("Sheet2")
    Set o_WS_01 = ActiveWorkbook.ActiveSheet
    '目的のシートをオブジェクト変数に代入（シートに短い仮名をつける感じ。）
    
    
'    Set o_Rngs_01 = o_WS_01.Range("B1:B" & s_PickFldPath(0).Count)
    Set o_Rngs_01 = Application.Selection.Resize(s_PickFldPath(0).Count, 1)
    'For Eachのループによって画像ファイルをセットするセル範囲を指定。
    '（一番上の行が列名になっているなら、"D2:D4" みたいな感じに変える。）
        
    
    l_RowHgt = 100
    '行の高さと画像ファイルの高さをこの高さに設定。
    
    
'    s_Colmn_01 = "C"
    '画像ファイルのフルパスの入力されている列を指定。
    



    i = 1
    
    '●メインループ処理
    '指定したフルパスの画像ファイルを、各セルの位置に挿入して大きさを合わせる。
    
    For Each o_Cel_01 In o_Rngs_01
    '指定したセル範囲のすべてのセルに以下の処理。

        o_Cel_01.Select
        'まずセルを選択。これをすることで、画像ファイルの挿入位置を決定。
        '選択したセルの位置に、画像ファイルが挿入されます。
        '（また、For Eachのループによって、自動的に一番上のセルから順番に選択されます。）
        

        Rows(o_Cel_01.Row).RowHeight = l_RowHgt
        '選択したセルの行の高さを、前段階で設定した高さに変更。
        
        
'        v_PicFulPath = o_WS_01.Range(s_Colmn_01 & o_Cel_01.Row)
        v_PicFulPath = s_PickFldPath(0).Item(i)
        '画像ファイルのフルパスの取得（C列より）
        
        
        o_WS_01.Pictures.Insert(v_PicFulPath).Select
        '「C列に入力されたフルパス」の画像ファイルを挿入してそれを選択。
        

        Selection.ShapeRange.ScaleHeight l_RowHgt / _
            Selection.ShapeRange.Height, _
            msoFalse, _
            msoScaleFromTopLeft
        '挿入・選択した画像ファイルを、その行の高さに合わせる。
        '※縦横比が保持されるので、自動的に横も合わさります。
        
        i = i + 1
        
    Next o_Cel_01




    '●後始末。

'    Application.ScreenUpdating = True
    
    MsgBox "完了。　　※存在しないか、パスやファイル名に誤りがある画像は抜けています。"
        
End Sub
'
'

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

'#############################################

'選択したセルから下へ、

'ファイルダイアログで選んだ画像ファイル数だけ、

'指定したセルの高さで縦横比を維持して吸い込み。

'ボタンにするなら

'「フォームコントロール」のほうの

'コマンドボタンで。

'じゃないとセルの選択が無効にされてしまうので。

'#############################################

Sub PicImp_n_Resize02()

Dim o_WS_01 As Worksheet

Dim o_Cel_01 As Range

Dim o_Rngs_01 As Range

Dim l_RowHgt As Long

' Dim s_Colmn_01 As String

Dim v_PicFulPath As Variant

Dim o_AnswFDialg As FileDialog

Dim s_PickFldPath As Variant

Dim i As Integer

' s_FoldPath = "D:\1"

Set o_AnswFDialg = Application. _

FileDialog(msoFileDialogFilePicker)

'↑ファイル選択ダイアログを使えるように準備。

If Not o_AnswFDialg.Show Then

Exit Sub

'↑キャンセルされたときは終わる。

Else

s_PickFldPath = Array(o_AnswFDialg.SelectedItems)

' s_PickFldPath = o_AnswFDialg.SelectedItems(1)

'↑フォルダが選択されたら、

'　ファイル選択ダイアログのオブジェクトの

'「SelectedItems プロパティ」にフォルダパスが

'自動的にゲットされるので、

'　一時的な処理として、いったん適当な変数に

'それをメモ代入。

End If

'↑ファイル選択ダイアログを実際に開き、

'　フォルダが選択されたら（＝フォルダパスがゲットできたら）

'　そのパスを一時保管して次へ行き、

'　キャンセルされたらプログラムを終わる。

On Error Resume Next

'もし入力されたフルパスの画像ファイルが、存在しないか、

'パスやファイル名に誤りがあるとエラーになるのですが、

'もしそうなっても最後のフルパスまで処理を続ける。

'（※いい加減なエラー処理なので改善が必要。）

' Application.ScreenUpdating = False

' '画面の描画を止める

'●各種設定。

' Set o_WS_01 = ActiveWorkbook.Worksheets("Sheet2")

Set o_WS_01 = ActiveWorkbook.ActiveSheet

'目的のシートをオブジェクト変数に代入（シートに短い仮名をつける感じ。）

' Set o_Rngs_01 = o_WS_01.Range("B1:B" & s_PickFldPath(0).Count)

Set o_Rngs_01 = Application.Selection.Resize(s_PickFldPath(0).Count, 1)

'For Eachのループによって画像ファイルをセットするセル範囲を指定。

'（一番上の行が列名になっているなら、"D2:D4" みたいな感じに変える。）

l_RowHgt = 100

'行の高さと画像ファイルの高さをこの高さに設定。

' s_Colmn_01 = "C"

'画像ファイルのフルパスの入力されている列を指定。

i = 1

'●メインループ処理

'指定したフルパスの画像ファイルを、各セルの位置に挿入して大きさを合わせる。

For Each o_Cel_01 In o_Rngs_01

'指定したセル範囲のすべてのセルに以下の処理。

o_Cel_01.Select

'まずセルを選択。これをすることで、画像ファイルの挿入位置を決定。

'選択したセルの位置に、画像ファイルが挿入されます。

'（また、For Eachのループによって、自動的に一番上のセルから順番に選択されます。）

Rows(o_Cel_01.Row).RowHeight = l_RowHgt

'選択したセルの行の高さを、前段階で設定した高さに変更。

' v_PicFulPath = o_WS_01.Range(s_Colmn_01 & o_Cel_01.Row)

v_PicFulPath = s_PickFldPath(0).Item(i)

'画像ファイルのフルパスの取得（C列より）

o_WS_01.Pictures.Insert(v_PicFulPath).Select

'「C列に入力されたフルパス」の画像ファイルを挿入してそれを選択。

Selection.ShapeRange.ScaleHeight l_RowHgt / _

Selection.ShapeRange.Height, _

msoFalse, _

msoScaleFromTopLeft

'挿入・選択した画像ファイルを、その行の高さに合わせる。

'※縦横比が保持されるので、自動的に横も合わさります。

i = i + 1

Next o_Cel_01

'●後始末。

' Application.ScreenUpdating = True

MsgBox "完了。　　※存在しないか、パスやファイル名に誤りがある画像は抜けています。"

End Sub

★ Excelの場合のおまけ０２
「Ｂ列」に、選んだ画像ファイルの数だけ、縦に、画像を貼り付け。
セルの高さ１００、横は、モト画像の縦横比を維持。

'
'
Sub PicImp_n_Resize03()

    Dim o_WS_01         As Worksheet
    Dim o_Cel_01        As Range
    Dim o_Rngs_01       As Range
    Dim l_RowHgt        As Long
    Dim s_Colmn_01      As String
    Dim v_PicFulPath    As Variant
   
    Dim o_AnswFDialg    As FileDialog
    Dim s_PickFldPath   As Variant
    Dim i               As Integer
    
    '    s_FoldPath = "D:\1"
    Set o_AnswFDialg = Application. _
                        FileDialog(msoFileDialogFilePicker)
    '↑ファイル選択ダイアログを使えるように準備。

    If Not o_AnswFDialg.Show Then
        Exit Sub
        '↑キャンセルされたときは終わる。
    Else
        s_PickFldPath = Array(o_AnswFDialg.SelectedItems)
'        s_PickFldPath = o_AnswFDialg.SelectedItems(1)
        '↑フォルダが選択されたら、
        '　ファイル選択ダイアログのオブジェクトの「SelectedItems プロパティ」にフォルダパスが自動的にゲットされるので、
        '　一時的な処理として、いったん適当な変数にそれをメモ代入。
    End If
    '↑ファイル選択ダイアログを実際に開き、
    '　フォルダが選択されたら（＝フォルダパスがゲットできたら）
    '　そのパスを一時保管して次へ行き、
    '　キャンセルされたらプログラムを終わる。




    On Error Resume Next
    'もし入力されたフルパスの画像ファイルが、存在しないか、
    'パスやファイル名に誤りがあるとエラーになるのですが、
    'もしそうなっても最後のフルパスまで処理を続ける。
    '（※いい加減なエラー処理なので改善が必要。）
    
    
'    Application.ScreenUpdating = False
'    '画面の描画を止める
    
    

    '●各種設定。
    
'    Set o_WS_01 = ActiveWorkbook.Worksheets("Sheet2")
    Set o_WS_01 = ActiveWorkbook.ActiveSheet
    '目的のシートをオブジェクト変数に代入（シートに短い仮名をつける感じ。）
    
    
    Set o_Rngs_01 = o_WS_01.Range("B1:B" & s_PickFldPath(0).Count)
    'For Eachのループによって画像ファイルをセットするセル範囲を指定。
    '（一番上の行が列名になっているなら、"D2:D4" みたいな感じに変える。）
        
    
    l_RowHgt = 100
    '行の高さと画像ファイルの高さをこの高さに設定。
    
    
    s_Colmn_01 = "C"
    '画像ファイルのフルパスの入力されている列を指定。
    



    i = 1
    
    '●メインループ処理
    '指定したフルパスの画像ファイルを、各セルの位置に挿入して大きさを合わせる。
    
    For Each o_Cel_01 In o_Rngs_01
    '指定したセル範囲のすべてのセルに以下の処理。

        o_Cel_01.Select
        'まずセルを選択。これをすることで、画像ファイルの挿入位置を決定。
        '選択したセルの位置に、画像ファイルが挿入されます。
        '（また、For Eachのループによって、自動的に一番上のセルから順番に選択されます。）
        

        Rows(o_Cel_01.Row).RowHeight = l_RowHgt
        '選択したセルの行の高さを、前段階で設定した高さに変更。
        
        
'        v_PicFulPath = o_WS_01.Range(s_Colmn_01 & o_Cel_01.Row)
        v_PicFulPath = s_PickFldPath(0).Item(i)
        '画像ファイルのフルパスの取得（C列より）
        
        
        o_WS_01.Pictures.Insert(v_PicFulPath).Select
        '「C列に入力されたフルパス」の画像ファイルを挿入してそれを選択。
        

        Selection.ShapeRange.ScaleHeight l_RowHgt / _
            Selection.ShapeRange.Height, _
            msoFalse, _
            msoScaleFromTopLeft
        '挿入・選択した画像ファイルを、その行の高さに合わせる。
        '※縦横比が保持されるので、自動的に横も合わさります。
        
        i = i + 1
        
    Next o_Cel_01




    '●後始末。

'    Application.ScreenUpdating = True
    
    MsgBox "完了。　　※存在しないか、パスやファイル名に誤りがある画像は抜けています。"
        
End Sub
'
'

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

Sub PicImp_n_Resize03()

Dim o_WS_01 As Worksheet

Dim o_Cel_01 As Range

Dim o_Rngs_01 As Range

Dim l_RowHgt As Long

Dim s_Colmn_01 As String

Dim v_PicFulPath As Variant

Dim o_AnswFDialg As FileDialog

Dim s_PickFldPath As Variant

Dim i As Integer

' s_FoldPath = "D:\1"

Set o_AnswFDialg = Application. _

FileDialog(msoFileDialogFilePicker)

'↑ファイル選択ダイアログを使えるように準備。

If Not o_AnswFDialg.Show Then

Exit Sub

'↑キャンセルされたときは終わる。

Else

s_PickFldPath = Array(o_AnswFDialg.SelectedItems)

' s_PickFldPath = o_AnswFDialg.SelectedItems(1)

'↑フォルダが選択されたら、

'　ファイル選択ダイアログのオブジェクトの「SelectedItems プロパティ」にフォルダパスが自動的にゲットされるので、

'　一時的な処理として、いったん適当な変数にそれをメモ代入。

End If

'↑ファイル選択ダイアログを実際に開き、

'　フォルダが選択されたら（＝フォルダパスがゲットできたら）

'　そのパスを一時保管して次へ行き、

'　キャンセルされたらプログラムを終わる。

On Error Resume Next

'もし入力されたフルパスの画像ファイルが、存在しないか、

'パスやファイル名に誤りがあるとエラーになるのですが、

'もしそうなっても最後のフルパスまで処理を続ける。

'（※いい加減なエラー処理なので改善が必要。）

' Application.ScreenUpdating = False

' '画面の描画を止める

'●各種設定。

' Set o_WS_01 = ActiveWorkbook.Worksheets("Sheet2")

Set o_WS_01 = ActiveWorkbook.ActiveSheet

'目的のシートをオブジェクト変数に代入（シートに短い仮名をつける感じ。）

Set o_Rngs_01 = o_WS_01.Range("B1:B" & s_PickFldPath(0).Count)

'For Eachのループによって画像ファイルをセットするセル範囲を指定。

'（一番上の行が列名になっているなら、"D2:D4" みたいな感じに変える。）

l_RowHgt = 100

'行の高さと画像ファイルの高さをこの高さに設定。

s_Colmn_01 = "C"

'画像ファイルのフルパスの入力されている列を指定。

i = 1

'●メインループ処理

'指定したフルパスの画像ファイルを、各セルの位置に挿入して大きさを合わせる。

For Each o_Cel_01 In o_Rngs_01

'指定したセル範囲のすべてのセルに以下の処理。

o_Cel_01.Select

'まずセルを選択。これをすることで、画像ファイルの挿入位置を決定。

'選択したセルの位置に、画像ファイルが挿入されます。

'（また、For Eachのループによって、自動的に一番上のセルから順番に選択されます。）

Rows(o_Cel_01.Row).RowHeight = l_RowHgt

'選択したセルの行の高さを、前段階で設定した高さに変更。

' v_PicFulPath = o_WS_01.Range(s_Colmn_01 & o_Cel_01.Row)

v_PicFulPath = s_PickFldPath(0).Item(i)

'画像ファイルのフルパスの取得（C列より）

o_WS_01.Pictures.Insert(v_PicFulPath).Select

'「C列に入力されたフルパス」の画像ファイルを挿入してそれを選択。

Selection.ShapeRange.ScaleHeight l_RowHgt / _

Selection.ShapeRange.Height, _

msoFalse, _

msoScaleFromTopLeft

'挿入・選択した画像ファイルを、その行の高さに合わせる。

'※縦横比が保持されるので、自動的に横も合わさります。

i = i + 1

Next o_Cel_01

'●後始末。

' Application.ScreenUpdating = True

MsgBox "完了。　　※存在しないか、パスやファイル名に誤りがある画像は抜けています。"

End Sub

★ Excelの場合のおまけ０３
画像ファイルのフォルダのパスが、アクティブセルに書かれていて
ファイルダイアログではそこを自動でデフォルトで開くようにして、
その中で選んだ画像ファイルを、
アクティブセルの右のセルから、縦に、下に、画像を貼り付ける。
セルの高さ１００、横は、モト画像の縦横比を維持。

'
'
'#############################################
'選択したセルから下へ、
'ファイルダイアログで選んだ画像ファイル数だけ、
'指定したセルの高さで縦横比を維持して吸い込み。
'ボタンにするなら
'「フォームコントロール」のほうの
'コマンドボタンで。
'じゃないとセルの選択が無効にされてしまうので。
'#############################################

Sub PicImp_n_Resize02()

Dim o_WS_01 As Worksheet
Dim o_Cel_01 As Range
Dim o_Rngs_01 As Range
Dim l_RowHgt As Long
' Dim s_Colmn_01 As String
Dim v_PicFulPath As Variant

Dim o_AnswFDialg As FileDialog
Dim s_PickFldPath As Variant
Dim i As Integer

' s_FoldPath = "D:\1"
Set o_AnswFDialg = Application. _
FileDialog(msoFileDialogFilePicker)
'↑ファイル選択ダイアログを使えるように準備。
'初期表示フォルダの設定
o_AnswFDialg.InitialFileName = Selection

If Not o_AnswFDialg.Show Then
Exit Sub
'↑キャンセルされたときは終わる。
Else
s_PickFldPath = Array(o_AnswFDialg.SelectedItems)
' s_PickFldPath = o_AnswFDialg.SelectedItems(1)
'↑フォルダが選択されたら、
' ファイル選択ダイアログのオブジェクトの
'「SelectedItems プロパティ」にフォルダパスが
'自動的にゲットされるので、
' 一時的な処理として、いったん適当な変数に
'それをメモ代入。
End If
'↑ファイル選択ダイアログを実際に開き、
' フォルダが選択されたら（＝フォルダパスがゲットできたら）
' そのパスを一時保管して次へ行き、
' キャンセルされたらプログラムを終わる。


Selection.Offset(0, 1).Activate

On Error Resume Next
'もし入力されたフルパスの画像ファイルが、存在しないか、
'パスやファイル名に誤りがあるとエラーになるのですが、
'もしそうなっても最後のフルパスまで処理を続ける。
'（※いい加減なエラー処理なので改善が必要。）


' Application.ScreenUpdating = False
' '画面の描画を止める



'●各種設定。

' Set o_WS_01 = ActiveWorkbook.Worksheets("Sheet2")
Set o_WS_01 = ActiveWorkbook.ActiveSheet
'目的のシートをオブジェクト変数に代入（シートに短い仮名をつける感じ。）


' Set o_Rngs_01 = o_WS_01.Range("B1:B" & s_PickFldPath(0).Count)
Set o_Rngs_01 = Application.Selection.Resize(s_PickFldPath(0).Count, 1)
'For Eachのループによって画像ファイルをセットするセル範囲を指定。
'（一番上の行が列名になっているなら、"D2:D4" みたいな感じに変える。）


l_RowHgt = 100
'行の高さと画像ファイルの高さをこの高さに設定。


' s_Colmn_01 = "C"
'画像ファイルのフルパスの入力されている列を指定。




i = 1

'●メインループ処理
'指定したフルパスの画像ファイルを、各セルの位置に挿入して大きさを合わせる。

For Each o_Cel_01 In o_Rngs_01
'指定したセル範囲のすべてのセルに以下の処理。

o_Cel_01.Select
'まずセルを選択。これをすることで、画像ファイルの挿入位置を決定。
'選択したセルの位置に、画像ファイルが挿入されます。
'（また、For Eachのループによって、自動的に一番上のセルから順番に選択されます。）


Rows(o_Cel_01.Row).RowHeight = l_RowHgt
'選択したセルの行の高さを、前段階で設定した高さに変更。


' v_PicFulPath = o_WS_01.Range(s_Colmn_01 & o_Cel_01.Row)
v_PicFulPath = s_PickFldPath(0).Item(i)
'画像ファイルのフルパスの取得（C列より）


o_WS_01.Pictures.Insert(v_PicFulPath).Select
'「C列に入力されたフルパス」の画像ファイルを挿入してそれを選択。


Selection.ShapeRange.ScaleHeight l_RowHgt / _
Selection.ShapeRange.Height, _
msoFalse, _
msoScaleFromTopLeft
'挿入・選択した画像ファイルを、その行の高さに合わせる。
'※縦横比が保持されるので、自動的に横も合わさります。

i = i + 1

Next o_Cel_01




'●後始末。

' Application.ScreenUpdating = True

MsgBox "完了。 ※存在しないか、パスやファイル名に誤りがある画像は抜けています。"

End Sub
'
'

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

'#############################################

'選択したセルから下へ、

'ファイルダイアログで選んだ画像ファイル数だけ、

'指定したセルの高さで縦横比を維持して吸い込み。

'ボタンにするなら

'「フォームコントロール」のほうの

'コマンドボタンで。

'じゃないとセルの選択が無効にされてしまうので。

'#############################################

Sub PicImp_n_Resize02()

Dim o_WS_01 As Worksheet

Dim o_Cel_01 As Range

Dim o_Rngs_01 As Range

Dim l_RowHgt As Long

' Dim s_Colmn_01 As String

Dim v_PicFulPath As Variant

Dim o_AnswFDialg As FileDialog

Dim s_PickFldPath As Variant

Dim i As Integer

' s_FoldPath = "D:\1"

Set o_AnswFDialg = Application. _

FileDialog(msoFileDialogFilePicker)

'↑ファイル選択ダイアログを使えるように準備。

'初期表示フォルダの設定

o_AnswFDialg.InitialFileName = Selection

If Not o_AnswFDialg.Show Then

Exit Sub

'↑キャンセルされたときは終わる。

Else

s_PickFldPath = Array(o_AnswFDialg.SelectedItems)

' s_PickFldPath = o_AnswFDialg.SelectedItems(1)

'↑フォルダが選択されたら、

' ファイル選択ダイアログのオブジェクトの

'「SelectedItems プロパティ」にフォルダパスが

'自動的にゲットされるので、

' 一時的な処理として、いったん適当な変数に

'それをメモ代入。

End If

'↑ファイル選択ダイアログを実際に開き、

' フォルダが選択されたら（＝フォルダパスがゲットできたら）

' そのパスを一時保管して次へ行き、

' キャンセルされたらプログラムを終わる。

Selection.Offset(0, 1).Activate

On Error Resume Next

'もし入力されたフルパスの画像ファイルが、存在しないか、

'パスやファイル名に誤りがあるとエラーになるのですが、

'もしそうなっても最後のフルパスまで処理を続ける。

'（※いい加減なエラー処理なので改善が必要。）

' Application.ScreenUpdating = False

' '画面の描画を止める

'●各種設定。

' Set o_WS_01 = ActiveWorkbook.Worksheets("Sheet2")

Set o_WS_01 = ActiveWorkbook.ActiveSheet

'目的のシートをオブジェクト変数に代入（シートに短い仮名をつける感じ。）

' Set o_Rngs_01 = o_WS_01.Range("B1:B" & s_PickFldPath(0).Count)

Set o_Rngs_01 = Application.Selection.Resize(s_PickFldPath(0).Count, 1)

'For Eachのループによって画像ファイルをセットするセル範囲を指定。

'（一番上の行が列名になっているなら、"D2:D4" みたいな感じに変える。）

l_RowHgt = 100

'行の高さと画像ファイルの高さをこの高さに設定。

' s_Colmn_01 = "C"

'画像ファイルのフルパスの入力されている列を指定。

i = 1

'●メインループ処理

'指定したフルパスの画像ファイルを、各セルの位置に挿入して大きさを合わせる。

For Each o_Cel_01 In o_Rngs_01

'指定したセル範囲のすべてのセルに以下の処理。

o_Cel_01.Select

'まずセルを選択。これをすることで、画像ファイルの挿入位置を決定。

'選択したセルの位置に、画像ファイルが挿入されます。

'（また、For Eachのループによって、自動的に一番上のセルから順番に選択されます。）

Rows(o_Cel_01.Row).RowHeight = l_RowHgt

'選択したセルの行の高さを、前段階で設定した高さに変更。

' v_PicFulPath = o_WS_01.Range(s_Colmn_01 & o_Cel_01.Row)

v_PicFulPath = s_PickFldPath(0).Item(i)

'画像ファイルのフルパスの取得（C列より）

o_WS_01.Pictures.Insert(v_PicFulPath).Select

'「C列に入力されたフルパス」の画像ファイルを挿入してそれを選択。

Selection.ShapeRange.ScaleHeight l_RowHgt / _

Selection.ShapeRange.Height, _

msoFalse, _

msoScaleFromTopLeft

'挿入・選択した画像ファイルを、その行の高さに合わせる。

'※縦横比が保持されるので、自動的に横も合わさります。

i = i + 1

Next o_Cel_01

'●後始末。

' Application.ScreenUpdating = True

MsgBox "完了。 ※存在しないか、パスやファイル名に誤りがある画像は抜けています。"

End Sub

投稿タグ: 「ニセモノ」への道, 「本物」に近づくために, ExcelVBA, Excelの独学, Excel操作の基礎, Excel連携VBA, パソコンでの自動化, ビジネスパソコンの基礎, ビジネス一般常識, マクロ, ワークシート関数, 独学, 画像, 自動化

MENU

関連記事

最近の投稿

カテゴリー

MENU

★ 指定した画像ファイルを取り込んでリサイズするサンプルプログラム（Excelの場合、Wordの場合）

関連記事

最近の投稿

カテゴリー

タグ