rename_mate.vbs

' Скрипт для переименования напарника в сейвах игры Сталкер Беларусь (by V10)
' Сохраните этот скрипт в папку с игрой под именем rename_mate.vbs и запустите
' ===================================================================================
' Настройки
' Папка с сейвами
strSavesFolder = "_user_dedicated_\savedgames"

' ===================================================================================
' Код

' Предупреждение
strWarning = "" _
& "Внимание! Это не официальный скрипт! На всякий случай скопируйте вашу папку user_dedicated куда нибудь для восстановления если понадобится!" & vbNewLine _
& "============================================" & vbNewLine _
& "Скрипт меняет имя игрока ТОЛЬКО в сейве сервера! Для возможности смены напарника на ходу."  & vbNewLine _
& "Если вы хотите изменить свой собственный никнейм вам нужно дополнительно отредактировать файл " & CreateObject("WScript.Shell").ExpandEnvironmentStrings("%USERPROFILE%") & "\sblauncher.json" & vbNewLine _
& "============================================" & vbNewLine _
& vbNewLine _
& "Скрипт по очереди спросит про каждого игрока которого найдет на сервере." & vbNewLine _
& "Продолжить?" & vbNewLine
If MsgBox(sc(strWarning), vbOKCancel or vbDefaultButton2, sc("Stalker Belarus Смена имени")) = vbCancel Then WScript.Quit

' Получаем список игроков
Set oFSO = CreateObject("Scripting.FileSystemObject")
For Each oFile in oFSO.GetFolder(strSavesFolder).Files
    If InStr(oFile.Name,"mp_actor_") > 0 and InStr(oFile.Name,"backup") = 0 and InStr(oFile.Name,".bak") = 0 Then
    ' Получаем имя игрока и предлагаем сменить ему никнейм
    strActorName = Replace(oFile.Name, "mp_actor_", "")
    If MsgBox(sc("Хотите переименовать игрока '") & strActorName & "' ?", vbYesNo or vbDefaultButton2, sc("Stalker Belarus Смена имени")) = vbYes Then
       strNewName = InputBox(sc("Введите новый никнейм"), sc("Stalker Belarus Смена имени"), strActorName)
       ' Если имя не ввели или оно не изменилось - завершаем скрипт
       If strNewName = "" or strNewName = strActorName Then Exit For

       ' Читаем сейв игрока
       With oFile.OpenAsTextStream()
            strBinary = .Read(oFile.Size)
            .Close
       End With

       ' Проверяем возможность записи в новый файл
       strOutFilename = oFile.ParentFolder & "\mp_actor_" & strNewName
       Set oOutFile = oFSO.createTextFile(strOutFilename)
       If Err.number <> 0 Then MsgBox(Err.message) : Exit For
       On Error GoTo 0
       Set oOutFile = Nothing

       ' Формируем новый заголовок для сейва
       intOldLen = BinaryToDecimal(s2h(Left(strBinary, 2)))
       intNewLen = intOldLen - (Len(strActorName) - Len(strNewName))
       strNewBinary = h2s(DecimalToBinary(intNewLen)) & Right(Left(strBinary,5), 3) & strNewName & Right(strBinary, Len(strBinary) - 5 - Len(strActorName))

       ' Сохраняем новый сейв
       With oFSO.createTextFile(strOutFilename)
            .Write(strNewBinary)
            .Close
       End With

       ' Бекапим старый сейв
       oFSO.MoveFile oFile.Path, oFile.Path & ".bak"

       ' Завершаем скрипт
       Exit For
    End If
    End if
Next

' Функция перекодировки текста из utf-8 (pastebin) в win1251 (windows)
Function sc(s)
    adReadAll = -1
    adTypeText = 2
    Set objStream = CreateObject("ADODB.Stream")
    objStream.Open()
    objStream.Type = adTypeText
    objStream.Charset = "windows-1251"
    objStream.WriteText(s)
    objStream.Flush()
    objStream.Position = 0
    objStream.Charset = "utf-8"
    sc = objStream.ReadText(adReadAll)
    objStream.Close()
End Function

' Функции для работы с двоичными данными
Function DecimalToBinary(Number)
    Do
       DecimalToBinary = Hex(Number Mod 16) & DecimalToBinary
       Number = Number \ 16
    Loop Until Number = 0
    DecimalToBinary = Right(DecimalToBinary, 2) & " " & Left(DecimalToBinary, 2)
End Function

Function BinaryToDecimal(S)
    BinaryToDecimal = CInt("&H" & Right(S, 2) & Left(S, 2))
End Function

Function s2a(s)
  ReDim a(Len(s) - 1)
  Dim i
  For i = 0 To UBound(a)
      a(i) = Mid(s, i + 1, 1)
  Next
  s2a = a
End Function

Function s2h(s)
  Dim a : a = s2a(s)
  Dim i
  For i = 0 To UBound(a)
      a(i) = Right(00 & Hex(Asc(a(i))), 2)
  Next
  s2h = Join(a)
End Function

Function h2s(h)
  Dim a : a = Split(h)
  Dim i
  For i = 0 To UBound(a)
      a(i) = Chr("&H" & a(i))
  Next
  h2s = Join(a, "")
End Function