Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/bimpzip2/splash.frm

Visual Basic Form | 1995-05-07 | 6.7 KB | 203 lines

VERSION 2.00
Begin Form Splash
   BackColor       =   &H00FF0000&
   Caption         =   "BimpZip 2.0"
   ClientHeight    =   2475
   ClientLeft      =   1755
   ClientTop       =   2370
   ClientWidth     =   4515
   ControlBox      =   0   'False
   Height          =   2880
   Icon            =   SPLASH.FRX:0000
   Left            =   1695
   LinkTopic       =   "Form2"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2475
   ScaleWidth      =   4515
   Top             =   2025
   Width           =   4635
   Begin Timer Timer3
      Left            =   3960
      Top             =   120
   End
   Begin Timer Timer2
      Left            =   3360
      Top             =   120
   End
   Begin Timer Timer1
      Interval        =   5000
      Left            =   2760
      Top             =   120
   End
   Begin FileListBox File1
      BackColor       =   &H00FFFF00&
      Height          =   420
      Left            =   2160
      Pattern         =   "*.bmp"
      TabIndex        =   4
      Top             =   120
      Visible         =   0   'False
      Width           =   495
   End
   Begin Label Label2
      BackStyle       =   0  'Transparent
      Caption         =   "BitMap Changer and Disk Space Saver!"
      FontBold        =   -1  'True
      FontItalic      =   0   'False
      FontName        =   "MS Sans Serif"
      FontSize        =   15
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      ForeColor       =   &H0000FFFF&
      Height          =   855
      Left            =   600
      TabIndex        =   1
      Top             =   720
      Width           =   3495
   End
   Begin Label status
      BackStyle       =   0  'Transparent
      Caption         =   "STATUS: Working..."
      ForeColor       =   &H000000FF&
      Height          =   255
      Left            =   240
      TabIndex        =   3
      Top             =   2040
      Width           =   3735
   End
   Begin Label Todaysbmp
      BackStyle       =   0  'Transparent
      Caption         =   "Today's Bitmap: "
      ForeColor       =   &H00FFFF00&
      Height          =   255
      Left            =   240
      TabIndex        =   2
      Top             =   1680
      Width           =   3735
   End
   Begin Label Label1
      BackColor       =   &H00FF0000&
      Caption         =   "Kurt's"
      FontBold        =   -1  'True
      FontItalic      =   -1  'True
      FontName        =   "MS Sans Serif"
      FontSize        =   22.5
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      ForeColor       =   &H00FFFFFF&
      Height          =   615
      Left            =   240
      TabIndex        =   0
      Top             =   0
      Width           =   1455
   End
Declare Function GetWindowsDirectory Lib "Kernel" (ByVal lpBuffer As String, ByVal nSize As Integer) As Integer
Declare Function WritePrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String, ByVal lplFileName As String) As Integer
Declare Function WriteProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any) As Integer
Declare Function GetPrivateProfileString Lib "Kernel" (ByVal lpAppName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
Declare Function GetProfileString Lib "Kernel" (ByVal lpAppName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer) As Integer
Dim lpReturnString As String * 80
Dim windir As String * 144
Dim newpaper As String * 12
Dim oldwallpaper, bmpfile, bmplist, windir2, windir3 As String
Dim tilecheck, p As Integer
Sub Form_Load ()
    timer1.Interval = 0
    timer2.Interval = 0
    timer3.Interval = 0
    n = GetWindowsDirectory(windir, 144)
    windir2 = Left$(windir, n)
    windir3 = windir2 + "\"
    ChDir windir2
    bmplist = windir3 + "bmps.lst"
    bmpfile = windir3 + "bmps.zip"
    file1.Path = windir2
    n = GetProfileString("Desktop", "wallpaper", "", lpReturnString, 80)
    oldwallpaper = Left$(lpReturnString, n)
    Todaysbmp.Caption = "Today's Bitmap: " + oldwallpaper
    status.Caption = "Status: Getting Next Bitmap..."
    splash.Refresh
    timer1.Interval = 200
End Sub
Sub Timer1_Timer ()
    On Error GoTo nolist
    Open bmplist For Input As #1
    status.Caption = "Status: Getting Next Bitmap..."
    foundit = False
    While (Not EOF(1)) And Not foundit
        Line Input #1, bmpname
        If bmpname = oldwallpaper Then
            foundit = True
            On Error Resume Next
            Kill windir3 + oldwallpaper
            If Not EOF(1) Then
                Line Input #1, newpaper
            Else
                Close #1
                Open bmplist For Input As #1
                Line Input #1, newpaper
            End If
        End If
    Wend
    Close #1
    If Not foundit Then
        newpaper = bmpname
    End If
    status.Caption = "Status: Unzipping " + newpaper
    doscmd = "pkunzip -o " + bmpfile + " " + windir2 + " " + newpaper
    x = Shell(doscmd, 2)
    n = WriteProfileString("Desktop", "wallpaper", newpaper)
    timer1.Interval = 0
    timer3.Interval = 5000
    Exit Sub
nolist:
    status.Caption = "Status: Creating BMPS.ZIP"
    p = 1
    doscmd = "pkzip -mu " + bmpfile + " " + windir3 + "*.bmp"
    x = Shell(doscmd, 2)
    timer1.Interval = 0
    timer2.Interval = 5000
    Exit Sub
End Sub
Sub Timer2_Timer ()
    If p = 1 Then
       file1.Pattern = "*.bmp"
       file1.Refresh
       If file1.ListCount > 0 Then
          status.Caption = status.Caption + "."
          Exit Sub
       Else
          p = 2
          status.Caption = "Status: Creating BMPS.LST"
          doscmd = "pkunzip -@" + bmplist + " " + bmpfile
          x = Shell(doscmd, 2)
          timer2.Interval = 2000
          Exit Sub
       End If
    Else
       file1.Pattern = "bmps.lst"
       file1.Refresh
       If file1.ListCount = 0 Then
          Exit Sub
       Else
          timer2.Interval = 0
          timer1.Interval = 500
          Exit Sub
       End If
    End If
End Sub
Sub Timer3_Timer ()
    On Error GoTo notyet
    Open windir3 + newpaper For Input As #2
    Close #2
    If FileLen(windir3 + newpaper) > 55000 Then
        n = WriteProfileString("Desktop", "Tilewallpaper", "0")
    Else
        n = WriteProfileString("Desktop", "Tilewallpaper", "1")
    End If
    End
notyet:
    Exit Sub
End Sub