Ответить на сообщение
Вернуться к теме
Вы отвечаете на сообщение:
ник: Аноним например, так
Option Explicit Private appWord As Word.Application Private docWord As Document Private objTable As Table Private rngCurrent As Word.Range Public Function rpt_Order(id As Long) As Boolean Dim lng As Long, _ sFileName As String, _ rs As ADODB.Recordset, _ sSQL As String On Error GoTo L_Err Screen.MousePointer = vbHourglass sFileName = App.Path & "\Templates\Order.dot" Set rs = New ADODB.Recordset sSQL = "SELECT tblOrder.*, tblCustomer.Name, tblOrderState.Name," _ & " [tblPersonnel].[Name] & IIf([FirstName]<>'',' ' & Left(([FirstName]),1) & '.','')" _ & " & IIf([PatronymicName]<>'',Left([PatronymicName],1) & '.','') AS FIO" _ & " FROM tblPersonnel INNER JOIN (tblOrderState INNER JOIN (tblOrder INNER JOIN" _ & " tblCustomer ON tblOrder.CustomerID = tblCustomer.CustomerID) ON" _ & " tblOrderState.OrderStateID = tblOrder.OrderStateID) ON tblPersonnel.PersonnelID" _ & " = tblOrder.PersonnelID" _ & " where OrderID=" & id rs.Open sSQL, cnn If rs.EOF Then MsgBox "Çàêàç íå íàéäåí â ÁÄ", vbExclamation, "rpt_Order": GoTo L_Exit Set appWord = New Word.Application appWord.Visible = True Set docWord = appWord.Documents.Add(sFileName, False, wdNewBlankDocument, True) docWord.SpellingChecked = False '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" Set objTable = docWord.Tables.Item(1) With objTable .Cell(2, 3).Range = IIf(IsNull(rs("DateOrder")), "", rs("DateOrder")) .Cell(3, 3).Range = IIf(IsNull(rs("NumberOrder")), "", rs("NumberOrder")) .Cell(4, 3).Range = IIf(IsNull(rs("OrderDescription")), "", rs("OrderDescription")) .Cell(5, 3).Range = IIf(IsNull(rs("tblCustomer.Name")), "", rs("tblCustomer.Name")) .Cell(6, 3).Range = IIf(IsNull(rs("CirculationProduction")), "", rs("CirculationProduction")) .Cell(7, 3).Range = IIf(IsNull(rs("FIO")), "", rs("FIO")) .Cell(8, 3).Range = IIf(IsNull(rs("tblOrderState.Name")), "", rs("tblOrderState.Name")) End With '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" Call ord_Calculation(id) L_Exit: Screen.MousePointer = vbDefault Set rs = Nothing: Set appWord = Nothing Set docWord = Nothing: Set objTable = Nothing Exit Function L_Err: MsgBox Err.Description & " (" & Err.Number & ")", vbExclamation, "rpt_Order": GoTo L_Exit End Function Private Sub ord_Calculation(id As Long) Dim DiscountKoeff As Double, _ IncreaseKoeff As Double, _ cost_Design As Double, _ cost_PrintWork As Double, _ cost_PrintMaterial As Double, _ cost_PrintCutting As Double, _ cost_PostPrintWork As Double, _ cost_PostPrintMaterial As Double, _ cost_AdditionalWork As Double, _ cost_Pay As Double, _ cost_Total As Double, _ cost_Final As Double Dim sSQL As String, _ rs As ADODB.Recordset On Error GoTo L_Err Set rs = New ADODB.Recordset 'êîýôôèöèåíòû ñêèäêè/íàäáàâêè, äèçàéí èç òàáëèöû "tblOrder" sSQL = "select * from tblOrder where OrderID=" & id rs.Open sSQL, cnn If rs.EOF Then rs.Close: GoTo L_Exit DiscountKoeff = IIf(IsNull(rs("CostDiscountKoeff")), 0#, rs("CostDiscountKoeff")) objTable.Cell(21, 2).Range = Format(cost_Design, "###0.00") IncreaseKoeff = IIf(IsNull(rs("CostIncreaseKoeff")), 0#, rs("CostIncreaseKoeff")) objTable.Cell(22, 2).Range = Format(cost_Design, "###0.00") cost_Design = IIf(IsNull(rs("CostDesign")), 0, rs("CostDesign")) objTable.Cell(11, 4).Range = Format(cost_Design, "###0.00") rs.Close 'ñòîèìîñòü ïå÷àòè èç òàáëèöû "tblOrderPrint" sSQL = "SELECT tblOrderPrint.OrderID, Sum(tblOrderPrint.PriceMaterial)" _ & " AS SumOfPriceMaterial, Sum(tblOrderPrint.PricePrint) AS SumOfPricePrint," _ & " Sum(tblOrderPrint.PriceCutting) AS SumOfPriceCutting" _ & " From tblOrderPrint" _ & " Where OrderID = " & id _ & " GROUP BY tblOrderPrint.OrderID" rs.Open sSQL, cnn If Not rs.EOF Then cost_PrintWork = IIf(IsNull(rs("SumOfPricePrint")), 0, rs("SumOfPricePrint")) objTable.Cell(12, 4).Range = Format(cost_PrintWork, "###0.00") cost_PrintMaterial = IIf(IsNull(rs("SumOfPriceMaterial")), 0, rs("SumOfPriceMaterial")) objTable.Cell(13, 4).Range = Format(cost_PrintMaterial, "###0.00") cost_PrintCutting = IIf(IsNull(rs("SumOfPriceCutting")), 0, rs("SumOfPriceCutting")) objTable.Cell(14, 4).Range = Format(cost_PrintCutting, "###0.00") End If rs.Close 'ñòîèìîñòü ïîñëåïå÷àòè èç òàáëèöû "tblOrderPostPrint" sSQL = "SELECT tblOrderPostPrint.OrderID, Sum(tblOrderPostPrint.PostPrintCostMaterial)" _ & " AS SumOfPostPrintCostMaterial, Sum(tblOrderPostPrint.PostPrintCostWork)" _ & " AS SumOfPostPrintCostWork" _ & " From tblOrderPostPrint" _ & " Where OrderID = " & id _ & " GROUP BY tblOrderPostPrint.OrderID" rs.Open sSQL, cnn If Not rs.EOF Then cost_PostPrintWork = IIf(IsNull(rs("SumOfPostPrintCostWork")), 0, rs("SumOfPostPrintCostWork")) objTable.Cell(15, 4).Range = Format(cost_PostPrintWork, "###0.00") cost_PostPrintMaterial = IIf(IsNull(rs("SumOfPostPrintCostMaterial")), 0, rs("SumOfPostPrintCostMaterial")) objTable.Cell(16, 4).Range = Format(cost_PostPrintMaterial, "###0.00") End If rs.Close 'âêëàäêà äîïîëíèòåëüíûå ðàáîòû sSQL = "SELECT tblOrderAdditionalWork.OrderID, Sum(tblOrderAdditionalWork.Cost)" _ & " AS SumOfCost From tblOrderAdditionalWork" _ & " Where OrderID = " & id _ & " GROUP BY tblOrderAdditionalWork.OrderID" rs.Open sSQL, cnn If Not rs.EOF Then cost_AdditionalWork = IIf(IsNull(rs("SumOfCost")), 0, rs("SumOfCost")) objTable.Cell(17, 4).Range = Format(cost_Pay, "###0.00") End If rs.Close cost_Total = cost_Design + cost_PrintWork + cost_PrintMaterial + cost_PrintCutting _ + cost_PostPrintWork + cost_PostPrintMaterial + cost_AdditionalWork objTable.Cell(18, 2).Range = Format(cost_Total, "###0.00") 'âêëàäêà îïëàòà sSQL = "SELECT tblOrderPay.OrderID, Sum(tblOrderPay.PaySumma) AS SumOfPaySumma" _ & " From tblOrderPay" _ & " Where OrderID = " & id _ & " GROUP BY tblOrderPay.OrderID" rs.Open sSQL, cnn If Not rs.EOF Then cost_Pay = IIf(IsNull(rs("SumOfPaySumma")), 0, rs("SumOfPaySumma")) objTable.Cell(20, 2).Range = Format(cost_Pay, "###0.00") End If rs.Close cost_Final = cost_Total - cost_Total * DiscountKoeff / 100# _ + cost_Total * IncreaseKoeff / 100# - cost_Pay objTable.Cell(24, 2).Range = Format(cost_Final, "###0.00") L_Exit: Set rs = Nothing: Exit Sub L_Err: MsgBox Err.Description & " (" & Err.Number & ")", vbExclamation, "update_Calculation": GoTo L_Exit End Sub
Ваше имя:
Пароль:
Сообщение:
Прикрепить:
Для вставки смайлов в текст щелкните по значку.