Paste this below code in the Agent, and change the view name.
Option Public
Option Declare
Sub Initialize
On Error GoTo Error_Handling
Dim sess As New NotesSession
Dim db As NotesDatabase
Dim coll As NotesDocumentCollection
Dim doc As NotesDocument
Dim view As NotesView
Dim spItem As string
Dim rtitem As Variant
Dim filename As Variant
Dim EnsureFolder As String
Dim EnsureFolder1 As String
Dim path1 As String
Dim SplitString As String
Dim Delimiter As String
Dim retSplit As Variant
Dim i As Integer
Dim j As Integer
Set db = sess.currentdatabase
'Set coll = db.unprocesseddocuments
Set view = db.getview("Data\By Country_I")
Set doc = view.getfirstdocument
While Not doc Is Nothing
Set rtitem = doc.GetFirstItem( "data_attachement" )
If Not rtitem Is Nothing Then
If ( rtitem.Type = RICHTEXT ) Then
Print doc.data_country(0)& "pROCESS" &doc.data_keyword(0)
For i=0 To UBound(doc.data_country)
For j=0 To UBound(doc.data_keyword)
SpItem = ReplaceSubString(doc.data_keyword(j) ,"/", "+")
Print "Error" &SpItem
'Exit sub
Path1 = CheckMakeFolder("c:\TEST2012", doc.data_country(i), SpItem)
If doc.HasEmbedded Then
ForAll o In rtitem.EmbeddedObjects
If ( o.Type = EMBED_ATTACHMENT ) Then
Print o.Source
Call o.ExtractFile(Path1 & "\" & o.Source )
Print path1 &"Done"
Call doc.Save( True, True )
End If
'Call doc.Save( True, True )
End ForAll
End If
Next
Next 'Call doc.Save( True, True )
End If
End If
Set doc = view.getnextdocument(doc)
Wend
Error_Handling:
'// Capture the error "Document already exists in this collection" - not a fatal error, just means that it already exists in the list
If Err = 4469 Then
Resume Next
Else
' Print "Error: " & Error$ & " (" & Err & ") on line " & Erl
MsgBox("Error: " & Error$ & " (" & Err & ") on line " & Erl)
Exit Sub
End If
End Sub
Function CheckMakeFolder ( root As String , leaf As String, subleaf As String) As String
Dim strPath As String
Dim strPath1 As String
strPath = root & "\" & leaf
'MsgBox (strpath)
If Not DirExists (strPath) Then
MkDir strPath
End If
strPath1 = strPath & "\" & subleaf
If Not DirExists (strPath1) Then
MkDir strPath1
End If
'End If
CheckMakeFolder = strPath1
End Function
REM
Function DirExists (strPath As String) As Boolean
DirExists = (Dir$ (strPath ,16 ) <> "" )
'MsgBox(DirExists)
End Function
Function ReplaceSubString (ByVal SrcStr As String, ByVal OrigSubStr As String,ByVal RplcSubString As String) As String
' Dimension variables:
Dim NextPos As Long
Dim OrigSubStringLen As Integer
Dim RplcSubStringLen As Integer
Dim NStr As String
' Make copy of SourceString
NStr = SrcStr
' Calculate the Original SubString and Replacement SubString lengths only once:
OrigSubStringLen = Len(OrigSubStr)
RplcSubStringLen = Len(RplcSubString)
' Find First SubString to Replace
NextPos = InStr(NStr, OrigSubStr)
' Loop searching for substrings to replace
Do Until NextPos = 0
' Replace substring with new substring
NStr = Left$(NStr, NextPos-1) + RplcSubString + Mid$(NStr, NextPos +OrigSubStringLen )
' Find the next substring to replace
NextPos = InStr(NextPos+RplcSubStringLen, NStr, OrigSubStr)
Loop
' Return the New String
ReplaceSubString = NStr
End Function
No comments:
Post a Comment