Не запускается макрос на другом ПК

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Не запускается макрос на другом ПК (Макросы/Sub)

leonardochoco

Дата: Понедельник, 06.05.2024, 23:44 | Сообщение № 1

Группа: Пользователи

Ранг: Прохожий

Сообщений: 9

Репутация: 0 ±

Замечаний: 0% ±

2019

Добрый вечер! Сразу скажу, я новичок в VBA, поэтому сильно не пинайте. Есть файл с макросами на выполнение функций. А именно вычисление контрольной суммы файлов MD5, CRC32, SHA1, и подстановка в шаблон всех извлекаемых данных. Беда в том что файл работает на ПК дома, но на работе нет. И такое прослеживается и на ПК в других организациях у коллег. Проблема - макрос выполняется - ошибки не выскакивают, но строки с вычислением MD5, SHA1 остаются пустыми. Алгоритм CRC32 работает исправно и строки заполняются. Версия excel (дома и на работе) одинаковая, ограничений со стороны админа нет. Библиотеки в References-VBAProject - стандартные. В настройках безопасности Excel лазил - безрезультатно.
Кто может подсказать, в каком направлении копать, как заставить работать файл на любом ПК.

К сообщению приложен файл: iul_v2.xlsm (74.9 Kb) · iul.pdf (129.9 Kb)

Сообщение отредактировал leonardochoco - Понедельник, 06.05.2024, 23:46

Ответить

китин

Дата: Вторник, 07.05.2024, 12:18 | Сообщение № 2

Группа: Модераторы

Ранг: Экселист

Сообщений: 7019

Репутация: 1074 ±

Замечаний: 0% ±

Excel 2007;2010;2016

файл не открывается. пишет, что поврежден

Не судите очень строго:я пытаюсь научиться
ЯД 41001877306852

Ответить

Nic70y

Дата: Вторник, 07.05.2024, 14:01 | Сообщение № 3

Группа: Друзья

Ранг: Экселист

Сообщений: 8791

Репутация: 2293 ±

Замечаний: 0% ±

Excel 2010

Цитата китин, 07.05.2024 в 12:18, в сообщении № 2 (

)

файл не открывается

у меня все норм: открывается, отрабатывает

ЮMoney 41001841029809

Ответить

leonardochoco

Дата: Вторник, 07.05.2024, 14:09 | Сообщение № 4

Группа: Пользователи

Ранг: Прохожий

Сообщений: 9

Репутация: 0 ±

Замечаний: 0% ±

2019

Sub ListFiles()

' Объявление переменной на пути к папке
Dim BrowseFolder As String

' Использование FileDialog для выбора папки
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Выберите папку или диск"
If .Show = -1 Then
' Присвоение переменной пути к выбранной папке
BrowseFolder = CStr(.SelectedItems(1))
Else
' Отображение сообщения, если папка не была выбрана
MsgBox "Вы ничего не выбрали!"
Exit Sub
End If
End With

' Очистка ячеек на "Лист1" перед заполнением новыми данными
Лист1.Range("A2:F31").ClearContents
' Присвоение числового формата на "Лист1"
Лист1.Range("C2:C31").NumberFormat = "[$-ru-RU-X-Genlower]dd mmmm yyyy г., hh:mm:ss"
' Присвоение числового формата на "Лист3"
Лист3.Range("E16").NumberFormat = "[$-ru-RU-X-Genlower]dd mmmm yyyy г., hh:mm:ss"

' Вызов для отображения списка файлов в выбранной папке, значение False - для исключения вложенных папок
ListFilesInFolder BrowseFolder, False
End Sub

' Вывод списка файлов в папке (необязательно включая вложенные папки)
Private Sub ListFilesInFolder(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean)
Dim fso As Object
Dim SourceFolder As Object
Dim SubFolder As Object
Dim FileItem As Object
Dim r As Long

' Настройка объекта файловой системы
Set fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = fso.GetFolder(SourceFolderName)

' Инициализация начальной строки на "Листе1"
r = Лист1.Range("A1").Row + 1

' Перечисление сведений о файле
For Each FileItem In SourceFolder.Files
Лист1.Cells(r, 1).Formula = FileItem.Name ' Имя файла
Лист1.Cells(r, 2).Formula = FileItem.Size ' Размер файла
Лист1.Cells(r, 3).Formula = FileItem.DateLastModified ' Дата и время последнего изменения
Лист1.Cells(r, 4) = FileMD5(FileItem.Path) ' MD5 хэш
Лист1.Cells(r, 6) = SHA1(FileItem.Path) ' SHA1 хэш

' Продолжение вычислений для CRC32 хэша
Dim varBinary As Variant
varBinary = ReadBinaryFile(FileItem.Path)
' Вычисление CRC32 и запись результата
If NoOfDimensionsInArray(varBinary) = 1 Then
Dim bytArray() As Byte
bytArray = varBinary
Dim Msg As String
Msg = Hex(CRC32(bytArray))
Лист1.Cells(r, 5) = Msg ' CRC32 хэш

r = r + 1 ' Переход к следующей строке
End If
Next FileItem

' Повторный поиск по вложенным папкам, если параметр имеет значение true
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If

' Аннулирование объектов для очистки
Set FileItem = Nothing
Set SourceFolder = Nothing
Set SubFolder = Nothing
Set fso = Nothing

' Выполнение макроса по работе с "Лист2"
Application.Run "CopyAndColorRange"

End Sub

' Вычисление MD5-хэш файла
Function FileMD5$(sFilePath$)
On Error GoTo ErrHandler
Dim byteArr() As Byte

' Считывание файла в массив байт
With CreateObject("adodb.stream")
.Type = 1: .Open: .LoadFromFile sFilePath
byteArr = .Read
End With

' Расчет MD5
With CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
FileMD5 = Join(Application.Dec2Hex(.ComputeHash_2(byteArr), 2), "")
End With

' Очистка
Erase byteArr
Exit Function

ErrHandler:
' Обработка ошибок
Debug.Print "Ошибка вычисления MD5: " & err.Description
FileMD5 = ""
End Function

' Вычисление SHA1-хэш файла
Function SHA1(sFilePath As String) As String
On Error Resume Next
Dim byteArr() As Byte

' Считывание файла в массив байт
With CreateObject("adodb.stream")
.Open
.Type = 1
.LoadFromFile sFilePath
byteArr = .Read
End With

' Расчет SHA1
With CreateObject("System.Security.Cryptography.SHA1CryptoServiceProvider")
Dim shaResult() As Byte
shaResult = .ComputeHash_2(byteArr)
Dim shaString As String
For i = LBound(shaResult) To UBound(shaResult)
shaString = shaString & Right("00" & Hex(shaResult(i)), 2)
Next i
SHA1 = shaString
End With

' Очистка
Erase byteArr
Exit Function

End Function

Private Function ReadBinaryFile(ByRef strFilePath As String) As Variant
With CreateObject("ADODB.Stream")
.Type = 1 ' adTypeBinary - двоичный файл
.Open
.LoadFromFile strFilePath
ReadBinaryFile = .Read
End With
End Function

Private Function CRC32(ByRef aiBuf() As Byte) As Long
Static aiCRC() As Long
Static bInit As Boolean
Dim i As Long
Dim j As Long
Dim iLookup As Integer

If Not bInit Then
Const iPoly As Long = &HEDB88320
Dim dwCrc As Long
ReDim aiCRC(0 To 255)

For i = 0 To 255
dwCrc = i

For j = 8 To 1 Step -1
If (dwCrc And 1) Then
dwCrc = ((dwCrc And &HFFFFFFFE) \ 2&) And &H7FFFFFFF
dwCrc = dwCrc Xor iPoly
Else
dwCrc = ((dwCrc And &HFFFFFFFE) \ 2&) And &H7FFFFFFF
End If
Next j

aiCRC(i) = dwCrc
Next i
bInit = True
End If

CRC32 = &HFFFFFFFF

For i = LBound(aiBuf) To UBound(aiBuf)
iLookup = (CRC32 And &HFF) Xor aiBuf(i)
CRC32 = ((CRC32 And &HFFFFFF00) \ &H100) And &HFFFFFF
CRC32 = CRC32 Xor aiCRC(iLookup)
Next i

CRC32 = Not CRC32
End Function

Private Function NoOfDimensionsInArray(ByVal varArray As Variant) As Byte
Dim bytDimNum As Byte
Dim varErrorCheck As Variant

On Error GoTo FinalDimension
For bytDimNum = 1 To 4
varErrorCheck = LBound(varArray, bytDimNum)
Next
FinalDimension:
On Error GoTo 0
NoOfDimensionsInArray = bytDimNum - 1
End Function

Вот код который должен работать. Функици MD5, SHA1 оставляют пустые строки.

Сообщение отредактировал leonardochoco - Вторник, 07.05.2024, 14:13

Ответить

СообщениеSub ListFiles()

' Объявление переменной на пути к папке
Dim BrowseFolder As String

' Использование FileDialog для выбора папки
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Выберите папку или диск"
If .Show = -1 Then
' Присвоение переменной пути к выбранной папке
BrowseFolder = CStr(.SelectedItems(1))
Else
' Отображение сообщения, если папка не была выбрана
MsgBox "Вы ничего не выбрали!"
Exit Sub
End If
End With

' Очистка ячеек на "Лист1" перед заполнением новыми данными
Лист1.Range("A2:F31").ClearContents
' Присвоение числового формата на "Лист1"
Лист1.Range("C2:C31").NumberFormat = "[$-ru-RU-X-Genlower]dd mmmm yyyy г., hh:mm:ss"
' Присвоение числового формата на "Лист3"
Лист3.Range("E16").NumberFormat = "[$-ru-RU-X-Genlower]dd mmmm yyyy г., hh:mm:ss"

' Вызов для отображения списка файлов в выбранной папке, значение False - для исключения вложенных папок
ListFilesInFolder BrowseFolder, False
End Sub

' Вывод списка файлов в папке (необязательно включая вложенные папки)
Private Sub ListFilesInFolder(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean)
Dim fso As Object
Dim SourceFolder As Object
Dim SubFolder As Object
Dim FileItem As Object
Dim r As Long

' Настройка объекта файловой системы
Set fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = fso.GetFolder(SourceFolderName)

' Инициализация начальной строки на "Листе1"
r = Лист1.Range("A1").Row + 1

' Перечисление сведений о файле
For Each FileItem In SourceFolder.Files
Лист1.Cells(r, 1).Formula = FileItem.Name ' Имя файла
Лист1.Cells(r, 2).Formula = FileItem.Size ' Размер файла
Лист1.Cells(r, 3).Formula = FileItem.DateLastModified ' Дата и время последнего изменения
Лист1.Cells(r, 4) = FileMD5(FileItem.Path) ' MD5 хэш
Лист1.Cells(r, 6) = SHA1(FileItem.Path) ' SHA1 хэш

' Продолжение вычислений для CRC32 хэша
Dim varBinary As Variant
varBinary = ReadBinaryFile(FileItem.Path)
' Вычисление CRC32 и запись результата
If NoOfDimensionsInArray(varBinary) = 1 Then
Dim bytArray() As Byte
bytArray = varBinary
Dim Msg As String
Msg = Hex(CRC32(bytArray))
Лист1.Cells(r, 5) = Msg ' CRC32 хэш

r = r + 1 ' Переход к следующей строке
End If
Next FileItem

' Повторный поиск по вложенным папкам, если параметр имеет значение true
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If

' Аннулирование объектов для очистки
Set FileItem = Nothing
Set SourceFolder = Nothing
Set SubFolder = Nothing
Set fso = Nothing

' Выполнение макроса по работе с "Лист2"
Application.Run "CopyAndColorRange"

End Sub

' Вычисление MD5-хэш файла
Function FileMD5$(sFilePath$)
On Error GoTo ErrHandler
Dim byteArr() As Byte

' Считывание файла в массив байт
With CreateObject("adodb.stream")
.Type = 1: .Open: .LoadFromFile sFilePath
byteArr = .Read
End With

' Расчет MD5
With CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
FileMD5 = Join(Application.Dec2Hex(.ComputeHash_2(byteArr), 2), "")
End With

' Очистка
Erase byteArr
Exit Function

ErrHandler:
' Обработка ошибок
Debug.Print "Ошибка вычисления MD5: " & err.Description
FileMD5 = ""
End Function

' Вычисление SHA1-хэш файла
Function SHA1(sFilePath As String) As String
On Error Resume Next
Dim byteArr() As Byte

' Считывание файла в массив байт
With CreateObject("adodb.stream")
.Open
.Type = 1
.LoadFromFile sFilePath
byteArr = .Read
End With

' Расчет SHA1
With CreateObject("System.Security.Cryptography.SHA1CryptoServiceProvider")
Dim shaResult() As Byte
shaResult = .ComputeHash_2(byteArr)
Dim shaString As String
For i = LBound(shaResult) To UBound(shaResult)
shaString = shaString & Right("00" & Hex(shaResult(i)), 2)
Next i
SHA1 = shaString
End With

' Очистка
Erase byteArr
Exit Function

End Function

Private Function ReadBinaryFile(ByRef strFilePath As String) As Variant
With CreateObject("ADODB.Stream")
.Type = 1 ' adTypeBinary - двоичный файл
.Open
.LoadFromFile strFilePath
ReadBinaryFile = .Read
End With
End Function

Private Function CRC32(ByRef aiBuf() As Byte) As Long
Static aiCRC() As Long
Static bInit As Boolean
Dim i As Long
Dim j As Long
Dim iLookup As Integer

If Not bInit Then
Const iPoly As Long = &HEDB88320
Dim dwCrc As Long
ReDim aiCRC(0 To 255)

For i = 0 To 255
dwCrc = i

For j = 8 To 1 Step -1
If (dwCrc And 1) Then
dwCrc = ((dwCrc And &HFFFFFFFE) \ 2&) And &H7FFFFFFF
dwCrc = dwCrc Xor iPoly
Else
dwCrc = ((dwCrc And &HFFFFFFFE) \ 2&) And &H7FFFFFFF
End If
Next j

aiCRC(i) = dwCrc
Next i
bInit = True
End If

CRC32 = &HFFFFFFFF

For i = LBound(aiBuf) To UBound(aiBuf)
iLookup = (CRC32 And &HFF) Xor aiBuf(i)
CRC32 = ((CRC32 And &HFFFFFF00) \ &H100) And &HFFFFFF
CRC32 = CRC32 Xor aiCRC(iLookup)
Next i

CRC32 = Not CRC32
End Function

Private Function NoOfDimensionsInArray(ByVal varArray As Variant) As Byte
Dim bytDimNum As Byte
Dim varErrorCheck As Variant

On Error GoTo FinalDimension
For bytDimNum = 1 To 4
varErrorCheck = LBound(varArray, bytDimNum)
Next
FinalDimension:
On Error GoTo 0
NoOfDimensionsInArray = bytDimNum - 1
End Function

Вот код который должен работать. Функици MD5, SHA1 оставляют пустые строки.

Автор - leonardochoco
Дата добавления - 07.05.2024 в 14:09

leonardochoco

Дата: Вторник, 07.05.2024, 14:12 | Сообщение № 5

Группа: Пользователи

Ранг: Прохожий

Сообщений: 9

Репутация: 0 ±

Замечаний: 0% ±

2019

Nic70y, а можете у себя пересохранить и обратно прислать ?? я уже не знаю на что думать.