Advertisement

04.05.2008 at 02:37AM PDT, ID: 23298114
[x]
Attachment Details

vb6 recordset error

Asked by Mearsy1976 in VB Objects, Miscellaneous Programming, Visual Basic Programming

Tags: MICROSOFT, vb6, vb6

Im using a program for work and it scans database for all files in which office i enter and all the benefit types of the files i enter then brings me back range results for my files that fit criteria.
if there are too may benefit types vb6 sort of times out on my and the results screen i get my file numbers wont fit all the results.

i wanted to output my results to a text file instead of my results window but am unsure how to
my form code is below
Start Free Trial 
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
306:
307:
308:
309:
310:
311:
312:
313:
314:
315:
316:
317:
318:
319:
320:
321:
322:
323:
324:
325:
326:
327:
328:
329:

Option Explicit
 
Public ws As Workspace
Public db As Database
Public con As Connection
Public rs As Recordset
Public rsUpdate As Recordset
Public rs1 As Recordset
Public rs2 As Recordset
 
Dim cRanges As colRanges
Dim colBoxesToKeep As Collection
Dim colBoxesToDelete As Collection
 
Private Sub ben1_Change()
txtBenTypes.Text = ben1.ItemData
End Sub
 
Private Sub cmdCheckMixedBoxes_Click()
Dim sQuery As String
Dim i, j As Integer
Dim iGood As Integer
Dim iBad As Integer
Dim rsThisOne As Recordset
 
Set colBoxesToKeep = Nothing
Set colBoxesToKeep = New Collection
 
Set colBoxesToDelete = Nothing
Set colBoxesToDelete = New Collection
 
sQuery = "select f.boxnumber, count(*) " & _
         "from files f " & _
         "inner join box b on b.boxnumber=f.boxnumber " & _
         "where b.code='" & txtFromCode.Text & "' and b.department='" & txtFromDept.Text & "' " & _
         "and f.text4 in (" & txtBenTypes.Text & ") and f.boxnumber not like '9[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-1]B' " & _
         "group by f.boxnumber " & _
         "order by convert(float,left(f.boxnumber,len(f.boxnumber)-1))"
 
Label5.Caption = "Executing Query"
DoEvents
 
Set rs = con.OpenRecordset(sQuery, dbOpenSnapshot)
 
If rs.RecordCount > 1 Then
    rs.MoveFirst
Else
    MsgBox "No results returned from Query!"
End If
 
txtMixedBoxes.Text = "Files of benefit type " & txtBenTypes.Text & " transferring from " & txtFromCode.Text & " to " & txtToCode.Text & vbCrLf
 
For i = 1 To rs.RecordCount
    Label5.Caption = "Checking Box " & i & " of " & rs.RecordCount
    DoEvents
    
    sQuery = "select boxnumber, filenumber, Text4, Text1, Text2, Text3 from files where boxnumber = '" & Trim(rs.Fields("BoxNumber")) & _
             "' and text4 not in (" & txtBenTypes.Text & ")"
    
    Set rs1 = con.OpenRecordset(sQuery, dbOpenSnapshot)
    If rs1.RecordCount <> 0 Then
        sQuery = "select boxnumber, filenumber, Text4, Text1, Text2, Text3 from files where boxnumber='" & Trim(rs.Fields("BoxNumber")) & _
             "' and text4 in (" & txtBenTypes.Text & ")"
        Set rs2 = con.OpenRecordset(sQuery, dbOpenSnapshot)
        
        iGood = rs2.RecordCount
        iBad = rs1.RecordCount
        txtMixedBoxes.Text = txtMixedBoxes.Text & "_______________________________" & vbCrLf
        txtMixedBoxes.Text = txtMixedBoxes.Text & "Box Number " & Trim(rs.Fields("BoxNumber")) & _
                             " contains " & iGood & " Files which conform to the xfer and " & iBad & _
                             " Files which do not conform" & vbCrLf
        txtMixedBoxes.Text = txtMixedBoxes.Text & "The following file(s) need to be transferred into a box of the correct benefit type : " & vbCrLf & vbCrLf
        
        If iBad > iGood Then
            Set rsThisOne = rs2
            colBoxesToDelete.Add Trim(rs.Fields("BoxNumber"))
        Else
            Set rsThisOne = rs1
            colBoxesToDelete.Add Trim(rs.Fields("BoxNumber"))
        End If
        
        rsThisOne.MoveFirst
        For j = 1 To rsThisOne.RecordCount
            txtMixedBoxes.Text = txtMixedBoxes.Text & Trim(rsThisOne.Fields("BoxNumber")) & vbTab & _
                                                     Trim(rsThisOne.Fields("FileNumber")) & vbTab & _
                                                     Trim(rsThisOne.Fields("Text4")) & vbTab & _
                                                     Trim(rsThisOne.Fields("Text1")) & vbTab & _
                                                     Trim(rsThisOne.Fields("Text2")) & vbTab & _
                                                     Trim(rsThisOne.Fields("Text3")) & vbTab & _
                                                     vbCrLf
            rsThisOne.MoveNext
        Next j
    Else
        colBoxesToKeep.Add Trim(rs.Fields("BoxNumber"))
    End If
    
    rs.MoveNext
Next i
Label5.Caption = "Done!  Use the Generate Ranges Excluding Mixed Boxes Button Below."
DoEvents
 
End Sub
 
Private Sub cmdExecQuery_Click()
Dim i As Integer
 
lblListDetails.Caption = "Executing Query ..."
DoEvents
Set rs = con.OpenRecordset(txtQuery.Text, dbOpenSnapshot)
 
If rs.RecordCount > 0 Then
    rs.MoveFirst
Else
    MsgBox "No results returned from Query!"
End If
 
lblListDetails.Caption = "Query Executed - " & rs.RecordCount & " Results Returned"
DoEvents
End Sub
 
 
Private Function CheckSourceDest() As Boolean
CheckSourceDest = False
If Not IsNumeric(txtFromCode.Text) Or Not IsNumeric(txtToCode.Text) Or _
   Not IsNumeric(txtFromDept.Text) Or Not IsNumeric(txtToDept.Text) Then
   MsgBox "You have not completed the from code, to code, from dept or to dept fields " & vbCrLf & _
          "with a valid number." & vbCrLf & vbCrLf & _
          "Please complete correctly and try again", , "Invalid From/To details!"
    Exit Function
End If
 
If txtFromCode = "" Or txtToCode = "" Or txtFromDept = "" Or txtToDept = "" Then
   MsgBox "You have not completed the from code, to code, from dept or to dept fields " & vbCrLf & _
          "with a valid number." & vbCrLf & vbCrLf & _
          "Please complete correctly and try again", , "Invalid From/To details!"
    Exit Function
End If
 
If txtFromCode = txtToCode Then
   MsgBox "The From Code should not be the same as the To Code!" & vbCrLf & vbCrLf & _
          "Please complete correctly and try again", , "Invalid From/To details!"
    Exit Function
End If
 
CheckSourceDest = True
End Function
 
Private Sub cmdGenerateRanges_Click()
Dim lStart As Long
Dim lEnd As Long
Dim lThisOne As Long
Dim lLastOne As Long
Dim i As Integer
Dim sThisRecord As String
 
If Not CheckSourceDest Then Exit Sub
 
' Get rid of the old range collection
Set cRanges = Nothing
Set cRanges = New colRanges
 
lblRangeDetails.Caption = "Generating Ranges ..... "
DoEvents
 
lLastOne = 0
lStart = 0
rs.MoveFirst
For i = 1 To rs.RecordCount
    sThisRecord = Trim(rs.Fields("BoxNumber"))
    If UCase(Right(sThisRecord, 1)) <> "B" Then
        MsgBox "Box Number Does Not end in a 'B' - Aborting"
        Exit Sub
    End If
    
    lThisOne = Val(Left(sThisRecord, Len(sThisRecord) - 1))
    If lThisOne <> lLastOne + 1 Then
        ' New Series - log old series first
        lEnd = lLastOne
        If lStart <> 0 Then
            cRanges.Add lEnd & "B", lStart & "B", (lEnd - lStart) + 1
            'MsgBox "Series = " & lStart & " to " & lEnd
        End If
        
        ' Now start a new series with this barcode
        lStart = lThisOne
    Else
        ' Same series just carry on
    End If
 
    If i = rs.RecordCount Then
        'Last record - Take appropriate action
        lEnd = lThisOne
        If lStart <> 0 Then
            cRanges.Add lEnd & "B", lStart & "B", (lEnd - lStart) + 1
            'MsgBox "Series = " & lStart & " to " & lEnd
        End If
    End If
    
    lLastOne = lThisOne
    rs.MoveNext
Next i
 
lblRangeDetails.Caption = cRanges.Count & " Ranges Generated ..... "
DoEvents
txtMixedBoxes.Text = ""
For i = 1 To cRanges.Count
    txtMixedBoxes.Text = txtMixedBoxes.Text & "exec sp_NewOwners " & _
                         "'" & txtFromCode.Text & "', " & _
                         "'" & txtToCode.Text & "', " & _
                         "'" & txtFromDept.Text & "', " & _
                         "'" & txtToDept.Text & "', " & _
                         "'" & cRanges(i).sStart & "', " & _
                         "'" & cRanges(i).sEnd & "'" & vbCrLf
Next i
End Sub
 
Private Sub cmdRangesFromCollection_Click()
Dim lStart As Long
Dim lEnd As Long
Dim lThisOne As Long
Dim lLastOne As Long
Dim i As Integer
Dim sThisRecord As String
 
If Not CheckSourceDest Then Exit Sub
 
' Get rid of the old range collection
Set cRanges = Nothing
Set cRanges = New colRanges
 
lblRangeDetails1.Caption = "Generating Ranges ..... "
DoEvents
 
lLastOne = 0
lStart = 0
For i = 1 To colBoxesToKeep.Count
    sThisRecord = Trim(colBoxesToKeep(i))
    If UCase(Right(sThisRecord, 1)) <> "B" Then
        MsgBox "Box Number Does Not end in a 'B' - Aborting"
        Exit Sub
    End If
    
    lThisOne = Val(Left(sThisRecord, Len(sThisRecord) - 1))
    If lThisOne <> lLastOne + 1 Then
        ' New Series - log old series first
        lEnd = lLastOne
        If lStart <> 0 Then
            cRanges.Add lEnd & "B", lStart & "B", (lEnd - lStart) + 1
            'MsgBox "Series = " & lStart & " to " & lEnd
        End If
        
        ' Now start a new series with this barcode
        lStart = lThisOne
    Else
        ' Same series just carry on
    End If
 
    If i = colBoxesToKeep.Count Then
        'Last record - Take appropriate action
        lEnd = lThisOne
        If lStart <> 0 Then
            cRanges.Add lEnd & "B", lStart & "B", (lEnd - lStart) + 1
            'MsgBox "Series = " & lStart & " to " & lEnd
        End If
    End If
    
    lLastOne = lThisOne
Next i
 
lblRangeDetails1.Caption = cRanges.Count & " Ranges Generated ..... "
DoEvents
txtMixedBoxes.Text = ""
For i = 1 To cRanges.Count
    txtMixedBoxes.Text = txtMixedBoxes.Text & "exec sp_NewOwners " & _
                         "'" & txtFromCode.Text & "', " & _
                         "'" & txtToCode.Text & "', " & _
                         "'" & txtFromDept.Text & "', " & _
                         "'" & txtToDept.Text & "', " & _
                         "'" & cRanges(i).sStart & "', " & _
                         "'" & cRanges(i).sEnd & "'" & vbCrLf
Next i
End Sub
 
Private Sub Combo1_Click()
    If Combo1.ListIndex > -1 Then
        txtBenTypes.Text = txtBenTypes.Text & (Combo1.List(Combo1.ListIndex))
    End If
End Sub
 
Private Sub Form_Load()
Dim strConnection As String
Dim sQuery As String
 
strConnection = "ODBC;DSN=MOPS;"
Set ws = CreateWorkspace("NewODBCWorkspace", "SOM", "SOM24022008", dbUseODBC)
Set con = ws.OpenConnection("Con1", , , strConnection)
con.QueryTimeout = 800
 
sQuery = "SETUSER 'FullAd' WITH NORESET"
con.Execute sQuery
 
txtQuery.Text = "select b.boxnumber, b.text3 from box b " & vbCrLf & _
                "left outer join files f on f.boxnumber=b.boxnumber " & vbCrLf & _
                "where b.code='' and b.department='01' " & vbCrLf & _
                "      and f.boxnumber is null " & vbCrLf & _
                "      and b.text3 in () " & vbCrLf & _
                "      and b.boxnumber not like '9[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-1]B' " & vbCrLf & _
                "order by convert(float,left(b.boxnumber,len(b.boxnumber)-1))"
txtFromDept.Text = "01"
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
Set cRanges = Nothing
 
If Not rs Is Nothing Then rs.Close
If Not rs1 Is Nothing Then rs1.Close
If Not rs2 Is Nothing Then rs2.Close
If Not con Is Nothing Then con.Close
Set rs = Nothing
Set rs1 = Nothing
Set rs2 = Nothing
Set con = Nothing
End Sub
 
 
Private Sub txtFromDept_Change()
    txtToDept.Text = txtFromDept.Text
    DoEvents
End Sub
[+][-]04.05.2008 at 03:13AM PDT, ID: 21287614

At Experts Exchange, members can ask their questions to thousands of technology professionals, also known as Experts. Experts compete and collaborate to answer those questions by leaving comments like this one.

Start your 7-day free trial to view this Expert Comment or ask the Experts your question.

 
[+][-]04.05.2008 at 03:23AM PDT, ID: 21287644

Often, when Experts are collaborating with members who have asked questions, they will request additional information about the problem. Askers respond with an author comment like this one.

Start your 7-day free trial to view this Author Comment or ask the Experts your question.

 
[+][-]04.05.2008 at 04:08AM PDT, ID: 21287739

At Experts Exchange, members can ask their questions to thousands of technology professionals, also known as Experts. Experts compete and collaborate to answer those questions by leaving comments like this one.

Start your 7-day free trial to view this Expert Comment or ask the Experts your question.

 
[+][-]04.05.2008 at 04:34AM PDT, ID: 21287797

Often, when Experts are collaborating with members who have asked questions, they will request additional information about the problem. Askers respond with an author comment like this one.

Start your 7-day free trial to view this Author Comment or ask the Experts your question.

 
[+][-]04.05.2008 at 10:47AM PDT, ID: 21288960

At Experts Exchange, members can ask their questions to thousands of technology professionals, also known as Experts. Experts compete and collaborate to answer those questions by leaving comments like this one.

Start your 7-day free trial to view this Expert Comment or ask the Experts your question.

 
[+][-]04.09.2008 at 05:28AM PDT, ID: 21314109

Often, when Experts are collaborating with members who have asked questions, they will request additional information about the problem. Askers respond with an author comment like this one.

Start your 7-day free trial to view this Author Comment or ask the Experts your question.

 
[+][-]04.09.2008 at 07:28AM PDT, ID: 21315263

At Experts Exchange, members can ask their questions to thousands of technology professionals, also known as Experts. Experts compete and collaborate to answer those questions by leaving comments like this one.

Start your 7-day free trial to view this Expert Comment or ask the Experts your question.

 
[+][-]04.09.2008 at 08:25AM PDT, ID: 21315919

Often, when Experts are collaborating with members who have asked questions, they will request additional information about the problem. Askers respond with an author comment like this one.

Start your 7-day free trial to view this Author Comment or ask the Experts your question.

 
[+][-]04.09.2008 at 08:53AM PDT, ID: 21316187

View this solution now by starting your 7-day free trial. Setting up your free trial is quick, easy, and secure. We will return you to this solution, unlocked, when you're done.

 

About this solution

Zones: VB Objects, Miscellaneous Programming, Visual Basic Programming
Tags: MICROSOFT, vb6, vb6
Sign Up Now!
Solution Provided By: GrahamSkan
Participating Experts: 1
Solution Grade: B
 
 
 
Loading Advertisement...
20080716-EE-VQP-32 / EE_QW_2_20070628