home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / tpw / owldemos / pxdemo.pas < prev    next >
Pascal/Delphi Source File  |  1991-05-20  |  12KB  |  410 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Pascal for Windows                     }
  4. {   Paradox Engine demo program                  }
  5. {   Copyright (c) 1991 by Borland International  }
  6. {                                                }
  7. {************************************************}
  8.  
  9. program PXDemo;
  10.  
  11. {$R PXDEMO.RES}
  12. {$N+}
  13.  
  14. uses WObjects, WinTypes, WinProcs, Strings, StdDlgs, PXEngine, PXAccess;
  15.  
  16. const
  17.   BKColor   = $00FFFF00;
  18.   ForeColor = $00000000;
  19.  
  20. const
  21.   cm_FileClose = 100;
  22.  
  23. const
  24.   MenuID      = 100;
  25.   IconID      = 100;
  26.  
  27. type
  28.   TParadoxDemo = object(TApplication)
  29.     destructor Done; virtual;
  30.     procedure InitMainWindow; virtual;
  31.     procedure Error(errorCode: Integer); virtual;
  32.   end;
  33.  
  34.   PParadoxTableWindow = ^TParadoxTableWindow;
  35.   TParadoxTableWindow = object(TWindow)
  36.     CharWidth: Integer;
  37.     CharHeight: Integer;
  38.     TableWidth: Integer;
  39.     FixedFont: HFont;
  40.     Table: PPXTable;
  41.     FieldStarts: PWordArray;
  42.     TitleBar: HBitmap;
  43.     ColumnBar: HBitmap;
  44.     constructor Init(AParent: PWindowsObject; TableName: PChar);
  45.     destructor Done; virtual;
  46.     procedure CloseTable;
  47.     function GetClassName: PChar; virtual;
  48.     procedure GetFixedFont(DC: HDC);
  49.     procedure GetWindowClass(var WndClass: TWndClass); virtual;
  50.     procedure Paint(DC: HDC; var PS: TPaintStruct); virtual;
  51.     procedure SetupWindow; virtual;
  52.     procedure CMFileClose(var Message: TMessage);
  53.       virtual cm_First + cm_FileClose;
  54.     procedure CMFileOpen(var Message: TMessage);
  55.       virtual cm_First + cm_FileOpen;
  56.     procedure WMKeyDown(var Msg: TMessage);
  57.       virtual wm_First + wm_KeyDown;
  58.     procedure WMSize(var Msg: TMessage);
  59.       virtual wm_First + wm_Size;
  60.   end;
  61.  
  62. { TParadoxDemo }
  63.  
  64. destructor TParadoxDemo.Done;
  65. begin
  66.   TApplication.Done;
  67.   PXExit;
  68. end;
  69.  
  70. procedure TParadoxDemo.InitMainWindow;
  71. begin
  72.   Status := PXWinInit('PXDemo', PXExclusive);
  73.   if Status = PXSuccess then
  74.     MainWindow := New(PParadoxTableWindow, Init(nil, 'Paradox Table Viewer'))
  75.   else MessageBox(0, PXErrMsg(Status), 'PXDemo', mb_OK)
  76. end;
  77.  
  78. procedure TParadoxDemo.Error(ErrorCode: Integer);
  79. begin
  80.   if Status < 0 then TApplication.Error(ErrorCode)
  81.   else MessageBox(GetFocus, PXErrMsg(Status), 'WinTable', MB_OK);
  82. end;
  83.  
  84. { TParadoxTableWindow }
  85.  
  86. constructor TParadoxTableWindow.Init(AParent: PWindowsObject;
  87.   TableName: PChar);
  88. begin
  89.   TWindow.Init(AParent, TableName);
  90.   with Attr do
  91.   begin
  92.     Menu := LoadMenu(HInstance, MakeIntResource(MenuID));
  93.     Style := Style or ws_VScroll or ws_HScroll;
  94.     X := 25;
  95.     Y := 40;
  96.     W := 500;
  97.     H := 350;
  98.   end;
  99.   Scroller := New(PScroller, Init(@Self, 1, 1, 0, 0));
  100.   Scroller^.TrackMode := False;
  101.   Scroller^.AutoOrg := False;
  102.   Table := nil;
  103.   FieldStarts := nil;
  104.   TitleBar := 0;
  105.   ColumnBar := 0;
  106. end;
  107.  
  108. destructor TParadoxTableWindow.Done;
  109. begin
  110.   CloseTable;
  111.   TWindow.Done;
  112. end;
  113.  
  114. procedure TParadoxTableWindow.CloseTable;
  115. begin
  116.   if Table <> nil then
  117.   begin
  118.     FreeMem(FieldStarts, SizeOf(Word) * (Table^.NumFields + 2));
  119.     FieldStarts := nil;
  120.     Dispose(Table, Done);
  121.     Table := nil;
  122.     DeleteObject(TitleBar);
  123.     InvalidateRect(HWindow, nil, True);
  124.   end;
  125. end;
  126.  
  127. procedure TParadoxTableWindow.CMFileClose(var Message: TMessage);
  128. begin
  129.   CloseTable;
  130. end;
  131.  
  132. procedure TParadoxTableWindow.CMFileOpen(var Message: TMessage);
  133. var
  134.   Filename: array[0..128] of Char;
  135.   I, J: Integer;
  136.   R: TRect;
  137.   DC, MemDC: HDC;
  138.   OldBrush: HBrush;
  139.   OldPen: HPen;
  140.   SepX, SepY, TitleWidth: Integer;
  141.   CurField: Integer;
  142.   FieldStart, FieldEnd: Integer;
  143.  
  144. function Min(X,Y: Integer): Integer;
  145. begin
  146.   if X < Y then Min := X else Min := Y;
  147. end;
  148.  
  149. begin
  150.   if Application^.ExecDialog(New(PFileDialog, Init(@Self, PChar(sd_FileOpen),
  151.     StrCopy(FileName, '*.db')))) = idOK then
  152.   begin
  153.     CloseTable;
  154.     Table := New(PPXTable, Init(FileName));
  155.     if Table^.Status <> 0 then
  156.     begin
  157.       Dispose(Table, Done);
  158.       Table := nil;
  159.     end
  160.     else
  161.     begin
  162.       { Record Field starts }
  163.       GetMem(FieldStarts, SizeOf(Word) * (Table^.NumFields + 2));
  164.       J := 0;
  165.       FieldStarts^[1] := 0;
  166.       for I := 2 to Table^.NumFields + 1 do
  167.         FieldStarts^[I] := Table^.FieldWidth(I - 1) + FieldStarts^[I - 1] + 1;
  168.       TableWidth := FieldStarts^[I];
  169.       GetClientRect(HWindow, R);
  170.       Scroller^.SetRange(TableWidth - R.right div CharWidth,
  171.         Table^.NumRecords - R.bottom div CharHeight);
  172.  
  173.       { Create the title bar bitmap }
  174.       DC := GetDC(HWindow);
  175.       MemDC := CreateCompatibleDC(DC);
  176.       ReleaseDC(HWindow, DC);
  177.       TitleWidth := TableWidth * CharWidth;
  178.       TitleBar := CreateCompatibleBitmap(DC, TitleWidth, CharHeight);
  179.       SelectObject(MemDC, TitleBar);
  180.       SelectObject(MemDC, FixedFont);
  181.       SetTextColor(MemDC, ForeColor);
  182.       SetBkColor(MemDC, BKColor);
  183.       OldBrush := SelectObject(MemDC, CreateSolidBrush(BKColor));
  184.       PatBlt(MemDC, 0, 0, TitleWidth, CharHeight, PatCopy);
  185.       DeleteObject(SelectObject(MemDC, OldBrush));
  186.  
  187.       { Draw double lines }
  188.       OldPen := SelectObject(MemDC, CreatePen(ps_Solid, 2, ForeColor));
  189.       SepX := CharWidth div 3;
  190.       SepY := CharHeight div 3;
  191.       {   Top line }
  192.       MoveTo(MemDC, SepX, SepY);
  193.       LineTo(MemDC, TitleWidth - SepX, SepY);
  194.       LineTo(MemDC, TitleWidth - SepX, CharHeight + 1);
  195.       {   Bottom lines and titles}
  196.       Inc(SepY, SepY);
  197.       for I := 1 to  Table^.NumFields do
  198.       begin
  199.         FieldStart := FieldStarts^[I] * CharWidth;
  200.         FieldEnd := FieldStart + Table^.FieldWidth(I) * CharWidth;
  201.         MoveTo(MemDC, FieldStart - SepX, CharHeight);
  202.         LineTo(MemDC, FieldStart - SepX, SepY);
  203.         LineTo(MemDC, FieldEnd + SepX, SepY);
  204.         LineTo(MemDC, FieldEnd + SepX, CharHeight + 1);
  205.         TextOut(MemDC, FieldStart, 0, Table^.FieldName(I),
  206.           Min(StrLen(Table^.FieldName(I)), Table^.FieldWidth(I)));
  207.       end;
  208.       DeleteObject(SelectObject(MemDC, OldPen));
  209.       DeleteDC(MemDC);
  210.       InvalidateRect(HWindow, nil, True);
  211.     end;
  212.   end;
  213. end;
  214.  
  215. function TParadoxTableWindow.GetClassName: PChar;
  216. begin
  217.   GetClassName := 'TurboTableView';
  218. end;
  219.  
  220. function EnumerateFont(LogFont: PLogFont; TextMetric: PTextMetric;
  221.   FontType: Integer; Data: Pointer): Bool; export;
  222. begin
  223.   PLogFont(Data)^ := LogFont^;
  224.   EnumerateFont := (TextMetric^.tmPitchAndFamily and 1) = 1;
  225. end;
  226.  
  227. procedure TParadoxTableWindow.GetFixedFont(DC: HDC);
  228. var
  229.   LogFont: TLogFont;
  230.   FontFunc: TFarProc;
  231. begin
  232.   FontFunc := MakeProcInstance(@EnumerateFont, HInstance);
  233.   EnumFonts(DC, 'SYSTEM', FontFunc, @LogFont);
  234.   FixedFont := CreateFontIndirect(LogFont);
  235.   FreeProcInstance(FontFunc);
  236. end;
  237.  
  238. procedure TParadoxTableWindow.GetWindowClass(var WndClass: TWndClass);
  239. var
  240.   LogBrush: TLogBrush;
  241. begin
  242.   TWindow.GetWindowClass(WndClass);
  243.   LogBrush.lbStyle := bs_Solid;
  244.   LogBrush.lbColor := BKColor;
  245.   WndClass.hbrBackground := CreateBrushIndirect(LogBrush);
  246.   WndClass.hIcon := LoadIcon(HInstance, MakeIntResource(IconID));
  247. end;
  248.  
  249. procedure TParadoxTableWindow.Paint(DC: HDC; var PS: TPaintStruct);
  250. var
  251.   OldFont: HFont;
  252.   OldCursor: HCursor;
  253.   HRgn1, HRgn2: HRgn;
  254.   MemDC: HDC;
  255.   StartX, StopX: Integer;
  256.   FirstField, LastField, FirstRec, LastRec: Integer;
  257.   I, J: Integer;
  258.   R: TRect;
  259.  
  260. procedure DrawField(X, Y, Width: Integer; FieldText: PChar);
  261. var
  262.   Temp: array[0..255] of Char;
  263.   XPos, YPos, Len: Integer;
  264.   R: TRect;
  265. begin
  266.   XPos := (X - Scroller^.XPos) * CharWidth;
  267.   YPos := (Y - Scroller^.YPos) * CharHeight;
  268.   Len := StrLen(FieldText);
  269.   TextOut(DC, XPos, YPos, FieldText, Len);
  270.   if Width > Len then
  271.   begin
  272.     FillChar(Temp, SizeOf(Temp), ' ');
  273.     TextOut(DC, XPos + Len * CharWidth, YPos, Temp, Width - Len);
  274.   end;
  275. end;
  276.  
  277. begin
  278.   if Table <> nil then
  279.   begin
  280.     SetTextColor(DC, ForeColor);
  281.     SetBkColor(DC, BKColor);
  282.     OldFont := SelectObject(DC, FixedFont);
  283.     StartX := (PS.rcPaint.left div CharWidth) + Scroller^.XPos;
  284.     StopX := (PS.rcPaint.right div CharWidth + 1) + Scroller^.XPos;
  285.     FirstField := 1;
  286.     while FieldStarts^[FirstField+1] <= StartX do Inc(FirstField);
  287.     LastField := Table^.NumFields;
  288.     while FieldStarts^[LastField] >= StopX do Dec(LastField);
  289.     FirstRec := (PS.rcPaint.top div CharHeight) + Scroller^.YPos;
  290.     LastRec := (PS.rcPaint.bottom div CharHeight + 1) + Scroller^.YPos + 1;
  291.     MemDC := CreateCompatibleDC(DC);
  292.     SelectObject(MemDC, ColumnBar);
  293.     for I := FirstField to LastField do
  294.     begin
  295.       J := (FieldStarts^[I + 1] - Scroller^.XPos - 1) * CharWidth;
  296.       BitBlt(DC, J, PS.rcPaint.top, J + CharWidth, PS.rcPaint.bottom,
  297.         MemDC, 0, 0, SrcCopy);
  298.     end;
  299.     DeleteDC(MemDC);
  300.     OldCursor := SetCursor(LoadCursor(0, idc_Wait));
  301.  
  302.     for I := FirstRec to LastRec do
  303.       if I = 0 then
  304.       begin
  305.         MemDC := CreateCompatibleDC(DC);
  306.         SelectObject(MemDC, TitleBar);
  307.         BitBlt(DC, 0, 0, (TableWidth - Scroller^.XPos) * CharWidth,
  308.           CharHeight, MemDC, Scroller^.XPos * CharWidth, 0, SrcCopy);
  309.         DeleteDC(MemDC);
  310.       end
  311.       else
  312.         for J := FirstField to LastField do
  313.           DrawField(FieldStarts^[J], I, Table^.FieldWidth(J),
  314.             Table^.GetField(I, J));
  315.     SetCursor(OldCursor);
  316.     SelectObject(DC, OldFont);
  317.     if Table^.Status <> 0 then CloseTable;
  318.   end;
  319. end;
  320.  
  321. procedure TParadoxTableWindow.SetupWindow;
  322. var
  323.   TextMetric: TTextMetric;
  324.   DC: HDC;
  325.   OldFont: THandle;
  326. begin
  327.   TWindow.SetupWindow;
  328.   DC := GetDC(HWindow);
  329.   GetFixedFont(DC);
  330.   OldFont := SelectObject(DC, FixedFont);
  331.   GetTextMetrics(DC, TextMetric);
  332.   CharWidth := TextMetric.tmAveCharWidth;
  333.   CharHeight := TextMetric.tmHeight;
  334.   Scroller^.SetUnits(CharWidth, CharHeight);
  335.   SelectObject(DC, OldFont);
  336.   ReleaseDC(HWindow, DC);
  337.   Scroller^.SetSBarRange;
  338. end;
  339.  
  340. procedure TParadoxTableWindow.WMKeyDown(var Msg: TMessage);
  341. begin
  342.   with Scroller^ do
  343.     case Msg.wParam of
  344.       vk_Left:
  345.         if GetKeyState(vk_Control) and $8000 <> 0 then
  346.           HScroll(sb_PageUp, 0)
  347.         else
  348.           HScroll(sb_LineUp, 0);
  349.       vk_Right:
  350.         if GetKeyState(vk_Control) and $8000 <> 0 then
  351.           HScroll(sb_PageDown, 0)
  352.         else
  353.           HScroll(sb_LineDown, 0);
  354.       vk_Up: VScroll(sb_LineUp, 0);
  355.       vk_Down: VScroll(sb_LineDown, 0);
  356.       vk_Next: VScroll(sb_PageDown, 0);
  357.       vk_Prior: VScroll(sb_PageUp, 0);
  358.       vk_Home: ScrollTo(XPos, 0);
  359.       vk_End: ScrollTo(XPos, Table^.NumRecords);
  360.     end;
  361. end;
  362.  
  363. procedure TParadoxTableWindow.WMSize(var Msg: TMessage);
  364. var
  365.   R: TRect;
  366.   DC, MemDC: HDC;
  367.   OldBrush: HBrush;
  368.   OldPen: HPen;
  369.   SepX: Integer;
  370. begin
  371.   TWindow.WMSize(Msg);
  372.   if Table <> nil then
  373.   begin
  374.     GetClientRect(HWindow, R);
  375.     Scroller^.SetRange(TableWidth - R.right div CharWidth,
  376.       Table^.NumRecords - R.bottom div CharHeight + 1);
  377.     { Call GetClientRect again because SetRange can change the size of
  378.       the client area if a scrollbar disappears }
  379.     GetClientRect(HWindow, R);
  380.     if ColumnBar <> 0 then DeleteObject(ColumnBar);
  381.     DC := GetDC(HWindow);
  382.     MemDC := CreateCompatibleDC(DC);
  383.     ReleaseDC(HWindow, DC);
  384.     ColumnBar := CreateCompatibleBitmap(DC, CharWidth,
  385.       R.bottom * CharHeight);
  386.     SelectObject(MemDC, ColumnBar);
  387.     SetTextColor(MemDC, ForeColor);
  388.     SetBKColor(MemDC, BKColor);
  389.     OldBrush := SelectObject(MemDC, CreateSolidBrush(BKColor));
  390.     PatBlt(MemDC, 0, 0, CharWidth, R.bottom * CharHeight, PatCopy);
  391.     DeleteObject(SelectObject(MemDC, OldBrush));
  392.     OldPen := SelectObject(MemDC, CreatePen(ps_Solid, 2, ForeColor));
  393.     SepX := CharWidth div 3;
  394.     MoveTo(MemDC, SepX, 0);
  395.     LineTo(MemDC, SepX, R.bottom);
  396.     MoveTo(MemDC, CharWidth - SepX, 0);
  397.     LineTo(MemDC, CharWidth - SepX, R.bottom);
  398.     DeleteObject(SelectObject(MemDC, OldPen));
  399.     DeleteDC(MemDC);
  400.   end;
  401. end;
  402.  
  403. var
  404.   ParadoxDemo: TParadoxDemo;
  405. begin
  406.   ParadoxDemo.Init('ParadoxDemo');
  407.   ParadoxDemo.Run;
  408.   ParadoxDemo.Done;
  409. end.
  410.