VBA not working

G

Gus

Hello.
I am using Access 2003. On a form I have a button that duplicates a record
and when I click the button the form becomes populated ok except when the
date comes into the form it comes in as year 2020. It was working fine but
then yesterday it started doing this. I don't know if a MS update broke it or
what but I have copied the vba below.

Can you please help?
Your help is greatly appreciated.

Option Compare Database
Option Explicit

Public QCMouseWheel As Boolean
Private Sub Form_BeforeUpdate(Cancel As Integer)

If QCMouseWheel Then
Cancel = True
QCMouseWheel = False
End If

End Sub

Private Sub Form_Current()

QCMouseWheel = False

End Sub

Private Sub Form_MouseWheel(ByVal Page As Boolean, ByVal Count As Long)

QCMouseWheel = True

End Sub
Private Sub cmdCloseQC_Click()
On Error GoTo Err_cmdCloseQC_Click

DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
DoCmd.Close

Exit_cmdCloseQC_Click:
Exit Sub

Err_cmdCloseQC_Click:
If Err.NUMBER = 2046 Then
DoCmd.Close
Exit Sub
Else
MsgBox Err.Description
Resume Exit_cmdCloseQC_Click
End If
End Sub

Private Sub cmdCopyQCtoNew_Click()
On Error GoTo Err_cmdCopyQCtoNew_Click

Dim iA As Integer
Dim iB As Integer
Dim ctrlCount As Integer
Dim strFormFields(50) As String
Dim check1 As Boolean
Dim check2 As Boolean

ctrlCount = Me.Controls.Count

'Read field values
For iA = 0 To ctrlCount - 1
'MsgBox "iA = " & iA & Chr(13) & "name = " & Me(iA).Name
If Left(Me(iA).Name, 5) <> "Image" And Left(Me(iA).Name, 3) <> "cmd"
And Right(Me(iA).Name, 5) <> "Check" Then
Me(iA).SetFocus
If Not IsNull(Me(iA).Text) And Not Me(iA).Text = "" Then
strFormFields(iA) = Me(iA).Text
End If
Next iA

CommOriginCheck.SetFocus
check1 = CommOriginCheck.Value
CommIdentityCheck.SetFocus
check2 = CommIdentityCheck.Value

'Go to blank form
DoCmd.GoToRecord , , acNewRec

'Fill in form with copied values
For iB = 0 To ctrlCount - 1
'MsgBox "ib = " & iB & Chr(13) & "name = " & Me(iB).Name
If Left(Me(iB).Name, 5) <> "Image" And Left(Me(iB).Name, 3) <> "cmd"
And Me(iB).Name <> "QCNUMBER" Then
Me(iB).SetFocus
If Not IsNull(strFormFields(iB)) And Not strFormFields(iB) = ""
Then Me(iB).Text = strFormFields(iB)
End If
Next iB

CommOriginCheck.SetFocus
CommOriginCheck.Value = check1
CommIdentityCheck.SetFocus
CommIdentityCheck.Value = check2

MsgBox "A new copy of the form has been created. Please enter a new QC
Number.", vbOKOnly, "QC Form"

MEETSREQOF.SetFocus
'QCNUMBER.Text = ""

Exit_cmdCopyQCtoNew_Click:
Exit Sub

Err_cmdCopyQCtoNew_Click:
MsgBox Err.Description
Resume Exit_cmdCopyQCtoNew_Click

End Sub

Private Sub cmdPreviewQC_Click()
On Error GoTo Err_cmdPreviewQC_Click

Dim intQuestion As VbMsgBoxResult

'If the phytonumber is not blank, ask if user still wants to print
Me.QCNUMBER.SetFocus
If Me.QCNUMBER.Text <> "" And Not IsNull(Me.QCNUMBER.Text) Then
intQuestion = MsgBox("This Certificate has already been printed, do
you want to print it again?", vbYesNo, "QC Certificate")
Select Case intQuestion
Case vbNo
Exit Sub
Case vbYes
GoTo PreviewCert
End Select
End If

'Ask the user if they want to proceed with numbering the certificate
intQuestion = vbCancel
intQuestion = MsgBox("This function will number this Certificate." &
Chr(13) & "Do you want to proceed?", vbYesNo, "QC Certificate")
If intQuestion = vbNo Then Exit Sub

'Retreive the current certificate number
Dim rstQnumber As New ADODB.Recordset
Dim strNewNumber As String
Dim strNewNumber2 As String

Dim strCurrentNumber As String
Dim strCurrentNumber2 As String
Dim strCurrentLocation As String
Dim strCurrentYear As String
Dim strCurrentCounty As String

intQuestion = vbCancel

rstQnumber.Open "tblCurrentValues", CurrentProject.Connection,
adOpenKeySet, adLockOptimistic
rstQnumber.MoveFirst
rstQnumber.Find "FieldName = 'QCAnnualCount'"
strCurrentNumber = rstQnumber!FieldValue
Select Case Len(strCurrentNumber)
Case 1
strCurrentNumber2 = "00" & strCurrentNumber
Case 2
strCurrentNumber2 = "0" & strCurrentNumber
Case 3
strCurrentNumber2 = "" & strCurrentNumber
End Select

rstQnumber.MoveFirst
rstQnumber.Find "FieldName = 'COUNTY'"
strCurrentCounty = rstQnumber!FieldValue

rstQnumber.MoveFirst
rstQnumber.Find "FieldName = 'Year'"
strCurrentYear = rstQnumber!FieldValue

rstQnumber.MoveFirst
rstQnumber.Find "FieldName = 'Location'"
strCurrentLocation = rstQnumber!FieldValue

strNewNumber = strCurrentCounty & strCurrentYear & strCurrentLocation &
strCurrentNumber2

'Ask if the certificate number is correct
' and if it is not, get the correct number
intQuestion = MsgBox("The current Certificate number is: " &
strNewNumber & Chr(13) & "Is this correct?", vbYesNo, "QC Certificate")

If intQuestion = vbNo Then
strNewNumber = InputBox("Please enter the new form number:", "QC
Certificate", strCurrentNumber)
MsgBox "Inform the Administrator that you have manually changed this
number.", vbOKOnly, "QC Certificate"
End If

Me.QCNUMBER.Locked = False
Me.QCNUMBER.Text = strNewNumber
DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
Me.QCNUMBER.Locked = False

'Write new number + 1 to table and close connection
rstQnumber.MoveFirst
rstQnumber.Find "FieldName = 'QCAnnualCount'"
rstQnumber!FieldValue = CStr(CDbl(strCurrentNumber) + 1)
rstQnumber.Update
rstQnumber.Close

PreviewCert:
'Preview the report
Dim stDocName As String
Dim stLinkCriteria As String

stDocName = "rptQC"

stLinkCriteria = "[QCNUMBER] = '" & Me![QCNUMBER] & "'"

DoCmd.OpenReport stDocName, acViewPreview, , stLinkCriteria

Exit_cmdPreviewQC_Click:
Exit Sub

Err_cmdPreviewQC_Click:
MsgBox Err.Description
Resume Exit_cmdPreviewQC_Click
End Sub
 
R

roger

First: No one will read all that code. We can't, its too much.

Second: you issue may have to do with date CONVERSION.
Are you sure that as you "duplicate" the record your date value remains in a
date FORMAT and or a date DATATYPE throughout the process? For instance: If
you assign a date value to string variable (without converting) you get an
integer.

If I was going to duplicate a record, I'd use a simple APPEND QUERY that
filters out to record I want and APPENDS it again. That way all the datatypes
and formats remain consistant.
hth

Gus said:
Hello.
I am using Access 2003. On a form I have a button that duplicates a record
and when I click the button the form becomes populated ok except when the
date comes into the form it comes in as year 2020. It was working fine but
then yesterday it started doing this. I don't know if a MS update broke it or
what but I have copied the vba below.

Can you please help?
Your help is greatly appreciated.

Option Compare Database
Option Explicit

Public QCMouseWheel As Boolean
Private Sub Form_BeforeUpdate(Cancel As Integer)

If QCMouseWheel Then
Cancel = True
QCMouseWheel = False
End If

End Sub

Private Sub Form_Current()

QCMouseWheel = False

End Sub

Private Sub Form_MouseWheel(ByVal Page As Boolean, ByVal Count As Long)

QCMouseWheel = True

End Sub
Private Sub cmdCloseQC_Click()
On Error GoTo Err_cmdCloseQC_Click

DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
DoCmd.Close

Exit_cmdCloseQC_Click:
Exit Sub

Err_cmdCloseQC_Click:
If Err.NUMBER = 2046 Then
DoCmd.Close
Exit Sub
Else
MsgBox Err.Description
Resume Exit_cmdCloseQC_Click
End If
End Sub

Private Sub cmdCopyQCtoNew_Click()
On Error GoTo Err_cmdCopyQCtoNew_Click

Dim iA As Integer
Dim iB As Integer
Dim ctrlCount As Integer
Dim strFormFields(50) As String
Dim check1 As Boolean
Dim check2 As Boolean

ctrlCount = Me.Controls.Count

'Read field values
For iA = 0 To ctrlCount - 1
'MsgBox "iA = " & iA & Chr(13) & "name = " & Me(iA).Name
If Left(Me(iA).Name, 5) <> "Image" And Left(Me(iA).Name, 3) <> "cmd"
And Right(Me(iA).Name, 5) <> "Check" Then
Me(iA).SetFocus
If Not IsNull(Me(iA).Text) And Not Me(iA).Text = "" Then
strFormFields(iA) = Me(iA).Text
End If
Next iA

CommOriginCheck.SetFocus
check1 = CommOriginCheck.Value
CommIdentityCheck.SetFocus
check2 = CommIdentityCheck.Value

'Go to blank form
DoCmd.GoToRecord , , acNewRec

'Fill in form with copied values
For iB = 0 To ctrlCount - 1
'MsgBox "ib = " & iB & Chr(13) & "name = " & Me(iB).Name
If Left(Me(iB).Name, 5) <> "Image" And Left(Me(iB).Name, 3) <> "cmd"
And Me(iB).Name <> "QCNUMBER" Then
Me(iB).SetFocus
If Not IsNull(strFormFields(iB)) And Not strFormFields(iB) = ""
Then Me(iB).Text = strFormFields(iB)
End If
Next iB

CommOriginCheck.SetFocus
CommOriginCheck.Value = check1
CommIdentityCheck.SetFocus
CommIdentityCheck.Value = check2

MsgBox "A new copy of the form has been created. Please enter a new QC
Number.", vbOKOnly, "QC Form"

MEETSREQOF.SetFocus
'QCNUMBER.Text = ""

Exit_cmdCopyQCtoNew_Click:
Exit Sub

Err_cmdCopyQCtoNew_Click:
MsgBox Err.Description
Resume Exit_cmdCopyQCtoNew_Click

End Sub

Private Sub cmdPreviewQC_Click()
On Error GoTo Err_cmdPreviewQC_Click

Dim intQuestion As VbMsgBoxResult

'If the phytonumber is not blank, ask if user still wants to print
Me.QCNUMBER.SetFocus
If Me.QCNUMBER.Text <> "" And Not IsNull(Me.QCNUMBER.Text) Then
intQuestion = MsgBox("This Certificate has already been printed, do
you want to print it again?", vbYesNo, "QC Certificate")
Select Case intQuestion
Case vbNo
Exit Sub
Case vbYes
GoTo PreviewCert
End Select
End If

'Ask the user if they want to proceed with numbering the certificate
intQuestion = vbCancel
intQuestion = MsgBox("This function will number this Certificate." &
Chr(13) & "Do you want to proceed?", vbYesNo, "QC Certificate")
If intQuestion = vbNo Then Exit Sub

'Retreive the current certificate number
Dim rstQnumber As New ADODB.Recordset
Dim strNewNumber As String
Dim strNewNumber2 As String

Dim strCurrentNumber As String
Dim strCurrentNumber2 As String
Dim strCurrentLocation As String
Dim strCurrentYear As String
Dim strCurrentCounty As String

intQuestion = vbCancel

rstQnumber.Open "tblCurrentValues", CurrentProject.Connection,
adOpenKeySet, adLockOptimistic
rstQnumber.MoveFirst
rstQnumber.Find "FieldName = 'QCAnnualCount'"
strCurrentNumber = rstQnumber!FieldValue
Select Case Len(strCurrentNumber)
Case 1
strCurrentNumber2 = "00" & strCurrentNumber
Case 2
strCurrentNumber2 = "0" & strCurrentNumber
Case 3
strCurrentNumber2 = "" & strCurrentNumber
End Select

rstQnumber.MoveFirst
rstQnumber.Find "FieldName = 'COUNTY'"
strCurrentCounty = rstQnumber!FieldValue

rstQnumber.MoveFirst
rstQnumber.Find "FieldName = 'Year'"
strCurrentYear = rstQnumber!FieldValue

rstQnumber.MoveFirst
rstQnumber.Find "FieldName = 'Location'"
strCurrentLocation = rstQnumber!FieldValue

strNewNumber = strCurrentCounty & strCurrentYear & strCurrentLocation &
strCurrentNumber2

'Ask if the certificate number is correct
' and if it is not, get the correct number
intQuestion = MsgBox("The current Certificate number is: " &
strNewNumber & Chr(13) & "Is this correct?", vbYesNo, "QC Certificate")

If intQuestion = vbNo Then
strNewNumber = InputBox("Please enter the new form number:", "QC
Certificate", strCurrentNumber)
MsgBox "Inform the Administrator that you have manually changed this
number.", vbOKOnly, "QC Certificate"
End If

Me.QCNUMBER.Locked = False
Me.QCNUMBER.Text = strNewNumber
DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
Me.QCNUMBER.Locked = False

'Write new number + 1 to table and close connection
rstQnumber.MoveFirst
rstQnumber.Find "FieldName = 'QCAnnualCount'"
rstQnumber!FieldValue = CStr(CDbl(strCurrentNumber) + 1)
rstQnumber.Update
rstQnumber.Close

PreviewCert:
'Preview the report
Dim stDocName As String
Dim stLinkCriteria As String

stDocName = "rptQC"

stLinkCriteria = "[QCNUMBER] = '" & Me![QCNUMBER] & "'"

DoCmd.OpenReport stDocName, acViewPreview, , stLinkCriteria

Exit_cmdPreviewQC_Click:
Exit Sub

Err_cmdPreviewQC_Click:
MsgBox Err.Description
Resume Exit_cmdPreviewQC_Click
End Sub
Click to expand...
 

Ask a Question

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

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

Ask a Question

Similar Threads

PowerPoint vba to insert name on Quiz Certificate in PowerPoint 0
Excel VBA to go to specific sheet & cell in the current workbook not working. 2
Email SendObject Code Not Working 4
Excel Worksheet_BeforeDelete code not working as expected. 1
Command Button not working on form - HELP!!! 3
Check mandatory fields using VBA not working properly 12
Docmd.Setwarning False Not Working 6
Requery Not Working 4

Top