Visual Basic For Applications Air Gap Communication Module (VAC-Parasite)

VAC_Parasite.BAS

Attribute VB_Name = "VAC_Parasite"

' VBA AIRGAP COMMUNICATION (VAC-Parasite) MODULE - Color Shapes
' Created By: Laughing_Mantis 7.4.2020
' Version 1.0

' This will create a square in the top left of the document that will change colors
' in order to communicate via morse code via airgapped machines
' BLUE = .
' RED = -
' GREEN = "_"
' BLACK = " "
' WHITE = New Character

' Depending on your op you can change the following characteristics:
' speed of delay
' morse code to color values
' morse code index
' location of visual signal box





' Morse Code Tweaked from: https://www.rosettacode.org/wiki/Morse_code#VBA

#Const DBGMODE = True

Const SEIZUREWARNING = True

Const MORSE_ALPHA As String = ".-,-...,-.-.,-..,.,..-.,--.,....,..,.---,-.-,.-..,--,-.,---,.--.,--.-,.-.,...,-,..-,...-,.--,-..-,-.--,--.."
Const MORSE_NUMERIC As String = "-----,.----,..---,...--,....-,.....,-....,--...,---..,----."

Const DOT As Long = 16711680
Const DASH As Long = 255
Const UNDERSCORE As Long = 65280
Const CHARSPACE As Long = 0
Const NEWCHAR As Long = 16777215
Const PAUSE As Long = 16777215

Const DELAY As Long = 200


Sub Main()
Dim Message As String
Dim SendNewCharFlag As Boolean
Dim SquareSize As Single

If SEIZUREWARNING Then
    If DisplayWarning = 2 Then Exit Sub
End If

SquareSize = 25
SendNewCharFlag = True
Message = ToMorse("Laughing_Mantis")


#If DBGMODE = True Then
    DbgColors
    If SendNewCharFlag = True Then
        Debug.Print "Morse Message: " & Message
    Else
        Debug.Print "Morse Message: " & Replace(Message, "+", "")
    End If
#End If

PlayMorseShape Message, SendNewCharFlag, SquareSize

End Sub

Public Function DisplayWarning() As Long
Dim Message As String
Message = "WARNING: This demonstration may potentially trigger seizures for people with photosensitive epilepsy. Viewer discretion is advised"
DisplayWarning = MsgBox(Message, vbCritical + vbOKCancel, "Seizure Warning")
End Function

 
Public Function ToMorse(Message As String) As String
Dim MorseAlpha() As String
Dim MorseNumeric() As String
Dim MorseCode As String
Dim CharAtIndex As Integer
    MorseAlpha = Split(MORSE_ALPHA, ",")
    MorseNumeric = Split(MORSE_NUMERIC, ",")
    Message = UCase(Message)
    For X = 1 To Len(Message)
        CharAtIndex = Asc(Mid(Message, X, 1))
        Select Case CharAtIndex
            Case 65 To 90
                MorseCode = MorseCode & MorseAlpha(CharAtIndex - 65) & "+"
            Case 48 To 57
                MorseCode = MorseCode & MorseNumeric(CharAtIndex - 48) & "+"
            Case 32
                MorseCode = MorseCode & " " & "+"
            Case Else
                MorseCode = MorseCode & "_" & "+"
        End Select
    Next
    ToMorse = MorseCode
End Function
 
Public Sub PlayMorseShape(MorseCode As String, Optional NewChars As Boolean = True, Optional Size As Single = 25)
ActiveDocument.Shapes.AddShape msoShapeRectangle, 0, 0, Size, Size
ActiveDocument.Shapes(1).Line.Weight = 0
If NewChars = False Then
    MorseCode = Replace(MorseCode, "+", "")
End If
Dim X As Long
    For X = 1 To Len(MorseCode)
        Select Case Mid(MorseCode, X, 1)
             Case ".": ActiveDocument.Shapes(1).Fill.ForeColor.RGB = DOT
             Case "-": ActiveDocument.Shapes(1).Fill.ForeColor.RGB = DASH
             Case "_": ActiveDocument.Shapes(1).Fill.ForeColor.RGB = UNDERSCORE
             Case " ": ActiveDocument.Shapes(1).Fill.ForeColor.RGB = CHARSPACE
             Case "+": ActiveDocument.Shapes(1).Fill.ForeColor.RGB = NEWCHAR
             
        End Select
        Sleep (DELAY)
        ActiveDocument.Shapes(1).Fill.ForeColor.RGB = PAUSE
    Next
ActiveDocument.Shapes(1).Delete
End Sub

Public Sub PlayMorseScreen(MorseCode As String, Optional NewChars As Boolean = True, Optional Size As Single = 25)

Dim OriginalColor As Long

OriginalColor = ActiveDocument.Background.Fill.ForeColor.RGB

ActiveDocument.ActiveWindow.View.DisplayBackgrounds = True
ActiveDocument.Background.Fill.Visible = msoTrue
ActiveDocument.Background.Fill.Solid

If NewChars = False Then
    MorseCode = Replace(MorseCode, "+", "")
End If
Dim X As Long
    For X = 1 To Len(MorseCode)
        Select Case Mid(MorseCode, X, 1)
             Case ".": ActiveDocument.Background.Fill.ForeColor.RGB = DOT
             Case "-": ActiveDocument.Background.Fill.ForeColor.RGB = DASH
             Case "_": ActiveDocument.Background.Fill.ForeColor.RGB = UNDERSCORE
             Case " ": ActiveDocument.Background.Fill.ForeColor.RGB = CHARSPACE
             Case "+": ActiveDocument.Background.Fill.ForeColor.RGB = NEWCHAR
             
        End Select
        Sleep (DELAY)
        ActiveDocument.Background.Fill.ForeColor.RGB = PAUSE
    Next
ActiveDocument.Background.Fill.ForeColor.RGB = OriginalColor
End Sub

Public Function Timestamp() As Currency
    Timestamp = (Round(Now(), 0) * 24 * 60 * 60 + Timer()) * 1000
End Function

Public Sub Sleep(milliseconds As Currency)
    If milliseconds < 0 Then Exit Sub
    Dim start As Currency
    start = Timestamp()
    While (Timestamp() < milliseconds + start)
        DoEvents
    Wend
End Sub

Sub DbgColors()

Dim VARDOT As Long
Dim VARDASH As Long
Dim VARUNDERSCORE As Long
Dim VARCHARSPACE As Long
Dim VARNEWCHAR As Long
Dim VARPAUSE As Long

VARDOT = RGB(0, 0, 255)
VARDASH = RGB(255, 0, 0)
VARUNDERSCORE = RGB(0, 255, 0)
VARCHARSPACE = RGB(0, 0, 0)
VARNEWCHAR = RGB(255, 255, 255)
VARPAUSE = RGB(255, 255, 255)

Debug.Print "CONST DOT As Long = " & CStr(VARDOT)
Debug.Print "CONST DASH As Long = " & CStr(VARDASH)
Debug.Print "CONST UNDERSCORE As Long = " & CStr(VARUNDERSCORE)
Debug.Print "CONST CHARSPACE As Long = " & CStr(VARCHARSPACE)
Debug.Print "CONST NEWCHAR As Long = " & CStr(VARNEWCHAR)
Debug.Print "CONST PAUSE As Long = " & CStr(VARPAUSE)

End Sub