Option Explicit
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long

Const SPI_SETDESKWALLPAPER = 20
Const SPIF_SENDWININICHANGE = &H2
Const SPIF_UPDATEINIFILE = &H1
Const REG_SZ As Long = 1
Const HKEY_CURRENT_USER = &H80000001
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Dim pic() As String
Public num, idme, sec, secl As Integer
Public str As String


Private Sub Command4_Click()
End
End Sub

Private Sub Command1_Click()
Timer1.Enabled = False
Dim interv
interv = InputBox("请输入间隔秒(s),小于等于零结束屏保")
If Val(interv) = 0 Or Val(interv) < 0 Then End
secl = Val(interv)
Timer1.Enabled = True
Call TransParent(20)
End Sub

Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If X >= Command1.Left + 50 And X <= Command1.Left + Command1.Width - 50 And Y >= Command1.Top + 40 And Y <= Command1.Top + Command1.Height - 40 Then
'Form
Call TransParent(150)
Else
Call TransParent(10)
End If
End Sub

Private Sub Command2_Click()
End
End Sub

Private Sub Command2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)   //鼠标滑过按钮时，根据状态调整窗体透明程度
If X >= 50 And X <= Command2.Width - 50 And Y >= 40 And Y <= Command2.Height - 40 Then
'Form
Call TransParent(150)
Else
Call TransParent(10)
End If
End Sub

Private Sub Form_Activate() //窗体加载完成激活时执行扫描文件夹中的图片文件的目的
Me.Top = 300
Me.Left = Screen.Width - 2500
str = Dir(App.Path & "\")
Do While str <> ""
If str = App.EXEName & ".exe" Then
ElseIf kzm(str) = "bmp" Or kzm(str) = "jpeg" Or kzm(str) = "jpg" Or kzm(str) = "gif" Or kzm(str) = "png" Or kzm(str) = "tif" Then
    num = num + 1
    ReDim Preserve pic(num)
    pic(num) = App.Path & "\" & str
End If
str = Dir
Loop
Timer1.Enabled = True
Timer1.Interval = 1000
End Sub



Private Sub Form_KeyPress(KeyAscii As Integer)  //按ESC键退出【貌似无效】
If KeyAscii = 27 Then End
End Sub

Private Sub Form_Load()
'Form
Call TransParent(10)
'
secl = 3
sec = 3
End Sub


Private Sub Timer1_Timer()   //记时，当达到设定秒数时激活内部的更换桌面的程序代码
Dim aa As String
Dim changewp
On Error Resume Next
sec = sec + 1
If sec > secl Then
'屏蔽区begin
idme = idme + 1
If num = 0 Then Timer1.Enabled = False: End
If idme > num Then idme = 1
Image1.Picture = LoadPicture(pic(idme))
SavePicture Image1, App.Path & "\now.bmp"
aa = App.Path & "\now.bmp"
changewp = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, aa, 0)
sec = 1
Else
End If
End Sub

Function kzm(ByVal pathme As String)  //获取文件扩展名
Dim qq As String
Dim qs As Long
qs = InStrRev(pathme, ".")
qq = Mid(pathme, qs + 1)
kzm = qq
End Function

Function TransParent(ByVal seevalue As Integer)  //根据seevalue值设置窗体透明度
Dim rtn As Long
rtn = GetWindowLong(Me.hwnd, (-20))
rtn = rtn Or &H80000
SetWindowLong Me.hwnd, (-20), rtn
SetLayeredWindowAttributes Me.hwnd, 0, seevalue, &H2
End Function