I've got a frustrating issue on MS Access 2010 that I would at this stage qualify as a bug. And after having tried all possible workarounds, I am out of ideas and rely on you.
Context
Huge Ms Access 2010 application with 25k lines of VBA and >50 forms. It has a client server architecture with a frontend compiled and an Access backend on the network. It makes connections to a twentish of different databases (Oracle/SQL Server/Sybase IQ).
The problem
Sometimes when I assign an ADODB recordset to a subform, its data isn't shown in bound fields. I've got #Name? everywhere
The data is there. I can debug.print it, I can see it in the Watches browser, I can read or manipulate it while looping on the recordset object with code. It just not appear in the subform.
It can work flawlessly during months, and suddenly one form will start having this issue without any apparent reason (it might happen even on forms that I have not changed). When it happens, it does for all users, so this is really something wrong in the frontend accdb/accde.
The issue is not related to a specific DBMS/Driver. It can happen with Oracle or Sybase data.
I have created my own class abstracting everything related to ADO connections and queries, and use the same technique everywhere. I've got several tenth of forms based on it and most of them works perfectly.
I have this issue in several parts of my application, and especially in a highly complicated form with lots of subforms and code.
On this Main form, a few subforms have the issue, while others don't. And they have the exact same parameters.
The Code
This is how I populate a form's recordset :
Set RST = Nothing
Set RST = New ADODB.Recordset
Set RST = Oracle_CON.QueryRS(SQL)
If Not RST Is Nothing Then
Set RST.ActiveConnection = Nothing
Set Form_the_form_name.Recordset = RST
End If
The code called with Oracle_CON.QueryRS(SQL) is
Public Function QueryRS(ByVal SQL As String, Optional strTitle As String) As ADODB.Recordset
Dim dbQuery As ADODB.Command
Dim Output As ADODB.Recordset
Dim dtTemp As Date
Dim strErrNumber As Long
Dim strErrDesc As String
Dim intSeconds As Long
Dim Param As Variant
If DBcon.state <> adStateOpen Then
Set QueryRS = Nothing
Else
DoCmd.Hourglass True
pLastRows = 0
pLastSQL = SQL
pLastError = ""
pLastSeconds = 0
Set dbQuery = New ADODB.Command
dbQuery.ActiveConnection = DBcon
dbQuery.CommandText = SQL
dbQuery.CommandTimeout = pTimeOut
Set Output = New ADODB.Recordset
LogIt SQL, strTitle
dtTemp = Now
On Error GoTo Query_Error
With Output
.LockType = adLockPessimistic
.CursorType = adUseClient
.CursorLocation = adUseClient
.Open dbQuery
End With
intSeconds = DateDiff("s", dtTemp, Now)
If Output.EOF Then
LogIt "-- " & Format(Now, "hh:nn:ss") & " | Executed in " & intSeconds & " second" & IIf(intSeconds = 1, "", "s") & " | Now rows returned."
Set QueryRS = Nothing
Else
Output.MoveLast
pLastRows = Output.RecordCount
LogIt "-- " & Format(Now, "hh:nn:ss") & " | Executed in " & intSeconds & " second" & IIf(intSeconds = 1, "", "s") & " | " & Output.RecordCount & " row" & IIf(Output.RecordCount = 1, "", "s") & " returned."
Output.MoveFirst
Set QueryRS = Output
End If
End If
Exit_Sub:
pLastSeconds = intSeconds
Set Output = Nothing
Set Parameter = Nothing
Set dbQuery = Nothing
DoCmd.Hourglass False
Exit Function
Query_Error:
intSeconds = DateDiff("s", dtTemp, Now)
strErrNumber = Err.Number
strErrDesc = Err.DESCRIPTION
pLastError = strErrDesc
MsgBox strErrDesc, vbCritical, "Error " & pDSN
LogIt strErrDesc, , "ERROR"
Set QueryRS = Nothing
Resume Exit_Sub
Resume
End Function
Things I tried so far
For the recordsets I tried every possible variation of
.LockType = adLockPessimistic
.CursorType = adUseClient
.CursorLocation = adUseClient
The subforms handling the recordsets have all a Snapshot recordsettype, problem remains if I try dynaset.
Dataentry, Addition, deletion, edits are all disabled. It's pure read-only.
I have a habit of disconnecting the recordsets using RST.ActiveConnection = Nothing so I can manipulate them afterwards, but this doesn't impact the problem either.
It can happens with very simple queries with only one field in the SELECT clause and only one field bound to it on a subform.
Reimporting all objects in a fresh accdb doesn't solve the problem either.
The solution proposed by random_answer_guy worked at first glance, which accreditate the bug hypothesis. Unfortunately my problems reappeared after some (totaly unrelated) changes in the main form. I am back with 4 or 5 subforms not showing data and adding/removing a Load event on all or part of them doesn't make any difference anymore
If you want more information about how weird is this issue, I advise you to read my comment on random_answer_guy's answer.
To conclude
What is extremely frustrating is that I can have 2 different forms with exactly the same properties and same fields, same SQL instruction over the same DB, same recordset management code: One is showing the data and the other doesn't !
When the problem happens, I have no other choice than erasing all objects manipulated and reimporting them from an older version or recreate them from scratch.
If this is not a bug, I am still looking for the proper word to qualify it.
Does anyone ever experienced the issue and has an explanation and/or a workaround to propose ?
I've had this same issue before and simply adding a blank Form_Load event solved the problem. No code needs to be with the Form_Load it just needs to be present.
So nobody could give at this stage a clear answer to the main question :
Why is this bug happens ?
In the meantime I have "elegantly" bypassed the issue by changing the method used for the subforms encountering the bug, from ADO to DAO.
I have created a new method in my ADO abstracting class, that actually use DAO to return a recordset (not logical, but hey...).
The code where I pass data to the form becomes :
Set RST = Nothing
Set RST = Oracle_CON.QueryDAORS(SQL)
If Not RST Is Nothing Then
Set Form_the_form_name.Recordset = RST
End If
And here's the method QueryDAORS called :
Public Function QueryDAORS(ByVal SQL As String, Optional strTitle As String) As DAO.Recordset
Dim RS As DAO.Recordset
Dim dtTemp As Date
Dim strErrNumber As Long
Dim strErrDesc As String
Dim intSeconds As Long
Dim Param As Variant
On Error GoTo Query_Error
dtTemp = Now
If DBcon.state <> adStateOpen Then
Set QueryDAORS = Nothing
Else
DoCmd.Hourglass True
Set pQDEF = CurrentDb.CreateQueryDef("")
pQDEF.Connect = pPassThroughString
pQDEF.ODBCTimeout = pTimeOut
pQDEF.SQL = SQL
pLastRows = 0
pLastSQL = SQL
pLastError = ""
pLastSeconds = 0
LogIt SQL, strTitle, , True
Set RS = pQDEF.OpenRecordset(dbOpenSnapshot)
intSeconds = DateDiff("s", dtTemp, Now)
If RS.EOF Then
LogIt "-- " & Format(Now, "hh:nn:ss") & " | Executed in " & intSeconds & " second" & IIf(intSeconds = 1, "", "s") & " | Now rows returned."
Set QueryDAORS = Nothing
Else
RS.MoveLast
pLastRows = RS.RecordCount
LogIt "-- " & Format(Now, "hh:nn:ss") & " | Executed in " & intSeconds & " second" & IIf(intSeconds = 1, "", "s") & " | " & RS.RecordCount & " row" & IIf(RS.RecordCount = 1, "", "s") & " returned."
RS.MoveFirst
Set QueryDAORS = RS
End If
End If
Exit_Sub:
pLastSeconds = intSeconds
Set RS = Nothing
DoCmd.Hourglass False
Exit Function
Query_Error:
intSeconds = DateDiff("s", dtTemp, Now)
strErrNumber = Err.Number
strErrDesc = Err.DESCRIPTION
pLastError = strErrDesc
MsgBox strErrDesc, vbCritical, "Error " & pDSN
LogIt strErrDesc, , "ERROR"
Set QueryDAORS = Nothing
Resume Exit_Sub
Resume
End Function
The property pPassThroughString is defined with another Method using the properties that I already had at my disposal in the class, because they were neccessary to open an ADO connection to the database :
Private Function pPassThroughString() As String
Select Case pRDBMS
Case "Oracle"
pPassThroughString = "ODBC;DSN=" & pDSN & ";UID=" & pUsername & ";Pwd=" & XorC(pXPassword, CYPHER_KEY)
Case "MS SQL"
pPassThroughString = "ODBC;DSN=" & pDSN & ";DATABASE=" & pDBname & ";Trusted_Connection=Yes"
Case "Sybase"
pPassThroughString = "ODBC;DSN=" & pDSN & ";"
Case Else
MsgBox "RDBMS empty ! ", vbExclamation
LogIt "RDBMS empty ! ", , "ERROR"
End Select
End Function
So the issue was solved rapidly by just changing the recordset assigned to the forms from ADODB.Recordset to DAO.recordset and adapting the method called from .OpenRS to .OpenDAORS.
The only con is that with DAO I can't use this anymore to disconnect the recordset:
Set RST.ActiveConnection = Nothing
Still, I would have prefered to get an explanation and fix :(
Related
I'm developping modules on a client XLSm with 32-bits 2013 Excel.
I'd like to use datas on worksheet as if it is an Access table.
With a lot of difficulties, I think connection is now OK.
Still, I have error : 3001 Arguments are of wrong type, are out of acceptable range. Error that I cannot understand.
Here excerpts of VBA lines :
In addition, I added 20 lines in data Worksheet below the header line to permit to Excel to interpret for the type of each columns.
varCnxStr = "Data Source=" & G_sWBookREINVOICingFilePath & ";" & "Extended Properties='Excel 12.0 Xml;HDR=YES;IMEX=15';"
With conXLdb
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Mode = adModeShareExclusive
.Open varCnxStr
End With
strSQL = "SELECT * "
strSQL = strSQL & " FROM [ReInvoiceDB$B2B5072] inum "
strSQL = strSQL & " WHERE inum.InvoiceNum LIKE '1712*' "
strSQL = strSQL & ";"
'>> TRIGGERs ERROR with the current Where Clause !!'
adoXLrst.Open strSQL, conXLdb, dbOpenDynamic, adLockReadOnly, adCmdText
If adoXLrst.BOF And adoXLrst.EOF Then
'no records returned'
GoTo Veloma
End If
adoXLrst.MoveFirst
Do While Not adoXLrst.EOF
'Doing stuff with row'
adoXLrst.MoveNext
Loop
sHighestSoFar = adoXLrst(1).Value '> just to try for RecordSet : Codes are not completed...
sPrefixeCURR = Mid(sHighestSoFar, 1, 4)
Highest = CInt(Mid(sHighestSoFar, 5))
'> Increment >'
Highest = Highest + 1
HighestStr = sPrefixeCURR & Format(Highest, "00")
strGSFNumber = HighestStr
adoXLrst.Close
conXLdb.Close
Veloma:
On Error Resume Next
Set adoXLrst = Nothing
Set conXLdb = Nothing
Exit Sub
Etc.
Any idea about what seems be wrong ?
Thank you
Below is an old example I have been using successfully. Note that the sheet name in the book are Sheet1 and Sheet2, but in the query I had to use sheet1$ and sheet2$. I noticed you had $ signs in the middle of your sheet names. perhaps that's the issue ?
Sub SQLUpdateExample()
Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Set con = New ADODB.Connection
con.Open "Driver={Microsoft Excel Driver (*.xls)};" & _
"DriverId=790;" & _
"Dbq=" & ThisWorkbook.FullName & ";" & _
"DefaultDir=" & ThisWorkbook.FullName & ";ReadOnly=False;"
Set rs = New ADODB.Recordset
Set rs = con.Execute("UPDATE [Sheet1$] inner join [Sheet2$] on [Sheet1$].test1 = [Sheet2$].test1 SET [Sheet1$].test3 = [Sheet2$].test2 ")
Set rs = Nothing
Set con = Nothing
End Sub
To give more details about the whole module to be implemented : it is to perform a Transaction unit.
This transaction will comprise 3 operations : get a max value from a column (Invoice number) to increment it, record the new number inside an Access table (by DAO), the same Excel file (by ADO) and generating document on HDD.
So it is aimed to use the Excel file as a table not as a file manipulated with Windows script or Excel VBA. My end user is disturbed by the pop-uping of an Excel opening file operation. As a developer, I'm feeling more comfortable with using SQL statements as much as possible inside Transaction session. Is that your opinion too ?
We got some old legacy application which was developed during 2000 and we have moved from access 2003 to 2007. When I am trying to run a module of an application, it is giving me an error:
"Run-time error 3847. ODBCDirect is no longer supported. Rewrite the code to use ADO instead of DAO".
And it highlights to the line Set WS = CreateWorkspace("NewWS", "", "", dbUseODBC). As I am really new to Access, I did research before posting this issue here but no luck. I am trying to rewrite the code to use ADO instead of DAO.
Following is my old vba code:
Public Function GetID (ByRef SegmentItem As clsSegmentDefinitions) As Long
Dim qdf As QueryDef
Dim qdfNewID As QueryDef
Dim rs As Recordset
Dim rsNewID As Recordset
Dim NaturalDescription As String
Dim WS As Workspace
Dim con As Connection
Set WS = CreateWorkspace("NewWS", "", "", dbUseODBC)
WS.DefaultCursorDriver = dbUseODBCCursor
Set con = WS.OpenConnection("", , , SQLConnectString)
DoCmd.Hourglass False
DoCmd.OpenForm " frmQuickAdd_AddNatural ", , , , , acDialog, SegmentItem.AddValue
DoCmd.Hourglass True
If Form_frmQuickAdd_AddNatural.Tag Then
Set qdf = con.CreateQueryDef("", "{ ? = call sp_Insert(?, ?, ?) }")
qdf.Parameters.Refresh
qdf![#prmDescription] = Left(Form_frmQuickAdd_AddNatural.txtSegmentDescription, 34)
qdf![#prmCreateUser] = CurrentUser
qdf![#prmProjectID] = 0
qdf.Execute
Set qdfNewID = CodeDb.CreateQueryDef("")
qdfNewID.Connect = SQLConnectString
qdfNewID.ReturnsRecords = True
qdfNewID.SQL = "sp_GetNewSegmentID"
Set rsNewID = qdfNewID.OpenRecordset
If Not IsNull(rsNewID!MaxOfSegmentID) Then
GetID = rsNewID!MaxOfSegmentID
Else
GetID = 0
End If
Else
GetID = 0
End If
DoCmd.Close acForm, "frmQuickAdd_AddNatural"
End Function
I had started to rewrite code but I have no clue if it is suppose to be like this at all.
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
cnn.Open "Provider=mssql;Data Source=" & dbq & ";User Id=" & uid & ";Password=" & pwd
With rst
.Open "SELECT COUNT(*) FROM " & tbl, cnn, adOpenKeyset, adLockOptimistic
num = .Fields(0)
.Close
End With
cnn.Close
Set rst = Nothing
Set cnn = Nothing
First, you really don’t want to introduce ADO into an application built and designed around DAO. Worse, is ADO has been on its way out for about 15 years now. In fact SQL server is dropping support for oleDB which ADO works on. (so don’t go there).
See this link about SQL server dropping oleDB support:
http://blogs.msdn.com/b/sqlnativeclient/archive/2011/08/29/microsoft-is-aligning-with-odbc-for-native-relational-data-access.aspx
The industry has moved away from ADO and all major vendors are suggesting to use Open Database Connectivity as the industry standard. (that means ODBC).
I would create and save a pass-though query in Access. You code can then be re-written as:
Public Function GetID(ByRef SegmentItem As String) As Long
Dim strSQL As String
strSQL = "sp_Insert('" & _
Left(Form_frmQuickAdd_AddNatural.txtSegmentDescription, 34) & "'," & _
"'" & CurrentUser & "', 0)"
With CurrentDb.QueryDefs("qryPass")
.SQL = strSQL
.ReturnsRecords = False
.Execute
End If
With CurrentDb.QueryDefs("qryPass")
.SQL = "sp_GetNewSegmentID"
.ReturnsRecords = True
GetID = Nz(.OpenRecordset()("MaxOfSegmentID"),0)
End With
End Function
So create one pass-though query. And you can use it quite much in all places where you were using JET-DIRECT. In access 2007, jet-direct support was dropped, but use of a simple pass-though query will more than suffice and also as the above shows save buckets of coding and developer time. If the “left” expression you have can return a null, then you likely need to wrap that expression in a nz() to return a “” (null string) or the appropriate value.
I have 2 fields - txtTR1_Unit and cmbTR2_Unit. Together, these 2 fields represent the total UNIT.
cmbTR2_Unit has a list of unique values that when selected - txtTR1_Unit automatically gets the related value.
I've created a function called Tier1from2 - that accepts a 'string' and returns the related Tier1 value.
So when I update cmbTR2_Unit in my After_Update event, I'd like to automatically tab to the next field. - Another combo box. I figured that I shouldn't need to set any focus, because it would automatically go to the next field after updating.
txtTR1 gets updated just as expected from my Function, but then it just sits there and won't go to the next field. So I have attempted to 'SetFocus' to the next field after the update.
Still no go. What did I miss??
Private Sub cmbTR2_UNIT_AfterUpdate()
If Len(Me.cmbTR2_UNIT.Value) <> 0 Then
Me.txtTR1_UNIT.Value = Tier1From2(Me.cmbTR2_UNIT.Text)
'cmb_CostCenter.setfocus - 'this doesn't seem necessary - but it doesn't work anyway.
End If
End Sub
As a test I tried removing the function "Tier1From2(Me.cmbTR2_UNIT.text)" simply hard coding the word 'RESULT' in txtTR1_UNIT and it works without a hitch. I know I used to write a more simple function but I haven't touched VBA in awhile - How can I simplify this function:
Private Function Tier1From2(strTier2 As String) As String
Dim qdf As DAO.QueryDef
Dim db As DAO.Database
Dim strQry As String
Dim rs As Recordset
Set db = CurrentDb
Set qdf = db.QueryDefs("qUNIT_HUB")
strQry = "SELECT Tier1_Unit, Tier2_Unit " & _
" FROM LTBL_Cost_Collector " & _
" GROUP BY Tier1_Unit, Tier2_Unit " & _
" HAVING (((Tier2_Unit) = '" & strTier2 & "'));"
qdf.SQL = strQry
db.QueryDefs.Refresh
Set rs = db.OpenRecordset(strQry)
Tier1From2 = rs![Tier1_Unit]
Set db = Nothing
Set qdf = Nothing
Set Recordset = Nothing
End Function
It turns out that something in this function was causing the field and form to loose focus. db.QueryDefs.refresh perhaps? The solution was to update my Function as follows
Private Function Tier1From2(strTier2 As String) As String
Dim rs As DAO.Recordset
Dim db As DAO.Database
Dim strSQL As String
Dim strTier1 As String
Set db = CurrentDb
strSQL = "SELECT Tier1_Unit, Tier2_Unit " & _
" FROM LTBL_Cost_Collector " & _
" GROUP BY Tier1_Unit, Tier2_Unit " & _
" HAVING (((Tier2_Unit) = '" & strTier2 & "'));"
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
strTier1 = rs!Tier1_Unit
Set rs = Nothing
Set db = Nothing
Tier1From2 = strTier1
End Function
This worked without a hitch.
I'm programming an Office 2010 Word template that needs to interact with the Active Directory, to retrieve some user info. The user filling out the template can give some input for the search that is used to retrieve the AD info.
I'm using the ADODB Recordset and Command to setup my query:
Public Function GetActiveDirectoryInfo(searchString As String) As Object
Dim adoCommand, adoConnection, strBase, strFilter, strAttributes
Dim strQuery, adoRecordset
'remove user input asteriks
searchString = Replace(searchString, "*", "")
' Setup ADO objects.
Set adoCommand = CreateObject("ADODB.Command")
Set adoConnection = CreateObject("ADODB.Connection")
adoConnection.Provider = "ADsDSOObject"
adoConnection.Open "Active Directory Provider"
Set adoCommand.ActiveConnection = adoConnection
strBase = "<LDAP://" & GLOBAL_LDAP_USER_OU & ">"
' Filter on user objects.
strFilter = "(&(objectCategory=person)(objectClass=user)(|(sn=" & searchString & "*)(cn=" & searchString & "*)))"
' Comma delimited list of attribute values to retrieve.
strAttributes = ACTIVE_DIRECTORY_FIELDS
' Construct the LDAP syntax query.
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";OneLevel"
adoCommand.CommandText = strQuery
adoCommand.Properties("Page Size") = 10
adoCommand.Properties("Timeout") = 30
adoCommand.Properties("Cache Results") = False
'adoCommand.Properties("Maximum Rows") = 10 'error: read only
On Error GoTo err_NoConnection
' Run the query.
Set adoRecordset = adoCommand.Execute
Set foundItems = adoRecordset
Debug.Print "Found : " & foundItems.RecordCount & " records"
Exit Function
err_NoConnection:
'in case of error: return <nothing>
Debug.Print Err.description
Set GetActiveDirectoryInfo = Nothing
End Function
THis function is part of a User Class in MS Word.
My question: how to prevent the user from retrieving thousands of records? I have been reading about paging, but that seems more like a network-load-thing than actually limiting the search results that will eventually get back to me.
I've tried several things but with no results. For instance setting the MaxRecords or Maximum Rows properties. Both give an error (non existing property for the first, and read only error for the second).
ANy ideas anyone.
MS Office 2010 dutch
ADO Objects 6.0
Thanx!
Unfortunately ADO MaxRecord that limits the number of search results is not implemented for ADsDSObject. The link https://support.microsoft.com/kb/269361 details the workaround to solve the issue.
I am seeking one suggestion on how to build an excel macro for below requirement. Request you to provide your valuable comments in EXCEL Only.
Scenario
I have one spreadsheet "Product Master" that contains all the product details.
(i.e. Product ID,Product Name,Product Type,Quantity etc etc)
I am designing a UserForm using excel VBA where anyone can fetch all the details of a product based on its Product ID. Now the product-master sheet where all the product details is present will get updated on a daily basis. And each user should be able to update any details in that sheet based on his requirement.
Questions/Doubts
How do I design my system? I mean where should I put my "Product-Master" spreadsheet so that it can be accessed by multiple users. What I am thinking is to put product-masster on a shared_drive so that all can access that sheet through VBA userform. I will provide excel VBA userform macro to everyone in my office & they will query that sheet present in shared drive. does this seem ok?
Does excel provide facility to Query data from sheet present in shared-drive & update it when required. And I want this to be queried by multiple users at a time.
I know there are other products/technologies that provides better solution than EXCEL. But I want the solution in EXCEL ONLY.
I would appreciate it if anyone can provide his/her valuable comments on this. Let me know in case you need any details.
Thanks you.
Here are some example functions getting data from/posting data to MS Access (took me awhile to dig these up, hah!). This uses a Reference to the Microsoft DAO 3.6 Object Library and will only work with legacy .mdb files, not accdb (because the mdb driver is 100x faster and doesn't have a memory leak.)
Const DBPath As String = "Full\Database\Path"
Function GET_ACCESS_DATA(DBPath, SQL) As Object
Dim dbConn As Object
Dim dbRS As Object
Dim SQL As String
On Error GoTo ErrorHandler
SQL = "Sql Query"
'Set up database connection string
Application.StatusBar = "Connecting to Database..."
'Open database connection
Set dbConn = OpenDatabase(DBPath)
'Run the query
Application.StatusBar = "Running Query..."
Set dbRS = dbConn.OpenRecordset(SQL, DAO.dbOpenForwardOnly, DAO.RecordsetOptionEnum.dbReadOnly)
'If no rows returned, display error message and exit
If dbRS.RecordCount = 0 Then
Application.StatusBar = "Running Query...Error"
MsgBox "There are no records for the selected criteria.", vbInformation, "Refresh Data"
Application.StatusBar = "REFRESHING DATA PLEASE WAIT.."
Exit Function
End If
'returns DAO Recordset with the data
Set GET_ACCESS_DATA = dbRS
'A recordset can either be looped through or pasted to a spreadsheet with the Worksheet.Range.CopyFromRecordset method
'Error trap here
End Function
Function POST_TO_ACCESS() As Boolean
POST_TO_ACCESS = False
errormod = "TRACKING"
On Error GoTo ERROR_TRAP:
'START CONTROLS
Application.StatusBar = "Formatting Data"
St_Timer = Timer 'start connection timer
Dim cn As DAO.Database
Set cn = DAO.OpenDatabase(DBPath)
En_Timer = Timer 'get connection time
'SetKey Parameters
UserNM = Replace(User_Name(), Chr(39), "")
CompNm = Environ("COMPUTERNAME")
Elapsed_Time = En_Timer - St_Timer
SQL = "INSERT INTO TBL_TRACKING " & _
"(UserNM) " & _
" VALUES ('" & UserNM & "')"
cn.Execute SQL
cn.Close
'END CONTROLS
Application.StatusBar = False
POST_TO_ACCESS = True
'error trap here
End Function
Function User_Name()
'This just gets the LDAP username of whoever is logged in. Useful for tracking. Not guarenteed to work for your Active Directory :)
Dim WshNetwork
Dim objAdoCon, objAdoCmd, objAdoRS
Dim objUser, objRootDSE
Dim strDomainDN, strUserName, strUserFullName
strUserFullName = ""
Set WshNetwork = CreateObject("WScript.Network")
strUserName = WshNetwork.UserName
Set objRootDSE = GetObject("LDAP://rootDSE")
strDomainDN = objRootDSE.Get("defaultNamingContext")
Set objAdoCon = CreateObject("ADODB.Connection")
objAdoCon.Open "Provider=ADsDSOObject;"
Set objAdoCmd = CreateObject("ADODB.Command")
Set objAdoCmd.ActiveConnection = objAdoCon
objAdoCmd.CommandText = _
"SELECT ADsPath FROM 'LDAP://" & strDomainDN & "' WHERE " & _
"objectCategory='person' AND objectClass='user' AND " & _
"sAMAccountName='" & strUserName & "'"
Set objAdoRS = objAdoCmd.Execute
If (Not objAdoRS.EOF) Then
Set objUser = GetObject(objAdoRS.Fields("ADsPath").Value)
objUser.GetInfoEx Array("displayName"), 0
strUserFullName = objUser.Get("displayName")
Set objUser = Nothing
User_Name = strUserFullName
Else
End If
Set objAdoRS = Nothing
Set objAdoCmd = Nothing
objAdoCon.Close
Set objAdoCon = Nothing
Set objRootDSE = Nothing
Set WshNetwork = Nothing
End Function