frmgroup.frm

来自「吃豆子游戏的源代码。 嘿嘿」· FRM 代码 · 共 212 行

VERSION 5.00
Begin VB.Form FrmGroup 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Add Program Group"
   ClientHeight    =   1950
   ClientLeft      =   1140
   ClientTop       =   1515
   ClientWidth     =   4110
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   1950
   ScaleWidth      =   4110
   ShowInTaskbar   =   0   'False
   Begin VB.TextBox TmpText 
      Height          =   285
      Left            =   3120
      TabIndex        =   7
      Top             =   1560
      Visible         =   0   'False
      Width           =   585
   End
   Begin VB.DirListBox DirList 
      Height          =   315
      Left            =   2355
      TabIndex        =   6
      Top             =   1605
      Visible         =   0   'False
      Width           =   1260
   End
   Begin VB.CommandButton NoClick 
      Caption         =   "No"
      Height          =   345
      Left            =   2340
      TabIndex        =   5
      Top             =   1185
      Width           =   1290
   End
   Begin VB.CommandButton YesClick 
      Caption         =   "Yes"
      Default         =   -1  'True
      Height          =   345
      Left            =   495
      TabIndex        =   4
      Top             =   1170
      Width           =   1290
   End
   Begin VB.CheckBox NoShowAgain 
      Caption         =   "Do Not Show This Again"
      Height          =   285
      Left            =   30
      TabIndex        =   1
      Top             =   1635
      Width           =   2145
   End
   Begin VB.Label Label2 
      Alignment       =   2  'Center
      Caption         =   "VB Pacman"
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   24
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   525
      Left            =   0
      TabIndex        =   3
      Top             =   -45
      Width           =   4125
   End
   Begin VB.Label Label1 
      Alignment       =   2  'Center
      Caption         =   "     There Is No Program Group For VB Pacman.     Do You Want To Create A New Group?"
      Height          =   510
      Left            =   150
      TabIndex        =   2
      Top             =   585
      Width           =   3795
   End
   Begin VB.Label LinkObject 
      Height          =   375
      Left            =   2415
      TabIndex        =   0
      Top             =   1665
      Visible         =   0   'False
      Width           =   315
   End
End
Attribute VB_Name = "FrmGroup"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
'the name of the folder in the start menu to be created
Const AppFolderName As String = "VB Pacman"
' get the current user name
Public Property Get GetUsrName() As String
   Dim nBuff As String * 255 ' set the buffer
   Dim nSize As Long 'holds the max name size
   nSize = 100 'set the max name size
   Call GetUserName(nBuff, nSize)
   TmpText.Text = Trim(nBuff) 'this ensures that only valid characters are in the name (as the rest of nBuff is filled with garbage)
   GetUsrName = TmpText.Text 'return the username
   nBuff = vbNullString 'reset valuse
   nSize = 0 'reset value
End Property
' get the current windows directory
Public Property Get GetWinDir() As Variant
 'this works the same as the above sub
   Dim nBuff As String * 255
   Dim nSize As Long
   nSize = 100
   Call GetWindowsDirectory(nBuff, nSize)
   TmpText.Text = Trim(nBuff)
   GetWinDir = TmpText.Text
   nBuff = vbNullString
   nSize = 0
 End Property
'created the group in the start menu
Public Sub CreateGroup(FolderName As String, AppTitle As String, CmdLine As String)
 On Error Resume Next
    LinkObject.LinkTopic = "ProgMan|Progman"
    LinkObject.LinkMode = 2
    Pause
    LinkObject.LinkTimeout = 100
    LinkObject.LinkExecute "[CreateGroup(" & FolderName & ")]"
    LinkObject.LinkExecute "[AddItem(" & CmdLine & Chr(44) & AppTitle & Chr(44) & ",,)]"
    Pause
    LinkObject.LinkTimeout = 50
    LinkObject.LinkMode = 0
End Sub
'check if the group is already there
Public Function CheckForAppGroup(FolderName As String) As Boolean
 On Error Resume Next
 If GetUsrName = "" Then ' check in the dir "[windows]\start menu\programs"
    DirList.Path = GetWinDir & "\start menu\programs\" & FolderName
    If DirList.Path = GetWinDir & "\start menu\programs\" & FolderName Then
        CheckForAppGroup = True 'group found
        Exit Function
    Else
        CheckForAppGroup = False 'group not found
        Exit Function
    End If
 Else 'the computer has multi-users, chech in thier profiles for individual start menus
      ' check in "[windows]\profiles\[username]\start menu\programs"
    DirList.Path = GetWinDir & "\profiles\" & GetUsrName & "\start menu\programs\" & FolderName
    If DirList.Path = GetWinDir & "\profiles\" & GetUsrName & "\start menu\programs\" & FolderName Then
        CheckForAppGroup = True 'group found
        Exit Function
    Else
         ' group not found, check the standard dir...
         ' check in the dir "[windows]\start menu\programs"
        DirList.Path = GetWinDir & "\start menu\programs\" & FolderName
        If DirList.Path = GetWinDir & "\start menu\programs\" & FolderName Then
            CheckForAppGroup = True  'found
            Exit Function
        Else
            CheckForAppGroup = False 'not found
            Exit Function
        End If
    End If
 End If
End Function
Private Sub Form_Load()
 Dim Ans As String
 If Command() <> "" Then 'if cmd params are given, load the form anyway
    SaveSetting App.Title, "Settings", "ShowGroup", "0"
    Exit Sub
 End If
 If CheckForAppGroup(AppFolderName) = True Then Unload Me 'see if there is already an app group
 'see if the do not show this checkbox has been ticked
 Ans = GetSetting(App.Title, "Settings", "ShowGroup", "0")
 If Val(Ans) = 1 Then
    Unload Me
    End
 Else
    Me.Show
 End If
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
 On Error Resume Next
 'if the "do not show this" checkbox has been ticked, save the setting
 If NoShowAgain.Value = 1 Then
    SaveSetting App.Title, "Settings", "ShowGroup", "1"
 End If
 Me.Hide
 Load MainFrm
End Sub
Private Sub YesClick_Click()
 'create the groups
 CreateGroup AppFolderName, "VB Pacman", App.Path & "\" & App.EXEName & ".exe"
 CreateGroup AppFolderName, "Level Editor", App.Path & "\" & "LevelEdit" & ".exe"
 Unload Me
End Sub
Private Sub NoClick_Click()
 'exit
 Unload Me
End Sub
Public Sub Pause()
 'is used to give time for linking
 Dim I As Integer
 For I = 0 To 10
    DoEvents
 Next I
End Sub