[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『（マクロ）進捗状況をステータスバー表示マクロの組み込み方法』（マイン）
お世話になっております。
Sheet内にある帳票から項目ごとにデータ抽出後、UserForm内のListBoxに読み込み
そのデータとWorksheetを同期させて印刷するというプログラムを作りました。
Sheet内リストから1列目にあるデータを抽出→ListBox読み込み→印刷
次に2列め・・・3列目・・・・という具合です。
このプログラムには進捗状況を示すコードを下記部分に組み込んでおります。
'★?A★リストで選択した名前と同じシートを選択
If ListBox1.List(ListBox1.ListIndex, 0) = "この曜日" Then
'「この曜日」が表示されていたら該当者なしなので処理せず、EndIf→Next c に飛ぶ
'★?C★印刷
Application.StatusBar = "○ 「 " & Worksheets("リスト").Cells(1, c).Value & " 曜日」を印刷中...."
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True '選択シート全てを強制印刷
正常に動作はしておりますが・・・少しばかり欲が出てしまい、ステータスバー表示に動きがほしいと
下記のようなテストマクロを作成しました。
↓
↓
↓
Sub 処理進捗状況アニメ表示()
Dim i As Long: Dim xy(7)
xy(0) = "／...": xy(1) = "─.....": xy(2) = "＼..........": xy(3) = "│......................."
xy(4) = "／..": xy(5) = "─.....": xy(6) = "│.........."
For i = 0 To 50
Application.StatusBar = xy(i Mod 7)
Application.Wait [Now()] + 60 / 86400000 '任意値/ミリ秒換算値（1日）
Next
End Sub
動作は「十字マーク」がクルクル周り「ドット」が伸び縮みするといった動きをします。
テストのためループの数値や時間の数値は適当に入力しております。
これを、下記のコードに組み替えたいと思っております。
分かりづらい質問かとは思いますが、何卒アドバイスをお願いします。
Private Sub CB_全ての曜日印刷_Click()
Application.ScreenUpdating = False
'-------------------------------------------------------------
'メッセージ表示し実行するか選択
If MsgBox("担当者の「 " & Label_w1.Caption & "～" & Label_w7.Caption & " 」分の記録を印刷しますか？" _
, Buttons:=vbYesNo + vbQuestion, Title:="印刷処理！") = 6 Then
Worksheets("リスト").Select
Call Label_wの編集制限
Call 全てのlabel黄色表示
Call CB_全曜日着色
Call 全ての曜日を印刷
Worksheets("リスト").Select
Call ボタン_リ全員_Click
MsgBox "全ての記録データをプリンターに送りました。", vbOKOnly, "印刷処理完了"
Else
MsgBox "キャンセルされました。", vbOKOnly, "印刷処理" '★キャンセル時はココに飛ぶ
End If
'-------------------------------------------------------------
Application.ScreenUpdating = True
End Sub
Sub 全ての曜日を印刷()
Dim i As Long 'リスト選択シートへ値転記用カウンター
Dim d As Variant '転記元シート：日付セル
Dim r As Long '転記元シート：日付セル行番号
Dim c As Long 'リストシート：曜日列番号
Dim cnt As Variant 'リスト内選択除外：印刷可以外は非選択
'※注意：データがない曜日はエラー出さずに次の処理に移る
'★?@★月曜～日曜日までをソート→リスト読み込み→全選択
For c = 6 To 12 '曜日の抽出元セル6列目～12列目まで処理
With Worksheets("リスト") 'リストシートのデータを月～日までをループで順番に抽出
.Select 'シート選択
If .FilterMode Then 'フィルタ状況確認
.ShowAllData
End If
.Range("A1:O21").CurrentRegion.AutoFilter Field:=2, Criteria1:="利用中" '(固定）
.Range("A1:O21").AutoFilter Field:=c, Criteria1:="<>" '（Field=変数・・・が曜日列）
End With
Call ListBox1への可視セルデータセット 'データをリストボックスにセット
For cnt = 0 To ListBox1.ListCount - 1 'ListBox内の「印刷可」表示リストのみ選択
If ListBox1.Selected(cnt) = False Then
ListBox1.Selected(cnt) = True
End If
If Not ListBox1.List(cnt, 0) = "印刷可" Then '値が「印刷可」以外の場合はチェックを外す
ListBox1.Selected(cnt) = False
End If
Next cnt
'★?A★リストで選択した名前と同じシートを選択
If ListBox1.List(ListBox1.ListIndex, 0) = "この曜日" Then
'「この曜日」が表示されていたら該当者なしなので処理せず、EndIf→Next c に飛ぶ
Application.StatusBar = "× 「 " & Worksheets("リスト").Cells(1, c).Value & " 曜日」の該当者なし"
Else '適正なリスト：該当者ある場合はシート選択し?Bと?Cの処理
Call シートリスト同期
'★?B★日付転記
r = c - 3 '曜日絞込の値から3を引くと日付転記元の開始位置である3行目を指定できる
d = Worksheets("設定").Range("A" & r).Value '転記元のセル値取得
With ListBox1 '選択状態にあるシートセルに日付を転記
For i = 0 To .ListCount - 1 '飛び飛びにリスト選択しても対応可能
If .Selected(i) Then '設定シートのセル値を記録シートへ書き込む
Worksheets(.List(i, 1)).Range("C4").Value = d
End If
Next i
End With
'★?C★印刷
Application.StatusBar = "○ 「 " & Worksheets("リスト").Cells(1, c).Value & " 曜日」を印刷中...."
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True '選択シート全てを強制印刷
End If
Next c '曜日列
Application.StatusBar = False
On Error GoTo 0
End Sub
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
Sub 全ての曜日を印刷()
For c = 6 To 12 '曜日の抽出元セル6列目～12列目まで処理
★
Next c '曜日列
End Sub
★内での処理が進行している最中に それとは"別スレッド"でStatusBarをアニメーションする
ということであれば、出来ないんじゃないかと思います。
別プロセスで、という事なら何かあるかもしれませんが、 具体的には思い付きませんし、それはそれでムダな様に感じます。
★内の要所要所にStatusBarを更新する処理を差し込んであげる っていう程度にとどめておくのが無難なんじゃないでしょうか?
（白茶） 2018/11/16(金) 19:51
ありがとうございます。確かに言われるとおりです・・・
下記のコードは削除するとして
'★?A★リストで選択した名前と同じシートを選択
If ListBox1.List(ListBox1.ListIndex, 0) = "この曜日" Then
削除→ Application.StatusBar = "× 「 " & Worksheets("リスト").Cells(1, c).Value & " 曜日」の該当者なし"
なんとかできないものでしょうか？
よろしくお願い致します。
（マイン） 2018/11/16(金) 23:19
結果:動いているようです。
Sub 全ての曜日を印刷()
Dim i As Long 'リスト選択シートへ値転記用カウンター
Dim d As Variant '転記元シート：日付セル
Dim r As Long '転記元シート：日付セル行番号
Dim c As Long 'リストシート：曜日列番号
Dim cnt As Variant 'リスト内選択除外：印刷可以外は非選択
'※注意：データがない曜日はエラー出さずに次の処理に移る
'★?@★月曜～日曜日までをソート→リスト読み込み→全選択
For c = 6 To 12 '曜日の抽出元セル6列目～12列目まで処理
'★プログレスバ---------------------------------------------<<
Dim pr As Long: Dim ptn(7)
ptn(0) = "／...": ptn(1) = "─.....": ptn(2) = "＼..........": ptn(3) = "│......................."
ptn(4) = "／..": ptn(5) = "─.....": ptn(6) = "│.........."
For pr = 0 To 12
'<<------------------------------------------------------<<
With Worksheets("リスト") 'リストシートのデータを月～日までをループで順番に抽出
.Select 'シート選択
If .FilterMode Then 'フィルタ状況確認
.ShowAllData
End If
.Range("A1:O21").CurrentRegion.AutoFilter Field:=2, Criteria1:="利用中" '(固定）
.Range("A1:O21").AutoFilter Field:=c, Criteria1:="<>" '（Field=変数・・・が曜日列）
End With
Call ListBox1への可視セルデータセット 'データをリストボックスにセット
For cnt = 0 To ListBox1.ListCount - 1 'ListBox内の「印刷可」表示リストのみ選択
If ListBox1.Selected(cnt) = False Then
ListBox1.Selected(cnt) = True
End If
If Not ListBox1.List(cnt, 0) = "印刷可" Then '値が「印刷可」以外の場合はチェックを外す
ListBox1.Selected(cnt) = False
End If
Next cnt
'★?A★リストで選択した名前と同じシートを選択
If ListBox1.List(ListBox1.ListIndex, 0) = "この曜日" Then
'「この曜日」が表示されていたら該当者なしなので処理せず、EndIf→Next c に飛ぶ
'Application.StatusBar = "× 「 " & Worksheets("リスト").Cells(1, c).Value & " 曜日」の担当者なし"
Else '適正なリスト：該当者ある場合はシート選択し?Bと?Cの処理
Call シートリスト同期
'★?B★日付転記
r = c - 3 '曜日絞込の値から3を引くと日付転記元の開始位置である3行目を指定できる
d = Worksheets("設定").Range("A" & r).Value '転記元のセル値取得
With ListBox1 '選択状態にあるシートセルに日付を転記
For i = 0 To .ListCount - 1 '飛び飛びにリスト選択しても対応可能
If .Selected(i) Then '設定シートのセル値を記録シートへ書き込む
Worksheets(.List(i, 1)).Range("C4").Value = d
End If
Next i
End With
'★?C★印刷
'ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True '選択シート全てを強制印刷
'★プログレスバ---------------------------------------------<<
Application.StatusBar = "「 " & Worksheets("リスト").Cells(1, c).Value & " 曜日」を印刷中...." & ptn(pr Mod 7)
Application.Wait [Now()] + 20 / 86400000 '任意値/ミリ秒換算値（1日）
'<<------------------------------------------------------<<
End If
Next pr '★プログレスバー
Next c '曜日列
Application.StatusBar = False
On Error GoTo 0
End Sub
（マイン） 2018/11/17(土) 00:00
訂正します。
実際にプリントしたら、無限ループになっていました。
（マイン） 2018/11/17(土) 00:04
自分も同じような悩みで昔色々やったことがあるもので(^^)
見栄えに懲りたくなるんですよね、どうしても（笑）
さて本題ですが
windows API関数って使用したことがありますか？
VBAにはない関数が色々あるので私はよく使っています。
特にApllication.Waitは全く使わず、自分はwin32APIのSleep関数をよく使いますね(^^)
こちらの方がCPUへの負担が少なく済ませられます。
SetTimer関数を使うとそれっぽく出来そうなんですが
今回はPrintOut処理が入っているそうで、うまく動くかは自信がないです。。（汗）
仕掛けは、時間の掛かるループ処理の直前にタイマー(SetTimer関数）を仕込み
ループ処理中内にDoeventsを入れて割り込み処理をしながらステータスバーを
更新していきます。
ループが終わるのと同時にタイマーを解除します。
但し、このSetTimer関数は非常に危険で使い方を間違えると
いきなりExcelを落としてしまいます。私は何度も痛い目を見ています（笑）
なのであくまでも参考程度で見てやってください(^^)
新規ワークBookでテストして下さい
Option Explicit
''APIの定義は必ず標準モジュールに置いてください！！
Public Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
Public Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, _
ByVal nIDEvent As Long) As Long
''このFunctionは必ず標準モジュールに置いてください！！
''Functionの名前の変更は可ですが、引数は変更しないで下さい
Public Function TimerProc(ByVal hWnd As Long, ByVal msg As Long, _
ByVal wp As Long, ByVal lp As Long) As Long
Static i As Long ''Static変数はこのプロシージャ内の値を保持します
Dim xy(7)
xy(0) = "／...": xy(1) = "─.....": xy(2) = "＼..........": xy(3) = "│......................."
xy(4) = "／..": xy(5) = "─.....": xy(6) = "│.........."
Application.StatusBar = xy(i Mod 7)
DoEvents
i = i + 1 ''次回このfunctionが呼ばれた時の為にiをインクリメントしておく
If i = 8 Then i = 0
End Function
''このプロシージャをステータスバーが見える状態で実行して下さい。
''シート上にボタンを設置するのが手っ取り早いですかね(^^)
Public Sub Test()
Dim i As Long
Dim TimerID As Long
''指定したミリ秒毎に指定したプロシージャを呼び出します
TimerID = SetTimer(0&, 0&, 69&, AddressOf TimerProc) ''69は 60 / 86400000のおおよその値です Timerの間隔をmsecで指定
''ここから時間の掛かる処理
For i = 0 To 500
DoEvents ''ループ内に必ずDoEventsを入れる事！！
Sleep 10 ''0.01秒待機 ←これはTest用であり本番のコードには不要です
Next
''ここまで時間の掛かる処理
KillTimer 0&, TimerID ''Timerを解除します
Application.StatusBar = False
MsgBox "End"
End Sub
これをマインさんのコードに組み込むとしたら
ループの前後をタイマーでサンドイッチします。
Dim TimerID As Long
TimerID = SetTimer(0&, 0&, 69&, AddressOf TimerProc)
For c = 6 To 12 '曜日の抽出元セル6列目～12列目まで処理
★
DoEventsを必ず一行入れて下さい！！(PrintOutの直前位が良さそうです）
Next c '曜日列
KillTimer 0&, TimerID
もし組み込んでテストするのであれば必ずBookのコピーを取ってからでお願い致します！
それ位SetTimer関数は危険です。
うまく動かないかもしれませんが、こんなAPI関数もあるよ！
というご紹介だったとご容赦下さい（笑）
（みそじのおじさん） 2018/11/17(土) 06:44
単純にプリンターに何枚分の内の何枚目のデータを送りました。 とかで良いんじゃないですか？ 後は、プリンターが共有なら順番待ちなだけだし。 常時グルグルだと、Webなんかのいつ読み込み終わるんだよ！ って、イラツク事ありませんか？（終わりが見えない） 計測中で、グルグルはありかも？
みそじのおじさんのAPI試してみました。 掲載コードだと、実行中にセルをクリックすると落ちました。 Win7 & Office2007環境で・・・。 APIは解らんのでSleep以外使った事がないので、何かが足りないのかも知れないけれど。 （BJ） 2018/11/17(土) 11:45
BJさんのほうでは落ちてしまいましたか、、（汗）
SetTimerとDoEventsの組み合わせは、普段出来ないことが可能になるのですが
ユーザーにやって欲しくない操作も受け付けてしまえる！のが問題点になりますね、、（汗）
なので実行中はキーボード・マウスに触らないを徹底するか、もしくはプログラムで一時的にシートを保護したりする手当とか、On Errorでエラーのトラップをする必要がありますね^^;
ここまでするなら私も、現在マインさんが作られているコードで十分だとは思っていました（^^）
処理時間の総数を自分で把握出来る場合ならいいのですが、不定の場合は私もステータスバーに軽くメッセージを乗せるだけっていうパターンがほとんどですね。
処理時間の総数がわかる場合はモードレスのユーザーフォームに自作のプログレスバークラスで表示したりもしていますが(^^)
ループ中でもDoEventsが入っている為に、
例えばセルをクリックして編集モードになっていても（カーソル点滅状態）
SetTimerで指定したプロシージャを実行出来てしまいます。
でもこれを逆手にとると、通常セルの編集モード中はマクロを発動できませんが、SetTimerを使えばマクロをキックする方法がある！と捉えることが出来ます。
危険を伴うSetTimerですが、上手に使えれば普段出来ないような処理が可能になるよ！という
ご紹介だったとご堪忍してください（笑）
#みそじのおじさんと名乗っていますが、いつのまにか私41歳になっていました（笑）
名前どうしようかな、、(^^)
（みそじのおじさん） 2018/11/18(日) 07:59
いえ、APIに関しては、とやかく言うつもりも言える知識もありません。 ただセルをクリックしてみたら、残念ながら私の環境では必ず落ちてしまうという情報だけです。 そういう情報を知りたい方もいるみたいなので・・・。
>いつのまにか私41歳になっていました
その辺は大丈夫だと思いますよ。 ほとんどの回答者は、自分はかなり年上の方だ思うようだけど、ところがどっこい上には上がかなりいます。
あ、改名するなら自分のHNに敬称つけるのはやめた方が・・・。 前回みたいに、敬称付けるの忘れたり・・・すみません。 （BJ） 2018/11/18(日) 11:02
すごいコードありがとうございます。
APIについてなのですが、残念ながら会社のセキュリティソフトに引っかかってしまい動作確認できませんでした(^_^;)
UserFormのタイトルバーを消して、なおかつマウスドラッグをAPIで仕掛けて使っていたのですが、新しいウィルスソフトになって、ウイルス検出！！！とブラックリストに入れられて・・・何度も繰り返したのでシステム屋に問い合わせされてしまいました。
すみません、後学のために自宅Pｃでひっそり試したいと思います。
本当にありがとうございます
解決とさせていただきます。
（マイン） 2018/11/19(月) 21:44
UserForm使っておられたのであれば、ちょっとそっち方面で何かの足しにでもなるか?と思って
一応、私の方で汎用的に使っているUserFormのデモ版を貼っておきますね。
まぁ、お役には立てない可能性が大きいですが^^;
'[UserForm1]モジュール
Option Explicit
Private Declare PtrSafe Function timeGetTime Lib "winmm.dll" () As Long
Private Declare PtrSafe Function timeBeginPeriod Lib "winmm.dll" (ByVal uPeriod As Long) As Long
Private Declare PtrSafe Function timeEndPeriod Lib "winmm.dll" (ByVal uPeriod As Long) As Long
Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc.dll" (ByVal IAcessible As Object, ByRef hWnd As LongPtr) As Long
Private Declare PtrSafe Function SetActiveWindow Lib "user32.dll" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetActiveWindow Lib "user32.dll" () As LongPtr
Private LabelPer1 As MSForms.Label
Private LabelPer2 As MSForms.Label
Private LabelVal1 As MSForms.Label
Private LabelVal2 As MSForms.Label
Private WithEvents ButtonCancel As MSForms.CommandButton
Private Image1 As MSForms.Image
Private Image2 As MSForms.Image
Private Image1bk As MSForms.Image
Private Image2bk As MSForms.Image
Private LabelTime1 As MSForms.Label
Private LabelTime2 As MSForms.Label
Private TextBoxLog As MSForms.TextBox
Private myValue1 As Long, myValue2 As Long '現在値
Private myMax1 As Long, myMax2 As Long '最大値
Private myUpdatePeriod As Long '更新周期
Private myCancelEnabled As Boolean 'キャンセル可否
Private PerFormat As String, myDecLevel As Long 'パーセント表示ラベルの小数点以下の表示位
Private Canceled As Boolean 'キャンセルボタンを押したかどうか
Private Complete1 As Boolean, Complete2 As Boolean 'ValueがMaxに達しているかどうか
Private LastUpdate1 As Double, LastUpdate2 As Double '前回の表示更新時刻
Private mqMode1 As Boolean, mqMode2 As Boolean 'マーキーモード
Private mqCnt1 As Long, mqCnt2 As Long 'マーキーの現在値
Private Const COLOR_DEFAULT As Long = &H80000012 '通常時の文字色
Private Const COLOR_HIGHLIGHT As Long = &HFF& 'Complete時の文字色
Private fm_MaxH As Single, fm_BtnTop As Single, fm_Bar2Top As Single, fm_BarLeft As Single, fm_BarW As Single
Private fm_TextTop As Single, fm_TextH As Single
Private fm_Title As String '稼働中にタイトルバーに表示する文字列
Private StartTimeMs1 As Double, StartTimeMs2 As Double 'Elapsedの初期値
Private OldSelStart As Long 'Logへの最後の書き込み先頭位置
Private UpdatedFlg1 As Boolean, UpdatedFlg2 As Boolean '進行状況表示が更新された直後だけTrue
Rem 読み取り専用プロパティ =================================================================================
Public Property Get IsCanceled() As Boolean 'キャンセルボタンを押したかどうか
IsCanceled = Canceled
End Property
Public Property Get IsComplete() As Boolean 'ValueがMaxに達しているかどうか
IsComplete = Complete1 And Complete2
End Property
Public Property Get DualMode() As Boolean '２本目バーが表示されているかどうか
DualMode = (myMax2 > 0)
End Property
Public Property Get hWnd() As Long 'ユーザーフォームのウインドウハンドル取得
WindowFromAccessibleObject Me, hWnd
End Property
Public Property Get Updated1() As Boolean '
Updated1 = UpdatedFlg1
End Property
Public Property Get Updated2() As Boolean
Updated2 = UpdatedFlg2
End Property
Rem 値と最大値プロパティ ===================================================================================
Public Property Get Max1() As Long '１本目の最大値
Max1 = myMax1
End Property
Public Property Let Max1(NewMax As Long)
If myMax1 = NewMax Then Exit Property
If NewMax <= 0 Then
myMax1 = 0
Else
myMax1 = NewMax
End If
Call Value1_Change
End Property
Public Property Get Max2() As Long '２本目の最大値
Max2 = myMax2
End Property
Public Property Let Max2(NewMax As Long)
If myMax2 = NewMax Then Exit Property
Dim ChangeFlg As Boolean
ChangeFlg = Me.DualMode
If NewMax <= 0 Then
myMax2 = 0
Complete2 = True
Else
myMax2 = NewMax
Complete2 = False
End If
If ChangeFlg <> Me.DualMode Then Call ChangeDualMode
Call Value2_Change
End Property
Public Property Get Value1() As Long '１本目の現在の値
Value1 = myValue1
End Property
Public Property Let Value1(NewValue As Long)
If myValue1 = NewValue Then Exit Property
myValue1 = NewValue
Call Value1_Change
End Property
Public Property Get Value2() As Long '２本目の現在の値
Value2 = myValue2
End Property
Public Property Let Value2(NewValue As Long)
If myValue2 = NewValue Then Exit Property
myValue2 = NewValue
Call Value2_Change
End Property
Rem その他のプロパティ ======================================================================================
Public Property Get Marquee1() As Boolean '１本目のマーキーモード
Marquee1 = mqMode1
End Property
Public Property Let Marquee1(newMode As Boolean)
If mqMode1 = newMode Then Exit Property
mqMode1 = newMode
Call Value1_Change
End Property
Public Property Get Marquee2() As Boolean '２本目のマーキーモード
Marquee2 = mqMode2
End Property
Public Property Let Marquee2(newMode As Boolean)
If mqMode2 = newMode Then Exit Property
mqMode2 = newMode
Call Value2_Change
End Property
Public Property Get Title() As String '稼働中にタイトルバーに表示されるキャプション文字列
Title = fm_Title
End Property
Public Property Let Title(NewTitle As String)
fm_Title = NewTitle
Me.Caption = fm_Title
End Property
Public Property Get Period() As Long '表示更新周期
Period = myUpdatePeriod
End Property
Public Property Let Period(NewPeriod As Long)
If myUpdatePeriod = NewPeriod Then Exit Property
myUpdatePeriod = NewPeriod
End Property
Public Property Get NumOfDecimals() As Long 'パーセント表示ラベルの小数点以下桁数
NumOfDecimals = myDecLevel
End Property
Public Property Let NumOfDecimals(NewNum As Long)
If myDecLevel = NewNum Then Exit Property
If NewNum >= 0 Then myDecLevel = NewNum
PerFormat = "0%"
If myDecLevel > 0 Then PerFormat = "0." & String$(myDecLevel, "0") & "%"
End Property
Public Property Get Elapsed1() As Double 'TimeReset実行時点からの経過時間
Elapsed1 = (UpTimeMs - StartTimeMs1)
End Property
Public Property Get Elapsed2() As Double
Elapsed2 = (UpTimeMs - StartTimeMs2)
End Property
Public Property Get EnableCancel() As Boolean '中断ボタンのEnabled
EnableCancel = myCancelEnabled
End Property
Public Property Let EnableCancel(NewEnable As Boolean)
If myCancelEnabled = NewEnable Then Exit Property
myCancelEnabled = NewEnable
ButtonCancel.enabled = myCancelEnabled
End Property
Public Property Get Log() As String 'テキストボックスに書き出すログメッセージ
Log = TextBoxLog.Text
End Property
Public Property Let Log(NewLog As String)
If Not Me.Visible Then Me.Show 0
With TextBoxLog
.Text = NewLog
If Not Me.ActiveControl Is TextBoxLog Then .SetFocus
.SelStart = .TextLength + 1
End With
OldSelStart = 0
Call ChangeDualMode
End Property
Rem メソッド ================================================================================================
Public Sub Reset(Optional iniMax1 As Long, Optional iniMax2 As Long, _
Optional UpdatePeriod As Long = 250, _
Optional CancelEnabled As Boolean = True, _
Optional DecimalsLevel As Long = 0, _
Optional TitleString As String _
)
Rem 最大値設定
Me.Max1 = iniMax1
Me.Max2 = iniMax2
Rem カウンタを初期化
myValue1 = 0
myValue2 = 0
Rem 更新サイクルの設定
Me.Period = UpdatePeriod
LastUpdate1 = 0
LastUpdate2 = 0
Call TimeReset1
Call TimeReset2
Rem キャンセルボタンの使用許可
Me.EnableCancel = CancelEnabled
Rem パーセント表示ラベルの小数点以下桁数の指定
Me.NumOfDecimals = DecimalsLevel
Rem タイトルバーに表示されるキャプション文字列
If Len(TitleString) > 0 Then Me.Title = TitleString
Rem 更新
Call ForceUpdate
If Not Me.Visible Then
Me.Show 0
End If
DoEvents
End Sub
Public Sub ReSet2(Optional iniMax2 As Long, Optional ResetElapsed2 As Boolean = True, Optional TitleString As String)
Me.Max2 = iniMax2
myValue2 = 0
LastUpdate2 = 0
If ResetElapsed2 Then Call TimeReset2
If Len(TitleString) > 0 Then Me.Title = TitleString
Call ForceUpdate
If Not Me.Visible Then
Me.Show 0
End If
DoEvents
End Sub
Public Sub Add1(Optional AddValue As Long = 1) '現在の値に加算
Me.Value1 = myValue1 + AddValue
End Sub
Public Sub Add2(Optional AddValue As Long = 1)
Me.Value2 = myValue2 + AddValue
End Sub
Public Sub TimeReset1() '経過時間のリセット
StartTimeMs1 = UpTimeMs
End Sub
Public Sub TimeReset2()
StartTimeMs2 = UpTimeMs
End Sub
Public Sub ForceUpdate() '表示強制更新
Call Value1_Change(True)
Call Value2_Change(True)
End Sub
Public Sub WriteLog(LogString As String, Optional TimeStamp As Boolean = False, Optional ReWriteLastLine As Boolean = False)
If Not Me.Visible Then Me.Show 0
With TextBoxLog
If ReWriteLastLine Then
.SelStart = OldSelStart
.SelLength = .TextLength + 1
Else
.SelStart = .TextLength + 1
OldSelStart = .SelStart
End If
If TimeStamp Then
.SelText = Application.Evaluate("TEXT(NOW(),""hh:mm:ss.00|"")") & LogString & vbCrLf
Else
.SelText = LogString & vbCrLf
End If
If Not Me.ActiveControl Is TextBoxLog Then .SetFocus
End With
Call ChangeDualMode
End Sub
Public Sub Activate()
If Not Me.Visible Then
Me.Show 0
Else
SetActiveWindow Me.hWnd
End If
End Sub
Rem 内部処理 =============================================================================================
Private Sub Value1_Change(Optional Force As Boolean = False)
UpdatedFlg1 = False
Dim Per1 As Double, w1 As Single, Lap As Double, Str As String
Rem 最大値到達判定
Complete1 = (myValue1 = myMax1)
If Complete1 Then
LabelVal1.ForeColor = COLOR_HIGHLIGHT
Else
LabelVal1.ForeColor = COLOR_DEFAULT
End If
Rem 前回から経過時間が更新周期未満で、且つ最大値以外だったら終了
Lap = UpTimeMs
If (Lap - LastUpdate1 < myUpdatePeriod) And Not Complete1 And Not Force Then Exit Sub
LastUpdate1 = Lap
Rem パーセントラベル、整数ラベルの更新
If myMax1 = 0 Then
Per1 = 0
Else
Per1 = myValue1 / myMax1
End If
LabelPer1.Caption = Format$(Per1, PerFormat)
Str = Format$(myValue1, "#,##0") & " / " & Format$(myMax1, "#,##0")
LabelVal1.Caption = Str
Rem バーの幅を更新
If mqMode1 Then 'マーキーモードの場合
Image1.Width = fm_BarW / 3
Image1.Left = fm_BarLeft - fm_BarW / 2 + fm_BarW * (mqCnt1 / 100)
mqCnt1 = (mqCnt1 + 1) Mod 150
Else '通常モードの場合
Per1 = PerForWidth(Per1)
If Per1 < 0 Then 'マイナス値の場合は伸縮方向を反転
Image1.Left = fm_BarLeft + fm_BarW - fm_BarW * Abs(Per1)
Else
Image1.Left = fm_BarLeft
End If
Image1.Width = fm_BarW * Abs(Per1)
End If
Rem 経過時間ラベルの更新
LabelTime1.Caption = Application.Evaluate("TEXT(" & Me.Elapsed1 / 1000 / 60 / 60 / 24 & ",""m:ss.00"")")
LabelTime2.Caption = Application.Evaluate("TEXT(" & Me.Elapsed2 / 1000 / 60 / 60 / 24 & ",""m:ss.00"")")
Rem キャンセルボタンの役割更新
Call CangeButtonCaption
If Not Me.Visible Then Me.Show 0
DoEvents
UpdatedFlg1 = True
End Sub
Private Sub Value2_Change(Optional Force As Boolean = False)
UpdatedFlg2 = False
Dim Per2 As Double, w2 As Single, Lap As Double, Str As String
Complete2 = (myValue2 = myMax2)
If Complete2 Then
LabelVal2.ForeColor = COLOR_HIGHLIGHT
Else
LabelVal2.ForeColor = COLOR_DEFAULT
End If
Lap = UpTimeMs
If (Lap - LastUpdate2 < myUpdatePeriod) And Not Complete2 And Not Force Then Exit Sub
LastUpdate2 = Lap
If Me.DualMode Then '２本目のバーが表示されている場合だけ実行
If myMax2 = 0 Then
Per2 = 0
Else
Per2 = myValue2 / myMax2
End If
LabelPer2.Caption = Format$(Per2, PerFormat)
Str = Format$(myValue2, "#,##0") & " / " & Format$(myMax2, "#,##0")
LabelVal2.Caption = Str
If mqMode2 Then
Image1.Width = fm_BarW / 3
Image2.Left = fm_BarLeft - fm_BarW / 2 + fm_BarW * (mqCnt2 / 100)
mqCnt2 = (mqCnt2 + 1) Mod 150
Else
Per2 = PerForWidth(Per2)
If Per2 < 0 Then 'マイナス値の場合は伸縮方向を反転
Image2.Left = fm_BarLeft + fm_BarW - fm_BarW * Abs(Per2)
Else
Image2.Left = fm_BarLeft
End If
Image2.Width = fm_BarW * Abs(Per2)
End If
End If
LabelTime1.Caption = Application.Evaluate("TEXT(" & Me.Elapsed1 / 1000 / 60 / 60 / 24 & ",""m:ss.00"")")
LabelTime2.Caption = Application.Evaluate("TEXT(" & Me.Elapsed2 / 1000 / 60 / 60 / 24 & ",""m:ss.00"")")
Call CangeButtonCaption
If Not Me.Visible Then Me.Show 0
DoEvents
UpdatedFlg2 = True
End Sub
Private Sub ChangeDualMode() '２本目バーの表示／非表示切替
Dim aMode As Boolean
aMode = Me.DualMode
LabelPer2.Visible = aMode
LabelVal2.Visible = aMode
LabelTime2.Visible = aMode
Image2.Visible = aMode
Image2bk.Visible = aMode
If aMode Then
LabelVal1.Top = fm_BtnTop
LabelTime1.Top = fm_BtnTop
ButtonCancel.Top = fm_BtnTop
TextBoxLog.Top = fm_TextTop
If TextBoxLog.TextLength = 0 Then
Me.Height = fm_MaxH - fm_TextH
Else
Me.Height = fm_MaxH
End If
Else
LabelVal1.Top = (fm_BtnTop - fm_Bar2Top)
LabelTime1.Top = (fm_BtnTop - fm_Bar2Top)
ButtonCancel.Top = (fm_BtnTop - fm_Bar2Top)
TextBoxLog.Top = fm_TextTop - (fm_BtnTop - fm_Bar2Top)
If TextBoxLog.TextLength = 0 Then
Me.Height = fm_MaxH - (fm_BtnTop - fm_Bar2Top) - fm_TextH
Else
Me.Height = fm_MaxH - (fm_BtnTop - fm_Bar2Top)
End If
End If
DoEvents
End Sub
Private Sub CangeButtonCaption() '中断ボタン／閉じるボタン切替
If Canceled Then Exit Sub
If Me.IsComplete Then
With ButtonCancel
.enabled = True
.Caption = "Ｏ Ｋ"
End With
Me.Caption = "完了"
Else
With ButtonCancel
.enabled = myCancelEnabled
.Caption = "キャンセル"
End With
Me.Caption = fm_Title
End If
End Sub
Private Function PerForWidth(per As Double) As Double
If per = 0 Then Exit Function
If per < 0 Then
PerForWidth = (per - Int(per)) - 1
Else
PerForWidth = 1 - (-per - Int(-per))
End If
End Function
'Rem 符号なし長整数型変換(イラネとも思うが一応)
Private Function UpTimeMs() As Double
Dim U As Long
U = timeGetTime()
If U < 0 Then UpTimeMs = U + (&H80000000 * -2#) Else UpTimeMs = U
End Function
Rem イベントプロシージャ =================================================================================
Private Sub ButtonCancel_Click() '中断ボタン
If Me.IsComplete Or Canceled Then
Unload Me
ElseIf MsgBox("処理を中断しますか?", vbYesNo + vbDefaultButton2) = vbYes Then
Canceled = True
ButtonCancel.Caption = "閉じる"
Me.Caption = "処理を中断しました"
End If
End Sub
Private Sub UserForm_Initialize()
Call Prepare
myUpdatePeriod = 250
myCancelEnabled = True
PerFormat = "0%"
mqCnt1 = 75
mqCnt2 = 75
Image1.Width = 0
Image2.Width = 0
fm_MaxH = Me.Height
fm_BarLeft = Image1.Left
fm_BarW = Image1bk.Width
fm_Bar2Top = LabelPer2.Top
fm_BtnTop = ButtonCancel.Top
fm_TextTop = TextBoxLog.Top
fm_TextH = Me.InsideHeight - fm_TextTop
fm_Title = Me.Caption
Call ChangeDualMode
Call timeBeginPeriod(1)
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) '×ボタン一時無効化
If Me.IsComplete Or Canceled Then Exit Sub
If CloseMode = 0 Then Cancel = True
End Sub
Private Sub UserForm_Terminate() 'デストラクタ
Call timeEndPeriod(1)
End Sub
Private Sub Prepare()
Me.Font.Name = "MS UI Gothic"
Me.Font.Size = 9
Set Image1bk = Me.Controls.Add("Forms.Image.1", "Image1bk")
With Image1bk
.Top = 1.5: .Left = 1.5: .Height = 15.75: .Width = 225
.BorderStyle = fmBorderStyleNone
End With
Set Image1 = Me.Controls.Add("Forms.Image.1", "Image1")
With Image1
.Top = 1.5: .Left = 1.5: .Height = 15.75: .Width = 112.5
.BorderStyle = fmBorderStyleNone
.BackColor = &H8000000D
End With
Set LabelPer1 = Me.Controls.Add("Forms.Label.1", "LabelPer1")
With LabelPer1
.Top = 0: .Left = 0: .Height = 18.75: .Width = 228
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectSunken
.TextAlign = fmTextAlignCenter
.Font.Size = 14
.Font.Bold = True
End With
Set Image2bk = Me.Controls.Add("Forms.Image.1", "Image2bk")
With Image2bk
.Top = 21.5: .Left = 1.5: .Height = 15.75: .Width = 225
.BorderStyle = fmBorderStyleNone
End With
Set Image2 = Me.Controls.Add("Forms.Image.1", "Image2")
With Image2
.Top = 21.5: .Left = 1.5: .Height = 15.75: .Width = 112.5
.BorderStyle = fmBorderStyleNone
.BackColor = &H8000000D
End With
Set LabelPer2 = Me.Controls.Add("Forms.Label.1", "LabelPer2")
With LabelPer2
.Top = 20: .Left = 0: .Height = 18.75: .Width = 228
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectSunken
.TextAlign = fmTextAlignCenter
.Font.Size = 14
.Font.Bold = True
End With
Set LabelTime1 = Me.Controls.Add("Forms.Label.1", "LabelTime1")
With LabelTime1
.Top = 42: .Left = 2: .Height = 11.25: .Width = 42
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectEtched
.TextAlign = fmTextAlignRight
End With
Set LabelTime2 = Me.Controls.Add("Forms.Label.1", "LabelTime2")
With LabelTime2
.Top = 54: .Left = 2: .Height = 11.25: .Width = 42
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectEtched
.TextAlign = fmTextAlignRight
End With
Set LabelVal1 = Me.Controls.Add("Forms.Label.1", "LabelVal1")
With LabelVal1
.Top = 42: .Left = 48: .Height = 11.25: .Width = 117
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectSunken
.TextAlign = fmTextAlignRight
End With
Set LabelVal2 = Me.Controls.Add("Forms.Label.1", "LabelVal2")
With LabelVal2
.Top = 54: .Left = 48: .Height = 11.25: .Width = 117
.BackStyle = fmBackStyleTransparent
.SpecialEffect = fmSpecialEffectSunken
.TextAlign = fmTextAlignRight
End With
Set ButtonCancel = Me.Controls.Add("Forms.CommandButton.1", "ButtonCancel")
With ButtonCancel
.Top = 42: .Left = 168: .Height = 21: .Width = 58
.Caption = "キャンセル"
.Default = True
.Cancel = True
End With
Set TextBoxLog = Me.Controls.Add("Forms.TextBox.1", "TextBoxLog")
With TextBoxLog
.Top = 67: .Left = 1.5: .Height = 51: .Width = 225
.BackStyle = fmBackStyleTransparent
.IntegralHeight = True
.Locked = True
.MultiLine = True
.WordWrap = False
.SelectionMargin = False
.ScrollBars = fmScrollBarsVertical
.SpecialEffect = fmSpecialEffectSunken
.TextAlign = fmTextAlignLeft
End With
Me.Height = 140.25: Me.Width = 232.5
End Sub
標準モジュールでのデモ
Sub デモ()
Dim PV As New UserForm1, i As Long, j As Long
PV.Reset , , 50
PV.Title = "処理の準備をしています..."
PV.WriteLog "最大値を算出中..."
PV.Marquee1 = True '最大値不定なのでマーキーモードで探る
For i = 1 To &H100000
If PV.Updated1 Then PV.WriteLog "最大値を算出中... " & i, , True
PV.Max1 = i
Next
PV.Title = "処理を実行中..."
PV.Marquee1 = False
PV.Reset &H10, &H100000, 200, , 1 '最大値確定したので本処理開始
For i = 1 To &H10
For j = 1 To &H100000
PV.Value2 = j
If PV.IsCanceled Then
PV.WriteLog "処理が中断されました", True
Exit For
End If
Next
If PV.IsCanceled Then Exit For
PV.Value1 = i
PV.WriteLog i & "回目を処理完了", True
Next
PV.ForceUpdate
If PV.IsCanceled Then
PV.WriteLog "途中で中断された為、処理が正常に完了していません", True
Else
PV.WriteLog "正常に処理が完了しました", True
End If
End Sub
（白茶） 2018/11/19(月) 21:58
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.