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
| Public Sub Export_Excelsheet(From_Table As String, to_file As String, Specific_param As Variant)
Dim recv As Recordset
Dim Reci As Recordset
Dim Recexcel As Recordset
Dim Argument As String
Dim Quote As String
Dim nada As Variant
Dim Dbv As Database
Dim document As String
Dim Excel_Workbook As String
Quote = """"
'Reference Current Database
Set Dbv = DBEngine.Workspaces(0).Databases(0)
'Open Recordset Zcontrol and get 1st record
Set recv = Dbv.OpenRecordset("SQL_Zcontrol", , dbReadOnly)
recv.FindFirst "DB_Year > 0"
If recv.EOF Then GoTo exit_export_excelsheet
'Open Recordset Installations and get 1st record
Set Reci = Dbv.OpenRecordset("SQL_Installation_Lines", , dbReadOnly)
Reci.FindFirst "Install_Nr > 0"
If Reci.NoMatch Then GoTo exit_export_excelsheet
document = Trim(recv![Generated_excel_Folder]) & Format(Now, "yyyy-mm-dd") & "-" & Trim(to_file) & ".Xls"
Excel_Workbook = recv![Generated_File_Prefix] & Format(Now, "yyyy-mm-dd") & "-" & Trim(to_file) & ".Xls"
On Error Resume Next
Kill document
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, From_Table, document, True
'Open Recordset Export_Excel and get 1st record
Set Recexcel = Dbv.OpenRecordset("SQL_Export_Excel", dbOpenDynaset, dbReadOnly)
Argument = "Object_Name = '" & From_Table & "'"
Recexcel.FindFirst Argument
If Recexcel.NoMatch Then
MsgBox to_file & " exported to " & Trim(recv![Generated_excel_Folder]) & Format(Now, "yyyy-mm-dd") & "-" & Trim(to_file) & ".Xls"
GoTo exit_export_excelsheet
End If
MsgBox to_file & " exported to " & Trim(recv![Generated_excel_Folder]) & Format(Now, "yyyy-mm-dd") & "-" & Trim(to_file) & ".Xls (Script File '" & Trim(recv![Excel_Script_File]) & "[" & Trim(Recexcel![Script_Name]) & "]' will be applied now)"
Call Execute_Excel_Script(document, Excel_Workbook, recv![Script_Folder], recv![Excel_Script_File], Recexcel![Script_Name], Specific_param)
Recexcel.Close
recv.Close
Reci.Close
exit_export_excelsheet: '
End Sub
Sub Execute_Excel_Script(document As String, Excel_Workbook As String, Script_Folder As String, Excel_Script_File As String, Script_Name As String, Specific_param As Variant)
On Error Resume Next
Dim XLApp As Object
Dim ExcelWasNotRunning As Boolean ' Indicateur de libération finale.
Dim FullScript As String
FullScript = Trim(Script_Folder) & Trim(Excel_Script_File)
Set XLApp = GetObject(, "Excel.Application")
If err <> 0 Then
err.Clear
ExcelWasNotRunning = True
Set XLApp = CreateObject("Excel.application")
Else
ExcelWasNotRunning = False
End If
XLApp.Visible = True
Set XlWkb = XLApp.Workbooks.Open(FullScript)
'
' ici nous lançons les macros automatiques d'Excel mais vous pouvez mettre du code
'
XlWkb.RunAutoMacros xlAutoOpen
XLApp.Run Script_Name, document, Excel_Workbook, Excel_Script_File, Specific_param
'XlWkb.Save
XlWkb.Close
'If ExcelWasNotRunning = True Then
XLApp.Application.Quit
'End If
Set XlWkb = Nothing
Set XLApp = Nothing
'Set m_Access = Access.Application
'm_Access.Visible = True
End Sub |
