MS Outlook COM : Export Calendar data into Excel

'Reference Google and MSDN Site

On Error resume Next

err.clear

Sub calendarExport

Dim objWord
Dim objExcelApp
Dim objExcelBook
Dim objExcelSheets
Dim objExcelSheet
Dim objExcelRange
Dim strRange
Dim lngASC
Dim strASCII
Dim i
Dim lngCount
Dim nms
Dim objFolder
Dim objItems
Dim objItem

strSheet = "C:\Calendar.xls"

'Adjust the following number to be 1 less than the row number of the
'first body row
i = 3

'Initialize column letters with 64, so the first letter used will be A
lngASCII = 64
Set objExcelApp = CreateObject("Excel.Application")
objExcelApp.Workbooks.Open(strSheet)
Set objExcelBook = objExcelApp.ActiveWorkbook
Set objExcelSheets = objExcelBook.Worksheets
Set objExcelSheet = objExcelBook.Sheets(1)
objExcelSheet.Activate
objExcelApp.Application.Visible = True

'Set reference to default Calendar folder
Set ot = CreateObject("Outlook.Application")
Set nms = ot.GetNamespace("MAPI")
Set fld = nms.GetDefaultFolder(9)
Set itms = fld.Items
lngCount = itms.Count

'Iterate through items in Calendar folder, and export a few fields
'from each item to a row in the Calendar worksheet
For Each itm in itms
i = i + 1
' If i > 809 then
objExcelSheet.Range("H1") = (i-3)
lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
strV = itm.Start
If err.number = 0 then
If itm.Start <> "" Then objRange.Value = itm.Start
Else
objRange.Value = "Conflict with Item, not able to retrieve data"
End If

lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
strV = itm.End
If err.number = 0 then
If itm.End <> "" Then objRange.Value = itm.End
Else
objRange.Value = "Conflict with Item, not able to retrieve data"
End If

lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
On Error resume Next
strV = itm.CreationTime
If err.number = 0 then
If itm.CreationTime <> "" Then objRange.Value = itm.CreationTime
Else
objRange.Value = "Conflict with Item, not able to retrieve data"
End If

lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
strV = itm.Subject
If err.number = 0 then
If itm.Subject <> "" Then objRange.Value = itm.Subject
Else
objRange.Value = "Conflict with Item, not able to retrieve data"
End If

lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
strV = itm.Location
If err.number = 0 then
If itm.Location <> "" Then objRange.Value = itm.Location
Else
objRange.Value = "Conflict with Item, not able to retrieve data"
End If

lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
strV = itm.Categories
If err.number = 0 then
If itm.Categories <> "" Then objRange.Value = itm.Categories
Else
objRange.Value = "Conflict with Item, not able to retrieve data"
End If

lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
strV = itm.IsRecurring
If err.number = 0 then
If itm.IsRecurring <> "" Then objRange.Value = itm.IsRecurring
Else
objRange.Value = "Conflict with Item, not able to retrieve data"
End If
lngASCII = 64
' End If

Next
objExcelBook.Save
objExcelBook.Close
End Sub

Call calendarExport

MS-Outlook COM: VBS to Delete old Calendar data

'Delete old calendar items in Outlook.
'Recurring items will not be deleted.
'Items with end date less than the mentioned, would be deleted.

On Error resume Next
err.clear

Public intDel
Public Action

Sub calendarDel()

Dim i
Dim lngCount
Dim nms
Dim objFolder
Dim objItems
Dim objItem

Action = InputBox("Thanks for Using Calender Items deletion tool, Enter 1 to continue")

If Action = 1 then
'Set reference to default Calendar folder
Set ot = CreateObject("Outlook.Application")
Set nms = ot.GetNamespace("MAPI")
Set fld = nms.GetDefaultFolder(9)
Set itms = fld.Items
lngCount = itms.Count
dtEnd = InputBox("Enter date in mm/dd/yyyy format")
intDel = 0
For Each itm in itms
i = i + 1
dtOrgEnd = itm.End
blFlagday = DateDiff("d", dtEnd,dtOrgEnd)
If blFlagday < 1 Then
If not(itm.IsRecurring) Then
itm.delete
intDel = intDel + 1
End If
intnotDel = intnotDel + 1
End If
Next
Else
MsgBox "Items not deleted"
End If
End Sub

'Procedure call to execute the calendar item delete function.

calendarDel()

' Notification on the number of calendar items deleted.

If Action = 1 then
msgbox "Number of calender items deleted = "& intDel
Else
msgbox "Number of calender items not deleted = "& intnotDel
End If

Wscript: Map Network drives

'VBS to connect and disconnect network drives.
'strPath and strDrive and the shared drive path and the drive letter to be mapped.
'Assumption is that the drive letter is valid and does not contain any drives mapped to it already.
'Commented line of code can be used to disconnet the mapped network drive.

Set objNetwork = CreateObject("Wscript.Network")
strPath = "\\test\test"
strDrive = "D:"

objNetwork.MapNetworkDrive strDrive ,strPath

'Use the code below to remove any network drive connections
'objNetwork.RemoveNetworkDrive strDrive
Set objNetwork = Nothing

MS Outlook Objcet Model : Send Email with Attachments

Set myOLApp = CreateObject("Outlook.Application")
Set myNameSpace = myOLApp.GetNameSpace("MAPI")
Set olMail = myOLApp.CreateItem(olMailItem)
set WshShell = CreateObject("WScript.Shell")

attachFile = "C:\test.txt"
With olMail
.to =""
.Subject = "Test Mail from QTP with Attachments"
.Body = "This is mail"
.NoAging = True
.Display
End With

Set myAttach = olMail.Attachments
myAttach.Add(ResFile)
'To avoid the display of modal dialog when trying to send email, use shortcut key CTRL S'
WshShell.SendKeys "%{s}"
Set myAttachments = Nothing
Set olMail = Nothing
Set myOLApp = Nothing

Excel COM : Delete Rows from Sheet

strDataFile = "(File Name with Full Path)"
strCurrentSheetName = "(Sheet Name or Index)"
Set ExcelObj = CreateObject("Excel.Application")
ExcelObj.Workbooks.Open strDataFile

'Delete the first row always as the row gets shifted by one when the previous row is deleted.

For intRow = 1 To 3
ExcelObj.ActiveWorkbook.Worksheets (strCurrentSheetName).Rows(1).Delete
ExcelObj.ActiveWorkbook.save
Cnt = ExcelObj.ActiveWorkbook.Worksheets (strCurrentSheetName).Rows.count
Next
ExcelObj.Workbooks.Close
Set ExcelObj = nothing

Execute QTP Tests stored in QC through VBS file

Dim qtApp 'As QuickTest.Application ' Declare the Application object variable
Dim qtUpdateRunOptions 'As QuickTest.UpdateRunOptions ' Declare an Update Run Options object variable
Dim qtRunResultsOptions 'As QuickTest.RunResultsOptions ' Declare a Run Results Options object variable
Dim blsSupportsVerCtrl ' Declare a flag for indicating version control support
Dim td As New TDConnection
Dim tstMgr As TestSetTreeManager
Dim tsttr As TestSetFolder
Dim tsetFact As TestSetFactory
Dim tsetList as List

Set qtApp = CreateObject("QuickTest.Application") ' Create the Application object
qtApp.Launch ' Start QuickTest
qtApp.Visible = True ' Make the QuickTest application visible


' Make changes in a test on Quality Center with version control
qtApp.TDConnection.Connect "http://tdserver/tdbin", _ "MY_DOMAIN", "My_Project", "UID", "Pwd", False ' Connect to Quality Center

' If connection is successful

If qtApp.TDConnection.IsConnected Then
blsSupportsVerCtrl = qtApp.TDConnection.SupportVersionControl
'Check whether the project supports vervion control

'Retrive all the Test from QC and Save them to Local Disk
Set tstMgr = td.TestSetTreeManager
Set tsttr = tstMgr.NodeByPath("Path\Test")
Set tsetFact = tsttr.TestSetFactory
Set tsetList = tsetFact.NewList("")
For Each tset in tsetList
qtApp.Open "[QualityCenter] Subject\tests\test1", False ' Open the test
If blsSupportsVerCtrl Then ' If the project supports version control
qtApp.Test.CheckOut ' Check out the test
End If
' Prepare the UpdateRunOptions object
Set qtUpdateRunOptions = CreateObject("QuickTest.UpdateRunOptions") ' Create the Update Run Options object
' Set the Update Run options: update the Active Screen and test object descriptions. Do not update checkpoint values
qtUpdateRunOptions.UpdateActiveScreen = True
qtUpdateRunOptions.UpdateCheckpoints = False
qtUpdateRunOptions.UpdateTestObjectDescriptions = True
' Prepare the RunResultsOptions object
Set qtRunResultsOptions = CreateObject("QuickTest.RunResultsOptions") ' Create the Run Results Options object
qtRunResultsOptions.ResultsLocation = "" ' Set a temporary results location

If blsSupportsVerCtrl And qtApp.Test.VerCtrlStatus = "CheckedOut" Then ' If the test is checked out
qtApp.Test.CheckIn ' Check it in
End If

Next

qtApp.TDConnection.Disconnect ' Disconnect from Quality Center
Else
MsgBox "Cannot connect to Quality Center" ' If connection is not successful, display an error message.

End If

'Exit QuickTest

qtApp.Quit
Set qtApp = nothing