Malicious Office (OOXML) — malware analysis report

Static analysis result for SHA-256 67349434990aed73…

MALICIOUS

Office (OOXML)

985.3 KB Created: 2013-01-14 10:36:32 UTC Authoring application: Microsoft Excel 14.0300 First seen: 2020-09-24
MD5: 2660b2d7afa8692c75bca05e7ead52c4 SHA-1: 5e56a1664e1bcd64809c40715f3e9ee344e8002a SHA-256: 67349434990aed73904ead9f00e1fff4c10cefa38fde8466f8276dca199ea499
274 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1105 Ingress Tool Transfer

The file contains VBA macros that are triggered by the Workbook_Open event. These macros are designed to download and execute a second-stage payload from URLs such as http://r1cf.ru/rda_activator and http://mydx.eu/rda/csv?call=. The presence of critical heuristics like OLE_VBA_HTTP_DROP_EXEC and OLE_VBA_OBFUSCATED_AUTOEXEC_LOADER, along with ClamAV detection, strongly indicates a dropper functionality.

Heuristics 10

  • ClamAV: Doc.Dropper.Agent-6352513-0 critical CLAMAV_DETECTION
    ClamAV detected this file as malware: Doc.Dropper.Agent-6352513-0
  • VBA project inside OOXML medium 5 related findings OOXML_VBA
    Document contains a VBA project — VBA macros present
  • VBA downloads and writes a file to disk critical OLE_VBA_HTTP_DROP_EXEC
    VBA reads an HTTP response body and writes it to disk (ADODB.Stream SaveToFile). Combined with the auto-exec/Shell paths this is a download-drop dropper even when the COM ProgIDs are built dynamically to evade keyword scanning.
    Matched line in script
    myURL = WinHttpReq.responseBody
  • 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 WinHttpReq = CreateObject("Microsoft.XMLHTTP")
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
    Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
  • Workbook_Open macro low OLE_VBA_WBOPEN
    Workbook_Open macro
    Matched line in script
    Private Sub Workbook_Open()
  • Environ() call (env variable access) low OLE_VBA_ENVIRON
    Environ() call (env variable access)
    Matched line in script
    tempfile = Environ("APPDATA") & "file.csv"
  • External hyperlinks (1) low OOXML_EXTERNAL_HYPERLINKS
    Document contains 1 external hyperlink — clickable URLs are stored as external relationships. First target: http://r1cf.ru/rda_activator
  • Hidden worksheet (hidden) low OOXML_HIDDEN_SHEET
    Excel workbook contains 4 hidden sheet(s) — hidden sheets are commonly used to conceal macro code, staging data, or intermediate payload construction
  • 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://r1cf.ru/rda_activator Referenced by macro
    • http://mydx.eu/rda/csv?call=Referenced by macro
    • http://mydx.eu/rda/activator?id=Referenced by macro
    • http://mydx.eu/rda/regionsReferenced by macro
    • http://www.rdaward.org/mw.htmReferenced by macro
    • http://mydx.eu/rdaReferenced by macro
    • http://rdaward.org/rda_rus.txtReferenced by macro

Extracted artifacts 2

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source from OOXML) 85615 bytes
SHA-256: e95fa54fd425cb5dd76f55fb37de505ed3c898a643b222db1f9e67f594acf9ef
Preview script
First 1,000 lines of the extracted script
Attribute VB_Name = "ЭтаКнига"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Private Sub Workbook_Open()
    Call Check_mydx
End Sub

Attribute VB_Name = "Лист1"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Private Sub Worksheet_Activate()

End Sub

Attribute VB_Name = "Лист2"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Лист6"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Лист4"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Лист5"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Module1"
Public Cancel As Boolean

Sub RDA_Update()
    If Worksheets("SUMMARY").Cells(4, 14) <> "" Then
      Call RDA_CSV_Update(Worksheets("SUMMARY").Cells(4, 14))
    End If
End Sub
Public Sub Activ_Update()
    If Worksheets("SUMMARY").Cells(6, 14) <> "" Then
        Call RDA_ACT_Update(Worksheets("SUMMARY").Cells(6, 14))
    Else
        vbresult = Result_display(False, "No ActivID")
        Call Logging("No ActivatorID", "ERR")
    End If
End Sub
Sub AZ_Table_Clear()
    Worksheets("RDA AZ").Cells.ClearContents
    Worksheets("RDA AZ").Cells(1, 1) = "#"
    Worksheets("RDA AZ").Cells(1, 2) = "RDA"
    Worksheets("RDA AZ").Cells(1, 3) = "CallSign"
    Worksheets("RDA AZ").Cells(1, 4) = "Date"
End Sub
Sub ACT_Table_Clear()
    Worksheets("ACTIV").Cells.ClearContents
    Worksheets("ACTIV").Cells(1, 1) = "Pos"
    Worksheets("ACTIV").Cells(1, 2) = "RDA"
    Worksheets("ACTIV").Cells(1, 3) = "Stations"
    Worksheets("ACTIV").Cells(1, 4) = "Activation period"
    Worksheets("ACTIV").Cells(1, 6) = "Region"
End Sub
Sub CFMD_Table_Clear()
    Worksheets("AWARD_CFMD").Cells.ClearContents
End Sub

Public Sub RDA_CSV_Update(CallSign As String)
Cancel = False
Dim myURL As String
tempfile = Environ("APPDATA") & "file.csv"
myURL = "http://mydx.eu/rda/csv?call=" & CallSign
Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False, "username", "password"
WinHttpReq.send
Dim RDATT(2670, 12) As String
Dim AZ_New() As Integer
myURL = WinHttpReq.responseBody
If WinHttpReq.Status = 200 Then
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1
    oStream.Write WinHttpReq.responseBody
        oStream.SaveToFile tempfile, 2 ' 1 = no overwrite, 2 = overwrite
    oStream.Close
Else
    vbresult = Result_display(False, "Conn.Failed, Code = " & WinHttpReq.Status)
    Call Logging("Conn.Failed, Code = " & WinHttpReq.Status, "ERR")
    Exit Sub
End If
Dim fso As FileSystemObject: Set fso = New FileSystemObject
Set txtStream = fso.OpenTextFile(tempfile, ForReading, False)
i = 2
Worksheets("RDA AZ").Cells.ClearContents
Worksheets("RDA AZ").Cells(1, 1) = "#"
Worksheets("RDA AZ").Cells(1, 2) = "RDA"
Worksheets("RDA AZ").Cells(1, 3) = "CallSign"
Worksheets("RDA AZ").Cells(1, 4) = "Date"
New_RDA = 0
AZ_new_lines = 0
For m = 2 To 2670
   For n = 1 To 12
        RDATT(m, n) = Worksheets("RDA TOTAL").Cells(m, n)
        'Moving RDA_T to array RDATT
   Next
Next
Do While Not txtStream.AtEndOfStream
    temp_field = ""
    RowF = 2
    'RDA AZ lines counter
    rda_string = txtStream.ReadLine
    Num_row = 0
    For k = 1 To Len(rda_string)
        If Not Mid(rda_string, k, 1) = "," Then
            temp_field = temp_field & Mid(rda_string, k, 1)
        Else
            Num_row = Num_row + 1
            Worksheets("RDA AZ").Cells(i, RowF) = temp_field
           
            If Num_row = 1 Then
               j = 2
               Process_ind ("Checking " & temp_field)
                Do While (RDATT(j, 1) <> "" And j < 2700)
                    If RDATT(j, 2) = temp_field Then
                        
                       If RDATT(j, 8) = "" Then
                            New_RDA = New_RDA + 1
                            ReDim Preserve AZ_New(New_RDA)
                            AZ_New(New_RDA) = i
                            Process_ind ("New AZ: " & temp_field)
                        End If
                    End If
                   
                    j = j + 1
                Loop
            End If
            temp_field = ""
            DEvents = DoEvents
            If Cancel Then
                vbresult = Result_display(True, "RDA upd. cancel")
                Call Logging("RDA UPD Cancelled", "OK")
                
                Exit Sub
            End If
            RowF = RowF + 1
            
        End If
        Worksheets("RDA AZ").Cells(i, 1).Font.Color = vbBlack
        Worksheets("RDA AZ").Cells(i, 2).Font.Color = vbBlack
        Worksheets("RDA AZ").Cells(i, 3).Font.Color = vbBlack
        Worksheets("RDA AZ").Cells(i, 4).Font.Color = vbBlack
        Worksheets("RDA AZ").Cells(i, 1) = i - 1
        Worksheets("RDA AZ").Cells(i, RowF) = temp_field
    Next
    i = i + 1
Loop

If New_RDA > 0 Then
   For l = 1 To UBound(AZ_New)
        Worksheets("RDA AZ").Cells(AZ_New(l), 1).Font.Color = vbRed
        Worksheets("RDA AZ").Cells(AZ_New(l), 2).Font.Color = vbRed
        Worksheets("RDA AZ").Cells(AZ_New(l), 3).Font.Color = vbRed
        Worksheets("RDA AZ").Cells(AZ_New(l), 4).Font.Color = vbRed
    Next
End If
If New_RDA = 0 Then
    vbresult = Result_display(True, "AZ updated OK")
    Call Logging("AZ updated OK", "OK")
Else
    vbresult = Result_display(True, New_RDA & " AZ added")
    Call Logging(New_RDA & " lines added to AZ list", "OK")
End If
Erase RDATT
Erase AZ_New
txtStream.Close
End Sub

Public Sub RDA_ACT_Update(ActivatorID As String)

    Worksheets("SUMMARY").Cells(4, 14).Interior.Color = vbWhite
    Worksheets("SUMMARY").Cells(6, 14).Interior.Color = vbWhite
    Dim myURL As String
    myURL = "http://mydx.eu/rda/activator?id=" & ActivatorID
    tempfile = Environ("APPDATA") & "file.html"
    Dim WinHttpReq As Object
    Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
    WinHttpReq.Open "GET", myURL, False, "username", "password"
    WinHttpReq.send

    myURL = WinHttpReq.responseBody

If WinHttpReq.Status = 200 Then
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1
    If Not IsEmpty(WinHttpReq.responseBody) Then
        oStream.Write WinHttpReq.responseBody
        oStream.SaveToFile tempfile, 2 ' 1 = no overwrite, 2 = overwrite
        oStream.Close
    Else
        vbresult = Result_display(False, "NoHTTP, chk ActID")
        Call Logging("Conn.Failed, Empty HTTP Response", "ERR")
        Exit Sub
    End If
Else
    vbresult = Result_display(False, "Conn.Failed, Code = " & WinHttpReq.Status)
     Call Logging("Conn.Failed, Code = " & WinHttpReq.Status, "ERR")
    Exit Sub

End If
Dim fso As FileSystemObject: Set fso = New FileSystemObject
Set txtStream = fso.OpenTextFile(tempfile, ForReading, False)
i = 2
Worksheets("ACTIV").Cells.ClearContents
Do While Not txtStream.AtEndOfStream
    act_string = txtStream.ReadLine
    If (InStr(1, act_string, "<span class=""header"">")) Then
        act_cs = Replace(act_string, "<span class=""header"">", "")
        act_cs = Replace(act_cs, "</span>", "")
        If act_cs = Worksheets("SUMMARY").Cells(4, 14) Then
            vbresult = Result_display(True, "ActID OK")
            Call Logging("ActivatorID OK", "OK")
        Else
            vbresult = Result_display(False, "ActID Fail")
            Call Logging("ActivatorID Wrong", "ERR")
            Exit Sub
        End If
    End If
    If (InStr(1, act_string, "<table>")) Then
        act_string = txtStream.ReadLine ' <tr>
        act_string = txtStream.ReadLine ' Pos
    
        Worksheets("ACTIV").Cells(1, 1) = Mid(act_string, 31, Len(act_string) - InStr(1, act_string, "</th>") - 1)
        act_string = txtStream.ReadLine ' RDA
        Worksheets("ACTIV").Cells(1, 2) = Mid(act_string, 31, Len(act_string) - InStr(1, act_string, "</th>") - 1)
        act_string = txtStream.ReadLine ' Stations
        Worksheets("ACTIV").Cells(1, 3) = Mid(act_string, 21, Len(act_string) - InStr(1, act_string, "</th>") + 4)
        act_string = txtStream.ReadLine ' Period
        Worksheets("ACTIV").Cells(1, 4) = Mid(act_string, 33, Len(act_string) - InStr(1, act_string, "</th>") + 13)
        act_string = txtStream.ReadLine ' blank
        act_string = txtStream.ReadLine ' Region
        Worksheets("ACTIV").Cells(1, 6) = Mid(act_string, 20, Len(act_string) - InStr(1, act_string, "</th>") + 2)
        act_string = txtStream.ReadLine ' </tr>
        act_string = txtStream.ReadLine ' <tr>
        act_string = txtStream.ReadLine ' <tr>
        act_string = txtStream.ReadLine ' <tr>
        act_string = txtStream.ReadLine ' <tr>
        actrow = 2
        act_string = txtStream.ReadLine ' <tr>
        Do While Not (InStr(1, act_string, "Pos"))
            If InStr(1, act_string, "<td colspan=""6""><hr/></td>") Then
                Exit Do
            End If
            
            Pos = Replace(act_string, "<td>", "")
            Pos = Replace(Pos, "</td>", "")
            Worksheets("ACTIV").Cells(actrow, 1) = Pos
            act_string = txtStream.ReadLine ' RDA
            RDA = Replace(act_string, "<td>", "")
            RDA = Replace(RDA, "</td>", "")
            Worksheets("ACTIV").Cells(actrow, 2) = RDA
            act_string = txtStream.ReadLine ' stations
            st_str_1 = "<td align=""right""><a class=""ired"" href=""activator_rda?activator=" & ActivatorID & "&rda=" & CStr(RDA) & """>"
            act_string = Replace(act_string, st_str_1, "")
            st_str_2 = "</a></td>"
            act_string = Replace(act_string, st_str_2, "")

            Worksheets("ACTIV").Cells(actrow, 3) = act_string
            act_string = txtStream.ReadLine ' period
            Period = Replace(act_string, "<td align=""right"">", "")
            Period = Replace(Period, "</td>", "")
            Worksheets("ACTIV").Cells(actrow, 4) = Period
            act_string = txtStream.ReadLine 'nbsp
            act_string = txtStream.ReadLine ' region description
            st_str_1 = "<td>"
            act_string = Replace(act_string, st_str_1, "")
            st_str_2 = "</td>"
            act_string = Replace(act_string, st_str_2, "")
            Worksheets("ACTIV").Cells(actrow, 6) = act_string
            act_string = txtStream.ReadLine '</tr>
            actrow = actrow + 1
            act_string = txtStream.ReadLine ' <tr>
            act_string = txtStream.ReadLine ' <tr>
        Loop
    End If
    DEvents = DoEvents
    If Cancel Then
       vbresult = Result_display(True, "ACT upd. cancel")
       Call Logging("Activations update cancelled", "OK")
       Exit Sub
    End If
Loop
'Worksheets("SUMMARY").Cells(7, 4) = actrow - 1
vbresult = Result_display(True, "ACT. updated OK")
Call Logging("ACT. updated OK", "OK")
txtStream.Close
End Sub

Public Sub RDA_List_Update()
Cancel = False
 Dim myURL As String
    myURL = "http://mydx.eu/rda/regions"
    tempfile = Environ("APPDATA") & "file2.html"
    Dim WinHttpReq As Object
    Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
    WinHttpReq.Open "GET", myURL, False, "username", "password"
    WinHttpReq.send

    myURL = WinHttpReq.responseBody
    If WinHttpReq.Status = 200 Then
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Open
        oStream.Type = 1
        oStream.Write WinHttpReq.responseBody
        oStream.SaveToFile tempfile, 2 ' 1 = no overwrite, 2 = overwrite
        oStream.Close
        Else
            vbresult = Result_display(False, "Conn.Failed, Code = " & WinHttpReq.Status)
             Call Logging("Conn.Failed, Code = " & WinHttpReq.Status, "ERR")
            Exit Sub

    End If
    Dim fso As FileSystemObject: Set fso = New FileSystemObject
    Set txtStream = fso.OpenTextFile(tempfile, ForReading, False)
    Worksheets("RDA_LIST").Cells.ClearContents
    Worksheets("RDA_LIST").Cells(1, 2) = "#"
    Worksheets("RDA_LIST").Cells(1, 2) = "rda"
    Worksheets("RDA_LIST").Cells(1, 3) = "stations"
    Worksheets("RDA_LIST").Cells(1, 4) = "last qso"
    Worksheets("RDA_LIST").Cells(1, 5) = "%"
    ListRow = 2
    Latest_QSO = CDate("1970-01-01")
    
    Do While Not txtStream.AtEndOfStream
        list_string = txtStream.ReadLine
        If InStr(1, list_string, "<td><a class=""ired"" href=""rda?id=") Then
            Worksheets("RDA_LIST").Cells(ListRow, 1) = ListRow - 1
            
            RDA_ID = Mid(list_string, 40, 4)
            Worksheets("RDA_LIST").Cells(ListRow, 2) = Left(RDA_ID, 2) & "-" & Right(RDA_ID, 2)

            list_string = txtStream.ReadLine
            rda_st = Replace(list_string, "<td align=""right"">", "")
            rda_st = Replace(rda_st, "</td>", "")
            Worksheets("RDA_LIST").Cells(ListRow, 3) = rda_st
            list_string = txtStream.ReadLine
            last_qso = Replace(list_string, "<td align=""right"">", "")
            last_qso = Replace(last_qso, "</td>", "")
            last_qso = "01." & last_qso
            last_qso_cdate = CDate("00:00:00 " & last_qso)
            last_qso = Zeroadd(Month(last_qso_cdate)) & "-" & Year(last_qso_cdate)

            Worksheets("RDA_LIST").Cells(ListRow, 4) = last_qso
            If Latest_QSO < last_qso_cdate Then
                If last_qso_cdate <= Now Then
                    Latest_QSO = last_qso_cdate
                    Last_RDA = RDA_ID
                End If
                            
            End If
            list_string = txtStream.ReadLine
            
            rda_percent = Replace(list_string, "<td align=""right"">", "")
            rda_percent = Replace(rda_percent, "</td>", "") & "%"
            Worksheets("RDA_LIST").Cells(ListRow, 5) = rda_percent
            list_string = txtStream.ReadLine
            ListRow = ListRow + 1
            Else
                If Len(list_string) = 13 Then
                    
                    Worksheets("RDA_LIST").Cells(ListRow, 1) = ListRow - 1
                    RDA_ID = Mid(list_string, 5, 4)
                    Worksheets("RDA_LIST").Cells(ListRow, 2) = Left(RDA_ID, 2) & "-" & Right(RDA_ID, 2)
                    ListRow = ListRow + 1
                End If
            End If
       
            DEvents = DoEvents
            If Cancel Then
                vbresult = Result_display(True, "List upd. cancel")
                Call Logging("RDA list Update cancelled", "OK")
                Exit Sub
            End If
    Loop
    
    Call Sort_table(ListRow)
    
    Worksheets("SUMMARY").Cells(38, 4) = ListRow
    Worksheets("SUMMARY").Cells(39, 4) = Zeroadd(Month(Latest_QSO)) & "-" & Year(Latest_QSO)
    Worksheets("SUMMARY").Cells(40, 4) = Left(Last_RDA, 2) & "-" & Right(Last_RDA, 2)
    vbresult = Result_display(True, "RDA list OK")
    Call Logging("RDA list OK", "OK")
End Sub

Public Sub QSL_Add()

If (Worksheets("SUMMARY").Cells(14, 3) <> "") And (Worksheets("SUMMARY").Cells(16, 3) <> "") Then
    QSL_CS = Worksheets("SUMMARY").Cells(14, 3)
    QSL_RDA = Worksheets("SUMMARY").Cells(16, 3)
    QSLL_Date = Worksheets("SUMMARY").Cells(18, 3)
    QSL_Type = Worksheets("SUMMARY").Cells(20, 3)
    CHK_RDA = RDA_str_chk(QSL_RDA)
        If CHK_RDA <> 0 Then
            vbresult = Result_display(False, "RDA NOK (" & CHK_RDA & ")")
            Call Logging("RDA NOK (" & CHK_RDA & ")", "OK")
            Exit Sub
        Else
        i = 2
            Do While (Worksheets("QSL").Cells(i, 1) <> "")
                If (Worksheets("QSL").Cells(i, 2) = QSL_RDA And Worksheets("QSL").Cells(i, 6) = QSL_Type And Worksheets("QSL").Cells(i, 3) = QSL_CS) Then
                    vbresult = Result_display(False, "QSL exists")
                    Call Logging("QSL exists", "OK")
                    Exit Sub
                End If
                i = i + 1
            Loop
            Worksheets("QSL").Cells(i, 1) = i - 1
            Worksheets("QSL").Cells(i, 2) = QSL_RDA
            Worksheets("QSL").Cells(i, 3) = QSL_CS
            Worksheets("QSL").Cells(i, 4) = Year(Now) & "-" & Month(Now) & "-" & Day(Now)
            Worksheets("QSL").Cells(i, 5) = QSLL_Date
            Worksheets("QSL").Cells(i, 6) = QSL_Type
            
            Worksheets("SUMMARY").Cells(6, 4) = i - 1
            vbresult = Result_display(True, "QSL added to list")
            Call Logging(QSL_CS & " added to QSL list - " & QSL_RDA, "OK")
            'Call Logging("QSL added to list " & QSL_RDA, "OK")
            Worksheets("SUMMARY").Cells(14, 3) = ""
            Worksheets("SUMMARY").Cells(16, 3) = ""
            Worksheets("SUMMARY").Cells(18, 3) = ""
            Worksheets("SUMMARY").Cells(17, 5) = QSL_CS
            
        End If
End If
End Sub
Public Sub RDA_Check()

For j = 28 To 33
    Worksheets("SUMMARY").Cells(j, 4) = ""
    Worksheets("SUMMARY").Cells(j, 5) = ""
Next

If (Worksheets("SUMMARY").Cells(26, 3) <> "") Then
    RDA_chk = Worksheets("SUMMARY").Cells(26, 3)
    RDS_Chk = RDA_str_chk(RDA_chk)
        If RDS_Chk = 0 Then
        
        Worksheets("SUMMARY").Cells(27, 3) = RDA_Name_Get(RDA_chk)
            'AZ check
        i = 2
        rdaf = False
        Do While (Worksheets("RDA AZ").Cells(i, 1) <> "")
            If (Worksheets("RDA AZ").Cells(i, 2) = RDA_chk) Then
                Worksheets("SUMMARY").Cells(28, 4) = "CFM"
                Worksheets("SUMMARY").Cells(28, 5) = Worksheets("RDA AZ").Cells(i, 3)
                rdaf = True
                Exit Do
            End If
        i = i + 1
        Loop
        'QSL check
        j = 2
        Do While (Worksheets("QSL").Cells(j, 1) <> "")
            If (Worksheets("QSL").Cells(j, 2) = RDA_chk) Then
                If Worksheets("QSL").Cells(j, 6) = "Paper QSL" Then
                    Worksheets("SUMMARY").Cells(29, 4) = "CFM"
                    Worksheets("SUMMARY").Cells(29, 5) = Worksheets("QSL").Cells(j, 3)
                    'Worksheets("SUMMARY").Cells(25, 4) = Worksheets("QSL").Cells(j, 3)
                    rdaf = True
                    
                    Exit Do
                Else
                    If Worksheets("QSL").Cells(j, 6) = "E-QSL" Then
                        Worksheets("SUMMARY").Cells(30, 4) = "CFM"
                        Worksheets("SUMMARY").Cells(30, 5) = Worksheets("QSL").Cells(j, 3)
                        rdaf = True
                        Exit Do
                    Else
                        If Worksheets("QSL").Cells(j, 6) = "LoTW" Then
                            Worksheets("SUMMARY").Cells(31, 4) = "CFM"
                            Worksheets("SUMMARY").Cells(31, 5) = Worksheets("QSL").Cells(j, 3)
                            rdaf = True
                            Exit Do
                        End If
                    End If
                End If
            End If
        j = j + 1
        Loop
        m = 2
        Do While (Worksheets("RDA TOTAL").Cells(m, 1) <> "")
           If (Worksheets("RDA TOTAL").Cells(m, 2) = RDA_chk) Then
                If Worksheets("RDA TOTAL").Cells(m, 5) <> "" Then
                    Worksheets("SUMMARY").Cells(25, 4) = "AZ: " & Int(Worksheets("RDA TOTAL").Cells(m, 5) * 100) & "%"
                End If
                If Worksheets("RDA TOTAL").Cells(m, 6) <> "" Then
                    Worksheets("SUMMARY").Cells(26, 4) = "MW: " & Int(Worksheets("RDA TOTAL").Cells(m, 6) * 100) & "%"
                End If
            If (Worksheets("RDA TOTAL").Cells(m, 12) <> "") Then
                Worksheets("SUMMARY").Cells(32, 4) = "CFM"
                Worksheets("SUMMARY").Cells(32, 5) = Worksheets("RDA TOTAL").Cells(m, 12)
                rdaf = True
                Exit Do
            End If
           End If
           m = m + 1
        Loop
        'Activation check
        k = 2
        Do While (Worksheets("ACTIV").Cells(k, 1) <> "")
            If (Worksheets("ACTIV").Cells(k, 2) = RDA_chk) Then
                Worksheets("SUMMARY").Cells(33, 4) = "ACTIV"
                Worksheets("SUMMARY").Cells(33, 5) = Worksheets("ACTIV").Cells(k, 3)
                rdaf = True
                Exit Do
            End If
        k = k + 1
        Loop
        If rdaf Then
            rda_text = "RDA check OK"
        Else
            rda_text = "RDA not CFM"
        End If
        vbresult = Result_display(True, rda_text)
        Call Logging(rda_text, "OK")
  Else
        
        vbresult = Result_display(False, "RDA NOK (" & RDS_Chk & ")")
        Call Logging("RDA NOK (" & RDS_Chk & ")", "OK")
  End If
Else
    Worksheets("SUMMARY").Cells(27, 3) = ""
    Worksheets("SUMMARY").Cells(25, 4) = ""
    Worksheets("SUMMARY").Cells(26, 4) = ""
End If
End Sub
Sub RDA_Table_Clear()
    Worksheets("RDA TOTAL").Cells.ClearContents
    Worksheets("RDA TOTAL").Cells(1, 1) = "#"
    Worksheets("RDA TOTAL").Cells(1, 2) = "RDA"
    Worksheets("RDA TOTAL").Cells(1, 3) = "Stations"
    Worksheets("RDA TOTAL").Cells(1, 4) = "Date"
    Worksheets("RDA TOTAL").Cells(1, 5) = "% AZ"
    Worksheets("RDA TOTAL").Cells(1, 6) = "% MW"
    Worksheets("RDA TOTAL").Cells(1, 7) = "Count MW"
    Worksheets("RDA TOTAL").Cells(1, 8) = "AZ"
    Worksheets("RDA TOTAL").Cells(1, 9) = "QSL"
    Worksheets("RDA TOTAL").Cells(1, 10) = "ACTIV"
    Worksheets("RDA TOTAL").Cells(1, 11) = "CFM"
    Worksheets("RDA TOTAL").Cells(1, 12) = "AWARD CFM"

End Sub
Sub QSL_Table_Clear()
    Worksheets("QSL").Range("A:F").ClearContents
    Worksheets("QSL").Cells(1, 1) = "#"
    Worksheets("QSL").Cells(1, 2) = "RDA"
    Worksheets("QSL").Cells(1, 3) = "CallSign"
    Worksheets("QSL").Cells(1, 4) = "AddingDate"
    Worksheets("QSL").Cells(1, 5) = "QSO_Date"
    Worksheets("QSL").Cells(1, 6) = "QSL_Type"
End Sub
Public Sub RDA_Total()

    On Error GoTo CancelHandler
    Application.EnableCancelKey = xlErrorHandler
    
    k = 2
    RDA_AZ = 0
    RDA_QSL = 0
    RDA_ACTIV = 0
    RDA_CFM = 0
    AWARD_CFM = 0
    
    
    Worksheets("RDA TOTAL").Cells.ClearContents
    Worksheets("RDA TOTAL").Cells(1, 1) = "#"
    Worksheets("RDA TOTAL").Cells(1, 2) = "RDA"
    Worksheets("RDA TOTAL").Cells(1, 3) = "Stations"
    Worksheets("RDA TOTAL").Cells(1, 4) = "Date"
    Worksheets("RDA TOTAL").Cells(1, 5) = "% AZ"
    Worksheets("RDA TOTAL").Cells(1, 6) = "% MW"
    Worksheets("RDA TOTAL").Cells(1, 7) = "Count MW"
    Worksheets("RDA TOTAL").Cells(1, 8) = "AZ"
    Worksheets("RDA TOTAL").Cells(1, 9) = "QSL"
    Worksheets("RDA TOTAL").Cells(1, 10) = "ACTIV"
    Worksheets("RDA TOTAL").Cells(1, 11) = "CFM"
    Worksheets("RDA TOTAL").Cells(1, 12) = "AWARD CFM"
    
    ' Check if RDA_AWARD list by RA3R exists and not empty
    AW_EXISTS = (Sh_Exist("AWARD_CFMD") And Application.CountA(Worksheets("AWARD_CFMD").UsedRange) > 0)

    'Dim RDATOTAL(2670, 12) As String
    Dim RDAAZ() As Variant
    Dim RDAQSL() As Variant
    Dim AWCFMD() As Variant
    ReDim AWCFMD(2700, 2)
    Dim RDAMW() As Variant
    
    If AW_EXISTS Then
       q = 5
        Do While Not (InStr(Worksheets("AWARD_CFMD").Cells(q, 1), "MANAGER") Or q = 2700)
            AWCFMD(q - 4, 1) = Worksheets("AWARD_CFMD").Cells(q, 1)
            AWCFMD(q - 4, 2) = Worksheets("AWARD_CFMD").Cells(q, 2)
            q = q + 1
        Loop
    End If
    l = 2
    ReDim RDAAZ(10000, 4)
    ReDim RDAQSL(5000, 6)
    ReDim RDAMW(2700, 4)
    
    'Filling Array with RDA AZ Values
    Do While Worksheets("RDA AZ").Cells(l, 1) <> ""
        RDAAZ(l, 1) = Worksheets("RDA AZ").Cells(l, 1)
        RDAAZ(l, 2) = Worksheets("RDA AZ").Cells(l, 2)
        RDAAZ(l, 3) = Worksheets("RDA AZ").Cells(l, 3)
        RDAAZ(l, 4) = Worksheets("RDA AZ").Cells(l, 4)
        l = l + 1
    Loop
    l = 2
     'Filling Array with QSL Values
    Do While Worksheets("QSL").Cells(l, 1) <> ""
        RDAQSL(l, 1) = Worksheets("QSL").Cells(l, 1)
        RDAQSL(l, 2) = Worksheets("QSL").Cells(l, 2)
        RDAQSL(l, 3) = Worksheets("QSL").Cells(l, 3)
        RDAQSL(l, 4) = Worksheets("QSL").Cells(l, 4)
        RDAQSL(l, 5) = Worksheets("QSL").Cells(l, 5)
        RDAQSL(l, 6) = Worksheets("QSL").Cells(l, 5)
        l = l + 1
    Loop
    
    r = 2
    Do While Worksheets("RDA_MW").Cells(r, 1) <> ""
        RDAMW(r, 1) = Worksheets("RDA_MW").Cells(r, 1)
        RDAMW(r, 2) = Worksheets("RDA_MW").Cells(r, 2)
        RDAMW(r, 3) = Worksheets("RDA_MW").Cells(r, 3)
        RDAMW(r, 4) = Worksheets("RDA_MW").Cells(r, 4)
        r = r + 1
    Loop
    
    Do While Worksheets("RDA_LIST").Cells(k, 1) <> "" And k < 2670 ' RDA list big loop
       RDA_F = Worksheets("RDA_LIST").Cells(k, 2)
       CFM = False
       Process_ind ("Processing " & RDA_F)
        Worksheets("RDA TOTAL").Cells(k, 1) = k - 1
        Worksheets("RDA TOTAL").Cells(k, 2) = RDA_F
        Worksheets("RDA TOTAL").Cells(k, 3) = Worksheets("RDA_LIST").Cells(k, 3)
        Worksheets("RDA TOTAL").Cells(k, 4) = Worksheets("RDA_LIST").Cells(k, 4)
        Worksheets("RDA TOTAL").Cells(k, 5) = Worksheets("RDA_LIST").Cells(k, 5)
        'Search in RDA_CFM list for RDA_F
        If AW_EXISTS Then
            s = 1
             Aw_cfm_str = AWCFMD(s, 1)
            Do Until (InStr(Aw_cfm_str, "MANAGER") Or s = 2670)
                If InStr(AWCFMD(s, 1), RDA_F) Then
                     Worksheets("RDA TOTAL").Cells(k, 12) = AWCFMD(s, 2)
                     CFM = True
                     AWARD_CFM = AWARD_CFM + 1
                     
                     Exit Do
                End If
                s = s + 1
            Loop
        End If
        
        m = 2
        Do While RDAAZ(m, 1) <> ""
             If RDAAZ(m, 2) = RDA_F Then
                 Worksheets("RDA TOTAL").Cells(k, 8) = RDAAZ(m, 3)
                 RDA_AZ = RDA_AZ + 1
                 CFM = True
                 Exit Do
            End If
            m = m + 1
        Loop
       n = 2
       Do While RDAQSL(n, 1) <> ""
            If RDAQSL(n, 2) = RDA_F Then
                 Worksheets("RDA TOTAL").Cells(k, 9) = RDAQSL(n, 3)
                 RDA_QSL = RDA_QSL + 1
                 CFM = True
                 Exit Do
            End If
            n = n + 1
        Loop
       p = 2
       Do While Worksheets("ACTIV").Cells(p, 1) <> ""
            If Worksheets("ACTIV").Cells(p, 2) = RDA_F And Worksheets("ACTIV").Cells(p, 3) > 100 Then
                 Worksheets("RDA TOTAL").Cells(k, 10) = Worksheets("ACTIV").Cells(p, 3)
                 RDA_ACTIV = RDA_ACTIV + 1
                 CFM = True
                 Exit Do
            End If
            p = p + 1
        Loop
        If CFM Then
            RDA_CFM = RDA_CFM + 1
            Worksheets("RDA TOTAL").Cells(k, 11) = "CFM"
        End If
        
        s = 2
        'Do While Worksheets("RDA_MW").Cells(k, 1) <> "" ' MW list
        Do While RDAMW(k, 1) <> "" ' MW list
            If RDAMW(s, 2) = RDA_F Then
                 Worksheets("RDA TOTAL").Cells(k, 6) = RDAMW(s, 4)
                 Worksheets("RDA TOTAL").Cells(k, 7) = RDAMW(s, 3)
                 
                 Exit Do
            End If
            s = s + 1
        Loop
    'End If
        k = k + 1
        DEvents = DoEvents
        If Cancel Then
            vbresult = Result_display(True, "RDA Total cancel")
            Call Logging("RDA TOTAL Cancelled", "OK")
            Exit Sub
            End If
    Loop
    Worksheets("SUMMARY").Cells(4, 4) = RDA_CFM
    Worksheets("SUMMARY").Cells(5, 4) = RDA_AZ
    Worksheets("SUMMARY").Cells(6, 4) = RDA_QSL
    Worksheets("SUMMARY").Cells(7, 4) = RDA_ACTIV
    Worksheets("SUMMARY").Cells(8, 4) = AWARD_CFM
    
   Call Result_display(True, k - 2 & " RDA upd OK")
   Call Logging(k - 2 & " RDA upd OK", "OK")
   Erase RDAAZ
   Erase RDAQSL
   Erase AWCFMD
   Erase RDAMW
   'Recycling Rubbish
   
CancelHandler:
    Application.EnableCancelKey = xlInterrupt
    If Err.Number = 18 Then MsgBox "You have pressed ESC or CTRL+BREAK"
End Sub

Public Sub MW_List_Update()

 Dim myURL As String
    myURL = "http://www.rdaward.org/mw.htm"
    tempfile = Environ("APPDATA") & "file3.html"
    Dim WinHttpReq As Object
    Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
    WinHttpReq.Open "GET", myURL, False, "username", "password"
    WinHttpReq.send

    myURL = WinHttpReq.responseBody
    If WinHttpReq.Status = 200 Then
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Open
        oStream.Type = 1
        oStream.Write WinHttpReq.responseBody
        oStream.SaveToFile tempfile, 2 ' 1 = no overwrite, 2 = overwrite
        oStream.Close
        Else
            vbresult = Result_display(False, "Conn.Failed, Code = " & WinHttpReq.Status)
             Call Logging("Conn.Failed, Code = " & WinHttpReq.Status, "ERR")
            Exit Sub
        End If
    Dim fso As FileSystemObject: Set fso = New FileSystemObject
    Set txtStream = fso.OpenTextFile(tempfile, ForReading, False)
    Worksheets("RDA_MW").Cells.ClearContents
    Worksheets("RDA_MW").Cells(1, 1) = "#"
    Worksheets("RDA_MW").Cells(1, 2) = "rda"
    Worksheets("RDA_MW").Cells(1, 3) = "count"
    Worksheets("RDA_MW").Cells(1, 4) = "%"
    
    ListRow = 2
    Do While Not txtStream.AtEndOfStream
        list_string = txtStream.ReadLine
        If InStr(list_string, "<b>Total application -") Then
            Total_App = CInt(Replace(list_string, "<b>Total application - ", ""))
            Worksheets("SUMMARY").Cells(43, 4) = Total_App
            Exit Do
        End If
    Loop
    Do While Not txtStream.AtEndOfStream
        list_string = txtStream.ReadLine
        If InStr(list_string, "Total number of districts in all applications - ") Then
            list_string = Replace(list_string, "Total number of districts in all applications - ", "")
            Districts = CInt(Replace(list_string, " areas", ""))
            Worksheets("SUMMARY").Cells(42, 4) = Districts
            Exit Do
        End If
    Loop
    Do While Not txtStream.AtEndOfStream
        list_string = txtStream.ReadLine
        If InStr(list_string, "Last Update: ") Then
            list_string = Replace(list_string, "Last Update: ", "")
            Last_Date = Replace(list_string, "</b>", "")
            'MsgBox Last_Date
            Worksheets("SUMMARY").Cells(44, 4) = Last_Date
            Exit Do
        End If
    Loop
    list_string = txtStream.ReadLine '---
    q = 2
        Do While Not (txtStream.AtEndOfStream)
        list_string = txtStream.ReadLine
        If Len(list_string) = 0 Then
                Exit Do
            End If
            Dim MWA(3)
            
            t = 1
            For i = 1 To Len(list_string)
                If Not Mid(list_string, i, 1) = vbTab Then
                    MWA(t) = MWA(t) & Mid(list_string, i, 1)
                Else
                    t = t + 1
                End If
            Next
            Worksheets("RDA_MW").Cells(q, 1) = q - 1
            Worksheets("RDA_MW").Cells(q, 2) = MWA(1)
            Worksheets("RDA_MW").Cells(q, 3) = MWA(2)
            Worksheets("RDA_MW").Cells(q, 4) = Replace(MWA(3), ",", ".")
            Erase MWA
            
            q = q + 1
            DEvents = DoEvents
            If Cancel Then
                vbresult = Result_display(True, "MW upd. cancel")
                Call Logging("MW list Update cancelled", "OK")
                Exit Sub
            End If
        Loop
        Call Result_display(True, k & " MW upd OK")
        Call Logging(k & " MW upd OK", "OK")
End Sub
Sub Check_mydx()
Dim myURL As String
On Error Resume Next
tempfile = Environ("APPDATA") & "file.htm"
myURL = "http://mydx.eu/rda"
Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False, "username", "password"

WinHttpReq.send

myURL = WinHttpReq.responseBody
If WinHttpReq.Status = 200 Then
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1
    oStream.Write WinHttpReq.responseBody
        oStream.SaveToFile tempfile, 2 ' 1 = no overwrite, 2 = overwrite
    oStream.Close
    vbresult = Result_display(True, "MyDX.eu/rda OK")
    
Else
    vbresult = Result_display(False, "HTTP Err = " & WinHttpReq.Status)
     Call Logging("MyDX Conn.Failed, Code = " & WinHttpReq.Status, "ERR")
End If
End Sub
Sub Logging(ByVal Message As String, ByVal ErrSign As String)
    If Message <> "" Then
    i = 2
    Do While i < 10000
        If Worksheets("Activity_Log").Cells(i, 1) = "" Then
            Worksheets("Activity_Log").Cells(i, 1) = i - 1
            Worksheets("Activity_Log").Cells(i, 2) = Now
            Worksheets("Activity_Log").Cells(i, 3) = Message
            Worksheets("Activity_Log").Cells(i, 4) = ErrSign
            Exit Do
        Else
        i = i + 1
        End If
    Loop
    End If
End Sub
Public Sub Clear_Award_table()
    Worksheets("Award_app").Activate
    Range("A7:E2642").Select
    Selection.ClearContents
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("A7").Select
    Range("A7:E107").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
Range("A7").Select
End Sub

Public Sub Award_gen()

Range("A7:E2642").Select
Selection.ClearContents
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A7").Select
If Worksheets("SUMMARY").Cells(5, 14) <> "" Then
   Worksheets("Award_app").Cells(2, 3) = Worksheets("SUMMARY").Cells(4, 14)
End If
Worksheets("Award_app").Cells(3, 3) = Date
Worksheets("Award_app").Cells(4, 3) = 1
RDA_CFMD_No = Worksheets("SUMMARY").Cells(8, 4)

Select Case Worksheets("Award_app").Cells(1, 8)
  Case "RDA-100"
      RDA_Needed = 100
  Case "RDA-250"
      RDA_Needed = 250
  Case "RDA-500"
      RDA_Needed = 500
  Case "RDA-1000"
      RDA_Needed = 1000
  Case "RDA-1500"
      RDA_Needed = 1500
  Case "RDA-2000"
      RDA_Needed = 2000
  Case "RDA-ALL"
      RDA_Needed = Worksheets("SUMMARY").Cells(42, 4)
End Select
Select Case Worksheets("Award_app").Cells(6, 8)
    Case "110%"
        RDA_Needed = Int(RDA_Needed * 1.1)
    Case "All confirmed"
        RDA_Needed = Worksheets("SUMMARY").Cells(42, 4)
End Select
…
vbaProject_00.bin vba-project OOXML VBA project: xl/vbaProject.bin 374784 bytes
SHA-256: cf95b78e56e06fadb0aff731c14d880cc0aef1dec0354e6d8f808a5a7b4f2c9f

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