Option Public
Declare Sub keybd_event Lib "user32.dll" (Byval bVk As Integer, Byval bScan As Integer, Byval dwFlags As Integer,Byval dwExtraInfo As Integer)
Dim curDB As NotesDatabase
Dim collection As NotesDocumentCollection
Dim curDoc As NotesDocument
Dim strURL As String

Sub Initialize
	'# Handle Error
	'# Assumption
	Dim session As New NotesSession
	Set curDB = session.CurrentDatabase
	Dim lsFileName As String
	Dim workspace As New NotesUIWorkspace
	Dim uidoc As NotesUIDocument
	Set uidoc = workspace.CurrentDocument
	Dim rtitem As NotesRichTextItem
	Dim object As NotesEmbeddedObject
	Set collection = curDB.UnprocessedDocuments
	Set curDoc = collection.GetFirstDocument()

	While Not(curDoc Is Nothing)
		strURL = Mid$(curDB.Server, 4, Instr( curDB.Server, "/O=" )-4 )
		strURL = "http://" + strURL+ "/" +   curDB.FilePath + "/0/" + curDoc.UniversalID
		Call CopyIEContents( strURL)
		lsPath = "C:ExportQuality"
		lsFileName$ = lsPath + "z.doc"

		'lsFileName = "C:ExportQualityTest.doc"
		Call PasteIEContentsToWord(lsFileName )

		'Set rtitem = New NotesRichTextItem( curDoc, "Body" )
		'Set object = rtitem.EmbedObject ( EMBED_ATTACHMENT, "", "c:test.doc" )
		'Call curDoc.Save( True, True )
		Set curDoc = collection.GetNextDocument (curDoc)
	Wend
End Sub

Sub Terminate
End Sub

Sub CopyIEContents( URL As String)

	Dim IE As Variant
	Set IE=CreateObject("InternetExplorer.Application")
	IE.ToolBar=True
	IE.Resizable=True
	IE.Navigate(URL)
	IE.visible=True
	Do While IE.Busy
		Yield
	Loop
	' select the document
	keybd_event 18,0,0,0 ' Alt key down
	keybd_event Asc("E"),0,0,0 ' A key down -- invokes actions
	keybd_event Asc("E"),0,2,0 ' A key up -- invokes actions
	keybd_event 18,0,2,0 ' Alt key up
	keybd_event Asc("A"),0,0,0 ' W key down -- invokes actions
	keybd_event Asc("A"),0,2,0 ' W key up -- invokes actions
	' copy the document
	keybd_event 18,0,0,0 ' Alt key down
	keybd_event Asc("E"),0,0,0 ' A key down -- invokes actions
	keybd_event Asc("E"),0,2,0 ' A key up -- invokes actions
	keybd_event 18,0,2,0 ' Alt key up
	keybd_event Asc("C"),0,0,0 ' W key down -- invokes actions
	keybd_event Asc("C"),0,2,0 ' W key up -- invokes actions
	' close the document
	keybd_event 18,0,0,0 ' Alt key down
	keybd_event Asc("F"),0,0,0 ' A key down -- invokes actions
	keybd_event Asc("F"),0,2,0 ' A key up -- invokes actions
	keybd_event 18,0,2,0 ' Alt key up
	keybd_event Asc("C"),0,0,0 ' W key down -- invokes actions
	keybd_event Asc("C"),0,2,0 ' W key up -- invokes actions
End Sub
Function PasteIEContentsToWord(lsFileName As String) As Integer
	On Error Goto ErrorHandlerFunc
	Dim wordObj, wdocs, wRange As Variant
	Set wordObj = CreateObject("Word.Application")
	wordObj.Visible = True
	'Set wdocs = wordObj.Documents.Add(lsFileName)
	Set wdocs = wordObj.Documents.Add("C:abc.doc")
	wdocs.Activate
	wordObj.Selection.Paste
	wordObj.Selection.WholeStory
	wordObj.Selection.ParagraphFormat.Alignment = 3
	Dim liCount As Integer
	Dim liCount1 As Integer
	liCount1 = wordObj.Selection.Tables.Count
	wordObj.Selection.MoveDown
	For liCount = 1 To			 liCount1
		Call wordObj.Selection.GoTo(2,3,1,"")
		wordObj.Selection.Find.ClearFormatting
		With wordObj.Selection.Find
			.Text = ""
			.Replacement.Text = ""
			.Forward = True
			.Wrap = 1
			.Format = False
			.MatchCase = False
			.MatchWholeWord = False
			.MatchWildcards = False
			.MatchSoundsLike = False
			.MatchAllWordForms = False
		End With
		wordObj.Selection.Tables(1).AutoFitBehavior (2)
	Next
	wdocs.SaveAs lsFileName$
	wordObj.Quit
	Set wordObj = Nothing
	PasteIEContentsToWord = True
	Exit Function
ErrorHandlerFunc:
	Print "Error Msg : " & Error$() & " at line no. of Function : " & Erl()
End Function