|
В этой статье опубликованы различные вспомогательные функции на VBA, которые порой помогают в работе.
1. Функция формирования инициалов из имени и отчества
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
2. Шифрование строк на VBA
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
3. Сортировка двумерного массива по нулевому столбцу
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
4. Преобразование строки в набор ASC кодов
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
5. Функции для определения нажатой клавиши
'============= Функции для определения нажатой клавиши =================================
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
6. Макрос для создания копии файла программы
(подразумевается наличие в программе глобальной константы или функции PROJECT_NAME)
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
7. Изменяем форматирование цифр в ячейке (выделяем все цифры полужирным шрифтом)
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
8. Поиск артикула (последовательности цифр заданной длины) в текстовой строке
Ссылка на примеры использования Regexp: script-coding.com/WSH/RegExp.html
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
9. Добавление значений сразу во весь столбец двумерного массива
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
10. Использование Application.OnTime с задержкой меньше секунды
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
11. Преобразование коллекции в массив
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
12. Разрешаем Excel доступ в Интернет путем отключения брандмауэра:
' включаем файрвол Windows (доступ в интернет ограничен)
CreateObject("HNetCfg.FwMgr").LocalPolicy.CurrentProfile.FirewallEnabled = True
' отключаем файрвол Windows (доступ в интернет открыт)
CreateObject("HNetCfg.FwMgr").LocalPolicy.CurrentProfile.FirewallEnabled = False |
