[Last Call] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 693
  • Last Modified:

VB6 - Why is using Redim Preserve for an array inside a while-wend causes to reset the array after the loop?

Experts,

I have the following code. It redims an array inside the loop, but when it comes out of the loop, the Dates() array is reset!

Please correct me!
Dim RS As New Recordset
           RS.Open "SELECT MAX(IKey) FROM M_Main_Calendar", CN, adOpenForwardOnly
           Me.txt_EventIKey = VAL(RS(0) & "") + 1
           
           Dim valueDate As Date, EDate As Date, Dates() As Date
           If Me.opt_EndAfter.Value = True Then
           ElseIf Me.opt_EndByDate.Value = True Then
              EDate = Me.txt_EDate.Value
           End If
           
           valueDate = Me.txt_SDate.Value
           i = 0
           
           While valueDate <= EDate
                  
                  ReDim Preserve Dates(i)
                  
                  If Me.chk_WorkingDays.Value = vbChecked And (Format(valueDate, "ddd") = "FRI" Or Format(valueDate, "ddd") = "SAT") Then
                     i = i - 1
                  Else
                     Dates(i) = valueDate
                  End If
                  
                  Select Case Me.cbo_Recurrence.Text
                         Case "Daily"
                              valueDate = DateAdd("d", 1, valueDate)
                         Case "Weekly"
                              If Format(valueDate, "dddd") = Me.cbo_WeekDays.Text Then
                                 Dates(i) = valueDate
                              Else
                                 i = i - 1
                              End If
                              valueDate = DateAdd("d", 1, valueDate)
                         Case "Monthly"
                              If Me.opt_Monthly_Day_BOM.Value = True Then
                                 valueDate = Format(DateAdd("m", 1, valueDate), "1/mm/yyyy")
                              ElseIf Me.opt_Monthly_Day_EOM.Value = True Then
                                 valueDate = DateAdd("d", -1, Format(DateAdd("m", 2, valueDate), "1/mm/yyyy")) 'DateAdd("m", DateSerial(Year(valueDate), Month(valueDate), 1)) - 1
                              ElseIf Me.opt_Monthly_Day_Custom.Value = True Then
                                 valueDate = DateAdd("m", 1, valueDate)
                              End If
                  End Select
                  i = i + 1
           Wend
           
           For i = 0 To UBound(Dates()) - 1
               Me.Form_Insert Me.txt_EventIKey, _
                              VAL(Uno), _
                              Me.txt_head, _
                              Me.txt_body, _
                              Me.txt_SDate.Value, _
                              EDate, _
                              Dates(i)
           Next

Open in new window

0
feesu
Asked:
feesu
  • 4
  • 3
  • 3
1 Solution
 
Louis01Commented:
What happens if you change
ReDim Preserve Dates(i)
to
If i > UBound(Dates) then ReDim Preserve Dates(i)
?
0
 
feesuAuthor Commented:
Then it gives a "Subscript out of range" error on the first loop.
0
 
Louis01Commented:
If i = 0 then
      ReDim Preserve Dates(i)
else
      If i > UBound(Dates) then ReDim Preserve Dates(i)
end if
0
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 
Chris BottomleyCommented:
Hello feesu,

Are you sure your operations on 'i' are doing what you want ... you potentially decrement it in a few paths so the subsequent increment may be setting it back to the value before the loop?  i.e. it is not the preserve that is failing rather the incremental redim by virtue of the fact that 'i' isn't working right.  You could put a few debug traces in each time i is changed to see what happens ...

                     i = i - 1
debug.print "i Decremented by Fri/Sat check to: " & i


Regards,
Chris
0
 
feesuAuthor Commented:
Louis01,
The code didn't solve the bug. However, it didn't give the first error anymore.

Chris,
I shall check that and get back.
0
 
Louis01Commented:
Your routine would decrease the value of the array by 2 everytime you hit the following condition:
If valueDate = "FRI" or "SAT" AND chk_WorkingDays is checked AND cbo_Recurrence = "Monthly" .

Perhaps you can explain what you are trying to do?
0
 
Chris BottomleyCommented:
Louis01

Wow! why didn't I think of that ... oh wait I did ... you ought to refresh the screen a bit more often.

Chris
0
 
feesuAuthor Commented:
Experts,

I have fixed my bug. It works fine now. Attached is the new code.

Thank you all.
           Dim RS As New Recordset
           RS.Open "SELECT MAX(IKey) FROM M_Main_Calendar", CN, adOpenForwardOnly
           Me.txt_EventIKey = VAL(RS(0) & "") + 1
           
           Dim valueDate As Date, EDate As Date, Dates() As Date
           If Me.opt_EndAfter.Value = True Then
                                                         
           ElseIf Me.opt_EndByDate.Value = True Then
              EDate = Me.txt_EDate.Value
           End If
             
           valueDate = Me.txt_SDate.Value
           i = 0
           
           While valueDate <= EDate
                  
                  ReDim Preserve Dates(i)
                  
                  If Me.chk_WorkingDays.Value = vbChecked And (Format(valueDate, "ddd") = "Fri" Or Format(valueDate, "ddd") = "Sat") Then
                     i = i - 1
                  Else
                     Dates(i) = valueDate
                  End If
                  
                  Select Case Me.cbo_Recurrence.Text
                         Case "Daily"
                              valueDate = DateAdd("d", 1, valueDate)
                         Case "Weekly"
                              If Format(valueDate, "dddd") = Me.cbo_WeekDays.Text Then
                                 Dates(i) = valueDate
                              Else
                                 i = i - 1
                              End If
                              valueDate = DateAdd("d", 1, valueDate)
                         Case "Monthly"
                              If Me.opt_Monthly_Day_BOM.Value = True Then
                                 valueDate = Format(DateAdd("m", 1, valueDate), "1/mm/yyyy  HH:mm")
                              ElseIf Me.opt_Monthly_Day_EOM.Value = True Then
                                 valueDate = DateAdd("d", -1, Format(DateAdd("m", 2, valueDate), "1/mm/yyyy  HH:mm")) 'DateAdd("m", DateSerial(Year(valueDate), Month(valueDate), 1)) - 1
                              ElseIf Me.opt_Monthly_Day_Custom.Value = True Then
                                 valueDate = DateAdd("m", 1, valueDate)
                              End If
                  End Select
                  i = i + 1
           Wend
           
           Me.ProgressBar1.Min = 0
           Me.ProgressBar1.Max = UBound(Dates())
           For i = 0 To UBound(Dates()) '- 1
               Me.Form_Insert Me.txt_EventIKey, _
                              VAL(Uno), _
                              Me.txt_head, _
                              Me.txt_body, _
                              Me.txt_SDate.Value, _
                              EDate, _
                              Dates(i)
               
               Me.ProgressBar1.Value = i
           Next
           Me.ProgressBar1.Value = 0
           MsgBox i & " note(s) added successfully.", vbInformation

Open in new window

0
 
Chris BottomleyCommented:
At the risk of seeming fascetious, well done to resolve the structure yourself.

I looked out of interest to see what you changed but it is not obvious, (maybe the removal of -1 in the last loop) so it was perhaps as well that you did work it out yourself as it may have taken us longer to drill down to the root cause.

Anyway again well done, glad to have helped a little.

Chris
0
 
Louis01Commented:
facetious - you chris? never...
0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 4
  • 3
  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now