[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『MsgBoxで入力待ちの間、セルを点滅させる方法』（やっぱり初歩）
いつもお世話になっています。 MsgBoxの結果を待っている間、対象セルを強調させる様に 次のようにしましたが、結果は全く駄目でした。 １）点滅しない。２)無限ルーチンとなりハングする。 どうしたらよいのでしょう？お知恵を拝借したいと思います。
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さん
早速のご教授有難うございます。私の目的に適うものでした。
とは言うもののＡＰＩも良く解りません。勝手な想像で理解をしようとしています。
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 が２つもあると理解できません。
' 変数Flagが不要となる処理ですね。真似したいです。
もう一点質問します。ichinoseさんのサンプルではモジュールを２つに分けていますが １個では不具合があるのでしょうか？ １本にして試しましたが問題なく動作しました。 いつも分けも解らなく質問していてすみません。宜しくお願いします。
（やっぱり初歩） 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
???さん 有難うございます。されど難解です・・・ ＡＰＩ関数などでhwndに類した文字が頻繁に出てきますが理解していません。又、Xor等の演算子も ビット操作すると言う事しか知りません。其れがどうなって結果こうなると言う事なども良く解りません。 （１）ＡＰＩ関数の参考書などはあるのでしょうか？ （２）.Color = .Color Xor vbRed ⇒１０進数同士の演算でもビット操作が可能？ 本当に訳の分からない事ばかりです。 もう一点、???さんへ 私のフローへの理解の仕方の是非はいかがでしょう？ 間違いもある筈です。 お忙しいとは思いますが、手短でも構いませんのでコメントをお願いします。
（やっぱり初歩） 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」については再度の質問前に検索しました。理解を充分出来ませんでしたが
想像しながら内容把握に努めました。 「ねむり猫のＡＰＩ関数」を参考にしました。
SetTimerの４番目の引数（AddressOf関数とその引数…SetTime）としているのでプロシージャーSetTimeが
置かれている場所を指定しているものと思いました。だから、SetTimer関数は指定した時間がくればSetTimeを実行する事となるものだと考えた次第です。
少なくとも今日現在、ある程度自分なりに「SetTimer KillTimer」を理解して使う事が出来る様になりました。
有難うございました。（亡失した時には又よろしくお願いします・・・）
（やっぱり初歩） 2014/12/18(木) 19:45
APIのSettimerは、指定プロシジャーを 指定間隔で実行する を並行処理してくれるので VBAでイベントを作成するときなど便利そうですよね！！ 繰り返し実行する方法は、VBAにも Ontimeメソッドというのがありますが、 別スレッドで動作しているわけではないのでサクサク動作しないし、今回の仕様には、使えないですよね！！
注意は、プログラムが途中で止まってしまうと Excelが停止する可能性がありますから、 On Error Resume 等で 終わらないようにすることと、 繰り返し処理するプログラムは、 単体テストを徹底することです。
>サンプルではモジュールを２つに分けていますが
あらっ、私間違えました。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 ０ は不要ですが、
例えば、赤と 青のブリンクの場合は、必要ですので そのために付けておきました。
昔（プログラムが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--ＯＫ 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 = " ＯＫ "
b2cap = " Ｃａｎｃｅｌ "
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.