Комментарий : Данный способ неактуален для применения в MS Excel 2000, XP
по причине появления в этих версиях буфера обмена. Впрочем в 2000 версии можно
очистить и собственный буфер обмена
[FAQ96]
Ответ :
Для того, чтобы получить перечень всех файлов/папок из
буфера обмена и создать гиперссылки, которые будут ссылаться на
эти файлы, можно использовать нижеприведённый макрос. Разумеется,
Вам необходимо указать свой незащищённый рабочий лист, а также
столбец, ячейки которого, также не должны быть защищены.
Обратите внимание на то, что здесь создаётся список
уникальных(неповторяющихся) гиперссылок и если Вас это не устраивает,
то просто уберите проверку, где используется поиск (метод .Find)
'Источник
'Название статьи : Получить список файлов из Clipboard
'URL ссылка : http://forum.sources.ru/index.php?showtopic=98290
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function DragQueryFile _
Lib "shell32.dll" Alias "DragQueryFileA" ( _
ByVal HDROP As Long, _
ByVal UINT As Long, _
ByVal lpStr As String, _
ByVal ch As Long) As Long
Private Sub CreateHyperlinksFilesOfClipbord()
Dim ihDrop As Long, iCount As Long
Dim iList As Worksheet, iRow As Long
Dim iFileName As String, tmp As String * 255
If IsClipboardFormatAvailable(15&) = 0 Then Exit Sub
If OpenClipboard(0&) = 0 Then Exit Sub
ihDrop = GetClipboardData(15&)
iCount = DragQueryFile(ihDrop, -1, vbNullString, 0)
If iCount = -1 Then Exit Sub
Set iList = ThisWorkbook.Worksheets(1) 'Укажите свой рабочий лист
iRow = iList.Cells(iList.Rows.Count, 1).End(xlUp).Row + 1
For iCount = 0 To iCount - 1
DragQueryFile ihDrop, iCount, tmp, 255&
iFileName = Application.Clean(tmp)
If iList.Columns(1).Find(iFileName, , xlValues, xlWhole) Is Nothing Then
'If Application.CountIf(iList.Columns(1), iFileName) = 0 Then
iList.Hyperlinks.Add iList.Cells(iRow, 1), iFileName
iRow = iRow + 1
End If
Next
CloseClipboard
End Sub |
Комментарий : При любом использовании материала, ссылка на
первоисточник обязательна.
Ответ :
Для того, чтобы определить сколько милисекунд прошло с момента
запуска Windows, достаточно воспользоваться нижеприведённой функцией WinAPI
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Private Sub GetMilliSeconds()
MsgBox "С момента запуска Windows прошло : " & _
GetTickCount & " милисекунд", , ""
End Sub |
Данная функция может быть полезна, например, при точном определении времени
выполнения макроса, т.е. в тех случаях, когда округление до секунды, нежелательно.
Если Вы хотите вызвать эту функцию из ячеек рабочего листа, то в
MS Excel 97 для этого можно использовать, например, функцию рабочего листа
=ВЫЗВАТЬ()
В следующих же версиях, вызов этой функции из ячеек листа заблокирован
разработчиками, поэтому, Вам, по всей видимости, придётся воспользоваться
пользовательской функцией, например =GetTickMilliSecond()
|
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Function GetTickMilliSecond&()
Application.Volatile True
GetTickMilliSecond& = GetTickCount
End Function |
Ответ :
Для того, чтобы определить сколько милисекунд выполнялся необходимый
макрос, достаточно воспользоваться нижеприведённой функцией WinAPI
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Private Sub YourMacro()
iMlSeconds& = GetTickCount
'Здесь должен быть код Вашей программы.
MsgBox "Время выполнения макроса составило " & _
GetTickCount - iMlSeconds& & " милисек.", vbExclamation, ""
End Sub |
Ответ :
Для того, чтобы определить цвет пиксела (RGB) в указанной точке Image,
можно использовать нижеприведённые функции WinAPI и событие
Image1_Click()
Для демонстрации данного примера,
создайте два элемента управления Image (Рисунок), затем, используя
свойство Picture, загрузите графическое изображение в Image1, и после вывода
формы на экран, кликните необходимую(ые) точку(и) на Image1.
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function FindWindow _
Lib "user32.dll" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetDC _
Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function GetCursorPos _
Lib "user32.dll" (lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient _
Lib "user32.dll" ( _
ByVal hWnd As Long, _
lpPoint As POINTAPI) As Long
Private Declare Function GetPixel _
Lib "gdi32.dll" ( _
ByVal hDC As Long, _
ByVal X As Long, _
ByVal Y As Long) As Long
Private Declare Function SetPixel _
Lib "gdi32.dll" ( _
ByVal hDC As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal crColor As Long) As Long
Private Declare Function SetPixelV _
Lib "gdi32.dll" ( _
ByVal hDC As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal crColor As Long) As Long
Private ihWnd As Long, ihDC As Long, iPOINT As POINTAPI
Private Sub UserForm_Initialize()
ihWnd = FindWindow(vbNullString, Me.Caption)
ihDC = GetDC(ihWnd)
End Sub
Private Sub Image1_Click()
Dim iColorPixel As Long
GetCursorPos iPOINT
ScreenToClient ihWnd, iPOINT
iColorPixel = GetPixel(ihDC, iPOINT.X, iPOINT.Y)
Image2.BackColor = iColorPixel 'для наглядности
'SetPixel ihDC, iPOINT.X, iPOINT.Y, vbRed 'изменить цвет
End Sub |
Ответ :
Private Declare Function GetSystemMetrics _
Lib "user32.dll" (ByVal nIndex As Long) As Long
Private Sub GetSystemScreen()
Dim iX As Long, iY As Long
iX = GetSystemMetrics(1&)
iY = GetSystemMetrics(0&)
MsgBox "Ваш экран имеет разрешение : " & _
iX & "x" & iY, vbExclamation, "Информация"
End Sub |
Ответ :
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function GetCursorPos _
Lib "user32.dll" (lpPoint As POINTAPI) As Long
Private Sub GetCursorPosition()
Dim iPOINT As POINTAPI
GetCursorPos iPOINT
MsgBox "X : " & iPOINT.X & vbNewLine & "Y : " & iPOINT.Y, _
vbExclamation, "Координаты курсора мышки"
End Sub |
Ответ :
Private Declare Function SetCursorPos _
Lib "user32.dll" ( _
ByVal X As Long, _
ByVal Y As Long) As Long
Private Sub SetCursorPosition()
SetCursorPos 100&, 500&
End Sub |
Ответ :
Если время выполнения Вашего макроса составляет более пяти-десяти
секунд, то скрасить "часы" ожидания можно, если всё это время на экране
будет маячить анимационный (живой) курсор мышки.
Private Declare Function LoadCursorFromFile _
Lib "user32.dll" Alias "LoadCursorFromFileA" ( _
ByVal lpFileName As String) As Long
Private Declare Function SetCursor _
Lib "user32.dll" ( _
ByVal hCursor As Long) As Long
Private Sub SetAniCursor()
iFileName$ = "C:\WINDOWS\CURSORS\HOURGLAS.ANI"
'Укажите необходимый "живой" указатель для создания курсора
ihCurcor& = LoadCursorFromFile(iFileName$)
SetCursor ihCurcor&
'Здесь должен быть код Вашей программы.
End Sub |
Ответ :
Актуально только для MS Excel 2000 и старше
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function GetCursorPos _
Lib "user32.dll" (lpPoint As POINTAPI) As Long
Private Sub GetRangeFromPoint()
Dim iPOINT As POINTAPI, iCell As Range
GetCursorPos iPOINT
Set iCell = ActiveWindow.RangeFromPoint(X:=iPOINT.X, Y:=iPOINT.Y)
If Not iCell Is Nothing Then
MsgBox "Курсор мышки находится над " & _
iCell.Address(External:=True), vbExclamation, ""
Else
MsgBox "Курсор мышки находится вне ячеек рабочего листа", , ""
End If
End Sub |
Ответ :
Для того, чтобы определить над каким окном (узнать его хэндл, имя класса,
и заголовок окна, разумеется, если он наличествует) находится курсор мышки,
достаточно выполнить макрос GetWindowFromPoint
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function GetCursorPos _
Lib "user32.dll" (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint _
Lib "user32.dll" ( _
ByVal X As Long, _
ByVal Y As Long) As Long
Private Declare Function GetClassName _
Lib "user32.dll" Alias "GetClassNameA" ( _
ByVal hWnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
Private Declare Function GetWindowText _
Lib "user32.dll" Alias "GetWindowTextA" ( _
ByVal hWnd As Long, _
ByVal lpString As String, _
ByVal cch As Long) As Long
Private Sub GetWindowFromPoint()
Dim iPOINT As POINTAPI, ihWnd As Long
Dim iClass As String * 255, iCaption As String * 255
GetCursorPos iPOINT
ihWnd = WindowFromPoint(iPOINT.X, iPOINT.Y)
GetClassName ihWnd, iClass, 255&
GetWindowText ihWnd, iCaption, 255&
MsgBox "Курсор мышки находится над окном :" & vbCrLf & _
"Handle = " & ihWnd & vbCrLf & _
"Class Name = " & Application.Trim(iClass) & vbCrLf & _
"Caption Text = " & Application.Trim(iCaption), , ""
End Sub |
Ответ :
Для того, чтобы скрыть курсор мышки, достаточно выполнить первую
инструкцию, а для того, чтобы отобразить, вторую инструкцию.
Private Declare Function ShowCursor Lib "user32.dll" (ByVal bShow As Long) As Long
Private Sub WinAPI_HiddenCursor()
ShowCursor 0& '[1]
'Здесь должен быть код Вашей программы.
ShowCursor 1& '[2]
End Sub |
Ответ :
Для того, чтобы после клика правой кнопкой мышки, над определёнными
ячейками рабочего листа, отобразить нужную панель инструментов, причём с
учётом координат, а стандартное контекстное меню "Ячейка" заблокировать,
достаточно воспользоваться событием Worksheet_BeforeRightClick
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function GetCursorPos _
Lib "user32.dll" (lpPoint As POINTAPI) As Long
Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean)
If Not Intersect(Target, Me.[A1:C10]) Is Nothing Then
Dim iPOINT As POINTAPI
GetCursorPos iPOINT
With Application.CommandBars("Fill Color")
.Left = iPOINT.X
.Top = iPOINT.Y
.Visible = True
End With
Cancel = True
End If
End Sub |
Если речь идёт о контекстном меню, в т.ч. и созданным с помощью VBA, то
вместо вышеприведённых свойств используйте метод ShowPopup
|
Application.CommandBars("Workbook Tabs").ShowPopup X:=iPOINT.X, Y:=iPOINT.Y
|
Примечание : Естественно, что диапазон ячеек [A1:C10] и панель
инструментов "Цвет заливки" используются исключительно в качестве примера.
Ответ :
Для того, чтобы перебрать все гиперссылки, расположенные в
столбце "A" активного рабочего листа и получить абсолютный путь из
относительного, можно воспользоваться нижеприведённым макросом.
Обратите внимание на то, что лист, диапазон(столбец), а также
функция MsgBox используются исключительно в качестве примера.
Private Declare Function PathIsRelative _
Lib "shlwapi.dll" Alias "PathIsRelativeA" ( _
ByVal pszPath As String) As Long
Private Declare Function GetFullPathName _
Lib "kernel32.dll" Alias "GetFullPathNameA" ( _
ByVal lpFileName As String, _
ByVal nBufferLength As Long, _
ByVal lpBuffer As String, _
ByVal lpFilePart As String) As Long
Private Sub getAbsoluteHyperlink()
Dim iHyperlink As Hyperlink
Dim iPath$, iAddress$, iAbsoluteName$
iPath = ThisWorkbook.BuiltinDocumentProperties("Hyperlink Base")
If iPath = "" Then ThisWorkbook.Path
If Not iPath Like "*\" Then iPath = iPath & "\"
For Each iHyperlink In Range("A:A").Hyperlinks
iAddress = iHyperlink.Address
If CBool(PathIsRelative(iAddress)) = True Then
iAbsoluteName = Space(255)
GetFullPathName _
iPath & iAddress, 255&, iAbsoluteName, vbNullString
iAbsoluteName = RTrim(iAbsoluteName)
'iAbsoluteName = Application.Clean(iAbsoluteName)
MsgBox _
"Относительная = " & iAddress & vbCr & _
"Абсолютная = " & iAbsoluteName, , iHyperlink.Range.Address
Else
MsgBox "Абсолютная = " & iAddress, , iHyperlink.Range.Address
End If
Next
End Sub |
| Private Sub getAbsoluteHyperlink2()
Dim iSource As Range, iHyperlink As Hyperlink
Dim iPath$, iAddress$, iAbsoluteName$, iLength&
iPath = ThisWorkbook.BuiltinDocumentProperties("Hyperlink Base")
If iPath <> "" Then
If Right(iPath, 1) <> "\" Then iPath = iPath & "\"
Else
iPath = ThisWorkbook.Path & "\"
End If
Set iSource = ThisProject.Лист1.Columns(1)
For Each iHyperlink In iSource.Hyperlinks
iAddress = iHyperlink.Address
If PathIsRelative(iAddress) = 1 Then
iAbsoluteName = Space(255)
iLength = GetFullPathName( _
iPath & iAddress, 255&, iAbsoluteName, vbNullString)
iAbsoluteName = Left(iAbsoluteName, iLength)
MsgBox _
"Относительная = " & iAddress & vbCr & _
"Абсолютная = " & iAbsoluteName, , ""
Else
MsgBox "Абсолютная = " & iAddress, , ""
End If
Next
End Sub |
Примечание : Используемые в данном макросе функции WinAPI
не проверяют ни корректность адреса гиперссылки, ни наличие
файлов(папок), так что будьте внимательны.
Ответ :
Для того, чтобы с помощью VBA создать относительную гиперссылку
file:// , т.е. гиперссылку, адрес которой будет определяться
относительно базового адреса (меню Файл команда
Свойства закладка Документ и поле База гиперссылки)
или, в случае отсутствия базы гиперссылки, папки, в которой
находится текущая книга
(разумеется, книга с макросом, предварительно должна быть сохранена) можно
использовать нижеопубликованный макрос CreateRelativeHyperlink .
Обратите внимание на то, что активный лист, ячейка "A1", диалоговое окно
выбора файла и т.п., используются исключительно в качестве примера.
Private Declare Function PathRelativePathTo _
Lib "shlwapi.dll" Alias "PathRelativePathToA" ( _
ByVal pszPath As String, _
ByVal pszFrom As String, _
ByVal dwAttrFrom As Long, _
ByVal pszTo As String, _
ByVal dwAttrTo As Long) As Long
Private Sub CreateRelativeHyperlink()
Dim iPath$, iAddress$, iFileName 'As Variant
iPath = ThisWorkbook.BuiltinDocumentProperties("Hyperlink Base")
If iPath = "" Then
iPath = ThisWorkbook.Path
Else
If iPath Like "*\" Then _
iPath = Left(iPath, Len(iPath) - 1)
End If
ChDrive Left(iPath, 3): ChDir iPath 'необязательно
iFileName = Application.GetOpenFilename( _
Title:="Выберите файл для создания гиперссылки")
If iFileName <> False Then
iAddress = Space(255)
If CBool(PathRelativePathTo( _
iAddress, iPath, 16&, CStr(iFileName), 0&)) = True Then
iAddress = RTrim(iAddress) 'Application.Clean(iAddress)
Else
iAddress = CStr(iFileName)
End If
Range("A1").Clear 'Range("A1").Hyperlinks.Delete
ActiveSheet.Hyperlinks.Add Range("A1"), iAddress
Else
MsgBox "Необходимо было выбрать файл", vbCritical, ""
End If
End Sub |
Ответ :
Для того, чтобы определить, допустимо ли использовать некий текст
в качестве адреса при создании гиперссылки, можно проверить начинается ли
он с "http:" , "ftp:" , "mailto:" , "file:" или "\\" Но можно
использовать и
альтернативный вариант, а именно WinAPI функцию PathIsURL
Private Declare Function PathIsURL _
Lib "shlwapi.dll" Alias "PathIsURLA" ( _
ByVal pszPath As String) As Long
Private Sub WinAPI_IsValidHyperlink()
Dim iAddress$
iAddress = Range("A1").Text '"http://mail.ru"
If PathIsURL(iAddress) = 1 Then
MsgBox "Можно создавать гиперссылку", , ""
Else
MsgBox "Не рекомендуется", vbCritical, ""
End If
End Sub |
Комментарий : Несмотря на то, что при создании гиперссылки
вручную возможно использование такого варианта www.yahoo.com ,
программное же создание, без указания http:// приведёт к появлению
следующего сообщения.
Поэтому не удивляйтесь, если текст, где отсутствует явное указание
протокола, будет признан негодным для создания гиперссылки. К сожалению,
это касается и строки, типа, "C:\Мои документы" которую можно использовать
в качестве адреса гиперссылки, но, повторюсь, функция PathIsURL считает
иначе.
Ответ :
Для того, чтобы получить перечень всех последних файлов и
адресов электронной почты, которые были использованы при создании
гиперссылок, можно использовать нижеопубликованный макрос. Обратите
внимание на то, что его тестирование проводилось исключительно на
машинах с OC Windows XP, 7. А все гиперссылки, если
таковые, разумеется, создавались на этом компьютере, будут выводиться
в ActiveX элементе управления ListBox. Который необходимо
предварительно создать. Обратите внимание на то, что в примере мы
"разделяем" гиперссылки, которые связаны с электронной почтой (E-Mail)
и выводим их в самое начало списка. Это не является обязательным
условием, просто бонус.
'Private Declare Function RegOpenKey _
' Lib "advapi32.dll" Alias "RegOpenKeyA" ( _
' ByVal hKey As Long, _
' ByVal lpSubKey As String, _
' phkResult As Long) As Long
Private Declare Function RegOpenKeyEx _
Lib "advapi32.dll" Alias "RegOpenKeyExA" ( _
ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
phkResult As Long) As Long
Private Declare Function RegCloseKey _
Lib "advapi32.dll" ( _
ByVal hKey As Long) As Long
Private Declare Function RegQueryValueEx _
Lib "advapi32.dll" Alias "RegQueryValueExA" ( _
ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal lpReserved As Long, _
lpType As Long, _
lpData As Any, _
lpcbData As Long) As Long
Private Sub WinAPI_RegArchiveHyperlinks()
Dim iKeyName$, iURL$, ihKey&, iCount&
iCount = 1: iURL = Space(255) 'String(255, 32)
iKeyName = "Software\Microsoft\Internet Explorer\TypedURLs"
'RegOpenKey -2147483647, iKeyName, ihKey
RegOpenKeyEx -2147483647, iKeyName, 0&, 131097, ihKey
Do Until RegQueryValueEx(ihKey, "URL" & iCount, 0&, 1&, ByVal iURL, 255&) <> 0
iURL = Trim(iURL)
If iURL Like "mailto:*" Then '"mailto:*@*.*"
ListBox1.AddItem iURL, 0
Else
ListBox1.AddItem iURL
End If
iCount = iCount + 1: iURL = Space(255) 'String(255, 32)
Loop
RegCloseKey ihKey
End Sub |
Ответ :
Для того, чтобы с помощью VBA скачать файл из интернета, при этом,
указав вручную папку, куда необходимо сохранить файл, а при необходимости,
и новое имя файла (т.е. фактически выполнив команду Сохранить как,
которая появляется в контекстном меню браузера, когда мы подводим курсор
к интересующей нас ссылке и кликаем правую кнопку мышки), можно использовать
следующий код, разумеется, указав свой файл.
Private Declare Function DoFileDownload _
Lib "shdocvw.dll" ( _
ByVal lpszFile As String) As Long
Private Sub WinAPI_DownloadFileWEB()
Dim iFileName$
iFileName = "http://www.msoffice-nm.ru/faq/files/FunctionExcel.chm"
DoFileDownload StrConv(iFileName, vbUnicode)
End Sub |
Ответ :
Для того, чтобы приостановить выполнение программы на нужное время,
можно воспользоваться нижеприведённым вариантом. Данную процедуру имеет
смысл использовать в том случае, когда стандартные возможности, как-то метод
Wait об'екта Application
[FAQ191]
не подходят, например, если время должно составлять 250 милисекунд.
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Private Sub WinAPI_MacroWait()
MsgBox "Первое сообщение" 'используется только для демонстрации
Sleep 250&
MsgBox "Второе сообщение" 'аналогично
End Sub |
Ответ :
Для того, чтобы во время выполнения макроса, заблокировать ввод данных
с клавиатуры, а также использование мышки, можно воспользоваться нижеприведённым
вариантом. Данной функцией имеет смысл воспользоваться в том случае, когда
стандартные возможности, например
[FAQ72],
[FAQ371] не подходят.
Обратите внимание на то, что применение функции BlockInput не позволит
Вам использовать диалоговые окна, в т.ч. и
стандартные,
а также функции MsgBox, InputBox
Private Declare Function BlockInput Lib "user32.dll" (ByVal fBlock As Long) As Long
Private Sub WinAPI_EnableKeyMouse()
BlockInput 1&
'Здесь должен быть код Вашей программы.
BlockInput 0&
End Sub |
Примечание : Минимальные требования, при использовании данной функции,
наличие Windows 98
Ответ :
Private Declare Function IsCharUpper _
Lib "user32.dll" Alias "IsCharUpperA" ( _
ByVal cChar As Byte) As Long
Private Sub Test_IsCharUp()
iSymbol$ = "F" '"f"
If IsCharUpper(Asc(iSymbol$)) <> 0 Then
MsgBox "Да", vbExclamation, ""
Else
MsgBox "Нет", vbExclamation, ""
End If
End Sub |
Ответ :
Private Declare Function IsCharLower _
Lib "user32.dll" Alias "IsCharLowerA" ( _
ByVal cChar As Byte) As Long
Private Sub Test_IsCharLw()
iSymbol$ = "r" '"R"
If IsCharLower(Asc(iSymbol$)) <> 0 Then
MsgBox "Да", vbExclamation, ""
Else
MsgBox "Нет", vbExclamation, ""
End If
End Sub |
Ответ :
Private Declare Function IsCharAlpha _
Lib "user32.dll" Alias "IsCharAlphaA" ( _
ByVal cChar As Byte) As Long
Private Sub Test_IsCharAlpha()
iText$ = "Microsoft Excel - это [...]"
For iCount& = 1 To Len(iText$)
iSymbol$ = Mid(iText$, iCount&, 1)
If IsCharAlpha(Asc(iSymbol$)) <> 0 Then
MsgBox "Символ «" & iSymbol$ & "» это буква алфавита", , ""
Else
MsgBox "Символ «" & iSymbol$ & "» не является буквой", , ""
End If
Next
End Sub |
Ответ :
Для того, чтобы из начала и конца строки удалить ненужные
символы, можно использовать WinAPI функцию StrTrim ,
не забывая, что при удалении перечисленных символов, данная функция
учитывает регистр.
Private Declare Function StrTrim _
Lib "shlwapi.dll" Alias "StrTrimA" ( _
ByVal pszText As String, _
ByVal pszTrimText As String) As Long
Private Sub WinAPI_StrTrim()
Dim iText$, iTrimText$
iText = "_!ABCDEFG#"
iTrimText = "#A_g\0!"
If StrTrim(iText, iTrimText) = 1 Then
MsgBox Application.Clean(iText), , ""
Else
MsgBox "Замены не произошло"
End If
End Sub |
Если же Вам нужно "отгрызть" символы только с одной стороны, то
Вы можете просто добавить к противоположной стороне какой-нибудь
символ, который абсолютно точно отсутствует в перечне удаляемых.
Что, собственно, и демонстрируется в нижеприведённом примере,
который, кстати, легко заменяется на одну строку, где используется
функция InStrRev (XL2000)
| Private Sub WinAPI_StrTrim2()
Dim iText$, iTrimText$
iText = "BMW-Photo.12.jpeg"
iTrimText = "JPEGIFBMN"
iText = "." & UCase(iText)
If StrTrim(iText, iTrimText) = 1 Then
iText = Mid(iText, 2, InStr(iText, vbNullChar) - 3)
MsgBox iText
Else
MsgBox "Замены не произошло"
End If
End Sub |
Примечание : Минимальные требования, при использовании данной
функции, наличие Windows 2000
Ответ :
Для быстрой сортировки массива, Вы можете воспользоваться
этим советом
(автор Aртём Скробов он же tyomitch)
| | | | | | | |
| | | | | | | | | | | | | | | |