- Before starting, ensure you check this
- Tools > References > Check the checkbox in front of "Microsoft ActiveX Data Objects 2.5 Library"
'---------------------------------------------------------------------------------------------------
Option Explicit
Private Function GetCurrCost() As String
Dim cn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim cmd As New ADODB.Command
Dim SqlStr As String
Dim TheCost As Currency, ThePrice As Currency
On Error GoTo GetCurrCost_Err
'Retrieve an ADO connection for the current user
Set cn = UserInfoGet.CreateADOConnection()
'Set the connection properties
cn.CursorLocation = adUseClient
'Set the current database, using the IntercompanyID property
cn.DefaultDatabase = UserInfoGet.IntercompanyID
SqlStr = ""
'Create a command to select result
cmd.ActiveConnection = cn
cmd.CommandType = adCmdText
'Get Current Cost
SqlStr = " select top 1 CURRCOST from dbo.IV00101 where ITEMNMBR = '" + ItemNumber + "'"
cmd.CommandText = SqlStr
Set rst = cmd.Execute
'Display the rows retrieved
' MsgBox ">>" + rst!ResultText
TheCost = rst!CURRCOST
'--------------------------------------------------------------------
'Get BasePrice
SqlStr = " select top 1 Price from dbo.BI_ExtPrc_BasePrices where ITEMNMBR = '" + ItemNumber
SqlStr = SqlStr + "' and UofM = '" + BaseUofM + "'"
cmd.CommandText = SqlStr
Set rst = cmd.Execute
ThePrice = rst!Price
'Close connection
cn.Close
'Write results
StringM18 = TheCost
StringM17 = ThePrice
Exit Function
GetCurrCost_Err:
Select Case Err.Number
Case 91
'Object variable or With block variable not set (Error 91)
'MsgBox "Error 91:" + Str(Err.Number) + "<" + Err.Description + ">"
Resume
Case Else
'MsgBox "Unknown Error:" + Str(Err.Number) + "<" + Err.Description + ">"
Exit Function
End Select
End Function
Private Function GetBasePrice() As String
Dim cn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim cmd As New ADODB.Command
Dim SqlStr
On Error GoTo GetBasePrice_Err
'Retrieve an ADO connection for the current user
Set cn = UserInfoGet.CreateADOConnection()
'Set the connection properties
cn.CursorLocation = adUseClient
'Set the current database, using the IntercompanyID property
cn.DefaultDatabase = UserInfoGet.IntercompanyID
SqlStr = ""
'--------------------------------------------------------------------
'Get BasePrice
SqlStr = " select top 1 Price from dbo.BI_ExtPrc_BasePrices where (ITEMNMBR = '" + ItemNumber
SqlStr = SqlStr + "') and UofM = ('" + BaseUofM + "')"
cmd.CommandText = SqlStr
Set rst = cmd.Execute
'Display the rows retrieved
' MsgBox ">>" + rst!ResultText
StringM17 = rst!Price
'Close the connection
cn.Close
Exit Function
GetBasePrice_Err:
Select Case Err.Number
Case 91
'Object variable or With block variable not set (Error 91)
'MsgBox "Error 91:" + Str(Err.Number) + "<" + Err.Description + ">"
Resume
Case Else
'MsgBox "Unknown Error:" + Str(Err.Number) + "<" + Err.Description + ">"
Exit Function
End Select
End Function
Private Function GETRunningUser(ByVal request As String) As String
Dim UserInfoObj As UserInfo
Dim CompanyName As String
Dim IntercompanyID As String
Dim SystemDatabase As String
Dim UserDate As Date
Dim UserID As String
Dim UserName As String
'Get the UserInfo object
Set UserInfoObj = VbaGlobal.UserInfoGet()
'Retrieve and display the UserInfo
Select Case request
Case "CompanyName"
GETRunningUser = UserInfoObj.CompanyName
Case "IntercompanyID"
GETRunningUser = UserInfoObj.IntercompanyID
Case "SystemDatabaseName"
GETRunningUser = UserInfoObj.SystemDatabaseName
Case "UserDate"
GETRunningUser = UserInfoObj.UserDate
Case "UserID"
GETRunningUser = UserInfoObj.UserID
Case "UserName"
GETRunningUser = UserInfoObj.UserName
Case Else
GETRunningUser = ""
End Select
End Function
Private Sub UpdateScreen()
StringM17 = 0
StringM18 = 0
If ItemNumber > "" Then
GetCurrCost
End If
End Sub
Private Sub EndofFileButtonToolbar_AfterUserChanged()
UpdateScreen
End Sub
Private Sub ItemNumber_Changed()
UpdateScreen
End Sub
Private Sub NextButtonToolbar_AfterUserChanged()
UpdateScreen
End Sub
Private Sub PreviousButtonToolbar_AfterUserChanged()
UpdateScreen
End Sub
Private Sub TopofFileButtonToolbar_AfterUserChanged()
UpdateScreen
End Sub
Private Sub Window_BeforeOpen(OpenVisible As Boolean)
End Sub
