Implement ReCaptcha in classic ASP - captcha

I've got a problem implementing ReCaptcha from google in classic asp.
The Captcha displays well below my form, but when I submit the form, it's always accepted even if the captcha fields are left empty or are wrong.
Here's the code I use in my first "form" page.
Right at the top of the page I've this :
<%
recaptcha_challenge_field = Request("recaptcha_challenge_field")
recaptcha_response_field = Request("recaptcha_response_field")
recaptcha_public_key = "mykeyofcourse" ' your public key
recaptcha_private_key = "and here the private one" ' your private key
' returns the HTML for the widget
function recaptcha_challenge_writer()
recaptcha_challenge_writer = _
"<script type=""text/javascript"">" & _
"var RecaptchaOptions = {" & _
" theme : 'red'," & _
" tabindex : 0" & _
"};" & _
"</script>" & _
"<script type=""text/javascript"" src=""http://www.google.com/recaptcha/api/challenge?k=" & recaptcha_public_key & """></script>" & _
"<noscript>" & _
"<iframe src=""http://www.google.com/recaptcha/api/noscript?k=" & recaptcha_public_key & """ frameborder=""1""></iframe><>" & _
"<textarea name=""recaptcha_challenge_field"" rows=""3"" cols=""40""></textarea>" & _
"<input type=""hidden"" name=""recaptcha_response_field""value=""manual_challenge"">" & _
""
end function
' returns "" if correct, otherwise it returns the error response
function recaptcha_confirm(rechallenge,reresponse)
Dim VarString
VarString = _
"privatekey=" & recaptcha_private_key & _
"&remoteip=" & Request.ServerVariables("REMOTE_ADDR") & _
"&challenge=" & rechallenge & _
"&response=" & reresponse
Dim objXmlHttp
Set objXmlHttp = Server.CreateObject("Msxml2.ServerXMLHTTP")
objXmlHttp.open "POST", "https://www.google.com/recaptcha/api/verify", False
objXmlHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
objXmlHttp.send VarString
Dim ResponseString
ResponseString = split(objXmlHttp.responseText, vblf)
Set objXmlHttp = Nothing
if ResponseString(0) = "true" then
'They answered correctly
recaptcha_confirm = ""
else
'They answered incorrectly
recaptcha_confirm = ResponseString(1)
end if
end function
server_response = ""
newCaptcha = True
if (recaptcha_challenge_field <> "" or recaptcha_response_field <> "") then
server_response = recaptcha_confirm(recaptcha_challenge_field, recaptcha_response_field)
newCaptcha = False
end if
%>
in my form, above the submit button I have this code :
<%=recaptcha_challenge_writer()%>
Now to the ASP page that checks the form.
On the top of the page I have this :
if server_response <> "" or newCaptcha then
Erreur="oui"
else
Erreur="non"
end if
response.write "erreur : "&erreur
But...erreur is always = non whatever the value of the captcha field is.
Any idea what I'm doing wrong
Thanks in advance

Related

How to use ServerXMLHTTP60 and a client SSL certificate in Excel using VBA?

I cannot get it to work in VBA - Excel. I use the same header and XML-body in Postman - fine! Good response. I need to use a client certificate to identify myself, but I cannot get it done in VBA. The code needs to post some data (the XMLPostMessage) and then it receives some data from the server (a XML message as well).
The response I get from the server is a message in XML that has something to do with "Unidentified user". So, I do have communication, but it is not recognised as 'from a trusted party'. But using this certificate in Postman does give a good response.
== My VBA code: ==
Public Sub server()
Dim O As New ServerXMLHTTP60
Dim xmlDoc As New MSXML2.DOMDocument60
Dim XMLPostMessage As String
XMLPostMessage = "<WEB-UAS-AANVR>" & _
"<ALG-GEG>" & _
"<PROC-IDENT>3637</PROC-IDENT>" & _
"<PROC-FUNC>1</PROC-FUNC>" & _
"<INFO-GEBR>DITISEENTEST</INFO-GEBR>" & _
"</ALG-GEG>" & _
"<WEB-UAS-GEG>" & _
"<UAS-VRR-EXAMEN-GEG>" & _
"<UAS-VRR-EX-INST></UAS-VRR-EX-INST>" & _
"<UAS-VRR-EX-SRT>A2</UAS-VRR-EX-SRT>" & _
"<UAS-VRR-EX-DAT>20211210</UAS-VRR-EX-DAT>" & _
"<GEB-DAT-UAS-VRR>19840726</GEB-DAT-UAS-VRR>" & _
"<UAS-VRR-EX-REF>#12345</UAS-VRR-EX-REF>" & _
"</UAS-VRR-EXAMEN-GEG>" & _
"</WEB-UAS-GEG>" & _
"</WEB-UAS-AANVR>"
With O
.Open "POST", "https://<the serverpath goes here>", False
.setRequestHeader "Content-type", "application/xml"
.setRequestHeader "Content-type", "text/xml"
.setRequestHeader "Charset", "UTF-8"
.setOption 3, "<The Friendly Name of the certificate goes here>"
' .setOption 3, "CURRENT_USER\My\<The Friendly Name of the certificate goes here>"
.send XMLPostMessage
xmlDoc.LoadXML (O.responseXML.XML)
Debug.Print xmlDoc.XML
If Not .Status = 200 Then
MsgBox "UnAuthorized. Message: " & .Status & " - " & .statusText
Exit Sub
End If
End With
Set O = Nothing
End Sub

Checking Null Value in Access VBA recordset throws null exception?

I have tried this every different way, and it was working yesterday, so I really don't know what changed.
I import a spreadsheet to a temp table in an Access app. Then I set that to be the dao.recordset, and start looping through. I check for the ID to not be null and if not go through checking fields for values, and updating as appropriate. the minute I hit a null, I get a system error "94 - invalid use of null"
It doesn't offer a debug, but I have debugs throughout my code, so I can see where it fails. It fails when I do this check: If IsNull(rstImportCList("columnx")) = False Then
I have tried nz(rstImportCList("columnx"),"") <> "" I have tried rstImportCList("columnx") is not null, and everything else I can think of. Why is the check that is supposed to prevent this error, causing this error?
Edit:
This is the beginning where I declare the recordset I can't get past doing anything with the recordset field.
Dim db As DAO.Database
Dim rstImportCList As DAO.Recordset
Dim RSsql As String
Set db = CurrentDb()
RSsql = "Select * from tblTempImportCList"
Set rstImportCList = db.OpenRecordset(RSsql)
If rstImportCList.EOF Then Exit Sub
Do While Not rstImportCList.EOF
whether I try to check
IsNull(rstImportCList("xyz").Value) = False
or
nz(rstImportCList("xyz").Value,"") <> ""
or
dim x as string
x = rstImportCList!xyz.value
I get the same error 94 invalid use of null.
Any idea why this is?
--edit with more code.
I took some time to take a the beginning and some of each section of the code, so I could make it generic and see if anyone can help. Here is what I am working on. The Code1 and Code2 parts don't seem to be the issue. Sometimes it fails on a null value in a Yes/No column (I'm just looking for Y but the value is null), sometimes on the notes being null. It's not consistent, which is why I'm having a hard time nailing down the issue.
Private Sub cmdImportList_Click()
On Error GoTo cmdImportExcel_Click_err:
Dim fdObj As FileDialog
Set fdObj = Application.FileDialog(msoFileDialogFilePicker)
Dim varfile As Variant
Dim importCT As Integer
Dim dbu As DAO.Database
Dim cBadXVal, cBadYVal As Integer
Dim preNotes As String
Dim RSsql As String
Dim uNotesql, uVal1sql, uVal2sql As String
Dim db As DAO.Database
Dim rstImportCList As DAO.Recordset
Dim CheckB4Import As Integer
CheckB4Import = MsgBox("Are you SURE the sheet you are importing has the following column names in the same order:" & vbCrLf & vbCrLf & _
"IDName/ First/ Mid/ Last/ Sfx/ Age/ Telephone/ Code1/ Code2/ YN1/ YN2/ NY3/ Notes/ AsYN1edTo" & vbCrLf & vbCrLf & _
"AND that there are NO empty rows or empty columns?" & vbCrLf & vbCrLf & _
"Click OK to proceed, Click CANCEL to go double-check your CallSheet before importing.", vbOKCancel, "WITH GREAT POWER COMES GREAT RESPONSIBILITY TO QC DATA")
If CheckB4Import = vbOK Then
CurrentDb.Execute "DELETE * FROM tblTempImportCList", dbFailOnError
With fdObj
'CAN ONLY SELECT 1 FILE
.allowmultiselect = False
.Filters.Clear
.Filters.Add "Excel 2007+", "*.xlsx"
.Title = "Please select the completed list to import:"
.Show
If .SelectedItems.Count = 1 Then
varfile = .SelectedItems(1)
DoCmd.TransferSpreadsheet acImport, , "tblTempImportCList", varfile, True, "Sheet1!"
cBadXVal = DLookup("BadXCount", "qryImpCheckBadXVal")
Debug.Print "cBadXVal - " & cBadXVal
If cBadXVal <> 0 Then
DoCmd.OpenForm "frmImportError", acNormal
Forms!frmImportError.Form.lblErrorMsg.Caption = _
"Oh No! Your list import failed!" & vbCrLf & _
cBadXVal & " X values are not valid." & vbCrLf & _
"Don't worry. You can fix your sheet and re-import!" & vbCrLf & _
"Would you like to open the documentation for the valid codes" & vbCrLf & _
"Or are you all set?"
End If
cBadYVal = DLookup("BadYCount", "qryImpCheckBadYVal")
Debug.Print "cBadYVal - " & cBadYVal
If cBadYVal <> 0 Then
DoCmd.OpenForm "frmImportError", acNormal
Forms!frmImportError.Form.lblErrorMsg.Caption = _
"Oh No! Your list import failed!" & vbCrLf & _
cBadYVal & " YN1 values are not valid." & vbCrLf & _
"Don't worry. You can fix your sheet and re-import!" & vbCrLf & _
"Would you like to open the documentation for the valid codes" & vbCrLf & _
"Or are you all set?"
Exit Sub
End If
Else
MsgBox "No file was selected. Try again!", vbCritical, "Uh-oh Spaghettios!"
End If
End With
'PASSED CHECKS
Set db = CurrentDb()
RSsql = "Select * from tblTempImportCList"
Set rstImportCList = db.OpenRecordset(RSsql)
If rstImportCList.EOF Then Exit Sub
Debug.Print "got here"
Do While Not rstImportCList.EOF
Debug.Print "Start Processing: " & Nz(rstImportCList("IDName").Value, "")
'GET NOTES ALREADY ON RECORD
If Nz(rstImportCList("IDName").Value, "") <> "" Then
Debug.Print "got past if IDName is not null"
If Nz(rstImportCList("Notes").Value, "") <> "" Then
Debug.Print "got past if notes is not null"
preNotes = Replace(Nz(DLookup("Notes", "tblVFileImport", "IDName = " & rstImportCList("IDName").Value), ""), """", "")
'UPDATE NOTES
If Nz(preNotes, "") <> "" Then
uNotesql = "Update tblVFileImport SET tblVFileImport.Notes = '" & preNotes & "; " & Replace(Nz(rstImportCList("Notes").Value, ""), """", "") & "' " & _
"WHERE tblVFileImport.IDName = " & rstImportCList("IDName").Value
'debug.print "Notes"
'debug.print "uNotesql - " & uNotesql
Else
uNotesql = "Update tblVFileImport SET tblVFileImport.Notes = '" & Replace(Nz(rstImportCList("Notes").Value, ""), """", "") & "' " & _
"WHERE tblVFileImport.IDName = " & rstImportCList("IDName").Value
End If
RunMySql (uNotesql)
'DoCmd.RunSQL (uNotesql), dbFailOnError
End If
If Nz(rstImportCList("YN1").Value, "") = "Y" Then
'UPDATE YN1
uYN1sql = "Update tblVFileImport SET tblVFileImport.YN1 = '" & rstImportCList("YN1") & "', tblVFileImport.callprocessed = 'Y' " & _
"WHERE tblVFileImport.IDName = " & rstImportCList("IDName")
Debug.Print "YN1 = Y or y"
Debug.Print "uYN1sql - " & uYN1sql
RunMySql (uYN1sql)
'DoCmd.RunSQL (uYN1sql), dbFailOnError
End If
If Nz(rstImportCList("YN2").Value, "") = "Y" Then
'UPDATE YN2
uYN2sql = "Update tblVFileImport SET tblVFileImport.YN2 = '" & rstImportCList("YN2") & "', tblVFileImport.callprocessed = 'Y' " & _
"WHERE tblVFileImport.IDName = " & rstImportCList("IDName")
Debug.Print "YN2 = Y or y"
Debug.Print "uYN2sql - " & uYN2sql
RunMySql (uYN2sql)
'DoCmd.RunSQL (uYN2sql), dbFailOnError
End If
'START Code1 PROCESSING
If Nz(rstImportCList("Code1").Value, "") <> "" Then
'Code1 Case abc
vdispo = DLookup("Code1", "tblvFileImport", "IDName = " & rstImportCList("IDName"))
If rstImportCList("Code1") = "ABC" Then
Debug.Print "Dispo Case ABC"
'DELETE RECORD
dMDsql = "DELETE from tblVFileImport " & _
"WHERE tblVFileImport.IDName = " & rstImportCList("IDName")
Debug.Print "dMDsql - " & dMDsql
RunMySql (dMDsql)
'DoCmd.RunSQL (dMDsql), dbFailOnError
'Code1 Case DEF OR GHI OR JKL
ElseIf Nz(rstImportCList("Code1"), "") = "DEF" Or Nz(rstImportCList("Code1"), "") = "GHI" Or Nz(rstImportCList("Code1"), "") = "JKL" Then
Debug.Print "Dispo Case DEF OR GHI OR JKL "
'IF DEF
If rstImportCList("Code1") = "DEF" Then
'IF CELL SAME - UPDATE NULL
ccellsame = DLookup("IDName", "tblVFileImport", "IDName = " & rstImportCList("IDName") & " AND nz(Cell,'') = Phone ")
If ccellsame = rstImportCList("IDName") Then
uCellsql = "Update tblVFileImport SET tblVFileImport.Cell = NULL, tblVFileImport.CellString = NULL, tblVFileImport.mobileflag = NULL " & _
"WHERE tblVFileImport.IDName = " & rstImportCList("IDName")
Debug.Print "uCellsql - " & uCellsql
RunMySql (uCellsql)
'DoCmd.RunSQL (uCellsql), dbFailOnError
End If
End If
End If
End If
End If
Debug.Print "End Processing: " & rstImportCList("IDName")
rstImportCList.MoveNext
Loop
Debug.Print "Finished Looping"
rstImportCList.Close
importCT = DCount("IDName", "tblTempImportCList")
MsgBox importCT & " Records imported for list.", vbOKOnly, "List Processed"
Else
MsgBox "Good Call. Check twice, import once!", vbOKOnly, "Better Safe Than Sorry"
End If
Exit Sub
cmdImportExcel_Click_err:
Select Case Err.Number
Case Else
Call MsgBox(Err.Number & " – " & Err.Description, vbCritical + vbOKOnly, "System Error …")
End Select
End Sub
Any suggestions are greatly appreciated. I'm 1/2 tempted to suck this into a SQL table and just execute a stored procedure. I can get it to work in there, I think.
If IsNull(rstImportCList("columnx").Value) Then
otherwise you're checking if the Field object itself is null.
https://learn.microsoft.com/en-us/office/client-developer/access/desktop-database-reference/field-object-dao#:~:text=To%20refer%20to,Fields(%22name%22)
This is a case where relying on a default property (in this case Value) causes problems.

Content Control not recognizing content

I was hoping someone could help me work out why the the 'F' value in my code below continues to include my error label in the ErrorMessage String when the Count value is 5?
In the document, the content control contains text just like all the other controls (which work perfectly) but this content Control text value is not being recognised in the VBA code to map error labels.
Have tried just replacing the control and checking the properties match. Debug messages suggest the the value is just being set to the default Content Control Value of "Click or Tap here to input text".
Private Sub Create_Click()
Dim oCC As ContentControl
Dim oCC2 As ContentControl
Dim Mandatory(9) As String
Dim ErrorMessage As String
Dim ErrorCount As Integer
Dim ErrorLabel(9) As String
Dim objDoc As Document
Dim strFilename As String
Dim strFileString As String
Dim Number As String
Mandatory(0) = "A"
Mandatory(1) = "B"
Mandatory(2) = "C"
Mandatory(3) = "D"
Mandatory(4) = "E"
Mandatory(5) = "F"
Mandatory(6) = "G"
Mandatory(7) = "H"
Mandatory(8) = "I"
ErrorLabel(0) = "A Label"
ErrorLabel(1) = "B Label"
ErrorLabel(2) = "C Label"
ErrorLabel(3) = "D Label"
ErrorLabel(4) = "E Label"
ErrorLabel(5) = "F Label"
ErrorLabel(6) = "G Label"
ErrorLabel(7) = "H Label"
ErrorLabel(8) = "I Label"
ErrorMessage = ""
ErrorMessage = "The following mandatory fields are missing: "
For Count = 0 To 8
Set oCC = ActiveDocument.SelectContentControlsByTitle(Mandatory(Count)).Item(1)
MsgBox (oCC.Range.Text)
If Count = 0 Then
Number = ActiveDocument.SelectContentControlsByTitle(Mandatory(Count)).Item(1).Range.Text
End If
If oCC.Range.Text = "Click or tap here to enter text." Or oCC.Range.Text = "0.00" Then
ErrorMessage = ErrorMessage & vbCrLf & vbCrLf & "- " & ErrorLabel(Count)
MsgBox (oCC.Range.Text)
ErrorCount = ErrorCount + 1
End If
Next Count
If ErrorCount > 0 Then
MsgBox (ErrorMessage)
Else
strFileString = Number
MsgBox (strFileString)
strFilename = "Some Text Here" & " - " & strFileString & ".pdf"
With ActiveDocument
NewPath = .Path & "\" & strFilename
.SaveAs2 FileName:=NewPath, FileFormat:=wdFormatPDF
.ExportAsFixedFormat OutputFileName:=strFilename, ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=True, OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, Item:=wdExportDocumentContent
End With
End If
End Sub
Check there are no other content controls with the same title in the document.
I couldn't test your code for lack of data but from your description I guess that the ErrorMessage must be reset with each loop since it will be changed when used and would naturally retain the modified version thereafter.
Except for what follows the loop, I looked closely at your code in order to understand it. Perhaps, the changes I made will be of some use to you.
Option Explicit
Private Sub Create_Click()
Dim Doc As Document
Dim Mandatory() As String
Dim ErrorMessage As String
Dim ErrorCount As Integer
Dim strFilename As String
Dim strFileString As String ' this appears identical with 'Number'
Dim Number As String
Dim Count As Integer ' loop counter
Set Doc = ActiveDocument
Mandatory = Split("A B C D E F G H I")
Number = Doc.SelectContentControlsByTitle(Mandatory(0))(1).Range.Text
For Count = 1 To UBound(Mandatory) + 1
ErrorMessage = "The following mandatory fields are missing: "
With Doc.SelectContentControlsByTitle(Mandatory(Count))(1).Range
MsgBox "Number = " & Number & vbCr & .Text
If .Text = "Click or tap here to enter text." Or _
.Text = "0.00" Then
ErrorMessage = ErrorMessage & vbCrLf & vbCrLf & "- " & Mandatory(Count) & " Label"
MsgBox (.Text)
ErrorCount = ErrorCount + 1
End If
End With
If Count = 1 Then Exit For
Next Count
If ErrorCount > 0 Then
MsgBox (ErrorMessage)
Else
strFileString = Number
MsgBox (strFileString)
strFilename = "Some Text Here" & " - " & strFileString & ".pdf"
With Doc
NewPath = .Path & "\" & strFilename
.SaveAs2 FileName:=NewPath, FileFormat:=wdFormatPDF
.ExportAsFixedFormat OutputFileName:=strFilename, _
ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=True, _
OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, _
Item:=wdExportDocumentContent
End With
End If
End Sub
You can have VBA add the useful (some would say necessary) Option Explicit to all new code modules automatically. Select Tools > Options in the VBE window and check "Require Variable Declaration" on the Editor tab.

Advice about Arabic characters using VBA

I'm working to send Emails to each student containing ( student name and his marks ) from excel sheet as shown below
Everything working fine, But when the student name is in Arabic char. the name shows as ( ???? ) as you can see below
I changed the setting for local system to Arabic, but still, get the same problem.
Any advice?
You need to set htmlBody and use utf-8 character set.
Use the following function to make a simple transformation of a text string into html string.
Function StringToHTML(sStr As String) As String
sStr = Replace(sStr, Chr(10), "<br/>")
sStr = Replace(sStr, Chr(13), "<br/>")
sStr = Replace(sStr, Chr(11), "<br/>")
StringToHTML = "<!doctype html><html lang=""en""><body><p>"
StringToHTML = StringToHTML & sStr
StringToHTML = StringToHTML & "</p></body></html>"
End Function
With reference to this, you need to replace the line objEmail.TextBody = mailBody with the following two lines
objEmail.htmlBody = StringToHTML(mailBody)
objEmail.HtmlBodyPart.Charset = "utf-8"
If you face further problems (e.g. the email subject contains arabic chars but doesn't display properly) try adding these two lines
objEmail.TextBodyPart.Charset = "utf-8"
objEmail.BodyPart.Charset = "utf-8"
Edit (following comment)
Your full code should be like this
Sub SendMail()
Dim objEmail
Dim mailBody as String
Const cdoSendUsingPort = 2 ' Send the message using SMTP
Const cdoBasicAuth = 1 ' Clear-text authentication
Const cdoTimeout = 100 ' Timeout for SMTP in seconds
mailServer = "smtp.gmail.com"
SMTPport = 465 '25 'SMTPport = 465
mailusername = "email#some.com"
mailpassword = "password"
''''''''
Dim n As Integer
n = Application.WorksheetFunction.CountA(Range("c:c"))
For i = 2 To n
mailto = Range("c" & i).Value
mailSubject = Range("e" & i).Value
mailBody = "Hi " & Range("b" & i) & "," & vbCrLf & vbCrLf & _
"Below you can find your marks:" & vbCrLf & vbCrLf & _
"Math: - " & Range("F" & i) & vbCrLf & _
"Network: - " & Range("G" & i) & vbCrLf & _
"Physics: - " & Range("H" & i) & vbCrLf & _
"Antenna: - " & Range("I" & i)
Set objEmail = CreateObject("CDO.Message")
Set objConf = objEmail.Configuration
Set objFlds = objConf.Fields
With objFlds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = mailServer
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = SMTPport
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = cdoTimeout
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasicAuth
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = mailusername
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = mailpassword
.Update
End With
objEmail.To = mailto
objEmail.From = mailusername
objEmail.Subject = mailSubject
objEmail.htmlBody = StringToHTML(mailBody)
objEmail.HtmlBodyPart.Charset = "utf-8"
objEmail.Send
Set objFlds = Nothing
Set objConf = Nothing
Set objEmail = Nothing
Next i
End Sub
Function StringToHTML(sStr As String) As String
sStr = Replace(sStr, Chr(10), "<br/>")
sStr = Replace(sStr, Chr(13), "<br/>")
sStr = Replace(sStr, Chr(11), "<br/>")
StringToHTML = "<!doctype html><html lang=""en""><body><p>"
StringToHTML = StringToHTML & sStr
StringToHTML = StringToHTML & "</p></body></html>"
End Function

VBA/Access: How to stop "You... FORM to be active window"

I want to be able to tell IF a form is the active window.
It seems simply invoking that method produces an error. I guess I could catch that error and run with it, but it's a backwards way of doing it.
Screen.ActiveForm.Name
This needs a form to be active. If I am breaking any rules of stackOverflow please be kind and remind me as I am new to forum.
Screen.parent, screen.activeControl, etc. What if VBA editor is open, as often it is?
Function CStatus(strStatus, ByRef intType As Integer, Optional ByRef erNo, Optional erMsg, Optional strDatum)
'pXname = "CStatus"
'pXStack = Left(pXStack, 500) & ">" & pXname
'Updates and manages the status bar
Dim strPreamble As String, strOut As String, strForm As String, strComment As String, strSQL As String, strPxStack As String, strCErrStack As String
Dim intColor As Double
Dim intPreLen As Integer
'On Error GoTo err_hand
'Color Codes
'12632256 = Lt Grey
'33023 = Orange
'65280 = Green
'16744576 = Steel Grey
'Define "Constants"
intPreLen = 350 'Length of previous message cache
'** Fix missings
If (IsMissing(strDatum) = True) Then strDatum = "[N/A]"
'** Other inits
strWindow = Screen.Parent.Name
strForm = Screen.ActiveForm.Name
'** intDebug ' Minimum Level of to report to status
'bEcho = True 'Whether to echo to status
intColor = errNoColor(intType)
'Error-level idiot explanations
strComment = "0"
If IsMissing(erNo) Then erNo = 0
If (IsNull(erMsg) = False) Then
If IsMissing(erMsg) = False Then strComment = erMsg
End If
strComment = errorTree(erNo)
strPreamble = Left(strPreamble, intPreLen) & "..."
strErrStack = Left(strErrStack, intPreLen) & " > " & pXname & ":" & intType
strCErrStack = strErrStack
reS:
If ((strForm = "finvmain") Or (strForm = "fclips")) Then Screen.ActiveForm.timeStatusUpdated = Now() 'Small field keeps time
If bEcho = True Then
strPxStack = ""
strCErrStack = "" 'Internal error stack
End If
strOut = Now() & " " & intType & " (" & strType & "): " & erNo & " " & strCErrStack & " >> " & strComment & " / " & strStatus & " [" & strDatum & "] .. " & strPreamble
If bEcho = True Then
If (strForm = "fInvMain") Then Screen.ActiveForm.txtStatus2 = Screen.ActiveForm.txtStatus 'Added second window to show previous message
Screen.ActiveForm.txtStatus = strOut
End If
Screen.ActiveForm.txtStatus.ForeColor = intColor
If strForm = "fInvMain" Then strTag = Screen.ActiveForm.Controls("txttag").value
'***Event Log
If erNo = "" Then erNo = 0
If IsMissing(erMsg) = True Then erMsg = ""
If IsMissing(strDatum) = True Then strDatum = ""
If Len(strPreamble) < 2 Then strPreamble = "[None]"
'Fixxed - Syntax Error for Some Odd Reason! Apr 27th
If ((strTag = Empty) And (strForm = "fInvMain")) Then strTag = Screen.ActiveForm.txtTag 'Attempt to add tag# to entry
strStatus = cleanString(strStatus)
strDatum = cleanString(strDatum)
strComment = cleanString(strComment)
strSQL = "INSERT INTO tEvents(txtdate, myerrno, interrno, myerrmsg, interrmsg, txtform, stack, process, Datum, idLink) VALUES ('" & Now() & "','" & intType & "','" & erNo & "','" & strStatus & "','" & strComment & "','" & strForm & "','" & strErrStack & "','" & pXname & "','" & strDatum & "','" & strTag & "');"
CurrentDb.Execute strSQL, dbFailOnError
Exit Function
err_hand:
If Err.Number = 2475 Then
bEcho = False
Resume reS
Else: MsgBox "555: CStatus Internal Error, Turn off error handling to view"
End If
End Function
I need a boolean true or false IF form is active. If it isn't, I can't put stuff into a textbox in that.
To determine if a particular form is open then set focus to form:
If CurrentProject.AllForms("finvmain").IsLoaded
strForm = "finvmain"
Elseif CurrentProject.AllForms("fclips").IsLoaded Then
strForm = "fclips"
End If
If strForm <> "" Then DoCmd.SelectObject acForm, strForm