VBA slideshow-ish

CsJHUN

Active Member
Joined
Jan 13, 2015
Messages
360
Office Version
  1. 365
  2. 2021
  3. 2019
Platform
  1. Windows
  2. Mobile
Hi guys

i would like to create a userform, which load pictures from a folder, and change the pictures every 3-4 seconds, while the user can select between 2 option button ( good or not good).
And the picture name,the selected option button value would be registered below each other.
The 'sleep' and 'wait' can not let user to choose between optionbuttons (basically not let you do anything, but... xD ) I stared ggle 30 minutes ago. the result is some "wastetime" macro (by Philip Trecay) but its looks like not working for me.

Parts of the userform macro is here, some parts has to be added later, but the issue now is the next-picture-auto-loading
So far i have this with comments for you:
Code:
Private Sub btn_start_Click()

Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim ofiles As Variant
Dim i As Integer
Dim item As Variant

btn_start.Visible = False                      'a start button to start process
lbl_bevezeto.Visible = False                 'pre-start notification with information for the users
opbtn_OK.Visible = True                       'one optionbutton
opbtn_NG.Visible = True                      'other optionbutton
img_test.Visible = True                         'the picture frame
lbl_timer.Visible = True                         'a visible timer. This could be good to have but not necessary.

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(kepk)
Set ofiles = oFolder.Files

For Each item In ofiles
kep = item.Path
img_test.Picture = LoadPicture("") 'added this becuase looked like its not change the pictures.
img_test.Picture = LoadPicture(kep)

'___________here I need your help, to automatically load the next picture



'___below this is just register the choice and picture name
i = i + 1
Range("B6").Offset(i, 0).Value = item.Name
Range("C6").Offset(i, 0).Value = which_optionbutton_selected             'not writed yet

Next item
End Sub


Any advice, guidelines are welcome.
Cheers J.
 

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.
yo guys,
managed to solve it with VBA.Timer, here is the full code:
VBA Code:
Private Sub btn_start_Click()
If tb_nev.Value = "" Or tb_tsz.Value = "" Then
MsgBox ("Töltsd ki a nevet és a törzszámot!")
Exit Sub
End If

Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim ofiles As Variant
Dim i As Integer
Dim pic_arr As Variant

btn_start.Visible = False
lbl_bevezeto.Visible = False
opbtn_OK.Visible = True
opbtn_NG.Visible = True
img_test.Visible = True
lbl_timer.Visible = True

Range("B1").Value = tb_nev.Value
Range("B2").Value = tb_tsz.Value
Range("B3").Value = Now

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(kepk)
Set ofiles = oFolder.Files


Dim item As Variant
For Each item In ofiles
    kep = item.Path
    img_test.Picture = LoadPicture("")
    img_test.Picture = LoadPicture(kep)
    
    Application.ScreenUpdating = True
    
    a = VBA.Timer
    Do
    B = VBA.Timer
    DoEvents
    Loop Until B >= a + idokoz
    
    
    If opbtn_OK.Value = False And opbtn_NG.Value = False Then valasz = "NV"
    If opbtn_OK.Value = True Then valasz = "OK"
    If opbtn_NG.Value = True Then valasz = "NG"
    
    
    i = i + 1
    Range("B6").Offset(i, 0).Value = item.Name
    Range("C6").Offset(i, 0).Value = valasz
    kepstatus = Mid(item.Name, Len(item.Name) - 5, 2)
    If kepstatus <> valasz Then
    Range("D6").Offset(i, 0).Value = "Rossz válasz"
    rv = rv + 1
    Else
    Range("D6").Offset(i, 0).Value = "Jó válasz"
    jv = jv + 1
    End If
    
    opbtn_NG.Value = False
    opbtn_OK.Value = False
    
Next item
Unload Me
Range("B4").Value = Now
ThisWorkbook.SaveAs ThisWorkbook.Path & "\tesztek\" & Environ("username") & Format(Now, "yyyymmdd hhnnss") & ThisWorkbook.Name
MsgBox ("Jó válasz: " & jv & vbCrLf & "Rossz válasz: " & rv)
ThisWorkbook.Close
End Sub

Optionally i will save the result to a results file where all previous test result will be.
 
Upvote 0

Forum statistics

Threads
1,212,927
Messages
6,110,695
Members
448,293
Latest member
jin kazuya

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top