Experts Exchange connects you with the people and services you need so you can get back to work.
Improve company productivity with a Business Account.Sign Up
'Retrieves the engineering part description and puts it into a messagebox.
Dim db As Object, rs As Object
Dim s As String, sDesc As String, sSQL As String
Dim i As Long
'sPartNumber = ActiveCell.Value 'I was triggering the code by right-clicking a cell containing the part number
sPartNumber = InputBox("Please enter the desired part number") 'Display a screen allowing the user to enter the part number
Set db = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
db.Open "Provider=IBMDA400;Data Source=AS400PRDEXEC;", "DPAPPSERV", "DPAPPSERV"
If Err <> 0 Then
s = "Could not retrieve description from AS/400. If you dropped your connection momentarily," & vbLf & _
"please wait 30 seconds and try again." & vbLf & vbLf & _
"Click 'Yes' if you still want to see the cutsheet."
Else 'Build a SQL string using the partnumber to retrieve the engineering description
sSQL = "SELECT IM.IMDSC, ED.REEDSC FROM SIM400MFG.FKITMSTR IM" _
& " LEFT JOIN SIM400MFG.FKITEXTD ED ON IM.IMCO=ED.IMCO AND IM.IMPN=ED.IMPN" _
& " WHERE IM.IMCO=1 AND IM.IMPN='" & sPartNumber & "'"
rs.Open sSQL, db, 3, 3 'Last two parameters are integer values of constants adOpenStatic & adLockOptimistic
If Not (rs.BOF And rs.EOF) Then
s = sPartNumber & vbLf & .Fields("IMDSC") & vbLf
For i = 1 To 100 'Allow up to 100 lines in the engineering description
If .EOF Then Exit For
s = s & .Fields("REEDSC") & vbLf
Open in new window
Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.
Have a better answer? Share it in a comment.
Please enter a first name
Please enter a last name
Must be at least 4 characters long.
Join and Comment
From novice to tech pro — start learning today.
Premium members can enroll in this course at no extra cost.