1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
| Private Sub btnUploadData_Click()
On Error GoTo Err_btnUploadData_Click
Dim fd As FileDialog
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim rsProj As ADODB.Recordset
Dim path As String
' Dim counter As Long
Dim strSQL As String
Dim strFile As String
Dim sizeRs As Long
Dim blnInTrans As Boolean
Dim frmAddInfo As Form_фрмВставкаДанных 'Ссылка на информационную форму
Set fd = Application.FileDialog(msoFileDialogOpen)
fd.AllowMultiSelect = False
fd.Filters.Clear
fd.Filters.Add "Excel 2003", "*.xls"
If fd.Show = False Then
Exit Sub
End If
path = Trim(fd.SelectedItems(1))
'MsgBox path
Set fd = Nothing
If path <> "" Then
Set conn = CreateObject("ADODB.Connection")
conn.Provider = "Microsoft.Jet.OLEDB.4.0"
strFile = Mid(path, InStrRev(path, "\") + 1, Len(path) - InStrRev(path, "\") - 4)
'MsgBox strFile
conn.Properties("Data Source") = path
conn.Properties("Extended Properties") = "Excel 8.0; HDR=YES"
strSQL = "SELECT SpecPos, SpecName, SpecEI, SpecQty, SpecPrice " _
& "FROM [" & strFile & "$]"
'MsgBox strSQL
End If
conn.Open
' With conn
' .CursorLocation = adUseClient 'Это нужно для движения курсора вперед-назад для подсчета размера
' .Open
' End With
conn.BeginTrans
blnInTrans = True
Set rs = New ADODB.Recordset
rs.Open strSQL, conn, adOpenStatic, adLockReadOnly ', adCmdText
' rs.MoveLast
' rs.MoveFirst
sizeRs = rs.RecordCount
Set rsProj = New ADODB.Recordset
rsProj.Open "dbo.tblOMTOOrderSpec", CurrentProject.Connection, adOpenDynamic, adLockOptimistic
' counter = 0
' DoCmd.OpenForm "фрмВставкаДанных"
' Forms![фрмВставкаДанных].Form!lblNumRecAll.Caption = sizeRs 'Значения меток информационной формы
' Forms![фрмВставкаДанных].Form!lblNumRecAdd.Caption = 0
Set frmAddInfo = New Form_фрмВставкаДанных
frmAddInfo.lblNumRecAll.Caption = sizeRs 'Значения меток информационной формы
frmAddInfo.lblNumRecAdd.Caption = 0
frmAddInfo.Visible = True 'Показать информационную форму
While Not (rs.EOF)
With rsProj
.AddNew
.Fields("ID_Order") = Me.frmIDOrder.Value
.Fields("SpecPos") = rs.Fields("SpecPos").Value
.Fields("SpecName") = rs.Fields("SpecName").Value
.Fields("SpecEI") = rs.Fields("SpecEI").Value
.Fields("SpecQty") = rs.Fields("SpecQty").Value
.Fields("SpecPrice") = rs.Fields("SpecPrice").Value
.Update
' counter = counter + 1
End With
' Forms![фрмВставкаДанных].Form!lblNumRecAdd.Caption = counter 'Счетчик на информационной форме
' Forms![фрмВставкаДанных].Form.Repaint 'Обновление информационной формы
frmAddInfo.lblNumRecAdd.Caption = rs.AbsolutePosition ' + 1 'Счетчик на информационной форме
frmAddInfo.Repaint 'Обновление информационной формы
rs.MoveNext
Wend
conn.CommitTrans
blnInTrans = False
' DoCmd.Close acForm, "фрмВставкаДанных"
Set frmAddInfo = Nothing 'Закрыть информационную форму
' rsProj.Close
' Set rsProj = Nothing
' conn.Close
' Set conn = Nothing
' Set rs = Nothing
Me![фрмОМТОДобавитьЗаказ_03].Form.Refresh
'В этом сообщении было counter вместо sizeRs
MsgBox "Данные успешно загружены." & vbCrLf & _
"Общее количество строк: " & sizeRs, vbInformation + vbOKOnly, "Загрузка данных"
'MsgBox counter
Exit_btnUploadData_Click:
If Not rs Is Nothing Then If rs.State = 1 Then rs.Close
Set rs = Nothing
If Not rsProj Is Nothing Then If rsProj.State = 1 Then rsProj.Close
Set rsProj = Nothing
conn.Close
Set conn = Nothing
Exit Sub
Err_btnUploadData_Click:
If Err.Number = -2147467259 Then 'Обход ошибки про неподдерживаемую сортировку
Resume
Else
If blnInTrans Then conn.RollbackTrans: blnInTrans = Not blnInTrans
MsgBox Err.Number & ": " & Err.Description, vbCritical, "Ошибка"
Resume Exit_btnUploadData_Click
End If
End Sub |