Private Sub Комманда8_Click()
Dim STR_FILE As String
Dim STR_Filter As String
Dim PROGRAMS_NAME As String
Dim rst As ADODB.Recordset
Dim STR_ID_KEY As String
' для документа
Dim APPWrd As Object
Dim oDoc1 As Object
Dim DOKS_PATCH As String
Dim STR_NACHALO As String
Dim DOKS As String
Dim DOKS1 As String
'Для циклов
Dim i As Integer
Dim F As Integer
Dim F1 As Integer
' хронология
Dim REG_PROD As Integer ' Регистрированные продукты
Dim PRO_NOMER As Integer 'Производственный номер
Dim KOL_VO_PROGRAMM As Integer ' количество добавленных программ
Dim POVTOR As String
On Error GoTo Комманда8_Click_Error
' нулим переменные
POVTOR = ""
STR_ID_KEY = ""
Call CLEAR_FIELD
REG_PROD = 0
PRO_NOMER = 0
KOL_VO_PROGRAMM = 0
STR_Filter = "Выбор файла (*.doc)" & Chr$(0) & "*.doc" & Chr$(0) & "All Files (*.*)" & Chr$(0) & "*.*" & Chr$(0)
DOKS_PATCH = FileOpenSave(OFN_OVERWRITEPROMPT, App.path & "\IMPORT\", STR_Filter, , ".doc", , "Выбор файла", -1, True)
If NZVB(DOKS_PATCH) = "" Then
MESS "Не выбран файл"
Exit Sub
End If
STR_FILE = FUN_FILE_NAME(DOKS_PATCH)
STR_FILE = Mid(STR_FILE, 1, Len(STR_FILE) - 4)
' проверка наличия уже загруженного такого же ключа
Set rst = New ADODB.Recordset
rst.Open "SELECT KEY_TBL.* " _
& " FROM KEY_TBL " _
& " Where (((KEY_TBL.KEY_NAMBER) = '" & STR_FILE & "')) ", GLB_CONNECTION, adOpenKeyset, adLockOptimistic
If Not rst.EOF And Not rst.BOF Then
MESS "Такой ключ уже загружен! " & vbCrLf & "Добавим только новые программы."
STR_ID_KEY = rst("ID_KEY")
Me!ID_KEY = rst("ID_KEY")
Me!KEY_NAMBER = rst("KEY_NAMBER")
GoTo TOKA_PROGRAMMI 'Такой ключ уже загружен грузим только программы
End If
' проверка наличия уже загруженного такого же ключа
' загрузка нового ключа
Set rst = New ADODB.Recordset
' новая запись
rst.Open "SELECT KEY_TBL.* From KEY_TBL ", GLB_CONNECTION, adOpenKeyset, adLockOptimistic
STR_ID_KEY = FUN_GENERATE
rst.AddNew
rst("ID_KEY") = STR_ID_KEY
rst("KEY_NAMBER") = STR_FILE
rst("USER_NAME") = GLB_USER_NAME
rst("DATE_RECORDS") = Date
rst.UpdateBatch ' запомнить
Me!ID_KEY = STR_ID_KEY
Me!KEY_NAMBER = STR_FILE
rst.Close
Set rst = Nothing
'Грузим только программы
TOKA_PROGRAMMI:
STR_NACHALO = 0 ' строка "Регистрированные продукты" ещё не найдена
'Чтение файла xxx.DOC
Set APPWrd = CreateObject("Word.Application")
' APPWrd.Visible = False
Set oDoc1 = APPWrd.Documents.Open(DOKS_PATCH)
'Построчное чтение файла
With oDoc1 ' .Parent.Visible = True
' Чтение сток документа
For i = 1 To 100 ' строки документа от балды шукаем 100 строк
' On Error GoTo m1
Me!KOLVO = i
Me!KOLVO.Refresh
' ВЫЯВИТЬ конец документа
'If oDoc1.ActiveWindow.Selection.End Then MsgBox "Конец"
'If oDoc1.Content.End Then MsgBox "Конец"
'If oDoc1.ActiveWindow.Selection.End = oDoc1.Content.End Then MsgBox "Конец"
DOKS = NZVB(.Paragraphs(i))
' если пустая строка
If NZVB(DOKS) = "" Then GoTo dalee
' если уже пошли строки программ
If STR_NACHALO = 1 Then GoTo Pognali
If InStr(1, NZVB(DOKS), "Производственный номер", vbTextCompare) <> 0 Then
' сравнение номера ключа
If InStr(1, NZVB(DOKS), KEY_NAMBER, vbTextCompare) = 0 Then
MESS "Не верно указан документ!"
oDoc1.Close
APPWrd.Quit
Exit Sub
End If
PRO_NOMER = 1
GoTo dalee:
End If
If InStr(1, NZVB(DOKS), "Регистрированные продукты", vbTextCompare) <> 0 Then
STR_NACHALO = 1 'Если найден идентиф. начала считывания ' начало строк
REG_PROD = 1
GoTo dalee:
End If
Pognali:
'Если идентиф. начала считывания STR_NACHALO = 1 , то погнали
If STR_NACHALO = 1 Then
' считывание
DOKS1 = ""
DOKS = Replace(DOKS, Chr(9), " ")
DOKS = Replace(DOKS, Chr(10), " ")
DOKS = Replace(DOKS, Chr(13), " ")
DOKS = LTrim(DOKS)
DOKS = RTrim(DOKS)
If NZVB(DOKS) = "" Then GoTo dalee
' создание строки кода ключа
For F1 = 1 To Len(DOKS)
If Asc(Mid(DOKS, F1, 1)) <= 57 And Asc(Mid(DOKS, F1, 1)) >= 48 Or Asc(Mid(DOKS, F1, 1)) = 32 Then
DOKS1 = DOKS1 & Mid(DOKS, F1, 1)
End If
Next F1
DOKS1 = LTrim(DOKS1)
DOKS1 = RTrim(DOKS1)
' создание строки наименования программы
PROGRAMS_NAME = Mid(DOKS, 1, Len(DOKS) - Len(DOKS1))
PROGRAMS_NAME = LTrim(PROGRAMS_NAME)
PROGRAMS_NAME = RTrim(PROGRAMS_NAME)
DOKS = ""
' простановка пробелов
If NZVB(DOKS1) <> "" Then
If InStr(1, DOKS1, " ", vbTextCompare) = 0 Then
For F1 = 1 To Len(DOKS1)
If Asc(Mid(DOKS1, F1, 1)) <= 57 And Asc(Mid(DOKS1, F1, 1)) >= 48 Then
DOKS = DOKS & Mid(DOKS1, F1, 1)
If F1 / 5 = Int(F1 / 5) Then
DOKS = DOKS & " "
End If
End If
Next F1
Else
DOKS = DOKS1
End If
Else
MESS "Не распознан код продукта (программы)! " & PROGRAMS_NAME
POVTOR = "Не распознан код продукта (программы)! "
Exit Sub
End If
' проверка программы на наличие в базе
Set rst = New ADODB.Recordset
rst.Open "SELECT PRODUKT_TBL.* From PRODUKT_TBL " _
& " WHERE (((PRODUKT_TBL.ID_KEY)='" & STR_ID_KEY & "') AND ((PRODUKT_TBL.PRODUKT_NAME)= '" & PROGRAMS_NAME & "'));", GLB_CONNECTION, adOpenKeyset, adLockOptimistic
If Not rst.EOF And Not rst.BOF Then
MESS "Повтор загрузки! " & PROGRAMS_NAME & vbCrLf & "Загрузка отменена."
POVTOR = " Повтор загрузки " & PROGRAMS_NAME
GoTo dalee
End If
Set rst = New ADODB.Recordset
rst.Open "SELECT PRODUKT_TBL.* " _
& " From PRODUKT_TBL ", GLB_CONNECTION, adOpenKeyset, adLockOptimistic
rst.AddNew
rst("ID_PRODUKT") = FUN_GENERATE
rst("ID_KEY") = STR_ID_KEY
rst("PRODUKT_NAME") = PROGRAMS_NAME
rst("PRODUKT_NAMBER") = DOKS
rst("USER_NAME") = NZVB(GLB_USER_NAME)
rst("DATE_RECORDS") = Date
rst.UpdateBatch
KOL_VO_PROGRAMM = KOL_VO_PROGRAMM + 1
End If
dalee:
Next i ' строки документа
End With
FINISH:
Call FRM_OKNO_KEY.IN_EKRAN_KEY
Call FRM_OKNO_KEY.IN_EKRAN_PROGRAM
Me!KOLVO = KOL_VO_PROGRAMM
' переносфайла в другую папку
STR_FILE = FUN_FILE_NAME(DOKS_PATCH)
If FUN_COPY_FILE(App.path & "\IMPORT\", STR_FILE, App.path & "\IMPORT\Обработано\") = True Then
'сохранить как
'oDoc1.SaveAs App.path & "\IMPORT\Обработано\Обработано_" & STR_FILE
Call FUN_DELETE_FILE_NAME(App.path & "\IMPORT\" & STR_FILE) ' , App.path & "\IMPORT\Обработано\" & STR_FILE)
End If
oDoc1.Close
APPWrd.Quit
' ----------------------------------------------------
On Error GoTo 0
Exit Sub
Комманда8_Click_Error:
If REG_PROD = 0 Then
MESS "Не найдена строка " & vbCrLf & " (Регистрированные продукты:) "
End If
If PRO_NOMER = 0 Then
MESS "Не найдена строка " & vbCrLf & " ( Производственный номер: ) "
End If
MESS STR_FILE & vbCrLf & POVTOR
MESS "Удалось добавить программ - " & vbCrLf & KOL_VO_PROGRAMM & "шт."
Me!SEACH_KEY = STR_FILE
Call FRM_OKNO_KEY.IN_EKRAN_KEY
Call FRM_OKNO_KEY.IN_EKRAN_PROGRAM
Me!KOLVO = KOL_VO_PROGRAMM
Set rst = Nothing
'oDoc1.Close
'APPWrd.Quit
Call FUN_IN_TXT(FUN_Patch_File(App.path, "Error.txt"), "ошибка " & Err.Number & " (" & Err.Description & ") в процедуре Комманда8_Click из Form FRM_OKNO_KEY")
End Sub
|