Option Public

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 = " + 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