Разное - всего понемногу

Function CropFIO(ByVal FIO As String) As String
    ' получает в качестве параметра текстовую строку с виде "Фамилия имя отчество"
    ' обрезает имя и отчество, оставляя лишь инициалы - в виде "Фамилия И. О."
    CropFIO = Application.Trim(FIO): arr = Split(CropFIO, " ")
    If UBound(arr) <> 2 Then Exit Function    ' Если в ячейке не 3 слова - выход из процедуры
    CropFIO = Replace(CropFIO, " " & arr(1), " " & UCase(Left(arr(1), 1)) & ".")
    CropFIO = Replace(CropFIO, " " & arr(2), " " & UCase(Left(arr(2), 1)) & ".")
End Function

Dim s(0 To 255) As Integer, kep(0 To 255) As Integer
 
Public Function EnDeCrypt(ByVal plaintxt As String, ByVal Password As String) As String
    Dim temp As Integer, a As Integer, b As Integer, cipherby As Byte, cipher As String
    b = 0: For a = 0 To 255: b = b + 1: If b > Len(Password) Then b = 1
        kep(a) = Asc(Mid$(Password, b, 1)): Next a
    For a = 0 To 255: s(a) = a: Next a: b = 0
    For a = 0 To 255: b = (b + s(a) + kep(a)) Mod 256: temp = s(a): s(a) = s(b): s(b) = temp: Next a
    For a = 1 To Len(plaintxt): cipherby = EnDeCryptSingle(Asc(Mid$(plaintxt, a, 1)))
        cipher = cipher & Chr(cipherby): Next: EnDeCrypt = cipher
End Function
Public Function EnDeCryptSingle(plainbyte As Byte) As Byte
    Dim i As Integer, j As Integer, temp As Integer, k As Integer, cipherby As Byte
    i = (i + 1) Mod 256: j = (j + s(i)) Mod 256: temp = s(i): s(i) = s(j): s(j) = temp
    k = s((s(i) + s(j)) Mod 256): cipherby = plainbyte Xor k: EnDeCryptSingle = cipherby
End Function
 
' примеры использования
Sub Шифрование_с_расшифровкой()
    MsgBox EnDeCrypt(EnDeCrypt("123456", "passw"), "passw")
End Sub
 
Sub Тест_шифра()
    MsgBox EnDeCrypt("123456", "пароль")
End Sub

Public Function CoolSort(SourceArr As Variant) As Variant
    Dim Check As Boolean, iCount As Integer, jCount As Integer, nCount As Integer
    ReDim tmpArr(UBound(SourceArr, 2)) As Variant
    Do Until Check
        Check = True
        For iCount = LBound(SourceArr, 1) To UBound(SourceArr, 1) - 1
            If Val(SourceArr(iCount, 0)) > Val(SourceArr(iCount + 1, 0)) Then
                For jCount = LBound(SourceArr, 2) To UBound(SourceArr, 2)
                    tmpArr(jCount) = SourceArr(iCount, jCount)
                    SourceArr(iCount, jCount) = SourceArr(iCount + 1, jCount)
                    SourceArr(iCount + 1, jCount) = tmpArr(jCount)
                    Check = False
                Next
            End If
        Next
    Loop
    CoolSort = SourceArr
End Function

Function String2CharCodes(ByVal txt$) As String
    sep = " & "
    For i = 1 To Len(txt)
        charcode = "Chr(" & Asc(Mid(txt, i, 1)) & ")"
        String2CharCodes = String2CharCodes & sep & charcode
    Next i
    String2CharCodes = Mid(String2CharCodes, Len(sep) + 1)
End Function

'============= Функции для определения нажатой клавиши =================================
Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As VirtualKeys) As Integer
 
Public Enum VirtualKeys    ' Virtual Keys, Standard Set
    VK_LBUTTON = &H1: VK_RBUTTON = &H2: VK_CANCEL = &H3: VK_MBUTTON = &H4    'VK_MBUTTON = &H4 -  NOT contiguous with L RBUTTON
    VK_BACK = &H8: VK_TAB = &H9: VK_CLEAR = &HC: VK_RETURN = &HD
    VK_SHIFT = &H10: VK_CONTROL = &H11: VK_MENU = &H12: VK_PAUSE = &H13: VK_CAPITAL = &H14: VK_ESCAPE = &H1B
    VK_SPACE = &H20: VK_PRIOR = &H21: VK_NEXT = &H22: VK_END = &H23: VK_HOME = &H24
    VK_LEFT = &H25: VK_UP = &H26: VK_RIGHT = &H27: VK_DOWN = &H28: VK_SELECT = &H29: VK_PRINT = &H2A
    VK_EXECUTE = &H2B: VK_SNAPSHOT = &H2C: VK_INSERT = &H2D: VK_DELETE = &H2E: VK_HELP = &H2F
 
    ' VK_A thru VK_Z are the same as their ASCII equivalents: 'A' thru 'Z'
    ' VK_0 thru VK_9 are the same as their ASCII equivalents: '0' thru '9'

    VK_NUMPAD0 = &H60: VK_NUMPAD1 = &H61: VK_NUMPAD2 = &H62: VK_NUMPAD3 = &H63: VK_NUMPAD4 = &H64
    VK_NUMPAD5 = &H65: VK_NUMPAD6 = &H66: VK_NUMPAD7 = &H67: VK_NUMPAD8 = &H68: VK_NUMPAD9 = &H69
    VK_MULTIPLY = &H6A: VK_ADD = &H6B: VK_SEPARATOR = &H6C: VK_SUBTRACT = &H6D: VK_DECIMAL = &H6E: VK_DIVIDE = &H6F
    VK_F1 = &H70: VK_F2 = &H71: VK_F3 = &H72: VK_F4 = &H73: VK_F5 = &H74: VK_F6 = &H75: VK_F7 = &H76
    VK_F8 = &H77: VK_F9 = &H78: VK_F10 = &H79: VK_F11 = &H7A: VK_F12 = &H7B
    VK_F13 = &H7C: VK_F14 = &H7D: VK_F15 = &H7E: VK_F16 = &H7F: VK_F17 = &H80: VK_F18 = &H81
    VK_F19 = &H82: VK_F20 = &H83: VK_F21 = &H84: VK_F22 = &H85: VK_F23 = &H86: VK_F24 = &H87
    VK_NUMLOCK = &H90: VK_SCROLL = &H91
 
    '   VK_L VK_R - left and right Alt, Ctrl and Shift virtual keys.
    '   Used only as parameters to GetAsyncKeyState() and GetKeyState().
    '   No other API or message will distinguish left and right keys in this way.
    VK_LSHIFT = &HA0: VK_RSHIFT = &HA1: VK_LCONTROL = &HA2: VK_RCONTROL = &HA3: VK_LMENU = &HA4: VK_RMENU = &HA5
 
    VK_ATTN = &HF6: VK_CRSEL = &HF7: VK_EXSEL = &HF8: VK_EREOF = &HF9: VK_PLAY = &HFA
    VK_ZOOM = &HFB: VK_NONAME = &HFC: VK_PA1 = &HFD: VK_OEM_CLEAR = &HFE
End Enum
'==========================================================================================

Public Function KeyPressed(ByVal VKey As VirtualKeys) As Boolean
    KeyPressed = IIf(GetKeyState(VKey) < 0, True, False)
End Function

Sub CreateBackup()
    On Error Resume Next: ThisWorkbook.Save
    BackupsPath = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, PROJECT_NAME & " Backups\")
    MkDir BackupsPath
    filename = PROJECT_NAME & "_BACKUP_" & Format(Now, "DD-MM-YYYY__HH-NN-SS") & ".xls"
    ThisWorkbook.SaveCopyAs BackupsPath & filename
    'Debug.Print BackupsPath & filename
End Sub

Sub BoldingDigits(ByRef celll As Range)
    For i = 1 To celll.Characters.count
        letter = celll.Characters(start:=i, Length:=1).Text
        celll.Characters(start:=i, Length:=1).Font.Bold = IsNumeric(letter)
    Next
End Sub

Function FindDigits(ByVal txt$, ByVal DigitsCount%) As String
    ' ищет в строке txt$ подстроку цифр длиной DigitsCount%
    Set expres = CreateObject("VBScript.RegExp")
    expres.Pattern = Replace(String(DigitsCount%, "%"), "%", "[0-9]")
    If expres.test(txt$) Then FindDigits = expres.Execute(txt$)(0).Value
End Function

Function FindDigits(ByVal txt$, ByVal DigitsCount%) As String
    ' ищет в строке txt$ подстроку цифр длиной DigitsCount%
    Set RegExp = CreateObject("VBScript.RegExp"): RegExp.Global = True
    RegExp.Pattern = "[\D]": txt$ = " " & RegExp.Replace(txt$, " ") & " "
    RegExp.Pattern = " [\d]{" & DigitsCount% & "} "
    If RegExp.test(txt$) Then FindDigits = RegExp.Execute(txt$)(0).Value
End Function

Sub AddValueIntoColumn(ByRef arr, ByVal ColumnIndex%, ByVal NewValue)
    ' добавляет значение NewValue в столбец ColumnIndex% всех строк
    ' переданного по ссылке двумерного массива arr
    For i = LBound(arr) To UBound(arr)
        arr(i, ColumnIndex%) = NewValue
    Next i
End Sub

Sub ЗапускМакросаСНебольшойЗадержкой() ' по мотивам макроса ZVI_Timer
    ЗадержкаВСекундах = 0.3    ' в секундах
    НазваниеМакроса$ = "test"    ' этот макрос будет запущен через 0.3 сек.
    ЗадержкаВЧасах$ = Replace(Format(CDbl(TimeSerial(0, 0, 1)) * ЗадержкаВСекундах, "0.000000000"), ",", ".")
    macro = "ON.TIME(NOW()+" & ЗадержкаВЧасах$ & ", """ & НазваниеМакроса$ & """)" ' формируем команду запуска
    ExecuteExcel4Macro macro ' macro = ON.TIME(NOW()+0.000003472, "test")
End Sub

Function Collection2Array(ByVal coll As Collection) As Variant
    ReDim arr(0 To coll.Count - 1): Dim i As Long
    For i = 1 To coll.Count: arr(i - 1) = coll(i): Next i
    Collection2Array = arr
End Function

' включаем файрвол Windows (доступ в интернет ограничен)
CreateObject("HNetCfg.FwMgr").LocalPolicy.CurrentProfile.FirewallEnabled = True
 
' отключаем файрвол Windows (доступ в интернет открыт)
CreateObject("HNetCfg.FwMgr").LocalPolicy.CurrentProfile.FirewallEnabled = False