Dim FS
Dim ts

sub Init_Components
with self
 .Left = 233
 .Top = 141
 .BorderStyle = "bsDialog"
 .Caption = "   Excel"
 .ClientHeight = 110
 .ClientWidth = 271
 .Color = "clBtnFace"
 .Font.Charset = 204
 .Font.Color = "clWindowText"
 .Font.Height = -11
 .Font.Name = "MS Sans Serif"
 .Font.Style = ""
 .OldCreateOrder = False
 .PixelsPerInch = 96
 self.add "Panel1", "TPanel"
 with Panel1
  .Left = 0
  .Top = 75
  .Width = 271
  .Height = 35
  .Align = "alBottom"
  .BevelInner = "bvRaised"
  .BevelOuter = "bvLowered"
  .TabOrder = 0
  Panel1.add "BitBtn1", "TBitBtn",TRUE
 with BitBtn1
   .Left = 184
   .Top = 5
   .Width = 81
   .Height = 25
   .Caption = ""
   .TabOrder = 0
   .Kind = "bkCancel"
   end with
  Panel1.add "OKBtn", "TBitBtn",TRUE
 with OKBtn
   .Left = 104
   .Top = 5
   .Width = 73
   .Height = 25
   .TabOrder = 1
   .Caption="OK"
   .Kind="bkOk"
   end with
  end with
 self.add "GroupBox1", "TGroupBox"
 with GroupBox1
  .Left = 0
  .Top = 0
  .Width = 271
  .Height = 75
  .Align = "alClient"
  .Caption = ""
  .Font.Charset = 204
  .Font.Color = "clWindowText"
  .Font.Height = -11
  .Font.Name = "MS Sans Serif"
  .Font.Style = "fsBold"
  .ParentFont = False
  .TabOrder = 1
  GroupBox1.add "Label1", "TLabel"
 with Label1
   .Left = 24
   .Top = 22
   .Width = 133
   .Height = 13
   .Caption = "  "
   .Font.Charset = 204
   .Font.Color = "clWindowText"
   .Font.Height = -11
   .Font.Name = "MS Sans Serif"
   .Font.Style = ""
   .ParentFont = False
   end with
  GroupBox1.add "Label2", "TLabel"
 with Label2
   .Left = 14
   .Top = 49
   .Width = 151
   .Height = 13
   .Caption = "  "
   .Font.Charset = 204
   .Font.Color = "clWindowText"
   .Font.Height = -11
   .Font.Name = "MS Sans Serif"
   .Font.Style = ""
   .ParentFont = False
   end with
  GroupBox1.add "BegDate", "TDBDateTimeEditEh"
 with BegDate
   .Left = 169
   .Top = 21
   .Width = 97
   .Height = 19
   .Flat = True
   .Kind = "dtkDateEh"
   .TabOrder = 0
   .Visible = True
   .EditButton.Style="ebsEllipsisEh"
   end with
  GroupBox1.add "EndDate", "TDBDateTimeEditEh"
 with EndDate
   .Left = 170
   .Top = 46
   .Width = 95
   .Height = 19
   .Flat = True
   .Kind = "dtkDateEh"
   .TabOrder = 1
   .EditButton.Style="ebsEllipsisEh"
   .Visible = True
   end with
  end with
 end with
end sub
'******************************************************************************
'  
'******************************************************************************
Dim pos
pos=0
dateVyp = date()
pDate = date()
dim Cell1
dim Sheet
dim app
Dim Database
'******************************************************************************
'Helper 
'******************************************************************************
sub zz ()
  Cell1.Font.Bold = TRUE
end sub

sub FillCellNew(Col, S)
  pos = pos + 1
 set Cell1 = Sheet.Cells(pos, Col)
  Cell1.Value = S
end sub

sub FillCell(Col, S, F)
  set Cell1 = Sheet.Cells(pos, Col)
  if(IsNull(F)<>true) then
   Cell1.Font.ColorIndex = F
  end if
  Cell1.Value = S
end sub
'******************************************************************************
Sub connect ()
set Database=MainForm.Controls("Database")
 Self.Add "Trans","TIBTransaction"
 Trans.DefaultDatabase=Database
 Self.Add "Query", "TIBQuery"
  With Query
    .Database=DataBase
  End With

 Self.Add "QueryAcc", "TIBQuery"
  With QueryAcc
    .Database=DataBase
    .SQL.Clear
    .SQL.Add "select accnumber,valcode, f.valfull,f.valshort from firmsaccounts f where idcontr=-1"
  End With

end sub

sub PrintShapka (verh)
    if(verh=1) then
               s=" " & QueryAcc.FieldByNamestring("accnumber") & "  " & QueryACC.Fieldbynamestring("valcode")& ":" & QueryaCC.Fieldbynamestring("valfull")
               ts.WriteLine s
               s1=" :"
               s=Query.FieldByNameString("ammin")
               if(s="") then
               s=""
               end if
               ts.WriteLine s1 & s
    end if
              ' 
   if(verh=0) then
               s1=" :"
               s=Query.FieldByNameString("ammout")
               if(s="") then
               s=""
               end if
               ts.WriteLine s1 & s
   end if

end sub

sub MakeOfOneAccount ()
Dim s
s="select * from  vipiska v where v.acc='" & QueryAcc.FieldByNamestring("accnumber") & "'"
s=s & " and v.valcode='" & QueryAcc.FieldByNamestring("valcode")
s=s & "' and v.datvip>'" & CStr(BegDate.Value) & "' and v.datvip<'" & CStr(EndDate.Value+1) & "'  order by datvip, v.idvip,acc"
Query.Sql.Clear
Query.Sql.Add (s)

Query.Active=true
call PrintShapka(1)
Query.Active=false
' 
s="select * from  vipiska v, fullvipiska f where v.idvip=f.idvip and v.acc=f.payeracc and v.acc='" & QueryAcc.FieldByNamestring("accnumber") & "'"
s=s & " and v.valcode='" & QueryAcc.FieldByNamestring("valcode")
s=s & "' and v.datvip>'" & CStr(BegDate.Value) & "' and v.datvip<'" & CStr(EndDate.Value+1) & "'  order by datvip, v.idvip,acc"

Query.Sql.Clear
Query.Sql.Add (s)
Query.Active=true
do while not Query.Eof
  s1=Query.FieldByNaMESTRING("DATVIP") & chr(9) & "+"& Query.FieldByNameString("SUM") & chr(9) & Query.FieldByNameString("ground")
  ts.WriteLine s1
 Query.Next
loop
' 
s="select * from  vipiska v, fullvipiska f where v.idvip=f.idvip and v.acc<>f.payeracc and v.acc='" & QueryAcc.FieldByNamestring("accnumber") & "'"
s=s & " and v.valcode='" & QueryAcc.FieldByNamestring("valcode")
s=s & "' and v.datvip>'" & CStr(BegDate.Value) & "' and v.datvip<'" & CStr(EndDate.Value+1) & "'  order by datvip, v.idvip,acc"
Query.Sql.Clear
Query.Sql.Add (s)
Query.Active=true
do while not Query.Eof

    s1=Query.FieldByNaMESTRING("DATVIP") & chr(9) & "-" & Query.FieldByNameString("SUM") & chr(9) & Query.FieldByNameString("ground")
    ts.WriteLine s1

   Query.Next
loop
'  
call PrintShapka (0)
end sub


sub MakeAll ()
  QueryAcc.Active=true
  do while not QueryAcc.Eof
  call MakeOfOneAccount()
  QueryAcc.Next
  loop
 end sub

' Cancel
sub BitBtn1_onClick
self.Close
end sub

 '  OK
sub OKBtn_onClick
if (IsNull(BegDate.Value)=true) then
 MsgBox "   ",0," BARS"
exit sub
end if

if (IsNull(EndDate.Value)=true) then
 MsgBox "   ",0," BARS"
exit sub
end if

call connect ()

set FS=CreateObject("Scripting.FileSystemObject")
tt=FS.GetFolder("macroses")
tt=tt&"\vigruzka_1.txt"

SET ts=FS.OpenTextFile (tt,2,True,0)
s=" : " & Date
ts.WriteLine s
call MakeAll()
ts.Close
SET FS=nothing

set app = CreateObject("Excel.Application")
call app.Workbooks.OpenText(tt,2,True)


set Sheet = app.Sheets(1)
app.Sheets(1).Columns("C:C").ColumnWidth = 12
app.Sheets(1).Columns("A:A").ColumnWidth = 10
app.Sheets(1).Columns("B:B").ColumnWidth = 13
app.Sheets(1).Columns("D:D").ColumnWidth = 13
app.Sheets(1).Columns("E:E").ColumnWidth = 13

app.Visible = TRUE

self.Close()


end sub


' 
sub main ()
call Init_Components()
end sub
