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
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
| Option Compare Database
Option Explicit
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function LookupAccountName Lib "advapi32.dll" Alias "LookupAccountNameA" (lpSystemName As String, ByVal lpAccountName As String, sid As Any, cbSid As Long, ByVal ReferencedDomainName As String, cbReferencedDomainName As Long, peUse As Long) As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public CompName As String 'объявляем переменную доступную для всего проекта
Dim Workbooks As Object
Dim xlWbkEx As Object
Dim xlAppEx As Object
Public Rowss1 As Variant
Public Rowss2 As Integer
'Const MyFile = "P:\Судебные дела\СУДЕБНЫЕ ДЕЛА 2015 ОПОСД.xls"
Const MyFile = "c:\iSKi_X\ДЕЛА 2015 ОПОСД.xls"
Const l = "Сводная таблица_2015г"
Public rng As Object
Sub reportToExcel_Isk()
Call StatusBarYes
Set xlAppEx = CreateObject("Excel.Application.14") 'создаем объект Excel, чтобы можно было работать с его методами и свойствами
Again:
'проверка на открытие файла
If IsOpen(MyFile) Then
MsgBox "Файл " & MyFile & " УЖЕ кем-то ИСПОЛЬЗУЕТСЯ. Останавливаемся.", vbExclamation
DoCmd.HourGlass False
Call Get_UserStatus_Info
Exit Sub
Else
DoCmd.HourGlass False
MsgBox "Файл " & MyFile & " никем не используется. Продолжаем...", vbInformation
End If
'запрос значения Rowss - указать номер строки под которой надо вставить
Rowss1 = InputBox("Введите номер строки, ПОД которой надо вставить новую строку", "Ввод числа")
Dim myReply
If Not IsNumeric(Rowss1) Then
myReply = MsgBox("Номер строки был указан не цифрой. Повторить процедуру?", vbYesNo + vbQuestion + vbApplicationModal, "Ввод номера строки")
If myReply = vbNo Then
Exit Sub
End If
If myReply = vbYes Then
MsgBox "Повторяем..."
GoTo Again
End If
Else: GoTo 1
If Rowss1 = "" Then
myReply = MsgBox("Номер строки не указан. Остановить процедуру?", vbYesNo + vbQuestion + vbApplicationModal, "Ввод номера строки")
If myReply = vbYes Then
Exit Sub
End If
If myReply = vbNo Then
MsgBox "Повторяем..."
GoTo Again
End If
Else: GoTo 1
End If
1:
Dim Msg, Style, Title, Response
Msg = "Вы правильно указали номер строки ПОД которой вставить? " & " ---> " & Rowss1 & vbCr & "Будет вставлена строка: ---> " & Rowss1 + 1 & vbCr & "Продолжаем?" 'ns
Style = vbYesNo + vbQuestion + vbApplicationModal
Title = "Ввод номера строки"
Response = MsgBox(Msg, Style, Title)
If Response = vbNo Then ' User chose No.
MsgBox "Исправьте значение и продолжайте", vbApplicationModal, "Ввод номера строки"
GoTo Again
Else ' User chose Yes.
MsgBox "Продолжаем!", vbApplicationModal
End If
End If
DoCmd.HourGlass (-1) 'True
'Rowss1 = ns
Rowss2 = Rowss1 + 1
'strPathExcel = MyFile
Set xlWbkEx = xlAppEx.Workbooks.Open(MyFile)
'то добавляем строку
xlWbkEx.Worksheets(l).Rows(Rowss2).Insert
'Запомним нашу строку
'Set newrow = xlWbk.Worksheets(L).Rows(Rowss2)
With xlWbkEx.Worksheets(l)
.Rows(Rowss1).Copy
.Rows(Rowss2).PasteSpecial Paste:=-4122
.Rows(Rowss2).Select
'динамически формируем адрес нужной ячейки и задаем ей значение
.Range("A" & Rowss2).Value = "МКП ""Воронежтеплосеть"" "
.Range("B" & Rowss2).Value = Forms![Данные]![Краткое_наименование] '.Value 'если поле
.Range("D" & Rowss2).Value = "№ " & Forms![Данные]![Номер_платежки] & " от " & Forms![Данные]![Дата_платежки] '.Value 'если поле
.Range("E" & Rowss2).Value = Date '.Value 'если поле
.Range("F" & Rowss2).Value = "взыскание задолженности за тепловую энергию"
.Range("G" & Rowss2).Value = Forms![Данные]![Начало_периода] & "-" & Forms![Данные]![Конец_периода]
.Range("J" & Rowss2).Value = Nz(Forms![Данные]![Сумма_долга], 0) + Nz(Forms![Данные]![Сумма_процентов], 0)
.Range("X" & Rowss2).Value = "С.А.Калинин"
' .Range("B10").Value = "B10-наше значение"
' .[D5] = Forms![Данные]![Краткое_наименование]
' задаем диапазон выбора ячеек и задаем им форматирование границ
'Set rng = .Range("A" & Rowss2, "X" & Rowss2)
'Call make_border_2
End With
xlAppEx.CutCopyMode = False
xlAppEx.Visible = True 'запускаем приложение Excel, можно сдвинуть вниз
'Set appEx = Nothing 'уничтожаем переменную с объектом
Set xlAppEx = Nothing
Set xlWbkEx = Nothing
'Set ns = Nothing
Set Rowss1 = Nothing
Call StatusBarNo
End Sub
Public Function IsOpen(File$) As Boolean
Dim fn%
fn = FreeFile
On Error Resume Next
Open File For Random Access Read Write Lock Read Write As #fn
Close #fn
IsOpen = Err
End Function
Public Sub Get_UserStatus_Info()
Dim asUsers, sUserName As String, sDateTime As String, sStatus As String
Dim li As Long
Dim xlAppExGet As Object
Set xlAppExGet = GetObject(MyFile)
On Error Resume Next
asUsers = xlAppExGet.Workbooks(MyFile).UserStatus
Select Case Err.number
Case 9:
MsgBox "Файл отсутствует? " & vbNewLine & "Номер ошибки: " & Err.number & vbNewLine & "Описание ошибки: " & Err.Description
'Resume Next
Err.Clear
Exit Sub
End Select
For li = 1 To UBound(asUsers, 1)
sUserName = sUserName & vbNewLine & asUsers(li, 1) & "; время изменения файла: " & Format(asUsers(li, 2), "dd.mm.yyyy hh:mm")
sDateTime = asUsers(li, 2)
Select Case asUsers(li, 3)
Case 1
sStatus = "Монопольный"
Case 2
sStatus = "Общий"
Case Else
sStatus = "Не определен"
End Select
Next
MsgBox "Пользователи файла:" & vbNewLine & sUserName & vbNewLine & "Доступ к файлу - " & sStatus
Call Get_LogonUser
Call Get_ComputerName
Debug.Print IIf(xlAppExGet.Workbooks("c:\iSKi_X\ДЕЛА 2015 ОПОСД.xls").UserStatus(1, 3) = 1, "Exclusive", "Shared")
Set xlAppExGet = Nothing
End Sub
Public Sub Get_LogonUser()
MsgBox "LogonDomain: " & GetLogonDomainuser & " / " & "LogonUser: " & GetLogonUser
End Sub
Public Function GetLogonDomainuser() As String
Dim lResult As Long
Dim i As Integer
Dim bUserSid(255) As Byte
Dim sUserName As String
Dim sDomainName As String * 255
Dim lDomainNameLength As Long
Dim lSIDType As Long
sUserName = GetLogonUser
lResult = LookupAccountName(vbNullString, sUserName, bUserSid(0), 255, sDomainName, lDomainNameLength, lSIDType)
sDomainName = Space(lDomainNameLength)
lResult = LookupAccountName(vbNullString, sUserName, bUserSid(0), 255, sDomainName, lDomainNameLength, lSIDType)
If (lResult = 0) Then
MsgBox "Ошибка: невозможно найти имя домена для юзера: " & sUserName
Exit Function
End If
sDomainName = Left$(sDomainName, InStr(sDomainName, Chr$(0)) - 1)
GetLogonDomainuser = Trim(sDomainName)
End Function
Public Function GetLogonUser() As String
Dim strTemp As String, strUserName As String
strTemp = String(100, Chr$(0))
strTemp = Left$(strTemp, InStr(strTemp, Chr$(0)) - 1)
strUserName = String(100, Chr$(0))
GetUserName strUserName, 100
strUserName = Left$(strUserName, InStr(strUserName, Chr$(0)) - 1)
GetLogonUser = strUserName
End Function
Public Function UserName() As String
Dim cn As String
Dim ls As Long
Dim Res As Long
cn = String(1024, 0)
ls = 1024
Res = GetUserName(cn, ls)
If Res <> 0 Then
UserName = Mid(cn, 1, InStr(cn, Chr(0)) - 1)
Else
UserName = ""
End If
End Function
Public Sub Get_ComputerName()
Dim scomp As String, h As String
scomp = Space(255)
h = GetComputerName(scomp, 255)
CompName = Trim(scomp)
MsgBox "Имя компьютера, с которого открыт файл: " & CompName
End Sub |
(
