'Let all currency fields be text. VB does not populate the values into currency fields correctly.
'Global Declares
Option Explicit
'Connection objects
Dim cn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim cmd As New ADODB.Command
'
Dim UID As String
Dim sqlstring As String
Private Sub Report_BeforeAH(ByVal Level As Integer, SuppressBand As Boolean)
Dim z
On Error GoTo Report_BeforeBody_Error
UID = UserInfoGet.UserID
sqlstring = ""
sqlstring = sqlstring & " SELECT TAXAMNT FROM POP10110 WHERE (PONUMBER = '" & PONumber & "') AND (ORD = " & Ord & ");"
cmd.CommandType = adCmdText
cmd.CommandText = sqlstring
Set rst = cmd.Execute
If Not (rst.EOF And rst.BOF) Then
' UserID = rst!UserID
' EMPLOYID = rst!EMPLOYID
xVat = Format(rst!TaxAmnt, "$#,##0.00;($#,##0.00)")
' xVat = rst!TaxAmnt
End If
Exit Sub
Report_BeforeBody_Error:
MsgBox "Report_BeforeBody Error:>" + Str(Err)
Select Case Err.Number
Case 3704
' object closed
z = ExecuteOpen
Resume
Case Else
MsgBox "Unknown Error:" + Str(Err.Number) + "<" + Err.Description + ">"
Exit Sub
End Select
End Sub
Private Sub Report_BeforeRH(SuppressBand As Boolean)
Dim z
On Error GoTo Report_BeforeBody_Error
'---------------------------------------------------------------------------------------------------------
' Get Location Address Info
UID = UserInfoGet.UserID
sqlstring = ""
sqlstring = sqlstring & " SELECT TOP 1 POP10110.PONUMBER, IV40700.ADDRESS1, IV40700.ADDRESS2, IV40700.ADDRESS3, IV40700.CITY, IV40700.STATE, IV40700.LOCNCODE, IV40700.LOCNDSCR"
sqlstring = sqlstring & " FROM POP10110 INNER JOIN "
sqlstring = sqlstring & " IV40700 ON POP10110.LOCNCODE = IV40700.LOCNCODE WHERE (POP10110.PONUMBER = '" & PONumber & "');"
cmd.CommandType = adCmdText
cmd.CommandText = sqlstring
Set rst = cmd.Execute
If Not (rst.EOF And rst.BOF) Then
' UserID = rst!UserID
' EMPLOYID = rst!EMPLOYID
' xVat = Format(rst!TaxAmnt, "$#,##0.00;($#,##0.00)")
xLocShipToAdd1 = rst!Address1
xLocShipToAdd2 = rst!Address2
xLocShipToAdd3 = rst!Address3
xLocShipToAdd4 = rst!City
xLocShipToAdd5 = rst!State
xLocShipToSite = rst!Locncode
xLocShipToSiteDesc = Trim(rst!Locncode) + " " + rst!Locndscr
End If
Exit Sub
Report_BeforeBody_Error:
MsgBox "Report_BeforeBody Error:>" + Str(Err)
Select Case Err.Number
Case 3704
' object closed
z = ExecuteOpen
Resume
Case Else
MsgBox "Unknown Error:" + Str(Err.Number) + "<" + Err.Description + ">"
Exit Sub
End Select
End Sub
'
Private Sub Report_Start()
Dim z
z = ExecuteOpen
End Sub
'
Private Sub Report_End()
Dim z
z = ExecuteClose()
End Sub
'
Function ExecuteOpen() As Boolean
On Error GoTo ExecuteOpen_Error
'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
'Create a command to select all records
cmd.ActiveConnection = cn
'report open status
ExecuteOpen = True
Exit Function
ExecuteOpen_Error:
MsgBox "ExecuteOpen Error:>" + Str(Err)
ExecuteOpen = False
'Close the connection
cn.Close
End Function
'
Function ExecuteClose() As Boolean
On Error GoTo ExecuteClose_Error
'Close the recordset and connection objects
If rst.State = adStateOpen Then rst.Close
If cn.State = adStateOpen Then cn.Close
ExecuteClose_Error:
Set rst = Nothing
Set cn = Nothing
Set cmd = Nothing
End Function
No comments:
Post a Comment