کمک کد انتقال مطلب از ورد به اکسس

[narese]

سلام یک فایل ورد داشتم که می خواستم اطلاعات آنرا وارد اکسس کنم .خصوصیات فایل وردی :
هر مطلب آن با مطلب دیگر توسط ستاره جدا شده است.بنابراین فاصله بین ستاره بالایی تا پایینی می شود یک رکورد(نمونه در ضمیمه آمده است)
هر خط آن بصورت یک پاراگراف آمده است.بنابراین هر پاراگراف ورد میشود یک فیلد اکسس.(پاراگراف 1 الی 3)
تا اینجا مشکلی نیست و کدش را دارم :


Sub fw()
On Error Resume Next
Dim rs As Recordset
Set rs = CurrentDb.OpenRecordset("table1")
Set w = CreateObject("Word.Application")
Set dc = w.Documents.Open("d:\la.docx")
For t = 1 To dc.Paragraphs.Count
sr = dc.Paragraphs(t).Range.Text

If Left(sr, 3) = "***" Then
rs.AddNew

sr = dc.Paragraphs(t + 1)
n = InStr(1, sr, ":", vbTextCompare)
rs!fld1 = Right(sr, Len(sr) - n)

sr = dc.Paragraphs(t + 2)
n = InStr(1, sr, ":", vbTextCompare)
rs!fld2 = Right(sr, Len(sr) - n)

sr = dc.Paragraphs(t + 3)
n = InStr(1, sr, ":", vbTextCompare)
rs!fld3 = Right(sr, Len(sr) - n)

rs.Update
End If
Next
dc.Close
Set w = Nothing
End Sub




حال مشکلی که وجوددارد ،توضیحات هر مطلب است که ممکن است بعضی فیلد ها داشته باشند و در پاراگراف چهارم به بعد قرار می گیرد.(در فایل ورد ضمیمه مشهوداست)
لطفا راهنمایی بفرمایید که چطور میشه کد را اصلاح کرد که بشود پاراگراف چهارم به بعد فایل وردی را در یک رکورد از اکسس قرار داد

[narese]

دوستان خیلی مهمه لطفا کمک کنید

[narese]

بالاخره درست شد.کد مورد نظر را برای استفاده دوستان می گذارم


Private Sub Command0_Click()
On Error Resume Next
Dim rs As Recordset
Set rs = CurrentDb.OpenRecordset("table1")
Set w = CreateObject("Word.Application")
Set dc = w.Documents.Open("d:\la.docx")

For t = 1 To dc.Paragraphs.Count
sr = dc.Paragraphs(t).Range.Text



If Left(sr, 3) = "***" Then
rs.AddNew
sr = dc.Paragraphs(t + 1)
n = InStr(1, sr, ":", vbTextCompare)
rs!fld1 = Right(sr, Len(sr) - n)

sr = dc.Paragraphs(t + 2)
n = InStr(1, sr, ":", vbTextCompare)
rs!fld2 = Right(sr, Len(sr) - n)

sr = dc.Paragraphs(t + 3)
n = InStr(1, sr, ":", vbTextCompare)
rs!fld3 = Right(sr, Len(sr) - n)

sr = dc.Paragraphs(t + 4)
n = InStr(1, sr, ":", vbTextCompare)
rs!fld4 = Right(sr, Len(sr) - n)
' --------------------------------------- Farshid:
txt = ""
For k = 2 To 500
sr = dc.Paragraphs(t + 3 + k)
If Left(sr, 3) <> "***" Then
txt = txt & sr
Else
Exit For
End If
Next k
rs!Description = txt
' --------------------------------------- Farshid /

rs.Update
End If
Next
dc.Close
w.Close
Set w = Nothing
MsgBox "عمليات به پايان رسيد"
End Sub