需要一个人员抽点的程序，显示的界面能够看到出场的顺序，以及能够控制出场的人员，抽点到指定的人员。

Question

需要一个人员抽点的程序，能够实现抽点到的人员是可控制的，想抽到谁就可以抽到谁。

Answer 1

使用方法，编辑names文件，每个名字1行
注意，需要抽取的人，名字后面加上一个空格
不希望抽取的人，不要加
则程序滚动的时候，所有人都参与滚动，停止的时候，有空格的才会出来

Option Explicit

Private isRunning As Boolean
Dim names() As String

Private Sub CommandButton1_Click()
    CommandButton1.Enabled = False
    Dim filecontent As String
    Open "names.txt" For Binary As #1
        filecontent = Input(LOF(1), #1)
    Close #1
    names = Split(filecontent, vbCrLf)
    Randomize
    isRunning = True
    While isRunning
        TextBox1.Text = RndName(False)
        DoEvents
    Wend
    TextBox1.Text = RndName(True)
    If TextBox1.Text = "" Then CommandButton1.Enabled = True: Exit Sub
    If Me.Application.ActivePresentation.Slides(2).Shapes(6).TextFrame.TextRange.Text <> "" Then Me.Application.ActivePresentation.Slides(2).Shapes(6).TextFrame.TextRange.Text = Me.Application.ActivePresentation.Slides(2).Shapes(6).TextFrame.TextRange.Text & ","
    Me.Application.ActivePresentation.Slides(2).Shapes(6).TextFrame.TextRange.Text = Me.Application.ActivePresentation.Slides(2).Shapes(6).TextFrame.TextRange.Text & TextBox1.Text
    CommandButton1.Enabled = True
End Sub

Private Function RndName(isSpec As Boolean) As String
    Dim cnt As Long
    cnt = 1
    Dim idx As Long
    Do
        cnt = cnt + 1
        If cnt > 99999 Then
            RndName = ""
            Exit Function
        End If
        idx = Int(Rnd * (UBound(names) - LBound(names) + 1)) + LBound(names)
        If Not IsExist(names(idx)) Then
            If isSpec Then
                If (names(idx) <> Trim(names(idx))) Then
                    RndName = Trim(names(idx))
                    Exit Do
                End If
            Else
                RndName = Trim(names(idx))
                Exit Do
            End If
        End If
    Loop
End Function

Private Function IsExist(name As String) As Boolean
    Dim arr() As String
    arr = Split(Me.Application.ActivePresentation.Slides(2).Shapes(6).TextFrame.TextRange.Text, ",")
    Dim i As Long
    For i = LBound(arr) To UBound(arr)
        If Trim(name) = Trim(arr(i)) Then
            IsExist = True
            Exit Function
        End If
    Next
    IsExist = False
End Function

Private Sub CommandButton2_Click()
    isRunning = False
End Sub

其他人如果也需要：https://download.csdn.net/download/caozhy/11311604