[RESOLVED] Application Hang Category: (101) Event ID: 1002-VBForums
Results 1 to 7 of 7

Thread: [RESOLVED] Application Hang Category: (101) Event ID: 1002

  1. #1

    Thread Starter
    New Member
    Join Date
    May 2012
    Posts
    6

    Resolved [RESOLVED] Application Hang Category: (101) Event ID: 1002

    I have an application written in VB5, VB6, C++, etc.. the application stores data on a remote server in a Microsoft Access database. The software runs fine on the server where we have the main database files as opposed to the mover files on the separate data entry stations but hangs when you drill down to the frmOrder (source code below) on one of the data entry stations. I tried using Dbgview with no luck (may be the XP operating system on the data entry machine). Can't figure out what is causing the exception that is stopping the program. I compared a good database file vs the "bad" files to see if I could spot an invalid or corrupt record...or even something that I didn't allow for being in one of the fields, but didn't have any luck though it's been running for a long time for something like that to show up now. The data integrity looks good to say the least.

  2. #2

    Thread Starter
    New Member
    Join Date
    May 2012
    Posts
    6

    Re: Application Hang Category: (101) Event ID: 1002

    Source code from frmOrder:
    Code:
    Option Explicit
    'I sure would have done this a lot different if ADO had existed when I wrote it
    
    Public fInmate As frmInmateSelect
    Dim Updated As Boolean
    Dim LastRow As Long
    Dim Busy As Boolean
    Public NewBalance As Currency
    Public SubTotal As Currency
    Public Tax As Currency
    Public Total As Currency
    Private QuickActive As Boolean
    Private OrderID As Long
    Private TransactionID As Long
    Private UsingQuickFind As Boolean
    Private ValidEntry As Boolean
    Private PostedTransactionsTotal As Currency
    Private PostedTransactionsCount As Integer
    
    'used to flag that an order was open with invalid amounts to prevent repeated warning in entry screen
    Private LoadedWithInvalidAmounts As Boolean
    
    Private MaxOrderExemptCategories As String
    Private MaxOrderExemptLimit As Currency
    Private MaxOrderExemptAmount As Currency
    
    Private CatLimits As COrderLimitCategories
    
    Private Sub SetControls()
        Dim m As Variant
    
        On Error Resume Next
        For Each m In Me.Controls
            If Len(m.tag) > 0 Then 'don't do nothing if tag not set
                If (CurrentUser.SecurityToken = "*") Or (Val(CurrentUser.SecurityToken) >= Val(m.tag)) Then
                    m.Visible = True
                    m.Enabled = True
                Else
                    m.Visible = False
                    m.Enabled = False
                End If
            End If
        Next
    End Sub
    
    Private Function SetOrderLimitedItems() As Boolean
        'read the grid, return true if any limit category is over allowed
        Dim row As Integer
        
        CatLimits.ClearAll
        With FGrid1
            For row = 0 To .rows - 1
                CatLimits.AddCount .TextMatrix(row, 9), Val(.TextMatrix(row, 10)) * Val(.TextMatrix(row, 0))
            Next
        End With
        SetOrderLimitedItems = CatLimits.Over
    End Function
    
    Private Function VerifyOrderAmounts() As Integer
        VerifyOrderAmounts = 0
        If NewBalance < CurrentSession.MinimumBalance Then
            VerifyOrderAmounts = 1
        ElseIf (Total - MaxOrderExemptAmount) > CurrentSession.MaximumOrder And CurrentSession.MaximumOrder > 0# Then
            VerifyOrderAmounts = 2
        ElseIf MaxOrderExemptAmount > MaxOrderExemptLimit Then
            VerifyOrderAmounts = 3
        ElseIf SetOrderLimitedItems Then
            VerifyOrderAmounts = 4
        End If
    End Function
    
    Private Sub CommitOrder()
    'update account balance
    'make account transaction entry
    'add to order table(s)
    
        Dim row As Integer
        Dim col As Integer
        Dim s As String
        Dim posStart As Long
        Dim bal As Currency
        Dim c As Currency
        Dim d As Currency
    
        'set stuff in the order table
        dbOrder.Recordset.Edit
        If IsNull(dbOrder.Recordset.Fields("FirstEntryTime")) Then
            dbOrder.Recordset.Fields("FirstEntryTime") = Now
        End If
        dbOrder.Recordset.Fields("LastEntryTime") = Now
        dbOrder.Recordset.Fields("SalesTax") = CurrentLocation.SalesTax
        dbOrder.Recordset.Fields("Rebate") = CurrentLocation.Rebate
        dbOrder.Recordset.Update
    
        'make the new transaction if not one already there
        With dbAcntTrans.Recordset
            If TransactionID = -1 Then
                s = "SELECT Max(TransactionID) AS [Next] From AccountTransactions where " _
                    & "AccountId = '" & CurrentAccount.AccountID & "'" _
                    & " and LocationID = '" & CurrentLocation.LocationID & "'"
                dbTransID.RecordSource = s
                dbTransID.Refresh
                If IsNull(dbTransID.Recordset.Fields(0)) Then
                    TransactionID = 1
                Else
                    TransactionID = dbTransID.Recordset.Fields(0) + 1
                End If
                s = "SELECT * From AccountTransactions where " _
                    & " AccountId = '" & CurrentAccount.AccountID & "'" _
                    & " and LocationID = '" & CurrentLocation.LocationID & "'"
                dbAcntTrans.RecordSource = s
                dbAcntTrans.Refresh
                .AddNew
                .Fields("TransactionID") = TransactionID
                .Fields("TransactionCode") = "Commissary Order"
                .Fields("AccountID") = CurrentAccount.AccountID
                .Fields("DateTime") = Now
                .Fields("Description") = "Commissary Order #" & Str$(OrderID)
                .Fields("LocationID") = CurrentLocation.LocationID
                .Update
                s = "SELECT * From AccountTransactions where " _
                    & " AccountId = '" & CurrentAccount.AccountID & "'" _
                    & " and TransactionID = " & Str$(TransactionID) _
                    & " and LocationID = '" & CurrentLocation.LocationID & "'"
                dbAcntTrans.RecordSource = s
                dbAcntTrans.Refresh
            End If
        End With
    
        'delete items already in database
        s = "Select * from Items where " _
            & " LocationID = '" & CurrentLocation.LocationID & "' and" _
            & " AccountID = '" & CurrentAccount.AccountID & "' and" _
            & " OrderID = " & Str$(OrderID)
        dbItem.RecordSource = s
        dbItem.Refresh
        With dbItem.Recordset
            If Not .EOF Then ' then this is edit, not new
                .MoveFirst
                While Not .EOF
                    .Delete
                    .MoveNext
                Wend
            End If
        End With
    
        'scan the form and put into item records
        Debug.Print "Order for: "; CurrentAccount.FirstName; " "; CurrentAccount.MiddleName; " "; CurrentAccount.LastName
        With FGrid1
            For row = 0 To .rows - 1
                If Val(.TextMatrix(row, 0)) > 0 Then
                    For col = 0 To .Cols - 1
                        Debug.Print .TextMatrix(row, col); ",";
                    Next
                    Debug.Print
                    With dbItem.Recordset
                        .AddNew
                        .Fields("OrderID") = OrderID
                        .Fields("LocationID") = CurrentLocation.LocationID
                        .Fields("AccountID") = CurrentAccount.AccountID
                        .Fields("TransactionID") = TransactionID
                        .Fields("ProductID") = FGrid1.TextMatrix(row, 1)
                        .Fields("Description") = FGrid1.TextMatrix(row, 2)
                        .Fields("Quantity") = Val(FGrid1.TextMatrix(row, 0))
                        .Fields("Price") = Val(FGrid1.TextMatrix(row, 3))
                        .Fields("Cost") = Val(FGrid1.TextMatrix(row, 8))
                        .Fields("Taxrate") = Val(FGrid1.TextMatrix(row, 5))
                        .Fields("Rebate") = Val(FGrid1.TextMatrix(row, 6))
                        .Update
                    End With
                End If
            Next
            Debug.Print "SubTotal:", Format(SubTotal, "0.00")
            Debug.Print "     Tax:", Format(Tax, "0.00")
            Debug.Print "   Total:", Format(Total, "0.00")
            Debug.Print " Balance:", Format(NewBalance, "0.00")
        End With
    
        'update the transaction
        dbAcntTrans.Recordset.Edit
        dbAcntTrans.Recordset.Fields("Debit") = Total
        dbAcntTrans.Recordset.Update
    
        'update account balance
        CurrentAccount.CurrentBalance = RndCur(CurrentAccount.CurrentBalance) - Total
        fInmate.UserRecord.Edit
        fInmate.UserRecord.Fields("CurrentBalance") = CurrentAccount.CurrentBalance
        fInmate.UserRecord.Update
    
        datCalc.Refresh
        With datCalc.Recordset
            posStart = dbAcntTrans.Recordset.AbsolutePosition - 1
            If posStart < 5 Then
                bal = 0#
                .MoveFirst
            Else
                .AbsolutePosition = posStart
                bal = RndCur(.Fields("Balance"))
                .MoveNext
            End If
            While Not .EOF
                If IsNull(.Fields("Credit")) Then
                    c = 0
                Else
                    c = .Fields("Credit")
                End If
                If IsNull(.Fields("Debit")) Then
                    d = 0
                Else
                    d = .Fields("Debit")
                End If
                bal = bal + RndCur(c)
                bal = bal - RndCur(d)
                .Edit
                .Fields("Balance") = bal
                .Update
                .MoveNext
            Wend
        End With
    End Sub
    
    
    Private Sub MoveTextBox()
        On Error Resume Next
        With FGrid1
            If .RowIsVisible(.row) And .RowIsVisible(.row + 1) Then
                Text1.Left = .CellLeft + FGrid1.Left
                Text1.Top = .CellTop + FGrid1.Top
                Text1.Height = .CellHeight
                Text1.Width = .CellWidth
                Text1.Visible = True
                Text1.SetFocus
           Else
                Text1.Visible = False
            End If
        End With
    End Sub
    
    Private Sub NextRow()
        Dim row As Long
    
        On Error Resume Next
        With FGrid1
            row = .row + 1
            If row < .rows Then
                .row = row
            End If
            If Not .RowIsVisible(row + 1) Then
                .TopRow = .TopRow + 1
            End If
        End With
    End Sub
    Last edited by si_the_geek; May 16th, 2012 at 03:15 PM. Reason: added Code tags

  3. #3

    Thread Starter
    New Member
    Join Date
    May 2012
    Posts
    6

    Re: Application Hang Category: (101) Event ID: 1002

    Private Sub PrevRow()
    Dim row As Long
    row = FGrid1.row - 1
    If row > FGrid1.FixedRows Then
    FGrid1.row = row
    End If
    If Not FGrid1.RowIsVisible(row) Then
    FGrid1.TopRow = row
    End If
    End Sub

    Private Sub UpdateRow(row As Long)
    Dim oldprice As Currency
    Dim newprice As Currency
    Dim sh As String
    Dim tmpNewBalance As Currency
    Dim tmpSubTotal As Currency
    Dim tmpMaxOrderExemptAmount As Currency
    Dim tmpTax As Currency
    Dim tmpTotal As Currency
    Dim IsExempt As Boolean

    Debug.Print "UpdateRow"
    On Error Resume Next
    ValidEntry = True
    With FGrid1
    IsExempt = (0 < Len(Intersect(MaxOrderExemptCategories, .TextMatrix(row, 9))))
    oldprice = Val(.TextMatrix(row, 4))
    newprice = Val(.TextMatrix(row, 0)) * Val(.TextMatrix(row, 3))
    If oldprice <> newprice Then
    sh = Intersect(CurrentAccount.SpecialHandling, .TextMatrix(row, 7))
    If Len(sh) > 0 Then
    If Not (MsgBox("Special handling conflict: " & sh & vbCrLf & "Allow item anyway?", vbYesNo) = vbYes) Then
    .TextMatrix(row, 0) = ""
    newprice = 0#
    ValidEntry = False
    End If
    End If
    End If
    If newprice > 0 Then
    .TextMatrix(row, 4) = Format(newprice, "0.00")
    Else
    .TextMatrix(row, 4) = ""
    End If
    If IsExempt Then
    tmpMaxOrderExemptAmount = MaxOrderExemptAmount - oldprice - (CurrentLocation.SalesTax * Val(.TextMatrix(row, 5)) * oldprice) + newprice + (CurrentLocation.SalesTax * Val(.TextMatrix(row, 5)) * newprice)
    Else
    tmpMaxOrderExemptAmount = MaxOrderExemptAmount
    End If
    tmpSubTotal = SubTotal - oldprice + newprice
    tmpTax = Tax - (CurrentLocation.SalesTax * Val(.TextMatrix(row, 5)) * oldprice)
    tmpTax = tmpTax + (CurrentLocation.SalesTax * Val(.TextMatrix(row, 5)) * newprice)
    tmpTotal = RndCur(tmpSubTotal) + RndCur(tmpTax)
    tmpNewBalance = RndCur(CurrentAccount.CurrentBalance) - tmpTotal
    If (Not LoadedWithInvalidAmounts) And (tmpNewBalance < CurrentSession.MinimumBalance) Then
    .TextMatrix(row, 0) = ""
    .TextMatrix(row, 4) = ""
    Text1.Text = ""
    newprice = 0#
    If oldprice <> 0 Then
    If IsExempt Then
    MaxOrderExemptAmount = MaxOrderExemptAmount - oldprice - (CurrentLocation.SalesTax * Val(.TextMatrix(row, 5)) * oldprice)
    End If
    SubTotal = SubTotal - oldprice
    Tax = Tax - (CurrentLocation.SalesTax * Val(.TextMatrix(row, 5)) * oldprice)
    Total = RndCur(tmpSubTotal) + RndCur(tmpTax)
    NewBalance = RndCur(CurrentAccount.CurrentBalance) - tmpTotal
    End If
    MsgBox "Resulting balance of " & Format(tmpNewBalance, "$0.00") & vbCrLf & " falls below minimum allowed balance of " & Format(CurrentSession.MinimumBalance, "$0.00"), vbCritical
    ValidEntry = False
    FGrid1.SetFocus
    ElseIf (Not LoadedWithInvalidAmounts) And (((tmpTotal - tmpMaxOrderExemptAmount) > CurrentSession.MaximumOrder) And (CurrentSession.MaximumOrder > 0#)) Then
    .TextMatrix(row, 0) = ""
    .TextMatrix(row, 4) = ""
    Text1.Text = ""
    newprice = 0#
    If oldprice <> 0 Then
    If IsExempt Then
    MaxOrderExemptAmount = MaxOrderExemptAmount - oldprice - (CurrentLocation.SalesTax * Val(.TextMatrix(row, 5)) * oldprice)
    End If
    SubTotal = SubTotal - oldprice
    Tax = Tax - (CurrentLocation.SalesTax * Val(.TextMatrix(row, 5)) * oldprice)
    Total = RndCur(tmpSubTotal) + RndCur(tmpTax)
    NewBalance = RndCur(CurrentAccount.CurrentBalance) - tmpTotal
    End If
    MsgBox "Order amount of " & Format(tmpTotal, "$0.00") & vbCrLf & "exceeds maximum allowed order of " & Format(CurrentSession.MaximumOrder, "$0.00"), vbCritical
    ValidEntry = False
    FGrid1.SetFocus
    ElseIf (Not LoadedWithInvalidAmounts) And (tmpMaxOrderExemptAmount > MaxOrderExemptLimit) Then
    .TextMatrix(row, 0) = ""
    .TextMatrix(row, 4) = ""
    Text1.Text = ""
    newprice = 0#
    If oldprice <> 0 Then
    If IsExempt Then
    MaxOrderExemptAmount = MaxOrderExemptAmount - oldprice - (CurrentLocation.SalesTax * Val(.TextMatrix(row, 5)) * oldprice)
    End If
    SubTotal = SubTotal - oldprice
    Tax = Tax - (CurrentLocation.SalesTax * Val(.TextMatrix(row, 5)) * oldprice)
    Total = RndCur(tmpSubTotal) + RndCur(tmpTax)
    NewBalance = RndCur(CurrentAccount.CurrentBalance) - tmpTotal
    End If
    MsgBox "Exeeds maximum exempt order item amount", vbCritical
    ValidEntry = False
    FGrid1.SetFocus
    'ElseIf (Not LoadedWithInvalidAmounts) And CatLimits.AddCount(.TextMatrix(row, 9), Val(.TextMatrix(row, 10)) * Val(.TextMatrix(row, 0))) Then
    ElseIf (Not LoadedWithInvalidAmounts) And SetOrderLimitedItems Then
    .TextMatrix(row, 0) = ""
    .TextMatrix(row, 4) = ""
    Text1.Text = ""
    newprice = 0#
    If oldprice <> 0 Then
    If IsExempt Then
    MaxOrderExemptAmount = MaxOrderExemptAmount - oldprice - (CurrentLocation.SalesTax * Val(.TextMatrix(row, 5)) * oldprice)
    End If
    SubTotal = SubTotal - oldprice
    Tax = Tax - (CurrentLocation.SalesTax * Val(.TextMatrix(row, 5)) * oldprice)
    Total = RndCur(tmpSubTotal) + RndCur(tmpTax)
    NewBalance = RndCur(CurrentAccount.CurrentBalance) - tmpTotal
    End If
    MsgBox "Maximum number of limited items exceeded", vbCritical
    ValidEntry = False
    FGrid1.SetFocus
    Else
    If IsExempt Then
    MaxOrderExemptAmount = tmpMaxOrderExemptAmount
    End If
    SubTotal = tmpSubTotal
    Tax = tmpTax
    Total = tmpTotal
    NewBalance = tmpNewBalance
    lblSub.Caption = Format(SubTotal, "$0.00")
    lblTax.Caption = Format(Tax, "$0.00")
    lblTotal.Caption = Format(Total, "$0.00")
    lblEndBal.Caption = Format(NewBalance, "$0.00")
    End If
    End With
    Debug.Print "Subtotal: " & Format(SubTotal, "$0.00") & "ExemptAmount: " & Format(MaxOrderExemptAmount, "$0.00")
    End Sub

    Private Sub btnCancel_Click()
    Dim s As String

    If SubTotal <> 0# Then
    If MsgBox("Are you sure you wish to cancel the items on this order?", vbYesNo) <> vbYes Then
    Exit Sub
    End If
    End If

    With dbAcntTrans
    If TransactionID <> -1 Then
    s = "SELECT * From AccountTransactions where " _
    & " AccountId = '" & CurrentAccount.AccountID & "'" _
    & " and TRansactionID = " & Str$(TransactionID) _
    & " and LocationID = '" & CurrentLocation.LocationID & "'"
    .RecordSource = s
    .Refresh
    .Recordset.Delete
    .Recordset.MoveNext
    End If
    End With
    Me.Hide
    End Sub

    Private Sub btnCheck_Click()
    Dim f As New frmCheck

    Set f = New frmCheck
    Set f.RSInmate = fInmate.UserRecord
    f.TransactionID = 0
    f.Show vbModal, Me
    lblBegBal.Caption = Format(CurrentAccount.CurrentBalance, "$0.00")
    lblEndBal.Caption = Format(CCur(lblBegBal.Caption) - CCur(lblTotal.Caption), "$0.00")
    End Sub

  4. #4

    Thread Starter
    New Member
    Join Date
    May 2012
    Posts
    6

    Re: Application Hang Category: (101) Event ID: 1002

    Private Sub btnOK_Click()
    Dim voa As Integer

    voa = VerifyOrderAmounts()
    Select Case True
    Case 0 = voa
    CommitOrder
    Me.Hide
    Case 1 = voa
    MsgBox "Resulting balance of " & Format(NewBalance, "$0.00") & vbCrLf & " falls below minimum allowed balance of " & Format(CurrentSession.MinimumBalance, "$0.00"), vbCritical
    Case 2 = voa
    MsgBox "Order amount of " & Format(Total, "$0.00") & vbCrLf & "exceeds maximum allowed order of " & Format(CurrentSession.MaximumOrder, "$0.00"), vbCritical
    Case 3 = voa
    MsgBox "Exeeds maximum exempt order item amount", vbCritical
    Case 4 = voa
    MsgBox "Maximum number of limited items exceeded", vbCritical
    End Select
    End Sub

    Private Sub Check1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Check1.Value = vbUnchecked Then
    FGrid1.SetFocus
    ElseIf Check1.Value = vbChecked Then
    txtQuickFind.SetFocus
    End If
    End Sub

    Private Sub FGrid1_EnterCell()
    MoveTextBox
    Text1.Text = FGrid1.Text
    Text1.SelStart = 0
    Text1.SelLength = 99
    Debug.Print "Enter Cell", FGrid1.row
    End Sub

    Private Sub FGrid1_GotFocus()
    MoveTextBox
    End Sub

    Private Sub FGrid1_LeaveCell()
    If Busy Then Exit Sub
    FGrid1.Text = Text1.Text
    UpdateRow FGrid1.row
    Debug.Print "Leave Cell", FGrid1.row
    End Sub

    Private Sub FGrid1_RowColChange()
    If Busy Then Exit Sub
    Busy = True
    With FGrid1
    .col = 0
    If .TextMatrix(.row, 0&) = "----" Then
    Busy = False
    If .row > LastRow Or .row = .FixedRows Then
    NextRow
    ElseIf .row < LastRow Then
    PrevRow
    End If
    DoEvents
    Exit Sub
    End If
    .RowSel = .row
    .ColSel = .Cols - 1
    LastRow = .row
    End With
    'Text1.SelStart = 0
    'Text1.SelLength = 99
    Busy = False
    Debug.Print "RowCol Change"
    End Sub

    Private Sub FGrid1_Scroll()
    With FGrid1
    MoveTextBox
    Debug.Print .RowIsVisible(.row)
    End With
    End Sub

    Private Sub FGrid1_SelChange()
    With FGrid1
    Debug.Print "SelChange", .row, .col, .RowSel, .ColSel
    ' .RowSel = .row
    ' .ColSel = .Cols - 1
    End With
    End Sub

    Private Sub Form_GotFocus()
    Debug.Print "Form_GotFocus"
    MoveTextBox
    End Sub

    Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Dim rows As Long
    Dim NewRow As Long

    With FGrid1
    Debug.Print "Form_KeyDown "; KeyCode, Shift
    If KeyCode = 40 Then
    NextRow
    KeyCode = 0
    ElseIf KeyCode = 38 Then
    PrevRow
    KeyCode = 0
    ElseIf KeyCode = 33 Then 'page up
    rows = .Height \ (.RowPos(2) - .RowPos(1)) - 2
    NewRow = .row - rows
    If NewRow < .FixedRows Then
    NewRow = .FixedRows
    End If
    .row = NewRow
    .TopRow = NewRow
    ElseIf KeyCode = 34 Then 'page down
    rows = .Height \ (.RowPos(2) - .RowPos(1)) - 2
    NewRow = .row + rows
    If NewRow >= .rows Then
    NewRow = .rows - 1
    End If
    .row = NewRow
    .TopRow = NewRow
    End If
    End With
    End Sub

    Private Sub Form_KeyPress(KeyAscii As Integer)
    Debug.Print "Form_KeyPress "; KeyAscii
    If KeyAscii = 13 Then ' CR
    If Check1.Value = vbChecked Then
    If QuickActive Then
    QuickSel
    Else
    FGrid1.Text = Text1.Text
    UpdateRow FGrid1.row
    txtQuickFind.SetFocus
    End If
    Else
    'FGrid1.Text = Text1.Text
    'UpdateRow FGrid1.row
    NextRow
    End If
    KeyAscii = 0
    End If
    End Sub

    Private Sub Form_Load()
    Dim i As Integer
    Dim rtn As Long
    Dim s As String

    LogMessage "Screen Opened: " & Me.name
    Screen.MousePointer = vbHourglass
    Updated = False
    Busy = False
    LastRow = -1
    QuickActive = False
    TransactionID = -1
    OrderID = -1
    SubTotal = 0#
    MaxOrderExemptAmount = 0#
    Total = 0#
    Tax = 0#

    'set up for registery access
    SysReg.Root = HKEY_LOCAL_MACHINE
    SysReg.KeyPrefix = "SOFTWARE\......\" 'Romved KeyPrefix, but I know this is correct

    'get and validate screen position
    Dim tmp As Integer
    tmp = SysReg.GetSetting(Me.Caption, "Size", "Width", -1)
    If tmp > -1 Then Me.Width = tmp
    tmp = SysReg.GetSetting(Me.Caption, "Size", "Left", -1)
    If tmp > -1 Then Me.Left = tmp
    If Me.Left > Screen.Width - Me.Width Then
    Me.Left = Screen.Width - Me.Width
    ElseIf Me.Left < 0 Then
    Me.Left = 0
    End If
    tmp = SysReg.GetSetting(Me.Caption, "Size", "Height", -1)
    If tmp > -1 Then Me.Height = tmp
    tmp = SysReg.GetSetting(Me.Caption, "Size", "Top", -1)
    If tmp > -1 Then Me.Top = tmp
    If Me.Top > Screen.Height - Me.Height Then
    Me.Top = Screen.Height - Me.Height
    ElseIf Me.Top < 0 Then
    Me.Top = 0
    End If
    Me.WindowState = SysReg.GetSetting(Me.Caption, "Size", "State", vbNormal)
    Check1.Value = SysReg.GetSetting(Me.Caption, "Settings", "Quick Entry", 0)
    For i = 0 To FGrid1.Cols - 1
    rtn = SysReg.GetSetting(Me.Caption, "Size", "ColWidth" & Trim$(Str$(i)), -1)
    If rtn > 0 Then FGrid1.ColWidth(i) = rtn
    Next


    MaxOrderExemptCategories = SysReg.GetSetting("Program", "Settings", "MaxOrderExemptCategories", DefaultMaxOrderExemptCategories)
    MaxOrderExemptLimit = SysReg.GetSetting("Program", "Settings", "MaxOrderExemptLimit", DefaultMaxOrderExemptLimit)

    ' Set fInmate = New frmInmateSelect
    ' fInmate.Show vbModal
    Label1.Caption = CurrentAccount.FirstName & " " & CurrentAccount.MiddleName & " " & CurrentAccount.LastName

    FGrid1.ColAlignment(0) = flexAlignRightCenter
    FGrid1.ColAlignment(1) = flexAlignLeftCenter
    FGrid1.ColAlignment(2) = flexAlignRightCenter
    FGrid1.ColAlignment(3) = flexAlignRightCenter
    FGrid1.ColAlignment(4) = flexAlignRightCenter
    'invisible columns used as array elements
    FGrid1.ColWidth(5) = 0 'rebate
    FGrid1.ColWidth(6) = 0 'tax rate
    FGrid1.ColWidth(7) = 0 'special handling
    FGrid1.ColWidth(8) = 0 'cost
    FGrid1.ColWidth(9) = 0 'category
    FGrid1.ColWidth(10) = 0 'OnHand used for order limit counting
    FGrid1.ColWidth(11) = 0 'blank end

    FGrid1.TextMatrix(0, 0) = "Quantity"
    FGrid1.TextMatrix(0, 1) = "Item"
    FGrid1.TextMatrix(0, 2) = "Description"
    FGrid1.TextMatrix(0, 3) = "Each"
    FGrid1.TextMatrix(0, 4) = "Price"

    NewBalance = CurrentAccount.CurrentBalance

    'set database path and do all the crap needed to make that work
    On Error Resume Next
    With dbProduct
    .DatabaseName = SetDatabaseName(.DatabaseName, DatabasePath)
    .Refresh
    .Recordset.MoveFirst
    End With
    '
    With dbCat
    .DatabaseName = SetDatabaseName(.DatabaseName, DatabasePath)
    .Refresh
    .Recordset.MoveFirst
    End With
    '
    With dbOrder
    .DatabaseName = SetDatabaseName(.DatabaseName, DatabasePath)
    .Refresh
    .Recordset.MoveFirst
    End With
    '
    With dbItem
    .DatabaseName = SetDatabaseName(.DatabaseName, DatabasePath)
    .Refresh
    .Recordset.MoveFirst
    End With
    '
    With dbTransID
    .DatabaseName = SetDatabaseName(.DatabaseName, DatabasePath)
    .Refresh
    .Recordset.MoveFirst
    End With
    '
    With dbAcntTrans
    .DatabaseName = SetDatabaseName(.DatabaseName, DatabasePath)
    .Refresh
    .Recordset.MoveFirst
    End With
    '
    With datCalc
    .DatabaseName = SetDatabaseName(.DatabaseName, DatabasePath)
    s = Trim$(CurrentAccount.AccountID)
    s = "select Debit,Credit,Balance,AccountID,LocationID from AccountTransactions where AccountId = '" & s & "' and LocationID = '" & CurrentLocation.LocationID & "' Order by TransactionID"
    .RecordSource = s
    .Refresh
    .Recordset.MoveFirst
    End With

    With dbPostQ
    .DatabaseName = SetDatabaseName(.DatabaseName, DatabasePath)
    s = "SELECT * from Postings where [AccountID] = '" & CurrentAccount.AccountID & "' and [Posted] = 0 and [LocationID] = '" & CurrentLocation.LocationID & "' order by AccountName, EntryDate"
    .RecordSource = s
    .Refresh
    With .Recordset
    PostedTransactionsTotal = 0
    PostedTransactionsCount = 0
    .MoveFirst
    While Not .EOF
    PostedTransactionsCount = PostedTransactionsCount + 1
    If .Fields("Credit") Then
    PostedTransactionsTotal = PostedTransactionsTotal + .Fields("Amount")
    Else
    PostedTransactionsTotal = PostedTransactionsTotal - .Fields("Amount")
    End If
    .MoveNext
    Wend
    End With
    End With

    Set CatLimits = New COrderLimitCategories
    SetControls
    DisplayOrderForm
    Timer1.Enabled = True
    End Sub

  5. #5

    Thread Starter
    New Member
    Join Date
    May 2012
    Posts
    6

    Re: Application Hang Category: (101) Event ID: 1002

    Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If UnloadMode = vbFormControlMenu Then
    Cancel = True
    btnCancel_Click
    End If
    Debug.Print "QueryUnload "; UnloadMode
    End Sub

    Private Sub Form_Resize()
    Dim l As Long
    Dim TopRow As Long

    On Error Resume Next
    Busy = True
    TopRow = FGrid1.TopRow

    'lblBalance.Left = Me.ScaleWidth - Label1.Left - lblBalance.Width
    'Label2.Left = lblBalance.Left - Label2.Width

    btnCancel.Top = Me.ScaleHeight - btnCancel.Height - 60
    btnCancel.Left = Me.ScaleWidth - btnCancel.Width - 120

    btnOK.Top = Me.ScaleHeight - btnOK.Height - 60
    btnOK.Left = btnCancel.Left - btnOK.Width - 120

    lblTotal.Top = btnCancel.Top - lblTotal.Height - 180
    lblTotal.Left = Me.ScaleWidth - lblTotal.Width - 120
    lTotal.Top = lblTotal.Top
    lTotal.Left = lblTotal.Left - lTotal.Width - 60

    lblTax.Top = lblTotal.Top - lblTax.Height
    lblTax.Left = Me.ScaleWidth - lblTax.Width - 120
    lTax.Top = lblTax.Top
    lTax.Left = lblTax.Left - lTax.Width - 60
    '
    lblBegBal.Top = lblTax.Top
    Label2.Top = lblTax.Top
    btnCheck.Top = lblTax.Top

    lblSub.Top = lblTax.Top - lblSub.Height
    lblSub.Left = Me.ScaleWidth - lblSub.Width - 120
    lSub.Top = lblSub.Top
    lSub.Left = lblSub.Left - lSub.Width - 60
    '
    lblEndBal.Top = lblTotal.Top
    Label3.Top = lblTotal.Top
    '
    Label1.Top = lblSub.Top

    l = lblSub.Top - FGrid1.Top - 60
    If l < 0 Then l = 0
    FGrid1.Height = l

    Check1.Top = Me.ScaleHeight - Check1.Height - 60
    txtQuickFind.Top = Me.ScaleHeight - txtQuickFind.Height - 60
    txtQuickFind.Left = Check1.Left + Check1.Width

    FGrid1.Width = Me.ScaleWidth
    If Updated Then
    FGrid1.col = 0
    'FGrid1.Row = 1
    'l = FGrid1.CellLeft * 6.5

    'l = FGrid1.Width _
    - l _
    - FGrid1.GridLineWidth * 6 _
    - FGrid1.ColWidth(0) _
    - FGrid1.ColWidth(1) _
    - FGrid1.ColWidth(3) _
    - FGrid1.ColWidth(4)
    'If l > 0 Then FGrid1.ColWidth(2) = l
    FGrid1.ColWidth(5) = 0
    FGrid1.ColWidth(6) = 0
    FGrid1.ColWidth(7) = 0
    FGrid1.ColWidth(8) = 0
    FGrid1.TopRow = TopRow
    LastRow = FGrid1.row
    MoveTextBox
    End If
    Busy = False
    End Sub

    Private Sub Form_Unload(Cancel As Integer)
    Dim i As Integer

    LogMessage "Screen Closed: " & Me.name

    Set CatLimits = Nothing

    If Me.WindowState <> vbMinimized Then
    SysReg.SaveSetting Me.Caption, "Size", "State", Me.WindowState
    If Me.WindowState = vbNormal Then
    SysReg.SaveSetting Me.Caption, "Size", "Left", Me.Left
    SysReg.SaveSetting Me.Caption, "Size", "Top", Me.Top
    SysReg.SaveSetting Me.Caption, "Size", "Width", Me.Width
    SysReg.SaveSetting Me.Caption, "Size", "Height", Me.Height
    End If
    End If
    SysReg.SaveSetting Me.Caption, "Settings", "Quick Entry", Check1.Value
    For i = 0 To FGrid1.Cols - 1
    SysReg.SaveSetting Me.Caption, "Size", "ColWidth" & Trim$(Str$(i)), FGrid1.ColWidth(i)
    Next
    ' If Not fInmate Is Nothing Then
    ' Unload fInmate
    ' Set fInmate = Nothing
    ' End If
    End Sub

    Private Sub Label1_Click()
    Debug.Print "Break"
    End Sub

    Private Sub Text1_GotFocus()
    Text1.SelStart = 0
    Text1.SelLength = 99
    End Sub

    Private Sub Text1_LostFocus()
    FGrid1.Text = Text1.Text
    UpdateRow FGrid1.row
    End Sub

    Private Sub DisplayOrderForm()
    Dim qry As String
    Dim s As String
    Dim s2 As String
    Dim Cat, catcode As String
    Dim Price As Currency
    Dim doHeader As Boolean
    Dim NewOrder As Boolean
    Dim i As Long

    On Error Resume Next
    If Not CurrentAccount.PurchaseRights = True Then
    MsgBox "This account does not have purchase rights"
    'Me.Hide
    Me.Visible = False
    Screen.MousePointer = vbDefault
    SendKeys ("{ESC}")
    Exit Sub
    End If
    With dbCat.Recordset
    .MoveFirst
    While Not .EOF
    catcode = .Fields("CategoryCode")
    Cat = .Fields("Description")
    doHeader = True
    With dbProduct.Recordset
    .FindFirst "[CategoryCode] = '" & catcode & "'"
    While Not .NoMatch
    If .Fields("Active") Then
    If (Len(CurrentSession.SessionGroups) = 0) _
    Or (Len(.Fields("SessionGroups")) = 0) _
    Or (Len(Intersect(CurrentSession.SessionGroups, .Fields("SessionGroups"))) > 0) Then
    If doHeader Then
    doHeader = False
    FGrid1.AddItem "----" & vbTab & "----" & vbTab & Cat
    End If

    s = vbTab & .Fields("ProductID") _
    & vbTab & .Fields("Description") _
    & vbTab
    Price = 0#
    If CurrentLocation.PriceIndex > 0 And CurrentLocation.PriceIndex < 5 Then
    s2 = "AlternatePrice" & Trim$(CurrentLocation.PriceIndex)
    Price = .Fields(s2)
    End If
    If Price = 0# Then
    Price = .Fields("Price")
    End If
    'starts at colum 3
    ' 3 4 5 6
    s = s + Format(Price, "0.00") + vbTab + vbTab + Str$(.Fields("Taxrate")) + vbTab + Str$(.Fields("Rebate"))
    If IsNull(.Fields("SpecialHandling")) Then
    s = s + vbTab + ""
    Else
    ' 7
    s = s + vbTab + .Fields("SpecialHandling")
    End If
    ' 8
    s = s + vbTab + Str$(.Fields("Cost"))

    ' 9
    s = s + vbTab + Trim(catcode)
    ' 10
    s = s + vbTab + Str$(.Fields("QuantityOnHand"))
    FGrid1.AddItem s
    End If
    End If
    .FindNext "[CategoryCode] = '" & catcode & "'"
    Wend
    End With
    .MoveNext
    Wend
    End With

    s = "SELECT Max(OrderID) From Orders where LocationID = '" _
    & CurrentLocation.LocationID & "'"
    dbOrder.RecordSource = s
    dbOrder.Refresh
    If IsNull(dbOrder.Recordset.Fields(0)) Then
    OrderID = 1
    Else
    OrderID = dbOrder.Recordset.Fields(0)
    End If
    s = "SELECT * from Orders where " _
    & "LocationID = '" & CurrentLocation.LocationID & "' and " _
    & "OrderID = " & Str$(OrderID)
    dbOrder.RecordSource = s
    dbOrder.Refresh
    NewOrder = False
    If dbOrder.Recordset.EOF Then
    NewOrder = True
    Else
    If Not IsNull(dbOrder.Recordset.Fields("TransmitTime")) Then
    NewOrder = True
    OrderID = OrderID + 1
    End If
    End If

    If NewOrder Then
    'create new order record
    dbOrder.Recordset.AddNew
    dbOrder.Recordset.Fields("OrderID") = OrderID
    dbOrder.Recordset.Fields("LocationID") = CurrentLocation.LocationID
    dbOrder.Recordset.Update
    dbOrder.Recordset.Bookmark = dbOrder.Recordset.LastModified
    Else
    'see if account already has items in this order
    'put already ordered items in form
    'delete them from the database...
    '...this allows [Cancel] to cancel an order
    'find transaction for this order
    'adjust balances, zero transaction

    'set recordset to this account's order items
    s = "Select * from Items where " _
    & " LocationID = '" & CurrentLocation.LocationID & "' and" _
    & " AccountID = '" & CurrentAccount.AccountID & "' and" _
    & " OrderID = " & Str$(OrderID)
    dbItem.RecordSource = s
    dbItem.Refresh
    With dbItem.Recordset
    If Not .EOF Then ' then this is edit, not new
    .MoveFirst
    TransactionID = Val(.Fields("TransactionID"))

    'find the transaction for this order
    s = "SELECT * From AccountTransactions where " _
    & " AccountId = '" & CurrentAccount.AccountID & "'" _
    & " and TransactionID = " & Str$(TransactionID) _
    & " and LocationID = '" & CurrentLocation.LocationID & "'"
    dbAcntTrans.RecordSource = s
    dbAcntTrans.Refresh

    If Not dbAcntTrans.Recordset.EOF Then
    'adjust balance
    CurrentAccount.CurrentBalance = CurrentAccount.CurrentBalance + dbAcntTrans.Recordset.Fields("Debit")
    fInmate.UserRecord.Edit
    fInmate.UserRecord.Fields("CurrentBalance") = CurrentAccount.CurrentBalance
    fInmate.UserRecord.Update

    'zero transaction amount
    dbAcntTrans.Recordset.Edit
    dbAcntTrans.Recordset.Fields("Debit") = 0#
    dbAcntTrans.Recordset.Update
    Else
    'somebody deleted the transaction!!
    TransactionID = -1
    End If

    'loop through all order items to put in form
    Tax = 0#
    While Not .EOF
    For i = 0 To FGrid1.rows - 1
    If Trim$(.Fields("ProductID")) = FGrid1.TextMatrix(i, 1) Then
    FGrid1.TextMatrix(i, 0) = Trim$(Str$(.Fields("Quantity")))
    Price = Val(FGrid1.TextMatrix(i, 0)) * Val(FGrid1.TextMatrix(i, 3))
    FGrid1.TextMatrix(i, 4) = Format(Price, "0.00")
    If 0 < Len(Intersect(FGrid1.TextMatrix(i, 9), MaxOrderExemptCategories)) Then
    MaxOrderExemptAmount = MaxOrderExemptAmount + Price + (CurrentLocation.SalesTax * Val(FGrid1.TextMatrix(i, 5)) * Price)
    End If
    SubTotal = SubTotal + Price
    Tax = Tax + CurrentLocation.SalesTax * Val(FGrid1.TextMatrix(i, 5)) * Price
    Exit For
    End If
    Next
    .Delete
    .MoveNext
    Wend
    Total = RndCur(SubTotal) + RndCur(Tax)
    NewBalance = RndCur(CurrentAccount.CurrentBalance) - Total
    End If
    End With

    End If

    LoadedWithInvalidAmounts = (VerifyOrderAmounts > 0)

    'display form totals
    lblSub.Caption = Format(SubTotal, "$0.00")
    lblTax.Caption = Format(Tax, "$0.00")
    lblTotal.Caption = Format(Total, "$0.00")
    lblBegBal.Caption = Format(CurrentAccount.CurrentBalance, "$0.00")
    lblEndBal.Caption = Format(NewBalance, "$0.00")
    Debug.Print "MaxOrderExemptAmount: " + Format(MaxOrderExemptAmount, "0.00")

    ' FGrid1.col = 3
    Updated = True
    Form_Resize
    FGrid1_RowColChange
    Screen.MousePointer = vbDefault

    End Sub

    Private Sub Timer1_Timer()
    Timer1.Enabled = False
    If Check1.Value Then
    txtQuickFind.SetFocus
    End If
    If PostedTransactionsCount > 0 Then
    MsgBox "This account has " & Format(PostedTransactionsCount) & " posted transactions totaling " & Format(PostedTransactionsTotal, "$0.00"), vbInformation
    End If
    End Sub

    Private Sub txtQuickFind_LostFocus()
    QuickActive = False
    Debug.Print "txtQuickFind_LostFocus"
    End Sub

    Private Sub QuickSel()
    Dim NewRow As Long
    Dim i As Long
    Dim s As String
    Dim found As Boolean

    On Error Resume Next
    s = Trim$(txtQuickFind.Text)
    If Len(s) > 0 Then
    found = False
    For i = 0 To FGrid1.rows - 1
    If s = Trim$(FGrid1.TextMatrix(i, 1)) Then
    found = True
    Exit For
    End If
    Next
    If found Then
    'If FGrid1.row <> i Then
    FGrid1.row = i
    If Not FGrid1.RowIsVisible(i + 1) Then
    FGrid1.TopRow = i
    End If
    FGrid1.SetFocus
    'End If
    Else
    Beep
    txtQuickFind_GotFocus
    End If
    End If
    End Sub

    Private Sub txtQuickFind_GotFocus()
    Debug.Print "txtQuickFind_GotFocus"
    txtQuickFind.SelStart = 0
    txtQuickFind.SelLength = 99
    QuickActive = True
    End Sub

  6. #6
    Web developer Nightwalker83's Avatar
    Join Date
    Dec 2001
    Location
    Adelaide, Australia
    Posts
    12,808

    Re: Application Hang Category: (101) Event ID: 1002

    @ aburn

    Please wrap your code in [highlight="vb"][/highlight] it will make the code easier for people to read.

    @ jmsrickland

    Your post doesn't add anything useful to the discussion so please keep that stuff to the chit-chat section.
    when you quote a post could you please do it via the "Reply With Quote" button or if it multiple post click the "''+" button then "Reply With Quote" button.
    If this thread is finished with please mark it "Resolved" by selecting "Mark thread resolved" from the "Thread tools" drop-down menu.
    Please consider giving me some rep points if I help you a lot.
    Links to my code examples can now be found on my website: My websites
    Please rate my post if you find it helpful!
    Technology is a dangerous thing in the hands of an idiot! I am that idiot.

  7. #7

    Thread Starter
    New Member
    Join Date
    May 2012
    Posts
    6

    Re: Application Hang Category: (101) Event ID: 1002

    Nightwalker83 I will ensure to do that next time. I resolved the issue..wasn't software related. The permissions weren't set correctly on the server. This should have been taken care of by our networking contractors but I took care of it.

    Thanks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width

Survey posted by VBForums.