ADOQuery

HEJ,

Jeg ved ikke om denne kode kan bruges:

Jeg har, siden det blev kendt at ADO-tabeller med rette værktøj - som kan fås på nettet kan åbnes af udenforstående (arbejder med lægedata - derfor ) IKKE brugt ADO-tabeller overhovedet, men andre typer databaser.

Denne koden KAN MÅSKE bruges. Men prøv selv.

Den kan (hos mig) hente FIELDNAMES og data (men ikke datatyperne - VarChar, Integer etc)   


KRistian

procedure TForm1.Button1Click(Sender: TObject);
VAR
  MName : String;
  N, n1 : Integer;
  MyDef : Variant;

begin
  MyTable.GetFieldNames(Listbox1.Items); 
  With DBgrid1.DataSource.DataSet Do
      BEGIN
        First;
        For N := 0 to RecordCount -1 DO
            BEGIN
              For N1 := 0 to FieldCount -1 DO
                  Listbox2.Items.Add(VARtoStr(Fields[N1].AsVariant));
              NExt;
          END;
      END;
end;

Hvis databaser understoetter tilpas ny SQL standard:

SELECT * FROM INFORMATION_SCHEMA.COLUMNS

adoConnection.gettablenames.

Jeg har lavet en databasebrowser her:

object Form1: TForm1
  Left = 295
  Top = 238
  Width = 1212
  Height = 540
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -13
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  PixelsPerInch = 96
  TextHeight = 16
  object ListBox1: TListBox
    Left = 24
    Top = 88
    Width = 233
    Height = 377
    ItemHeight = 16
    PopupMenu = pop
    TabOrder = 0
    OnClick = ListBox1Click
    OnDblClick = Open1Click
  end
  object ListBox2: TListBox
    Left = 288
    Top = 88
    Width = 217
    Height = 377
    ItemHeight = 16
    PopupMenu = PopupMenu1
    TabOrder = 1
    OnClick = ListBox2Click
  end
  object Memo1: TMemo
    Left = 552
    Top = 88
    Width = 601
    Height = 113
    Lines.Strings = (
      'Memo1')
    TabOrder = 2
    OnKeyDown = Memo1KeyDown
  end
  object DBGrid1: TDBGrid
    Left = 560
    Top = 248
    Width = 593
    Height = 193
    DataSource = DataSource1
    TabOrder = 3
    TitleFont.Charset = DEFAULT_CHARSET
    TitleFont.Color = clWindowText
    TitleFont.Height = -13
    TitleFont.Name = 'MS Sans Serif'
    TitleFont.Style = []
    OnColEnter = DBGrid1ColEnter
  end
  object Button1: TButton
    Left = 560
    Top = 456
    Width = 129
    Height = 25
    Caption = 'Copy to clipboard'
    TabOrder = 4
    OnClick = Button1Click
  end
  object bnext: TButton
    Left = 648
    Top = 208
    Width = 75
    Height = 25
    Caption = '>>'
    TabOrder = 5
    OnClick = bnextClick
  end
  object bprior: TButton
    Left = 560
    Top = 208
    Width = 75
    Height = 25
    Caption = '<<'
    TabOrder = 6
    OnClick = bpriorClick
  end
  object btnGo: TButton
    Left = 768
    Top = 208
    Width = 75
    Height = 25
    Caption = 'Go'
    TabOrder = 7
    OnClick = btnGoClick
  end
  object Button2: TButton
    Left = 752
    Top = 456
    Width = 201
    Height = 25
    Caption = 'Save as fixed length records'
    TabOrder = 8
    OnClick = Button2Click
  end
  object db: TADOConnection
    ConnectionString = 'FILE NAME=C:\database\satair.udl'
    LoginPrompt = False
    Provider = 'C:\database\satair.udl'
    Left = 48
    Top = 16
  end
  object pop: TPopupMenu
    Left = 120
    Top = 192
    object Delete1: TMenuItem
      Caption = 'Drop table'
      OnClick = Delete1Click
    end
    object Open1: TMenuItem
      Caption = 'Open'
      OnClick = Open1Click
    end
    object Addfield2: TMenuItem
      Caption = 'Add field'
      object Integer2: TMenuItem
        Caption = 'Integer'
        OnClick = AddFieClick
      end
      object Varchar2: TMenuItem
        Tag = 1
        Caption = 'Varchar'
      end
      object Date2: TMenuItem
        Tag = 2
        Caption = 'Date'
      end
    end
    object Rename1: TMenuItem
      Caption = 'Rename'
      OnClick = Rename1Click
    end
  end
  object DataSource1: TDataSource
    DataSet = query1
    Left = 592
    Top = 288
  end
  object query1: TADOQuery
    Connection = db
    Parameters = <>
    Left = 672
    Top = 288
  end
  object PopupMenu1: TPopupMenu
    Left = 352
    Top = 200
    object Dropfield1: TMenuItem
      Caption = 'Drop field'
      OnClick = Dropfield1Click
    end
    object Addfield1: TMenuItem
      Caption = 'Add field'
      OnClick = AddFieClick
      object Integer1: TMenuItem
        Caption = 'Integer'
        OnClick = AddFieClick
      end
      object Varchar1: TMenuItem
        Tag = 1
        Caption = 'Varchar'
      end
      object Date1: TMenuItem
        Tag = 2
        Caption = 'Date'
      end
    end
    object Rename: TMenuItem
      Caption = 'Rename'
      OnClick = RenameClick
    end
  end
end


unit UdbExplore;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, DB, ADODB, Menus, Grids, DBGrids, clipBrd;

type
  TForm1 = class(TForm)
    db: TADOConnection;
    ListBox1: TListBox;
    ListBox2: TListBox;
    pop: TPopupMenu;
    Delete1: TMenuItem;
    Open1: TMenuItem;
    Memo1: TMemo;
    DBGrid1: TDBGrid;
    Button1: TButton;
    bnext: TButton;
    bprior: TButton;
    btnGo: TButton;
    DataSource1: TDataSource;
    query1: TADOQuery;
    PopupMenu1: TPopupMenu;
    Dropfield1: TMenuItem;
    Addfield1: TMenuItem;
    Integer1: TMenuItem;
    Varchar1: TMenuItem;
    Date1: TMenuItem;
    Addfield2: TMenuItem;
    Integer2: TMenuItem;
    Varchar2: TMenuItem;
    Date2: TMenuItem;
    Rename: TMenuItem;
    Rename1: TMenuItem;
    Button2: TButton;
    procedure FormCreate(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
        procedure Memo1KeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure updatebtns;
    procedure Button1Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure btnGoClick(Sender: TObject);
    procedure bnextClick(Sender: TObject);
    procedure bpriorClick(Sender: TObject);
    procedure Open1Click(Sender: TObject);
    procedure Delete1Click(Sender: TObject);
    procedure ListBox2Click(Sender: TObject);
    procedure AddFieClick(Sender: TObject);
    procedure Dropfield1Click(Sender: TObject);
    procedure RenameClick(Sender: TObject);
    procedure Rename1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure DBGrid1ColEnter(Sender: TObject);

  private
    tablename, fieldname : string;
    refr : boolean;
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}


procedure TForm1.ListBox1Click(Sender: TObject);
begin
  with listbox1 do
  tablename :=
  items[itemindex];
  with listbox1 do
    db.GetFieldNames(tablename, listbox2.Items);

end;
var ptr : integer;

procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (shift = [ssctrl]) and (key = vk_return) then
  begin
    btngo.click;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var s : string;
  str : tstringlist;
  i : integer;
begin
  str := tstringlist.Create;
  with query1 do
  begin
    try
    disablecontrols;
    first;
    s := '';
    for i := 0 to fieldcount-1 do
    s := s +fields[i].displaylabel+chr(vk_tab);
    str.add(s);
    while not eof do
    begin
      s := '';
      for i := 0 to fieldcount-1 do
      s := s +fields[i].asstring+chr(vk_tab);
      str.add(s);
      next;
    end;
    finally
      enablecontrols;
    end;
    clipboard.astext := str.text;
    caption := 'OK';
  end;
end;

var memory : tstringlist;

function extract(s : string) : string;
var p : integer;
  str : tstringlist;
begin
  str := tstringlist.Create;
  repeat
    p := pos ('\', s);
    if p > 0 then
    str.add(copy(s,1,p-1));
    s := copy(s,p+1, 1000);
  until p = 0;
  str.add(s);
  result := str.Text;
end;

function pack(str : tstrings) : string;
var s, sl : string;
    i : integer;
begin
  s := '';
  sl := '';
  for i := 0 to str.count-1 do
  begin
    if str[i] <> '' then
    s := s +sl+str[i];
    if i=0 then sl := '\';
  end;
  result := s;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
    db.GetTableNames(listbox1.Items);
  if sender = nil then exit;
  memory := tstringlist.Create;
  try
    memory.loadfromfile('sql.his');
  except

  end;
  memo1.lines.Text := extract(memory[0]);
  ptr := 0;
  updatebtns;

    with db do
  begin



  end;

end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  try
    memory.savetofile('sql.his');
  except

  end;

end;                 


procedure TForm1.btnGoClick(Sender: TObject);
var s : string;
    i : integer;
begin
    query1.close;
    query1.sql.text := memo1.Lines.Text;
    try
    if pos('select', query1.SQL.Text) = 1 then
    query1.open else
    begin
    query1.ExecSQL;
    if refr then
    begin
        with listbox1 do
        db.GetFieldNames(tablename, listbox2.Items);

      formCreate(nil);
      refr := false;
    end;
    end;
    finally
    s := pack(memo1.lines);
    repeat
      i := memory.indexof(s);
      if i > -1 then
      memory.delete(i);
    until i = -1;
    memory.Insert(0, s);
    end;
    ptr := 0;
    Updatebtns;
end;

procedure TForm1.bnextClick(Sender: TObject);
begin
  dec(ptr);
  memo1.lines.Text := extract(memory[ptr]);

  updatebtns;
end;

procedure TForm1.bpriorClick(Sender: TObject);
begin
  inc(ptr);
  memo1.lines.Text := extract(memory[ptr]);

  updatebtns;

end;

procedure TForm1.updatebtns;
begin
  bnext.enabled := ptr > 0;
  bprior.enabled := ptr < memory.count-1;
end;

procedure TForm1.Open1Click(Sender: TObject);
var tablename : string;
begin
with listBox1 do
  tablename := items[itemindex];

  memo1.text := 'select * from '+tablename;
  btnGo.click;
end;

procedure TForm1.Delete1Click(Sender: TObject);
begin
with listBox1 do
  tablename := items[itemindex];

  memo1.text := 'drop table '+tablename;
  refr := true;

end;

procedure TForm1.ListBox2Click(Sender: TObject);
begin

with listBox2 do
if itemindex <> -1 then
  fieldname := items[itemindex];
memo1.lines.text := 'select '+fieldname+' from '+tablename;
btngo.click;
end;

procedure TForm1.AddFieClick(Sender: TObject);
var ft : string;
begin
  case (sender as tmenuitem).tag of
  0 : ft := 'integer';
  1 : ft := 'varchar(00)';
  2 : ft := 'date';
  end;

  memo1.text := 'alter table '+tablename+' add xxx '+ft;

end;

procedure TForm1.Dropfield1Click(Sender: TObject);
begin
  memo1.text := 'alter table '+tablename+' drop column '+fieldname

end;

procedure TForm1.RenameClick(Sender: TObject);
begin
  memo1.lines.Text := 'exec sp_rename '+quotedstr(tablename+'.'+fieldname)+','+quotedstr(fieldname)+',''COLUMN'' ';
  refr := true;
end;

procedure TForm1.Rename1Click(Sender: TObject);
begin

  memo1.lines.Text := 'exec sp_rename '+quotedstr(tablename)+','+quotedstr(tablename);
  refr := true;

end;

function max(a,b : real) : real;
begin
  if a > b then result := a else result := b;
end;

procedure TForm1.Button2Click(Sender: TObject);
var maxlen : array [0..40] of real;
    i : integer;
function pad(s : string; len : integer ): string;
begin
  while length(s) < len do s := s + ' ';
  result := copy(s,1,len);
end;


begin
  with query1 do
  begin
    fillchar(maxlen, sizeof(maxlen), #0);
    first;
    while not eof do
    begin
      for i := 0 to  fieldcount-1 do
      maxlen[i] := max(length(fields[i].asstring), maxlen[i]);
      next;
    end;
    assignfile(output, 'c:\test.txt');
    rewrite(output);
    first;
    while not eof do
    begin
      for i := 0 to  fieldcount-1 do
      write(pad(fields[i].asstring,round(maxlen[i]+1)));
      writeln;
      next;
    end;
    closefile(output);
  end;

end;

procedure TForm1.DBGrid1ColEnter(Sender: TObject);
begin
  with dbgrid1 do
  case columns[selectedindex].field.datatype of
  ftInteger : caption := 'integer';
  ftautoinc : caption := 'integer, identity';
  ftfloat : caption := 'Float';
  ftString : begin caption := 'String '+inttostr(columns[selectedindex].field.size); end;
  ftDatetime : begin caption := 'Dato'; end;
  else caption := '??';
  end;
end;

end.

Hej,

Arne_V og Snestrup2000 - smid et svar - jeg deler point mellem jer alle 3... (dvs. inkl "Kloge")...