РАССЫЛКИ ПОРТАЛА RFPRO.RU

Лучшие эксперты в разделе

zdwork Статус: 5-й класс Рейтинг: 318 ∙ повысить рейтинг »

solowey Статус: Бакалавр Рейтинг: 217 ∙ повысить рейтинг »

Sergey V. Gornostaev Статус: Специалист Рейтинг: 120 ∙ повысить рейтинг »

∙ Basic

Номер выпуска:	1138
Дата выхода:	05.10.2019, 06:15
Администратор рассылки:	Андреенков Владимир (Академик)
Подписчиков / экспертов:	15 / 14
Вопросов / ответов:	3 / 7

Консультация # 67767:

Доброго дня. Подскажите кодом или ссылкой по VB. Тема такая. Нужно проверить диск на наличие файлов или папок (включая вложенные папки) по маске имени для дальнейшего переименования. Мне нужен код именно поиска по всему диску. Спаибо всем кто чем-нибудь поможет

Дата отправки: 19.12.2006, 23:29
Вопрос задал: Igigig
Всего ответов: 1
Страница онлайн-консультации »

Консультирует HookEst:

Здравствуйте, Igigig!
Предлагаю Вашему вниманию 2 функции для поиска файлов по маске, одна использует Windows API вторая нет.
т.к. взяты и переделаны из MSDN, кроме списка файлов вычисляют еще и дополнителную информацию.
После доработки, думаю, можно использовать.

Аргументы:
(IN) path As String - место поиска;
(IN) SearchStr As String - маска поиска;
(OUT) Files As String - список найденых файлов и папок с путями, разделенный vbCrLf;
(OUT) FileCount As Integer - количество найденых файлов и папок;
(OUT) DirCount As Integer - количество вложенных папок в которых производился поиск;

Return:
возвращают as Long - суммарный размер всех найденых файлов;

будут вопросы, пишите.

Приложение:
\'с использованием API\'В отдельном модуле Option Explicit Declare Function FindFirstFile Lib "kernel32" Alias _ "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData _ As WIN32_FIND_DATA) As Long Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" _ (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long Declare Function GetFileAttributes Lib "kernel32" Alias _ "GetFileAttributesA" (ByVal lpFileName As String) As Long Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) _ As Long Public Const MAX_PATH = 260 Public Const MAXDWORD = &HFFFF Public Const INVALID_HANDLE_VALUE = -1 Public Const FILE_ATTRIBUTE_ARCHIVE = &H20 Public Const FILE_ATTRIBUTE_DIRECTORY = &H10 Public Const FILE_ATTRIBUTE_HIDDEN = &H2 Public Const FILE_ATTRIBUTE_NORMAL = &H80 Public Const FILE_ATTRIBUTE_READONLY = &H1 Public Const FILE_A TTRIBUTE_SYSTEM = &H4 Public Const FILE_ATTRIBUTE_TEMPORARY = &H100 Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Type WIN32_FIND_DATA dwFileAttributes As Long ftCreationTime As FILETIME ftLastAccessTime As FILETIME ftLastWriteTime As FILETIME nFileSizeHigh As Long nFileSizeLow As Long dwReserved0 As Long dwReserved1 As Long cFileName As String * MAX_PATH cAlternate As String * 14 End Type Public Function StripNulls(OriginalStr As String) As String If (InStr(OriginalStr, Chr(0)) > 0) Then OriginalStr = Left(OriginalStr, _ InStr(OriginalStr, Chr(0)) - 1) End If StripNulls = OriginalStr End Function Function FindFilesAPI(path As String, SearchStr As String, _ Files As String, FileCount As Integer, DirCount As Integer) As Long Dim FileName As String \' Walking filename variable... Dim DirName As String \' SubDirectory Name Dim dirNames() As Stri ng \' Buffer for directory name entries Dim nDir As Integer \' Number of directories in this path Dim i As Integer \' For-loop counter... Dim hSearch As Long \' Search Handle Dim WFD As WIN32_FIND_DATA Dim Cont As Integer Dim FT As FILETIME Dim DateCStr As String, DateMStr As String If Right(path, 1) <> "\" Then path = path & "\" \' Search for subdirectories. nDir = 0 ReDim dirNames(nDir) Cont = True hSearch = FindFirstFile(path & "*", WFD) If hSearch <> INVALID_HANDLE_VALUE Then Do While Cont DirName = StripNulls(WFD.cFileName) \' Ignore the current and encompassing directories. If (DirName <> ".") And (DirName <> "..") Then \' Check for directory with bitwise comparison. If GetFileAttributes(path & DirName) And _ FILE_ATTRIBUTE_DIRECTORY Then dirNames(nDir) = DirName DirCount = DirCount + 1 nDir = nDir + 1 ReDim Preserve dirNames(nDir) \'Files = Files & path & DirName & vbCrLf End If End If Cont = FindNextFile(hSearch, WFD) \' Get next subdirectory. Loop Cont = FindClose(hSearch) End If \' Walk through this directory and sum file sizes. hSearch = FindFirstFile(path & SearchStr, WFD) Cont = True If hSearch <> INVALID_HANDLE_VALUE Then While Cont FileName = StripNulls(WFD.cFileName) If (FileName <> ".") And (FileName <> "..") Then FindFilesAPI = FindFilesAPI + (WFD.nFileSizeHigh * _ MAXDWORD) + WFD.nFileSizeLow FileCount = FileCount + 1 Files = Files & path & FileName & vbCrLf End If Cont = FindNextFile(hSearch, WFD) \' Get next file Wend Cont = FindClose(hSearch) End If \' If there are sub-directories... If nDir > 0 Then \' Recursively walk into them... For i = 0 To nDir - 1 FindFilesAPI = FindFilesAPI + FindFilesAPI(path & dirNames(i) _ & "\", SearchStr, Files, FileCount, DirCount) Next i End If End Function\'без API\'В отдельном модулеFunction FindFiles(path As String, SearchStr As String, _ Files As String, FileCount As Integer, DirCount As Integer) As Long Dim FileName As String \' Walking filename variable. Dim DirName As String \' SubDirectory Name. Dim dirNames() As String \' Buffer for directory name entries. Dim nDir As Integer \' Number of directories in this path. Dim i As Integer \' For-loop counter. On Error GoTo sysFileERR If Right(path, 1) <> "\" Then path = path & "\" \' Search for subdirectories. nDir = 0 ReDim dirNames(nDir) DirName = Dir(path, vbDirectory Or vbHidden Or vbArchive Or vbReadOnly _Or vbSystem) \' Even if hidden, and so on. Do While Len(DirName) > 0 \ ' Ignore the current and encompassing directories. If (DirName <> ".") And (DirName <> "..") Then \' Check for directory with bitwise comparison. If GetAttr(path & DirName) And vbDirectory Then dirNames(nDir) = DirName DirCount = DirCount + 1 nDir = nDir + 1 ReDim Preserve dirNames(nDir) \'Files = Files & path & DirName & vbCrLf End IfsysFileERRCont: End If DirName = Dir() \' Get next subdirectory. Loop \' Search through this directory and sum file sizes. FileName = Dir(path & SearchStr, vbNormal Or vbHidden Or vbDirectory Or vbSystem _ Or vbReadOnly Or vbArchive) While Len(FileName) <> 0 FindFiles = FindFiles + FileLen(path & FileName) FileCount = FileCount + 1 Files = Files & path & FileName & vbCrLf FileName = Dir() \' Get next file. Wend \' If there are sub-di rectories.. If nDir > 0 Then \' Recursively walk into them For i = 0 To nDir - 1 FindFiles = FindFiles + FindFiles(path & dirNames(i) & "\", _ SearchStr, Files, FileCount, DirCount) Next i End IfAbortFunction: Exit FunctionsysFileERR: If Right(DirName, 4) = ".sys" Or path = "System Volume Information" Then Resume sysFileERRCont \' Known issue with pagefile.sys Else \'MsgBox "Error: " & Err.Number & " - " & Err.Description, , "Unexpected Error" Resume AbortFunction End If End Function\'процедура для тестированияPrivate Sub test() Dim SearchPath As String, FindStr As String, Files As String, Msg As String Dim FileSize As Long Dim NumFiles As Integer, NumDirs As Integer SearchPath = "c:\Windows" FindStr = "sys*.dat" Files = "" NumFiles = 0 NumDirs = 0 FileSize = FindFilesAPI(SearchPath, FindStr, Files, NumFiles, NumDirs) M sg = NumFiles & " Files and Folders found with API in " & NumDirs + 1 & " Directories" & vbCrLf Msg = Msg & String(Len(Msg), "*") & vbCrLf Msg = Msg & Files & vbCrLf & vbCrLf Msg = Msg & "Size of files found under " & SearchPath & " = " & Format(FileSize, "#,###,###,##0") & " Bytes" & vbCrLf MsgBox Msg Files = "" NumFiles = 0 NumDirs = 0 FileSize = FindFiles(SearchPath, FindStr, Files, NumFiles, NumDirs) Msg = NumFiles & " Files and Folders found in " & NumDirs + 1 & " Directories" & vbCrLf Msg = Msg & String(Len(Msg), "*") & vbCrLf Msg = Msg & Files & vbCrLf & vbCrLf Msg = Msg & "Size of files found under " & SearchPath & " = " & Format(FileSize, "#,###,###,##0") & " Bytes" & vbCrLf MsgBox Msg End Sub

Консультировал: HookEst Дата отправки: 20.12.2006, 12:24

Рейтинг ответа: 0 поблагодарить эксперта

Консультация # 42041:

Добрый день.
Помогите пожалуйста решить небольшую задачу на VB:
Есть предложение, нужно в каждом слове поменять местами 1-ю и последнюю букву.
Заранее благодарна.

Дата отправки: 04.05.2006, 13:18
Вопрос задал: Iris
Всего ответов: 2
Страница онлайн-консультации »

Консультирует Филатов Евгений Геннадьевич:

Здравствуйте, Iris!

Помещаем на форме Form1 объект Text1, куда будем вносить данные.
Под ним Label1, где выводится результат.
В код формы помещаем

Private Sub Form_Load( )
Form1.Label1 = ""
Form1.Text1 = ""
End Sub

Private Sub Text1_Change( )
If Len(Trim(Form1.Text1 ) ) > 1 Then
\'сначала проверяем, чтобы длина строки была не менее 2 символов.
Form1.Label1 = Right(Trim(Form1.Text1 ), 1 ) & Mid(Trim(Form1.Text1 ), 2, Len(Trim(Form1.Text1 ) ) - 2 ) & Left(Trim(Form1.Text1 ), 1 )
\'сначала подсчитывается результат операции, а затем он заносится в переменную.
Else
Form1.Label1 = ""
End If
End Sub

С уважением.

Консультировал: Филатов Евгений Геннадьевич Дата отправки: 04.05.2006, 13:56

Рейтинг ответа: 0 поблагодарить эксперта

Консультирует PsySex (Профессионал):

Здравствуйте, Iris!
В дополнению к предыдущему ответу.
Предыдущий пример работает только если введено одно слово. Следующий пример обрабатывает все слова в предложении. На форме размещаем Text1,Label1,Command1.
====================================================
Option Explicit
Private Sub Command1_Click()
Dim strText As String
Dim vWord As Variant
Dim vWords As Variant
Dim strWord As String
Dim strNewText As String

strText = Trim(Text1.Text)
strNewText = ""

If Len(strText) > 1 Then
vWords = Split(strText, Chr(32)) \'32-space
For Each vWord In vWords
strWord = CStr(vWord)
strWord = Right(strWord, 1) & Mid(strWord, 2, Len(strWord) - 2) & Left(strWord, 1)
strNewText = strNewText + strWord + Chr(32)
Next
strNewText = RTrim(strNewText) \'обрезка лишнего пробела
End If
Label1.Caption = strNewText
End Sub
====================================================

Консультировал: PsySex (Профессионал) Дата отправки: 04.05.2006, 14:56

Рейтинг ответа: 0 поблагодарить эксперта

Консультация # 90692:

Уважаемые эксперты!
Подскажите пожалуйста:
есть данные (номера телефонов) в ячейках с A3 по A2000
есть мои данные в ячейках с C3 по С15000
Нужно сравнить все телефоны в столбце А со всеми телефонами
в столбце С, и если в ячейке С встречается такой же телефон как и
в столбце А, то напротив совпавшего телефона столбца А, в столбце В
нужно вставить фразу "есть". Так как вручеую считать больше месяца,
то мне сказали написать макрос. Даже ума не приложу что именно писать,
так как у меня слабые знания в VisualBasic. Начал делать, поставил кнопку.
Написал для нее событие, но она делает совсем не то. Помогите, пожалуйста,
иначе придется анализировать вручную, а это адский труд.
С уважением Сергей

Дата отправки: 09.06.2007, 11:42
Вопрос задал: Worsvch
Всего ответов: 4
Страница онлайн-консультации »

Консультирует Felix:

Здравствуйте, Worsvch!

Не нужно использовать ВБА. Используйте функцию ВПР:
1. Отсортируйте столбец А по возрастанию
2. в ячейке В3 пишете формулу: =ЕСЛИ(ВПР(C3;$A$2:$A$2000;1)=C3;"есть";"")
3. копируете формулу вниз до последней заполненной ячейки в столбце С (B1500).

Консультировал: Felix Дата отправки: 09.06.2007, 12:32

Рейтинг ответа: +1 поблагодарить эксперта

Консультирует Ualife:

Здравствуйте, Worsvch!
Смотрите приложение, там код макроса.
Если что-то не понятно то пишите на mailto:ua.life@mail.ru

Приложение:
Sub Макрос()n = 2000 \'До какой строки считатьI1 = "A" \'Первая ячейка для сравниванияI2 = "C" \'Вторая ячейка для сравниванияI3 = "B" \'Ячейка для записи результатов сравненияFor i = 3 To n \'Цикл rang = I1 & i \'Выбираем ячейку Range(rang).Select If ActiveCell.FormulaR1C1 = "" Then \'Если в ячейке нет даных, то MsgBox "В ячейке " & i & rang & " нет данных", vbOKOnly, "Нет даных" \'Сказать об этом Exit Sub Else \'Иначе tmp = ActiveCell.FormulaR1C1 \'Загоняем в переменую содержание ячейки rang = I2 & i \'Выбираем ячейку Range(rang).Select If ActiveCell.FormulaR1C1 = "" Then \'Если в ячейке нет даных, то MsgBox "В ячейке " & rang & " нет данных", vbOKOnly, "Нет даных" \'Сказать об этом Exit Sub Else If ActiveCell.FormulaR1C1 = tmp Then \'Если содержание второй ячейки равно переменой то rang = I3 & i \'Выбираем ячейку Range(rang).Select ActiveCell.FormulaR1C1 = "есть" \'Записуем "есть" Else \'Иначе rang = I3 & i \'Выбираем ячейку Range(rang).Select ActiveCell.FormulaR1C1 = "не" \'Записуем "не" End If End If End If Next iEnd Sub

Консультировал: Ualife Дата отправки: 09.06.2007, 15:01

Рейтинг ответа: +1 поблагодарить эксперта

Консультирует Тесленко Евгений Алексеевич:

Здравствуйте, Worsvch!
Вариант ответа от Felix, самый подходящий для решения Вашей задачи не прибегая к VBA. Если же Вы решили "познакомиться с VBA", предлагаю маленький кусочек кода с помощью которого так же можно решить Вашу задачу.
Удачи.
Евгений.

Приложение:
Sub checkData()Application.ScreenUpdating = FalseDim iRow As Long, vVal, sAdr As String, c sAdr = Cells(3, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False) _ & ":" & Cells(65000, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False)iRow = 2Do While iRow < 65000 iRow = iRow + 1 vVal = Trim(Cells(iRow, 2).Value) If vVal <> "" Then Set c = Range(sAdr).Find(vVal, LookIn:=xlFormulas) If Not c Is Nothing Then Cells(iRow, 3).Formula = "есть" End If End IfLoopApplication.ScreenUpdating = TrueEnd Sub

Консультировал: Тесленко Евгений Алексеевич Дата отправки: 09.06.2007, 21:38

Рейтинг ответа: +1 поблагодарить эксперта

Консультирует Залетин Виталий Викторович (мь:

Здравствуйте, Worsvch!
Sub Sravn()
Dim lA As Long
Dim sh As Object, stat As String

Set sh = Excel.Sheets(1)
sh.Activate

stat = Application.StatusBar
Application.StatusBar = "Подождите, пожалуйста..."
DoEvents

Application.ScreenUpdating = False \'Это для того, чтобы экран до окончания не перерисовывался - так мы экономим некоторое кол-во времени

For lA = 3 To 15000 \'У Вас 15000
If Cells(lA, 1) = Cells(lA, 3) Then \'Смотрим, если А??=С??, то...
Cells(lA, 2) = "--- Есть ---" \'...в В?? пишем слово "--- есть ---"
End If
Next lA

Application.StatusBar = stat
Application.ScreenUpdating = True \'Обновляем экран
Set sh = Nothing
End Sub

Может еще как-то оптимизируете по скорости, но, по-моему, 1,5 секунды удовлетворительный результат (у меня на машине все отрабатывает за 1316 мс.)

Консультировал: Залетин Виталий Викторович (мь Дата отправки: 10.06.2007, 14:48

Рейтинг ответа: +1 поблагодарить эксперта

Оценить выпуск | Задать вопрос экспертам

главная страница  |  стать участником  |  получить консультацию
техническая поддержка