Office TANAKA - Excel VBA Tips[画像の大きさを取得する]

ユーザーが選択した画像をワークシートに挿入するには次のようにします。

Sub Sample1()
    Dim PicFile As String
    PicFile = Application.GetOpenFilename()
    If PicFile = "False" Then Exit Sub
    ActiveSheet.Pictures.Insert PicFile
End Sub

GetOpenFilenameメソッドで画像ファイルを指定して、PicturesコレクションのInsertメソッドで挿入します。簡単ですね。では、選択された画像の大きさを、挿入する前に取得するにはどうしたらいいでしょう。何となくVBAだけでは無理っぽい予感がしますので、ここはひとつ発想を変えて「とりあえず挿入してみて、挿入した画像の大きさを調べる」という手を検討してみます。挿入する画像(Sample.jpg)の大きさは、上のように「W283 × H212」です。

Sub Sample2()
    Dim PicFile As String
    PicFile = Application.GetOpenFilename()
    If PicFile = "False" Then Exit Sub
    ActiveSheet.Pictures.Insert PicFile
    With ActiveSheet.Pictures(1)
        MsgBox .Width & " × " & .Height
    End With
End Sub

なんか微妙に違いますね。

実は、画像を挿入する前に、画像の大きさを取得するのは、けっこう簡単にできます。それもVBAの機能だけで。

Sub Sample3()
    Dim PicFile As String, P As Object
    PicFile = Application.GetOpenFilename()
    If PicFile = "False" Then Exit Sub
    ''選択した画像ファイルをオブジェクト型変数に格納する
    Set P = LoadPicture(PicFile)
    MsgBox CLng(P.Width * 0.0378) & " × " & CLng(P.Height * 0.0378)
End Sub

LoadPicture関数は、引数に指定した画像ファイルをImageコントロールのPictureプロパティに設定するときなどに使います。LoadPicture関数はPicture型のオブジェクトを返しますが、このPicture型オブジェクトにはWidthプロパティとHeightプロパティが実装されています。

画像の大きさはピクセルですので、単位を変換するために0.0378を乗じています。これを応用すると、次のように画像を管理するUserFormなども作成できそうですね。

TreeViewコントロールやListViewコントロールの使い方は次のページを参照してください。

UserFormでツリービューを使う　

UserFormでリストビューを使う

TreeViewでフォルダツリーを登録する部分は手を抜きましたが(^^; だいたい次のような感じです。

Private Sub ListView1_ItemClick(ByVal Item As MSComctlLib.ListItem)
    Image1.Picture = LoadPicture(TreeView1.SelectedItem.Key & "\" & Item)
End Sub

Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)
    Dim TargetPath As String, buf As String, P As Object
    TargetPath = Node.Key
    buf = LCase(Dir(TargetPath & "\*.*"))
    Do While buf <> ""
        If Right(buf, 3) = "jpg" Or _
           Right(buf, 3) = "gif" Or _
           Right(buf, 3) = "bmp" Then
            Set P = LoadPicture(TargetPath & "\" & buf)
            With ListView1.ListItems.Add
                .Text = buf
                .SubItems(1) = FileLen(TargetPath & "\" & buf)
                .SubItems(2) = CLng(P.Width * 0.0378)
                .SubItems(3) = CLng(P.Height * 0.0378)
            End With
        End If
        buf = Dir()
    Loop
End Sub