A
Amour
Hi, I am new to access saying nothing about a header program.
Right now I have this header program:
Option Explicit
Function ListHeadConvert(whichposting)
Select Case whichposting
Case "MEMA"
ListHeadConvert = "Membership Appointment"
Case "MEMR"
ListHeadConvert = "Membership Reappointment"
Case "CNSR"
ListHeadConvert = "Consultant Renewal"
Case "CNMA"
ListHeadConvert = "Consultant Non-Member Appointment"
Case "CNMR"
ListHeadConvert = "Consultant Non-Member Reappointment"
End Select
End Function
Function modifyPostHeads(whichposting)
Dim qrystring As String
Dim theform As String
Select Case whichposting
Case 1
qrystring = "MEMA"
theform = "frmMbrAppoinmentSub"
Case 2
qrystring = "MEMR"
theform = "frmMbrRenewalSub"
Case 3
qrystring = "CNSR"
theform = "frmConsultantRenewalSub"
Case 4
qrystring = "CNMA"
theform = "frmConNonMbrAppointmentSub"
Case 5
qrystring = "CNMR"
theform = "frmConsultantNonMbrRenewelSub"
End Select
DoCmd.OpenForm "frmPostingHeadLRH", , , "list_name = '" & qrystring & "'"
End Function
Function ChangeHeadings()
Dim rst2 As Recordset
Dim dbs As Database
Dim strSql As String
Dim mycontrol As Control
Dim NumberofNotEmpty As Integer
Dim NumberofdateFields As Integer
Dim x As Integer
Dim i As Integer
Dim Controlname As String
Dim leftpost As Integer
Dim toppost As Integer
Dim tabnumber As Integer
Dim thedata As String
Dim thewidth As Integer
Dim theheight As Integer
Dim NewControl As Control
Dim firstcontrol As Control
Dim xoldnum As Integer
Dim tempname As String
Dim intI As Integer
Dim xnumber, xrecords, xdates As Integer
Dim xhowmany As Integer
Dim CurCaption() As String
Dim xName, xcontrolsource As String
Dim xyz As Integer
Dim ctl As Control
Dim junk As String
Dim xform
Dim theform As String
Dim abc As String
Dim newForm
Dim totline As Integer
Dim xpdate As Boolean
Dim nc, nextitem As Integer
Dim qrystring, xACTION As String
Dim frm As String, mdl As Module
Dim ctlname As String, lngreturn, lngformreturn, lngcloseformreturn,
lngDeclarationreturn As Long
Dim xunderscore, thiscaption, blank, xfoundblank, xfoundapostroph As String
Dim xblankpos, nextblankpos, xapostrophepos, xopenparenpos, xcloseparenpos,
xbackslashpos, xforslashpos As Long
If ListHeadConvert([LIST_NAME]) = "Membership Appointment" Then
qrystring = "MEMA"
theform = "frmMbrAppoinmentSub"
ElseIf ListHeadConvert([LIST_NAME]) = "Membership Reappointment" Then
qrystring = "MEMR"
theform = "frmMbrRenewalSub"
ElseIf ListHeadConvert([LIST_NAME]) = "Consultant Renewal" Then
qrystring = "CNSR"
theform = "frmConsultantRenewelSub"
ElseIf ListHeadConvert([LIST_NAME]) = "Consultant Non-Member Appointment" Then
qrystring = "CNMA"
theform = "frmConNonMbrAppointmentSub"
ElseIf ListHeadConvert([LIST_NAME]) = "Consultant Non-Member Reappointment"
Then
qrystring = "CNMR"
theform = "frmConsultantNonMbrRenewelSub"
End If
Set dbs = CurrentDb()
strSql = "SELECT * FROM [tblPostingHead]"
strSql = strSql & " WHERE [list_name]='" & qrystring & "'"
strSql = strSql & " ORDER BY VAL (MID([xFieldName],5,2));"
Set rst2 = dbs.OpenRecordset(strSql)
Debug.Print strSql
rst2.MoveFirst
xrecords = rst2.RecordCount 'GET THE NUMBER OF RECORDS!!!
xdates = xrecords - 5 ' HARD CODED TO SUBTRACT REQUIRED FIELDS SSN, NAME,
LIST_NAME, AND OLDNUMBER
xnumber = 0
DoCmd.OpenForm theform, acDesign
If rst2!LIST_NAME = "MEMA" Then
Forms!frmMbrAppoinmentSub.HasModule = False
xyz = Forms!frmMbrAppoinmentSub.Controls.Count - 1
ElseIf rst2!LIST_NAME = "MEMR" Then
Forms!frmMbrRenewalSub.HasModule = False
xyz = Forms!frmMbrRenewalSub.Controls.Count - 1
ElseIf rst2!LIST_NAME = "CNSR" Then
Forms!frmConsultantRenewelSub.HasModule = False
xyz = Forms!frmConsultantRenewelSub.Controls.Count - 1
ElseIf rst2!LIST_NAME = "CNMA" Then
Forms!frmConNonMbrAppointmentSub.HasModule = False
xyz = Forms!frmConNonMbrAppointmentSub.Controls.Count - 1
ElseIf rst2!LIST_NAME = "CNMR" Then
Forms!frmConsultantNonMBRRenewelsub.HasModule = False
xyz = Forms!frmConsultantNonMBRRenewelsub.Controls.Count - 1
End If
For x = xyz To 0 Step -1
If rst2!LIST_NAME = "MEMA" Then
junk = Forms!frmMbrAppoinmentSub.Controls(x).Name
ElseIf rst2!LIST_NAME = "MEMR" Then
junk = Forms!frmMbrRenewalSub.Controls(x).Name
ElseIf rst2!LIST_NAME = "CNSR" Then
junk = Forms!frmConsultantRenewelSub.Controls(x).Name
ElseIf rst2!LIST_NAME = "CNMA" Then
junk = Forms!frmConNonMbrAppointmentSub.Controls(x).Name
ElseIf rst2!LIST_NAME = "CNMR" Then
junk = Forms!frmConsultantNonMBRRenewelsub.Controls(x).Name
End If
DeleteControl theform, junk
Debug.Print junk
Next
'Forms!frmMbrAppoinmentSub.HasModule = False
'DoCmd.DoMenuItem acFormBar, acFile, acSaveForm
'DoCmd.DoMenuItem acFormBar, acFile, acSaveForm, , acMenuVer70
'DoCmd.OpenForm theform, acDesign
'DoCmd.RunCommand acCmdSave
xpdate = False
If rst2!LIST_NAME = "MEMA" Then
xyz = Forms!frmMbrAppoinmentSub.Controls.Count
Forms!frmMbrAppoinmentSub.HasModule = True
Set newForm = Forms!frmMbrAppoinmentSub
Set mdl = Forms!frmMbrAppoinmentSub.Module
xform = "frmMbrAppoinmentSub"
ElseIf rst2!LIST_NAME = "MEMR" Then
xyz = Forms!frmMbrRenewalSub.Controls.Count
Forms!frmMbrRenewalSub.HasModule = True
Set newForm = Forms!frmMbrRenewalSub
Set mdl = Forms!frmMbrRenewalSub.Module
xform = "frmMbrRenewalSub"
xpdate = True
ElseIf rst2!LIST_NAME = "CNSR" Then
xyz = Forms!frmConsultantRenewelSub.Controls.Count
Forms!frmConsultantRenewelSub.HasModule = True
Set newForm = Forms!frmConsultantRenewelSub
Set mdl = Forms!frmConsultantRenewelSub.Module
xform = "frmConsultantRenewelSub"
xpdate = True
ElseIf rst2!LIST_NAME = "CNMA" Then
xyz = Forms!frmConNonMbrAppointmentSub.Controls.Count
Forms!frmConNonMbrAppointmentSub.HasModule = True
Set newForm = Forms!frmConNonMbrAppointmentSub
Set mdl = Forms!frmConNonMbrAppointmentSub.Module
xform = "frmConNonMbrAppointmentSub"
ElseIf rst2!LIST_NAME = "CNMR" Then
xyz = Forms!frmConsultantNonMBRRenewelsub.Controls.Count
Forms!frmConsultantNonMBRRenewelsub.HasModule = True
Set newForm = Forms!frmConsultantNonMBRRenewelsub
Set mdl = Forms!frmConsultantNonMBRRenewelsub.Module
xform = "frmConsultantNonMbrRenewelSub"
xpdate = True
End If
rst2.MoveFirst
xhowmany = rst2.RecordCount
leftpost = 50
toppost = 50
tabnumber = 0
thewidth = 500
theheight = 200
'insert code in form module
'I commented this out
'lngformreturn = mdl.CreateEventProc("Load", "Form")
'mdl.InsertLines lngformreturn + 1, "Me!SSN.ColumnHidden = -1"
'mdl.InsertLines lngformreturn + 2, "Me!LIST_NAME.ColumnHidden = -1"
'mdl.InsertLines lngformreturn + 3, "Me!mbrName.ColumnWidth = -2"
'mdl.InsertLines lngformreturn + 4, "Me![date posted].ColumnWidth = -2"
'mdl.InsertLines lngformreturn + 4, "Me![Past Due].ColumnWidth = -2"
'check for invalid event handlers
' delete out all code in module
totline = mdl.CountOfLines
mdl.DeleteLines 1, totline
'hard coded for ssn, list_name, post_date, status
Set NewControl = CreateControl(theform, acTextBox, , , , leftpost, toppost,
thewidth, theheight)
newForm.Controls(0).Name = "ssn"
newForm.Controls(0).ControlSource = "ssn"
newForm.Controls(0).TabStop = 0
newForm.Controls(0).TabIndex = 0
newForm.Controls(0).Visible = 0
Set NewControl = CreateControl(theform, acTextBox, , , , leftpost, toppost,
thewidth, theheight)
newForm.Controls(1).Name = "list_name"
newForm.Controls(1).ControlSource = "list_name"
newForm.Controls(1).TabStop = 0
newForm.Controls(1).TabIndex = 0
newForm.Controls(1).Visible = 0
Set NewControl = CreateControl(theform, acTextBox, , , , leftpost, toppost,
thewidth, theheight)
newForm.Controls(2).Name = "Name"
newForm.Controls(2).ControlSource = "mbrName"
newForm.Controls(2).TabStop = 0
newForm.Controls(2).TabIndex = 0
newForm.Controls(2).Visible = -1
newForm.Controls(2).Enabled = 0
nc = 2
If xpdate Then
nc = 3
Set NewControl = CreateControl(theform, acTextBox, , , , leftpost,
toppost, thewidth, theheight)
newForm.Controls(3).Name = "Exp Date"
newForm.Controls(3).ControlSource = "exp_date"
newForm.Controls(3).TabStop = 0
newForm.Controls(3).TabIndex = 0
newForm.Controls(3).Visible = -1
newForm.Controls(3).Enabled = 0
End If
Set NewControl = CreateControl(theform, acTextBox, , , , leftpost, toppost,
thewidth, theheight)
newForm.Controls(nc + 1).Name = "Date Posted"
newForm.Controls(nc + 1).ControlSource = "post_date"
newForm.Controls(nc + 1).TabStop = 1
newForm.Controls(nc + 1).TabIndex = 0
newForm.Controls(nc + 1).Visible = -1
newForm.Controls(nc + 1).Enabled = 0
Set NewControl = CreateControl(theform, acTextBox, , , , leftpost, toppost,
thewidth, theheight)
newForm.Controls(nc + 2).Name = "Past Due"
newForm.Controls(nc + 2).ControlSource = "Status"
newForm.Controls(nc + 2).TabStop = 2
newForm.Controls(nc + 2).TabIndex = 0
newForm.Controls(nc + 2).Visible = -1
newForm.Controls(nc + 2).Enabled = 0
'Set NewControl = CreateControl(theform, acTextBox, , , , leftpost, toppost,
thewidth, theheight)
'newForm.Controls(nc + 3).Name = "Nominated by:"
'newForm.Controls(nc + 3).ControlSource = "Name"
'newForm.Controls(nc + 3).TabStop = 3
'newForm.Controls(nc + 3).TabIndex = 0
'newForm.Controls(nc + 3).Visible = -1
'newForm.Controls(nc + 3).Enabled = 0
rst2.MoveFirst
Do Until UCase(Left(rst2.Fields("xfieldname"), 5)) = "DATE1"
rst2.MoveNext
Loop
nextitem = nc + 4
Debug.Print ("nextitem" & nextitem)
For i = nextitem To xhowmany
thiscaption = rst2!Caption
If Not IsNull(thiscaption) Then
xcontrolsource = rst2!xFieldName
xName = rst2!Caption
'xName = thiscaption
ctlname = xName
nc = nc + 1
Debug.Print "i " & i & "xcontrol " & xcontrolsource & " ctl " &
ctlname
Set NewControl = CreateControl(theform, acTextBox, , , ,
leftpost, toppost, thewidth, theheight)
If rst2!LIST_NAME = "MEMA" Then
Forms!frmMbrAppoinmentSub.Controls(i - 1).Name = xName
Forms!frmMbrAppoinmentSub.Controls(i - 1).ControlSource =
xcontrolsource
Forms!frmMbrAppoinmentSub.Controls(i - 1).TabStop = nc + 3
ElseIf rst2!LIST_NAME = "MEMR" Then
Forms!frmMbrRenewalSub.Controls(i - 1).Name = xName
Forms!frmMbrRenewalSub.Controls(i - 1).ControlSource =
xcontrolsource
Forms!frmMbrRenewalSub.Controls(i - 1).TabStop = nc + 3
ElseIf rst2!LIST_NAME = "CNSR" Then
Forms!frmConsultantRenewelSub.Controls(i - 1).Name = xName
Forms!frmConsultantRenewelSub.Controls(i - 1).ControlSource
= xcontrolsource
Forms!frmConsultantRenewelSub.Controls(i - 1).TabStop = nc + 3
ElseIf rst2!LIST_NAME = "CNMA" Then
Forms!frmConNonMbrAppointmentSub.Controls(i - 1).Name = xName
Forms!frmConNonMbrAppointmentSub.Controls(i -
1).ControlSource = xcontrolsource
Forms!frmConNonMbrAppointmentSub.Controls(i - 1).TabStop =
nc + 3
ElseIf rst2!LIST_NAME = "CNMR" Then
Forms!frmConsultantNonMBRRenewelsub.Controls(i - 1).Name =
xName
Forms!frmConsultantNonMBRRenewelsub.Controls(i -
1).ControlSource = xcontrolsource
Forms!frmConsultantNonMBRRenewelsub.Controls(i - 1).TabStop
= nc + 3
End If
Debug.Print ("nc during " & nc)
'Create After Update event procedure for date fields
If ctlname = "LIST_NAME" Or ctlname = "SSN" Or ctlname = "mbrNAME"
Then
leftpost = leftpost + thewidth + 50
rst2.MoveNext
Else
If (Not IsNull(rst2!Trigger)) And (Not IsEmpty(rst2!Trigger)) Then
thiscaption = xName
xblankpos = InStr(thiscaption, " ")
If xblankpos > 0 Then
Mid(thiscaption, xblankpos, 1) = "_"
End If
nextblankpos = InStr(7, thiscaption, " ", 0)
If nextblankpos > 0 Then
Mid(thiscaption, nextblankpos, 1) = "_"
End If
xapostrophepos = InStr(thiscaption, "'")
If xapostrophepos > 0 Then
Mid(thiscaption, xapostrophepos, 1) = "_"
End If
xopenparenpos = InStr(thiscaption, "(")
If xopenparenpos > 0 Then
Mid(thiscaption, xopenparenpos, 1) = "_"
End If
xcloseparenpos = InStr(thiscaption, ")")
If xcloseparenpos > 0 Then
Mid(thiscaption, xcloseparenpos, 1) = "_"
End If
xforslashpos = InStr(thiscaption, "/")
If xforslashpos > 0 Then
Mid(thiscaption, xforslashpos, 1) = "_"
End If
xbackslashpos = InStr(thiscaption, "\")
If xbackslashpos > 0 Then
Mid(thiscaption, xbackslashpos, 1) = "_"
End If
If IsNumeric(Left(thiscaption, 1)) Then
thiscaption = "ctl" & thiscaption
End If
Debug.Print ("this cap" & thiscaption)
lngreturn = mdl.CreateEventProc("AfterUpdate", thiscaption)
mdl.InsertLines lngreturn + 1, "Dim Msg, Style, TITLE, Help,
Ctxt, Response, MyString "
mdl.InsertLines lngreturn + 2, "Dim criteria, ssnnumber,
DocName As String"
mdl.InsertLines lngreturn + 3, "Dim ctl As Control"
mdl.InsertLines lngreturn + 4, "Dim xFieldName, xlistname As
String"
mdl.InsertLines lngreturn + 5, "OnCurrent = ""[Event
Procedure]"""
mdl.InsertLines lngreturn + 6, "ssnnumber = Me!SSN"
mdl.InsertLines lngreturn + 7, "criteria = ""[SSN]= '"" &
ssnnumber & ""'"""
mdl.InsertLines lngreturn + 8, "Msg = ""Form Letter needs to
be sent, Would you like to send it now ?"""
mdl.InsertLines lngreturn + 9, "Style = vbYesNo +
vbExclamation + vbDefaultButton2"
mdl.InsertLines lngreturn + 10, "TITLE = ""Action"""
mdl.InsertLines lngreturn + 11, "Response = MsgBox(Msg,
Style, TITLE)"
mdl.InsertLines lngreturn + 12, "If Response = vbYes Then"
mdl.InsertLines lngreturn + 13, " Set ctl =
Screen.ActiveControl"
mdl.InsertLines lngreturn + 14, " xFieldName =
ctl.ControlSource"
mdl.InsertLines lngreturn + 15, " xlistname = Me!LIST_NAME"
mdl.InsertLines lngreturn + 16, " DocName =
""FrmSendLetter"""
mdl.InsertLines lngreturn + 17, " DoCmd.OpenForm DocName, ,
, criteria"
mdl.InsertLines lngreturn + 18, "
Forms!frmSendLetter!xFieldName = xFieldName"
mdl.InsertLines lngreturn + 19, "
Forms!frmSendLetter!LIST_NAME = xlistname"
mdl.InsertLines lngreturn + 20, " Forms!frmSendLetter!SSN =
ssnnumber"
mdl.InsertLines lngreturn + 21, "End If"
End If
leftpost = leftpost + thewidth + 50
rst2.MoveNext
End If
End If
Next
rst2.Close
DoCmd.Save acForm, xform
'docmd.RunCommand acCmdSave
'DoCmd.DoMenuItem acFormBar, acFile, acSaveForm, , acMenuVer70
DoCmd.Close
End Function
Private Sub Command12_Click()
On Error GoTo Err_Command12_Click
DoCmd.Close
Exit_Command12_Click:
Exit Sub
Err_Command12_Click:
MsgBox Err.Description
Resume Exit_Command12_Click
End Sub
Private Sub btnClose_Click()
'On Error GoTo Err_btnClose_Click
Dim retvalue As String
retvalue = ChangeHeadings()
DoCmd.Close
DoCmd.Close acForm, "frmPostingHeadLRH", acSaveNo
Exit_btnClose_Click:
Exit Sub
Err_btnClose_Click:
MsgBox Err.Description
Resume Exit_btnClose_Click
End Sub
Private Sub Command20_Click()
Dim i As Integer
Dim x As String
'Set fs = Application.FileSearch
With Application.FileSearch
.LookIn = "C:\asb6\lettertemplates"
.SearchSubFolders = True
.filename = "*.doc"
x = ""
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
x = x & .FoundFiles(i) & ";"
Next i
Else
x = "No Files"
End If
End With
Me!filelist.RowSource = x
End Sub
Private Sub Form_Load()
Dim i As Integer
Dim x As String
'Command20_Click
End Sub
The Subform that comes up is in Datasheet View, NOTE: I cannot change this
to a continues form because my boss wants to freeze the first colum.
All I want to do is add another Colum or 2, but the counter will not let me.
Please help And Thank You For Any Help!
Right now I have this header program:
Option Explicit
Function ListHeadConvert(whichposting)
Select Case whichposting
Case "MEMA"
ListHeadConvert = "Membership Appointment"
Case "MEMR"
ListHeadConvert = "Membership Reappointment"
Case "CNSR"
ListHeadConvert = "Consultant Renewal"
Case "CNMA"
ListHeadConvert = "Consultant Non-Member Appointment"
Case "CNMR"
ListHeadConvert = "Consultant Non-Member Reappointment"
End Select
End Function
Function modifyPostHeads(whichposting)
Dim qrystring As String
Dim theform As String
Select Case whichposting
Case 1
qrystring = "MEMA"
theform = "frmMbrAppoinmentSub"
Case 2
qrystring = "MEMR"
theform = "frmMbrRenewalSub"
Case 3
qrystring = "CNSR"
theform = "frmConsultantRenewalSub"
Case 4
qrystring = "CNMA"
theform = "frmConNonMbrAppointmentSub"
Case 5
qrystring = "CNMR"
theform = "frmConsultantNonMbrRenewelSub"
End Select
DoCmd.OpenForm "frmPostingHeadLRH", , , "list_name = '" & qrystring & "'"
End Function
Function ChangeHeadings()
Dim rst2 As Recordset
Dim dbs As Database
Dim strSql As String
Dim mycontrol As Control
Dim NumberofNotEmpty As Integer
Dim NumberofdateFields As Integer
Dim x As Integer
Dim i As Integer
Dim Controlname As String
Dim leftpost As Integer
Dim toppost As Integer
Dim tabnumber As Integer
Dim thedata As String
Dim thewidth As Integer
Dim theheight As Integer
Dim NewControl As Control
Dim firstcontrol As Control
Dim xoldnum As Integer
Dim tempname As String
Dim intI As Integer
Dim xnumber, xrecords, xdates As Integer
Dim xhowmany As Integer
Dim CurCaption() As String
Dim xName, xcontrolsource As String
Dim xyz As Integer
Dim ctl As Control
Dim junk As String
Dim xform
Dim theform As String
Dim abc As String
Dim newForm
Dim totline As Integer
Dim xpdate As Boolean
Dim nc, nextitem As Integer
Dim qrystring, xACTION As String
Dim frm As String, mdl As Module
Dim ctlname As String, lngreturn, lngformreturn, lngcloseformreturn,
lngDeclarationreturn As Long
Dim xunderscore, thiscaption, blank, xfoundblank, xfoundapostroph As String
Dim xblankpos, nextblankpos, xapostrophepos, xopenparenpos, xcloseparenpos,
xbackslashpos, xforslashpos As Long
If ListHeadConvert([LIST_NAME]) = "Membership Appointment" Then
qrystring = "MEMA"
theform = "frmMbrAppoinmentSub"
ElseIf ListHeadConvert([LIST_NAME]) = "Membership Reappointment" Then
qrystring = "MEMR"
theform = "frmMbrRenewalSub"
ElseIf ListHeadConvert([LIST_NAME]) = "Consultant Renewal" Then
qrystring = "CNSR"
theform = "frmConsultantRenewelSub"
ElseIf ListHeadConvert([LIST_NAME]) = "Consultant Non-Member Appointment" Then
qrystring = "CNMA"
theform = "frmConNonMbrAppointmentSub"
ElseIf ListHeadConvert([LIST_NAME]) = "Consultant Non-Member Reappointment"
Then
qrystring = "CNMR"
theform = "frmConsultantNonMbrRenewelSub"
End If
Set dbs = CurrentDb()
strSql = "SELECT * FROM [tblPostingHead]"
strSql = strSql & " WHERE [list_name]='" & qrystring & "'"
strSql = strSql & " ORDER BY VAL (MID([xFieldName],5,2));"
Set rst2 = dbs.OpenRecordset(strSql)
Debug.Print strSql
rst2.MoveFirst
xrecords = rst2.RecordCount 'GET THE NUMBER OF RECORDS!!!
xdates = xrecords - 5 ' HARD CODED TO SUBTRACT REQUIRED FIELDS SSN, NAME,
LIST_NAME, AND OLDNUMBER
xnumber = 0
DoCmd.OpenForm theform, acDesign
If rst2!LIST_NAME = "MEMA" Then
Forms!frmMbrAppoinmentSub.HasModule = False
xyz = Forms!frmMbrAppoinmentSub.Controls.Count - 1
ElseIf rst2!LIST_NAME = "MEMR" Then
Forms!frmMbrRenewalSub.HasModule = False
xyz = Forms!frmMbrRenewalSub.Controls.Count - 1
ElseIf rst2!LIST_NAME = "CNSR" Then
Forms!frmConsultantRenewelSub.HasModule = False
xyz = Forms!frmConsultantRenewelSub.Controls.Count - 1
ElseIf rst2!LIST_NAME = "CNMA" Then
Forms!frmConNonMbrAppointmentSub.HasModule = False
xyz = Forms!frmConNonMbrAppointmentSub.Controls.Count - 1
ElseIf rst2!LIST_NAME = "CNMR" Then
Forms!frmConsultantNonMBRRenewelsub.HasModule = False
xyz = Forms!frmConsultantNonMBRRenewelsub.Controls.Count - 1
End If
For x = xyz To 0 Step -1
If rst2!LIST_NAME = "MEMA" Then
junk = Forms!frmMbrAppoinmentSub.Controls(x).Name
ElseIf rst2!LIST_NAME = "MEMR" Then
junk = Forms!frmMbrRenewalSub.Controls(x).Name
ElseIf rst2!LIST_NAME = "CNSR" Then
junk = Forms!frmConsultantRenewelSub.Controls(x).Name
ElseIf rst2!LIST_NAME = "CNMA" Then
junk = Forms!frmConNonMbrAppointmentSub.Controls(x).Name
ElseIf rst2!LIST_NAME = "CNMR" Then
junk = Forms!frmConsultantNonMBRRenewelsub.Controls(x).Name
End If
DeleteControl theform, junk
Debug.Print junk
Next
'Forms!frmMbrAppoinmentSub.HasModule = False
'DoCmd.DoMenuItem acFormBar, acFile, acSaveForm
'DoCmd.DoMenuItem acFormBar, acFile, acSaveForm, , acMenuVer70
'DoCmd.OpenForm theform, acDesign
'DoCmd.RunCommand acCmdSave
xpdate = False
If rst2!LIST_NAME = "MEMA" Then
xyz = Forms!frmMbrAppoinmentSub.Controls.Count
Forms!frmMbrAppoinmentSub.HasModule = True
Set newForm = Forms!frmMbrAppoinmentSub
Set mdl = Forms!frmMbrAppoinmentSub.Module
xform = "frmMbrAppoinmentSub"
ElseIf rst2!LIST_NAME = "MEMR" Then
xyz = Forms!frmMbrRenewalSub.Controls.Count
Forms!frmMbrRenewalSub.HasModule = True
Set newForm = Forms!frmMbrRenewalSub
Set mdl = Forms!frmMbrRenewalSub.Module
xform = "frmMbrRenewalSub"
xpdate = True
ElseIf rst2!LIST_NAME = "CNSR" Then
xyz = Forms!frmConsultantRenewelSub.Controls.Count
Forms!frmConsultantRenewelSub.HasModule = True
Set newForm = Forms!frmConsultantRenewelSub
Set mdl = Forms!frmConsultantRenewelSub.Module
xform = "frmConsultantRenewelSub"
xpdate = True
ElseIf rst2!LIST_NAME = "CNMA" Then
xyz = Forms!frmConNonMbrAppointmentSub.Controls.Count
Forms!frmConNonMbrAppointmentSub.HasModule = True
Set newForm = Forms!frmConNonMbrAppointmentSub
Set mdl = Forms!frmConNonMbrAppointmentSub.Module
xform = "frmConNonMbrAppointmentSub"
ElseIf rst2!LIST_NAME = "CNMR" Then
xyz = Forms!frmConsultantNonMBRRenewelsub.Controls.Count
Forms!frmConsultantNonMBRRenewelsub.HasModule = True
Set newForm = Forms!frmConsultantNonMBRRenewelsub
Set mdl = Forms!frmConsultantNonMBRRenewelsub.Module
xform = "frmConsultantNonMbrRenewelSub"
xpdate = True
End If
rst2.MoveFirst
xhowmany = rst2.RecordCount
leftpost = 50
toppost = 50
tabnumber = 0
thewidth = 500
theheight = 200
'insert code in form module
'I commented this out
'lngformreturn = mdl.CreateEventProc("Load", "Form")
'mdl.InsertLines lngformreturn + 1, "Me!SSN.ColumnHidden = -1"
'mdl.InsertLines lngformreturn + 2, "Me!LIST_NAME.ColumnHidden = -1"
'mdl.InsertLines lngformreturn + 3, "Me!mbrName.ColumnWidth = -2"
'mdl.InsertLines lngformreturn + 4, "Me![date posted].ColumnWidth = -2"
'mdl.InsertLines lngformreturn + 4, "Me![Past Due].ColumnWidth = -2"
'check for invalid event handlers
' delete out all code in module
totline = mdl.CountOfLines
mdl.DeleteLines 1, totline
'hard coded for ssn, list_name, post_date, status
Set NewControl = CreateControl(theform, acTextBox, , , , leftpost, toppost,
thewidth, theheight)
newForm.Controls(0).Name = "ssn"
newForm.Controls(0).ControlSource = "ssn"
newForm.Controls(0).TabStop = 0
newForm.Controls(0).TabIndex = 0
newForm.Controls(0).Visible = 0
Set NewControl = CreateControl(theform, acTextBox, , , , leftpost, toppost,
thewidth, theheight)
newForm.Controls(1).Name = "list_name"
newForm.Controls(1).ControlSource = "list_name"
newForm.Controls(1).TabStop = 0
newForm.Controls(1).TabIndex = 0
newForm.Controls(1).Visible = 0
Set NewControl = CreateControl(theform, acTextBox, , , , leftpost, toppost,
thewidth, theheight)
newForm.Controls(2).Name = "Name"
newForm.Controls(2).ControlSource = "mbrName"
newForm.Controls(2).TabStop = 0
newForm.Controls(2).TabIndex = 0
newForm.Controls(2).Visible = -1
newForm.Controls(2).Enabled = 0
nc = 2
If xpdate Then
nc = 3
Set NewControl = CreateControl(theform, acTextBox, , , , leftpost,
toppost, thewidth, theheight)
newForm.Controls(3).Name = "Exp Date"
newForm.Controls(3).ControlSource = "exp_date"
newForm.Controls(3).TabStop = 0
newForm.Controls(3).TabIndex = 0
newForm.Controls(3).Visible = -1
newForm.Controls(3).Enabled = 0
End If
Set NewControl = CreateControl(theform, acTextBox, , , , leftpost, toppost,
thewidth, theheight)
newForm.Controls(nc + 1).Name = "Date Posted"
newForm.Controls(nc + 1).ControlSource = "post_date"
newForm.Controls(nc + 1).TabStop = 1
newForm.Controls(nc + 1).TabIndex = 0
newForm.Controls(nc + 1).Visible = -1
newForm.Controls(nc + 1).Enabled = 0
Set NewControl = CreateControl(theform, acTextBox, , , , leftpost, toppost,
thewidth, theheight)
newForm.Controls(nc + 2).Name = "Past Due"
newForm.Controls(nc + 2).ControlSource = "Status"
newForm.Controls(nc + 2).TabStop = 2
newForm.Controls(nc + 2).TabIndex = 0
newForm.Controls(nc + 2).Visible = -1
newForm.Controls(nc + 2).Enabled = 0
'Set NewControl = CreateControl(theform, acTextBox, , , , leftpost, toppost,
thewidth, theheight)
'newForm.Controls(nc + 3).Name = "Nominated by:"
'newForm.Controls(nc + 3).ControlSource = "Name"
'newForm.Controls(nc + 3).TabStop = 3
'newForm.Controls(nc + 3).TabIndex = 0
'newForm.Controls(nc + 3).Visible = -1
'newForm.Controls(nc + 3).Enabled = 0
rst2.MoveFirst
Do Until UCase(Left(rst2.Fields("xfieldname"), 5)) = "DATE1"
rst2.MoveNext
Loop
nextitem = nc + 4
Debug.Print ("nextitem" & nextitem)
For i = nextitem To xhowmany
thiscaption = rst2!Caption
If Not IsNull(thiscaption) Then
xcontrolsource = rst2!xFieldName
xName = rst2!Caption
'xName = thiscaption
ctlname = xName
nc = nc + 1
Debug.Print "i " & i & "xcontrol " & xcontrolsource & " ctl " &
ctlname
Set NewControl = CreateControl(theform, acTextBox, , , ,
leftpost, toppost, thewidth, theheight)
If rst2!LIST_NAME = "MEMA" Then
Forms!frmMbrAppoinmentSub.Controls(i - 1).Name = xName
Forms!frmMbrAppoinmentSub.Controls(i - 1).ControlSource =
xcontrolsource
Forms!frmMbrAppoinmentSub.Controls(i - 1).TabStop = nc + 3
ElseIf rst2!LIST_NAME = "MEMR" Then
Forms!frmMbrRenewalSub.Controls(i - 1).Name = xName
Forms!frmMbrRenewalSub.Controls(i - 1).ControlSource =
xcontrolsource
Forms!frmMbrRenewalSub.Controls(i - 1).TabStop = nc + 3
ElseIf rst2!LIST_NAME = "CNSR" Then
Forms!frmConsultantRenewelSub.Controls(i - 1).Name = xName
Forms!frmConsultantRenewelSub.Controls(i - 1).ControlSource
= xcontrolsource
Forms!frmConsultantRenewelSub.Controls(i - 1).TabStop = nc + 3
ElseIf rst2!LIST_NAME = "CNMA" Then
Forms!frmConNonMbrAppointmentSub.Controls(i - 1).Name = xName
Forms!frmConNonMbrAppointmentSub.Controls(i -
1).ControlSource = xcontrolsource
Forms!frmConNonMbrAppointmentSub.Controls(i - 1).TabStop =
nc + 3
ElseIf rst2!LIST_NAME = "CNMR" Then
Forms!frmConsultantNonMBRRenewelsub.Controls(i - 1).Name =
xName
Forms!frmConsultantNonMBRRenewelsub.Controls(i -
1).ControlSource = xcontrolsource
Forms!frmConsultantNonMBRRenewelsub.Controls(i - 1).TabStop
= nc + 3
End If
Debug.Print ("nc during " & nc)
'Create After Update event procedure for date fields
If ctlname = "LIST_NAME" Or ctlname = "SSN" Or ctlname = "mbrNAME"
Then
leftpost = leftpost + thewidth + 50
rst2.MoveNext
Else
If (Not IsNull(rst2!Trigger)) And (Not IsEmpty(rst2!Trigger)) Then
thiscaption = xName
xblankpos = InStr(thiscaption, " ")
If xblankpos > 0 Then
Mid(thiscaption, xblankpos, 1) = "_"
End If
nextblankpos = InStr(7, thiscaption, " ", 0)
If nextblankpos > 0 Then
Mid(thiscaption, nextblankpos, 1) = "_"
End If
xapostrophepos = InStr(thiscaption, "'")
If xapostrophepos > 0 Then
Mid(thiscaption, xapostrophepos, 1) = "_"
End If
xopenparenpos = InStr(thiscaption, "(")
If xopenparenpos > 0 Then
Mid(thiscaption, xopenparenpos, 1) = "_"
End If
xcloseparenpos = InStr(thiscaption, ")")
If xcloseparenpos > 0 Then
Mid(thiscaption, xcloseparenpos, 1) = "_"
End If
xforslashpos = InStr(thiscaption, "/")
If xforslashpos > 0 Then
Mid(thiscaption, xforslashpos, 1) = "_"
End If
xbackslashpos = InStr(thiscaption, "\")
If xbackslashpos > 0 Then
Mid(thiscaption, xbackslashpos, 1) = "_"
End If
If IsNumeric(Left(thiscaption, 1)) Then
thiscaption = "ctl" & thiscaption
End If
Debug.Print ("this cap" & thiscaption)
lngreturn = mdl.CreateEventProc("AfterUpdate", thiscaption)
mdl.InsertLines lngreturn + 1, "Dim Msg, Style, TITLE, Help,
Ctxt, Response, MyString "
mdl.InsertLines lngreturn + 2, "Dim criteria, ssnnumber,
DocName As String"
mdl.InsertLines lngreturn + 3, "Dim ctl As Control"
mdl.InsertLines lngreturn + 4, "Dim xFieldName, xlistname As
String"
mdl.InsertLines lngreturn + 5, "OnCurrent = ""[Event
Procedure]"""
mdl.InsertLines lngreturn + 6, "ssnnumber = Me!SSN"
mdl.InsertLines lngreturn + 7, "criteria = ""[SSN]= '"" &
ssnnumber & ""'"""
mdl.InsertLines lngreturn + 8, "Msg = ""Form Letter needs to
be sent, Would you like to send it now ?"""
mdl.InsertLines lngreturn + 9, "Style = vbYesNo +
vbExclamation + vbDefaultButton2"
mdl.InsertLines lngreturn + 10, "TITLE = ""Action"""
mdl.InsertLines lngreturn + 11, "Response = MsgBox(Msg,
Style, TITLE)"
mdl.InsertLines lngreturn + 12, "If Response = vbYes Then"
mdl.InsertLines lngreturn + 13, " Set ctl =
Screen.ActiveControl"
mdl.InsertLines lngreturn + 14, " xFieldName =
ctl.ControlSource"
mdl.InsertLines lngreturn + 15, " xlistname = Me!LIST_NAME"
mdl.InsertLines lngreturn + 16, " DocName =
""FrmSendLetter"""
mdl.InsertLines lngreturn + 17, " DoCmd.OpenForm DocName, ,
, criteria"
mdl.InsertLines lngreturn + 18, "
Forms!frmSendLetter!xFieldName = xFieldName"
mdl.InsertLines lngreturn + 19, "
Forms!frmSendLetter!LIST_NAME = xlistname"
mdl.InsertLines lngreturn + 20, " Forms!frmSendLetter!SSN =
ssnnumber"
mdl.InsertLines lngreturn + 21, "End If"
End If
leftpost = leftpost + thewidth + 50
rst2.MoveNext
End If
End If
Next
rst2.Close
DoCmd.Save acForm, xform
'docmd.RunCommand acCmdSave
'DoCmd.DoMenuItem acFormBar, acFile, acSaveForm, , acMenuVer70
DoCmd.Close
End Function
Private Sub Command12_Click()
On Error GoTo Err_Command12_Click
DoCmd.Close
Exit_Command12_Click:
Exit Sub
Err_Command12_Click:
MsgBox Err.Description
Resume Exit_Command12_Click
End Sub
Private Sub btnClose_Click()
'On Error GoTo Err_btnClose_Click
Dim retvalue As String
retvalue = ChangeHeadings()
DoCmd.Close
DoCmd.Close acForm, "frmPostingHeadLRH", acSaveNo
Exit_btnClose_Click:
Exit Sub
Err_btnClose_Click:
MsgBox Err.Description
Resume Exit_btnClose_Click
End Sub
Private Sub Command20_Click()
Dim i As Integer
Dim x As String
'Set fs = Application.FileSearch
With Application.FileSearch
.LookIn = "C:\asb6\lettertemplates"
.SearchSubFolders = True
.filename = "*.doc"
x = ""
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
x = x & .FoundFiles(i) & ";"
Next i
Else
x = "No Files"
End If
End With
Me!filelist.RowSource = x
End Sub
Private Sub Form_Load()
Dim i As Integer
Dim x As String
'Command20_Click
End Sub
The Subform that comes up is in Datasheet View, NOTE: I cannot change this
to a continues form because my boss wants to freeze the first colum.
All I want to do is add another Colum or 2, but the counter will not let me.
Please help And Thank You For Any Help!