Crash on interacting w/long Word doc

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

hi everybody in this most wonderful access user group

ive got this problem

i have a module which opens up a word document and then iterates through
each paragraph gleaning certain information.
at certain paragraphs the module opens a recordset adds a record with the
gleaned info and closes the recordset.

what happens is, that if the word doc is 150 pages or more, then a lot of
times access crashes right at start, sometimes after a few 100 paragraphs,
and sometimes never.

ive got windows xp w/sp2 & office2003 w/sp2

at first ive left the recordset open till end of procedure, but then it
crashed almost always.

id greatly appreciate any help
Thankfully, YisMan
 
It could be a problem in Word, in the way you're using Word, or in the
document(s). Or something else. Unless you show us your code it won't be
possible to do more than guess.
 
Thank you so much for taking the time to answer.
The code is extremely lenghty, so I'll try to give an abbreviated version
(which isnt either very short) these gibberish letters work fine theyre just
nonenglish control names or text strings. If there's a possibility I would
definitely like to send you the entire module as is


Sub CollectMaterial()
Dim m As Integer
Dim ApWord As New Word.Application
Dim InCounter As Integer, InCounterCollect As Integer, InCounterMissed As
Integer
Dim stTask(3, 3) As String
Dim stKod As String
'variables from 'import' table
Dim frImport As Form
Set frImport = Forms("frImport")
Dim inTask As Integer: inTask = frImport.[îùéîä] '1=proof 2=import
Dim boSubTitles As Boolean: boSubTitles = frImport.[ëåúøåú îùðä]
Dim boStarter As Boolean: boStarter = frImport.[ëåúøåú úçéìéú]
Dim lnKodBaseTitleAs Long: lnKodBaseTitle= frImport.[áñéñ ëåúøåú îùðä]
'variables for insertion
Dim lnBookCode As Long
Dim lnCommentCode As Long
Dim lnKodBasis As Long
Dim lnCodeLevel2As Long
Dim stDocumentName As String, stDocumentPath As String
Dim stCommentDescript As String
stTask(1, 1) = "äâää"
stTask(1, 2) = "îâéä"
stTask(1, 3) = "äâä"
stTask(2, 1) = "ìé÷åè"
stTask(2, 2) = "îì÷è"
stTask(2, 3) = "ì÷è"
Dim DlBox As FileDialog
Set DlBox = Application.FileDialog(msoFileDialogFilePicker)
DlBox.InitialFileName = Application.CurrentProject.Path
DlBox.ButtonName = stTask(inTask, 3)
DlBox.Title = stTask(inTask, 1)
DlBox.Filters.Clear
DlBox.Filters.Add "÷áöé ååøã", "*.doc", 1
DlBox.Show
If DlBox.SelectedItems.Count = 0 Then
Exit Sub
End If
Set ApWord = CreateObject("word.application")
ApWord.Documents.Open DlBox.SelectedItems(1)
stDocumentName = ApWord.ActiveDocument.Name
stDocumentPath = ApWord.ActiveDocument.FullName
'if importing---now check if this document was already collected
If inTask = 2 Then
Dim inDocumentID As Integer
inDocumentID = Nz(DLookup("[îæää îñîê]", "îñîëéí", "[ùí îñîê] = '" &
stDocumentName & "'"), 0)
If inDocumentID <> 0 Then
'which means document was done
m = MsgBox("?îñîê '" & Left(stDocumentName, Len(stDocumentName) - 4) & "'
ëáø ìå÷è, äàí áøöåðê ìîçå÷ ëì ä÷èòéí ùìå÷èå îîðå. åìì÷åè îçãù", vbExclamation
+ vbYesNo, APPTITLE)
If m = vbNo Then
Exit Sub
Else
DeleteRecords "÷èòéí", "[÷åã îñîê]=" & inDocumentID
lnKodMismach = inDocumentID
End If
Else
'this document wasnt done yet
'so add to document table
DoCmd.SetWarnings False
DoCmd.RunSQL "insert into [îñîëéí] ([ùí îñîê],[ðúéá îñîê]) values ('" &
stDocumentName & "', '#" & stDocumentPath & "#')"
DoCmd.SetWarnings True
End If
Else
'proofing only
End If
'show doc
ApWord.Visible = True
ApWord.Activate
'if import--delete all old bookmarks
If inTask = 2 Then
Dim inCountDeletes As Integer
Dim BmOwn As Bookmark
For Each BmOwn In ApWord.ActiveDocument.Bookmarks
inCountDeletes = inCountDeletes + 1
BmOwn.Delete
ApWord.StatusBar = "îåç÷ ñéîðéä/äòøä " & inCountDeletes
Next
End If
Dim CmOwn As Comment
For Each CmOwn In ApWord.ActiveDocument.Comments
inCountDeletes = inCountDeletes + 1
CmOwn.Delete
ApWord.StatusBar = "îåç÷ ñéîðéä/äòøä " & inCountDeletes
Next
AcharPticha:
Dim lnTotalParas As Long
Dim lnCounter As Long
InCounter = 0
InCounterMissed= 0
Dim ZPara As Paragraph
lnTotalParas = ApWord.ActiveDocument.Paragraphs.Count
'now we start working
For Each ZPara In ApWord.ActiveDocument.Paragraphs
InCounter = InCounter + 1
'If InCounter > 100 Then Exit Sub 'Test
stPara = ZPara.Range.Text & ""
If Trim(stPara) = "" Or Asc(Trim(stPara)) = 13 Then GoTo NextPara
'Debug.Print Left(stPara, 30)
stKod = Left(stPara, 3)
stPara = Trim(Mid(stPara, 4))
If Right(stPara, 1) = Chr(13) Then stPara = Left(stPara, Len(stPara) - 1)
ZPara.Range.Select
'***** Code Listing*****
DoCmd.SetWarnings False
DoEvents
On Error GoTo ParaError
Select Case stKod
Case stBookCode
If Left(stPara, Len(stBook)) = stBook Then stPara = Trim(Mid(stPara,
Len(stBook) + 1))
lnBookCode= 0
lnCommentCode= 0
lnKodBasis = 0
lnCodeLevel2= 0
'Debug.Print stPara & " " & Len(stPara)
lnBookCode= Nz(DLookup("[îæää ñôø]", "ñôøéí", "[ùí ñôø] = '" & stPara &
"'"), 0)
'maybe add new book now
If inTask = 2 And lnBookCode= 0 Then
DoCmd.RunSQL "insert into [ñôøéí] ([ùí ñôø],[ñåâ øîä á],[ñåâ øîä â],[ñåâ øîä
ã],[ñåâ øîä ä]) values ('" & stPara & "', '" & stRama2 & "', '" & stRama3 &
"', '" & stRama4 & "', '" & stRama5 & "')"
lnBookCode= Nz(DLookup("[îæää ñôø]", "ñôøéí", "[ùí ñôø] = '" & stPara &
"'"), 0)
End If
'for proofing
If lnBookCode= 0 Then Err.Raise vbObjectError + 514, "äâää", "àéï ñôø ëæä
áøùéîä"
'the lnBookCodeis now set
Case stKodRama2 'zraim, moed...
If Left(stPara, Len(stRama2)) = stRama2 Then stPara = Trim(Mid(stPara,
Len(stRama2) + 1))
lnCodeLevel2= 0
lnKodRama3 = 0
inRama4 = 0
inRama5 = 0
lnCodeLevel2= Nz(DLookup("[îæää øîä á]", "øîä á", "[÷åã ñôø]=" & lnBookCode&
" and [ùí øîä á]='" & stPara & "'"), 0)
If inTask = 2 And lnCodeLevel2= 0 Then
DoCmd.RunSQL "insert into [øîä á] ([÷åã ñôø],[ùí øîä á]) values (" &
lnBookCode& ", '" & stPara & "')"
lnCodeLevel2= Nz(DLookup("[îæää øîä á]", "øîä á", "[÷åã ñôø]=" & lnBookCode&
" and [ùí øîä á]='" & stPara & "'"), 0)
End If
'for proofing
If lnCodeLevel2= 0 Then Err.Raise vbObjectError + 515, "äâää", "àéï " &
stRama2 & " ëæä áøùéîä"
'the lnCodeLevel2is now set
Case stKodBasis
lnKodBasis = 0
stPara = Replace(stPara, Chr(39), "-")
'see if we have him
lnKodBasis = Nz(DLookup("[îæää áñéñ]", "áñéñéí", "[÷åã ñôø]=" & lnBookCode&
" and " & "[ùí áñéñ] = '" & stPara & "'"), 0)
If inTask = 2 And lnKodBasis = 0 Then
DoCmd.RunSQL "insert into [áñéñéí] ([÷åã ñôø],[ùí áñéñ]) values (" &
lnBookCode& ", '" & stPara & "')"
lnKodBasis = Nz(DLookup("[îæää áñéñ]", "áñéñéí", "[÷åã ñôø]=" & lnBookCode&
" and " & "[ùí áñéñ] = '" & stPara & "'"), 0)
End If
If lnKodBasis = 0 Then Err.Raise vbObjectError + 517, "äâää", "àéï áñéñ ëæä
áøùéîä"
'the lnKodbasis is now set
'maybe add now a koteret record
If inTask = 2 And boSubTitles Then
If InStr(stPara, "âî") Or InStr(stPara, "îùðä") Then
InCounterCollect = InCounterCollect + 1
ApWord.ActiveDocument.Bookmarks.Add "÷èò" & InCounterCollect, ZPara.Range
stKishur = "#" & stDocumentPath & "#" & "÷èò" & InCounterCollect
lnKodBasis = lnKodBasisKoteret
InsertPara lnKodRama3, inRama4, inRama5, stKodBasis & stPara, lnKodMismach,
stKishur, lnKodBasis, , , , True
End If
End If
'*** now for the zPara
Case stKodTchilit
Dim inStartPatiach As Integer, inStartKeta As Integer
inStartPatiach = InStr(stPara, stKodPatiach)
inStartKeta = InStr(stPara, stKodKeta)
'check for patiach
If inStartPatiach = 0 Then
stPatiach = ""
stTchilit = Trim(Left(stPara, inStartKeta - 1))
Else
stTchilit = Trim(Mid(stPara, 1, inStartPatiach - 1))
If inStartKeta = 0 Then inStartKeta = 50
stPatiach = Mid(stPara, inStartPatiach + 3, inStartKeta - inStartPatiach - 3)
End If
If Right(stTchilit, 1) = "." Then stTchilit = Left(stTchilit, Len(stTchilit)
- 1)
If Left(stTchilit, 3) = "ã" & Chr(34) & "ä" Then stTchilit = Mid(stTchilit, 5)
If Right(stPatiach, 1) = "." Then stPatiach = Left(stPatiach, Len(stPatiach)
- 1)
If Left(stTchilit, 4) = "ñã" & Chr(34) & "ä" Then stTchilit =
Trim(Mid(stTchilit, 6))
If Left(stTchilit, 4) = "áã" & Chr(34) & "ä" Then stTchilit =
Trim(Mid(stTchilit, 6))
If Right(stTchilit, 3) = "ëå" & Chr(39) Then stTchilit =
Trim(Left(stTchilit, InStrRev(stTchilit, " ")))
'prepare for new zPara
InCounterCollect = InCounterCollect + 1
ApWord.ActiveDocument.Bookmarks.Add "÷èò" & InCounterCollect, ZPara.Range
stKishur = "#" & stDocumentPath & "#" & "÷èò" & InCounterCollect
stTchilit = Trim(Left(stTchilit, 100))
stPatiach = Trim(Left(stPatiach, 100))
'now make zPara if importing
If inTask = 2 Then
InsertPara lnKodRama3, inRama4, inRama5, stPara, lnKodMismach, stKishur,
lnKodBasis, stPatiach, stTchilit, lnKodMifaresh
End If
'messagebar
ApWord.StatusBar = "ìå÷è ÷èò " & InCounterCollect & " îúåê " & lnTotalParas
Case Else
Err.Raise vbObjectError + 513, "CollectMaterial", "÷åã áìúé îæåää"
End Select
DoCmd.SetWarnings True
NextPara:
Next
'*** After looping through all ktaim ***
ApWord.Quit wdSaveChanges
Exit Sub
ParaError:
ApWord.ActiveDocument.Comments.Add ZPara.Range, Err.Description & " åìëï
ãåìâ ÷èò æä. éù ìáãå÷ äùìëåú òì ÷èòéí äáàéí"
Resume NextPara
End Sub



Sub InsertPara(lnKodRama3 As Long, inRama4 As Integer, inRama5 As Integer,
stPara As String, lnKodMismach As Long, stKishur As String, lnKodBasis As
Long, Optional stPatiach As String, Optional stTchilit As String, Optional
lnCommentCodeAs Long, Optional boKoteret As Boolean)
Dim rsKtaim As New ADODB.Recordset
rsKtaim.Open "÷èòéí", CurrentProject.Connection, adOpenDynamic,
adLockOptimistic
With rsKtaim
..AddNew
..Fields("÷åã îôøù") = IIf(lnCommentCode= 0, Null, lnKodMifaresh)
..Fields("÷åã øîä â") = lnKodRama3
..Fields("îñ øîä ã") = inRama4
..Fields("úçéìú ãéáåø") = stTchilit
..Fields("ëåúøú") = boKoteret
..Update
..Close
End With
End Sub
 
The code is extremely lenghty, so I'll try to give an abbreviated
version
Click to expand...

Is this a record?

251 lines, 28 comments, no identing -- it's the original WORN[1] code!

[1] Write Once, Read Never


Just an observation


Tim F
 
I have to agree with Tim. If you indent your code consistently, make
liberal use of comments where the code isn't self-documenting, and break
extra-long procedures into shorter pieces each of which does a single,
easily tested part of the whole, then (a) you'll find it much easier to
debug your own code, and (b) others will be more willing to help you.

Meanwhile, here are some problems with the code to get you started.

1) You're creating two instances of Word each time you run the
procedure, only using the second, and leaving the first in memory.

2) You're declaring stTask() as a 4x4 array but only seem to use 6 of
its 16 elements.

3) You're selecting zPara.Range but never doing anything with it.

4) Your error handler is hiding the run-time errors. Disable it while
you're debugging.

Thank you so much for taking the time to answer.
The code is extremely lenghty, so I'll try to give an abbreviated version
(which isnt either very short) these gibberish letters work fine theyre just
nonenglish control names or text strings. If there's a possibility I would
definitely like to send you the entire module as is


Sub CollectMaterial()
Dim m As Integer
Dim ApWord As New Word.Application
Dim InCounter As Integer, InCounterCollect As Integer, InCounterMissed As
Integer
Dim stTask(3, 3) As String
Dim stKod As String
'variables from 'import' table
Dim frImport As Form
Set frImport = Forms("frImport")
Dim inTask As Integer: inTask = frImport.[îùéîä] '1=proof 2=import
Dim boSubTitles As Boolean: boSubTitles = frImport.[ëåúøåú îùðä]
Dim boStarter As Boolean: boStarter = frImport.[ëåúøåú úçéìéú]
Dim lnKodBaseTitleAs Long: lnKodBaseTitle= frImport.[áñéñ ëåúøåú îùðä]
'variables for insertion
Dim lnBookCode As Long
Dim lnCommentCode As Long
Dim lnKodBasis As Long
Dim lnCodeLevel2As Long
Dim stDocumentName As String, stDocumentPath As String
Dim stCommentDescript As String
stTask(1, 1) = "äâää"
stTask(1, 2) = "îâéä"
stTask(1, 3) = "äâä"
stTask(2, 1) = "ìé÷åè"
stTask(2, 2) = "îì÷è"
stTask(2, 3) = "ì÷è"
Dim DlBox As FileDialog
Set DlBox = Application.FileDialog(msoFileDialogFilePicker)
DlBox.InitialFileName = Application.CurrentProject.Path
DlBox.ButtonName = stTask(inTask, 3)
DlBox.Title = stTask(inTask, 1)
DlBox.Filters.Clear
DlBox.Filters.Add "÷áöé ååøã", "*.doc", 1
DlBox.Show
If DlBox.SelectedItems.Count = 0 Then
Exit Sub
End If
Set ApWord = CreateObject("word.application")
ApWord.Documents.Open DlBox.SelectedItems(1)
stDocumentName = ApWord.ActiveDocument.Name
stDocumentPath = ApWord.ActiveDocument.FullName
'if importing---now check if this document was already collected
If inTask = 2 Then
Dim inDocumentID As Integer
inDocumentID = Nz(DLookup("[îæää îñîê]", "îñîëéí", "[ùí îñîê] = '" &
stDocumentName & "'"), 0)
If inDocumentID <> 0 Then
'which means document was done
m = MsgBox("?îñîê '" & Left(stDocumentName, Len(stDocumentName) - 4) & "'
ëáø ìå÷è, äàí áøöåðê ìîçå÷ ëì ä÷èòéí ùìå÷èå îîðå. åìì÷åè îçãù", vbExclamation
+ vbYesNo, APPTITLE)
If m = vbNo Then
Exit Sub
Else
DeleteRecords "÷èòéí", "[÷åã îñîê]=" & inDocumentID
lnKodMismach = inDocumentID
End If
Else
'this document wasnt done yet
'so add to document table
DoCmd.SetWarnings False
DoCmd.RunSQL "insert into [îñîëéí] ([ùí îñîê],[ðúéá îñîê]) values ('" &
stDocumentName & "', '#" & stDocumentPath & "#')"
DoCmd.SetWarnings True
End If
Else
'proofing only
End If
'show doc
ApWord.Visible = True
ApWord.Activate
'if import--delete all old bookmarks
If inTask = 2 Then
Dim inCountDeletes As Integer
Dim BmOwn As Bookmark
For Each BmOwn In ApWord.ActiveDocument.Bookmarks
inCountDeletes = inCountDeletes + 1
BmOwn.Delete
ApWord.StatusBar = "îåç÷ ñéîðéä/äòøä " & inCountDeletes
Next
End If
Dim CmOwn As Comment
For Each CmOwn In ApWord.ActiveDocument.Comments
inCountDeletes = inCountDeletes + 1
CmOwn.Delete
ApWord.StatusBar = "îåç÷ ñéîðéä/äòøä " & inCountDeletes
Next
AcharPticha:
Dim lnTotalParas As Long
Dim lnCounter As Long
InCounter = 0
InCounterMissed= 0
Dim ZPara As Paragraph
lnTotalParas = ApWord.ActiveDocument.Paragraphs.Count
'now we start working
For Each ZPara In ApWord.ActiveDocument.Paragraphs
InCounter = InCounter + 1
'If InCounter > 100 Then Exit Sub 'Test
stPara = ZPara.Range.Text & ""
If Trim(stPara) = "" Or Asc(Trim(stPara)) = 13 Then GoTo NextPara
'Debug.Print Left(stPara, 30)
stKod = Left(stPara, 3)
stPara = Trim(Mid(stPara, 4))
If Right(stPara, 1) = Chr(13) Then stPara = Left(stPara, Len(stPara) - 1)
ZPara.Range.Select
'***** Code Listing*****
DoCmd.SetWarnings False
DoEvents
On Error GoTo ParaError
Select Case stKod
Case stBookCode
If Left(stPara, Len(stBook)) = stBook Then stPara = Trim(Mid(stPara,
Len(stBook) + 1))
lnBookCode= 0
lnCommentCode= 0
lnKodBasis = 0
lnCodeLevel2= 0
'Debug.Print stPara & " " & Len(stPara)
lnBookCode= Nz(DLookup("[îæää ñôø]", "ñôøéí", "[ùí ñôø] = '" & stPara &
"'"), 0)
'maybe add new book now
If inTask = 2 And lnBookCode= 0 Then
DoCmd.RunSQL "insert into [ñôøéí] ([ùí ñôø],[ñåâ øîä á],[ñåâ øîä â],[ñåâ øîä
ã],[ñåâ øîä ä]) values ('" & stPara & "', '" & stRama2 & "', '" & stRama3 &
"', '" & stRama4 & "', '" & stRama5 & "')"
lnBookCode= Nz(DLookup("[îæää ñôø]", "ñôøéí", "[ùí ñôø] = '" & stPara &
"'"), 0)
End If
'for proofing
If lnBookCode= 0 Then Err.Raise vbObjectError + 514, "äâää", "àéï ñôø ëæä
áøùéîä"
'the lnBookCodeis now set
Case stKodRama2 'zraim, moed...
If Left(stPara, Len(stRama2)) = stRama2 Then stPara = Trim(Mid(stPara,
Len(stRama2) + 1))
lnCodeLevel2= 0
lnKodRama3 = 0
inRama4 = 0
inRama5 = 0
lnCodeLevel2= Nz(DLookup("[îæää øîä á]", "øîä á", "[÷åã ñôø]=" & lnBookCode&
" and [ùí øîä á]='" & stPara & "'"), 0)
If inTask = 2 And lnCodeLevel2= 0 Then
DoCmd.RunSQL "insert into [øîä á] ([÷åã ñôø],[ùí øîä á]) values (" &
lnBookCode& ", '" & stPara & "')"
lnCodeLevel2= Nz(DLookup("[îæää øîä á]", "øîä á", "[÷åã ñôø]=" & lnBookCode&
" and [ùí øîä á]='" & stPara & "'"), 0)
End If
'for proofing
If lnCodeLevel2= 0 Then Err.Raise vbObjectError + 515, "äâää", "àéï " &
stRama2 & " ëæä áøùéîä"
'the lnCodeLevel2is now set
Case stKodBasis
lnKodBasis = 0
stPara = Replace(stPara, Chr(39), "-")
'see if we have him
lnKodBasis = Nz(DLookup("[îæää áñéñ]", "áñéñéí", "[÷åã ñôø]=" & lnBookCode&
" and " & "[ùí áñéñ] = '" & stPara & "'"), 0)
If inTask = 2 And lnKodBasis = 0 Then
DoCmd.RunSQL "insert into [áñéñéí] ([÷åã ñôø],[ùí áñéñ]) values (" &
lnBookCode& ", '" & stPara & "')"
lnKodBasis = Nz(DLookup("[îæää áñéñ]", "áñéñéí", "[÷åã ñôø]=" & lnBookCode&
" and " & "[ùí áñéñ] = '" & stPara & "'"), 0)
End If
If lnKodBasis = 0 Then Err.Raise vbObjectError + 517, "äâää", "àéï áñéñ ëæä
áøùéîä"
'the lnKodbasis is now set
'maybe add now a koteret record
If inTask = 2 And boSubTitles Then
If InStr(stPara, "âî") Or InStr(stPara, "îùðä") Then
InCounterCollect = InCounterCollect + 1
ApWord.ActiveDocument.Bookmarks.Add "÷èò" & InCounterCollect, ZPara.Range
stKishur = "#" & stDocumentPath & "#" & "÷èò" & InCounterCollect
lnKodBasis = lnKodBasisKoteret
InsertPara lnKodRama3, inRama4, inRama5, stKodBasis & stPara, lnKodMismach,
stKishur, lnKodBasis, , , , True
End If
End If
'*** now for the zPara
Case stKodTchilit
Dim inStartPatiach As Integer, inStartKeta As Integer
inStartPatiach = InStr(stPara, stKodPatiach)
inStartKeta = InStr(stPara, stKodKeta)
'check for patiach
If inStartPatiach = 0 Then
stPatiach = ""
stTchilit = Trim(Left(stPara, inStartKeta - 1))
Else
stTchilit = Trim(Mid(stPara, 1, inStartPatiach - 1))
If inStartKeta = 0 Then inStartKeta = 50
stPatiach = Mid(stPara, inStartPatiach + 3, inStartKeta - inStartPatiach - 3)
End If
If Right(stTchilit, 1) = "." Then stTchilit = Left(stTchilit, Len(stTchilit)
- 1)
If Left(stTchilit, 3) = "ã" & Chr(34) & "ä" Then stTchilit = Mid(stTchilit, 5)
If Right(stPatiach, 1) = "." Then stPatiach = Left(stPatiach, Len(stPatiach)
- 1)
If Left(stTchilit, 4) = "ñã" & Chr(34) & "ä" Then stTchilit =
Trim(Mid(stTchilit, 6))
If Left(stTchilit, 4) = "áã" & Chr(34) & "ä" Then stTchilit =
Trim(Mid(stTchilit, 6))
If Right(stTchilit, 3) = "ëå" & Chr(39) Then stTchilit =
Trim(Left(stTchilit, InStrRev(stTchilit, " ")))
'prepare for new zPara
InCounterCollect = InCounterCollect + 1
ApWord.ActiveDocument.Bookmarks.Add "÷èò" & InCounterCollect, ZPara.Range
stKishur = "#" & stDocumentPath & "#" & "÷èò" & InCounterCollect
stTchilit = Trim(Left(stTchilit, 100))
stPatiach = Trim(Left(stPatiach, 100))
'now make zPara if importing
If inTask = 2 Then
InsertPara lnKodRama3, inRama4, inRama5, stPara, lnKodMismach, stKishur,
lnKodBasis, stPatiach, stTchilit, lnKodMifaresh
End If
'messagebar
ApWord.StatusBar = "ìå÷è ÷èò " & InCounterCollect & " îúåê " & lnTotalParas
Case Else
Err.Raise vbObjectError + 513, "CollectMaterial", "÷åã áìúé îæåää"
End Select
DoCmd.SetWarnings True
NextPara:
Next
'*** After looping through all ktaim ***
ApWord.Quit wdSaveChanges
Exit Sub
ParaError:
ApWord.ActiveDocument.Comments.Add ZPara.Range, Err.Description & " åìëï
ãåìâ ÷èò æä. éù ìáãå÷ äùìëåú òì ÷èòéí äáàéí"
Resume NextPara
End Sub



Sub InsertPara(lnKodRama3 As Long, inRama4 As Integer, inRama5 As Integer,
stPara As String, lnKodMismach As Long, stKishur As String, lnKodBasis As
Long, Optional stPatiach As String, Optional stTchilit As String, Optional
lnCommentCodeAs Long, Optional boKoteret As Boolean)
Dim rsKtaim As New ADODB.Recordset
rsKtaim.Open "÷èòéí", CurrentProject.Connection, adOpenDynamic,
adLockOptimistic
With rsKtaim
.AddNew
.Fields("÷åã îôøù") = IIf(lnCommentCode= 0, Null, lnKodMifaresh)
.Fields("÷åã øîä â") = lnKodRama3
.Fields("îñ øîä ã") = inRama4
.Fields("úçéìú ãéáåø") = stTchilit
.Fields("ëåúøú") = boKoteret
.Update
.Close
End With
End Sub
Click to expand...
 
dearest john
im full of thanks for your taking the time to read through my 'a little
lengthy' code.
i just spent quite a while indenting my code as you advised (when will
access users have auto-formatting like we have in VS) .

i would love to have broken my code to pieces (submodules, that is) but i
barely found redundent lines as each 'code' situation is treated differently,
tell me if im mistaking.

now for your kind advice. where am i creating 2 copies of word in memory?
the selection of the para range is for the user so he should see that
something is moving as each para gets processed it is selected on-screen.

and of course at testing error-handlig was off, but there is never no
exception prior to the crash.

and now im posting the full reformatted code, hold tight.

Sub CollectMaterial()
'this procedure opens a word document full of comments and iterates
through
'each paragraph and based on 'codes' provided in the import dialog box
decides what
'to do with each paragraph, some paragraphs (startcode) are actual
comments. other
'paragraphs are only commntors name, reference information, page numbers
and the
'like for upcoming comments.

'a document may look like this (lets say codes are A01,A02, A03 etc.)
'A01 mr migoo
'A02 black beauty
'a03 page 341
'a04 "nice job"
'a03 page 23
'a04 "could be better
'a02 robinhood
'a01 DaVinci
'..............


Dim m As Integer
Dim inCounter As Integer, inParasCollected As Integer
Dim stTask(2, 3) As String
Dim stCode As String

'variables from 'import' dialog box
Dim frImport As Form
Set frImport = Forms("ééáåà è")
Dim stBookCode As String: stBookCode = frImport.[÷åã ñôø]
Dim stCommentorCode As String: stCommentorCode = frImport.[÷åã îôøù]
Dim stBaseCode As String: stBaseCode = frImport.[÷åã áñéñ]
Dim stLevel2Code As String: stLevel2Code = frImport.[÷åã øîä á]
Dim stLevel3Code As String: stLevel3Code = frImport.[÷åã øîä â]
Dim stLevel4Code As String: stLevel4Code = frImport.[÷åã øîä ã]
Dim stLevel5Code As String: stLevel5Code = Nz(frImport.[÷åã øîä ä], "")
Dim stStartCode As String: stStartCode = frImport.[÷åã úçéìú ãéáåø] 'kod
tchilit dibur bamakor
Dim stOpenCode As String: stOpenCode = frImport.[÷åã ôúéç ìçéôåù] 'for
searching in mikor
Dim stParaCode As String: stParaCode = frImport.[÷åã ÷èò]
Dim stBook As String: stBook = "ñôø"
Dim stLevel2 As String: stLevel2 = frImport.[ùí øîä á]
Dim stLevel3 As String: stLevel3 = frImport.[ùí øîä â]
Dim stLevel4 As String: stLevel4 = frImport.[ùí øîä ã]
Dim stLevel5 As String: stLevel5 = frImport.[ùí øîä ä]
Dim inMisima As Integer: inMisima = frImport.[îùéîä] '1=proof 2=import
Dim boSubTitles As Boolean: boSubTitles = frImport.[ëåúøåú îùðä]
Dim boTchiliot As Boolean: boTchiliot = frImport.[ëåúøåú úçéìéú]
Dim lnKodBasisKoteret As Long: lnKodBasisKoteret = frImport.[áñéñ ëåúøåú
îùðä]

'variables for inserting in insertketa procedure which will be set
within this sub
Dim lnKodSefer As Long
Dim lnKodMifaresh As Long
Dim lnKodBasis As Long
Dim lnKodRama2 As Long
Dim lnKodRama3 As Long
Dim inRama4 As Integer
Dim inRama5 As Integer
Dim stKeta As String
Dim lnKodMismach As Long
Dim stKishur As String
Dim stTchilit As String
Dim stPatiach As String

Dim stDocumentName As String, stDocumentPath As String
Dim stCommentDescript As String

stTask(1, 1) = "äâää"
stTask(1, 2) = "îâéä"
stTask(1, 3) = "äâä"

stTask(2, 1) = "ìé÷åè"
stTask(2, 2) = "îì÷è"
stTask(2, 3) = "ì÷è"


Dim Taiva As FileDialog
Set Taiva = Application.FileDialog(msoFileDialogFilePicker)
Taiva.InitialFileName = Application.CurrentProject.Path
Taiva.ButtonName = stTask(inMisima, 3)
Taiva.Title = stTask(inMisima, 1)
Taiva.Filters.Clear
Taiva.Filters.Add "÷áöé ååøã", "*.doc", 1
Taiva.Show

If Taiva.SelectedItems.Count = 0 Then
Exit Sub
End If

'open word
Dim Yisum As New Word.Application
Set Yisum = CreateObject("word.application")
Yisum.Documents.Open Taiva.SelectedItems(1)
stDocumentName = Yisum.ActiveDocument.Name
stDocumentPath = Yisum.ActiveDocument.FullName



'if importing---now check if this document was already collected
If inMisima = 2 Then
Dim inDocumentID As Integer
inDocumentID = Nz(DLookup("[îæää îñîê]", "îñîëéí", "[ùí îñîê] = '" &
stDocumentName & "'"), 0)
If inDocumentID <> 0 Then
'which means document was done
m = MsgBox("?îñîê '" & Left(stDocumentName, Len(stDocumentName)
- 4) & "' ëáø ìå÷è, äàí áøöåðê ìîçå÷ ëì ä÷èòéí ùìå÷èå îîðå. åìì÷åè îçãù",
vbExclamation + vbYesNo, APPTITLE)
If m = vbNo Then
Exit Sub
Else
DeleteRecords "÷èòéí", "[÷åã îñîê]=" & inDocumentID
lnKodMismach = inDocumentID
End If
Else
'this document wasnt done yet
'so add to document table
DoCmd.SetWarnings False
DoCmd.RunSQL "insert into [îñîëéí] ([ùí îñîê],[ðúéá îñîê])
values ('" & stDocumentName & "', '#" & stDocumentPath & "#')"
DoCmd.SetWarnings True
End If
Else
'proofing only
End If



'show doc
Yisum.Visible = True
Yisum.Activate

'if import--delete all old bookmarks
If inMisima = 2 Then
Dim inCountDeletes As Integer
Dim Simaniya As Bookmark
For Each Simaniya In Yisum.ActiveDocument.Bookmarks
inCountDeletes = inCountDeletes + 1
Simaniya.Delete
Yisum.StatusBar = "îåç÷ ñéîðéä/äòøä " & inCountDeletes
Next
End If

'delete old comments in doc
Dim Haara As Comment
For Each Haara In Yisum.ActiveDocument.Comments
inCountDeletes = inCountDeletes + 1
Haara.Delete
Yisum.StatusBar = "îåç÷ ñéîðéä/äòøä " & inCountDeletes
Next

AcharPticha:
Dim lnTotalParas As Long
inCounter = 0

Dim Keta As Paragraph
lnTotalParas = Yisum.ActiveDocument.Paragraphs.Count

'now we start working
For Each Keta In Yisum.ActiveDocument.Paragraphs
'parse and trim string of paragraph
inCounter = inCounter + 1
stKeta = Keta.Range.Text & ""
If Trim(stKeta) = "" Or Asc(Trim(stKeta)) = 13 Then GoTo NextKeta
stCode = Left(stKeta, 3)
stKeta = Trim(Mid(stKeta, 4))
If Right(stKeta, 1) = Chr(13) Then stKeta = Left(stKeta, Len(stKeta)
- 1)
Keta.Range.Select

'***** Code Listing*****
DoCmd.SetWarnings False
DoEvents
On Error GoTo KetaError 'almost always will be my own homemade errs
Select Case stCode

Case stBookCode 'shas, shulchan aruch.....
If Left(stKeta, Len(stBook)) = stBook Then stKeta =
Trim(Mid(stKeta, Len(stBook) + 1))
lnKodSefer = 0
lnKodMifaresh = 0
lnKodBasis = 0
lnKodRama2 = 0
lnKodRama3 = 0
inRama4 = 0
inRama5 = 0
lnKodSefer = Nz(DLookup("[îæää ñôø]", "ñôøéí", "[ùí ñôø] =
'" & stKeta & "'"), 0)

'maybe add new book now
If inMisima = 2 And lnKodSefer = 0 Then
DoCmd.RunSQL "insert into [ñôøéí] ([ùí ñôø],[ñåâ øîä
á],[ñåâ øîä â],[ñåâ øîä ã],[ñåâ øîä ä]) values ('" & stKeta & "', '" &
stLevel2 & "', '" & stLevel3 & "', '" & stLevel4 & "', '" & stLevel5 & "')"
lnKodSefer = Nz(DLookup("[îæää ñôø]", "ñôøéí", "[ùí ñôø]
= '" & stKeta & "'"), 0)
End If

'for proofing
If lnKodSefer = 0 Then Err.Raise vbObjectError + 514,
"äâää", "àéï ñôø ëæä áøùéîä"
'the lnKodSefer is now set


Case stLevel2Code 'zraim, moed...
If Left(stKeta, Len(stLevel2)) = stLevel2 Then stKeta =
Trim(Mid(stKeta, Len(stLevel2) + 1))
lnKodRama2 = 0
lnKodRama3 = 0
inRama4 = 0
inRama5 = 0
lnKodRama2 = Nz(DLookup("[îæää øîä á]", "øîä á", "[÷åã
ñôø]=" & lnKodSefer & " and [ùí øîä á]='" & stKeta & "'"), 0)
If inMisima = 2 And lnKodRama2 = 0 Then
DoCmd.RunSQL "insert into [øîä á] ([÷åã ñôø],[ùí øîä á])
values (" & lnKodSefer & ", '" & stKeta & "')"
lnKodRama2 = Nz(DLookup("[îæää øîä á]", "øîä á", "[÷åã
ñôø]=" & lnKodSefer & " and [ùí øîä á]='" & stKeta & "'"), 0)
End If
'for proofing
If lnKodRama2 = 0 Then Err.Raise vbObjectError + 515,
"äâää", "àéï " & stLevel2 & " ëæä áøùéîä"
'the lnKodrama2 is now set


Case stLevel3Code 'brochos, shabbas.....
If Left(stKeta, Len(stLevel3)) = stLevel3 Then stKeta =
Trim(Mid(stKeta, Len(stLevel3) + 1))
lnKodRama3 = 0
inRama4 = 0
inRama5 = 0
lnKodRama3 = Nz(DLookup("[îæää øîä â]", "øîä â", "[÷åã øîä
á]=" & lnKodRama2 & " and [ùí øîä â]='" & stKeta & "'"), 0)
If inMisima = 2 And lnKodRama3 = 0 Then
DoCmd.RunSQL "insert into [øîä â] ([÷åã øîä á],[ùí øîä
â]) values (" & lnKodRama2 & ", '" & stKeta & "')"
lnKodRama3 = Nz(DLookup("[îæää øîä â]", "øîä â", "[÷åã
øîä á]=" & lnKodRama2 & " and [ùí øîä â]='" & stKeta & "'"), 0)
End If
'for proofing
If lnKodRama3 = 0 Then Err.Raise vbObjectError + 516, "äâää",
"àéï " & stLevel3 & " ëæä áøùéîä"
'the lnKodrama3 is now set


Case stLevel4Code 'perek or daf NUMERIC
If Left(stKeta, Len(stLevel4)) = stLevel4 Then stKeta =
Trim(Mid(stKeta, Len(stLevel4) + 1))
inRama4 = 0
inRama4 = HebNum(stKeta)
'special consideration for "éâ:" notation
If Right(stKeta, 1) = ":" Then
inRama5 = 2
ElseIf Right(stKeta, 1) = "." Then
inRama5 = 1
Else
inRama5 = 0
End If
'the inrama4 is now set


Case stLevel5Code 'mishna or amud NUMERIC
If Left(stKeta, Len(stLevel5)) = stLevel5 Then stKeta =
Trim(Mid(stKeta, Len(stLevel5) + 1))
inRama5 = 0
inRama5 = HebNum(stKeta)
'the inrama5 is now set

Case stCommentorCode
'new sefer initialize any old info
If Left(stKeta, 3) = "ñôø" Then stKeta = Mid(stKeta, 4)
lnKodMifaresh = 0
lnKodBasis = 0
lnKodRama2 = 0
'lnKodRama3 = 0
inRama4 = 0
inRama5 = 0
stKeta = Replace(stKeta, Chr(39), "-")

'see if we have him
lnKodMifaresh = Nz(DLookup("[îæää îôøù]", "îôøùéí", "[úéàåø]
= '" & stKeta & "'"), 0)
If lnKodMifaresh = 0 Then
DoCmd.RunSQL "insert into [îôøùéí] ([úéàåø]) values ('"
& stKeta & "')"
lnKodMifaresh = Nz(DLookup("[îæää îôøù]", "îôøùéí",
"[úéàåø] = '" & stKeta & "'"), 0)
End If
'the lnKodMifaresh is now set


Case stBaseCode
lnKodBasis = 0
stKeta = Replace(stKeta, Chr(39), "-")
'see if we have him
lnKodBasis = Nz(DLookup("[îæää áñéñ]", "áñéñéí", "[÷åã
ñôø]=" & lnKodSefer & " and " & "[ùí áñéñ] = '" & stKeta & "'"), 0)
If inMisima = 2 And lnKodBasis = 0 Then
DoCmd.RunSQL "insert into [áñéñéí] ([÷åã ñôø],[ùí áñéñ])
values (" & lnKodSefer & ", '" & stKeta & "')"
lnKodBasis = Nz(DLookup("[îæää áñéñ]", "áñéñéí", "[÷åã
ñôø]=" & lnKodSefer & " and " & "[ùí áñéñ] = '" & stKeta & "'"), 0)
End If
If lnKodBasis = 0 Then Err.Raise vbObjectError + 517,
"äâää", "àéï áñéñ ëæä áøùéîä"
'the lnKodbasis is now set

'maybe add now a koteret record
If inMisima = 2 And boSubTitles Then
If InStr(stKeta, "âî") Or InStr(stKeta, "îùðä") Then
inParasCollected = inParasCollected + 1
Yisum.ActiveDocument.Bookmarks.Add "÷èò" &
inParasCollected, Keta.Range
stKishur = "#" & stDocumentPath & "#" & "÷èò" &
inParasCollected
lnKodBasis = lnKodBasisKoteret
InsertKeta lnKodRama3, inRama4, inRama5, stBaseCode
& stKeta, lnKodMismach, stKishur, lnKodBasis, , , , True
End If
End If


'*** now for the keta
Case stStartCode

Dim inStartPatiach As Integer, inStartKeta As Integer
inStartPatiach = InStr(stKeta, stOpenCode)
inStartKeta = InStr(stKeta, stParaCode)

'check for patiach
If inStartPatiach = 0 Then
stPatiach = ""
stTchilit = Trim(Left(stKeta, inStartKeta - 1))
Else
stTchilit = Trim(Mid(stKeta, 1, inStartPatiach - 1))
If inStartKeta = 0 Then inStartKeta = 50
stPatiach = Mid(stKeta, inStartPatiach + 3, inStartKeta
- inStartPatiach - 3)
End If

If Right(stTchilit, 1) = "." Then stTchilit =
Left(stTchilit, Len(stTchilit) - 1)
If Left(stTchilit, 3) = "ã" & Chr(34) & "ä" Then stTchilit =
Mid(stTchilit, 5)
If Right(stPatiach, 1) = "." Then stPatiach =
Left(stPatiach, Len(stPatiach) - 1)
If Left(stTchilit, 4) = "ñã" & Chr(34) & "ä" Then stTchilit
= Trim(Mid(stTchilit, 6))
If Left(stTchilit, 4) = "áã" & Chr(34) & "ä" Then stTchilit
= Trim(Mid(stTchilit, 6))
If Right(stTchilit, 3) = "ëå" & Chr(39) Then stTchilit =
Trim(Left(stTchilit, InStrRev(stTchilit, " ")))

'prepare for new keta
inParasCollected = inParasCollected + 1
Yisum.ActiveDocument.Bookmarks.Add "÷èò" & inParasCollected,
Keta.Range
stKishur = "#" & stDocumentPath & "#" & "÷èò" &
inParasCollected

'special consideration for gemara pieces also koteret for
dibur hamatchil
If inMisima = 2 Then
Dim MaybeGem As String
MaybeGem = DLookup("[ùí áñéñ]", "áñéñéí", "[îæää áñéñ]="
& lnKodBasis)
If Left(MaybeGem, 2) = "âî" Or Left(MaybeGem, 3) = "áâî"
Then
stPatiach = stTchilit & " " & stPatiach
ElseIf boTchiliot And (InStr(MaybeGem, "øù" & Chr(34) &
"é") Or InStr(MaybeGem, "úåñ")) Then 'make koteret for dibur hamatchil
InsertKeta lnKodRama3, inRama4, inRama5, "@80ã" &
Chr(34) & "ä " & stTchilit, lnKodMismach, stKishur, lnKodBasis, , , , True
End If
End If

stTchilit = Trim(Left(stTchilit, 100))
stPatiach = Trim(Left(stPatiach, 100))


'now make keta if importing
If inMisima = 2 Then
InsertKeta lnKodRama3, inRama4, inRama5, stKeta,
lnKodMismach, stKishur, lnKodBasis, stPatiach, stTchilit, lnKodMifaresh
End If

'messagebar
Yisum.StatusBar = "ìå÷è ÷èò " & inParasCollected & " îúåê "
& lnTotalParas


Case Else
Err.Raise vbObjectError + 513, "CollectMaterial", "÷åã áìúé
îæåää"
End Select
DoCmd.SetWarnings True

NextKeta:
Next
'*** After looping through all ktaim ***
Yisum.Quit wdSaveChanges
Exit Sub

KetaError:
Yisum.ActiveDocument.Comments.Add Keta.Range, Err.Description & " åìëï
ãåìâ ÷èò æä. éù ìáãå÷ äùìëåú òì ÷èòéí äáàéí"
Resume NextKeta
End Sub


Sub InsertKeta(lnKodRama3 As Long, inRama4 As Integer, inRama5 As Integer,
stKeta As String, lnKodMismach As Long, stKishur As String, lnKodBasis As
Long, Optional stPatiach As String, Optional stTchilit As String, Optional
lnKodMifaresh As Long, Optional boKoteret As Boolean)
Dim rsKtaim As New ADODB.Recordset
rsKtaim.Open "÷èòéí", CurrentProject.Connection, adOpenDynamic,
adLockOptimistic
With rsKtaim
.AddNew
.Fields("÷åã îôøù") = IIf(lnKodMifaresh = 0, Null, lnKodMifaresh)
.Fields("÷åã øîä â") = lnKodRama3
.Fields("îñ øîä ã") = inRama4
.Fields("îñ øîä ä") = inRama5
.Fields("÷èò") = stKeta
.Fields("÷åã îñîê") = lnKodMismach
.Fields("÷éùåø") = stKishur
.Fields("÷åã áñéñ") = lnKodBasis
.Fields("ôúéç ìçéôåù") = stPatiach
.Fields("úçéìú ãéáåø") = stTchilit
.Fields("ëåúøú") = boKoteret
.Update
.Close
End With



End Sub
 
Back
Top