document processing

W

woody

ok,
access database contains company names, addresses,
document security keys

document A is a company garauntee letter, 1 page document,
has placeholders in it using the naming convention of
[datafieldname], [date], [certificationcodekey], etc

goal is to create document b, that has 1 page for every
company record that is processed.

so user gets a list of companies to choose from, selects
all that they desire and press teh print letter key.

the program should then:
1) open document a
2) create new document b
3) insert contents of a into b
4) read a record from the database
5) search and replace the placeholders with data from teh
database and with program generated values
6) go to end of document b, insert page break
return to step3 until no more records to process.

when i try
dim documenta as document
set documenta = document.open ("GaraunteeLetter")
i get either err 53, file not found or 429 activex cannot
create the object.

this is driving me nuts.

thanks
Woody
 
D

Doug Robbins - Word MVP

Hi Woody,

I would do it with an Access Report.

Please respond to the newsgroups for the benefit of others who may be
interested.

Hope this helps
Doug Robbins - Word MVP
 
W

woody

if i knew how to do the program generated values and how
to flag the processed records from access i would, in 1
place in the document i have to include history, its easy
enough to do with vb... i guess if i cant do it with word
i will try thru common dialog/print option. not as
sophisticated or as pretty but i know how to make it work.

thanks

Woody
-----Original Message-----
Hi Woody,

I would do it with an Access Report.

Please respond to the newsgroups for the benefit of others who may be
interested.

Hope this helps
Doug Robbins - Word MVP
woody said:
ok,
access database contains company names, addresses,
document security keys

document A is a company garauntee letter, 1 page document,
has placeholders in it using the naming convention of
[datafieldname], [date], [certificationcodekey], etc

goal is to create document b, that has 1 page for every
company record that is processed.

so user gets a list of companies to choose from, selects
all that they desire and press teh print letter key.

the program should then:
1) open document a
2) create new document b
3) insert contents of a into b
4) read a record from the database
5) search and replace the placeholders with data from teh
database and with program generated values
6) go to end of document b, insert page break
return to step3 until no more records to process.

when i try
dim documenta as document
set documenta = document.open ("GaraunteeLetter")
i get either err 53, file not found or 429 activex cannot
create the object.

this is driving me nuts.

thanks
Woody
Click to expand...


.
Click to expand...
 
W

woody

wrote the whole thing over as vba in the host document.
discovered some interesting things.

1) you cant say delete unit:= page.

2) it actually works better to insert the new material in
front of the finished section rather than behind. I cant
get Find to go to a specific page but it will always find
wdgotofirstpage.

3) .filter property wont work on ado set to complex sql
query ie connection = "select * where x= y, z = a, b = c"

4) even though forms editor will let you set an ado souce
on a form its practically worth less since you cant early
bind or late bind to it..so why does it let you select it?

5) all lists, combos and datagrids must be late bind. good
thing is that properties that arent exposed in vb are thru
vba.. interesting.

how can set a range for a find/replace operation to just
the first page? i figure if i can set in a raneg then i
dont have to worry so much about processing time when
doing a couple of hundred records with over 20 fields each.

thanx

Woody
 
W

woody

Thanx I will use the bookmark tip.

if i use edit replace it will change the copy of the
document that i am holding on teh clipboard? if i do that
then i dont have a fresh unchanged copy to insert into the
document.

i am using a single document method now.

i open document A,
do a save as to make a new copy of teh document
copy all contents of new document to clibboard,
replace placeholders with values,
then for every record in database after the first i ;
go to top of page 1
insert page break
go to top of (new) page 1
paste clipboard contents
replace placeholders with values

after completion save the new document.

if interested i can put teh code here buts its a lengthy
and probably not good form.
 
W

woody

ok..its long so here it is..
-----------------------------------------------------------
Option Explicit

Dim conLetters As Connection
Dim recLetters As Recordset

Const clrWhite As Variant = &H80000005
Const clrRed As Variant = &H8080FF
Const clrYellow As Variant = &HC0FFFF
Const clrBlue As Variant = &HFFFFC0
Const clrblack As Variant = &H0&

Const MARRIED_WORD As String = "[MARRIED]"
Const GENDER_WORD As String = "[GENDER]"
Const SCHEDULE_WORD As String = "[SCHEDULE]"
Const BEGIN_WORD As String = "[BGNDATE]"
Const END_WORD As String = "[ENDDATE]"

Dim dblStart As Double
Dim strSQLCommand As String
Dim strCode As String

Const SELECT_SQL As String = "SELECT
Applicant_Table.Applicant_Key,
Applicant_Table.Applicant_Name,
Applicant_Table.Applicant_Sex,
Applicant_Table.Applicant_Marital, " _

& "Applicant_Table.Applicant_Dob,
Applicant_Table.Applicant_PlaceBirth,
Applicant_Table.Applicant_Hire_Company,
Applicant_Table.Applicant_Hire_Position, " _

& "Applicant_Table.Assigned_Agent,
Applicant_Table.Assigned_Principle,
Applicant_Table.Applicant_Scheduled,
Applicant_Table.Applicant_Date_Schedules, " _

& "Applicant_Table.Applicant_Interviewed,
Applicant_Table.Applicant_Status,
Applicant_Table.Applicant_PassportNum,
Applicant_Table.Applicant_VisaType,
Agent_Table.Agent_Name, " _
& "Agent_Table.Agent_Address,
Agent_Table.Agent_PhoneNumber,
Agent_Table.Agent_FaxNumber,
Principle_Table.Principle_ContactName,
Principle_Table.Principle_Name, " _

& "Principle_Table.Principle_Address,
Principle_Table.Principle_PhoneNumber,
Principle_Table.Principle_FaxNumber " _
& "FROM Principle_Table INNER
JOIN " _
& "(Agent_Table INNER JOIN " _
& "Applicant_Table ON
Agent_Table.Agent_Key = Applicant_Table.Assigned_Agent) " _
& "ON
Principle_Table.Principle_key =
Applicant_Table.Assigned_Principle"
Const MARRIED_SQL As String
= "((Applicant_Table.Applicant_Marital='[MARRIED]'))"
Const GENDER_SQL As String
= "((Applicant_Table.Applicant_Sex='[GENDER]'))"
Const SCHEDULE_FLTR As String
= "Applicant_Table.Applicant_Scheduled='[SCHEDULE]'"
Const DATE_SQL As String
= "(Applicant_Table.Applicant_Dob = #[BGNDATE]# OR
Applicant_Table.Applicant_Dob = #[ENDDATE]#) OR
(Applicant_Table.Applicant_Dob > #[BGNDATE]# AND
Applicant_Table.Applicant_Dob < #[ENDDATE]#)"
Const SORT_SQL As String = "ORDER BY
Applicant_Table.Applicant_Name ASC"

Dim strDateSQL As String
Dim strGenderSQL As String
Dim strSchedFltr As String
Dim strMarrSql As String


Private Sub cmbGender_AfterUpdate()

' reset field color after it looses focus and store final
selected value
cmbGender.BackColor = clrWhite
If cmbGender.Text = "ALL" Then
strGenderSQL = ""
Else
strGenderSQL = Swap_Text(Trim(cmbGender.Text),
GENDER_SQL, GENDER_WORD)
End If

strSQLCommand = Assemble_SQL(SELECT_SQL, strGenderSQL,
strMarrSql, strDateSQL, SORT_SQL)
Change_Query (strSQLCommand)

End Sub

Private Sub cmbGender_Change()

' store final selected value
cmbGender.Text = cmbGender.List(cmbGender.ListIndex)
If cmbGender.Text = "ALL" Then
strGenderSQL = ""
Else
strGenderSQL = Swap_Text(Trim(cmbGender.Text),
GENDER_SQL, GENDER_WORD)
End If

strSQLCommand = Assemble_SQL(SELECT_SQL, strGenderSQL,
strMarrSql, strDateSQL, SORT_SQL)
Change_Query (strSQLCommand)

End Sub

Private Sub cmbGender_Click()

' store final selected value
If cmbGender.Text = "ALL" Then
strGenderSQL = ""
Else
strGenderSQL = Swap_Text(Trim(cmbGender.Text),
GENDER_SQL, GENDER_WORD)
End If

strSQLCommand = Assemble_SQL(SELECT_SQL, strGenderSQL,
strMarrSql, strDateSQL, SORT_SQL)
Change_Query (strSQLCommand)

End Sub

Private Sub cmbGender_Enter()

cmbGender.BackColor = clrYellow

End Sub

Private Sub cmbMarried_Change()

' store final selected value
cmbMarried.Text = cmbMarried.List(cmbMarried.ListIndex)
If cmbMarried.Text = "ALL" Then
strMarrSql = ""
Else
strMarrSql = Swap_Text(Trim(cmbMarried.Text),
MARRIED_SQL, MARRIED_WORD)
End If

strSQLCommand = Assemble_SQL(SELECT_SQL, strGenderSQL,
strMarrSql, strDateSQL, SORT_SQL)
Change_Query (strSQLCommand)

End Sub

Private Sub cmbMarried_Click()

' final selected value
If cmbMarried.Text = "ALL" Then
strMarrSql = ""
Else
strMarrSql = Swap_Text(Trim(cmbMarried.Text),
MARRIED_SQL, MARRIED_WORD)
End If

strSQLCommand = Assemble_SQL(SELECT_SQL, strGenderSQL,
strMarrSql, strDateSQL, SORT_SQL)
Change_Query (strSQLCommand)

End Sub

Private Sub cmbMarried_Enter()

cmbMarried.BackColor = clrYellow

End Sub

Private Sub cmbMarried_AfterUpdate()

' reset field color after it looses focus and store final
selected value
cmbMarried.BackColor = clrWhite
If cmbMarried.Text = "ALL" Then
strMarrSql = ""
Else
strMarrSql = Swap_Text(Trim(cmbMarried.Text),
MARRIED_SQL, MARRIED_WORD)
End If

strSQLCommand = Assemble_SQL(SELECT_SQL, strGenderSQL,
strMarrSql, strDateSQL, SORT_SQL)
Change_Query (strSQLCommand)

End Sub

Private Sub cmdDoIt_Click()
On Error Resume Next

Const SERIAL_CONST As String = "[SERIALNUMBER]"

Const CURRDATE_CONST As String = "[TODAY]"
Const BIRTHDATE_CONST As String = "[DOB]"
Const BIRTHPLACE_CONST As String = "[POB]"
Const VISA_CONST As String = "[VISA]"
Const NAME_CONST As String = "[APPLICANTNAME]"
Const COMPANY_CONST As String = "[HIRECOMPANY]"
Const POSITION_CONST As String = "[HIREPOSITION]"
Const PASSPORT_CONST As String = "[PASSPORT]"

Const PRIORISSUE_CONST As String = "[PRIORISSUE]"

Const USNAME_CONST As String = "[USNAME]"
Const USADDRESS_CONST As String = "[USADDRESS]"
Const USPHONE_CONST As String = "[USPHONE]"
Const USFAX_CONST As String = "[USFAX]"
Const USCONTACT_CONST As String = "[USCONTACT]"

Const PRNAME_CONST As String = "[PRNAME]"
Const PRADDRESS_CONST As String = "[PRADDRESS]"
Const PRPHONE_CONST As String = "[PRPHONE]"
Const PRFAX_CONST As String = "[PRFAX]"
Const PRCONTACT_CONST As String = "[PRCONTACT]"
Const KEY_WORD As String = "[KEY]"

Const EMBASSY_LETTER As String = "Embassy Scheduling
Letter for "
Const SQLPRIOR As String = "SELECT * FROM
Applicant_Prior_Table where
Applicant_Prior_Table.Prior_key = '[KEY]'"
Const SQLUPDATE As String = "UPDATE Applicant_Table
SET Applicant_Scheduled = 'Y', Applicant_Date_Schedules = #
[TODAY]# WHERE Applicant_Key = [KEY]"

Dim intStart As Integer

Dim bolStarted As Boolean
Dim bolPage As Boolean

Dim curDate As Date

Dim dblBgn As Double
Dim dblEnd As Double
Dim DblRange As Double

Dim newDocName As String
Dim strPrior As String
Dim strSqlPrior As String
Dim strSqlUpdate As String

Dim conPrior As Connection
Dim recPrior As Recordset

Dim conUpdate As Connection
Dim recUpdate As Recordset

' establish beginning of selected range
If grdLetters.Row < grdLetters.RowSel Then
dblBgn = grdLetters.Row
dblEnd = grdLetters.RowSel
Else
dblEnd = grdLetters.Row
dblBgn = grdLetters.RowSel
End If

DblRange = (dblEnd - dblBgn) + 1

If DblRange < 1 Then
Display_Message "Must select at least 1 person to
Schedule", "e"
Exit Sub
End If

intStart = 0

curDate = Date

lblStatus.Visible = False
lblStatus.Enabled = False
barProg.Visible = True
barProg.Enabled = True
grdLetters.Visible = False

barProg.Max = DblRange
barProg.Min = 0
barProg.Value = 0

' make new document name using old name and current
date
newDocName = Trim(EMBASSY_LETTER) & " " &
FormatDateTime(curDate, vbShortDate)
' remove slashes from name, replace with dashes
Mid(newDocName, InStr(1, newDocName, "/"), 1) = "-"
Mid(newDocName, InStr(1, newDocName, "/"), 1) = "-"

'save as method, creates new document from old
template document
Save_Document newDocName

' grab entire document contents as it will be repeated
x times
Selection.WholeStory
Selection.Copy
bolPage = False
'start at beginning of user selections
'----------------------------------------------------------
---------------
For DblRange = dblBgn To dblEnd Step 1
'set progress bar
barProg.Value = barProg.Value + 1

' need new page for processing?
If bolPage = True Then
'position to very first position in document
Selection.GoTo what:=wdGoToPage,
which:=wdGoToFirst
Selection.GoTo what:=wdGoToLine,
which:=wdGoToFirst

'insert a page break
Selection.InsertBreak Type:=wdPageBreak
'go to the inserted blank page
Selection.GoTo what:=wdGoToPage,
which:=wdGoToFirst
'paste in new copy of document
Selection.Paste
End If

'put variables into place holders
Replace_Variables SERIAL_CONST, Generate_Serial_Number
(curDate, dblStart)
Replace_Variables CURRDATE_CONST, FormatDateTime
(curDate, vbLongDate)
Replace_Variables BIRTHDATE_CONST, grdLetters.TextMatrix
(DblRange, 4)
Replace_Variables BIRTHPLACE_CONST, grdLetters.TextMatrix
(DblRange, 5)
Replace_Variables VISA_CONST, grdLetters.TextMatrix
(DblRange, 15)
Replace_Variables NAME_CONST, grdLetters.TextMatrix
(DblRange, 1)
Replace_Variables PASSPORT_CONST, grdLetters.TextMatrix
(DblRange, 14)
Replace_Variables COMPANY_CONST, grdLetters.TextMatrix
(DblRange, 6)
Replace_Variables POSITION_CONST, grdLetters.TextMatrix
(DblRange, 7)

Replace_Variables USNAME_CONST, grdLetters.TextMatrix
(DblRange, 17)
Replace_Variables USADDRESS_CONST, grdLetters.TextMatrix
(DblRange, 18)
Replace_Variables USPHONE_CONST, grdLetters.TextMatrix
(DblRange, 19)
Replace_Variables USFAX_CONST, grdLetters.TextMatrix
(DblRange, 20)
Replace_Variables USCONTACT_CONST, grdLetters.TextMatrix
(DblRange, 16)

Replace_Variables PRNAME_CONST, grdLetters.TextMatrix
(DblRange, 22)
Replace_Variables PRADDRESS_CONST, grdLetters.TextMatrix
(DblRange, 23)
Replace_Variables PRPHONE_CONST, grdLetters.TextMatrix
(DblRange, 24)
Replace_Variables PRFAX_CONST, grdLetters.TextMatrix
(DblRange, 25)
Replace_Variables PRCONTACT_CONST, grdLetters.TextMatrix
(DblRange, 21)

'special processing goes here
strSqlPrior = Swap_Text(Trim(Str(grdLetters.TextMatrix
(DblRange, 0))), SQLPRIOR, KEY_WORD)
'open query to retrieve prior history, may be none or
multiple
Set conPrior = New Connection
conPrior.CursorLocation = adUseClient
conPrior.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data
Source=" & ActiveDocument.Path & "\H2b_Applicants.mdb;"

Set recPrior = New Recordset
recPrior.Open strSqlPrior, conPrior,
adOpenForwardOnly, adLockReadOnly
' clear out work area
strPrior = ""

Do While recPrior.EOF = False
' if date field is null(required field) then
no record
If IsNull(recPrior.Fields(1).Value) = False
Then
'if nothing in string just copy into place
If Len(Trim(strPrior)) = 0 Then
strPrior = strPrior & FormatDateTime
(recPrior.Fields(1).Value, vbShortDate)
strPrior = strPrior & ", " & Trim
(recPrior.Fields(2).Value)
Else
' stick it to backend after adding a
linebreak
strPrior = strPrior & vbCrLf
strPrior = strPrior & FormatDateTime
(recPrior.Fields(1).Value, vbShortDate)
strPrior = strPrior & " " & Trim
(recPrior.Fields(2).Value)

End If
End If

recPrior.MoveNext

Loop

recPrior.Close
Set recPrior = Nothing

conPrior.Close
Set conPrior = Nothing
'check if any history
If Len(Trim(strPrior)) = 0 Then
strPrior = "None"
End If
' put work string into document
Replace_Variables PRIORISSUE_CONST, strPrior

' update record flags with new status
strSqlUpdate = Swap_Text(Trim(grdLetters.TextMatrix
(DblRange, 0)), SQLUPDATE, KEY_WORD)
strSqlUpdate = Swap_Text(FormatDateTime(curDate,
vbShortDate), strSqlUpdate, CURRDATE_CONST)

Set conUpdate = New Connection
conUpdate.CursorLocation = adUseClient
conUpdate.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data
Source=" & ActiveDocument.Path & "\H2b_Applicants.mdb;"

Set recUpdate = New Recordset
recUpdate.Open strSqlUpdate, conUpdate, adOpenDynamic,
adLockPessimistic

conUpdate.BeginTrans
conUpdate.Execute strSQLCommand, 1
conUpdate.CommitTrans

recUpdate.Close
Set recUpdate = Nothing

conUpdate.Close
Set conUpdate = Nothing

'update sequential counter
dblStart = dblStart + 1
' need new page now
bolPage = True

Next DblRange

CleanUp_Processing:
'save all new pages
Save_Document newDocName
' save count of documents produced
Put_Starting_Count dblStart
'display print preview screen
ActiveDocument.ActiveWindow.ActivePane.Document.PrintPrevie
w
' stop vb program
End

End Sub

Private Sub grdLetters_Enter()

grdLetters.BackColor = clrYellow

End Sub

Private Sub grdLetters_AfterUpdate()

grdLetters.BackColor = clrWhite

Count_Selection

End Sub

Private Sub cmdEndAll_Click()

UserForm_Terminate

End Sub

Private Sub optAllAge_Click()

' final selected value

If optAllAge = True Then
optOld = False
optYoung = False
strDateSQL = ""
strSQLCommand = Assemble_SQL(SELECT_SQL,
strGenderSQL, strMarrSql, strDateSQL, SORT_SQL)
Change_Query strSQLCommand
End If


End Sub

Private Sub optAllAge_Enter()

optAllAge.BackColor = clrYellow

End Sub

Private Sub optAllAge_AfterUpdate()

optAllAge.BackColor = clrBlue

End Sub

Private Sub optInitial_Click()

' store final selected value

If optInitial = True Then
OptReschedule = False
strSchedFltr = Swap_Text("N", SCHEDULE_FLTR,
SCHEDULE_WORD)
strSQLCommand = Assemble_SQL(SELECT_SQL, strGenderSQL,
strMarrSql, strDateSQL, SORT_SQL)
Change_Query strSQLCommand
End If

End Sub

Private Sub optInitial_Enter()

optInitial.BackColor = clrYellow

End Sub

Private Sub optInitial_AfterUpdate()

optInitial.BackColor = clrBlue

End Sub

Private Sub optOld_Click()

' store final selected value
' if wanting over 30, must choose applicants born from
' beginning of last century to a date 30 years(360 months)
before today
If optOld = True Then
optAllAge = False
optYoung = False
strDateSQL = Swap_Text("01/01/1901", DATE_SQL,
BEGIN_WORD)
strDateSQL = Swap_Text("01/01/1901", strDateSQL,
BEGIN_WORD)
strDateSQL = Swap_Text((DateAdd("m", -360, Date)),
strDateSQL, END_WORD)
strDateSQL = Swap_Text((DateAdd("m", -360, Date)),
strDateSQL, END_WORD)
strSQLCommand = Assemble_SQL(SELECT_SQL,
strGenderSQL, strMarrSql, strDateSQL, SORT_SQL)
Change_Query strSQLCommand
End If

End Sub

Private Sub optOld_Enter()

optOld.BackColor = clrYellow

End Sub

Private Sub optOld_AfterUpdate()

optOld.BackColor = clrBlue

End Sub

Private Sub optReSchedule_Click()

' store final selected value
If OptReschedule = True Then
optInitial = False
strSchedFltr = Swap_Text("Y", SCHEDULE_FLTR,
SCHEDULE_WORD)
strSQLCommand = Assemble_SQL(SELECT_SQL, strGenderSQL,
strMarrSql, strDateSQL, SORT_SQL)
Change_Query strSQLCommand
End If

End Sub

Private Sub optReSchedule_Enter()

OptReschedule.BackColor = clrYellow

End Sub

Private Sub optReSchedule_AfterUpdate()

OptReschedule.BackColor = clrBlue

End Sub

Private Sub optYoung_Click()

' store final selected value
' if young applicanst are selected must look for born
after date 30 years
' before now until today
If optYoung = True Then
optOld = False
optAllAge = False
strDateSQL = Swap_Text(DateAdd("m", -360, Date),
DATE_SQL, BEGIN_WORD)
strDateSQL = Swap_Text(DateAdd("m", -360, Date),
strDateSQL, BEGIN_WORD)
strDateSQL = Swap_Text(Str(Date), strDateSQL,
END_WORD)
strDateSQL = Swap_Text(Str(Date), strDateSQL,
END_WORD)
strSQLCommand = Assemble_SQL(SELECT_SQL,
strGenderSQL, strMarrSql, strDateSQL, SORT_SQL)
Change_Query strSQLCommand
End If

End Sub

Private Sub optYoung_Enter()

optYoung.BackColor = clrYellow

End Sub

Private Sub optYoung_AfterUpdate()

optYoung.BackColor = clrBlue

End Sub

Private Sub Display_Message(strMessage As String, strLevel
As String)

' show option/warning/error message
lblStatus.Enabled = True
lblStatus.Visible = True

barProg.Enabled = False
barProg.Visible = False

lblStatus.Caption = Trim(strMessage)

Select Case strLevel
Case Is = "w"
Beep
lblStatus.BackColor = clrBlue
lblStatus.ForeColor = clrblack
Case Is = "e"
Beep
lblStatus.BackColor = clrWhite
Beep
lblStatus.ForeColor = clrRed
Beep
End Select

End Sub

Private Function Assemble_SQL(SELECT_SQL As String,
strGenderSQL As String, strMarrSql As String, strDateSQL
As String, SORT_SQL As String)

Dim strCommand As String
Dim strwrk As String
Dim bolWhere As Boolean

bolWhere = False
strCommand = Trim(SELECT_SQL)

' if date range selected it ust go first since complex
selection
If Len(Trim(strDateSQL)) > 0 Then
If bolWhere = True Then
strwrk = Trim(strCommand) & " AND " & Trim
(strDateSQL)
strCommand = strwrk
Else
strwrk = Trim(strCommand) & " WHERE " & Trim
(strDateSQL)
strCommand = strwrk
bolWhere = True
End If
End If

If Len(Trim(strGenderSQL)) > 0 Then
If bolWhere = True Then
strwrk = Trim(strCommand) & " AND " & Trim
(strGenderSQL)
strCommand = strwrk
Else
strwrk = Trim(strCommand) & " WHERE " & Trim
(strGenderSQL)
strCommand = strwrk
bolWhere = True
End If
End If

If Len(Trim(strMarrSql)) > 0 Then
If bolWhere = True Then
strwrk = Trim(strCommand) & " AND " & Trim
(strMarrSql)
strCommand = strwrk
Else
strwrk = Trim(strCommand) & " WHERE " & Trim
(strMarrSql)
strCommand = strwrk
bolWhere = True
End If
End If

strwrk = Trim(strCommand) & " " & Trim(SORT_SQL)
strCommand = strwrk

Assemble_SQL = strCommand

End Function

Private Function Swap_Text(strReplace As String, StrInput
As String, strFind As String)

Dim dblBgn As Double
Dim dblEnd As Double
Dim dblLen As Double
Dim dblStr As Double

Dim str1st As String
Dim strLst As String

dblStr = InStr(1, StrInput, strFind)

str1st = Left(StrInput, (dblStr - 1)) & Trim(strReplace)
dblBgn = dblStr + Len(strFind)

dblLen = Len(StrInput)
dblEnd = (dblLen - dblBgn) + 1

strLst = Right(StrInput, dblEnd)

Swap_Text = str1st & strLst

End Function

Private Sub Change_Query(SqlCommand As String)
On Error Resume Next

Dim bolLoad As Boolean
Dim lngLooper As Long
Dim intLooper As Integer

' clear screen grid
grdLetters.ClearStructure
grdLetters.Clear
grdLetters.Rows = 1

Set conLetters = New Connection
conLetters.CursorLocation = adUseClient
conLetters.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data
Source=" & ActiveDocument.Path & "\H2b_Applicants.mdb;"

Set recLetters = New Recordset
recLetters.Open SqlCommand, conLetters, adOpenForwardOnly,
adLockReadOnly

' filter property doesnt work!!!!!!!!!!!!!!!!!!!!!!!!
'If strSchedFltr = "" Then
' recLetters.Filter = adFilterNone
' Else
' recLetters.Filter = strSchedFltr
' If Err <> 0 Then
' MsgBox Err.Number & " " & Err.Description
' End If
' End If

lngLooper = 0
grdLetters.Rows = recLetters.RecordCount + 1

' get record set
recLetters.MoveFirst

Do While recLetters.EOF = False

' check for if prior processed
If OptReschedule.Value = True Then
If recLetters.Fields("Applicant_Scheduled") = "Y"
Then
bolLoad = True
Else
bolLoad = False
End If
Else
If IsNull(recLetters.Fields("Applicant_Scheduled")) =
True _
Or recLetters.Fields("Applicant_Scheduled") = "N" Then
bolLoad = True
Else
bolLoad = False
End If
End If

If bolLoad = True Then
lngLooper = lngLooper + 1
' put into first column of row x of screen
grdLetters.AddItem recLetters.Fields(0).Value,
lngLooper
' load rest of values to screen
For intLooper = 1 To 24 Step 1

If IsNull(recLetters.Fields(intLooper).Value)
= False Then
grdLetters.TextMatrix(lngLooper, intLooper)
= recLetters.Fields(intLooper).Value
Else
grdLetters.TextMatrix(lngLooper,
intLooper) = " "
End If
Next intLooper
' format column 4 as date
grdLetters.TextMatrix(lngLooper, 4) = FormatDateTime
(recLetters.Fields(4).Value, vbShortDate)

End If

' get next record
recLetters.MoveNext
' continue looping till done
Loop

' set widths of nondisplayed columns to 0(dont want to
display)
For intLooper = 6 To 25 Step 1
grdLetters.ColWidth(intLooper) = 0
Next intLooper

grdLetters.ColWidth(0) = 0
grdLetters.ColWidth(1) = 1900
grdLetters.ColWidth(2) = 750
grdLetters.ColWidth(3) = 850
grdLetters.ColWidth(4) = 900
grdLetters.ColWidth(5) = 3000

' set column headers
grdLetters.TextMatrix(0, 1) = "Applicant Name"
grdLetters.TextMatrix(0, 2) = "Gender"
grdLetters.TextMatrix(0, 3) = "Mar.Status"
grdLetters.TextMatrix(0, 4) = "Birth Date"
grdLetters.TextMatrix(0, 5) = "Place of Birth"
grdLetters.Rows = lngLooper + 1
grdLetters.FixedRows = 1

' shows status message on screen
If grdLetters.Rows - 1 > 0 Then
Display_Message "Selection is " & Trim(Str
(grdLetters.Rows - 1)) & " Applicants", "w"
Else
Display_Message "None Selected", "w"
End If

End Sub

Private Sub Count_Selection()

Dim dblBgn As Double
Dim dblEnd As Double
Dim DblRange As Double

' establish beginning of selected range
dblBgn = grdLetters.Row
'establish ending of selected range
dblEnd = grdLetters.RowSel
' number of letters to print is .....
If dblEnd > dblBgn Then
DblRange = (dblEnd - dblBgn) + 1
Else
DblRange = (dblBgn - dblEnd) + 1
End If

If DblRange > 0 Then
Display_Message "Selection is " & Trim(Str(DblRange))
& " Applicants", "w"
Else
Display_Message "None Selected", "w"
End If

End Sub
Private Function Get_Starting_Count()

Dim fs1 As Object
Dim fs2 As Object
Dim ts As Object
Dim strRec As String

' get stored sequential count of generated letters
Set fs1 = CreateObject("Scripting.FileSystemObject")
Set fs2 = fs1.GetFile(ActiveDocument.Path & "\"
& "start.txt")
Set ts = fs2.openastextstream(1, -2)
strRec = ts.ReadLine

ts.Close

Get_Starting_Count = CDbl(Trim(strRec))

End Function

Private Sub Put_Starting_Count(EndCount As Double)

Dim fs1 As Object
Dim fs2 As Object

' store updated count of generated letters
Set fs1 = CreateObject("Scripting.FileSystemObject")
Set fs2 = fs1.createtextfile(ActiveDocument.Path & "\"
& "start.txt", True)

fs2.WriteLine Str(EndCount)

fs2.Close

End Sub

Private Function Generate_Serial_Number(inDate As Date,
inCount As Double)
Const ALPHA_CONST As String = "JABCDEFGHIJ"

Dim StrDate As String
Dim intNdx As Integer
Dim strCode As String
Dim intWrk As Integer
Dim strwrk As String

'build simple code key using date as base
StrDate = Str(Year(inDate)) _
& Format((Month(inDate)), "0#") _
& Format((Day(inDate)), "0#")

StrDate = Trim(StrDate)

For intNdx = 1 To 8 Step 1

strwrk = Mid(StrDate, intNdx, 1)

intWrk = CInt(strwrk)
intWrk = intWrk + 1

strCode = strCode & Mid(ALPHA_CONST, intWrk, 1)

Next intNdx

Generate_Serial_Number = strCode & "-" & Trim(Str(inCount))

End Function

Sub Replace_Variables(StrKeyWord As String, StrValue As
String)
On Error Resume Next

' positio to current document page
Selection.GoTo what:=wdGoToPage, which:=wdGoToFirst

'preform find and replace
ActiveDocument.Bookmarks("\page").Range.Select

Selection.Find.Execute findtext:=StrKeyWord, _
MatchCase:=True, _
MatchWholeWord:=True, _
MatchWildcards:=False, _
MatchSoundsLike:=False, _
Forward:=True, _
replacewith:=Trim(StrValue)

End Sub

Private Sub UserForm_Initialize()

dblStart = Get_Starting_Count

' build pick boxe values
cmbGender.AddItem "ALL", 0
cmbGender.AddItem "FEMALE", 1
cmbGender.AddItem "MALE", 2
cmbGender.ListIndex = 0
cmbGender.Text = "ALL"

cmbMarried.AddItem "ALL", 0
cmbMarried.AddItem "MARRIED", 1
cmbMarried.AddItem "SINGLE", 2
cmbMarried.ListIndex = 0
cmbMarried.Text = "ALL"

strSQLCommand = SELECT_SQL & " " & SORT_SQL

Change_Query strSQLCommand

End Sub

Private Sub UserForm_Terminate()

recLetters.Close
Set recLetters = Nothing

conLetters.Close
Set conLetters = Nothing

Application.Quit

End

End Sub

Private Sub Save_Document(strFileName As String)

ActiveDocument.SaveAs FileName:=ActiveDocument.Path
& "\" & strFileName, _
FileFormat:=wdFormatDocument, LockComments:=False,
Password:="", _
AddToRecentFiles:=True, WritePassword:="",
ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False,
SaveNativePictureFormat:=False, SaveFormsData _
:=False, SaveAsAOCELetter:=False

End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

VBA - exporting serial letters to single documents 0
Pointers for some google searches? Batch document processing 0
Are you documenting all your business processes repeatable actions?? 0
Header usage 5
Dropdown selection displays a shape with text. 6
Formatting document for multiple headers and different pages 3
Creating a master document made up of several linked source docume 5
Insert pictures in word document - search and replace with a picture 2

Top