The issue I am having is connect my Save_Record (suppose to save and push info) & btnExit (saves & exits) to push the information inputted on the form to be pushed out to the web database. The only way it will push the information is if I exit out, come back in and make a small change then it will push it out.
How can I achieve this without doing this?
Option Compare Database
Option Explicit
'-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**
Private Sub btnCancel_Click() '==**== undo changes
On Error Resume Next
RunCommand acCmdUndo
Err = 0
End Sub
'-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**
Private Sub btnExit_Click()
DoCmd.Close
End Sub
Private Sub cmdViewPDF_Click()
On Error GoTo Err_cmdViewPDF_Click
Dim stDocName As String
Dim stLinkCriteria As String
stDocName = "frm_Images"
DoCmd.OpenForm stDocName, , , stLinkCriteria
Exit_cmdViewPDF_Click:
Exit Sub
Err_cmdViewPDF_Click:
MsgBox Err.Description
Resume Exit_cmdViewPDF_Click
End Sub
'-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**
Private Sub Form_AfterUpdate()
'DoCmd.Save
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
[DT_MOD] = Now()
[MstrWinUser] = Forms!frFilter!txtWinUser
End Sub
'-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**
Private Sub MOREoperInfo_Click()
Dim DocName As String
Dim LinkCriteria As String
DoCmd.Save
DocName = "frmsearch"
DoCmd.OpenForm DocName, , , LinkCriteria
End Sub
'-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**-**
'Save record and close
Private Sub Save_Record_Click()
On Error GoTo Err_Save_Record_Click
[DT_MOD] = Now()
[MstrWinUser] = Forms!frmFilter!txtWinUser
'MsgBox "Saving frm_View"
'Save the record
'If there was a record already in txt box, we will assume it has been created in web
If Trim(txtEOCIncident.Value & vbNullString) = vbNullString Then
Me.txtEOCPushFlag = "0"
RunCommand acCmdSaveRecord
DoCmd.Save
Else
'SET EOC PUSH FLAG
Me.txtEOCPushFlag = "1"
RunCommand acCmdSaveRecord
DoCmd.Save
'TRY TO UPDATE WEB DATA
If (pushEOCData(Me.ID)) Then
'CLEAR PUSH FLAG AND SET PUSHDATE
Me.txtEOCPushFlag = "0"
Me.txtEOCPushDate = Now()
RunCommand acCmdSaveRecord
DoCmd.Save
End If
End If
Exit_Save_Record_Click:
Exit Sub
Err_Save_Record_Click:
MsgBox Error$
Resume Exit_Save_Record_Click
End Sub
'*** 08-20-13 New code. Creates PDF of the Report.
Private Sub btnSaveasPDF_Click()
On Error GoTo Err_btnSaveasPDF_Click
Dim db As Database, rs As Recordset
Dim vFN As String, vPATH As String, vFile As String
Dim blRet As Boolean
Dim stDocName As String
Dim strConstantName As String
stDocName = "rpt_Out"
'added 2014-09-02, MAB
strConstantName = "REPORT_FOLDER"
vPATH = Trim(DLookup("[ConstantValue]", "dbo_Constants", "[ConstantName] = '" & [strConstantName] & "'"))
If Forms!frm_View![DIST] = "1" Or Forms!frm_View![DIST] = "2" Or Forms!frm_View![DIST] = "3" Or Forms!frm_View![DIST] = "4" Then
vFN = Forms!frm_View![ID] & "_" & Forms!frm_View![Typeofreport] & "_" & Month(Now()) & "_" & Day(Now()) & "_" & Year(Now()) & "_" & Hour(Now()) & Minute(Now()) & ".pdf"
'vPATH = "\\...\...\Reports\"
vFile = vPATH & vFN
Else
MsgBox "Please enter your number." & vbCrLf & "It must be a single digit.", vbOKOnly Or vbInformation, "*****"
End If
'write to IMAGES
Set db = CurrentDb
Set rs = db.OpenRecordset("IMAGES")
rs.AddNew
rs!SPL_FILENAME = vFN
rs!SPL_ID = [Forms]![frm_View]![ID]
rs!SPL_MOD_DT = Format$(Now(), "mm/dd/yyyy")
rs!SPL_DOC_TYP = Forms!frm_View![DOC_TYP]
rs!SPL_FILELOC = vFile
rs!SPL_ACTIVE = "-1"
rs.Update
rs.Close
DoCmd.OpenReport "rpt_OUT", acViewPreview
DoCmd.OutputTo acReport, stDocName, acFormatPDF, vFile
MsgBox "An image of this report has been saved.", vbOKOnly Or vbInformation, "*****"
Exit_btnSaveasPDF_Click:
Exit Sub
Err_btnSaveasPDF_Click:
MsgBox Err.Description
Resume Exit_btnSaveasPDF_Click
End Sub
********************PUSHEOCDATA*******************************************
'* iSpillID is the value of SPILL_ID from Spills table for the
'* the record you want to update
'*
'*******************************************************************************
Public Function pushEOCData(iSpillID As Integer) As Boolean
Dim db As Database
Dim sSql As String
Dim strStoredProcSql As String
Dim qdef As DAO.QueryDef
Dim sEOCIncident As String
Dim rs As Recordset
Dim iEOCSpillID, iEOCMat1ID, iEOCMat2ID As Long
Dim iReturn As Integer
Dim dAmount1 As Double
Dim dAmount2 As Double
Dim sSpillResponse As String
Dim sMaterialResponse As String
Dim sEOCSpillID, sEOCMat1ID, sEOCMat2ID As String
Dim iFoundAt As Long
Dim iStart As Long
Dim sTemp As String
Dim bReturn As Boolean
Dim objSpillNode As IXMLDOMNode
Dim objMaterialsNodes As IXMLDOMNodeList
Dim objMaterialNode As IXMLDOMNode
pushEOCData = True
initWEBEoc
iEOCSpillID = -1
iEOCMat1ID = -1
iEOCMat2ID = -1
'RETRIEVE INCIDENT NUMBER FROM DATABASE and associated data
'from the database. Note: this is a stored procedure
Set db = CurrentDb
Set qdef = CurrentDb.CreateQueryDef("")
qdef.Connect = CurrentDb.TableDefs("usysWellHistory").Connect
qdef.ReturnsRecords = True
'
' This stored procedure is written to return a record set with
' fields named the same as in webeoc.
'
'strStoredProcSql = "EXEC RBDMS.SPILL_QUERY #N_SPILLID=" & iSpillID
strStoredProcSql = "{CALL RBDMS.SPILL_QUERY (" & iSpillID & ")}"
qdef.sql = strStoredProcSql
Set rs = qdef.OpenRecordset
'Check to see if the recordset actually contains rows
If Not (rs.EOF And rs.BOF) Then
rs.MoveFirst 'Unnecessary in this case, but still a good habit
sEOCIncident = rs!INCIDENTID_NUMBER
If Len(sEOCIncident) < 1 Then
pushEOCData = False
Exit Function
End If
'Get the data from webeoc.
'business rules say that we have to have data
'in webeoc to continue
iReturn = getSpillNode(sEOCIncident, objSpillNode)
If iReturn < 1 Then
'MsgBox "No WEBEoc data exists for EOC Incident: " & sEOCIncident
pushEOCData = False
Exit Function
End If
'grab the data id from the spill data, we will need this later to
'update the materials
sEOCSpillID = objSpillNode.Attributes.getNamedItem("dataid").Text
iEOCSpillID = CLng(sEOCSpillID)
If iEOCSpillID < 1 Then
pushEOCData = False
Exit Function
End If
bReturn = updateEOCSpillData(rs, objSpillNode)
If bReturn = False Then
pushEOCData = False
Exit Function
End If
dAmount1 = rs!AMOUNT1
dAmount2 = rs!AMOUNT2
'Get the materials records from webeoc for this incident number.
iResult = getMaterialNodes(sEOCSpillID, objMaterialsNodes)
If dAmount1 > 0 Then
'If webeoc has one or more materials records for the incident,
'grab the first record and update it with dbase values
If objMaterialsNodes.LENGTH > 0 Then
Set objSpillNode = objMaterialsNodes.Item(0)
'update materials
updateEOCMaterialData rs, objSpillNode, 1
Else
'insert materials
insertEOCMaterialData rs, 1, sEOCSpillID
End If
End If
If dAmount2 > 0 Then
'if webeoc has more than one materials record for the incident,
'grab the second record and update it.
If objMaterialsNodes.LENGTH > 1 Then
Set objSpillNode = objMaterialsNodes.Item(1)
'update materials
updateEOCMaterialData rs, objSpillNode, 2
Else
'insert materials
insertEOCMaterialData rs, 2, sEOCSpillID
End If
End If
Else
'MsgBox "No data needs to be pushed to webeoc for this spill."
pushEOCData = True
Exit Function
End If
rs.Close
End Function
Related
I do a calculation on all three Events on a subform to update the main form:
Private Sub Form_AfterDelConfirm(Status As Integer)
Me.Parent.UpdateStunden
End Sub
Private Sub Form_AfterInsert()
Me.Parent.UpdateStunden
End Sub
Private Sub Form_AfterUpdate()
Me.Parent.UpdateStunden
End Sub
Public Sub UpdateStunden(Optional BeforeUpdateEvent As Boolean = False)
On Error GoTo ErrorHandler
Dim rst As Recordset
Dim sql As String
Dim NewStunden As Variant
If Me.NewRecord Then Exit Sub
sql = _
"SELECT Sum(Stunden) AS SumStunden " & _
"FROM Tätigkeiten " & _
"WHERE Tätigkeitsdatum = #" & Format(Me!Tätigkeitsdatum, "yyyy-mm-dd") & "#;"
Set rst = CurrentDb().OpenRecordset(sql, dbOpenSnapshot)
If Not rst.EOF Or Not rst.BOF Then
NewStunden = rst!SumStunden
If Nz(NewStunden) <> Nz(Me.Stunden) Or IsNull(Me.Stunden) Then
Me.Stunden = NewStunden
End If
End If
ExitPoint:
On Error Resume Next
If Me.Dirty And Not BeforeUpdateEvent Then Me.Dirty = False
rst.Close
Set rst = Nothing
Exit Sub
ErrorHandler:
Select Case Err
Case Else: LogNTEvent Now & "Error: " & Err & ": " & Err.Description & ": UpdateStunden", EVENTLOG_ERROR_TYPE, 1000, "Error: " & Err.Number
End Select
Resume ExitPoint
End Sub
This normally works fine.
But there is a bug if I copy and paste more than one record into the subform. When I copy and paste multiple records from one subform to the same subform but on another main-form record the calculation is wrong.
This should work as Standard because I use it everywhere.
We Need an After Paste Event!
Does anyone know how to do this?
Regards Richard
Just set the main form value to null from the subform:
Private Sub Form_AfterDelConfirm(Status As Integer)
Me.Parent.Stunden = Null
End Sub
Private Sub Form_AfterInsert()
Me.Parent.Stunden = Null
End Sub
Private Sub Form_AfterUpdate()
Me.Parent.Stunden = Null
End Sub
Then use the timer:
Private Sub Form_Timer()
If IsNull(Me.Stunden) Then UpdateStunden
End Sub
Private Sub Stunden_AfterUpdate()
Me.Dirty = False
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
UpdateStunden True
End Sub
Public Sub UpdateStunden(Optional BeforeUpdateEvent As Boolean = False)
On Error GoTo ErrorHandler
Dim rst As Recordset
Dim sql As String
Dim NewStunden As Variant
If Me.NewRecord Then Exit Sub
sql = _
"SELECT Sum(Stunden) AS SumStunden " & _
"FROM Tätigkeiten " & _
"WHERE Tätigkeitsdatum = #" & Format(Me!Tätigkeitsdatum, "yyyy-mm-dd") & "#;"
Set rst = CurrentDb().OpenRecordset(sql, dbOpenSnapshot)
If Not rst.EOF Or Not rst.BOF Then
NewStunden = rst!SumStunden
If Nz(NewStunden) <> Nz(Me.Stunden) Or IsNull(Me.Stunden) Then
Me.Stunden = NewStunden
End If
End If
ExitPoint:
On Error Resume Next
If Me.Dirty And Not BeforeUpdateEvent Then Me.Dirty = False
rst.Close
Set rst = Nothing
Exit Sub
ErrorHandler:
Select Case Err
Case Else: LogNTEvent Now & "Error: " & Err & ": " & Err.Description & ": UpdateStunden", EVENTLOG_ERROR_TYPE, 1000, "Error: " & Err.Number
End Select
Resume ExitPoint
End Sub
Just set the Control-Source of the Textbox-Control on the main form to this:
=DomSumme("Stunden";"Tätigkeiten";"Tätigkeitsdatum = #" & Format([Tätigkeitsdatum];"jjjj-mm-tt") & "#")
And then requery after all three Events:
Private Sub Form_AfterDelConfirm(Status As Integer)
Me.Parent!Test.Requery
End Sub
Private Sub Form_AfterInsert()
Me.Parent!Test.Requery
End Sub
Private Sub Form_AfterUpdate()
Me.Parent!Test.Requery
End Sub
N.B. German Office 2010
I have two linked Tables 'tblPatients' and 'tblDSA' and two continues forms 'frmPatients' and 'frmDSA'. When I create a new patient via 'frmPatient'I would like to add a new record for that patient in 'frmDSA' without closing the form.
On 'frmPatients' next to each record there is a button 'SaveNewRecord' that does the following:
(1)saves a new record to 'tblPatients' and also filters
(2) opens 'frmDSA' to display related records to that Patients.
Here is the filtering code:
If Not Me.NewRecord Then
DoCmd.OpenForm "DSAfrm", _
WhereCondition:="LABCODE=" & Me.LABCODE
End If
Here is what happens:
After the 'DSAfrm' pops up and I try to enter a new record I get the following error."can not add records joint key of table 'TableName' not in record-set"
The new patient has been save to 'tblPatients' but Access is not letting me add any new records. Please help!
Here is the code that I use to save the new records:
Private Sub Command385_Click()
Dim db As DAO.Database
Dim PatientTable As DAO.Recordset
Dim DSAtable As DAO.Recordset2
Dim errMsg As String 'Where we will store error messages
Dim errData As Boolean 'Default = False if we have an error we will set it to True.
Dim i As Integer 'used as a counter in For..Next loops.
Dim x As Integer 'used as counter in For..Next loops.
Dim errorArray(0 To 3) As String 'Array to hold the error messages so we can 'use them if needed.
If Me.LABCODE.Value = "" Then
errorArray(0) = "Must Enter Labcode."
errData = True
End If
If Me.LastName.Value = 0 Then
errorArray(1) = "Must Enter Patient Number"
errData = True
End If
If Me.FirstName.Value = "" Then
errorArray(2) = "Must Enter Insurance Type"
errData = True
End If
If Me.MRN.Value = "" Then
errorArray(3) = "Must Enter Intake Nurse"
errData = True
End If
'MsgBox "errData = " & errData
If errData = True Then
i = 0
x = 0
For i = 0 To 3
If errorArray(i) <> "" Then
If x > 0 Then
errMsg = errMsg & vbNewLine & errorArray(i)
Else
errMsg = errorArray(i)
x = x + 1
End If
End If
Next i
MsgBox errMsg & vbNewLine & "Please try again."
errMsg = ""
Me.LABCODE.SetFocus
Exit Sub
End If
Set db = CurrentDb()
Set PatientTable = db.OpenRecordset("tblPatients")
With PatientTable
.AddNew
!LABCODE = Me.LABCODE.Value
!LastName = Me.LastName.Value
!FirstName = Me.FirstName.Value
!MRN = Me.MRN.Value
!MRNTwo = Me.MRN2.Value
Debug.Print Me.MRN.Value
'!CPI#2 = Me.MRN2.Value
!Kidney = Me.cbKidney.Value
!Heart = Me.cbHeart.Value
!Lung = Me.cbLung.Value
!Liver = Me.cbLiver.Value
!Pancreas = Me.cbPancreas.Value
!DateLogged = Format(Date, "MM/DD/YY")
.Update
End With
'End If
Set DSAtable = db.OpenRecordset("tblDSA")
With DSAtable
.AddNew
!LABCODE = Me.LABCODE.Value
.Update
End With
'Let the user know it worked.
MsgBox "This patient has been added successfully.", vbOKOnly
'If Not Me.NewRecord Then
DoCmd.OpenForm "DSAfrm", _
WhereCondition:="LABCODE=" & Me.LABCODE
'End If
End Sub
I'm getting a compile error:
Sub or function not defined(error area in bold)
Option Compare Database
Option Explicit
Private Sub cboDates_AfterUpdate()
On Error Resume Next
Dim strInterval As String
Dim dblValue As Double
Dim datStartDate As Date
Dim datEndDate As Date
Dim WeekdayStsrt As Integer
WeekdayStsrt = 1 'Start day of week - 1=Sunday, 2=Monday, 3=Tuesday...
'Sets Start and End Date textboxes based on combobox selection
strInterval = Me.cboDates.Column(1)
dblValue = Me.cboDates.Column(2)
Select Case strInterval
Case "d"
datStartDate = Date
datEndDate = Date
Case "ww"
datStartDate = Date - Weekday(Date) + WeekdayStsrt
datEndDate = datStartDate + 6
Case "m"
datStartDate = DateSerial(Year(Date), Month(Date) + dblValue, 1)
datEndDate = DateSerial(Year(Date), Month(Date) + dblValue + 1, 0)
dblValue = 0
Case "yyyy"
datStartDate = DateSerial(Year(Date), 1, 1)
datEndDate = DateSerial(Year(Date), 12, 31)
Case "YTD"
datStartDate = DateSerial(Year(Date), 1, 1)
datEndDate = Date
strInterval = "yyyy"
Case "All"
datStartDate = DateSerial(2000, 1, 1) 'Earliest Date of available data in system
datEndDate = DateSerial(Year(Date), 12, 31)
strInterval = "d"
End Select
Me.txtStartDate = DateAdd(strInterval, dblValue, datStartDate)
Me.txtEndDate = DateAdd(strInterval, dblValue, datEndDate)
End Sub
Private Sub cboReportGroup_AfterUpdate()
On Error GoTo Err_Trap
'Filter listbox based on Report Group combobox selection.
Dim SQL As String
Me.lstReport = Null
SQL = Me.lstReport.Tag
If Not Me.cboReportGroup = "(All)" Then
SQL = SQL & " WHERE ReportGroup='" & Me.cboReportGroup & "'"
End If
SQL = SQL & " ORDER BY tsysReports.ReportTitle;"
Me.lstReport.RowSource = SQL
Err_Trap_Exit:
Exit Sub
Err_Trap:
MsgBox Err.Description
Resume Err_Trap_Exit
End Sub
Private Sub cmdEndDate_Click()
On Error Resume Next
'Launch Calendar Control
DateCheck_MEI Me.txtEndDate
Me.cboDates = Null
End Sub
Private Sub cmdExport_Click()
On Error GoTo Err_Trap
Dim SQL As String
Echo False
Call cmdOpen_Click 'execute the button that opens the report for print preview
SQLEdit_MEI "ArrivalTimingTableQuery", Application.Reports(Me.lstReport).RecordSource
If Application.Reports(Me.lstReport).Filter = "" Then
SQL = "SELECT * FROM ArrivalTimingTableQuery "
Else
SQL = "SELECT * FROM ArrivalTimingTableQuery WHERE " & Application.Reports(Me.lstReport).Filter
End If
SQLEdit_MEI "qryTempExport", SQL
DoCmd.OutputTo acOutputQuery, "qryTempExport", acFormatXLS, CurrentProject.Path & "\temp.xls", True
DoCmd.Close acReport, Me.lstReport, acSaveNo
Echo True
Err_Trap_Exit:
Exit Sub
Err_Trap:
Echo True
MsgBox Err.Description
Resume Err_Trap_Exit
End Sub
Private Sub cmdOpen_Click()
On Error GoTo Err_Trap
Dim strCriteria As String
If Me.txtEndDate < Me.txtStartDate Then
MsgBox "End Date cannot be prior to Start Date."
Exit Sub
End If
If IsNull(Me.lstReport) Then
MsgBox "Please select a report"
Exit Sub
End If
If Not Me.lstReport.Column(2) = "" Then
strCriteria = Me.cboField & " Between #" & Me.txtStartDate & "# And #" & Me.txtEndDate & "#"
End If
DoCmd.OpenReport Me.lstReport, acViewReport, , strCriteria
Err_Trap_Exit:
Exit Sub
Err_Trap:
MsgBox Err.Description
Resume Err_Trap_Exit
End Sub
Private Sub cmdStartDate_Click()
On Error Resume Next
'Launch Calendar Control
DateCheck_MEI Me.txtStartDate
Me.cboDates = Null
End Sub
Private Sub Form_Load()
Call cboReportGroup_AfterUpdate
End Sub
Private Sub lstReport_Click()
On Error Resume Next
Me.lblDescription.Caption = "Report Description: " & Me.lstReport.Column(3)
Me.cboField.RowSource = Me.lstReport.Column(2) 'Set to values of DateCriteria field of table tsysReports
Me.cboField = Me.cboField.ItemData(0) 'Select 1st item in combobox
'Hide Report Criteria Section if no Date Filter for selected report
If Me.lstReport.Column(2) = "" Then
Me.box1.Visible = True
Else
Me.box1.Visible = False
End If
End Sub
Private Sub lstReport_DblClick(Cancel As Integer)
Call cmdOpen_Click
End Sub
From what you've posted, and ignoring what may be wrong inside of your sub,
the fix would be to end the sub:
Private Sub cmdStartDate_Click()
'Do stuff
End Sub 'This is the part you are missing
I have been searching for days for ways on how to implement an audit trail in my access 2010 database. There are plenty of solutions out there that work great when the form is bound, but I have several forms that are unbound and perform certain critical functions I wish to have an audit trail on (they are unbound due to having to edit different tables depending on user input, functions performed through VB and SQL scripting, so binding them to a table would not work). But there seems to be no easy solutions on this type of auditing without doing weeks and weeks worth of custom coding. Does anyone have any ideas on how to do this? Is there a way to audit all activity without having to bind a form? Can't I just have code that monitors a table's changes without having to go though code on the back side of the forms?
I have recently done this!
Each form has code to write changes to a table.
The Audit Trail gets a bit tricky when you lose Screen.ActiveForm.Controls as the reference - which happens if you use a Navigation Form.
It is also using Sharepoint lists so I found that none of the published methods were available.
I (often) use a form in the middle as a display layer and I find it has to fire the Form_Load code in the next forms down the line as well.
Once they are open they need to be self sustaining.
Module Variable;
Dim Deleted() As Variant
Private Sub Form_BeforeUpdate(Cancel As Integer)
'Audit Trail - New Record, Edit Record
Dim rst As Recordset
Dim ctl As Control
Dim strSql As String
Dim strTbl As String
Dim strSub As String
strSub = Me.Caption & " - BeforeUpdate"
If TempVars.Item("AppErrOn") Then
On Error Resume Next 'On Error GoTo Err_Handler
Else
On Error GoTo 0
End If
strTbl = "tbl" & TrimL(Me.Caption, 6)
strSql = "SELECT * FROM tblzzAuditTrail WHERE DateTimeMS = #" & GetTimeUTC & "#;"
Set rst = dbLocal.OpenRecordset(strSql)
For Each ctl In Me.Detail.Controls
If ctl.ControlType = acTextBox Or ctl.ControlType = acComboBox Then
If ctl.Name <> "DateUpdated" Then
If Nz(ctl.Value) <> Nz(ctl.OldValue) Then
If Me.NewRecord Then
With rst
.AddNew
!DateTimeMS = GetTimeUTC()
!UserID = TempVars.Item("CurrentUserID")
!ClientID = TempVars.Item("frmClientOpenID")
!RecordID = Me.Text26
!ActionID = 1
!TableName = strTbl
!FieldName = ctl.ControlSource
!NewValue = ctl.Value
.Update
End With
Else
With rst
.AddNew
!DateTimeMS = GetTimeUTC()
!UserID = TempVars.Item("CurrentUserID")
!ClientID = TempVars.Item("frmClientOpenID")
!RecordID = Me.Text26
!ActionID = 2
!TableName = strTbl
!FieldName = ctl.ControlSource
!NewValue = ctl.Value
!OldValue = ctl.OldValue
.Update
End With
End If
End If
End If
End If
Next ctl
rst.Close
Set rst = Nothing
Exit Sub
Err_Handler:
Select Case Err.Number
Case 3265
Resume Next 'Item not found in recordset
Case Else
'Unexpected Error
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf & "Error Source: " & strSub & vbCrLf & "Error Description: " & _
Err.Description, vbExclamation, "An Error has Occured!"
End Select
rst.Close
Set rst = Nothing
End Sub
Private Sub Form_Delete(Cancel As Integer)
Dim ctl As Control
Dim i As Integer
Dim strTbl As String
strTbl = "tbl" & TrimL(Me.Caption, 6)
ReDim Deleted(3, 1)
For Each ctl In Me.Detail.Controls
If ctl.ControlType <> acLabel Then
' Debug.Print .Name
If ctl.Name <> "State" And ctl.Name <> "Pcode" Then
If Nz(ctl.Value) <> "" Then
Deleted(0, i) = ctl.ControlSource
Deleted(1, i) = ctl.Value
Deleted(2, i) = Me.Text26
' Debug.Print Deleted(0, i) & ", " & Deleted(1, i)
i = i + 1
ReDim Preserve Deleted(3, i)
End If
End If
End If
Next ctl
End Sub
Private Sub Form_AfterDelConfirm(Status As Integer)
Dim rst As Recordset
Dim ctl As Control
Dim strSql As String
Dim strTbl As String
Dim i As Integer
Dim strSub As String
strSub = Me.Caption & " - AfterDelConfirm"
If TempVars.Item("AppErrOn") Then
On Error Resume Next 'On Error GoTo Err_Handler
Else
On Error GoTo 0
End If
strTbl = "tbl" & TrimL(Me.Caption, 6)
strSql = "SELECT * FROM tblzzAuditTrail WHERE DateTimeMS = #" & GetTimeUTC() & "#;"
Set rst = dbLocal.OpenRecordset(strSql)
'Audit Trail - Deleted Record
If Status = acDeleteOK Then
For i = 0 To UBound(Deleted, 2) - 1
With rst
.AddNew
!DateTimeMS = GetTimeUTC()
!UserID = TempVars.Item("CurrentUserID")
!ClientID = TempVars.Item("frmClientOpenID")
!RecordID = Deleted(2, i)
!ActionID = 3
!TableName = strTbl
!FieldName = Deleted(0, i)
!NewValue = Deleted(1, i)
.Update
End With
Next i
End If
rst.Close
Set rst = Nothing
Exit Sub
Err_Handler:
Select Case Err.Number
Case 3265
Resume Next 'Item not found in recordset
Case Else
'Unexpected Error
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf & "Error Source: " & strSub & vbCrLf & "Error Description: " & _
Err.Description, vbExclamation, "An Error has Occured!"
End Select
rst.Close
Set rst = Nothing
End Sub
first off I am brand new to iMacros and not great with VBA (I know not a great start)
So my end game is to use iMacros to go to a site fill in a form on the site with a name from a table in access enter the name and grab some resulting text from that site grab the text and put it in a table. I will have to do this for each record in the table. So far this is what I have:
Dim Rs As DAO.Recordset 'recordset for list of names from VcWAuditUsers
Dim db As DAO.Database
Dim SQL As String
Dim Sql2 As String
Dim STRErr As String
Dim sTableName As String
Dim serverName As String
Dim dbName As String
Dim strUserCnt As Integer
Dim UserName As Variant
Dim StrSql As String
Dim iim1, iret
Set iim1 = CreateObject("imacros")
iret = iim1.iimInit
iret = iim1.iimPlayCode("URL GOTO=https://www.sam.gov/portal/public/SAM/)
sTableName = "vCPpAuditUsers"
serverName = GetLinkedServer(sTableName)
dbName = GetLinkedDatabase(sTableName)
SQL = "Select Distinct FName, LName from " & sTableName
Set db = CurrentDb
Set Rs = db.OpenRecordset(SQL)
If (Not Rs.EOF And Not Rs.BOF) Then
Rs.MoveLast
Rs.MoveFirst
With Rs
Do While (Rs.EOF = False)
UserName = Trim(![FName]) & " " & Trim(![LName])
MsgBox ("New Name: " & UserName)
strUserCnt = Rs.recordCount
MsgBox ("Number of rows: " & strUserCnt)
'set iMacros variables
iret = iim1.iimSet("CONTENT", UserName)
iret = iim1.iimPlay("Y:\Data\FS01-M\Healthcare\SAM_iMacro\SAMiMacro.iim")
If iret < 0 Then
MsgBox iim1.iimGetLastError()
End If
StrSql = "Insert Into ExceptionResults Values('" & UserName & "','" & iim1.iimGetExtract(1) & Now & "')"
MsgBox ("Test SqlInsert: " & StrSql)
.MoveNext
Loop
End With
Rs.Close
db.Close
End If
I know that I am missing some key stuff but I have been unable to find a good example to base what I am doing on.
Any help is greatly appreciated!
Thanks.
What I came up with:
Option Compare Database
Option Explicit
Private Sub cmdGetExceptions_Click()
Dim YNMess As String
YNMess = MsgBox("Do you wish to truncate results table ExceptionResults?", vbYesNo, "TRUNCATE?")
If YNMess = vbYes Then
Call ClearExceptionTable
Call RunExceptionTable
End If
If YNMess = vbNo Then
Call RunExceptionTable
End If
End Sub
Private Sub RunExceptionTable()
Dim Rs As DAO.Recordset 'recordset for list of names from VcWAuditUsers
Dim db As DAO.Database
Dim SQL As String
Dim sTableName As String
Dim serverName As String
Dim dbName As String
Dim strUserCnt As Integer
Dim UserName As Variant
Dim StrSql As String
Dim ExceptStat As String
On Error GoTo ErrHandler
Dim iim1, iret
' Creates iMacros object and gives the starting webpage
Set iim1 = CreateObject("imacros")
iret = iim1.iimInit
iret = iim1.iimPlayCode("URL GOTO=https://www.sam.gov/)
'Sets the source table name
sTableName = "[SourceTable]"
'Sets the SQL string to grab the names of people to be inserted into website input section
SQL = "Select Distinct FName, LName from " & sTableName
'Starts the recordset for the source table and recordset
Set db = CurrentDb
Set Rs = db.OpenRecordset(SQL)
'resets the RS to start at the begining
If (Not Rs.EOF And Not Rs.BOF) Then
Rs.MoveLast
Rs.MoveFirst
'Grabs the total record count to use for end user messaging.
strUserCnt = Rs.recordCount
'MsgBox ("Number of rows: " & strUserCnt)
'Opens RS and starts while loop to open first record of the source table
With Rs
Do While (Rs.EOF = False)
'Creates new UserName by combining first and last name
UserName = Trim(![FName]) & " " & Trim(![LName])
'MsgBox ("New Name: " & UserName)
'set iMacros variables This subs the spot in the iMacros code where you manually entered information (there should be {{USERNAME}} in the iMacros where you want to enter data.
iret = iim1.iimSet("USERNAME", UserName)
'Plays the iMacro you recorded and altered earlier.
iret = iim1.iimPlay("Location of your iMacros goes here.iim")
'Checks for errors in the iMacros(anything in the negative is considered an error)
If iret < 0 Then
MsgBox iim1.iimGetLastError()
End If
'grabs the extracted data from recorded iMacro. the extracted data is stored in an (1) based array. Makes substitutions for the text that it extracts to convert to 1 or 0
If Left(iim1.iimGetExtract(1), 2) = "No" Then
ExceptStat = 0
Else
ExceptStat = 1
End If
'For each record in the source the extracted data is entered into the insert statement below along with the employee name and date. then warnings are suppressed and each is inserted into a local access table, Loop and move to the next.
StrSql = "Insert Into ExceptionResults Values('" & UserName & "'," & ExceptStat & ",'" & Now & "')"
DoCmd.SetWarnings False
DoCmd.RunSQL (StrSql)
DoCmd.SetWarnings True
.MoveNext
Loop
End With
MsgBox ("ExceptionResults table is complete and has " & strUserCnt & " Records")
'Clean up
Rs.Close
db.Close
End If
'Clean up
Set db = CurrentDb
Set Rs = db.OpenRecordset(SQL)
Set iim1 = Nothing
strUserCnt = 0
ErrHandler:
MsgBox "ERROR" & vbCrLf & Err.Description, vbCritical, "CmdGetExceptions"
End Sub
Private Sub ClearExceptionTable()
Dim StrSql2 As String
StrSql2 = "Delete from ExceptionResults"
DoCmd.SetWarnings False
DoCmd.RunSQL (StrSql2)
DoCmd.SetWarnings True
MsgBox ("All records from ExceptionResults have been truncated")
End Sub