目安箱 IV

目安箱投稿のルールはこちらをごらんください。
ご意見は電子メールで承っています。
「目安箱」は質問禁止です。技術的な質問はそれぞれの質問箱へどうぞ。

迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

┃ ┃ ┃ ┃ ┃ ┃

146 / 277

←次へ　｜　前へ→

【143】テロップ

Jaka - 06/3/13(月) 11:23 -


	引用なし

	パスワード

お遊びですが、セル版テロップ。
（谷さん、ごめんなさい。）

気に食わない点を少々。
・文字数にあわせたセルのオートフィットの幅がビシっと決まらない。
・エクセルバージョンの違いで幅が違う。
・PCによってフォントが無い（他で代用される）から、余計に幅が決まらない。
・色の変化が解りづらい、にごって見える、残像が残る（数色の場合）。

（注意）
テロップの速度調整にAPIを使用していますから、
下記APIコードをモジュールの１番上に記載。
（全モジュール通して１個だけで良いです。）

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

***********************************************************
Sub テロップ流れ1_セル版()
　　Dim st1 As String, SP1 As String, TX1 As String, Flg As Boolean
　　Dim DefoFntIdx As Long, Defocol As Double, i As Long
　　Dim MAd　As String
　　
　　MAd = "B2"
　　st1 = "シート内容に注意！！"
　　SP1 = StrConv(Space(4), vbWide)　'間隔
　　
　　'文字を１回1回ループさせようと思ったが、最初に作っておくのが簡単。
　　For i = 1 To 6
　　　　TX1 = TX1 & st1 & SP1
　　Next

　　TX1 = TX1 & StrConv(Space(Int(Len(st1) \ 2)), vbWide)
　　With Range(MAd)
　　　　.Value = ""
　　　　If .Column > 1 Then
　　　　　 If .Offset(, -1).Formula = "" Then
　　　　　　　.Offset(, -1).Value = Space(1)
　　　　　　　Flg = True
　　　　　 End If
　　　　End If
　　　　DefoFntIdx = .Font.ColorIndex
　　　　Defocol = .ColumnWidth
　　　　With .Font
　　　　　　.ColorIndex = 2
　　　　　　.Name = "HG正楷書体-PRO"
　　　　　　'.FontStyle = "ﾒﾃﾞｨｳﾑ太字斜体" 'PCによって無い。2002
　　　　　　.Size = 20
　　　　　　.Bold = True
　　　　　　.Italic = True
　　　　End With
　　　　.HorizontalAlignment = xlRight
　　　　.Value = StrConv(Right(st1, Len(st1) - 4), vbWide)
　　　　.Columns.AutoFit
　　　　FitCol = .ColumnWidth
　　　　.ColumnWidth = FitCol
　　　　.Value = ""
　　　　.Font.ColorIndex = 3
　　　　
　　　　For i = 1 To Len(TX1)
　　　　　　.Value = .Value & Mid(TX1, i, 1)
　　　　　　Sleep 200
　　　　Next
　　　　
　　　　.ColumnWidth = Defocol
　　　　.Font.ColorIndex = DefoFntIdx
　　　　.ClearContents
　　　　If Flg Then
　　　　　.Offset(, -1).ClearContents
　　　　End If
　　End With
End Sub

*******************************************
Sub テロップ１色_セル版()
　　St1 = "お読みください！！"
　　SPS = 4
　　MAd = "B2"
　　With Range(MAd)
　　　　.Value = ""
　　　　DefoFntIdx = .Font.ColorIndex
　　　　Defocol = .ColumnWidth

　　　　With .Font
　　　　　　.ColorIndex = 2
　　　　　　.Name = "HG正楷書体-PRO"
　　　　　　'.FontStyle = "ﾒﾃﾞｨｳﾑ太字斜体" 'PCによって無い。2002
　　　　　　.Size = 20
　　　　　　.Bold = True
　　　　　　.Italic = True
　　　　　　.ColorIndex = 3
　　　　End With

　　　　.Value = StrConv(Space(Len(St1) + SPS - 1), vbWide) & "あ"
　　　　.Columns.AutoFit
　　　　FitCol = .ColumnWidth
　　　　.ColumnWidth = FitCol
　　　　.Value = ""
　　　　Tx1 = StrConv(Space(Len(St1) + SPS), vbWide)
　　　　.Value = Tx1
　　　　
　　　　For CC = 1 To 3
　　　　　　.Value = Left(Tx1, Len(Tx1) - 1) & Mid(St1, i + 1, 1)
　　　　　　For i = 1 To Len(St1)
　　　　　　　　Tx1 = Left(Tx1, Len(Tx1) - 1) & Mid(St1, i, 1)
　　　　　　　　.Value = Tx1
　　　　　　　　Sleep 200
　　　　　　　　For ii = Len(Tx1) To i Step -1
　　　　　　　　　　Tx1 = Left(Tx1, ii - 1) & Mid(St1, i, 1) & _
　　　　　　　　　　　　　StrConv(Space(Len(Tx1) - ii), vbWide)
　　　　　　　　　　.Value = Tx1
　　　　　　　　　　DoEvents
　　　　　　　　　　Sleep 20
　　　　　　　　Next
　　　　　　Next
　　　　　　Sleep 1200
　　　　Next
　　　　'フリッカー
　　　　For iii = 1 To 5
　　　　　　Sleep 400
　　　　　　.Value = ""
　　　　　　Sleep 400
　　　　　　.Value = Trim(Tx1)
　　　　Next
　　　　.ColumnWidth = Defocol
　　　　.Font.ColorIndex = DefoFntIdx
　　End With
End Sub

*******************************************
'1=黒、2=白、3=赤、4=黄緑、5=青、6=黄、7=ピンク、8=水色、9=茶、10=緑
'11=濃紺、12=黄土色、13=濃紫、16=灰色50%、54=紫、41=淡い青　紫は茶色に見える。
'33=スカイブルー、46=オレンジ

*******************************************
Sub テロップ数色_セル版()
　　Dim IroTb As Variant, ColorNo As Long, CLNo As Long, St1 As String
　　Dim Defocol As Double, Tx1 As String, CC As Long, i As Long
　　Dim SPS As Long, MAd As String
　　IroTb = Array(1, 3, 5, 7, 33, 4, 3, 1)
　　St1 = "お読みください！！"
　　SPS = 4
　　MAd = "B2"
　　With Range(MAd)
　　　　Defocol = .ColumnWidth
　　　　With .Font
　　　　　　.ColorIndex = 2
　　　　　　.Name = "HG正楷書体-PRO"
　　　　　　'.FontStyle = "ﾒﾃﾞｨｳﾑ太字斜体" 'PCによって無い。2002
　　　　　　.Bold = True
　　　　　　.Italic = True
　　　　End With
　　　　If Val(Application.Version) = 8 Then
　　　　　 .Value = StrConv(Space(Len(St1) + SPS - 1), vbWide) & "あ"
　　　　Else
　　　　　 .Value = StrConv(Space(Len(St1) + SPS - 1), vbWide)
　　　　End If
　　　　.Columns.AutoFit
　　　　FitCol = .ColumnWidth
　　　　.ColumnWidth = FitCol
　　　　.Value = ""
　　　　.Font.ColorIndex = xlAutomatic
　　　　Tx1 = StrConv(Space(Len(St1) + SPS), vbWide)
　　　　.Value = Tx1
　　　　For CC = 1 To UBound(IroTb) - 1 '3
　　　　　 .Value = Left(Tx1, Len(Tx1) - 1) & Mid(St1, i + 1, 1)
　　　　　 If i = Len(St1) + 1 Then
　　　　　　　CLNo = ColorNo - 1
　　　　　 End If
　　　　　 .Characters(Start:=Len(Tx1), Length:=1).Font.ColorIndex = IroTb(CLNo)
　　　　　 DoEvents
　　　　　 For i = 1 To Len(St1)
　　　　　　　 If ColorNo >= UBound(IroTb) Then
　　　　　　　　　ColorNo = 0
　　　　　　　 Else
　　　　　　　　　ColorNo = CC
　　　　　　　 End If
　　　　　　
　　　　　　　 Tx1 = Left(Tx1, Len(Tx1) - 1) & Mid(St1, i, 1)
　　　　　　　 .Value = Tx1
　　　　　　　 .Characters(Start:=Len(Tx1), Length:=1).Font.ColorIndex = IroTb(ColorNo)
　　　　　　　 Sleep 200 '150
　　　　　　
　　　　　　　 For ii = Len(Tx1) To i Step -1
　　　　　　　　　 Tx1 = Left(Tx1, ii - 1) & Mid(St1, i, 1) & _
　　　　　　　　　　　　 StrConv(Space(Len(Tx1) - ii), vbWide)
　　　　　　　　　 .Value = Tx1
　　　　　　　　　 .Characters(Start:=ii, Length:=1).Font.ColorIndex = IroTb(ColorNo)
　　　　　　　　　 DoEvents
　　　　　　　　　 Sleep 30　'ここで、テロップ速度調整。
　　　　　　　 Next
　　　　　 Next
　　　　　 Sleep 1200
　　　　Next
　　　　.ColumnWidth = Defocol
　　　　'フリッカー
　　　　For iii = 1 To 5
　　　　　　Sleep 400
　　　　　　.Value = ""
　　　　　　Sleep 400
　　　　　　.Value = Trim(Tx1)
　　　　Next
　　End With
End Sub

3,452 hits