Visual Basic 6 - visualizzazione fotografie....

ShowInTaskBar = False

Attribute VB_Name = "Funct"
Public Const folkey = "HKLM\Software\Desktop Image Changer\IFOLPATH"
Public Const modekey = "HKLM\Software\Desktop Image Changer\ISMODE"
Public Const ipkey = "HKLM\Software\Desktop Image Changer\Image"
Public Const icount = "HKLM\Software\Desktop Image Changer\TCOUNT"
Public Const TID = "HKLM\Software\Desktop Image Changer\NextID"
Public Const rwkey = "HKLM\Software\Microsoft\Windows\CurrentVersion\Run\Desktop Image Changer"
Public Const convkey = "HKLM\Software\Desktop Image Changer\CFName"

Public modeo As Integer
Public mode As Integer
Public ImageFound As Long
Public FileNameList(100) As String

Private Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
        dwFileAttributes As Long
        ftCreationTime As FILETIME
        ftLastAccessTime As FILETIME
        ftLastWriteTime As FILETIME
        nFileSizeHigh As Long
        nFileSizeLow As Long
        dwReserved0 As Long
        dwReserved1 As Long
        cFileName As String * 255
        cAlternate As String * 14
End Type

Public Const FILE_ATTRIBUTE_DIRECTORY = &H10
Public Const SPI_SETDESKWALLPAPER = 20
Public Const SPIF_UPDATEINIFILE = &H1
Public Const SPIF_SENDWININICHANGE = &H2

Public Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Private Declare Function SHGetSpecialFolderPath Lib "shell32.dll" Alias "SHGetSpecialFolderPathA" (ByVal hwndOwner As Long, ByVal lpszPath As String, ByVal nFolder As Long, ByVal fCreate As Long) As Long

Dim f As New FileSystemObject

Public Function showdir(hwnd As Long, Title As String, dtype As Long) As String
      On Error GoTo err
      Dim sh As New Shell
      Dim fol As Folder
      Set fol = sh.BrowseForFolder(hwnd, Title, dtype)
      showdir = fol.Items.Item.Path
      Exit Function
err:  showdir = ""
End Function

Public Sub regwriter(PKey As String, VKey As String)
       Dim reg As Object
       Dim rkey As String
       Set reg = CreateObject("Wscript.shell")
       reg.regwrite PKey, VKey
       Set reg = Nothing
End Sub

Public Function regreader(PKey As String) As String
       Dim reg As Object
       Dim rkey As String
       Set reg = CreateObject("Wscript.shell")
       regreader = reg.regread(PKey)
       Set reg = Nothing
End Function

Public Sub regdeleter(PKey As String)
       Dim reg As Object
       Dim rkey As String
       Set reg = CreateObject("Wscript.shell")
       reg.regdelete PKey
       Set reg = Nothing
End Sub

Public Sub FirstRun()
       On Error Resume Next
        modeo = 1
        opRandm.Value = True
        Dim mdpath As String
        Dim mppath As String
        mdpath = Space$(255)
        ret = SHGetSpecialFolderPath(ddsktop.hwnd, mdpath, 5, 0)
        mppath = Trim$(mdpath) & "\My Pictures"
        regwriter folkey, mppath
        regwriter modekey, "Random"
        ddsktop.folpath.Text = mppath
        regwriter icount, "0"
        regwriter TID, "-1"
        regwriter convkey, ""
        regwriter rwkey, App.Path & "\Desktop.exe INVISIBLE"
        If mode = 1 Then Call process
End Sub

Public Sub findfiles(FolderPath As String, SearchString As String)
     Dim fdta As WIN32_FIND_DATA
     Dim ret As Long
     Dim srchcont As Long
     Dim srchpth As String
     Dim fname As String
     Dim ifound As Long
     srchpth = FolderPath & "\" & SearchString
     srchcont = FindFirstFile(srchpth, fdta)
     ifound = 0
     If srchcont = -1 Then GoTo skip
     Do
        DoEvents
        fname = Left(fdta.cFileName, InStr(fdta.cFileName, vbNullChar) - 1)
        fname = FolderPath & "\" & fname
        FileNameList(ImageFound) = fname
        ImageFound = ImageFound + 1
        ifound = ifound + 1
        ret = FindNextFile(srchcont, fdta)
     Loop Until ret = 0
skip: ret = FindClose(srchcont)
End Sub

Public Sub process()
        Dim ret As Long
        Dim ext As String
        Dim killpath As String
        
        On Error Resume Next
        killpath = regreader(convkey)
        If killpath <> "" Then
           Call Kill(killpath)
           Call regwriter(convkey, "")
        End If
        
        If ddsktop.folpath.Text <> "" Then regwriter folkey, Trim$(ddsktop.folpath.Text)
        
        If ddsktop.opRandm.Value = True Then
           regwriter modekey, "Random"
        Else
           regwriter modekey, "Seq"
        End If
        
        ImageFound = 0
        findfiles ddsktop.folpath.Text, "*.jpg"
        findfiles ddsktop.folpath.Text, "*.jpeg"
        findfiles ddsktop.folpath.Text, "*.gif"
        findfiles ddsktop.folpath.Text, "*.bmp"
        'findfiles ddsktop.folpath.Text, "*.dib"
        'findfiles ddsktop.folpath.Text, "*.png"
        'findfiles ddsktop.folpath.Text, "*.htm"
        'findfiles ddsktop.folpath.Text, "*.html"
        If ImageFound = 0 Then
           MsgBox "No Image File Found In Selected Directory", vbCritical
        Else
           Dim i As Long
           For i = 0 To ImageFound - 1
               regwriter ipkey & Str$(i), FileNameList(i)
           Next i
        End If
        
        Dim tmp As String
        tmp = regreader(icount)
        
        If CLng(tmp) > ImageFound And ImageFound > 0 Then
           For i = ImageFound To CLng(tmp) - 1
               regdeleter ipkey & Str$(i)
           Next i
        End If
        
        regwriter icount, Str$(ImageFound)
        tmp = regreader(modekey)
        
        If tmp <> "Seq" Then
           Dim num As Double
           num = Rnd()
           Dim tfid As Long
           tfid = CLng(num * (ImageFound - 1))
           regwriter TID, Str$(tfid)
           tmp = regreader(ipkey & Str$(tfid))
           ext = UCase$(f.GetExtensionName(tmp))
           If ext <> "BMP" Then tmp = convert(tmp)
           ddsktop.ImgStore.Picture = LoadPicture(tmp)
           ret = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, ByVal tmp, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
        Else
           tmp = regreader(TID)
           If CLng(tmp) + 1 > ImageFound - 1 Then tmp = "-1"
           regwriter TID, Str$(CLng(tmp) + 1)
           tmp = regreader(ipkey & Str$(CLng(tmp) + 1))
           ext = UCase$(f.GetExtensionName(tmp))
           If ext <> "BMP" Then tmp = convert(tmp)
           ddsktop.ImgStore.Picture = LoadPicture(tmp)
           ret = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, ByVal tmp, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
        End If
        
        If mode = 1 Then End
End Sub

Private Function convert(imgpath As String) As String
                 Dim nimg As String
                 nimg = Replace$(imgpath, f.GetExtensionName(imgpath), "bmp")
                 ddsktop.ImgStore.Picture = LoadPicture(imgpath)
                 Call SavePicture(ddsktop.ImgStore, nimg)
                 Call regwriter(convkey, nimg)
                 convert = nimg
End Function

 On Error GoTo noreg
        Dim rval As String
        rval = regreader(folkey)
        folpath.Text = rval
        rval = regreader(modekey)
        Call process
        Exit Sub
noreg:  Call FirstRun