[[20140721212857]]　『マクロ実行中のメッセージボックスが表示されない』（ゆうこ）　ページの最後に飛ぶ

『マクロ実行中のメッセージボックスが表示されないようにしたい』（ゆうこ）

現在使用しているマクロで、マクロ実行させると
メッセージボックスで処理を選択するようになっているのですが
それを表示させないようにするには、どうしたらいいでしょうか？

画像を指定の結合セルにぴったりサイズが合うように挿入したいのですが
メッセージボックスで表示される選択肢は、すべて「はい」を選択するものとして
メッセージボックスを表示させずにすべての処理を完了させたいです。

初心者のため、うまく説明できずすみません。

現在利用しているマクロは下記の通りです。

Dim n, fi, cc As Range, ya, ca, g, ok, fl, l
Sub 複数画像の挿入()

    Dim a, c, sr, sc, s, rr, pkfile, ar, ac, z, rc, ccc, ca0
On Error GoTo err
    Set a = Application.InputBox("画像を挿入するセルを選択してください" _
            & Chr(13) & Chr(10) & "複数選択可 (ShiftキーまたはCtrlキーで選択)" _
         , "複数画像の一括挿入（セル選択）", Selection.Address, , , , , 8)
    Application.ScreenUpdating = False
         a.Select
        sr = Selection.Row
        sc = Selection.Column
    rr = sr
pkfile = Application.GetOpenFilename _
    ("すべての図(*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bmp;*.gif), *.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bmp;*.gif", 2, "挿入する図の選択（複数選択可）", , True)
If Not IsArray(pkfile) Then MsgBox "ファイルが指定されていません", , "複数画像の一括挿入": End
    For fi = 1 To UBound(pkfile)
       If pkfile(fi) = False Then MsgBox "ファイルが指定されていません", , "複数画像の一括挿入": End 'キャンセルの場合終わる
    Next fi
n = ActiveSheet.Pictures.Count
Application.DisplayAlerts = False
z = MsgBox("画像のサイズをセルに合わせますか", vbYesNo, "複数画像の挿入")
ok = 0
If Application.Version < 12 Then
    If MsgBox("縦横比を保持しますか", 4, "複数画像の一括挿入") = 6 Then ok = 0 Else ok = 1
End If
If z = 6 Then ya = MsgBox("画像圧縮しますか", vbYesNo, "複数画像の挿入")
    l = MsgBox("元の画像へのリンクを作成しますか", 4 + 256)

  ar = a.Address
 ac = Range(ar).Count
fi = 1
  If ac > 1 Then GoTo ech Else GoTo pc
ech:
    ca0 = ""
   For Each cc In ActiveSheet.Range(ar)
    ca = Range(cc.Address).MergeArea.Address
    rc = Range(ca).Rows.Count
    ccc = Range(ca).Columns.Count
    If rc > 1 Or cc > 1 Then
    ca = Cells(Range(ca).Row + rc - 1, Range(ca).Column + ccc - 1).Address
    End If
    If ca0 = ca Then GoTo mne
    ca0 = ca
    ca = Range(cc.Address).MergeArea.Address
    Range(ca).Select

' cc.Select

        g = ActiveSheet.Shapes.AddPicture( _
            Filename:=pkfile(fi), _
             LinkToFile:=False, _
            SaveWithDocument:=True, _
            Left:=Selection.Left, _
            Top:=Selection.Top, _
            Width:=400#, _
            Height:=300#).Name
'図のサイズを元のサイズに戻します

    With ActiveSheet.Shapes(g)
        .ScaleHeight 1!, msoTrue
        .ScaleWidth 1!, msoTrue
    End With

        fl = pkfile(fi)
'右のセルにファイル名を表示
        Cells(Range(ca).Row, Range(ca).Column + 1) = fl

        If z = 6 Then セルにサイズを合わせる
        fi = fi + 1
    If fi = UBound(pkfile) + 1 Then GoTo en
mne:
    Next
    Application.DisplayAlerts = True
    a.Select
Exit Sub

pc:

    For fi = 1 To UBound(pkfile)
        ca = Cells(rr, sc).Address
        Range(ca).Select
        g = ActiveSheet.Shapes.AddPicture( _
            Filename:=pkfile(fi), _
             LinkToFile:=False, _
            SaveWithDocument:=True, _
            Left:=Selection.Left, _
            Top:=Selection.Top, _
            Width:=400#, _
            Height:=300#).Name
'図のサイズを元のサイズに戻します

    With ActiveSheet.Shapes(g)
        .ScaleHeight 1!, msoTrue
        .ScaleWidth 1!, msoTrue
    End With

        fl = pkfile(fi)
'右のセルにファイル名を表示
        Cells(Range(ca).Row, Range(ca).Column + 1) = fl

        If z = 6 Then セルにサイズを合わせる
        rr = rr + 1
    Next fi
Exit Sub
en:
Application.DisplayAlerts = True
    Application.ScreenUpdating = False

    a.Select
Exit Sub
err: MsgBox "選択が正しくありません", , "複数画像の一括挿入"
End Sub

Sub セルにサイズを合わせる()

    Dim c As Range, cm As Range
    Dim rX As Single, rY As Single, r As Single

    Application.ScreenUpdating = False
'    For Each c In Selection

' Set cm = c.MergeArea

        Set cm = Range(ca)
'        If c.Address = cm.Item(1).Address Then
 '           If Application.Dialogs(xlDialogInsertPicture).Show = False Then Exit Sub
         ActiveSheet.Shapes(g).Select
           With Selection
                rX = cm.Width / .Width
                rY = cm.Height / .Height
                If ok = 0 Then
                    If rX < rY Then
                         cx = .Width * rX
                         cy = .Height * rX
                    Else
                         cx = .Width * rY
                         cy = .Height * rY
                    End If
                Else
                 cx = cm.Width
                 cy = cm.Height
                 End If
                    .Width = cx
                    .Height = cy
                    .Left = cm.Left
                    .Top = cm.Top + cm.Height - .Height
               If ya = 6 Then 図の圧縮
            End With
 '       End If
 '  Next
    Set cm = Nothing
    Application.ScreenUpdating = True
End Sub
Sub 図の圧縮()
    Selection.Cut
    Range(ca).Select
    ActiveSheet.PasteSpecial Format:="図 (JPEG)"
        If l = 6 Then
           ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=fl
           Else
            Cells(Range(ca).Row, Range(ca).Column + 1) = ""
        End If
        g = Selection.ShapeRange.Name

End Sub

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

 どこから参照したかはわかりませんが、ずいぶんとごちゃごちゃとしたコードですね。

 こういっては失礼ですけれど、プログラミングの悪い書き方を集めたようなコードで
 初心者でなくとも、処理を追いかけるのは大変そうです。

 無責任な回答になりますが、とりあえず所望のことを実現するには、
 　z = MsgBox("画像のサイズをセルに合わせますか", vbYesNo, "複数画像の挿入")
 のような箇所を
 　z = vbYes
 のように置き換えることで、メッセージボックスで YESを選択したのと同等になります。

 ですが、このような変更を積み重ねると、さらに可読性や保守性が低下するので、
 できれば一度目的に合わせて整理した方が、今後のためのような気はします。

 特にあちこちに散見するマジックナンバー（意味の分からない定数）はきちんと
 定義名を使用した方が良いと思います。

http://www.geocities.jp/cbc_vbnet/function/mseegefunction.html

 If z = 6 Then
 なんてコードを見て、これが YES を選択したときの処理だなんて、特に初心者には
 想像もつかないのではないでしょうか。

（Mook） 2014/07/21(月) 22:08

Mook様

さっそくのご回答、ありがとうございます。
教えていただいた通りに置き換えて、メッセージボックスを表示させずに処理することができました。
ありがとうございました。

今後いろいろと勉強していきたいと思います。
本当にありがとうございました。

（ゆうこ） 2014/07/21(月) 22:36

コメント返信：

[ 一覧(最新更新順) ]

[[20140721212857]] 『マクロ実行中のメッセージボックスが表示されない』（ゆうこ） ページの最後に飛ぶ

[[20140721212857]]　『マクロ実行中のメッセージボックスが表示されない』（ゆうこ）　ページの最後に飛ぶ