bbsriver |
2007-07-10 06:41 |
这部分代码用于自动生成每种特权的可作用对象列表。代码设计是:
天神输入每个玩家的“行动”之后,程序自动判断这个行动可以作用的对象,并生成下拉框列表供天神选择,或者自动填充。 程序将自动检查每个玩家的生死状态,将死者排除在可作用对象之外。 使用“瞄准狙击”特权后,程序将弹出对话框,要求输入瞄准的牌的顺位,并自动判断这张牌是不是底牌,有没有没丢掉。如果不符合规则将报错。 使用“变形”特权后,程序将自动列出所有可以变成的牌型。排除玩家在游戏开始时已经持有的牌,(还应该排除已经变过的牌,这部分代码到第一天的模块中再加入)。
法医特权的对象是每夜的牺牲者,特赦特权的对象每天的被处决者。因为牺牲者计算模块和被处决者计算模块还没有写,这两部分暂缺。
另外优化了前几部分代码,改进了循环的效率。 每多写一点,对VBA的认识就深一点。
Private Sub Worksheet_Change(ByVal Target As Range)
'第四部分:如果玩家使用了特权,自动设定该特权对应的作用对象下拉框选项 '如果天神在“行动”当中输入了特权,则 If Target.Column = 10 Or Target.Column = 13 Or Target.Column = 16 Or Target.Column = 19 Then If Target.Count = 1 Then Select Case Target.Value '如果删除了某次行动,则清除对应的“作用对象”单元格 Case "" Target.Offset(0, 2) = "" Target.Offset(0, 2).Validation.Delete '列出瞄准狙击特权的作用对象:手上至少还有两张牌的玩家 Case "瞄准狙击" Call ShootPrivilege(Target) '直接写入圣人、防弹衣、狼毒特权的作用对象:使用者自己 Case "圣人", "防弹衣", "狼毒" Call Myself(Target) '列出禁锢和纵火犯特权的作用对象:除了自己以外其他还活着的玩家 Case "禁锢", "纵火犯" Call AllExceptMe(Target) '直接写入反狙击特权的作用对象:全体玩家 Case "反狙击" Call AllPlayers(Target) Case "特赦" Case "法医" '列出变形特权的作用对象:自己没拿到的任一特权牌牌型 Case "变形" Call Transform(Target) '列出一般特权作用对象:全体还活着的玩家 Case Else Call GenlPrivileges(Target) End Select End If '如果一次删除多个单元格的内容,则把对应的作用对象都清零 If Target.Count > 1 Then Target.Offset(0, 2).Value = "" Target.Offset(0, 2).Validation.Delete End If End If '第四部分之二:要求天神手工输入瞄准狙击哪张牌 '如果天神选择了“瞄准狙击”特权的作用对象,且只改动了一个单元格,而且不是删除单元格中的内容,则 If Target.Column = 12 Or Target.Column = 15 Or Target.Column = 18 Or Target.Column = 21 Then If Target.Count = 1 Then If Target.Offset(0, -2).Value = "瞄准狙击" And Target.Value <> "" Then '声明变量WhichCard,记录被瞄准的牌的倒数序号 Dim WhichCard As Integer '要求手工输入被瞄准的牌的倒数序号 WhichCard = Application.InputBox("要瞄准" & Target.Value & "的倒数第几张牌?" + _ " (例如:要瞄准狙击倒数第二张牌就输入“2”)", Title:="指定要瞄准的牌", Type:=1) '将序号写到瞄准狙击可作用对象列表区域的末尾 Worksheets("日程").Cells(Target.Row, 158).Value = WhichCard
'声明变量AimPlayer,调用WhichPlayer函数记录被瞄准的玩家的代号 Dim AimPlayer As Integer AimPlayer = WhichPlayer(Target.Value) '声明变量AimCards,到“变量2”表格中检查这张牌是否被丢掉 Dim AimCards As Integer AimCard = Worksheets("变量2").Cells(AimPlayer + 1, WhichCard + 1).Value '如果瞄准的是底牌,报错并要求重新输入 If WhichCard = 1 Then aaa = MsgBox("不能瞄准狙击底牌!请重新选择目标!", Buttons:=vbCritical) Target.Value = "" End If '如果瞄准的是已经被丢掉的牌,报错并要求重新输入 If AimCard <> 1 And WhichCard <= 5 And WhichCard > 1 Then aaa = MsgBox(Target.Value & "的倒数第" & CStr(WhichCard) & "张牌已经被丢掉了。不能瞄准被丢掉的牌!请重新选择目标!", Buttons:=vbCritical) Target.Value = "'" End If '如果瞄准的是不存在的牌,报错并要求重新输入 If WhichCard > 5 Then aaa = MsgBox("每个玩家最多只有5张牌。倒数第" & CStr(WhichCard) & "张牌不存在!请重新选择目标!", Buttons:=vbCritical) Target.Value = "'" End If End If End If End If End Sub
Option Explicit Sub GenlPrivileges(Target As Range)
'清空一般特权可作用对象列表区域以准备写入 Dim d As Integer For d = 151 To 157 Worksheets("日程").Cells(Target.Row, d).Select Selection.Clear Next d '在“变量2”表格中循环检查7位玩家的底牌是否还在(在就表示这个玩家还活着) Dim genl As Integer For genl = 2 To 8 '声明变量LivePlayer,记录玩家的名字 Dim LivePlayer As String LivePlayer = Worksheets("变量2").Cells(genl, 1).Value If Worksheets("变量2").Cells(genl, 2).Value = 1 Then '循环查找一般特权可作用对象列表区域的第一个空白单元格 Dim PrivilegesCol As Integer PrivilegesCol = 151 Do While Worksheets("日程").Cells(Target.Row, PrivilegesCol).Value <> "" PrivilegesCol = PrivilegesCol + 1 Loop '将玩家的名字写到第一个空白单元格中 Worksheets("日程").Cells(Target.Row, PrivilegesCol).Value = LivePlayer End If Next genl '调用RangeAddress函数,生成记录一般特权可作用对象列表区域的A1格式地址 Dim privilegeAim As String privilegeAim = RangeAddress(Target.Row, 151, Target.Row, 157) '指定“作用对象”单元格的下拉框列表地址 With Target.Offset(0, 2).Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="=" & privilegeAim .IgnoreBlank = True .InCellDropdown = True .IMEMode = xlIMEModeNoControl .ShowInput = True .ShowError = True End With '清空并选中“作用对象”单元格,以供天神选择新的作用对象 Target.Offset(0, 2).Value = "" Target.Offset(0, 2).Select
End Sub
Sub ShootPrivilege(Target As Range)
'清空瞄准狙击可作用对象列表区域以准备写入 Dim s As Integer For s = 161 To 167 Worksheets("日程").Cells(Target.Row, s).Select Selection.Clear Next s '在“变量2”表格中循环检查7位玩家的倒数第二张牌是否还在(瞄准狙击不能打底牌) Dim shot As Integer For shot = 2 To 8 '声明变量ShotPlayer,记录玩家的名字 Dim ShotPlayer As String ShotPlayer = Worksheets("变量2").Cells(shot, 1).Value If Worksheets("变量2").Cells(shot, 3).Value = 1 Then '循环查找瞄准狙击可作用对象列表区域的第一个空白单元格 Dim PrivilegesCol As Integer PrivilegesCol = 161 Do While Worksheets("日程").Cells(Target.Row, PrivilegesCol).Value <> "" PrivilegesCol = PrivilegesCol + 1 Loop '将玩家的名字写到第一个空白单元格中 Worksheets("日程").Cells(Target.Row, PrivilegesCol).Value = ShotPlayer End If Next shot '调用RangeAddress函数,生成记录瞄准狙击特权可作用对象列表区域的A1格式地址 Dim privilegeAim As String privilegeAim = RangeAddress(Target.Row, 161, Target.Row, 167) '指定“作用对象”单元格的下拉框列表地址 With Target.Offset(0, 2).Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="=" & privilegeAim .IgnoreBlank = True .InCellDropdown = True .IMEMode = xlIMEModeNoControl .ShowInput = True .ShowError = True End With '清空并选中“作用对象”单元格,以供天神选择新的作用对象 Target.Offset(0, 2).Value = "" Target.Offset(0, 2).Select End Sub
Sub Myself(Target As Range) '将行使特权者本人写入“作用对象”单元格(用于圣人、防弹衣、狼毒特权) Dim privilegeAim As String privilegeAim = Worksheets("日程").Cells(Target.Row, 2).Value Target.Offset(0, 2).Value = privilegeAim Target.Offset(0, 2).Validation.Delete End Sub
Sub AllExceptMe(Target As Range)
'清空禁锢特权可作用对象列表区域以准备写入(也用于纵火犯特权) Dim f As Integer For f = 171 To 176 Worksheets("日程").Cells(Target.Row, f).Select Selection.Clear Next f '在“变量2”表格中循环检查7位玩家的底牌是否还在(在就表示这个玩家还活着) Dim forb As Integer For forb = 2 To 8 '声明变量LivePlayer,记录玩家的名字 Dim LivePlayer As String LivePlayer = Worksheets("变量2").Cells(forb, 1).Value '循环检查该玩家的底牌是否还在,并把自己排除在外 If Worksheets("变量2").Cells(forb, 2).Value = 1 And LivePlayer <> Worksheets("日程").Cells(Target.Row, 2).Value Then '循环查找一般特权可作用对象列表区域的第一个空白单元格 Dim PrivilegesCol As Integer PrivilegesCol = 171 Do While Worksheets("日程").Cells(Target.Row, PrivilegesCol).Value <> "" PrivilegesCol = PrivilegesCol + 1 Loop '将玩家的名字写到第一个空白单元格中 Worksheets("日程").Cells(Target.Row, PrivilegesCol).Value = LivePlayer End If Next forb '调用RangeAddress函数,生成记录禁锢特权可作用对象列表区域的A1格式地址 Dim privilegeAim As String privilegeAim = RangeAddress(Target.Row, 171, Target.Row, 176) '指定“作用对象”单元格的下拉框列表地址 With Target.Offset(0, 2).Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="=" & privilegeAim .IgnoreBlank = True .InCellDropdown = True .IMEMode = xlIMEModeNoControl .ShowInput = True .ShowError = True End With '清空并选中“作用对象”单元格,以供天神选择新的作用对象 Target.Offset(0, 2).Value = "" Target.Offset(0, 2).Select
End Sub
Sub Transform(Target As Range)
'清空变形特权可作用对象列表区域以准备写入 Dim d As Integer For d = 201 To 209 Worksheets("日程").Cells(Target.Row, d).Select Selection.Clear Next d '在“常量”表格中循环检查11种牌型 Dim trans As Integer For trans = 2 To 12 '声明变量CardName,记录牌型的名字 Dim CardName As String CardName = Worksheets("常量").Cells(trans, 1).Value '声明变量PlayerNo以确定该玩家的代号 Dim PlayerNo As Integer PlayerNo = WhichPlayer(Worksheets("日程").Cells(Target.Row, 2).Value) '声明变量DoMeHave,记录是否该玩家是否已持有这张牌(默认为没有) Dim DoMeHave As Integer DoMeHave = 0 '循环检查该玩家自己手中的5张牌是否有和CardName重复的牌型 Dim mc As Integer For mc = 4 To 8 If CardName = Worksheets("日程").Cells(PlayerNo + 29, mc).Value Then DoMeHave = 1 Exit For End If Next mc '如果没有重复,将牌型名称写入变形特权可作用对象列表区域 If DoMeHave = 0 Then '循环查找变形特权可作用对象列表区域的第一个空白单元格 Dim PrivilegesCol As Integer PrivilegesCol = 201 Do While Worksheets("日程").Cells(Target.Row, PrivilegesCol).Value <> "" PrivilegesCol = PrivilegesCol + 1 Loop '将牌型写到第一个空白单元格中 Worksheets("日程").Cells(Target.Row, PrivilegesCol).Value = CardName End If Next trans '调用RangeAddress函数,生成记录变形特权可作用对象列表区域的A1格式地址 Dim privilegeAim As String privilegeAim = RangeAddress(Target.Row, 201, Target.Row, 209) '指定“作用对象”单元格的下拉框列表地址 With Target.Offset(0, 2).Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="=" & privilegeAim .IgnoreBlank = True .InCellDropdown = True .IMEMode = xlIMEModeNoControl .ShowInput = True .ShowError = True End With '清空并选中“作用对象”单元格,以供天神选择新的作用对象 Target.Offset(0, 2).Value = "" Target.Offset(0, 2).Select
End Sub
Sub AllPlayers(Target As Range) '将"全体玩家"写入“作用对象”单元格(用于反狙击特权) Dim privilegeAim As String privilegeAim = "全体玩家" Target.Offset(0, 2).Value = privilegeAim Target.Offset(0, 2).Validation.Delete
End Sub
Function Address(r As Integer, c As Integer) As String 'Address函数,通过调用“函数”表格中的Excel函数,将Cell地址格式转化为A1地址格式 '输入行的数字 Worksheets("函数").Range("B2").Value = r '输入列的数字 Worksheets("函数").Range("D2").Value = c Address = Worksheets("函数").Range("F2").Value End Function
Function RangeAddress(StartRow As Integer, StartCol As Integer, LastRow As Integer, LastCol As Integer) As String Dim Start, Last As String Start = Address(StartRow, StartCol) Last = Address(LastRow, LastCol) RangeAddress = Start & ":" & Last End Function
|
|