[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『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
代わりに解説。
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利用には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
遅くなりまして済みません。モジュールを分割されたその意味は解りました。利便性ですね。 どうも有り難うございました。
(やっぱり初歩) 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.