Better presentation of Results - vba

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.

Related

MS-Access - MailMerge specific record from a form

I am creating an Access 2019 database for small family business (dog breeding) so I setup some tables containing all details on the dogs and the owners. Just to give an idea (simplistic description of the situation):
Dogs
Name
Birth
Microchip
Etc…
Owners
Name
Address
Etc…
I was now trying to create a "Contract composer" for when we sell the dogs. So I made a new table "Contract" and a related form
Contract
Seller ->linked to Owners table
Buyer ->linked to Owners table
Dog ->linked to Dogs table
Price
And made a query to pull all relevant information from the related tables so that I can have
ContractQuery
Seller!Name
Seller!Address
Buyer!Name
Buyer!Address
Dog!Name
Dog!Birthdate
Dog!Microchip
Contract!Price
Everything so far is working perfectly fine.
Now I need to convert the ContractQuery fields in a form of "human readable" contract. I think the best way to do so is the MailMerge to a specific Word document, and I've already setup one. My problem is: how can I set a button into the Contract form so that the "contract.doc" is populated with the specific record I'm seeing now in the form?
I had made some researches and the most relevant information I've found is this
https://www.access-programmers.co.uk/forums/threads/run-mail-merge-from-vba.158126/
and this https://www.tek-tips.com/faqs.cfm?fid=3237
But they are related to old MS-Access so when I tried to apply it I had errors all around. Unluckily my VBA knowledge is far from being proficient and I was not able to make it work.
Can anyone help me, or address me to a solution?
Thanks in advance for any advice
OK I got it working thanks to Kostas K, pointing me in the fight direction. This is my final code, it might need some cleanup and tweaking (for example, the loop within the resulst is now redundant as I only have one result), but it is working :)
The solution is based on this post, should anyone need please have a look at it as reference for the template docx etc
Generating completed PDF forms using word docs and ms access
Option Explicit
Private Sub cmdMergeIt_Click()
On Error GoTo Trap
' **** defining project path as string to make this portable
Dim CurPath As String
CurPath = CurrentProject.path & "\"
' MsgBox (CurPath) 'debug
Dim TEMPLATE_PATH As String
TEMPLATE_PATH = CurPath & "Contratto.dotx"
Dim wApp As Word.Application
Dim wDoc As Word.Document
Dim rs As DAO.Recordset
Dim idx As Long
' *** intercepting the contract ID field from the launching form
Dim checkID As String
checkID = ID.Value
'MsgBox (checkID) 'debug
' **** defining a SQL query on my Access query
Dim strSQL As String
strSQL = "Select * from qContratto where ID =" & checkID & ""
' MsgBox (strSQL) 'debug
Set wApp = New Word.Application
wApp.Visible = False
' ***** changed the OpenRecordset to call my strSQL query insetad than reading the whole Access query
Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)
If rs.EOF Then GoTo Leave
With rs
.MoveLast
.MoveFirst
End With
For idx = 1 To rs.RecordCount
Set wDoc = wApp.Documents.Add(TEMPLATE_PATH)
With wDoc
.Bookmarks("Prezzo").Range.Text = Nz(rs!Prezzo, vbNullString)
.Bookmarks("Venditore").Range.Text = Nz(rs!Venditore, vbNullString)
.Bookmarks("Acquirente").Range.Text = Nz(rs!Acquirente, vbNullString)
.Bookmarks("Cessione").Range.Text = Nz(rs!Cessione, vbNullString)
.Bookmarks("NomeCane").Range.Text = Nz(rs!NomeCane, vbNullString)
.Bookmarks("Riproduzione").Range.Text = Nz(rs!Riproduzione, vbNullString)
.Bookmarks("Sesso").Range.Text = Nz(rs!Sesso, vbNullString)
.ExportAsFixedFormat CurPath & rs!Acquirente & ".pdf", wdExportFormatPDF, False, wdExportOptimizeForOnScreen
.Close wdDoNotSaveChanges
' in the ExportAsFixedFormat here above called one of the SQL query values to make a unique and distinctive name. Also please note use of CurPath for portability
End With
Set wDoc = Nothing
rs.MoveNext
Next
Leave:
On Error Resume Next
If Not rs Is Nothing Then rs.Close
If Not wDoc Is Nothing Then wDoc.Close wdDoNotSaveChanges
If Not wApp Is Nothing Then wApp.Quit wdDoNotSaveChanges
On Error GoTo 0
Exit Sub
Trap:
MsgBox Err.Description, vbCritical
Resume Leave
End Sub

Showing a database extracted array in a message box

I need to show a group of records from an Access database in a message box or any form that is only for view without adding sheets to the workbook.
The information is divided into 9 fields, and are up to 15 rows per entry. I've tried several forms of showing the information, but they don't work, or add another sheet to the workbook. The environment where the workbook is used is only for data and printing capture. Apparently, I already have covered the database connection, the only issue is the display of the information.
Private Sub Srch_Click()
Dim A As Object, rs As Object, sSQL As String, CN As String, Arr As Variant, FL As Long, txt As String, i As Long
FL = tbFolio.Value - 1
Set A = CreateObject("ADODB.Connection")
CN = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=S:\Common\Quality\RASTREABILIDAD\MAIN PROJECT\PROYECTO KOREANO MX.accdb;"
sSQL = "SELECT * FROM Trazabilidad WHERE Folio = " & (FL) & ";"
A.Open CN
Set rs = A.Execute(sSQL)
Arr = rs.GetRows
MsgBox Arr, vbOKOnly, Trazabilidad
rs.Close
A.Close
Unload Me
End Sub
In the debugging, the highlighted section of the code is this:
MsgBox Arr, vbOKOnly, Trazabilidad
The error message is
"Error '13': Type mismatch"
I've been breaking my mind over how to do it, and I would appreciate any help.
Thanks in advance.
#Alex K. is right saying a good solution is to loop over the recordset.
But you may also find useful to copy the data to a sheet and then work over it using this code:
mysheet.Range("A2").CopyFromRecordset rs

Automatisation of macros

I have a Word document and I want to do following with it:
Select some part of it when I open a Word doc (let´s say from page 40 to 45).
Reverse text in selected area.
Get text reversed again as it was before opening, when I close document.
I have this code, that reverses the text:
Sub ReverseSelectedWords()
Dim i As Integer
Dim oWords As Words
Dim oWord As Range
Set oWords = Selection.Range.Words
For i = 1 To oWords.Count Step 1
Set oWord = oWords(i)
Do While oWord.Characters.Last.Text = " "
Call oWord.MoveEnd(WdUnits.wdCharacter, -1)
Loop
Debug.Print "'" & oWord.Text & "'"
oWord.Text = StrReverse(oWord.Text)
Next i
End Sub
For what you've described as being your goal, it would make far more sense to apply a password for opening to the document and provide only the intended reader(s) with that password. No code required.

How to properly from VBA connection from Excel sheet to another Excel sheet?

I currently have 2 separate Excel worksheets. One is data entry and another is display.
The display uses VBA to connect to data entry to obtain data. Normally, it functions well enough. However I'm required to have the 2 worksheets in separate windows, meaning both can be displayed at the same time in separate windows, in the same screen.
The issue in this scenario is that when I click Execute in display to begin SQL query, the display window opens another data entry worksheet (read-only) and reads that instead of the one I opened initially. Is this issue due to my connection string or my ADODB.Recordset has issues?
Here is the sub which contains the connection string and ADODB.Recordset.
Edit: Full code is included to provide full context for those who need it.
Public Sub QueryWorksheet(szSQL As String, rgStart As Range, wbWorkBook As String, AB As String)
Dim rsData As ADODB.Recordset
Dim szConnect As String
On Error GoTo ErrHandler
If AB = "1st" Then
wbWorkBook = ThisWorkbook.Sheets("Inner Workings").Range("B9").Text
End If
Application.StatusBar = "Retrieving data ....."
'Set up the connection string to excel - thisworkbook
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & wbWorkBook & ";" & _
"Extended Properties=Excel 8.0;"
Set rsData = New ADODB.Recordset
'Run the query as adCmdText
rsData.Open szSQL, szConnect, adOpenForwardOnly, adLockReadOnly, adCmdText
'Check if data is returned
If Not rsData.EOF Then
'if the recordset contains data put them on the worksheet
rgStart.CopyFromRecordset rsData
Else
End If
'Close connection
rsData.Close
'Clean up and get out
Set rsData = Nothing
Application.StatusBar = False
Exit Sub
ErrHandler:
'an error occured in the SQL-statement
MsgBox "Your query could not be executed, the SQL-statement is incorrect."
Set rsData = Nothing
Application.StatusBar = False
End Sub
Sub process()
Call clear
Call testsql("1st") ' populate 1st Summary
Call testsql("2nd") ' find Date+Time
Call testsql("3rd") ' arrange record by newest
Call testsql("4th") ' show final results
End Sub
Sub testsql(AB As String)
Dim rgPlaceOutput As Range 'first cell for the output of the query
Dim stSQLstring As String 'text of the cell containing the SQL statement
Dim rg As String, SQL As String
If AB = "1st" Then
stSQLstring = ThisWorkbook.Sheets("Inner Workings").Range("B2").Text
Set rgPlaceOutput = ThisWorkbook.Sheets("1st Summary").Range("A2")
End If
If AB = "2nd" Then
stSQLstring = ThisWorkbook.Sheets("Inner Workings").Range("B3").Text
Set rgPlaceOutput = ThisWorkbook.Sheets("2nd Summary").Range("A2")
End If
If AB = "3rd" Then
stSQLstring = ThisWorkbook.Sheets("Inner Workings").Range("B4").Text
Set rgPlaceOutput = ThisWorkbook.Sheets("3rd Summary").Range("A2")
End If
If AB = "4th" Then
stSQLstring = ThisWorkbook.Sheets("Inner Workings").Range("B5").Text
Set rgPlaceOutput = ThisWorkbook.Sheets("Final Summary").Range("A5")
End If
QueryWorksheet stSQLstring, rgPlaceOutput, ThisWorkbook.FullName, AB
End Sub
Sub clear()
ActiveWorkbook.Sheets("1st Summary").Range("A2:BR5000").Value = Empty
ActiveWorkbook.Sheets("2nd Summary").Range("A2:BR5000").Value = Empty
ActiveWorkbook.Sheets("3rd Summary").Range("A2:BR5000").Value = Empty
ActiveWorkbook.Sheets("Final Summary").Range("A5:BR5000").Value = Empty
End Sub
Also another thing I noticed. Depending on which file I open first, it can result in both files creating a read-only copy when I click Execute. If I open Display first then Entry form, both in different instances of Excel, it will create read-only copies of both files.
If I open Entry form first, then Display in again, different instances of Excel, only the read-only copy of Display will appear.
The only time a read-only does not appear is when both files are in a single instance of Excel, which is not what I want.
Edit2:
For more info, here is the SQL I used (4 total)
SQL1 - select * from EntryTable
SQL2 - select A.*,[Date + Time] from Summary1 A left join (select [Die No], max (Date + Time) as [Date + Time] from Summary1 group by [Die No]) B on A.[Die No] = B.[Die No]
SQL3 - select * from Summary2 where [Date + Time] = Date + Time
SQL4 - select Project_No, Die_No, Description, Repair_Details, Status from Summary3
Workbook name in cell B9 = V:\Die Maintenance System v2\Die Maintenance Menu.xlsx
Update: My colleague has tested the system on her PC and tested no problems. I've been told its most likely my Excel settings. But for the life of me, I can't figure out what is causing it. What type of setting is used to prevent the read-only file from appearing?
Edit: I can see that this post has gone on too long. I decided to continue this on a new thread right here.
So i would do it with the Workbook.Open() Method.
Sub Example()
Dim wb as Workbook
Dim path as String
path = "C:\Users\User\Desktop\1.xlsx"
set wb = Workbook.Open(path)
End Sub
Now you can use wb to execute every vba function. Then there a options to check if a workbook is already opened, look here. I dont think you can do that with adodb.
I tired using ACE and it worked just fine. It didn't open a new file.
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & _
wbWorkBook & "';" & _
"Extended Properties='Excel 12.0;HDR=Yes;IMEX=1';"
Your SQL FROM clause is referencing a different named range. Please post your SQL text. It must be qualified to correct Named Range or sheet name.
SELECT Project No, Die No, Description, Repair Details, Status
FROM DATA1 <- correct this to qualified named range or sheet name
like
FROM [Entry Form$] 'or
FROM [Named Range] <- this can be found in Formulas | Name Manager
Edit:
I am not sure about your "1st" source workbook's location so let us try to insert the line I commented below
wbWorkBook = ThisWorkbook.Sheets("Inner Workings").Range("B9").Text
wbWorkBook = Workbooks(wbWorkbook).FullName '<- add this line
If it still does not work, please post your SQL AND Workbook name in cell B9.
Edit 2:
What is the result if you change the FROM clause like:
select * from [EntryTable$]
Edit 3: Do you have password? if so, try to disable it first to isolate the problem in read only.

Update MS Access Marquee text on each loop

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!