main.frm

电子书 一个很不错的程序 电子书童(110KB) 希望大家有用的下

 .MaxFileSize = 10000
End With
Comdlg.ShowOpen

'If mnuMuilt.Checked Then

 If tvMain.Nodes.Count > 0 Then '判断是否有节点
  n = tvMain.SelectedItem.index
 Else
  Set nodx = tvMain.Nodes.Add(, , , "我的文件", 12, 13)
  n = 1
 End If

tfn = Comdlg.FileName
'Debug.Print tFN
tStr1 = Left(tfn, InStr(tfn, Chr(0))) '判断是否选择了多个文件
If tStr1 = "" Then '添加单个文件
  If mnuAFSon.Checked Then '判断是否添加为子级
   Set nodx = tvMain.Nodes.Add(n, 4, , "导入文件")
  Else
   Set nodx = tvMain.Nodes.Add(n, 2, , "导入文件")
  End If
  nodx.EnsureVisible
  nodx.Selected = True
  nodx.Text = GetMainName(tfn)
  nodx.Tag = tfn
  nodx.Image = Imagen((tfn))
  If Not nodx.Parent Is Nothing Then
  If nodx.Parent.Image = 0 Then nodx.Parent.Image = 12: nodx.Parent.SelectedImage = 13
  End If
  For i = Len(tfn) To 1 Step -1
   If Mid(tfn, i, 1) = "\" Then Exit For
  Next
  DataPath = Left(tfn, i)

  lbCaption.Caption = GetMainName(tfn)
  sbMain.Panels(2).Text = tfn
  onshow.n = nodx.index
  loadtext (tfn)
Else '添加多个文件
  tfn = Right(tfn, Len(tfn) - Len(tStr1)) + Chr(0) '所有文件名
  fnLen = Len(tfn)
  tStr1 = Left(tStr1, Len(tStr1) - 1) '文件所在的目录
  DataPath = tStr1
  '***************
  'If nodx.Parent Is Nothing Then
  'If nodx.Parent.Image = 0 Then nodx.Parent.Image = 12: nodx.Parent.SelectedImage = 13
  'End If
  If mnuAFSon.Checked = True And tvMain.Nodes(n).Image = 0 Then tvMain.Nodes(n).Image = 12: tvMain.Nodes(n).Image = 13
  'if mnuafson.Checked=False then
  For i = 1 To fnLen
  c = Mid$(tfn, i, 1)
   If c = Chr(0) Then
     If tStr2 <> "" Then
       If Right(tStr1, 1) = "\" Then
         tFN2 = tStr1 + tStr2
       Else
         tFN2 = tStr1 + "\" + tStr2
       End If
      If mnuAFSon.Checked Then
       Set nodx = tvMain.Nodes.Add(n, 4, , "导入文件")
      Else
       Set nodx = tvMain.Nodes.Add(n, 2, , "导入文件")
      End If
      nodx.Text = GetMainName(tFN2)
      nodx.Tag = tFN2
      nodx.Image = Imagen((tFN2))
     End If
     tStr2 = ""
   Else
    tStr2 = tStr2 & c
   End If
  Next i
 nodx.EnsureVisible
 nodx.Selected = True
 lbCaption.Caption = nodx.Text
 sbMain.Panels(2).Text = Right(nodx.Tag, Len(nodx.Tag) - InStr(nodx.Tag, Chr(0)))
 onshow.n = nodx.index
 loadtext nodx.Tag
End If
HasModify = True
errd:

End Sub

Private Sub mnuAddPoint_Click()
Dim nodx As Node
With tvMain
 If .Nodes.Count > 0 Then
  Set nodx = .Nodes.Add(.SelectedItem.index, 2, , "新建标题")
 Else
  Set nodx = .Nodes.Add(, , , "我的文件")
 End If
 nodx.EnsureVisible
 nodx.Selected = True
 .StartLabelEdit
 HasModify = True
End With
End Sub

Private Sub mnuAddSub_Click()
Dim nodx As Node
With tvMain
 If .Nodes.Count > 0 Then
  .SelectedItem.Expanded = True
  Set nodx = .Nodes.Add(.SelectedItem.index, 4, , "新建标题")
  If .SelectedItem.Image = 0 Then .SelectedItem.Image = 12: .SelectedItem.SelectedImage = 13
 Else
  Set nodx = .Nodes.Add(, , , "我的文件", 12, 13)
 End If
 nodx.EnsureVisible
 nodx.Selected = True
 .StartLabelEdit
 HasModify = True
End With
End Sub

Private Sub mnuAFSon_Click()
mnuAFSon.Checked = Not mnuAFSon.Checked
tbMain.Buttons(26).Value = -mnuAFSon.Checked
End Sub

Private Sub mnuAppend_Click()
If txtMain.SelText <> "" Then
    Clipboard.SetText Clipboard.GetText(vbCFText) + txtMain.SelText
Else
    Clipboard.SetText Clipboard.GetText(vbCFText) + txtMain.Text
End If
End Sub

Private Sub mnuBOIOpenM_Click()

Dim SearchPath As String
Dim hKey As Long
Dim hkey2 As Long

Dim regres As String
Dim length As Long
Dim fn As String
Dim regtype As Long
Dim phkResult As Long
Dim lpdwDisposition As Long
Dim hhh As Long
Dim lpData As String
Dim abc As SECURITY_ATTRIBUTES
length = 256
regres = Space$(length)

If Right(App.path, 1) = "\" Then
 fn = App.path + "bookman.exe"
Else
 fn = App.path + "\" + "bookman.exe"
End If
'MsgBox fn


If RegOpenKeyEx(HKEY_CLASSES_ROOT, ".boi", 0&, KEY_ALL_ACCESS, hKey) = 0& Then
 MsgBox "*.BOI文件已经关联"
 RegCloseKey hKey
Else
 If RegCreateKeyEx(HKEY_CLASSES_ROOT, ".boi", 0&, "aaa", -1&, KEY_ALL_ACCESS, abc, hKey, REG_CREATED_NEW_KEY) = 0& Then
 Call RegSetValueEx(hKey, "", 0&, REG_SZ, ByVal "Book Manager", Len("Book manager") + 1)
 RegCloseKey hKey
 End If
 Call RegCreateKeyEx(HKEY_CLASSES_ROOT, "Book Manager", 0&, "aaa", -1&, KEY_ALL_ACCESS, abc, hKey, REG_CREATED_NEW_KEY)
 Call RegSetValueEx(hKey, "", 0&, REG_SZ, ByVal "Book Manager Document", Len("Book Manager Document") + 1)
 
 Call RegCreateKeyEx(hKey, "DefaultIcon", 0&, "aaa", -1&, KEY_ALL_ACCESS, abc, hkey2, REG_CREATED_NEW_KEY)
 Call RegSetValueEx(hkey2, "", 0&, REG_SZ, ByVal fn + " ,0", Len(fn + " ,0") + 1)
 
 RegCloseKey hkey2
 Call RegCreateKeyEx(hKey, "shell", 0&, "aaa", -1&, KEY_ALL_ACCESS, abc, hkey2, REG_CREATED_NEW_KEY)
 RegCloseKey hKey
 Call RegCreateKeyEx(hkey2, "open", 0&, "aaa", -1&, KEY_ALL_ACCESS, abc, hKey, REG_CREATED_NEW_KEY)
 RegCloseKey hkey2
 Call RegCreateKeyEx(hKey, "command", 0&, "aaa", -1&, KEY_ALL_ACCESS, abc, hkey2, REG_CREATED_NEW_KEY)
 Call RegSetValueEx(hkey2, "", 0&, REG_SZ, ByVal fn + " %1", Len(fn + " %1") + 1)
 RegCloseKey hkey2
 MsgBox "文件关联成功，以后您只要在资源管理器里单击BOI文件即可打开!"
End If
End Sub

Private Sub mnuBOIOpenUN_Click()
Dim SearchPath As String
Dim hKey As Long
Dim hkey2 As Long

Dim regres As String
Dim length As Long
Dim fn As String
Dim regtype As Long
Dim phkResult As Long
Dim lpdwDisposition As Long
Dim hhh As Long
Dim lpData As String
Dim abc As SECURITY_ATTRIBUTES
length = 256
regres = Space$(length)

If RegOpenKeyEx(HKEY_CLASSES_ROOT, ".boi", 0&, KEY_ALL_ACCESS, hKey) = 0& Then
 RegCloseKey hKey
 RegDeleteKey HKEY_CLASSES_ROOT, ".boi"
 RegDeleteKey HKEY_CLASSES_ROOT, "Book Manager"
 MsgBox "取消文件关联成功！"
Else
 MsgBox "尚未建立关联！"
End If
End Sub

Private Sub mnuClearLink_Click()
With tvMain

If .Nodes.Count > 0 Then
 .SelectedItem.Tag = ""

 If .SelectedItem.Children > 0 Then
  .SelectedItem.Image = 12
  .SelectedItem.SelectedImage = 13
 Else
  .SelectedItem.Image = 0
  .SelectedItem.SelectedImage = 0
 End If
 
End If

If .Nodes.Count > 0 Then
 Call tvMain_NodeClick(ByVal .SelectedItem)
End If

End With
End Sub

Private Sub mnuCopy_Click()
If txtMain.SelText <> "" Then
    Clipboard.SetText txtMain.SelText
Else
    Clipboard.SetText txtMain.Text
End If
End Sub

Private Sub mnuDefBrowse_Click()
Dim result As Long
On Error GoTo errd:
With Comdlg
 .CancelError = True
 .Filter = "可执行文件(*.EXE)|*.exe"
 .DialogTitle = "选择阅读文本文件的默认浏览器"
 .FileName = "*.exe"
 .Flags = &H4 Or &H1000
End With

 Comdlg.ShowOpen
 DefBrowse = Comdlg.FileName
Exit Sub
errd:
If DefBrowse <> "" Then '如果在选择默认浏览器时按"取消",提示是否使用系统默认浏览器,还是使用原来的浏览器
 If MsgBox("是使用系统默认浏览器(NotePad) , 还是仅仅取消本次操作?", vbYesNo) = vbYes Then DefBrowse = ""
End If
End Sub

Private Sub mnuDeleteFile_Click()
Dim result As Long, tfn As String
With tvMain
If .Nodes.Count > 0 Then

 If .SelectedItem.Children > 0 Then
   result = MsgBox("真的要删除此标题即其所有子标题和所有与此关联的文件？", vbQuestion Or vbYesNo, "请求确认")
   If result = 6 Then
    FilesToDelete = ""
    ListAllSub .SelectedItem.index
    'tfn = Right(FilesToDelete, Len(FilesToDelete) - 1)
    DeleteFile FilesToDelete
    .Nodes.Remove .SelectedItem.index
   End If
 Else
 
   tfn = .SelectedItem.Tag
   DeleteFile Right(tfn, Len(tfn) - InStr(tfn, Chr(0)))
  .Nodes.Remove .SelectedItem.index
 End If
 
 If .Nodes.Count > 0 Then
  Call tvMain_NodeClick(ByVal .SelectedItem)
 End If
End If
HasModify = True

End With
'Debug.Print FilesToDelete

End Sub

Private Sub mnuDeletePoint_Click()
Dim result
With tvMain
If .Nodes.Count > 0 Then
 If .SelectedItem.Children > 0 Then result = MsgBox("真的要删除此标题即其所有子标题？", vbQuestion Or vbOKCancel, "请求确认")
 If result <> 2 Then .Nodes.Remove .SelectedItem.index
End If
If .Nodes.Count > 0 Then
 Call tvMain_NodeClick(ByVal .SelectedItem)
End If
HasModify = True
End With
End Sub

Private Sub mnuDrag_Click()
mnuDrag.Checked = Not mnuDrag.Checked
End Sub

Private Sub mnuEditCap_Click()
tvMain.StartLabelEdit
End Sub

Private Sub mnuExec_Click()
Dim handle As Long
Dim tn, NFN(10) As String
Dim txt As Boolean
NFN(0) = ".BMP"
NFN(1) = ".ZIP"
NFN(2) = ".EXE"
NFN(3) = ".CHM"
NFN(4) = ".JPG"
NFN(5) = ".GIF"
NFN(6) = ".MP3"
NFN(7) = ".MID"
NFN(8) = ".WAV"


If ShowText <> "" Then ''''''''''''''*******************
  
  For Each tn In NFN()
   If Right(UCase(ShowText), 4) = tn Then txt = True: Exit For
  Next
  
  If txt = False Then
   If DefBrowse = "" Then
    handle = Me.hwnd
    Call ShellExecute(handle, "open", ShowText, "", "", 1)
   Else
    Shell DefBrowse + " " + ShowText, vbNormalFocus
   End If
  Else
   Call ShellExecute(handle, "open", ShowText, "", "", 1)
  End If
End If
End Sub

Private Sub mnuExit_Click()
Unload Me
End Sub

Private Sub mnuExport_Click()
'''
MsgBox "对不起，本功能将在2.8版中提供，请稍等"
End Sub

Private Sub mnuFind_Click()
' 如果文本框中有文本，把它赋值给“查找”窗体中的文本框，
' 否则赋值上一次搜索文本的值
    If Me.txtMain.SelText <> "" Then
        frmFind.Text1.Text = Me.txtMain.SelText
    Else
        frmFind.Text1.Text = gFindString
    End If
    ' 设置全局变量为从头部开始
    gFirstTime = True
    ' 设置区分大小写复选框以匹配全局变量
    If (gFindCase) Then
        frmFind.chkCase = 1
    End If
    ' 显示“查找”窗体
    txtMain.SetFocus
    frmFind.Show vbModal

End Sub

Private Sub mnuFindNext_Click()
    If Len(gFindString) > 0 Then
        FindIt
    Else
        mnuFind_Click
    End If
End Sub

Private Sub mnuFont_Click()
On Error Resume Next
With Comdlg
.Flags = cdlCFBoth Or &H100
.CancelError = True
.FontName = txtMain.Font.Name
.FontSize = txtMain.Font.Size
.FontBold = txtMain.Font.Bold
.FontItalic = txtMain.Font.Italic
.FontStrikethru = txtMain.Font.Strikethrough
.FontUnderline = txtMain.Font.Underline
.ShowFont

txtMain.Font.Name = .FontName
txtMain.Font.Size = .FontSize
txtMain.Font.Bold = .FontBold
txtMain.Font.Italic = .FontItalic
txtMain.Font.Strikethrough = .FontStrikethru
txtMain.Font.Underline = .FontUnderline
End With
End Sub

Private Sub mnuHelp_Click()
Dim path As String
path = App.path
If Right(path, 1) <> "\" Then path = path + "\"
If Dir(path + "bmreadme.txt") <> "" Then
  txtMain.Loadfile path + "bmreadme.txt", 1
  ShowText = ""
 Else
  txtMain.Text = "无法找到说明文件 - " + path + "BMReadme.txt"
  ShowText = ""
 End If

End Sub

Private Sub mnuHtml_Click()
On Error Resume Next
mnuHtml.Checked = Not mnuHtml.Checked
tbMain.Buttons(25).Value = -mnuHtml.Checked
ShowText = ""