VPF::Как сделать программу фоновой ?

XPurple

Дата 22.5.2006, 12:55 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 140
Регистрация: 4.5.2006
Где: Челябинск

Репутация: 1
Всего: 1

Akina

Код


Public Sub WriteListDir()

If fso.FolderExists(sourceDir) Then
Set fold = fso.GetFolder(sourceDir)
otf2.Write "Файлы в " & sourceDir & vbCrLf
dirListStatus = FileTree(fold)
'otf2.Close

Else
'msg = MsgBox("Папка " & sFile & " не найдена", vbInformation, "Результат")
End If

End Sub

Public Function ListFile(ByRef folder As Object) As String

For Each vfile In folder.Files
otf2.Write Chr(124) + String(6, 151) + Chr(62)
otf2.Write (vfile.Name) & vbCrLf
Next

End Function


Public Function FileTree(ByVal fold1 As folder) As String
'Public Function FileTree(ByVal fold1 As object) As String

For Each vdir In fold1.SubFolders
otf2.Write Chr(124) + String(3, 151) + Chr(62)
otf2.Write UCase(vdir.Name) & vbCrLf
FileTree = FileTree(vdir)
Next

msg = ListFile(fold1)
End Function

Это сообщение отредактировал(а) XPurple - 22.5.2006, 13:02

--------------------

Кто никогда ни о чем не спрашивает: тот либо знает все, либо не знает ничего. Не помню, кто сказал, может быть, я (с)

Akina

Дата 22.5.2006, 14:08 (ссылка)

(нет голосов)

Загрузка ...

Советчик

Профиль
Группа: Модератор
Сообщений: 20581
Регистрация: 8.4.2004
Где: Зеленоград

Репутация: 34
Всего: 454

А что есть otf2? файл вывода? как открыт?

Думаю, именно тут источник проблем... попробуй кластеризовать вывод, типа такого:

Код


Const FlushPortion as long = 65536&
buffer = ""
FileHandle = FreeFile
Open FileName$ For Output As #FileHandle
...
buffer = buffer & NextDataToWrite
call FlushBuffer(buffer, FileHandle, False)
...
call FlushBuffer(buffer, FileHandle, True)
Close #FileHandle

...

Sub FlushBuffer(ByVal buffer as string, FileHandle as long, Done as boolean)
if Done then
   write #FileHandle, buffer;
   buffer = ""
ElseIf Len(buffer)>FlushPortion Then
   write #FileHandle, left(buffer, FlushPortion);
   buffer = mid(buffer, FlushPortion+1)
End If
end sub

--------------------

О(б)суждение моих действий - в соответствующей теме, пожалуйста. Или в РМ. И высшая инстанция - Администрация форума.

XPurple

Дата 22.5.2006, 14:23 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 140
Регистрация: 4.5.2006
Где: Челябинск

Репутация: 1
Всего: 1

Akina
Вся программа

Код


Option Explicit
Const ForReading = 1, ForWriting = 2, ForAppending = 8
'Const IDLE_PRIORITY_CLASS = &H40
Dim fso, otf, gf, otf2 As Object
Dim fso1 As New FileSystemObject
Dim sourceDir, FileTreeFileName As String
Dim msg
Dim ConfFile, ResultFile, ResultDir As String
Dim confFileExist As Boolean
Dim fold As Object
Dim vfile As Object
Dim vdir As Object
Dim dirListStatus As String
Dim permissionFile As Boolean
Dim retval As Integer


Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function SetPriorityClass Lib "kernel32" (ByVal hProcess As _
Long, ByVal dwPriorityClass As Long) As Long
Private Declare Function GetPriorityClass Lib "kernel32" (ByVal hProcess As _
Long) As Long

Public Enum Priority
   IDLE_PRIORITY_CLASS = &H40
   NORMAL_PRIORITY_CLASS = &H20
   HIGH_PRIORITY_CLASS = &H80
   REALTIME_PRIORITY_CLASS = &H100
End Enum

Public Sub SetPriority(pParam As Priority)
   SetPriorityClass GetCurrentProcess(), pParam
End Sub




Private Sub Form_Load()
SetPriority (IDLE_PRIORITY_CLASS)

ConfFile = "filetree.ini"
confFileExist = ReadConfFile()
'ResultFile = ResultDir & "\" & FileTreeFileName
ResultFile = ResultDir & FileTreeFileName

On Error GoTo CheckError ' Turn on error handling.
    If confFileExist And fso.FolderExists(ResultDir) Then
    Set otf2 = fso.OpenTextFile(ResultFile, ForWriting, True)
    WriteListDir
    
    
    otf2.Close
    Else
    'msg = MsgBox("Файл resultDir" & fso.FolderExists(ResultDir) & " существует", vbInformation, "Результат")
    End If
 
CheckError:
permissionFile = PermissionAccess()

  End
End Sub

Public Function ReadConfFile() As Boolean

   Set fso = CreateObject("Scripting.FileSystemObject")
   If (fso.FileExists(ConfFile)) Then
        Set otf = fso.OpenTextFile(ConfFile, ForReading, True)
      Set gf = fso.GetFile(ConfFile)
             If gf.Size > 0 Then
           
             sourceDir = SelectString(otf, True)
             ResultDir = SelectString(otf, True)
             FileTreeFileName = SelectString(otf, False)
             'FileTreeFileName = SelectString(9)
             'otf.Skip (12)
             'ResultDir = otf.ReadLine()
             'otf.Skip (9)
             'FileTreeFileName = otf.ReadLine()
             
             'msg = MsgBox("Файл sFile" & ConfFile & " существует", vbInformation, "Результат")
             ReadConfFile = True
             'msg = MsgBox("Файл " & ConfFile & " нормальный", vbInformation, "Результат")
              Else
            'msg = MsgBox("Файл " & ConfFile & " пустой", vbInformation, "Результат")
            ReadConfFile = False
            
            End If
          otf.Close
    Else
      'msg = MsgBox("Файл " & ConfFile & " не найден", vbInformation, "Результат")
   End If
End Function

Public Sub WriteListDir()

If fso.FolderExists(sourceDir) Then
Set fold = fso.GetFolder(sourceDir)
otf2.Write "Файлы в " & sourceDir & vbCrLf
dirListStatus = FileTree(fold)
'otf2.Close
Else
'msg = MsgBox("Папка " & sFile & " не найдена", vbInformation, "Результат")
End If
End Sub

Public Function PermissionAccess() As Boolean
Const conErrPermissionDenied = 70
    If (Err.Number = conErrPermissionDenied) Then
    PermissionAccess = False
    'msg = MsgBox("Файл " & ResultFile & " не доступен", vbInformation, "Результат")
    Else
    'msg = MsgBox("Файл " & ResultFile & " доступен", vbInformation, "Результат")
    
    PermissionAccess = True
      End If
End Function

Public Function ListFile(ByRef folder As Object) As String

For Each vfile In folder.Files
otf2.Write Chr(124) + String(6, 151) + Chr(62)
otf2.Write (vfile.Name) & vbCrLf
Next

End Function


Public Function FileTree(ByVal fold1 As folder) As String
'Public Function FileTree(ByVal fold1 As object) As String
For Each vdir In fold1.SubFolders
otf2.Write Chr(124) + String(3, 151) + Chr(62)
otf2.Write UCase(vdir.Name) & vbCrLf
FileTree = FileTree(vdir)
Next
msg = ListFile(fold1)
End Function



Public Function SelectString(ByVal openReadConf As Object, ByVal CheckSlash As Boolean) _
As String
Dim valTemp As String
Dim position As Integer

valTemp = openReadConf.ReadLine()
position = InStr(1, valTemp, "=", vbTextCompare)
valTemp = Right(valTemp, Len(valTemp) - position)
'MsgBox valTemp

If Right(valTemp, 1) <> "\" And CheckSlash Then
SelectString = valTemp + "\"
Else
SelectString = valTemp
End If
End Function

Это сообщение отредактировал(а) XPurple - 22.5.2006, 14:24

--------------------

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| VB6 \| Следующая тема »