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
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
|
Option Explicit
'Flags ShellExecuteEx
Private Const SEE_MASK_NOCLOSEPROCESS = &H40
Private Const SEE_MASK_FLAG_NO_UI = &H400
'Constantes ERREUR ShellExecuteEx
Private Const SE_ERR_FNF As Byte = 2
Private Const SE_ERR_PNF As Byte = 3
Private Const SE_ERR_ACCESSDENIED As Byte = 5
Private Const SE_ERR_OOM As Byte = 8
Private Const SE_ERR_SHARE As Byte = 26
Private Const SE_ERR_ASSOCINCOMPLETE As Byte = 27
Private Const SE_ERR_DDETIMEOUT As Byte = 28
Private Const SE_ERR_DDEFAIL As Byte = 29
Private Const SE_ERR_DDEBUSY As Byte = 30
Private Const SE_ERR_NOASSOC As Byte = 31
Private Const SE_ERR_DLLNOTFOUND As Byte = 32
'Constantes AFFICHAGE ShellExecuteEx
Private Const SW_SHOWNORMAL = 1
Private Const SW_SHOW = 5
Private Const SW_SHOWDEFAULT = 10
Private Type SHELLEXECUTEINFO
cbSize As Long
fMask As Long
hWnd As Long
lpVerb As String
lpFile As String
lpParameters As String
lpDirectory As String
nShow As Long
hInstApp As Long
lpIDList As Long
lpClass As String
hkeyClass As Long
dwHotKey As Long
hIcon As Long
hProcess As Long
End Type
'OpenProgram
Private Declare Function ShellExecuteEx Lib "shell32.dll" _
(SEI As SHELLEXECUTEINFO) As Long
'CloseProgram
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" _
(ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)
Public Const WM_CLOSE = &H10
Const GW_HWNDNEXT = 2
Dim mWnd As Long
Dim PhWnd As Long
Dim P_Attachement_file As String
Private AppCible As String
' ***********************************************************
' *
' * Lance le programme par défaut associé à un fichier (en fonction de son
' * extension ) et retourne le hWnd de la fênetre du programme lançé.
' *
' ***********************************************************
Public Function OpenProgram(ByRef Filename As String, ByRef OwnerhWnd As Long) As Long
Dim SEI As SHELLEXECUTEINFO
On Error GoTo ErrorHandler
'Vérifie si le fichier à lancer est un exécutable (.exe)
If GetExtension(Filename) = "exe" Then
If vbNo = MsgBox("ATTENTION, êtes-vous sûr de vouloir lancer ce programme exécutable ?", vbExclamation + vbYesNo) _
Then
OpenProgram = 0
Exit Function
End If
End If
With SEI
.cbSize = Len(SEI)
.fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_FLAG_NO_UI
.hWnd = OwnerhWnd
.lpVerb = "open"
.lpFile = Filename
.lpParameters = vbNullChar
.lpDirectory = vbNullChar
.nShow = SW_SHOW
.hInstApp = OwnerhWnd
End With
OpenProgram = ShellExecuteEx(SEI)
If SEI.hInstApp <= 32 Then
'Erreurs
OpenProgram = 0
Select Case SEI.hInstApp
Case SE_ERR_FNF
OpenProgram = SEI.hProcess
Case SE_ERR_PNF
MsgBox "Le chemin du fichier à ouvrir est incorrect.", vbExclamation
Case SE_ERR_ACCESSDENIED
MsgBox "Accès au fichier refusé.", vbExclamation
Case SE_ERR_OOM
MsgBox "Mémoire insuffisante.", vbExclamation
Case SE_ERR_DLLNOTFOUND
MsgBox "Dynamic-link library non trouvé.", vbExclamation
Case SE_ERR_SHARE
MsgBox "Le fichier est déjà ouvert.", vbExclamation
Case SE_ERR_ASSOCINCOMPLETE
MsgBox "Information d'association du fichier incomplète.", vbExclamation
Case SE_ERR_DDETIMEOUT
MsgBox "Opération DDE dépassée.", vbExclamation
Case SE_ERR_DDEFAIL
MsgBox "Opération DDE echouée.", vbExclamation
Case SE_ERR_DDEBUSY
MsgBox "Opération DDE occupée.", vbExclamation
Case SE_ERR_NOASSOC
'Ouvrir avec...
Call Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " + Filename, vbNormalFocus)
End Select
Else
'Retourne le hWnd du programme lançé par ShellExecuteEx
OpenProgram = SEI.hProcess
End If
Exit Function
ErrorHandler:
OpenProgram = 0
End Function
' ***********************************************************
' *
' * Ferme un programme à partir du hWnd de sa fenêtre.
' *
' ***********************************************************
Public Function CloseProgram(hWnd As Long) As Boolean
Dim lExitCode As Long
If hWnd = 0 Then
Exit Function
End If
On Error Resume Next
CloseProgram = CBool(TerminateProcess(hWnd, lExitCode))
'On Error Resume Next
CloseHandle hWnd
DoEvents
Sleep (100)
End Function
Public Function GetExtension(Filename As String) As String
Dim tablo() As String
tablo = Split(Filename, ".")
GetExtension = tablo(UBound(tablo))
End Function
Function Unquote(MyString As Variant) As Variant
Dim lng As Integer
lng = Len(Trim(MyString))
If lng > 2 Then
Unquote = Mid(Trim(MyString), 2, lng - 2)
Else
Unquote = " "
End If
End Function
Sub Z_hide_Show_Parm()
Dim status As Boolean
If Worksheets("Parms").Range("C17") = True Then
Worksheets("Parms").Range("C17") = False
Else
Worksheets("Parms").Range("C17") = True
End If
status = Worksheets("Parms").Range("C17")
Worksheets("Parms").Visible = status
End Sub
Function Send_1_File(Folder As String, Found_Entry As String, Attachement_folder As String, Debug_Sw As Boolean, P_Phwnd As Long, Attachement_file As String) As Boolean
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() As String
Dim Attachement_ext As String
Dim Attachement_brut As String
Dim Mxattach_name As String
Dim Destination 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 Fax_file As String
Send_1_File = True
'*****************************************************************
'* Send PDF Labels Using FAX*STAR *
'*****************************************************************
Fullname = Folder & Found_Entry
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 = ""
If Found_keys Then
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 Debug_Sw Then
Mail = "Mymail"
Else
Mail = Unquote(Trim(tablVar(elem)))
End If
Case "**(MAILCC)"
If Not Debug_Sw Then
Mailcc = Unquote(Trim(tablVar(elem)))
End If
Case "**(MAILBCC)"
If Not 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
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
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
Send_1_File = False
Exit Function
End If
'Close View Previous Attachment and remove it
If P_Attachement_file <> "" Then
If PhWnd <> 0 Then
'Close default Viewer if openedt
Call CloseProgram(PhWnd)
DoEvents
End If
On Error Resume Next
If Not Debug_Sw Then
Kill P_Attachement_file
End If
DoEvents
End If
P_Attachement_file = ""
PhWnd = 0
Application.Wait (Now + TimeValue("0:00:01"))
'*************************************
'Show Attachement With Default Viewer
PhWnd = OpenProgram(Attachement_file, 0)
P_Phwnd = PhWnd
'Excel premier Plan
AppActivate "Microsoft Excel"
DoEvents
End Select
Next
'Formattage Fichier sortie
If Mail <> "" And Attachement_brut <> "" Then
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
Operation = "lpr -S 149.209.142.14 -P faxstar " & Fax_file
shell_res = Shell(Operation, vbNormalFocus)
DoEvents
Else
Close #2
End If
End If
Close #1
'If Not Me.Debug_Sw Then
On Error Resume Next
Kill Fullname
'End If
If Ps_file <> "" Then
If Not Debug_Sw Then
On Error Resume Next
Kill Ps_file
End If
End If
Application.Wait (Now + TimeValue("0:00:01"))
If Fax_file <> "" Then
On Error Resume Next
Kill Fax_file
End If
'Backup Attachement name
P_Attachement_file = Attachement_file
End Function
Sub map_mxattach()
Dim Operation As String
Dim shell_res As Variant
Operation = "net use X: \\149.209.142.14\faxstar_xattach /PERSISTENT:NO "
shell_res = Shell(Operation, vbNormalFocus)
DoEvents
End Sub
Sub Xl_réduit()
'réduit la fenêtre et la positionne
'dans le coin supérieur gauche
With Application
.WindowState = xlNormal
.Width = 300
.Height = 300
.Top = 0
.Left = 0
End With
End Sub
Sub Xl_plein_ecran()
'redimensionne la fenêtre en plein écran
Application.WindowState = xlMaximized
End Sub
Sub relaunch()
Worksheets("Sheet1").Activate
'Réduit Excel'
Xl_réduit
UserForm2.Show
End Sub |
problème d'instabillité de code
Répondre avec citation
Envoyé par zazaraignée
Partager