Results of 1 - 1 of about 37686 for IF (0.007 sec.)
- [[20181116181428]]
- #score: 1591
- @digest: fb66b722e2ca7fd32ef3dd564b9a1dd0
- @id: 77853
- @mdate: 2018-11-19T12:58:39Z
- @size: 41026
- @type: text/plain
- #keywords: textboxlog (97381), buttoncancel (84670), labelval1 (64439), property (61442), uptimems (58560), labelval2 (56447), bar2top (55646), myvalue2 (50279), myvalue1 (47640), 択if (38155), settimer (35202), 本目 (32383), fm (26563), statusbar (22291), image1 (17790), public (13653), listbox1 (12381), optional (11616), label (11087), msforms (9719), caption (9629), value2 (8751), 曜日 (8084), スバ (8051), controls (7658), title (7483), boolean (7443), 記元 (7368), doevents (7195), declare (6507), ト選 (6463), private (6421)
- 『（マクロ）
進捗状況をステータスバー表示マクロの組み込み方法』（マイン） お世話になっております。 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 ---- みそじのおじさん 様 BJ 様 すごいコードありがとうございます。 APIについてなのですが、残念ながら会社のセキュリティソフトに引っかかってしまい動作確認できませんでした(^_^;) UserFormのタイトルバーを消して、なおかつマウスドラッグをAPIで仕掛けて使っていたのですが、新しいウィルスソフトになって、ウイルス検出!!!とブラックリストに入れられて・・・何度も繰り返したのでシステム屋に問い合わせされてしまいました。 すみません、後学のために自宅Pcでひっそり試したいと思います。 本当にありがとうございます 解決とさせていただきます。 （マイン） 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 '2本目バーが表示されているかどうか 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 '1本目の最大値 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 '2本目の最大値 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 '1本目の現在の値 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 '2本目の現在の値 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 '1本目のマーキーモード 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 '2本目のマーキーモード 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 '2本目のバーが表示されている場合だけ実行 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() '2本目バーの表示/非表示切替 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 = "O K" 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
... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/201811/20181116181428.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97045 documents and 608224 words.
訪問者：