ExcelVBA ～ 指定した複数の図形を一斉に点滅させるプログラム
3つの図形（名前は図形01、図形02、図形03）のうち、A1:A3セルに書いた名前のものだけを一括点滅させます。
配列に、一括点滅させたい図形の名前を記録し、それをもとに一斉点滅をさせます。
図形は、グループ化したものでもOKです。
グループ化した図形をクリックすると、イミディエイトウィンドウで
「Selection.Name="××××"」でグループ化した図形にも名前を付けられます。
なぜか、名前がダブっても大丈夫なので、もしかしたら
「２つで１ペア」みたいな図形は、同じ名前を付けてもいいのかも？しれません。
試してませんが・・・。
●Sheet1のコマンドボタンのプログラム
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
' ' Option Explicit Private Sub CommandButton1_Click() ' Let v_Ary_Chair01() = Array("図形01", "図形02") Let i_Answ01 = 1 Call FlushShapsConfig01 Call ShapeFlash01(v_Ary_Chair01) End Sub Private Sub CommandButton2_Click() Call CharsFlashStop End Sub ' ' |
●標準モジュールのプログラム
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 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 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 |
' ' Option Explicit Public i_Answ01 As Integer '一応、「点滅してるよ」的なフラグを立てる。無意味かも。 Public v_Ary_Chair01() As Variant '図形の点滅に使います。どの図形を点滅させるべきか、図形の名前を複数、格納するための変数です。 '##################################################################################### '図形の点滅を停止する処理。 ' '「停止」ボタンにて。 ' '##################################################################################### Function CharsFlashStop() Let i_Answ01 = 0 '「点滅してるよ」的なフラグを寝かす。 ThisWorkbook.Save '一応上書き。 End Function '##################################################################################### '図形の点滅を、一定時間（ここでは0.5秒）ごとに繰り返す処理。 'Application.Wait [Now()] + wait_sec / 86400 'https://www.higashisalary.com/entry/vba-wait-ms '呼び出し方→ShapeFlash01(Array("図形34", "図形33")) '##################################################################################### Function ShapeFlash01(v_Ary_CharName01 As Variant) Dim o_WS01 As Worksheet Dim o_ConfWs01 As Worksheet Dim d_OldTime01 As Date ' Dim d_OldTime02 As Date Dim o_Shapes01 As ShapeRange Dim v_Ary_CharName02() As Variant Dim s_SecNum As String Set o_WS01 = Excel.Application. _ ThisWorkbook. _ Worksheets.Item("Sheet1") '↑ターゲットセルがあるワークシートの確定。 Let s_SecNum = "15" '↑何秒間点滅させるかの設定。 If v_Ary_CharName01(0) <> Empty Then 'v_Ary_CharName01の先頭の要素の中に、１つでも図形名があった場合の処理。 Let v_Ary_CharName02 = v_Ary_CharName01 '↑エラー回避のための処理。 ' 「v_Ary_CharName01をまんまで使う」だとなぜかエラーになってしまうので、 ' いったん、v_Ary_CharName02に格納し換えます。 ' それだけやって、次へ進みます。 Else 'v_Ary_CharName01(0) のなかに、図形名が１つも無かった場合の処理。 MsgBox "現在時間超過した図形はありません。" Exit Function 'このプログラムを中断します。 End If '↑チェック用 ' 対象となる席が一つも無いと、配列の中身が空なためにここでエラーになってしまうので、 ' そのエラー回避。 '' Let o_ConfWs01.Range("K1") = 1 ' Let i_FlushFlg01 = 1 ' '「点滅中」を表すフラグを有効にする。役立たずかも。 Let d_OldTime01 = Now '↑今現在の時間を取得。 Set o_Shapes01 = o_WS01.Shapes.Range(v_Ary_CharName02) '↑複数の図形を一括で点滅させられるように、 ' その複数の図形の名前たちで、その図形たちを決定設定。 Do Until d_OldTime01 + TimeValue("0:00:" & s_SecNum) < Now ' Do Until d_OldTime01 + TimeValue(ssss) < Now '↑「s_SecNum」で設定した秒数のあいだ、繰り返します。 DoEvents '「停止」ボタンが押せるようにする命令 If i_Answ01 = 1 Then '「点滅してるよ」的なフラグが立ってたら、 '何もしない。 ElseIf i_Answ01 = 0 Then '「点滅してるよ」的なフラグが立ってなかったら、 '以下の処理。 Let i_Answ01 = 1 '「点滅してるよ」的なフラグを立ててから Let o_Shapes01.Visible = True 'イスたちを可視にして、 Exit Function 'プログラムを中断。停止。 Else End If Call Application.Wait([Now() + "0:00:00.5"]) '０．５秒待つ If o_Shapes01.Visible = True Then Let o_Shapes01.Visible = False 'さっき一斉に見えてたなら、一斉に見えなくする。 ElseIf o_Shapes01.Visible = False Then Let o_Shapes01.Visible = True 'さっき一斉に見えてなかったなら、一斉に見えるようにする。 Else End If '↑イスたちを一斉に点滅させる。 ' Debug.Print Now DoEvents '再度、念のため、「停止」ボタンを押したり、 '他の事ができるようにする。 Loop Let o_Shapes01.Visible = True '↑最後、明示的に一括で表示。（消えたままだと困るので） Let i_Answ01 = 1 ''「点滅してるよ」的なフラグを立てる。無意味かも？ End Function '##################################################################################### 'https://vbabeginner.net/array-push/ のまんまパクり。 ' '配列の末尾に要素を追加していく処理。 ' '図形の一斉点滅に使います。 '一斉点滅させるための「図形の複数の名前を入れる配列」に、 '１つずつ図形の名前を追加していきます。 ' '##################################################################################### '// 終端に追加 '// 引数１：配列 '// 引数２：追加するデータ '// 戻り値：追加後の配列要素数（UBound関数結果） Function ArrayPush(ar As Variant, addValue As Variant) As Long '// 引数が配列でない場合 If IsArray(ar) = False Then '// 処理せず抜ける Exit Function End If '// 配列要素数を取得 Dim iSize As Long '// 配列サイズ '// 配列サイズを拡張後のサイズで取得 iSize = UBound(ar) + 1 '// 拡張 ReDim Preserve ar(iSize) Dim i As Long '// ループカウンタ '// オブジェクト型変数の場合 If IsObject(ar(0)) = True Then '// 終端に現在ループ値を設定 Set ar(iSize) = addValue '// プリミティブ型変数（IntegerやStringなど）の場合 Else '// 終端に現在ループ値を設定 ar(iSize) = addValue End If '// 要素数を返却 ArrayPush = UBound(ar) End Function '##################################################################################### 'https://vbabeginner.net/array-shift/ のまんまパクり。 ' '配列の先頭をカットする処理。 ' '図形の一斉点滅に使います。 '図形の名前を入れた配列の一番先頭の要素がゴミデータなので、それをカットします。 ' '##################################################################################### Function ArrayShift(ar As Variant) As Variant '// 引数が配列でない場合 If IsArray(ar) = False Then '// 処理せず抜ける Exit Function End If '// 配列要素数を取得 Dim iSize As Long '// 配列サイズ iSize = UBound(ar) '// 配列の先頭を戻り値として取得 '// オブジェクト型変数の場合 If IsObject(ar(0)) = True Then Set ArrayShift = ar(0) '// プリミティブ型変数（IntegerやStringなど）の場合 Else ArrayShift = ar(0) End If '// 配列にデータが複数ない場合 If iSize = 0 Then '// 配列をクリア（先頭データを削除）して処理を抜ける ReDim ar(0) Exit Function End If Dim i As Long '// ループカウンタ '// 配列要素数ループ（２番目の要素から処理する） For i = 1 To iSize '// オブジェクト型変数の場合 If IsObject(ar(i)) = True Then '// １つ前の要素に現在ループ値を設定 Set ar(i - 1) = ar(i) '// プリミティブ型変数（IntegerやStringなど）の場合 Else '// １つ前の要素に現在ループ値を設定 ar(i - 1) = ar(i) End If Next '// 終端の要素を削除 ReDim Preserve ar(UBound(ar) - 1) End Function '##################################################################################### ' '一斉点滅させたい、複数の図形を指定する処理 ' '##################################################################################### Function FlushShapsConfig01() Dim o_SrcWS01 As Worksheet Dim l_xlLastRow As Long Dim l_LastRow As Long Dim i_RowCnt01 As Integer Set o_SrcWS01 = ThisWorkbook.Worksheets.Item("Sheet1") 'データもとのシートを、「作業シート」に設定。 Let l_xlLastRow = Cells(Rows.Count, 1).Row 'Excelの最終行を取得 '最終行はどのシートでも同じなので、「o_SrcWS01.」は不要。 ReDim v_Ary_Chair01(0) '↑★★ のちの、「Call ArrayPush(v_Ary_Chair01, o_SrcWS01.Cells(i_RowCnt01, "A").Value)」のための準備。 ' ★★ つまり、席の名前を配列に入れるための準備。 Let l_LastRow = o_SrcWS01.Cells(l_xlLastRow, "A").End(xlUp).Row 'A列の、現在の最終行の取得。 For i_RowCnt01 = 1 To l_LastRow '今のところ、l_LastRowの行数分繰り返す。 Call ArrayPush(v_Ary_Chair01, o_SrcWS01.Cells(i_RowCnt01, "A").Value) '↑一斉点滅させたい図形の名前をセルから配列に１つずつ足していく。 Next i_RowCnt01 '次の図形用の行へ移動。 Call ArrayShift(v_Ary_Chair01) '配列の先頭をカットする処理。 '図形の一斉点滅に使います。 '一斉点滅させたい図形の名前を入れた配列の一番先頭の要素がゴミデータなので、それをカットします。 End Function ' ' |
