frmmain.frm

本系统是图书管理信息系统一个简单实例。本系统主要有系统管理、图书管理、借书证管理、借书和还书操作、报表打印等模块组成。

End Sub

Private Sub imgSplitter2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    
    SizeControlsH picSplitter2.Top
    picSplitter2.Visible = False
    mbMoving = False
    
End Sub

Private Sub lvListView_AfterLabelEdit(Cancel As Integer, NewString As String)
 
  If Trim(NewString) = "" Then
     MsgBox "对不起,文件名称不能为空。    ", vbCritical + vbOKOnly, "重命名错误..."
     Cancel = -1                           '取消重命名
     Exit Sub
  End If

  If Trim(NewString) = Trim(OldName) Then Exit Sub  '新文件名与旧文件名相同时
  
  '变更文件名称
   Dim SHop As SHFILEOPSTRUCT
   Dim strFile As String
   strFile = ValidateDir(fPath$) & OldName
   
   With SHop
      .wFunc = FO_RENAME
      .pFrom = strFile
      .pTo = ValidateDir(fPath$) & NewString
      .fFlags = FOF_NOCONFIRMATION
   End With
   
   Dim retVal As Long   '执行
   retVal = SHFileOperation(SHop)
   
   If retVal <> 0 Then  '不能执行时取消操作
      Cancel = -1
   End If

End Sub

Private Sub lvListView_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)

  lvListView.SortKey = ColumnHeader.Index - 1
  lvListView.SortOrder = lvwAscending
  lvListView.Sorted = True
  
End Sub

Private Sub lvListView_DblClick()

 If lvListView.ListItems.Count > 0 Then
   If lvListView.SelectedItem.Selected Then
      OpenSelected
   End If
 End If
 
End Sub

Private Sub lvListView_ItemClick(ByVal Item As MSComctlLib.ListItem)

   '检测是否为同一项目
   NewItem = Item.Text
   If NewItem = OldItem Then Exit Sub
      OldItem = NewItem

   If Item.Text > "" Then
       MenuEnabled (-1)
   Else
       MenuEnabled (0)
   End If
     
   fPath$ = ValidateDir(fPath$)
   Dim picFile As String
       picFile = fPath$ & Item.Text
       SourceFile = picFile
'给出文件类型
 Select Case VbGetFileType(Item.Text)
  Case "图片"
     '处理图片
     PictureProccess (picFile)
  Case "动画"
     GifProccess (picFile)
  Case "文本"
     txtProccess (picFile)
  Case "声音"
     AudioProccess (picFile)
     SourceFile = ""  '不能启动多媒体播放设备
  Case "影视"
     VideoProccess (picFile)
  Case Else
   If mnuEditCopy.Enabled = True Then  '上次为图片时
     mnuEditCopy.Enabled = False '复制按钮无效
     MnuLookFor.Enabled = False  '查看菜单无效
     MnuPrintPicture.Enabled = False
    '隐藏图片菜单
     tbToolBar.Buttons(Copy_Number).Enabled = False
     tbToolBar.Buttons(Printer_Number).Enabled = False
     sbStatusBar.Panels(3).Text = "未注册版: V1.0"
   End If
   If MnuVideo.Visible Then  '视频菜单
      MnuVideo.Visible = False
   End If
   
  End Select

   sbStatusBar.Panels(4).Text = Item.Text
   sbStatusBar.Panels(5).Text = Item.ListSubItems(1).Text
   sbStatusBar.Panels(6).Text = Item.ListSubItems(2).Text
   sbStatusBar.Panels(7).Text = Item.ListSubItems(3).Text
   sbStatusBar.Panels(8).Text = Item.ListSubItems(4).Text
     
End Sub

Private Sub lvListView_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
   
 If Shift = 1 Then
    UndoK = True
    mnuFileOpenAs.Visible = True
  Else
    UndoK = False
    mnuFileOpenAs.Visible = False
 End If
 
 If lvListView.ListItems.Count > 0 Then
    If lvListView.SelectedItem.Selected Then
       MenuEnabled (-1)
     Else
       MenuEnabled (0)
    End If
 End If
 
 If Button = 2 Then PopupMenu mnuMainView
   
End Sub

Private Sub mnuArrangeFileIcon_Click()

   mnuArrangeFileIcon.Checked = Not mnuArrangeFileIcon.Checked
   
   If mnuArrangeFileIcon.Checked = True Then
      lvListView.Arrange = lvwAutoTop
      SaveSetting App.Title, "Settings", "AutoArrange", 1
    Else
      lvListView.Arrange = lvwNone
      SaveSetting App.Title, "Settings", "AutoArrange", 0
   End If
   
   '保存状态
   
End Sub

Private Sub MnuArrangSort_Click(Index As Integer)
    
    lvListView.SortKey = Index
    lvListView.SortOrder = 0
    lvListView.Sorted = True
    
End Sub

Private Sub MnuArrangSortAuto_Click()
   
      lvListView.SortOrder = 0
      lvListView.Sorted = True
    
End Sub

Private Sub MnuArrangSortAutoZ_Click()
      
      lvListView.SortOrder = 1
      lvListView.Sorted = True

End Sub

Private Sub MnuCleanBackground_Click()

ChangePaper picBuffer, False
 
End Sub

Private Sub MnuClearClipboard_Click()
  
  Clipboard.Clear
  
End Sub

Private Sub mnuDisplayPictureViewWindow_Click()
  
  Screen.MousePointer = vbHourglass
  
  If Not frmPictureView.Visible Then
     Load frmPictureView
  End If
  
  If picLoad Then
     frmPictureView.picView.Picture = picBuffer.Picture
  End If
  
  Screen.MousePointer = vbDefault
  frmPictureView.Show vbNormal
  
End Sub

Private Sub mnuEditCopyTo_Click()

  TargetFile = SelectFilePath(Me.hWnd, "请选择复制到的目录：")

  If Trim(TargetFile) = "" Then  '如果等于空时退出
     Exit Sub
  End If
 
  TargetFile = ValidateDir(TargetFile) & lvListView.SelectedItem.Text
  SourceFile = ValidateDir(fPath$) & lvListView.SelectedItem.Text
     
  If SourceFile = TargetFile Then
     Exit Sub
  End If
  
  '系统内Shell复制文件
  Dim Result As Long, fileOp As SHFILEOPSTRUCT
   With fileOp
        .hWnd = Me.hWnd
        .wFunc = FO_COPY
        .pFrom = SourceFile
        .pTo = TargetFile
        .fFlags = FOF_SIMPLEPROGRESS + FOF_FILESONLY
   End With
   
   Result = SHFileOperation(fileOp)

End Sub

Private Sub mnuEditMove_Click()

TargetFile = SelectFilePath(Me.hWnd, "请选择移动到的目录：")

If Trim(TargetFile) = "" Then  '如果等于空时退出
   Exit Sub
End If
 
  TargetFile = ValidateDir(TargetFile) & lvListView.SelectedItem.Text
  SourceFile = ValidateDir(fPath$) & lvListView.SelectedItem.Text
  
  If SourceFile = TargetFile Then
     Exit Sub
  End If
     
  '使用Name命令移动文件
  'Name SourceFile As TargetFile
  '系统内Shell移动文件
  Dim Result As Long, fileOp As SHFILEOPSTRUCT
   With fileOp
        .hWnd = Me.hWnd
        .wFunc = FO_MOVE
        .pFrom = SourceFile
        .pTo = TargetFile
        .fFlags = FOF_SIMPLEPROGRESS + FOF_FILESONLY
   End With
   
   Result = SHFileOperation(fileOp)
    
  '系统删除操作完成时,测试有没有删除
   Result = GetFileAttributes(SourceFile)

  If Result = -1 Then '完成时
     lvListView.ListItems.Remove lvListView.SelectedItem.Index
     RefreshDesk
   Else
     Exit Sub '没有时
  End If
   
    
End Sub

Private Sub MnuFileAttribute_Click()

  '显示文件属性
  If lvListView.ListItems.Count > 0 Then
     If lvListView.SelectedItem.Selected Then
        ShowFileProperties ValidateDir(fPath$) & lvListView.SelectedItem.Text
     End If
   ElseIf Trim(DisplayPath.Text) > "" Then
        ShowFileProperties Trim(DisplayPath.Text)
  End If
  
End Sub


Private Sub mnuFileOpenAs_Click()
 
 If lvListView.ListItems.Count > 0 Then
   If lvListView.SelectedItem.Selected Then
      OpenSelectedAs
   End If
 End If

End Sub

Private Sub mnuFileRename_Click()

   '文件重命名
   If lvListView.ListItems.Count > 0 Then
      If lvListView.SelectedItem.Selected Then
      
         OldName = lvListView.SelectedItem.Text '取得编辑前的文件名
         lvListView.StartLabelEdit              '开始编辑
         
      End If
   End If
   
End Sub

Private Sub MnuFullScreen_Click()

  MnuFullScreen.Checked = Not MnuFullScreen.Checked
  
  AudioDisplay.Pause
  
  If MnuFullScreen.Checked = True Then
     AudioDisplay.FullScreenMode = True
   Else
     AudioDisplay.FullScreenMode = False
  End If
  
  AudioDisplay.Run
  
End Sub

Private Sub MnuLookFor_Click()

  If picLoad = False Then  '但预览窗口没有装载时
     Dim picFile As String
         picFile = fPath$ & lvListView.SelectedItem.Text
     Screen.MousePointer = vbHourglass
     picBuffer.Picture = LoadPicture(picFile)
     Screen.MousePointer = vbDefault
     picLoad = True    '已经安装
  End If
    MnuPictureView_Click
 
End Sub

Private Sub MnuMediaPlay_Click()

 If AudioDisplay.Visible Then
    If AudioDisplay.CurrentState = amvRunning Then
       If SourceFile <> "" Then
          AudioDisplay.Stop
       End If
    End If
 End If
 
 Dim retVal As Long
     retVal = Shell("FlVcd3.0.Exe " & SourceFile, vbNormalFocus)
 If retVal = 0 Then
    MsgBox "对不起，未知错误不能启动多媒体播放器"
 End If
 
End Sub

Private Sub MnuMemdiaPlay_Click()
 
 If AudioDisplay.Visible Then
    If AudioDisplay.CurrentState = amvRunning Then
       If SourceFile <> "" Then
          AudioDisplay.Stop
       End If
    End If
 End If
  
 Dim retVal As Long
     retVal = Shell("FlVcd3.0.Exe " & SourceFile, vbNormalFocus)
 If retVal = 0 Then
    MsgBox "对不起，未知错误不能启动多媒体播放器"
 End If
 
End Sub

Private Sub MnuPictureView_Click()
  
  Screen.MousePointer = vbHourglass
  
  If frmPictureView.Visible Then
     frmPictureView.picView.Picture = picBuffer.Picture
   Else
     Load frmPictureView
     frmPictureView.picView.Picture = picBuffer.Picture
  End If
  
  Screen.MousePointer = vbDefault
  frmPictureView.Show vbNormal
  
End Sub

Private Sub MnuPrinterSet_Click()

  Dim setPrinter As New cCommonDialog
  
  setPrinter.CancelError = True
  setPrinter.flags = PD_PRINTSETUP
  
  setPrinter.ShowPrinter
  
     
End Sub

Private Sub MnuPrintPicture_Click()

   If picLoad = False Then
     Dim picFile As String
         picFile = fPath$ & lvListView.SelectedItem.Text
     Screen.MousePointer = vbHourglass
     picBuffer.Picture = LoadPicture(picFile)
     Screen.MousePointer = vbDefault
     picLoad = True '已经安装完毕
   End If
  '显示打印选项
   frmPicturePrint.Show 1
   
End Sub