Per DCMA-NPKA:
(NASA) does not like the best version of the report that I can
generate in Access. He insists that we use a MS Word version of the report.
I am a novice with Access and cannot figure out how to use a Word document
for the report. Can anyone point me in the right direction?
As a novice, you've got some learning ahead of you. Nice to hear NASA has
deep pockets and your resume' should benefit accordingly.
First thing: you're going to be writing VB code.... Learn to love it.
Second thing: Once you've gotten to the point where you can instantiate an
instance of MS Word in your app and it's time to start pulling the strings,
start making use of MS Word's Tools|Macro|Record New Macro facility. Just
start a macro, do what you want to do, and then copy/paste/adapt the macro's
code into your MS Access routines.
Depending on the nature of the report, you might save some coding by opening up
a template doc, saving it under another name, and then plugging in data. OTOH,
you'll learn more doing it from scratch.
Here is some sample code. Not pretty and probably wretched excess - but a lot
of the basic functionality is there - like opening a new doc, opening an
existing doc, and so-forth. WordBegin() opens up a model document...
Don't even *think* about this stuff compiling for you - too many calls to debug
routines and such.
---------------------------------------------------------------------------
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 mRpcServerUnavailable = -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
GranteeContactAddress As String
GrantReceivedDate As Double
NameLegal As String
LetterName As String
PersonIdGroup As String
PersonToBeAcknowledged As String
PrimaryContactAddress As String
PrimaryContactGreeting As String
PrimaryContactSalutationNameTitle As String
ProgramAccountName As String
PurposeProg As String
Recipients As String
TotalAmountGrant As String
TotalAmountProceeds As Double
TotalAmountDonorEstimated As Double
VastAccountNumber As String
End Type
' ----------------------------------------
' Structure to support getGrantRequestInfo()
' 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 GrantRequestInfo
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
PrimaryContactGreeting As String
PrimaryContactAddress As String
PrimaryContactSalutationNameTitle As String
EXC_GNT_FEE_AM As Double
GNT_CNRN_AREA_ID 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_TX 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.Application)
debugStackPush mModuleName & ": findAndReplace"
On Error GoTo findAndReplace_err
' PURPOSE: To find and replace a single occurrence, 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.Selection.HomeKey Unit:=wdStory, Extend:=wdMove
With theApp.Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = theFromString
.Replacement.Text = theToString
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
theApp.Selection.Find.Execute
With theApp.Selection
If .Find.Forward = True Then
.Collapse Direction:=wdCollapseStart
Else
.Collapse Direction:=wdCollapseEnd
End If
.Find.Execute Replace:=wdReplaceOne
If .Find.Forward = True Then
.Collapse Direction:=wdCollapseEnd
Else
.Collapse Direction:=wdCollapseStart
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_letterCustContribProblem(theLetterName As String, DonorID_NotUsed,
theContribID As Long, GrantRequestID_NotUsed, GranteeID_NotUsed) As Integer
4000 debugStackPush mModuleName & ": a_letterCustContribProblem: "
4001 On Error GoTo a_letterCustContribProblem_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 contribLineItemRS 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 mySalutationNameTitle As String
Dim myAddress As String
Dim myProgramAccountName As String
Dim myGreeting As String
Const CannotCreateLetter = "Cannot Create Letter"
4050 Set thisDB = DBEngine(0)(0)
4066 Set myQuery = thisDB.QueryDefs("qryContribRecFetch")
4067 myQuery.Parameters("theContribID") = theContribID
4068 Set contribRS = myQuery.OpenRecordset(DB_OPEN_SNAPSHOT)
4070 If contribRS.BOF And contribRS.EOF Then
4071 bugAlert "Contribution# " & Str(theContribID) & " not found."
4072 Else
4075 Set myQuery = thisDB.QueryDefs("qryContribLineItemsFetch")
4076 myQuery.Parameters("theContribID") = theContribID
4077 Set contribLineItemRS = myQuery.OpenRecordset(DB_OPEN_SNAPSHOT)
4079 If contribLineItemRS.BOF And contribLineItemRS.EOF Then
4080 statusSet ""
4100 MsgBox "There are no line items with active pool allocations for this
contribution", 16, CannotCreateLetter
4101 Else
4110 Set myQuery = thisDB.QueryDefs("qryNamedAccountRecFetchByName")
4120 myQuery.Parameters("theNamedAccountID") = contribRS!NMD_ACCT_ID
4130 Set namedAccountRS = myQuery.OpenRecordset(DB_OPEN_SNAPSHOT)
4140 If namedAccountRS.BOF And namedAccountRS.EOF Then
4141 bugAlert "Named Account# " & Str(contribRS!NMD_ACCT_ID) & " not
found."
4142 Else
4150 Set myQuery = thisDB.QueryDefs("qryContribExceptionList")
4152 myQuery.Parameters("theContribID") = theContribID
4153 Set problemRS = myQuery.OpenRecordset(DB_OPEN_SNAPSHOT)
4154 If problemRS.BOF And problemRS.EOF Then
4155 MsgBox "There are no problems outstanding for this
contribution.", 16, CannotCreateLetter
4160 Else
4200 myProgramAccountName = namedAccountRS!PROG_ACCT_NM
4210 Set myQuery = thisDB.QueryDefs("qryDonorRecFetch")
4220 myQuery.Parameters("theDonorID") = namedAccountRS!DON_ID
4230 Set donorRS = myQuery.OpenRecordset(DB_OPEN_SNAPSHOT)
4231 If donorRS.BOF And donorRS.EOF Then
4232 bugAlert "Donor ID# " & Str(namedAccountRS!DON_ID) & " not
found."
4233 Else
4240 mySalutationNameTitle =
formatSalutationNameTitle(donorRS!DON_SALUT_NM, donorRS!DON_FRST_NM,
donorRS!DON_MI_NM, donorRS!DON_LST_NM, donorRS!DON_TITLE_TX)
4245 myAddress = formatAddress(False, True,
donorRS!DON_ADDR_1_TX, donorRS!DON_ADDR_2_TX, donorRS!DON_CITY_TX,
donorRS!DON_STE_TX, donorRS!DON_ZIP_CD)
4250 myGreeting = formatGreeting(donorRS!DON_SALUT_NM,
donorRS!DON_FRST_NM, donorRS!DON_LST_NM)
'4431 gWord.EditReplace "<theSalutationNameTitle>",
mySalutationNameTitle, , , , , , , True, False
'4440 gWord.EditReplace "<theProgramAccountName>",
myProgramAccountName, , , , , , , False, True
'4446 gWord.EditReplace "<theAddress>", myAddress, , , , , , ,
False, True
'4449 gWord.EditReplace "<theGreeting>", myGreeting, , , , , , ,
False, True
'4450 gWord.EditReplace "<theProgramAccountName>",
myProgramAccountName, , , , , , , False, True
'4455 gWord.EditReplace "<theCharityPhone800>",
charityPhone800Get(), , , , , , , False, True
'4460 gWord.StartOfDocument
'4462 gWord.EditFind "%NumberSharesCertificates%", "", 0
4260 With gWord 'DMN
4265 findAndReplace "<theSalutationNameTitle>",
mySalutationNameTitle, gWord 'DMN
4270 findAndReplace "<theProgramAccountName>",
myProgramAccountName, gWord 'DMN
4275 findAndReplace "<theAddress>", myAddress, gWord 'DMN
4280 findAndReplace "<theGreeting>", myGreeting, gWord 'DMN
4285 findAndReplace "<theProgramAccountName>",
myProgramAccountName, gWord 'DMN
4290 findAndReplace "<theCharityPhone800>",
charityPhone800Get(), gWord 'DMN
4295 .Selection.HomeKey Unit:=wdStory, Extend:=wdMove 'DMN
4300 findAndReplace "%NumberSharesCertificates%", "", gWord
4305 End With 'DMN
4464 contribLineItemRS.MoveLast
4466 If contribLineItemRS.RecordCount > 1 Then
4467 For x = 1 To contribLineItemRS.RecordCount - 1 'DMN
'4468 gWord.TableInsertRow contribLineItemRS.RecordCount -
1
4468 gWord.Selection.Tables(1).Rows.Add
BeforeRow:=Selection.Rows(1) 'DMN
4469 Next x 'DMN
4470 End If
4480 contribLineItemRS.MoveFirst
4482 Do Until contribLineItemRS.EOF
4484 If contribLineItemRS!ISSR_NM = "Cash" Then
'4486 gWord.Insert Format$(contribLineItemRS!NO_SHRS_QY,
"Currency")
4486 gWord.Selection.InsertAfter
Text:=Format$(contribLineItemRS!NO_SHRS_QY, "Currency")
4488 Else
'4490 gWord.Insert Str(contribLineItemRS!NO_SHRS_QY)
4490 gWord.Selection.InsertAfter
Text:=Str(contribLineItemRS!NO_SHRS_QY)
4492 End If
'4494 gWord.NextCell
4494 gWord.Selection.Move Unit:=wdCell, Count:=1
'4496 gWord.Insert contribLineItemRS!ISSR_NM
4496 gWord.Selection.InsertAfter
Text:=contribLineItemRS!ISSR_NM
4498 contribLineItemRS.MoveNext
4500 If Not contribLineItemRS.EOF Then
'4502 gWord.NextCell
4502 gWord.Selection.Move Unit:=wdCell, Count:=1
4504 End If
4506 Loop
'4508 gWord.StartOfDocument 'Selection.HomeKey Unit:=wdStory,
Extend:=wdMove
4508 gWord.Selection.HomeKey Unit:=wdStory, Extend:=wdMove
'4510 gWord.EditFind "%theExceptions%", "", 0
4510 findText "%theExceptions%", gWord
4520 problemRS.MoveLast
4530 If problemRS.RecordCount > 1 Then
'4540 gWord.TableInsertRow problemRS.RecordCount - 1
4540 For x = 1 To problemRS.RecordCount - 1
4541 gWord.Selection.Tables(1).Rows.Add
BeforeRow:=Selection.Rows(1)
4542 Next x
4550 End If
4600 problemRS.MoveFirst
4610 Do Until problemRS.EOF
'4620 gWord.Insert problemRS!myDescription
4620 gWord.Selection.InsertAfter Text:=problemRS!myDescription
4630 problemRS.MoveNext
4640 If Not problemRS.EOF Then
'4650 gWord.NextCell
4650 gWord.Selection.Move Unit:=wdCell, Count:=1
4660 End If
4670 Loop
'4690 gWord.StartOfDocument
'4691 gWord.EditReplace "<theAmountSum>", Format$(mySum,
"Currency"), , , , , , , False, True
4680 With gWord 'DMN
4690 .Selection.HomeKey Unit:=wdStory, Extend:=wdMove 'DMN
4700 findAndReplace "<theAmountSum>", Format$(mySum,
"Currency"), gWord 'DMN
4710 End With 'DMN
4990 a_letterCustContribProblem = True
4991 End If
4992 End If
4993 End If
4994 End If
4999 End If
a_letterCustContribProblem_xit:
debugStackPop
On Error Resume Next
Set myQuery = Nothing
donorRS.Close
Set donorRS = Nothing
contribRS.Close
Set contribRS = Nothing
contribLineItemRS.Close
Set contribLineItemRS = Nothing
namedAccountRS.Close
Set namedAccountRS = Nothing
problemRS.Close
Set problemRS = Nothing
Set thisDB = Nothing
Exit Function
a_letterCustContribProblem_err:
bugAlert ""
Resume a_letterCustContribProblem_xit
End Function
Private Function conCustCash(theLCI 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 CannotCreateLetter = "Cannot Create Letter"
2070 If poolRecsContribInvalid(theLCI.ContribID) Then
2071 DoCmd.Hourglass False
2072 MsgBox "Information for one or more pool allocations is incomplete.",
16, "CannotCreateLetter2"
2073 Else
2090 Set thisDB = DBEngine(0)(0)
2100 Set myQuery = thisDB.QueryDefs("qryLetterPoolRecsSumByPool")
2110 myQuery.Parameters("theContribID") = theLCI.ContribID
2120 Set poolRS = myQuery.OpenRecordset(DB_OPEN_SNAPSHOT)
2130 If poolRS.BOF And poolRS.EOF Then
2140 MsgBox "There are no pool allocations for this contribution", 16,
CannotCreateLetter
2150 Else
2210 findAndReplace "<theSalutationNameTitle>", theLCI.Recipients, gWord
2220 findAndReplace "<theAddress>", theLCI.PrimaryContactAddress, gWord
2230 findAndReplace "<theGreeting>", theLCI.PrimaryContactGreeting,
gWord
2240 findAndReplace "<theProgramAccountName>",
theLCI.ProgramAccountName, gWord 'NB: Two occurrances of this field
2241 findAndReplace "<theProgramAccountName>",
theLCI.ProgramAccountName, gWord
2250 findAndReplace "<theCharityPhone800>", charityPhone800Get(), gWord
2270 findText "%thePoolName%", gWord
2356 With gWord.Selection
2257 .MoveRight Unit:=wdWord, Count:=4, Extend:=wdExtend 'Select
entire row
2258 .Delete Unit:=wdCharacter, Count:=1 'Clear the literals from
table's single row
2420 poolRS.MoveLast
2430 If poolRS.RecordCount > 1 Then 'Add extra lines to table as
needed
2432 .MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
2433 .InsertRows poolRS.RecordCount - 1
2434 .MoveLeft Unit:=wdCharacter, Count:=1
2436 End If 'We
should now have required #of rows and have cursor in top left cell
2440 poolRS.MoveFirst 'Populate the MS Word table
2450 Do Until poolRS.EOF
2451 myPrincipalSum = myPrincipalSum + poolRS!SumOfPRNC_AM
2552 .TypeText Text:=poolRS!POOL_NM
2554 .MoveRight Unit:=wdCell, Count:=1
2555 .TypeText Text:=Format$(poolRS!myPercent, "Percent")
2560 .MoveRight Unit:=wdCell, Count:=1
2561 .TypeText Text:=Format$(poolRS!SumOfPRNC_AM, "Currency")
2562 .MoveRight Unit:=wdCell, Count:=1
2563 .TypeText Text:=Str(poolRS!PORT_ID) & "-" &
poolRS!VAST_ACCT_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 "<thePrincipalSum>", Format$(myPrincipalSum,
"Currency"), gWord 'NB: Two occurrances of this field
2701 findAndReplace "<thePrincipalSum>", Format$(myPrincipalSum,
"Currency"), gWord
'2710 If myPrincipalSum <> theLCI.TotalAmountDonorEstimated Then
'2711 bugAlert "Computed total <> passed total. Computed = " &
Format$(myPrincipalSum, "Currency") & ", Passed = " &
Format$(theLCI.TotalAmountDonorEstimated, "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(theLCI As mLetterCustInfo) As Integer
20000 debugStackPush mModuleName & ": conCustMixed"
20001 On Error GoTo conCustMixed_err
' 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 CannotCreateLetter = "Cannot Create Letter"
20070 If poolRecsContribInvalid(theLCI.ContribID) Then
20071 DoCmd.Hourglass False
20072 MsgBox "Information for one or more pool allocations is incomplete.",
16, "CannotCreateLetter2"
20073 Else
20080 Set thisDB = DBEngine(0)(0)
20100 Set myQuery = thisDB.QueryDefs("qryLetterConLineItemsNonCashFetch")
20110 myQuery.Parameters("theContribID") = theLCI.ContribID
20120 Set securityRS = myQuery.OpenRecordset(DB_OPEN_SNAPSHOT)
20130 If securityRS.BOF And securityRS.EOF Then
20131 bugAlert "No security items found for contrib ID '" &
Str(theLCI.ContribID) & "'. Since this is a 'mixed' letter, this should not
happen."
20139 Else
20140 Set myQuery = thisDB.QueryDefs("qryLetterConCashTotalFetch")
20141 myQuery.Parameters("theContribID") = theLCI.ContribID
20142 Set cashTotalRS = myQuery.OpenRecordset(DB_OPEN_SNAPSHOT)
20143 If cashTotalRS.BOF And cashTotalRS.EOF Then
20144 bugAlert "No cash items found for contrib ID '" &
Str(theLCI.ContribID) & "'. Since this is a 'mixed' letter, this should not
happen."
20149 Else
20160 Set myQuery = thisDB.QueryDefs("qryLetterPoolRecsSumByPool")
20170 myQuery.Parameters("theContribID") = theLCI.ContribID
20180 Set poolRS = myQuery.OpenRecordset(DB_OPEN_SNAPSHOT)
20190 If poolRS.BOF And poolRS.EOF Then
20200 MsgBox "There are no pool allocations for this contribution",
16, CannotCreateLetter
20210 Else
20230 findAndReplace "<theSalutationNameTitle>", theLCI.Recipients,
gWord 'DMN
20240 findAndReplace "<theAddress>", theLCI.PrimaryContactAddress,
gWord 'DMN
20250 findAndReplace "<theGreeting>", theLCI.PrimaryContactGreeting,
gWord 'DMN
20260 findAndReplace "<theProgramAccountName>",
theLCI.ProgramAccountName, gWord 'DMN
20270 findAndReplace "<theCharityPhone800>", charityPhone800Get(),
gWord 'DMN
20300 findText "%NumberSharesCertificates%", gWord
20310 With gWord.Selection
20320 .MoveRight Unit:=wdCharacter, Count:=3, Extend:=wdExtend
'Select entire row
20330 .Delete Unit:=wdCharacter, Count:=1 'Clear the literals
from table's single row
20340 securityRS.MoveLast
20350 If securityRS.RecordCount > 1 Then 'Add extra lines to
table as needed
20360 .MoveRight Unit:=wdCharacter, Count:=2, Extend:=wdExtend
20370 .InsertRows securityRS.RecordCount - 1
20380 .MoveLeft Unit:=wdCharacter, Count:=1
20390 End If 'We should now have required #of rows and have
cursor in top left cell
20400 securityRS.MoveFirst 'Populate the MS Word table
20410 Do Until securityRS.EOF
20411 .TypeText Text:=Format$(securityRS!NO_SHRS_QY,
"#,###.000")
20412 .MoveRight Unit:=wdCell, Count:=1
20413 .TypeText Text:=securityRS!ISSR_NM
20414 securityRS.MoveNext
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:=wdCharacter, Count:=1 'Deletes
everything in that row
20540 If poolRS.RecordCount > 1 Then 'Add extra lines
to table as needed
20560 .InsertRows poolRS.RecordCount - 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.MoveFirst 'Populate the MS
Word table
20610 Do Until poolRS.EOF
20620 .TypeText Text:=poolRS!POOL_NM
20621 myPrincipalSum = myPrincipalSum + poolRS!SumOfPRNC_AM
20630 .MoveRight Unit:=wdCell, Count:=1
20640 .TypeText Text:=Format$(poolRS!myPercent, "Percent")
20650 .MoveRight Unit:=wdCell, Count:=1
20660 .TypeText Text:=Format$(poolRS!SumOfPRNC_AM, "Currency")
20670 .MoveRight Unit:=wdCell, Count:=1
20680 .TypeText Text:=Str(poolRS!PORT_ID) & "-" &
poolRS!VAST_ACCT_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$(cashTotalRS!CashTotal, "Currency"), gWord 'DMN
20860 findAndReplace "<thePrincipalSum>", Format$(myPrincipalSum,
"Currency"), gWord 'DMN
20930 conCustMixed = True
20931 End If
20940 End If
20997 End If
20998 End If
20999 DoCmd.Hourglass False
conCustMixed_xit:
debugStackPop
Set myQuery = Nothing
poolRS.Close
Set poolRS = Nothing
securityRS.Close
Set securityRS = Nothing
cashTotalRS.Close
Set cashTotalRS = Nothing
Set thisDB = Nothing
On Error Resume Next
Exit Function
conCustMixed_err:
bugAlert ""
Resume conCustMixed_xit
End Function
Private Function conCustSec(theLCI 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 CannotCreateLetter = "Cannot Create Letter"
13070 If poolRecsContribInvalid(theLCI.ContribID) Then
13071 DoCmd.Hourglass False
13072 MsgBox "Information for one or more pool allocations is incomplete.",
16, "CannotCreateLetter2"
13073 Else
13080 Set thisDB = DBEngine(0)(0)
13100 Set myQuery = thisDB.QueryDefs("qryLetterConLineItemsNonCashFetch")
13110 myQuery.Parameters("theContribID") = theLCI.ContribID
13120 Set securityRS = myQuery.OpenRecordset(DB_OPEN_SNAPSHOT)
13130 If securityRS.BOF And securityRS.EOF Then
13131 bugAlert "No security items found for contrib ID '" &
Str(theLCI.ContribID) & "'. Since this is a 'mixed' letter, this should not
happen."
13139 Else
13160 Set myQuery = thisDB.QueryDefs("qryLetterPoolRecsSumByPool")
13170 myQuery.Parameters("theContribID") = theLCI.ContribID
13180 Set poolRS = myQuery.OpenRecordset(DB_OPEN_SNAPSHOT)
13190 If poolRS.BOF And poolRS.EOF Then
13200 MsgBox "There are no pool allocations for this contribution", 16,
CannotCreateLetter
13210 Else
13230 findAndReplace "<theSalutationNameTitle>", theLCI.Recipients,
gWord
13240 findAndReplace "<theAddress>", theLCI.PrimaryContactAddress,
gWord
13250 findAndReplace "<theGreeting>", theLCI.PrimaryContactGreeting,
gWord
13260 findAndReplace "<theProgramAccountName>",
theLCI.ProgramAccountName, gWord
13265 findAndReplace "<theProgramAccountName>",
theLCI.ProgramAccountName, gWord 'there are 2
13270 findAndReplace "<theCharityPhone800>", charityPhone800Get(),
gWord
13290 findText "NumberSharesCertificates%", gWord
13356 With gWord.Selection
13257 .MoveRight Unit:=wdWord, Count:=2, Extend:=wdExtend 'Select
entire row
13258 .Delete Unit:=wdCharacter, Count:=1 'Clear the literals from
table's single row
13420 securityRS.MoveLast
13430 If securityRS.RecordCount > 1 Then 'Add extra lines to table
as needed
13432 .MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
13433 .InsertRows securityRS.RecordCount - 1
13434 .MoveLeft Unit:=wdCharacter, Count:=1
13536 End If 'We should now have required #of rows and have cursor
in top left cell
13440 securityRS.MoveFirst 'Populate the MS Word table
13450 Do Until securityRS.EOF
13452 .TypeText Text:=Format$(securityRS!NO_SHRS_QY, "#,###.000")
13454 .MoveRight Unit:=wdCell, Count:=1
13455 .TypeText Text:=securityRS!ISSR_NM
13457 securityRS.MoveNext
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:=wdExtend 'Select
entire row
13758 .Delete Unit:=wdCharacter, Count:=1 'Clear the literals from
table's single row
13820 poolRS.MoveLast
13830 If poolRS.RecordCount > 1 Then 'Add extra lines to table as
needed
13832 .MoveRight Unit:=wdCell, Count:=2, Extend:=wdExtend
13833 .InsertRows poolRS.RecordCount - 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.MoveFirst 'Populate the MS Word table
13850 Do Until poolRS.EOF
13852 .TypeText Text:=poolRS!POOL_NM
13853 myPrincipalSum = myPrincipalSum + poolRS!SumOfPRNC_AM
13854 .MoveRight Unit:=wdCell, Count:=1
13855 .TypeText Text:=Format$(poolRS!myPercent, "Percent")
13860 .MoveRight Unit:=wdCell, Count:=1
13861 .TypeText Text:=Format$(poolRS!SumOfPRNC_AM, "Currency")
13862 .MoveRight Unit:=wdCell, Count:=1
13863 .TypeText Text:=Str(poolRS!PORT_ID) & "-" &
poolRS!VAST_ACCT_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 "<thePrincipalSum>", Format$(myPrincipalSum,
"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.Close
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(theText As String, theApp As Word.Application)
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.Selection.HomeKey Unit:=wdStory, Extend:=wdMove
With theApp.Selection.Find
.ClearFormatting
.Text = theText
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
findText_xit:
debugStackPop
On Error Resume Next
Exit Sub
findText_err:
bugAlert ""
Resume findText_xit
End Sub
Private Function genericGranteeCust(theLCI As mLetterCustInfo) As Integer
16000 debugStackPush mModuleName & ": genericGranteeCust: "
16001 On Error GoTo genericGranteeCust_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.NameLegal, gWord
16041 findAndReplace "<theNameLegal>", theLCI.NameLegal, gWord
16050 findAndReplace "<theAddress>", theLCI.GranteeAddress, gWord
16060 findAndReplace "<theContactAttn>", theLCI.Recipients, gWord
16070 findAndReplace "<theContactGreeting>", theLCI.Greeting, gWord
16080 findAndReplace "<theCharityPhone800>", charityPhone800Get(), gWord
16994 genericGranteeCust = True
genericGranteeCust_xit:
debugStackPop
On Error Resume Next
Exit Function
genericGranteeCust_err:
bugAlert ""
Resume genericGranteeCust_xit
End Function
Private Function genericPersonCust(theLCI As mLetterCustInfo) As Integer
debugStackPush mModuleName & ": genericPersonCust: "
On Error GoTo genericPersonCust_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 "<theSalutationNameTitle>", theLCI.Recipients, gWord
findAndReplace "<theAddress>", theLCI.Address, gWord
findAndReplace "<theGreeting>", theLCI.Greeting, gWord
findAndReplace "<theCharityPhone800>", charityPhone800Get(), gWord
genericPersonCust = True
genericPersonCust_xit:
debugStackPop
On Error Resume Next
Exit Function
genericPersonCust_err:
bugAlert ""
Resume genericPersonCust_xit
End Function
Private Function getGranteeContactPersonInfo(theGranteeID,
theGranteeContactAttn, theGranteeContactGreeting) As Integer
debugStackPush mModuleName & ": getGranteeContactPersonInfo"
On Error GoTo getGranteeContactPersonInfo_err
' 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 myGranteeContactPersonID As Long
If granteeContactPersonSelect(theGranteeID, myGranteeContactPersonID) = True
Then
If myGranteeContactPersonID > 0 Then
Set thisDB = DBEngine(0)(0)
Set myQuery = thisDB.QueryDefs("qryGranteeContactPersonRecFetch")
myQuery.Parameters("theGranteeContactPersonID") =
myGranteeContactPersonID
Set myRS = myQuery.OpenRecordset(DB_OPEN_SNAPSHOT, DB_FORWARDONLY)
If myRS.BOF And myRS.EOF Then
bugAlert "Unable to find contactPersonID" &
Str(myGranteeContactPersonID)
Else
theGranteeContactAttn = "Attn: " &
formatSalutationNameTitle(myRS!SALUT_TX, myRS!FRST_NM, myRS!MI_NM, myRS!LST_NM,
myRS!TITLE_TX)
theGranteeContactGreeting = formatGreeting(myRS!SALUT_TX,
myRS!FRST_NM, myRS!LST_NM)
getGranteeContactPersonInfo = True
End If
Else
getGranteeContactPersonInfo = True
End If
End If
getGranteeContactPersonInfo_xit:
debugStackPop
On Error Resume Next
Set myQuery = Nothing
myRS.Close
Set myRS = Nothing
Set thisDB = Nothing
Exit Function
getGranteeContactPersonInfo_err:
bugAlert ""
Resume getGranteeContactPersonInfo_xit
End Function
Private Function getGrantRequestInfo(theGrantRequestID As Long,
theNamedAccountID As Long, theGRI As GrantRequestInfo) As Integer
debugStackPush mModuleName & ": getGrantRequestInfo"
On Error GoTo getGrantRequestInfo_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 = namedAccountAdvisersGet(theNamedAccountID, theAdvisers, theCount)
For y = 1 To theCount
Length = Len(theAdvisers)
x = InStr(1, theAdvisers, " and ")
If x > 0 Then
myAdvisers = myAdvisers & Left(theAdvisers, x - 1)
Else
myAdvisers = myAdvisers & theAdvisers
End If
If y <> theCount Then
myAdvisers = myAdvisers & Chr$(13) ' Chr$(13) is a line
feed
theAdvisers = Right(theAdvisers, Length - (x + 4))
End If
Next y
Set thisDB = DBEngine(0)(0)
Set myQuery = thisDB.QueryDefs("qryGetGrantRequestInfo")
myQuery.Parameters("theGrantRequestID") = theGrantRequestID
Set myRS = myQuery.OpenRecordset(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_NM & ""
.VAST_ACCT_NO = myRS!VAST_ACCT_NO & ""
.PROG_ACCT_NM = myRS!PROG_ACCT_NM & ""
.PROG_PURP_TX = myRS!PROG_PURP_TX & ""
.PrimaryContactAddress = personAddressGet(myRS!PrimaryContactPerson)
.PrimaryContactSalutationNameTitle = myAdvisers
.PrimaryContactGreeting = formatGreeting(myRS!SALUTATION,
myRS!FIRST_NAME, myRS!LAST_NAME)
End With
getGrantRequestInfo = True
End If
getGrantRequestInfo_xit:
debugStackPop
On Error Resume Next
Set myQuery = Nothing
myRS.Close
Set myRS = Nothing
Set thisDB = Nothing
Exit Function
getGrantRequestInfo_err:
bugAlert ""
Resume getGrantRequestInfo_xit
End Function
Private Function grantCustAnon(theLCI As mLetterCustInfo) As Integer
10000 debugStackPush mModuleName & ": grantCustAnon: "
10001 On Error GoTo grantCustAnon_err
' 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 myGranteeContactAttn As String
Dim myGranteeContactGreeting As String
Const CannotCreateLetter = "Cannot Create Letter"
10020 If getGranteeContactPersonInfo(theLCI.GranteeID, myGranteeContactAttn,
myGranteeContactGreeting) = True Then
10050 findAndReplace "<theNameLegal>", theLCI.NameLegal, gWord 'DMN
10051 findAndReplace "<theNameLegal>", theLCI.NameLegal, gWord 'DMN
10060 findAndReplace "<theAddress>", theLCI.GranteeAddress, gWord 'DMN
10070 findAndReplace "<theContactAttn>", myGranteeContactAttn, gWord 'DMN
10080 findAndReplace "<theContactGreeting>", myGranteeContactGreeting, gWord
'DMN
10090 findAndReplace "<theAmount>", theLCI.TotalAmountGrant, gWord 'DMN
10100 findAndReplace "<theCharityPhone800>", charityPhone800Get(), gWord 'DMN
10110 findAndReplace "<thePurposeProgram>", theLCI.PurposeProg, gWord 'DMN
10994 grantCustAnon = True
19990 End If
grantCustAnon_xit:
debugStackPop
On Error Resume Next
Exit Function
grantCustAnon_err:
bugAlert ""
Resume grantCustAnon_xit
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 GranteeContactPersonInfo
Dim x As Integer
Dim myGranteeContactAttn As String
Dim myGranteeContactGreeting As String
Dim FrontOfString As String
Dim RestOfString As String
Dim Length As String
Const CannotCreateLetter = "Cannot Create Letter"
11020 If getGranteeContactPersonInfo(theLCI.GranteeID, myGranteeContactAttn,
myGranteeContactGreeting) = True Then
11050 findAndReplace "<theNameLegal>", theLCI.NameLegal, gWord
11051 findAndReplace "<theNameLegal>", theLCI.NameLegal, gWord
11060 findAndReplace "<theAddress>", theLCI.GranteeAddress, gWord
11070 findAndReplace "<theContactAttn>", myGranteeContactAttn, gWord
11080 findAndReplace "<theContactGreeting>", myGranteeContactGreeting, gWord
11090 findAndReplace "<theAmount>", theLCI.TotalAmountGrant, gWord
11100 findAndReplace "<thePurposeProgram>", theLCI.PurposeProg, gWord
11110 findAndReplace "<theCharityPhone800>", charityPhone800Get(), gWord
11120 findAndReplace "<theProgramAccountName>", theLCI.ProgramAccountName,
gWord
11130 findAndReplace "<thePersonToBeAcknowledged>",
theLCI.PersonToBeAcknowledged, gWord
'This section of code takes theLCI.PrimaryContactSalutationNameTitle apart and
puts a "vbTab" between the
' advisers' names - if there are 2 advisers.
11140 Length = Len(theLCI.PrimaryContactSalutationNameTitle)
11150 x = InStr(1, theLCI.PrimaryContactSalutationNameTitle, Chr$(13)) 'find
the carriage return
11155 If x > 0 Then
11160 FrontOfString = Left(theLCI.PrimaryContactSalutationNameTitle, x)
11170 RestOfString = Right(theLCI.PrimaryContactSalutationNameTitle,
Length - x) 'put the back part in holding place
11180 theLCI.PrimaryContactSalutationNameTitle = FrontOfString & vbTab &
RestOfString 'get the TAB in the string
11185 End If
11190 findAndReplace "<theDonorSalutationNameTitle>",
theLCI.PrimaryContactSalutationNameTitle, gWord 'DMN
11200 findAndReplace "<theDonorAddress>", theLCI.PrimaryContactAddress, 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 grantCustToDonor(theLCI As mLetterCustInfo) As Integer
21000 debugStackPush mModuleName & ": grantCustToDonor: "
21001 On Error GoTo grantCustToDonor_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 grantRequestLineItemRS As Recordset
Dim myQuery As QueryDef
Dim myNav As Double
Dim x As Integer
Const CannotCreateLetter = "Cannot Create Letter"
21100 Set thisDB = DBEngine(0)(0)
21110 Set myQuery = thisDB.QueryDefs("qryGrantRequestLineItemsFetch")
21111 myQuery.Parameters("theGrantRequestID") = theLCI.GrantRequestID
21112 Set grantRequestLineItemRS = myQuery.OpenRecordset(DB_OPEN_DYNASET)
21120 If grantRequestLineItemRS.BOF And grantRequestLineItemRS.EOF Then
21121 bugAlert "No line items found for grant# " & Str(theLCI.GrantRequestID)
21122 Else
21200 findAndReplace "<theSalutationNameTitle>",
theLCI.PrimaryContactSalutationNameTitle, gWord
21210 findAndReplace "<theProgramAccountName>", theLCI.ProgramAccountName,
gWord
21220 findAndReplace "<theAddress>", theLCI.PrimaryContactAddress, gWord
21230 findAndReplace "<theGreeting>", theLCI.PrimaryContactGreeting, gWord
21240 findAndReplace "<theGranteeName>", theLCI.NameLegal, gWord 'NB: Two
occurrances of this field in letter
21241 findAndReplace "<theGranteeName>", theLCI.NameLegal, gWord
21250 findAndReplace "<thePersonToBeAcknowledged>",
theLCI.PersonToBeAcknowledged, gWord
'21260 findAndReplace "<theReceivedDate>", Format$(theLCI.GrantReceivedDate,
"mm/dd/yyyy"), gWord
21270 findAndReplace "<theCharityPhone800>", charityPhone800Get(), gWord
21280 findAndReplace "<theAmount>", theLCI.TotalAmountGrant, 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:=wdCharacter, Count:=1 'Deletes everything in
that row
21330 grantRequestLineItemRS.MoveLast
21340 If grantRequestLineItemRS.RecordCount > 1 Then 'Add
extra lines to table as needed
21360 .InsertRows grantRequestLineItemRS.RecordCount - 1
21370 .HomeKey Unit:=wdLine
21380 End If 'We
should now have required #of rows and have cursor in top left cell
21400 grantRequestLineItemRS.MoveFirst 'Populate the MS Word table
21410 Do Until grantRequestLineItemRS.EOF
21420 .TypeText Text:=grantRequestLineItemRS!POOL_NM
21430 .MoveRight Unit:=wdCell, Count:=1
21440 .TypeText Text:=Format$(grantRequestLineItemRS!REDMPTN_DT,
"mm/dd/yyyy")
21450 .MoveRight Unit:=wdCell, Count:=1
21460 .TypeText Text:=Format$(grantRequestLineItemRS!SHRS_QY,
"#,###.000")
21470 myNav = DLookup("NAV_AMT", "tlkpPoolValue", "VAL_DT=#" &
grantRequestLineItemRS!REDMPTN_DT & "# And POOL_ID=" &
grantRequestLineItemRS!POOL_ID)
21480 .MoveRight Unit:=wdCell, Count:=1
21490 .TypeText Text:=Format$(myNav, "#,###.00")
21500 .MoveRight Unit:=wdCell, Count:=1
21510 .TypeText Text:=Format$(grantRequestLineItemRS!DOL_GNTD_AM,
"Currency")
21520 .MoveRight Unit:=wdCell, Count:=1
21530 .TypeText Text:=theLCI.VastAccountNumber
21540 grantRequestLineItemRS.MoveNext
21550 If grantRequestLineItemRS.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.TotalAmountGrant, gWord
21998 grantCustToDonor = True
21999 End If
grantCustToDonor_xit:
debugStackPop
On Error Resume Next
Set myQuery = Nothing
grantRequestLineItemRS.Close
Set grantRequestLineItemRS = Nothing
Exit Function
grantCustToDonor_err:
bugAlert ""
Resume grantCustToDonor_xit
End Function
Private Function granteeRequirementsCust(theLCI As mLetterCustInfo) As Integer
17000 debugStackPush mModuleName & ": granteeRequirementsCust: "
17001 On Error GoTo granteeRequirementsCust_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 GranteeContactPersonInfo
Const CannotCreateLetter = "Cannot Create Letter"
17020 Set thisDB = DBEngine(0)(0)
17080 Set myQuery = thisDB.QueryDefs("qryGranteeRecFetch")
17090 myQuery.Parameters("theGranteeID") = theLCI.GranteeID
17100 Set granteeRS = myQuery.OpenRecordset(DB_OPEN_SNAPSHOT)
17110 If granteeRS.BOF And granteeRS.EOF Then
17120 bugAlert "Grantee# " & Str(theLCI.GranteeID) & " not found."
17130 Else
17170 myNameLegal = granteeRS!LEGL_NM
17190 myAddress = formatAddress(False, True, granteeRS!ST_ADDR_1,
granteeRS!ST_ADDR_2, granteeRS!CITY, granteeRS!STE_ABV_CD, granteeRS!ZIP)
17200 If granteeContactPersonInfoGet(Forms!frmHome!txtGranteeContactPersonID,
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 "<theAddress>", myAddress, gWord
10070 findAndReplace "<theCharityPhone800>", charityPhone800Get(), gWord
10080 findAndReplace "<theAttnLine>", myAttnLine, gWord
10090 findAndReplace "<theContactPerson>", myContactPerson, gWord
17994 granteeRequirementsCust = True
17999 End If
granteeRequirementsCust_xit:
debugStackPop
On Error Resume Next
Set myQuery = Nothing
granteeRS.Close
Set granteeRS = Nothing
Set thisDB = Nothing
Exit Function
granteeRequirementsCust_err:
bugAlert ""
Resume granteeRequirementsCust_xit
End Function
Sub insertCC(theNamedAccountID)
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.QueryDefs("qryNamedAccountRecFetch")
12020 myQuery.Parameters("theNamedAccountID") = theNamedAccountID
12030 Set myRS = myQuery.OpenRecordset(DB_OPEN_SNAPSHOT, DB_FORWARDONLY)
12040 If (myRS.BOF And myRS.EOF) Then
12050 bugAlert "Failed to find named account ID " & Str(theNamedAccountID)
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!NOTES '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 gotInitialContrib 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 myNamedAccountID As Long
Dim mySecondaryAdvisers As String
1020 statusSet "Opening model letter..."
1022 Set thisWS = DBEngine(0)
1023 Set thisDB = DBEngine(0)(0)
1035 Set myQuery = thisDB.QueryDefs("qryLetterConLineItemsAllFetch")
1040 myQuery.Parameters("theContribID") = theContribID
1041 Set lineItemRS = myQuery.OpenRecordset(DB_OPEN_SNAPSHOT)
1050 If (lineItemRS.BOF And lineItemRS.EOF) Then
1051 bugAlert "No line items found for contrib ID " & Str(theContribID)
1052 Else
1100 lineItemRS.MoveFirst
1101 Do Until lineItemRS.EOF
1120 myCashFlag = DLookup("[CNTRBN_TYP_CASH_FL]", "tlkpContribType",
"[CNTRBN_TYP_ID]=" & lineItemRS!CNTRBN_TYP_ID)
1121 If myCashFlag = True Then
1122 gotCash = True
1123 Else
1124 gotSecurity = True
1125 End If
1130 myLCI.TotalAmountProceeds = myLCI.TotalAmountProceeds +
lineItemRS!WFS_PROCD_AM
1131 myLCI.TotalAmountDonorEstimated = myLCI.TotalAmountDonorEstimated +
lineItemRS!DON_EST_AM
1198 lineItemRS.MoveNext
1199 Loop
1200 gotInitialContrib = contribInitialStatusGet(theContribID)
1201 If gotInitialContrib = True Then
1202 If (gotCash = True) And (gotSecurity = False) Then
1203 myLetterID = gLetterIdConNewCash
1210 Else
1211 If (gotCash = False) And (gotSecurity = True) Then
1212 myLetterID = gLetterIdConNewSec
1220 Else
1221 If (gotCash = True) And (gotSecurity = True) Then
1222 myLetterID = gLetterIdConNewMixed
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 = gLetterIdConAddCash
1260 Else
1261 If (gotCash = False) And (gotSecurity = True) Then
1262 myLetterID = gLetterIdConAddSec
1270 Else
1271 If (gotCash = True) And (gotSecurity = True) Then
1272 myLetterID = gLetterIdConAddMixed
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.OpenRecordset("zstblLetter", DB_OPEN_TABLE)
1303 letterRS.Index = "PrimaryKey"
1304 letterRS.Seek "=", myLetterID
1305 If letterRS.NoMatch Then
1306 bugAlert "No record found for letterID " & Str(myLetterID)
1307 Else
1308 myDosName = wordBegin(letterRS!ModelName)
1330 If Len(myDosName) > 0 Then
1331 Set myQuery = thisDB.QueryDefs("qryLetterNamedAccountInfoFetch")
1335 myNamedAccountID = namedAccountIdGetFromContribID(theContribID)
1336 myQuery.Parameters("theNamedAccountID") = myNamedAccountID
1337 Set namedAccountRS = myQuery.OpenRecordset(DB_OPEN_SNAPSHOT)
1338 If namedAccountRS.BOF And namedAccountRS.EOF Then
1339 bugAlert "Named Account# " & Str(myNamedAccountID) & " not
found."
1340 Else
1241 With myLCI
1342 .PrimaryContactAddress =
personAddressGet(namedAccountRS!PrimaryContactPerson)
1343 mySecondaryAdvisers =
secondaryAdvisersFetch(myNamedAccountID)
1344 .PrimaryContactGreeting =
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 mySecondaryAdvisers =
secondaryAdvisersFetch(myNamedAccountID)
1348 If Len(mySecondaryAdvisers) > 0 Then
1349 .Recipients = myLCI.Recipients & Chr$(13) &
mySecondaryAdvisers
1350 End If
1351 .ProgramAccountName = namedAccountRS!PROG_ACCT_NM
1255 End With
1665 Set thisWS = DBEngine(0)
1666 thisWS.BeginTrans 'Transaction prevents adding
contact hist if customizing process fails
1667 transOpen = True
1668 If namedAccountContactHistoryRecAdd(myNamedAccountID,
"Re/Contribution# " & Str(theContribID) & ", generated '" &
letterRS!description & "' letter.", myLetterID, myDosName, theContribID, 0) Then
1669 statusSet "Customizing model letter..."
1670 insertCC myNamedAccountID
1699 tweakLetter1
1700 Select Case myLetterID
Case gLetterIdConNewCash, gLetterIdConAddCash
1711 okToProceed = conCustCash(myLCI)
1720 Case gLetterIdConNewSec, gLetterIdConAddSec
1721 okToProceed = conCustSec(myLCI)
1730 Case gLetterIdConNewMixed, gLetterIdConAddMixed
1731 okToProceed = conCustMixed(myLCI)
1740 Case Else
1741 bugAlert "Unexpected letter ID=" & Str(myLetterID)
1799 End Select
1800 If okToProceed = True Then
1810 tweakLetter2 (myDosName)
1820 thisWS.CommitTrans
1830 transOpen = False
1840 Forms!frmContrib!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.Close
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 letterBeginGenericNamedAccount(theLetterID, thePersonID,
theNamedAccountID) As Integer
15000 debugStackPush mModuleName & ": letterBeginGenericNamedAccount"
15001 On Error GoTo letterBeginGenericNamedAccount_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.OpenRecordset("zstblLetter", DB_OPEN_TABLE)
15014 letterRS.Index = "PrimaryKey"
15015 letterRS.Seek "=", theLetterID
15020 If letterRS.NoMatch Then
15021 bugAlert "No record found for letterID " & Str(theLetterID)
15022 Else
15023 Set fHome = Forms!frmHome
15024 fHome!txtGeneralText = Null
15030 DoCmd.OpenForm "frmGetThumbNailDescription", , , , , A_DIALOG
15039 If fHome!txtGeneralText & "" = "" 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(letterRS!ModelName)
15130 If Len(myDosName) > 0 Then
15131 Set thisWS = DBEngine(0)
15132 thisWS.BeginTrans 'Transaction prevents adding
contact hist if customizing process fails
15133 transOpen = True
25235 With myLCI
15160 .Address = personAddressGet(thePersonID)
15162 .Greeting = personGreetingGet(thePersonID)
15163 .Recipients = personNameFirstLastGet(thePersonID)
15165 End With
15170 If namedAccountContactHistoryRecAdd(CLng(theNamedAccountID),
"Letter To " & myLCI.Recipients & " Re/: " & fHome!txtGeneralText & ".", 0,
myDosName, 0, 0) Then
15171 statusSet "Customizing model letter..."
15178 insertCC theNamedAccountID
15180 tweakLetter1
15200 Select Case theLetterID
Case gLetterIdGenericPerson
15211 okToProceed = genericPersonCust(myLCI)
15220 Case gLetterIdGrantDenied
15221 okToProceed = genericPersonCust(myLCI)
15240 Case Else
15241 bugAlert "Unexpected letter ID=" & Str(theLetterID)
15299 End Select
15315 If okToProceed = True Then
15320 tweakLetter2 (myDosName)
15325 thisWS.CommitTrans
15330 transOpen = False
15335 namedAccountScreenLoad CLng(theNamedAccountID), True
15339 gWord.Activate 'DMN - used
to be: showLetter
15340 letterBeginGenericNamedAccount = 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
letterBeginGenericNamedAccount_xit:
debugStackPop
On Error Resume Next
Set fHome = Nothing
letterRS.Close
Set letterRS = Nothing
Set thisDB = Nothing
Set thisWS = Nothing
Exit Function
letterBeginGenericNamedAccount_err:
If transOpen = True Then
thisWS.Rollback
End If
Select Case Err
Case objectNotExist
MsgBox "Cannot find anything named " & Chr$(34) & letterRS!FunctionName &
Chr$(34) & ". " & Chr$(13) & Chr$(13) & "Check Spelling In " & Chr$(34) &
"zstblReport" & Chr$(34), 48, "Uh-Oh!"
Case ReportCancelled
' (do nothing, user chose to cancel...)
Case Else
bugAlert "letter ID=" & Str(theLetterID)
End Select
Resume letterBeginGenericNamedAccount_xit
Exit Function
End Function
Function letterBeginGrant(theLetterID As Integer, theNamedAccountID,
thePersonID, theGrantRequestID, theGranteeID) As Integer
8000 debugStackPush mModuleName & ": letterBeginGrant"
8001 On Error GoTo letterBeginGrant_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 GrantRequestInfo
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 destinationGrantee = 2
8011 statusSet "Opening model letter..."
8012 Set thisDB = DBEngine(0)(0)
8013 Set letterRS = thisDB.OpenRecordset("zstblLetter", DB_OPEN_TABLE)
8014 letterRS.Index = "PrimaryKey"
8015 letterRS.Seek "=", theLetterID
8016 If letterRS.NoMatch Then
8017 bugAlert "No record found for letterID " & Str(theLetterID)
8018 Else
8022 myDosName = wordBegin(letterRS!ModelName)
8130 If Len(myDosName) > 0 Then
8131 Set thisWS = DBEngine(0)
8132 thisWS.BeginTrans 'Transaction prevents
adding contact hist if customizing process fails
8133 transOpen = True
8134 If getGrantRequestInfo(Val(theGrantRequestID),
CLng(theNamedAccountID), myGRI) Then
8135 With myLCI
8141 .GranteeID = theGranteeID
8142 .NameLegal = myGRI.LEGL_NM
8143 .GranteeAddress = granteeAddressGet(theGranteeID)
8153 .PurposeProg = myGRI.PROG_PURP_TX
8154 .GrantReceivedDate = myGRI.RCVD_DT
8155 .PrimaryContactAddress = myGRI.PrimaryContactAddress
8156 .PrimaryContactGreeting = myGRI.PrimaryContactGreeting
8162 .PrimaryContactSalutationNameTitle =
myGRI.PrimaryContactSalutationNameTitle
8164 .GrantRequestID = theGrantRequestID
8166 .ProgramAccountName = myGRI.PROG_ACCT_NM
8168 .VastAccountNumber = myGRI.VAST_ACCT_NO
8170 .PersonToBeAcknowledged = myGRI.ACK_PERS_NM
8250 .TotalAmountGrant =
Format$(grantRequestAmountTotalGet(theGrantRequestID), "Currency")
8251 End With
8541 If namedAccountContactHistoryRecAdd(CLng(theNamedAccountID),
"Re/Grant# " & Str(theGrantRequestID) & " to " & myGRI.LEGL_NM & " from " &
myGRI.PROG_ACCT_NM & " , generated '" & letterRS!description & "' letter.",
CLng(theLetterID), myDosName, 0, CLng(theGrantRequestID)) Then
8542 If letterRS!Destination = destinationGrantee Then
8543 historyOK = granteeContactHistoryRecAdd(CLng(theGranteeID),
"Re/Grant# " & Str(theGrantRequestID) & " from " &
myGRI.PrimaryContactSalutationNameTitle & "/" & myGRI.PROG_ACCT_NM & ",
generated '" & letterRS!description & "' letter.", CLng(theLetterID),
myDosName, CLng(theGrantRequestID))
8544 Else
8545 historyOK = True
8546 End If
8550 If historyOK = True Then
8551 statusSet "Customizing model letter..."
8560 insertCC theNamedAccountID
8580 tweakLetter1
8600 Select Case theLetterID
' Case gLetterIdGrantDenied
' 8611 okToProceed = grantDeniedCust(myLCI)
Case gLetterIdGrantNotificationGranteeAnon
8621 okToProceed = grantCustAnon(myLCI)
8630 Case gLetterIdGrantNotificationGranteeAttrib
8631 okToProceed = grantCustAttrib(myLCI)
8640 Case gLetterIdGrantNotificationToDonor
8641 okToProceed = grantCustToDonor(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.CommitTrans
8820 transOpen = False ' "FunctionName"
points to a procedure in this module
On Error Resume Next
If Err = 0 Then
namedAccountContactHistoryLoad theNamedAccountID ' To
show entry for newly-created letter in donor contact history list
If letterRS!Destination = destinationGrantee Then
granteeScreenLoad theGranteeID ' To show entry
for newly-created letter in grantee contact history list
End If
End If
On Error GoTo letterBeginGrant_err
8829 gWord.Activate 'DMN -
used to be: showLetter
8830 letterBeginGrant = 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
letterBeginGrant_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
letterBeginGrant_err:
If transOpen = True Then
thisWS.Rollback
End If
Select Case Err
Case objectNotExist
MsgBox "Cannot find anything named " & Chr$(34) & letterRS!FunctionName &
Chr$(34) & ". " & Chr$(13) & Chr$(13) & "Check Spelling In " & Chr$(34) &
"zstblReport" & Chr$(34), 48, "Uh-Oh!"
Case ReportCancelled
' (do nothing, user chose to cancel...)
Case Else
bugAlert ""
End Select
Resume letterBeginGrant_xit
End Function
Function letterBeginGrantee(theLetterID, theGranteeContactPersonID,
theGranteeID) As Integer
22000 debugStackPush mModuleName & ": letterBeginGrantee"
22001 On Error GoTo letterBeginGrantee_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.OpenRecordset("zstblLetter", DB_OPEN_TABLE)
22014 letterRS.Index = "PrimaryKey"
22015 letterRS.Seek "=", theLetterID
22020 If letterRS.NoMatch Then
22021 bugAlert "No record found for letterID " & Str(theLetterID)
22022 Else
22023 Set fHome = Forms!frmHome
22024 fHome!txtGeneralText = Null
22030 DoCmd.OpenForm "frmGetThumbNailDescription", , , , , A_DIALOG
22039 If fHome!txtGeneralText & "" = "" 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(letterRS!ModelName)
22130 If Len(myDosName) > 0 Then
22131 Set thisWS = DBEngine(0)
22132 thisWS.BeginTrans 'Transaction prevents adding
contact hist if customizing process fails
22133 transOpen = True
22140 With myLCI
22500 .NameLegal = granteeNameGet(theGranteeID)
22502 .GranteeAddress = granteeAddressGet(theGranteeID)
22510 If theGranteeContactPersonID > 0 Then
22511 .Greeting =
granteeContactPersonGreetingGet(theGranteeContactPersonID)
22512 .Recipients = "ATTN: " &
granteeContactPersonNameFirstLastGet(theGranteeContactPersonID, True)
22513 End If
22534 .GranteeID = theGranteeID
22535 End With
22537 If granteeContactHistoryRecAdd(CLng(theGranteeID), "Letter Re/: "
& fHome!txtGeneralText & ".", CLng(theLetterID), myDosName, 0) Then
22538 statusSet "Customizing model letter..."
22540 tweakLetter1
22600 Select Case theLetterID
Case gLetterIdGenericGrantee
22621 okToProceed = genericGranteeCust(myLCI)
22630 Case gLetterIdRequirementGrantee
22631 okToProceed = genericGranteeCust(myLCI)
22640 Case Else
22641 bugAlert "Unexpected letter ID=" & Str(theLetterID)
22699 End Select
22700 If okToProceed = True Then
22720 tweakLetter2 (myDosName)
22725 thisWS.CommitTrans
22730 transOpen = False
22735 granteeScreenLoad theGranteeID
22740 letterBeginGrantee = 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
letterBeginGrantee_xit:
debugStackPop
On Error Resume Next
Set fHome = Nothing
letterRS.Close
Set letterRS = Nothing
Set thisDB = Nothing
Set thisWS = Nothing
Exit Function
letterBeginGrantee_err:
If transOpen = True Then
thisWS.Rollback
End If
Select Case Err
Case objectNotExist
MsgBox "Cannot find anything named " & Chr$(34) & letterRS!FunctionName &
Chr$(34) & ". " & Chr$(13) & Chr$(13) & "Check Spelling In " & Chr$(34) &
"zstblReport" & Chr$(34), 48, "Uh-Oh!"
Case ReportCancelled
' (do nothing, user chose to cancel...)
Case Else
bugAlert "letter ID=" & Str(theLetterID)
End Select
Resume letterBeginGrantee_xit
Exit Function
End Function
Sub letterBeginSubst(thePersonIdGroup, theContribID As Long, theDonorType As
Integer)
19000 debugStackPush mModuleName & ": letterBeginSubst"
19001 On Error GoTo letterBeginSubst_err
' PURPOSE: To open up a substantiation letter via MS Word - which is
addressed to the
' group of people clicked upon in frmletterBeginSubstList.
'
' ACCEPTS: RecordID of the record clicked upon
' RETURNS: (nothing)
' NOTES: - Although this function is used only by frmletterBeginSubst, 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 myNamedAccountID 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.QueryDefs("qryLetterSubstDonorTypesList")
19040 myQuery.Parameters("thePersonIdGroup") = thePersonIdGroup
19050 Set donorTypeRS = myQuery.OpenRecordset(DB_OPEN_DYNASET)
19060 If donorTypeRS.RecordCount > 1 Then
19070 MsgBox "There are both multiple donor types in this group.", 48,
"Cannot Create Letter"
19080 Else
19090 myTypeOfDonor = donorTypeRS!TypeOfDonor ' SB "5" or
32,749
19100 Set myQuery = thisDB.QueryDefs("qryLetterSubstRecsInPersonIdGroup")
19110 myQuery.Parameters("thePersonIdGroup") = thePersonIdGroup
19120 Set pickListRS = myQuery.OpenRecordset(DB_OPEN_SNAPSHOT,
DB_FORWARDONLY)
19130 Set myQuery = thisDB.QueryDefs("qryContribLineItemRecFetch")
19240 If pickListRS.BOF And pickListRS.EOF Then
19250 bugAlert "No records found for PersonIdGroup " & thePersonIdGroup
19260 Else
19265 With myLCI
19270 .Address =
contribLineItemAddressGet(CLng(pickListRS!CNTRBN_LN_ITEM_ID))
19271 .Greeting = pickListRS!Greeting
19272 .ContribID = theContribID
12273 .Donor = pickListRS!DonorNames & ""
19274 .Recipients = pickListRS!MsWordNames ' DISABLED PER
EXECPTIONS 2780/2865 .... & Chr$(13) &
personNameFirstLastGet(namedAccountContactGetViaContribID(theContribID)) 'This
field contains the same value in all records
19275 .PersonIdGroup = thePersonIdGroup
19280 Do Until pickListRS.EOF
19290 myQuery.Parameters("theContribLineItemID") =
pickListRS!CNTRBN_LN_ITEM_ID
19300 Set lineItemRS = myQuery.OpenRecordset(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]",
"tlkpContribType", "[CNTRBN_TYP_ID]=" & lineItemRS!CNTRBN_TYP_ID)
19332 If myCashFlag = True Then
19333 gotCash = True
19334 Else
19335 gotSecurity = True
19336 End If
19337 .TotalAmountProceeds = myLCI.TotalAmountProceeds +
lineItemRS!WFS_PROCD_AM
19338 .TotalAmountDonorEstimated =
myLCI.TotalAmountDonorEstimated + lineItemRS!DON_EST_AM
19340 myIssuer = justLeft(lineItemRS!ISSR_NM, 15)
19350 myType = justLeft(DLookup("[CNTRBN_TYP_CASH_FL]",
"tlkpContribType", "[CNTRBN_TYP_ID]=" & lineItemRS!CNTRBN_TYP_ID), 20)
19360 myShares = justRite(Format$(lineItemRS!NO_SHRS_QY,
"#,###"), 12)
19370 myAmount = justRite(Format$(lineItemRS!DON_EST_AM,
"#,###"), 12)
19400 myLineItemInfo = myLineItemInfo & " " & myIssuer
19410 End If
19420 pickListRS.MoveNext
19430 Loop
19435 End With
19460 End If
19500 If DLookup("IsNonProfit", "tlkpDonorType", "[DON_TYP_ID]=" &
theDonorType) = True Then
19501 myLetterID = gLetterIdSubNonPr
19502 Else
19510 If (gotCash = True) And (gotSecurity = False) Then
19511 myLetterID = gLetterIdSubCash
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 = gLetterIDSubMixed
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.OpenRecordset("zstblLetter", DB_OPEN_TABLE)
19603 letterRS.Index = "PrimaryKey"
19604 letterRS.Seek "=", myLetterID
19605 If letterRS.NoMatch Then
19606 bugAlert "No record found for letterID " & Str(myLetterID)
19607 Else
19608 myDosName = wordBegin(letterRS!ModelName)
19640 If Len(myDosName) > 0 Then
19641 Set myQuery =
thisDB.QueryDefs("qryLetterNamedAccountInfoFetch")
19645 myNamedAccountID =
namedAccountIdGetFromContribID(theContribID)
19651 myQuery.Parameters("theNamedAccountID") = myNamedAccountID
19652 Set namedAccountRS = myQuery.OpenRecordset(DB_OPEN_SNAPSHOT)
19653 If namedAccountRS.BOF And namedAccountRS.EOF Then
19654 bugAlert "Named Account# " & Str(myNamedAccountID) & " not
found."
19655 Else
13662 myLCI.ProgramAccountName = namedAccountRS!PROG_ACCT_NM
19664 Set thisWS = DBEngine(0)
19665 thisWS.BeginTrans 'Transaction prevents adding
contact hist if customizing process fails
19666 transOpen = True
19667 If namedAccountContactHistoryRecAdd(myNamedAccountID,
"Re/Contribution# " & Str(theContribID) & ", generated '" &
letterRS!description & "' letter to " & myLCI.Recipients & "RE/" &
myLineItemInfo, myLetterID, myDosName, theContribID, 0) Then
19668 statusSet "Customizing model letter..."
'19669 insertCC myNamedAccountID DISABLED PER FUNC
REL EXCEPTION #2752
19670 tweakLetter1
19700 Select Case myLetterID
Case gLetterIdSubCash
19711 okToProceed = subCustCash(myLCI)
19720 Case gLetterIdSubSec
19721 okToProceed = subCustSec(myLCI)
19740 Case gLetterIDSubMixed
19741 okToProceed = subCustMixed(myLCI)
19750 Case gLetterIDSubMixed
19751 okToProceed = subCustMixed(myLCI)
19760 Case gLetterIdSubNonPr
19761 If namedAccountAdvisersGet(myNamedAccountID,
myLCI.Advisers, myLCI.AdviserCount) = True Then
19762 okToProceed = subCustNonPr(myLCI)
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.QueryDefs("qryLetterSubstDateUpdate")
19830 myQuery.Parameters("thePersonIdGroup") =
thePersonIdGroup
19840 myQuery.Parameters("theDosName") = myDosName
19850 myQuery.Execute DB_FAILONERROR
19860 thisWS.CommitTrans
19870 transOpen = False
19880 Forms!frmContrib!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
letterBeginSubst_xit:
debugStackPop
On Error Resume Next
Set myQuery = Nothing
letterRS.Close
Set letterRS = Nothing
namedAccountRS.Close
Set namedAccountRS = Nothing
pickListRS.Close
Set pickListRS = Nothing
donorTypeRS.Close
Set donorTypeRS = Nothing
lineItemRS.Close
Set lineItemRS = Nothing
Set thisDB = Nothing
Set thisWS = Nothing
Exit Sub
letterBeginSubst_err:
bugAlert ""
Resume letterBeginSubst_xit
End Sub
Sub letterExistingOpen(theLetterName)
7000 debugStackPush "basLetter: letterExistingOpen: "
7001 On Error GoTo letterExistingOpen_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("tblPerson") & "\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
letterExistingOpen_loop:
7090 If (gWord Is Nothing) Or (userClosedWord = 1) Then
'7091 Set gWord = CreateObject("Word.Basic")
7091 Set gWord = CreateObject("Word.Application.8") 'DMN
7092 gWord.Visible = True 'DMN
7200 End If
'7400 gWord.ChDefaultDir myLetterPath, 0
7400 gWord.ChangeFileOpenDirectory (myLetterPath) 'DMN
'7401 gWord.FileOpen theLetterName, 0, 0 ' Open as Editable
7401 gWord.Documents.Open (theLetterName) 'DMN
'7401 gWord.Documents.Open FileName:=theLetterName, ReadOnly:=False 'DMN
7510 gWord.Activate 'DMN - used to be:
showLetter
7999 statusSet ""
letterExistingOpen_xit:
debugStackPop
On Error Resume Next
Exit Sub
letterExistingOpen_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 letterExistingOpen_xit
Case 2772
MsgBox "Unable to locate Microsoft Word program. Please notify your
administrator", 16, "Cannot Print Form Letter"
Resume letterExistingOpen_xit
Case oleError, mRpcServerUnavailable
If userClosedWord = 0 Then
userClosedWord = userClosedWord + 1
Set gWord = Nothing
Resume letterExistingOpen_loop
Else
bugAlert "Unable to open MS Word. Suspect user may have closed
existing instance."
Resume letterExistingOpen_xit
End If
Case Else
bugAlert ""
End Select
Resume letterExistingOpen_xit 'Shouldn't be needed, but just in
case.....
End Sub
Private Function numberOfLineItems(theContribID As Long) As Integer
debugStackPush mModuleName & ": numberOfLineItems"
On Error GoTo numberOfLineItems_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.QueryDefs("qryContribLineItemCount")
myQuery.Parameters("theContribID") = theContribID
Set myRS = myQuery.OpenRecordset(DB_OPEN_SNAPSHOT)
If myRS.EOF Then
numberOfLineItems = 0
Else
numberOfLineItems = myRS!LineItemCount
End If
numberOfLineItems_xit:
debugStackPop
On Error Resume Next
Set myQuery = Nothing
myRS.Close
Set myRS = Nothing
Set thisDB = Nothing
Exit Function
numberOfLineItems_err:
bugAlert ""
Resume numberOfLineItems_xit
End Function
Private Function poolRecsContribInvalid(theContribID As Long) As Integer
debugStackPush mModuleName & ": poolRecsContribInvalid"
On Error GoTo poolRecsContribInvalid_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 poolRecsContribInvalid_xit
Dim thisDB As Database
Dim myRS As Recordset
Dim myQuery As QueryDef
Set thisDB = DBEngine(0)(0)
Set myQuery = thisDB.QueryDefs("qryPoolRecsContribInvalid")
myQuery.Parameters("theContribID") = theContribID
Set myRS = myQuery.OpenRecordset(DB_OPEN_SNAPSHOT)
If Not myRS.EOF Then
poolRecsContribInvalid = True
End If
poolRecsContribInvalid_xit:
debugStackPop
On Error Resume Next
Set myQuery = Nothing
myRS.Close
Set myRS = Nothing
Set thisDB = Nothing
Exit Function
poolRecsContribInvalid_err:
bugAlert ""
Resume poolRecsContribInvalid_xit
End Function
Private Sub poolRowBuild(theTransactionDate As Double, theIssuerName, theShares
As Double, theNAV As Double, theAccountNumberVast)
debugStackPush mModuleName & ": poolRowBuild"
On Error GoTo poolRowBuild_err
' 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$(theTransactionDate, "mm/dd/yyyy")
.Move Unit:=wdCell, Count:=1
.InsertAfter Text:=theIssuerName
.Move Unit:=wdCell, Count:=1
.InsertAfter Text:=Format$(theShares, "#")
.Move Unit:=wdCell, Count:=1
.InsertAfter Text:=Format$(theNAV, "Currency")
.Move Unit:=wdCell, Count:=1
myAmount = theShares * theNAV
.InsertAfter Text:=Format$(myAmount, "Currency")
.Move Unit:=wdCell, Count:=1
.InsertAfter Text:=theAccountNumberVast
End With
poolRowBuild_xit:
debugStackPop
On Error Resume Next
Exit Sub
poolRowBuild_err:
bugAlert ""
Resume poolRowBuild_xit
End Sub
Function secondaryAdvisersFetch(theNamedAccountID As Long) As String
14000 debugStackPush mModuleName & ": secondaryAdvisersFetch"
14001 On Error GoTo secondaryAdvisersFetch_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.SALUTATION]" instead of just
"myRS!SALUTATION"
' 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.QueryDefs("qryLetterSecondaryAdvisersFetch")
14040 myQuery.Parameters("theNamedAccountID") = theNamedAccountID
14050 Set myRS = myQuery.OpenRecordset(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_NAME],
myRS![tblName.MIDDLE_INITIAL], myRS![tblName.LAST_NAME], myRS![tblName.TITLE])
14140 myRS.MoveNext
14150 Loop
14200 End If
14999 secondaryAdvisersFetch = myAdvisers
secondaryAdvisersFetch_xit:
debugStackPop
On Error Resume Next
Set myQuery = Nothing
myRS.Close
Set myRS = Nothing
Set thisDB = Nothing
Exit Function
secondaryAdvisersFetch_err:
bugAlert ""
Resume secondaryAdvisersFetch_xit
End Function
'Private Sub showLetter()
'debugStackPush mModuleName & ": showLetter"
'On Error GoTo showLetter_err
'gWord.StartOfDocument
'gWord.hScroll (0)
'gWord.DocMaximize (1)
'gWord.AppMaximize (1)
'gWord.AppShow
'showLetter_xit:
' debugStackPop
' On Error Resume Next
' Exit Sub
'showLetter_err:
' bugAlert ""
' Resume showLetter_xit
'End Sub
'----------------------------------------------------------------
Function subCustCash(theLCI 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 CannotCreateLetter = "Cannot Create Letter"
5070 If poolRecsContribInvalid(theLCI.ContribID) Then
5071 DoCmd.Hourglass False
5072 MsgBox "Information for one or more pool allocations is incomplete.",
16, "CannotCreateLetter2"
5073 Else
5110 findAndReplace "<theSalutationNameTitle>", theLCI.Recipients, gWord
5120 findAndReplace "<theProgramAccountName>", theLCI.ProgramAccountName,
gWord
5130 findAndReplace "<theAddress>", theLCI.Address, gWord
5140 findAndReplace "<theGreeting>", theLCI.Greeting, gWord
5150 findAndReplace "<theCharityPhone800>", charityPhone800Get(), gWord
5170 findAndReplace "<thePrincipalSum>", Format$(theLCI.TotalAmountProceeds,
"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(theLCI As mLetterCustInfo) As Integer
18000 debugStackPush mModuleName & ": subCustMixed: "
18001 On Error GoTo subCustMixed_err
' 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 CannotCreateLetter = "Cannot Create Letter"
18050 Set thisDB = DBEngine(0)(0)
18070 If poolRecsContribInvalid(theLCI.ContribID) Then
18071 DoCmd.Hourglass False
18072 MsgBox "Information for one or more pool allocations is incomplete.",
118, "CannotCreateLetter2"
18073 Else
18100 Set myQuery =
thisDB.QueryDefs("qryLetterSubstLineItemsForPersonIdGroupNonCash")
18110 myQuery.Parameters("thePersonIdGroup") = theLCI.PersonIdGroup
18120 Set lineItemRS = myQuery.OpenRecordset(DB_OPEN_SNAPSHOT)
18130 If lineItemRS.BOF And lineItemRS.EOF Then
18131 bugAlert "No line items found for PersonIdGroup '" &
theLCI.PersonIdGroup & "'."
18140 Else
18150 Set myQuery = thisDB.QueryDefs("qryLetterSubstCashForPersonIdGroup")
18151 myQuery.Parameters("thePersonIdGroup") = theLCI.PersonIdGroup
18152 Set cashRS = myQuery.OpenRecordset(DB_OPEN_SNAPSHOT)
18153 If (cashRS.BOF And cashRS.EOF) Then
18154 bugAlert "Mixed letter, but no cash found. PersonIdGroup=' &
theLCI.PersonIdGroup & " '."
18155 Else
18200 myCash = cashRS!TotalCash
18220 findAndReplace "<theSalutationNameTitle>", theLCI.Recipients,
gWord 'DMN
18230 findAndReplace "<theAddress>", theLCI.Address, gWord 'DMN
18240 findAndReplace "<theGreeting>", theLCI.Greeting, gWord 'DMN
18250 findAndReplace "<theCashPortion>", Format$(myCash, "Currency"),
gWord 'DMN
18260 findAndReplace "<theProgramAccountName>",
theLCI.ProgramAccountName, gWord 'DMN
18270 findAndReplace "<theCharityPhone800>", charityPhone800Get(),
gWord 'DMN
18290 findText "%NumberSharesCertificates%", gWord
18356 With gWord.Selection
18257 .MoveRight Unit:=wdCharacter, Count:=3, Extend:=wdExtend
'Select entire row
18258 .Delete Unit:=wdCharacter, Count:=1 'Clear the literals from
table's single row
18420 lineItemRS.MoveLast
18430 If lineItemRS.RecordCount > 1 Then 'Add extra lines to table
as needed
18432 .MoveRight Unit:=wdCharacter, Count:=2, Extend:=wdExtend
18433 .InsertRows lineItemRS.RecordCount - 1
18434 .MoveLeft Unit:=wdCharacter, Count:=1
18536 End If 'We should now have required #of rows and have cursor
in top left cell
18440 lineItemRS.MoveFirst 'Populate the MS Word table
18450 Do Until lineItemRS.EOF
18452 .TypeText Text:=Format$(lineItemRS!NO_SHRS_QY, "#,###.000")
18454 .MoveRight Unit:=wdCell, Count:=1
18455 .TypeText Text:=lineItemRS!ISSR_NM
18457 lineItemRS.MoveNext
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_xit:
debugStackPop
On Error Resume Next
Set myQuery = Nothing
cashRS.Close
Set cashRS = Nothing
lineItemRS.Close
Set lineItemRS = Nothing
Set thisDB = Nothing
Exit Function
subCustMixed_err:
bugAlert ""
Resume subCustMixed_xit
End Function
Function subCustNonPr(theLCI As mLetterCustInfo) As Integer
23000 debugStackPush mModuleName & ": subCustNonPr: "
23001 On Error GoTo subCustNonPr_err
' 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 CannotCreateLetter = "Cannot Create Letter"
23070 If poolRecsContribInvalid(theLCI.ContribID) Then
23071 DoCmd.Hourglass False
23072 MsgBox "Information for one or more pool allocations is incomplete.",
16, "CannotCreateLetter2"
23073 Else
23090 findAndReplace "<theSalutationNameTitle>", theLCI.Recipients, gWord
'DMN
23100 findAndReplace "<theProgramAccountName>", theLCI.ProgramAccountName,
gWord 'DMN
23110 findAndReplace "<theDonor>", theLCI.Donor, gWord 'DMN
23120 findAndReplace "<theAddress>", theLCI.Address, gWord 'DMN
23130 findAndReplace "<theGreeting>", theLCI.Greeting, gWord 'DMN
23140 findAndReplace "<theAdvisers>", theLCI.Advisers, gWord 'DMN
23150 findAndReplace "<theCharityPhone800>", charityPhone800Get(), gWord 'DMN
23170 findAndReplace "<thePrincipalSum>", Format$(theLCI.TotalAmountProceeds,
"Currency"), gWord 'DMN
23370 subCustNonPr = True
23399 End If
23999 DoCmd.Hourglass False
subCustNonPr_xit:
debugStackPop
On Error Resume Next
Exit Function
subCustNonPr_err:
bugAlert ""
Resume subCustNonPr_xit
End Function
Private Function subCustSec(theLCI 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 CannotCreateLetter = "Cannot Create Letter"
6050 Set thisDB = DBEngine(0)(0)
6070 If poolRecsContribInvalid(theLCI.ContribID) Then
6071 DoCmd.Hourglass False
6072 MsgBox "Information for one or more pool allocations is incomplete.",
16, "CannotCreateLetter2"
6073 Else
6100 Set myQuery =
thisDB.QueryDefs("qryLetterSubstLineItemsForPersonIdGroup")
6110 myQuery.Parameters("thePersonIdGroup") = theLCI.PersonIdGroup
6120 Set lineItemRS = myQuery.OpenRecordset(DB_OPEN_SNAPSHOT)
6130 If lineItemRS.BOF And lineItemRS.EOF Then
6131 bugAlert "No line items found for PersonIdGroup '" &
theLCI.PersonIdGroup & "'."
6140 Else
6160 findAndReplace "<theSalutationNameTitle>", theLCI.Recipients, gWord
'DMN
6170 findAndReplace "<theProgramAccountName>", theLCI.ProgramAccountName,
gWord 'DMN
6180 findAndReplace "<theAddress>", theLCI.Address, gWord 'DMN
6190 findAndReplace "<theGreeting>", theLCI.Greeting, gWord 'DMN
6200 findAndReplace "<theCharityPhone800>", charityPhone800Get(), gWord
'DMN
6220 findAndReplace "<thePrincipalSum>",
Format$(theLCI.TotalAmountProceeds, "Currency"), gWord 'DMN
6255 findText "%NumberSharesCertificates%", gWord 'Locate
"Shares/Name of Security" table (only one row in table at this point...)
6356 With gWord.Selection
6257 .MoveRight Unit:=wdCharacter, Count:=3, Extend:=wdExtend 'Select
entire row
6258 .Delete Unit:=wdCharacter, Count:=1 'Clear
the literals from table's single row
6420 lineItemRS.MoveLast
6430 If lineItemRS.RecordCount > 1 Then 'Add
extra lines to table as needed
6432 .MoveRight Unit:=wdCharacter, Count:=2, Extend:=wdExtend
6433 .InsertRows lineItemRS.RecordCount - 1
6434 .MoveLeft Unit:=wdCharacter, Count:=1
6536 End If 'We
should now have required #of rows and have cursor in top left cell
6440 lineItemRS.MoveFirst 'Populate the MS Word table
6450 Do Until lineItemRS.EOF
6452 .TypeText Text:=Format$(lineItemRS!NO_SHRS_QY, "#,###.000")
6454 .MoveRight Unit:=wdCell, Count:=1
6455 .TypeText Text:=lineItemRS!ISSR_NM
6457 lineItemRS.MoveNext
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.Close
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_err
' 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
' .EditFindClearFormatting
' .EditReplaceClearFormatting
' .StartOfDocument
'.Selection.Find.ClearFormatting 'DMN
'.Selection.Find.Replacement.ClearFormatting 'DMN
'.Selection.HomeKey Unit:=wdStory, Extend:=wdMove 'DMN
.Visible = True
End With
tweakLetter1_xit:
debugStackPop
On Error Resume Next
Exit Sub
tweakLetter1_err:
bugAlert ""
Resume tweakLetter1_xit
End Sub
Private Sub tweakLetter2(theLetterName As String)
debugStackPush mModuleName & ": tweakLetter2"
On Error GoTo tweakLetter2_err
' Used by "letterBegin..." routines to make common document settings
With gWord
.ActiveDocument.Save
.Selection.HomeKey Unit:=wdStory, Extend:=wdMove
.ActiveWindow.HorizontalPercentScrolled = 0
.ActiveWindow.WindowState = wdWindowStateMaximize
.WindowState = wdWindowStateMaximize
.Visible = True
.Activate
End With
tweakLetter2_xit:
debugStackPop
On Error Resume Next
Exit Sub
tweakLetter2_err:
bugAlert ""
Resume tweakLetter2_xit
End Sub
Private Function wordBegin(theModelName) 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("tblPerson") & "\Models"
3010 LetterPath = pathDatDbGet("tblPerson") & "\Letters"
On Error Resume Next
MkDir LetterPath
On Error GoTo wordBegin_err
3020 dosName = Format$(recordNumberNextGet("LetterNumber"), "00000000") & ".DOC"
wordBegin_loop:
3390 If (gWord Is Nothing) Or (userClosedWord = 1) Then
3391 Set gWord = CreateObject("Word.Application.8")
3392 End If
3395 problemPath = modelPath & "\" & theModelName
3400 gWord.ChangeFileOpenDirectory (modelPath) 'DMN
3401 gWord.Documents.Open (theModelName)
3405 problemPath = LetterPath & "\" & theModelName
3410 gWord.ChangeFileOpenDirectory (LetterPath) 'DMN
3411 gWord.ActiveDocument.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, mRpcServerUnavailable
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
