DoCmd.OutputTo

Const stMsgTitle =  "209 ; 226 ; 255 ; 231 ; 252 ;  241 ; MS Office"


Dim objXLApp As Object            'New Excel.Application
Dim objXLBook As Object            'Excel.Workbook
Dim objSheet As Object            'Excel.Worksheet
Dim objXLRange As Object            'Excel.Range
Dim Cells As Object
Dim cnn As ADODB.Connection
Dim cmdLost As ADODB.Command
Dim rstLost As ADODB.Recordset
Dim varResults As Variant
Dim intCount As Integer
Dim intCountFld As Integer
Dim i As Integer
Dim f As Integer
Dim r As Integer
Dim iNum As Integer
Dim stGroup As String
Dim bDark As Boolean                'ïîëîñû
Dim stHC As String                  ' 239 ; 229 ; 240 ; 229 ; 236 ; 229 ; 237 ; 237 ; 237 ; 224 ; 255 ;  228 ; 235 ; 255 ;  243 ; 228 ; 224 ; 235 ; 229 ; 237 ; 232 ; 255 ;  237 ; 229 ; 239 ; 229 ; 247 ; 224 ; 242 ; 237 ; 251 ; 245 ;  241 ; 232 ; 236 ; 226 ; 238 ; 235 ; 238 ; 226 ;
Dim lAsc As Long
Dim iBeginFormat As Integer         'ïåðâàÿ ÿ÷åéêà ñëåâà äëÿ äåíåæíîãî ôîðìàòà
Dim ArGroupHeads() As Variant       ' 236 ; 224 ; 241 ; 241 ; 232 ; 226 ;  228 ; 235 ; 255 ;  231 ; 224 ; 239 ; 238 ; 236 ; 232 ; 237 ; 224 ; 237 ; 232 ; 255 ;  241 ; 242 ; 240 ; 238 ; 234 ;  231 ; 224 ; 227 ; 235 ; 238 ; 226 ; 238 ; 226 ;
Dim iArGH As Integer              'èíäåêñ äëÿ ýòîãî ìàññèâà
Dim stCompTel As String

Private Function SetXLobjects(stTemplatesName As String, stSheetName As String, strSQL As String, _
                                frmInd As Form, ctlInd As Control) As Boolean
On Error GoTo HandleError
   
    Set objXLApp = CreateObject("Excel.Application")    '. 9  ")
    Set objXLBook = GetObject(CurrentProject.Path & " \Templates\ " & stTemplatesName)
    Set objSheet = objXLBook.Worksheets(stSheetName)
    Set cnn = New ADODB.Connection
    cnn.ConnectionString = " Provider=Microsoft.Jet.OLEDB. 4 . 0 ; " & _
                " Data Source= " & CurrentProject.Path & " \ " & CurrentProject.name
    cnn.Open
    Set cmdLost = New Command
    With cmdLost
        .ActiveConnection = cnn.ConnectionString
        .CommandText = strSQL
        .Prepared = True
         Set rstLost = .Execute()
    End With
    varResults = rstLost.GetRows
    intCountFld = UBound(varResults, 1 ) +  1     ' ïîëåé
    intCount = UBound(varResults, 2) + 1    '  241 ; 242 ; 240 ; 238 ; 234 ;
   
    With frmInd
        !Capt1.Caption = " 212 ; 238 ; 240 ; 236 ; 232 ; 240 ; 238 ; 226 ; 224 ; 237 ; 232 ; 229 ;  228 ; 238 ; 234 ; 243 ; 236 ; 229 ; 237 ; 242 ; 224 ;  226 ; MS EXCEL... "
        ctlInd.Value = 1 
        ctlInd.Visible = True
        .Repaint
    End With
    ctlInd.Value =  2 
    frmInd.Repaint
ExitHere:
    SetXLobjects = True
    Exit Function
HandleError:
    Select Case Err.number
        Case  432 
            MsgBox " 206 ; 248 ; 232 ; 225 ; 234 ; 224 ; # " & Err.number & " :   205 ; 229 ;  237 ; 224 ; 233 ; 228 ; 229 ; 237 ;  244 ; 224 ; 233 ; 235 ;  248 ; 224 ; 225 ; 235 ; 238 ; 237 ; 224 ;  228 ; 238 ; 234 ; 243 ; 236 ; 229 ; 237 ; 242 ; 224 ; ", vbCritical, stMsgTitle
        Case Else
            MsgBox Err.Description, vbExclamation, " Error  " & Err.number
    End Select
    SetXLobjects = False
    Resume ExitHere
End Function

Public Sub CreateXLPriceList(strSQL As String, stFields As String, stComment As String, ByGroups As Boolean, _
                             showDate As Boolean, showCompany As Boolean, showTel As Boolean, showComment As Boolean, _
                             stComp As String, stTel As String, bLand As Boolean, iGrayXL As Integer, _
                             ctlInd As Control, frmInd As Form, ArHeads() As Variant, stTemplatesName As String, _
                             stSheetName As String)
                             
    On Error GoTo HandleError
    
    If Not SetXLobjects(stTemplatesName, stSheetName, strSQL, frmInd, ctlInd) Then Err.Raise 1000233 
    
    With objSheet
        .Range("rngClearA ").Clear
       stCompTel = IIf(showCompany = True, stComp, "  ") & IIf(showTel = True, _
                                 "                                  " & stTel, "  ")
        .Range(" companyname ") = stCompTel
        For f = 1  To UBound(ArHeads,  2 )
          stHC = CStr(ArHeads( 0 , f))
            ' óáèðàåì íåïå÷àòíûå ñèìâîëû (Ñhr(13) èëè Chr(10))
          For i = 1 To Len(stHC)
            lAsc = Asc(mid$(stHC, i, 1))
            If lAsc = 10 Or lAsc = 13 Then Mid$(stHC, i, 1) = " "
          Next i
          ctlInd.Value = 3
          frmInd.Repaint
          .Cells(7, 1 + f) = stHC
                ' 231 ; 224 ; 239 ; 238 ; 236 ; 232 ; 237 ; 224 ; 229 ; 236 ;  239 ; 229 ; 240 ; 226 ; 238 ; 229 ;  246 ; 229 ; 237 ; 238 ; 226 ; 238 ; 229 ;  239 ; 238 ; 235 ; 229 ;
          If ArHeads( 2 , f) =  10  Then iBeginFormat = f
          If ArHeads( 2 , f) <  10  Then
                'óñòàíàâëèâàåì øèðèíó ïîëåé
            If ArHeads(2, f) < 4 Then
               If ArHeads(2, f) = 1 Then
                 .Columns(2).ColumnWidth = 3
               Else
                 .Columns(1 + f).ColumnWidth = 5
               End If
            ElseIf ArHeads(2, f) = 4 Then
               .Columns(1 + f).ColumnWidth = Len(ArHeads(0, f)) * 1.5
            Else
               .Columns(1 + f).ColumnWidth = ArHeads(2, f)
            End If
          Else
            .Columns(1 + f).ColumnWidth = 11
          End If
          ctlInd.Value = 4
          frmInd.Repaint
         With .Rows(7)
            .RowHeight = 25.5
            .HorizontalAlignment = -4108        'xlCenter
            .VerticalAlignment = - 4108           'xlCenter
            .WrapText = True
            .Orientation = 0
            .AddIndent = False
            .ShrinkToFit = False
            .MergeCells = False
        End With
        Next
        ctlInd.Value = 5
        frmInd.Repaint
                ' 243 ; 241 ; 242 ; 224 ; 237 ; 224 ; 226 ; 235 ; 232 ; 226 ; 224 ; 229 ; 236 ;  237 ; 229 ; 233 ; 242 ; 240 ; 224 ; 235 ; 252 ; 237 ; 251 ; 233 ;  228 ; 229 ; 237 ; 229 ; 230 ; 237 ; 251 ; 233 ;  244 ; 238 ; 240 ; 236 ; 224 ; 242 ;  226 ; 224 ; 235 ; 254 ; 242 ; ( 225 ; 229 ; 231 ;  241 ; 232 ; 236 ; 226 ; 238 ; 235 ; 224 ;  234 ; 238 ; 237 ; 234 ; 240 ; 229 ; 242 ; 237 ; 238 ; 233 ;  226 ; 224 ; 235 ; 254 ; 242 ; 251 ;)
         .Range(objSheet.Cells( 8 , iBeginFormat), objSheet.Cells(intCount +  1 , f)).NumberFormat = "#,## 0 .00_ 240 ;_. "
        With .Range(objSheet.Cells(7 ,  2 ), objSheet.Cells( 7 , f))    'çàãîëîâîê
            With .Borders
                .LineStyle = 1  'xlContinuous
                .Weight =  2      'xlThin
            End With
            .Font.size = 8
            .HorizontalAlignment = -4108    'xlCenter
            '.Interior.ColorIndex = 15      ' 246 ; 226 ; 229 ; 242 ;  227 ; 235 ; 224 ; 226 ; 237 ; 238 ; 227 ; 238 ;  231 ; 224 ; 227 ; 238 ; 235 ; 238 ; 226 ; 234 ; 224 ;
        End With
    End With
        For i = intCount -  1  To  0  Step - 1 
            If ctlInd.Value <  99  Then
                ctlInd.Value = ctlInd.Value +  95  / intCount
                frmInd.Repaint
            End If
            'ïåðâóþ ñòðîêó ãðóïïû ïîäïèñûâàåì íàçâ ãðóïïû èç _
             ìàññèâà, à ïîòîì ïðèñâàèâàåì çíà÷åíèå ïåðåìåííîé
            If ByGroups Then
                If stGroup <> varResults(0, i) Then     ' 229 ; 241 ; 235 ; 232 ;  237 ; 229 ;  240 ; 224 ; 226 ; 237 ; 238 ;,  231 ; 237 ; 224 ; 247 ; 232 ; 242 ; -  237 ; 238 ; 226 ; 224 ; 255 ;  227 ; 240 ; 243 ; 239 ; 239 ; 224 ;,  231 ; 224 ; 239 ; 232 ; 241 ; 251 ; 226 ; 224 ; 229 ; 236 ;
                   If r <>  0  Then                            'åñëè íå ïåðâàÿ ñòðîêà
                        objSheet.Cells(8 + r, 3) = ""        ' 239 ; 243 ; 241 ; 242 ; 243 ; 254 ;  241 ; 242 ; 240 ; 238 ; 234 ; 243 ;,  247 ; 242 ; 238 ; 225 ; 251 ;  238 ; 242 ; 228 ; 229 ; 235 ; 232 ; 242 ; 252 ;  231 ; 224 ; 227 ; 238 ; 235 ; 238 ; 226 ; 238 ; 234 ;  227 ; 240 ; 243 ; 239 ; 239 ; 251 ;
                        r = r +  1 
                   End If
                   objSheet.Cells( 8  + r,  3 ) = varResults( 0 , i)
                   iArGH = iArGH +  1 
                   
                   ReDim Preserve ArGroupHeads(iArGH)   'çäåñü áóäåì çàïîìèíàòü ðÿäû ñ çàãîëîâêàìè ãðóï
                   ArGroupHeads(iArGH) = 8 + r
                   
                   With objSheet.Range(objSheet.Cells(8 + r, 3), objSheet.Cells(8 + r, intCountFld))
                        .Font.Italic = True
                        .Font.Bold = True
                   End With
                   stGroup = varResults(0, i)           ' 231 ; 224 ; 239 ; 238 ; 236 ; 232 ; 237 ; 224 ; 229 ; 236 ;
                   r = r +  1                             'äîáàâèëàñü ñòðîêà
                   bDark = False
                End If
            End If
            iNum = iNum + 1                      ' 226 ; 229 ; 228 ; 229 ; 236 ;  241 ; 247 ; 229 ; 242 ; 247 ; 232 ; 234 ;  239 ; 238 ; 240 ; 255 ; 228 ; 234 ; 238 ; 226 ; 251 ; 245 ;  237 ; 238 ; 236 ; 229 ; 240 ; 238 ; 226 ;
            objSheet.Cells( 8  + r,  2 ) = iNum                'ïîðÿäêîâûé íîìåð
            For f = 1 To intCountFld - 1 Step 1
                objSheet.Cells(8 + r, 2 + f) = varResults(f, i)
            Next f
            If iGrayXL = 3 Or iGrayXL = 2 Then
                If bDark Then
                   objSheet.Range(objSheet.Cells(8 + r, 2), objSheet.Cells(8 + r, intCountFld + 1)).Interior.ColorIndex = 15
                Else
                   objSheet.Range(objSheet.Cells(8 + r, 2), objSheet.Cells(8 + r, intCountFld + 1)).Interior.ColorIndex = 2
                End If
            End If
            bDark = Not bDark
            r = r + 1
        Next i
        With objSheet.Range(objSheet.Cells(8, 2), objSheet.Cells(7 + r, 1 + f))
            With .Borders
                .LineStyle = 1  'xlContinuous
                .Weight =  1      'xlHairline
                .ColorIndex = -4105     '16
            End With
            .Font.size =  8 
            .Font.name = "Arial Cyr "
        End With
        With objSheet
            If showComment Then
                With .Range(objSheet.Cells(7  + r +  2 ,  2 ), objSheet.Cells( 7  + r +  2 ,  2 ))
                    .Font.name = "Arial Cyr "
                    .Font.size = 8 
                    .FormulaR1C1 = " 207 ; 240 ; 232 ; 236 ; 229 ; 247 ; 224 ; 237 ; 232 ; 229 ;: "
                End With
                With .Range(objSheet.Cells(7  + r +  3 ,  2 ), objSheet.Cells( 7  + r +  8 , f))
                    .Font.name = "Arial Cyr "
                    .Font.size = 8 
                    .HorizontalAlignment = - 4131                 'xlLeft
                    .VerticalAlignment = -4160                  'xlTop
                    .WrapText = True
                    .Orientation =  0 
                    .AddIndent = False
                    .IndentLevel =  0 
                    .ShrinkToFit = False
                    .MergeCells = True
                    .FormulaR1C1 = stComment
                End With
            End If
            If showDate Then
                With .Range(objSheet.Cells( 2 ,  6 ), objSheet.Cells( 2 ,  8 ))
                    .Font.name = "Arial Cyr "
                    .Font.size = 8 
                    .HorizontalAlignment = - 4108                   'xlLeft
                    .VerticalAlignment = -4160                  'xlTop
                    .WrapText = True
                    .Orientation =  0 
                    .AddIndent = False
                    .IndentLevel =  0 
                    .ShrinkToFit = False
                    .MergeCells = True
                    .FormulaR1C1 = Date
                End With
            End If
        End With
            'òåïåðü îòôîðìàòèðîâàòü çàãîëîâêè ãðóïï ...
    If ByGroups Then
        For i = 1 To UBound(ArGroupHeads())
            iArGH = ArGroupHeads(i)
            With objSheet.Range(objSheet.Cells(iArGH, 2), objSheet.Cells(iArGH, f + 1))
                 .Borders.LineStyle = -4142
                 If iGrayXL = 3 Or iGrayXL = 2 Then .Interior.ColorIndex = 15
            End With
        Next
    End If
    If bLand = True Then
        objSheet.PageSetup.Orientation = 2          '  xlLandscape
    Else
        objSheet.PageSetup.Orientation =  1           '  xlPortrate
    End If
    objXLApp.Visible = True
    objXLBook.Windows(1).Visible = True
    objSheet.Activate
    objSheet.Range("A1").Select
ProcDone:
    On Error Resume Next
    DoCmd.Close acForm, "frmIndicator"
    rstLost.Close
ExitHere:
    ClearAllVariables
    Exit Sub
HandleError:
    Select Case Err.number
        Case 1000233
            MsgBox "Íå óäàëîñü âûâåñòè äîêóìåíò â ôîðìàòå Excel", vbExclamation, stMsgTitle
        Case 432
            MsgBox "Îøèáêà #" & Err.number & ":  Íå íàéäåí ôàéë øàáëîíà äîêóìåíòà", vbCritical, stMsgTitle
        Case Else
            MsgBox Err.Description, vbExclamation, "Error " & Err.number
    End Select
    Resume ProcDone
End Sub

Public Sub CreateXLschetFaktura(strSQL As String, stFields As String, stComment As String, ByGroups As Boolean, _
                             showDate As Boolean, showCompany As Boolean, showTel As Boolean, showComment As Boolean, _
                             stComp As String, stTel As String, bLand As Boolean, iGrayXL As Integer, _
                             ctlInd As Control, frmInd As Form, ArHeads() As Variant, _
                             stTemplatesName As String, stSheetName As String, Optional bNp As Boolean)
    Dim stRange As String
    Dim varVal As Variant
    Dim varVal1 As Variant
    Dim jF As Integer
    
    On Error GoTo HandleError
    
    If Not SetXLobjects(stTemplatesName, stSheetName, strSQL, frmInd, ctlInd) Then Err.Raise 1000233
    With objSheet
        For f = 1 To UBound(ArHeads, 2)
            On Error Resume Next
            stRange = ArHeads(0, f)
            varVal = ArHeads(1, f)
            varVal1 = .Range(stRange)
            If ArHeads(2, f) = 1 Then
               .Range(stRange).FormulaR1C1 = varVal1 & "   " & varVal
            Else
               .Range(stRange).NumberFormat = "#,##0.00"
               .Range(stRange).FormulaR1C1 = varVal
               If bNp Then
                  If stRange = "TotalSum" Then
                    .Range("NPtotalsum").NumberFormat = "#,##0.00"
                    .Range("NPtotalsum").FormulaR1C1 = varVal
                  ElseIf stRange = "SumWNDST" Then
                    .Range("TotalSum").FormulaR1C1 = varVal
                  ElseIf stRange = "curr1" Then
                    .Range("NPcurr").FormulaR1C1 = varVal
                  End If
               End If
            End If
        Next
        Err.Clear
        On Error GoTo HandleError
    For r = 0 To intCount - 1
        .Rows(21 + r).RowHeight = 12.75
        For f = 0 To intCountFld - 1
            .Cells(21 + r, 2 + f) = varResults(f, r)
        Next f
       .Range(objSheet.Cells(21 + r, 6), objSheet.Cells(21 + r, 10)).NumberFormat = "#,##0.00"
       If r <> intCount - 1 Then .Rows(22 + r).Insert Shift:=-4121       'xlDown
    Next
    If Not bNp Then
        .Rows( 28  + r).RowHeight =  2 . 75 
    Else
        .Rows( 22  + r).RowHeight =  12 . 75 
        .Range("NPtext ").FormulaR1C1 = "  194 ; 241 ; 229 ; 227 ; 238 ;  234 ;  238 ; 239 ; 235 ; 224 ; 242 ; 229 ;  241 ;  237 ; 224 ; 235 ; 238 ; 227 ; 238 ; 236 ;  241 ;  239 ; 240 ; 238 ; 228 ; 224 ; 230 ;: "
    End If
    End With
    objXLApp.Visible = True
    objXLBook.Windows(1 ).Visible = True
    objSheet.Activate
    objSheet.Range("A1 ").Select
ProcDone:
    On Error Resume Next
    DoCmd.Close acForm, " frmIndicator "
    rstLost.Close
ExitHere:
    ClearAllVariables
    Exit Sub
HandleError:
    Select Case Err.number
        Case 1000233 
            MsgBox " 205 ; 229 ;  243 ; 228 ; 224 ; 235 ; 238 ; 241 ; 252 ;  226 ; 251 ; 226 ; 229 ; 241 ; 242 ; 232 ;  228 ; 238 ; 234 ; 243 ; 236 ; 229 ; 237 ; 242 ;  226 ;  244 ; 238 ; 240 ; 236 ; 224 ; 242 ; 229 ; Excel ", vbExclamation, stMsgTitle
        Case 432 
            MsgBox " 206 ; 248 ; 232 ; 225 ; 234 ; 224 ; # " & Err.number & " :   205 ; 229 ;  237 ; 224 ; 233 ; 228 ; 229 ; 237 ;  244 ; 224 ; 233 ; 235 ;  248 ; 224 ; 225 ; 235 ; 238 ; 237 ; 224 ;  228 ; 238 ; 234 ; 243 ; 236 ; 229 ; 237 ; 242 ; 224 ; ", vbCritical, stMsgTitle
        Case Else
            MsgBox Err.Description, vbExclamation, " Error  " & Err.number
    End Select
    Resume ProcDone
End Sub

Public Sub CreateXLTorg12(strSQL As String, stFields As String, stComment As String, ByGroups As Boolean, _
                             showDate As Boolean, showCompany As Boolean, showTel As Boolean, showComment As Boolean, _
                             stComp As String, stTel As String, bLand As Boolean, iGrayXL As Integer, _
                             ctlInd As Control, frmInd As Form, ArHeads() As Variant, _
                             stTemplatesName As String, stSheetName As String, Optional bNp As Boolean)

    On Error GoTo HandleError
    Err.Clear
    Err.Raise vbObjectError + 1000233 , Description:=" 205 ; 229 ;  243 ; 228 ; 224 ; 235 ; 238 ; 241 ; 252 ;  226 ; 251 ; 226 ; 229 ; 241 ; 242 ; 232 ;  228 ; 238 ; 234 ; 243 ; 236 ; 229 ; 237 ; 242 ;  226 ;  244 ; 238 ; 240 ; 236 ; 224 ; 242 ; 229 ; Excel "
     
ProcDone:
    On Error Resume Next
    DoCmd.Close acForm, " frmIndicator "
    rstLost.Close
ExitHere:
    ClearAllVariables
    Exit Sub
HandleError:
    Select Case Err.number
        Case 432 
            MsgBox " 206 ; 248 ; 232 ; 225 ; 234 ; 224 ; # " & Err.number & " :   205 ; 229 ;  237 ; 224 ; 233 ; 228 ; 229 ; 237 ;  244 ; 224 ; 233 ; 235 ;  248 ; 224 ; 225 ; 235 ; 238 ; 237 ; 224 ;  228 ; 238 ; 234 ; 243 ; 236 ; 229 ; 237 ; 242 ; 224 ; ", vbCritical, stMsgTitle
        Case Else
            MsgBox Err.Description, vbExclamation, " Error " & Err.number
    End Select
    Resume ProcDone
End Sub

Private Sub ClearAllVariables()
On Error Resume Next
    Set objXLApp = Nothing
    Set objXLBook = Nothing
    Set objSheet = Nothing
    Set objXLRange = Nothing
    Set Cells = Nothing
    Set cnn = Nothing
    Set cmdLost = Nothing
    Set rstLost = Nothing
    varResults = Empty
    intCount = Empty
    intCountFld = Empty
    i = Empty
    f = Empty
    r = Empty
    iNum = Empty
    stGroup = Empty
    bDark = Empty
    stHC = Empty
    lAsc = Empty
    iBeginFormat = Empty
    ArGroupHeads() = Empty
    iArGH = Empty
    stCompTel = Empty
Err.Clear

End Sub