frmmain.frm

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

      End
      Begin VB.Menu MnuLine4 
         Caption         =   "-"
      End
      Begin VB.Menu MnuExit 
         Caption         =   "退出系统(&X)"
      End
   End
   Begin VB.Menu MnuHelp 
      Caption         =   "帮助(&H)"
      Begin VB.Menu MnuGyBXt 
         Caption         =   "关于本系统(&A)."
      End
   End
End
Attribute VB_Name = "FrmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Public WithEvents m_Menu As EnhancedMenu
Attribute m_Menu.VB_VarHelpID = -1

Dim mbMoving As Boolean
Dim IsMoving As Boolean
Const sglSplitLimit = 1000

Dim i As Integer
Dim k As Integer

Dim Sql_Str As String           '保存查询条件
Dim PlayTime As Single          '保存自动播放的间隔时间：单位为秒
Dim CurrentPosition As Integer  '当前选定条目位置：自动播放使用

Public Rec As New ADODB.Recordset

Private Sub Command1_Click()
    If Len(Trim(Text2.Text)) = 0 Then Exit Sub
    If Rec.State = 1 Then Rec.Close: Set Rec = Nothing
    
    Rec.CursorLocation = adUseClient
    Select Case Left(tvTreeView.SelectedItem.Key, 1)
        Case "r"
            Rec.Open "select TblPic.*,tbltype.tname from TblPic left join Tbltype on " & _
                "tbltype.tid=tblpic.tid where tblpic.pname like '%" & _
                Trim(Text2.Text) & "%' order by tblpic.pid", MdlMain.cn, adOpenDynamic, adLockOptimistic
        Case "L"
            Rec.Open "select TblPic.*,tbltype.tname from TblPic left join Tbltype on " & _
                "tbltype.tid=tblpic.tid where tblpic.pname like '%" & Trim(Text2.Text) & _
                "%' and " & Sql_Str, MdlMain.cn, adOpenDynamic, adLockOptimistic
    End Select
    Image1.Picture = LoadPicture()
    Call Init_LvListView1(Rec)
End Sub

Private Sub Form_Load()
    Set m_Menu = New EnhancedMenu
    m_Menu.Subclass Me.hWnd
    
    Set m_Menu(2).SubMenu(1).Picture = LoadPicture(SysDbPath + "\save.ICO")
    Set m_Menu(2).SubMenu(3).Picture = LoadPicture(SysDbPath + "\type.ICO")
    Set m_Menu(2).SubMenu(4).Picture = LoadPicture(SysDbPath + "\add.ico")
    Set m_Menu(2).SubMenu(5).Picture = LoadPicture(SysDbPath + "\change.ico")
    Set m_Menu(2).SubMenu(9).Picture = LoadPicture(SysDbPath + "\time.ico")
    Set m_Menu(2).SubMenu(11).Picture = LoadPicture(SysDbPath + "\desktop.ico")
    
    Set m_Menu(2).SubMenu(13).Picture = LoadPicture(SysDbPath + "\exit.ico")
    
    Set m_Menu(3).SubMenu(1).Picture = LoadPicture(SysDbPath + "\help.ICO")
    m_Menu(3).RightJustify = True
    
    PlayTime = 2        '自动播放时间间隔：2秒
    Text2.Text = ""
    Timer1.Enabled = False
    
    Me.Show
    Me.Caption = "照片管理系统"
    StatusBar1.Panels("panel3").Text = "登陆日期：" & Format(Now, "yyyy-mm-dd")
    DoEvents

    LvListView1.ColumnHeaders.Clear
    LvListView1.ColumnHeaders.Add , , "顺序号", 800
    LvListView1.ColumnHeaders.Add , , "图片编号", 1100
    LvListView1.ColumnHeaders.Add , , "图片名称", 2000
    LvListView1.ColumnHeaders.Add , , "入库时间", 1200
    LvListView1.ColumnHeaders.Add , , "图片描述", 2600
    LvListView1.ColumnHeaders.Add , , "图片类型", 1100
    
    tvTreeView.ImageList = ImageList3
    tvTreeView.Nodes.Add , , "r1", "所有图片", 3, 4
    Rec.CursorLocation = adUseClient
    Rec.Open "select * from TblType order by tid", MdlMain.cn, adOpenDynamic, adLockOptimistic
    If Not Rec.EOF And Not Rec.BOF Then
        Do While Not Rec.EOF
            tvTreeView.Nodes.Add "r1", tvwChild, "L" & Rec.Bookmark, Rec.Fields("tid").Value & " | " & _
                Rec.Fields("tname").Value, 7, 8
            Rec.MoveNext
        Loop
    End If
    
    tvTreeView.Nodes("r1").Selected = True
    tvTreeView.Nodes("r1").Expanded = True
    Call tvTreeView_NodeClick(tvTreeView.SelectedItem)
    
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If MsgBox("你真的要退出本系统吗？", vbOKCancel + vbInformation, "请确认...") = vbCancel Then
        Cancel = True
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    m_Menu.Destroy
    Set m_Menu = Nothing
End Sub

Private Sub LvListView1_DblClick()
    If LvListView1.ListItems.Count = 0 Then Exit Sub
    
    Rec.Bookmark = Val(Right(LvListView1.SelectedItem.Key, Len(LvListView1.SelectedItem.Key) - 1))
    FrmPicAdd.Caption = "修改图片资料..."
'    On Error Resume Next
    ReDim MdlMain.Chunk(0)
    With FrmPicAdd
        .Text1(0).Text = Rec.Fields("pid").Value
        .Text1(1).Text = Rec.Fields("pname").Value
        .Text1(2).Text = Rec.Fields("pdis").Value
        
        Dim i As Integer
        For i = 0 To .Combo1.ListCount
            If Trim(Left(.Combo1.List(i), InStr(.Combo1.List(i), " | "))) = Rec.Fields("tid").Value Then
                .Combo1.ListIndex = i
                Exit For
            End If
        Next i
        .DTPicker1.Value = Rec.Fields("pdate").Value
    End With
    Dim Prec As New ADODB.Recordset
    Prec.CursorLocation = adUseClient
    Prec.Open "select * from TblPicture where pid='" & Rec.Fields("pid").Value & "'", _
        MdlMain.cn, adOpenDynamic, adLockOptimistic
    If Not Prec.EOF And Not Prec.BOF Then
        If Prec.Fields("pic").ActualSize <> 0 Then MdlMain.Chunk() = Prec.Fields("pic").GetChunk(Prec.Fields("pic").ActualSize)
        Call FrmPicAdd.PicDisplay
    End If
    Prec.Close: Set Prec = Nothing
    FrmPicAdd.Text1(0).Enabled = False
    FrmPicAdd.Command1(0).Enabled = False
'    FrmPicAdd.Command1(1).Default = True
    MdlMain.ReturnSql = ""
    FrmPicAdd.Show vbModal
    With Rec
        LvListView1.SelectedItem.SubItems(1) = IIf(IsNull(.Fields("pid").Value), "", .Fields("pid").Value)
        LvListView1.SelectedItem.SubItems(2) = IIf(IsNull(.Fields("pname").Value), "", .Fields("pname").Value)
        LvListView1.SelectedItem.SubItems(3) = IIf(IsNull(.Fields("pdate").Value), "", Format(.Fields("pdate").Value, "yyyy-mm-dd"))
        LvListView1.SelectedItem.SubItems(4) = IIf(IsNull(.Fields("pdis").Value), "", .Fields("pdis").Value)
    End With
    If MdlMain.ReturnSql = "已修改" Then Call PicDisplay
End Sub

Private Sub LvListView1_ItemClick(ByVal Item As MSComctlLib.ListItem)
    If LvListView1.ListItems.Count = 0 Then Exit Sub
    Image1.Picture = LoadPicture()
    ReDim MdlMain.Chunk(0)
    Dim Prec As New ADODB.Recordset
    On Error GoTo Er
    Rec.Bookmark = Val(Right(LvListView1.ListItems(LvListView1.Tag).Key, _
        Len(LvListView1.ListItems(LvListView1.Tag).Key) - 1))
    With LvListView1
        .ListItems(.Tag).SmallIcon = 13
        .SelectedItem.SmallIcon = 11
        .Tag = .SelectedItem.Key
    End With
    Rec.Bookmark = Val(Right(Item.Key, Len(Item.Key) - 1))
    Prec.CursorLocation = adUseClient
    Prec.Open "select * from TblPicture where pid='" & Rec.Fields("pid").Value & "'", _
        MdlMain.cn, adOpenDynamic, adLockOptimistic
    If Not Prec.EOF And Not Prec.BOF Then
        MdlMain.Chunk() = Prec.Fields("pic").GetChunk(Prec.Fields("pic").ActualSize)
        Call PicDisplay
    End If
    CurrentPosition = LvListView1.ListItems(LvListView1.SelectedItem.Key).Index
    Prec.Close: Set Prec = Nothing
    Exit Sub
Er:
    If Err.Number = 91 Then
        Resume Next
    End If
End Sub

Private Sub m_Menu_ItemSelect(MenuObject As MenuItem)
    Select Case MenuObject.Caption
        Case "保存到文件(&S)..."
            Call Toolbar1_ButtonClick(Toolbar1.Buttons("TbrSave"))
        Case "照片类别(&T)..."
            Call Toolbar1_ButtonClick(Toolbar1.Buttons("TbrType"))
        Case "添加照片到数据库(&I)..."
            Call Toolbar1_ButtonClick(Toolbar1.Buttons("TbrAdd"))
        Case "修改照片资料(&C)..."
            Call Toolbar1_ButtonClick(Toolbar1.Buttons("TbrChange"))
        Case "删除选定照片(&D)"
            Call Toolbar1_ButtonClick(Toolbar1.Buttons("TbrDel"))
        Case "自动播放(&P)"
            Call Toolbar1_ButtonClick(Toolbar1.Buttons("TbrPlay"))
        Case "自动播放时间间隔设定(&G)..."
            Call Toolbar1_ButtonClick(Toolbar1.Buttons("TbrTime"))
            
        Case "居中(&C)..."
            Call Toolbar1_ButtonMenuClick(Toolbar1.Buttons("TbrDeskTop").ButtonMenus("TbrCenter"))
        Case "平铺(&A)..."
            Call Toolbar1_ButtonMenuClick(Toolbar1.Buttons("TbrDeskTop").ButtonMenus("TbrAll"))
        Case "拉伸(&S)..."
            Call Toolbar1_ButtonMenuClick(Toolbar1.Buttons("TbrDeskTop").ButtonMenus("TbrDeskTop2"))
        
        
        Case "退出系统(&X)"
            Unload Me
        
        Case "关于本系统(&A)."
            Flash = True
            FrmFlash.Show vbModal
    End Select
End Sub

Private Sub Timer1_Timer()
    CurrentPosition = CurrentPosition + 1
    If CurrentPosition > LvListView1.ListItems.Count Then
        CurrentPosition = 1
    End If
    LvListView1.ListItems(CurrentPosition).Selected = True
'    LvListView1.Tag = LvListView1.SelectedItem.Key
    With LvListView1
        .ListItems(.Tag).SmallIcon = 13
        .SelectedItem.SmallIcon = 11
        .Tag = .SelectedItem.Key
    End With
    DoEvents
    Call LvListView1_ItemClick(LvListView1.SelectedItem)
    If AutoPlay = True Then
        Call FrmPicLl.Form_Resize
    End If
End Sub

Public Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
    Select Case Button.Key
        Case "TbrExit"
            Unload Me
            
        Case "TbrSave"
            If Image1 = 0 Or LvListView1.ListItems.Count = 0 Then
                MsgBox "没有图片可供保存！", vbOKOnly + vbCritical, "保存失败..."
                Exit Sub
            End If
            
            On Error GoTo Er
            
            With CommonDialog1
                .Filter = "*.jpg|*.jpg|*.gif|*.gif|*.bmp|*.bmp|*.wmf|*.wmf" & _
                    "|*.emf|*.emf|*.ico|*.ico|*.cur|*.cur|*.dib|*.dib|*.*|*.*"
                .DialogTitle = "保存照片"
                .Filename = LvListView1.SelectedItem.SubItems(2)
                .CancelError = True
                .ShowSave
            End With
            If Len(Trim(CommonDialog1.Filename)) <> 0 Then
                If Dir(Trim(CommonDialog1.Filename)) <> "" Then
                    If MsgBox("文件：" & Trim(CommonDialog1.Filename) & " 已经存在，是否覆盖它？", vbOKCancel + vbExclamation, "文件重复...") = vbOK Then
                        SavePicture Image1, Trim(CommonDialog1.Filename)
                    End If
                Else
                    SavePicture Image1, Trim(CommonDialog1.Filename)
                End If
            End If
Er:
            
        Case "TbrType"
            FrmPicType.Show vbModal
            Call Toolbar1_ButtonClick(Toolbar1.Buttons("TbrRefresh"))
            
        Case "TbrAdd"
            FrmPicAdd.Command1(0).Enabled = True
'            FrmPicAdd.Command1(0).Default = True
            FrmPicAdd.Command1(1).Enabled = False
            FrmPicAdd.Show vbModal
            If MdlMain.ReturnSql = "已增加" Then Call tvTreeView_NodeClick(tvTreeView.SelectedItem)
        Case "TbrPassword"
    
        Case "TbrChange"
            Call LvListView1_DblClick
        Case "TbrRefresh"
            If Rec.State = 1 Then Rec.Close: Set Rec = Nothing
            
            tvTreeView.Nodes.Clear
            tvTreeView.ImageList = ImageList3
            tvTreeView.Nodes.Add , , "r1", "所有图片", 3, 4
            Rec.CursorLocation = adUseClient
            Rec.Open "select * from TblType order by tid", MdlMain.cn, adOpenDynamic, adLockOptimistic
            If Not Rec.EOF And Not Rec.BOF Then
                Do While Not Rec.EOF
                    tvTreeView.Nodes.Add "r1", tvwChild, "L" & Rec.Bookmark, Rec.Fields("tid").Value & " | " & _
                        Rec.Fields("tname").Value, 7, 8
                    Rec.MoveNext
                Loop
            End If
            
            tvTreeView.Nodes("r1").Selected = True
            tvTreeView.Nodes("r1").Expanded = True