Solved

80040e21 and 80004005 Run-time Errors

Posted on 2010-09-12
10
2,374 Views
Last Modified: 2012-05-10
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
Comment
Question by:ronayers
  • 5
  • 3
  • 2
10 Comments
 
LVL 77

Expert Comment

by:peter57r
ID: 33660324
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
 

Author Comment

by:ronayers
ID: 33660333
Its through a System ODBC connection to local host using the default settings.
0
 
LVL 77

Expert Comment

by:peter57r
ID: 33660431
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
What is SQL Server and how does it work?

The purpose of this paper is to provide you background on SQL Server. It’s your self-study guide for learning fundamentals. It includes both the history of SQL and its technical basics. Concepts and definitions will form the solid foundation of your future DBA expertise.

 

Author Comment

by:ronayers
ID: 33660711
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
 
LVL 77

Assisted Solution

by:peter57r
peter57r earned 250 total points
ID: 33661652
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
 

Author Comment

by:ronayers
ID: 33665038
Thanks for your help peter57r.
0
 
LVL 13

Accepted Solution

by:
Surone1 earned 250 total points
ID: 33677502
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
 

Author Comment

by:ronayers
ID: 33680394
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
 
LVL 13

Expert Comment

by:Surone1
ID: 33681019
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
 

Author Closing Comment

by:ronayers
ID: 33825812
Thanks for the help, seems the developer figured it out.
0

Featured Post

Master Your Team's Linux and Cloud Stack!

The average business loses $13.5M per year to ineffective training (per 1,000 employees). Keep ahead of the competition and combine in-person quality with online cost and flexibility by training with Linux Academy.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

A long time ago (May 2011), I have written an article showing you how to create a DLL using Visual Studio 2005 to be hosted in SQL Server 2005. That was valid at that time and it is still valid if you are still using these versions. You can still re…
Load balancing is the method of dividing the total amount of work performed by one computer between two or more computers. Its aim is to get more work done in the same amount of time, ensuring that all the users get served faster.
Learn how to number pages in an Access report over each group. Activate two pass printing by referencing the pages property: Add code to the Page Footers OnFormat event to capture the pages as there occur for each group. Use the pages property to …
With Secure Portal Encryption, the recipient is sent a link to their email address directing them to the email laundry delivery page. From there, the recipient will be required to enter a user name and password to enter the page. Once the recipient …

808 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question