?
Solved

Problems With FlexGrid And Subscript Out Of Range Error

Posted on 2003-03-12
4
Medium Priority
?
579 Views
Last Modified: 2010-05-18
Hi
I am using vb6 which is connected to a msaccess db

I have 2 msflexgrids on a form the 1st grid populates with data, when a user double clicks on one of the rows the data from that grid moves to the second flexgrid, this works fine however when i unload the form and load it back up again and populate the first grid with data on a double click instead of placing that data in the second grid I get a Subscript out of range error. Can someone please help me with this I have been stuck on this one for a while.

Thank you in advance and regards
0
Comment
Question by:supra80
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
4 Comments
 
LVL 11

Expert Comment

by:LordWabbit
ID: 8126042
Umm, well I'm currently working with flex grids in vb6 so i will try to help.  From the look of things you've got some global variables which are not being initialized on form load.  if this is the case either make them local or init them on form load (i'm geussing at an index).
Not much help I suppose, but if you could give some more detail I can possibly be of more help.
0
 

Accepted Solution

by:
supra80 earned 0 total points
ID: 8126164
Thanks LordWabbit i have already solved the problem and that was it i did not set one of the variables in the form load to zero. But i have another little problem hopefully you can help me with. I have a command button that populates a grid with data only what happens it does not remove all the lines when i hit the command button to display a different customers orders. How do i remove all the rows except for one, i need one blank row. I have attached my code i know its a bit messy but im a starting programmer and this is my first project.

As you can see i have a function in there to remove rows that somebody helped me with but, it dosent really work the way i thought it would. Any help will be greatly appreciated Lordwabbit

Option Explicit
Dim Activation As ADODB.Connection
Dim rsOrder As Recordset
Dim rsCustomer As Recordset
Dim rsBundleHold As New ADODB.Recordset
Dim strCustomer As String
Dim strOrder As String
Dim strName As String 'Variable from Input box to find customer
Dim CustID As String
Dim OrdID As Integer
Dim strAddress As String
Dim strOrdNum As String
Dim strCRD As String
Dim strTCD As String
Dim strStatus As String
Dim newrow  As Integer
Dim rownumber As Integer
Dim GRow As Variant
Public gHW As Long
Private Sub cmdPrevious_Click()
   With rsCustomer
        .MovePrevious
        If .BOF Then
            .MoveFirst
        End If
    End With
    BindCustomerData
End Sub

Private Sub cmdBundleWait_Click()

Dim strErrorMessage As String
Dim Activation As ADODB.Connection
Dim strSQL As String
Dim i As Integer
Dim OrderNumber As String
Dim rsActEmployee As New ADODB.Recordset
Dim rsRetEmployee As New ADODB.Recordset


On Error GoTo HandleErrors:

If txtComments.Text = "" Then
    MsgBox "You Must Enter Comments", vbOKOnly, "Customer Solutions Manager"
    txtComments.SetFocus
    Exit Sub
End If
Set Activation = New ADODB.Connection
   
   Activation.ConnectionString = CONN_STRING
   Activation.Open ' Open the database
   rsOrder.Open

        For i = 1 To flxOrderBundle.Rows Step 1
   
            Do While Not rsOrder.EOF
                If rsOrder.Fields("OrderNumber") = flxOrderBundle.TextMatrix(i, 0) Then
                    OrderNumber = rsOrder.Fields("OrderNumber")
                    strSQL = "UPDATE Orders SET [status] = 'Waiting' WHERE [OrderNumber] = '" & OrderNumber & "'"
                    Activation.Execute strSQL
                    i = i + 1
                    rsOrder.MoveFirst
                Else
                    rsOrder.MoveNext
                End If
            Loop
        Next
  rsBundleHold.ActiveConnection = Activation
  rsBundleHold.CursorLocation = adUseServer
  rsBundleHold.CursorType = adOpenDynamic
  rsBundleHold.LockType = adLockPessimistic
  rsBundleHold.Open "BundleWait"
On Error GoTo TransactionFail
  Activation.BeginTrans
 
Dim rownumber As Integer

flxOrderBundle.Rows = flxOrderBundle.Rows - 1
i = 1
Do
    rsBundleHold.AddNew
    rsBundleHold.Fields("bundlecode") = txtBundleCode.Text & ""
    rsBundleHold.Fields("bundlewaitcomments") = txtComments.Text & ""
    rsBundleHold.Fields("LoginId") = txtEmpId.Text & ""
    rownumber = flxOrderBundle.Rows
    rsBundleHold.Fields("orderNumber") = flxOrderBundle.TextMatrix(i, 0)
    rsBundleHold.Update
    flxOrderBundle.Rows = rownumber
    i = i + 1
Loop While i < flxOrderBundle.Rows
  Activation.CommitTrans
  Activation.Close
  Set rsBundleHold = Nothing
  MsgBox "Bundle has been sent to Hold Queue", vbOKOnly, "Success"
  Clear
    Exit Sub

TransactionFail:
    Activation.RollbackTrans
    MsgBox "Could Not Add Invoice. Transaction aborted with the error " & Err.Number - vbObjectError
    Set rsBundleHold = Nothing
   
HandleErrors:
Dim errDBError As ADODB.Error

For Each errDBError In Activation.Errors
    strErrorMessage = strErrorMessage & errDBError.Description & vbCrLf
Next
    MsgBox strErrorMessage, vbExclamation, "Database Error"
On Error GoTo 0
End Sub

Private Sub cmdNext_Click()
    With rsCustomer
        .MoveNext
        If .EOF Then
            .MoveLast
        End If
    End With
    BindCustomerData
End Sub
Private Sub cmdViewOrder_Click()
'Displays Customers Orders
Dim i As Integer
Dim Status As String
Set rsOrder = New ADODB.Recordset
Activation.Close

mnuSort.Enabled = True

CustID = txtCustomerid.Text

Activation.ConnectionString = CONN_STRING

Activation.Open

strOrder = "Select * from Orders where CIDN ='" & CustID & "'  "

    With rsOrder
        .CursorLocation = adUseServer
        .CursorType = adOpenDynamic
        .LockType = adLockPessimistic
        .Open strOrder, Activation, , , adCmdText
    End With
   
    flxCustomerOrders.Clear
    GridHeader
    BindOrderGrid
'call the function to clear the grid lines with no data
    removeBlankRows flxCustomerOrders
    For i = 1 To Me.flxCustomerOrders.Rows - 1
     flxCustomerOrders.Col = 4
     flxCustomerOrders.Row = i
     Status = flxCustomerOrders.Text
        Select Case Status
           Case Is = "Waiting"
               ColorThisRow (i)
           Case ""
               UNColorThisRow (i)
           Case Is = "done"
               ColorRowdone(i)
            Case Is = "Attempted"
                ColorRowAttempted (i)
         End Select
    Next
    flxCustomerOrders.Visible = True
    flxOrderBundleHeader
    cmdPrevious.Enabled = False
    cmdNext.Enabled = False
    rsOrder.Close
End Sub

Private Sub flxCustomerOrders_DblClick()

On Error GoTo flxCustomerOrders_DblClick_Error

cmdBundleWait.Enabled = True

GRow = flxCustomerOrders.Row

If flxCustomerOrders.TextMatrix(GRow, 4) = "done" Then
    MsgBox "Order Has Been done", vbOKOnly, "Customer Solutions Manager"
    Exit Sub
ElseIf flxCustomerOrders.TextMatrix(GRow, 4) = "Waiting" Then
    MsgBox "Order Part Of Waiting Bundle", vbOKOnly, "Customer Solutions Manager"
    Exit Sub
ElseIf flxCustomerOrders.TextMatrix(GRow, 4) = "Attempted" Then
    MsgBox "Customer Requested Order Not To Be done", vbOKOnly, "Customer Solutions Manager"
    Exit Sub
Else
    If GRow < 0 Or GRow = flxCustomerOrders.Rows Then Exit Sub
        strOrdNum = flxCustomerOrders.TextMatrix(GRow, 0)
        strAddress = flxCustomerOrders.TextMatrix(GRow, 1)
        strCRD = flxCustomerOrders.TextMatrix(GRow, 2)
        strTCD = flxCustomerOrders.TextMatrix(GRow, 3)
        strStatus = flxCustomerOrders.TextMatrix(GRow, 4)
        flxCustomerOrders.RemoveItem GRow
       
   
    GetOrderLine
   
flxCustomerOrders_DblClick_Exit:
        Exit Sub
End If
flxCustomerOrders_DblClick_Error:
    If Err.Number = 30015 Then
        MsgBox "There are no Orders to remove!", , "Bundle Error"
    Else
        MsgBox "Problems: " & Err.Number & " " & Err.Description
    End If
    GoTo flxCustomerOrders_DblClick_Exit
End Sub
Private Sub flxOrderBundleHeader()
'Put headings on the Order Bundle Grid

Dim intLoopIndex As Integer
Dim Labels(5)

Labels(0) = "Order Number"
Labels(1) = "Address End"
Labels(2) = "CRD"
Labels(3) = "TCD"
Labels(4) = "Status"

For intLoopIndex = flxOrderBundle.FixedCols To flxOrderBundle.Cols
    flxOrderBundle.TextArray(intLoopIndex) = Labels(intLoopIndex)
Next
    flxOrderBundle.ColWidth(0) = 1300
    flxOrderBundle.ColWidth(1) = 5000

End Sub

Private Sub Form_Load()

mnuBundle.Enabled = False
mnuSort.Enabled = False

End Sub

Private Sub mnuBundleFinalise_Click()

frmFinaliseBundle.Show

End Sub

Private Sub mnuFileExit_Click()
newrow = 0
Unload frmAddBundle

End Sub

Private Sub BindCustomerData()

    txtCustomerName.Text = rsCustomer.Fields("Cust_Name") & ""
    txtAddress.Text = rsCustomer.Fields("Address") & ""
    txtState.Text = rsCustomer.Fields("State") & ""
    txtPCode.Text = rsCustomer.Fields("PostC") & ""
    txtCustomerid.Text = rsCustomer.Fields("CIDN") & ""
    txtAEName.Text = rsCustomer.Fields("AE_Name") & ""
    mskAENumber.Text = rsCustomer.Fields("AE_Phone") & ""
    txtADName.Text = rsCustomer.Fields("AD_Name") & ""
    mskADNumber.Text = rsCustomer.Fields("AD_Phone") & ""
End Sub

Private Sub BindOrderGrid()
'Binds the information in the flxCustomerOrders Grid
Dim newrow As Integer
Dim rownumber As Integer

newrow = 1
Do While Not rsOrder.EOF
    rownumber = flxCustomerOrders.Rows
    flxCustomerOrders.TextMatrix(newrow, 0) = rsOrder.Fields("OrderNumber") & ""
    flxCustomerOrders.TextMatrix(newrow, 1) = rsOrder.Fields("Address_End") & ""
    flxCustomerOrders.TextMatrix(newrow, 2) = rsOrder.Fields("CRD") & ""
    flxCustomerOrders.TextMatrix(newrow, 3) = rsOrder.Fields("TCD") & ""
    flxCustomerOrders.TextMatrix(newrow, 4) = rsOrder.Fields("Status") & ""
    rownumber = rownumber + 1
    flxCustomerOrders.Rows = rownumber
    rsOrder.MoveNext
    newrow = newrow + 1
Loop
End Sub

Private Sub GetOrderLine()

 newrow = newrow + 1
 rownumber = flxOrderBundle.Rows
 flxOrderBundle.TextMatrix(newrow, 0) = strOrdNum
 flxOrderBundle.TextMatrix(newrow, 1) = strAddress
 flxOrderBundle.TextMatrix(newrow, 2) = strCRD
 flxOrderBundle.TextMatrix(newrow, 3) = strTCD
 flxOrderBundle.TextMatrix(newrow, 4) = strStatus
 rownumber = rownumber + 1
 flxOrderBundle.Rows = rownumber
 
End Sub

Private Sub mnuSearchCustomerName_Click()
Dim strCustName As String
'Create the connection and get the data
Set Activation = New ADODB.Connection
Set rsCustomer = New ADODB.Recordset

Activation.ConnectionString = CONN_STRING

Activation.Open

strCustomer = " SELECT Customer.CIDN, Customer.Cust_Name, Customer.Address, Customer.POSTC, Customer.State, Account_Team.AE_Name, Account_Team.AE_Phone, Account_Team.AD_Name, Account_Team.AD_Phone FROM Customer INNER JOIN Account_Team ON Customer.CIDN = Account_Team.CIDN;"
   
    With rsCustomer
        .CursorLocation = adUseClient
        .CursorType = adOpenDynamic
        .LockType = adLockOptimistic
        .Open strCustomer, Activation, , , adCmdText
    End With

On Error GoTo HandleError

strCustName = InputBox("Enter in Company Name You Wish To Select" _
        & vbCrLf & "Partial Name OK", "Select By Customer Name")

With rsCustomer
    .Filter = "[Cust_Name] Like '" & strCustName & "*'"
   
    If .EOF Then
        MsgBox "No Records Match ' " & strCustName & "'", _
                vbInformation, "Select By Customer Name"
        .Filter = ""
    Else
        BindCustomerData
        cmdViewOrder.Enabled = True
        cmdPrevious.Enabled = True
        cmdNext.Enabled = True
    End If
End With
    mnuSearchCustomerName.Checked = True
    mnuSearchAddress.Checked = False
mnuSearchCustomerName_Exit:
    Exit Sub

HandleError:
    MsgBox "Unable to carry out requested operation.", _
        vbInformation, "Customer Solutions Manager"
        Activation.Close
    On Error GoTo 0

End Sub


Private Sub mnuSearchAddress_Click()
Dim strAddress As String
Set Activation = New ADODB.Connection
Set rsCustomer = New ADODB.Recordset

Activation.ConnectionString = CONN_STRING

Activation.Open

strCustomer = "SELECT Customer.CIDN, Customer.Cust_Name, Customer.Address, Customer.POSTC, Customer.State, Account_Team.AE_Name, Account_Team.AE_Phone, Account_Team.AD_Name, Account_Team.AD_Phone FROM Customer INNER JOIN Account_Team ON Customer.CIDN = Account_Team.CIDN;"
   
    With rsCustomer
        .CursorLocation = adUseClient
        .CursorType = adOpenDynamic
        .LockType = adLockOptimistic
        .Open strCustomer, Activation, , , adCmdText
    End With

On Error GoTo HandleError

strAddress = InputBox("Enter in Service Address You Wish To Search" _
        & vbCrLf & "Partial Address OK", "Search By Service Address")

With rsCustomer
    .Filter = "[Address] Like '" & strAddress & "*'"
   
    If .EOF Then
        MsgBox "No Records Match ' " & strAddress & "'", _
                vbInformation, "Search By Service Address"
        .Filter = ""
    Else
          BindCustomerData
          cmdViewOrder.Enabled = True
          cmdPrevious.Enabled = True
          cmdNext.Enabled = True
    End If
End With
    mnuSearchCustomerName.Checked = False
    mnuSearchAddress.Checked = True

mnuSearchAddress_Exit:
    Exit Sub

HandleError:
    MsgBox "Unable to carry out requested operation.", _
        vbInformation, "Customer Solutions Manager"
    On Error GoTo 0

End Sub

Private Sub GridHeader()
'Put headings on the Grid
Dim intLoopIndex As Integer
Dim Labels(5)

Labels(0) = "Order Number"
Labels(1) = "Address End"
Labels(2) = "CRD"
Labels(3) = "TCD"
Labels(4) = "Status"

For intLoopIndex = flxCustomerOrders.FixedCols To flxCustomerOrders.Cols
    flxCustomerOrders.TextArray(intLoopIndex) = Labels(intLoopIndex)
Next
    flxCustomerOrders.ColWidth(0) = 1300
    flxCustomerOrders.ColWidth(1) = 5000

End Sub
Private Sub ColorThisRow(ByVal rowNum As Integer)
'Function to colour a row in the grid
Dim i As Integer

    flxCustomerOrders.Row = rowNum
    For i = 0 To flxCustomerOrders.Cols - 1
    flxCustomerOrders.Col = i
    flxCustomerOrders.CellBackColor = vbGreen
    Next i

End Sub

Private Sub mnuSortAddress_Click()
flxCustomerOrders.Col = 1
flxCustomerOrders.Sort = 1 'Sorts the grid by Address ASC

mnuSortAddress.Checked = True
mnuSortOrderNumber.Checked = False
mnuSortStatus.Checked = False
End Sub

Private Sub mnuSortOrderNumber_Click()
flxCustomerOrders.Col = 0
flxCustomerOrders.Sort = 1 'Sorts the grid by Order Number ASC

mnuSortAddress.Checked = False
mnuSortOrderNumber.Checked = True
mnuSortStatus.Checked = False
End Sub

Private Sub mnuSortStatus_Click()

flxCustomerOrders.Col = 4
flxCustomerOrders.Sort = 1 'Sorts the grid by Status ASC

mnuSortAddress.Checked = False
mnuSortOrderNumber.Checked = False
mnuSortStatus.Checked = True

End Sub

Private Sub mnuWindowTileHorizontally_Click()
frmMain.Arrange vbTileHorizontal

mnuWindowCascade.Checked = False
mnuWindowTileHorizontally.Checked = True
mnuWindowTileVertically.Checked = False
End Sub

Private Sub txtCNumber_LostFocus()
    Dim Cnumber As String
    Dim strLoginID As String
mnuBundle.Enabled = True
If txtCNumber.Text = "" Then
    MsgBox "Enter In Log-In ID", vbOKOnly, "Customer Solutions Manager"
    txtCNumber.SetFocus
Exit Sub
End If
   
    Cnumber = txtCNumber.Text
    txtBundleCode.Text = Cnumber & "_" & Now
   
    strLoginID = txtCNumber.Text
   
    deActivation.rsActEmployee.Open
   
    With deActivation.rsActEmployee
        .Find "[LoginID] = '" & strLoginID & "'"
        If .EOF Then
            MsgBox "No records Match  " & strLoginID & "  Try Again", _
            vbInformation, "Find Employee"
        End If
    End With
    BindEmployeeDetails
    deActivation.rsActEmployee.Close
txtCNumber_LostFocus_Exit:
    Exit Sub
   
End Sub

Private Sub BindEmployeeDetails()
    With deActivation.rsActEmployee
        If .EOF Then
            txtCNumber.Text = ""
            txtCNumber.SetFocus
            Exit Sub
        Else
            txtActFName.Text = ![FirstName]
            txtActLName.Text = ![Surname]
            mskActContact.Text = ![Phone]
            txtEmpId.Text = ![LoginId]
        End If
    End With
End Sub

Private Sub UNColorThisRow(ByVal rowNum As Integer)
'Function to colour a row in the grid
Dim i As Integer

    flxCustomerOrders.Row = rowNum
    For i = 0 To flxCustomerOrders.Cols - 1
    flxCustomerOrders.Col = i
    flxCustomerOrders.CellBackColor = vbWhite
    Next i

End Sub
Private Sub Clear()
Dim i As Integer
'Clears the text boxs
    txtCustomerName.Text = ""
    txtAddress.Text = ""
    txtState.Text = ""
    txtPCode.Text = ""
    txtComments.Text = ""
    txtCustomerid.Text = ""
    txtAEName.Text = ""
    mskAENumber.Text = ""
    txtADName.Text = ""
    mskADNumber.Text = ""
    flxCustomerOrders.Clear
    flxCustomerOrders.Rows = flxCustomerOrders.FixedRows
    flxCustomerOrders.Cols = flxCustomerOrders.FixedCols
    flxOrderBundle.Clear
    flxOrderBundle.Rows = flxOrderBundle.FixedRows
    flxOrderBundle.Cols = flxOrderBundle.FixedCols
End Sub
Private Sub ColorRowdone(ByVal rowNum As Integer)
'Function to colour a row in the grid
Dim i As Integer

    flxCustomerOrders.Row = rowNum
    For i = 0 To flxCustomerOrders.Cols - 1
    flxCustomerOrders.Col = i
    flxCustomerOrders.CellBackColor = vbYellow
    Next i

End Sub
Public Sub removeBlankRows(ByRef flexgrid As MSFlexGrid)

 Dim xCtr, yCtr As Integer         ' dimension counters
 Dim boolRowFilled As Boolean      ' set bool variable
 
On Error GoTo HandleError
With flexgrid
 Do                                        ' run yCtr for all rows
     .Row = yCtr                           ' current row = yCtr
     For xCtr = .FixedCols To .Cols - 1    ' run xCtr for all cols
         .Col = xCtr                       'current column = xCtr
         If .Text <> "" Then boolRowFilled = True
         ' if the text in current row and col is not
         ' empty, then set boolRowFilled to TRUE
     Next ' next xCtr
     If boolRowFilled = False Then ' if our bool is false
         ' that means that we found text in the row and
         ' we have to ...
         If yCtr <= .Rows Then
           .RemoveItem yCtr          ' ... remove the empty row
'           .AddItem flexgrid, yCtr
          yCtr = yCtr - 1
         End If

     Else
         boolRowFilled = False ' if it was no blank, then
                               ' we reset
                               ' our boolRowFilled to
                               ' False
     End If
     yCtr = yCtr + 1

 Loop Until yCtr > .Rows - 1 ' next yCtr
End With
removeBlankRows_Exit:
 Exit Sub
 
HandleError:
    If Err.Number = 30015 Then
        MsgBox "Customer Has No Orders!", , "Error"
        Exit Sub
    Else
        MsgBox "Problems: " & Err.Number & " " & Err.Description
        Exit Sub
    End If
End Sub

Private Sub ColorRowAttempted(ByVal rowNum As Integer)
'Function to colour a row in the grid
Dim i As Integer

    flxCustomerOrders.Row = rowNum
    For i = 0 To flxCustomerOrders.Cols - 1
    flxCustomerOrders.Col = i
    flxCustomerOrders.CellBackColor = vbBlue
    Next i

End Sub

Private Sub mnuWindowCascade_Click()

frmMain.Arrange vbCascade

mnuWindowCascade.Checked = True
mnuWindowTileHorizontally.Checked = False
mnuWindowTileVertically.Checked = False

End Sub
Private Sub mnuWindowTileVertically_Click()

frmMain.Arrange vbTileVertical

mnuWindowCascade.Checked = False
mnuWindowTileHorizontally.Checked = False
mnuWindowTileVertically.Checked = True

End Sub
0
 

Expert Comment

by:CleanupPing
ID: 9447181
supra80:
This old question needs to be finalized -- accept an answer, split points, or get a refund.  For information on your options, please click here-> http:/help/closing.jsp#1 
EXPERTS:
Post your closing recommendations!  No comment means you don't care.
0

Featured Post

Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

Question has a verified solution.

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

The SignAloud Glove is capable of translating American Sign Language signs into text and audio.
This article will show how Aten was able to supply easy management and control for Artear's video walls and wide range display configurations of their newsroom.
Viewers will learn how to properly install Eclipse with the necessary JDK, and will take a look at an introductory Java program. Download Eclipse installation zip file: Extract files from zip file: Download and install JDK 8: Open Eclipse and …
In this seventh video of the Xpdf series, we discuss and demonstrate the PDFfonts utility, which lists all the fonts used in a PDF file. It does this via a command line interface, making it suitable for use in programs, scripts, batch files — any pl…

800 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