[[20141218082047]] 『MsgBoxで入力待ちの間、セルを点滅させる方法』(やっぱり初歩) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『MsgBoxで入力待ちの間、セルを点滅させる方法』(やっぱり初歩)

 いつもお世話になっています。
 MsgBoxの結果を待っている間、対象セルを強調させる様に
 次のようにしましたが、結果は全く駄目でした。
 1)点滅しない。2)無限ルーチンとなりハングする。
 どうしたらよいのでしょう?お知恵を拝借したいと思います。

 Declare Function GetTickCount Lib "kernel32.dll" () As Long

 Sub セルを点滅()
    Dim Ret As Long, Rg As Range
    Dim Cnt As Long, Flag As Boolean

    Set Rg = Range("A1")
    Do
       DoEvents
       Do
          Cnt = GetTickCount
          Rg.Font.ColorIndex = IIf(Flag = True, vbRed, 0)
       Loop While GetTickCount - Cnt < 500

       Ret = MsgBox("このセルを対象として良いですか?", vbYesNo)
       If Ret = vbYes Then Exit Do
    Loop While Ret = 0
 End Sub

 駄目なルーチンです。別件でDoEventsを入れる場合どこへ入れるのが妥当でしょうか?

< 使用 Excel:Excel2013、使用 OS:Windows8 >


 apiのSettimerを使った簡単な例です。

 標準モジュールに

 '================================================================
 Option Explicit
 Declare Function SetTimer Lib "user32" _
     (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, _
      ByVal lpTimerFunc As Long) As Long
 Declare Function KillTimer Lib "user32" _
      (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
 Sub settime()
    On Error Resume Next
    With Range("A1").Font
        .Color = .Color Xor vbRed Xor 0
    End With
 End Sub

 別の標準モジュールに

 Option Explicit
 Dim id As Long
 Sub stt()
    id = SetTimer(0&, 10000&, 250&, AddressOf settime)
 End Sub
 Sub ed()
    KillTimer 0&, id
 End Sub
 Sub test()
    Dim ans As Long
    stt
    ans = vbCancel
    Do Until ans = vbOK
       ans = MsgBox("ok", vbOKCancel)
    Loop
    ed
 End Sub

 理解して使ってください。

 他には Msgboxではなく、UserFormでMagboxを自作する方法もあります。

(ichinose) 2014/12/18(木) 09:03


 ichinoseさん
 早速のご教授有難うございます。私の目的に適うものでした。
 とは言うもののAPIも良く解りません。勝手な想像で理解をしようとしています。
 Sub Test()
    Dim ans As Long
    stt                '← この呼出しでFunction SetTimerからID取得と同時に、設定時間後にsettime()
              を実行しているように思われる。但し、結果のIDは何なんでしょうか?
    ans = vbCancel
    Do Until ans = vbOK
       ans = MsgBox("ok", vbOKCancel)
    Loop
    ed                 '← SetTimer を解放
 End Sub

 この程度の自分勝手な理解ですが如何なものでしょうか?
 特にSub settime()が解りません。現実的にはステップ実行してもここへは何故か来ません?
 Sub settime()
    On Error Resume Next
    With Range("A1").Font
        .Color = .Color Xor vbRed Xor 0     ' ここの Xor はどうなっているのでしょう?
    End With                                ' =IIf(Flag = True, VbRed, 0) と同じ意味でしょうか
 End Sub                  ' Xor が2つもあると理解できません。
                      ' 変数Flagが不要となる処理ですね。真似したいです。 

 もう一点質問します。ichinoseさんのサンプルではモジュールを2つに分けていますが
 1個では不具合があるのでしょうか? 1本にして試しましたが問題なく動作しました。
 いつも分けも解らなく質問していてすみません。宜しくお願いします。

(やっぱり初歩) 2014/12/18(木) 12:39


MsgBoxのモーダルよりも、コールバックの割り込みイベントの方が強いのですね。 なるほど! 勉強になりました。

代わりに解説。
SetTimerの引数にhwndを指定した場合、IDは任意に指示します。hwndを指定しない場合、IDはダミー。
この場合、システムが振ってくれたIDを、KillTimer時に指定します。

settime()に飛んでこないのは、MsgBoxがモーダル表示されており、Excelの機能が止められているため。
MsgBoxを使わないコーディングにすれば、ちゃんと飛んできます。

.Color = .Color Xor vbRed Xor 0 は、うしろの Xor 0 は不要でしょう。

あと、呼び出し側は以下で十分かと。

 Sub Test()
    stt
    MsgBox "ok", vbYes
    ed
 End Sub

また、呼び出し側も含めて、全部1つの標準モジュールで構わないかと思います。
(???) 2014/12/18(木) 13:20


 ???さん 有難うございます。されど難解です・・・
 API関数などでhwndに類した文字が頻繁に出てきますが理解していません。又、Xor等の演算子も
 ビット操作すると言う事しか知りません。其れがどうなって結果こうなると言う事なども良く解りません。
 (1)API関数の参考書などはあるのでしょうか?
 (2).Color = .Color Xor vbRed ⇒10進数同士の演算でもビット操作が可能?
 本当に訳の分からない事ばかりです。
 もう一点、???さんへ 私のフローへの理解の仕方の是非はいかがでしょう? 間違いもある筈です。
 お忙しいとは思いますが、手短でも構いませんのでコメントをお願いします。

(やっぱり初歩) 2014/12/18(木) 16:17


APIを解説した本は今でも存在するとは思いますが、Web利用できる現在では、ググるだけです。
例えば、今回ichinoseさんのサンプルに、「SetTimer KillTimer」というAPIが出てきました。
これを検索してみてください。特に、MSDNのページが見つかれば、そこにAPI仕様が書かれています。

API利用にはC言語の知識が必要なので、決して初心者向けではありませんので、意味が判らなければ、
ここで諦めてしまってもOKです。どうしても理解したい、実現したい!、と思うのであれば、とことん調べてください。
(今回の点滅は、短いですが、難易度は高い方法ですので、判らなくても全然問題ありません)

XOR(排他的論理和:exclusive or)については、プログラミングの基礎です。これは理解されているようですが、
簡単に言うと、両方共ONならばOFFになる、そうでないならORを取る命令です。
1 xor 1 = 0、1 xor 0 = 1、0 xor 0 = 0 こうですね。
同じ値同士をXORすると0になるのを利用し、xor 1 すると、値が0と1を交互に繰り返すわけです。
赤色は255ですが、これも同じように動作するので、
255 xor 255 = 0、0 xor 255 = 255 こうなります。xor 255 は、赤と黒を交互に繰り返す事になります。
(XORを2回行うと元の値に戻る、という点に注目)

hwndは、ウィンドウハンドルによく使われる変数名です。ウィンドウハンドルって何?、となるかと思いますので、調べてみてください。
(簡単に言ってしまうと、windowsが管理している、重複しないウィンドウ番号です)

処理の理解は、う〜ん、間違ってはいませんが、理解しているとは見えませんね。
使っているAPIがどういう機能なのか、これを理解すれば全て判ります。

難しいかな、と思うのは、コールバックに関数のアドレスを指定している、という箇所かと思います。
ここまでいくと、windows OS(他にも似たOS多数)はどういう仕組みで動いているか、の世界になりますので。
(???) 2014/12/18(木) 17:28


???さんへ
有難うございます。まだまだ解らない所だらけですが地道に勉強してきます。

「SetTimer KillTimer」については再度の質問前に検索しました。理解を充分出来ませんでしたが
想像しながら内容把握に努めました。 「ねむり猫のAPI関数」を参考にしました。

SetTimerの4番目の引数(AddressOf関数とその引数…SetTime)としているのでプロシージャーSetTimeが
置かれている場所を指定しているものと思いました。だから、SetTimer関数は指定した時間がくればSetTimeを実行する事となるものだと考えた次第です。

少なくとも今日現在、ある程度自分なりに「SetTimer KillTimer」を理解して使う事が出来る様になりました。
有難うございました。(亡失した時には又よろしくお願いします・・・)
(やっぱり初歩) 2014/12/18(木) 19:45


 APIのSettimerは、指定プロシジャーを 指定間隔で実行する を並行処理してくれるので
 VBAでイベントを作成するときなど便利そうですよね!!
 繰り返し実行する方法は、VBAにも Ontimeメソッドというのがありますが、
 別スレッドで動作しているわけではないのでサクサク動作しないし、今回の仕様には、使えないですよね!!

 注意は、プログラムが途中で止まってしまうと Excelが停止する可能性がありますから、
 On Error Resume 等で 終わらないようにすることと、 繰り返し処理するプログラムは、
 単体テストを徹底することです。

 >サンプルではモジュールを2つに分けていますが

 あらっ、私間違えました。Settimer関連は、私が使いやすいように ラッピングしています。

 それでテスト後に抜粋した際に投稿を間違えました。

 ただ、モジュール分割はしていますよ!!

 これは、再度の投稿です。

 新規ブックの標準モジュールに Settimer を司るコード

 Option Explicit
 Private s_hwnd As Long
 Private s_nidevent As Long
 Private s_nelapse As Long
 Private s_tmfunc As Long
 Private s_id As Long
 Declare Function SetTimer Lib "user32" _
     (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, _
      ByVal lpTimerFunc As Long) As Long
 Declare Function KillTimer Lib "user32" _
      (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
 Sub s_setting(p_hwnd As Long, p_nidevent As Long, p_nelapse As Long, p_tmfunc As Long)
    s_hwnd = p_hwnd
    s_nidevent = p_nidevent
    s_nelapse = p_nelapse
    s_tmfunc = p_tmfunc
 End Sub
 Sub s_start()
    On Error Resume Next
    s_id = SetTimer(s_hwnd, s_nidevent, s_nelapse, s_tmfunc)
    On Error GoTo 0
 End Sub
 Sub s_ed()
    On Error Resume Next
    KillTimer s_hwnd, s_id
    On Error GoTo 0
 End Sub

 別の標準モジュールに

 '=======================================================
 Option Explicit
 Sub test()
    Dim ans As Long
    Dim rw As Long
    Range("a1:a100").Value = 100
    s_setting 0, 0, 250, AddressOf cell_Blink
    ans = vbCancel
    Do Until ans = vbOK
       rw = rw + 1
       Cells(rw, "a").Select
       s_ed
       s_start
       ans = MsgBox("ok", vbOKCancel)
       Cells(rw, "a").Font.Color = 0
    Loop
    s_ed
 End Sub
 Sub cell_Blink()
    On Error Resume Next
    With ActiveCell.Font
        .Color = .Color Xor vbRed Xor 0
    End With
    On Error GoTo 0
 End Sub

 このようにしておくと、便利なので私は、モジュールを分けています。

 Xorの件です。

 ご指摘の通り Xor 0 は不要ですが、

 例えば、赤と 青のブリンクの場合は、必要ですので そのために付けておきました。

 昔(プログラムが64K以内のメモリで動かさなければならない)は、よく使いましたが、
 今は、たまにこういう掲示板投稿では、気分で使いますが、
    With ActiveCell.Font
        .Color = IIf(.Color = vbRed, 0, vbRed)
    End With
 これの方が分かりやすいと思いますよ。私は、お仕事では、殆ど使いません(と思ったけどなあ)。
 こういうの使うと コードレヴューで文句がでますし・・・。

(ichinose) 2014/12/19(金) 06:08


ichinoseさん
 遅くなりまして済みません。モジュールを分割されたその意味は解りました。利便性ですね。
 どうも有り難うございました。

(やっぱり初歩) 2014/12/19(金) 23:47


 解決後ですが、別のアプローチで考察してみました。

 最初の投稿で
 >他には Msgboxではなく、UserFormでMagboxを自作する方法もあります。  誤字
 他には Msgboxではなく、UserFormでMsgBox関数を自作する方法もあります。 

 APIのSettimerの代わりに Ontimeを使って繰り返し処理を管理し、
 Msgboxの代わりに ユーザーフォームを使って メッセージ表示処理を自作すれば、
 セルの点滅を行いながら、処理を選択する(ユーザーフォームを使ったMsgbox処理)という仕様が、
 実現できました。

 が、やはり、動作(点滅動作)はぎこちなく、処理が遅くなりました。

 そこでMsgboxを自作(既作)したユーザーフォームに 
 登録されたデータを ユーザーフォーム表示中、監視するというイベント機能を新たに追加しました。

 新規ブックにて

 ユーザーフォームを一つ作成してください(UserForm1)。
 このUserForm1には、コントロールはプログラムで作成しますので何も作成しないでください。

 UserForm1のモジュールに

 '============================================================================
 '=============================================================
 '機能 メッセージをフォームに表示し、結果として、押されたボタンの種類を返す
 '   オプションで指定されたデータをメッセージ表示中監視する
 Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 Event init(ByVal avariable As Variant)
 Event repeat(ByVal avariable As Variant)
 Event term(ByVal avariable As Variant)
 Public ava As Variant                             '監視イベント対象変数
 Public btn_id As Long                             '押されたボタンのID 0--OK  1--Cancel
 Public mes As String                              '表示メッセージ
 Public messz As Long                              'メッセージの文字サイズ
 Public mescl As Long                              'メッセージの色
 Public mesblink As Boolean                        'メッセージの点滅 True -あり False -なし
 Public boxtype As Long                            'メッセージフォームタイプ 0---ボタン一つ 1ボタン二つ
 Public myleft As Single                           'フォームの表示横位置
 Public mytop As Single                            'フォームの縦位置
 Public b1cap As String                            '一つ目のボタンのCaption
 Public b2cap As String                            '二つ目のボタンのCaption
 Public rtime As Long                              'メッセージのブリンク 及び Repeatイベント発生間隔 既定値300 0.3秒
 Private looping As Boolean                        'メッセージ点滅中又は データ監視中 True 点滅中 False 点滅解除
 'イベント   Init repeat term
 '  メッセージ表示中に変数avaに設定されたデータを以下のイベントで監視することができます。
 '    変数avaが空出ない場合 上記3つのイベントが発生します。
 '    init      メッセージ表示された場合の初期作動するイベント
 '  Repeat    メッセージ表示中に繰り返し発生するイベント
 '    term      メッセージ表示終了時(ボタンが押されたタイミング)で発生するイベント
 Private lbl As MSForms.Label
 Private WithEvents btn1 As MSForms.CommandButton
 Private WithEvents btn2 As MSForms.CommandButton
 '=============================================================
 Private Sub UserForm_Activate()
    Dim colnone As Long
    Dim fcl As Long
    mk_msgbox_layout
    If mesblink = True Or Not IsEmpty(ava) Then
       If Not IsEmpty(ava) Then
          RaiseEvent init(ava)
       End If
       looping = True
       Do While looping = True
         If mesblink = True Then
            lbl.ForeColor = IIf(lbl.ForeColor = mescl, lbl.BackColor, mescl)
         End If
         If Not IsEmpty(ava) Then
            RaiseEvent repeat(ava)
         End If
         Sleep rtime
         DoEvents
       Loop
       If Not IsEmpty(ava) Then
          RaiseEvent term(ava)
       End If
    End If
 End Sub
 '=============================================================
 Sub mk_msgbox_layout()
    With Me
      .Caption = "メッセージ"
      If mytop >= 0 And myleft >= 0 Then
         .StartUpPosition = 0
         .Top = mytop
         .Left = myleft
      Else
         mytop = .Top
         myleft = .Left
      End If
      Set lbl = .Controls.Add("Forms.Label.1")
      With lbl
        .Top = 10
        .Left = 10
        .Caption = mes
        .Width = Len(mes) * messz
        .Font.Size = messz
        .AutoSize = True
        .ForeColor = mescl
      End With
      Set btn1 = .Controls.Add("Forms.CommandButton.1")
      With btn1
        .Caption = b1cap
        .Top = lbl.Top + lbl.Height + 10
        .AutoSize = True
        End With
      Select Case boxtype
        Case 0
          .Width = Application.Max(lbl.Left + lbl.Width + 30, btn1.Left + btn1.Width + 20)
          .Height = btn1.Top + btn1.Height + 30
          btn1.Left = .Width / 2 - btn1.Width / 2
        Case 1
          Set btn2 = .Controls.Add("Forms.CommandButton.1")
          With btn2
            .Caption = b2cap
            .Top = lbl.Top + lbl.Height + 10
            .AutoSize = True
            End With
          btn1.Width = Application.Max(btn1.Width, btn2.Width)
          btn2.Width = btn1.Width
          .Width = Application.Max(lbl.Left + lbl.Width + 10, btn1.Left + btn1.Width + 4 + btn2.Width + 20)
          .Height = btn1.Top + Application.Max(btn1.Height, btn2.Height) + 30
          btn1.Left = .Width / 2 - btn1.Width - 2
          btn2.Left = .Width / 2 + 2
        End Select
   End With
   DoEvents
 End Sub
 '=============================================================
 Private Sub btn1_Click()
   btn_id = 0
   Me.Hide
   looping = False
 End Sub
 '=============================================================
 Private Sub btn2_Click()
   btn_id = 1
   Me.Hide
   looping = False
 End Sub
 '=============================================================
 Private Sub UserForm_Initialize()
    Me.StartUpPosition = 1
    messz = 11
    mescl = 0
    boxtype = 0
    myleft = -1
    mytop = -1
    b1cap = "     OK     "
    b2cap = "   Cancel   "
    rtime = 300
 End Sub
 '=============================================================
 Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = 0 Then
       Cancel = True
    Else
       looping = False
    End If
 End Sub

 適当なシートのモジュールに(標準モジュールではないですよ)、

 '====================================================================================
 Option Explicit
 Private WithEvents frm As UserForm1
 Sub samp1()
    Dim ans As Long
    Dim rw As Long
    Range("a1:a100").value = "ichinose"
    rw = 0
    ans = 3
    Set frm = New UserForm1                     '自作Msgboxのインスタンス作成
    With frm
       .mes = "このセルを対象として良いですか?" '表示メッセージの登録
       .messz = 18                               'メッセージのサイズ指定
       .mescl = vbBlack                          'メッセージの色指定
       .mesblink = True                          'メッセージの点滅指示
       .boxtype = 1                              'ボタン二つのタイプ
       .b1cap = "このセルで決定"                 '一つ目のボタンの項目名
       .b2cap = "次の候補"                       '二つ目のボタンの項目名
       Do Until ans = 0
          rw = rw + 1
          Set .ava = Cells(rw, "a")              '監視対象データ(セル)の登録
          .Show                                  'メッセージ表示
          ans = .btn_id                          '結果(どのボタンが押されたか)設定
       Loop
       Application.Goto .ava
    End With
    Unload frm
 End Sub
 '==================================================================
 Private Sub frm_repeat(ByVal avariable As Variant) '対象データの監視(表示中)
    With avariable.Font
       .Color = IIf(.Color = vbRed, 0, vbRed)
    End With
 End Sub
 '=====================================================================
 Private Sub frm_term(ByVal avariable As Variant) '対象データ監視中(表示終了)
    avariable.Font.Color = 0
 End Sub

 対象シートのsamp1を実行してみてください。 Settimerを使った例と同じことが実現できると思います。

(ichinose) 2014/12/21(日) 12:23


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.