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 |