frmgame.frm

游戏菜单 的例子

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form FrmGame 
   BackColor       =   &H00000000&
   Caption         =   "游戏大本营2.0"
   ClientHeight    =   7110
   ClientLeft      =   285
   ClientTop       =   120
   ClientWidth     =   10350
   ForeColor       =   &H00404040&
   Icon            =   "FrmGame.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   7110
   ScaleWidth      =   10350
   Begin VB.CommandButton CmdEdit 
      Caption         =   "CmdEdit"
      Height          =   375
      Left            =   4560
      TabIndex        =   2
      Top             =   6600
      Width           =   1215
   End
   Begin MSComDlg.CommonDialog CDlg 
      Left            =   4920
      Top             =   3360
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.PictureBox Picture1 
      BackColor       =   &H00000000&
      BorderStyle     =   0  'None
      Height          =   2000
      Left            =   1200
      Picture         =   "FrmGame.frx":0442
      ScaleHeight     =   1995
      ScaleWidth      =   7995
      TabIndex        =   3
      TabStop         =   0   'False
      Top             =   -300
      Width           =   7995
   End
   Begin VB.CommandButton Cmd 
      Caption         =   "Command1"
      Height          =   375
      Index           =   0
      Left            =   840
      TabIndex        =   4
      Top             =   2040
      Width           =   1455
   End
   Begin VB.CommandButton CmdQuit 
      Cancel          =   -1  'True
      Caption         =   "Cmdquit"
      Height          =   375
      Left            =   6045
      TabIndex        =   0
      TabStop         =   0   'False
      Top             =   6600
      Width           =   1215
   End
   Begin VB.Label LabSum 
      Alignment       =   2  'Center
      BackColor       =   &H00C0C0C0&
      BackStyle       =   0  'Transparent
      BorderStyle     =   1  'Fixed Single
      Caption         =   "Label1"
      ForeColor       =   &H0000FF00&
      Height          =   4575
      Index           =   0
      Left            =   600
      TabIndex        =   1
      Top             =   1800
      Width           =   1935
   End
End
Attribute VB_Name = "FrmGame"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim GameName(99) As String  '游戏名称
Dim RunGameName As String   '文件名(不带路径)
Dim CmdName(99) As String   'Command名称
Dim GameType(19) As String  '游戏类别
Dim GameFile(99) As String  '文件名(带路径)
Dim GameSum(9) As Integer   '每个类别的游戏数目
Dim JianGe(9) As Integer    '每一列Command控件之间的纵向间隔
Dim TopJianGe As Integer    'Label控件与第一个Command控件的纵向间隔
Dim JianGeX As Integer      'Label控件与Command控件的横向间隔
Dim CmdCount As Integer     'Command控件的总数目
Dim SumGameType As Integer  '游戏类别的总数目
Dim CmdY As Integer         '控件的总数目
Dim I As Integer            '供所有For...Next循环使用的变量

Const strGamehome = "《游戏大本营》"
Const strVer = "2003  2.0"
Const strQuit = "退 出(&Q)"
Const strTitle = "提示"
Const strTitleErr = "提示错误"
Const strFileError1 = "配置文件错误，请先检查文件 Gamehome.ini是否"
Const strWrite = "按规定格式书写，然后再运行"
Const strFileError2 = "文件路径不存在，请检查文件 Gamehome.ini。"
Const strNoFindFile = "未找到配置文件 Gamehome.ini，"
Const strHand = "请手工"
Const strProRun = "该程序已被运行！"
Const strNoRun = "不能运行！"
Const strFindFile = "查找配置文件Gamehome.ini"
Const strFilter1 = "配置文件"
Const strFilter2 = "所有文件"
Private Sub CountJianGe()
'************************
'以下这一段代码计算command控件的纵向间隔
Dim K As Integer
For I = 0 To CmdY
    K = (LabSum(0).Height - _
    ((Cmd(0).Height) * (GameSum(I))) - TopJianGe) / (GameSum(I) + 1)
    If K > 0 Then
        JianGe(I) = K
    Else
        JianGe(I) = 0
    End If
Next
End Sub


Private Sub Loadgame()
Dim X
'调游戏程序
X = Shell(RunGameName, 1)
End Sub

Private Sub CmdEdit_Click()
Ini.Show
Me.Hide
End Sub

Private Sub CmdQuit_Click()
End
End Sub

Private Sub Cmd_Click(Index As Integer)
'将路径从文件名(带路径)中分离出来
Dim TmpFile As String
Dim DriveName As String
Dim RoadName As String
Dim FileLength As Integer
Dim L As Integer
On Error GoTo RunError
L = 0
TmpFile = GameFile(Index)
 GetAttr (TmpFile)
Do While Not Left$(Right$(TmpFile, L), 1) = "\"
   L = L + 1
Loop
'获得驱动器号(盘符)
DriveName = UCase$(Left$(TmpFile, 2))
'获得路径
FileLength = Len(TmpFile) - L

RoadName = UCase$(Left$(TmpFile, (FileLength)))
'获得单独的文件名
RunGameName = UCase$(Right$(TmpFile, (L - 1)))
'改变驱动器名
ChDrive DriveName
'改变路径
ChDir RoadName

Loadgame
Exit Sub
'当运行程序出错时
RunError:
MsgBox Chr(34) & CmdName(Index) & _
Chr(34) & _
strNoRun & _
strFileError2 & _
Chr(13) & Chr(10) _
 , vbOKOnly & vbExclamation, strTitleErr
End Sub


Private Sub GetGameName()
'******************************
'将名称与文件名(带路径)分离
Dim T As Integer
For I = 0 To CmdCount - 1
    '计算"," 在字符串中的位置
    T = InStr(GameName(I), ",")
    '","左边的即是游戏名称
    CmdName(I) = Left$(GameName(I), T - 1)
    '","右边的即是文件名
    GameFile(I) = Right$(GameName(I), (Len(GameName(I)) - T))
Next

End Sub
Private Sub CmdWhere()
'用控件数组设置动态控件的位置


Dim U As Integer
Dim V As Integer
Dim K As Integer
Dim JianGeLab As Integer

Cmd(0).Caption = CmdName(0)
LabSum(0).Caption = GameType(0)

'调入Command控件并分别赋予名称（设置Caption属性）
For I = 1 To CmdCount - 1
    Load Cmd(I)
    Cmd(I).Caption = CmdName(I)
    '使调入的每个Command控件可见
    Cmd(I).Visible = True
Next I

'计算Label控件的横向间隔
JianGeLab = (Width - (LabSum(0).Width * (CmdY + 1))) \ (CmdY + 2)
LabSum(0).Left = JianGeLab

'调入Label控件并分别赋予名称（设置Caption属性）
For I = 1 To CmdY
    Load LabSum(I)
    LabSum(I).Caption = GameType(I)
    LabSum(I).Left = LabSum(I - 1).Left + LabSum(0).Width + JianGeLab
    LabSum(I).Visible = True
Next


I = 0: U = 0
K = 0: V = 0
'用二重循环改变控件的位置
For I = 0 To CmdY
    '先求出每一列第一个控件的位置
    Cmd(U).Top = Cmd(0).Top
    Cmd(U).Left = LabSum(I).Left + JianGeX
    V = V + GameSum(I)
    For K = U + 1 To V - 1
    '每一列从第二个控件开始
    'X坐标与第一个控件相同
    'Y坐标相隔一定距离
        Cmd(K).Left = Cmd(U).Left
        Cmd(K).Top = Cmd(K - 1).Top + Cmd(K - 1).Height + JianGe(I)
    Next
    U = U + GameSum(I)
Next
End Sub
Private Sub Startset()

Dim J As Integer
Dim K As Integer
Dim intGameName As Integer
Dim NullOffset%
Dim NullOffset2%
Dim SumGameType As Integer
Dim strJ As String
I = 0: J = 0
On Error Resume Next
'获取节点值
rtn = String$(128, 0)
rtn2 = String$(128, 0)
Success = GetPrivateProfileStringSections(0, 0, "", rtn, 127, Filename)
    

Do
NullOffset% = InStr(rtn, Chr$(0))
If NullOffset% > 1 Then
   GameType(I) = rtn
      rtn = Mid$(rtn, NullOffset% + 1)
   
   I = I + 1
End If
Loop While NullOffset% > 1
SumGameType = I - 1

K = 0
strJ = ""
Do While Not K > SumGameType
   J = 0

   Do
      strJ = Str(J)

    rtn2 = GetPrivateStringValue(GameType(K), strJ, Filename)
    rtn2 = RTrim$(LTrim$(rtn2))
    NullOffset2% = Asc(Left$(rtn2, 1))
        If NullOffset2% <> 0 Then
            GameName(Val(intGameName)) = rtn2
            J = J + 1
            intGameName = intGameName + 1
        End If
    Loop While NullOffset2% <> 0
        GameSum(K) = J
        K = K + 1
        
Loop
SumGameType = intGameName - 1

CmdY = K - 1
For I = 0 To CmdY
CmdCount = CmdCount + GameSum(I)
Next

End Sub



Private Sub Form_Activate()
Cmd(0).SetFocus
End Sub

Private Sub Form_Load()
On Error GoTo LabError
Dim tmpAttr As Integer
Dim startFileName As String
'默认的配置文件名
startFileName = "gamehome.ini"
Me.Caption = strGamehome & strVer
CmdQuit.Caption = strQuit
'CmdEdit.Visible = False
CmdEdit.Caption = "编辑(&E)"
Me.Width = 11565
'窗体居中
Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2
'图片框居中
Picture1.Left = (Width - Picture1.Width) / 2
JianGeX = (LabSum(0).Width - Cmd(0).Width) / 2
TopJianGe = Cmd(0).Top - LabSum(0).Top
Filename = App.Path & "\" & startFileName

LoadFile:
    tmpAttr = GetAttr(Filename)
    Startset
    GetGameName
    CountJianGe
    CmdWhere
Exit Sub

LabError:

Select Case Err.Number
    '当文件未找到时
    Case 53
    
        MsgBox strNoFindFile & _
        Chr(13) & Chr(10) & _
        strHand & _
        strFindFile, vbOKOnly & vbExclamation, strTitleErr
        With CDlg
            '.CancelError = True
            .DialogTitle = strFindFile
            
            .Filter = strFilter1 & "|*.ini|" & _
            strFilter2 & "|*.*"
            .FilterIndex = 0
            .Action = 1
            If Len(.Filename) > 0 Then
                Filename = .Filename
                GoTo LoadFile
                Exit Sub
            Else
                MsgBox strGamehome & strNoRun, 48, strTitleErr
                End
            End If
        End With
    '当调用过程出错时
    Case 5
    MsgBox strFileError1 & _
    Chr(13) & Chr(10) & _
    strWrite & _
    strGamehome, vbOKOnly & vbExclamation, strTitleErr
End Select
End
End Sub


Private Sub Form_Initialize()
Dim Msg As String
If App.PrevInstance Then
Msg = MsgBox(strProRun, 48, strGamehome & strTitle)
End
End If
End Sub