Update MS Access Marquee text on each loop - vba

I admit to being a bit of a novice, but have designed myself a very handy personal MS Access database. I have tried to find a solution to the following on the net, but have been unsuccessful so far, hence my post (the first time I've done this).
I have a marquee on a form in MS Access, which scrolls the count of "incomplete tasks" to do. A "Tasks COUNT Query" provides a number from zero upwards. After the form loads, the code below scrolls a message (right to left) on the marquee in the form "There are X tasks requiring action." X is the number provided from the "Tasks COUNT Query". I would like the text string on the marquee to update on each loop, so that when I mark a task as complete, the next pass on the marquee shows the number (X) as being the updated count.
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim Number As String
Set db = CurrentDb
Set rst = db.OpenRecordset("Tasks COUNT Query")
If Not (rst.EOF And rst.BOF) Then
Do While Not rst.EOF
Number = rst![Tasks]
strTxt = strTxt & "There are " & Number & " tasks requiring action."
rst.MoveNext
Loop
End If
rst.Close
strTxt = Left(strTxt, Len(strTxt)) 'remove the coma at the end
strTxt = Space(30) & strTxt 'start position
Set rst = Nothing
Set db = Nothing
Me.TimerInterval = 180
End Sub
The following code runs on the form timer interval:
Private Sub Form_Timer()
Dim x
On Error GoTo Form_Timer_Err
x = Left(strTxt, 1)
strTxt = Right(strTxt, Len(strTxt) - 1)
strTxt = strTxt & x
lblMarqTask.Caption = Left(strTxt, 180)
Exit Sub
Form_Timer_Exit:
Exit Sub
Form_Timer_Err:
Me.TimerInterval = 0
Exit Sub
End Sub
I would be grateful for any assistance :)

To answer you question: -
I would like the text string on the marquee to update on each loop
To do this you need to place your code that collects the string into its own procedure and then pick a time to call it. I.e.
Move the Form_Load() code into its own procedure
Private Sub GetString()
Dim db As DAO.Database
... [The remaining code] ...
Me.TimerInterval = 180
End Sub
Change Form_Load() to call the new procedure
Private Sub Form_Load()
GetString
End Sub
Have the timer call the new procedure every so often to update the marquee (also known as ticker tape).
Private Sub Form_Timer()
Dim x
Static LngTimes As Long
On Error GoTo Form_Timer_Err
LngTimes = LngTimes + 1
If LngTimes = 100 Then
GetString
LngTimes = 0
End If
x = Left(StrTxt, 1)
StrTxt = Right(StrTxt, Len(StrTxt) - 1)
StrTxt = StrTxt & x
lblMarqTask.Caption = Left(StrTxt, 180)
Exit Sub
Form_Timer_Exit:
Exit Sub
This will update it every 100 times the timer runs. I have tested this and it works, albeit causing a judder in marquee scrolling.
I would like to take the time to give you some extra support in your code that may help understand VBA and make things clearer/easier for you in any future development.
The changes I have supplied are minimal to give you the desired result within the code you have currently. However it does mean I carried some issue across with it. I would perform the same feature with the below: -
Option Compare Database
Option Explicit
Private StrStatus As String
Private Sub GetStatus()
Dim Rs As DAO.Recordset
Set Rs = CurrentDb.OpenRecordset("SELECT count([Task]) FROM [TblTasks] WHERE [Done] = 'No'")
StrStatus = "There are " & Rs(0) & " tasks requiring action."
Rs.Close
Set Rs = Nothing
End Sub
Private Sub Form_Load()
Me.TimerInterval = 180
Me.lblMarqTask.Caption = ""
End Sub
Private Sub Form_Timer()
Static StrStatus_Lcl As String
If StrStatus_Lcl = "" Then
GetStatus
StrStatus_Lcl = StrStatus & Space(30)
If Me.lblMarqTask.Caption = "" Then Me.lblMarqTask.Caption = Space(Len(StrStatus_Lcl))
End If
Me.lblMarqTask.Caption = Right(Me.lblMarqTask.Caption, Len(Me.lblMarqTask.Caption) - 1) & Left(StrStatus_Lcl, 1)
StrStatus_Lcl = Right(StrStatus_Lcl, Len(StrStatus_Lcl) - 1)
End Sub
The result is the string scrolling will remain smooth the value get updates with each iteration.
To talk through what I have done here.
'Option Explicit' Is always good practice to have at the top of your modules/code, it forces you to declare your variables which can save you a headache in the future. This can be automatically added with new code object by enabling 'Require Variable Declaration' in 'Tools' > 'Options' of the VBA Developer environment (also known as the VBE).
Its not clear what the query was doing but to save on a loop I change it to return a single value that I could use. SELECT count([Task]) FROM [TblTasks] WHERE [Done] = 'No' will return a count of all items in TblTasks where the column Done equals No.
In format load I set the timer interval as this only needs setting once and I also ensured the marquee was empty before it run.
The timer keeps a local copy of the status that it remembers. Declaring with the word Static means the content of the variable is not lost between executions in the way a Dim declared variable would be.
If the local copy is empty (i.e. we have used it all up) then update what the status is (GetStatus) and get a new copy.
I hope this has been of help!

Related

Bulk editing Microsoft Access Reports - Toolbar property

Summary:
I have a need to modify several reports (300+). The toolbar property no longer exists in this new database (was a port of an ADP, have a custom ribbon to replace it), so I need the modify the Toolbar property in all my reports to be blank
What I've tried
Iterating through all reports and changing the property to a string. I've been this with success with essentially the same code to modify a RecordSource and it worked.
Sub RemoveToolbarItemFromReports()
Dim oReport As Report
Dim nItem As Long
Dim bIsLoaded As Boolean
Dim n As Integer
n = FreeFile()
Open "pathToMystuff\test.txt" For Output As #n
For nItem = 0 To CurrentProject.AllReports.Count - 1
bIsLoaded = CurrentProject.AllReports(nItem).IsLoaded
DoCmd.OpenReport CurrentProject.AllReports(nItem).Name, acDesign
Set oReport = Reports(CurrentProject.AllReports(nItem).Name)
If (oReport.Toolbar = "MYTOOLBAR") Then
Debug.Print (oReport.Name)
Debug.Print (oReport.Toolbar)
Write #n, oReport.Name
Write #n, oReport.Toolbar
' Does not persist
Reports(oReport.Name).Toolbar = ""
' Does not persist
Reports(oReport.Name).Report.Toolbar = ""
' Does not persist
oReport.Toolbar = ""
End If
If Not bIsLoaded Then
DoCmd.Close acReport, oReport.Name
End If
Next
Close #n
End Sub
What would be great is if I could either get this VBA code to write changes to my accdb file or if there was a .NET library for reading/modifying Access forms/reports (All libraries that I can find are for reading/writing tables)

How to check for duplicate names, but avoid activating on itself

I have form in which user have to enter company name, to avoid duplicates I wrote On_Exit event for data entry field. It checks all the records and if it finds duplicate it notifies user. Problem is that I use same form for entered data viewing and then doing it same On_Exit event shows duplicate warning despite entry not being duplicate. It happens because code check for all entries and since it is already in database it founds itself and raises false alarm, it is a code flaw, but I have no idea how to avoid. Can somebody offer clever way to avoid this problem without creating two identical forms (except one without duplicate checking)?
My code for duplicate checking:
Private Sub Pareisk_pav_Exit(Cancel As Integer)
Dim Par_pav As String
Dim rst As DAO.Recordset
Dim Counter As Long
Set rst = CurrentDb.OpenRecordset("tblPareiskejai")
Do Until rst.EOF
Par_pav = rst(1)
If rst(1) = Me.Pareisk_pav.Value Then
Me.WarningLB.Caption = "Entry with this name already exist"
Exit Do
Else
Me.WarningLB.Caption = ""
End If
rst.MoveNext
Loop
Exit Sub
I have tried to implement Counter in my code to ignore first match, but in this case it catches only second duplicate then entering new entry.
Counter solution (not working as intended) I have tried:
Do Until rst.EOF
Par_pav = rst(1)
If rst(1) = Me.Pareisk_pav.Value Then
Counter = Counter + 1
If Counter = 2 Then
Me.WarningLB.Caption = "Entry with this name already exist"
Exit Do
End If
Else
Me.WarningLB.Caption = ""
End If
rst.MoveNext
Loop
I suddenly come up with a solution myself. Since new entry gets new ID even before saved I thought I can use it in my advantage and added And rst(0) <> Me.ID.Value to my if clause. So far it works fine. Full edited code:
Private Sub Pareisk_pav_Exit(Cancel As Integer)
Dim Par_pav As String
Dim rst As DAO.Recordset
Dim marker As Boolean
Set rst = CurrentDb.OpenRecordset("tblPareiskejai")
Counter = 0
Do Until rst.EOF
Par_pav = rst(1)
If rst(1) = Me.Pareisk_pav.Value And rst(0) <> Me.ID.Value Then
Me.WarningLB.Caption = "Name already exist!"
Exit Do
Else
Me.WarningLB.Caption = ""
End If
rst.MoveNext
Loop
Exit Sub
End Sub

VBA - Unable to map drive to sharepoint on another computer

I'm mapping to the company's sharepoint drive using VBA. The intention is to save local file to sharepoint, and delete local file and unmapped the drive after success.
On my machine(Windows 10 64bits), the code works perfectly fine, successfully mapped the drive, created folder and file, successfully uploaded to sharepoint and unmap the drive.
However, when I run the same excel workbook that contains the same code on my colleague's computer(Window 7), it failed. There's no error being shown, except that it keeps on loading and loading until Excel Not Responsive. I tried manually mapping the drive, it success.
I tried to debug and found out that the code stops (keeps on loading) at MsgBox "Hello" but could not figure out what's missing.
Both are using Excel 2016
Any help and suggestions are appreciated. let me know if more info is needed. Thanks in advance.
This is my vba code
Sub imgClicked()
Dim fileName As String
Dim SharePointLib As String
Dim MyPath As String
Dim folderPath As String
Dim objNet As Object
Dim copyPath As String
Dim copyFilePath As String
folderPath = Application.ThisWorkbook.path
MyPath = Application.ThisWorkbook.FullName
Dim objFSO As Object
Dim strMappedDriveLetter As String
Dim strPath As String
Dim spPath As String
strPath = "https://company.com/sites/test/test 123/" 'example path
spPath = AvailableDriveLetter + ":\test.xlsm" 'example path
copyPath = folderPath + "\copyPath\"
'Add reference if missing
Call AddReference
Set objFSO = CreateObject("Scripting.FileSystemObject")
With objFSO
strMappedDriveLetter = IsAlreadyMapped(.GetParentFolderName(strPath))
If Not Len(strMappedDriveLetter) > 0 Then
strMappedDriveLetter = AvailableDriveLetter
If Not MapDrive(strMappedDriveLetter, .GetParentFolderName(strPath)) Then
MsgBox "Failed to map SharePoint directory", vbInformation, "Drive Mapping Failure"
Exit Sub
End If
End If
' Check file/folder path If statement here
End With
Set objFSO = Nothing
End Sub
Code for getting available drive
' Returns the available drive letter starting from Z
Public Function AvailableDriveLetter() As String
' Returns the last available (unmapped) drive letter, working backwards from Z:
Dim objFSO As Object
Dim i As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
For i = Asc("Z") To Asc("A") Step -1
Select Case objFSO.DriveExists(Chr(i))
Case True
Case False
Select Case Chr(i)
Case "C", "D" ' Not actually necessary - .DriveExists should return True anyway...
Case Else
AvailableDriveLetter = Chr(i)
Exit For
End Select
End Select
Next i
Set objFSO = Nothing
MsgBox "This is the next available drive: " + AvailableDriveLetter ' returns Z drive
MsgBox "Hello" ' After this msgBox, starts loading until Not Responsive
End Function
Function to Map drive
Public Function MapDrive(strDriveLetter As String, strDrivePath As String) As Boolean
Dim objNetwork As Object
If Len(IsAlreadyMapped(strDrivePath)) > 0 Then Exit Function
Set objNetwork = CreateObject("WScript.Network")
objNetwork.MapNetworkDrive strDriveLetter & ":", strDrivePath, False
MapDrive = True
MsgBox "Successfully Created the Drive!"
Set objNetwork = Nothing
End Function
Code for MappedDrive
Public Function GetMappedDrives() As Variant
' Returns a 2-D array of (1) drive letters and (2) network paths of all mapped drives on the users machine
Dim objFSO As Object
Dim objDrive As Object
Dim arrMappedDrives() As Variant
Dim i As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
ReDim arrMappedDrives(1 To 2, 1 To 1)
For i = Asc("A") To Asc("Z")
If objFSO.DriveExists(Chr(i)) Then
Set objDrive = objFSO.GetDrive(Chr(i))
If Not IsEmpty(arrMappedDrives(1, UBound(arrMappedDrives, 2))) Then
ReDim Preserve arrMappedDrives(1 To 2, 1 To UBound(arrMappedDrives, 2) + 1)
End If
arrMappedDrives(1, UBound(arrMappedDrives, 2)) = Chr(i) ' Could also use objDrive.DriveLetter...
arrMappedDrives(2, UBound(arrMappedDrives, 2)) = objDrive.ShareName
End If
Next i
GetMappedDrives = arrMappedDrives
Set objDrive = Nothing
Set objFSO = Nothing
End Function
Public Function IsAlreadyMapped(strPath As String) As String
' Tests if a given network path is already mapped on the users machine
' (Returns corresponding drive letter or ZLS if not found)
Dim strMappedDrives() As Variant
Dim i As Long
strMappedDrives = GetMappedDrives
For i = LBound(strMappedDrives, 2) To UBound(strMappedDrives, 2)
If LCase(strMappedDrives(2, i)) Like LCase(strPath) Then
IsAlreadyMapped = strMappedDrives(1, i)
Exit For
End If
Next i
Set objNetwork = Nothing
End Function
Add Reference
Sub AddReference()
'Macro purpose: To add a reference to the project using the GUID for the
'reference library
Dim strGUID As String, theRef As Variant, i As Long
'Update the GUID you need below.
strGUID = "{420B2830-E718-11CF-893D-00A0C9054228}"
'Set to continue in case of error
On Error Resume Next
'Remove any missing references
For i = ThisWorkbook.VBProject.References.Count To 1 Step -1
Set theRef = ThisWorkbook.VBProject.References.Item(i)
If theRef.isbroken = True Then
ThisWorkbook.VBProject.References.Remove theRef
End If
Next i
'Clear any errors so that error trapping for GUID additions can be evaluated
Err.Clear
'Add the reference
ThisWorkbook.VBProject.References.AddFromGuid _
GUID:=strGUID, Major:=1, Minor:=0
'If an error was encountered, inform the user
Select Case Err.Number
Case Is = 32813
'Reference already in use. No action necessary
Case Is = vbNullString
'Reference added without issue
Case Else
'An unknown error was encountered, so alert the user
MsgBox "A problem was encountered trying to" & vbNewLine _
& "add or remove a reference in this file" & vbNewLine & "Please check the " _
& "references in your VBA project!", vbCritical + vbOKOnly, "Error!"
End Select
On Error GoTo 0
End Sub
Procedure imgClicked is calling function AvailableDriveLetter multiple times. Remember that the function has to execute each time you refer to it.
I ran imgClicked (assuming that's the procedure you start with) and I was told, twice, "Next available letter = Z" and "Hello" and then it crashed Excel (perhaps getting stuck in a loop of creating FileSystem objects to look for an available drive letter?)
Try assigning AvailableDriveLetter to a variable (string) at the beginning of the procedure and referring to the variable each time you need the value, and see if you still have the issue.
(Remember to save before execution -- I get frustrated when troubleshooting "application hanging" issues because I keep forgetting to save my changes and then lose them on the crash!)
If this doesn't work, add a breakpoint (F9) on the End Function line after your "Hello" box and see if the code stops there. (I have trouble believing the MsgBox or End Function are the culprit.) If not, which procedure runs after that?
One more thing whether the issue is resolved or not:
Add Option Explicit at the very beginning of your module and then Compile the project and fix your missing variable declaration(s).
This is recommended whenever troubleshooting an issue as a means to eliminate variable declaration issues as a possible cause.

Better presentation of Results

As a part of a database that i am developing i have a function that i developed in Access 2010 . on presenting it to my Superiors i was asked to enhance the presentation or Display. i am just hoping someone can Point me the right direction..
so basically i am inserting some values from one table to the other. but i first run Loops to determine which field names match and copy from the Import table only those fields which match for the target table. so far it works perfectly. no Problems. i am displaying the matching field names in a msg box. the code for this field Name comparision is as follows:
Private Sub Command50_Click()
Dim n As Long
Dim m As Long
Dim Ret_Type As Integer
Dim str As String
Dim stp As String
Dim mystr As String
Dim mysas As String
Dim rs As DAO.Recordset
Dim rs1 As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("MLE_Table")
Set rs1 = CurrentDb.OpenRecordset("tbl_Import")
With rs
For n = 0 To .Fields.Count - 1
str = CurrentDb().TableDefs("MLE_Table").Fields(n).Name
With rs1
For m = 0 To .Fields.Count - 1
stp = CurrentDb().TableDefs("tbl_Import").Fields(m).Name
Debug.Print stp
If str = stp Then
mystr = mystr & str & ", "
fnd = True
Exit For
End If
Next m
If Not fnd Then mysas = mysas & str & vbCrLf
fnd = False
End With
Next n
.Close
End With
Ret_Type = MsgBox("The Following Fields could not be found in your upload !!" & vbCrLf & mysas, vbOKOnly + vbExclamation, " MISSING DATA")
End Sub
now what my colleagues want is that this msg box is not sufficient.. they want a more detailed Display. maybe a form or a text file or something so that the user has a more clear Picture.
the Suggestion was to Show up all the fields of the target table and then Show the fields that matched as green or maybe a tick or checkmark.
i am sure this cannot be done in a msgbox. i know it sounds elegant and i am not sure it can be done. some colleagues say it can be.
can somebody Point me in the right direction or some Suggestion please. i am not experianced enough in Access, so this would be a learning experiance..
thanks in advance..
What I like to do when I want to show text or data that doesn't fit into a MsgBox (or isn't suitable), is to paste it to a new Notepad window:
Shell "notepad", vbNormalFocus
ClipBoard_SetData strText ' google this function
SendKeys "^V", True
Or if it's tabular data, I open Excel and write it to a new sheet.
Starting a separate application has the additional advantage that users can easily save the data, if necessary.

Write Conflict error in access even after a requery on the main form

I've done a ton of research on this topic. I've tried every plausible solution under the internet's sun. Maybe I'm not thinking about this logically since I've been trying to figure out a solution for this for a week. After an actual change to the data and a save from the user I get the write conflict error message "Save Change, Copy to Clipboard, Drop Changes" this random little nuisance is becoming a bigger headache than it's worth.
Just for refrence my main form is called frmCNSUpdates which on a button press opens the subform frmContactInfo
What happens is after a user changes data on this subform and clicks the save button, then closes the subform and returns to the main form then proceeds to move away from the record that has been changed in the subform, saves it from the mainform, add it from the mainform, or even close out of the form I get the write conflict error. I have tried refreshing the parent form and the subform, and do a sql injection update instead of a record set, I have even tried just suppressing the error but I fear I'm putting my solutions in the wrong place. Here is the code for the save button on the subform:
Private Sub cmdSave_Click()
On Error GoTo Err_cmdSave_Click
SaveRecord
Exit_cmdSave_Click:
Exit Sub
Err_cmdSave_Click:
MsgBox Err.Description
Resume Exit_cmdSave_Click
End Sub
Private Sub SaveRecord()
On Error GoTo Err_SaveRecord
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim intRow As Integer
Dim varItem As Variant
Dim strSQL As String
DoCmd.Hourglass True
strSQL = "select * from tblConstructionUpdates where [ProjectNo] =" & Forms![frmCNSUpdates]!ProjectNo
Set db = CurrentDb
Set rst = db.OpenRecordset(strSQL, dbOpenDynaset)
rst.Edit
'rst("ProjectNo") = Me.txtID
'rst("ContractNo") = Me.txtContractNo
rst("EstimatedCompletionDate") = Me.EstimatedCompletionDate
rst("PercentComplete") = Me.txtPercentComplete
rst("SupervisorFirstName") = Me.txtSupervisorFirstName
rst("SupervisorLastName") = Me.txtSupervisorLastName
rst("SupervisorOfficePhoneNumber") = Me.txtSupOfficePhone
rst("SupervisorMobilPhoneNumber") = Me.txtSupMobilPhone
rst("ResidentFirstName") = Me.txtResidentFirstName
rst("ResidentLastName") = Me.txtResidentLastName
rst("ResidentOfficePhoneNumber") = Me.txtResOffice
rst("TelephoneNo") = Me.txtResMobil
rst("ResidentHomePhoneNumber") = Me.txtResHome
rst("ConsultantFirstName") = Me.txtConsultantFirstName
rst("ConsultantLastName") = Me.txtConsultantLastName
rst("ConsultantOfficePhoneNumber") = Me.txtConOffice
rst("ConsultantMobilPhoneNumber") = Me.txtConMobil
rst("ConsultantHomePhoneNumber") = Me.txtConHome
rst("Contractor") = Me.txtGenContractor
rst("GeneralOfficePhoneNumber") = Me.txtGenOfficePhone
rst("GeneralMobilPhoneNumber") = Me.txtGenMobilPhone
rst("GeneralHomePhoneNumber") = Me.txtGenHomePhone
rst("ContractorRep1Name") = Me.cboRep1
rst("ContractorRep1OfficePhone") = Me.txtOffice
rst("ContractorRep1MobilPhone") = Me.txtMobil
rst("ContractorRep1HomePhone") = Me.txtHome
rst("ContractorRep2Name") = Me.cboRep2
rst("ContractorRep2OfficePhone") = Me.txtOffice2
rst("ContractorRep2MobilPhone") = Me.txtMobil2
rst("ContractorRep2HomePhone") = Me.txtHome2
rst("TrafficControlCompanyName") = Me.cboTrafficName
rst("TrafficControlContactName") = Me.txtContact
rst("TrafficControlPhoneNumber") = Me.txtTrafficPhone
rst("ElectricalContractor") = Me.txtContractor
rst("ElectricalPhoneNumber") = Me.txt24hrElecPhone
rst("StateRep") = Me.txtStateRep
rst("StateSen") = Me.txtStateSen
rst.Update
blnChangeMade = False
rst.Close
LoadScreen
MsgBox "The record has been saved.", vbOKOnly, "Save Complete"
Exit_SaveRecord:
DoCmd.Hourglass False
Exit Sub
Err_SaveRecord:
LogErrorDAO Err.Description, CStr(Err.Number), Application.CurrentObjectName, _
"SaveRecord"
Resume Exit_SaveRecord
End Sub
Change all the rst("XXXX") to rst![XXXX] = me.etc , or do it like:
with rst
.edit
![XXX] = me.XXX
![AAA] = me.AAA
...
![something] = me.something
.update
end with
That's a start. (Note that the [] are actually only needed in cases of spaces.)