Добрый день!
Есть несколько вопросов, на которые не смог найти ответы.
Первое. Вот код скрипта.
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.
'Provider=Microsoft.Jet.OLEDB.4.0;Data Source="C:\Program Files\GeoS\K3-Мебель ПКМ 64\Data\PKM\Proto\";Extended Properties=dBase IV
' Набор глобальных переменных
Dim objCn 'Обект - соединение с базой
Dim ObjExc 'Объект Excel
Dim dbPrice 'Имя базы с прайсом
Dim dbOut 'Имя выводной базы
Dim Path 'Путь для сохранения
Dim MaxElements ' Максимальное число строк в табличке ++23.12.2004
Dim NowElements ' Сколько уже показано ++23.12.2004
Dim LastPageRow ' Последняя строка на странице ++23.12.2004
Dim NumTablesOnPage 'Число страниц на таблице ++23.12.2004
'=============== СТАРТОВАЯ ФУНКЦИЯ ======================
'Входные параметры для выполнения скрипта:
' szWMFPath - путь до картинки с WMF
' szPath - путь до DBF файлов
' szOutTbl - имя файла bOutTbl
' szPrice - имя DBF c прайсом
' i - номер листа
'========================================================
Sub DoForma(szWMFPath,szPath,szOutTbl,szPrice,client,mail)
MaxElements = 23 'Всего строк в таблице (от 1 до 23) ++23.12.2004
NowElements = 0 '++23.12.2004
LastPageRow = 57 'Сдвиг до следующего листа в терминах строк ++23.12.2004
NumTablesOnPage = 1 ' Пока число таблиц на листе ++23.12.2004
Path = szPath
DoConnectBase(szPath),(szOutTbl),(szPrice)' Подсоединение к базе данных
CreatTable() 'Создадим заготовку таблицу
FillTbl() 'Заполним заготовку таблицу
Set ObjExc = CreateExcel("Клиент") ' Документ Excel
FillExcel(ObjExc) ' Заполним документ Excel
' InsertWmfPicture(szWMFPath),(nScale) ' Вставка картинки в шаблон
' DoFillForma(nDet)
' FinishForma()
' objCn.Close
End Sub
'========================================================
' Подсоединение к базе данных
'========================================================
Function DoConnectBase(szPath, szOutTbl, szPrice)
' Переименуем .ptm в более удобоваримое
Set Fobj = CreateObject("Scripting.FileSystemObject")
Fobj.CopyFile szPath&"\"&szPrice, szPath&"\"&"TmpShkaf.dbf"
Set Fobj = Nothing
dbPrice = "TmpShkaf.dbf"
dbOut = szOutTbl
' Процесс подсоединения к базам DBF
Set objCn = CreateObject("ADODB.Connection")
objCn.Provider = "Microsoft.Jet.OLEDB.4.0"
objCn.ConnectionString = "Data Source="+szPath+";Extended Properties=dBase IV"
objCn.Open
End Function
'========================================================
'Создадим заготовку таблицу
'========================================================
Sub CreatTable()
If (FsoIsFileExist(Path+"SpecTbl.dbf")) Then
FsoDeleteFile(Path+"SpecTbl.dbf")
End If
SQLStr="CREATE TABLE SpecTbl (Mark INTEGER, Name VARCHAR(50), Cnt INTEGER, Unit VARCHAR(6))"
Set RsetM = CreateObject("ADODB.Recordset")
RSetM.CursorType = 1
RSetM.Open SQLStr, ObjCn
End Sub
'========================================================
'Заполним таблицу данными сцены
'========================================================
Sub FillTbl()
'-- Выбираем материалы
SQLStr="SELECT MATNAME FROM ["+dbOut+"],["+dbPrice+_
"] WHERE (UNITS = 2 OR MATTYPE = 99 OR MATTYPE = 48) AND PRICEID = COD AND ASSEMBLY = 0 GROUP BY MATNAME"
Set RSet1=RecordsetDB(ObjCn, SQLStr)
Rows1 = RSet1.RecordCount
If Rows1<>0 Then
SQLStr="INSERT INTO SpecTbl VALUES (1,'Материалы',0,0)"
RSet1.Close
RSet1.Open SQLStr, ObjCn
SQLStr="INSERT INTO SpecTbl (Mark, Name , Cnt, Unit) SELECT 0, MATNAME, Round(SUM(XUNIT*YUNIT)/1000000.0,2), 'кв.м' FROM ["+dbOut+"],["+dbPrice+_
"] WHERE (UNITS = 2 OR MATTYPE = 99 OR MATTYPE = 48) AND PRICEID = COD AND ASSEMBLY = 0 GROUP BY MATNAME"
RSet1.Open SQLStr, ObjCn
End If
'-- Выбираем Комплектующие
SQLStr="SELECT MATNAME FROM ["+dbOut+"],["+dbPrice+_
"] WHERE (MATTYPE = 93 OR (MATTYPE = 134 AND PRICEID <> 388 AND PRICEID <> 665 AND PRICEID <> 666 AND PRICEID <> 667) OR MATTYPE = 136 OR MATTYPE = 143 OR MATTYPE = 190 OR MATTYPE = 192) AND UNITS<>11 AND PRICEID = COD AND ASSEMBLY = 0 GROUP BY MATNAME"
Set RSet1=RecordsetDB(ObjCn, SQLStr)
Rows1 = RSet1.RecordCount
If Rows1<>0 Then
SQLStr="INSERT INTO SpecTbl VALUES (1,'Комплектующие',0,0)"
RSet1.Close
RSet1.Open SQLStr, ObjCn
SQLStr="INSERT INTO SpecTbl (Mark, Name , Cnt, Unit) SELECT 0, MATNAME, SUM(COUNT), 'шт' FROM ["+dbOut+"],["+dbPrice+_
"] WHERE (MATTYPE = 93 OR (MATTYPE = 134 AND PRICEID <> 388 AND PRICEID <> 665 AND PRICEID <> 666 AND PRICEID <> 667) OR MATTYPE = 136 OR MATTYPE = 143 OR MATTYPE = 190 OR MATTYPE = 192) AND UNITS<>11 AND PRICEID = COD AND ASSEMBLY = 0 GROUP BY MATNAME"
RSet1.Open SQLStr, ObjCn
End If
'-- Выбираем длиномеры
SQLStr="SELECT LNGNAME FROM LBOutTbl GROUP BY LNGNAME"
Set RSet1=RecordsetDB(ObjCn, SQLStr)
Rows1 = RSet1.RecordCount
If Rows1<>0 Then
SQLStr="INSERT INTO SpecTbl VALUES (1,'Длиномеры',0,0)"
RSet1.Close
RSet1.Open SQLStr, ObjCn
SQLStr="INSERT INTO SpecTbl (Mark, Name , Cnt, Unit) SELECT 0, (Switch(LNGTYPE=0,'Столешница',LNGTYPE=4,"+_
"'Карниз профильный',LNGTYPE=3,'Плинтус',LNGTYPE=5,'Цоколь',LNGTYPE=2,'Ф/П',LNGTYPE=6,'Св.панель',"+_
"LNGTYPE=7,'Балюстрада')), SUM(XUNIT), 'м.п.' FROM LBOutTbl"+_
" WHERE LNGTYPE <> 1 GROUP BY LNGTYPE"
RSet1.Open SQLStr, ObjCn
End If
End Sub
'========================================================
'Создадим приложение Excel
'========================================================
'-- Функция создает объект "документ Excel"
'-- Входные данные:
'-- Name - имя листа
'-- Выходные параметры:
'-- функция возвращает значение - объект Excel
Function CreateExcel(Name)
Set ObjExc = CreateObject("Excel.Application")
If Not ObjExc Is Nothing Then
ObjExc.Visible = True
ObjExc.Workbooks.Add(1)
With ObjExc.Sheets(1)
.Select
.Name = Name
.PageSetup.RightMargin = objExc.CentimetersToPoints(0.6)
.PageSetup.LeftMargin = objExc.CentimetersToPoints(1)
.PageSetup.BottomMargin = objExc.CentimetersToPoints(0.6)
.PageSetup.TopMargin = objExc.CentimetersToPoints(1.9)
.PageSetup.CenterHorizontally = True
End With
Set CreateExcel=ObjExc
Else
Set CreateExcel=Nothing
End If
End Function
'========================================================
' Заполним документ
'========================================================
Sub FillExcel(Doc)
With Doc
.Columns("A:A").ColumnWidth = 2.8
.Columns("B:K").ColumnWidth = 8.43
.Columns("D:D").ColumnWidth = 10.86
.Columns("F:F").ColumnWidth = 4.71
.Columns("J:J").ColumnWidth = 11.43
.Sheets(1).PageSetup.RightHeader = "&""-,italic""&20МФ ""-----"""
End With
temp=Write("Заказчик:","A",1,Doc,1,0,14)
temp=Write(client,"C",1,Doc,0,1,14)
End Sub
'========================================================
' Завершение работы
' Надо предложить сохранить документ
'========================================================
Function FinishForma()
Dim Name
Name = Path&"\Hell.xls"
objCn.Close
ObjExc.ActiveWorkBook.SaveAs(Name)
ObjExc.Quit
Set ObjExc = Nothing
End Function
'========================================================
' Вставка картинки в шаблон
'========================================================
Function InsertWmfPicture(szWMFPath, WScale)
Dim lWscale
Dim Aspect
Dim Shift
'lWscale = WScale*2.0
lWscale = Eval(WScale)*1.0
'K3F.Display(lWscale)
' Привяжемся к верхнему левому углу
rr="C7"
objExc.ActiveSheet.Range(rr).Select
Set r1 = objExc.Range("C7:I50")
Set a = ObjExc.ActiveSheet.Pictures.Insert(szWMFPath)
a.ShapeRange.LockAspectRatio = 0'WScale
a.ShapeRange.Height = r1.Height
a.ShapeRange.Width = r1.Width
Aspect = r1.Height / r1.Width
'a.ShapeRange.ScaleWidth 1.0, msoFalse, msoScaleFromTopLeft
'K3F.Display(lWscale)
'K3F.Display(Aspect)
If lWscale < Aspect Then
a.ShapeRange.ScaleHeight (lWscale/Aspect), msoFalse, msoScaleFromTopLeft
a.ShapeRange.ScaleHeight (0.9), msoFalse, msoScaleFromTopLeft
a.ShapeRange.ScaleWidth (0.9), msoFalse, msoScaleFromTopLeft
'K3F.Display(Aspect)
a.ShapeRange.IncrementLeft (r1.Width*(0.1)/2)
Else
Shift = (r1.Width-r1.Width*(Aspect/lWscale))/2
a.ShapeRange.ScaleWidth (Aspect/lWscale), msoFalse, msoScaleFromTopLeft
'K3F.Display(Shift)
a.ShapeRange.IncrementLeft Shift
End If
End Function
'------------------------------------------------------------------------------------------------
Function FsoIsFileExist(DstFile)
Dim Res
Set Fso = CreateObject("Scripting.FileSystemObject")
Res = Fso.FileExists(DstFile)
Set Fso = Nothing
FsoIsFileExist = Res
End Function
'---------------------------------------------------------------------------------------
Sub FsoDeleteFile(DstFile)
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.DeleteFile(DstFile)
Set Fso = Nothing
End Sub
'------------------------------------------------------------------------------------------------
'-- Функция возвращает набор записей из базы данных
'-- Входные параметры
'-- SQLStr - строка SQL
'-- ObjDB - объект - соединение с БД
'-- Выходные параметры:
'-- Функция возвращает значение - объект "набор записей"
Function RecordsetDB(ObjDB, SQLStr)
Set objRs = CreateObject("ADODB.Recordset")
objRs.CursorType = 1
objRs.Open SQLStr, ObjDB
Rows = objRs.RecordCount
Set RecordsetDB=objRs
If Rows < 1 Then
Exit Function
End If
objRs.MoveFirst
End Function
'--------------------------------------------------------------------------------------
'-- Функция выводит в текст
'-- Входные данные:
'-- text - Текст
'-- Row - номер строки для вывода
'-- Column - номер колонки для вывода первого элемента
'-- Object - объект Excel, в который вставляются данные
'-- FBold - логическая переменная, показывающая жирность шрифта
'-- FItalic - логическая переменная, показывающая курсивность шрифта
'-- FSize - размер шрифта
'-- Выходные данные:
'-- Функция возвращает номер записанной строки
Function Write(text, Row, Column, Doc, FBold, FItalic, FSize)
Cell=Row&Column
With Doc
.Range(Cell).Value = text
.Range(Cell).Font.Bold = FBold
.Range(Cell).Font.Italic = FItalic
.Range(Cell).Font.Size = FSize
End With
Write=Row
End Function
Входная функция DoForma принимает переменные. Дальше выполняются подфункии.
Когда идёт запуск функции FillExcel(ObjExc), в которой заполняется лист Экселя, то все переменные пропадают.
Почему так?
Почему-то после закрытия документа excel остаётся висеть сам процесс excel.
Что бы залить ячейку цветом, исходя из макроса сделанного в самом Excel, есть параметр
.ThemeColor = код цвета. В макросе Excel цвет можно задать названием, но в скрипте он не сработает. Когда направляешь курсор на эту переменную, в макросе, то выводится цифра 1 или 2, но введя такую цифру в скрипте нужного цвета не получится. Тут вообще получается лишь 10 цветов. Как залить нужным цветом?
Ещё создал макрос с заливкой ячейки градиентом. Вставил полученный код в скрипт, но он ругается на свойство или объект .Gradient . Как градиентом залить. Вот код, который в скрипте не сработал.
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.
'-- Функция выводит в заголовок раздела
'-- Входные данные:
'-- text - Текст
'-- Row - номер строки для вывода
'-- Object - объект Excel, в который вставляются данные
'-- FBold - логическая переменная, показывающая жирность шрифта
'-- FItalic - логическая переменная, показывающая курсивность шрифта
'-- FSize - размер шрифта
'-- Clr - цвет заливки
'-- Выходные данные:
'-- Функция возвращает номер записанной строки
Function WriteH(text, Row, Doc, FBold, FItalic, FSize, Clr)
Cell="E"&Row
With Doc
.Range(Cell).Value = text
.Range(Cell).Font.Bold = FBold
.Range(Cell).Font.Italic = FItalic
.Range(Cell).Font.Size = FSize
.Range("E"&Row&":"&"K"&Row).MergeCells = True
.Range("E"&Row).HorizontalAlignment = 1
End With
With Doc.Range("E"&Row).Interior
.Pattern = xlPatternLinearGradient
' .Gradient.Degree = 180
' .Gradient.ColorStops.Clear
End With
With Doc.Range("E"&Row).Interior.Gradient.ColorStops.Add(0)
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With Doc.Range("E"&Row).Interior.Gradient.ColorStops.Add(1)
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.349009674367504
End With
End Function
|
