VB6 label update problem

Hi

I am running VB6 on a pentium 4 and Win XP pro.

I wrote a small program to copy files to a memory card or mp3 player etc in a specific order or a random order instead of the windows default alphabetical order. Because the files take about 1 second to be copied, if there are 150 files, it takes about 150 seconds to copy them all. During this time, it appears as if nothing is happening, so I use a label that is constantly updated and refreshed with each new file as it is being copied. The user can now see what is happening.

Everything works perfectly unless the user click the mouse anywhere on the form while the copying is taking place. If they do, the label stops updating and the cursor changes to the hourglass. The files continue to copy to the end, but the label never updates again, even though the loop is continuing and the label.refresh code is run at every pass of the loop.

I am sure there is probably something simple that I am missing.

Any help or ideas greatly appreciated.

Thanks

Ken

re: VB6 label update problem

Could you post the code you are using, that might help clear things up a little. Also, is the a function that activates on form click ? It sounds like a function is active on form click.. Please post your code and I will be in a better position to help.

re: VB6 label update problem

Hi

I tried switching from a label to a textbox so I could setfoucus back to the textbox, but that did not help.

Is there a way in code to disable all mouse input while the code is being run and then enable mouse input again? I think that would solve my problem.

Thanks

Ken



There is no form click code of any kind. I click a command button and run this code which works perfectly. A second mouse click only stops the textbox from updating. The code continues to run and work.


Private Sub Command4_Click()
On Error GoTo WasErr

Dim t As Integer, k As Integer, m As Integer
Dim chosen As Long, numchosen(4000) As Variant
Dim time1 As Double, time2 As Double, avTime As Double
Dim Answer As String

ReqSpace = 0


' Make sure there is at least 1 file in the right list
If List1(1).ListCount = 0 Then
MsgBox " No Files In Right List!!"
Exit Sub
End If



For t = 0 To List1(1).ListCount - 1
ReqSpace = ReqSpace + FileLen(StartPath & List1(1).List(t))
Next t

'Get Drive Type
DestType = GetDriveType(Left(Drive2, 2) & "\")
Fattributes = GetFileAttributes(Left(Drive2, 2) & "\")
'MsgBox Fattributes
If Fattributes = 17 Then
MsgBox "CD\DVD in Drive is Read Only. Must Be a CDRW or DVD RW formatted with Roxio's Direct to Disk etc to write to it."
Exit Sub
End If



'MsgBox DestType
' Check for removable drive, but not a Floppy.
If DestType <> 2 And DestType <> 5 Or UCase(Left(Drive2, 2)) < "C:" Then
MsgBox " Can't Copy To Non Removable Drive Or A FLOPPY." & vbCr & vbCr & " Please Select a Memory Card with the Right DriveListBox."
Exit Sub
End If


SpaceAvail = GetDiskFreeSpaceEx(DestPath, lpFreeBytesAvailableToCaller, _
lpTotalNumberOfBytes, lpTotalNumberOfFreeBytes)


DriveSizeGig = lpTotalNumberOfBytes \ 102400
DriveFreeSpaceGig = lpTotalNumberOfFreeBytes \ 102400
DriveSizeMeg = (lpTotalNumberOfBytes \ 102400)
DriveFreeSpaceMeg = (lpTotalNumberOfFreeBytes \ 102400)

If DriveSizeGig > 1 Or DriveFreeSpaceGig > 1 Then
Label10.Caption = UCase(Left(Drive2, 2)) & " " & DriveFreeSpaceGig & " Gig Free."
ElseIf DriveSizeMeg > 1 Or DriveFreeSpaceMeg > 1 Then
Label10.Caption = UCase(Left(Drive2, 2)) & " " & DriveFreeSpaceMeg & " Meg Free."
Else
Label10.Caption = UCase(Left(Drive2, 2)) & " " & Format(Int((lpTotalNumberOfFreeBytes * 10000)), "###,###,###") & " Bytes Free."
End If

If List1(1).ListCount = 0 Then
Label5.Visible = False
Label6.Visible = False
Label7.Visible = False
Else
Label5.Visible = True
Label6.Visible = True
Label7.Visible = True
End If

If Int((lpTotalNumberOfFreeBytes * 10000)) > ReqSpace Then


Label5.BackColor = &HC000&
Label6.BackColor = &HC000&
Label7.BackColor = &HC000&
Label5.Caption = "Good"
Label6.Caption = "To"
Label7.Caption = "Go"
Else
Label5.BackColor = &HFF&
Label6.BackColor = &HFF&
Label7.BackColor = &HFF&
Label5.Caption = "Warning!"
Label6.Caption = "Not Enough"
Label7.Caption = "Free Space"
End If


If DestType = 2 Then
Answer = MsgBox("Copying these " & List1(1).ListCount & " Files to Memory Card could take up to " & vbCr & "approximately " & List1(1).ListCount * 4.1 & " seconds. " & vbCr & vbCr & " Continue? Yes/No", vbYesNo)
Else
Answer = MsgBox("Copying these " & List1(1).ListCount & " Files to a CDRW will take" & vbCr & "approximately " & List1(1).ListCount * 6.1 & " seconds. " & vbCr & vbCr & " Continue? Yes/No", vbYesNo)

End If
If Answer = 7 Then Exit Sub


Option3.Value = True

'Option7.Value = True

For m = 0 To List1(1).ListCount - 1
numchosen(m) = m
Next m

' Start timer and Copy the files
time1 = Timer

If Option6.Value = True Then

For k = 0 To List1(1).ListCount - 1
pickagain:

Randomize Timer
chosen = Int(Rnd * List1(1).ListCount)
If numchosen(chosen) = "" Then GoTo pickagain


frmListDrag.SetFocus
frmListDrag.Text1.SetFocus
frmListDrag.Text1.Text = ""
frmListDrag.Text1.Text = "........Copying file " & k + 1 & " Of " & List1(1).ListCount & " " & List1(1).List(chosen)
frmListDrag.Text1.Refresh

CopyFile StartPath & List1(1).List(chosen), DestPath & List1(1).List(chosen), bFailIfExists

'If chosen = 33 Then MsgBox (chosen)
'If chosen = 0 Then MsgBox (chosen)
'If chosen = 21 Then MsgBox (chosen)
numchosen(chosen) = ""
Next k


Else
For i = 0 To List1(1).ListCount - 1

frmListDrag.SetFocus
frmListDrag.Text1.SetFocus
frmListDrag.Text1.Text = ""
frmListDrag.Text1.Text = "........Copying file " & i + 1 & " Of " & List1(1).ListCount & " " & List1(1).List(i)
frmListDrag.Text1.Refresh

CopyFile StartPath & List1(1).List(i), DestPath & List1(1).List(i), bFailIfExists

Next i

End If

SpaceAvail = GetDiskFreeSpaceEx(DestPath, lpFreeBytesAvailableToCaller, _
lpTotalNumberOfBytes, lpTotalNumberOfFreeBytes)


DriveSizeGig = lpTotalNumberOfBytes \ 102400
DriveFreeSpaceGig = lpTotalNumberOfFreeBytes \ 102400
DriveSizeMeg = (lpTotalNumberOfBytes \ 102400)
DriveFreeSpaceMeg = (lpTotalNumberOfFreeBytes \ 102400)

If DriveSizeGig > 1 Or DriveFreeSpaceGig > 1 Then
Label10.Caption = UCase(Left(Drive2, 2)) & " " & DriveFreeSpaceGig & " Gig Free."
ElseIf DriveSizeMeg > 1 Or DriveFreeSpaceMeg > 1 Then
Label10.Caption = UCase(Left(Drive2, 2)) & " " & DriveFreeSpaceMeg & " Meg Free."
Else
Label10.Caption = UCase(Left(Drive2, 2)) & " " & Format(Int((lpTotalNumberOfFreeBytes * 10000)), "###,###,###") & " Bytes Free."
End If



time2 = Timer
avTime = (time2 - time1) / List1(1).ListCount

frmListDrag.SetFocus
frmListDrag.Text1.SetFocus
frmListDrag.Text1.Text = ""
frmListDrag.Text1.Refresh

MsgBox Space(17) & "Done Copying. " & vbCr & vbCr & "Time Taken To Copy Files Was " & Format(time2 - time1, "0.0 \s\ec") & vbCr & vbCr & "Average Time per file was " & Format(avTime, "0.0") & " Seconds"

Option7.Value = True


Call Command7_Click

Exit Sub

WasErr:
MsgBox Err



End Sub

re: VB6 label update problem

Hi All

I found the solution posted on another site by Cimperiali.

It works great and solved my problem, but you have to be carefull to turn it back on in the correct place or you could hang up with no way to input anything. If so, Ctrl Alt Del and start over.

Here is the simple code.

In the General area

Private Declare Function BlockInput Lib "user32" (ByVal fBlock As Long) As Long


in your sub


'block the mouse and keyboard input
BlockInput True


To turn back on in your sub

'unblock the mouse and keyboard input

BlockInput False



HTH

Ken