www.pudn.com > ProgramBox.rar > Form1.frm, change:2013-08-24,size:17689b


VERSION 5.00 
Begin VB.Form Form1  
   AutoRedraw      =   -1  'True 
   Caption         =   "常用程序管理器" 
   ClientHeight    =   6375 
   ClientLeft      =   165 
   ClientTop       =   735 
   ClientWidth     =   4350 
   Icon            =   "Form1.frx":0000 
   LinkTopic       =   "Form1" 
   ScaleHeight     =   6375 
   ScaleMode       =   0  'User 
   ScaleWidth      =   3497.938 
   StartUpPosition =   3  '窗口缺省 
   Begin VB.PictureBox Picture1  
      Height          =   6375 
      Left            =   0 
      OLEDropMode     =   1  'Manual 
      ScaleHeight     =   6315 
      ScaleWidth      =   16515 
      TabIndex        =   0 
      Top             =   0 
      Width           =   16575 
      Begin VB.PictureBox Picture2  
         BorderStyle     =   0  'None 
         Height          =   975 
         Index           =   0 
         Left            =   -480 
         ScaleHeight     =   975 
         ScaleWidth      =   1455 
         TabIndex        =   1 
         Top             =   -360 
         Visible         =   0   'False 
         Width           =   1455 
      End 
   End 
   Begin VB.Menu AddTo  
      Caption         =   "添加程序" 
   End 
End 
Attribute VB_Name = "Form1" 
Attribute VB_GlobalNameSpace = False 
Attribute VB_Creatable = False 
Attribute VB_PredeclaredId = True 
Attribute VB_Exposed = False 
Private Declare Function DrawIcon Lib "user32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal hIcon As Long) As Long 
Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long 
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hDC As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size) As Long 
 
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long 
Private Type Size 
          cx   As Long 
          cy   As Long 
  End Type 
 Private Type RECT 
Left As Long 
Top As Long 
Right As Long 
Bottom As Long 
End Type 
  Private Type POINTAPI 
X As Long 
Y As Long 
End Type 
Private Declare Function timeGetTime Lib "winmm.dll" () As Long 
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFilename As String) As Long 
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFilename As String) As Long 
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long 
 
Private Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As RECT) As Long 
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long 
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long 
Private Declare Function CreatePopupMenu Lib "user32" () As Long 
Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long 
Dim hMenuPopup As Long, hzMenuPopup As Long 
Dim ctime As Long 
 
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long 
 Private Declare Function GetFileTitle Lib "comdlg32.dll" Alias "GetFileTitleA" (ByVal lpszFile As String, ByVal lpszTitle As String, ByVal cbBuf As Integer) As Integer 
'设置OPENFILENAME类所包含的属性值 
Private Type OPENFILENAME 
        lStructSize As Long 
        hwndOwner As Long 
        hInstance As Long 
        lpstrFilter As String 
        lpstrCustomFilter As String 
        nMaxCustFilter As Long 
        nFilterIndex As Long 
        lpstrFile As String 
        nMaxFile As Long 
        lpstrFileTitle As String 
        nMaxFileTitle As Long 
        lpstrInitialDir As String 
        lpstrTitle As String 
        flags As Long 
        nFileOffset As Integer 
        nFileExtension As Integer 
        lpstrDefExt As String 
        lCustData As Long 
        lpfnHook As Long 
        lpTemplateName As String 
End Type 
 
'定义打开时的各项常数 
Private Const OFN_READONLY = &H1 
Private Const OFN_OVERWRITEPROMPT = &H2 
Private Const OFN_HIDEREADONLY = &H4 
Private Const OFN_NOCHANGEDIR = &H8 
Private Const OFN_SHOWHELP = &H10 
Private Const OFN_ENABLEHOOK = &H20 
Private Const OFN_ENABLETEMPLATE = &H40 
Private Const OFN_ENABLETEMPLATEHANDLE = &H80 
Private Const OFN_NOVALIDATE = &H100 
Private Const OFN_ALLOWMULTISELECT = &H200 
Private Const OFN_EXTENSIONDIFFERENT = &H400 
Private Const OFN_PATHMUSTEXIST = &H800 
Private Const OFN_FILEMUSTEXIST = &H1000 
Private Const OFN_CREATEPROMPT = &H2000 
Private Const OFN_SHAREAWARE = &H4000 
Private Const OFN_NOREADONLYRETURN = &H8000 
Private Const OFN_NOTESTFILECREATE = &H10000 
Private Const OFN_NONETWORKBUTTON = &H20000 
Private Const OFN_NOLONGNAMES = &H40000                      '  force no long names for 4.x modules 
Private Const OFN_EXPLORER = &H80000                         '  new look commdlg 
Private Const OFN_NODEREFERENCELINKS = &H100000 
Private Const OFN_LONGNAMES = &H200000                       '  force long names for 3.x modules 
 
Private Const OFN_SHAREFALLTHROUGH = 2 
Private Const OFN_SHARENOWARN = 1 
Private Const OFN_SHAREWARN = 0 
 
  
 
Private Function OpenFile() As String 
    Dim file As OPENFILENAME, sFile As String, sFileTitle As String, lResult As Long, iDelim As Integer 
    file.lStructSize = Len(file) 
    file.hwndOwner = Me.hwnd 
    file.flags = OFN_HIDEREADONLY + OFN_PATHMUSTEXIST + OFN_FILEMUSTEXIST 
    file.lpstrFile = "*.exe" & String$(250, 0) '设置默认要打开文件的扩展名 
    file.nMaxFile = 255 '显示文件名的长度 
    file.lpstrFileTitle = String$(255, 0) '打开对话框的标题 
    file.nMaxFileTitle = 255 '打开对话框的标题的长度 
    'file.lpstrInitialDir = App.Path ' Environ$("WinDir") '设置盘符 
    file.lpstrFilter = "可执行文件 *.exe" '打开的文件类型 
    file.nFilterIndex = 1 
    file.lpstrTitle = "打开文件" 
    lResult = GetOpenFileName(file) '取得文件名 
    If lResult <> 0 Then 
        iDelim = InStr(file.lpstrFileTitle, Chr$(0)) 
        If iDelim > 0 Then 
            sFileTitle = Left$(file.lpstrFileTitle, iDelim - 1) 
        End If 
        iDelim = InStr(file.lpstrFile, Chr$(0)) 
        If iDelim > 0 Then 
            sFile = Left$(file.lpstrFile, iDelim - 1) 
        End If 
        OpenFile = sFile 
    End If 
 
End Function 
 
 
Private Function INIRead(iAppName As String, iKeyName As String, iFileName As String) As String 
Dim iStr$, aaa$ 
iStr = String(1000, Chr(0)) 
aaa = Left(iStr, GetPrivateProfileString(iAppName, ByVal iKeyName, "", iStr, Len(iStr), iFileName)) 
INIRead = IIf(InStr(aaa, Chr(0)) > 0, Replace(aaa, Chr(0), ""), aaa) 
End Function 
 
Private Function INIWrite(iAppName As String, iKeyName As String, iKeyString As String, iFileName As String) 
Call WritePrivateProfileString(iAppName, iKeyName, iKeyString, iFileName) 
End Function 
 
 
Private Sub InitPopupMenu(k As Integer)    '创建 弹出菜单 
     If hMenuPopup = 0 Then 
        hMenuPopup = CreatePopupMenu() 
        If k > 0 Then 
        AppendMenu hMenuPopup, &H0&, 301, "打开程序" 
        AppendMenu hMenuPopup, &H0&, 305, "打开文件夹" 
        AppendMenu hMenuPopup, &H0&, 302, "添加新程序" 
        AppendMenu hMenuPopup, &H0&, 303, "删除程序" 
        AppendMenu hMenuPopup, &H0&, 304, "删除所有程序" 
        Else 
        AppendMenu hMenuPopup, &H0&, 306, "添加新程序" 
        AppendMenu hMenuPopup, &H0&, 307, "删除所有程序" 
        End If 
     End If 
End Sub 
 
Public Sub OnPopMenu(ByVal hwnd As Long, k As Integer) '右键弹出菜单 的响应函数 
Dim ki As Integer 
ki = k 
Dim menRect As RECT, m As Integer, iniPath As String, dpath As String, Ename As String, EPath As String 
iniPath = App.Path & "\config.ini" 
     If hMenuPopup = 0 Then InitPopupMenu k 
        Dim p As POINTAPI, RetID As Long: GetCursorPos p '获取鼠标屏幕位置 
       
        RetID = TrackPopupMenu(hMenuPopup, &H100&, p.X, p.Y, 0&, hwnd, menRect) '弹出菜单 
        ctime = timeGetTime 
        Select Case RetID    '响应菜单操作 
           Case 301 
           dpath = INIRead("Program", "Exe" & k, iniPath) 
           Ename = ExeName(dpath) 
           EPath = Replace(dpath, Ename, "") 
            
           ShellExecute 0, "Open", dpath, "", EPath, SW_SHOWNORMAL 
           Picture2(k).BorderStyle = 0 
            
           Case 302 
           AdToPic 
           ctime = timeGetTime 
           Case 303 
           m = Picture2.Count - 1 
           Delini k 
           For i = ki To m - 1 
           Picture2(i).Picture = Picture2(i + 1).Image 
           Next 
           Unload Picture2(m) 
            
           Case 304 
            m = Picture2.Count - 1 
           For i = 1 To m 
           Unload Picture2(i) 
           INIWrite "Program", "Exe" & i, vbNullString, iniPath 
           Next 
           Case 305 
           dpath = INIRead("Program", "Exe" & k, iniPath) 
           Ename = ExeName(dpath) 
           EPath = Replace(dpath, Ename, "") 
           Shell "explorer " & EPath, 1 
            
            
           Case 306 
           AdToPic 
           Case 307 
     
           m = Picture2.Count - 1 
           For i = 1 To m 
           Unload Picture2(i) 
           INIWrite "Program", "Exe" & i, vbNullString, iniPath 
           Next 
           End Select 
        If hMenuPopup Then DestroyMenu hMenuPopup: hMenuPopup = 0 '销毁弹出菜单 
End Sub 
 
 
 
Private Sub AddTo_Click() 
AdToPic 
End Sub 
 
Private Sub AdToPic() 
Dim dpath As String, k As Integer, rPath As String 
 
    dpath = OpenFile 
    If dpath <> "" Then 
  Dim iniPath As String 
    iniPath = App.Path & "\config.ini" 
     
    i = 1 
    rPath = INIRead("Program", "Exe" & i, iniPath) 
    Do While rPath <> "" 
    If rPath = dpath Then Exit Sub 
    i = i + 1 
    rPath = INIRead("Program", "Exe" & i, iniPath) 
    Loop 
    AddToP dpath 
    End If 
    End Sub 
     
     
    Sub AddToP(dpath As String) 
    If InStr(LCase(dpath), ".lnk") > 0 Then 
     
    dpath = GetShellLinkPath(dpath) 
    End If 
    If dpath = "" Then Exit Sub 
    Dim iniPath As String, k As Integer 
    iniPath = App.Path & "\config.ini" 
 
    k = Picture2.Count 
    INIWrite "Program", "Exe" & k, dpath, iniPath 
    Load Picture2(k) 
    Picture2(k).Visible = True 
    If k > 1 Then 
    If Picture2(k - 1).Left + (Picture2(k - 1).Width * 2) - 200 > Picture1.ScaleWidth Then 
    Picture2(k).Left = 10 
    Picture2(k).Top = Picture2(k - 1).Top + Picture2(k - 1).Height + 5 
    Else 
    Picture2(k).Left = Picture2(k - 1).Left + Picture2(k - 1).Width + 5 
    Picture2(k).Top = Picture2(k - 1).Top 
    End If 
    Else 
    Picture2(k).Top = 10 
    Picture2(k).Left = 10 
    End If 
    Picture2(k).AutoRedraw = True 
 
     
    AddIco dpath, k 
 
    If Picture2(k).Top + Picture2(k).Height > Picture1.Height Then Me.Height = Me.Height + Picture2(k).Height 
   
 
 
 
End Sub 
 
Sub AddIco(dpath As String, k As Integer) 
Dim lngReturn     As Long 
          Dim typSize     As Size 
          Dim lngX     As Long 
          Dim lngY     As Long 
 
Dim Ename As String, nameXs As Long 
p = ExtractIcon(App.hInstance, dpath, 0) '读取每个图标 
DrawIcon Picture2(k).hDC, 25, 0, p 
Ename = ExeName(dpath) 
namelen = StrLen(Ename) 
Do While namelen > 26 
Ename = Mid(Ename, 1, Len(Ename) - 4) & "..." 
namelen = StrLen(Ename) 
Loop 
Picture2(k).FontSize = 10 
Picture2(k).ForeColor = &HFF0000 
    xx = Picture2(k).Width - Len(txt) * 20 * (Picture2(k).FontSize / 14) 
    yy = Picture2(k).Height - Picture2(k).FontSize * 25 
    Picture2(k).CurrentX = 0 
    Picture2(k).CurrentY = 500 
    Picture2(k).Print Ename 
 
 
 
 
End Sub 
 
 
 
Private Function GetShellLinkPath(ByVal LnkPath As String) As String 
GetShellLinkPath = "" 
 Dim mShell     As Shell, mFile       As FolderItem, mFolder       As Folder 
 Dim lnk     As ShellLinkObject, i       As Long 
 Dim LnkName As String, LnktPath As String 
LnkName = ExeName(LnkPath) 
 LnktPath = Replace(LnkPath, "\" & LnkName, "") 
 Set mShell = New Shell 
 Set mFolder = mShell.NameSpace(LnktPath) 
 On Error Resume Next 
 Set mFile = mFolder.Items.Item(LnkName) 
 If Err Then 
 Err.Clear 
Exit Function 
 Else 
 If mFile.IsLink Then 
 Set lnk = mFile.GetLink 
 
GetShellLinkPath = lnk.Path 
 Else 
Exit Function 
 End If 
 End If 
 End Function 
  
Function ExeName(pathname As String) As String 
 
Dim k As Integer, lname As String 
k = InStr(pathname, "\") 
lname = pathname 
Do While k > 0 
lname = Mid(lname, k + 1) 
k = InStr(lname, "\") 
Loop 
ExeName = lname 
 
End Function 
 
 
Function StrLen(Str As String) As Integer 
 
Dim xcode As String 
xcode = "" 
For i = 1 To Len(Str) 
xcode = xcode & Hex(Asc(Mid(Str, i, 1))) 
Next 
 
 
StrLen = Len(xcode) 
 
 
End Function 
 
 
 
Private Sub Form_Load() 
ret = GetTargetProcessID("程序管理器.exe") 
If ret > 0 Then MsgBox "已经运行一个实例。": End 
Dim iniPath As String, rPath As String, i As Integer 
iniPath = App.Path & "\config.ini" 
mWid = INIRead("SIZE", "WIDTH", iniPath) 
mHei = INIRead("SIZE", "HEIGHT", iniPath) 
If mWid <> "" And mHei <> "" Then 
Me.Width = CLng(mWid) 
Me.Height = CLng(mHei) 
End If 
i = 1 
 rPath = INIRead("Program", "Exe" & i, iniPath) 
    Do While rPath <> "" 
    If Dir(rPath) <> "" Then 
    AddToP rPath 
    Else 
    Delini i 
    End If 
    i = i + 1 
    rPath = INIRead("Program", "Exe" & i, iniPath) 
    Loop 
     
End Sub 
 
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 
For i = 1 To Picture2.Count - 1 
If Picture2(i).BorderStyle = 1 Then Picture2(i).BorderStyle = 0 
Next 
End Sub 
 
 
 
 
 
Private Sub Delini(j As Integer) 
 
Dim iniPath As String 
Dim pStr As String 
iniPath = App.Path & "\config.ini" 
Do 
pStr = INIRead("Program", "Exe" & j + 1, iniPath) 
If pStr <> "" Then 
INIWrite "Program", "Exe" & j, pStr, iniPath 
j = j + 1 
Else 
INIWrite "Program", "Exe" & j, vbNullString, iniPath 
Exit Do 
End If 
Loop 
 
 
 
 
 
 
End Sub 
 
 
 
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) 
If Me.WindowState <> 1 Then 
Dim iniPath As String 
iniPath = App.Path & "\config.ini" 
INIWrite "SIZE", "WIDTH", Me.Width, iniPath 
INIWrite "SIZE", "HEIGHT", Me.Height, iniPath 
End If 
End 
End Sub 
 
Private Sub Form_Resize() 
 
Picture1.Left = 5 
Picture1.Width = Me.ScaleWidth - 10 
Picture1.Top = 0 
Picture1.Height = Me.ScaleHeight - 10 
For k = 0 To Picture2.Count - 1 
If k > 0 Then 
If k > 1 Then 
    If Picture2(k - 1).Left + (Picture2(k - 1).Width * 2) - 200 > Picture1.ScaleWidth Then 
    Picture2(k).Left = 10 
    Picture2(k).Top = Picture2(k - 1).Top + Picture2(k - 1).Height + 5 
    Else 
    Picture2(k).Left = Picture2(k - 1).Left + Picture2(k - 1).Width + 5 
    Picture2(k).Top = Picture2(k - 1).Top 
    End If 
    Else 
    Picture2(k).Top = 10 
    Picture2(k).Left = 10 
    End If 
 
End If 
 
Next 
 
 
End Sub 
 
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 
For i = 1 To Picture2.Count - 1 
If Picture2(i).BorderStyle = 1 Then Picture2(i).BorderStyle = 0 
Next 
End Sub 
 
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
If Button = 2 Then OnPopMenu Picture1.hwnd, -1 
End Sub 
 
Private Sub Picture1_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) 
Dim sStr As String, dpath As String, iniPath As String 
On Error GoTo Ext 
iniPath = App.Path & "\config.ini" 
For i = 1 To Data.Files.Count '逐个读取文件路径 
       sStr = Data.Files(i) 
    Next 
    dpath = sStr 
    If dpath <> "" Then 
    i = 1 
    rPath = INIRead("Program", "Exe" & i, iniPath) 
    Do While rPath <> "" 
    If rPath = dpath Then Exit Sub 
    i = i + 1 
    rPath = INIRead("Program", "Exe" & i, iniPath) 
    Loop 
    AddToP dpath 
   End If 
Ext: 
End Sub 
 
Private Sub Picture2_Click(Index As Integer) 
If timeGetTime - ctime > 1000 Then 
Dim dpath As String, Ename As String, EPath As String, iniPath As String 
iniPath = App.Path & "\config.ini" 
dpath = INIRead("Program", "Exe" & Index, iniPath) 
           Ename = ExeName(dpath) 
           EPath = Replace(dpath, Ename, "") 
            
           ShellExecute 0, "Open", dpath, "", EPath, SW_SHOWNORMAL 
           Picture2(Index).BorderStyle = 0 
           ctime = timeGetTime 
 End If 
End Sub 
 
Private Sub Picture2_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) 
If timeGetTime - ctime > 1000 Then 
For i = 1 To Picture2.Count - 1 
If i <> Index Then 
If Picture2(i).BorderStyle = 1 Then Picture2(i).BorderStyle = 0 
End If 
Next 
If X > 0 And X < Picture2(Index).Width And Y > 0 < Picture2(Index).Height Then 
Picture2(Index).BorderStyle = 1 
Else 
Picture2(Index).BorderStyle = 0 
End If 
End If 
End Sub 
 
Private Sub Picture2_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) 
If timeGetTime - ctime > 1000 Then 
If Button = 2 Then 
OnPopMenu Picture2(Index).hwnd, Index 
End If 
End If 
End Sub