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 все работает нормально.
Русский при вставке в любой браузер не отображается... но, уверен, что грамотные люди и без комментариев поймут что к чему.