Открытие формы до завершения Form_Load (новый вопрос)

[Vasiliy8338]

Продолжение темы
http://bbs.vbstreets.xian.ru/viewtopic.php?f=1&t=37379

Код: Выделить всё

Public TmpPath As String, CMS$
Dim ScanName As Integer, ScanCoding As Integer, ScanSrvPassive As Integer, ScanSaveLog As Integer, _
        ScanMin As Long, ScanSumChk As Integer, ScanSumSet$, ScanURL$, ScanArchive$, ScanLogURL$
Dim ScanFTPLogin$, ScanFTPPass$, ScanFTPSrv$, ScanFTPFolder$
'ФУНКЦИИ РАБОТЫ С FTP-СЕРВЕРОМ
'указание интернет-протокола
    Private Const INTERNET_SERVICE_FTP = 1


'функция открытия интернет-соединения
Private Declare Function InternetOpen _
    Lib "wininet.dll" Alias "InternetOpenA" ( _
    ByVal sAgent As String, _
    ByVal nAccessType As Long, _
    ByVal sProxyName As String, _
    ByVal sProxyBypass As String, _
    ByVal nFlags As Long) As Long


'функция соединения с интернетом
Private Declare Function InternetConnect _
    Lib "wininet.dll" Alias "InternetConnectA" ( _
    ByVal hInternetSession As Long, _
    ByVal sServerName As String, _
    ByVal nServerPort As Integer, _
    ByVal sUserName As String, _
    ByVal sPassword As String, _
    ByVal nService As Long, _
    ByVal dwFlags As Long, _
    ByVal dwContext As Long) As Long

'выгрузка на FTP
Private Declare Function FtpPutFile _
    Lib "wininet.dll" Alias "FtpPutFileA" ( _
    ByVal hFtpSession As Long, _
    ByVal lpszLocalFile As String, _
    ByVal lpszRemoteFile As String, _
    ByVal dwFlags As Long, _
    ByVal dwContext As Long) As Boolean

'закрытие соединения с FTP
Private Declare Function InternetCloseHandle _
    Lib "wininet.dll" (ByVal hInet As Long) As Integer


'ФУНКЦИИ ДЛЯ РАБОТЫ С РЕЕСТРОМ
Private Const REG_SZ = 1

Public Enum HKEY_CONSTANTS
    HKEY_CLASSES_ROOT = &H80000000
    HKEY_CURRENT_CONFIG = &H80000005
    HKEY_CURRENT_USER = &H80000001
    HKEY_DYN_DATA = &H80000006
    HKEY_LOCAL_MACHINE = &H80000002
    HKEY_PERFORMANCE_DATA = &H80000004
    HKEY_USERS = &H80000003
End Enum

'Чтение значения из реестра
Private Declare Function RegQueryValueExS Lib "advapi32.dll" _
    Alias "RegQueryValueExA" ( _
    ByVal hkey As Long, _
    ByVal lpValueName As String, _
    ByVal lpReserved As Long, _
    lpType As Long, _
    ByVal lpData As String, _
    lpcbData As Long) As Long
   
'Запись значения в реестр
Private Declare Function RegSetValueExS Lib "advapi32.dll" _
    Alias "RegSetValueExA" ( _
    ByVal hkey As Long, _
    ByVal lpValueName As String, _
    ByVal Reserved As Long, _
    ByVal dwType As Long, _
    ByVal lpData As String, _
    ByVal cbData As Long) As Long

'открытие реестра для чтения/записи
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 RegCloseKey Lib "advapi32.dll" ( _
    ByVal hkey As Long) As Long

'создание ключа в реестре
Private Declare Function RegCreateKey Lib "advapi32.dll" _
    Alias "RegCreateKeyA" ( _
    ByVal hkey As Long, _
    ByVal lpSubKey As String, _
    phkResult As Long) As Long

'ФУНКЦИЯ ПОЛУЧЕНИЯ ЗНАЧЕНИЯ ИЗ РЕЕСТРА
Private Function GetString( _
    ByVal HomeKey As HKEY_CONSTANTS, _
    ByVal KeyName As String, _
    ByVal ValueName As String) As String

    'Handle раздела реестра
    Dim hkey As Long
    'переменная для хранения значения
    Dim sData As String
    'Результат работы API функций
    Dim lres As Long
    'Тип возвращаемого значения
    Dim lDataType As Long
    'переменная для хранения длины строки
    Dim lDlen As Long
   
    'Открываем Раздел
    lres = RegOpenKey(HomeKey, KeyName, hkey)
   
    'Если вернулся не ноль - ошибка, выходим
    If lres <> 0 Then
        lres = RegCloseKey(hkey)
        GetString = vbNullString: Exit Function
    End If
   
    'Продолжаем, заполняем строку пробелами.
    sData = String$(64, 32) & Chr$(0)
    lDlen = Len(sData)
    'Читаем значение
    lres = RegQueryValueExS(hkey, ValueName, 0, lDataType, sData, lDlen)
   
    'опять проверка на ошибку
    If lres <> 0 Then
        GetString = vbNullString: Exit Function
    End If
   
    'проверяем тип полученных данных
    If lDataType = REG_SZ Then
        GetString = Left$(sData, lDlen - 1)
    Else:
        GetString = vbNullString
    End If
   
    'и закрываем раздел
    lres = RegCloseKey(hkey)
   
End Function

'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'ФУНКЦИЯ ИЗМЕНЕНИЯ КОДИРОВКИ
Private Function StringConvert(ByVal strSrc As String, ByVal nFromCP As Long, ByVal nToCP As Long) As String
    Dim nLen As Long
    Dim strDst As String
    Dim strRet As String
    Dim nRet As Long
   
    nLen = Len(strSrc)
    strDst = String(nLen * 2, Chr(0))
    strRet = String(nLen * 2, Chr(0))
    nRet = MultiByteToWideChar(nFromCP, MB_PRECOMPOSED, strSrc, nLen, strDst, nLen)
    nRet = WideCharToMultiByte(nToCP, 0, strDst, nRet, strRet, nLen * 2, ByVal 0, 0)
    StringConvert = Left(strRet, nRet)
'Значения для кодировок:
'0) Win-1251 - 1251
'1) KOI8-R - 20866
'2) KOI8-U - 21866
'3) Unicode UTF-7 - 65000
'4) Unicode UTF-8 - 65001
'5) ISO-8859-5 - 28595
'6) DOS Cyr - 866
'7) MAC Cyr 2000 - 10007

End Function
Private Function nasDirExists(strPathName As String) As Boolean
    On Error Resume Next
    Dim strDir As String
   
    strDir = Dir(strPathName, vbDirectory)
    If (Len(strDir) = 0 Or Err = 76) Then
        nasDirExists = False
    Else:
        nasDirExists = True
    End If
End Function
Private Function ReadURL(ByVal URL4Read As String)
    Dim i%, URLLen%, CurURL$
    URLLen = Len(URL4Read)
    CurURL = URL4Read
    For i = 1 To URLLen
        If Right(Left(CurURL, i), 1) = ":" Then
            ScanFTPLogin = Left(CurURL, i - 1)
            CurURL = Right(CurURL, URLLen - i)
            i = URLLen
        End If
    Next i
    URLLen = Len(CurURL)
    For i = 1 To URLLen
        If Right(Left(CurURL, i), 1) = "@" Then
            ScanFTPPass = Left(CurURL, i - 1)
            CurURL = Right(CurURL, URLLen - i)
            i = URLLen
        End If
    Next i
    URLLen = Len(CurURL)
    For i = 1 To URLLen
        If Right(Left(CurURL, i), 1) = "/" Then
            ScanFTPSrv = Left(CurURL, i - 1)
            ScanFTPFolder = Right(CurURL, URLLen - i)
            i = URLLen
        End If
    Next i
End Function

Private Sub Form_Activate()
DoEvents


    Dim FileNum As Integer 'задаем переменную (Номер файла для ввода-вывода)


    lblAppName.Caption = "Scan2FTP v" & App.Major & "." & App.Minor  'устанавливаем заголовок окна
    frFTP.Visible = False 'делаем фрейм по-умолчанию невидимым
   
    Dim CmdPath$, TodayTime$, YYYY$, MM$, DD$, HH$, MI$, SS$   'объявление переменных
    TodayTime = Now 'определение переменной (текущая дата)
    YYYY = Year(TodayTime) 'определение переменной (текущий год)
    MM = Month(TodayTime) 'определение переменной (текущий месяц)
    DD = Day(TodayTime) 'определение переменной (текущий день)
    HH = Hour(TodayTime) 'определение переменной (текущий час)
    MI = Minute(TodayTime) 'определение переменной (текущая минута)
    SS = Second(TodayTime) 'определение переменной (текущая секунда)
    If Len(MM) < 2 Then 'если месяц меньше 10, то добавляем в начале "0"
        MM = "0" & MM
    End If
    If Len(DD) < 2 Then 'если день меньше 10, то добавляем в начале "0"
        DD = "0" & DD
    End If
    If Len(HH) < 2 Then 'если час меньше 10, то добавляем в начале "0"
        HH = "0" & HH
    End If
    If Len(MI) < 2 Then 'если минута меньше 10, то добавляем в начале "0"
        MI = "0" & MI
    End If
    If Len(SS) < 2 Then 'если секунда меньше 10, то добавляем в начале "0"
        SS = "0" & SS
    End If
   
    If Dir(App.Path & "\s2f.dat") <> "s2f.dat" Then 'если не найден файл с настроками, то закрываем программу с сообщением об ошибке
        MsgBox "Не найден файл настроек." & Chr(10) & "Дальнейшая работа невозможна." _
        & Chr(10) & "Приложение будет закрыто.", vbCritical, "Ошибка"
        End
    End If
   
    CMS = GetString(HKEY_LOCAL_MACHINE, "Software\2FTP", "CMS")
   

        FileNum = FreeFile 'объявляем переменную (Номер файла для ввода-вывода)
        Open App.Path & "\s2f.dat" For Input As #FileNum

        Line Input #FileNum, ScanSumSet
        ScanSumSet = modCryptText.UnCryptText(ScanSumSet)
        If ScanSumSet = "UNCRYPTERROR" Then
                Close FileNum
                MsgBox "Критическая ошибка (321)!" & Chr(10) & "Дальнейшая работа невозможна." _
                & Chr(10) & "Приложение будет закрыто.", vbCritical, "Ошибка"
                End
        End If
        Line Input #FileNum, ScanPass
        ScanPass = modCryptText.UnCryptText(ScanPass)
        If ScanPass = "UNCRYPTERROR" Then
                Close FileNum
                MsgBox "Критическая ошибка (321)!" & Chr(10) & "Дальнейшая работа невозможна." _
                & Chr(10) & "Приложение будет закрыто.", vbCritical, "Ошибка"
                End
        End If
        ScanName = Left(ScanSumSet, 1)
        ScanCoding = Right(Left(ScanSumSet, 2), 1)
        ScanSrvPassive = Right(Left(ScanSumSet, 3), 1)
        ScanSaveLog = Right(Left(ScanSumSet, 4), 1)
        ScanMin = Right(Left(ScanSumSet, 7), 3)
        ScanSumChk = Right(Left(ScanSumSet, 10), 3)
        If ScanSumChk <> ScanName + ScanCoding + ScanSrvPassive + ScanSaveLog + ScanMin Then
                Close FileNum
                MsgBox "Критическая ошибка (321)!" & Chr(10) & "Дальнейшая работа невозможна." _
                & Chr(10) & "Приложение будет закрыто.", vbCritical, "Ошибка"
                End
        End If
       
        Line Input #FileNum, ScanURL
        ScanURL = modCryptText.UnCryptText(ScanURL)
        If ScanURL = "UNCRYPTERROR" Then
                Close FileNum
                MsgBox "Критическая ошибка (321)!" & Chr(10) & "Дальнейшая работа невозможна." _
                & Chr(10) & "Приложение будет закрыто.", vbCritical, "Ошибка"
                End
        End If
        Line Input #FileNum, ScanArchive
        ScanArchive = modCryptText.UnCryptText(ScanArchive)
        If ScanArchive = "UNCRYPTERROR" Then
                Close FileNum
                MsgBox "Критическая ошибка (321)!" & Chr(10) & "Дальнейшая работа невозможна." _
                & Chr(10) & "Приложение будет закрыто.", vbCritical, "Ошибка"
                End
        End If
   
        If ScanSaveLog = 1 Then
            Line Input #FileNum, ScanLogURL
            ScanLogURL = modCryptText.UnCryptText(ScanLogURL)
            If ScanLogURL = "UNCRYPTERROR" Then
                Close FileNum
                MsgBox "Критическая ошибка (321)!" & Chr(10) & "Дальнейшая работа невозможна." _
                & Chr(10) & "Приложение будет закрыто.", vbCritical, "Ошибка"
                End
            End If
        End If
       
        Close FileNum
   
    CmdPath = Command
   
    'определение переменных (путь к сканированному файлу)
    If ScanName = 1 Then
        addData.Show 1
        TmpPath = App.Path & "\tmp\tmp_" & TmpPath
    Else:
        TmpPath = App.Path & "\tmp\tmp_" & CMS & "_" & YYYY & MM & DD & "_" & HH & MI & SS & _
        ".jpg" 'определение переменных (путь к временному файлу)
    End If


    If nasDirExists(App.Path & "\tmp\") = False Then 'если нет папки временных файлов, то создаем ее
        MkDir (App.Path & "\tmp\")
    End If
   

   
    If CmdPath = vbNullString Then 'если командная строка пустая, то проверяем неотправленные файлы
        If Dir(App.Path & "\tmp\tmp_*.jpg") <> "" Then 'если есть неотправленные файлы, то пытаемся их отправить без вопросов
        lblStatus.Caption = "Найдены неотправленные файлы."
            While Dir(App.Path & "\tmp\tmp_*.jpg") <> ""
                lblFTP.Caption = "Отправляется файл " & Dir(App.Path & "\tmp\tmp_*.jpg") & "..."
                Call SendScan(App.Path & "\tmp\" & Dir(App.Path & "\tmp\tmp_*.jpg"))
            Wend
        Else: 'иначе закрываем программу с сообщением об отсутствии скана и неотправленных файлов
            MsgBox "Сканирование не производилось." & Chr(10) & "Неотправленных файлов не найдено." _
            & Chr(10) & "Приложение будет закрыто.", vbInformation, "Scan2FTP v" & App.Major & "." & App.Minor
            End
        End If
    Else:
        CmdPath = Left(CmdPath, Len(CmdPath) - 1)
        CmdPath = Right(CmdPath, Len(CmdPath) - 1)
        If Right(Dir(CmdPath), 4) <> ".jpg" Then 'если не найден файл скана, то закрываем программу с сообщением об ошибке
            MsgBox "Сканер передал неверный путь," & Chr(10) & "или файл имеет неверный формат." _
            & Chr(10) & "Приложение будет закрыто.", vbCritical, "Ошибка получения файла"
            End
        End If
        Dim Chislo As Long
        Chislo = 1024 * ScanMin
        If FileLen(CmdPath) < Chislo Then
            MsgBox "Минимальный допустимый размер файла: " & ScanMin & " КБ." & Chr(10) & _
            "Увеличьте разрешение и повторите попытку.", vbCritical, "Ошибка размера файла"
            Kill CmdPath
            End
        End If
        If FileLen(CmdPath) > 307200 Then
            Kill CmdPath
            MsgBox "Максимальный допустимый размер файла: 300 КБ." & Chr(10) & _
            "Уменьшите разрешение и повторите попытку.", vbCritical, "Ошибка размера файла"
            End
        End If
        FileCopy CmdPath, TmpPath
        Kill CmdPath
        lblStatus.Caption = "Файл от сканера получен. Идет отправка..."
        Call SendScan(TmpPath)
        If Dir(App.Path & "\tmp\tmp_*.jpg") <> "" Then 'если есть неотправленные файлы, то пытаемся их отправить без вопросов
            lblStatus.Caption = "Найдены неотправленные файлы."
            While Dir(App.Path & "\tmp\tmp_*.jpg") <> ""
                lblFTP.Caption = "Отправляется файл " & Dir(App.Path & "\tmp\tmp_*.jpg") & "..."
                Call SendScan(App.Path & "\tmp\" & Dir(App.Path & "\tmp\tmp_*.jpg"))
            Wend
        End If
    End If
MsgBox "Отправка завершена.", vbInformation, "Сообщение"
End
End Sub

Private Sub cmdFTP_Click()
    End
End Sub
'функция отправки скана
Private Function SendScan(ByVal FileFrom As String)
DoEvents

    'переменные работы с ФТП-сервером
    Dim hInetSession As Variant, hSession As Variant
    Dim FTPPath$, FTPMode$

   
        frFTP.Visible = True
        lblFTP.Caption = "Установка связи с сервером..."
        progFTP.Value = 10
    'разбираем ссылку для сканов на логин, пароль, сервер, папку
    Call ReadURL(ScanURL)
    'задаем путь к файлу скана на ФТП
    FTPPath = ScanFTPFolder & Right(Dir(FileFrom), Len(Dir(FileFrom)) - 4)
        progFTP.Value = 20
        'меняем кодировку путей в соответствии с настройками
    If ScanCoding = 1 Then
        FTPPath = StringConvert(FileFrom, 1251, 20866)
    End If
    If ScanCoding = 2 Then
        FTPPath = StringConvert(FileFrom, 1251, 21866)
    End If
    If ScanCoding = 3 Then
        FTPPath = StringConvert(FileFrom, 1251, 65000)
    End If
    If ScanCoding = 4 Then
        FTPPath = StringConvert(FileFrom, 1251, 65001)
    End If
    If ScanCoding = 5 Then
        FTPPath = StringConvert(FileFrom, 1251, 28595)
    End If
    If ScanCoding = 6 Then
        FTPPath = StringConvert(FileFrom, 1251, 866)
    End If
    If ScanCoding = 7 Then
        FTPPath = StringConvert(FileFrom, 1251, 10007)
    End If
    lblFTP.Caption = "Открываем соединение с Интернетом..."
    progFTP.Value = 30
   
    hInetSession = InternetOpen("MyFTPClient", 0, vbNullString, vbNullString, 0)
    If ScanSrvPassive = 1 Then
        FTPMode = "&H8000000"
    Else:
        FTPMode = "0"
    End If
    lblFTP.Caption = "Соединение с Интернетом открыто."
    progFTP.Value = 40
    lblFTP.Caption = "Устанавливаем соединение с FTP-сервером..."
   
    hSession = InternetConnect(hInetSession, ScanFTPSrv, "21", ScanFTPLogin, ScanFTPPass, 1, FTPMode, 1)
    If hSession = 0 Then
        progFTP.Value = 0
        Call InternetCloseHandle(hSession)
        Call InternetCloseHandle(hInetSession)
        MsgBox "Не удалось установить соединение с FTP-сервером." _
        & Chr(10) & "Попробуйте повторить позднее или обратитесь в техподдержку.", vbCritical, "Ошибка связи": End
    End If
    progFTP.Value = 50
    lblFTP.Caption = "Соединение с сервером установлено."
    Dim SendFile As Boolean
    SendFile = FtpPutFile(hSession, FileFrom, FTPPath, 2, 1)
    If SendFile = False Then
        progFTP.Value = 0
        Call InternetCloseHandle(hSession)
        Call InternetCloseHandle(hInetSession)
        MsgBox "Соединение с сервером было установлено," & Chr(10) & _
        "но файл скопировать не удалось." & Chr(10) & _
        "Обратитесь за помощью в техподдержку.", vbCritical, "Ошибка копирования": End
    End If
    Call InternetCloseHandle(SendFile)
    Call InternetCloseHandle(hSession)
    Call InternetCloseHandle(hInetSession)
    'если стоит опция сохранения логов, то проделываем опять все для лог-файла
    If ScanSaveLog = 1 Then
        progFTP.Value = 60
        Dim ScanLogName$, LogFileNum As Integer
        LogFileNum = FreeFile
        ScanLogName = Left(Right(Dir(FileFrom), Len(Dir(FileFrom)) - 4), Len(Right(Dir(FileFrom), Len(Dir(FileFrom)) - 4)) - 4)
        Open App.Path & "\tmp\" & ScanLogName For Output As #LogFileNum
        Close #LogFileNum
        Open App.Path & "\tmp\" & ScanLogName For Output As #LogFileNum
        Close #LogFileNum
        Call ReadURL(ScanLogURL)
        FTPPath = ScanFTPFolder & ScanLogName
        progFTP.Value = 70
        'меняем кодировку путей в соответствии с настройками
        If ScanCoding = 1 Then
            FTPPath = StringConvert(FileFrom, 1251, 20866)
        End If
        If ScanCoding = 2 Then
            FTPPath = StringConvert(FileFrom, 1251, 21866)
        End If
        If ScanCoding = 3 Then
            FTPPath = StringConvert(FileFrom, 1251, 65000)
        End If
        If ScanCoding = 4 Then
            FTPPath = StringConvert(FileFrom, 1251, 65001)
        End If
        If ScanCoding = 5 Then
            FTPPath = StringConvert(FileFrom, 1251, 28595)
        End If
        If ScanCoding = 6 Then
            FTPPath = StringConvert(FileFrom, 1251, 866)
        End If
        If ScanCoding = 7 Then
            FTPPath = StringConvert(FileFrom, 1251, 10007)
        End If
        lblFTP.Caption = "Открываем соединение с Интернетом..."
        progFTP.Value = 80
       
        hInetSession = InternetOpen("MyFTPClient", 0, vbNullString, vbNullString, 0)
        If ScanSrvPassive = 1 Then
            FTPMode = "&H8000000"
        Else:
            FTPMode = "0"
        End If
        progFTP.Value = 90
       
        hSession = InternetConnect(hInetSession, ScanFTPSrv, "21", ScanFTPLogin, ScanFTPPass, 1, FTPMode, 1)
        If hSession = 0 Then
            progFTP.Value = 100
            Call InternetCloseHandle(hSession)
            Call InternetCloseHandle(hInetSession)
            MsgBox "Сканированная копия была успешно отправлена." _
            & Chr(10) & "Лог-файл отправить не удалось.", vbExclamation, "Ошибка связи": End
        End If
        progFTP.Value = 90
        lblFTP.Caption = "Соединение с сервером установлено."
        Dim SendLogFile As Boolean
        SendLogFile = FtpPutFile(hSession, FileFrom, FTPPath, 2, 1)
        If SendFile = False Then
            progFTP.Value = 100
            Call InternetCloseHandle(hSession)
            Call InternetCloseHandle(hInetSession)
            MsgBox "Сканированная копия была успешно отправлена." & Chr(10) & _
            "Лог-файл отправить не удалось.", vbExclamation, "Ошибка копирования": End
        End If
        Call InternetCloseHandle(hSession)
        Call InternetCloseHandle(hInetSession)
        Kill App.Path & "\tmp\" & ScanLogName
    End If
    If nasDirExists(ScanArchive) = False Then 'если нет папки временных файлов, то создаем ее
        MkDir (ScanArchive)
    End If
    ScanArchive = ScanArchive & Right(Dir(FileFrom), Len(Dir(FileFrom)) - 4)
    FileCopy FileFrom, ScanArchive
    Kill FileFrom
    lblFTP.Caption = "Отправка завершена."
    lblStatus.Caption = "Файл " & Dir(Right(TmpPath, Len(TmpPath) - 4)) & " успешно отправлен."
    progFTP.Value = 100
End Function




Есть такой вот код. При завершении работы приложения (процедура Form_Activate()) программа зависает и все.
Иногда получается запустить ее 1 раз, но потом она снова виснет при завершении работы. Из VB все работает нормально.

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

[Хакер]

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

Ох...

Чтобы руччкий "вставлялся", надо чтобы при копировании из VB6IDE была включена русская раскладка клавиатуры.

[Vasiliy8338]

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

Ох...

Чтобы руччкий "вставлялся", надо чтобы при копировании из VB6IDE была включена русская раскладка клавиатуры.

Спасибо за подсказку
Исправил.

[Viper]

Vasiliy8338, в данном случае стоило вместо портянки кода приложить файл с проектом, оставив в нем только нужное.

[Денис]

Vasiliy8338
1. Не вижу нигде выгрузку формы. (Unload Me)
2. Все настоятельнее рекомендую переходить на запуск из модуля (из процедуры Main), например:

Код: Выделить всё

'Модуль1 (код)

Sub Main()

'Так можно назвать форму, которую ты будешь показывать.
   Dim frmStatus as frmStatusForm
   set frmStatus = new frmStatusform

'здесь идет твой код до загрузки формы

'теперь загружаешь форму для показа счетчиков и прогресса

   load frmStatus
   frmStatus.Show 'owner и modal работают и отсюда.

'далее идет опять твой код, где ты обращаешься к форме не через me а через frmStatus, ну или то название, которое ты дашь.

'теперь, чтобы прога не висела в памяти, ты уничтожаешь окно:
   unload frmStatus
   set frmStatus = Nothing

End Sub

[Viper]

Vasiliy8338, выкинь нафиг End отовсюду. Поставь DoEvents туда, где он идолжен быть (т.е. в тело цикла). Далее, следуй советам предыдущего оратора, т.е. код в Sub Main.
З.Ы. И вообще сей код надо вдумчиво переписать, ибо в данном варианте это ужас, ужас и еще раз ужас.

[Vasiliy8338]

З.Ы. И вообще сей код надо вдумчиво переписать, ибо в данном варианте это ужас, ужас и еще раз ужас.

В курсе, но когда задача ставится формулировкой "надо срочно", а ты администратор, а не программист... приходится делать так. Странно, что он вообще работает!

[Viper]

Странно, что он вообще работает!

Я бы сказал, что он вообще не должен работать.

[Vasiliy8338]

Странно, что он вообще работает!

Я бы сказал, что он вообще не должен работать.

задача настолько узкая, что массового и везде работающего решения не требуется. а ошибки буду потом исправлять по мере их поступления (за неимением опыта, чтобы исправлять их сразу при написании).

Vasiliy8338
1. Не вижу нигде выгрузку формы. (Unload Me)
2. Все настоятельнее рекомендую переходить на запуск из модуля (из процедуры Main), например:

1) Там стоит End.
2) Попробывал данную схему - результат абсолютно такой же. Первый раз все закрылось, далее опять висит в процессах.

[Денис]

1) Там стоит End.
2) Попробывал данную схему - результат абсолютно такой же. Первый раз все закрылось, далее опять висит в процессах.

1. Никаких End'ов. Должна быть явная выгрузка (Unload) всех экземпляров объектов по порядку. Желательно и уничтожать ссылки на них (Set = Nothing).
2. Результат такой же из-за пункта 1. Кури мануалы по ООП. Ты мыслишь категориями QBasic'a.
_________________
Смысл в том, что у тебя должна программа работать вообще без форм. Запускается модуль, процедура Main, начинает работать, устанавливает все необходимые соединения, и только когда появляется необходимость ты ЯВНО создаешь экземпляр формы, загружаешь его (САМ!) и показываешь на экране.
Уж не думаешь ли ты, что у таких продуктов, как, например, менеджеры закачек, логика программы реализована в формах??

[Vasiliy8338]

Ты мыслишь категориями QBasic'a.

не знаю что это, а потому не могу мыслить его категориями

Методом тыка (пихал Unload в разные части кода) выяснил, что не закрывается хэндл hSession, т.е. не получается закрыть соединение с FTP-сервером. Хотя тот же Anvir Task Manager на данное FTP-соединение , пишет "закрыто локальной программой".

[Денис]

Методом тыка (пихал

Это ведь не твой код, да? Ты его скопипастил еще откуда-то, да?
Ну потыкай еще вот этим

Код: Выделить всё

hSession = Nothing

Авось сработает.

[Vasiliy8338]

Это ведь не твой код, да? Ты его скопипастил еще откуда-то, да?
Ну потыкай еще вот этим

Код: Выделить всё

hSession = Nothing

Авось сработает.

Все функции для работы с FTP-сервером взял с какого-то перевода иностранной статьи. Дорабатывал сам, так как у них было очень скудно все описано. И функционал использовался не весь.

Не авось. Ошибка 91: Object Variable or With block variable not set.

[Viper]

Ну потыкай еще вот этим

Код: Выделить всё

hSession = Nothing

Авось сработает.

Это такая шутка юмора, да?
2 Vasiliy8338, у тебя в коде hSession и hInetSession объявлены как Variant. Это есть ересь. Объявляй их как Long. Далее, открытые сессии необходимо закрыть при помощи InternetCloseHandle. У тебя похоже где-то до вызова этой функции дело не доходит.

[Vasiliy8338]

Объявляй их как Long. Далее, открытые сессии необходимо закрыть при помощи InternetCloseHandle. У тебя похоже где-то до вызова этой функции дело не доходит.

Изменил на Long - увы, никакого результата. Опять с первого раза все прошло нормально, а потом висит раз за разом.
Самое обидное, что этот код в таком именно виде уже был использован мной, и программа отлично работает...

[Viper]

Выводи лог работы программы. Возможно у тебя что-то не выполняется по какой-либо причине, сессия остается незакрытой и так далее... Отсюда и ошибки.

[Vasiliy8338]

Выводи лог работы программы.

а каким образом можно получить лог работы программы?

[Viper]

Элементарно. Открываешь файл и записываешь в него выполняемые программой действия. По завершении работы программы просматриваешь файл и анализируешь, что выполнилось, а что не выполнилось.

[Vasiliy8338]

Элементарно. Открываешь файл и записываешь в него выполняемые программой действия. По завершении работы программы просматриваешь файл и анализируешь, что выполнилось, а что не выполнилось.

Сделал так:

Код: Выделить всё

Dim LogNum As Integer
    LogNum = FreeFile
    Open App.Path & "\log.lg" For Output As #LogNum
    Dim hSes As Long, hISes As Long
    hSes = InternetCloseHandle(hSession)
    hISes = InternetCloseHandle(hInetSession)
   
    Print #LogNum, hSes
    Print #LogNum, hISes
   
    Close #LogNum

в файле: 1 1
т.е. я так понимаю функции выполняются? И еще вопрос - нужно ли закрывать хэндл

Код: Выделить всё

SendFile = FtpPutFile(hSession, FileFrom, FTPPath, 2, 1)

[Viper]

Элементарно. Открываешь файл и записываешь в него выполняемые программой действия. По завершении работы программы просматриваешь файл и анализируешь, что выполнилось, а что не выполнилось.

Сделал так:

Код: Выделить всё

Dim LogNum As Integer
    LogNum = FreeFile
    Open App.Path & "\log.lg" For Output As #LogNum
    Dim hSes As Long, hISes As Long
    hSes = InternetCloseHandle(hSession)
    hISes = InternetCloseHandle(hInetSession)
   
    Print #LogNum, hSes
    Print #LogNum, hISes
   
    Close #LogNum

в файле: 1 1
т.е. я так понимаю функции выполняются?

В приводимом тобой примере видимо выполняются. А вот в реальной твоей проге?

И еще вопрос - нужно ли закрывать хэндл

Код: Выделить всё

SendFile = FtpPutFile(hSession, FileFrom, FTPPath, 2, 1)

Где здесь хэндл, который можно закрыть? Функция возвращает либо TRUE, либо FALSE указывающие на успех, либо на крах отправки файла.

[Vasiliy8338]

В приводимом тобой примере видимо выполняются. А вот в реальной твоей проге?

все описанные результаты получены в уже скомпилированной программе

[Viper]

В приводимом тобой примере видимо выполняются. А вот в реальной твоей проге?

все описанные результаты получены в уже скомпилированной программе

Выкладывай исходник проекта (лишнее убрать, нужное оставить). Естественно не портянкой кода, а в архиве. Будем посмотреть, что у тебя не так.

[Vasiliy8338]

В Sub Main() необходимо задать ссылку на FTP-сервер любой (свою оставлять было бесполезно - сервер не опубликованный).

[Viper]

В Sub Main() необходимо задать ссылку на FTP-сервер любой (свою оставлять было бесполезно - сервер не опубликованный).

Уточнил бы ты все же формат командной строки, а то что-то странное у меня получается. Пара комментариев к коду:

Код: Выделить всё

TodayTime = Now 'определение переменной (текущая дата)
YYYY = Year(TodayTime) 'определение переменной (текущий год)
MM = Month(TodayTime) 'определение переменной (текущий месяц)
DD = Day(TodayTime) 'определение переменной (текущий день)
HH = Hour(TodayTime) 'определение переменной (текущий час)
MI = Minute(TodayTime) 'определение переменной (текущая минута)
SS = Second(TodayTime) 'определение переменной (текущая секунда)
If Len(MM) < 2 Then 'если месяц меньше 10, то добавляем в начале "0"
    MM = "0" & MM
End If
If Len(DD) < 2 Then 'если день меньше 10, то добавляем в начале "0"
    DD = "0" & DD
End If
If Len(HH) < 2 Then 'если час меньше 10, то добавляем в начале "0"
    HH = "0" & HH
End If
If Len(MI) < 2 Then 'если минута меньше 10, то добавляем в начале "0"
    MI = "0" & MI
End If
If Len(SS) < 2 Then 'если секунда меньше 10, то добавляем в начале "0"
    SS = "0" & SS
End If

Открой для себя функцию Format, полезная вещь!Код

Код: Выделить всё

MM = Format$(Month(TodayTime),"00")

как раз и выведет номер месяца в двухзнаковом формате.

Код: Выделить всё

ScanName = "0"
ScanCoding = "0"
ScanSrvPassive = "0"
ScanSaveLog = "1"
ScanMin = "100"

А на кой ляд целым числам присваивать строковые значения?

[Vasiliy8338]

Уточнил бы ты все же формат командной строки, а то что-то странное у меня получается.

String, если ты об этом. Если же ты про значение, то там идет такое: "путь_к_скану" (типа "c:\scan.jpg").

Пара комментариев к коду...

за это спасибо! впредь буду обязательно использовать.

[Viper]

Гм... после исправления пары, скажем так, опечяток, программа вполне показала свою работоспособность. Однако напильником там есть где поработать. Тормозит при отправке файлов по черному.

[Vasiliy8338]

Гм... после исправления пары, скажем так, опечяток, программа вполне показала свою работоспособность. Однако напильником там есть где поработать. Тормозит при отправке файлов по черному.

Внутри одной сети время работы - секунды 2-3. Но на счет оптимизации кода - не спорю.
А работоспособный вариант можно увидеть?))

[Vasiliy8338]

Viper, так у тебя получилось найти причину, почему программа не закрывается или нет?

[Viper]

Viper, так у тебя получилось найти причину, почему программа не закрывается или нет?

На данный момент не удалось. Надо пройтись по коду, а это дело нелегкое, да и требующее времени.

[Денис]

Viper, так у тебя получилось найти причину, почему программа не закрывается или нет?

Могу предложить хак. Но все-равно, лучше найти причину, ибо этот код:

Код: Выделить всё

Private Sub Form_Unload(Cancel As Integer)

For Each Form In Forms
   Unload Form
Next

End Sub

- не решает проблему, а борется с последствиями.