VBA技術解説
VBAで電光掲示板を作成

ExcelマクロVBAの問題点と解決策、VBAの技術的解説
最終更新日:2020-03-08

VBAで電光掲示板を作成


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


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

VBA マクロ 電光掲示板

東雲フォントについて

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

詳細については、以下を参照してください。
上記ページでは、著者さんが用意してくれたGitHubページからファイルをダウンロード出来ます。

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

東雲フォントの追加説明

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

VBA マクロ 電光掲示板

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

VBA マクロ 電光掲示板

この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の実行結果は、

VBA マクロ 電光掲示板

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

電光掲示板のシート構成

VBA マクロ 電光掲示板

シートおよびセル位置は問いません、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 マクロ 電光掲示板

VBA マクロ 電光掲示板

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

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

DisplayBoard1,2
電光掲示板に表示できる配列を作成
 文字列をドットパターンの配列にする

上の配列から電光掲示板に表示する配列に変換
 呼び出されるたびに位置を1つずつずらします。
 ここが表示パターンで処理内容が変わります。

電光掲示板へ出力

Application.OnTimeで自身を呼び出しています。

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

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

VBA マクロ 電光掲示板

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

VBA マクロ 電光掲示板

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

VBA マクロ 電光掲示板

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

VBA マクロ 電光掲示板

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

VBA マクロ 電光掲示板

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

VBA マクロ 電光掲示板

VBAで電光掲示板を作成の最後に

さすがに、実際に電光掲示板として使う人はいないと思います。
文字のドットパターンの処理や、1次元配列、2次元配列、ジャグ配列、
これらの使い方の参考にしてください。
また、
Application.OnTime、Sleep、DoEvents
これらを使って、よりスムーズに表示できるように工夫するといった所も参考になるかと思います。
ただし、この部分については正解というものは難しく、動作環境にある程度合わせる必要も出てくると思います。



同じテーマ「マクロVBA技術解説」の記事

VBAで写真の撮影日時や音楽動画の長さを取得する
VBAでWindowsMediaPlayerを使い動画再生する
VBAでWEBカメラ操作する
VBAで電光掲示板を作成
ユーザーに絶対に停止させたくない場合のVBA設定
列幅・行高をDPI取得しピクセルで指定する
VBAでWMIの使い方について
アクティブシート以外のWindowを設定できるWorksheetView
LSetとユーザー定義型のコピー(100桁の足し算)
省略可能なVariant引数の参照不可をラップ関数で利用
ブックのいろいろな開き方(GetObject,参照設定,アドイン)


新着記事NEW ・・・新着記事一覧を見る

VBA100本ノック 18本目:名前定義の削除|VBA練習問題100(11月6日)
VBA100本ノック 17本目:重複削除(ユニーク化)|VBA練習問題100(11月6日)
VBA100本ノック 16本目:無駄な改行を削除|VBA練習問題100(11月5日)
VBA100本ノック 15本目:シートの並べ替え|VBA練習問題100(11月4日)
VBA100本ノック 14本目:社外秘シート削除|VBA練習問題100(11月3日)
VBA100本ノック 13本目:文字列の部分フォント|VBA練習問題100(11月1日)
VBA100本ノック 12本目:セル結合を解除|VBA練習問題100(10月31日)
VBA100本ノック 11本目:セル結合の警告|VBA練習問題100(10月30日)
VBA100本ノック 10本目:行の削除|VBA練習問題100(10月29日)
VBA100本ノック 9本目:フィルターコピー|VBA練習問題100(10月28日)


アクセスランキング ・・・ ランキング一覧を見る

1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.変数宣言のDimとデータ型|VBA入門
4.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
5.マクロって何?VBAって何?|VBA入門
6.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
7.繰り返し処理(For Next)|VBA入門
8.セルに文字を入れるとは(Range,Value)|VBA入門
9.とにかく書いてみよう(Sub,End Sub)|VBA入門
10.マクロはどこに書くの(VBEの起動)|VBA入門




このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。


記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。



このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
本文下部へ