Can Access create Word documents?

[etuncer@gmail.com]

Hello All,
I have Access 2003, and am trying to build a database for my small
company. I want to be able to create a word document based on the data
entered through a form. the real question is this: can Access create
the document and place it as an OLE object to the relevant table?
Any help is greatly appreciated.

Ricky

[pietlinden@hotmail.com]

Re: Can Access create Word documents?

On Feb 3, 1:28 pm, etun...@gmail.c om wrote:

Hello All,
I have Access 2003, and am trying to build a database for my small
company. I want to be able to create a word document based on the data
entered through a form. the real question is this: can Access create
the document and place it as an OLE object to the relevant table?
Any help is greatly appreciated.
>
Ricky

You mean use mail merge? Albert Kallal has a really nice solution for
that on his website.

http://www.members.shaw.ca/AlbertKallal/wordmerge/index.html

Putting Word documents in OLE fields? Why? Just store the path to the
file. You can't merge to a file in an OLE field, I don't think.
(Never thought to try it, but then I never use OLE fields either...)

[(PeteCresswell)]

Re: Can Access create Word documents?

Per etuncer@gmail.c om:

>I have Access 2003, and am trying to build a database for my small
>company. I want to be able to create a word document based on the data
>entered through a form. the real question is this: can Access create
>the document and place it as an OLE object to the relevant table?
>Any help is greatly appreciated.

Yes, but I'd think twice about storing the doc per se in a JET table.

I always went the route of storing the actual doc in a DOS or Windows directory
and storing only a UNC to the doc in the JET table.

It's been awhile since I visited this, but my recollection is that the tradeoffs
favored that strategy - in spite of it's obvious shortcomings (like not knowing
if somebody deleted a doc until the code tries to retrieve it).
--
PeteCresswell

[etuncer@gmail.com]

Re: Can Access create Word documents?

On Feb 3, 5:29 pm, "(PeteCresswell )" <x...@y.Invalid wrote:

Per etun...@gmail.c om:
>

I have Access 2003, and am trying to build a database for my small
company. I want to be able to create a word document based on the data
entered through a form. the real question is this: can Access create
the document and place it as an OLE object to the relevant table?
Any help is greatly appreciated.

>
Yes, but I'd think twice about storing the doc per se in a JET table.
>
I always went the route of storing the actual doc in a DOS or Windows directory
and storing only a UNC to the doc in the JET table.
>
It's been awhile since I visited this, but my recollection is that the tradeoffs
favored that strategy - in spite of it's obvious shortcomings (like not knowing
if somebody deleted a doc until the code tries to retrieve it).
--
PeteCresswell

Thank you pete, this was helpful.

[(PeteCresswell)]

Re: Can Access create Word documents?

Per etuncer@gmail.c om:

>Thank you pete, this was helpful.

Here's some code... nothing you can use out-of-the box.. but at least it
addresses the main issues in creating/saving an MS Word doc.


The app that it's from does a lot of creating "form letters" from
a model document. User clicks a button, up comes MS Word with
skeleton document pre-populated with data from the DB.

--------------------------------------------------------
Option Compare Database 'Use database order for string comparisons
Option Explicit

'next available line# series = 24000

' =============== =============== =============== =============== =====
'
' This module contains all routines whose name begins with "Letter"
' plus any private routines used by them.
'
' =============== =============== =============== =============== ===== 2

Const mModuleName = "basLetter"
Const mRpcServerUnava ilable = -2147023174


' ---------------------
' Passed parameters were getting out of hand, so we resort to passing this
structure
' between "letter...Begin ..." and "letter...Cust. .." routines

Type mLetterCustInfo
Greeting As String
PersonID As Long
ContribID As Long
GranteeID As Long
GrantRequestID As Long

Address As String
Advisers As String
AdviserCount As Integer
Donor As String
GranteeAddress As String
GranteeContactA ddress As String
GrantReceivedDa te As Double
NameLegal As String
LetterName As String
PersonIdGroup As String
PersonToBeAckno wledged As String
PrimaryContactA ddress As String
PrimaryContactG reeting As String
PrimaryContactS alutationNameTi tle As String
ProgramAccountN ame As String
PurposeProg As String
Recipients As String
TotalAmountGran t As String
TotalAmountProc eeds As Double
TotalAmountDono rEstimated As Double
VastAccountNumb er As String
End Type

' ----------------------------------------
' Structure to support getGrantRequest Info()
' Last few fields are *NOT* from the
' table. We use them when using
' a more complex query to pass
' a more complete set of information

Type GrantRequestInf o
GNT_REQST_ID As Long
ACK_PERS_NM As String
ANON_GNT_FL As Integer
CHK_DT As Variant
CHK_NO As String
CMNTS_TX As String
CNTGNT_REDMPTN_ FEE_AM As Double
DEND_RSN_TX As String
PrimaryContactG reeting As String
PrimaryContactA ddress As String
PrimaryContactS alutationNameTi tle As String
EXC_GNT_FEE_AM As Double
GNT_CNRN_AREA_I D As Variant
VAST_ACCT_NO As String
GNTE_ID As Long
GNT_STATUS_ID As Long
GNT_TYP_ID As Long
GNT_GEO_RGN_ID As Long
NMD_ACCT_ID As Long
PERS_WHO_SIGN_T X As String
PROG_PURP_TX As String
RCVD_DT As Variant
SIGNATURE_DATE As Variant
VAST_OK_FL As Integer
STATUS_DT As Variant
'-----------
LEGL_NM As String
PROG_ACCT_NM As String
End Type

Private Sub findAndReplace( theFromString As String, theToString As String,
theApp As Word.Applicatio n)
debugStackPush mModuleName & ": findAndReplace"
On Error GoTo findAndReplace_ err

' PURPOSE: To find and replace a single occurrance, beginning at the start of
the document
' ACCEPTS: - String to find
' - String to replace found string with
' - Pointer to the application
'
' NOTES: 1) This seems a little shaky for the following reasons
' - We really don't know why .Find always begins at the start of the
document...it just does...
' - Seems like the "right" way to do this would be to pass a pointer
to
' the document in question rather than the app, hoping that the
user hasn't
' activated some other document on us
' - The entire routine was just copied from a Word macro we
generated when
' doing what we wanted to do....we don't really understand each
line of code.


' theApp.Selectio n.HomeKey Unit:=wdStory, Extend:=wdMove

With theApp.Selectio n.Find
.ClearFormattin g
.Replacement.Cl earFormatting
.Text = theFromString
.Replacement.Te xt = theToString
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLik e = False
.MatchAllWordFo rms = False
End With

theApp.Selectio n.Find.Execute

With theApp.Selectio n
If .Find.Forward = True Then
.Collapse Direction:=wdCo llapseStart
Else
.Collapse Direction:=wdCo llapseEnd
End If
.Find.Execute Replace:=wdRepl aceOne
If .Find.Forward = True Then
.Collapse Direction:=wdCo llapseEnd
Else
.Collapse Direction:=wdCo llapseStart
End If
.Find.Execute
End With

findAndReplace_ xit:
debugStackPop
On Error Resume Next
Exit Sub

findAndReplace_ err:
bugAlert ""
Resume findAndReplace_ xit
End Sub
Function a_letterCustCon tribProblem(the LetterName As String, DonorID_NotUsed ,
theContribID As Long, GrantRequestID_ NotUsed, GranteeID_NotUs ed) As Integer
4000 debugStackPush mModuleName & ": a_letterCustCon tribProblem: "
4001 On Error GoTo a_letterCustCon tribProblem_err

' Customizes already-opened model letter CONFPROB.DOC as
' named in zstblLetter.

' Accepts: DOS 8.3 name of newly-opened letter
' DonorID of person for whom letter is being generated
' Returns: TRUE or FALSE depending on success

' Assumes global variable "gWord" has already been set

Dim thisDB As Database
Dim donorRS As Recordset
Dim contribRS As Recordset
Dim contribLineItem RS As Recordset
Dim namedAccountRS As Recordset
Dim problemRS As Recordset
Dim myQuery As QueryDef
Dim myAmount As Double
Dim mySum As Double
Dim x As Integer

Dim mySalutationNam eTitle As String
Dim myAddress As String
Dim myProgramAccoun tName As String
Dim myGreeting As String

Const CannotCreateLet ter = "Cannot Create Letter"

4050 Set thisDB = DBEngine(0)(0)
4066 Set myQuery = thisDB.QueryDef s("qryContribRe cFetch")
4067 myQuery.Paramet ers("theContrib ID") = theContribID
4068 Set contribRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT)
4070 If contribRS.BOF And contribRS.EOF Then
4071 bugAlert "Contributi on# " & Str(theContribI D) & " not found."
4072 Else
4075 Set myQuery = thisDB.QueryDef s("qryContribLi neItemsFetch")
4076 myQuery.Paramet ers("theContrib ID") = theContribID
4077 Set contribLineItem RS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT)
4079 If contribLineItem RS.BOF And contribLineItem RS.EOF Then
4080 statusSet ""
4100 MsgBox "There are no line items with active pool allocations for this
contribution", 16, CannotCreateLet ter
4101 Else
4110 Set myQuery = thisDB.QueryDef s("qryNamedAcco untRecFetchByNa me")
4120 myQuery.Paramet ers("theNamedAc countID") = contribRS!NMD_A CCT_ID
4130 Set namedAccountRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT)
4140 If namedAccountRS. BOF And namedAccountRS. EOF Then
4141 bugAlert "Named Account# " & Str(contribRS!N MD_ACCT_ID) & " not
found."
4142 Else
4150 Set myQuery = thisDB.QueryDef s("qryContribEx ceptionList")
4152 myQuery.Paramet ers("theContrib ID") = theContribID
4153 Set problemRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT)
4154 If problemRS.BOF And problemRS.EOF Then
4155 MsgBox "There are no problems outstanding for this
contribution.", 16, CannotCreateLet ter
4160 Else
4200 myProgramAccoun tName = namedAccountRS! PROG_ACCT_NM
4210 Set myQuery = thisDB.QueryDef s("qryDonorRecF etch")
4220 myQuery.Paramet ers("theDonorID ") = namedAccountRS! DON_ID
4230 Set donorRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT)
4231 If donorRS.BOF And donorRS.EOF Then
4232 bugAlert "Donor ID# " & Str(namedAccoun tRS!DON_ID) & " not
found."
4233 Else
4240 mySalutationNam eTitle =
formatSalutatio nNameTitle(dono rRS!DON_SALUT_N M, donorRS!DON_FRS T_NM,
donorRS!DON_MI_ NM, donorRS!DON_LST _NM, donorRS!DON_TIT LE_TX)
4245 myAddress = formatAddress(F alse, True,
donorRS!DON_ADD R_1_TX, donorRS!DON_ADD R_2_TX, donorRS!DON_CIT Y_TX,
donorRS!DON_STE _TX, donorRS!DON_ZIP _CD)
4250 myGreeting = formatGreeting( donorRS!DON_SAL UT_NM,
donorRS!DON_FRS T_NM, donorRS!DON_LST _NM)

'4431 gWord.EditRepla ce "<theSalutation NameTitle>",
mySalutationNam eTitle, , , , , , , True, False
'4440 gWord.EditRepla ce "<theProgramAcc ountName>",
myProgramAccoun tName, , , , , , , False, True
'4446 gWord.EditRepla ce "<theAddres s>", myAddress, , , , , , ,
False, True
'4449 gWord.EditRepla ce "<theGreeting>" , myGreeting, , , , , , ,
False, True
'4450 gWord.EditRepla ce "<theProgramAcc ountName>",
myProgramAccoun tName, , , , , , , False, True
'4455 gWord.EditRepla ce "<theCharityPho ne800>",
charityPhone800 Get(), , , , , , , False, True
'4460 gWord.StartOfDo cument
'4462 gWord.EditFind "%NumberSharesC ertificates%", "", 0

4260 With gWord 'DMN
4265 findAndReplace "<theSalutation NameTitle>",
mySalutationNam eTitle, gWord 'DMN
4270 findAndReplace "<theProgramAcc ountName>",
myProgramAccoun tName, gWord 'DMN
4275 findAndReplace "<theAddres s>", myAddress, gWord 'DMN
4280 findAndReplace "<theGreeting>" , myGreeting, gWord 'DMN
4285 findAndReplace "<theProgramAcc ountName>",
myProgramAccoun tName, gWord 'DMN
4290 findAndReplace "<theCharityPho ne800>",
charityPhone800 Get(), gWord 'DMN
4295 .Selection.Home Key Unit:=wdStory, Extend:=wdMove 'DMN
4300 findAndReplace "%NumberSharesC ertificates%", "", gWord
4305 End With 'DMN

4464 contribLineItem RS.MoveLast
4466 If contribLineItem RS.RecordCount 1 Then
4467 For x = 1 To contribLineItem RS.RecordCount - 1 'DMN
'4468 gWord.TableInse rtRow contribLineItem RS.RecordCount -
1
4468 gWord.Selection .Tables(1).Rows .Add
BeforeRow:=Sele ction.Rows(1) 'DMN
4469 Next x 'DMN
4470 End If

4480 contribLineItem RS.MoveFirst
4482 Do Until contribLineItem RS.EOF
4484 If contribLineItem RS!ISSR_NM = "Cash" Then
'4486 gWord.Insert Format$(contrib LineItemRS!NO_S HRS_QY,
"Currency")
4486 gWord.Selection .InsertAfter
Text:=Format$(c ontribLineItemR S!NO_SHRS_QY, "Currency")
4488 Else
'4490 gWord.Insert Str(contribLine ItemRS!NO_SHRS_ QY)
4490 gWord.Selection .InsertAfter
Text:=Str(contr ibLineItemRS!NO _SHRS_QY)
4492 End If
'4494 gWord.NextCell
4494 gWord.Selection .Move Unit:=wdCell, Count:=1

'4496 gWord.Insert contribLineItem RS!ISSR_NM
4496 gWord.Selection .InsertAfter
Text:=contribLi neItemRS!ISSR_N M
4498 contribLineItem RS.MoveNext
4500 If Not contribLineItem RS.EOF Then
'4502 gWord.NextCell
4502 gWord.Selection .Move Unit:=wdCell, Count:=1
4504 End If
4506 Loop

'4508 gWord.StartOfDo cument 'Selection.Home Key Unit:=wdStory,
Extend:=wdMove
4508 gWord.Selection .HomeKey Unit:=wdStory, Extend:=wdMove


'4510 gWord.EditFind "%theExceptions %", "", 0
4510 findText "%theExceptions %", gWord
4520 problemRS.MoveL ast
4530 If problemRS.Recor dCount 1 Then
'4540 gWord.TableInse rtRow problemRS.Recor dCount - 1
4540 For x = 1 To problemRS.Recor dCount - 1
4541 gWord.Selection .Tables(1).Rows .Add
BeforeRow:=Sele ction.Rows(1)
4542 Next x
4550 End If

4600 problemRS.MoveF irst
4610 Do Until problemRS.EOF
'4620 gWord.Insert problemRS!myDes cription
4620 gWord.Selection .InsertAfter Text:=problemRS !myDescription
4630 problemRS.MoveN ext
4640 If Not problemRS.EOF Then
'4650 gWord.NextCell
4650 gWord.Selection .Move Unit:=wdCell, Count:=1
4660 End If
4670 Loop

'4690 gWord.StartOfDo cument
'4691 gWord.EditRepla ce "<theAmountSum> ", Format$(mySum,
"Currency") , , , , , , , False, True

4680 With gWord 'DMN
4690 .Selection.Home Key Unit:=wdStory, Extend:=wdMove 'DMN
4700 findAndReplace "<theAmountSum> ", Format$(mySum,
"Currency") , gWord 'DMN
4710 End With 'DMN

4990 a_letterCustCon tribProblem = True
4991 End If
4992 End If
4993 End If
4994 End If
4999 End If

a_letterCustCon tribProblem_xit :
debugStackPop
On Error Resume Next
Set myQuery = Nothing
donorRS.Close
Set donorRS = Nothing
contribRS.Close
Set contribRS = Nothing
contribLineItem RS.Close
Set contribLineItem RS = Nothing
namedAccountRS. Close
Set namedAccountRS = Nothing
problemRS.Close
Set problemRS = Nothing
Set thisDB = Nothing
Exit Function

a_letterCustCon tribProblem_err :
bugAlert ""
Resume a_letterCustCon tribProblem_xit
End Function
Private Function conCustCash(the LCI As mLetterCustInfo ) As Integer
2000 debugStackPush mModuleName & ": conCustCash"
2001 On Error GoTo conCustCash_err

' PURPOSE: To Customize already-opened model letter nConCash.doc as
' named in zstblLetter.
' ACCEPTS: - DOS 8.3 name of newly-opened letter
' - A structure containing various fields needed to customize letter
' RETURNS: TRUE or FALSE depending on success
'
' NOTES: 1) Assumes global variable "gWord" has already been set
' 2) "namedAccountRS " includes named account info plus the Primary
Contact Person's name/address


2010 Dim thisDB As Database
Dim poolRS As Recordset
Dim myQuery As QueryDef
Dim x As Integer

Dim myPrincipalSum As Double

Const CannotCreateLet ter = "Cannot Create Letter"

2070 If poolRecsContrib Invalid(theLCI. ContribID) Then
2071 DoCmd.Hourglass False
2072 MsgBox "Informatio n for one or more pool allocations is incomplete.",
16, "CannotCreateLe tter2"
2073 Else
2090 Set thisDB = DBEngine(0)(0)
2100 Set myQuery = thisDB.QueryDef s("qryLetterPoo lRecsSumByPool" )
2110 myQuery.Paramet ers("theContrib ID") = theLCI.ContribI D
2120 Set poolRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT)
2130 If poolRS.BOF And poolRS.EOF Then
2140 MsgBox "There are no pool allocations for this contribution", 16,
CannotCreateLet ter
2150 Else
2210 findAndReplace "<theSalutation NameTitle>", theLCI.Recipien ts, gWord
2220 findAndReplace "<theAddres s>", theLCI.PrimaryC ontactAddress, gWord
2230 findAndReplace "<theGreeting>" , theLCI.PrimaryC ontactGreeting,
gWord
2240 findAndReplace "<theProgramAcc ountName>",
theLCI.ProgramA ccountName, gWord 'NB: Two occurrances of this field
2241 findAndReplace "<theProgramAcc ountName>",
theLCI.ProgramA ccountName, gWord
2250 findAndReplace "<theCharityPho ne800>", charityPhone800 Get(), gWord
2270 findText "%thePoolName%" , gWord
2356 With gWord.Selection
2257 .MoveRight Unit:=wdWord, Count:=4, Extend:=wdExten d 'Select
entire row
2258 .Delete Unit:=wdCharact er, Count:=1 'Clear the literals from
table's single row
2420 poolRS.MoveLast
2430 If poolRS.RecordCo unt 1 Then 'Add extra lines to table as
needed
2432 .MoveRight Unit:=wdWord, Count:=1, Extend:=wdExten d
2433 .InsertRows poolRS.RecordCo unt - 1
2434 .MoveLeft Unit:=wdCharact er, Count:=1
2436 End If 'We
should now have required #of rows and have cursor in top left cell

2440 poolRS.MoveFirs t 'Populate the MS Word table
2450 Do Until poolRS.EOF
2451 myPrincipalSum = myPrincipalSum + poolRS!SumOfPRN C_AM
2552 .TypeText Text:=poolRS!PO OL_NM
2554 .MoveRight Unit:=wdCell, Count:=1
2555 .TypeText Text:=Format$(p oolRS!myPercent , "Percent")
2560 .MoveRight Unit:=wdCell, Count:=1
2561 .TypeText Text:=Format$(p oolRS!SumOfPRNC _AM, "Currency")
2562 .MoveRight Unit:=wdCell, Count:=1
2563 .TypeText Text:=Str(poolR S!PORT_ID) & "-" &
poolRS!VAST_ACC T_NO
2564 poolRS.MoveNext
2565 If poolRS.EOF = False Then
2569 .MoveDown Unit:=wdLine, Count:=1
2570 .MoveLeft Unit:=wdWord, Count:=3
2571 End If
2572 Loop
2573 End With
2699 End If

2700 findAndReplace "<thePrincipalS um>", Format$(myPrinc ipalSum,
"Currency") , gWord 'NB: Two occurrances of this field
2701 findAndReplace "<thePrincipalS um>", Format$(myPrinc ipalSum,
"Currency") , gWord

'2710 If myPrincipalSum <theLCI.TotalAm ountDonorEstima ted Then
'2711 bugAlert "Computed total <passed total. Computed = " &
Format$(myPrinc ipalSum, "Currency") & ", Passed = " &
Format$(theLCI. TotalAmountDono rEstimated, "Currency") & "."
'2712 End If

2990 conCustCash = True
2995 End If

2999 DoCmd.Hourglass False

conCustCash_xit :
debugStackPop
On Error Resume Next
Set myQuery = Nothing
poolRS.Close
Set poolRS = Nothing
Set thisDB = Nothing
Exit Function

conCustCash_err :
bugAlert ""
Resume conCustCash_xit
End Function

Private Function conCustMixed(th eLCI As mLetterCustInfo ) As Integer
20000 debugStackPush mModuleName & ": conCustMixed"
20001 On Error GoTo conCustMixed_er r

' PURPOSE: To Customize already-opened model letter nConMixed.doc as
' named in zstblLetter.
' ACCEPTS: - DOS 8.3 name of newly-opened letter
' - A structure containing various fields needed to customize
letter
' RETURNS: TRUE or FALSE depending on success
'
' NOTES: 1) Assumes global variable "gWord" has already been set
' 2) "namedAccountRS " includes named account info plus the Primary
Contact Person's name/address

20010 Dim thisDB As Database
Dim poolRS As Recordset
Dim securityRS As Recordset
Dim cashTotalRS As Recordset
Dim x As Integer

Dim myQuery As QueryDef

Dim myPrincipalSum As Double

Const CannotCreateLet ter = "Cannot Create Letter"

20070 If poolRecsContrib Invalid(theLCI. ContribID) Then
20071 DoCmd.Hourglass False
20072 MsgBox "Informatio n for one or more pool allocations is incomplete.",
16, "CannotCreateLe tter2"
20073 Else
20080 Set thisDB = DBEngine(0)(0)
20100 Set myQuery = thisDB.QueryDef s("qryLetterCon LineItemsNonCas hFetch")
20110 myQuery.Paramet ers("theContrib ID") = theLCI.ContribI D
20120 Set securityRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT)
20130 If securityRS.BOF And securityRS.EOF Then
20131 bugAlert "No security items found for contrib ID '" &
Str(theLCI.Cont ribID) & "'. Since this is a 'mixed' letter, this should not
happen."
20139 Else
20140 Set myQuery = thisDB.QueryDef s("qryLetterCon CashTotalFetch" )
20141 myQuery.Paramet ers("theContrib ID") = theLCI.ContribI D
20142 Set cashTotalRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT)
20143 If cashTotalRS.BOF And cashTotalRS.EOF Then
20144 bugAlert "No cash items found for contrib ID '" &
Str(theLCI.Cont ribID) & "'. Since this is a 'mixed' letter, this should not
happen."
20149 Else
20160 Set myQuery = thisDB.QueryDef s("qryLetterPoo lRecsSumByPool" )
20170 myQuery.Paramet ers("theContrib ID") = theLCI.ContribI D
20180 Set poolRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT)
20190 If poolRS.BOF And poolRS.EOF Then
20200 MsgBox "There are no pool allocations for this contribution",
16, CannotCreateLet ter
20210 Else
20230 findAndReplace "<theSalutation NameTitle>", theLCI.Recipien ts,
gWord 'DMN
20240 findAndReplace "<theAddres s>", theLCI.PrimaryC ontactAddress,
gWord 'DMN
20250 findAndReplace "<theGreeting>" , theLCI.PrimaryC ontactGreeting,
gWord 'DMN
20260 findAndReplace "<theProgramAcc ountName>",
theLCI.ProgramA ccountName, gWord 'DMN
20270 findAndReplace "<theCharityPho ne800>", charityPhone800 Get(),
gWord 'DMN

20300 findText "%NumberSharesC ertificates%", gWord
20310 With gWord.Selection
20320 .MoveRight Unit:=wdCharact er, Count:=3, Extend:=wdExten d
'Select entire row
20330 .Delete Unit:=wdCharact er, Count:=1 'Clear the literals
from table's single row
20340 securityRS.Move Last
20350 If securityRS.Reco rdCount 1 Then 'Add extra lines to
table as needed
20360 .MoveRight Unit:=wdCharact er, Count:=2, Extend:=wdExten d
20370 .InsertRows securityRS.Reco rdCount - 1
20380 .MoveLeft Unit:=wdCharact er, Count:=1
20390 End If 'We should now have required #of rows and have
cursor in top left cell

20400 securityRS.Move First 'Populate the MS Word table
20410 Do Until securityRS.EOF
20411 .TypeText Text:=Format$(s ecurityRS!NO_SH RS_QY,
"#,###.000" )
20412 .MoveRight Unit:=wdCell, Count:=1
20413 .TypeText Text:=securityR S!ISSR_NM
20414 securityRS.Move Next
20420 If securityRS.EOF = False Then
20421 .MoveDown Unit:=wdLine, Count:=1
20422 .MoveLeft Unit:=wdWord, Count:=1
20423 End If
20424 Loop

20500 findText "%thePoolName%" , gWord
20510 .HomeKey Unit:=wdLine 'Moves to the
front of the first cell
20520 .SelectRow 'Selects the
entire row
20530 .Delete Unit:=wdCharact er, Count:=1 'Deletes
everything in that row
20540 If poolRS.RecordCo unt 1 Then 'Add extra lines
to table as needed
20560 .InsertRows poolRS.RecordCo unt - 1
20570 .HomeKey Unit:=wdLine 'Make sure we're
in at the begining
20580 End If 'We should now
have required #of rows and
'have cursor
in top left cell
20600 poolRS.MoveFirs t 'Populate the MS
Word table
20610 Do Until poolRS.EOF
20620 .TypeText Text:=poolRS!PO OL_NM
20621 myPrincipalSum = myPrincipalSum + poolRS!SumOfPRN C_AM
20630 .MoveRight Unit:=wdCell, Count:=1
20640 .TypeText Text:=Format$(p oolRS!myPercent , "Percent")
20650 .MoveRight Unit:=wdCell, Count:=1
20660 .TypeText Text:=Format$(p oolRS!SumOfPRNC _AM, "Currency")
20670 .MoveRight Unit:=wdCell, Count:=1
20680 .TypeText Text:=Str(poolR S!PORT_ID) & "-" &
poolRS!VAST_ACC T_NO
20690 poolRS.MoveNext
20700 If poolRS.EOF = False Then
20710 .MoveRight Unit:=wdCell 'This is
equivalent of a TAB - if we are not
20730 End If ' in the last
cell on the line = trouble.
20740 Loop
20750 End With

20820 findAndReplace "<theCashTotal> ",
Format$(cashTot alRS!CashTotal, "Currency") , gWord 'DMN
20860 findAndReplace "<thePrincipalS um>", Format$(myPrinc ipalSum,
"Currency") , gWord 'DMN

20930 conCustMixed = True
20931 End If
20940 End If
20997 End If
20998 End If

20999 DoCmd.Hourglass False

conCustMixed_xi t:
debugStackPop
Set myQuery = Nothing
poolRS.Close
Set poolRS = Nothing
securityRS.Clos e
Set securityRS = Nothing
cashTotalRS.Clo se
Set cashTotalRS = Nothing
Set thisDB = Nothing
On Error Resume Next
Exit Function

conCustMixed_er r:
bugAlert ""
Resume conCustMixed_xi t
End Function
Private Function conCustSec(theL CI As mLetterCustInfo ) As Integer
13000 debugStackPush mModuleName & ": conCustSec"
13001 On Error GoTo conCustSec_err

' PURPOSE: To Customize already-opened model letter nConSec.doc as
' named in zstblLetter.
' ACCEPTS: - DOS 8.3 name of newly-opened letter
' - A structure containing various fields needed to customize
letter
' RETURNS: TRUE or FALSE depending on success
'
' NOTES: 1) Assumes global variable "gWord" has already been set
' 2) "namedAccountRS " includes named account info plus the Primary
Contact Person's name/address

13010 Dim thisDB As Database
Dim poolRS As Recordset
Dim securityRS As Recordset
Dim x As Integer

Dim myQuery As QueryDef

Dim myPrincipalSum As Double

Const CannotCreateLet ter = "Cannot Create Letter"

13070 If poolRecsContrib Invalid(theLCI. ContribID) Then
13071 DoCmd.Hourglass False
13072 MsgBox "Informatio n for one or more pool allocations is incomplete.",
16, "CannotCreateLe tter2"
13073 Else
13080 Set thisDB = DBEngine(0)(0)
13100 Set myQuery = thisDB.QueryDef s("qryLetterCon LineItemsNonCas hFetch")
13110 myQuery.Paramet ers("theContrib ID") = theLCI.ContribI D
13120 Set securityRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT)
13130 If securityRS.BOF And securityRS.EOF Then
13131 bugAlert "No security items found for contrib ID '" &
Str(theLCI.Cont ribID) & "'. Since this is a 'mixed' letter, this should not
happen."
13139 Else
13160 Set myQuery = thisDB.QueryDef s("qryLetterPoo lRecsSumByPool" )
13170 myQuery.Paramet ers("theContrib ID") = theLCI.ContribI D
13180 Set poolRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT)
13190 If poolRS.BOF And poolRS.EOF Then
13200 MsgBox "There are no pool allocations for this contribution", 16,
CannotCreateLet ter
13210 Else
13230 findAndReplace "<theSalutation NameTitle>", theLCI.Recipien ts,
gWord
13240 findAndReplace "<theAddres s>", theLCI.PrimaryC ontactAddress,
gWord
13250 findAndReplace "<theGreeting>" , theLCI.PrimaryC ontactGreeting,
gWord
13260 findAndReplace "<theProgramAcc ountName>",
theLCI.ProgramA ccountName, gWord
13265 findAndReplace "<theProgramAcc ountName>",
theLCI.ProgramA ccountName, gWord 'there are 2
13270 findAndReplace "<theCharityPho ne800>", charityPhone800 Get(),
gWord

13290 findText "NumberSharesCe rtificates%", gWord
13356 With gWord.Selection
13257 .MoveRight Unit:=wdWord, Count:=2, Extend:=wdExten d 'Select
entire row
13258 .Delete Unit:=wdCharact er, Count:=1 'Clear the literals from
table's single row
13420 securityRS.Move Last
13430 If securityRS.Reco rdCount 1 Then 'Add extra lines to table
as needed
13432 .MoveRight Unit:=wdWord, Count:=1, Extend:=wdExten d
13433 .InsertRows securityRS.Reco rdCount - 1
13434 .MoveLeft Unit:=wdCharact er, Count:=1
13536 End If 'We should now have required #of rows and have cursor
in top left cell

13440 securityRS.Move First 'Populate the MS Word table
13450 Do Until securityRS.EOF
13452 .TypeText Text:=Format$(s ecurityRS!NO_SH RS_QY, "#,###.000" )
13454 .MoveRight Unit:=wdCell, Count:=1
13455 .TypeText Text:=securityR S!ISSR_NM
13457 securityRS.Move Next
13456 If securityRS.EOF = False Then
13458 .MoveDown Unit:=wdLine, Count:=1
13469 .MoveLeft Unit:=wdWord, Count:=1
13470 End If
13471 Loop
13472 End With

13701 findText "%thePoolName%" , gWord
13756 With gWord.Selection
13757 .MoveRight Unit:=wdWord, Count:=4, Extend:=wdExten d 'Select
entire row
13758 .Delete Unit:=wdCharact er, Count:=1 'Clear the literals from
table's single row
13820 poolRS.MoveLast
13830 If poolRS.RecordCo unt 1 Then 'Add extra lines to table as
needed
13832 .MoveRight Unit:=wdCell, Count:=2, Extend:=wdExten d
13833 .InsertRows poolRS.RecordCo unt - 1
13834 .MoveLeft Unit:=wdCell, Count:=1
13835 End If 'We should now have required #of rows and have cursor
in top left cell

13840 poolRS.MoveFirs t 'Populate the MS Word table
13850 Do Until poolRS.EOF
13852 .TypeText Text:=poolRS!PO OL_NM
13853 myPrincipalSum = myPrincipalSum + poolRS!SumOfPRN C_AM
13854 .MoveRight Unit:=wdCell, Count:=1
13855 .TypeText Text:=Format$(p oolRS!myPercent , "Percent")
13860 .MoveRight Unit:=wdCell, Count:=1
13861 .TypeText Text:=Format$(p oolRS!SumOfPRNC _AM, "Currency")
13862 .MoveRight Unit:=wdCell, Count:=1
13863 .TypeText Text:=Str(poolR S!PORT_ID) & "-" &
poolRS!VAST_ACC T_NO
13864 poolRS.MoveNext
13865 If poolRS.EOF = False Then
13870 .MoveDown Unit:=wdLine, Count:=1
13871 .MoveLeft Unit:=wdCell, Count:=3
13872 End If
13873 Loop
13874 End With
13899 End If

13950 findAndReplace "<thePrincipalS um>", Format$(myPrinc ipalSum,
"Currency") , gWord 'DMN
13990 conCustSec = True
13997 End If
13998 End If

13999 DoCmd.Hourglass False
conCustSec_xit:
debugStackPop
On Error Resume Next
Set myQuery = Nothing
poolRS.Close
Set poolRS = Nothing
securityRS.Clos e
Set securityRS = Nothing
Set thisDB = Nothing
Exit Function

conCustSec_err:
bugAlert ""
Resume conCustSec_xit

End Function

Private Function formatGreeting( theSalutation, theNameFirst, theNameLast) As
String
debugStackPush mModuleName & ": formatGreeting"
On Error GoTo formatGreeting_ err

' Accepts: Salutation, first name, last name
' Returns: Concatonation of all three or fewer depending on what's present

Dim line1 As String

If theSalutation & "" <"" Then
line1 = line1 + "Dear " & theSalutation & " " & theNameLast
Else
line1 = line1 + "Dear " & theNameFirst & " " & theNameLast
End If

formatGreeting = line1

formatGreeting_ xit:
debugStackPop
On Error Resume Next
Exit Function

formatGreeting_ err:
bugAlert ""
Resume formatGreeting_ xit

End Function
Private Sub findText(theTex t As String, theApp As Word.Applicatio n)
debugStackPush mModuleName & ": findText"
On Error GoTo findText_err

' PURPOSE: To find a text string, beginning at the start of the document
' ACCEPTS: - String to find
' - Pointer to the application
'
' NOTES: 1) This seems a little shaky for the following reasons
' - We really don't know why .Find always begins at the start of the
document...it just does...
' - Seems like the "right" way to do this would be to pass a pointer
to
' the document in question rather than the app, hoping that the
user hasn't
' activated some other document on us
' - The entire routine was just copied from a Word macro we
generated when
' doing what we wanted to do....we don't really understand each
line of code.

' theApp.Selectio n.HomeKey Unit:=wdStory, Extend:=wdMove

With theApp.Selectio n.Find
.ClearFormattin g
.Text = theText
.Replacement.Te xt = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLik e = False
.MatchAllWordFo rms = False
.Execute
End With

findText_xit:
debugStackPop
On Error Resume Next
Exit Sub

findText_err:
bugAlert ""
Resume findText_xit
End Sub

Private Function genericGranteeC ust(theLCI As mLetterCustInfo ) As Integer
16000 debugStackPush mModuleName & ": genericGranteeC ust: "
16001 On Error GoTo genericGranteeC ust_err

' PURPOSE: To customizes already-opened model letter GENORG.DOC as
' named in zstblLetter.
' ACCEPTS: DOS 8.3 name of newly-opened letter
' DonorID of person for whom letter is being generated
' RETURNS: TRUE or FALSE depending on success

' REQUIRES: global variable "gWord" has already been set

16040 findAndReplace "<theNameLegal> ", theLCI.NameLega l, gWord
16041 findAndReplace "<theNameLegal> ", theLCI.NameLega l, gWord
16050 findAndReplace "<theAddres s>", theLCI.GranteeA ddress, gWord
16060 findAndReplace "<theContactAtt n>", theLCI.Recipien ts, gWord
16070 findAndReplace "<theContactGre eting>", theLCI.Greeting , gWord
16080 findAndReplace "<theCharityPho ne800>", charityPhone800 Get(), gWord


16994 genericGranteeC ust = True

genericGranteeC ust_xit:
debugStackPop
On Error Resume Next
Exit Function

genericGranteeC ust_err:
bugAlert ""
Resume genericGranteeC ust_xit
End Function

Private Function genericPersonCu st(theLCI As mLetterCustInfo ) As Integer
debugStackPush mModuleName & ": genericPersonCu st: "
On Error GoTo genericPersonCu st_err

' PURPOSE: To customize already-opened model letter GENDONOR.DOC as
' named in zstblLetter.

' ACCEPTS: DOS 8.3 name of newly-opened letter
' DonorID of person for whom letter is being generated
' RETURNS: TRUE or FALSE depending on success

' NOTES: - Assumes global variable "gWord" has already been set

Dim thisDB As Database
Dim personRS As Recordset
Dim myQuery As QueryDef
Dim fHome As Form

findAndReplace "<theSalutation NameTitle>", theLCI.Recipien ts, gWord
findAndReplace "<theAddres s>", theLCI.Address, gWord
findAndReplace "<theGreeting>" , theLCI.Greeting , gWord
findAndReplace "<theCharityPho ne800>", charityPhone800 Get(), gWord

genericPersonCu st = True

genericPersonCu st_xit:
debugStackPop
On Error Resume Next
Exit Function

genericPersonCu st_err:
bugAlert ""
Resume genericPersonCu st_xit
End Function

Private Function getGranteeConta ctPersonInfo(th eGranteeID,
theGranteeConta ctAttn, theGranteeConta ctGreeting) As Integer
debugStackPush mModuleName & ": getGranteeConta ctPersonInfo"
On Error GoTo getGranteeConta ctPersonInfo_er r

' PURPOSE: To get an "ATTN: salutation/name/title and a "Dear..." greeting line
for one contact person
' ACCEPTS: GranteeID
' RETURNS: True or False depending on success
' SETS: An "Attn:" line
' A "Greeting" line (both suitable for .Insert into MS Word...)
'
' NOTES: 1) Even if there is no contact person, we consider it a success as
long as nothing bombed.

Dim thisDB As Database
Dim myRS As Recordset
Dim myQuery As QueryDef

Dim myGranteeContac tPersonID As Long

If granteeContactP ersonSelect(the GranteeID, myGranteeContac tPersonID) = True
Then
If myGranteeContac tPersonID 0 Then
Set thisDB = DBEngine(0)(0)
Set myQuery = thisDB.QueryDef s("qryGranteeCo ntactPersonRecF etch")
myQuery.Paramet ers("theGrantee ContactPersonID ") =
myGranteeContac tPersonID
Set myRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT, DB_FORWARDONLY)
If myRS.BOF And myRS.EOF Then
bugAlert "Unable to find contactPersonID " &
Str(myGranteeCo ntactPersonID)
Else
theGranteeConta ctAttn = "Attn: " &
formatSalutatio nNameTitle(myRS !SALUT_TX, myRS!FRST_NM, myRS!MI_NM, myRS!LST_NM,
myRS!TITLE_TX)
theGranteeConta ctGreeting = formatGreeting( myRS!SALUT_TX,
myRS!FRST_NM, myRS!LST_NM)
getGranteeConta ctPersonInfo = True
End If
Else
getGranteeConta ctPersonInfo = True
End If
End If

getGranteeConta ctPersonInfo_xi t:
debugStackPop
On Error Resume Next
Set myQuery = Nothing
myRS.Close
Set myRS = Nothing
Set thisDB = Nothing
Exit Function

getGranteeConta ctPersonInfo_er r:
bugAlert ""
Resume getGranteeConta ctPersonInfo_xi t
End Function

Private Function getGrantRequest Info(theGrantRe questID As Long,
theNamedAccount ID As Long, theGRI As GrantRequestInf o) As Integer
debugStackPush mModuleName & ": getGrantRequest Info"
On Error GoTo getGrantRequest Info_err

' PURPOSE: To extract information about a given grant request
' Accepts: ID of the grant request in question
' Returns: TRUE or FALSE depending on success
' Sets: theGRI with the information

Dim thisDB As Database
Dim myRS As Recordset
Dim myQuery As QueryDef
Dim x, y As Integer
Dim Length As Integer
Dim theAdvisers As String
Dim theCount As Integer
Dim myAdvisers As String


' This call and the little loop get the advisers names, properly formatted and
work them
' into 2 lines for the letter.
x = namedAccountAdv isersGet(theNam edAccountID, theAdvisers, theCount)

For y = 1 To theCount
Length = Len(theAdvisers )
x = InStr(1, theAdvisers, " and ")
If x 0 Then
myAdvisers = myAdvisers & Left(theAdviser s, x - 1)
Else
myAdvisers = myAdvisers & theAdvisers
End If
If y <theCount Then
myAdvisers = myAdvisers & Chr$(13) ' Chr$(13) is a line
feed
theAdvisers = Right(theAdvise rs, Length - (x + 4))
End If
Next y

Set thisDB = DBEngine(0)(0)
Set myQuery = thisDB.QueryDef s("qryGetGrantR equestInfo")
myQuery.Paramet ers("theGrantRe questID") = theGrantRequest ID

Set myRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT)
If Not (myRS.BOF And myRS.EOF) Then
With theGRI
.GNTE_ID = myRS!GNTE_ID
.LEGL_NM = myRS!LEGL_NM & ""
.RCVD_DT = myRS!RCVD_DT
.ACK_PERS_NM = myRS!ACK_PERS_N M & ""
.VAST_ACCT_NO = myRS!VAST_ACCT_ NO & ""
.PROG_ACCT_NM = myRS!PROG_ACCT_ NM & ""
.PROG_PURP_TX = myRS!PROG_PURP_ TX & ""
.PrimaryContact Address = personAddressGe t(myRS!PrimaryC ontactPerson)
.PrimaryContact SalutationNameT itle = myAdvisers
.PrimaryContact Greeting = formatGreeting( myRS!SALUTATION ,
myRS!FIRST_NAME , myRS!LAST_NAME)
End With
getGrantRequest Info = True
End If

getGrantRequest Info_xit:
debugStackPop
On Error Resume Next
Set myQuery = Nothing
myRS.Close
Set myRS = Nothing
Set thisDB = Nothing
Exit Function

getGrantRequest Info_err:
bugAlert ""
Resume getGrantRequest Info_xit
End Function

Private Function grantCustAnon(t heLCI As mLetterCustInfo ) As Integer
10000 debugStackPush mModuleName & ": grantCustAnon: "
10001 On Error GoTo grantCustAnon_e rr

' PURPOSE: To customize already-opened model letter: ORGANON.DOC as
' named in zstblLetter.
' ACCEPTS: DOS 8.3 name of newly-opened letter
' DonorID of person for whom letter is being generated
' RETURNS: TRUE or FALSE depending on success

' NOTES: Assumes global variable "gWord" has already been set


10010 Dim myGranteeContac tAttn As String
Dim myGranteeContac tGreeting As String

Const CannotCreateLet ter = "Cannot Create Letter"

10020 If getGranteeConta ctPersonInfo(th eLCI.GranteeID, myGranteeContac tAttn,
myGranteeContac tGreeting) = True Then
10050 findAndReplace "<theNameLegal> ", theLCI.NameLega l, gWord 'DMN
10051 findAndReplace "<theNameLegal> ", theLCI.NameLega l, gWord 'DMN
10060 findAndReplace "<theAddres s>", theLCI.GranteeA ddress, gWord 'DMN
10070 findAndReplace "<theContactAtt n>", myGranteeContac tAttn, gWord 'DMN
10080 findAndReplace "<theContactGre eting>", myGranteeContac tGreeting, gWord
'DMN
10090 findAndReplace "<theAmount >", theLCI.TotalAmo untGrant, gWord 'DMN
10100 findAndReplace "<theCharityPho ne800>", charityPhone800 Get(), gWord 'DMN
10110 findAndReplace "<thePurposePro gram>", theLCI.PurposeP rog, gWord 'DMN
10994 grantCustAnon = True
19990 End If

grantCustAnon_x it:
debugStackPop
On Error Resume Next
Exit Function

grantCustAnon_e rr:
bugAlert ""
Resume grantCustAnon_x it
End Function
Private Function grantCustAttrib (theLCI As mLetterCustInfo ) As Integer
11000 debugStackPush mModuleName & ": grantCustAttrib : "
11001 On Error GoTo grantCustAttrib _err

' PURPOSE: To customizes already-opened model letter ORGGRANT.DOC as
' named in zstblLetter.
' ACCEPTS: Structure containing required info
' RETURNS: TRUE or FALSE depending on success

' NOTES: Assumes global variable "gWord" has already been set

11010 Dim myAmount As String
Dim myGCI As GranteeContactP ersonInfo
Dim x As Integer
Dim myGranteeContac tAttn As String
Dim myGranteeContac tGreeting As String
Dim FrontOfString As String
Dim RestOfString As String
Dim Length As String

Const CannotCreateLet ter = "Cannot Create Letter"

11020 If getGranteeConta ctPersonInfo(th eLCI.GranteeID, myGranteeContac tAttn,
myGranteeContac tGreeting) = True Then
11050 findAndReplace "<theNameLegal> ", theLCI.NameLega l, gWord
11051 findAndReplace "<theNameLegal> ", theLCI.NameLega l, gWord
11060 findAndReplace "<theAddres s>", theLCI.GranteeA ddress, gWord
11070 findAndReplace "<theContactAtt n>", myGranteeContac tAttn, gWord
11080 findAndReplace "<theContactGre eting>", myGranteeContac tGreeting, gWord
11090 findAndReplace "<theAmount >", theLCI.TotalAmo untGrant, gWord
11100 findAndReplace "<thePurposePro gram>", theLCI.PurposeP rog, gWord
11110 findAndReplace "<theCharityPho ne800>", charityPhone800 Get(), gWord
11120 findAndReplace "<theProgramAcc ountName>", theLCI.ProgramA ccountName,
gWord
11130 findAndReplace "<thePersonToBe Acknowledged>",
theLCI.PersonTo BeAcknowledged, gWord
'This section of code takes theLCI.PrimaryC ontactSalutatio nNameTitle apart and
puts a "vbTab" between the
' advisers' names - if there are 2 advisers.
11140 Length = Len(theLCI.Prim aryContactSalut ationNameTitle)
11150 x = InStr(1, theLCI.PrimaryC ontactSalutatio nNameTitle, Chr$(13)) 'find
the carriage return
11155 If x 0 Then
11160 FrontOfString = Left(theLCI.Pri maryContactSalu tationNameTitle , x)
11170 RestOfString = Right(theLCI.Pr imaryContactSal utationNameTitl e,
Length - x) 'put the back part in holding place
11180 theLCI.PrimaryC ontactSalutatio nNameTitle = FrontOfString & vbTab &
RestOfString 'get the TAB in the string
11185 End If
11190 findAndReplace "<theDonorSalut ationNameTitle> ",
theLCI.PrimaryC ontactSalutatio nNameTitle, gWord 'DMN

11200 findAndReplace "<theDonorAddre ss>", theLCI.PrimaryC ontactAddress, gWord
'DMN
11993 grantCustAttrib = True
11999 End If

grantCustAttrib _xit:
debugStackPop
On Error Resume Next
Exit Function

grantCustAttrib _err:
bugAlert ""
Resume grantCustAttrib _xit
End Function
Private Function grantCustToDono r(theLCI As mLetterCustInfo ) As Integer
21000 debugStackPush mModuleName & ": grantCustToDono r: "
21001 On Error GoTo grantCustToDono r_err

' PURPOSE: To customizes already-opened model letter DONGRANT.DOCC as
' ACCEPTS: Structure containing required info
' RETURNS: TRUE or FALSE depending on success

' NOTES: Assumes global variable "gWord" has already been set

21010 Dim thisDB As Database
Dim grantRequestLin eItemRS As Recordset

Dim myQuery As QueryDef
Dim myNav As Double
Dim x As Integer


Const CannotCreateLet ter = "Cannot Create Letter"

21100 Set thisDB = DBEngine(0)(0)

21110 Set myQuery = thisDB.QueryDef s("qryGrantRequ estLineItemsFet ch")
21111 myQuery.Paramet ers("theGrantRe questID") = theLCI.GrantReq uestID
21112 Set grantRequestLin eItemRS = myQuery.OpenRec ordset(DB_OPEN_ DYNASET)
21120 If grantRequestLin eItemRS.BOF And grantRequestLin eItemRS.EOF Then
21121 bugAlert "No line items found for grant# " & Str(theLCI.Gran tRequestID)
21122 Else
21200 findAndReplace "<theSalutation NameTitle>",
theLCI.PrimaryC ontactSalutatio nNameTitle, gWord
21210 findAndReplace "<theProgramAcc ountName>", theLCI.ProgramA ccountName,
gWord
21220 findAndReplace "<theAddres s>", theLCI.PrimaryC ontactAddress, gWord
21230 findAndReplace "<theGreeting>" , theLCI.PrimaryC ontactGreeting, gWord
21240 findAndReplace "<theGranteeNam e>", theLCI.NameLega l, gWord 'NB: Two
occurrances of this field in letter
21241 findAndReplace "<theGranteeNam e>", theLCI.NameLega l, gWord
21250 findAndReplace "<thePersonToBe Acknowledged>",
theLCI.PersonTo BeAcknowledged, gWord
'21260 findAndReplace "<theReceivedDa te>", Format$(theLCI. GrantReceivedDa te,
"mm/dd/yyyy"), gWord
21270 findAndReplace "<theCharityPho ne800>", charityPhone800 Get(), gWord
21280 findAndReplace "<theAmount >", theLCI.TotalAmo untGrant, gWord

21290 findText "%thePoolName%" , gWord

21300 With gWord.Selection
21310 .HomeKey Unit:=wdLine 'Moves to the front of
the first cell
21320 .SelectRow 'Selects the entire row
21325 .Delete Unit:=wdCharact er, Count:=1 'Deletes everything in
that row
21330 grantRequestLin eItemRS.MoveLas t
21340 If grantRequestLin eItemRS.RecordC ount 1 Then 'Add
extra lines to table as needed
21360 .InsertRows grantRequestLin eItemRS.RecordC ount - 1
21370 .HomeKey Unit:=wdLine
21380 End If 'We
should now have required #of rows and have cursor in top left cell

21400 grantRequestLin eItemRS.MoveFir st 'Populate the MS Word table
21410 Do Until grantRequestLin eItemRS.EOF
21420 .TypeText Text:=grantRequ estLineItemRS!P OOL_NM
21430 .MoveRight Unit:=wdCell, Count:=1
21440 .TypeText Text:=Format$(g rantRequestLine ItemRS!REDMPTN_ DT,
"mm/dd/yyyy")
21450 .MoveRight Unit:=wdCell, Count:=1
21460 .TypeText Text:=Format$(g rantRequestLine ItemRS!SHRS_QY,
"#,###.000" )
21470 myNav = DLookup("NAV_AM T", "tlkpPoolValue" , "VAL_DT=#" &
grantRequestLin eItemRS!REDMPTN _DT & "# And POOL_ID=" &
grantRequestLin eItemRS!POOL_ID )
21480 .MoveRight Unit:=wdCell, Count:=1
21490 .TypeText Text:=Format$(m yNav, "#,###.00")
21500 .MoveRight Unit:=wdCell, Count:=1
21510 .TypeText Text:=Format$(g rantRequestLine ItemRS!DOL_GNTD _AM,
"Currency")
21520 .MoveRight Unit:=wdCell, Count:=1
21530 .TypeText Text:=theLCI.Va stAccountNumber
21540 grantRequestLin eItemRS.MoveNex t
21550 If grantRequestLin eItemRS.EOF = False Then
21560 .MoveRight Unit:=wdCell 'This is a TAB - so we'd
better be in the right place
21580 End If
21590 Loop
21599 End With

21600 findAndReplace "<theAmountSum> ", theLCI.TotalAmo untGrant, gWord

21998 grantCustToDono r = True
21999 End If

grantCustToDono r_xit:
debugStackPop
On Error Resume Next
Set myQuery = Nothing
grantRequestLin eItemRS.Close
Set grantRequestLin eItemRS = Nothing
Exit Function

grantCustToDono r_err:
bugAlert ""
Resume grantCustToDono r_xit
End Function
Private Function granteeRequirem entsCust(theLCI As mLetterCustInfo ) As Integer
17000 debugStackPush mModuleName & ": granteeRequirem entsCust: "
17001 On Error GoTo granteeRequirem entsCust_err

' PURPOSE: To customize already-opened model letter ORGINFO.DOC as
' named in zstblLetter
' ACCEPTS: DOS 8.3 name of newly-opened letter
' DonorID of person for whom letter is being generated
' RETURNS: TRUE or FALSE depending on success

' NOTES: Assumes global variable "gWord" has already been set

17010 Dim thisDB As Database
Dim granteeRS As Recordset
Dim myQuery As QueryDef

Dim myNameLegal As String
Dim myAddress As String
Dim myContactPerson As String
Dim myAttnLine As String
Dim myGCI As GranteeContactP ersonInfo

Const CannotCreateLet ter = "Cannot Create Letter"

17020 Set thisDB = DBEngine(0)(0)

17080 Set myQuery = thisDB.QueryDef s("qryGranteeRe cFetch")
17090 myQuery.Paramet ers("theGrantee ID") = theLCI.GranteeI D
17100 Set granteeRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT)
17110 If granteeRS.BOF And granteeRS.EOF Then
17120 bugAlert "Grantee# " & Str(theLCI.Gran teeID) & " not found."
17130 Else
17170 myNameLegal = granteeRS!LEGL_ NM
17190 myAddress = formatAddress(F alse, True, granteeRS!ST_AD DR_1,
granteeRS!ST_AD DR_2, granteeRS!CITY, granteeRS!STE_A BV_CD, granteeRS!ZIP)
17200 If granteeContactP ersonInfoGet(Fo rms!frmHome!txt GranteeContactP ersonID,
myGCI) Then
17201 myAttnLine = "ATTN: " & myGCI.SALUT_TX & " " & myGCI.FRST_NM & " " &
myGCI.MI_NM & " " & myGCI.LST_NM & " " & myGCI.TITLE_TX & ": " &
myGCI.JOB_TITLE _TX
17202 myContactPerson = myGCI.SALUT_TX & " " & myGCI.LST_NM
17203 Else
17204 myAttnLine = ""
17205 myContactPerson = ""
17206 End If

10050 findAndReplace "<theNameLegal> ", myNameLegal, gWord 'NB: Two
occurrances of this field in letter
10051 findAndReplace "<theNameLegal> ", myNameLegal, gWord
10060 findAndReplace "<theAddres s>", myAddress, gWord
10070 findAndReplace "<theCharityPho ne800>", charityPhone800 Get(), gWord
10080 findAndReplace "<theAttnLine>" , myAttnLine, gWord
10090 findAndReplace "<theContactPer son>", myContactPerson , gWord

17994 granteeRequirem entsCust = True
17999 End If

granteeRequirem entsCust_xit:
debugStackPop
On Error Resume Next
Set myQuery = Nothing
granteeRS.Close
Set granteeRS = Nothing
Set thisDB = Nothing
Exit Function

granteeRequirem entsCust_err:
bugAlert ""
Resume granteeRequirem entsCust_xit
End Function

Sub insertCC(theNam edAccountID)
debugStackPush mModuleName & ": insertCC"
On Error GoTo insertCC_err

' PURPOSE: To insert a "CC" block at the end of the letter
' ACCEPTS: ID of the named account
' RETURNS: nothing
'
' NOTES: 1) The whole CC thing is a *very* weak design - strictly a
last-minute kludge.
' What we really need is to store a person-to-CC as a personID and
' a mailing-address-to-CC in tblNamedAccount .
' 2) We could use some beautification in formatting. Right now it's
something like:
' cc:
' Mr John Smith
' 123 Main Street
' Corelville, FL 19329
' It would be nice to work out the Word formatting commands to get
"CC:" and the
' first line of the text block on the same line.


Dim thisDB As Database
Dim myRS As Recordset
Dim myQuery As QueryDef

12000 Set thisDB = DBEngine(0)(0)
12010 Set myQuery = thisDB.QueryDef s("qryNamedAcco untRecFetch")
12020 myQuery.Paramet ers("theNamedAc countID") = theNamedAccount ID
12030 Set myRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT, DB_FORWARDONLY)
12040 If (myRS.BOF And myRS.EOF) Then
12050 bugAlert "Failed to find named account ID " & Str(theNamedAcc ountID)
12060 Else
12070 If myRS!CC = True Then
12071 With gWord.Selection
12080 .EndKey Unit:=wdStory 'DMN
12090 .InsertAfter Text:=(Chr$(13) & "cc: " & Chr$(13)) 'DMN
'12100 gWord.Indent 'DMN
12110 .InsertAfter Text:=myRS!NOTE S 'DMN
12111 End With
12120 End If
12130 End If

12140 insertCC_xit:
12150 debugStackPop
12160 On Error Resume Next
12170 Set myQuery = Nothing
12180 myRS.Close
12190 Set myRS = Nothing
12200 Set thisDB = Nothing
12210 Exit Sub

12220 insertCC_err:
12230 bugAlert ""
12240 Resume insertCC_xit
End Sub

Function letterBeginCon( theContribID As Long) As Integer
1000 debugStackPush mModuleName & ": letterBeginCon"
1001 On Error GoTo letterBeginCon_ err

' PURPOSE: To start a confirmation letter via MS Word
' ACCEPTS: Contrib ID of the contribution
' RETURNS: True or False depending on success

1010 Dim thisWS As Workspace
Dim thisDB As Database
Dim letterRS As Recordset
Dim lineItemRS As Recordset
Dim namedAccountRS As Recordset
Dim myQuery As QueryDef

Dim myLCI As mLetterCustInfo

Dim gotCash As Integer
Dim gotInitialContr ib As Integer
Dim transOpen As Integer
Dim gotSecurity As Integer
Dim okToProceed As Integer
Dim myDosName As String
Dim myLetterID As Long
Dim myCashFlag As Integer
Dim myNamedAccountI D As Long
Dim mySecondaryAdvi sers As String

1020 statusSet "Opening model letter..."
1022 Set thisWS = DBEngine(0)
1023 Set thisDB = DBEngine(0)(0)
1035 Set myQuery = thisDB.QueryDef s("qryLetterCon LineItemsAllFet ch")
1040 myQuery.Paramet ers("theContrib ID") = theContribID
1041 Set lineItemRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT)

1050 If (lineItemRS.BOF And lineItemRS.EOF) Then
1051 bugAlert "No line items found for contrib ID " & Str(theContribI D)
1052 Else
1100 lineItemRS.Move First
1101 Do Until lineItemRS.EOF
1120 myCashFlag = DLookup("[CNTRBN_TYP_CASH _FL]", "tlkpContribTyp e",
"[CNTRBN_TYP_ID]=" & lineItemRS!CNTR BN_TYP_ID)
1121 If myCashFlag = True Then
1122 gotCash = True
1123 Else
1124 gotSecurity = True
1125 End If
1130 myLCI.TotalAmou ntProceeds = myLCI.TotalAmou ntProceeds +
lineItemRS!WFS_ PROCD_AM
1131 myLCI.TotalAmou ntDonorEstimate d = myLCI.TotalAmou ntDonorEstimate d +
lineItemRS!DON_ EST_AM
1198 lineItemRS.Move Next
1199 Loop

1200 gotInitialContr ib = contribInitialS tatusGet(theCon tribID)
1201 If gotInitialContr ib = True Then
1202 If (gotCash = True) And (gotSecurity = False) Then
1203 myLetterID = gLetterIdConNew Cash
1210 Else
1211 If (gotCash = False) And (gotSecurity = True) Then
1212 myLetterID = gLetterIdConNew Sec
1220 Else
1221 If (gotCash = True) And (gotSecurity = True) Then
1222 myLetterID = gLetterIdConNew Mixed
1230 Else
1231 bugAlert "(#1) Looks like no cash and no securities. This
should not happen."
1232 End If
1248 End If
1249 End If
1251 Else
1252 If (gotCash = True) And (gotSecurity = False) Then
1253 myLetterID = gLetterIdConAdd Cash
1260 Else
1261 If (gotCash = False) And (gotSecurity = True) Then
1262 myLetterID = gLetterIdConAdd Sec
1270 Else
1271 If (gotCash = True) And (gotSecurity = True) Then
1272 myLetterID = gLetterIdConAdd Mixed
1280 Else
1281 bugAlert "(#2) Looks like no cash and no securities. This
should not happen."
1282 End If
1288 End If
1289 End If
1299 End If

1300 statusSet "Opening model letter..."
1301 Set thisDB = DBEngine(0)(0)
1302 Set letterRS = thisDB.OpenReco rdset("zstblLet ter", DB_OPEN_TABLE)
1303 letterRS.Index = "PrimaryKey "
1304 letterRS.Seek "=", myLetterID
1305 If letterRS.NoMatc h Then
1306 bugAlert "No record found for letterID " & Str(myLetterID)
1307 Else
1308 myDosName = wordBegin(lette rRS!ModelName)
1330 If Len(myDosName) 0 Then
1331 Set myQuery = thisDB.QueryDef s("qryLetterNam edAccountInfoFe tch")
1335 myNamedAccountI D = namedAccountIdG etFromContribID (theContribID)
1336 myQuery.Paramet ers("theNamedAc countID") = myNamedAccountI D
1337 Set namedAccountRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT)
1338 If namedAccountRS. BOF And namedAccountRS. EOF Then
1339 bugAlert "Named Account# " & Str(myNamedAcco untID) & " not
found."
1340 Else
1241 With myLCI
1342 .PrimaryContact Address =
personAddressGe t(namedAccountR S!PrimaryContac tPerson)
1343 mySecondaryAdvi sers =
secondaryAdvise rsFetch(myNamed AccountID)
1344 .PrimaryContact Greeting =
formatGreeting( namedAccountRS! SALUTATION, namedAccountRS! FIRST_NAME,
namedAccountRS! LAST_NAME)
1345 .ContribID = theContribID
1346 .Recipients = formatFullName( namedAccountRS! FIRST_NAME,
namedAccountRS! MIDDLE_INITIAL, namedAccountRS! LAST_NAME, namedAccountRS! TITLE)
1347 mySecondaryAdvi sers =
secondaryAdvise rsFetch(myNamed AccountID)
1348 If Len(mySecondary Advisers) 0 Then
1349 .Recipients = myLCI.Recipient s & Chr$(13) &
mySecondaryAdvi sers
1350 End If
1351 .ProgramAccount Name = namedAccountRS! PROG_ACCT_NM
1255 End With
1665 Set thisWS = DBEngine(0)
1666 thisWS.BeginTra ns 'Transaction prevents adding
contact hist if customizing process fails
1667 transOpen = True
1668 If namedAccountCon tactHistoryRecA dd(myNamedAccou ntID,
"Re/Contribution# " & Str(theContribI D) & ", generated '" &
letterRS!descri ption & "' letter.", myLetterID, myDosName, theContribID, 0) Then
1669 statusSet "Customizin g model letter..."
1670 insertCC myNamedAccountI D
1699 tweakLetter1

1700 Select Case myLetterID
Case gLetterIdConNew Cash, gLetterIdConAdd Cash
1711 okToProceed = conCustCash(myL CI)
1720 Case gLetterIdConNew Sec, gLetterIdConAdd Sec
1721 okToProceed = conCustSec(myLC I)
1730 Case gLetterIdConNew Mixed, gLetterIdConAdd Mixed
1731 okToProceed = conCustMixed(my LCI)
1740 Case Else
1741 bugAlert "Unexpected letter ID=" & Str(myLetterID)
1799 End Select

1800 If okToProceed = True Then
1810 tweakLetter2 (myDosName)
1820 thisWS.CommitTr ans
1830 transOpen = False
1840 Forms!frmContri b!embLineItems. Form.Requery
1992 End If
1993 End If
1994 End If
1995 End If
1996 End If
1997 End If

1999 DoCmd.Hourglass False

letterBeginCon_ xit:
debugStackPop
On Error Resume Next
Set myQuery = Nothing
letterRS.Close
Set letterRS = Nothing
lineItemRS.Clos e
Set lineItemRS = Nothing
namedAccountRS. Close
Set namedAccountRS = Nothing
Set thisDB = Nothing
Set thisWS = Nothing
Exit Function

letterBeginCon_ err:
bugAlert ""
Resume letterBeginCon_ xit
End Function

Function letterBeginGene ricNamedAccount (theLetterID, thePersonID,
theNamedAccount ID) As Integer
15000 debugStackPush mModuleName & ": letterBeginGene ricNamedAccount "
15001 On Error GoTo letterBeginGene ricNamedAccount _err

' PURPOSE: - To open up via MS Word a blank letter addressed to the person
in question
' - To append a contact history record with a brief description of
the letter's
' subject to the named account in question
' ACCEPTS: ID of record in zstblLetter which contains DOS name of letter
' ID of person to whom letter is to be addressed
' ID of named account to whose contact history a record of this
letter will be appended

' RETURNS: TRUE or FALSE depending on success

15010 Dim thisWS As Workspace
Dim thisDB As Database
Dim letterRS As Recordset
Dim fHome As Form

Dim myLCI As mLetterCustInfo

Dim x As Integer
Dim myDosName As String
Dim transOpen As Integer
Dim okToProceed As Integer

Const objectNotExist = 2103
Const ReportCancelled = 2501

15012 Set thisDB = DBEngine(0)(0)
15013 Set letterRS = thisDB.OpenReco rdset("zstblLet ter", DB_OPEN_TABLE)
15014 letterRS.Index = "PrimaryKey "
15015 letterRS.Seek "=", theLetterID

15020 If letterRS.NoMatc h Then
15021 bugAlert "No record found for letterID " & Str(theLetterID )
15022 Else
15023 Set fHome = Forms!frmHome
15024 fHome!txtGenera lText = Null
15030 DoCmd.OpenForm "frmGetThumbNai lDescription", , , , , A_DIALOG
15039 If fHome!txtGenera lText & "" = "" Then
15040 DoCmd.Hourglass False
15050 MsgBox "Letter Cancelled", 0, "Cancelled"
15060 Else
15070 DoCmd.Hourglass True

15080 statusSet "Opening model letter..."
15090 myDosName = wordBegin(lette rRS!ModelName)
15130 If Len(myDosName) 0 Then
15131 Set thisWS = DBEngine(0)
15132 thisWS.BeginTra ns 'Transaction prevents adding
contact hist if customizing process fails
15133 transOpen = True
25235 With myLCI
15160 .Address = personAddressGe t(thePersonID)
15162 .Greeting = personGreetingG et(thePersonID)
15163 .Recipients = personNameFirst LastGet(thePers onID)
15165 End With
15170 If namedAccountCon tactHistoryRecA dd(CLng(theName dAccountID),
"Letter To " & myLCI.Recipient s & " Re/: " & fHome!txtGenera lText & ".", 0,
myDosName, 0, 0) Then
15171 statusSet "Customizin g model letter..."
15178 insertCC theNamedAccount ID
15180 tweakLetter1

15200 Select Case theLetterID
Case gLetterIdGeneri cPerson
15211 okToProceed = genericPersonCu st(myLCI)
15220 Case gLetterIdGrantD enied
15221 okToProceed = genericPersonCu st(myLCI)
15240 Case Else
15241 bugAlert "Unexpected letter ID=" & Str(theLetterID )
15299 End Select

15315 If okToProceed = True Then
15320 tweakLetter2 (myDosName)
15325 thisWS.CommitTr ans
15330 transOpen = False
15335 namedAccountScr eenLoad CLng(theNamedAc countID), True
15339 gWord.Activate 'DMN - used
to be: showLetter
15340 letterBeginGene ricNamedAccount = True
15345 Else
15350 thisWS.Rollback 'Customizing process probably
found invalid data for given letter...
15355 transOpen = False
15360 End If
15361 statusSet ""
15365 End If

15970 End If
15980 End If
15999 End If

letterBeginGene ricNamedAccount _xit:
debugStackPop
On Error Resume Next
Set fHome = Nothing
letterRS.Close
Set letterRS = Nothing
Set thisDB = Nothing
Set thisWS = Nothing
Exit Function

letterBeginGene ricNamedAccount _err:
If transOpen = True Then
thisWS.Rollback
End If
Select Case Err
Case objectNotExist
MsgBox "Cannot find anything named " & Chr$(34) & letterRS!Functi onName &
Chr$(34) & ". " & Chr$(13) & Chr$(13) & "Check Spelling In " & Chr$(34) &
"zstblRepor t" & Chr$(34), 48, "Uh-Oh!"
Case ReportCancelled
' (do nothing, user chose to cancel...)
Case Else
bugAlert "letter ID=" & Str(theLetterID )
End Select
Resume letterBeginGene ricNamedAccount _xit
Exit Function
End Function

Function letterBeginGran t(theLetterID As Integer, theNamedAccount ID,
thePersonID, theGrantRequest ID, theGranteeID) As Integer
8000 debugStackPush mModuleName & ": letterBeginGran t"
8001 On Error GoTo letterBeginGran t_err

' PURPOSE: To set the stage for creating one of several flavors of
grant-related letters
' ACCEPTS: - Letter ID, which identifies a record in zstblLetter which
contains DOS name of letter
' - Donor ID of person concerned
' - Grant Request ID
' - GranteeID

' RETURNS: TRUE or FALSE depending on success
' CREATES: Contact history records for both donor and grantee
'
' NOTES: 1) We do as much as possible at this level, before calling the
setter-specific routine.
' 2) We do not get the grantee contact person at this level because
one of the letters
' does not use it and the process involves a prompt to the user.

8010 Dim thisWS As Workspace
Dim thisDB As Database
Dim letterRS As Recordset
Dim granteeRS As Recordset
Dim contactRS As Recordset
Dim myQuery As QueryDef

Dim myLCI As mLetterCustInfo
Dim myGRI As GrantRequestInf o

Dim x As Integer
Dim myDosName As String
Dim transOpen As Integer
Dim historyOK As Integer
Dim okToProceed As Integer

Const objectNotExist = 2103
Const ReportCancelled = 2501
Const destinationGran tee = 2

8011 statusSet "Opening model letter..."
8012 Set thisDB = DBEngine(0)(0)
8013 Set letterRS = thisDB.OpenReco rdset("zstblLet ter", DB_OPEN_TABLE)
8014 letterRS.Index = "PrimaryKey "
8015 letterRS.Seek "=", theLetterID
8016 If letterRS.NoMatc h Then
8017 bugAlert "No record found for letterID " & Str(theLetterID )
8018 Else
8022 myDosName = wordBegin(lette rRS!ModelName)

8130 If Len(myDosName) 0 Then
8131 Set thisWS = DBEngine(0)
8132 thisWS.BeginTra ns 'Transaction prevents
adding contact hist if customizing process fails
8133 transOpen = True
8134 If getGrantRequest Info(Val(theGra ntRequestID),
CLng(theNamedAc countID), myGRI) Then
8135 With myLCI
8141 .GranteeID = theGranteeID
8142 .NameLegal = myGRI.LEGL_NM
8143 .GranteeAddress = granteeAddressG et(theGranteeID )

8153 .PurposeProg = myGRI.PROG_PURP _TX
8154 .GrantReceivedD ate = myGRI.RCVD_DT
8155 .PrimaryContact Address = myGRI.PrimaryCo ntactAddress
8156 .PrimaryContact Greeting = myGRI.PrimaryCo ntactGreeting
8162 .PrimaryContact SalutationNameT itle =
myGRI.PrimaryCo ntactSalutation NameTitle
8164 .GrantRequestID = theGrantRequest ID
8166 .ProgramAccount Name = myGRI.PROG_ACCT _NM
8168 .VastAccountNum ber = myGRI.VAST_ACCT _NO
8170 .PersonToBeAckn owledged = myGRI.ACK_PERS_ NM

8250 .TotalAmountGra nt =
Format$(grantRe questAmountTota lGet(theGrantRe questID), "Currency")
8251 End With
8541 If namedAccountCon tactHistoryRecA dd(CLng(theName dAccountID),
"Re/Grant# " & Str(theGrantReq uestID) & " to " & myGRI.LEGL_NM & " from " &
myGRI.PROG_ACCT _NM & " , generated '" & letterRS!descri ption & "' letter.",
CLng(theLetterI D), myDosName, 0, CLng(theGrantRe questID)) Then
8542 If letterRS!Destin ation = destinationGran tee Then
8543 historyOK = granteeContactH istoryRecAdd(CL ng(theGranteeID ),
"Re/Grant# " & Str(theGrantReq uestID) & " from " &
myGRI.PrimaryCo ntactSalutation NameTitle & "/" & myGRI.PROG_ACCT _NM & ",
generated '" & letterRS!descri ption & "' letter.", CLng(theLetterI D),
myDosName, CLng(theGrantRe questID))
8544 Else
8545 historyOK = True
8546 End If

8550 If historyOK = True Then
8551 statusSet "Customizin g model letter..."
8560 insertCC theNamedAccount ID
8580 tweakLetter1

8600 Select Case theLetterID
' Case gLetterIdGrantD enied
' 8611 okToProceed = grantDeniedCust (myLCI)

Case gLetterIdGrantN otificationGran teeAnon
8621 okToProceed = grantCustAnon(m yLCI)

8630 Case gLetterIdGrantN otificationGran teeAttrib
8631 okToProceed = grantCustAttrib (myLCI)

8640 Case gLetterIdGrantN otificationToDo nor
8641 okToProceed = grantCustToDono r(myLCI)

'8680 Case gLetterIdxxx
'8681 okToProceed = xxxCust(myLCI)

8690 Case Else
8691 bugAlert "Unexpected letter ID=" & Str(theLetterID )
8699 End Select

8700 If okToProceed = True Then
8800 tweakLetter2 (myDosName)
8801 thisWS.CommitTr ans
8820 transOpen = False ' "FunctionNa me"
points to a procedure in this module

On Error Resume Next
If Err = 0 Then
namedAccountCon tactHistoryLoad theNamedAccount ID ' To
show entry for newly-created letter in donor contact history list
If letterRS!Destin ation = destinationGran tee Then
granteeScreenLo ad theGranteeID ' To show entry
for newly-created letter in grantee contact history list
End If
End If
On Error GoTo letterBeginGran t_err
8829 gWord.Activate 'DMN -
used to be: showLetter
8830 letterBeginGran t = True
8850 Else
8851 thisWS.Rollback 'Customizing
process probably found invalid data for given letter...
8852 transOpen = False
8855 End If
8856 statusSet ""
8860 End If
8870 End If
8880 End If
8890 End If
8999 End If

letterBeginGran t_xit:
debugStackPop
On Error Resume Next
Set myQuery = Nothing
letterRS.Close
Set letterRS = Nothing

contactRS.Close
Set contactRS = Nothing

granteeRS.Close
Set granteeRS = Nothing

Set thisDB = Nothing
Set thisWS = Nothing
Exit Function

letterBeginGran t_err:
If transOpen = True Then
thisWS.Rollback
End If
Select Case Err
Case objectNotExist
MsgBox "Cannot find anything named " & Chr$(34) & letterRS!Functi onName &
Chr$(34) & ". " & Chr$(13) & Chr$(13) & "Check Spelling In " & Chr$(34) &
"zstblRepor t" & Chr$(34), 48, "Uh-Oh!"
Case ReportCancelled
' (do nothing, user chose to cancel...)
Case Else
bugAlert ""
End Select
Resume letterBeginGran t_xit


End Function

Function letterBeginGran tee(theLetterID , theGranteeConta ctPersonID,
theGranteeID) As Integer
22000 debugStackPush mModuleName & ": letterBeginGran tee"
22001 On Error GoTo letterBeginGran tee_err

' PURPOSE: - To open up via MS Word a blank letter addressed to the grantee
in question
' - To append a contact history record with a brief description of
the letter's
' subject to the named account in question
' ACCEPTS: ID of record in zstblLetter which contains DOS name of letter
' ID of person to whom letter is to be addressed
' ID of grantee to whose contact history a record of this letter
will be appended

' RETURNS: TRUE or FALSE depending on success

22010 Dim thisWS As Workspace
Dim thisDB As Database
Dim letterRS As Recordset
Dim fHome As Form

Dim myLCI As mLetterCustInfo

Dim x As Integer
Dim myDosName As String
Dim transOpen As Integer
Dim okToProceed As Integer

Const objectNotExist = 2103
Const ReportCancelled = 2501

22012 Set thisDB = DBEngine(0)(0)
22013 Set letterRS = thisDB.OpenReco rdset("zstblLet ter", DB_OPEN_TABLE)
22014 letterRS.Index = "PrimaryKey "
22015 letterRS.Seek "=", theLetterID

22020 If letterRS.NoMatc h Then
22021 bugAlert "No record found for letterID " & Str(theLetterID )
22022 Else
22023 Set fHome = Forms!frmHome
22024 fHome!txtGenera lText = Null
22030 DoCmd.OpenForm "frmGetThumbNai lDescription", , , , , A_DIALOG
22039 If fHome!txtGenera lText & "" = "" Then
22040 DoCmd.Hourglass False
22050 MsgBox "Letter Cancelled", 0, "Cancelled"
22060 Else
22070 DoCmd.Hourglass True

22080 statusSet "Opening model letter..."
22090 myDosName = wordBegin(lette rRS!ModelName)
22130 If Len(myDosName) 0 Then
22131 Set thisWS = DBEngine(0)
22132 thisWS.BeginTra ns 'Transaction prevents adding
contact hist if customizing process fails
22133 transOpen = True
22140 With myLCI
22500 .NameLegal = granteeNameGet( theGranteeID)
22502 .GranteeAddress = granteeAddressG et(theGranteeID )

22510 If theGranteeConta ctPersonID 0 Then
22511 .Greeting =
granteeContactP ersonGreetingGe t(theGranteeCon tactPersonID)
22512 .Recipients = "ATTN: " &
granteeContactP ersonNameFirstL astGet(theGrant eeContactPerson ID, True)
22513 End If

22534 .GranteeID = theGranteeID
22535 End With
22537 If granteeContactH istoryRecAdd(CL ng(theGranteeID ), "Letter Re/: "
& fHome!txtGenera lText & ".", CLng(theLetterI D), myDosName, 0) Then
22538 statusSet "Customizin g model letter..."
22540 tweakLetter1

22600 Select Case theLetterID
Case gLetterIdGeneri cGrantee
22621 okToProceed = genericGranteeC ust(myLCI)
22630 Case gLetterIdRequir ementGrantee
22631 okToProceed = genericGranteeC ust(myLCI)
22640 Case Else
22641 bugAlert "Unexpected letter ID=" & Str(theLetterID )
22699 End Select

22700 If okToProceed = True Then
22720 tweakLetter2 (myDosName)
22725 thisWS.CommitTr ans
22730 transOpen = False
22735 granteeScreenLo ad theGranteeID
22740 letterBeginGran tee = True
22745 Else
22750 thisWS.Rollback 'Customizing process probably
found invalid data for given letter...
22755 transOpen = False
22760 End If
22761 statusSet ""
22765 End If
22970 End If
22980 End If
22999 End If

letterBeginGran tee_xit:
debugStackPop
On Error Resume Next
Set fHome = Nothing
letterRS.Close
Set letterRS = Nothing
Set thisDB = Nothing
Set thisWS = Nothing
Exit Function

letterBeginGran tee_err:
If transOpen = True Then
thisWS.Rollback
End If
Select Case Err
Case objectNotExist
MsgBox "Cannot find anything named " & Chr$(34) & letterRS!Functi onName &
Chr$(34) & ". " & Chr$(13) & Chr$(13) & "Check Spelling In " & Chr$(34) &
"zstblRepor t" & Chr$(34), 48, "Uh-Oh!"
Case ReportCancelled
' (do nothing, user chose to cancel...)
Case Else
bugAlert "letter ID=" & Str(theLetterID )
End Select
Resume letterBeginGran tee_xit
Exit Function

End Function

Sub letterBeginSubs t(thePersonIdGr oup, theContribID As Long, theDonorType As
Integer)
19000 debugStackPush mModuleName & ": letterBeginSubs t"
19001 On Error GoTo letterBeginSubs t_err

' PURPOSE: To open up a substantiation letter via MS Word - which is
addressed to the
' group of people clicked upon in frmletterBeginS ubstList.
'
' ACCEPTS: RecordID of the record clicked upon
' RETURNS: (nothing)

' NOTES: - Although this function is used only by frmletterBeginS ubst, the
code has to reside
' here so we can call it from the subform DoubleClick event.
'
' - You might think that the lookups to lineItemRS are redunant
because
' line item info already exists in the pick list. However the
line item info
' in each picklist record shows all the line items for the
personId group and
' the query that presents it just does a "Group By" to show a
single record
' representing all line items in the group.

19010 Dim thisWS As Workspace
Dim thisDB As Database
Dim letterRS As Recordset
Dim lineItemRS As Recordset
Dim pickListRS As Recordset
Dim donorTypeRS As Recordset
Dim namedAccountRS As Recordset
Dim myQuery As QueryDef

Dim myLCI As mLetterCustInfo

Dim myType As String
Dim myIssuer As String
Dim myShares As String
Dim myAmount As String
Dim myLineItemInfo As String

Dim myDosName As String
Dim myNamedAccountI D As Long

Dim transOpen As Integer
Dim myTypeOfDonor As Integer
Dim okToProceed As Integer
Dim gotCash As Integer
Dim gotSecurity As Integer
Dim myLetterID As Long
Dim myCashFlag As Integer

Dim CRLF As String
CRLF = Chr$(13) & Chr$(10)

Const myLineSeparator = "--------------------------"


19020 statusSet "Opening model letter..."
19021 Set thisWS = DBEngine(0)
19022 Set thisDB = DBEngine(0)(0)
19035 Set myQuery = thisDB.QueryDef s("qryLetterSub stDonorTypesLis t")
19040 myQuery.Paramet ers("thePersonI dGroup") = thePersonIdGrou p
19050 Set donorTypeRS = myQuery.OpenRec ordset(DB_OPEN_ DYNASET)

19060 If donorTypeRS.Rec ordCount 1 Then
19070 MsgBox "There are both multiple donor types in this group.", 48,
"Cannot Create Letter"
19080 Else
19090 myTypeOfDonor = donorTypeRS!Typ eOfDonor ' SB "5" or
32,749
19100 Set myQuery = thisDB.QueryDef s("qryLetterSub stRecsInPersonI dGroup")
19110 myQuery.Paramet ers("thePersonI dGroup") = thePersonIdGrou p
19120 Set pickListRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT,
DB_FORWARDONLY)

19130 Set myQuery = thisDB.QueryDef s("qryContribLi neItemRecFetch" )

19240 If pickListRS.BOF And pickListRS.EOF Then
19250 bugAlert "No records found for PersonIdGroup " & thePersonIdGrou p
19260 Else
19265 With myLCI
19270 .Address =
contribLineItem AddressGet(CLng (pickListRS!CNT RBN_LN_ITEM_ID) )
19271 .Greeting = pickListRS!Gree ting
19272 .ContribID = theContribID
12273 .Donor = pickListRS!Dono rNames & ""
19274 .Recipients = pickListRS!MsWo rdNames ' DISABLED PER
EXECPTIONS 2780/2865 .... & Chr$(13) &
personNameFirst LastGet(namedAc countContactGet ViaContribID(th eContribID)) 'This
field contains the same value in all records
19275 .PersonIdGroup = thePersonIdGrou p
19280 Do Until pickListRS.EOF
19290 myQuery.Paramet ers("theContrib LineItemID") =
pickListRS!CNTR BN_LN_ITEM_ID
19300 Set lineItemRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT,
DB_FORWARDONLY)
19310 If lineItemRS.BOF And lineItemRS.EOF Then
19320 bugAlert "Nothing found for contrib line item ID " &
Str(pickListRS! CNTRBN_LN_ITEM_ ID)
19330 Else
19331 myCashFlag = DLookup("[CNTRBN_TYP_CASH _FL]",
"tlkpContribTyp e", "[CNTRBN_TYP_ID]=" & lineItemRS!CNTR BN_TYP_ID)
19332 If myCashFlag = True Then
19333 gotCash = True
19334 Else
19335 gotSecurity = True
19336 End If
19337 .TotalAmountPro ceeds = myLCI.TotalAmou ntProceeds +
lineItemRS!WFS_ PROCD_AM
19338 .TotalAmountDon orEstimated =
myLCI.TotalAmou ntDonorEstimate d + lineItemRS!DON_ EST_AM
19340 myIssuer = justLeft(lineIt emRS!ISSR_NM, 15)
19350 myType = justLeft(DLooku p("[CNTRBN_TYP_CASH _FL]",
"tlkpContribTyp e", "[CNTRBN_TYP_ID]=" & lineItemRS!CNTR BN_TYP_ID), 20)
19360 myShares = justRite(Format $(lineItemRS!NO _SHRS_QY,
"#,###"), 12)
19370 myAmount = justRite(Format $(lineItemRS!DO N_EST_AM,
"#,###"), 12)
19400 myLineItemInfo = myLineItemInfo & " " & myIssuer
19410 End If
19420 pickListRS.Move Next
19430 Loop
19435 End With
19460 End If

19500 If DLookup("IsNonP rofit", "tlkpDonorType" , "[DON_TYP_ID]=" &
theDonorType) = True Then
19501 myLetterID = gLetterIdSubNon Pr
19502 Else
19510 If (gotCash = True) And (gotSecurity = False) Then
19511 myLetterID = gLetterIdSubCas h
19512 Else
19520 If (gotCash = False) And (gotSecurity = True) Then
19521 myLetterID = gLetterIdSubSec
19530 Else
19540 If (gotCash = True) And (gotSecurity = True) Then
19541 myLetterID = gLetterIDSubMix ed
19550 Else
19560 bugAlert "Looks like no cash and no securities. This
should not happen."
19570 End If
19580 End If
End If
19590 End If

19600 statusSet "Opening model letter..."
19601 Set thisDB = DBEngine(0)(0)
19602 Set letterRS = thisDB.OpenReco rdset("zstblLet ter", DB_OPEN_TABLE)
19603 letterRS.Index = "PrimaryKey "
19604 letterRS.Seek "=", myLetterID
19605 If letterRS.NoMatc h Then
19606 bugAlert "No record found for letterID " & Str(myLetterID)
19607 Else
19608 myDosName = wordBegin(lette rRS!ModelName)
19640 If Len(myDosName) 0 Then
19641 Set myQuery =
thisDB.QueryDef s("qryLetterNam edAccountInfoFe tch")
19645 myNamedAccountI D =
namedAccountIdG etFromContribID (theContribID)
19651 myQuery.Paramet ers("theNamedAc countID") = myNamedAccountI D
19652 Set namedAccountRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT)
19653 If namedAccountRS. BOF And namedAccountRS. EOF Then
19654 bugAlert "Named Account# " & Str(myNamedAcco untID) & " not
found."
19655 Else
13662 myLCI.ProgramAc countName = namedAccountRS! PROG_ACCT_NM
19664 Set thisWS = DBEngine(0)
19665 thisWS.BeginTra ns 'Transaction prevents adding
contact hist if customizing process fails
19666 transOpen = True
19667 If namedAccountCon tactHistoryRecA dd(myNamedAccou ntID,
"Re/Contribution# " & Str(theContribI D) & ", generated '" &
letterRS!descri ption & "' letter to " & myLCI.Recipient s & "RE/" &
myLineItemInfo, myLetterID, myDosName, theContribID, 0) Then
19668 statusSet "Customizin g model letter..."
'19669 insertCC myNamedAccountI D DISABLED PER FUNC
REL EXCEPTION #2752
19670 tweakLetter1

19700 Select Case myLetterID
Case gLetterIdSubCas h
19711 okToProceed = subCustCash(myL CI)

19720 Case gLetterIdSubSec
19721 okToProceed = subCustSec(myLC I)

19740 Case gLetterIDSubMix ed
19741 okToProceed = subCustMixed(my LCI)

19750 Case gLetterIDSubMix ed
19751 okToProceed = subCustMixed(my LCI)

19760 Case gLetterIdSubNon Pr
19761 If namedAccountAdv isersGet(myName dAccountID,
myLCI.Advisers, myLCI.AdviserCo unt) = True Then
19762 okToProceed = subCustNonPr(my LCI)
19763 End If

19790 Case Else
19691 bugAlert "Unexpected letter ID=" & Str(myLetterID)
19679 End Select

19800 If okToProceed = True Then
19810 tweakLetter2 (myDosName)
19820 Set myQuery =
thisDB.QueryDef s("qryLetterSub stDateUpdate")
19830 myQuery.Paramet ers("thePersonI dGroup") =
thePersonIdGrou p
19840 myQuery.Paramet ers("theDosName ") = myDosName
19850 myQuery.Execute DB_FAILONERROR
19860 thisWS.CommitTr ans
19870 transOpen = False
19880 Forms!frmContri b!embLineItems. Form.Requery
19992 End If
19993 End If
19994 End If
19995 End If
19996 End If
19997 End If

19999 DoCmd.Hourglass False

letterBeginSubs t_xit:
debugStackPop
On Error Resume Next
Set myQuery = Nothing
letterRS.Close
Set letterRS = Nothing
namedAccountRS. Close
Set namedAccountRS = Nothing
pickListRS.Clos e
Set pickListRS = Nothing
donorTypeRS.Clo se
Set donorTypeRS = Nothing
lineItemRS.Clos e
Set lineItemRS = Nothing
Set thisDB = Nothing
Set thisWS = Nothing
Exit Sub

letterBeginSubs t_err:
bugAlert ""
Resume letterBeginSubs t_xit
End Sub

Sub letterExistingO pen(theLetterNa me)
7000 debugStackPush "basLetter: letterExistingO pen: "
7001 On Error GoTo letterExistingO pen_err

' PURPOSE: To open up specified document using MS Word
' ACCEPTS: DOS 8.3 name of model document to be used for letter
' RETURNS: (nothing)

7010 Dim myLetterPath As String
Dim userClosedWord As Integer

Const oleError = 2753

7070 statusSet "Opening letter in Microsoft Word..."

7080 myLetterPath = pathDatDbGet("t blPerson") & "\Letters"

'Modifications made to accommodate new version of WORD
' new line 7091
' new line 7400, and 7401
' changed line # 7092 to # 7200, added a new line 7192

letterExistingO pen_loop:
7090 If (gWord Is Nothing) Or (userClosedWord = 1) Then
'7091 Set gWord = CreateObject("W ord.Basic")
7091 Set gWord = CreateObject("W ord.Application .8") 'DMN
7092 gWord.Visible = True 'DMN
7200 End If

'7400 gWord.ChDefault Dir myLetterPath, 0
7400 gWord.ChangeFil eOpenDirectory (myLetterPath) 'DMN
'7401 gWord.FileOpen theLetterName, 0, 0 ' Open as Editable
7401 gWord.Documents .Open (theLetterName) 'DMN
'7401 gWord.Documents .Open FileName:=theLe tterName, ReadOnly:=False 'DMN


7510 gWord.Activate 'DMN - used to be:
showLetter

7999 statusSet ""

letterExistingO pen_xit:
debugStackPop
On Error Resume Next
Exit Sub

letterExistingO pen_err:
Select Case Err
Case 2763
MsgBox "Microsoft Word is unable to find " & myLetterPath & "\" &
theLetterName & ". Please notify your administrator", 16, "Cannot Print Form
Letter"
Resume letterExistingO pen_xit
Case 2772
MsgBox "Unable to locate Microsoft Word program. Please notify your
administrator", 16, "Cannot Print Form Letter"
Resume letterExistingO pen_xit
Case oleError, mRpcServerUnava ilable
If userClosedWord = 0 Then
userClosedWord = userClosedWord + 1
Set gWord = Nothing
Resume letterExistingO pen_loop
Else
bugAlert "Unable to open MS Word. Suspect user may have closed
existing instance."
Resume letterExistingO pen_xit
End If
Case Else
bugAlert ""
End Select
Resume letterExistingO pen_xit 'Shouldn't be needed, but just in
case.....

End Sub

Private Function numberOfLineIte ms(theContribID As Long) As Integer
debugStackPush mModuleName & ": numberOfLineIte ms"
On Error GoTo numberOfLineIte ms_err

' Accepts: ID of contribution in question
' Returns: Number of line items in that contribution

Dim thisDB As Database
Dim myRS As Recordset
Dim myQuery As QueryDef

Set thisDB = DBEngine(0)(0)
Set myQuery = thisDB.QueryDef s("qryContribLi neItemCount")

myQuery.Paramet ers("theContrib ID") = theContribID

Set myRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT)

If myRS.EOF Then
numberOfLineIte ms = 0
Else
numberOfLineIte ms = myRS!LineItemCo unt
End If

numberOfLineIte ms_xit:
debugStackPop
On Error Resume Next
Set myQuery = Nothing
myRS.Close
Set myRS = Nothing
Set thisDB = Nothing
Exit Function

numberOfLineIte ms_err:
bugAlert ""
Resume numberOfLineIte ms_xit
End Function

Private Function poolRecsContrib Invalid(theCont ribID As Long) As Integer
debugStackPush mModuleName & ": poolRecsContrib Invalid"
On Error GoTo poolRecsContrib Invalid_err

' PURPOSE: To determine whether-or-not VAST records for this contrib
(tblContribPool )
' are complete
' ACCEPTS: Contribution ID
' RETURNS: True or False depending...

' ====== DISABLED =============== ===="
' This type of validation could open up a can of worms because
' 1) There is no relation between pool recs and line item recs
' 2) This validation would now be related to specific line items instead of all
line items
'
' We'll wait and see what the testers say. With Maureen gone, this may not
' be an issue....


GoTo poolRecsContrib Invalid_xit

Dim thisDB As Database
Dim myRS As Recordset
Dim myQuery As QueryDef

Set thisDB = DBEngine(0)(0)
Set myQuery = thisDB.QueryDef s("qryPoolRecsC ontribInvalid")

myQuery.Paramet ers("theContrib ID") = theContribID

Set myRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT)

If Not myRS.EOF Then
poolRecsContrib Invalid = True
End If

poolRecsContrib Invalid_xit:
debugStackPop
On Error Resume Next
Set myQuery = Nothing
myRS.Close
Set myRS = Nothing
Set thisDB = Nothing
Exit Function

poolRecsContrib Invalid_err:
bugAlert ""
Resume poolRecsContrib Invalid_xit
End Function

Private Sub poolRowBuild(th eTransactionDat e As Double, theIssuerName, theShares
As Double, theNAV As Double, theAccountNumbe rVast)
debugStackPush mModuleName & ": poolRowBuild"
On Error GoTo poolRowBuild_er r

' Accepts: Information need to build one record in the Word document's "Pools"
table
' Sets: (guess what...)

Dim myAmount As Double

With gWord.Selection
.InsertAfter Text:=Format$(t heTransactionDa te, "mm/dd/yyyy")
.Move Unit:=wdCell, Count:=1
.InsertAfter Text:=theIssuer Name
.Move Unit:=wdCell, Count:=1
.InsertAfter Text:=Format$(t heShares, "#")
.Move Unit:=wdCell, Count:=1
.InsertAfter Text:=Format$(t heNAV, "Currency")
.Move Unit:=wdCell, Count:=1
myAmount = theShares * theNAV
.InsertAfter Text:=Format$(m yAmount, "Currency")
.Move Unit:=wdCell, Count:=1
.InsertAfter Text:=theAccoun tNumberVast
End With

poolRowBuild_xi t:
debugStackPop
On Error Resume Next
Exit Sub

poolRowBuild_er r:
bugAlert ""
Resume poolRowBuild_xi t
End Sub

Function secondaryAdvise rsFetch(theName dAccountID As Long) As String
14000 debugStackPush mModuleName & ": secondaryAdvise rsFetch"
14001 On Error GoTo secondaryAdvise rsFetch_err

' PURPOSE: To get all advisers for a named account who are *not* the primary
contact person
' ACCEPTS: Named Account ID
' RETURNS: String containing formatted names delimited by CRLF
'
' NOTES: 1) For reasons unknown, the query returns field names qualified
by table name.
' Hence "myRS![tblName.SALUTAT ION]" instead of just
"myRS!SALUTATIO N"
' 2) Since this text is to be inserted into MS word, we just use CR
instead of CRLF

14010 Dim thisDB As Database
Dim myRS As Recordset
Dim myQuery As QueryDef

Dim myAdvisers As String

14020 Set thisDB = DBEngine(0)(0)
14030 Set myQuery = thisDB.QueryDef s("qryLetterSec ondaryAdvisersF etch")
14040 myQuery.Paramet ers("theNamedAc countID") = theNamedAccount ID
14050 Set myRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT, DB_FORWARDONLY)
14060 If Not (myRS.BOF And myRS.EOF) Then
14090 Do Until myRS.EOF
14100 If Len(myAdvisers) 0 Then
14110 myAdvisers = myAdvisers & Chr$(13)
14120 End If
14130 myAdvisers = formatFullName( myRS![tblName.FIRST_N AME],
myRS![tblName.MIDDLE_ INITIAL], myRS![tblName.LAST_NA ME], myRS![tblName.TITLE])
14140 myRS.MoveNext
14150 Loop
14200 End If

14999 secondaryAdvise rsFetch = myAdvisers

secondaryAdvise rsFetch_xit:
debugStackPop
On Error Resume Next
Set myQuery = Nothing
myRS.Close
Set myRS = Nothing
Set thisDB = Nothing
Exit Function

secondaryAdvise rsFetch_err:
bugAlert ""
Resume secondaryAdvise rsFetch_xit
End Function

'Private Sub showLetter()
'debugStackPush mModuleName & ": showLetter"
'On Error GoTo showLetter_err

'gWord.StartOfD ocument
'gWord.hScroll (0)
'gWord.DocMaxim ize (1)
'gWord.AppMaxim ize (1)
'gWord.AppShow

'showLetter_xit :
' debugStackPop
' On Error Resume Next
' Exit Sub

'showLetter_err :
' bugAlert ""
' Resume showLetter_xit
'End Sub
'----------------------------------------------------------------
Function subCustCash(the LCI As mLetterCustInfo ) As Integer
5000 debugStackPush mModuleName & ": subCustCash: "
5001 On Error GoTo subCustCash_err

' PURPOSE: To Customize already-opened model letter SubCash.doc as
' named in zstblLetter.
' ACCEPTS: - DOS 8.3 name of newly-opened letter
' - A structure containing various fields needed to customize letter
' RETURNS: TRUE or FALSE depending on success
'
' NOTES: 1) Assumes global variable "gWord" has already been set
' 2) "namedAccountRS " includes named account info plus the Primary
Contact Person's name/address

5010 Const CannotCreateLet ter = "Cannot Create Letter"

5070 If poolRecsContrib Invalid(theLCI. ContribID) Then
5071 DoCmd.Hourglass False
5072 MsgBox "Informatio n for one or more pool allocations is incomplete.",
16, "CannotCreateLe tter2"
5073 Else
5110 findAndReplace "<theSalutation NameTitle>", theLCI.Recipien ts, gWord
5120 findAndReplace "<theProgramAcc ountName>", theLCI.ProgramA ccountName,
gWord
5130 findAndReplace "<theAddres s>", theLCI.Address, gWord
5140 findAndReplace "<theGreeting>" , theLCI.Greeting , gWord
5150 findAndReplace "<theCharityPho ne800>", charityPhone800 Get(), gWord
5170 findAndReplace "<thePrincipalS um>", Format$(theLCI. TotalAmountProc eeds,
"Currency") , gWord

5990 subCustCash = True
5996 End If

5999 DoCmd.Hourglass False

subCustCash_xit :
debugStackPop
On Error Resume Next
Exit Function

subCustCash_err :
bugAlert ""
Resume subCustCash_xit
End Function

Private Function subCustMixed(th eLCI As mLetterCustInfo ) As Integer
18000 debugStackPush mModuleName & ": subCustMixed: "
18001 On Error GoTo subCustMixed_er r

' PURPOSE: To Customize already-opened model letter SubMix.doc as
' named in zstblLetter.
' ACCEPTS: - DOS 8.3 name of newly-opened letter
' - A structure containing various fields needed to customize
letter
' RETURNS: TRUE or FALSE depending on success
'
' NOTES: 1) Assumes global variable "gWord" has already been set
' 2) "namedAccountRS " includes named account info plus the Primary
Contact Person's name/address

Dim thisDB As Database
Dim cashRS As Recordset
Dim lineItemRS As Recordset
Dim myQuery As QueryDef
Dim x As Integer

Dim myCash As Double

Const CannotCreateLet ter = "Cannot Create Letter"

18050 Set thisDB = DBEngine(0)(0)

18070 If poolRecsContrib Invalid(theLCI. ContribID) Then
18071 DoCmd.Hourglass False
18072 MsgBox "Informatio n for one or more pool allocations is incomplete.",
118, "CannotCreateLe tter2"
18073 Else
18100 Set myQuery =
thisDB.QueryDef s("qryLetterSub stLineItemsForP ersonIdGroupNon Cash")
18110 myQuery.Paramet ers("thePersonI dGroup") = theLCI.PersonId Group
18120 Set lineItemRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT)
18130 If lineItemRS.BOF And lineItemRS.EOF Then
18131 bugAlert "No line items found for PersonIdGroup '" &
theLCI.PersonId Group & "'."
18140 Else
18150 Set myQuery = thisDB.QueryDef s("qryLetterSub stCashForPerson IdGroup")
18151 myQuery.Paramet ers("thePersonI dGroup") = theLCI.PersonId Group
18152 Set cashRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT)
18153 If (cashRS.BOF And cashRS.EOF) Then
18154 bugAlert "Mixed letter, but no cash found. PersonIdGroup=' &
theLCI.PersonId Group & " '."
18155 Else
18200 myCash = cashRS!TotalCas h

18220 findAndReplace "<theSalutation NameTitle>", theLCI.Recipien ts,
gWord 'DMN
18230 findAndReplace "<theAddres s>", theLCI.Address, gWord 'DMN
18240 findAndReplace "<theGreeting>" , theLCI.Greeting , gWord 'DMN
18250 findAndReplace "<theCashPortio n>", Format$(myCash, "Currency") ,
gWord 'DMN
18260 findAndReplace "<theProgramAcc ountName>",
theLCI.ProgramA ccountName, gWord 'DMN
18270 findAndReplace "<theCharityPho ne800>", charityPhone800 Get(),
gWord 'DMN
18290 findText "%NumberSharesC ertificates%", gWord

18356 With gWord.Selection
18257 .MoveRight Unit:=wdCharact er, Count:=3, Extend:=wdExten d
'Select entire row
18258 .Delete Unit:=wdCharact er, Count:=1 'Clear the literals from
table's single row
18420 lineItemRS.Move Last
18430 If lineItemRS.Reco rdCount 1 Then 'Add extra lines to table
as needed
18432 .MoveRight Unit:=wdCharact er, Count:=2, Extend:=wdExten d
18433 .InsertRows lineItemRS.Reco rdCount - 1
18434 .MoveLeft Unit:=wdCharact er, Count:=1
18536 End If 'We should now have required #of rows and have cursor
in top left cell

18440 lineItemRS.Move First 'Populate the MS Word table
18450 Do Until lineItemRS.EOF
18452 .TypeText Text:=Format$(l ineItemRS!NO_SH RS_QY, "#,###.000" )
18454 .MoveRight Unit:=wdCell, Count:=1
18455 .TypeText Text:=lineItemR S!ISSR_NM
18457 lineItemRS.Move Next
18456 If lineItemRS.EOF = False Then
18459 .MoveDown Unit:=wdLine, Count:=1
18469 .MoveLeft Unit:=wdWord, Count:=1
18461 End If
18470 Loop
18471 End With
18990 subCustMixed = True
18994 End If
18995 End If
18996 End If

18999 DoCmd.Hourglass False

subCustMixed_xi t:
debugStackPop
On Error Resume Next
Set myQuery = Nothing
cashRS.Close
Set cashRS = Nothing
lineItemRS.Clos e
Set lineItemRS = Nothing
Set thisDB = Nothing
Exit Function

subCustMixed_er r:
bugAlert ""
Resume subCustMixed_xi t
End Function

Function subCustNonPr(th eLCI As mLetterCustInfo ) As Integer
23000 debugStackPush mModuleName & ": subCustNonPr: "
23001 On Error GoTo subCustNonPr_er r

' PURPOSE: To Customize already-opened model letter SubNonPr.doc as
' named in zstblLetter.
' ACCEPTS: - DOS 8.3 name of newly-opened letter
' - A structure containing various fields needed to customize letter
' RETURNS: TRUE or FALSE depending on success
'
' NOTES: 1) Assumes global variable "gWord" has already been set
' 2) "namedAccountRS " includes named account info plus the Primary
Contact Person's name/address

23010 Const CannotCreateLet ter = "Cannot Create Letter"

23070 If poolRecsContrib Invalid(theLCI. ContribID) Then
23071 DoCmd.Hourglass False
23072 MsgBox "Informatio n for one or more pool allocations is incomplete.",
16, "CannotCreateLe tter2"
23073 Else
23090 findAndReplace "<theSalutation NameTitle>", theLCI.Recipien ts, gWord
'DMN
23100 findAndReplace "<theProgramAcc ountName>", theLCI.ProgramA ccountName,
gWord 'DMN
23110 findAndReplace "<theDonor> ", theLCI.Donor, gWord 'DMN
23120 findAndReplace "<theAddres s>", theLCI.Address, gWord 'DMN
23130 findAndReplace "<theGreeting>" , theLCI.Greeting , gWord 'DMN
23140 findAndReplace "<theAdvisers>" , theLCI.Advisers , gWord 'DMN
23150 findAndReplace "<theCharityPho ne800>", charityPhone800 Get(), gWord 'DMN
23170 findAndReplace "<thePrincipalS um>", Format$(theLCI. TotalAmountProc eeds,
"Currency") , gWord 'DMN

23370 subCustNonPr = True
23399 End If

23999 DoCmd.Hourglass False

subCustNonPr_xi t:
debugStackPop
On Error Resume Next
Exit Function

subCustNonPr_er r:
bugAlert ""
Resume subCustNonPr_xi t
End Function

Private Function subCustSec(theL CI As mLetterCustInfo ) As Integer
6000 debugStackPush mModuleName & ": subCustSec: "
6001 On Error GoTo subCustSec_err

' PURPOSE: To Customize already-opened model letter SubSec.doc as
' named in zstblLetter.
' ACCEPTS: - DOS 8.3 name of newly-opened letter
' - A structure containing various fields needed to customize letter
' RETURNS: TRUE or FALSE depending on success
'
' NOTES: 1) Assumes global variable "gWord" has already been set
' 2) "namedAccountRS " includes named account info plus the Primary
Contact Person's name/address

Dim thisDB As Database
Dim lineItemRS As Recordset
Dim myQuery As QueryDef
Dim x As Integer

Const CannotCreateLet ter = "Cannot Create Letter"

6050 Set thisDB = DBEngine(0)(0)

6070 If poolRecsContrib Invalid(theLCI. ContribID) Then
6071 DoCmd.Hourglass False
6072 MsgBox "Informatio n for one or more pool allocations is incomplete.",
16, "CannotCreateLe tter2"
6073 Else
6100 Set myQuery =
thisDB.QueryDef s("qryLetterSub stLineItemsForP ersonIdGroup")
6110 myQuery.Paramet ers("thePersonI dGroup") = theLCI.PersonId Group
6120 Set lineItemRS = myQuery.OpenRec ordset(DB_OPEN_ SNAPSHOT)
6130 If lineItemRS.BOF And lineItemRS.EOF Then
6131 bugAlert "No line items found for PersonIdGroup '" &
theLCI.PersonId Group & "'."
6140 Else
6160 findAndReplace "<theSalutation NameTitle>", theLCI.Recipien ts, gWord
'DMN
6170 findAndReplace "<theProgramAcc ountName>", theLCI.ProgramA ccountName,
gWord 'DMN
6180 findAndReplace "<theAddres s>", theLCI.Address, gWord 'DMN
6190 findAndReplace "<theGreeting>" , theLCI.Greeting , gWord 'DMN
6200 findAndReplace "<theCharityPho ne800>", charityPhone800 Get(), gWord
'DMN
6220 findAndReplace "<thePrincipalS um>",
Format$(theLCI. TotalAmountProc eeds, "Currency") , gWord 'DMN

6255 findText "%NumberSharesC ertificates%", gWord 'Locate
"Shares/Name of Security" table (only one row in table at this point...)
6356 With gWord.Selection
6257 .MoveRight Unit:=wdCharact er, Count:=3, Extend:=wdExten d 'Select
entire row
6258 .Delete Unit:=wdCharact er, Count:=1 'Clear
the literals from table's single row
6420 lineItemRS.Move Last
6430 If lineItemRS.Reco rdCount 1 Then 'Add
extra lines to table as needed
6432 .MoveRight Unit:=wdCharact er, Count:=2, Extend:=wdExten d
6433 .InsertRows lineItemRS.Reco rdCount - 1
6434 .MoveLeft Unit:=wdCharact er, Count:=1
6536 End If 'We
should now have required #of rows and have cursor in top left cell

6440 lineItemRS.Move First 'Populate the MS Word table
6450 Do Until lineItemRS.EOF
6452 .TypeText Text:=Format$(l ineItemRS!NO_SH RS_QY, "#,###.000" )
6454 .MoveRight Unit:=wdCell, Count:=1
6455 .TypeText Text:=lineItemR S!ISSR_NM
6457 lineItemRS.Move Next
6456 If lineItemRS.EOF = False Then
6459 .MoveDown Unit:=wdLine, Count:=1
6469 .MoveLeft Unit:=wdWord, Count:=1
6461 End If
6470 Loop
6471 End With
6990 subCustSec = True
6995 End If
6996 End If

6999 DoCmd.Hourglass False

subCustSec_xit:
debugStackPop
On Error Resume Next
Set myQuery = Nothing
lineItemRS.Clos e
Set lineItemRS = Nothing
Set thisDB = Nothing
Exit Function

subCustSec_err:
bugAlert ""
Resume subCustSec_xit
End Function
Private Sub tweakLetter1()
debugStackPush mModuleName & ": tweakLetter1"
On Error GoTo tweakLetter1_er r

' PURPOSE: To to whatever is needed to initialize a newly-opened model
' ACCEPTS: (nothing)
' RETURNS: (nothing)
'
' NOTES: 1) For reasons unknown, we *must* make Word visible before
' proceeding further. If not, all the menus and toolbars
' are lost.

With gWord
' .EditFindClearF ormatting
' .EditReplaceCle arFormatting
' .StartOfDocumen t

'.Selection.Fin d.ClearFormatti ng 'DMN
'.Selection.Fin d.Replacement.C learFormatting 'DMN
'.Selection.Hom eKey Unit:=wdStory, Extend:=wdMove 'DMN

.Visible = True
End With

tweakLetter1_xi t:
debugStackPop
On Error Resume Next
Exit Sub

tweakLetter1_er r:
bugAlert ""
Resume tweakLetter1_xi t
End Sub
Private Sub tweakLetter2(th eLetterName As String)
debugStackPush mModuleName & ": tweakLetter2"
On Error GoTo tweakLetter2_er r

' Used by "letterBegin... " routines to make common document settings

With gWord
.ActiveDocument .Save
.Selection.Home Key Unit:=wdStory, Extend:=wdMove
.ActiveWindow.H orizontalPercen tScrolled = 0
.ActiveWindow.W indowState = wdWindowStateMa ximize
.WindowState = wdWindowStateMa ximize
.Visible = True
.Activate
End With

tweakLetter2_xi t:
debugStackPop
On Error Resume Next
Exit Sub

tweakLetter2_er r:
bugAlert ""
Resume tweakLetter2_xi t
End Sub

Private Function wordBegin(theMo delName) As String
3000 debugStackPush mModuleName & ": wordBegin: "
3001 On Error GoTo wordBegin_err

' PURPOSE: - Start an instance of MS WORD or use an existing instance
' - Open up a model document and saves it under a unique DOS 8.3
name
' - Leave a global object "gWord" pointing to the Word Basic engine
' behind the newly-opened document so the calling procedure can
OLE to it
' ACCEPTS: DOS 8.3 name of model document to be used for letter
' RETURNS: DOS 8.0 name of the newly-opend letter if successful, zero-length
string if failed
'
' NOTES: 1) We do not want to keep opening up new instances of Word every
time this routine
' is called, so we do the "= Nothing" check to see if gWord has
already been set.
' OTHO the user may have closed that instance of Word, leaving
gWord pointing to
' Neverneverland. Experimentation shows that an error 2753 is
generated in this case.
' Hence the error trap and the "userClosedWord " switch.
' 2) In the FileSaveAs, it is important to force the document type
to Word. Otherwise, if
' the models are Word 7 and the user is in Word 8, the document
will default to .RTF
' and paragraph marks will not work (.RTF needs CRLF wheras Word
used just CR)

Dim modelPath As String
Dim LetterPath As String
Dim dosName As String
Dim problemPath As String
Dim userClosedWord As Integer

Const oleError = 2753

3009 modelPath = pathDatDbGet("t blPerson") & "\Models"
3010 LetterPath = pathDatDbGet("t blPerson") & "\Letters"

On Error Resume Next
MkDir LetterPath
On Error GoTo wordBegin_err

3020 dosName = Format$(recordN umberNextGet("L etterNumber"), "00000000") & ".DOC"

wordBegin_loop:
3390 If (gWord Is Nothing) Or (userClosedWord = 1) Then
3391 Set gWord = CreateObject("W ord.Application .8")
3392 End If

3395 problemPath = modelPath & "\" & theModelName
3400 gWord.ChangeFil eOpenDirectory (modelPath) 'DMN
3401 gWord.Documents .Open (theModelName)

3405 problemPath = LetterPath & "\" & theModelName
3410 gWord.ChangeFil eOpenDirectory (LetterPath) 'DMN
3411 gWord.ActiveDoc ument.SaveAs (dosName) 'DMN

3999 wordBegin = dosName

wordBegin_xit:
debugStackPop
On Error Resume Next
Exit Function

wordBegin_err:
Select Case Err
Case 2763
MsgBox "Microsoft Word is unable to find " & problemPath & ". Please
notify your administrator", 16, "Cannot Print Form Letter"
Resume wordBegin_xit
Case 2772
MsgBox "Unable to locate Microsoft Word program. Please notify your
administrator", 16, "Cannot Print Form Letter"
Resume wordBegin_xit
Case oleError, mRpcServerUnava ilable
If userClosedWord = 0 Then
userClosedWord = userClosedWord + 1
Resume wordBegin_loop
Else
bugAlert "Unable to open MS Word. Suspect user may have closed
existing instance."
Resume wordBegin_xit
End If
Case Else
bugAlert ""
Resume wordBegin_xit
End Select
Resume wordBegin_xit 'Shouldn't be needed, but just in case.....
End Function
------------------------------------------------------------------------------
--
PeteCresswell