MAC能用的PPT抽奖宏

Option Explicit

' ============================================================
'  ★ 抽奖参数配置区 ★
' ============================================================
Public Const THIRD_COUNT  As Long = 6
Public Const SECOND_COUNT As Long = 3
Public Const FIRST_COUNT  As Long = 1
Public Const SPIN_MS      As Long = 2000
' ============================================================

Dim gPool() As String
Dim gRow() As Long
Dim gUsed() As Boolean
Dim gResult() As String
Dim gTotal As Long
Dim gCount As Long
Dim gThirdDrawn As Long, gSecondDrawn As Long, gFirstDrawn As Long
Dim gBusy As Boolean
Dim gRolling As Boolean
Dim gLevel As Long

Dim gXl As Object, gWb As Object, gWs As Object
Dim gOwnExcel As Boolean
Dim gXlsxPath As String

Dim gCsvPath As String

Function GetFolder() As String
    On Error Resume Next
    Dim p As Object
    Set p = ActivePresentation
    If Not p Is Nothing Then
        If p.Path <> "" Then GetFolder = p.Path: Exit Function
    End If
    Set p = Application.Presentations(1)
    GetFolder = p.Path
End Function

Function IsMac() As Boolean
    On Error Resume Next
    IsMac = (InStr(1, Application.OperatingSystem, "Mac", 1) > 0)
    On Error GoTo 0
End Function

Function XlsxPath() As String
    Dim sep As String
    If IsMac() Then sep = Chr(47) Else sep = Chr(92)
    XlsxPath = GetFolder() & sep & "qd.xlsx"
End Function

Function CsvPath() As String
    Dim sep As String
    If IsMac() Then sep = Chr(47) Else sep = Chr(92)
    CsvPath = GetFolder() & sep & "qd.csv"
End Function

Function ThisPres() As Object
    On Error Resume Next
    Dim p As Object
    Set p = ActivePresentation
    If Not p Is Nothing Then Set ThisPres = p: Exit Function
    Set ThisPres = Application.Presentations(1)
End Function

Sub LoadCsv()
    Dim f As Integer, ln As String, parts, n As Long, k As Long
    Dim nums() As String, val
    On Error Resume Next
    If gCsvPath = "" Then gCsvPath = CsvPath()
    GrantAccessToMultipleFiles Array(gCsvPath)
    f = FreeFile
    Open gCsvPath For Input As #f
    n = 0
    ReDim nums(0) As String
    Do While Not EOF(f)
        Line Input #f, ln
        ln = Trim(ln)
        If ln <> "" Then
            If InStr(1, ln, "号码") > 0 And InStr(1, ln, "中奖结果") > 0 Then GoTo nextline
            parts = Split(ln, ",")
            If UBound(parts) >= 0 Then
                val = Trim(parts(0))
                If IsNumeric(val) And val <> "" Then
                    ReDim Preserve nums(n) As String
                    nums(n) = CStr(val)
                    n = n + 1
                End If
            End If
        End If
nextline:
    Loop
    Close #f
    gTotal = n
    gCount = n
    If n > 0 Then
        ReDim gPool(n - 1) As String
        ReDim gRow(n - 1) As Long
        ReDim gUsed(n - 1) As Boolean
        ReDim gResult(n - 1) As String
        For k = 0 To n - 1
            gPool(k) = nums(k)
            gRow(k) = k + 2
            gUsed(k) = False
            gResult(k) = ""
        Next k
    End If
    On Error GoTo 0
End Sub

Sub SaveCsv()
    Dim f As Integer, i As Long
    On Error Resume Next
    If gCsvPath = "" Then gCsvPath = CsvPath()
    GrantAccessToMultipleFiles Array(gCsvPath)
    f = FreeFile
    Open gCsvPath For Output As #f
    Print #f, "号码,中奖结果"
    For i = 0 To gTotal - 1
        Print #f, gPool(i) & "," & gResult(i)
    Next i
    Close #f
    On Error GoTo 0
End Sub

Sub InitPool()
    If gTotal > 0 Then Exit Sub
    #If Mac Then
        gCsvPath = CsvPath()
        LoadCsv
        If gCount <= 0 Then
            MsgBox "未能读取 qd.csv：文件不存在或第1列没有数字。" & vbCrLf & "请在 Mac 上使用 qd.csv（不要用 .xlsx），并与本PPT放在同一文件夹。" & vbCrLf & "尝试路径：" & gCsvPath, vbExclamation, "错误"
            Exit Sub
        End If
    #Else
        Dim fPath As String, lastRow As Long, i As Long, k As Long, v
        fPath = XlsxPath()
        If gXlsxPath <> "" Then fPath = gXlsxPath
        On Error Resume Next
        Set gXl = GetObject(, "Excel.Application")
        If gXl Is Nothing Then
            Set gXl = CreateObject("Excel.Application")
            gOwnExcel = True
        Else
            gOwnExcel = False
        End If
        If gXl Is Nothing Then
            MsgBox "未能读取 qd.xlsx：无法启动 Excel，请确认已安装 Excel。", vbExclamation, "错误"
            Exit Sub
        End If
        Set gWb = gXl.Workbooks("qd.xlsx")
        If gWb Is Nothing Then Set gWb = gXl.Workbooks.Open(fPath)
        If gWb Is Nothing Then
            MsgBox "未能读取 qd.xlsx：文件无法打开（可能被占用/未授权/已损坏）。" & vbCrLf & "尝试路径：" & fPath, vbExclamation, "错误"
            Exit Sub
        End If
        Set gWs = gWb.Worksheets(1)
        lastRow = gWs.Cells(gWs.Rows.Count, 1).End(-4162).Row
        k = 0
        ReDim gPool(0) As String
        ReDim gRow(0) As Long
        ReDim gUsed(0) As Boolean
        ReDim gResult(0) As String
        For i = 2 To lastRow
            v = gWs.Cells(i, 1).Value
            If IsNumeric(v) And v <> "" Then
                ReDim Preserve gPool(k) As String
                ReDim Preserve gRow(k) As Long
                ReDim Preserve gUsed(k) As Boolean
                ReDim Preserve gResult(k) As String
                gPool(k) = CStr(v)
                gRow(k) = i
                gUsed(k) = False
                gResult(k) = ""
                k = k + 1
            End If
        Next i
        gTotal = k
        gCount = k
        If gCount <= 0 Then
            MsgBox "未能读取 qd.xlsx：A 列（第2行起）没有找到数字。" & vbCrLf & "尝试路径：" & fPath, vbExclamation, "错误"
            Exit Sub
        End If
        On Error GoTo 0
    #End If
End Sub

Function GetOne(ByRef outIdx As Long) As String
    Dim avail() As Long, n As Long, j As Long, pick As Long
    If gTotal <= 0 Then GetOne = "": outIdx = -1: Exit Function
    n = 0
    For j = 0 To gTotal - 1
        If Not gUsed(j) Then
            ReDim Preserve avail(n): avail(n) = j: n = n + 1
        End If
    Next j
    If n = 0 Then GetOne = "": outIdx = -1: Exit Function
    pick = avail(Int(Rnd * n))
    gUsed(pick) = True
    GetOne = gPool(pick)
    outIdx = pick
End Function

' 仅滚动，不抽不锁定
Sub FakeScroll(sIdx As Long)
    Dim sh As Object, r As Long
    On Error Resume Next
    Set sh = ThisPres.Slides(sIdx).Shapes("PrizeBox")
    If sh Is Nothing Then gRolling = False: Exit Sub
    Randomize
    Do While gRolling
        If gTotal > 0 Then
            r = Int(Rnd * gTotal)
            If r < 0 Then r = 0
            If r > gTotal - 1 Then r = gTotal - 1
            If Not gUsed(r) Then sh.TextFrame.TextRange.Text = gPool(r)
        End If
        DoEvents
    Loop
    On Error GoTo 0
End Sub

' 锁定当前屏幕号码作为中奖
Sub CommitWin(sIdx As Long)
    Dim sh As Object, finalVal As String, idx As Long, k As Long
    Dim label As String, drawn As Long
    On Error Resume Next
    Set sh = ThisPres.Slides(sIdx).Shapes("PrizeBox")
    finalVal = sh.TextFrame.TextRange.Text
    idx = -1
    For k = 0 To gTotal - 1
        If Not gUsed(k) And gPool(k) = finalVal Then
            idx = k: Exit For
        End If
    Next k
    If idx < 0 Then
        GetOne idx
        If idx < 0 Then Exit Sub
        finalVal = gPool(idx)
        sh.TextFrame.TextRange.Text = finalVal
    Else
        gUsed(idx) = True
    End If
    If gLevel = 1 Then label = "中三等奖": gThirdDrawn = gThirdDrawn + 1: drawn = gThirdDrawn
    If gLevel = 2 Then label = "中二等奖": gSecondDrawn = gSecondDrawn + 1: drawn = gSecondDrawn
    If gLevel = 3 Then label = "中一等奖": gFirstDrawn = gFirstDrawn + 1: drawn = gFirstDrawn
    MarkWin idx, label
    PutCounter sIdx, drawn, IIf(gLevel = 1, THIRD_COUNT, IIf(gLevel = 2, SECOND_COUNT, FIRST_COUNT))
    On Error GoTo 0
End Sub

Sub MarkWin(idx As Long, label As String)
    On Error Resume Next
    #If Mac Then
        If idx >= 0 And idx < gTotal Then gResult(idx) = label
        SaveCsv
    #Else
        If gWs Is Nothing Then Exit Sub
        gWs.Cells(gRow(idx), 2).Value = label
        gWb.Save
    #End If
    On Error GoTo 0
End Sub

Sub PutText(sIdx As Long, sName As String, txt As String)
    On Error Resume Next
    ThisPres.Slides(sIdx).Shapes(sName).TextFrame.TextRange.Text = txt
    On Error GoTo 0
End Sub

Sub PutCounter(sIdx As Long, drawn As Long, total As Long)
    On Error Resume Next
    ThisPres.Slides(sIdx).Shapes("Counter").TextFrame.TextRange.Text = "已抽 " & drawn & " / " & total
    On Error GoTo 0
End Sub

' ---------- 按钮接线：开始抽奖 = 仅假滚动；停止 = 真实锁定 ----------
Sub StartScrollThird()
    If gBusy Or gRolling Then Exit Sub
    If gThirdDrawn >= THIRD_COUNT Then MsgBox "三等奖已抽完，共 " & THIRD_COUNT & " 名。", vbInformation, "提示": Exit Sub
    If gTotal <= 0 Then InitPool
    If gTotal <= 0 Then Exit Sub
    gLevel = 1: gRolling = True: gBusy = True
    FakeScroll 1
    gBusy = False
End Sub

Sub StartScrollSecond()
    If gBusy Or gRolling Then Exit Sub
    If gSecondDrawn >= SECOND_COUNT Then MsgBox "二等奖已抽完，共 " & SECOND_COUNT & " 名。", vbInformation, "提示": Exit Sub
    If gTotal <= 0 Then InitPool
    If gTotal <= 0 Then Exit Sub
    gLevel = 2: gRolling = True: gBusy = True
    FakeScroll 2
    gBusy = False
End Sub

Sub StartScrollFirst()
    If gBusy Or gRolling Then Exit Sub
    If gFirstDrawn >= FIRST_COUNT Then MsgBox "一等奖已抽完，共 " & FIRST_COUNT & " 名。", vbInformation, "提示": Exit Sub
    If gTotal <= 0 Then InitPool
    If gTotal <= 0 Then Exit Sub
    gLevel = 3: gRolling = True: gBusy = True
    FakeScroll 3
    gBusy = False
End Sub

Sub StopThird()
    If Not gRolling Then Exit Sub
    If gLevel <> 1 Then Exit Sub
    gRolling = False
    CommitWin 1
End Sub

Sub StopSecond()
    If Not gRolling Then Exit Sub
    If gLevel <> 2 Then Exit Sub
    gRolling = False
    CommitWin 2
End Sub

Sub StopFirst()
    If Not gRolling Then Exit Sub
    If gLevel <> 3 Then Exit Sub
    gRolling = False
    CommitWin 3
End Sub

Sub ClearWins()
    #If Mac Then
        If gTotal <= 0 Then
            gCsvPath = CsvPath()
            LoadCsv
        End If
        Dim i As Long
        For i = 0 To gTotal - 1
            gUsed(i) = False
            gResult(i) = ""
        Next i
        SaveCsv
    #Else
        Dim xl As Object, wb As Object, ws As Object, lastRow As Long, j As Long
        Dim ownClear As Boolean, fp As String
        On Error Resume Next
        If Not gWb Is Nothing Then
            If gOwnExcel Then gWb.Close True
            Set gWb = Nothing
        End If
        If Not gXl Is Nothing Then
            If gOwnExcel Then gXl.Quit
            Set gXl = Nothing
        End If
        Set gWs = Nothing
        gOwnExcel = False
        gTotal = 0: gCount = 0
        fp = XlsxPath()
        If gXlsxPath <> "" Then fp = gXlsxPath
        Set xl = GetObject(, "Excel.Application")
        If xl Is Nothing Then
            Set xl = CreateObject("Excel.Application")
            ownClear = True
        Else
            ownClear = False
        End If
        Set wb = xl.Workbooks("qd.xlsx")
        If wb Is Nothing Then Set wb = xl.Workbooks.Open(fp)
        If Not wb Is Nothing Then
            Set ws = wb.Worksheets(1)
            lastRow = ws.Cells(ws.Rows.Count, 1).End(-4162).Row
            For j = 2 To lastRow
                ws.Cells(j, 2).Value = ""
            Next j
            wb.Save
        End If
        If ownClear Then
            If Not wb Is Nothing Then wb.Close False
            If Not xl Is Nothing Then xl.Quit
        End If
        Set ws = Nothing: Set wb = Nothing: Set xl = Nothing
        On Error GoTo 0
    #End If
End Sub

Sub ResetLottery()
    gRolling = False
    gBusy = False
    ClearWins
    gThirdDrawn = 0: gSecondDrawn = 0: gFirstDrawn = 0
    PutText 1, "PrizeBox", "—"
    PutText 2, "PrizeBox", "—"
    PutText 3, "PrizeBox", "—"
    PutCounter 1, 0, THIRD_COUNT
    PutCounter 2, 0, SECOND_COUNT
    PutCounter 3, 0, FIRST_COUNT
    MsgBox "已重置，可重新抽奖。", vbInformation, "提示"
End Sub