I hi there guys I've tried a few things. Looked at this answer:Record is too large MS Access runtime error.
Tried memo fields, compact and repairs the database file and nothing has worked. As far as i can see everything in the table is okay according to this: https://support.office.com/en-us/article/access-specifications-0cf3c66f-9cf2-4e32-9568-98c1025bb47c?ocmsassetID=HA010341462&CorrelationId=49a62e69-cf72-400b-aad8-302c3b9d6ff0&ui=en-US&rs=en-US&ad=US.
So the table has 87 columns(alpha-numerical), some columns have no characters other have 200, which i cant breakdown sadly. There are some records which have more than 2000 characters however, the one in question only has 1908 unless which i suspect might be the case that it has something to do with the french characters(accents etc.). Thank you very much for any help. I'll try and reply as quickly as possible.
The section where the code breaks is:
Set rs = CurrentDb.OpenRecordset("Select " & TableName & ".* FROM " & TableName & ";")
If Not (rs.EOF And rs.BOF) Then
rs.MoveFirst
Do Until rs.EOF = True
DirName = rs!DEARNAME
RegNumbers = rs!REG
Call SurnameFinder2(DirName, RegNumbers)
rs.Edit
rs!RegSur = DirID
rs.Update
rs.MoveNext
Loop
Else
MsgBox ("Import Failed")
Exit Sub
End If
It calls this function:
Public Function SurnameFinder2(DirectorName, RegNo) As String
Dim SQLInsertQuery
Dim DirectorName2 As String
Dim Regno3 As String
Dim Lngstr As Long
Dim lSpace As Long
Dim StrName As String
Dim Space As Long
StrName = Trim(DirectorName)
Lngstr = Len(StrName)
Testing = InStrRev(StrName, " ", , vbTextCompare)
Space = Lngstr - Testing
Surname = Trim(Right(StrName, Space))
DirID = RegNo & Surname
End Function
Related
I want to be able to view the contents of my access database's laccdb file through VBA so I can use it to alert users (through a button) who else is in the database.
I specifically don't want to use a 3rd Party tool. I have tried using:
Set ts = fso.OpenTextFile(strFile, ForReading)
strContents = ts.ReadAll
This works fine if only 1 user is in the database. But for multiple users it gets confused by the presumably non-ASCII characters and goes into this kind of thing after one entry:
Does anyone have any suggestions? It's fine if I just open the file in Notepad++...
Code eventually used is as follows (I didn't need the title and have removed some code not being used):
Sub ShowUserRosterMultipleUsers()
Dim cn As New ADODB.Connection, rs As New ADODB.Recordset
cn.Provider = "Microsoft.ACE.OLEDB.12.0"
cn.Open "Data Source=" & CurrentDb.Name
Set rs = cn.OpenSchema(adSchemaProviderSpecific, , "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
While Not rs.EOF
Debug.Print rs.Fields(0)
rs.MoveNext
Wend
End Sub
I found this which should help, it's not actually reading the ldb file, but it has the info that you need (Source: https://support.microsoft.com/en-us/kb/198755):
Sub ShowUserRosterMultipleUsers()
Dim cn As New ADODB.Connection
Dim cn2 As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim i, j As Long
cn.Provider = "Microsoft.Jet.OLEDB.4.0"
cn.Open "Data Source=c:\Northwind.mdb"
cn2.Open "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=c:\Northwind.mdb"
' The user roster is exposed as a provider-specific schema rowset
' in the Jet 4 OLE DB provider. You have to use a GUID to
' reference the schema, as provider-specific schemas are not
' listed in ADO's type library for schema rowsets
Set rs = cn.OpenSchema(adSchemaProviderSpecific, _
, "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
'Output the list of all users in the current database.
Debug.Print rs.Fields(0).Name, "", rs.Fields(1).Name, _
"", rs.Fields(2).Name, rs.Fields(3).Name
While Not rs.EOF
Debug.Print rs.Fields(0), rs.Fields(1), _
rs.Fields(2), rs.Fields(3)
rs.MoveNext
Wend
End Sub
I put together some code to read through the lock file and output a message listing users currently using the system.
Trying to read the whole file in at once seems to result in VBA treating the string as Unicode in the same way notepad does so I read in character by character and filter out non printing characters.
Sub TestOpenLaccdb()
Dim stm As TextStream, fso As FileSystemObject, strLine As String, strChar As String, strArr() As String, nArr As Long, nArrMax As Long, nArrMin As Long
Dim strFilename As String, strMessage As String
strFilename = CurrentProject.FullName
strFilename = Left(strFilename, InStrRev(strFilename, ".")) & "laccdb"
Set fso = New FileSystemObject
Set stm = fso.OpenTextFile(strFilename, ForReading, False, TristateFalse) 'open the file as a textstream using the filesystem object (add ref to Microsoft Scripting Runtime)
While Not stm.AtEndOfStream 'Read through the file one character at a time
strChar = stm.Read(1)
If Asc(strChar) > 13 And Asc(strChar) < 127 Then 'Filter out the nulls and other non printing characters
strLine = strLine & strChar
End If
Wend
strMessage = "Users Logged In: " & vbCrLf
'Debug.Print strLine
strArr = Split(strLine, "Admin", , vbTextCompare) 'Because everyone logs in as admin user split using the string "Admin"
nArrMax = UBound(strArr)
nArrMin = LBound(strArr)
For nArr = nArrMin To nArrMax 'Loop through all machine numbers in lock file
strArr(nArr) = Trim(strArr(nArr)) 'Strip leading and trailing spaces
If Len(strArr(nArr)) > 1 Then 'skip blank value at end
'Because I log when a user opens the database with username and machine name I can look it up in the event log
strMessage = strMessage & DLast("EventDescription", "tblEventLog", "[EventDescription] like ""*" & strArr(nArr) & "*""") & vbCrLf
End If
Next
MsgBox strMessage 'let the user know who is logged in
stm.Close
Set stm = Nothing
Set fso = Nothing
End Sub
I am more or less a rookie in using VBA in Access and hope I'm not asking something stupid. Is it possible through VBA to run and save several queries that begin by the same word?
I have an Access file with multiple tables and queries, which are identified by an initial 3 digit code, eg 100QueryName. I am trying to only run the queries that begin with "901".
Hope someone can help me out.
Best regards
Jorge
The following code is a start (depending on what type of queries)...
Create a module and paste the following code. Then execute subroutine 'Test_it'
Option Compare Database
Option Explicit
Sub Test_it()
Dim strPrefix As String
' Ask user for query prefix
strPrefix = InputBox("Please enter query prefix", "Qry Prefix")
MsgBox "Executed " & Run_Queries(strPrefix) & " queries.", vbOKOnly, "COunt of Queries"
End Sub
Function Run_Queries(strPrefix As String) As Integer
Dim dbs As DAO.Database
Dim qdf As DAO.QueryDef
Dim strQryName As String
Dim iQryCt As Integer
Dim iQryRan As Integer
Dim i As Integer
Set dbs = CurrentDb
iQryCt = dbs.QueryDefs.Count
i = Len(strPrefix)
iQryRan = 0
For Each qdf In dbs.QueryDefs
strQryName = qdf.Name
Debug.Print strQryName
If LCase(left(strQryName, i)) = LCase(strPrefix) Then
Debug.Print " ** Run: " & strQryName & vbTab & qdf.Type
If qdf.Type = 0 Then ' Select query
' Open this query to view results
DoCmd.OpenQuery strQryName
ElseIf qdf.Type = 48 Then ' Update query
dbs.Execute strQryName
End If
iQryRan = iQryRan + 1
Else
End If
Next qdf
Set qdf = Nothing
Set dbs = Nothing
Run_Queries = iQryRan
End Function
Hello Fellow programmers,
I am absolutely desperate as I can not figure out how to solve (maybe) simple problem. I have two tables. First one [Files] with two fields: [FName](file name) and [FPath](file path) and second one [Reports] with [DocNo] [Title]...blah blah...
FName string consists of [DocNo] [Title](but the whole title string is not as a file path)
Example:
[DocNo] Smith/RT/2000/001
[Title] Assessment of modified aluminothermic welds in 68kg/m head hardened rail for BHP Iron Ore Pty Ltd
[FName] SmithRT2000001 Assessment of modified aluminothermic welds .pdf
I have a form which has a search list on it. this list brings up records which are in [Reports]. By double clicking on a specific record, it fires up doubleclick event. in the Event I get the value of DocNo and Title and search into Files table for the Fname to match. But surprisingly it doesn't return anything when I put the sql search or even in the design mode for query?
BUT the funny thing is that when I hard code to find the record, both of ways will find it. how is that?
Here is the VBA to check out:
Private Sub SearchResults_DblClick(Cancel As Integer)
'Initializing the string variables
Dim strSQL As String
Dim strFileName As String
Dim strTitle As String
Dim DocumentNo As String
Dim titleLeng As Integer
DocumentNo = Me.SearchResults.Column(0)
DocumentNo = Replace(DocumentNo, "/", "")
strTitle = Me.SearchResults.Column(1)
Debug.Print (DocumentNo)
SrchText = DocumentNo
SearchResults.RowSourceType = "Table/Query"
SearchResults.RowSource = "QRY_OpenFile"
Debug.Print (strTitle)
strTitle = Left(strTitle, 10)
SrchText = strTitle
Debug.Print (SrchText)
SearchResults.RowSource = "QRY_OpenFile"
Dim rst As Recordset
Dim db As DAO.Database
Set db = CurrentDb()
strSQL = "SELECT Files.FName FROM Files WHERE Files.FName Like " * " & strTitle & " * ";"
Debug.Print (strSQL)
Set rst = db.OpenRecordset(strSQL, dbOpenDynaset)
Application.FollowHyperlink strFileName, , True, False, , , "John Smith"
I have tried every variation in SQL string, changing outer " " to ' ' does not work. But if I change strTitle with "Assessment" string or "SmithRT2000001" it will finds it. DO not know why?
This does not work in the query design window where you put criteria:
Like "* & Forms![Search For Reports]![SrchText] & *"
But as soon as I change it something static it will work. Going crazy!!
Can you guide me as what to do or how to achieve my goal which is opening the file in FILE table??
Okay, After testing 3 different approaches at the end one of them gave a good response and what I wanted. I changed the "like" command in my query to:
Like "*" & [Forms]![Search For Reports]![SrchText] & "*"
and suddenly it worked. Also I found out that SQL Select query doesn't work from VBA specially with Double click event.
Here is the final code:
Private Sub SearchResults_DblClick(Cancel As Integer)
'Initializing the string variables
Dim strTitle As String
Dim DocumentNo As String
DocumentNo = Me.SearchResults.Column(0)
DocumentNo = Replace(DocumentNo, "/", "")
strTitle = Me.SearchResults.Column(1)
strTitle = Replace(strTitle, "'", "''")
SrchText.Value = DocumentNo
SearchResults.RowSourceType = "Table/Query"
SearchResults.RowSource = "QRY_OpenFile"
End Sub
I could not get the path and name from the list, to put them together and fire up a hyperlink to Acrobat...What I had to do was sending an event via a button to get the values from the list. For some reason after SearchResults.RowSource = "QRY_OpenFile" the list.Column(index) was returning null.
Anyway thanks for reading my question and thinking about it.
Did that code actually run? You have the SQL string in a tangle:
''You need to watch out for quotes in the string, so
strTitle = Replace(strtile, "'", "''")
strSQL = "SELECT Files.FName FROM Files WHERE Files.FName Like '*" _
& strTitle & "*';"
The point of this line:
Debug.Print (strSQL)
Is to get an SQL string to test in the query design window. Use it.
I am trying to make a form which searches for the value inside all of the tables in the database (there are more than 1 table). The result will be displayed as the name of the table which this appears in. If someone can help me that will be nice.
In short, I have a form with a textbox and button. I enter the search string (for example 183939) and click on the button. It searches the value (183939) inside all the fields in the tables in the database, and if the value is found, then it displays the name of the table that it appears in. Thanks for the help.
I think this is a bad idea because it could take a very long time, and provide confusing results due to also searching system tables... but the following function will return an array of all table names containing the search term or nothing if it wasn't found. Calling example is such: theTables = containingTable("hello") where theTables is a variant. A limitation is that this will fail for multi-valued fields.
Function containingTables(term As String)
Dim db As Database
Dim tds As TableDefs
Dim td As TableDef
Set db = CurrentDb
Set tds = db.TableDefs
For Each td In tds
For Each f In td.Fields
On Error Resume Next
If DCount("[" & f.Name & "]", "[" & td.Name & "]", "[" & f.Name & "] LIKE '*" & term & "*'") Then
If Err.Number <> 0 Then
Debug.Print Err.Number, Err.Description
Err.Clear
On Error GoTo 0
Else
containingTables = containingTables & td.Name & ","
Exit For
End If
End If
Next
Next
Set tds = Nothing
Set db = Nothing
'Alternate Version
if Len(containgingTables) then containingTables = Left(containingTables, Len(containingTables) - 1)
'Original Version
'if Len(containgingTables) then containingTables = Split(Left(containingTables, Len(containingTables) - 1), ",")
End Function
To display the results with the alternate version, just use: Msgbox(containingTables(searchTerm)) where searchTerm is whatever you are searching.
Me as well i don't know why you would want to do something like that...
I think the solution posted by Daniel Cook is correct, i just took a slightly different approach. Do you need to match the exact value like I do? Anyway, here's my code:
Function searchTables(term as String)
Dim T As TableDef
Dim Rs As Recordset
Dim Result() As String
Dim Counter
Counter = 0
For Each T In CurrentDb.TableDefs
If (Left(T.Name, 4) <> "USys") And (T.Attributes = 0) Then
Set Rs = T.OpenRecordset
While Not Rs.EOF
For Each Field In Rs.Fields
If Rs(Field.Name) = term Then
Counter = Counter + 1
ReDim Preserve Result(Counter)
Result(Counter) = T.Name & "," & Field.Name
End If
Next
Rs.MoveNext
Wend
Rs.Close
End If
Next
If Counter = 0 Then
searchTables = Null
Else
searchTables = Result
End If
End Function
You should filter out duplicated values, in case the function matches multiple times the same filed in the same table.
The following code runs as far as the marked line. Word then shows a file locked for editing/ open read only prompt. I need to be able to edit the document (that is the whole point of the code).
Sorry for incredibly long code block - I felt it was important to show everything so that it was easier to find the problem.
The code is also kind of clunky with the multiple recordsets, if anyone has any better ideas would love to here them.
Option Explicit
Option Compare Database
Sub InputSafetyData()
Dim dbCur As Database
Dim appCur As Word.Application
Dim docCur As Word.Document
Dim dlgCur As FileDialog
Dim rngCcCur As Range
Dim varDlgCur As Variant
Dim strDocName As String
Dim strDocPath As String
Dim strSQL As String
Dim rsIt As DAO.Recordset
Dim rsHc As DAO.Recordset
Dim rsHz As DAO.Recordset
Dim rsPr As DAO.Recordset
Dim strHc As String
Dim strHz As String
Dim strPr As String
Set dbCur = CurrentDb()
Set dlgCur = Application.FileDialog(msoFileDialogFolderPicker)
With dlgCur
.AllowMultiSelect = False
If .Show <> -1 Then End
varDlgCur = .SelectedItems(1)
End With
strDocPath = CStr(varDlgCur) & "\"
strDocName = Dir(strDocPath & "*.docx")
Set appCur = New Word.Application
appCur.Visible = True
Set dlgCur = Nothing
Do While strDocName <> ""
'Runs as far here
Set docCur = appCur.Documents.Open(FileName:=strDocPath & strDocName, ReadOnly:=False, Visible:=False)
If docCur.ReadOnly = False Then
Set rngCcCur = docCur.ContentControls(6).Range
rngCcCur = ""
appCur.ActiveDocument.Tables.Add Range:=rngCcCur, NumRows:=1, NumColumns:=4
With rngCcCur.Tables(0)
If .Style <> "Table Grid" Then
.Style = "Table Grid"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
.Style = "Light Shading"
.AutoFitBehavior wdAutoFitWindow
.Cell(1, 1).Range.InsertAfter "Item"
.Cell(1, 2).Range.InsertAfter "Hazcard"
.Cell(1, 3).Range.InsertAfter "Hazard"
.Cell(1, 4).Range.InsertAfter "Precaution"
'select distinct item based on filename
strSQL = "Select Distinct Item From IHR where filename is"
strSQL = strSQL & strDocName
Set rsIt = dbCur.OpenRecordset(strSQL, dbOpenDynaset)
If Not (rsIt.BOF And rsIt.EOF) = True Then
While Not rsIt.EOF
.Rows.Add
.Cell(rsIt.AbsolutePosition + 2, 1).Range.InsertAfter rsIt.Fields(1).Value
'select distinct hazcard based on item
strSQL = "Select Distinct Hazcard From IHR where item is"
strSQL = strSQL & rsIt.Fields(1).Value
Set rsHc = dbCur.OpenRecordset(strSQL, dbOpenDynaset)
If Not (rsHc.BOF And rsHc.EOF) = True Then
While Not rsHc.EOF
strHc = strHc & " " & rsHc.Fields(2).Value
.Cell(rsIt.AbsolutePosition + 2, 2).Range.InsertAfter strHc
rsHc.MoveNext
Wend
End If
rsHc.Close
Set rsHc = Nothing
'select distinct hazard based on item
strSQL = "Select Distinct Hazard From IHR where item is"
strSQL = strSQL & rsIt.Fields(1).Value
Set rsHz = dbCur.OpenRecordset(strSQL, dbOpenDynaset)
If Not (rsHz.BOF And rsHz.EOF) = True Then
While Not rsHz.EOF
strHc = strHz & " " & rsHz.Fields(2).Value
.Cell(rsIt.AbsolutePosition + 2, 3).Range.InsertAfter strHz
rsHz.MoveNext
Wend
End If
rsHz.Close
Set rsHz = Nothing
'select distinct precaution based on item
strSQL = "Select Distinct Precaution From IHR where item is"
strSQL = strSQL & rsIt.Fields(1).Value
Set rsPr = dbCur.OpenRecordset(strSQL, dbOpenDynaset)
If Not (rsPr.BOF And rsPr.EOF) = True Then
While Not rsPr.EOF
strPr = strPr & " " & rsPr.Fields(4).Value
.Cell(rsIt.AbsolutePosition + 2, 4).Range.InsertAfter strPr
rsPr.MoveNext
Wend
End If
rsPr.Close
Set rsPr = Nothing
rsIt.MoveNext
Wend
End If
End With
rsIt.Close
Set rsIt = Nothing
Debug.Print (docCur.Name)
docCur.Save
End If
docCur.Close
Set docCur = Nothing
strDocName = Dir
Loop
Set appCur = Nothing
End Sub
Focus on the immediate problem --- "Cannot open word file for editing".
I created a folder, C:\share\testdocs\, and added Word documents. The code sample below uses a constant for the folder name. I wanted a simple test, so got rid of FileDialog. I also discarded all the recordset code.
I used Visible:=True when opening the Word documents. I didn't understand why you have the Word application visible, but the individual documents not visible. Whatever the logic for that, I chose to make them visible so I could observe the content changes.
I tested this with Access 2007, and it works without errors. If it doesn't work for you, double-check the file system permissions for the current user for both the folder and the target documents.
Public Sub EditWordDocs()
Const cstrFolder As String = "C:\share\testdocs\"
Dim appCur As Word.Application
Dim docCur As Word.Document
Dim strDocName As String
Dim strDocPath As String
Dim strMsg As String
On Error GoTo ErrorHandler
strDocPath = cstrFolder
strDocName = Dir(strDocPath & "*.docx")
Set appCur = New Word.Application
appCur.Visible = True
Do While strDocName <> ""
Debug.Print "strDocName: " & strDocName
Set docCur = appCur.Documents.Open(FileName:=strDocPath & strDocName, _
ReadOnly:=False, Visible:=True)
Debug.Print "FullName: " & docCur.FullName
Debug.Print "ReadOnly: " & docCur.ReadOnly
' add text to the document ... '
docCur.content = docCur.content & vbCrLf & CStr(Now)
docCur.Close SaveChanges:=wdSaveChanges
Set docCur = Nothing
strDocName = Dir
Loop
ExitHere:
On Error Resume Next
appCur.Quit SaveChanges:=wdDoNotSaveChanges
Set appCur = Nothing
On Error GoTo 0
Exit Sub
ErrorHandler:
strMsg = "Error " & Err.Number & " (" & Err.Description _
& ") in procedure EditWordDocs"
MsgBox strMsg
Debug.Print strMsg
GoTo ExitHere
End Sub
Assuming you're able to get past the read-only problem, I think you have more challenges ahead. Your SELECT statements look highly suspicious to me ...
'select distinct item based on filename '
strSQL = "Select Distinct Item From IHR where filename is"
strSQL = strSQL & strDocName
For example, if strDocName contains "temp.docx", strSQL will contain this text ...
Select Distinct Item From IHR where filename istemp.docx
That is not a valid SELECT statement. I think you may need something more like this ...
SELECT DISTINCT [Item] FROM IHR WHERE filename = 'temp.docx'
Item is a reserved word, so I enclosed it in square brackets to avoid confusing the db engine. Use the equality operator (=) instead of "is" for your string comparisons.
It is extremely useful to Debug.Print your strSQL string, so that you may directly examine the completed statement you're asking the db engine to run ... view it instead of relying on your imagination to guess what it looks like. And when it fails, you can copy the Debug.Print output from the Immediate window and paste it into SQL View of a new query for testing.
However, those Access query issues don't matter until you can get past the read-only issue with your Word documents.
To follow up on the issue of visibility vs. read-only, my code opened the Word documents and modified them without throwing errors when I included either or both of these two changes:
appCur.Visible = False
and
Set docCur = appCur.Documents.Open(FileName:=strDocPath & strDocName, _
ReadOnly:=False, Visible:=False)
I had the same problem with a file opened read only. You can try putting in the following code:
appcur.ActiveWindow.View.ReadingLayout = False