frmsec.frm

小秘书(类似于MyHelper的程序)（附源代码）

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Form1 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "小秘书"
   ClientHeight    =   3465
   ClientLeft      =   150
   ClientTop       =   435
   ClientWidth     =   2070
   Icon            =   "frmSec.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   3465
   ScaleWidth      =   2070
   StartUpPosition =   3  '窗口缺省
   Begin VB.Data Data1 
      Caption         =   "Data1"
      Connect         =   "Access"
      DatabaseName    =   "E:\Mysoft\secretary\Files.mdb"
      DefaultCursorType=   0  '缺省游标
      DefaultType     =   2  '使用 ODBC
      Exclusive       =   0   'False
      Height          =   345
      Left            =   480
      Options         =   0
      ReadOnly        =   0   'False
      RecordsetType   =   1  'Dynaset
      RecordSource    =   "pathname"
      Top             =   3120
      Width           =   1140
   End
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   0
      Top             =   3000
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.ListBox List1 
      BackColor       =   &H00E0E0E0&
      Height          =   3300
      Left            =   120
      TabIndex        =   0
      ToolTipText     =   "启动程序:双击 操作:单击右键"
      Top             =   0
      Width           =   1815
   End
   Begin VB.Label Label1 
      DataField       =   "name"
      DataSource      =   "Data1"
      Height          =   135
      Left            =   240
      TabIndex        =   1
      Top             =   2760
      Width           =   975
   End
   Begin VB.Menu mnuDo 
      Caption         =   "操作"
      Visible         =   0   'False
      Begin VB.Menu mnuAdd 
         Caption         =   "添加"
      End
      Begin VB.Menu mnuDel 
         Caption         =   "删除"
      End
      Begin VB.Menu mnuRename 
         Caption         =   "重命名"
      End
      Begin VB.Menu mnuDial 
         Caption         =   "拨号上网"
      End
      Begin VB.Menu mnuSep 
         Caption         =   "-"
      End
      Begin VB.Menu mnuExit 
         Caption         =   "退出"
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'===============================================================================
'程序名称：小秘书
'程序简介：利用 Shell 函数启动带 Windows 窗口的程序,以便让桌面和开始菜单整洁一些
'程序性质：自由软件
'开发环境：PWin98、VB6.0
'作者：土人 [[e-mail]]
'说明：程序中的拨号代码借用在 VB编程乐园 上发表的某作者的成果。在此表示感谢！
'===============================================================================
Option Explicit
     
'申明拨号上网的API函数
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" _
    (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _
    ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" _
    (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
    ByRef lpType As Long, ByVal szData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
'常数
Const HKEY_CURRENT_USER = &H80000001
Const ERROR_SUCCESS = 0&
Dim sFilename As String

Private Sub mnuDial_Click()
'启动默认拨号连接
Shell "rundll rnaui.dll,RnaDial " + GetConnect, vbNormalFocus
End Sub
     
Public Function GetConnect() As String
Dim hKey As Long
Dim SubKey As String
hKey = HKEY_CURRENT_USER  '主键
SubKey = "RemoteAccess"   '子键
'取得默认连接名
GetConnect = GetRegValue(hKey, SubKey, "Default")
End Function

Public Function GetRegValue(hKey As Long, lpszSubKey As String, szKey As String) As Variant
On Error GoTo ErrorRoutineErr:
Dim phkResult As Long
Dim lResult As Long
Dim szBuffer As String
Dim lBuffSize As Long

'创建缓冲区
szBuffer = Space(255)
lBuffSize = Len(szBuffer)

'打开注册键
RegOpenKeyEx hKey, lpszSubKey, 0, 1, phkResult

'查询结果
lResult = RegQueryValueEx(phkResult, szKey, 0, 0, szBuffer, lBuffSize)

'关闭注册键
RegCloseKey phkResult

'返回结果
If lResult = ERROR_SUCCESS Then
GetRegValue = Left(szBuffer, lBuffSize - 1)
Else
GetRegValue = ""
End If
Exit Function

ErrorRoutineErr:
GetRegValue = ""
End Function

'初始化程序
Private Sub Form_Load()
    Dim AllLines As New Collection    '内存中的行数据库
    Dim CurrentLine As Long    '当前行集合索引
    Dim nextLine As String    '从文件中读出的每一行
    Dim InFile As Integer    '文件的描述符
    InFile = FreeFile
    Data1.Visible = False
    Label1.Visible = False
    Data1.DatabaseName = App.Path + "\Files.mdb"
    Data1.RecordSource = "pathname"
    On Error GoTo RedoErr
    Open App.Path + "\Record.txt" For Input As InFile '打开文件
    While Not EOF(InFile)
        Line Input #InFile, nextLine
       AllLines.Add nextLine
   Wend
   Close InFile
    Dim i As Integer
    '以下为提取当前行和下一行
    For i = 0 To AllLines.Count - 1
        CurrentLine = CurrentLine + 1
        If AllLines.Count < CurrentLine Then
            CurrentLine = 1
        End If
        If AllLines.Count > 0 Then
            List1.AddItem AllLines.Item(CurrentLine)
        End If
    Next i
    Exit Sub
RedoErr:
    MsgBox "无程序列表文件库。请添加。", vbExclamation, "提示"
   mnuAdd_Click
   
End Sub

'单击列表框事件
Private Sub List1_Click()
    Dim Ind As Integer
    Ind = List1.ListIndex
    If Ind < Data1.Recordset.RecordCount Then
        Data1.Recordset.AbsolutePosition = Ind
    Else
        Data1.Recordset.Move (Ind)
    End If
End Sub

'双击列表框事件
Private Sub List1_dblClick()
    sFilename = Label1.Caption
    Shell sFilename, vbNormalFocus
End Sub

'重命名
Private Sub mnuRename_Click()
    Dim Ind As Integer
    Ind = List1.ListIndex  '获取索引
    List1.List(Ind) = InputBox("重新命名为：", "更名", List1.List(Ind))
    Kill App.Path + "\Record.txt"
    For Ind = 0 To List1.ListCount - 1
    Open App.Path + "\Record.txt" For Append As #1
    Print #1, List1.List(Ind)
    Close #1
    Next
End Sub

'删除
Private Sub mnuDel_Click()
    Dim Ind As Integer
    Ind = List1.ListIndex  '获取索引
    If Ind >= 0 Then  '确保选定列表项目
        List1.RemoveItem (Ind)  '将其从列表中删除
    End If
    Kill App.Path + "\Record.txt"
    For Ind = 0 To List1.ListCount - 1
        Open App.Path + "\Record.txt" For Append As #1
        Print #1, List1.List(Ind)
    Close #1
    Next
    Data1.Recordset.Delete
End Sub

'添加
Private Sub mnuAdd_Click()
    Dim sN As String, rN As String
    With CommonDialog1
        .Filter = "程序文件(*.exe)|*.exe"
        .ShowOpen
    End With
    sN = CommonDialog1.FileTitle
    rN = InputBox("请输入自定义的名称", "命名", sN)
    List1.AddItem rN
    Open App.Path + "\Record.txt" For Append As #1
    Print #1, rN
    Close #1
    Data1.Recordset.AddNew
    Label1.Caption = CommonDialog1.FileName
End Sub

'退出
Private Sub mnuExit_Click()
    End
End Sub

'动态菜单
Private Sub List1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then
PopupMenu mnuDo, vbPopupMenuLeftAlign
Else
Exit Sub
End If
End Sub