I am using windows server 2008 R2 64-bit and IIS 7.5 and hosting a classic asp (32-bit) web site and invoking COM components on COM server (which too have windows server 2008 R2 64-bit). But getting a error "Permission denied" and error code is 800A0046.
Set oDictAOGroup = CreateObject("Scripting.Dictionary")
oDictAOGroup.Add "1000", "5"
oUser.fn_Update_AO_Groups(oDictAOGroup)
asp website server uses DCOM to communicate with COM server. On asp web site server proxy is created of COM server classes.
I created a test function and passed the values to that function then code works perfectly fine.
oUser.fn_Update_AO_Groups_Test1("1000", "21")
But when try to pass Scipting.Dictionary object then permission denied error is raised.
I have googled a lot for this but all in vain nothing much relevant.
Function's code is
Public Function fn_Update_AO_Groups(vntAODict As Variant)
On Error GoTo ErrorHandler
Dim oADOConnect As AMLCONNECT_V2.clsConnect
Dim oADOConn As ADODB.Connection
Dim oADOCmd As ADODB.Command
Dim vntKey As Variant
If Not objContext Is Nothing Then
Set oADOConnect = objContext.CreateInstance("AMLCONNECT_V2.clsConnect")
Set oADOCmd = objContext.CreateInstance("ADODB.Command")
Else
Set oADOConnect = New clsConnect
Set oADOCmd = New ADODB.Command
End If
If IsObject(vntAODict) Then
If oADOConnect.OpenADOConnection(oADOConn) Then
With oADOCmd
.CommandText = "Sp_Upd_AOGroups"
.CommandType = adCmdStoredProc
.Parameters.Append .CreateParameter("AO_ID", adInteger, adParamInput)
.Parameters.Append .CreateParameter("Email_Group_ID", adInteger, adParamInput)
Set .ActiveConnection = oADOConn
End With
'Execute stored procedure for each item in the dictionary
For Each vntKey In vntAODict.Keys
oADOCmd.Parameters("AO_ID").Value = vntKey
oADOCmd.Parameters("Email_Group_ID").Value = vntAODict(vntKey)
oADOCmd.Execute
Next
End If
End If
TidyUp:
Set oADOConn = Nothing
Set oADOCmd = Nothing
Set oADOConnect = Nothing
Exit Function
ErrorHandler:
Dim ErrHandler As AMLCONNECT_V2.clsConnect
If Not objContext Is Nothing Then
Set ErrHandler = objContext.CreateInstance("AMLCONNECT_V2.clsConnect")
Else
Set ErrHandler = New AMLCONNECT_V2.clsConnect
End If
m_sErrorMessage = "Error Number: " + CStr(Err.Number) + "<BR>" + "Description: " + ErrHandler.LogError(Err.Number, Err.Description, "MODULE: AMLADMIN_V2.clsUsers", "FUNCTION:fn_Update_AO_Groups", errError, errVB, errDatabase, "")
If Not ErrHandler Is Nothing Then Set ErrHandler = Nothing
GoTo TidyUp:
End Function
Can any one suggest a remedy for this ?
code for function accepting string
Public Function fn_Update_AO_Groups_Test1(strKey As String, strValue As String)
On Error GoTo ErrorHandler
Dim oADOConnect As AMLCONNECT_V2.clsConnect
Dim oADOConn As ADODB.Connection
Dim oADOCmd As ADODB.Command
Dim vntKey As Variant
Dim ErrHandlerTest As AMLCONNECT_V2.clsConnect
If Not objContext Is Nothing Then
Set oADOConnect = objContext.CreateInstance("AMLCONNECT_V2.clsConnect")
Set oADOCmd = objContext.CreateInstance("ADODB.Command")
Else
Set oADOConnect = New clsConnect
Set oADOCmd = New ADODB.Command
End If
If oADOConnect.OpenADOConnection(oADOConn) Then
With oADOCmd
.CommandText = "Sp_Upd_AOGroups"
.CommandType = adCmdStoredProc
.Parameters.Append .CreateParameter("AO_ID", adInteger, adParamInput)
.Parameters.Append .CreateParameter("Email_Group_ID", adInteger, adParamInput)
Set .ActiveConnection = oADOConn
End With
'Execute stored procedure for each item in the dictionary
oADOCmd.Parameters("AO_ID").Value = strKey
oADOCmd.Parameters("Email_Group_ID").Value = strValue
oADOCmd.Execute
End If
TidyUp:
Set oADOConn = Nothing
Set oADOCmd = Nothing
Set oADOConnect = Nothing
Exit Function
ErrorHandler:
Dim ErrHandler As AMLCONNECT_V2.clsConnect
If Not objContext Is Nothing Then
Set ErrHandler = objContext.CreateInstance("AMLCONNECT_V2.clsConnect")
Else
Set ErrHandler = New AMLCONNECT_V2.clsConnect
End If
m_sErrorMessage = "Error Number: " + CStr(Err.Number) + "<BR>" + "Description: " + ErrHandler.LogError(Err.Number, Err.Description, "MODULE: AMLADMIN_V2.clsUsers", "FUNCTION:fn_Update_AO_Groups", errError, errVB, errDatabase, "")
If Not ErrHandler Is Nothing Then Set ErrHandler = Nothing
GoTo TidyUp:
End Function
Thanks,
Vaibhav
Too long for comment, so while this is not full answer it might put you on right direction.
First, I noticed the field types are integer while your dictionary keys and values are string. So first try converting those by changing the code in the function to:
oADOCmd.Parameters("AO_ID").Value = CLng(vntKey)
oADOCmd.Parameters("Email_Group_ID").Value = CLng(vntAODict(vntKey))
If still same error, I need to know if the exact same code works fine when you explicitly pass two parameters to the function instead of a dictionary?
Another thing that comes to mind is maybe something is going wrong with your error handling, try to remove it for sake of debug and see if you get more meaningful error message.
Either use Call oUser.fn_Update_AO_Groups(oDictAOGroup) or oUser.fn_Update_AO_Groups oDictAOGroup without parentheses.
Try these signatures instead:
Public Function fn_Update_AO_Groups(ByVal vntAODict As Variant)
or
Public Function fn_Update_AO_Groups(ByVal vntAODict As Scripting.Dictionary)
You demand far more of the marshalling code if you allow the default ByRef to prevail. Also providing the explict type expected gives marshalling code more options too. These changes may be enough to allow the operation you expect.
If that fails I would reconsider the approach, I prefer to pass XML strings through into the SPs. This gives greatest flexibility allowing code changes to SQL and ASP to effect a new requirement without recompilation and deployment of new binaries.
Related
I have a sub which creates a recordset. A function is called with values from the recordset. The goal is to use multiple values from the recordset, however, there is a possibility that a recordset value is null, then the function call will result in an error: "Invalid use of Null". To handle this error, each time the recordset value is checked for null values, if it is null, it will be replaced with an empty string. However, the way I have programmed this feels very inefficient, even more when later on more than ten parameters should be checked. Is there a way to do this more efficiently?
I have skipped the last part off the code as this is not necessary to understand my question. I've replaced it with ......... If needed, I will edit and provide full code.
Sub CallFunctionWithArray()
Dim conn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim arrValues(1 To 3) As Variant
Set conn = New ADODB.Connection
conn.Open "provider=Microsoft.JET.OLEDB.4.0;Data Source=" & CurrentProject.Path & "\Northwind.mdb"
Set rst = New ADODB.Recordset
rst.Open "SELECT * FROM CustomersCopy", conn, adOpenForwardOnly, adLockReadOnly, adCmdText
If Not (rst.EOF And rst.BOF) Then
rst.MoveFirst
Do Until rst.EOF = True
If IsNull(rst![CompanyName]) Then
arrValues(1) = ""
Else
arrValues(1) = rst![CompanyName]
End If
If IsNull(rst![DateTest]) Then
arrValues(2) = ""
Else
arrValues(2) = rst![DateTest]
End If
If IsNull(rst![INTTest]) Then
arrValues(3) = ""
Else
arrValues(3) = rst![INTTest]
End If
Call ReturnValuesOfArray(arrValues(1), arrValues(2), arrValues(3))
.........
End Sub
Function ReturnValuesOfArray(ByVal ValueOne As String, ByVal ValueTwo As String, ByVal ValueThree As String)
Debug.Print "Waarde variabele 1: " & ValueOne
Debug.Print "Waarde variabele 2: " & ValueTwo
Debug.Print "Waarde variabele 3: " & ValueThree
End Function
There is no problem with the code, it does what it's supposed to do. However, I will be passing many more parameters to the function when this is going to be really used.
You could loop through the fields of your Recordset instead of hard coding for every field. Using your code as a starting point, it could look something like this:
Private Sub Test()
Dim rst As ADODB.Recordset
Dim i As Integer
If Not (rst.EOF And rst.BOF) Then
rst.MoveFirst
Do Until rst.EOF = True
For i = 0 To rst.Fields.Count - 1
If IsNull(rst.Fields(i).Value) Then
arrValues(i) = ""
Else
arrValues(i) = rst.Fields(i).Value
End If
Next
Loop
End If
End Sub
Incorporating the ideas presented by #HansUp and #Mathieu Guindon, the code is even shorter:
Private Sub Test()
Dim rst As ADODB.Recordset
Dim i As Integer
Do Until rst.EOF
For i = 0 To rst.Fields.Count - 1
arrValues(i + 1) = Nz(rst.Fields(i).Value, "")
Next
Loop
End Sub
The rest of your code can be simplified, too, while allowing for any number of parameters:
Function ReturnValuesOfArray(ByVal Values As Variant)
Dim i As Integer
For i = LBound(Values) To UBound(Values)
Debug.Print "Waarde variabele " & i & ": " & Values(i)
Next
End Function
The Nz Function does what I think you want.
arrValues(1) = Nz(rst![CompanyName], "")
arrValues(2) = Nz(rst![DateTest], "")
arrValues(3) = Nz(rst![INTTest], "")
I have included an audit trail code to be called to 2 different forms in my access database. The code works fine for one of the forms but in the other form it produces a 438 error.
-The same parameter is used to call the code in both forms
-The debugger highlights this line : 'If Nz(ctl.Value) <> Nz(ctl.OldValue) Then
-I have attempted to comment out the code which calls the procedure and the problem appears to be with the parameter "SingleName"
-I have checked both the Control Source and Name for the textbox and both appear correct.
Sub AuditChanges(IDField As String, UserAction As String)
On Error GoTo AuditChanges_Err
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim ctl As Control
Dim datTimeCheck As Date
Dim strUserID As String
Set cnn = CurrentProject.Connection
Set rst = New ADODB.Recordset
rst.Open "SELECT * FROM TBL_AuditTrail", cnn, adOpenDynamic,
adLockOptimistic
datTimeCheck = Now()
strUserID = Environ("USERNAME")
Select Case UserAction
Case "EDIT"
For Each ctl In Screen.ActiveForm.Controls
If ctl.Tag = "Audit" Then
If Nz(ctl.Value) <> Nz(ctl.OldValue) Then
With rst
.AddNew
![DateTime] = datTimeCheck
![UserName] = strUserID
![FormName] = Screen.ActiveForm.Name
![Action] = UserAction
![RecordID] =
Screen.ActiveForm.Controls(IDField).Value
![FieldName] = ctl.ControlSource
![OldValue] = ctl.OldValue
![NewValue] = ctl.Value
.Update
End With
End If
End If
Next ctl
Case Else
With rst
.AddNew
![DateTime] = datTimeCheck
![UserName] = strUserID
![FormName] = Screen.ActiveForm.Name
![Action] = UserAction
![RecordID] = Screen.ActiveForm.Controls(IDField).Value
.Update
End With
End Select
AuditChanges_Exit:
On Error Resume Next
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
Exit Sub
AuditChanges_Err:
MsgBox Err.Number & Err.Description
Resume AuditChanges_Exit
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
If Me.NewRecord Then
Call AuditChanges("SingleName", "NEW")
Else
Call AuditChanges("SingleName", "EDIT")
End If
End Sub
The BeforeUpdate event of the form is supposed to call the procedure and send any changes, deletions or additions to TBL_AuditTrail.
After the data is inputted and I attempt to save, the 438 error occurs.
The information is still sent to the table (TBL_AuditTrail)
An unbound control doesn't have an OldValue property. You could check for that:
If ctl.ControlSource <> "" Then
![OldValue].Value = ctl.OldValue
Else
' Skip unbound control.
End If
Without seeing the three forms in question, I can only say that something is different on Screen.ActiveForm.Controls(IDField) field. I would compare the properties of all three fields to see how the one that is failing is different.
I have an audit trail table setup with an MS Access form that works although the ID (PK) is a GUID and when the data shows in my AuditTrail table it shows as Chinese characters. I can't work out why its not showing the actual ID.
In my BeforeUpdate event I have the following code which helps but not 100%:
Option Compare Database
Option Explicit
Private Sub Form_BeforeUpdate(Cancel As Integer)
On Error GoTo errHandler
If Me.NewRecord Then
Call AuditChanges("ID", "NEW")
Else
Call AuditChanges("ID", "EDIT")
End If
Exit Sub
errHandler:
MsgBox "Error " & Err.Number & ": " & Err.Description & " in " & _
VBE.ActiveCodePane.CodeModule, vbOKOnly, "Error"
End Sub
'I am using this code to for the AuditChanges
Sub AuditChanges (IDField As String, UserAction As String)
On Error GoTo AuditChanges_Err
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim ctl As Control
Dim datTimeCheck As Date
Dim strUserID As String
Set cnn = CurrentProject.Connection
Set rst = New ADODB.Recordset
rst.Open "SELECT * FROM tblAuditTrail", cnn, adOpenDynamic, adLockOptimistic
datTimeCheck = Now()
strUserID = Environ("USERNAME")
Select Case useraction
Case "EDIT"
For Each ctl In Screen.ActiveForm.Controls
If ctl.Tag = "Audit" Then
If Nz(ctl.Value) <> Nz(ctl.OldValue) Then
With rst
.AddNew
![FormName] = Screen.ActiveForm.Name
![RecordID] = Screen.ActiveForm.Controls(IDField).Value
![FieldName] = ctl.ControlSource
![OldValue] = ctl.OldValue
![NewValue] = ctl.Value
![UserID] = strUserID
![DateTime] = datTimeCheck
.Update
End With
End If
End If
Next ctl
Case Else
With rst
.AddNew
![DateTime] = datTimeCheck
![UserID] = strUserID
![FormName] = Screen.ActiveForm.Name
![Action] = useraction
![RecordID] = Screen.ActiveForm.Controls(IDField).Value
.Update
End With
End Select
AuditChanges_Exit:
On Error Resume Next
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
Exit Sub
AuditChanges_Err:
MsgBox Err.Description, vbCritical, "ERROR!"
Resume AuditChanges_Exit
End Sub
Although the ID is not showing correctly. I tried using StringFromGUID but this throws an error of cannot find the field. Example of GUID is {EF95C08E-D344-42B3-B678-2A64A50366DE}.
I hope someone can help although this is probably the wrong way of doing this it is the only way I have managed so far. Thanks.
The problem is that Application.StringFromGUID takes a byte array, and you've stored the bytes of your GUID as a string.
Access uses UTF-16 to store strings. Because a large fraction of two-byte UTF-16 characters are Chinese, you often get Chinese characters if you display random bytes as a string.
The following code casts them back to a bytearray, and then calls StringFromGUID. I've tested it on Access 2016 with default locale settings.
Public Function StringFromStringGUID(strGUIDBytes As String) As String
If Len(strGUIDBytes) = 8 Then
Dim bytes() As Byte
bytes = strGUIDBytes
StringFromStringGUID = Application.StringFromGUID(bytes)
Else
'Invalid string, GUID = 16 bytes, Access stores UTF-16 strings = 2 bytes per character
End If
End Function
You can use this in queries/VBA to cast those strings back to GUIDs
I have class
Class dbaccess
Public Sub DBOpenAccess()
...
strConnStr = "PROVIDER=Microsoft.Jet.OLEDB.4.0;DATA SOURCE="
strConnStr = strConnStr & strDBLoc & ";"
Set cnnObj = server.CreateObject("ADODB.Connection")
cnnObj.Open strConnStr
End Sub
...
Public Function OpenRec()
Set objRec = server.CreateObject("ADODB.Connection")
End Function
Public Function ExecuteUpdateSQL(strSQLStatement)
Set objRec = cnnObj.Execute(strSQLStatement)
End Function
...
Public Function CloseRec()
objRec.close
Set objRec = Nothing
End Function
End Class
When i want execute query from other sub and loop throught recordset
Sub transl()
Set db = New dbaccess
Call db.DBOpenAccess()
Call db.OpenRec()
Set rst = db.ExecuteUpdateSQL("select * from Translations")
Do while Not rst.eof
...
rst.movenext
loop
rst.close
Set rst = Nothing
Call db.CloseRec()
Call db.DBClose()
Set db = Nothing
End Sub
But I get error on line objRec.close
ADODB.Connection error '800a0e78'
Operation is not allowed when the object is closed.
What i doing wrong? And how to fix this?
A VBscript function returns its result via an assignment to the function's name:
>> Function add(x, y) : add = x + y : End Function
>> WScript.Echo add(4,5)
>>
9
So your ExecuteUpdateSQL() should look like this
Public Function ExecuteUpdateSQL(strSQLStatement)
Set ExecuteUpdateSQL = cnnObj.Execute(strSQLStatement)
End Function
Mark the Set needed for object assignment.
Then you don't need a global (phooey!) variable objRec,
Set rst = db.ExecuteUpdateSQL("select * from Translations")
will set (the one and only) rst to the recordset, and no unsuitable interactions (cf. Alex' comment) are possible.
I have a VB6 application that calls a Crystal Report XI Report. However when I try to change the connection info I get a type mismatch. Any help would be appreciated.
Dim Report As craxddrt.Report ' This is how Report is defined
ChangeReportTblLocation Report ' This is the function where the mismatch occurs
This is the definition of ChangeReportTblLocation:
Private Function ChangeReportTblLocation(ByRef pReport As craxddrt.Report) As Boolean
Dim ConnectionInfo As craxddrt.ConnectionProperties
Dim crxTables As craxddrt.DatabaseTables
Dim crxTable As craxddrt.DatabaseTable
Dim crxSections As craxddrt.Sections
Dim crxSection As craxddrt.section
Dim crxSubreportObj As craxddrt.SubreportObject
Dim crxReportObjects As craxddrt.ReportObjects
Dim crxSubreport As craxddrt.Report
Dim ReportObject As Object
Dim Y As Integer
Dim lsDatabase As String
On Error GoTo errHandle_CRTL
lsDatabase = GetCurrentUserRoot("SOFTWARE\COTTSYSTEMS\APP", "Database")
If lsDatabase = "" Then
lsDatabase = gConn.DefaultDatabase
End If
If lsDatabase = "" Then
lsDatabase = "frasys"
End If
With pReport
For Y = 1 To .Database.Tables.Count
Set ConnectionInfo = .Database.Tables(Y).ConnectionProperties
ConnectionInfo.DeleteAll
ConnectionInfo.Add "DSN", frasysdsn
ConnectionInfo.Add "Database", lsDatabase
'This is the Line that causes the type mismatch
.Database.Tables(Y).Location = lsDatabase & ".dbo." & Database.Tables(Y).Location
Next Y
Set crxSections = .Sections
For Each crxSection In crxSections
Set crxReportObjects = crxSection.ReportObjects
For Each ReportObject In crxReportObjects
If ReportObject.Kind = crSubreportObject Then
Set crxSubreportObj = ReportObject
Set crxSubreport = crxSubreportObj.OpenSubreport
Set crxTables = crxSubreport.Database.Tables
For Y = 1 To crxTables.Count
Set crxTable = crxTables.Item(Y)
crxTable.Location = lsDatabase & ".dbo." & crxTable.Location
Next Y
End If
Next ReportObject
Next crxSection
End With
Set ConnectionInfo = Nothing
Set crxTables = Nothing
Set crxTable = Nothing
Set crxSections = Nothing
Set crxSection = Nothing
Set crxSubreportObj = Nothing
Set crxReportObjects = Nothing
Set crxSubreport = Nothing
Set ReportObject = Nothing
ChangeReportTblLocation = True
Exit Function
errHandle_CRTL:
Screen.MousePointer = vbDefault
MsgBox err.Number, err.Description, "ChangeReportTblLocation", err.Source
End Function
I think its just a typo:
.Database.Tables(Y).Location = lsDatabase & ".dbo." & .Database.Tables(Y).Location
I've added a . before the second Database.Tables(Y).Location in this line.
This does suggest though that you aren't using Option Explicit in your code. I can't stress strongly enough how important it is to use this. It will save you lots of time looking for odd typos (like this) and save your code from doing all sorts of weird things.
try using
call ChangeReportTblLocation(Report)