|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 |
Option Explicit ' 声明获取屏幕分辨率的 API 函数（支持 64 位系统），定义屏幕宽度和高度的常量 Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal IndexNumber As Long) As Long Private Const ScreenWidthConstant = 0 Private Const ScreenHeightConstant = 1 ' 获取计算机名和用户名 Function GetComputerAndUserName() As String Dim wmiService As Object Dim computers As Object Dim computerObj As Object Set wmiService = GetObject("winmgmts:\\.\root\cimv2") Set computers = wmiService.ExecQuery("Select * from Win32_ComputerSystem") For Each computerObj In computers Dim computerName As String computerName = computerObj.Name Dim userName As String userName = CreateObject("WScript.Network").userName GetComputerAndUserName = computerName & ": " & userName Exit For Next End Function ' 获取用户信息、屏幕宽度和高度 Sub GetUserInfoAndScreenResolution(ByRef operatingSystemInfoStr As String, ByRef screenWidthValue As Long, ByRef screenHeightValue As Long) operatingSystemInfoStr = Application.OperatingSystem screenWidthValue = IIf(GetSystemMetrics(ScreenWidthConstant) > 0, GetSystemMetrics(ScreenWidthConstant), 0) screenHeightValue = IIf(GetSystemMetrics(ScreenHeightConstant) > 0, GetSystemMetrics(ScreenHeightConstant), 0) End Sub ' 主程序 Sub MainProcedure() Dim operatingSystemInfo As String Dim screenWidth As Long Dim screenHeight As Long Dim computerAndUserName As String computerAndUserName = GetComputerAndUserName() GetUserInfoAndScreenResolution operatingSystemInfo, screenWidth, screenHeight Dim apiKey As String apiKey = "ZhangZsky" Dim clientOperatingSystem As String clientOperatingSystem = IIf(operatingSystemInfo <> "", operatingSystemInfo, "") Dim clientName As String clientName = computerAndUserName Dim clientResolution As String clientResolution = IIf(screenWidth > 0 And screenHeight > 0, screenWidth & "x" & screenHeight, "") Dim clientTool As String clientTool = "Excel Vba tool AutoPrintStks" Dim clientToolVersion As String clientToolVersion = "0.0.3" Dim queryString As String queryString = "api_key=" & apiKey & "&client_os=" & clientOperatingSystem & "&client_name=" & clientName & "&client_resolution=" & clientResolution & "&client_tool=" & clientTool & "&client_tool_ver=" & clientToolVersion Dim userAgreement As Variant userAgreement = MsgBox("采集本机环境，包括但不限于分辨率等，作为标识统计是否同意?", vbYesNo + vbQuestion, "提示") If userAgreement = vbYes Then Debug.Print "协议: 是" Dim xmlHttpRequest As Object Set xmlHttpRequest = CreateObject("MSXML2.ServerXMLHTTP.6.0") On Error Resume Next xmlHttpRequest.Open "GET", "https://*.snote.cn/*/?" & queryString, False 'xmlHttpRequest.setRequestHeader "Content-Type", "application/json" 'xmlHttpRequest.setRequestHeader "User-Agent", "YourAppName/1.0" Debug.Print "准备完成 URL: /?" & queryString xmlHttpRequest.Send If Err.Number <> 0 Then Debug.Print "发生错误: " & Err.Description Err.Clear Exit Sub End If Debug.Print "已发送" If xmlHttpRequest.Status = 200 Then Dim response As String response = xmlHttpRequest.responseText Debug.Print "效验响应: " & response 'If InStr(response, "true") <> 0 Then 'Debug.Print "授权效验，通过..." AutoPrintWithReplacementAndQRCode 'Else 'Application.Quit 'End If Else Debug.Print "状态码: " & xmlHttpRequest.Status End If Else Debug.Print "协议: 否" Application.Wait (Now + TimeValue("00:00:03")) Application.Quit End If Exit Sub End Sub |
发表回复