Справочник функций

Ваш аккаунт

Войти через: 
Забыли пароль?
Регистрация
Информацию о новых материалах можно получать и без регистрации:

Последние темы форума

Показать новые сообщения »

Почтовая рассылка

Подписчиков: 11648
Последний выпуск: 19.06.2015

Правильно ли удалены ссылки и освобождена память в программе на Visual basic

328
25 октября 2016 года
Fellinggood
165 / / 27.04.2009
Здравствуйте. Не подскажете правильно ли я удаляю ссылки и освобождаю память в
программе? А то на компьютере где выполняется программа начали происходить странные вещи:
при запуске какого либо документа Word он оказывается пуст, а при следующем запуске
напечатанный текст становится виден, excel загружается не сразу, а как бы волнами сверху
вниз и др.

Вот все инструкции в программе, где я создаю и удаляю ссылки и освобождаю память:

Код:
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(put_files)

Set SourceFolder = Nothing
Set FSO = Nothing

Set resul_zapros = MyExcel.ActiveSheet.QueryTables.Add(Connection:= _
             connect, _
             Destination:=MyExcel.ActiveSheet.Range("A1"))

Set resul_zapros = Nothing

Set nash_list = MyExcel.ActiveWorkbook.Sheets(nazv_list_File) 'Устанавливаем объект nash_list как лист "Основные пок-ли" в
   'активной книге
   'Для всех остальных листов тоже вводим их объекты, чтобы к ним обращаться
Set list_1 = MyExcel.ActiveWorkbook.Sheets(name_list(1))
Set list_2 = MyExcel.ActiveWorkbook.Sheets(name_list(2))
Set list_3 = MyExcel.ActiveWorkbook.Sheets(name_list(3))

MyExcel.ActiveWorkbook.Close
MyExcel.Quit
   
Set list_1 = Nothing
Set list_2 = Nothing
Set list_3 = Nothing
Set MyExcel = Nothing
Set nash_list = Nothing
   
Unload Form1

Сама программа:

Код:
Private Sub Form_Load()
    Dim FSO As Object
    Dim SourceFolder As Object
    Dim SubFolder As Object
    Dim FileItem As Object
    Dim r As Long
    Dim str As String
    Dim namefile As String
    Dim stroka_name_file As String
    Dim chast_name_file As String
    Dim MyExcel As Object
    Set MyExcel = CreateObject("Excel.Application")
    Dim Data_time_system
    Dim fs, f, s, stroka
    Dim MyTime
    Dim MyDate
    Dim time_Prover, time_created, timeDate_created
    Dim arrPutFile(10) As String
    Dim arrNameFile(10) As String
    Dim arrTimeCreation(10) As String
    Dim arrOnlyHour(10) As String
    Dim put_files
    Dim Put_files_withNamefile
    Dim put_file_s_chert
    Dim str_probel
    Dim kolvo_files
    Dim name_list(10) As String
    Dim time_creatZamenadvoet(10) As String
    Dim index_TEK_FILE
    Dim connect As String 'connection при извлечении из csv
   Dim nazv_list_File As String
    Dim correct_list_files As String 'Корректное название листа и файла без двоеточий
   Const xlDelimited = 1  'xlDelimited это константа и ее надо приравнивать 1 или 2 в зависимости от того нужно извлекать файл с разделителями
   'или нет
   Const xlTextQualifierDoubleQuote = 1 'xlTextQualifierDoubleQuote это константа и ее надо приравнивать 1 или 2 в зависимости от
   'того нужно поставить в качестве разделителя двойные или одинарные кавычки
   Dim zapros
    Dim i As Integer
    Dim Chas_sozd(8) As String
    Dim nazv As String
    Dim direct_save As String 'Директория для сохранения
   Dim direct_and_nameFile As String 'Полный путь сохранения вместе с названием
   
    MyTime = Time
    MyDate = Date

    i = 1
    put_files = "D:papka" ' "D:papka" '"D:REPORT"
   put_file_s_chert = put_files & ""
    str_probel = ""
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.GetFolder(put_files)
   
    stroka_name_file = "Основные"
   
    For Each FileItem In SourceFolder.Files
       
        namefile = FileItem.Name
        chast_name_file = Left(namefile, 8)
       
        If chast_name_file = stroka_name_file Then
            arrPutFile(i) = FileItem.Path
 
            Put_files_withNamefile = arrPutFile(i)
            'Имя самого файла arrNameFile(i)
           arrNameFile(i) = Replace(Put_files_withNamefile, put_file_s_chert, str_probel)
            timeDate_created = FileItem.DateCreated
            arrTimeCreation(i) = Right(timeDate_created, 8)
            time_creatZamenadvoet(i) = Replace(arrTimeCreation(i), ":", "_") 'Замена : во времени на знак подчеркивания
           arrOnlyHour(i) = Mid(timeDate_created, 12, 2) 'Время (час) создания файла
           i = i + 1
        End If
     Next FileItem
     
     Set SourceFolder = Nothing
     Set FSO = Nothing
   
     kolvo_files = i - 1
   
     MyExcel.Workbooks.Add 'создание новой рабочей книги
    MyExcel.Visible = True
   
     For i = 1 To kolvo_files
         If arrOnlyHour(i) = "6:" Then
             MyExcel.ActiveWorkbook.Sheets("Лист1").Select
             name_list(1) = "Основные показатели " & time_creatZamenadvoet(i)
             MyExcel.ActiveWorkbook.Sheets("Лист1").Name = name_list(1)
             
             Chas_sozd(1) = arrTimeCreation(i) 'Час создания по порядку
            connect = "TEXT;" & arrPutFile(i) 'Строка для запроса connect, которая говорит что это TEXT - текстовый файл и
            'путь к файлу
            Set resul_zapros = MyExcel.ActiveSheet.QueryTables.Add(Connection:= _
             connect, _
             Destination:=MyExcel.ActiveSheet.Range("A1"))
     
             With resul_zapros
                 .Name = name_list(1)
                 .FieldNames = True
                 .RowNumbers = False
                 .FillAdjacentFormulas = False
                 .PreserveFormatting = True
                 .RefreshOnFileOpen = False
                 .RefreshStyle = xlInsertDeleteCells
                 .SavePassword = False
                 .SaveData = True
                 .AdjustColumnWidth = True
                 .RefreshPeriod = 0
                 .TextFilePromptOnRefresh = False
                 .TextFilePlatform = -535
                 .TextFileStartRow = 1
                 .TextFileParseType = xlDelimited
                 .TextFileTextQualifier = xlTextQualifierDoubleQuote
                 .TextFileConsecutiveDelimiter = True
                 .TextFileTabDelimiter = True
                 .TextFileSemicolonDelimiter = True
                 .TextFileCommaDelimiter = False
                 .TextFileSpaceDelimiter = False
                 .TextFileColumnDataTypes = Array(1, 1, 1)
                 .TextFileTrailingMinusNumbers = True
                 .Refresh BackgroundQuery:=False
             End With
         
             Exit For
             
         End If
     Next i
     
     Set resul_zapros = Nothing
     
     For i = 1 To kolvo_files
         If arrOnlyHour(i) = "8:" Then
             MyExcel.ActiveWorkbook.Sheets("Лист2").Select
             name_list(2) = "Основные показатели " & time_creatZamenadvoet(i)
             MyExcel.ActiveWorkbook.Sheets("Лист2").Name = name_list(2)
   
             Chas_sozd(2) = arrTimeCreation(i) 'Час создания по порядку
            connect = "TEXT;" & arrPutFile(i) 'Строка для запроса connect, которая говорит что это TEXT - текстовый файл и
            'путь к файлу
            Set resul_zapros = MyExcel.ActiveSheet.QueryTables.Add(Connection:= _
             connect, _
             Destination:=MyExcel.ActiveSheet.Range("A1"))
     
             With resul_zapros
                 .Name = name_list(1)
                 .FieldNames = True
                 .RowNumbers = False
                 .FillAdjacentFormulas = False
                 .PreserveFormatting = True
                 .RefreshOnFileOpen = False
                 .RefreshStyle = xlInsertDeleteCells
                 .SavePassword = False
                 .SaveData = True
                 .AdjustColumnWidth = True
                 .RefreshPeriod = 0
                 .TextFilePromptOnRefresh = False
                 .TextFilePlatform = -535
                 .TextFileStartRow = 1
                 .TextFileParseType = xlDelimited
                 .TextFileTextQualifier = xlTextQualifierDoubleQuote
                 .TextFileConsecutiveDelimiter = True
                 .TextFileTabDelimiter = True
                 .TextFileSemicolonDelimiter = True
                 .TextFileCommaDelimiter = False
                 .TextFileSpaceDelimiter = False
                 .TextFileColumnDataTypes = Array(1, 1, 1)
                 .TextFileTrailingMinusNumbers = True
                 .Refresh BackgroundQuery:=False
             End With
             
             Exit For
         End If
     Next i
     
     Set resul_zapros = Nothing
     
     For i = 1 To kolvo_files
         If arrOnlyHour(i) = "10" Then
             MyExcel.ActiveWorkbook.Sheets("Лист3").Select
             name_list(3) = "Основные показатели " & time_creatZamenadvoet(i)
             MyExcel.ActiveWorkbook.Sheets("Лист3").Name = name_list(3)
           
             Chas_sozd(3) = arrTimeCreation(i) 'Час создания по порядку
            connect = "TEXT;" & arrPutFile(i) 'Строка для запроса connect, которая говорит что это TEXT - текстовый файл и
            'путь к файлу
            Set resul_zapros = MyExcel.ActiveSheet.QueryTables.Add(Connection:= _
             connect, _
             Destination:=MyExcel.ActiveSheet.Range("A1"))
     
             With resul_zapros
                 .Name = name_list(1)
                 .FieldNames = True
                 .RowNumbers = False
                 .FillAdjacentFormulas = False
                 .PreserveFormatting = True
                 .RefreshOnFileOpen = False
                 .RefreshStyle = xlInsertDeleteCells
                 .SavePassword = False
                 .SaveData = True
                 .AdjustColumnWidth = True
                 .RefreshPeriod = 0
                 .TextFilePromptOnRefresh = False
                 .TextFilePlatform = -535
                 .TextFileStartRow = 1
                 .TextFileParseType = xlDelimited
                 .TextFileTextQualifier = xlTextQualifierDoubleQuote
                 .TextFileConsecutiveDelimiter = True
                 .TextFileTabDelimiter = True
                 .TextFileSemicolonDelimiter = True
                 .TextFileCommaDelimiter = False
                 .TextFileSpaceDelimiter = False
                 .TextFileColumnDataTypes = Array(1, 1, 1)
                 .TextFileTrailingMinusNumbers = True
                 .Refresh BackgroundQuery:=False
             End With
             
             Exit For
         End If
     Next i
     
     Set resul_zapros = Nothing
     
     'Удалить файлы csv по заданному пути
   
'     For i = 1 To kolvo_files
'        Kill (arrPutFile(i))
'     Next i

    MyDate = Replace(MyDate, ".", "_")
    nazv_list_File = "Основные показатели " & MyDate 'Название для листа и имени файла с временем создания
   MyExcel.ActiveWorkbook.Sheets(name_list(3)).Select 'Выбираем 3-ий лист
   MyExcel.ActiveWorkbook.Sheets.Add 'Добавляем новый лист
   MyExcel.ActiveWorkbook.Sheets("Лист4").Select 'Выбираем созданный лист
   MyExcel.ActiveWorkbook.Sheets("Лист4").Move After:=MyExcel.ActiveWorkbook.Sheets(name_list(3)) 'Передвигаем созданный лист
   'в конец через все листы
   MyExcel.ActiveWorkbook.Sheets("Лист4").Name = nazv_list_File 'Именуем новый лист названием и временем создания
   Set nash_list = MyExcel.ActiveWorkbook.Sheets(nazv_list_File) 'Устанавливаем объект nash_list как лист "Основные пок-ли" в
   'активной книге
   'Для всех остальных листов тоже вводим их объекты, чтобы к ним обращаться
   Set list_1 = MyExcel.ActiveWorkbook.Sheets(name_list(1))
    Set list_2 = MyExcel.ActiveWorkbook.Sheets(name_list(2))
    Set list_3 = MyExcel.ActiveWorkbook.Sheets(name_list(3))
   
    'СОЗДАЕМ ШАБЛОН ЛИСТА КУДА БУДЕМ ПОМЕЩАТЬ ЗНАЧЕНИЯ С ДРУГИХ ЛИСТОВ
   With nash_list
        .Columns("A:A").ColumnWidth = 12
        With .Range("A1:A2") '.Selection
           .HorizontalAlignment = -4108 'Выравнивание по горизонтали в ячейке
           .VerticalAlignment = -4117 'Выравнивание по вертикали в объединенной ячейке
           .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = -5002
            .MergeCells = True  'Здесь атрибут .mergecells = true - объединить ячейки
           .FormulaR1C1 = "Показатель"
        End With
       
        .Columns("B:B").ColumnWidth = 12
        With .Range("B1:B2") '.Selection
           .HorizontalAlignment = -4108 'Выравнивание по горизонтали в ячейке
           .VerticalAlignment = -4117 'Выравнивание по вертикали в объединенной ячейке
           .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = -5002
            .MergeCells = True  'Здесь атрибут .mergecells = true - объединить ячейки
           .FormulaR1C1 = "Единица измерения"
        End With
       
        With .Range("C1:D1")
            .HorizontalAlignment = -4108
            .VerticalAlignment = -4117
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = -5002
            .MergeCells = True
            .FormulaR1C1 = "Замер в " & Chas_sozd(1)
        End With
       
        With .Range("E1:F1")
            .HorizontalAlignment = -4108
            .VerticalAlignment = -4117
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = -5002
            .MergeCells = True
            .FormulaR1C1 = "Замер в " & Chas_sozd(2)
        End With
       
        With .Range("C2")
            .HorizontalAlignment = -4108
            .VerticalAlignment = -4117
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = -5002
            .MergeCells = False
            .FormulaR1C1 = "Норматив"
        End With
       
        With .Range("D2")
            .HorizontalAlignment = -4108
            .VerticalAlignment = -4117
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = -5002
            .MergeCells = False
            .FormulaR1C1 = "Факт"
        End With
       
        With .Range("E2")
            .HorizontalAlignment = -4108
            .VerticalAlignment = -4117
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = -5002
            .MergeCells = False
            .FormulaR1C1 = "Норматив"
        End With
       
        With .Range("F2")
            .HorizontalAlignment = -4108
            .VerticalAlignment = -4117
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = -5002
            .MergeCells = False
            .FormulaR1C1 = "Факт"
        End With
    End With
   
   
   
    'Копируем данные с 3х листов
   'в наш лист
       
    'Для 1-го листа
   For i = 3 To 5 'Для строк в копируемый лист
       j = i + 8
        nash_list.Range("A1:D100").Cells(i, 4) = list_1.Range("A1:D100").Cells(j, 4)
        '[Диап_Наш_лист].Cells(i, 4) = [Диапазон_ЛИСТ1].Cells(j, 4)
   Next i
   
    'Для 2-го листа
   For i = 3 To 5 'Для строк в копируемый лист
       j = i + 8
        nash_list.Range("A1:D100").Cells(i, 6) = list_2.Range("A1:D100").Cells(j, 4)
        '[Диап_Наш_лист].Cells(i, 4) = [Диапазон_ЛИСТ1].Cells(j, 4)
   Next i
   
    'Удаляем листы кроме скомпанованного листа
   With MyExcel.ActiveWorkbook
        For i = 1 To 3
            MyExcel.DisplayAlerts = False
            .Sheets(name_list(i)).Delete
            MyExcel.DisplayAlerts = True
        Next i
    End With
   
    direct_save = "D:install games"
    direct_and_nameFile = direct_save & "" & nazv_list_File & ".xls"
   
    'Обязательно сохранять файлы ТОЛЬКО В РАЗНЫЕ ДНИ ИНАЧЕ ИМЯ БУДЕТ СОВПАДАТЬ НАПРИМЕР В 23:50:00 КАЖДЖЫЙ ДЕНЬ
   ChDir direct_save 'Здесь нужно прописать директорию куда будем сохранять данный файл
   MyExcel.ActiveWorkbook.SaveAs FileName:=direct_and_nameFile, FileFormat:= _
        -4143, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
        , CreateBackup:=False
       
    MyExcel.ActiveWorkbook.Close
    MyExcel.Quit
   
    Set list_1 = Nothing
    Set list_2 = Nothing
    Set list_3 = Nothing
    Set MyExcel = Nothing
    Set nash_list = Nothing
   
    Unload Form1
End Sub
  • Перед вопросом пишите: Среда разработки... Среда исполнения... от OldProcessor, 25 октября 2016 года

Знаете кого-то, кто может ответить? Поделитесь с ним ссылкой.

Ваш ответ

Реклама на сайте | Обмен ссылками | Ссылки | Экспорт (RSS) | Контакты
Добавить статью | Добавить исходник | Добавить хостинг-провайдера | Добавить сайт в каталог