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
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
|
Dim BStop As Boolean
Private Sub UserForm_Initialize()
Me.StartUpPosition = 3
'Disable
Me.Stop_Polling.Visible = False
'Enable
Me.Start_Polling.Visible = True
Me.Open_Parm_Userform.Visible = True
'text
Me.Status_text = "*Stopped"
'last File
Me.Last_File_Name = ""
'Scanning_name
Me.Scanning_Name = ""
'Fax Sent
Worksheets("Parms").Range("C20") = 0
Me.Fax_Sent = Worksheets("Parms").Range("C20")
'Fax Sent Cumulated
Me.Fax_Sent_Cumulated = Worksheets("Parms").Range("C21")
Search_file = Folder & Trim(Worksheets("Parms").Range("C3"))
Me.AcroPDF1.LoadFile ("G:\Emballage\Format\Hydro.pdf")
DoEvents
Me.Repaint
'Retrieve Debug_mode
Me.Debug_Sw = Worksheets("Parms").Range("C22")
End Sub
Private Sub Open_Parm_Userform_Click()
If Me.Password <> "Secret1" Then
MsgBox "Please Specify a valid password at the right of this button and retry", vbCritical
Else
UserForm1.Show
'Retrieve Debug_mode
Me.Debug_Sw = Worksheets("Parms").Range("C22")
End If
End Sub
Private Sub Start_Polling_Click()
Dim Folder As String 'Folder To browse
Dim Search_file As String 'Pattern File to search for in Folder
Dim Found_entry As String 'Found File name
Dim Fullname As String 'FullName of Found File
Dim Rech As String
Dim Found_keys As Boolean
Dim Pos_REF As Integer 'Position of first **REF in record
Dim elem As Integer
Dim ref As String
Dim refx As String
Dim Mail As String
Dim Mailcc As String
Dim Mailbcc As String
Dim Subject As String
Dim Body() As String
Dim BSize As Integer
Dim Attachement_Folder As String 'Folder where to store attachement
Dim Attachement() As String
Dim Attachement_ext As String
Dim Attachement_brut As String
Dim Attachement_file As String
Dim P_Attachement_file As String
Dim Mxattach_name As String
Dim Operation As String
Dim Pdf_file As String
Dim Ps_file As String
Dim res As Boolean
Dim shell_res As Variant
Dim lng As Integer
Dim Laligne As String, tablKeys As Variant, tablVar As Variant
Dim Where_pos As Long
Dim End_Where As Long
Dim beg_ligne As String
Dim End_ligne As String
Dim PhWnd As Long
Dim P_PhWnd As Long
'Mapping X pour attachemnt
map_mxattach
'Disable
Me.Start_Polling.Visible = False
Me.Open_Parm_Userform.Visible = False
Me.Password.Visible = False
'Enable
Me.Stop_Polling.Visible = True
'text
Me.Status_text = "Polling"
Me.Started_Box = "Started at " & CStr(Now())
BStop = False
PhWnd = 0
'*****************************************************************
'* Send PDF Labels Using FAX*STAR *
'*****************************************************************
'1. Retrieve Folder to browse
Folder = Worksheets("Parms").Range("C2")
If Right(Folder, 1) <> "\" Then
Folder = Trim(Folder) & "\"
End If
'2. Retrieve Pattern File to browse
Search_file = Folder & Trim(Worksheets("Parms").Range("C3"))
Me.Scanning_Name = Search_file
Me.Repaint
'3. Retrieve Folder where to store attachement for FAXSTAR (MXATTACH)
Attachement_Folder = Trim(Worksheets("Parms").Range("C4"))
If Right(Attachement_Folder, 1) <> "\" Then
Attachement_Folder = Trim(Attachement_Folder) & "\"
End If
'4. Loop until button Stop used
Do While BStop = False
DoEvents
'text
Me.Status_text = "Polling"
Me.Repaint
'5. Browse Folder until end of sources files or Button Stop used.
Found_entry = Dir(Search_file, vbNormal)
Do While Found_entry <> "" And BStop = False ' Start the loop.
'Excel premier Plan
'AppActivate "Microsoft Excel"
Fullname = Folder & Found_entry
Me.Last_File_Name = Fullname
Me.Status_text = "Looking for **(REF)"
Me.Repaint
Open Fullname For Input As #1
Found_keys = False
Line Input #1, Laligne
Do While Not EOF(1) And Found_keys = False
Pos_REF = InStr(1, Laligne, "**(REF)", vbTextCompare)
If Pos_REF > 0 Then
Found_keys = True
Else
Line Input #1, Laligne
End If
Loop
ref = ""
refx = ""
Mail = ""
Mailcc = ""
Mailbcc = ""
Subject = ""
Attachement_brut = ""
ReDim Body(1)
BSize = 0
Attachement_file = ""
Ps_file = ""
Fax_file = ""
PhWnd = 0
If Found_keys Then
Me.Status_text = "Extracting Data"
Me.Repaint
tablKeys = Split(Laligne, ",")
Line Input #1, Laligne
tablVar = Split(Laligne, ",")
For elem = 0 To UBound(tablKeys)
'Debug.Print Trim(tablKeys(elem)) & " - "; Trim(tablVar(elem))
Select Case Trim(tablKeys(elem))
Case "**(REF)"
ref = Trim(tablVar(elem))
Case "**(REFX)"
refx = Trim(tablVar(elem))
Case "**(MAIL)"
If Me.Debug_Sw Then
Mail = "Thierry.Schmitz@hydro.com"
Else
Mail = Unquote(Trim(tablVar(elem)))
End If
Case "**(MAILCC)"
If Not Me.Debug_Sw Then
Mailcc = Unquote(Trim(tablVar(elem)))
End If
Case "**(MAILBCC)"
If Not Me.Debug_Sw Then
Mailbcc = Unquote(Trim(tablVar(elem)))
End If
Case "**(SUBJECT)"
Subject = Trim(tablVar(elem))
Case "**(BODY)", "**(BODY1)", "**(BODY2)", "**(BODY3)", "**(BODY4)", "**(BODY5)", "**(BODY6)", "**(BODY7)", "**(BODY8)", "**(BODY9)", "**(BODY10)"
BSize = BSize + 1
ReDim Preserve Body(BSize)
Body(BSize - 1) = Unquote(Trim(tablVar(elem)))
Case "**MXATTACHD"
Attachement_brut = Unquote(Trim(tablVar(elem)))
Attachement = Split(Attachement_brut, ".")
Attachement_ext = Attachement(1)
Fax_file = Attachement(0) & "." & "INI"
If Attachement_ext = "PS" Then
Me.Status_text = "Converting Postscript to PDF"
Me.Repaint
Ps_file = Attachement_brut
Pdf_file = Attachement(0) & "." & "Pdf"
res = Application.Run("GSAPI_VBA.XLS!Convertfile", Attachement_brut, Pdf_file)
Attachement_brut = Pdf_file
End If
Attachement_file = Attachement_brut
'Move Attachement to Attachement_Folder
Me.Status_text = "Moving Attachement for FAX*STAR"
Me.Repaint
Attachement = Split(Attachement_brut, "\")
Destination = Attachement_Folder & Attachement(UBound(Attachement))
Mxattach_name = Attachement(UBound(Attachement))
On Error Resume Next
FileCopy Attachement_brut, Destination
If Err.Number = 76 Then
MsgBox (Destination & " Path/drive not available. Process Halted")
Close #1
Exit Sub
End If
'Close View Previous Attachment and remove it
If P_Attachement_file <> "" Then
Me.Status_text = "Removing " & P_Attachement_file & " File"
Me.Repaint
If P_PhWnd <> 0 Then
'Close default Viewer if openedt
'Call CloseProgram(P_PhWnd)
'DoEvents
End If
Me.AcroPDF1.LoadFile ("G:\Emballage\Format\Hydro.pdf")
DoEvents
Me.Repaint
On Error Resume Next
If Not Me.Debug_Sw Then
Kill P_Attachement_file
End If
DoEvents
End If
P_Attachement_file = ""
P_PhWnd = 0
Application.Wait (Now + TimeValue("0:00:02"))
'*************************************
'Show Attachement With Default Viewer
'PhWnd = OpenProgram(Attachement_file, 0)
'Excel premier Plan
'AppActivate "Microsoft Excel"
Me.AcroPDF1.LoadFile (Attachement_file)
DoEvents
Me.Repaint
End Select
Next
'Formattage Fichier sortie
If Mail <> "" And Attachement_brut <> "" Then
Me.Status_text = "Formatting Fax File"
Me.Repaint
Open Fax_file For Output As #2
Laligne = "**(REF) " & ref
Print #2, Laligne
If refx <> "" Then
Laligne = "**(REFX) " & refx
Print #2, Laligne
End If
Laligne = "**(MAIL) " & Mail
Print #2, Laligne
If Mailcc <> "" Then
Laligne = "**(MAILCC) " & Mailcc
Print #2, Laligne
End If
If Mailbcc <> "" Then
Laligne = "**(MAILBCC) " & Mailbcc
Print #2, Laligne
End If
If Subject <> "" Then
Laligne = "**(SUBJECT) " & Subject
Print #2, Laligne
End If
For elem = 1 To BSize
Laligne = Trim(Body(elem - 1))
Print #2, Laligne
Next
Print #2, " "
Laligne = "**MXATTACHD " & Mxattach_name
Print #2, Laligne
Print #2, " "
Close #2
Me.Status_text = "Printing to Fax*Star"
Me.Repaint
Operation = "lpr -S 149.209.142.14 -P faxstar " & Fax_file
shell_res = Shell(Operation, vbNormalFocus)
DoEvents
Worksheets("Parms").Range("C20") = Worksheets("Parms").Range("C20") + 1
Me.Fax_Sent = Worksheets("Parms").Range("C20")
Worksheets("Parms").Range("C21") = Worksheets("Parms").Range("C21") + 1
Me.Fax_Sent_Cumulated = Worksheets("Parms").Range("C21")
Else
Close #2
End If
End If
Close #1
Me.Status_text = "Removing " & Found_entry & " File"
Me.Repaint
'If Not Me.Debug_Sw Then
On Error Resume Next
Kill Fullname
'End If
If Ps_file <> "" Then
Me.Status_text = "Removing " & Ps_file & " File"
Me.Repaint
If Not Me.Debug_Sw Then
On Error Resume Next
Kill Ps_file
End If
End If
Me.Status_text = "Pause 2 sec"
Application.Wait (Now + TimeValue("0:00:02"))
Me.Repaint
If Fax_file <> "" Then
Me.Status_text = "Removing " & Fax_file & " File"
Me.Repaint
On Error Resume Next
Kill Fax_file
End If
'Backup ID Task View Attachement & Attachement name
P_PhWnd = PhWnd
P_Attachement_file = Attachement_file
Found_entry = Dir ' Get next entry.
Loop
If BStop = False Then
Me.Status_text = "Waiting 5 sec before Polling"
Application.Wait (Now + TimeValue("0:00:05"))
Me.Repaint
End If
DoEvents
Loop
'Close View Last Attachment and remove it
If Attachement_file <> "" Then
Me.Status_text = "Removing " & Attachement_file & " File"
Me.Repaint
If PhWnd <> 0 Then
'Close default Viewer if openedt
'Call CloseProgram(PhWnd)
'DoEvents
End If
Me.AcroPDF1.LoadFile ("G:\Emballage\Format\Hydro.pdf")
DoEvents
Me.Repaint
If Not Me.Debug_Sw Then
On Error Resume Next
Kill Attachement_file
DoEvents
End If
End If
Attachement_file = ""
PhWnd = 0
End Sub
Private Sub Stop_Polling_Click()
'Xl_plein_ecran
'Disable
Me.Stop_Polling.Visible = False
'Enable
Me.Start_Polling.Visible = True
Me.Open_Parm_Userform.Visible = True
Me.Password.Visible = True
'text
Me.Status_text = "*Stopped"
BStop = True
Me.Started_Box = "Stopped at " & CStr(Now())
End Sub |
problème d'instabillité de code
Répondre avec citation
Partager