1 (05 Apr 2018 11:47:29 отредактировано crazy_man)

Тема: Вытащить размер папок Outlook

Скрипт вытаскивает  размер папок Outlook и упорядочивает их по убыванию, т.е. сверху будут самые большие папки.

Const olFolderDeletedItems = 3
Const olFolderSentMail = 5
Const olFolderInbox = 6
Const olFolderDrafts = 16
 
scriptfile=Wscript.ScriptFullName
sSourcefolder = Left(scriptfile,InStrRev(scriptfile, "\")-1)
set oShell = CreateObject("WScript.Shell")
strUsername = oShell.ExpandEnvironmentStrings( "%USERNAME%" )
Set objExplorer = CreateObject("InternetExplorer.Application")
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set arrSize = CreateObject("Scripting.Dictionary")
Set objFSO = CreateObject("Scripting.FileSystemObject")
 
Initalize("Outlook Folder Size")
For Each oFolder In objNamespace.Folders
       k=0
       For Each oChildFolder In oFolder.Folders
              k=k+1: p=round((k*100)/oFolder.Folders.Count,2)
              Call total(p,oChildFolder.Name)
              Call GetSize(oChildFolder)
       next
Next
 
Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)
'Возвратить размер подпапок
GetSubfolders(objInbox)
 
'Сортируем массив (словарь)
Set arrSize=SortDict(arrSize)
 
'Вывод результатов
totalsize=0
For i = 0 To arrSize.Count - 1
       intSize=Round((arrSize.Items()(i)/1024)/1024,2)
       totalsize=totalsize+intsize
    sClipboard = sClipboard & arrSize.Keys()(i)";" & intSize & ";MB" & vbCrLf
       if i<7 then sText = sText & arrSize.Keys()(i)" => " & intSize & " MB" & vbCrLf
Next
sClipboard = sClipboard & vbcrlf & String(10, "-") & vbcrlf & "Всего;" & totalsize & ";МБ"
sText = sText & vbcrlf & String(10, "-") & vbcrlf"Всего => " & totalsize & " MB"
 
 
Set objFile = objFSO.OpenTextFile(sSourcefolder & "\" & strUsername & "_outlook_folder_size.csv", 2, true)
objFile.Write  sClipboard
objFile.close
destroy()
 
msgbox "Первые 7 наибольших папок в Outlook:" & vbcrlf & sText & vbcrlf & vbcrlf & "Полный список папок в " & strUsername & "_outlook_folder_size.csv", vbInformation
 
 
Sub GetSubfolders(objParentFolder)
    Set colFolders = objParentFolder.Folders
       k=0
    For Each objFolder in colFolders
              k=k+1: p=round((k*100)/colFolders.Count,2)
              Call total(p,objFolder.Name)
        Set objSubfolder = objParentFolder.Folders(objFolder.Name)
              GetSize objFolder
 
        GetSubfolders objSubfolder
    Next
 
End Sub
 
sub GetSize(objFolder)
       intSize=0
       if not arrSize.Exists(objFolder.Name) then
              Set colItems = objFolder.Items
              For Each objItem in colItems
                     z=z+1: p=round((z*100)/colItems.Count,2)
                     Call current(p,vbnullstring)': msgbox p
                     intSize = intSize + objItem.Size
              Next
              arrSize.Add objFolder.Name,intSize
        end if
end sub
 
Function SortDict(Dict)
    'Allocate storage space for the dynamic array
    ReDim Arr(Dict.Count - 1, 1)
 
    'Fill the array with the keys and items from the Dictionary
    For i = 0 To Dict.Count - 1
        'msgbox Dict.Keys()(i)
              Arr(i, 0) = Dict.Keys()(i)
        Arr(i, 1) = Dict.Items()(i)
    Next
 
    'Sort the array using the bubble sort method
    For i = LBound(Arr, 1) To UBound(Arr, 1) - 1
        For j = i + 1 To UBound(Arr, 1)
            If Arr(i, 1) < Arr(j, 1) Then
                Temp1 = Arr(j, 0)
                Temp2 = Arr(j, 1)
                Arr(j, 0) = Arr(i, 0)
                Arr(j, 1) = Arr(i, 1)
                Arr(i, 0) = Temp1
                Arr(i, 1) = Temp2
            End If
        Next
    Next
 
    'Clear the Dictionary
    Dict.RemoveAll
 
    'Add the sorted keys and items from the array back to the Dictionary
    For i = LBound(Arr, 1) To UBound(Arr, 1)
        Dict.Add Arr(i, 0), Arr(i, 1)
    Next
 
       Set SortDict=Dict
End Function
 
function CopyToClipboard(sText)
        Set objIE = CreateObject("InternetExplorer.Application")
        objIE.Navigate("about:blank")
        objIE.document.parentwindow.clipboardData.SetData "text", sText
        objIE.Quit       
 
              'Set WshShell = CreateObject("WScript.Shell")
              'Set oExec = WshShell.Exec("clip")
              'Set oBuff = oExec.stdIn
              'oBuff.WriteLine sText
end function
 
sub Initalize(sTitle)
 
 
       objExplorer.Navigate "about:blank"   
       objExplorer.ToolBar = 0
       objExplorer.StatusBar = 0
       objExplorer.Left = 200
       objExplorer.Top = 200
       objExplorer.Width = 400
       objExplorer.Height = 200
       objExplorer.Visible = 1   
       objExplorer.Document.Title = sTitle
       objExplorer.Document.Body.InnerHTML = "Итого: <a id='text1'>0</a> % complete, <a id='msg1'></a><br/><div style='background-color:blue;width:5px;height:10px;' id='p1'></div><br>"
 
       objExplorer.Document.Body.InnerHTML = objExplorer.Document.Body.InnerHTML & "Current Folder: <a id='text2'>0</a> % complete, <a id='msg2'></a>" _
       & "<br/><div style='background-color:orange;width:5px;height:10px;' id='p2'></div>"
end sub
 
sub total(intPercentComplete, sText)
       objExplorer.document.getElementById("text1").innerText=intPercentComplete
       objExplorer.document.getElementById("msg1").innerText=sText
       objExplorer.document.getElementById("p1").style.width=intPercentComplete*3
end sub
 
sub current(intPercentComplete,sText)
       objExplorer.document.getElementById("text2").innerText=intPercentComplete
       objExplorer.document.getElementById("msg2").innerText=sText
       objExplorer.document.getElementById("p2").style.width=intPercentComplete*3
end sub
 
sub destroy()
       objExplorer.Quit
end sub