Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 2436
  • Last Modified:

80040e21 and 80004005 Run-time Errors

We had a developer come in and write a bit of code to check one table in our database against several others. The developer used microsoft access 2010 and vb. If the records don't exist, the code adds them. I've been getting continual Run-time 80040e21 and 80004005 errors. I have MS Access 2010, MS SQL 2005, and SQL Server Business Intelligence Development Studio. I'm a novice with VB code and can't reach the developer to help us figure this out. We are running Windows 2003 SP2. All of this takes place on the same box that I'm logging into through RDS. I've read MDAC can be an issue but I'm fully updated with 2.8 sp2. Any help would be much appreciated.
Option Compare Database

Private Sub cmdGo_Click()

    Dim conn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim cmd As New ADODB.Command
    Dim yearId As String
    Dim typeId As String
    Dim makeId As String
    Dim modelId As String
    Dim groupId As String
    Dim partId As String
    Dim numRequired As String
    Dim partDesc As String
    
    Set conn = CurrentProject.Connection
    
    rs.ActiveConnection = conn
    rs.Source = "SELECT * FROM dbo_Mozenda"
    rs.Open
    
    While Not rs.EOF
        If IsNull(rs("NumRequired")) Then
            numRequired = ""
        Else
            numRequired = rs("NumRequired")
        End If
        partDesc = Left(rs("PartDescription"), 50)
        yearId = getYearId(rs("Year"))
        'MsgBox "YEARID: " & yearId
        typeId = getTypeId(rs("Type"))
        'MsgBox "TYPEID: " & typeId
        modelId = getModelId(rs("Model"), rs("MakeID"), typeId, yearId)
        'MsgBox "MODELID: " & modelId
        If modelId = "0" Then modelId = newModelId(rs("MakeId"), yearId, typeId, rs("Model"))
        'MsgBox "MODELID2: " & modelId
        groupId = getGroupId(modelId, rs("Group"))
        'MsgBox "GROUPID: " & groupId
        If groupId = "0" Then groupId = newGroupId(modelId, rs("Group"), rs("ImgURL"))
        'MsgBox "GROUPID2: " & groupId
        partId = getPartId(groupId, rs("RefNumber"), cleanPart(rs("PartNumber")))
        'MsgBox "PARTID: " & partId
        If partId = "0" Then partId = newPartId(cleanPart(rs("PartNumber")), rs("RefNumber"), numRequired, partDesc, groupId)
        'MsgBox "PARTID2: " & partId
        rs.MoveNext
    Wend

    MsgBox "DONE!!!!!!!!!!"

End Sub



Private Function getYearId(inYear As String) As String
    Dim conn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim rtn As String
    
    inYear = cleanSql(inYear)
    Set conn = CurrentProject.Connection
    rs.ActiveConnection = conn
    rs.Source = "SELECT YearID FROM dbo_Year WHERE Year = '" & inYear & "'"
    rs.Open
    If Not rs.EOF Then
        rtn = rs("YearID")
    Else
        rtn = "0"
    End If
    getYearId = rtn
End Function

Private Function getTypeId(inType As String) As String
    Dim rtn As String
    Select Case inType
        Case "ATV"
            rtn = "3"
        Case "MOTORCYCLES"
            rtn = "26"
    End Select
    getTypeId = rtn
End Function

Private Function getModelId(inModel As String, inMake As String, inType As String, inYear As String) As String
    Dim conn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim rtn As String
    
    inModel = cleanSql(inModel)
    inMake = cleanSql(inMake)
    inType = cleanSql(inType)
    inYear = cleanSql(inYear)
    Set conn = CurrentProject.Connection
    rs.ActiveConnection = conn
    rs.Source = "SELECT ModelId FROM dbo_Model WHERE Model = '" & inModel & "' AND MakeId = " & inMake & " AND TypeId = " & inType & " AND YearId=" & inYear
    rs.Open
    If Not rs.EOF Then
        rtn = rs("ModelID")
    Else
        rtn = "0"
    End If
    getModelId = rtn
End Function

Private Function newModelId(inMake As String, inYear As String, inType As String, inModel As String) As String
    Dim conn As New ADODB.Connection
    Dim cmd As New ADODB.Command
    Dim rtn As String
    
    inMake = cleanSql(inMake)
    inYear = cleanSql(inYear)
    inType = cleanSql(inType)
    inModel = cleanSql(inModel)
    Set conn = CurrentProject.Connection
    cmd.ActiveConnection = conn
    cmd.CommandText = "INSERT INTO dbo_model (MakeID,YearID,TypeID,Model) values (" & inMake & "," & inYear & "," & inType & ",'" & inModel & "')"
    cmd.Execute
    rtn = lastModelId()
    newModelId = rtn
End Function

Private Function getGroupId(inModel As String, inGroup As String) As String
    Dim conn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim rtn As String
    
    inModel = cleanSql(inModel)
    inGroup = cleanSql(inGroup)
    Set conn = CurrentProject.Connection
    rs.ActiveConnection = conn
    rs.Source = "SELECT GroupId FROM dbo_Parts_Group WHERE ModelId = " & inModel & " AND Group_Name = '" & inGroup & "'"
    rs.Open
    If Not rs.EOF Then
        rtn = rs("GroupID")
    Else
        rtn = "0"
    End If
    getGroupId = rtn
End Function

Private Function newGroupId(inModel As String, inGroup As String, inImgUrl As String) As String
    Dim conn As New ADODB.Connection
    Dim cmd As New ADODB.Command
    Dim rtn As String
    
    inModel = cleanSql(inModel)
    inGroup = cleanSql(inGroup)
    inImgUrl = cleanSql(inImgUrl)
    Set conn = CurrentProject.Connection
    cmd.ActiveConnection = conn
    cmd.CommandText = "INSERT INTO dbo_Parts_Group (ModelID,Group_Name,Image_URL,Group_Viewed) values (" & inModel & ",'" & inGroup & "','" & inImgUrl & "',1)"
    cmd.Execute
    rtn = lastGroupId()
    newGroupId = rtn
End Function

Private Function getPartId(inGroup As String, inRef As String, inPart As String) As String
    Dim conn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim rtn As String
    
    inGroup = cleanSql(inGroup)
    inRef = cleanSql(inRef)
    inPart = cleanSql(inPart)
    Set conn = CurrentProject.Connection
    rs.ActiveConnection = conn
    rs.Source = "SELECT PartID FROM dbo_Parts_Listing WHERE GroupID = " & inGroup & " AND Part_Ref_Number = '" & inRef & "' AND Part_Number='" & inPart & "'"
    rs.Open
    If Not rs.EOF Then
        rtn = rs("PartID")
    Else
        rtn = "0"
    End If
    getPartId = rtn
    
End Function

Private Function newPartId(inPart As String, inRef As String, inNum As String, inDesc As String, inGroup As String) As String
    Dim conn As New ADODB.Connection
    Dim cmd As New ADODB.Command
    Dim rs As New ADODB.Recordset
    Dim rtn As String
    
    inPart = cleanSql(inPart)
    inRef = cleanSql(inRef)
    inNum = cleanSql(inNum)
    inDesc = cleanSql(inDesc)
    inGroup = cleanSql(inGroup)
    Set conn = CurrentProject.Connection
    cmd.ActiveConnection = conn
    cmd.CommandText = "INSERT INTO dbo_Parts_Listing (Part_Number,Part_Ref_Number,Part_Qty,Part_Description,GroupID) values ('" & inPart & "','" & inRef & "','" & inNum & "','" & inDesc & "'," & inGroup & ")"
    cmd.Execute
    rtn = lastPartId()
    newPartId = rtn
End Function


Private Function lastModelId() As String
    Dim conn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim rtn As String
    
    Set conn = CurrentProject.Connection
    rs.ActiveConnection = conn
    rs.Source = "SELECT MAX(ModelID) as ID FROM dbo_Model"
    rs.Open
    If Not rs.EOF Then
        rtn = rs("ID")
    Else
        rtn = "0"
    End If
    lastModelId = rtn
End Function

Private Function lastGroupId() As String
    Dim conn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim rtn As String
    
    Set conn = CurrentProject.Connection
    rs.ActiveConnection = conn
    rs.Source = "SELECT MAX(GroupID) as ID FROM dbo_Parts_Group"
    rs.Open
    If Not rs.EOF Then
        rtn = rs("ID")
    Else
        rtn = "0"
    End If
    lastGroupId = rtn
End Function

Private Function lastPartId() As String
    Dim conn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim rtn As String
    
    Set conn = CurrentProject.Connection
    rs.ActiveConnection = conn
    rs.Source = "SELECT MAX(PartID) as ID FROM dbo_Parts_Listing"
    rs.Open
    If Not rs.EOF Then
        rtn = rs("ID")
    Else
        rtn = "0"
    End If
    lastPartId = rtn
End Function

Private Function cleanPart(inPart As String) As String
    Dim parseString() As String
    Dim rtn As String
    
    parseString = Split(inPart, " ")
    rtn = parseString(0)
    cleanPart = rtn
End Function

Private Function cleanSql(inString As String) As String
    Dim rtn As String
    
    rtn = Replace(inString, "'", "''")
    cleanSql = rtn

End Function

Private Sub Command1_Click()
    Dim test As String
    test = "asdf:23432:asdf (replaces asdf9ern3k4j9234k98293804)"
    MsgBox Left(test, 5)
    
End Sub

Open in new window

0
ronayers
Asked:
ronayers
  • 5
  • 3
  • 2
2 Solutions
 
peter57rCommented:
I have only skimmed over the code but i suspect the problems do not lie in the code as such but in your connection to the database.
There is nothing in the code which shows how the connection is being made, so we need that information.

0
 
ronayersAuthor Commented:
Its through a System ODBC connection to local host using the default settings.
0
 
peter57rCommented:
When you test the odbc connection  (from the same machine you have the Access problem on) does it work OK?

Did you ever use the application succesfully before this code was added?

Can you succesfully open the tables used in this code just by double clicking them?

(dbo_Mozenda, dbo_Year, dbo_Model, dbo_Parts_Group, dbo_Parts_Listing, are what I can see)

Does the code halt at a specific line when you get the error?
0
NFR key for Veeam Backup for Microsoft Office 365

Veeam is happy to provide a free NFR license (for 1 year, up to 10 users). This license allows for the non‑production use of Veeam Backup for Microsoft Office 365 in your home lab without any feature limitations.

 
ronayersAuthor Commented:
The ODBC connection tests successfully. I didn't have an application within access before the developer built the code but i've always been able to use this same access db to connect with all those tables. The debugger shows that it will stop on the "rs.Open" portion of the functions. It mostly stops on the getmodelid function but I've also seen it stop on getyearid as well. Thanks for your help!
0
 
peter57rCommented:
Your setup is not something I can replicate. I am still inclined to feel that the code itself is not the issue here although I can't rule that out.  The variable debug lines that you get might even suggest a data problem although if you can view the tables OK by double-clicking them that steers me away from that cause.
I've requested others to take a look.

0
 
ronayersAuthor Commented:
Thanks for your help peter57r.
0
 
Surone1Commented:
if i help fix this do split points with peter, since without him i would not have gotten to this question.
first of all 2 pages mention said errors:

http://tutorials.aspfaq.com/8000xxxxx-errors/80004005-errors.html
http://tutorials.aspfaq.com/8000xxxxx-errors/why-do-i-get-80040e21-errors.html

that is a lot of reasons, so why not add some error handling?


Private Function cleanPart(inPart As String) As String
    Dim parseString() As String
    Dim rtn As String
    on error goto hell
    parseString = Split(inPart, " ")
    rtn = parseString(0)
    cleanPart = rtn
End Function

Private Function cleanSql(inString As String) As String
    Dim rtn As String
   
    rtn = Replace(inString, "'", "''")
    cleanSql = rtn

End Function

Private Sub Command1_Click()
    Dim test As String
    test = "asdf:23432:asdf (replaces asdf9ern3k4j9234k98293804)"
    MsgBox Left(test, 5)
    exit sub
    hell:
MsgBox Err.Description & vbCrLf & Err.Source & vbCrLf & Err.Number
End Sub
0
 
ronayersAuthor Commented:
Sure surone1, if you want to split the points, thats not a problem. I've forwarded this on to the original developer who is also currently battling the issue.

Thanks, I will be in touch.
0
 
Surone1Commented:
well i would need to help first, having the original developer work on it is a plus. but an error description would probably speed things up a bit
0
 
ronayersAuthor Commented:
Thanks for the help, seems the developer figured it out.
0

Featured Post

Microsoft Certification Exam 74-409

Veeam® is happy to provide the Microsoft community with a study guide prepared by MVP and MCT, Orin Thomas. This guide will take you through each of the exam objectives, helping you to prepare for and pass the examination.

  • 5
  • 3
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now