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 = "Sheet3"
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
    Private 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
    Private 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
'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

'Private 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)
Const MAX_PATH = 260

'Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
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

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

End Function

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

Public Function GetTmpPath()

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

sFolder = String(MAX_PATH, 0)
lRet = GetTempPath(MAX_PATH, sFolder)

If lRet <> 0 Then
GetTmpPath = Left(sFolder, InStr(sFolder, _
Chr(0)) - 1)
Else
GetTmpPath = vbNullString
End If

End Function

Public Function GetPathOnly(sPath As String) As String
GetPathOnly = Left(sPath, InStrRev(sPath, "\", Len(sPath)) - 1)

End Function

Function GetFileInfo(ByVal infName As String, _
                     Optional fRet As UDFileInfo = UDFileInfo.UDFIPath, _
                     Optional sUrl As Boolean = False) As String
Dim i As Integer
Dim fName As String, fPath As String, fExt As String
Dim spSep As String

If sUrl Then spSep = "/" Else spSep = "\"

For i = Len(infName) To 1 Step -1
    If mId(infName, i, 1) = spSep Then
       fName = mId(infName, i + 1)
       fPath = mId(infName, 1, i - 1)
       If InStr(fName, ".") = 0 Then
          fExt = vbNullString
       Else
          fExt = mId(fName, InStr(fName, ".") + 1)
       End If
       Exit For
    End If
Next i

Select Case fRet
   Case UDFileInfo.UDFIPath
      GetFileInfo = fPath
   Case UDFileInfo.UDFIFileName
      GetFileInfo = fName
   Case UDFileInfo.UDFIFileExt
      GetFileInfo = fExt
End Select

End Function

Function dl_file(ByVal URL As String, Optional localFileName) As Boolean
' Note that this file is 2M, so you might want to try with something simpler
Dim errcode As Long

If IsMissing(localFileName) Then _
   localFileName = GetTmpPath & "\" & GetFileInfo(URL, UDFIFileName, True)

Call DeleteUrlCacheEntry(URL)
errcode = URLDownloadToFile(0&, URL, localFileName, 0&, 0&)
If errcode = 0 Then
   dl_file = True
Else
   dl_file = False
End If

End Function

Function fGetFileText(ByVal filename As String, Optional fResponse As Boolean = True) As String
Dim handle As Integer

' ensure that the file exists
If Len(Dir$(filename)) = 0 And fResponse Then
   'Call CustomErr("fGetFileText", tcErr(10100), Erl) 'Err.Raise 53   ' File not found
   Exit Function
End If

' open in binary mode
handle = FreeFile
Open filename$ For Binary As #handle
' read the string and close the file
fGetFileText = Space$(LOF(handle))
Get #handle, , fGetFileText
Close #handle

End Function

Function fFormatDate(ByVal sDate As String) As String
If Not TestRegExp("\d+ \D+ \d+", sDate) = "String Matching Failed" Then
   fFormatDate = Format(sDate, "yyyy-mm-dd")
ElseIf Not TestRegExp("\d+-\D+-\d+", sDate) = "String Matching Failed" Then
   fFormatDate = Format(sDate, "yyyy-mm-dd")
Else
   fFormatDate = sDate
End If

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 apiDeleteObject Lib "gdi32" Alias "DeleteObject" (ByVal hObject As Long) As Long
    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
#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
     
     '*******************************************
     'DEVELOPED AND TESTED UNDER MICROSOFT ACCESS 97 VBA ONLY
     '
     'Copyright: Lebans Holdings 1999 Ltd.
     '           May not be resold in whole or part. Please feel
     '           free to use any/all of this code within your
     '           own application without cost or obligation.
     '           Please include the one line Copyright notice
     '           if you use this function in your own code.
     '
     'Name:      BitmapToPicture &
     '           GetClipBoard
     '
     'Purpose:   Provides a method to save the contents of a
     '           Bound or Unbound OLE Control to a Disk file.
     '           This version only handles BITMAP files.
     '           '
     'Author:    Stephen Lebans
     'Email:     Step...@lebans.com
     'Web Site:  www.lebans.com
     'Date:      Apr 10, 2000, 05:31:18 AM
     '
     'Called by: Any
     '
     'Inputs:    Needs a Handle to a Bitmap.
     '           This must be a 24 bit bitmap for this release.
     '
     'Credits:
     'As noted directly in Source :-)
     '
     'BUGS:
     'To keep it simple this version only works with Bitmap files of
     '16 Or 24 bits.
     'I'll go back and add the
     'code to allow any depth bitmaps and add support for
     'metafiles as well.
     'No serious bugs notices at this point in time.
     'Please report any bugs to my email address.
     '
     'What's Missing:
     '
     '
     'HOW TO USE:
     '
     '*******************************************
     
    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
…