Malicious Office (OOXML) — malware analysis report

Attribute VB_Name = "ThisWorkbook"
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

Attribute VB_Name = "Sheet1"
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 = "Sheet2"
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 = "mMain"
Option Explicit
Public Enum UDCIFRET
   UDCIFValid = 0
   UDCIFMemberState = 1
   UDCIFName = 2
   UDCIFAddress = 3
   UDCIFAll = 4
   UDCIFSystemResponse = 5
End Enum
#If Win64 Then
    Private Declare PtrSafe Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
    Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
    Private Declare PtrSafe Function EnumProcesses Lib "PSAPI.DLL" (lpidProcess As Long, ByVal cb As Long, cbNeeded As Long) As Long
    Private Declare PtrSafe Function EnumProcessModules Lib "PSAPI.DLL" (ByVal hProcess As Long, lphModule As Long, ByVal cb As Long, lpcbNeeded As Long) As Long
    Private Declare PtrSafe Function GetModuleBaseName Lib "PSAPI.DLL" Alias "GetModuleBaseNameA" (ByVal hProcess As Long, ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long
    Public Declare PtrSafe Function GetSystemDefaultLCID Lib "kernel32" () As Long
    Public Declare PtrSafe Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lplcdata As String, ByVal cchData As Long) As Long
    Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
    Private Declare PtrSafe Function WaitForInputIdle Lib "user32" (ByVal hProcess As Long, ByVal dwMilliseconds As Long) As Long
    Public Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

    Public Declare PtrSafe Function DeleteUrlCacheEntry Lib "wininet.dll" (ByVal lpszUrlName As String) As Long
    Public Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
    Public Declare PtrSafe Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
    Public Declare PtrSafe Function Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
    Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
    Private Declare Function EnumProcesses Lib "PSAPI.DLL" (lpidProcess As Long, ByVal cb As Long, cbNeeded As Long) As Long
    Private Declare Function EnumProcessModules Lib "PSAPI.DLL" (ByVal hProcess As Long, lphModule As Long, ByVal cb As Long, lpcbNeeded As Long) As Long
    Private Declare Function GetModuleBaseName Lib "PSAPI.DLL" Alias "GetModuleBaseNameA" (ByVal hProcess As Long, ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long
    Public Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long
    Public Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lplcdata As String, ByVal cchData As Long) As Long
    Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
    Private Declare Function WaitForInputIdle Lib "user32" (ByVal hProcess As Long, ByVal dwMilliseconds As Long) As Long
    Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

    Public Declare Function DeleteUrlCacheEntry Lib "wininet.dll" (ByVal lpszUrlName As String) As Long
    Public Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
    public Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
    Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
 
Private Const PROCESS_VM_READ = &H10
Private Const PROCESS_QUERY_INFORMATION = &H400
Public L_SDECIMAL As String
Public Const LOCALE_SDECIMAL = &HE         '  decimal separator
'Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Const WAIT_FAILED = -1&
Private Const WAIT_OBJECT_0 = 0
Private Const WAIT_ABANDONED = &H80&
Private Const WAIT_ABANDONED_0 = &H80&
Private Const WAIT_TIMEOUT = &H102&
Private Const INFINITE = &HFFFFFFFF       '  Infinite timeout
Private Const NORMAL_PRIORITY_CLASS = &H20
Private Const SYNCHRONIZE = &H100000
Function fExportD394(Optional inTipExport As String = "Detalii")
Dim fName As String
Dim iHandle As Integer
Dim aCif() As String, aCifNoDups() As String
Dim sLineHeader As String, sLine As String
Dim i As Long, j As Long
Dim rCount As Long
Dim tVal1 As Double, tVal2 As Double, tVal3 As Double, tVal4 As Double
Dim bCIFErr As Boolean

'L_SDECIMAL = Locale(LOCALE_SDECIMAL)
'If L_SDECIMAL = vbNullString Then L_SDECIMAL = ","

'If Not fCheckD394Config Then
'   Exit Function
'End If

ReDim aCif(ActiveCell.SpecialCells(xlLastCell).Row - 1, 1)

bCIFErr = False
For i = 2 To ActiveCell.SpecialCells(xlLastCell).Row
   Select Case inTipExport
      Case "Detalii"
         aCif(i - 2, 0) = TestRegExp("\d+", Range("D" & i) & vbNullString, False)
         aCif(i - 2, 1) = ",#" & Range("H" & i) & "#"
         If Not Range("D" & i) & vbNullString = vbNullString Then
         If CheckCIF(TestRegExp("\d+", Range("D" & i) & vbNullString, False)) = "False" Then
            Range("M" & i).Value = "Structura CIF eronata"
            bCIFErr = True
         Else
            Range("M" & i).Value = vbNullString
         End If
         End If
      Case "Total"
         aCif(i - 2, 0) = TestRegExp("\d+", Range("A" & i) & vbNullString, False)
         aCif(i - 2, 1) = ",#" & Range("B" & i) & "#"
         If Not Range("A" & i) & vbNullString = vbNullString Then
         If CheckCIF(TestRegExp("\d+", Range("A" & i) & vbNullString, False)) = "False" Then
            Range("G" & i).Value = "Structura CIF eronata"
            bCIFErr = True
         Else
            Range("G" & i).Value = vbNullString
         End If
         End If
   End Select
Next i
If bCIFErr Then
   MsgBox "Clienti/furnizori cu structura codului fiscal incorecta!", vbCritical, "D394"
   Exit Function
End If

aCifNoDups = FilterDuplicates2(aCif, 0)
    
If inTipExport = "Detalii" Then
   Sheets("Optiuni").Select
   sLineHeader = sLineHeader & " 2 " & vbCrLf
   sLineHeader = sLineHeader & Range("B5") & ","
   sLineHeader = sLineHeader & "#" & Range("B4") & "#,"
   sLineHeader = sLineHeader & "##," '"#" & Range("B") & "#,"
   sLineHeader = sLineHeader & "##," '"#" & Range("B") & "#,"
   sLineHeader = sLineHeader & Range("B3") & ","
   sLineHeader = sLineHeader & "#" & Range("B6") & "#,"
   sLineHeader = sLineHeader & "#" & Range("B7") & "#,"
   sLineHeader = sLineHeader & "#" & Range("B8") & "#,"
   sLineHeader = sLineHeader & "#" & Range("B9") & "#,"
   sLineHeader = sLineHeader & "#" & Range("B10") & "#,"
   sLineHeader = sLineHeader & "##," '"#" & Range("B") & "#,"
   sLineHeader = sLineHeader & "##," '"#" & Range("B") & "#,"
   sLineHeader = sLineHeader & "##," '"#" & Range("B") & "#,"
   sLineHeader = sLineHeader & Range("B11") & ","
   sLineHeader = sLineHeader & "#" & Range("B12") & "#,"
   sLineHeader = sLineHeader & "#" & Range("B13") & "#,"
   sLineHeader = sLineHeader & "#" & Range("B14") & "#,"
   sLineHeader = sLineHeader & "#" & Range("B15") & "#,"
   sLineHeader = sLineHeader & "#" & Range("B16") & "#"

Else
   rCount = ActiveCell.SpecialCells(xlLastCell).Row
   Range("C" & rCount & ":F" & rCount).Select
   Selection.FormulaR1C1 = "=SUM(R[-" & rCount - 2 & "]C:R[-1]C)"
   tVal1 = Round(Range("C" & rCount), 0)
   tVal2 = Round(Range("D" & rCount), 0)
   tVal3 = Round(Range("E" & rCount), 0)
   tVal4 = Round(Range("F" & rCount), 0)
   
   Sheets("Optiuni").Select
   Range("B18") = tVal3
   Range("B19") = tVal4
   Range("B20") = tVal1
   Range("B21") = tVal2
   
   j = 0
   For i = 0 To UBound(aCifNoDups)
       If Not aCifNoDups(i, 0) = vbNullString Then _
          j = j + 1
   Next i

   Range("B17") = j

   Sheets("D394_UF").Select
   Range("C" & rCount & ":F" & rCount).Select
   Selection.ClearContents

   Range("A2").Select
   Sheets("Optiuni").Select
   sLineHeader = sLineHeader & Range("B2") & ","
   sLineHeader = sLineHeader & Range("B3") & ","
   sLineHeader = sLineHeader & "#" & Range("B4") & "#,"
   sLineHeader = sLineHeader & Range("B5") & ","
   sLineHeader = sLineHeader & "#" & Range("B6") & "#,"
   sLineHeader = sLineHeader & "#" & Range("B7") & "#,"
   sLineHeader = sLineHeader & "#" & Range("B8") & "#,"
   sLineHeader = sLineHeader & "#" & Range("B9") & "#,"
   sLineHeader = sLineHeader & "#" & Range("B10") & "#,"
   sLineHeader = sLineHeader & Range("B11") & ","
   sLineHeader = sLineHeader & "#" & Range("B12") & "#,"
   sLineHeader = sLineHeader & "#" & Range("B13") & "#,"
   sLineHeader = sLineHeader & "#" & Range("B14") & "#,"
   sLineHeader = sLineHeader & "#" & Range("B15") & "#,"
   sLineHeader = sLineHeader & "#" & Range("B16") & "#,"
   sLineHeader = sLineHeader & Range("B17") & ","
   sLineHeader = sLineHeader & Range("B18") & ","
   sLineHeader = sLineHeader & Range("B19") & ","
   sLineHeader = sLineHeader & Range("B20") & ","
   sLineHeader = sLineHeader & Range("B21")
End If

Select Case inTipExport
   Case "Detalii"
      fName = Range("B22") & "\394\D394_" & Range("B5") & Range("B4") & "_" & Range("B3") & ".txt"
   Case "Total"
      fName = Range("B22") & "\394UF\394_SSAA_JCCCCCCCCCC.TXT"
      fName = Replace(fName, "SS", Range("B4"))
      fName = Replace(fName, "AA", Right(Range("B5"), 2))
      fName = Replace(fName, "CCCCCCCCCC", Range("B3"))
End Select

iHandle = FreeFile
Open fName For Output As #iHandle
sLine = sLineHeader
Print #iHandle, sLine

If inTipExport = "Detalii" Then
Sheets("D394").Select

For i = 0 To UBound(aCifNoDups)
    sLine = aCifNoDups(i, 0) & aCifNoDups(i, 1)
    If Not aCifNoDups(i, 0) = vbNullString Then _
       Print #iHandle, sLine
Next i

sLine = "STOP1"
Print #iHandle, sLine

For i = 2 To ActiveCell.SpecialCells(xlLastCell).Row
   If Range("I" & i) <> 0 Then
      sLine = vbNullString
      sLine = sLine & TestRegExp("\d+", Range("D" & i) & "", False) & "," & _
              Round(Range("I" & i) + Range("J" & i), 2) & "," & _
              Round(Range("I" & i), 2) & "," & _
              Round(Range("J" & i), 2)
      Print #iHandle, sLine
   End If
Next i

sLine = "STOP2"
Print #iHandle, sLine

For i = 2 To ActiveCell.SpecialCells(xlLastCell).Row
   If Range("K" & i) <> 0 Then
      sLine = vbNullString
      sLine = sLine & TestRegExp("\d+", Range("D" & i) & "", False) & "," & _
              Round(Range("K" & i) + Range("L" & i), 2) & "," & _
              Round(Range("K" & i), 2) & "," & _
              Round(Range("L" & i), 2)
      Print #iHandle, sLine
   End If
Next i

Else 'Tip Export: Total
Sheets("D394_UF").Select

For i = 2 To ActiveCell.SpecialCells(xlLastCell).Row
   If Not Range("C" & i) = 0 Then
      sLine = vbNullString
      sLine = sLine & _
              "#A#," & _
              TestRegExp("\d+", Range("A" & i) & "", False) & "," & _
              "#" & Range("B" & i) & "#," & _
              Round(Range("C" & i), 0) & "," & _
              Round(Range("D" & i), 0)
      Print #iHandle, sLine
   End If
   If Not Range("E" & i) = 0 Then
      sLine = vbNullString
      sLine = sLine & _
              "#L#," & _
              TestRegExp("\d+", Range("A" & i) & "", False) & "," & _
              "#" & Range("B" & i) & "#," & _
              Round(Range("E" & i), 0) & "," & _
              Round(Range("F" & i), 0)
      Print #iHandle, sLine
   End If
Next i

End If

Close #iHandle
Call MsgBox("Operatiunea de export s-a incheiat cu succes!", vbInformation, "Export")

End Function

Public Function CheckCIFVIES(ByVal inCif As String, Optional fRet As UDCIFRET = UDCIFRET.UDCIFValid) As Variant

Dim objMSHTML As New mshtml.HTMLDocument
Dim objDocument As mshtml.HTMLDocument
Dim tArray(3, 1) As String
Dim bCIFValid As Boolean
Dim tStr As String
Dim sItem As String
Dim S As String

Set objDocument = objMSHTML.createDocumentFromUrl("http://ec.europa.eu/taxation_customs/vies/viesquer.do?ms=RO&iso=RO&vat=" & inCif & "&BtnSubmitVat=Verify", _
                                                   vbNullString)

While objDocument.readyState <> "complete"
    DoEvents
Wend

tArray(0, 0) = "Member State": tArray(0, 1) = ".+"
tArray(1, 0) = "Name": tArray(1, 1) = ".+"
tArray(2, 0) = "Address": tArray(2, 1) = ".+"
tArray(3, 0) = "VAT Validation Response": tArray(3, 1) = "\r\n.+"

If TestRegExp("Yes, valid VAT number", objDocument.documentElement.innerText) = "Yes, valid VAT number" Then
   bCIFValid = True
Else
   bCIFValid = False
End If

Select Case fRet
   Case UDCIFRET.UDCIFValid
      If Not bCIFValid Then
         GoTo Site_SystemResponse
      Else
         CheckCIFVIES = bCIFValid
      End If
   Case UDCIFRET.UDCIFMemberState
      If bCIFValid Then
         tStr = tArray(0, 0) & tArray(0, 1)
         sItem = Mid(TestRegExp(tStr, objDocument.documentElement.innerText, False), Len(tStr))
         sItem = Replace(sItem, vbCrLf, vbNullString): sItem = Replace(sItem, vbCr, vbNullString): sItem = Replace(sItem, vbLf, vbNullString): sItem = LTrim(RTrim(sItem))
         CheckCIFVIES = sItem
      Else
         GoTo Site_SystemResponse
      End If
   Case UDCIFRET.UDCIFName
      If bCIFValid Then
         tStr = tArray(1, 0) & tArray(1, 1)
         sItem = Mid(TestRegExp(tStr, objDocument.documentElement.innerText, False), Len(tStr))
         sItem = Replace(sItem, vbCrLf, vbNullString): sItem = Replace(sItem, vbCr, vbNullString): sItem = Replace(sItem, vbLf, vbNullString): sItem = LTrim(RTrim(sItem))
         CheckCIFVIES = sItem
      Else
         GoTo Site_SystemResponse
      End If
   Case UDCIFRET.UDCIFAddress
      If bCIFValid Then
         tStr = tArray(2, 0) & tArray(2, 1)
         sItem = Mid(TestRegExp(tStr, objDocument.documentElement.innerText, False), Len(tStr))
         sItem = Replace(sItem, vbCrLf, vbNullString): sItem = Replace(sItem, vbCr, vbNullString): sItem = Replace(sItem, vbLf, vbNullString): sItem = LTrim(RTrim(sItem))
         CheckCIFVIES = sItem
      Else
         GoTo Site_SystemResponse
      End If
   Case UDCIFRET.UDCIFAll
      If bCIFValid Then
         tStr = tArray(0, 0) & tArray(0, 1)
         sItem = Mid(TestRegExp(tStr, objDocument.documentElement.innerText, False), Len(tStr))
         sItem = Replace(sItem, vbCrLf, vbNullString): sItem = Replace(sItem, vbCr, vbNullString): sItem = Replace(sItem, vbLf, vbNullString): sItem = LTrim(RTrim(sItem))
         CheckCIFVIES = sItem
      Else
         GoTo Site_SystemResponse
      End If
   Case UDCIFRET.UDCIFSystemResponse
Site_SystemResponse:
      tStr = tArray(3, 0) & tArray(3, 1)
      sItem = Mid(TestRegExp(tStr, objDocument.documentElement.innerText, False), Len(tStr) - 3)
      sItem = Replace(sItem, vbCrLf, vbNullString): sItem = Replace(sItem, vbCr, vbNullString): sItem = Replace(sItem, vbLf, vbNullString): sItem = LTrim(RTrim(sItem))
      CheckCIFVIES = sItem
End Select

Set objDocument = Nothing
Set objMSHTML = Nothing

End Function

Function TestRegExp(ByVal myPattern As String, _
                    ByVal myString As String, _
                    Optional inGlobal As Boolean = True, _
                    Optional bRetAll As Boolean = False)
   'Create objects.
   Dim objRegExp As RegExp
   Dim objMatch As Match
   Dim colMatches As MatchCollection
   Dim RetStr As String
   Dim aURL() As String
   Dim i As Integer
   
   ' Create a regular expression object.
   Set objRegExp = New RegExp

   'Set the pattern by using the Pattern property.
   objRegExp.Pattern = myPattern

   ' Set Case Insensitivity.
   objRegExp.IgnoreCase = True

   'Set global applicability.
   objRegExp.Global = inGlobal

   'Test whether the String can be compared.
   If (objRegExp.test(myString) = True) Then

   'Get the matches.
    Set colMatches = objRegExp.Execute(myString)   ' Execute search.
        
    i = -1
    For Each objMatch In colMatches   ' Iterate Matches collection.
      'RetStr = RetStr & "Match found at position "
      'RetStr = RetStr & objMatch.FirstIndex & ". Match Value is '"
      'RetStr = RetStr & objMatch.value & "'." & vbCrLf
      ReDim Preserve aURL(i + 1): i = i + 1
      aURL(i) = objMatch.Value
      RetStr = objMatch.Value
    Next
   Else
    RetStr = "String Matching Failed"
   End If
   
   If Not bRetAll Then
      TestRegExp = RetStr
   Else
      TestRegExp = aURL
   End If

'Print TestRegExp("[A-Z]{2}\d+", "RO6959548")
'Print TestRegExp("\D{2}\d{2}\D{4}[A-Z0-9]{16}", "^%988347 oisd uiosdg9873 09 erpo hgfpofg 655415616515641RO24BRDE441SV35229564410897 kjfdc hkuhgdi6r 8ifwef")
'Print TestRegExp(".at", "bat")

End Function

Function CheckCIF(ByVal inCif As String) As String
Dim a(8) As Byte
Dim sCIFRev As String
Dim i As Integer
Dim dKey As Integer
Dim bKeyMod As Byte

If inCif = "0" Then
   CheckCIF = False
   Exit Function
End If

a(0) = 2: a(1) = 3: a(2) = 5: a(3) = 7: a(4) = 1: a(5) = 2: a(6) = 3: a(7) = 5: a(8) = 7

If Len(inCif) > 10 Then
   CheckCIF = False
   Exit Function
End If

For i = 1 To Len(inCif)
    If Not IsNumeric(Mid(inCif, i, 1)) Then
       CheckCIF = False
       Exit Function
    End If
Next i

sCIFRev = StrReverse(inCif)
dKey = 0
For i = 1 To Len(sCIFRev)
    If Not i = 1 Then
       dKey = dKey + a(i - 2) * Mid(sCIFRev, i, 1)
    End If
Next i

dKey = dKey * 10
bKeyMod = dKey Mod 11

If bKeyMod = 10 Then bKeyMod = 0
If bKeyMod = CByte(Right(inCif, 1)) Then
   CheckCIF = CDbl(inCif)
Else
   CheckCIF = False
End If

End Function

'Sub Check()
'    Range("M2").Select
'    ActiveCell.FormulaR1C1 = "=CheckCIFVIES(CheckCIF(TestRegExp(""\d+"",RC[-9])))"
'    Range("M2").Select
'    Selection.AutoFill Destination:=Range("M2:M" & ActiveCell.SpecialCells(xlLastCell).Row), Type:=xlFillDefault
'    Range("M2").Select

'    Call MsgBox("Verificarea s-a incheiat cu succes!", vbInformation, "D394")
'End Sub

Function FilterDuplicates(arr As Variant) As Variant
    Dim col As Collection, index As Long, dups As Long
    Set col = New Collection
    
    On Error Resume Next
    
    For index = LBound(arr) To UBound(arr)
        ' build the key using the array element
        ' an error occurs if the key already exists
        If CStr(arr(index)) = vbNullString Then GoTo NextIndex
        col.Add 0, CStr(arr(index))
        If Err Then
            ' we've found a duplicate
            arr(index) = Empty
            dups = dups + 1
            Err.Clear
        ElseIf dups Then
            ' if we've found one or more duplicates so far
            ' we need to move elements towards lower indices
            arr(index - dups) = arr(index)
            arr(index) = Empty
        End If
NextIndex:
    Next
    
    ' return the number of duplicates
    
    If dups Then
       ReDim Preserve arr(LBound(arr) To UBound(arr) - dups) As String
    End If
    FilterDuplicates = arr
    
End Function

Function FilterDuplicates2(arr As Variant, aIndex As Byte)
Dim tArray1() As Variant
Dim tArray2() As Variant
Dim i As Long, j As Long
Dim bFound As Boolean

ReDim tArray1(UBound(arr))

For i = 0 To UBound(tArray1)
    tArray1(i) = arr(i, aIndex)
Next i

tArray2 = FilterDuplicates(tArray1)

For i = 0 To UBound(arr)
    bFound = False
    For j = 0 To UBound(tArray2)
        If arr(i, aIndex) = tArray2(j) Then
           bFound = True
           tArray2(j) = vbNullString
           GoTo NextJ
        End If
    Next j
NextJ:
    If Not bFound Then
       arr(i, aIndex) = vbNullString
    End If
Next i

FilterDuplicates2 = arr

End Function

'Sub ExportD394_UF()
'Call fExportD394("Total")

'End Sub

Sub ExportD394()
'Call fExportD394
Application.ScreenUpdating = False
Call fXMLExport
Application.ScreenUpdating = True

End Sub

Function fCheckD394Config() As Boolean
Dim sD394exe As String
Dim sD394folder As String
Dim sD394folder_UF As String

fCheckD394Config = True
sD394exe = Range("B22") & "\D394.exe"
sD394folder = Range("B22") & "\394"
sD394folder_UF = Range("B22") & "\394_UF"

If Dir(sD394exe) = vbNullString Then
   Call MsgBox("Fisierul 'D394.exe' nu exista in calea specificata.", vbCritical, "Export D394")
   fCheckD394Config = False
   Exit Function
End If

If Dir(sD394folder, vbDirectory) = vbNullString Then
   Call MsgBox("Folderul '394' nu exista in calea specificata.", vbCritical, "Export D394")
   fCheckD394Config = False
   Exit Function
End If

If Dir(sD394folder_UF, vbDirectory) = vbNullString Then
   Call MsgBox("Folderul '394_UF' nu exista in calea specificata.", vbCritical, "Export D394")
   fCheckD394Config = False
   Exit Function
End If

If Not L_SDECIMAL = "." Then
   Call MsgBox("Pentru functionarea corecta a declaratiei 394 trebuie ca separatorul decimal sa fie punct. Separator actual: '%#0'.", vbCritical, "Export D394")
   fCheckD394Config = False
   Exit Function
End If

If IsProcessRunning("D394.exe") Then
   Call MsgBox("Programul de la ANAF pentru prelucrarea declaratiilor este deschis.%#0Va rugam sa inchideti programul si sa incercati din nou.", vbCritical, "Export D394")
   fCheckD394Config = False
   Exit Function
End If

End Function

Public Function IsProcessRunning(ByVal sProcess As String) As Boolean
    Const MAX_PATH As Long = 260
    Dim lProcesses() As Long, lModules() As Long, N As Long, lRet As Long, hProcess As Long
    Dim sName As String
   
    sProcess = UCase$(sProcess)
  
    ReDim lProcesses(1023) As Long
    If EnumProcesses(lProcesses(0), 1024 * 4, lRet) Then
        For N = 0 To (lRet \ 4) - 1
            hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, lProcesses(N))
            If hProcess Then
                ReDim lModules(1023)
                If EnumProcessModules(hProcess, lModules(0), 1024 * 4, lRet) Then
                    sName = String$(MAX_PATH, vbNullChar)
                    GetModuleBaseName hProcess, lModules(0), sName, MAX_PATH
                    sName = Left$(sName, InStr(sName, vbNullChar) - 1)
                    If Len(sName) = Len(sProcess) Then
                        If sProcess = UCase$(sName) Then IsProcessRunning = True: Exit Function
                    End If
                End If
            End If
            CloseHandle hProcess
        Next N
    End If
End Function

Function Locale(ByVal locName As Long)
Dim lplcdata As String * 255
Dim cchData As Long

cchData = 0

Call GetLocaleInfo(GetSystemDefaultLCID(), locName, lplcdata, 255)
Locale = Mid(lplcdata, 1, GetLocaleInfo(GetSystemDefaultLCID(), locName, lplcdata, cchData) - 1)
End Function

Function fSaveTextToFile(ByVal infName As String, _
                         ByVal inText As String)
Dim sFolder As String
On Error Resume Next

sFolder = GetFileInfo(infName, UDFIPath)
If Dir(sFolder, vbDirectory) = vbNullString Then
   Call MkDir(sFolder)
End If

Open infName For Output As #1
Print #1, inText
Close #1

End Function

Function ShellAndWait(sFilePath As String, Optional sCommandLine, Optional lState As VbAppWinStyle = vbNormalFocus, Optional lMaxTimeOut As Long = -1) As Boolean
    Dim lRetVal As Long, siStartTime As Single, lProcID As Long

    'Check to see that the file exists
    If Not Dir(sFilePath) = vbNullString Then
        'Add double quotes around the path (otherwise you can't use spaces in the path)
        If Left$(sFilePath, 1) <> Chr(34) Then
            sFilePath = Chr(34) & sFilePath
        End If
        If Right$(sFilePath, 1) <> Chr(34) Then
            sFilePath = sFilePath & Chr(34)
        End If
    End If
    
    'Start the shell
    If Not IsMissing(sCommandLine) Then
       lRetVal = Shell(Trim$(sFilePath + " " + sCommandLine), lState)
    Else
       lRetVal = Shell(Trim$(sFilePath), lState)
    End If
    'Open the process
    lProcID = OpenProcess(SYNCHRONIZE, True, lRetVal)
    
    siStartTime = Timer
    Do
        lRetVal = WaitForSingleObject(lProcID, 0)
        If lRetVal = WAIT_OBJECT_0 Then
            'Finished process
            lRetVal = CloseHandle(lProcID)
            ShellAndWait = False
            Exit Do
        ElseIf lRetVal = WAIT_FAILED Then
            lRetVal = CloseHandle(lProcID)
            'Failed to open process
            ShellAndWait = True
            Exit Do
        End If
        Sleep 100
        If lMaxTimeOut > 0 Then
            'Check timeout has not been exceeded
            If siStartTime + lMaxTimeOut < Timer Then
                'Failed, timeout exceeded
                lRetVal = CloseHandle(lProcID)
                ShellAndWait = True
            End If
        End If
    Loop
End Function

'Demonstration routine
Function DeleteCookieByName(ByVal scName As String)
    Dim avURLs As Variant, vThisValue As Variant
    
    On Error Resume Next
    'Return an array of all internet cache files
'    For Each vThisValue In avURLs
'        'Print files
'        Debug.Print CStr(vThisValue)
'    Next
'
'    'Return the an array of all cookies
'    avURLs = InternetCacheList(eCookie)
'    If MsgBox("Delete cookies?", vbQuestion + vbYesNo) = vbYes Then
'        For Each vThisValue In avURLs
'            'Delete cookies
'            InternetDeleteCache CStr(vThisValue)
'            Debug.Print "Deleted " & vThisValue
'        Next
'    Else
'        For Each vThisValue In avURLs
'            'Print cookie files
'            Debug.Print vThisValue
'        Next
'    End If

InternetDeleteCache CStr(scName)

End Function


'Purpose     :  Deletes the specified internet cache file
'Inputs      :  sCacheFile              The name of the cache file
'Outputs     :  Returns True on success.


Function InternetDeleteCache(sCacheFile As String) As Boolean
    InternetDeleteCache = CBool(DeleteUrlCacheEntry(sCacheFile))
End Function






Attribute VB_Name = "mBitmapToPicture"
Option Explicit
 
Private Const vbPicTypeBitmap = 1
 
Private Type IID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type
 
Private Type PictDesc
    Size As Long
    Type As Long
        hBmp As Long
        hPal As Long
        Reserved As Long
    End Type
     
#If Win64 Then
    Private Declare PtrSafe Function apiDeleteObject Lib "gdi32" Alias "DeleteObject" (ByVal hObject As Long) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PictDesc, RefIID As IID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
    Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
#Else
    Private Declare Function OleCreatePictureIndirect Lib _
    "olepro32.dll" _
    (PicDesc As PictDesc, RefIID As IID, _
    ByVal fPictureOwnsHandle As Long, _
    IPic As IPicture) As Long
     
     '''Windows API Function Declarations
     
     'Does the clipboard contain a bitmap/metafile?
    Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
     
     'Open the clipboard to read
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
     
     'Get a pointer to the bitmap/metafile
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
     
     'Close the clipboard
    Private Declare Function CloseClipboard Lib "user32" () As Long
     
     'Create our own copy of the metafile, so it doesn't get wiped out by    subsequent clipboard updates.
    Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
     
     'Create our own copy of the bitmap, so it doesn't get wiped out by     subsequent clipboard updates.
    Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
    Private Declare Function apiDeleteObject Lib "gdi32" Alias "DeleteObject" (ByVal hObject As Long) As Long
#End If
     'The API format types we're interested in
    Const CF_BITMAP = 2
    Const CF_PALETTE = 9
    Const CF_ENHMETAFILE = 14
    Const IMAGE_BITMAP = 0
    Const LR_COPYRETURNORG = &H4
     ' Addded by SL Apr/2000
    Const xlPicture = CF_BITMAP
    Const xlBitmap = CF_BITMAP
     
    Public Function BitmapToPicture(ByVal hBmp As Long, _
        Optional ByVal hPal As Long = 0&) _
        As IPicture '
         
         ' The following code is adapted from
         ' Bruce McKinney's "Hardcore Visual Basic"
         ' And Code samples from:
         ' http://www.mvps.org/vbnet/code/bitmap/printscreenole.htmv
         ' and examples posted on MSDN
         
         ' The handle to the Bitmap created by CreateDibSection
         ' cannot be passed directly as the PICTDESC.Bitmap element
         ' that get's passed to OleCreatePictureIndirect.
         ' We need to create a regular bitmap from our CreateDibSection
         'Dim hBmptemp As Long, hBmpOrig As Long
         'Dim hDCtemp As Long
         
         'Fill picture description
        Dim lngRet As Long
        Dim IPic As IPicture, picdes As PictDesc, iidIPicture As IID
         
         'hDCtemp = apiCreateCompatibleDC(0)
         'hBmptemp = apiCreateCompatibleBitmap _
         '(mhDCImage, lpBmih.bmiHeader.biWidth, _
         'lpBmih.bmiHeader.biHeight)
         
         'hBmpOrig = apiSelectObject(hDCtemp, hBmptemp)
         
         '  lngRet = apiBitBlt(hDCtemp, 0&, 0&, lpBmih.bmiHeader.biWidth, _
         '        lpBmih.bmiHeader.biHeight, mhDCImage, 0, 0, SRCCOPY)
         
         'hBmptemp = apiSelectObject(hDCtemp, hBmpOrig)
         'Call apiDeleteDC(hDCtemp)
         
        picdes.Size = Len(picdes)
        picdes.Type = vbPicTypeBitmap
        picdes.hBmp = hBmp
         
         ' No palette info here
         ' Everything is 24bit for now
         
        picdes.hPal = hPal
         ' ' Fill in magic IPicture GUID        {7BF80980-BF32-101A-8BBB-00AA00300CAB}
        iidIPicture.Data1 = &H7BF80980
        iidIPicture.Data2 = &HBF32
        iidIPicture.Data3 = &H101A
        iidIPicture.Data4(0) = &H8B
        iidIPicture.Data4(1) = &HBB
        iidIPicture.Data4(2) = &H0
        iidIPicture.Data4(3) = &HAA
        iidIPicture.Data4(4) = &H0
        iidIPicture.Data4(5) = &H30
        iidIPicture.Data4(6) = &HC
        iidIPicture.Data4(7) = &HAB
         '' Create picture from bitmap handle
        lngRet = OleCreatePictureIndirect(picdes, iidIPicture, True, IPic)
         '' Result will be valid Picture or Nothing-either way set it
        Set BitmapToPicture = IPic
    End Function
     
    Function GetClipBoard() As Long
         ' Adapted from original Source Code by:
         '* MODULE NAME:     Paste Picture
         '* AUTHOR & DATE:   STEPHEN BULLEN, Business Modelling Solutions Ltd.
         '*                  15 November 1998
         '*
         '* CONTACT:         Step...@BMSLtd.co.uk
         '* WEB SITE:        http://www.BMSLtd.co.uk
         
         ' Handles for graphic Objects
        Dim hClipBoard As Long
        Dim hBitmap As Long
        Dim hBitmap2 As Long
         
         'Check if the clipboard contains the required format
         'hPicAvail = IsClipboardFormatAvailable(lPicType)
         
         ' Open the ClipBoard
        hClipBoard = OpenClipboard(0&)
         
        If hClipBoard <> 0 Then
             ' Get a handle to the Bitmap
            hBitmap = GetClipboardData(CF_BITMAP)
             
            If hBitmap = 0 Then GoTo exit_error
             ' Create our own copy of the image on the clipboard, in the
             'If lPicType = CF_BITMAP Then
            hBitmap2 = CopyImage(hBitmap, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
             '   Else
             '  hBitmap2 = CopyEnhMetaFile(hBitmap, vbNullString)
             ' End If
             
             'Release the clipboard to other programs
            hClipBoard = CloseClipboard
             
            GetClipBoard = hBitmap2
            Exit Function
             
        End If
         
exit_error:
         ' Return False
        GetClipBoard = -1
    End Function
     

 
Function fSaveKaptcha()
     ' *********************
     ' You must set a Reference to:
     ' "OLE Automation"
     ' for this function to work.
     ' Goto the Menu and select
     ' Tools->References
     ' Scroll down to:
     ' Ole Automation
     ' and click in the check box to select
     ' this reference.
     
    Dim lngRet As Long
    Dim lngBytes As Long
    Dim hPix As IPicture
    Dim hBitmap As Long
     'Dim hPicBox As StdPicture
     
    'Me.OLEBound19.SetFocus
     'Me.OLEbound19.SizeMode = acOLESizeZoom
    'DoCmd.RunCommand acCmdCopy
    hBitmap = GetClipBoard
    Set hPix = BitmapToPicture(hBitmap)
    SavePicture hPix, GetTmpPath & "kaptcha.bmp"
    apiDeleteObject (hBitmap)
     
    Set hPix = Nothing
End Function
 
 ' Here's the code behind the code module
 





Attribute VB_Name = "mMFinante"
Option Explicit
Public Enum UDCIFMFinanteRET
   UDCIFValid = 0
   UDCIFDenumirePlatitor = 1
   UDCIFAdresa = 2
   UDCIFJudet = 3
   UDCIFNrRegCom = 4
   UDCIFCodPostal = 6
   UDCIFTelefon = 7
   UDCIFStareSocietate = 9
   UDCIFDataInreg = 11
   UDCIFTva = 19
   UDCIFAll = -1
End Enum

Public Enum UDFileInfo
   UDFIPath = 0
   UDFIFileName = 1
   UDFIFileExt = 2
End Enum

Dim sLink As String
Const MAX_PATH = 260
Const bRequest = 5

Public Function GetTmpPath()

Dim sFolder As String ' Name of the folder
Dim lRet As Long ' Return Value
…