VBAで電光掲示板を作成

公開日：2020-03-08　最終更新日：2020-03-08

VBAで電光掲示板を作成

VBAで電光掲示板っぽいものを作成しました。
方眼紙エクセルのセルをドットとしてフォントを表示し、それを移動させています。

電光掲示板をVBAで作っても使い道があるとは思えませんが、
他に転用できる内容としては、東雲フォントのドットパターンを使い、1ドットを１セルで文字を表示するところでしょう。
VBAの技術的には、
1次元配列、2次元配列、ジャグ配列、そして、Application.OnTimeを使用しています。

東雲フォントについて

フリーの日本語漢字ビットマップフォントです。
ファイルがテキストエディタで開くことができ、今回のような目的で使うにはとても便利です。

詳細については、以下を参照してください。

日本語漢字ビットマップフォント、東雲フォントについて

上記ページでは、著者さんが用意してくれたGitHubページからファイルをダウンロード出来ます。

https://github.com/mgo-tec/SDcard_sample_filses
↓
https://github.com/mgo-tec/SDcard_sample_filses/tree/master/font

以下のVBAでは、
shnmk16.bdf
こちらを使用しました。
以下のVBAは、フォントサイズを16*16固定で作成しています。
この16は、Constで定義しました。
とはいえ、これを変更するとなるといろいろ問題があると思います。

東雲フォントの追加説明

ダウンロードした東雲フォント(shnmk16.bdf)をメモ帳で開くと、

スクロールして下に進むと、各文字のBITMAPパターンが出てきます。

このbdfの見方は、先のページに詳しく書かれていますので、参考にしてください。

16*16のフォントなので、
縦は16行あります。
そして、
0200
これは、上位2文字(02)と下位2文字(00)を2進数にして、
00000010 00000000
これがドットパターンになります。

追加説明としては、
STRATCHARが10進のJISコード
ENCODINGが16進のJISコード
VBAでは、JISコードは簡単に取得できないので、シートのCODE関数を使用しました。

東雲フォントをシートに取得するVBA


  
    
      Option Explicit


      Public Const ShtBitMap As String = "bitmap font"


      Public Sub BitMapFont2Sheet()

　　Dim strFile As String

　　strFile = Application.GetOpenFilename("BitMap Font,*.bdf")

　　If strFile = "False" Then Exit Sub

　　

　　Dim ws As Worksheet

　　Dim aryRec() As String

　　Set ws = Worksheets(ShtBitMap) 'シートはあるものとします

　　aryRec = GetFontArray(strFile)

　　Call Ary2Sheet(aryRec, ws)

End Sub


Private Function GetFontArray(ByVal strFile As String) As String()

　　Dim objFSO As New Scripting.FileSystemObject

　　Dim inTS As TextStream

　　Dim strRec As String

　　Dim aryRec() As String

　　Dim i As Long, j As Long

　　

　　Set inTS = objFSO.OpenTextFile(CStr(strFile), ForReading)

　　strRec = Replace(inTS.ReadAll, vbCrLf, vbLf) '念の為置換

　　GetFontArray = Split(strRec, vbLf)

　　

　　Set inTS = Nothing

　　Set objFSO = Nothing

End Function


Private Sub Ary2Sheet(ByRef aryRec() As String, ws As Worksheet)

　　Dim i As Long, col As Long

　　Dim ix As Long

　　Dim strSTARTCHAR As String, strENCODING As String

　　Dim isBITMAP As Boolean

　　

　　ws.Cells.Clear

　　ws.Cells.NumberFormat = "@"

　　i = 0

　　For ix = LBound(aryRec) To UBound(aryRec)

　　　　Select Case True

　　　　　　Case aryRec(ix) Like "STARTCHAR *"

　　　　　　　　strSTARTCHAR = Mid(aryRec(ix), 11)

　　　　　　Case aryRec(ix) Like "ENCODING *"

　　　　　　　　strENCODING = Mid(aryRec(ix), 10)

　　　　　　Case aryRec(ix) Like "ENDCHAR*"

　　　　　　　　isBITMAP = False

　　　　　　Case aryRec(ix) Like "BITMAP*"

　　　　　　　　i = i + 1

　　　　　　　　ws.Cells(i, 1) = strSTARTCHAR

　　　　　　　　ws.Cells(i, 2) = strENCODING

　　　　　　　　col = 3

　　　　　　　　isBITMAP = True

　　　　　　Case isBITMAP

　　　　　　　　ws.Cells(i, col) = aryRec(ix)

　　　　　　　　col = col + 1

　　　　End Select

　　Next

      End Sub

ロジックは難しくないので、特にコメントも記載しませんでした。
シートは、"bitmap font"で固定しています。
このBitMapFont2Sheetの実行結果は、

A列がSTRATCHAR、B列がENCODINGになります。
C列からがビットマップの行を横に展開しているので、R列まであります。
全部で、6879文字入っていました。

電光掲示板のシート構成

シートおよびセル位置は問いません、VBAは名前定義だけで作成しました。
電光掲示版の行列は、高さおよび幅は適当に設定して構いません。

電光掲示板の範囲には、条件付き書式として、
1なら緑色になるように設定します。
これにより、単にセルに1を入れるだけで緑色になる事を利用しています。

電光掲示板のVBA


  
    
      Option Explicit

      　　　　　　　　　　　　　　　　　　　　

      Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)


      Public Const FontSize As Long = 16

      Public Const ShtBitMap As String = "bitmap font"


      Public gStrSend As String　 '送信文字列

      Public gArySend As Variant　'送信文字列の表示用配列

      Public gBoardRange As Range '電光掲示板の横幅

      Public gBoardPos As Long　　'電光掲示板への表示位置

      Public gMargin As Long　　　'字間

      Public isStop As Boolean　　'終了フラグ


      Public Sub 停止()

      　　Application.Cursor = xlDefault

      　　isStop = True

      　　Application.Range("電光掲示板").Value = ""

      End Sub


      Public Sub 送信()

      　　Application.Cursor = xlWait

      　　Dim strSend As String

      　　'全角のみ対応

      　　gStrSend = StrConv(Application.Range("送信文言").Value, vbWide)

      　　

      　　Dim arySend As Variant

      　　arySend = GetFontArray(gStrSend)

      　　gArySend = Jag1ToJag2(arySend)

      　　

      　　Set gBoardRange = Application.Range("電光掲示板")

      　　gMargin = Application.Range("字間").Value

      　　isStop = False

      　　

      　　Select Case Application.Range("パターン").Value

      　　　　Case "パターン1"

      　　　　　　gBoardPos = gBoardRange.Columns.Count * -1

      　　　　　　Application.OnTime Now() + TimeSerial(0, 0, 0), "DisplayBoard1"

      　　　　Case "パターン2"

      　　　　　　gBoardPos = 0

      　　　　　　Application.OnTime Now() + TimeSerial(0, 0, 0), "DisplayBoard2"

      　　End Select

      End Sub


      '表示パターン1

      Private Sub DisplayBoard1()

      　　If isStop Then Exit Sub

      　　

      　　Dim iBoardRow As Long, iBoardCol As Long

      　　iBoardRow = gBoardRange.Rows.Count

      　　iBoardCol = gBoardRange.Columns.Count

      　　

      　　Dim i1 As Long, i2 As Long

      　　Dim myArray1 As Variant, myArray2 As Variant

      　　

      　　'電光掲示板に表示できる配列を作成

      　　myArray1 = CreateDispArray()

      　　

      　　'電光掲示板の表示用に配列から切り出し

      　　ReDim myArray2(1 To iBoardRow, 1 To iBoardCol)

      　　For i1 = 1 To UBound(myArray2, 1) 'Font縦

      　　　　For i2 = 1 To UBound(myArray2, 2) 'Font横

      　　　　　　If i2 + gBoardPos >= LBound(myArray1, 2) And _

      　　　　　　　 i2 + gBoardPos <= UBound(myArray1, 2) Then

      　　　　　　　　myArray2(i1, i2) = myArray1(i1, i2 + gBoardPos)

      　　　　　　End If

      　　　　　　If gBoardPos > 0 And i2 < gBoardPos Then

      　　　　　　　　If iBoardCol > UBound(myArray1, 2) Then

      　　　　　　　　　　If i2 <= UBound(myArray1, 2) Then

      　　　　　　　　　　　　myArray2(i1, iBoardCol - gBoardPos + i2) = myArray1(i1, i2)

      　　　　　　　　　　End If

      　　　　　　　　Else

      　　　　　　　　　　If UBound(myArray1, 2) - gBoardPos + i2 < UBound(myArray2, 2) Then

      　　　　　　　　　　　　myArray2(i1, UBound(myArray1, 2) - gBoardPos + i2) = myArray1(i1, i2)

      　　　　　　　　　　End If

      　　　　　　　　End If

      　　　　　　End If

      　　　　Next

      　　Next

      　　

      　　'電光掲示板へ出力

      　　gBoardRange.Offset(1, 1).Resize(UBound(myArray2, 1), _

      　　　　　　　　　　　　　　　　　　UBound(myArray2, 2)).Value = myArray2

      　　gBoardPos = gBoardPos + 1

      　　If gBoardPos > UBound(myArray1, 2) And _

      　　　 gBoardPos > iBoardCol Then

      　　　　gBoardPos = 0

      　　End If

      　　Sleep 10

      　　DoEvents

      　　Application.OnTime Now() + TimeSerial(0, 0, 0), "DisplayBoard1"

      End Sub


      '表示パターン2

      Private Sub DisplayBoard2()

      　　If isStop Then Exit Sub

      　　

      　　Dim iBoardRow As Long, iBoardCol As Long

      　　iBoardRow = gBoardRange.Rows.Count

      　　iBoardCol = gBoardRange.Columns.Count

      　　

      　　Dim i1 As Long, i2 As Long

      　　Dim myArray1 As Variant, myArray2 As Variant

      　　

      　　'電光掲示板に表示できる配列を作成

      　　myArray1 = CreateDispArray()

      　　

      　　'電光掲示板の表示用に、電光掲示板幅+文字列を必要回数繰り返し

      　　Dim i3 As Long, i4 As Long

      　　i1 = iBoardCol / UBound(myArray1, 2) + 1.5

      　　ReDim myArray2(1 To iBoardRow, _

      　　　　　　　　　 1 To iBoardCol + (UBound(myArray1, 2) * i1))

      　　For i2 = 1 To UBound(myArray1, 1) 'Font縦

      　　　　For i3 = 1 To UBound(myArray1, 2) 'Font横

      　　　　　　myArray2(i2, iBoardCol + i3) = myArray1(i2, i3)

      　　　　　　For i4 = 1 To i1 - 1

      　　　　　　　　myArray2(i2, _

      　　　　　　　　　　　　 iBoardCol + i3 + (UBound(myArray1, 2) * i4)) _

      　　　　　　　　　　　　 = myArray1(i2, i3)

      　　　　　　Next

      　　　　Next

      　　Next

      　　

      　　'電光掲示板の表示位置で配列を切り出す

      　　ReDim myArray1(1 To iBoardRow, 1 To iBoardCol)

      　　For i1 = 1 To UBound(myArray2, 1) '縦

      　　　　For i2 = 1 To gBoardRange.Columns.Count '横

      　　　　　　myArray1(i1, i2) = myArray2(i1, gBoardPos + i2)

      　　　　Next

      　　Next

      　　

      　　'電光掲示板へ出力

      　　gBoardRange.Offset(1, 1).Resize(UBound(myArray1, 1), _

      　　　　　　　　　　　　　　　　　　UBound(myArray1, 2)).Value = myArray1

      　　gBoardPos = gBoardPos + 1

      　　If gBoardPos > iBoardCol + (Len(gStrSend) * (FontSize + gMargin)) Then

      　　　　gBoardPos = gBoardPos - (Len(gStrSend) * (FontSize + gMargin))

      　　End If

      　　Sleep 10

      　　DoEvents

      　　Application.OnTime Now() + TimeSerial(0, 0, 0), "DisplayBoard2"

      End Sub


      '電光掲示板に表示できる配列を作成

      Private Function CreateDispArray() As Variant

      　　Dim iBoardRow As Long

      　　iBoardRow = gBoardRange.Rows.Count


      　　Dim i1 As Long, i2 As Long, i3 As Long

      　　Dim iOf As Long

      　　Dim myArray1 As Variant

      　　ReDim myArray1(1 To iBoardRow, 1 To Len(gStrSend) * (FontSize + gMargin))

      　　For i1 = LBound(gArySend) To UBound(gArySend) '文字ごとJag配列

      　　　　For i2 = 1 To FontSize 'Font縦

      　　　　　　For i3 = 1 To FontSize 'Font横

      　　　　　　　　myArray1(i2, i3 + iOf) = gArySend(i1)(i2, i3)

      　　　　　　Next

      　　　　Next

      　　　　iOf = iOf + FontSize + gMargin

      　　Next

      　　CreateDispArray = myArray1

      End Function


      '文字列から文字コードのBitMap Fontの配列へ

      Private Function GetFontArray(ByVal sCode As String) As Variant

      　　Dim sTemp As String

      　　Dim i As Long

      　　Dim aryBitMap()

      　　

      　　ReDim aryBitMap(1 To Len(sCode))

      　　For i = 1 To Len(sCode)

      　　　　sTemp = Mid(sCode, i, 1)

      　　　　sTemp = Evaluate("CODE(""" & sTemp & """)")

      　　　　aryBitMap(i) = GetBitMapArray(sTemp)

      　　Next

      　　GetFontArray = aryBitMap

      End Function


      '文字コードからBitMap Fontの配列を取得

      Private Function GetBitMapArray(ByVal sCode1 As String) As String()

      　　On Error Resume Next

      　　Dim ws As Worksheet

      　　Set ws = Worksheets(ShtBitMap)

      　　

      　　Dim rtnArray() As String

      　　ReDim rtnArray(1 To FontSize)

      　　

      　　Dim i As Long, j As Long

      　　i = WorksheetFunction.Match(sCode1, ws.Columns(2), 0)
　　If Err Then

　　　　i = 1 'フォントがない文字は先頭の空白文字にする

　　End If

      　　

      　　Dim sTemp As String, aryTemp() As String

      　　For j = 1 To FontSize

      　　　　sTemp = ws.Cells(i, j + 2)

      　　　　sTemp = WorksheetFunction.Hex2Bin(Left(sTemp, 2), 8) & _

      　　　　　　　　WorksheetFunction.Hex2Bin(Right(sTemp, 2), 8)

      　　　　rtnArray(j) = sTemp

      　　Next

      　　GetBitMapArray = rtnArray

      End Function


      'Jag配列内の2進数(00101010)を1文字ずつの配列(0,0,1,0,1,0,1,0)にする

      Private Function Jag1ToJag2(ByRef argAry As Variant) As Variant

      　　Dim rtnAry() As Variant

      　　ReDim rtnAry(LBound(argAry) To UBound(argAry))

      　　Dim tmpAry(1 To FontSize, 1 To FontSize) As Variant

      　　Dim i1 As Long, i2 As Long, i3 As Long

      　　For i1 = LBound(argAry) To UBound(argAry)

      　　　　For i2 = 1 To FontSize

      　　　　　　For i3 = 1 To Len(argAry(i1)(i2))

      　　　　　　　　tmpAry(i2, i3) = Mid(argAry(i1)(i2), i3, 1)

      　　　　　　　　If tmpAry(i2, i3) = "0" Then

      　　　　　　　　　　tmpAry(i2, i3) = ""

      　　　　　　　　End If

      　　　　　　Next

      　　　　Next

      　　　　rtnAry(i1) = tmpAry

      　　Next

      　　Jag1ToJag2 = rtnAry

      End Function

電光掲示板の表示パターン

コード量としては、シートに表示するパターンの書き分け部分が多くを占めています。
この表示パターンは、いろいろなパターンが考えられます。

文字列から電光掲示板に表示するまでのそれぞれの処理概要

送信

まず文字列を全角変換します。
東雲フォントは全角のみです。
VBA的には半角混在対応させることはできますが、16ドットなので全角だけで良いと思います。
Application.OnTimeで、実際の電光けて地盤への表示プロシージャーを起動しています。

DisplayBoard1,2

電光掲示板に表示できる配列を作成
　文字列をドットパターンの配列にする
↓
上の配列から電光掲示板に表示する配列に変換
　呼び出されるたびに位置を1つずつずらします。
　ここが表示パターンで処理内容が変わります。
↓
電光掲示板へ出力
↓
Application.OnTimeで自身を呼び出しています。

このプロシージャーは、かなり無理やりで作成しています。
文字列が左端まで行った後の動作について、なかなかうまく書けずに苦し紛れ力技で解決しました。
もっとすっきりVBAの書きようがあるように思います。
もしかしたら、1文字ずつ電光掲示板のセルに出力するように制御したほうが簡単かもしれませんね。

CreateDispArray

電光掲示板に表示できる配列を作成します。
ジャグ配列をシートに出力できるように2次元配列にして返します。

上のジャグ配列を下のように2次元配列に直して返します。

GetFontArray

文字列から、ドットパターンの配列を作成。
1文字ごとに、GetFontArrayを呼び出して1文字分の1次元配列を受け取り、
それを別の1次元配列に入れています。
いわゆるジャグ配列を作成しています。

GetBitMapArray

文字コードからフォントのドットパターンを配列で返します。

Jag1ToJag2

Jag配列内の2進数(00101010)を1文字ずつの配列(0,0,1,0,1,0,1,0)にします。

00101010→0,0,1,0,1,0,1,0
そして、0は表示に必要ないので消しています。