frmpicll.frm

利用VB+SQL2000开发的照片管理系统

VERSION 5.00
Begin VB.Form FrmPicLl 
   Caption         =   "照片浏览"
   ClientHeight    =   7605
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   10680
   Icon            =   "FrmPicLl.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   7605
   ScaleWidth      =   10680
   StartUpPosition =   2  '屏幕中心
   Begin VB.PictureBox Picture3 
      AutoSize        =   -1  'True
      Height          =   960
      Left            =   2640
      ScaleHeight     =   900
      ScaleWidth      =   1800
      TabIndex        =   2
      Top             =   1080
      Visible         =   0   'False
      Width           =   1860
   End
   Begin VB.PictureBox Picture1 
      BackColor       =   &H00000000&
      BorderStyle     =   0  'None
      Height          =   7335
      Left            =   1200
      ScaleHeight     =   7335
      ScaleWidth      =   10305
      TabIndex        =   0
      Top             =   840
      Width           =   10305
      Begin VB.PictureBox Picture2 
         AutoRedraw      =   -1  'True
         BackColor       =   &H00000000&
         BorderStyle     =   0  'None
         Height          =   6225
         Left            =   1200
         ScaleHeight     =   6225
         ScaleWidth      =   7830
         TabIndex        =   1
         Top             =   -120
         Width           =   7830
      End
   End
   Begin VB.Image Image1 
      Height          =   480
      Index           =   1
      Left            =   0
      Picture         =   "FrmPicLl.frx":030A
      Top             =   555
      Visible         =   0   'False
      Width           =   480
   End
   Begin VB.Image Image1 
      Height          =   480
      Index           =   0
      Left            =   0
      Picture         =   "FrmPicLl.frx":0614
      Top             =   0
      Visible         =   0   'False
      Width           =   480
   End
   Begin VB.Menu popupmnu 
      Caption         =   "popupmnu"
      Visible         =   0   'False
      Begin VB.Menu MnuBig 
         Caption         =   "放大(&O)"
         Visible         =   0   'False
      End
      Begin VB.Menu MnuSmall 
         Caption         =   "缩小(&I)"
         Visible         =   0   'False
      End
      Begin VB.Menu MnuLine1 
         Caption         =   "-"
         Visible         =   0   'False
      End
      Begin VB.Menu MnuDesktop 
         Caption         =   "设成桌面(&D)"
      End
      Begin VB.Menu MnuLine2 
         Caption         =   "-"
      End
      Begin VB.Menu MnuPlay 
         Caption         =   "自动播放(&P)"
      End
      Begin VB.Menu MnuTime 
         Caption         =   "秒数设定(&M)..."
      End
   End
End
Attribute VB_Name = "FrmPicLl"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim DownX As Single
Dim Downy As Single

Private Sub Form_DblClick()
    Unload Me
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyEscape Then Unload Me
End Sub

Private Sub Form_Load()
    Me.KeyPreview = True
    Call SetWindowPos(Me.hWnd, HWND_TOPMOST, 0, 0, 0, 0, FLAG)
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 2 Then PopupMenu popupmnu
End Sub

Public Sub Form_Resize()
    On Error Resume Next
    Dim Wr As Single, Hr As Single, r As Single
    Picture1.Top = 30
    Picture1.Left = 20
    Picture1.Width = Me.ScaleWidth - 8
    Picture1.Height = Me.ScaleHeight - 8
    
    Picture3.Picture = MdlMain.Chunk2Image(MdlMain.Chunk, "")
    Picture2.Height = Picture3.Height
    Picture2.Width = Picture3.Width
    Picture2.Top = (Me.ScaleHeight - Picture2.ScaleHeight) / 2
    Picture2.Left = (Me.ScaleWidth - Picture2.ScaleWidth) / 2
    Picture2.PaintPicture Picture3.Picture, 0, 0
    
End Sub

Private Sub MnuBig_Click()
    MsgBox "放大"
End Sub

Private Sub MnuDesktop_Click()
    '取得windows目录
    Dim Path As String
    Dim strSave As String
    
    strSave = String(50, Chr$(0))
    Path = Left$(strSave, GetWindowsDirectory(strSave, Len(strSave)))
    '转换图片并保存到Windows目录下面
    
    SavePicture Picture3, Path & "\FIL663.bmp"
    
    '更换墙纸
    Dim aa As String
    aa = Path & "\FIL663.bmp"
    
    '写入注册表
    MdlReg.UpdateKey MdlReg.HKEY_CURRENT_USER, "Control Panel\desktop", "TileWallpaper", REG_SZ, "0", 1
    MdlReg.UpdateKey MdlReg.HKEY_CURRENT_USER, "Control Panel\desktop", "Wallpaper", REG_EXPAND_SZ, aa, LenB(aa)
    MdlReg.UpdateKey MdlReg.HKEY_CURRENT_USER, "Control Panel\desktop", "WallpaperStyle", REG_SZ, "0", 1
    
    MdlReg.UpdateKey MdlReg.HKEY_CURRENT_USER, "Software\Microsoft\Internet Explorer\Desktop\General", "TileWallpaper", REG_SZ, "0", 1
    MdlReg.UpdateKey MdlReg.HKEY_CURRENT_USER, "Software\Microsoft\Internet Explorer\Desktop\General", "Wallpaper", REG_EXPAND_SZ, aa, LenB(aa)
    MdlReg.UpdateKey MdlReg.HKEY_CURRENT_USER, "Software\Microsoft\Internet Explorer\Desktop\General", "WallpaperStyle", REG_SZ, "0", 1
    
    MdlMain.SystemParametersInfo SPI_SETDESKWALLPAPER, 0, aa, 0
End Sub

Private Sub MnuPlay_Click()
    MnuPlay.Caption = IIf(MnuPlay.Caption = "自动播放(&P)", "停止播放(&S)", "自动播放(&P)")
    Call FrmMain.Toolbar1_ButtonClick(FrmMain.Toolbar1.Buttons("TbrPlay"))
    AutoPlay = IIf(AutoPlay, False, True)
End Sub

Private Sub MnuSmall_Click()
    MsgBox "缩小"
End Sub

Private Sub MnuTime_Click()
    Call FrmMain.Toolbar1_ButtonClick(FrmMain.Toolbar1.Buttons("TbrTime"))
End Sub

Private Sub Picture1_DblClick()
    Unload Me
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 2 Then PopupMenu popupmnu
End Sub

Private Sub Picture2_DblClick()
    Unload Me
End Sub

Private Sub Picture3_DblClick()
    Unload Me
End Sub

Private Sub Picture2_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    DownX = x: Downy = y
    If Button = 1 Then
        Picture2.MousePointer = 99
        If Picture2.Height >= Picture1.Height Then
            Picture2.MouseIcon = Image1(1).Picture
        Else
            Picture2.MouseIcon = Image1(0).Picture
        End If
    ElseIf Button = 2 Then
        PopupMenu popupmnu
    End If
End Sub

Private Sub Picture2_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    Picture2.MousePointer = 0
End Sub

Private Sub Picture2_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 1 Then
        If Picture2.Width > Picture1.Width Then
            If (x - DownX) + Picture2.Left > 0 Then
                Picture2.Left = 0
            ElseIf Picture2.Width + (x - DownX) + Picture2.Left < Picture1.Width Then
                Picture2.Left = -(Picture2.Width - Picture1.Width)
            Else
                Picture2.Left = (x - DownX) + Picture2.Left
            End If
        End If
        If Picture2.Height > Picture1.Height Then
            If (y - Downy) + Picture2.Top > 0 Then
                Picture2.Top = 0
            ElseIf Picture2.Height + (y - Downy) + Picture2.Top < Picture1.Height Then
                Picture2.Top = -(Picture2.Height - Picture1.Height)
            Else
                Picture2.Top = (y - Downy) + Picture2.Top
            End If
        End If
    End If
End Sub

Private Sub Picture3_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 2 Then PopupMenu popupmnu
End Sub