動かした文字をスーっと消してみる。 - Infomentのブログ～Excel VBA奮闘記～

昨日は、以下を実現するクラスモジュールの作成に挑戦した。

セル内の文字列を転記したテキストボックスを作成
同テキストボックスを指定セルまで移動
移動先のセルに同テキストボックスの文字列を転記

infoment.hatenablog.com

そこで今日は、動かした文字をスーっと消してみることに挑戦する。
f:id:Infoment:20181208183102p:plain

スーっと消したように見せるために、今回は色を段階的に変えることにする。
文字色を黒に限定することになるが、RGB関数を用いて以下のようにする。
※「ｉ」は変数

位置	RGB関数	色
始点	RGB(0,0,0)	黒色
途中	RGB(i,i,i)	灰色
終点	RGB(255,255,255)	白色

これで「ｉ」を0～255で段階的に動かせば、文字色も黒から白へ段階的に変化し、あたかもスーッと消えたように見えはしないか？と考えた。
消すか消さないかは、引数で選択可能なようにする。

クラスモジュール（TextBoxClass）

Public Sub MovingTextBox(Optional fade_out_flag As Boolean = False)
    '一回の移動を細分化する回数。
    Dim iMax As Long: iMax = 200
    ' 移動の始点。
    Dim x1 As Double: x1 = myTextBox.Left
    Dim y1 As Double: y1 = myTextBox.Top
    ' 移動の終点。
    Dim x2 As Double: x2 = DestinationCell.Left
    Dim y2 As Double: y2 = DestinationCell.Top
    ' 細分化した一回の移動距離。
    Dim dx As Double: dx = (x2 - x1) / iMax
    Dim dy As Double: dy = (y2 - y1) / iMax
    
    Dim color_index As Integer
    
    Dim i As Long
        For i = 1 To iMax
            myTextBox.Left = myTextBox.Left + dx
            myTextBox.Top = myTextBox.Top + dy
            
            If fade_out_flag = True Then
                color_index = 255 * (1 - i) / (1 - iMax)
                Debug.Print color_index
                
                myTextBox.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = _
                    RGB(color_index, color_index, color_index)
            End If
            Application.Wait [now()+"0:00:00.001"]
        Next
End Sub

試してみると、こんな感じになった。
f:id:Infoment:20181208184804g:plain
なかなかいい感じだ。

次に、移動する文字を指定できるようにしてみた。実際には、動かす文字を何文字目からか指定できるようにする。

Public OriginalCharacter As String

Public Sub CellToTextbox(Optional moving_character_start_position As Long = 1)
        If TargetRange = "" Then Exit Sub
        OriginalCharacter = TargetRange.Value
    
    Dim RemainingCharacter As String
    Dim MovingCharacter As String
    Select Case moving_character_start_position
        Case 1
            RemainingCharacter = ""
            MovingCharacter = OriginalCharacter
        Case Is > Len(OriginalCharacter)
            RemainingCharacter = OriginalCharacter
            MovingCharacter = ""
        Case Else
            RemainingCharacter = Left(OriginalCharacter, moving_character_start_position - 1)
            MovingCharacter = WorksheetFunction.Rept("　", Len(RemainingCharacter)) & _
                              Mid(OriginalCharacter, moving_character_start_position)
    End Select
    
    Set myTextBox = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _
                                                myLeft, myTop, myWidth, myHeight)
        myTextBox.TextFrame2.TextRange.Characters.Text = MovingCharacter
        TargetRange.Value = RemainingCharacter
        myTextBox.TextFrame2.TextRange.Font.NameComplexScript = TargetRange.Font.Name
        myTextBox.TextFrame2.TextRange.Font.NameFarEast = TargetRange.Font.Name
        myTextBox.TextFrame2.TextRange.Font.Name = TargetRange.Font.Name
        myTextBox.TextFrame2.TextRange.Font.Size = TargetRange.Font.Size
        myTextBox.TextFrame2.VerticalAnchor = msoAnchorMiddle
        myTextBox.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignLeft
        myTextBox.TextFrame2.MarginLeft = 1.5
        myTextBox.Line.Visible = msoFalse
        myTextBox.Fill.Visible = msoFalse
End Sub