● スタッフロールもどきを作成する ●
物を動かす時には裏画面を使おう。ありゃ、ドキュメントタイトルと画像のタイトルがあってないねぇ。まあ、いいや。

文字列が下から上へ流れる。文字列は構造体配列の一番下から順に格納する。詳しいやり方はソースを読んでね。あと背景に星を流してあげると綺麗かもね。今回は標準モジュールのコーディングがちょっと多いかな。 

  Private Type Size
      cx As Long
      cy As Long
  End Type

  Private Type RECT
       Left As Long
       Top As Long
       Right As Long
       Bottom As Long
  End Type
'ビットマップを転送する
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

'文字サイズを得る
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size) As Long

'テキストを描画する
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long

Private Const DT_CENTER = &H1 '水平方向に中央揃え
Private Const DT_VCENTER = &H4 '垂直方向に中央揃え(単一行の時のみ)
Private Const DT_SINGLELINE = &H20 '単一行表示

'文字列サイズをバイト単位で取得する
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long 

'描画用オリジナル構造体
Private Type DrawTextInfo
    xPos As Long            '描画Ｘ位置
    yPos As Long            '描画Ｙ位置
    DrawText As String      '描画テキスト
    TextColor As Long       'テキスト文字色
    TextUnder As Boolean    'テキスト下線付き
End Type
Public udtDRT() As DrawTextInfo

Private RollDataArray(30) As String
Private StrHeight As Long   '文字の高さ

'---------------------------------------------------------------------------
' 関数名 ： AppInitialize
' 機  能 ： 初期化する
' 引  数 ： (in)SrcForm … メイン画面用フォーム
' 返り値 ： なし
' 備  考 ： １回だけ呼べばよろしい
'---------------------------------------------------------------------------
Public Sub AppInitialize(ByVal SrcForm As Form)
    Dim i As Long
    Dim udtSize As Size

    '文字の高さを取得
    Call GetTextExtentPoint32(SrcForm.hdc, "A", 1, udtSize)
    
    '外部変数に設定
    StrHeight = udtSize.cy

    '高さ分ループし、画面に表示できる行数を取得する
    For i = 0 To 200
        If i * StrHeight > SrcForm.ScaleHeight Then Exit For
    Next i
    
    '描画文字列構造体に表示行分のサイズを確保する
    '+2 は気持ち(起動時２行分表示を遅らせる)
    ReDim udtDRT(i + 2) As DrawTextInfo
    
    '一番最後の要素(目に見えて表示される文字列としては１番目)に
    '１行の文字列の高さを設定する
    udtDRT(UBound(udtDRT)).yPos = StrHeight
    
    '0：タイトル   1：データ    9：１行空き
    RollDataArray(0) = "0,George Gershwin"
    RollDataArray(1) = "1,I Got Rhythm"
    RollDataArray(2) = "1,Blue Monday"
    RollDataArray(3) = "1,Liza"
    RollDataArray(4) = "1,How Long Has This Been Going On?"
    RollDataArray(5) = "9"
    RollDataArray(6) = "0,Irving Berlin"
    RollDataArray(7) = "1,Cheek To Cheek"
    RollDataArray(8) = "1,White Christmas"
    RollDataArray(9) = "1,Alexander's Ragtime Band"
    RollDataArray(10) = "9"
    RollDataArray(11) = "0,Scott Joplin"
    RollDataArray(12) = "1,The Entertainer"
    RollDataArray(13) = "1,Weeping Willow Rag"
    RollDataArray(14) = "1,Bethena"
    RollDataArray(15) = "1,Maple Leaf Rag"
    RollDataArray(16) = "1,Heliotrope Bouquet"
    
    '１行空きは最後のインデックス + udtDRTの要素数は欲しいね
    RollDataArray(17) = "9"
    RollDataArray(18) = "9"
    RollDataArray(19) = "9"
    RollDataArray(20) = "9"
    RollDataArray(21) = "9"
    RollDataArray(22) = "9"
    RollDataArray(23) = "9"
    RollDataArray(24) = "9"
    RollDataArray(25) = "9"
    RollDataArray(26) = "9"
    RollDataArray(27) = "9"
    RollDataArray(28) = "9"
    RollDataArray(29) = "9"
    RollDataArray(30) = "9"
End Sub

'---------------------------------------------------------------------------
' 関数名 ： DrawLineText
' 機  能 ： DrawTextInfo 構造体の文字列情報を描画する
' 引  数 ： (in)SrcForm … メイン画面用フォーム
'           (in)picBackScreen … 裏画面用ピクチャーボックス
' 返り値 ： なし
'---------------------------------------------------------------------------
Public Sub DrawLineText(ByVal SrcForm As Form, ByVal picBackScreen As PictureBox)
    Static yPos As Long           '１行あたりの描画Ｙ位置
    Static LineCounter As Long    '行カウンター
    Dim udtRect As RECT
    Dim i As Long

    yPos = IIf(yPos = 0, StrHeight, yPos - 1)

    '描画Ｙ位置が一番下である
    If yPos = StrHeight Then
        '行カウンターが行文字列配列数を超えていない場合は
        '新たに描画する文字列を設定
        If LineCounter < UBound(RollDataArray) Then
            Call SetDrawTextData(LineCounter)
            LineCounter = LineCounter + 1
        '行カウンターが行文字列配列数を超えていたら初期化
        Else
            LineCounter = 0
        End If
    End If

    With udtRect
        .Left = 0
        .Right = SrcForm.ScaleWidth
    End With

    '行描画構造体データを列単位に編集・描画
    For i = UBound(udtDRT) To 1 Step -1
        '描画位置を設定する
        With udtRect
            .Top = (i - 1) * StrHeight - (StrHeight - yPos)
            .Bottom = i * StrHeight - (StrHeight - yPos)
        End With

        'ピクチャーボックスのプロパティ設定
        picBackScreen.ForeColor = udtDRT(i).TextColor
        picBackScreen.FontUnderline = udtDRT(i).TextUnder
        
        'テキストを描画する
        Call DrawText(picBackScreen.hdc, udtDRT(i).DrawText, lstrlen(udtDRT(i).DrawText), _
                      udtRect, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE)
    Next i
    
    '描画位置を１ピクセル上げる
    yPos = yPos - 1
End Sub

'---------------------------------------------------------------------------
' 関数名 ： SetDrawTextData
' 機  能 ： 描画文字列構造体に文字列情報を設定する
' 引  数 ： (in)DrawLine … 表示されている最大行数
' 返り値 ： なし
'---------------------------------------------------------------------------
Private Sub SetDrawTextData(ByVal DrawLine As Long)
  Dim i As Long
  Dim DrawScreenText As String
  
  '文字列情報を１行上にスライドさせる
  For i = 0 To UBound(udtDRT) - 1
      With udtDRT(i)
          .DrawText = udtDRT(i + 1).DrawText
          .TextColor = udtDRT(i + 1).TextColor
          .TextUnder = udtDRT(i + 1).TextUnder
          .xPos = udtDRT(i + 1).xPos
          .yPos = StrHeight * i
      End With
  Next i

  '一番下の要素に新たな文字列情報を設定する
  With udtDRT(UBound(udtDRT))
      '該当行文字列を取得
      DrawScreenText = RollDataArray(DrawLine)

      '文字列設定(この辺は個人仕様)
      .DrawText = Mid$(DrawScreenText, 3)
      '左の１文字が"0"である → 文字色：白、下線：あり
      '左の１文字が"0"でない → 文字色：水色
      .TextColor = IIf(Left$(DrawScreenText, 1) = "0", vbWhite, RGB(0, 255, 255))
      .TextUnder = IIf(Left$(DrawScreenText, 1) = "0", True, False)
  End With
d Sub

'---------------------------------------------------------------------------
' 関数名 ： DrawScreen
' 機  能 ： 裏画面をメイン画面に描画する
' 引  数 ： (in)SrcForm … メイン画面用フォーム
'           (in)picBackScreen … 裏画面用ピクチャーボックス
' 返り値 ： なし
'---------------------------------------------------------------------------
Public Sub DrawScreen(ByVal SrcForm As Form, ByVal picBackScreen As PictureBox)
    picBackScreen.Refresh '裏画面再描画
    Call BitBlt(SrcForm.hdc, 0, 0, SrcForm.ScaleWidth, SrcForm.ScaleHeight, _
                picBackScreen.hdc, 0, 0, vbSrcCopy)
    SrcForm.Refresh       'メイン画面再描画
    picBackScreen.Cls     '裏画面消去
End Sub
標準モジュールはこれで終わり。あとはフォームにピクチャーボックス(名前：picBackScreen)とタイマー(名前：Timer1)を貼り付けて、以下のコードを書けばよい。 
Private Sub Form_Load()
    With Me
        .ScaleMode = vbPixels
        .AutoRedraw = True
        .BackColor = vbBlack
        .FontSize = 16

        .Width = 300 * Screen.TwipsPerPixelX
        .Height = 200 * Screen.TwipsPerPixelY '+ .Height - .ScaleHeight * Screen.TwipsPerPixelY
    End With

    With picBackScreen
        .ScaleMode = vbPixels
        .BorderStyle = 1
        .AutoRedraw = True
        .Visible = False
        .BackColor = vbBlack
        .ForeColor = vbWhite
        .Left = 0: .Top = 0
        .Width = Me.ScaleWidth
        .Height = Me.ScaleHeight
    End With

    '初期化
    Call AppInitialize(Me)

    With Timer1
        .Interval = 70
        .Enabled = True
    End With
End Sub

Private Sub Timer1_Timer()
    Call DrawLineText(Me, picBackScreen)
    Call DrawScreen(Me, picBackScreen)
End Sub
戻る