エクセルVBAについて質問です。急いでます。

良回答者には1000ポイントぐらい検討します。

並びは5×5のセルで、左角の(0,0)がRange(H22:I24) になります。
このマスに画像の貼付け、リサイズ、圧縮、センター合わせ を行いたいです。
下記のコードを完成させて下さい。もっと短く書くことができるなら他の方法でも良いです。
よろしくお願いします。

Sub picture()
Dim strFilePath As String
Dim strFileName As String
Dim i As Integer
Dim j As Integer
Dim rngSpace As Range
Dim myShape As shape
i = 0
j = 0

strFilePath = "./"
strFileName = Dir(strFilePath & "*.jpg")
Do
Set rngSpace = Worksheets(1).Range("H21").Offset(j, i)
Set myShape = ActiveSheet.Shapes.addPicture( _
Filename:=strFilePath & strFileName, _
LinkToFile:=False, SaveWithDocument:=True, Left:=Selection.Left, _
Top:=Selection.Top, Width:=0, height:=0)

With myShape
.ScaleHeight 0.4, msoTrue
.ScaleWidth 0.4, msoTrue
End With

strFileName = Dir()
Loop While strFileName <> ""
End Sub

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2011/11/23 02:29:27
  • 終了:2011/11/27 16:43:07

回答(2件)

id:robbie21 No.1

robbie21回答回数34ベストアンサー獲得回数12011/11/23 07:18:09

ポイント100pt

・"左角の(0,0)がRange(H22:I24)" の意味がよくわからなかったので、
多少期待と動作が違うかもしれません。
・圧縮は保存時に行われると思うので、行っていません。

Sub InsertPictures()
    Const TableSize = 5
    Const StartAddress = "H22"
    Const SheetNumber = 1
    Const FolderPath = "./"
    
    Dim PictureName As String
    Dim Counter As Integer
    Dim RowIndex As Integer
    Dim ColIndex As Integer
    Dim CurrentCell As Range
    Dim Pic As Shape
    Dim StartCell As Range

    '初期化
    DellPics
    Set StartCell = Worksheets(SheetNumber).Range(StartAddress)
    
    PictureName = Dir(FolderPath & "*.jpg")
    
    
    Counter = 0
    RowIndex = 0
    ColIndex = 0
    Do
        RowIndex = Int(Counter / TableSize)
        ColIndex = Counter Mod TableSize
        
        Set CurrentCell = StartCell.Offset(RowIndex, ColIndex)
        
        Set Pic = CurrentCell.Worksheet.Shapes.AddPicture( _
            FileName:=FolderPath & PictureName, _
            LinkToFile:=False, SaveWithDocument:=True, Left:=CurrentCell.Left, _
            Top:=CurrentCell.Top, Width:=0, Height:=0)
        
        FitPicture Pic
        CenteringPicture Pic
        'CompressPic Pic
        
        PictureName = Dir()
        Counter = Counter + 1
    
    Loop While PictureName <> ""
End Sub

Sub FitPicture(s As Shape)
    
    '縦横比の復元
    s.ScaleHeight 1, msoTrue
    s.ScaleWidth 1, msoTrue
    
    '横幅をセルにフィット
    s.LockAspectRatio = msoTrue
    s.Width = s.TopLeftCell.Width
    
    'はみ出したら高さを縮める
    If s.Height > s.TopLeftCell.Height Then
        s.Height = s.TopLeftCell.Height
    End If
    
    
End Sub

'図の圧縮
'Sub CompressPic(s As Shape)
'    参考URL
' http://park7.wakwak.com/~efc21/cgi-bin/exqalounge.cgi?print+200906/09060124.txt
'    '圧縮処理 Excel2007以降なら、保存するときに圧縮できるのでこの処理はおそらく不要
'    Dim Cel As Range
'    Set Cel = s.TopLeftCell
'    s.Cut
'    Cel.Worksheet.PasteSpecial Format:="図 (JPEG)"
'
'End Sub

Sub CenteringPicture(s As Shape)
    s.Top = s.TopLeftCell.Top + (s.TopLeftCell.Height - s.Height) / 2
    s.Left = s.TopLeftCell.Left + (s.TopLeftCell.Width - s.Width) / 2

End Sub

Sub DellPics()
    Dim s As Shape
    
    For Each s In ActiveSheet.Shapes
        s.Delete
    Next
End Sub

id:pochi1234

ご回答ありがとうございます。
質問の趣旨がうまく伝わらなく申し訳ありません。
新しい質問の方に移動しますので、もしよろしければそちらをご覧下さい。

2011/11/27 16:43:48
id:taknt No.2

きゃづみぃ回答回数13539ベストアンサー獲得回数11982011/11/23 09:09:48

H22から5×5のセルに画像がなるようにしました。

ただ、このプログラムだと 全部の画像が 同じ場所に貼り付けられてしまいますが・・・。

貼り付ける場所を変更する場合は、
Left:=Worksheets(1).Range("H22:L26").Left, _
Top:=Worksheets(1).Range("H22:L26").Top, _
Width:=Worksheets(1).Range("H22:L26").Width, _
Height:=Worksheets(1).Range("H22:L26").Height)
を変更してください。

なお Range("H22:L26")は Range(Cells(22, "H"), Cells(26, "L"))
というように記述することもできます。

Sub picture()
Dim strFilePath As String
Dim strFileName As String
Dim i As Integer
Dim j As Integer
Dim rngSpace As Range
Dim myShape As Shape
i = 0
j = 0

strFilePath = "./"
strFileName = Dir(strFilePath & "*.jpg")
Do
    Set myShape = ActiveSheet.Shapes.AddPicture( _
    Filename:=strFilePath & strFileName, _
    LinkToFile:=False, SaveWithDocument:=True, _
    Left:=Worksheets(1).Range("H22:L26").Left, _
    Top:=Worksheets(1).Range("H22:L26").Top, _
    Width:=Worksheets(1).Range("H22:L26").Width, _
    Height:=Worksheets(1).Range("H22:L26").Height)
    
    
    strFileName = Dir()
Loop While strFileName <> ""



End Sub



id:pochi1234

ご回答ありがとうございます。質問の趣旨が違い申し訳ありません。

2011/11/27 19:23:05
id:taknt

質問の趣旨が違うのは、残念ですが、回答の内容は 理解できましたでしょうか?

あと、回答とくらべてどこが趣旨と違うか考えて 教えてください。

2011/11/27 20:10:50

コメントはまだありません

この質問への反応(ブックマークコメント)

トラックバック

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません