Excel VBAでAmong Usのタスクっぽいプログレスバーを作ってみた

最近話題のゲーム、宇宙人狼こと『Among Us』。
このゲームが人気な点はやはりプレイヤー同士が疑い合い、疑心暗鬼になりながらもインポスター(人狼)を見つけ出すという人狼ゲームのおもしろさです。ただ、それ以上にこのゲームを魅力的にしたのは、そのゲーム内容とは真逆のイメージの”ポップ”なキャラクターや絵のタッチです。

そこで今回はそんな”可愛らしい”Among Usのキャラクターを拝借しExcel VBAのプログレスバーを作成してみました。作中では「タスク」と呼ばれる作業がありますがその中でも「ダウンロードタスク」をイメージして作成しています。

ただ、このプログレスバーはビジュアル面にステータスを全振りしたため基本的に作業処理は重くなるという致命的な欠陥を持っています。

効率UPさせるのがVBAの本来の目的なのに…

しかしながらこのプログレスバーには下記のようなさまざまな手法が潜んでいます。

・UserForm上でgif画像を動かす
・Excel VBAで音楽を鳴らす
・UserFormの[×]ボタンが押された時に条件分岐で処理を行う　　　　　　　
・処理にかかる時間を推測し、残り時間を表示する

Among Usに興味のある方もない方もExcel VBAのいくつかのテクニックが学べるはずので、「使えねえプログレスバーだな」と思わずに「こういう方法もあるのか！」と何かしら学べる点を見つけて何かしらのの知識を持って帰って頂けたらもらえたら幸いです。

1. Among Usのタスクっぽいプログレスバー
2. プログレスバーのコード
3. まとめ

Among Usのタスクっぽいプログレスバー

上記の動画を見れば今回作成した“Among Usのタスクっぽいプログレスバー”のシステムが理解できると思います。プログレスバーに使われている言語が英語なのは原作リスペクトのためです。~~(実はこのプログレスバーを作ったのが日本語訳がまだないAmong Us初期の頃だったためというのは内緒)~~

プログレスバーに使用している素材をはじめとしたExcelファイルは下記よりダウンロードできます。ダウンロード後、Excelファイルを開き、シート上にあるボタンを押せば動画のようなプログレスバーが表示されます。

AmongUs_ProgressBar (クリックでzipファイルダウンロード)

プログレスバーのコード

このプログレスバーはUserFormだけで全て完結しません。メインの処理を行なっている標準モジュール上でもいくつかの処理を書いておく必要があるので注意してください。

基本的には下記の「標準モジュールコード」に書かれている「何らかの処理」の部分を実際に行う処理にすればOKです。

またダウンロードしたExcelファイルでうまくいかない場合は下記コードをコピペして実行してみてください。UserFormについてもコントロールさえ存在していれば自動で大きさや位置を設定するようになっているので、下項目の画像を参考にUserFormを作成して下さい。(※この時、各コントロールの配置位置の前後は非常に重要なのでうまく並び替えてください)
　

標準モジュールコード

Option Explicit
Sub main()

    UserForm1.Show vbModeless

    Dim Percent As String
    Dim EstimatedTime As Double
    Dim EstimatedTime_msg As String
     
    Dim i As Long
    Dim j As Long
    Dim tmp_i As Long:          tmp_i = 1
    Dim cnt As Long:            cnt = 5000
    Dim tmp_time As Double:     tmp_time = Timer
    
    For i = 1 To cnt
    
     '何らかの処理 ---------------------------------------------------------
        For j = 1 To 100000
        
        Next j
     '----------------------------------------------------------------------
        
        If (Timer - tmp_time) > 1 Then
            EstimatedTime = (Timer - tmp_time) * (cnt - tmp_i) / (i - tmp_i)
            tmp_i = i
            tmp_time = Timer
            
            EstimatedTime_msg = "Estimated  Time：           " & _
                                Int(EstimatedTime / 3600) & "hr     " & _
                                Int(EstimatedTime / 60) Mod 60 & "m     " & _
                                Int(EstimatedTime) Mod 60 & "s"
                                
            UserForm1.Label2.Caption = EstimatedTime_msg
            
            With UserForm1.Label1
            If .Caption = "Running." Then
                .Caption = "Running.."
            ElseIf .Caption = "Running.." Then
                .Caption = "Running..."
            ElseIf .Caption = "Running..." Then
                .Caption = "Running."
            End If
            End With
            
        End If

        Percent = Str(Int(100 * (i / cnt))) & "%"
        UserForm1.Image2.Width = 300 * (i / cnt)
        
        UserForm1.Label3.Caption = Percent
        DoEvents
    Next i
    
    UserForm1.Tag = "True"
    
    Unload UserForm1

End Sub

Option Explicit

Sub main()

UserForm1.Show vbModeless

Dim Percent As String

Dim EstimatedTime As Double

Dim EstimatedTime_msg As String

Dim i As Long

Dim j As Long

Dim tmp_i As Long: tmp_i = 1

Dim cnt As Long: cnt = 5000

Dim tmp_time As Double: tmp_time = Timer

For i = 1 To cnt

'何らかの処理 ---------------------------------------------------------

For j = 1 To 100000

Next j

'----------------------------------------------------------------------

If (Timer - tmp_time) > 1 Then

EstimatedTime = (Timer - tmp_time) * (cnt - tmp_i) / (i - tmp_i)

tmp_i = i

tmp_time = Timer

EstimatedTime_msg = "Estimated Time： " & _

Int(EstimatedTime / 3600) & "hr " & _

Int(EstimatedTime / 60) Mod 60 & "m " & _

Int(EstimatedTime) Mod 60 & "s"

UserForm1.Label2.Caption = EstimatedTime_msg

With UserForm1.Label1

If .Caption = "Running." Then

.Caption = "Running.."

ElseIf .Caption = "Running.." Then

.Caption = "Running..."

ElseIf .Caption = "Running..." Then

.Caption = "Running."

End If

End With

End If

Percent = Str(Int(100 * (i / cnt))) & "%"

UserForm1.Image2.Width = 300 * (i / cnt)

UserForm1.Label3.Caption = Percent

DoEvents

Next i

UserForm1.Tag = "True"

Unload UserForm1

End Sub

UserFormコード

#If Win64 Then
    Private Declare PtrSafe Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
    (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _
     ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
#Else
    Private Declare Function mciSendString Lib "winmm" Alias "mciSendStringA" _
    (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _
     ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
#End If

Dim se1 As String
Dim se2 As String
Dim se3 As String
Dim html1 As String
Dim html2 As String
Dim gif1 As String
'-----------------------------------------------------------------------------------------------------
Private Sub UserForm_Initialize()

    Dim wbDir As String
    wbDir = ActiveWorkbook.Path

    se1 = wbDir & "\emergency_se.mp3"
    se2 = wbDir & "\completed_se.mp3"
    se3 = wbDir & "\close_se.mp3"
    html1 = wbDir & "\running.html"
    html2 = wbDir & "\emergency.html"
    gif1 = wbDir & "\bar.gif"
 
    With Me
        .Width = 400
        .Height = 200
        .Tag = "False"
        .Caption = "Task is Running"
        .BackColor = RGB(59, 99, 140)
    End With

    With Me.WebBrowser1
        .Left = -10
        .Top = -30
        .Width = Me.Width + 10
        .Height = 250
        .Navigate html1
    End With
    
    With Me.Frame1
        .Caption = ""
        .Left = 0
        .Top = 115
        .Width = Me.Width
        .Height = Me.Height - .Top
        .BackColor = RGB(59, 99, 140)
        .BorderStyle = fmBorderStyleNone
        .SpecialEffect = fmSpecialEffectFlat
    End With
    
    With Me.Frame2
        .Caption = ""
        .Left = 110
        .Top = 0
        .Width = 160
        .Height = 115
        .BackColor = RGB(59, 99, 140)
        .BorderStyle = fmBorderStyleNone
        .SpecialEffect = fmSpecialEffectFlat
    End With
    
    With Me.Image3
        .Picture = LoadPicture(gif1)
        .Left = 20
        .Top = 0
        .Width = 300
        .Height = 30
        .BorderStyle = fmBorderStyleNone
        .PictureSizeMode = fmPictureSizeModeStretch
        .BackStyle = fmBackStyleTransparent
    End With

    With Me.Image2
        .Left = 20
        .Top = 0
        .Width = 200
        .Height = 30
        .BackColor = RGB(50, 127, 1)
        .BorderStyle = fmBorderStyleNone
        .SpecialEffect = fmSpecialEffectFlat
    End With

    With Me.Image1
        .Left = 20
        .Top = 0
        .Width = 300
        .Height = 30
        .BackColor = RGB(255, 255, 255)
        .BorderStyle = fmBorderStyleNone
        .SpecialEffect = fmSpecialEffectFlat
    End With
    
    With Me.Label1
        .Top = 48
        .Left = 23
        .Width = 250
        .Height = 35
        .Caption = "Running..."
        .BackStyle = fmBackStyleTransparent
        .ForeColor = &HFFFFFF
        .Font = "Calibri"
        .Font.Size = 28
        .Font.Bold = True
    End With

    With Me.Label2
        .Top = 32
        .Left = 25
        .Width = 400
        .Height = 35
        .Caption = "Estimated  Time：           Being  calculated"
        .BackStyle = fmBackStyleTransparent
        .ForeColor = &HFFFFFF
        .Font = "Calibri"
        .Font.Size = 18
        .Font.Bold = True
    End With

    With Me.Label3
        .Top = -1
        .Left = 324
        .Width = 200
        .Height = 50
        .Caption = "100%"
        .BackStyle = fmBackStyleTransparent
        .ForeColor = &HFFFFFF
        .Font = "Calibri"
        .Font.Size = 24
        .Font.Bold = True
    End With
    
End Sub
'-----------------------------------------------------------------------------------------------------
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

    Dim i As Long

    If Me.Tag = "False" Then
        If CloseMode = vbFormControlMenu Then Cancel = True
        DoEvents
        With Me
            .Tag = "True"
            .Frame1.Visible = False
            .Frame2.Visible = False
            .WebBrowser1.Navigate html2
        End With
    
     'se1(emergency_se.mp3)を再生
        Call mciSendString("play " & se1, "", 0, 0)
        For i = 1 To 20000
            DoEvents
        Next i
        
        Cancel = False
        MsgBox "Forced Termination"
        
        End
        
    ElseIf Me.Tag = "True" Then
    
     'se2(completed_se.mp3)を再生
        Call mciSendString("play " & se2, "", 0, 0)
        For i = 1 To 3000
            DoEvents
        Next i
        
        With UserForm1.Label1
            .Caption = ""
            .Left = 16
        End With
        
        UserForm1.Label2.Caption = "Complete"
        
        For i = 1 To 10000
            DoEvents
        Next i
        
     'se3(close_se.mp3)を再生
        Call mciSendString("play " & se3, "", 0, 0)
        For i = 1 To 1000
            DoEvents
        Next i
        
        Cancel = False
    Else
        Cancel = False
    End If

End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

#If Win64 Then

Private Declare PtrSafe Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _

(ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _

ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

#Else

Private Declare Function mciSendString Lib "winmm" Alias "mciSendStringA" _

(ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _

ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

#End If

Dim se1 As String

Dim se2 As String

Dim se3 As String

Dim html1 As String

Dim html2 As String

Dim gif1 As String

'-----------------------------------------------------------------------------------------------------

Private Sub UserForm_Initialize()

Dim wbDir As String

wbDir = ActiveWorkbook.Path

se1 = wbDir & "\emergency_se.mp3"

se2 = wbDir & "\completed_se.mp3"

se3 = wbDir & "\close_se.mp3"

html1 = wbDir & "\running.html"

html2 = wbDir & "\emergency.html"

gif1 = wbDir & "\bar.gif"

With Me

.Width = 400

.Height = 200

.Tag = "False"

.Caption = "Task is Running"

.BackColor = RGB(59, 99, 140)

End With

With Me.WebBrowser1

.Left = -10

.Top = -30

.Width = Me.Width + 10

.Height = 250

.Navigate html1

End With

With Me.Frame1

.Caption = ""

.Left = 0

.Top = 115

.Width = Me.Width

.Height = Me.Height - .Top

.BackColor = RGB(59, 99, 140)

.BorderStyle = fmBorderStyleNone

.SpecialEffect = fmSpecialEffectFlat

End With

With Me.Frame2

.Caption = ""

.Left = 110

.Top = 0

.Width = 160

.Height = 115

.BackColor = RGB(59, 99, 140)

.BorderStyle = fmBorderStyleNone

.SpecialEffect = fmSpecialEffectFlat

End With

With Me.Image3

.Picture = LoadPicture(gif1)

.Left = 20

.Top = 0

.Width = 300

.Height = 30

.BorderStyle = fmBorderStyleNone

.PictureSizeMode = fmPictureSizeModeStretch

.BackStyle = fmBackStyleTransparent

End With

With Me.Image2

.Left = 20

.Top = 0

.Width = 200

.Height = 30

.BackColor = RGB(50, 127, 1)

.BorderStyle = fmBorderStyleNone

.SpecialEffect = fmSpecialEffectFlat

End With

With Me.Image1

.Left = 20

.Top = 0

.Width = 300

.Height = 30

.BackColor = RGB(255, 255, 255)

.BorderStyle = fmBorderStyleNone

.SpecialEffect = fmSpecialEffectFlat

End With

With Me.Label1

.Top = 48

.Left = 23

.Width = 250

.Height = 35

.Caption = "Running..."

.BackStyle = fmBackStyleTransparent

.ForeColor = &HFFFFFF

.Font = "Calibri"

.Font.Size = 28

.Font.Bold = True

End With

With Me.Label2

.Top = 32

.Left = 25

.Width = 400

.Height = 35

.Caption = "Estimated Time： Being calculated"

.BackStyle = fmBackStyleTransparent

.ForeColor = &HFFFFFF

.Font = "Calibri"

.Font.Size = 18

.Font.Bold = True

End With

With Me.Label3

.Top = -1

.Left = 324

.Width = 200

.Height = 50

.Caption = "100%"

.BackStyle = fmBackStyleTransparent

.ForeColor = &HFFFFFF

.Font = "Calibri"

.Font.Size = 24

.Font.Bold = True

End With

End Sub

'-----------------------------------------------------------------------------------------------------

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

Dim i As Long

If Me.Tag = "False" Then

If CloseMode = vbFormControlMenu Then Cancel = True

DoEvents

With Me

.Tag = "True"

.Frame1.Visible = False

.Frame2.Visible = False

.WebBrowser1.Navigate html2

End With

'se1(emergency_se.mp3)を再生

Call mciSendString("play " & se1, "", 0, 0)

For i = 1 To 20000

DoEvents

Next i

Cancel = False

MsgBox "Forced Termination"

End

ElseIf Me.Tag = "True" Then

'se2(completed_se.mp3)を再生

Call mciSendString("play " & se2, "", 0, 0)

For i = 1 To 3000

DoEvents

Next i

With UserForm1.Label1

.Caption = ""

.Left = 16

End With

UserForm1.Label2.Caption = "Complete"

For i = 1 To 10000

DoEvents

Next i

'se3(close_se.mp3)を再生

Call mciSendString("play " & se3, "", 0, 0)

For i = 1 To 1000

DoEvents

Next i

Cancel = False

Else

Cancel = False

End If

End Sub

まとめ

今回は「Among Usのタスクっぽいプログレスバー」の紹介でした。

コードについて深い解説はしていませんが読めば何をしているかは理解できると思います。
ここでは冒頭で言っていた手法の答えを簡単にまとめておきます。

・UserForm上でgif画像を動かす
→「WebBrowser」を使用 ※imageの場合はアニメーションが動かないため
　ただWebBrowserは必ず最前面に設置され全てのコントロールが隠れてしまう　　
　唯一「Frame」のみWebBrowserより前側に設置できるためうまく利用する

・Excel VBAで音楽を鳴らす
→ Windows API「mciSendString関数」を使用

・UserFormの[×]ボタンが押された時に条件分岐で処理を行う　　　　　
→ UserForm_QueryCloseイベントとTagプロパティを組み合わせる

・処理にかかる時間を推測し、残り時間を表示する
→ 現在の処理回数を全体の処理回数で割る
　(参考：【ExcelVBA】残りの処理時間と進捗をステータスバーに表示する方法)

2021年4月26日Excel, VBA