Re: Error when running vb app with FlexGrid control

Thank you both for your replies. The code is posted below. It consists of
one form and one module. Please exuse the code for structure, as it's not
mine. To process the grid it pulls data from a SQL table and then uploads
data to a product called Matrix One via an ODBC entry. It's interesting,
just starting the product and then hitting the exit button creates the memory
error....

Here's the form code with some
functions...............................................

Option Explicit

Private Sub cmdCancel_Click()
cmdCancel.Enabled = False
cmdUpLoad.Enabled = True
cmdNetChange.Enabled = True
End Sub

Private Sub cmdNetChange_Click()
cmdUpLoad.Enabled = False
flxTDM.Rows = 1
DoEvents
Call fnGetSQLData(flxTDM)
If flxTDM.Rows > 0 Then
cmdUpLoad.Enabled = True
End If
End Sub

Private Sub cmdUpLoad_Click()
If flxTDM.Rows > 0 Then
cmdUpLoad.Enabled = False
cmdNetChange.Enabled = False
cmdCancel.Enabled = True
Call fnLoopNetChange
Else
MsgBox "There are no records to Upload!", vbExclamation + vbOKOnly,
"No Records"
End If
cmdCancel.Enabled = False
End Sub

Private Sub Command1_Click()
On Error GoTo Command1_Click_Error

Label2(0) = ""
Label2(1) = ""
Label2(2) = ""
Label6 = ""
Text1 = ""
flx2.Rows = 1

Call fnGetData("BUSINESS_OBJECT", "", flx1)

Command1_Click_Exit:
Exit Sub
Command1_Click_Error:
LogErrorMsg Err, Error, "Command1_Click", "", True
GoTo Command1_Click_Exit
End Sub

Private Sub Command2_Click()
Call Form_Unload(True)
End Sub

Private Sub Command3_Click()
Call fnSetData
End Sub

Private Sub Command4_Click()
If fraSQL.Visible = True Then
cmdNetChange.Enabled = False
cmdUpLoad.Enabled = False
fraSQL.Visible = False
Else
cmdNetChange.Enabled = True
If Me.flxTDM.Rows > 0 Then
cmdUpLoad.Enabled = True
End If
fraSQL.Visible = True
fraSQL.ZOrder (0)
End If
End Sub

Private Sub flx1_Click()
With flx1
Call fnGetData("BUSINESS_OBJECT_LONG_STRING_ATTRIBUTE",
..TextMatrix(.Row, 0), flx2)
Label2(0) = .TextMatrix(.Row, 2)
Label2(1) = .TextMatrix(.Row, 3)
Label2(2) = .TextMatrix(.Row, 4)
Label6 = .TextMatrix(.Row, 0)
End With
End Sub

Private Sub fnGetData(strParam0 As String, strParam1 As String, FLX As
MSFlexGrid)
On Error GoTo fnGetData_Error
Dim rsADOObject As Recordset
Dim strSQL As String
Dim strRow As String
Dim intI As Integer
Dim intJ As Integer

Screen.MousePointer = vbHourglass
If strParam0 = "BUSINESS_OBJECT" Then
strSQL = "SELECT * FROM " & strParam0 & " WHERE NAME = '" &
UCase(Trim(txt1(1))) & "' ORDER BY REVISION" 'AND REVISION LIKE '" &
UCase(Trim(txt1(2))) & "?'
Else
strSQL = "SELECT * FROM " & strParam0 & " WHERE OID = '" &
strParam1 & "' ORDER BY ATTRIBUTE_NAME"
End If
Set rsADOObject = curMatrixDB.OpenRecordset(strSQL, dbOpenDynaset)
If strParam0 = "BUSINESS_OBJECT" Then
intJ = rsADOObject.Fields().Count - 1
Else
intJ = rsADOObject.Fields().Count - 1
End If
FLX.Rows = 0
strRow = rsADOObject(0).Name
FLX.Cols = intJ + 1
For intI = 1 To intJ
strRow = strRow & vbTab & rsADOObject(intI).Name
Next intI
With FLX
.AddItem strRow
.Rows = 2
.FixedRows = 1
If strParam0 <> "BUSINESS_OBJECT" Then
.ColWidth(0) = 3000
.ColWidth(1) = 3000
.ColWidth(2) = .Width - 6350
.ColAlignment(0) = 0
.ColAlignment(2) = 0
End If
.Rows = 1
End With
If Not rsADOObject.EOF Then
While Not rsADOObject.EOF
strRow = rsADOObject(0)
For intI = 1 To intJ
strRow = strRow & vbTab & Trim(rsADOObject(intI))
Next intI
If rsADOObject(1) = "TDM_View_Filename" Then
Text1 = IIf(IsNull(rsADOObject(2)), "", rsADOObject(2))
End If
FLX.AddItem strRow
rsADOObject.MoveNext
Wend
rsADOObject.Close
End If

fnGetData_Exit:
Screen.MousePointer = vbNormal
Set rsADOObject = Nothing
Exit Sub
fnGetData_Error:
LogErrorMsg Err, Error, "fnGetData", "", False
GoTo fnGetData_Exit
End Sub

Private Sub fnSetData()
On Error GoTo fnSetData_Error
Dim strSQL As String

Screen.MousePointer = vbHourglass
strSQL = "UPDATE BUSINESS_OBJECT_LONG_STRING_ATTRIBUTE SET [VALUE] = '"
& Text1.Text & "' WHERE OID = '" & Label6.Caption & "' AND ATTRIBUTE_NAME =
'TDM_View_Filename'"
curMatrixDB.Execute strSQL, 0

fnSetData_Exit:
Screen.MousePointer = vbNormal
Exit Sub
fnSetData_Error:
LogErrorMsg Err, Error, "fnSetData", "", False
GoTo fnSetData_Exit
End Sub

Public Sub fnGetSQLData(FLX As MSFlexGrid)
On Error GoTo fnGetSQLData_Error
Dim rsADOOMatrix As ADODB.Recordset
Dim strSQL As String
Dim strRow As String
Dim intI As Integer
Dim intJ As Integer
Dim strSplit() As String

Screen.MousePointer = vbHourglass
If Trim(gstrInput) = "" Then
If Trim(Text2) <> "" And Trim(Text3) <> "" Then
If Not IsNumeric(Trim(Text3)) = True Then
MsgBox "Please enter a Numeric Value in to the second text box",
vbOKOnly + vbCritical, "Numeric Value"
GoTo fnGetSQLData_Exit
End If
strSQL = "tdm_MatrixChanges '" & Text2 & "'," & Text3 & ""
Else
strSQL = "tdm_MatrixChanges 'FULL', 0"
End If
Else
strSplit = Split(gstrInput, ",")
If UCase(Trim(strSplit(0))) = "FULL" Then
strSQL = "tdm_MatrixChanges 'FULL',0"
Else
strSQL = "tdm_MatrixChanges '" & strSplit(0) & "', " & strSplit(1) &
""
End If
End If
Set rsADOOMatrix = curSQLDB.Execute(strSQL)
If Not rsADOOMatrix.EOF Then
intJ = rsADOOMatrix.Fields.Count - 1
FLX.Rows = 0
FLX.Cols = intJ + 1
strRow = rsADOOMatrix.Fields(0).Name
For intI = 1 To intJ
strRow = strRow & vbTab & rsADOOMatrix(intI).Name
Next intI
With FLX
.AddItem strRow
.Rows = 2
.FixedRows = 1
.Rows = 1
.ColWidth(0) = 1000
.ColWidth(1) = 2500
.ColWidth(3) = 4380
.ColWidth(5) = 1200
.ColWidth(6) = 690
.ColAlignment(0) = 0
.ColAlignment(1) = 0
.ColAlignment(4) = 0
.ColAlignment(6) = 0
End With
While Not rsADOOMatrix.EOF
strRow = rsADOOMatrix(0)
For intI = 1 To intJ
strRow = strRow & vbTab & Trim(rsADOOMatrix(intI))
Next intI
FLX.AddItem strRow
rsADOOMatrix.MoveNext
Wend
Label8.Caption = "Total Netchange Records: " & FLX.Rows - 1
LogErrorMsg 9990, "Total Netchange Records: " & FLX.Rows - 1,
"fnGetSQLData", "", False
rsADOOMatrix.Close
Me.cmdUpLoad.Enabled = True
End If

fnGetSQLData_Exit:
Screen.MousePointer = vbNormal
Set rsADOOMatrix = Nothing
Exit Sub
fnGetSQLData_Error:
LogErrorMsg Err, Error, "fnGetSQLData", "", False
GoTo fnGetSQLData_Exit
End Sub

Public Function fnUpdateMatrix(OID As String, sParam As String, sValue As
String) As Boolean
On Error GoTo fnUpdateMatrix_Error
Dim strSQL As String

strSQL = "UPDATE BUSINESS_OBJECT_LONG_STRING_ATTRIBUTE SET [VALUE] = '"
& sValue & "' WHERE OID = '" & OID & "' AND ATTRIBUTE_NAME = '" & sParam & "'"
curMatrixDB.Execute strSQL, 0
If curMatrixDB.RecordsAffected > 0 Then
fnUpdateMatrix = True
Else
fnUpdateMatrix = False
End If

fnUpdateMatrix_Exit:
Exit Function
fnUpdateMatrix_Error:
LogErrorMsg Err, Error, "fnUpdateMatrix", "", False
fnUpdateMatrix = False
GoTo fnUpdateMatrix_Exit
End Function

Public Function fnLoopNetChange() As Boolean
On Error GoTo fnLoopNetChange_Error
Dim intI As Long
Dim strSQL As String
Dim rsADOMtxObject As Recordset
Dim blRet As Boolean
Dim intJ As Long
Dim intRows As Long
Dim intZ As Long
Dim startTime As Date
Dim blFirst As Boolean
Dim blSuccess As Boolean

startTime = Date & " " & Time
Label10.Caption = "Time Started: " & startTime
With flxTDM
intJ = 1
intI = 1
intZ = 0
intRows = .Rows - 1
LogErrorMsg 9991, "Started Looping Through Netchange Table",
"fnLoopNetChange", "", False
comeHERE:
intJ = intI
For intI = intJ To .Rows - 1
If cmdCancel.Enabled = True Then
intZ = intZ + 1
Label9.Caption = "Processing " & "(" & .TextMatrix(intI, 1)
& ") " & intZ & "/" & intRows & "..."
.RowSel = intI
.ColSel = .Cols - 1
strSQL = "SELECT * FROM BUSINESS_OBJECT WHERE NAME = '" &
UCase(Trim(.TextMatrix(intI, 1))) & "' AND REVISION = '" &
UCase(Trim(.TextMatrix(intI, 2))) & "'"
Set rsADOMtxObject = curMatrixDB.OpenRecordset(strSQL,
dbOpenDynaset)
'If UCase(Trim(.TextMatrix(intI, 1))) = "22B18" Then Stop
If Not rsADOMtxObject.EOF Then
blFirst = True
While Not rsADOMtxObject.EOF
DoEvents
If fnUpdateMatrix(rsADOMtxObject("OID"),
"TDM_CAD_Server_ID", .TextMatrix(intI, 4)) = True Then
If fnUpdateMatrix(rsADOMtxObject("OID"),
"TDM_State", .TextMatrix(intI, 5)) = True Then
If fnUpdateMatrix(rsADOMtxObject("OID"),
"TDM_View_Filename", .TextMatrix(intI, 3)) = True Then
If fnUpdateMatrix(rsADOMtxObject("OID"),
"TDM_Version", .TextMatrix(intI, 6)) = True Then
If blFirst = True Then
If fnUpdateSQL(.TextMatrix(intI,
0), .TextMatrix(intI, 1), .TextMatrix(intI, 2), .TextMatrix(intI, 3),
..TextMatrix(intI, 4), .TextMatrix(intI, 5), 1, .TextMatrix(intI, 6)) = True
Then
blFirst = False
blSuccess = True
End If
End If
Else
Call fnUpdateSQL(.TextMatrix(intI,
0), .TextMatrix(intI, 1), .TextMatrix(intI, 2), .TextMatrix(intI, 3),
..TextMatrix(intI, 4), .TextMatrix(intI, 5), 0, .TextMatrix(intI, 6))
End If
Else
Call fnUpdateSQL(.TextMatrix(intI, 0),
..TextMatrix(intI, 1), .TextMatrix(intI, 2), .TextMatrix(intI, 3),
..TextMatrix(intI, 4), .TextMatrix(intI, 5), 0, .TextMatrix(intI, 6))
End If
Else
Call fnUpdateSQL(.TextMatrix(intI, 0),
..TextMatrix(intI, 1), .TextMatrix(intI, 2), .TextMatrix(intI, 3),
..TextMatrix(intI, 4), .TextMatrix(intI, 5), 0, .TextMatrix(intI, 6))
End If
Else
Call fnUpdateSQL(.TextMatrix(intI, 0),
..TextMatrix(intI, 1), .TextMatrix(intI, 2), .TextMatrix(intI, 3),
..TextMatrix(intI, 4), .TextMatrix(intI, 5), 0, .TextMatrix(intI, 6))
End If
rsADOMtxObject.MoveNext
Wend
If blSuccess = True Then
blSuccess = False
If .Rows > 2 Then
.RemoveItem (intI)
GoTo comeHERE
Else
.Rows = 1
Me.cmdUpLoad.Enabled = False
End If
End If
End If
Set rsADOMtxObject = Nothing
DoEvents
Else
GoTo cmdCancel
Label9.Caption = "Processed " & intZ & "/" & intRows & "..."
End If
Next intI
Label9.Caption = "Processed " & intRows & "/" & intRows & "..."
cmdCancel:
Label10.Caption = Label10.Caption & "--Time Ended: " & Date & " " &
Time
End With
'rsADOMtxObject.Close
LogErrorMsg 9992, "Ended Looping Through Netchange Table",
"fnLoopNetChange", "", False

fnLoopNetChange_Exit:
Set rsADOMtxObject = Nothing
Exit Function
fnLoopNetChange_Error:
LogErrorMsg Err, Error, "fnLoopNetChange", "", True
GoTo fnLoopNetChange_Exit
End Function

Public Function fnUpdateSQL(itemID As String, itemPartNumber As String,
itemRevision As String, itemViewFileName As String, itemRegisteredID As
String, itemStateName As String, uploadStatus As Integer, itemVersion As
String) As Boolean
On Error GoTo fnUpdateSQL_Error
Dim strSQL As String

strSQL = "tdm_MatrixHistory " & itemID & ", '" & itemPartNumber & "', '"
& itemRevision & "', '" & itemViewFileName & "', " & itemRegisteredID & ", '"
& itemStateName & "', " & itemVersion & ", " & uploadStatus & ", '" &
gEventID & "'"
curSQLDB.Execute (strSQL)
fnUpdateSQL = True

fnUpdateSQL_Exit:
Exit Function
fnUpdateSQL_Error:
LogErrorMsg Err, Error, "fnUpdateSQL", "", False
fnUpdateSQL = False
GoTo fnUpdateSQL_Exit
End Function

Private Sub Form_Load()
gstrInput = Command$()
Call fnSQLDBConnect
Call fnMatrixDBConnect
If gstrInput <> "" Then
Load fmMain
With fmMain
.cmdCancel.Enabled = True
.Visible = False
LogErrorMsg 1111, "getting SQL Data", "form_load", "", False
Call .fnGetSQLData(.flxTDM)
If .flxTDM.Rows > 0 Then
Call .fnLoopNetChange
End If
Call .Form_Unload(True)
End
End With
Else
fmMain.Visible = True
End If
End Sub

Private Sub Form_Terminate()
Call Form_Unload(True)
End Sub

Public Sub Form_Unload(Cancel As Integer)
LogErrorMsg 9998, "Session Ended", "App Exit", "", False
curSQLDB.Close
Set curSQLDB = Nothing
End
End Sub


Here's the module...........................................................

Option Explicit

Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal
lpBuffer As String, nSize As Long) As Long
Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA"
(ByVal lpBuffer As String, nSize As Long) As Long
Public curSQLDB As ADODB.Connection
Public curMatrixDB As Database
Public gUserID As String
Public gComputerName As String
Public gstrConnectMatrix As String
Public gstrConnectSQL As String
Public gstrInput As String
Public gEventID As String

Public Function fnMatrixDBConnect() As Boolean
On Error GoTo fnMatrixDBConnect_Error
Dim strSQL As String
Dim strErr As Long
Dim strAlias As String

gstrConnectMatrix = "DSN=MatrixOne, Inc." ';UID=XXXXX;PWD=XXXXX"
Set curMatrixDB = OpenDatabase("", False, False, gstrConnectMatrix)
With curMatrixDB
.QueryTimeout = 9000
End With
fmMain.Label11.Caption = gstrConnectMatrix
fnMatrixDBConnect = True

fnMatrixDBConnect_Exit:
Exit Function
fnMatrixDBConnect_Error:
fmMain.Label11.Caption = "DSN!=MatrixOne, Inc."
fnMatrixDBConnect = False
strErr = Err
LogErrorMsg strErr, Error, "fnMatrixDBConnect", "", False
Err.Clear
GoTo fnMatrixDBConnect_Exit
End Function

Function fnAPIGetUsername() As Boolean
On Error GoTo fnAPIGetUsername_Error
Dim strUserID As String
Dim vRet
Dim intI As Integer

strUserID = String$(50, " ")
vRet = GetUserName(strUserID, 8)
gUserID = UCase(Mid(Trim(strUserID), 1, 6))
If Trim(gUserID) = "" Then
GoTo fnAPIGetUsername_Exit
Else
For intI = 1 To Len(gUserID)
If Asc(Mid(gUserID, intI, 1)) < 48 Then
gUserID = Mid(gUserID, 1, intI - 1)
End If
Next intI
End If
fnAPIGetUsername = True

fnAPIGetUsername_Exit:
Exit Function
fnAPIGetUsername_Error:
LogErrorMsg Err, Error, "fnAPIGetUsername", "", False
GoTo fnAPIGetUsername_Exit
End Function


Public Sub LogErrorMsg(ErrorNumber As Long, ErrorDescription As String,
ErrorLocation As String, CustomMessage As String, DoIDisplay As Boolean)
On Error GoTo LogErrorMsg_Error
Dim strErrMsg As String
Dim strSQL As String

DoEvents
If CustomMessage <> "" Then
strErrMsg = "No: " & ErrorNumber & " .. Desc: " & ErrorDescription &
" Message: " & CustomMessage
Else
strErrMsg = "No: " & ErrorNumber & " .. Desc: " & ErrorDescription
End If
strErrMsg = Trim(Left(strErrMsg, 254))
If DoIDisplay Then
If CustomMessage <> "" Then
Call ErrorNotify(ErrorNumber, ErrorDescription & " " &
CustomMessage, ErrorLocation)
Else
Call ErrorNotify(ErrorNumber, ErrorDescription, ErrorLocation)
End If
Else
strSQL = "tdm_LogEvent '" & App.ProductName & " " & App.Major & "."
& App.Minor & "', '" & gComputerName & "', '" & gUserID & "','" &
ErrorLocation & "','" & ErrorNumber & "', '" & ErrorDescription & "', '" &
gEventID & "'"
curSQLDB.Execute (strSQL)
End If

LogErrorMsg_Exit:
Exit Sub
LogErrorMsg_Error:
GoTo LogErrorMsg_Exit
End Sub

Public Sub ErrorNotify(ErrNo, errorDesc As String, ErrLocation As String)

MsgBox "Error Number: " & ErrNo & vbCrLf & vbCrLf & "Error Description:
" & errorDesc & vbCrLf & vbCrLf & "Error Location: " & ErrLocation & vbCrLf &
vbCrLf & "Please contact your System Administrator to resolve the Error...",
vbOKOnly + vbCritical, "Error in " & ErrLocation

End Sub

Function fnAPIGetComputerName() As Boolean
On Error GoTo fnAPIGetComputerName_Error
Dim lstrComputerName As String
Dim lngLength As Long
Dim lngResult As Long

lngLength = 50
lstrComputerName = String$(lngLength, 0)
lngResult = GetComputerName(lstrComputerName, lngLength)
gComputerName = Left(lstrComputerName, InStr(1, lstrComputerName,
Chr(0)) - 1)
gEventID = gUserID & gComputerName & Format(Date, "MMDDYYYY") &
Format(Time, "HHMMSS")
fnAPIGetComputerName = True

fnAPIGetComputerName_Exit:
Exit Function
fnAPIGetComputerName_Error:
fnAPIGetComputerName = False
Call ErrorNotify(Err, Error, "fnAPIGetComputerName")
Err.Clear
GoTo fnAPIGetComputerName_Exit
End Function

Public Function fnSQLDBConnect() As Boolean
On Error GoTo fnSQLDBConnect_Error
Dim strSQL As String
Dim strErr As Long

If fnAPIGetUsername = True Then
Call fnAPIGetComputerName
gstrConnectSQL = "Provider=sqloledb;Data Source=" & "XXXXXXX" &
";Initial Catalog=" & "IDEASTDM" & ";User Id=" & "XXXXXXX" & ";Password=" &
"XXXXXXX" & ";"
Set curSQLDB = New ADODB.Connection
With curSQLDB
.ConnectionString = gstrConnectSQL
.CommandTimeout = 180
.Open
End With
LogErrorMsg 9999, "Session Started - " & gstrInput,
"fnSQLDBConnect", "", False
fnSQLDBConnect = True
Else
LogErrorMsg 999, "No Connection to the SQL Server.",
"fnSQLDBConnect", "", True
End
End If

fnSQLDBConnect_Exit:
Exit Function
fnSQLDBConnect_Error:
fnSQLDBConnect = False
strErr = Err
LogErrorMsg Err, Error, "fnSQLDBConnect", "", False
If strErr = -2147217843 Or strErr = -2147467259 Or strErr = -2147217865
Then
End
End If
Err.Clear
GoTo fnSQLDBConnect_Exit
End Function


I blocked out any server names, ids and passwords to protect the
innocent........

I really appreciate your suggestions/input............Thanks.
.