『アウトルックに常に画像の高さを一定に縮小して、エクセルからコピーしたいです。』（vba素人）

アウトルックに常に画像の高さを一定に縮小して、エクセルからコピーしたいです。
下記のコードではセルごとの高さが一定になってしまい、セルによっては入力している文字が表示されなくなってしまいます。
どのように修正すればよいか、ご教示頂けますでしょうか。

Sub main() 
    Dim ap As Object, beforeheight As Variant, w1 As Worksheet, g As Long
    Set ap = CreateObject("outlook.application")
    Set w1 = Worksheets("コメント")
    g = w1.Cells(Rows.Count, 1).End(xlUp).Row
    With ap.ActiveInspector.wordeditor.Windows(1).Selection
        w1.Select
        beforeheight = Range(Cells(1, 1), Cells(g, 1)).RowHeight
        Range(Cells(1, 1), Cells(g, 1)).RowHeight = 30 'ちょうど良いサイズになるよう数字は適宜変える。
        Range(Cells(1, 1), Cells(g, 1)).Select
        Selection.CopyPicture
        .Paste
        Range(Cells(1, 1), Cells(g, 1)).RowHeight = beforeheight
        .TypeText Chr(13) & Chr(13)
    End With
End Sub



＜ 使用 Excel：Excel2010、使用 OS：unknown ＞