frmmain.frm

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

Private Sub MnuRefreshDir_Click()

  If tvTreeView.bLoaded Then
     tvTreeView.UnInit
     tvTreeView.Init
     tvTreeView_SelectionChange "", ""
  End If
  
End Sub

Private Sub MnuSetBackground_Click(Index As Integer)
  
  Screen.MousePointer = vbHourglass
  '决定其分布的类型
  Dim sKeyName As String, sEntry As String
  Dim sValue As String, bSuccess As Boolean
 
  Select Case Index
  Case 0
  '中心时
  sKeyName = "HKEY_CURRENT_USER\Control Panel\Desktop"
  sEntry = "WallpaperStyle"
  sValue = "0"
  bSuccess = WriteRegStringValue(sKeyName, sEntry, sValue)
  sKeyName = "HKEY_CURRENT_USER\Control Panel\Desktop"
  sEntry = "TileWallpaper"
  sValue = "0"
  bSuccess = WriteRegStringValue(sKeyName, sEntry, sValue)
 
  Case 1
  '伸展时
  sKeyName = "HKEY_CURRENT_USER\Control Panel\Desktop"
  sEntry = "WallpaperStyle"
  sValue = "2"
  bSuccess = WriteRegStringValue(sKeyName, sEntry, sValue)
  sKeyName = "HKEY_CURRENT_USER\Control Panel\Desktop"
  sEntry = "TileWallpaper"
  sValue = "0"
  bSuccess = WriteRegStringValue(sKeyName, sEntry, sValue)
 
  Case 2
  '平铺时
  sKeyName = "HKEY_CURRENT_USER\Control Panel\Desktop"
  sEntry = "WallpaperStyle"
  sValue = "1"
  bSuccess = WriteRegStringValue(sKeyName, sEntry, sValue)
  sKeyName = "HKEY_CURRENT_USER\Control Panel\Desktop"
  sEntry = "TileWallpaper"
  sValue = "1"
  bSuccess = WriteRegStringValue(sKeyName, sEntry, sValue)
  End Select
 
  ChangePaper picBuffer, True
  Screen.MousePointer = vbDefault

End Sub

Private Sub MnuShowSize_Click(Index As Integer)

  MnuShowSize(OldShowSize).Checked = False
  MnuShowSize(Index).Checked = True
  OldShowSize = Index
  SaveSetting App.Title, "Settings", "ShowSize", Index
    
  ShowPreview picBuffer, picBuffer.ScaleWidth, picBuffer.ScaleHeight, picShow, picDisplay.ScaleWidth, picDisplay.ScaleHeight, picDisplay.Visible, OldShowSize
  
End Sub

Private Sub mnuToolsOptions_Click()

  frmOption.Show 1
  
End Sub

Private Sub MnuVideoPause_Click()
   
   AudioDisplay.Pause
   
End Sub

Private Sub MnuVideoPlay_Click()
 
   AudioDisplay.Run
   
End Sub

Private Sub MnuVideoStop_Click()
  
   AudioDisplay.Stop
  
End Sub

Private Sub mnuView_Click(Index As Integer)

   MnuView(lvListView.View).Checked = False  '取消上次的查看
   MnuView(Index).Checked = True   '确定此次查看
    
   tbToolBar.Buttons(View_Number + Index).Value = tbrPressed
   
   lvListView.View = Index
   SaveSetting App.Title, "Settings", "ViewMode", Index

End Sub


Private Sub MnuViewPreview_Click()
    
    MnuViewPreview.Checked = Not MnuViewPreview.Checked
    
    '预览栏改变
    If MnuViewPreview.Checked = True Then
       tbToolBar.Buttons(Display_Number + 2).Value = tbrPressed
       SaveSetting App.Title, "Settings", "DisplayPreview", 1
    Else
       tbToolBar.Buttons(Display_Number + 2).Value = tbrUnpressed
       MnuPicture.Visible = False
       SaveSetting App.Title, "Settings", "DisplayPreview", 0
       RefreshDesk   '刷新板面
    End If
    picDisplay.Visible = MnuViewPreview.Checked
   
    SizeControlsH Val(GetSetting(App.Title, "Settings", "HPosition", 1500))
    SaveSetting App.Title, "Settings", "HPosition", imgSplitter2.Top
        
    'If picLoad = True Then
    '   If picDisplay.Visible Then
    '      Call picDisplay_Resize
    '   End If
    'End If
    
End Sub

Private Sub picDisplay_DblClick()

 'MnuPictureView_Click  '显示查看
  
End Sub

Private Sub picDisplay_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  
 'If Button = 2 And picShow.Visible = True Then PopupMenu MnuPicture

End Sub


Private Sub picDisplay_Resize()

If picShow.Visible Then  '如果图片浏览时
  If picShow.Height > picDisplay.Height Then
     picShow.Top = 0
     picShow.MouseIcon = picMouseOver.Picture
    Else
     picShow.Top = (picDisplay.Height - picShow.Height) / 2
  End If
  If picShow.Width > picDisplay.Width Then
     picShow.Left = 0
     picShow.MouseIcon = picMouseOver.Picture
    Else
     picShow.Left = (picDisplay.Width - picShow.Width) / 2
  End If
  '安装鼠标
  If picShow.ScaleHeight <= picDisplay.Height And picShow.ScaleWidth <= picDisplay.Width Then
     picShow.MouseIcon = picMouseUp.Picture
  End If
    
  '预览区有图片时
  If picLoad = True And OldShowSize = 0 Then
     Screen.MousePointer = vbArrowHourglass
      '是否安装图片
      If picDisplay.Visible Then
         ShowPreview picBuffer, picBuffer.ScaleWidth, picBuffer.ScaleHeight, picShow, picDisplay.ScaleWidth, picDisplay.ScaleHeight, picDisplay.Visible, OldShowSize
      End If
     Screen.MousePointer = vbDefault
  End If
End If

If GifView.Visible Then  '如果GIF有效时
   GifView.Left = 20
   GifView.Height = picDisplay.ScaleHeight - 40
   GifView.Width = picDisplay.ScaleWidth - 40
End If

If AudioDisplay.Visible Then  '如果声音有效时
  If AudioDisplay.Width >= picDisplay.Width Then
     AudioDisplay.Left = 0
   Else
     AudioDisplay.Left = (picDisplay.Width - AudioDisplay.Width) / 2
  End If
  
  If AudioDisplay.Height >= picDisplay.Height Then
     AudioDisplay.Top = 0
   Else
     AudioDisplay.Top = (picDisplay.Height - AudioDisplay.Height) / 2
  End If
End If

End Sub

Private Sub picShow_DblClick()

  MnuPictureView_Click  '显示查看
  
End Sub

Private Sub picShow_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
 
 If Button = 2 Then
    PopupMenu MnuPicture
  Else
   '安装鼠标
  If picShow.ScaleHeight <= picDisplay.Height And picShow.ScaleWidth <= picDisplay.Width Then
     picShow.MouseIcon = picMouseUp.Picture
     Exit Sub
   Else
     picShow.MouseIcon = picMouseDown.Picture
  End If
 End If
  
End Sub

Private Sub picShow_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

  If picShow.ScaleHeight <= picDisplay.Height And picShow.ScaleWidth <= picDisplay.Width Then
     Exit Sub
  Else
     MovePicture picShow, X, Y, Button '移动图片
  End If

End Sub

Private Sub picShow_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  
  '安装鼠标
  If picShow.ScaleHeight <= picDisplay.Height And picShow.ScaleWidth <= picDisplay.Width Then
     picShow.MouseIcon = picMouseUp.Picture
   Else
     picShow.MouseIcon = picMouseOver.Picture
  End If
  
End Sub

Private Sub picShow_Resize()

  If picShow.Height > picDisplay.Height Then
     picShow.Top = 0
     picShow.MouseIcon = picMouseOver.Picture
    Else
     picShow.Top = (picDisplay.Height - picShow.Height) / 2
  End If
  If picShow.Width > picDisplay.Width Then
     picShow.Left = 0
     picShow.MouseIcon = picMouseOver.Picture
    Else
     picShow.Left = (picDisplay.Width - picShow.Width) / 2
  End If
  '安装鼠标
  If picShow.ScaleHeight <= picDisplay.Height And picShow.ScaleWidth <= picDisplay.Width Then
     picShow.MouseIcon = picMouseUp.Picture
  End If
  
End Sub

Private Sub ShellFolderViewOC1_SelectionChanged()

End Sub

Private Sub ShellFolderViewX_SelectionChanged()

End Sub

Private Sub tbToolBar_ButtonClick(ByVal Button As MSComctlLib.Button)
    
    On Error Resume Next
    Select Case Button.Key
        Case "打开"
          MnuFileOpen_Click
        Case "播放"
          AudioDisplay.Run   '播放
        Case "剪切"
           Clipboard.Clear '清除剪贴板
        Case "复制"
            mnuEditCopy_Click
        Case "删除"
            mnuFileDelete_Click
        Case "属性"
            MnuFileAttribute_Click
        Case "打印"
            MnuPrintPicture_Click
        Case "大图标"
            mnuView_Click (0)
        Case "小图标"
            mnuView_Click (1)
        Case "列表"
            mnuView_Click (2)
        Case "详细资料"
            mnuView_Click (3)
        Case "升序"
            MnuArrangSortAuto_Click
        Case "降序"
            MnuArrangSortAutoZ_Click
        Case "工具栏"
            mnuViewToolbar_Click
        Case "状态栏"
            mnuViewStatusBar_Click
        Case "预览栏"
            MnuViewPreview_Click
        Case "帮助"
            
        
    End Select
    
End Sub

Private Sub mnuHelpAbout_Click()
    
    MsgBox "版本 " & App.Major & "." & App.Minor & "." & App.Revision
    
End Sub

Private Sub mnuHelpSearchForHelpOn_Click()
    
    Dim nRet As Integer

    '如果这个工程没有帮助文件，显示消息给用户
    '可以在“工程属性”对话框中为应用程序设置帮助文件
    If Len(App.HelpFile) = 0 Then
        MsgBox "无法显示帮助目录，该工程没有相关联的帮助。", vbInformation, Me.Caption
    Else

    On Error Resume Next
        nRet = OSWinHelp(Me.hWnd, App.HelpFile, 261, 0)
        If Err Then
            MsgBox Err.Description
        End If
    End If

End Sub

Private Sub mnuHelpContents_Click()

    Dim nRet As Integer

    '如果这个工程没有帮助文件，显示消息给用户
    '可以在“工程属性”对话框中为应用程序设置帮助文件
    If Len(App.HelpFile) = 0 Then
        MsgBox "无法显示帮助目录，该工程没有相关联的帮助。", vbInformation, Me.Caption
    Else
        On Error Resume Next
        nRet = OSWinHelp(Me.hWnd, App.HelpFile, 3, 0)
        If Err Then
            MsgBox Err.Description
        End If
    End If

End Sub

Private Sub mnuViewRefresh_Click()

   If picLoad = True Then
      mnuEditCopy.Enabled = False '复制按钮无效
      MnuLookFor.Enabled = False '查看菜单无效
      MnuPrintPicture.Enabled = False
      '隐藏图片菜单
      MnuPicture.Visible = False
      picShow.Visible = False
      tbToolBar.Buttons(Copy_Number).Enabled = False
      tbToolBar.Buttons(Printer_Number).Enabled = False
      sbStatusBar.Panels(3).Text = "未注册版: V1.0"
      picLoad = False
   End If
   
   If fPath$ > "" And frmMain.Visible Then
      fPath = ValidateDir(fPath)
      vbGetFileList
   End If
  
   '菜单为无效
   If lvListView.ListItems.Count > 0 Then
      lvListView.SetFocus  '列表获得焦点
    Else
      MenuEnabled (0)
   End If
   
End Sub

Private Sub mnuViewStatusBar_Click()
    
    mnuViewStatusBar.Checked = Not mnuViewStatusBar.Checked
    sbStatusBar.Visible = mnuViewStatusBar.Checked
    
    '状态栏改变
    If mnuViewStatusBar.Checked = True Then
       tbToolBar.Buttons(Display_Number + 1).Value = tbrPressed
       SaveSetting App.Title, "Settings", "DisplayStatusbar", 1
    Else
       tbToolBar.Buttons(Display_Number + 1).Value = tbrUnpressed
       SaveSetting App.Title, "Settings", "DisplayStatusbar", 0
    End If
    
    SizeControls tvTreeView.Width
    SizeControlsH imgSplitter2.Top
    
End Sub

Private Sub mnuViewToolbar_Click()
    
    mnuViewToolbar.Checked = Not mnuViewToolbar.Checked
    tbToolBar.Visible = mnuViewToolbar.Checked
    
    '工具栏改变
    If mnuViewToolbar.Checked = True Then
       tbToolBar.Buttons(Display_Number).Value = tbrPressed
       SaveSetting App.Title, "Settings", "DisplayToolbar", 1
    Else
       tbToolBar.Buttons(Display_Number).Value = tbrUnpressed
       SaveSetting App.Title, "Settings", "Dis