WARFR PPT 防盗信息收集系统使用文档
NotBad_Jqc
|
|
82
|
0
|
WARFR 专区

4438 字
|
24 分钟
本文最后更新于 41 天前，其中的信息可能已经有所发展或是发生改变。
  • 本系统提供注册、邮箱验证、登录与用户门户数据查看等功能。
  • 为保障安全，关键操作引入人机验证（图形验证码）、邮件验证码与多重反机器人机制。
  • 本系统加密方式符合国家一级等保相关规则，请放心使用。

    1.系统功能总览

    注册

    入口：访问 https://fd.nbjqc.cn/ 。

  • 填写信息：邮箱、昵称、密码与确认密码。
  • 人机验证：
    • 页面显示图形验证码，点击“刷新”按钮可更换验证码图片。
    • 在输入框填写图片中的字符（不区分大小写，统一按大写比较）。
    • 存在隐藏“蜜罐”字段，正常用户看不到；若被填写会被判定为机器人提交。
    • 从页面打开到提交至少需要等待 2 秒，过快提交会被拒绝。
  • 完成注册后：
    • 系统向你的邮箱发送“激活账号”验证邮件（24 小时有效）。
    • 邮件内有确认链接，点击即可完成邮箱验证。
    • 若未收到邮件，可检查垃圾箱或稍后重试；也可在登录页点击“重新发送验证邮件”。

邮箱验证

  • 验证入口：邮件中的“确认激活”按钮（跳转到 verify_email.php）。
  • 结果：
    • 验证成功后，登录页会显示提示“邮箱验证成功，请使用您的账号登录”。
    • 验证失败或过期：请返回登录页，使用“重新发送验证邮件”重新获取。

登录

  • 入口：访问 https://fd.nbjqc.cn 。
  • 填写信息：邮箱、密码。
  • 人机验证：
    • 与注册一致的图形验证码（可点击刷新）。
    • 隐藏蜜罐字段与最短填写时长限制（≥2 秒）同样生效。
  • 登录流程与提示：
    • 邮箱未验证：登录会被阻止，并显示“邮箱尚未验证”，点击“重新发送验证邮件”进行处理。
    • 登录成功：系统会向你的邮箱发送登录提醒（包含时间、IP 与设备信息），并跳转至用户门户。
  • 其他：
    • 可选择“记住我”；若换设备建议重新登录。
    • 退出登录可使用 user_logout.php。

用户门户与数据查看

  • 入口：登录后跳转 user_portal.php。
  • 查看数据前置验证：
    • 点击“查看”后将弹出验证码模态框。
    • 点击“发送验证码”后，系统向已绑定的邮箱发送 6 位验证码。
    • 在模态框中输入验证码并提交，验证通过后才能查看敏感数据。
  • 验证规则：
    • 验证码有效期为 5 分钟。
    • 发送频率限制为 60 秒（过于频繁会提示“稍后再试”）。
    • 验证通过后，门户的敏感数据访问权限保持 10 分钟（会话层校验），超时需重新验证。

验证码说明

  • 图形验证码（注册、登录）：
    • 字符集为 ABCDEFGHJKLMNPQRSTUVWXYZ23456789，尽量避免易混淆字符。
    • 图片含随机背景与噪点，提升自动识别难度。
    • 验证码在会话中保存 5 分钟，过期需刷新。
  • 邮件验证码（数据查看）：
    • 6 位数字，5 分钟有效。
    • 发送频率限制为 60 秒。
    • 验证通过后，门户敏感访问状态保存 10 分钟。

常见问题

  • 验证邮件收不到：
    • 检查垃圾箱或企业邮箱安全策略。
    • 稍后重试发送，或在登录页使用“重新发送验证邮件”。
    • 若系统未配置邮件服务，管理员可在服务器目录查看是否生成 mail_preview_YYYYmmdd_HHMMSS.html 调试文件。
  • 登录提示“邮箱尚未验证”：
    • 先完成邮箱验证；若链接过期，请重新发送验证邮件。
  • 人机验证失败或过期：
    • 点击刷新验证码图片，重新输入后再提交。
    • 提交过快会提示“提交过快，请稍后再试”，请等待 ≥2 秒。
  • 数据查看验证码提示“发送过于频繁”：
    • 发送间隔需 ≥ 60 秒，稍后再试。
  • 数据查看提示“验证码已过期/不正确”：
    • 重新“发送验证码”，在 5 分钟内输入正确验证码。

安全建议

  • 使用强密码（建议 12 位以上，包含大小写字母、数字与符号）。
  • 避免在公共设备上勾选“记住我”；用完及时退出登录。
  • 若收到异常登录提醒（时间或 IP 不匹配），请立即修改密码。
  • 请勿泄露或转发任何验证码或验证链接。

浏览器与设备建议

  • 推荐使用现代浏览器最新版本（Chrome、Edge、Firefox、Safari）。
  • 若验证码图片无法显示，请尝试强制刷新或关闭可能拦截图片的插件。
  • 移动端与桌面端均支持；在移动端输入验证码时可使用刷新按钮更换图片。

支持与反馈

  • 若遇到页面异常或无法完成验证，请记录提示信息并联系管理员。
  • 如需调整验证码长度、有效期或发送频率，管理员可按需进行系统配置变更。

2.API使用

PPT 端配置

PPT VBA 脚本：

  • 用于收集设备信息（计算机名、用户名、公网/内网 IP、MAC、操作系统、处理器、内存、PPT 版本、客户端时间），自动生成合规的 send_id ，并以 JSON 方式携带必要字段上传到服务器的API接口。
  • 使用晚绑定对象，不需要额外引用。
  • 请在脚本顶部填写你的 APP_ID 与 API_KEY

在 PowerPoint 中插入模块，粘贴以下代码并运行 UploadSystemInfo（上传有弹窗版）

Option Explicit
Private Const SERVER_URL As String = "https://api.fd.nbjqc.cn/"
Private Const APP_ID As String = "APP_xxx"   ' 替换为你的 APPID
Private Const API_KEY As String = "apikey_xxx"  ' 替换为你的 API Key

Private Function JsonEscape(ByVal s As String) As String
    Dim r As String
    r = s
    r = Replace(r, "\", "\\")
    r = Replace(r, """", "\""")
    r = Replace(r, vbCrLf, "\n")
    r = Replace(r, vbCr, "\n")
    r = Replace(r, vbLf, "\n")
    JsonEscape = r
End Function

Private Function GetPublicIP() As String
    On Error Resume Next
    Dim http As Object
    Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    http.setTimeouts 3000, 3000, 3000, 3000
    http.Open "GET", "https://api.ipify.org?format=text", False
    http.Send
    If http.Status = 200 Then
        GetPublicIP = Trim(http.responseText)
    Else
        GetPublicIP = ""
    End If
End Function

Private Function GetLocalIP() As String
    On Error Resume Next
    Dim ip As String, svc As Object, col As Object, itm As Object, a As Variant
    Set svc = GetObject("winmgmts:")
    Set col = svc.ExecQuery("SELECT IPAddress FROM Win32_NetworkAdapterConfiguration WHERE IPEnabled = True")
    For Each itm In col
        If Not IsNull(itm.IPAddress) Then
            For Each a In itm.IPAddress
                If InStr(1, a, ".") > 0 Then ip = a: Exit For
            Next a
        End If
        If Len(ip) > 0 Then Exit For
    Next itm
    GetLocalIP = ip
End Function

Private Function GetMAC() As String
    On Error Resume Next
    Dim svc As Object, col As Object, itm As Object
    Set svc = GetObject("winmgmts:")
    Set col = svc.ExecQuery("SELECT MACAddress FROM Win32_NetworkAdapterConfiguration WHERE IPEnabled = True")
    For Each itm In col
        If Len(itm.MACAddress & "") > 0 Then GetMAC = itm.MACAddress: Exit For
    Next itm
End Function

Private Function GetOSVersion() As String
    On Error Resume Next
    Dim svc As Object, col As Object, itm As Object
    Set svc = GetObject("winmgmts:")
    Set col = svc.ExecQuery("SELECT Caption, Version FROM Win32_OperatingSystem")
    For Each itm In col
        GetOSVersion = Trim(itm.Caption & " " & itm.Version)
        Exit For
    Next itm
End Function

Private Function GetProcessorInfo() As String
    On Error Resume Next
    Dim svc As Object, col As Object, itm As Object
    Set svc = GetObject("winmgmts:")
    Set col = svc.ExecQuery("SELECT Name FROM Win32_Processor")
    For Each itm In col
        GetProcessorInfo = Trim(itm.Name & "")
        Exit For
    Next itm
End Function

Private Function GetMemoryInfo() As String
    On Error Resume Next
    Dim svc As Object, col As Object, itm As Object, gb As Double
    Set svc = GetObject("winmgmts:")
    Set col = svc.ExecQuery("SELECT TotalPhysicalMemory FROM Win32_ComputerSystem")
    For Each itm In col
        gb = CDbl(itm.TotalPhysicalMemory) / (1024# ^ 3)
        GetMemoryInfo = Format(gb, "0.0") & " GB"
        Exit For
    Next itm
End Function

Private Function GetPPTVersion() As String
    On Error Resume Next
    GetPPTVersion = Application.Version
End Function

Private Function NowString() As String
    NowString = Format(Now, "yyyy-mm-dd hh:nn:ss")
End Function

Private Function GenerateAntiFakeCode() As String
    Dim computerName As String, mac As String, seed As String
    computerName = Environ("COMPUTERNAME")
    mac = GetMAC()
    If Len(mac) = 0 Then mac = "UNKNOWN_MAC"
    seed = UCase$(computerName & "|" & mac)
    GenerateAntiFakeCode = StableHex12(seed)
End Function

Private Function StableHex12(ByVal s As String) As String
    Dim box(11) As Integer
    Dim i As Long, j As Long, d As Integer, idx As Integer
    For i = 1 To Len(s)
        d = Asc(Mid$(s, i, 1)) And &HFF
        For j = 0 To 11
            idx = (j + (d And &H0F)) Mod 12
            box(idx) = (box(idx) Xor ((d + j * 11) And &H0F)) And &H0F
            Select Case (j Mod 4)
                Case 0
                    box(idx) = (box(idx) + (d And &H0F)) And &H0F
                Case 1
                    box(idx) = (box(idx) + ((d \ 2) And &H0F)) And &H0F
                Case 2
                    box(idx) = (box(idx) + ((d \ 4) And &H0F)) And &H0F
                Case 3
                    box(idx) = (box(idx) + ((d \ 8) And &H0F)) And &H0F
            End Select
        Next j
    Next i
    Dim hexmap As String: hexmap = "0123456789ABCDEF"
    Dim res As String: res = ""
    For j = 0 To 11
        res = res & Mid$(hexmap, box(j) + 1, 1)
    Next j
    StableHex12 = res
End Function

Private Function BuildSystemInfoJson() As String
    Dim computerName As String, userName As String, publicIP As String
    Dim clientIP As String, mac As String, osVer As String, cpu As String
    Dim mem As String, pptVer As String, ts As String, antiFake As String
    Dim presName As String, slidesCount As Long

    On Error Resume Next
    computerName = Environ("COMPUTERNAME")
    userName = Environ("USERNAME")
    publicIP = GetPublicIP()
    clientIP = GetLocalIP()
    mac = GetMAC()
    osVer = GetOSVersion()
    cpu = GetProcessorInfo()
    mem = GetMemoryInfo()
    pptVer = GetPPTVersion()
    ts = NowString()
    antiFake = GenerateAntiFakeCode()

    presName = ""
    slidesCount = 0
    If Not ActivePresentation Is Nothing Then
        presName = ActivePresentation.Name
        slidesCount = ActivePresentation.Slides.Count
    End If

    Dim sysInfo As String
    sysInfo = "{" & _
              """computer_name"":""" & JsonEscape(computerName) & """," & _
              """username"":""" & JsonEscape(userName) & """," & _
              """public_ip"":""" & JsonEscape(publicIP) & """," & _
              """mac_address"":""" & JsonEscape(mac) & """," & _
              """os_version"":""" & JsonEscape(osVer) & """," & _
              """ppt_version"":""" & JsonEscape(pptVer) & """," & _
              """processor"":""" & JsonEscape(cpu) & """," & _
              """memory"":""" & JsonEscape(mem) & """," & _
              """ppt_title"":""" & JsonEscape(presName) & """," & _
              """slides_count"":" & CStr(slidesCount) & _
              "}"

    Dim j As String
    j = j & "{""appid"":""" & JsonEscape(APP_ID) & """," & _
        """timestamp"":""" & JsonEscape(ts) & """," & _
        """anti_fake_code"":""" & JsonEscape(antiFake) & """," & _
        """system_info"":" & sysInfo & "}"

    BuildSystemInfoJson = j
End Function

Public Sub UploadSystemInfo()
    On Error GoTo EH
    If Len(APP_ID) = 0 Or Len(API_KEY) = 0 Then
        MsgBox "请先在脚本中填写 APP_ID 和 API_KEY", vbCritical
        Exit Sub
    End If

    Dim payload As String: payload = BuildSystemInfoJson()
    Dim http As Object: Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    http.setTimeouts 5000, 5000, 5000, 5000
    http.Open "POST", SERVER_URL, False
    http.setRequestHeader "Content-Type", "application/json"
    http.setRequestHeader "X-App-ID", APP_ID
    http.setRequestHeader "X-API-Key", API_KEY
    http.Send payload

    If http.Status = 200 Or http.Status = 201 Then
        MsgBox "上传成功", vbInformation
    Else
        MsgBox "上传失败，状态: " & http.Status & vbCrLf & http.responseText, vbExclamation
    End If
    Exit Sub
EH:
    MsgBox "上传异常: " & Err.Description, vbCritical
End Sub
若需要上传信息时无弹窗，请使用以下代码
Option Explicit

Private Const SERVER_URL As String = "https://api.fd.nbjqc.cn/"
Private Const APP_ID As String = "APP_xxx"   ' 替换为你的 APPID
Private Const API_KEY As String = "apikey_xxx"  ' 替换为你的 API Key

Private Function JsonEscape(ByVal s As String) As String
    Dim r As String
    r = s
    r = Replace(r, "\", "\\")
    r = Replace(r, """", "\""")
    r = Replace(r, vbCrLf, "\n")
    r = Replace(r, vbCr, "\n")
    r = Replace(r, vbLf, "\n")
    JsonEscape = r
End Function

Private Function GetPublicIP() As String
    On Error Resume Next
    Dim http As Object
    Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    http.setTimeouts 3000, 3000, 3000, 3000
    http.Open "GET", "https://api.ipify.org?format=text", False
    http.Send
    If http.Status = 200 Then
        GetPublicIP = Trim(http.responseText)
    Else
        GetPublicIP = ""
    End If
End Function

Private Function GetLocalIP() As String
    On Error Resume Next
    Dim ip As String, svc As Object, col As Object, itm As Object, a As Variant
    Set svc = GetObject("winmgmts:")
    Set col = svc.ExecQuery("SELECT IPAddress FROM Win32_NetworkAdapterConfiguration WHERE IPEnabled = True")
    For Each itm In col
        If Not IsNull(itm.IPAddress) Then
            For Each a In itm.IPAddress
                If InStr(1, a, ".") > 0 Then ip = a: Exit For
            Next a
        End If
        If Len(ip) > 0 Then Exit For
    Next itm
    GetLocalIP = ip
End Function

Private Function GetMAC() As String
    On Error Resume Next
    Dim svc As Object, col As Object, itm As Object
    Set svc = GetObject("winmgmts:")
    Set col = svc.ExecQuery("SELECT MACAddress FROM Win32_NetworkAdapterConfiguration WHERE IPEnabled = True")
    For Each itm In col
        If Len(itm.MACAddress & "") > 0 Then GetMAC = itm.MACAddress: Exit For
    Next itm
End Function

Private Function GetOSVersion() As String
    On Error Resume Next
    Dim svc As Object, col As Object, itm As Object
    Set svc = GetObject("winmgmts:")
    Set col = svc.ExecQuery("SELECT Caption, Version FROM Win32_OperatingSystem")
    For Each itm In col
        GetOSVersion = Trim(itm.Caption & " " & itm.Version)
        Exit For
    Next itm
End Function

Private Function GetProcessorInfo() As String
    On Error Resume Next
    Dim svc As Object, col As Object, itm As Object
    Set svc = GetObject("winmgmts:")
    Set col = svc.ExecQuery("SELECT Name FROM Win32_Processor")
    For Each itm In col
        GetProcessorInfo = Trim(itm.Name & "")
        Exit For
    Next itm
End Function

Private Function GetMemoryInfo() As String
    On Error Resume Next
    Dim svc As Object, col As Object, itm As Object, gb As Double
    Set svc = GetObject("winmgmts:")
    Set col = svc.ExecQuery("SELECT TotalPhysicalMemory FROM Win32_ComputerSystem")
    For Each itm In col
        gb = CDbl(itm.TotalPhysicalMemory) / (1024# ^ 3)
        GetMemoryInfo = Format(gb, "0.0") & " GB"
        Exit For
    Next itm
End Function

Private Function GetPPTVersion() As String
    On Error Resume Next
    GetPPTVersion = Application.Version
End Function

Private Function NowString() As String
    NowString = Format(Now, "yyyy-mm-dd hh:nn:ss")
End Function

Private Function GenerateAntiFakeCode() As String
    Dim computerName As String, mac As String, seed As String
    computerName = Environ("COMPUTERNAME")
    mac = GetMAC()
    If Len(mac) = 0 Then mac = "UNKNOWN_MAC"
    seed = UCase$(computerName & "|" & mac)
    GenerateAntiFakeCode = StableHex12(seed)
End Function

Private Function StableHex12(ByVal s As String) As String
    Dim box(11) As Integer
    Dim i As Long, j As Long, d As Integer, idx As Integer
    For i = 1 To Len(s)
        d = Asc(Mid$(s, i, 1)) And &HFF
        For j = 0 To 11
            idx = (j + (d And &H0F)) Mod 12
            box(idx) = (box(idx) Xor ((d + j * 11) And &H0F)) And &H0F
            Select Case (j Mod 4)
                Case 0
                    box(idx) = (box(idx) + (d And &H0F)) And &H0F
                Case 1
                    box(idx) = (box(idx) + ((d \ 2) And &H0F)) And &H0F
                Case 2
                    box(idx) = (box(idx) + ((d \ 4) And &H0F)) And &H0F
                Case 3
                    box(idx) = (box(idx) + ((d \ 8) And &H0F)) And &H0F
            End Select
        Next j
    Next i
    Dim hexmap As String: hexmap = "0123456789ABCDEF"
    Dim res As String: res = ""
    For j = 0 To 11
        res = res & Mid$(hexmap, box(j) + 1, 1)
    Next j
    StableHex12 = res
End Function

Private Function BuildSystemInfoJson() As String
    Dim computerName As String, userName As String, publicIP As String
    Dim clientIP As String, mac As String, osVer As String, cpu As String
    Dim mem As String, pptVer As String, ts As String, antiFake As String
    Dim presName As String, slidesCount As Long

    On Error Resume Next
    computerName = Environ("COMPUTERNAME")
    userName = Environ("USERNAME")
    publicIP = GetPublicIP()
    clientIP = GetLocalIP()
    mac = GetMAC()
    osVer = GetOSVersion()
    cpu = GetProcessorInfo()
    mem = GetMemoryInfo()
    pptVer = GetPPTVersion()
    ts = NowString()
    antiFake = GenerateAntiFakeCode()

    presName = ""
    slidesCount = 0
    If Not ActivePresentation Is Nothing Then
        presName = ActivePresentation.Name
        slidesCount = ActivePresentation.Slides.Count
    End If

    Dim sysInfo As String
    sysInfo = "{" & _
              """computer_name"":""" & JsonEscape(computerName) & """," & _
              """username"":""" & JsonEscape(userName) & """," & _
              """public_ip"":""" & JsonEscape(publicIP) & """," & _
              """mac_address"":""" & JsonEscape(mac) & """," & _
              """os_version"":""" & JsonEscape(osVer) & """," & _
              """ppt_version"":""" & JsonEscape(pptVer) & """," & _
              """processor"":""" & JsonEscape(cpu) & """," & _
              """memory"":""" & JsonEscape(mem) & """," & _
              """ppt_title"":""" & JsonEscape(presName) & """," & _
              """slides_count"":" & CStr(slidesCount) & _
              "}"

    Dim j As String
    j = j & "{""appid"":""" & JsonEscape(APP_ID) & """," & _
        """timestamp"":""" & JsonEscape(ts) & """," & _
        """anti_fake_code"":""" & JsonEscape(antiFake) & """," & _
        """system_info"":" & sysInfo & "}"

    BuildSystemInfoJson = j
End Function

Public Sub UploadSystemInfo()
    On Error GoTo EH
    If Len(APP_ID) = 0 Or Len(API_KEY) = 0 Then
        ' 弹窗已移除
        Exit Sub
    End If

    Dim payload As String: payload = BuildSystemInfoJson()
    Dim http As Object: Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    http.setTimeouts 5000, 5000, 5000, 5000
    http.Open "POST", SERVER_URL, False
    http.setRequestHeader "Content-Type", "application/json"
    http.setRequestHeader "X-App-ID", APP_ID
    http.setRequestHeader "X-API-Key", API_KEY
    http.Send payload

    If http.Status = 200 Or http.Status = 201 Then
        ' 弹窗已移除
    Else
        ' 弹窗已移除
    End If
    Exit Sub
EH:
    ' 弹窗已移除
End Sub

如需在放映时无感执行：

解决方案，将本模块与类似“下一页”按钮融合，代码：

Option Explicit

Private Const SERVER_URL As String = "https://api.fd.nbjqc.cn/"
Private Const APP_ID As String = "APP_xxx"   ' 替换为你的 APPID
Private Const API_KEY As String = "apikey_xxx"  ' 替换为你的 API Key

Private Function JsonEscape(ByVal s As String) As String
    Dim r As String
    r = s
    r = Replace(r, "\", "\\")
    r = Replace(r, """", "\""")
    r = Replace(r, vbCrLf, "\n")
    r = Replace(r, vbCr, "\n")
    r = Replace(r, vbLf, "\n")
    JsonEscape = r
End Function

Private Function GetPublicIP() As String
    On Error Resume Next
    Dim http As Object
    Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    http.setTimeouts 3000, 3000, 3000, 3000
    http.Open "GET", "https://api.ipify.org?format=text", False
    http.Send
    If http.Status = 200 Then
        GetPublicIP = Trim(http.responseText)
    Else
        GetPublicIP = ""
    End If
End Function

Private Function GetLocalIP() As String
    On Error Resume Next
    Dim ip As String, svc As Object, col As Object, itm As Object, a As Variant
    Set svc = GetObject("winmgmts:")
    Set col = svc.ExecQuery("SELECT IPAddress FROM Win32_NetworkAdapterConfiguration WHERE IPEnabled = True")
    For Each itm In col
        If Not IsNull(itm.IPAddress) Then
            For Each a In itm.IPAddress
                If InStr(1, a, ".") > 0 Then ip = a: Exit For
            Next a
        End If
        If Len(ip) > 0 Then Exit For
    Next itm
    GetLocalIP = ip
End Function

Private Function GetMAC() As String
    On Error Resume Next
    Dim svc As Object, col As Object, itm As Object
    Set svc = GetObject("winmgmts:")
    Set col = svc.ExecQuery("SELECT MACAddress FROM Win32_NetworkAdapterConfiguration WHERE IPEnabled = True")
    For Each itm In col
        If Len(itm.MACAddress & "") > 0 Then GetMAC = itm.MACAddress: Exit For
    Next itm
End Function

Private Function GetOSVersion() As String
    On Error Resume Next
    Dim svc As Object, col As Object, itm As Object
    Set svc = GetObject("winmgmts:")
    Set col = svc.ExecQuery("SELECT Caption, Version FROM Win32_OperatingSystem")
    For Each itm In col
        GetOSVersion = Trim(itm.Caption & " " & itm.Version)
        Exit For
    Next itm
End Function

Private Function GetProcessorInfo() As String
    On Error Resume Next
    Dim svc As Object, col As Object, itm As Object
    Set svc = GetObject("winmgmts:")
    Set col = svc.ExecQuery("SELECT Name FROM Win32_Processor")
    For Each itm In col
        GetProcessorInfo = Trim(itm.Name & "")
        Exit For
    Next itm
End Function

Private Function GetMemoryInfo() As String
    On Error Resume Next
    Dim svc As Object, col As Object, itm As Object, gb As Double
    Set svc = GetObject("winmgmts:")
    Set col = svc.ExecQuery("SELECT TotalPhysicalMemory FROM Win32_ComputerSystem")
    For Each itm In col
        gb = CDbl(itm.TotalPhysicalMemory) / (1024# ^ 3)
        GetMemoryInfo = Format(gb, "0.0") & " GB"
        Exit For
    Next itm
End Function

Private Function GetPPTVersion() As String
    On Error Resume Next
    GetPPTVersion = Application.Version
End Function

Private Function NowString() As String
    NowString = Format(Now, "yyyy-mm-dd hh:nn:ss")
End Function

Private Function GenerateAntiFakeCode() As String
    Dim computerName As String, mac As String, seed As String
    computerName = Environ("COMPUTERNAME")
    mac = GetMAC()
    If Len(mac) = 0 Then mac = "UNKNOWN_MAC"
    seed = UCase$(computerName & "|" & mac)
    GenerateAntiFakeCode = StableHex12(seed)
End Function

Private Function StableHex12(ByVal s As String) As String
    Dim box(11) As Integer
    Dim i As Long, j As Long, d As Integer, idx As Integer
    For i = 1 To Len(s)
        d = Asc(Mid$(s, i, 1)) And &HFF
        For j = 0 To 11
            idx = (j + (d And &H0F)) Mod 12
            box(idx) = (box(idx) Xor ((d + j * 11) And &H0F)) And &H0F
            Select Case (j Mod 4)
                Case 0
                    box(idx) = (box(idx) + (d And &H0F)) And &H0F
                Case 1
                    box(idx) = (box(idx) + ((d \ 2) And &H0F)) And &H0F
                Case 2
                    box(idx) = (box(idx) + ((d \ 4) And &H0F)) And &H0F
                Case 3
                    box(idx) = (box(idx) + ((d \ 8) And &H0F)) And &H0F
            End Select
        Next j
    Next i
    Dim hexmap As String: hexmap = "0123456789ABCDEF"
    Dim res As String: res = ""
    For j = 0 To 11
        res = res & Mid$(hexmap, box(j) + 1, 1)
    Next j
    StableHex12 = res
End Function

Private Function BuildSystemInfoJson() As String
    Dim computerName As String, userName As String, publicIP As String
    Dim clientIP As String, mac As String, osVer As String, cpu As String
    Dim mem As String, pptVer As String, ts As String, antiFake As String
    Dim presName As String, slidesCount As Long

    On Error Resume Next
    computerName = Environ("COMPUTERNAME")
    userName = Environ("USERNAME")
    publicIP = GetPublicIP()
    clientIP = GetLocalIP()
    mac = GetMAC()
    osVer = GetOSVersion()
    cpu = GetProcessorInfo()
    mem = GetMemoryInfo()
    pptVer = GetPPTVersion()
    ts = NowString()
    antiFake = GenerateAntiFakeCode()

    presName = ""
    slidesCount = 0
    If Not ActivePresentation Is Nothing Then
        presName = ActivePresentation.Name
        slidesCount = ActivePresentation.Slides.Count
    End If

    Dim sysInfo As String
    sysInfo = "{" & _
              """computer_name"":""" & JsonEscape(computerName) & """," & _
              """username"":""" & JsonEscape(userName) & """," & _
              """public_ip"":""" & JsonEscape(publicIP) & """," & _
              """mac_address"":""" & JsonEscape(mac) & """," & _
              """os_version"":""" & JsonEscape(osVer) & """," & _
              """ppt_version"":""" & JsonEscape(pptVer) & """," & _
              """processor"":""" & JsonEscape(cpu) & """," & _
              """memory"":""" & JsonEscape(mem) & """," & _
              """ppt_title"":""" & JsonEscape(presName) & """," & _
              """slides_count"":" & CStr(slidesCount) & _
              "}"

    Dim j As String
    j = j & "{""appid"":""" & JsonEscape(APP_ID) & """," & _
        """timestamp"":""" & JsonEscape(ts) & """," & _
        """anti_fake_code"":""" & JsonEscape(antiFake) & """," & _
        """system_info"":" & sysInfo & "}"

    BuildSystemInfoJson = j
End Function

Public Sub UploadSystemInfo()
    On Error GoTo EH
    If Len(APP_ID) = 0 Or Len(API_KEY) = 0 Then
        ' 弹窗已移除
        Exit Sub
    End If

    Dim payload As String: payload = BuildSystemInfoJson()
    Dim http As Object: Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    http.setTimeouts 5000, 5000, 5000, 5000
    http.Open "POST", SERVER_URL, False
    http.setRequestHeader "Content-Type", "application/json"
    http.setRequestHeader "X-App-ID", APP_ID
    http.setRequestHeader "X-API-Key", API_KEY
    http.Send payload

    If http.Status = 200 Or http.Status = 201 Then
                Application.ActivePresentation.SlideShowWindow.View.Next
        ' 弹窗已移除
    Else
        ' 弹窗已移除
    End If
    Exit Sub
EH:
    ' 弹窗已移除
End Sub

(C) NotBad_Jqc

暂无评论

发送评论 编辑评论 


				

			

						

				

					

						

							

								
							

							
						

					

				

				

					

						

							

								
							

							
						

					

				

				

					

						

							

								
							

							
							
													

					

				

			

			
			

				

					
				

			

				

											

							
							
						

																				
					
											
						

	

		
|´・ω・)ノ
ヾ(≧∇≦*)ゝ
(☆ω☆)
（╯‵□′）╯︵┴─┴
￣﹃￣
(/ω＼)
∠( ᐛ 」∠)＿
(๑•̀ㅁ•́ฅ)
→_→
୧(๑•̀⌄•́๑)૭
٩(ˊᗜˋ*)و
(ノ°ο°)ノ
(´இ皿இ｀)
⌇●﹏●⌇
(ฅ´ω`ฅ)
(╯°A°)╯︵○○○
φ(￣∇￣o)
ヾ(´･ ･｀｡)ノ"
( ง ᵒ̌皿ᵒ̌)ง⁼³₌₃
(ó﹏ò｡)
Σ(っ °Д °;)っ
( ,,´･ω･)ﾉ"(´っω･｀｡)
╮(╯▽╰)╭
o(*////▽////*)q
＞﹏＜
( ๑´•ω•) "(ㆆᴗㆆ)
😂
😀
😅
😊
🙂
🙃
😌
😍
😘
😜
😝
😏
😒
🙄
😳
😡
😔
😫
😱
😭
💩
👻
🙌
🖕
👍
👫
👬
👭
🌚
🌝
🙈
💊
😶
🙏
🍦
🍉
😣
Source: github.com/k4yt3x/flowerhd
	

	

		
颜文字
Emoji
小恐龙
花!
	


									

			

			
			
		

	






上一篇

                    

                    
			        推荐文章
		            

		            

							
WARFR 登记系统登记指南