Adding a new value to listbox Results

Hello people,

I'm having a bit (it has been stalling me for days) of a problem with a form. I have a bound form used to enter Counselling Sessions that health workers have with their patients...

Every patient in the programme (ARV AIDS medication is Southern Africa) has an introductory visit (Purpose = 1). Following the introduction, the patient has atleast 1, but often many On-going visits (Purpose = 2). Finally, when the person is deemed Eligible there is a Final visit (Purpose = 3).

What I want is that the user selects the Patient (through field HAARTNumber) and then the system should look up the previous visit records. If none are found, return value = 0, so Purpose automatically becomes 1.

If 1 is found the system will make the new visit 2.

If 2 are found the user can select either On-going (2) or Final (3) from a combobox.

If 3 is found no more records can be added in this table for this HAARTNumber.

I have tried using DMax and DLookup but couldn't get them to work. Someone gave me the following coding, but I cannot get this to work either...

Private Sub HAARTNumber_Click()
Dim db As Database
Dim rs As Recordset
Dim sqlstr As String
Set db = CurrentDb
sqlstr = "SELECT [Table Sheet 4 CounSess].Haartnumber, [Table Sheet 4 CounSess].purpose" & " FROM [Table Sheet 4 CounSess]" & " WHERE ((([Table Sheet 4 CounSess].Haartnumber=" & Me.HAARTNumber & "))" & " ORDER BY [Table Sheet 4 CounSess].purpose DESC;"
Set rs = db.OpenRecordset(sqlstr, dbOpenSnapshot)
If rs.BOF = True And rs.EOF = True Then
Me.Purpose = 1
'There are no prior records so the record type is forced to 1
ElseIf rs.Purpose = 3 Then
MsgBox ("This patient has already ad a final councelling session, no further session may be added")
'This patient has left the program
Else
Me.Purpose.Enabled = True
'Now we know that the patient has at least a record type 1 and we can allow them choose 2 or 3 from a listbox or checkbox or etc.. by unlocking the control or making it visible.
End If
rs.Close
Set db = Nothing
End Sub

The debug comes up on two places:
ElseIf rs.Purpose = 3 Then
* the system does not recoqnise rs.purpose

and:
Set rs = db.OpenRecordset(sqlstr, dbOpenSnapshot)
* the whole command is not accepted

Could this be because my database is not running in SQL?

Does anyone have any suggestions how I may fix the code or how to best tackle this problem?!?

HTBH - Hope to be Helped!!!!

Cheers,
Daniel.

Hi, I found this code on another forum for a postcode lookup form:

Code: Private Sub Text0_AfterUpdate() Me.List2.RowSource = "" Dim Pcode, sStr As String 'First up, Format the postcode Pcode = UCase(Replace(Text0, " ", "")) Select Case Len(Pcode) Case 5 Pcode = Mid(Pcode, 1, 2) & " " & Mid(Pcode, 3, 3) Case 6 Pcode = Mid(Pcode, 1, 3) & " " & Mid(Pcode, 4, 3) Case 7 Pcode = Mid(Pcode, 1, 4) & " " & Mid(Pcode, 5, 3) End Select 'Now create the search string 'http://www.192.com/places/ab/ab10-1/ab10-1an/ sStr = "http://www.192.com/places/" For a = 1 To Len(Pcode) If IsNumeric(Mid(Pcode, a, 1)) Then sStr = sStr & Mid(Pcode, 1, a - 1) & "/" a = Len(Pcode) End If Next a sStr = sStr & Mid(Replace(Pcode, " ", "-"), 1, InStr(Pcode, " ") + 1) & "/" sStr = sStr & Replace(Pcode, " ", "-") & "/" 'Now I create a WinHTTP request to get the information from the server Dim winReq As WinHttpRequest Dim HTM, Address As Variant Dim Add1, Add2, Add3, Add4 As String Dim sCount As Integer Set winReq = New WinHttpRequest With winReq .Open "GET", sStr, False .Send HTM = Split(Replace(.ResponseText, """", "'"), "") > 0 Then 'You can the assign the address to a listbox as below Me.List2.AddItem (Replace(i, "td class='address'>", "")) 'Or you can split the address in to variables Address = Split((Replace(i, "td class='address'>", "")), ",") sCount = 0 For Each j In Address sCount = sCount + 1 Next Select Case sCount Case 3 Add1 = Address(0) Add4 = Address(1) Case 4 Add1 = Address(0) Add3 = Address(1) Add4 = Address(2) Case 5 Add1 = Address(0) Add2 = Address(1) Add3 = Address(2) Add4 = Address(3) Case 6 Add1 = Address(0) & " " & Address(1) Add2 = Address(2) Add3 = Address(3) Add4 = Address(4) End Select 'Put code here to assign these variables to anything you like End If Next End Sub The result appears as follows:



What I'm wanting to do is this:
The house number and the street name need to go in a field called Street on the form frmCustomerDetailsThe town/city needs to go in a field called Town/city on the same formThe region needs to go in a field called Region on the same formThe postcode needs to go in a field called Postcode on the same form.
However, the Postcode field has an input mask L?09 0LL, and so I am questioning whether or not this will work efficiently with all postcodes unless I remove the input mask?

Thanks in advance for any help

I have a listbox on a form which displays data based on the value of a textbox. I requery the listbox every second or so using the timer event on the form. What I want to accomplish is that whenever the listbox changes, i.e. a new row is added to the list, a subsequent action (in my case, a beep) occurs.

I tried the afterupdate property of the listbox but that doesnt seem to work. The listbox is unbound.

ANy help would be appreciated....

So I am back with another (what I hope is a simple solution). I understand how to pass text boxes to bookmarked locations in Word, but when it comes to combo boxes, list boxes, or option buttons, I am lost. So, my problem this time is the following:

I have an access user form that is asking the user to input data and make selections. Once entered I am trying to get everything to export directly to respective bookmarked locations in a Word Report. I have my text boxes working and I have the combo box now working. The issue I am experiencing is with the user making multiple selections from a list box and I am not really sure how to get that to export to the word document.

Here is what I have:

Code: Dim strNames As String Dim ctl As Control Dim varItem as Variant 'ensure the user has made a selection from the testers name text box If Me.testersNamesText.ItemsSelected.Count = 0 Then MsgBox "You must select at least 1 Capability Testers Name" Exit Sub End if 'Add the selected values to a string Set ctl = Me.testersNamesText For Each varItem in ctl.ItemsSelected strNames = strNames & ctl.ItemData(varItem) & ", " strNames = strNames & "'" & ctl.ItemData(varItem) & "'" Next varItem 'trim the trailing comma off strNames = Left(strNames, Len(strNames) -1 ) 'Move to each bookmark and insert text from the form .ActiveDocument.Bookmarks("testersNames").Select .Selection.Text = (CStr(Forms!WebBasedIFV!testersNamesText)) 'reapply the bookmark name to the selection .ActiveDocument.Bookmarks.Add Name:="testersNames", Range:=Selection.Range I am very new to trying to code with the Visual Basic side of things, I know this is probably the best method to do this but the issue that I am experiencing is receiving a Null error for the line with the .Selection.Text = (CStr(Forms!WebBasedIFV!testersNamesText)) and when I attempt to pass the strNames in place of the testersNamesText I receive that the user form can't find the field "strNames" referred to in my expression. I am pretty confused on how to fix this, any help?

I have a project split into FE and BE end files. When more than one user was connected I was having very slow response times on some queries. At the suggestion of some other forum threads, I used a startup form in the FE file to open a persistent connection to the BE file. This solved the problem of those queries being slow, but made one other portion of the app slow to respond. Even with multiple users connected, this portion of the app runs quickly as long as I TURN OFF the persistent connections. But I obviously need to keep persistent connections ON for the sake of all other queries in the project. I've tried the following to no avail:

-for all tables, turning subdatasheets off
-linked to the BE file using UNC instead of mapped drive
-made sure all autocorrect options where off in FE an BE files (they already were)
-made sure the FE and BE files are in trusted locations

Here's the code that runs slowly. The code lets a user select a value from a combobox, then click an "add" button that will add a record in a junction table to link the current company to the "division" that the user selected in the combobox. The listbox then refreshes to show the new entry. The problem (only when using persistent connections) is that the record apparently doesn't actually get written fast enough before the listbox refreshes and therefore it's not displayed to the user. Waiting a second or two and refreshing allows enough time and the entry will then show up in the listbox. There is also a "remove" button that will allow the user to select a listbox entry and remove it from the junction table. That function has the same problem: the deletion occurs, but not before the listbox is requeried.

Is there anything else I can do to avoid this side effect of using persistent connections??


Code: Private Sub Add_Divsion_of_Work_Click() Dim strSQL As String Dim rs As DAO.Recordset If IsNull(Me.combo_subdivision_lookup.Value) Then MsgBox ("You must make a selection before adding") Else strSQL = "SELECT company_id, subdivision_number from company_division where company_division.company_id = " & Me.ID.Value & _ " AND company_division.subdivision_number = '" & Me.combo_subdivision_lookup.Column(2) & "';" Set rs = CurrentDb.OpenRecordset(strSQL, , dbAppendOnly) If rs.EOF Then rs.AddNew MsgBox ("Debug: Adding company ID: " & Me.ID.Value) rs!company_id = Me.ID MsgBox ("Debug: Adding division ID: " & Me.combo_subdivision_lookup.Column(2)) rs!subdivision_number = Me.combo_subdivision_lookup.Column(2) rs.Update Else MsgBox ("This division of work is already defined for this company") End If rs.Close Set rs = Nothing Me.List_of_subdivisions.Requery End If End Sub Private Sub remove_Click() Dim i As Integer Dim company_division_id As Integer Dim strSQL As String 'Dim rs As Recordset For i = Me.List_of_subdivisions.ListCount - 1 To 0 Step -1 If Me.List_of_subdivisions.Selected(i) Then company_division_id = Me.List_of_subdivisions.Column(4) 'MsgBox ("Debug: The company division ID to delete is: " & company_division_id) 'Prompt user to save changes before updating Dim strMsg As String Dim iResponse As Integer ' Specify the message to display. strMsg = "Are you sure you wish to delete the scope of work for this company?" & Chr(10) strMsg = strMsg & "Click Yes to proceed or No to Discard changes." ' Display the message box. iResponse = MsgBox(strMsg, vbQuestion + vbYesNo, "Delete?") ' Check the user's response. If iResponse = vbNo Then 'Do nothing Else strSQL = "DELETE from company_division WHERE company_division.id = " & company_division_id & ";" 'Set rs = CurrentDb.OpenRecordset(strSQL) CurrentDb.Execute (strSQL) MsgBox ("Divsion of work deleted successfully.") ' Cancel the update. 'Cancel = True End If End If Next i Me.List_of_subdivisions.Requery End Sub
thanks in advance,

baulrich

My database is now setup using linked, external tables. I recently setup a form with a subform and after adding a new feature, the subject message began appearing in a message box. The help, is no help.
The form lists staff members. The subform lists descriptions of tasks performed on projects by these persons. The data is coming from two tables. Both have an ID field that is my join. On the main area of the form, I added a list box that is populated from a query of the two tables. What appears as a result of the query is a list of "descriptions" from a Description field on the subform's source table, but only those descriptions that apply to the current staff member as contained on the main form.
For example, if the current record of the main form has 5 sub-records on the subform, this list box will list the 5 values of the Description field as found on the 5 sub-records.
I added code to sort both the records and the listbox so that I could use the subform's CurrentRecord value to set the listbox Selected property (subtracting 1 from the value) so that as you navigate the sub-records, the listbox indicates the current record.
And for ease of use, I also made it so you could select a record via the text box.
I believe it is somewhere in that move that introduced this problem.
I will not post any code until someone indicates they think they can help, as this post is already pretty wordy. TIA

I've been struggling with this for a bit now. I'm trying to create a Freeday program for our HR department. I have the code figured out how to use a multi-Select List box to add new earned freedays to the tblFreedays. However I need to also update the earned hours based on the multi-select listbox. I attached the database to this posting. Below the list box is an add button that I would like to have it update the tblFreedays date earned(which is working) and also increment the daysearned and daysavailable field in the tblEmp(this isn't working) I added a cmdbutton for Update Hours to practice writing a code to make this happen. Any help would greatly be accepted.

Thanks in advanced Attached Files FreeDay.zip (44.3 KB, 36 views) Reply With Quote 06-14-2010, 12:21 PM #2 pbaldy Who is John Galt? Windows XP Access 2007 Join Date Feb 2010 Location Nevada, USA Posts 9,234 Haven't looked at the sample, but within the standard multiselect loop you can run an update query:

CurrentDb.Execute "UPDATE TableName SET FieldName = 123 WHERE KeyField = " & Me.ListboxName.ItemData(varItem)

Presumably you'd want to concatenate in some value as well.

Hi all, hope you can help with this as I am a bit of a newbie when it comes to Access and VBA...

I am developing a database system at work that is used to record audits of work quality, and we want to be able to e-mail an Access report to workers where quality issues have been identified - nothing special, just a single record report.

The auditor selects an audit record from a listbox on the main form - the first column of which is the unique ID of the audit. Below the list box I have put three command buttons which allow the report to be viewed, printed or e-mailed, the first two of which are working very nicely thanks to the 'OpenArgs' attribute in DoCmd.OpenObject. The 'proforma' report is also called from two other forms which are used for creating the audit records in the back-end tables, and when a 'fail' record is added a module is called which saves a Snapshot Format copy of the report to a network drive. This too works fine.

I have a problem however when trying to generate the report when using DoCmd.SendObject - no matter what method I use to input it, the report simply will not pick up the unique audit record ID to complete the SQL command which populates the fields in the report. I have written a new function in a module for generating the e-mail, and the e-mail itself is generating fine, however the attachment generated by SendObject is just the report template.

On the main form the code behind the command button which attempts to send the e-mail is very simple:


	Code:
	run sendproforma(Me.LstHistory.Column(0))

The argument for getting the record ID into this function has been coded as follows:


	Code:
	Public Function sendproforma(auditID As String)

The first lines of the Reports 'On Activate' routine deal with picking up the audit record ID from the various inputs mentioned before. I am going from memory on this a bit, but is essentially as follows:


	Code:
	Dim strvariable, SQL As String
 
If forms!frmresults1.IsLoaded Then
   strvariable = forms!frmresults1.UniqueID
ElseIf forms!frmresults1view.IsLoaded Then
   strvariable = forms!frmresults1view.NewUniqueID
ElseIf Not IsNull(Me.OpenArgs) Then
   strvariable = Me.OpenArgs
Else
   strvariable = auditID
End If
 
SQL = "SELECT * FROM qryauditresults WHERE uniqueref = '" & strvariable & "'"

The last part of the group of IF's is the bit I'm trying to get to work when sending the report via e-mail. I have tried populating this from the listbox on the main form, a hidden text field which contains the same value as the selected record in the listbox in both a new form as well as the original main form, all to no avail thus far which is very frustrating to say the least!

We are running Access 2003 (SP3) on Windows XP currently. I will try and get online here tomorrow at work and post up all the relevant code tomorrow but in the meantime maybe what I have posted here will be sufficient for one of you boffins to be able to spot where I am running into trouble

Howdy all! I am rather new to Access and am looking for some help for a database I'm building for work.

I have a form that imports data from an excel sheet to a temporary table in my database. From that table I load the first column "Loan number" into a list box on a second form.

Now, on that second form, I want the user to be able to select all or some of the entries in the listbox and then fill out a few text boxes (In this case there are four "date received","date loaded", "time received" and "time loaded") and I want to create a button that will then create entries into a loan table that will save each of those loan numbers as a seperate record and will put the values from the text boxes in each record created.

I know almost nothing about coding or macros so I'm not even really sure where to start as far as doing this. Can any of you help?

I have an issue where my rstCalibrationInformation.NoMatch is not working. I would like to have a combo box where a user can pick a txtCalibGroup (PK) and a listbox will show a query related to the PK. That works fine, however I would like if the user entered a PK that doesn't match any of the records to add a new record with that PK. I think my code isn't entering the rstCalibrationInformation.NoMatch and creating a new record, because the list box is empty and no new record is created nor Msgbox.
Any suggestions?




	Code:
	Private Sub Search_Click()
'On Error GoTo Error_Search_Click:
   Dim db As DAO.Database
   Dim rstCalibrationGroup As DAO.Recordset
   
   Set db = CurrentDb
   Set rstCalibrationInformation = db.OpenRecordset("tblCalibrationInformation")
   
    If IsNull(Me!cboFilter) Then
        GoTo Finish
    End If

    rstCalibrationInformation.OpenRecordset.FindFirst " txtCalibGroup= '" & Me.cboFilter & "'"


    If rstCalibrationInformation.NoMatch Then
        rstCalibrationInformation.AddNew
        rstCalibrationInformation("txtCalibGroup").Value = Me!cboFilter
        rstCalibrationInformation.Update
        MsgBox "Added new entry"
    Else
        Me!LstSearch.RowSource = "SELECT txtLabNum FROM tblCalibrationGroup WHERE [txtCalibGroup] = '" & Me!cboFilter & "' "
    End If
       
    
Finish:
            Exit Sub
 
Exit_Search_Click:
    Exit Sub
 
'Error_Search_Click:
    'MsgBox Err.Number & Err.Description
   'Resume Exit_Search_Click

End Sub



Ok guys - I cannot quick grasp this

I need to hard code the directoy to absolute to
C:Bumblebee

(I will switch the code to my network..)

but I cannot see where





Option Compare Database
Option Explicit
'Const TextMerge As String = "merge.txt"
' May 20/2003 - see below comments why txt file name was changed.

Const TextMerge As String = "merge.888"


'******************************************
'* Word merge code *
'* (c) 2001 Albert D. Kallal *
'* kallal@msn.com *
'* *
'******************************************
'
' Usage:
' In code on a form with a data source, just place the following
' command behind a button
'
' MergeSingleWord
'
' That is it!!!
'
' You can also specify a dir for the above. This dir location is relative
' to location of the access dir. The default dir is "Word". Hence, the real
' usage is:
' MergeSingleWord [dir],[bolFullPath]
'
' Example:
' MergeSingleWord "Customers"
'
' The above would use/create the templates in a dir called Customers (relative to app dir).
' The "" is optional. If you leave out the "", then my code appends a "" to the dir
'
' An absolute location can be specified as:
' MergeSingleWord "c:MyWord", True
' The use of the True above forces the dir to be a full path name, and not relative
' to the app dir. The path must be a FULL path, and not relative.
'
'==========================================
' Revisions
' Date who Comments
' May 20, 2003 ADK - added on error resume next to the mkdir command in GetWordDir
' May 20, 2003 ADK - changed merge.txt file to merge.888 to fix text import bug
' (this is a know problem when you turn off file extensions
' in windows, the mail merge will fail KB article 137385)
' Aug 06, 2003 ADK - added ability to use different dire for each form.
' Aug 09, 2003 ADK - added a listbox sort routine
' Aug 28, 2003 ADK - change the "modify" template option to *always* set the
' data source to merge.888. That way, just hitting modify option
' will set the data source to the correct dir.
'
' Oct 22, 2003 ADK - changed the "qu" routine that surrounds the text data field to
' remove all " quotes to a ' (single quote).
'
' Oct 29, 2003 ADK - removed use of AppActivate "Microsoft Word" to use
' wordApp.Activate (this works with all versions, including xp where
' the window names are "separate"
' Feb 14, 2004 ADK - Added the code to set the data source EACH TIME a word doc is loaded.
' (This was done to fix problems with office 2003, and the message:
' "Opening This Will Run the Following SQL Command Message"
' There is a number of registry settings that can be changed. However
' just setting the data source EACH TIME the word doc is loaded also
' seems to by-pass the run SQL command nag message. Since this is hole
' in what is supposed to prevent automation code from setting the data
' source, I am betting that future releases will beak my code!
' Sept 24, 2004 ADK - added some code to allow name of output doc to be set.
' Mar 06, 2005 ADK - unbound text boxes are now included for single word merge
' Sep 07, 2005 ADK - mergenoprompts now allows sql string to be based
' Oct 10, 2006 ADK - text boxes on forms now can be used in the merge.
' Oct 14, 2006 ADK - fill prompt fields cased menu bars to not show, fixed by
' moving the visible + activate code to BEFORE the merge.
' Dec 11, 2006 ADK - fixed a focus bug, and now use a SEPERATE instance of
' the "open" word document to fix a problem when docuemnts
' are already open

Public Function MergeSingleWord(Optional strDir As String = "Word", _
Optional bolFullPath As Boolean = False, _
Optional strOutPutDoc As String = "")

' Main Word merge function
' Albert D. Kallal
' kallal@msn.com
'
'
' starts the whole process of a "merge" template (single record) in rides.
'
' Simply place this command behind a button on a form.
' A function was used here in place of a "sub". This was done since a
' custom menu bar can call this code by placing =MergeSingleWord() in the
' menu's on-action. Thus, if you use custom menu bars, this code will work!
' This code thus picks up the active screen name, and functions from that.

' Parms are:
' strDir optional dir (include the ) the dir name - relative to applicaton dir
' bolfullPath optinal flag. Set to TRUE if the above dir is a full path name. If you
' do NOT set this flag (or leave it as false), the the path name is relative
' to the appliction dir.
' stroutPutDoc Name of the document to be saved to disk. (full path requied here)

Dim strOutFile As String ' temp csv merge text file name
Dim frmF As Form
Dim strDirPath As String ' full path name to working dir

Set frmF = Screen.ActiveForm
frmF.Refresh

strDirPath = DirToPath(strDir, bolFullPath)

strOutFile = strDirPath & TextMerge

' output our simple merge file

If MakeMergeText(frmF, strOutFile) Then
DoCmd.OpenForm "GuiWordTemplate", , , , , , strDirPath & "~" & strOutPutDoc
End If

End Function


Public Function MergeAllWord(strSql As String, _
Optional strDir As String = "Word", _
Optional bolFullPath As Boolean = False, _
Optional strOutPutDoc As String) As Boolean

' Merge all reocrds from the form.
' This rouinte can take any sql statement you pass, and create
' a merge doc. Thus, this is used for "many" merged, and not
' a single merge.

' Simply this rouintes writes out a csv file based on the
' sql, and then launches the merge form.

' Parms are:
' strDir relative path to dir
' bolFullPath if set true, then above path is NOT relative
' strOutPutDoc if set, then write out the merged doc to this file

' build our merge file, and write a "csv" file to disk

Dim strDirPath As String ' full path name to working dir
Dim OneField As DAO.Field ' dao code
Dim strFields As String
Dim strData As String
Dim intFile As Integer

Dim rstOutput As DAO.Recordset
Dim strOutFile As String ' csv file output name

On Error GoTo exit2 ' if sql is bad...simply exit...

Set rstOutput = CurrentDb.OpenRecordset(strSql)

If rstOutput.RecordCount = 0 Then
' no records...exit.
GoTo exit1
End If

' build the merge file, but show the process bar
'
clsRidesPBar.ShowProgress
clsRidesPBar.TextMsg = "Building merge file..."

On Error GoTo exit1 ' if sql is bad...simply exit...
rstOutput.MoveLast
rstOutput.MoveFirst

' set max value of progress bar to number of records
clsRidesPBar.Pmax = rstOutput.RecordCount

' build the first line of fields for csv

For Each OneField In rstOutput.Fields
If strFields "" Then strFields = strFields & ","
strFields = strFields & qu(OneField.Name)
Next OneField

' build the merge.txt file

strDirPath = DirToPath(strDir, bolFullPath)
strOutFile = strDirPath & TextMerge

'delete the out file if there
On Error Resume Next
Kill strOutFile

' now open file...

On Error GoTo exit1

intFile = FreeFile()
Open strOutFile For Output As intFile
Print #intFile, strFields

' output all data
Do While rstOutput.EOF = False

strData = "" ' one line of data for csv file
For Each OneField In rstOutput.Fields

If strData "" Then strData = strData & ","
strData = strData & qu(rstOutput(OneField.Name))

Next OneField

Dim vField As Control




Print #intFile, strData

rstOutput.MoveNext
clsRidesPBar.IncOne
Loop

Close intFile

MergeAllWord = True

clsRidesPBar.HideProgress

DoCmd.OpenForm "GuiWordTemplate", , , , , , strDirPath & "~" & strOutPutDoc

Exit Function

exit1:

clsRidesPBar.HideProgress

exit2:

MsgBox "No data was created for this merge" & vbCrLf & _
"Make sure the sql is correct" & vbCrLf & _
"sql was " & vbCrLf & vbCrLf & strSql, _
vbCritical, "no data for this merge"

MergeAllWord = False


End Function

Public Function MergeNoPrompts(strDoc As String, _
Optional strDir As String = "word", _
Optional bolFullPath As Boolean = False, _
Optional strOutDocName As String, _
Optional strSql As String = "", _
Optional bolPrint As Boolean = False, _
Optional StrPrinter As String = "")

Dim frmF As Form
Dim strFullDocName As String
Dim strDirPath As String
Dim strOutFile As String

Set frmF = Screen.ActiveForm
frmF.Refresh

strDirPath = DirToPath(strDir, bolFullPath)

strFullDocName = strDirPath & strDoc
strOutFile = strDirPath & TextMerge ' temp text file name

' sql passed?
If strSql "" Then
If MakeMergeAll(strSql, strDir, bolFullPath) = False Then
' could not create...exit
Exit Function
End If
Else
If MakeMergeText(frmF, strOutFile) = False Then
' could not create...exit
Exit Function
End If
End If

Call RidesMergeWord(strFullDocName, strDirPath, strOutDocName, bolPrint, StrPrinter)


End Function

Function GetAppDir() As String

' This routine simply returns the current applction dir
'+ word
' If the dir does not exist, then we create it.
' This is the dir where the word docs will be created.

Dim strDB As String

' build a string based on the CURRENT mdb direcotry + word

strDB = CurrentDb.Name

GetAppDir = Left(strDB, Len(strDB) - Len(Dir(strDB)))

End Function

Function DirToPath(strDir As String, bolFullPath) As String

If Right(strDir, 1) "" Then
strDir = strDir & ""
End If

If bolFullPath = True Then
' full path name to a dir ...not relative
DirToPath = strDir
Else
DirToPath = GetAppDir & strDir
End If

Call CheckDir(DirToPath) ' checks if dir exist..if not it creates the dir

End Function
Sub CheckDir(strDir As String)

If strDir = "" Then Exit Sub

If Len(Dir(strDir)) = 0 Then
On Error Resume Next
MkDir strDir
End If

End Sub

Function qu(vText As Variant) As String
' takes a string and surrounds it with double quotes
' All " (double quotes) are converted to ' (single quotes) before
' this is done

If IsNull(vText) = False Then
If InStr(vText, Chr(34)) > 0 Then
vText = strDReplace(CStr(vText), Chr(34), "'")
End If
End If

qu = Chr$(34) & vText & Chr$(34)

End Function


Function strDReplace(vText As String, strSearchFor As String, strReplaceTo As String) As String

Dim intFoundPos As Integer
Dim intSearchLen As Integer
Dim intReplaceLen As Integer

intSearchLen = Len(strSearchFor)
intReplaceLen = Len(strReplaceTo)

intFoundPos = InStr(vText, strSearchFor)

Do While intFoundPos > 0
vText = Left$(vText, intFoundPos - 1) & strReplaceTo & Mid(vText, intFoundPos + intSearchLen)
intFoundPos = InStr(vText, strSearchFor)
Loop

strDReplace = vText

End Function
Function RidesMergeWord(strDocName As String, _
strDataDir As String, _
Optional strOutDocName As String, _
Optional bolPrint As Boolean = False, _
Optional StrPrinter As String)

' This code takes a word document that has been setup as a MERGE document.
' This merge document is opened, then mailmerge is executed. The original
' document is then closed. The result is a raw word document with no connectons
' to the merge.txt (a csv source data file).

'Parms:
' strDocName - full path name of word doc (.doc)
' strDataDir - dir (full path) where docuemnts and the merge.888 file is placed
' strOutDocName - full path name of merged document (saved).
' bolPrint - if true, then output docuemnt is printed - if strOutDocName is suppled then we close the docuemnt
' strPrinter - sends output to the printer name
'
'
' The above parms are suppled by other routines. You likey should not need to call this
' routine directly. See the sub called MergeNoPrompts.

' Albert D. Kallal (c) 2001
' kalla@msn.com
'
Dim WordApp As Object ' running instance of word
Dim WordDoc As Object ' one instance of a word doc
Dim WordDocM As Object ' one instance of a word doc
Dim strActiveDoc As String ' doc name (no path)
Dim lngWordDest As Long ' const for dest, 0 = new doc, 1 = printer
Dim MyPbar As New clsRidesPBar ' create a instance of our Progress bar.


MyPbar.ShowProgress
MyPbar.TextMsg = "Launching Word...please wait..."
MyPbar.Pmax = 4 ' 4 steps to inc
MyPbar.IncOne ' step 1....start!

On Error GoTo CreateWordApp
Set WordApp = GetObject(, "Word.Application")
On Error Resume Next

MyPbar.IncOne ' step 2, word is loaded.

Set WordDoc = WordApp.Documents.Open(strDocName)

MyPbar.IncOne ' step 3, doc is loaded

strActiveDoc = WordApp.ActiveDocument.Name
'wordApp.Activate

If bolPrint = False Then
WordApp.Visible = True
WordApp.Activate
WordApp.WindowState = 0 'wdWindowStateRestore
End If

WordDoc.MailMerge.OpenDataSource _
Name:=strDataDir & TextMerge, _
ConfirmConversions:=False, _
ReadOnly:=False, LinkToSource:=True, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _
WritePasswordTemplate:="", Revert:=False, Format:=0, _
Connection:="", SQLStatement:="", SQLStatement1:=""


With WordDoc.MailMerge
.Destination = 0 ' 0 = new doc
.MailAsAttachment = False
.MailAddressFieldName = ""
.MailSubject = ""
.SuppressBlankLines = True
With .datasource
.FirstRecord = 1
' .LastRecord = 1
End With
.Execute Pause:=False
End With
Set WordDocM = WordApp.ActiveDocument

MyPbar.IncOne ' step 4, doc is merged
WordDoc.Close (False)

WordApp.Visible = True

If strOutDocName "" Then
'wordApp.ActiveDocument.SaveAs strOutDocName
WordDocM.SaveAs strOutDocName

End If

If bolPrint = False Then

WordDocM.Activate

Else

' print this document

If StrPrinter "" Then
With WordApp.Dialogs(97) ' 97 - wdDialogFilePrintSetup
.Printer = StrPrinter
.DoNotSetAsSysDefault = True
.Execute
End With
End If


WordDocM.PrintOut
'If strOutDocName "" Then
'wordApp.ActiveDocument.Close (False)
' when we print...we *always* close the docuemnt..

WordDocM.Close (False)

'End If

WordApp.Visible = True

End If


MyPbar.HideProgress

Set WordApp = Nothing
Set WordDoc = Nothing
Set WordDocM = Nothing
Set MyPbar = Nothing

DoEvents

' If bolShowMerge = True Then
' WordApp.Dialogs(676).Show 'wdDialogMailMerge
' End If

Exit Function

CreateWordApp:
' this code is here to use the EXISTING copy of
' ms-access running. If getobject fails, then
' ms-word was NOT running. The below will then
' launch word
Set WordApp = CreateObject("Word.Application")
Resume Next

End Function

Function RidesEditTemplate(strWordDoc As String, strSaveDir As String)


' Opens a word doc in mail merge mode

Dim WordApp As Object
Dim WordDoc As Object

clsRidesPBar.ShowProgress
clsRidesPBar.TextMsg = "Launching Word...please wait..."

On Error GoTo CreateWordApp
Set WordApp = GetObject(, "Word.Application")
On Error GoTo 0

Set WordDoc = WordApp.Documents.Open(strWordDoc)
WordApp.Visible = True
'*-
WordDoc.MailMerge.MainDocumentType = 0 ' wdFormLetters = 0

WordDoc.MailMerge.OpenDataSource _
Name:=strSaveDir & TextMerge, _
ConfirmConversions:=False, _
ReadOnly:=False, LinkToSource:=True, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _
WritePasswordTemplate:="", Revert:=False, Format:=0, _
Connection:="", SQLStatement:="", SQLStatement1:=""
'*-

'AppActivate "Microsoft Word"
WordApp.Activate
WordApp.WindowState = 0 'wdWindowStateRestore

clsRidesPBar.HideProgress

Exit Function

CreateWordApp:

Set WordApp = CreateObject("Word.Application")
Resume Next


End Function
Function RidesNewTemplate(strSaveDir As String)

' ask user for template name to create
'
' Parms:
' strSaveDir = full path of dir is (includes the last backslash

Dim strNewName As String
Dim WordApp As Object 'Word.Applicaton
Dim WordDoc As Object 'Word.Document

strNewName = ""
strNewName = InputBox("What name for new template" & vbCrLf & vbCrLf & _
"(Enter name with no file extension)", _
"Create New Word merge Template")

If strNewName = "" Then Exit Function

' get work object...

clsRidesPBar.ShowProgress
clsRidesPBar.TextMsg = "Launching Word...please wait..."
clsRidesPBar.Pmax = 4
clsRidesPBar.IncOne

On Error GoTo CreateWordApp
Set WordApp = GetObject(, "Word.Application")
On Error GoTo 0

clsRidesPBar.IncOne

Set WordDoc = WordApp.Documents.Add

WordDoc.MailMerge.MainDocumentType = 0 ' wdFormLetters = 0

'MsgBox strSaveDir

WordDoc.MailMerge.OpenDataSource _
Name:=strSaveDir & TextMerge, _
ConfirmConversions:=False, _
ReadOnly:=False, LinkToSource:=True, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _
WritePasswordTemplate:="", Revert:=False, Format:=0, _
Connection:="", SQLStatement:="", SQLStatement1:=""

clsRidesPBar.IncOne

' write doc to disk....
WordDoc.SaveAs FileName:=strSaveDir & strNewName, _
FileFormat:=0, _
LockComments:=False, Password:="", AddToRecentFiles:=False, WritePassword:="", _
ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:=False


clsRidesPBar.IncOne

WordApp.Visible = True
'AppActivate "Microsoft Word"
WordApp.Activate
WordApp.WindowState = 0 'wdWindowStateRestore

clsRidesPBar.HideProgress

Exit Function

CreateWordApp:

Set WordApp = CreateObject("Word.Application")
Resume Next

End Function



Function MakeMergeText(frmF As Form, strOutFile As String) As Boolean

' build our merge file, and write a simple "csv" file to disk

Dim OneField As DAO.Field
Dim strFields As String
Dim strData As String
Dim intFile As Integer
Dim vField As Control
Dim t As Variant

If frmF.RecordSource "" Then

If frmF.RecordsetClone.Fields.Count > 0 Then
For Each OneField In frmF.RecordsetClone.Fields

If strFields "" Then strFields = strFields & ","
strFields = strFields & qu(OneField.Name)

If strData "" Then strData = strData & ","
strData = strData & qu(frmF(OneField.Name))

Next OneField
End If
End If


For Each vField In frmF.Controls
If vField.ControlType = acTextBox Then
' if it is a text box, then include in field list

If vField.ControlSource = "" Then

If strFields "" Then strFields = strFields & ","
strFields = strFields & qu(vField.Name)
' now add data from this box

If strData "" Then strData = strData & ","
strData = strData & qu(frmF(vField.Name))

Else
' text box is bound, but ONLY include if it is NOT in the field list
On Error Resume Next
t = frmF.RecordsetClone.Fields(vField.Name).Name
If Err.Number = 0 Then
' field name is in reocrd set...skip
Else
Err.Clear
If strFields "" Then strFields = strFields & ","
strFields = strFields & qu(vField.Name)
' now add data from this box

If strData "" Then strData = strData & ","
strData = strData & qu(frmF(vField.Name))
End If

End If
End If
Next vField

'delete the out file if there
On Error Resume Next
Kill strOutFile

' now open file...

On Error GoTo exit1
intFile = FreeFile()
Open strOutFile For Output As intFile
Print #intFile, strFields
Print #intFile, strData
Close intFile

MakeMergeText = True
Exit Function

exit1:

MsgBox "Can't make merge file in directory called word" & vbCrLf & _
"The Word template may already be in use. Try closing word first." & vbCrLf & vbCrLf & _
"Make sure a directory called Word exists" & vbCrLf & _
"path name was " & strOutFile & vbCrLf & vbCrLf & _
"Please create a word directory, exit word and try again", vbCritical, "no word directory, or in already in use"

MakeMergeText = False


End Function

I had to create a new FE of a DB I was working on and in the new FE I have been re ceiving an error for a function that was previously working and I can't figure out why. On a couple of the forms there is a command button to send an email; the user is prompted if they would like to use a template, if yes is clicked it creates a VBA error. If I close the VBA ending the debugger, the form to select template opens- it;s supposed to open when the user clicks yes to use a template. I've done compact and repair which doesn't resolve the issue either. Just not sure why this particular function produces the error now... If I choose no to selecting a template it will open a new message in outlook without a problem... The full code is below

Any possible solutions would be much appreciated!

I'm receiving the error "Ambiguous Name Detected: ~"
The word strDField in the line bolStoreEmailHistory = (strDField(Me.OpenArgs, "~", 1) = "True") is highlighted in blue and Private Sub Form_Load() is highlighted in yellow.

Option Compare Database
Option Explicit

Dim DisplayType As Integer '1 = full, 2 = full w No delete, 3 = send/preview only
Dim DisplayType2 As Integer '1 = regular, 2 = sending emails, 3 = previewing emails
Dim EmailTemplateID As Long
Dim bolSingular As Boolean
Dim FormTitle As String
Dim strDisplayType As String
Dim bolStoreEmailHistory As Boolean

Const olMailItem = 0
Const olFormatHTML = 2
Const olFormatPlain = 1

Private Sub ComboRecordCorrespondence_AfterUpdate()
If IsDebugMode = 0 Then On Error GoTo ComboRecordCorrespondence_AfterUpdate_Error

If (Nz(Me.ComboRecordCorrespondence, "") = "") Then
Me.ComboRecordCorrespondence = "Yes"
End If

ComboRecordCorrespondence_AfterUpdate_Exit:
Exit Sub

ComboRecordCorrespondence_AfterUpdate_Error:
Call ErrorLog(Err.Description, Err.Number, Me.Name, Erl, "ComboRecordCorrespondence_AfterUpdate")
Resume ComboRecordCorrespondence_AfterUpdate_Exit
End Sub

Private Sub ListEmailTemplates_DblClick(Cancel As Integer)
If IsDebugMode = 0 Then On Error GoTo ListEmailTemplates_DblClick_Error

cmdModify_Click

ListEmailTemplates_DblClick_Exit:
Exit Sub

ListEmailTemplates_DblClick_Error:
Call ErrorLog(Err.Description, Err.Number, Me.Name, Erl, "ListEmailTemplates_DblClick")
Resume ListEmailTemplates_DblClick_Exit
End Sub

Private Sub MergeEmails(Optional preview As String)
'If Preview = "Yes" then it doesn't send any email directly but instead
'just opens the emails in outlook
'Note: we limit previewing to < 10 emails
Dim result As Long

If IsDebugMode = 0 Then On Error GoTo MergeEmails_Error

If (DisplayType 3) Then
EmailTemplateID = Nz(Me.ListEmailTemplates, 0)
End If

If (EmailTemplateID > 0) Then

If (preview "Yes") Then
DisplayType2 = 2 'set to sending email mode

'set two global vars to indicate timestamp and whether to record correspondence
'the inidvidual correspondence records will be added in the routine that send the individual emails
'also set the screen control txtEmailTimeStamp so the query that drives the email results will work

result = SendEmail(EmailTemplateID, "")
If (result >= 0) Then
ElseIf (result = -1) Then
MsgBox "Problem matching merge fields in the E-Mail template. Please check over the E-Mail template for valid merge fields. Contact RPT Software for support if needed.", vbOKOnly, "Error"
End If

DoCmd.Close
Else
DisplayType2 = 3 'set to preview mode
result = SendEmail(EmailTemplateID, preview)

End If
Else
MsgBox "You need to select an E-Mail template", vbExclamation, "Error"
End If

MergeEmails_Exit:
Exit Sub

MergeEmails_Error:
Call ErrorLog(Err.Description, Err.Number, Me.Name, Erl, "MergeEmails")
Resume MergeEmails_Exit
End Sub
Private Sub cmdMerge_Click()
If IsDebugMode = 0 Then On Error GoTo cmdMerge_Click_Error

If IsNull(Me.ListEmailTemplates) = False Then
Call MergeEmails
Else
MsgBox "You need to select an E-Mail template from the list.", vbOKOnly, "Error"
End If

cmdMerge_Click_Exit:
Exit Sub

cmdMerge_Click_Error:
Call ErrorLog(Err.Description, Err.Number, Me.Name, Erl, "cmdMerge_Click")
Resume cmdMerge_Click_Exit
End Sub
Private Sub cmdPreview_Click()
Dim preview As String

If IsDebugMode = 0 Then On Error GoTo cmdPreview_Click_Error

preview = "Yes"
Call MergeEmails(preview)

cmdPreview_Click_Exit:
Exit Sub

cmdPreview_Click_Error:
Call ErrorLog(Err.Description, Err.Number, Me.Name, Erl, "cmdPreview_Click")
Resume cmdPreview_Click_Exit
End Sub

Private Sub cmdAddNew_Click()
If IsDebugMode = 0 Then On Error GoTo cmdAddNew_Click_Error

DoCmd.OpenForm "frmEmail", , , , acFormAdd, acDialog
Call RequeryList
Me.ListEmailTemplates = GlobalID

cmdAddNew_Click_Exit:
Exit Sub

cmdAddNew_Click_Error:
Call ErrorLog(Err.Description, Err.Number, Me.Name, Erl, "cmdAddNew_Click")
Resume cmdAddNew_Click_Exit
End Sub

Private Sub cmdCancel_Click()
If IsDebugMode = 0 Then On Error GoTo cmdCancel_Click_Error

DoCmd.Close

cmdCancel_Click_Exit:
Exit Sub

cmdCancel_Click_Error:
Call ErrorLog(Err.Description, Err.Number, Me.Name, Erl, "cmdCancel_Click")
Resume cmdCancel_Click_Exit
End Sub

Private Sub cmdDelete_Click()
If IsDebugMode = 0 Then On Error GoTo cmdDelete_Click_Error

If (Nz(Me.ListEmailTemplates, 0) > 0) Then
If MsgBox("Are you sure you want to delete the template " & Me.ListEmailTemplates.Column(1) & "?", _
vbQuestion + vbYesNoCancel + vbDefaultButton2, "Delete template?") = vbYes Then
DoCmd.SetWarnings False
DoCmd.RunSQL "DELETE * FROM tblEmailTemplate where EmailTemplateID = " & CStr(Me.ListEmailTemplates)
Call RequeryList
Me.ListEmailTemplates.Selected(0) = True
End If
Else
MsgBox "You need to select an E-Mail template to delete", vbExclamation, "Error"
End If

cmdDelete_Click_Exit:
DoCmd.SetWarnings True
Exit Sub

cmdDelete_Click_Error:
Call ErrorLog(Err.Description, Err.Number, Me.Name, Erl, "cmdDelete_Click")
Resume cmdDelete_Click_Exit
End Sub

Private Sub cmdModify_Click()
' edit template
If IsDebugMode = 0 Then On Error GoTo cmdModify_Click_Error

If (Nz(Me.ListEmailTemplates, 0) > 0) Then
DoCmd.OpenForm "frmEmail", , , "EmailTemplateID = " & CStr(Me.ListEmailTemplates), acFormEdit, acDialog
Call RequeryList
Else
MsgBox "You need to select an E-Mail template", vbExclamation, "Error"
End If

cmdModify_Click_Exit:
Exit Sub

cmdModify_Click_Error:
Call ErrorLog(Err.Description, Err.Number, Me.Name, Erl, "cmdModify_Click")
Resume cmdModify_Click_Exit
End Sub

Private Sub Form_Load()
If IsDebugMode = 0 Then On Error GoTo Form_Load_Error

Dim strDisplay As String

DisplayType = 1 'set to full functionality
DisplayType2 = 1 'set to regular mode
If IsNull(Me.OpenArgs) = False Then
bolStoreEmailHistory = (strDField(Me.OpenArgs, "~", 1) = "True")
EmailTemplateID = CLng(strDField(Me.OpenArgs, "~", 2))
DisplayType = CInt(strDField(Me.OpenArgs, "~", 3))
bolSingular = (strDField(Me.OpenArgs, "~", 4) = "True")
FormTitle = strDField(Me.OpenArgs, "~", 5)
strDisplay = strDField(Me.OpenArgs, "~", 6)
strDisplayType = strDField(Me.OpenArgs, "~", 7)
End If
Me.txtData = strDisplay

Me.ListEmailTemplates.SetFocus
Me.ListEmailTemplates.Selected(0) = True

Form_Load_Exit:
Exit Sub

Form_Load_Error:
Call ErrorLog(Err.Description, Err.Number, Me.Name, Erl, "Form_Load")
Resume Form_Load_Exit
End Sub

Private Sub RequeryList()
'requeries the main list box and sets focus back on the listbox
If IsDebugMode = 0 Then On Error GoTo RequeryList_Error

Me.ListEmailTemplates.Requery
Me.ListEmailTemplates.SetFocus

RequeryList_Exit:
Exit Sub

RequeryList_Error:
Call ErrorLog(Err.Description, Err.Number, Me.Name, Erl, "RequeryList")
Resume RequeryList_Exit
End Sub

Private Function SendEmail(EmailTemplateID As Long, preview As String) As Long
'This function runs the GlobalEmailSQL (supplied at the very beginning in the ModuleEmail)
'and sends emails using the supplied emailTemplateID
'Note: if Preview = "YES" then it does NOT send the emails and instead
' just opens the first email email in Outlook
'Returns postive number = number of emails it tried to send
'Returns -1 = could not send emails due to token problems in email template

If IsDebugMode = 0 Then On Error GoTo SendEmail_Error

Dim db As Database
Dim rs As DAO.Recordset
Dim RSAttachments As DAO.Recordset
Dim filepath As String
Dim emailtemplatesql As String
Dim fld As DAO.Field
Dim OrigToString As String
Dim OrigCCString As String
Dim OrigBCCString As String
Dim OrigSubjectString As String
Dim OrigBodyString As String
Dim OrigBodyHTMLString As String
Dim ToString As String
Dim CCString As String
Dim BCCString As String
Dim SubjectString As String
Dim BodyString As String
Dim BodyHTMLString As String
Dim result As Variant
Dim ReturnValue As Long
Dim ContactID As Long
Dim GoodEmail As Long
Dim BadEmail As Long
Dim Attachments(9) As String
Dim iii As Long

'counters to count emails sent and not sent
GoodEmail = 0
BadEmail = 0
ReturnValue = 0

'retrieve email template information from table into variables
emailtemplatesql = "Select * from tblEmailTemplate WHERE EmailTemplateID = " & CStr(EmailTemplateID)
Set db = CurrentDb()
Set rs = db.OpenRecordset(emailtemplatesql, dbOpenDynaset)
If Not (rs.BOF And rs.EOF) Then
rs.MoveFirst
OrigToString = rs("To")
OrigCCString = Nz(rs("CC"), "")
OrigBCCString = Nz(rs("BCC"), "")
OrigSubjectString = rs("Subject")
OrigBodyString = rs("Body")
OrigBodyHTMLString = Nz(rs("BodyHTML"), "")
'Open recordset of attachments, save each one to disk and assign to attachments() array
For iii = 1 To 9
Attachments(iii) = ""
Next iii
filepath = CurrentDBDir() & "Attachments999"
If Len(Dir(filepath, vbDirectory)) = 0 Then
MkDir filepath
End If
iii = 1
Set RSAttachments = rs.Fields("Attachments").Value
While Not RSAttachments.EOF
If (FileExists(filepath & RSAttachments.Fields("FileName").Value)) Then
Kill filepath & RSAttachments.Fields("FileName").Value
End If
RSAttachments.Fields("FileData").SaveToFile filepath
Attachments(iii) = filepath & RSAttachments.Fields("FileName").Value
iii = iii + 1
RSAttachments.MoveNext
Wend
RSAttachments.Close
End If
rs.Close

'run through recordset and send email for each record
Set rs = db.OpenRecordset(GlobalEmailSQL, dbOpenDynaset)
If Not (rs.BOF And rs.EOF) Then
rs.MoveFirst
Do While Not rs.EOF

'check to see if user stopped email process
DoEvents

'get ids for use in correspondence history
ContactID = rs("ContactID")

'Set vars back to original values (needed if doing multiple emails)
ToString = OrigToString
CCString = OrigCCString
BCCString = OrigBCCString
SubjectString = OrigSubjectString
BodyString = OrigBodyString
BodyHTMLString = OrigBodyHTMLString

'Change variables as needed by replacing ##xxxxx## token in the email template with actual values
For Each fld In rs.Fields
'Debug.Print fld.Name
If (fld.Name "Attachments") Then 'attachments field is special
ToString = ReplaceIfNeeded(ToString, fld.Name, CStr(Nz(rs(fld.Name), "")))
CCString = ReplaceIfNeeded(CCString, fld.Name, CStr(Nz(rs(fld.Name), "")))
BCCString = ReplaceIfNeeded(BCCString, fld.Name, CStr(Nz(rs(fld.Name), "")))
SubjectString = ReplaceIfNeeded(SubjectString, fld.Name, CStr(Nz(rs(fld.Name), "")))
BodyString = ReplaceIfNeeded(BodyString, fld.Name, CStr(Nz(rs(fld.Name), "")))
BodyHTMLString = ReplaceIfNeeded(BodyHTMLString, fld.Name, CStr(Nz(rs(fld.Name), "")))
End If
Next

'check to make sure all variables have been replaced (if not exit function with error
result = InStr(ToString & CCString & BCCString & SubjectString & BodyString, "##")
If Not ((result = 0) Or (IsNull(result))) Then
ReturnValue = -1
GoTo SendEmail_Exit
End If

'Send ONE email (if previewing email will open in Outlook but not send)
'On Error Resume Next
If (SendONEEmail(ContactID, ToString, CCString, BCCString, SubjectString, BodyString, BodyHTMLString, Attachments, preview) = 1) Then
GoodEmail = GoodEmail + 1
Else
BadEmail = BadEmail + 1
End If
On Error GoTo SendEmail_Error

ReturnValue = ReturnValue + 1

'if previewing emails only open the first email in Outlook
If (Nz(preview, "") = "Yes") Then
GoTo SendEmail_Exit
End If
rs.MoveNext
Loop
End If

'if sending emails display a message bos indicating how many emails were sent (good and bad)
If (Nz(preview, "") "Yes") Then
MsgBox CStr(GoodEmail) & " Email" & IIf((GoodEmail > 1), "s have", " has") & " been sent." & IIf(BadEmail > 0, " Had problems sending " & CStr(BadEmail) & " Email" & IIf((BadEmail > 1), "s.", ""), "")
GoTo SendEmail_Exit
End If

SendEmail_Exit:
rs.Close
SendEmail = ReturnValue
Set rs = Nothing
Set RSAttachments = Nothing
Set db = Nothing
Exit Function

SendEmail_Error:
Call ErrorLog(Err.Description, Err.Number, Me.Name, Erl, "SendEmail")
Resume SendEmail_Exit
End Function
Function ReplaceIfNeeded(TheString As String, TheFieldName As String, TheValue As String)
'If it finds ##TheFieldName## in TheString then replace with TheValue
If IsDebugMode = 0 Then On Error GoTo ReplaceIfNeeded_Error

Dim NewString As String
Dim result As Variant
Dim CharsOnRight As Long
Dim doneflag As Boolean

doneflag = False
While Not (doneflag)
result = InStr(TheString, "##" & TheFieldName & "##")
If Not ((result = 0) Or (IsNull(result))) Then
'get text before the ##xxxxx# token
NewString = Left(TheString, result - 1)
'append the real value (that replaces the token)
NewString = NewString & TheValue
'append the rest of the string after the token
CharsOnRight = Len(TheString) - (result + Len(TheFieldName) + 3)
NewString = NewString & Right(TheString, CharsOnRight)
'Set TheString equal to the newly changed string (we might have more substitutions and have to loop again)
TheString = NewString
Else
doneflag = True
NewString = TheString
End If
Wend

ReplaceIfNeeded = NewString


ReplaceIfNeeded_Exit:
Exit Function

ReplaceIfNeeded_Error:
Call ErrorLog(Err.Description, Err.Number, Me.Name, Erl, "ReplaceIfNeeded")
Resume ReplaceIfNeeded_Exit
End Function

Private Function SendONEEmail(ContactID As Long, ToString As String, CCString As String, BCCString As String, SubjectString As String, BodyString As String, BodyHTMLString As String, Attachments() As String, preview As String) As Long
'tries to send ONE email, logs results to tblCorrespondence and returns either
' a 1 for a successful send or 0 for a failure due to some error
'Note: tblCorrespondence is used temporarily to show status of each email (even if user doesn't want to store correspondence)
Dim ReturnValue As Long

Dim OlApp As Object 'Outlook.Application
Dim olMail As Object 'MailItem
Dim i As Integer
Dim Emailtext As String
Dim TheDateTime As Date

ReturnValue = 0

'Code removed (early binding)
'Set OlApp = New Outlook.Application

'Code added for late binding
'---------------------------
On Error Resume Next
Set OlApp = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Set OlApp = CreateObject("Outlook.application")
End If
If IsDebugMode = 0 Then On Error GoTo SendONEEmail_Error
'---------------------------

Set olMail = OlApp.CreateItem(olMailItem)
With olMail
.To = ToString
.CC = CCString
.BCC = BCCString
.Subject = SubjectString
If (Nz(BodyHTMLString, "") "") Then
.BodyFormat = olFormatHTML
.Body = BodyString
.HTMLBody = BodyHTMLString
Else
.BodyFormat = olFormatPlain
.Body = BodyString
End If

For i = 1 To 9
If (Attachments(i) "") Then
.Attachments.Add Attachments(i)
End If
Next i
If (Nz(preview, "") = "Yes") Then
.Display
ReturnValue = 1
Else
.Send
'Note if NO email address specified or some other error occurs then the code will jump to
'the error handling and will return a 0 (indicating a problem sending this email)
ReturnValue = 1

'if ComboRecordCorrespondence = "Yes" then create an activity to
'indicate that an email has been sent
If (Me.ComboRecordCorrespondence = "Yes") Then
Emailtext = "TO: " & ToString & "
" & IIf(CCString = "", "", "CC: " & CCString & "
") & IIf(BCCString = "", "", "BCC: " & BCCString & "
") & "Subject: " & SubjectString & "
" & Replace(BodyString, vbCrLf, "
")
TheDateTime = Now()
Call AddCorrespondenceHistory(ContactID, Emailtext, TheDateTime)
End If
End If
End With


SendONEEmail_Exit:
SendONEEmail = ReturnValue
Set olMail = Nothing
Set OlApp = Nothing
Exit Function

SendONEEmail_Error:
'Don't display message - allow errors to continue
'Call ErrorLog(Err.Description, Err.Number, Me.Name, Erl, "SendONEEmail")
Resume SendONEEmail_Exit

End Function
Private Sub AddCorrespondenceHistory(ContactID As Long, Emailtext As String, TheDateTime As Date)
If IsDebugMode = 0 Then On Error GoTo AddCorrespondenceHistory_Error

Dim sql As String
sql = "INSERT INTO tblActivity ( ContactID, ActivityType, ActivityDate, ActivityTime, Description, Notes, UpdatedDate, CreatedDate ) " & _
"SELECT tblContact.ContactID, 'E-Mail' AS Expr3, #" & Format(TheDateTime, "mm/dd/yyyy") & "# AS Expr5, #" & Format(TheDateTime, "hh:mm AMPM") & "# AS Expr6, 'E-Mail using E-Mail template' AS Expr7, """ & Emailtext & """ as Expr8, #" & Format(TheDateTime, "mm/dd/yyyy hh:mm AMPM") & "# AS Expr9, #" & Format(TheDateTime, "mm/dd/yyyy hh:mm AMPM") & "# AS Expr10 " & _
"From tblContact " & _
"WHERE (tblContact.ContactID = " & ContactID & ");"

CurrentDb.Execute (sql)

AddCorrespondenceHistory_Exit:
Exit Sub

AddCorrespondenceHistory_Error:
Call ErrorLog(Err.Description, Err.Number, Me.Name, Erl, "AddCorrespondenceHistory")
Resume AddCorrespondenceHistory_Exit
End Sub

Hello All-

There may be a very simple fix for this but I'm very new to the code world and don't completely understand what's going wrong.

I have a data entry form in a survey-like database. One subform is used to enter in responses for each of 12 criteria (equivalent to "questions"). The 12 criteria are featured in a combobox which then filters a multiselect listbox (they can choose more than 1 response under each criteria)to contain only the potential answers related to that particular criteria. This then passes each selection to a separate record in the response table. Its set up so that when the person presses the next criteria button it moves to the next criteria on the list.

The problem comes when you get to the 12th and last criteria. I'm not sure how to tell the form that after responses have been entered for the 12th criteria, save that record(s), and then move on to next control (which is another subform.

I'd added in another button "end criteria" which would move the focus to the next control but it often doesn't save the records associated with the last criteria. And it would be great if the second button wasn't necessary.

Here's the code:

Option Compare Database
Option Explicit

Private Sub cboCriteriaid_AfterUpdate()
Me.OptionID.Requery
End Sub

Private Sub Command10_Click()

'Dim OptionID As Control
Dim MyControl As Control
Dim varItm As Variant
Dim intI As Integer
Dim strPick As String
Set MyControl = Forms!frmApplication!fsubResponse!cboCriteriaid
For Each varItm In OptionID.ItemsSelected 'now process selected items...
If varItm >= 0 Then 'selected item?
strPick = "Insert into Response(HabitatID, Criteriaid, OptionID, Answercom) Values (" & Forms!frmApplication!fsubResponse!HabitatID & "," & Me.cboCriteriaid.Column(0) & "," & OptionID.Column(0, varItm) & ",'" & Me.AnswerCom & "');"
'MsgBox strPick 'To view what numbers are being saved for troubleshooting
xSql strPick
End If
Next
'clear selected items
For Each varItm In OptionID.ItemsSelected
If varItm >= 0 Then 'is this one selected
OptionID.Selected(varItm) = False
End If
Next

Me.cboCriteriaid = MyControl + 1
Me.AnswerCom = ""
cboCriteriaid_AfterUpdate


End Sub

Private Sub Command11_Click()
Forms!frmApplication!fsubHowDoYouEnjoy2!enjoyCode. SetFocus
End Sub

And I've attached a screen shot of the form.

Thanks for any assistance!

Stephanie

I have dabbled in object oriented programming in the past but not much. My database is getting quite complicated, so I thought I would begin to implement it to keep things from getting too cumbersome when future changes are necessary.

I have created a Vendor object, which when initialized will pull pertinent stats concerning my various vendors. I have added several properties that will return the results of more complex calculations if their values are not already set.

I can now create and destroy a Vendor object, obtaining the pertinent information I need, in about 235 miliseconds.


	Code:
	Sub TestOne()
    Dim Vendor As Vendor
    Dim stpWtch As StopWatch
    
    Set stpWtch = New StopWatch
    Set Vendor = New Vendor
    
    stpWtch.StartTimer
    Vendor.InitializeFirm (2)
    MsgBox "Name: " & Vendor.Name & vbCrLf _
        & "ID: " & Vendor.ID & vbCrLf _
        & "Rating: " & Vendor.CurrentRating & vbCrLf _
        & "Distance: " & Vendor.Distance("63042") & vbCrLf _
        & "Cost: " & Format(Vendor.EstimatedCost("63042"), "currency") & vbCrLf _
        & "Time: " & stpWtch.Formatted
    
    Set Vendor = Nothing
    Set stpWtch = Nothing
End Sub

This is where I get lost using the object oriented approach. I now need to create vendor objects for each vendor in a pre-defined subset, sort the information, and display it back to the user.

First, I am a little shaky on creating and working with a collection of objects, but I think I can work through that.

My real problem is that with the exception of creating a temp table to store the retrieved information (which doesn't seem preferable in a multiuser environment), I cannot think of a good way to display the data back to the user. I basically am looking to populate a listbox with the results and allow the user the option to sort by rating, estimated cost, or distance (obviously changing the sort order of the underlying record source). I cannot set the RowSource propety directly, as the resulting string will often times be longer than what is allowed.

I am tempted to blow up my vendor object, and just create separate functions that I could include in a query, even though it would increase the amount of processing time necessary to pull the information. I would really appreciate the recommendations of anyone who has experience with an object oriented approach.

Hello everyone. im new to Access and willing to learn and someday be able to help someone. Here's the problem.. i need a code or someone to show me how to fix this problem...
im working on a personal expence ledger. I need some assistance on a particular field that is labeled [expence/income], and a field labeled [amount]. the [expence/income]field is a listbox field "with expence and imcome as the values. Here is what i want to do. when i select income from the listbox i want it to sum the total in the amount] field, and if i select expence i want it to subtract the total in the [amount] field. i hope i explain it correctly.

/Thanks Bobby

Hi all,

I am an Access/ VB newby, but an application & database veteran. Normally I use Oracle, SQL and PL/SQL but want to broaden my horizon.
I did a lot of SAS/ AF programming in the past and the event driven developments are a lot alike. (design screen, put in code for events that happen on screen)

So I bought the Visual Basic for Applications Fundamentals and read and exercised through it. Understand all that in there, but reading clicking along is something else then "roll your own"....

I want to develop a simple app for tracking projects, subprojects, materials, hours. Then send bills, see progress and budget limits etc. (Yeah, I've seen MS Projects, thanks, but no thanks!)

So here's a bunch of questions on how to get started in this area. Any, help, links, code examples etc. will be be very much appreciated. (TIA!)
I'm sorry I refer to what I did and how I did it in SAS, but that's the only ApDev environment I know.

In SAS you can use lists. A list is a memmory allocation which can store data or settings. Sort of like an ARRAY in other evironments, but unstructured and with an unknown number of entries.

Q: Is there anything simular in Access VB??? How is it called and how do I use it?

In SAS I always created an application manager class, that was aware of all my current settings. For instance when a user set the background color to 'black' I called the Managers SetBackGroundColor method with the value 'BLACK' and when the next screen opens I started with the GetBackGroundColor method,
resulting in 'BLACK', making the background of my new screen turn .... Black.

Q: Is this the way you do it in Access as well, or are there other ways to store global values, needed at any time through the application???? How are these golbal application settings called, how does one set and get them??

Once more on the list thing: In my current Access app I want to appoint people to projects. So if the user selected an project, she gets a listbox on the left with all (still) available resources and a listbox on the right with all the resources appointed to this project. (And there are buttond with > , >> , < ,

I created a form which allows me to add multiple systems to one Work center.. I dreated an add button that attaches each system with a work center ID See code below:

Private Sub cmd_Add_Click()
'Define all of your variables dim = dimension - old termonolgy
Dim Sys As Integer
Dim sql As String
Dim source As String

'turn off warnings so it does not tell you it is adding rows to a table
DoCmd.SetWarnings False


'This code checks to see that the user has selected a name before trying to add an system
If lbSys.ItemsSelected.Count = 0 Then
MsgBox "Please select a system"
Me.lbSys.SetFocus
End If

'Create an insert query to write the new record to the xref table
sql = "insert into tbl_WC_Sys_xref (WC_ID, Sys_ID) values (" & Me.WC_ID & ", " & Me.lbSys & ")"

'run the query you just wrote
DoCmd.RunSQL sql

'Reset the values in the list box to display the new entries
'source = "SELECT distinct [tbl_systems].[Sys_ID], [tbl_systems].[Sys_Name] FROM tbl_systems, tbl_general_information, tbl_WC_Sys_xref WHERE [tbl_systems].[Sys_ID]=[tbl_WC_Sys_xref].[Sys_ID] And [tbl_WC_Sys_xref].[WC_ID]=" & Me.WC_ID

'Set the source of the listbox to the query you just wrote
'lb_assigned.RowSource = source
lb_assigned.Requery
'turn the warnings back on
DoCmd.SetWarnings True

End Sub

My question is what code would I write to prevent multiple records. Example If I sit on system 1 and click add to assign it in my table...when go back to my table it says
Wc_ID Sys_ID
1 1
1 1
1 1
1 1

I would like it to just be listed once..Any suggestions?

Thanks

I have a main form with several continuous subforms. Each subform consists of several listbox controls. I would like to require the user to select an item from the listbox before being allowed to move to the next record in the subform, and upon reaching the last record in that continuous subform, to require an entry there in order to move to the first record in the next cont. subform.

As an added bonus, it would be nice, though not necessary, to automatically jump the focus from one record to the next after data is entered. But my basic goal is to avoid skipping records.

Caveat: I cannot use the "required" option in the field to which the control is bound because that field has a default value previously entered using an append query. (The default value basically means "not yet entered" and is not one of the options in the listbox. I am using this because this field is a foreign key in the table, thus it must have a value in order to have a record with which to populate the subform.)

My apologies if this has been asked and answered elsewhere, but I've searched and, while I found a few related threads, they don't quite answer my question. Here they are for reference:

http://www.access-programmers.co.uk/...ad.php?t=38364
http://www.access-programmers.co.uk/...ad.php?t=69047
http://www.access-programmers.co.uk/...d.php?t=103176

Thanks for any help! Also, if you are going to recommend VB code, could you be specific about how and where I should use it? I'm not afraid of code, but I'm definitely new to it...

hi guys i was wondering if you can help me this is my code: i have a main form with this code, this form contains a subform linked by the All_PricingID

Set rst = CurrentDb.OpenRecordset("tblAll_Pricing") 'main table
' adding data to the table
rst.AddNew
' Main table
rst!All_PricingID = Me.txtPricingID 'Main table pk
rst!MainContract_ID = Me.cmbMainContract 'combo box in parent form
rst!ItemNumber = Me.txtItem 'Main form text
rst.Update

'sub Table
Set rst2 = CurrentDb.OpenRecordset("tblPricing") 'sub table
For varItem = 0 To Me.lstsubContracts.ListCount - 1 'this is a list in the main form
'--- loop through all the items in the list box and create a new row in the subform for each subcontract in the listbox lstSubcontracts.
rst2.AddNew
rst2!ID = Me.All_PricingID 'sub table foreign key
rst2!SubContractID = Me.lstsubContracts.Column(0, varItem) 'sub table
rst2.Update
Next varItem
'--- close the tables
rst.Close
rst2.Close
Set rst = Nothing
Set rst2 = Nothing


the subform appears correctly with the rows i wanted added but i need the user to be able to edit a column in the subform for the rows just created (my form is on datasheet view). but everytime i move to cursor into the subform, i can't even scroll up and down.

i keep getting an error that says :

The changes you requested to the table were not successful because they would create duplicate values in the index, primary key, or relationship. (Error 3022)


but when i check my tables tblAll_Pricing and tblPricing , everything is inserted correctly according to my recorset above, do you know why this is happening? and why i am not able to edit my subform. my subform allowsedits and additions.


help!!

Hello everyone,

I had a question in regards to a listbox problem that I seem to be having.

I have a listbox on a form. The listbox is unbound. The rowsource is set to a query to pull in the results of a textbox on the screen.

The problem I have is I have two textboxes on the screen and those are used to add a "call log" into the tblContacts table. When the persons name and summary of what they said was entered, on the press of the Add button, the action does the following:


	Code:
	Private Sub Command239_Click()

Dim cnn1 As ADODB.Connection
Dim rstcontact As ADODB.Recordset
Dim strCnn As String

' Open a connection.
    Set cnn1 = New ADODB.Connection
   mydb = "databaselocationremovedforcodetest"
strCnn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & mydb
    cnn1.Open strCnn

' Open contact table.
    Set rstcontact = New ADODB.Recordset
    rstcontact.CursorType = adOpenKeyset
    rstcontact.LockType = adLockOptimistic
    rstcontact.Open "tblContact", cnn1, , , adCmdTable


'get the new record data
rstcontact.AddNew
        rstcontact!ContactPerson = txtContact
        rstcontact!Summary = txtSummary
        rstcontact!Date = DateTime.Now
        rstcontact!ID = IDNumber.Value
        
        rstcontact.Update
        
' Show the newly added data.
        MsgBox "New contact: " & rstcontact!ContactPerson & " has been successfully added."
        
'close connections
rstcontact.Close
    cnn1.Close
   
    'clear values
    txtContact = ""
    txtSummary = ""
   
   TWait = Time
TWait = DateAdd("s", 1.5, TWait)
Do Until TNow >= TWait
     TNow = Time
Loop

List250.Requery
    
    
End Sub

I added the timer in there because what was happening was when the add would happen, the listbox is to requery and show the newly added result. However, that has been hap-hazard at best. Sometimes it works and sometimes it doesn't even with the timer.

I am beginning to think the problem lies in the query that the listbox depends on. When I requery the listbox I am assuming it runs the query to which its row source is Dependant on. But I don't understand why it doesn't update like it should since the data is in the database.

Any help would be appreciated.


Not finding an answer? Try a Google search.