Hi Hitesh,
Attached all the VB6 code to do with this. Ignore all the Debug stuff and
also all the RaiseEvent lines. Note that this uses the free VB SQLite
wrapper from Olaf Schmidt and if you don't use that then that is very much
recommended. Let me know if you want that and I will explain.
Also note that my code does something slightly different then what you want
to do, but still, it might be useful.
Bart
On Sat, Apr 27, 2013 at 2:12 PM, hiteshambaliya
<hitesh.ambal...@gmail.com>wrote:
> Ya I am interested to know more.
>
> My mail ID hitesh.ambal...@gmail.com
>
> Thank you so much
>
>
>
> --
> View this message in context:
> http://sqlite.1065341.n5.nabble.com/sequential-row-numbers-from-query-tp47370p68515.html
> Sent from the SQLite mailing list archive at Nabble.com.
> _______________________________________________
> sqlite-users mailing list
> sqlite-users@sqlite.org
> http://sqlite.org:8080/cgi-bin/mailman/listinfo/sqlite-users
>
Public Function SetSequentialGroups(strDB As String, _
strTable As String, _
strGroupField As String, _
strIDField As String, _
strCompareField1 As String, _
Optional strCompareField2 As String, _
Optional strCompareField3 As String, _
Optional lFirstGroupNumber As Long, _
Optional bLog As Boolean, _
Optional bDebug As Boolean) As Long
Dim i As Long
Dim c As Long
Dim cRs As cRecordset
Dim cCmd As cCommand
Dim lGroupIdx As Long
Dim bDoGroupSwitch As Boolean
Dim lCompareFields As Long
Dim V1
Dim V2
Dim V3 'compare-values as variant
Dim lFieldCount As Long
Dim lCompareFieldNumber1 As Long 'all these 4 0-based for convenience
Dim lCompareFieldNumber2 As Long
Dim lCompareFieldNumber3 As Long
Dim lIDFieldNumber As Long
10 On Error GoTo ERROROUT
20 SetSQLiteConn strDB, , , False
30 If SQLiteTableExists(strTable, strDB, False, True) = False Then
40 SetSequentialGroups = -1
50 Exit Function
60 End If
70 If FieldNumberInTable(strDB, strTable, strGroupField, , False) < 1 Then
80 SetSequentialGroups = -1
90 Exit Function
100 End If
110 If FieldNumberInTable(strDB, strTable, strIDField, , False) < 1 Then
120 SetSequentialGroups = -1
130 Exit Function
140 End If
150 If FieldNumberInTable(strDB, strTable, strCompareField1, , False) < 1
Then
160 SetSequentialGroups = -1
170 Exit Function
180 End If
190 lGroupIdx = lFirstGroupNumber 'initilize the first lGroupIdx
200 Set cRs = Cnn.OpenRecordset("SELECT * FROM " & strTable & _
" ORDER BY " & strIDField & " ASC")
210 lFieldCount = cRs.Fields.Count
220 If Len(strCompareField2) = 0 Then
230 lCompareFields = 1
240 Else
250 If Len(strCompareField3) > 0 Then
260 lCompareFields = 3
270 Else
280 lCompareFields = 2
290 End If
300 End If
'IndexInFieldList is zero based
'------------------------------
310 lIDFieldNumber = cRs.Fields(strIDField).IndexInFieldList
320 lCompareFieldNumber1 = cRs.Fields(strCompareField1).IndexInFieldList
330 If lCompareFields > 1 Then
340 lCompareFieldNumber2 = cRs.Fields(strCompareField2).IndexInFieldList
350 End If
360 If lCompareFields > 2 Then
370 lCompareFieldNumber3 = cRs.Fields(strCompareField3).IndexInFieldList
380 End If
390 If bDebug Then
400 MsgBoxDLL "lFieldCount" & vbTab & lFieldCount & vbCrLf & _
"lIDFieldNumber" & vbTab & lIDFieldNumber & vbCrLf & _
"lCompareFieldNumber1" & vbTab & lCompareFieldNumber1 &
vbCrLf & _
"lCompareFieldNumber2" & vbTab & lCompareFieldNumber2 &
vbCrLf & _
"lCompareFieldNumber3" & vbTab & lCompareFieldNumber3 &
vbCrLf & _
"lCompareFields" & vbTab & lCompareFields, _
"Parameters of SetSequentialGroups", _
lFormColour:=lColourForm, bLineUpTabs:=True
410 End If
420 Set cCmd = Cnn.CreateCommand("UPDATE " & strTable & _
" SET " & strGroupField & " = ? WHERE " & _
strIDField & " = ?")
430 If bLog Then
440 ShowStatement "Procedure SetSequentialGroups", , , 2, True, , strDB
450 End If
460 BeginTransaction strDB, False
470 Select Case lCompareFields
Case 1
'now we work with valuematrix for more speed
480 V1 = cRs.ValueMatrix(0, lCompareFieldNumber1)
490 For i = 0 To cRs.RecordCount - 1
'we split up the comparisons, for a little bit more speed (VB has
no "early exit" in combined If-conditions)
500 If cRs.ValueMatrix(i, lCompareFieldNumber1) <> V1 Then
510 bDoGroupSwitch = True
520 Else
530 bDoGroupSwitch = False
540 End If
550 If bDoGroupSwitch Then 'set the next set of compare-values
560 V1 = cRs.ValueMatrix(i, lCompareFieldNumber1)
570 lGroupIdx = lGroupIdx + 1
580 End If
590 cCmd.SetInt32 1, lGroupIdx
600 cCmd.SetInt32 2, cRs.ValueMatrix(i, lIDFieldNumber) 'the current
ID-Field for the Where-Cond.
610 cCmd.Execute
620 Next i
630 Case 2
640 V1 = cRs.ValueMatrix(0, lCompareFieldNumber1)
650 V2 = cRs.ValueMatrix(0, lCompareFieldNumber2)
660 If bDebug Then
670 MsgBoxDLL "V1" & vbTab & V1 & vbCrLf & _
"V1" & vbTab & V1, _
"first compare values of SetSequentialGroups", _
lFormColour:=lColourForm, bLineUpTabs:=True
680 End If
690 For i = 0 To cRs.RecordCount - 1
'we split up the comparisons, for a little bit more speed (VB has
no "early exit" in combined If-conditions)
700 If cRs.ValueMatrix(i, lCompareFieldNumber1) <> V1 Then
710 bDoGroupSwitch = True
720 ElseIf cRs.ValueMatrix(i, lCompareFieldNumber2) <> V2 Then
730 bDoGroupSwitch = True
740 Else 'all Values are equal to the last ones
750 bDoGroupSwitch = False
760 End If
770 If bDoGroupSwitch Then 'set the next set of compare-values
780 V1 = cRs.ValueMatrix(i, lCompareFieldNumber1)
790 V2 = cRs.ValueMatrix(i, lCompareFieldNumber2)
800 lGroupIdx = lGroupIdx + 1
810 End If
820 cCmd.SetInt32 1, lGroupIdx
830 cCmd.SetInt32 2, cRs.ValueMatrix(i, lIDFieldNumber) 'the current
ID-Field for the Where-Cond.
840 cCmd.Execute
850 Next i
860 Case 3
870 V1 = cRs.ValueMatrix(0, lCompareFieldNumber1)
880 V2 = cRs.ValueMatrix(0, lCompareFieldNumber2)
890 V3 = cRs.ValueMatrix(0, lCompareFieldNumber3)
900 For i = 0 To cRs.RecordCount - 1
'we split up the comparisons, for a little bit more speed (VB has
no "early exit" in combined If-conditions)
910 If cRs.ValueMatrix(i, lCompareFieldNumber1) <> V1 Then
920 bDoGroupSwitch = True
930 ElseIf cRs.ValueMatrix(i, lCompareFieldNumber2) <> V2 Then
940 bDoGroupSwitch = True
950 ElseIf cRs.ValueMatrix(i, lCompareFieldNumber3) <> V3 Then
960 bDoGroupSwitch = True
970 Else 'all Values are equal to the last ones
980 bDoGroupSwitch = False
990 End If
1000 If bDoGroupSwitch Then 'set the next set of compare-values
1010 V1 = cRs.ValueMatrix(i, lCompareFieldNumber1)
1020 V2 = cRs.ValueMatrix(i, lCompareFieldNumber2)
1030 V3 = cRs.ValueMatrix(i, lCompareFieldNumber3)
1040 lGroupIdx = lGroupIdx + 1
1050 End If
1060 cCmd.SetInt32 1, lGroupIdx
1070 cCmd.SetInt32 2, cRs.ValueMatrix(i, lIDFieldNumber) 'the current
ID-Field for the Where-Cond.
1080 cCmd.Execute
1090 Next i
1100 End Select
1110 CommitTransaction strDB, False
1120 SetSequentialGroups = lGroupIdx
1130 Exit Function
ERROROUT:
1140 SetSequentialGroups = -1
1150 RaiseEvent RunErrorLog("SetSequentialGroups", Erl, Err, _
"strDB: " & strDB, True)
End Function
Public Function SQLiteTableExists(strTable As String, _
Optional strDB As String, _
Optional bStatement As Boolean, _
Optional bNotExistIfEmptyTable As Boolean, _
Optional bDropIfEmpty As Boolean, _
Optional strDBName As String = "main", _
Optional bDebug As Boolean) As Boolean
Dim cT As cTable
Dim cDB As cDataBase
10 If bFileExists(strDB) = False Then
20 Exit Function
30 End If
40 If LCase(strTable) = "sqlite_master" Then
50 SQLiteTableExists = True
60 Exit Function
70 End If
80 If Len(strTable) = 0 Or Len(strDB) = 0 Then
90 Exit Function
100 End If
110 If m_bShowErrors Then
120 On Error GoTo 0
130 Else
140 On Error GoTo ERROROUT
150 End If
160 If SetSQLiteConn(strDB, , "SQLiteTableExists", False) = False Then
170 Exit Function
180 End If
190 If bStatement Then
200 ShowStatement "checking for the table " & strTable, _
, , 2, True, True, strDB, , , , "SQLiteTableExists"
210 End If
220 Set cDB = Cnn.DataBases(strDBName)
230 For Each cT In cDB.Tables
240 If bDebug Then
250 MsgBoxDLL cT.Name, "table name", lFormColour:=lColourForm
260 End If
270 If LCase(cT.Name) = LCase(strTable) Or LCase(cT.Name) =
"sqlite_master" Then
280 If bNotExistIfEmptyTable Then
290 If SQLiteTableIsEmpty(strDB, strTable) Then
300 If bDropIfEmpty Then
'note that this can't be the default as node tables can be
empty
'if no records were found, but they are still needed to make
the
'concatenated big table to be dumped to the main table sheet
'---------------------------------------------------------------
310 DropSQLiteTable strDB, strTable, True, False
320 End If
330 Else
340 SQLiteTableExists = True
350 Exit Function
360 End If
370 Else 'If bNotExistIfEmptyTable
380 SQLiteTableExists = True
390 Exit Function
400 End If 'If bNotExistIfEmptyTable
410 End If
420 Next cT
430 Exit Function
ERROROUT:
440 RaiseEvent RunErrorLog("SQLiteTableExists", Erl, Err, _
"strDB: " & strDB & " strTable: " & strTable,
True)
End Function
Public Function FieldNumberInTable(strDB As String, _
strTable As String, _
strField As String, _
Optional bCaseInsensitive As Boolean = True,
_
Optional bPartial As Boolean = True, _
Optional strDBName As String = "main", _
Optional strButNotCSV As String) As Long
'if field found will produce field number, 1-base
'if field not found, but no error will produce 0
'if error will produce -1
'------------------------------------------------
Dim c As Long
Dim i As Long
Dim cDB As cDataBase
Dim cCo As cColumn
Dim arrNot As Variant
Dim bNot As Boolean
Dim bInNotArray As Boolean
On Error GoTo ERROROUT
If Len(strButNotCSV) > 0 Then
arrNot = Split(strButNotCSV, ",", , vbBinaryCompare)
bNot = True
End If
If SetSQLiteConn(strDB, , "FieldNumberInTable", False) = False Then
FieldNumberInTable = -1
Exit Function
End If
Set cDB = Cnn.DataBases(strDBName)
With cDB.Tables(strTable)
If bNot Then
If bCaseInsensitive Then
If bPartial Then
For Each cCo In .Columns
c = c + 1
'case-insensitive and partial compare
'------------------------------------
If InStr(1, UCase(cCo.Name), UCase(strField), vbBinaryCompare) > 0
Then
bInNotArray = False
For i = 0 To UBound(arrNot)
If InStr(1, UCase(cCo.Name), UCase(arrNot(i)), vbBinaryCompare)
> 0 Then
bInNotArray = True
Exit For
End If
Next i
If bInNotArray = False Then
FieldNumberInTable = c
Exit Function
End If
End If
Next cCo
Else 'If bPartial
For Each cCo In .Columns
c = c + 1
'case-insensitive and full compare
'---------------------------------
If UCase(cCo.Name) = UCase(strField) Then
bInNotArray = False
For i = 0 To UBound(arrNot)
If UCase(cCo.Name) = UCase(arrNot(i)) Then
bInNotArray = True
Exit For
End If
Next i
If bInNotArray = False Then
FieldNumberInTable = c
Exit Function
End If
End If
Next cCo
End If 'If bPartial
Else 'If bCaseInsensitive
If bPartial Then
For Each cCo In .Columns
c = c + 1
'case-sensitive and partial compare
'----------------------------------
If InStr(1, cCo.Name, strField, vbBinaryCompare) > 0 Then
bInNotArray = False
For i = 0 To UBound(arrNot)
If InStr(1, cCo.Name, arrNot(i), vbBinaryCompare) > 0 Then
bInNotArray = True
Exit For
End If
Next i
If bInNotArray = False Then
FieldNumberInTable = c
Exit Function
End If
End If
Next cCo
Else 'If bPartial
For Each cCo In .Columns
c = c + 1
'case-sensitive and full compare
'---------------------------------
If cCo.Name = strField Then
bInNotArray = False
For i = 0 To UBound(arrNot)
If cCo.Name = arrNot(i) Then
bInNotArray = True
Exit For
End If
Next i
If bInNotArray = False Then
FieldNumberInTable = c
Exit Function
End If
End If
Next cCo
End If 'If bPartial
End If 'If bCaseInsensitive
Else 'If bNot
If bCaseInsensitive Then
If bPartial Then
For Each cCo In .Columns
c = c + 1
'case-insensitive and partial compare
'------------------------------------
If InStr(1, UCase(cCo.Name), UCase(strField), vbBinaryCompare) > 0
Then
FieldNumberInTable = c
Exit Function
End If
Next cCo
Else 'If bPartial
For Each cCo In .Columns
c = c + 1
'case-insensitive and full compare
'---------------------------------
If UCase(cCo.Name) = UCase(strField) Then
FieldNumberInTable = c
Exit Function
End If
Next cCo
End If 'If bPartial
Else 'If bCaseInsensitive
If bPartial Then
For Each cCo In .Columns
c = c + 1
'case-sensitive and partial compare
'----------------------------------
If InStr(1, cCo.Name, strField, vbBinaryCompare) > 0 Then
FieldNumberInTable = c
Exit Function
End If
Next cCo
Else 'If bPartial
For Each cCo In .Columns
c = c + 1
'case-sensitive and full compare
'---------------------------------
If cCo.Name = strField Then
FieldNumberInTable = c
Exit Function
End If
Next cCo
End If 'If bPartial
End If 'If bCaseInsensitive
End If 'If bNot
End With
Exit Function
ERROROUT:
FieldNumberInTable = -1
End Function
_______________________________________________
sqlite-users mailing list
sqlite-users@sqlite.org
http://sqlite.org:8080/cgi-bin/mailman/listinfo/sqlite-users
