Turbo Toolbox/Turbo_Toolbox.iso/dtx9302/fillbar/fbdll.pas

Pascal/Delphi Source File | 1993-03-02 | 11.2 KB | 427 lines

{$A+,B-,D+,E-,F-,G+,I+,K+,N-,O-,P-,Q-,R-,S+,T-,V+,W+,X+,Y-}
(*========================================================*)
(*                        FBDLL.PAS                       *)
(*         (C) 1993 Andreas Siegmund & DMV-Verlag         *)
(*                                                        *)
(* DLL, die Fillbars in Dialogboxen zur Verfⁿgung stellt. *)
(* Compiler: Turbo Pascal für Windows, Borland Pascal 7.0 *)
(*========================================================*)

LIBRARY FillBar;

{$R FBDLL.RES}

USES
  WinTypes, WinProcs, Strings, CustCntl,
{$IFDEF VER70} OWindows, Objects; {$ELSE} WObjects; {$ENDIF}

CONST
  ofBitmap1 =  2;
  ofBitmap2 =  4;
  ofColor   =  6;
  ofFillBar = 10;
  ofFont    = 12;
  ofValue   = 14;
  ofSize    = 16;

CONST
  FillBarHeight        = 21;
  fbm_NewValue  : WORD = 0;

TYPE
  pParamRec = ^tParamRec;
  tParamRec = RECORD
    CtlStyle: tHandle;
    IdToStr : tIdToStr;
    StrToId : tStrToId;
  END;

PROCEDURE SetFillBarValue(Dlg: hWND; aId: INTEGER;
                          NewValue: INTEGER); EXPORT;
BEGIN
  SendDlgItemMessage(Dlg, aId, fbm_NewValue, NewValue, 0);
END;

FUNCTION FillBarMsg(hWindow: hWND; Message: WORD;
                    wParam: WORD; lParam: LONGINT): LONGINT;
                    EXPORT;
VAR
  Bitmap      : hBitmap;
  PaintStruct : tPaintStruct;

FUNCTION GetBitmap1: hBitmap;
BEGIN
  GetBitmap1 := GetWindowWord(hWindow, ofBitmap1);
END;

FUNCTION GetBitmap2: hBitmap;
BEGIN
  GetBitmap2 := GetWindowWord(hWindow, ofBitmap2);
END;

FUNCTION GetColor: tColorRef;
BEGIN
  GetColor := GetWindowLong(hWindow, ofColor);
END;

PROCEDURE SetColor(t: tColorRef);
BEGIN
  SetWindowLong(hWindow, ofColor, t);
END;

FUNCTION GetFillBar: hBitmap;
BEGIN
  GetFillBar := GetWindowWord(hWindow, ofFillBar);
END;

PROCEDURE SetFillBar(b: hBitmap);
BEGIN
  SetWindowWord(hWindow, ofFillBar, b);
END;

FUNCTION GetFont: hFont;
BEGIN
  GetFont := GetWindowWord(hWindow, ofFont);
END;

PROCEDURE SetFont(Font: hFont);
BEGIN
  SetWindowWord(hWindow, ofFont, Font);
END;

FUNCTION GetValue: WORD;
BEGIN
  GetValue := GetWindowWord(hWindow, ofValue);
END;

PROCEDURE SetValue(w: WORD);
BEGIN
  SetWindowWord(hWindow, ofValue, w);
END;

PROCEDURE Paint(DC: hDC);
VAR
  ClientRect: tRect;
  MemDC     : hDC;
  Bitmap    : hBitmap;
BEGIN
  GetClientRect(hWindow, ClientRect);
  WITH ClientRect DO BEGIN
    Bitmap := GetFillBar;
    MemDC  := CreateCompatibleDC(DC);
    SelectObject(MemDC, Bitmap);
    BitBlt(DC, 0, 0, Right, Bottom, MemDC, 0, 0, SrcCopy);
    DeleteObject(MemDC);
  END;
END;

PROCEDURE Repaint;
VAR
  DC : hDC;
BEGIN
  DC := GetDC(hWindow);
  Paint(DC);
  ReleaseDC(hWindow, DC);
END;

PROCEDURE SetNewValue(aValue: INTEGER);
VAR
  DC        : hDC;
  MemDC     : hDC;
  BitmapDC  : hDC;
  Handle    : hBitmap;
  ClientRect: tRect;
  r         : REAL;
  FillLen   : INTEGER;
  s         : ARRAY[0..6] OF CHAR;
BEGIN
  IF aValue IN [0..100] THEN BEGIN
    SetValue(aValue);
    DC := GetDC(hWindow);
    GetClientRect(hWindow, ClientRect);
    WITH ClientRect DO BEGIN
      r := (Right / 100) * aValue;
      FillLen := Round(r);
      MemDC := CreateCompatibleDC(DC);
      BitmapDC := CreateCompatibleDC(DC);
      Handle := GetFillBar;
      IF Handle <> 0 THEN DeleteObject(Handle);
      Handle := CreateCompatibleBitmap(DC, Right,
                                       FillBarHeight);
      SetFillBar(Handle);
      SelectObject(BitmapDC, Handle);

      (* ====== Grundgerⁿst des Fillbar erstellen ====== *)
      SelectObject(MemDC, GetBitmap1);
      BitBlt(BitmapDC, 0, 0, 4, FillBarHeight,
             MemDC, 0, 0, SrcCopy);
      StretchBlt(BitmapDC, 4, 0, Right - 8, FillBarHeight,
                 MemDC, 4, 0, 20, FillBarHeight, SrcCopy);
      BitBlt(BitmapDC, Right-4, 0, 4, FillBarHeight, MemDC,
             60, 0, SrcCopy);

      (* ====== Fⁿllgrad erstellen falls Wert > 0 ======= *)
      IF aValue <> 0 THEN BEGIN
        SelectObject(MemDC, GetBitmap2);
        BitBlt(BitmapDC, 0, 0, 2, FillBarHeight,
               MemDC, 0, 0, SrcCopy);
        StretchBlt(BitmapDC, 2, 0, FillLen-7, FillBarHeight,
                   MemDC, 3, 0, 20, FillBarHeight, SrcCopy);
        BitBlt(BitmapDC, FillLen - 5, 0, 5, FillBarHeight,
               MemDC, 59, 0, SrcCopy);
      END;
      (* ================= Text ausgeben ================ *)
      IF GetColor <> RGB(255, 255, 255) THEN BEGIN
        SelectObject(BitmapDC, GetFont);
        Str(aValue, s);
        StrCat(s, ' %');
        SetTextColor(BitmapDC, GetColor);
        SetTextAlign(BitmapDC, ta_Center);
        SetBkMode(BitmapDC, Transparent);
        TextOut(BitmapDC, Right DIV 2, 4, s, StrLen(s));
      END;
      DeleteObject(BitmapDC);
      DeleteObject(MemDC);
    END;
    ReleaseDC(hWindow, DC);
  END;
END;

FUNCTION ChooseColor(Style: LONGINT): tColorRef;
BEGIN
  CASE Style OF
    0 : ChooseColor := RGB(  0,   0, 255);
    1 : ChooseColor := RGB(128,   0,   0);
    2 : ChooseColor := RGB(  0,   0,   0);
    3 : ChooseColor := RGB(  0, 128,   0);
    4 : ChooseColor := RGB(  0, 255, 255);
    5 : ChooseColor := RGB(255, 255, 255);
  END;
END;

FUNCTION CreateSmallFont: hFont;
VAR
  Font   : hFont;
  LogFont: tLogFont;
BEGIN
  Font := GetStockObject(ANSI_VAR_FONT);
  GetObject(Font, SizeOf(LogFont), @LogFont);
  LogFont.lfWeight := 700;
  Font := CreateFontIndirect(LogFont);
  CreateSmallFont := Font;
END;

BEGIN
  FillBarMsg := 0;
  IF Message = fbm_NewValue THEN
  BEGIN
    SetNewValue(wParam);
    Repaint;
  END ELSE
  CASE Message OF
    wm_Create:
      BEGIN
        Bitmap := LoadBitmap(hInstance, pChar(100));
        SetWindowWord(hWindow, ofBitmap1, Bitmap);
        Bitmap := LoadBitmap(hInstance, pChar(200));
        SetWindowWord(hWindow, ofBitmap2, Bitmap);
        WITH pCreateStruct(lParam)^ DO
          SetColor(ChooseColor(Style));
        SetFillBar(0);
        SetFont(CreateSmallFont);
        SetNewValue(0);
      END;
    wm_Paint:
      BEGIN
        BeginPaint(hWindow, PaintStruct);
        Paint(PaintStruct.hDC);
        EndPaint(hWindow, PaintStruct);
      END;
    wm_NCHitTest: FillBarMsg := -1;
    wm_Destroy:
      BEGIN
        FillBarMsg := DefWindowProc(hWindow, Message,
                                    wParam, lParam);
        DeleteObject(GetBitmap1);
        DeleteObject(GetBitmap2);
        DeleteObject(GetFillBar);
        DeleteObject(GetFont);
      END;
  ELSE
    FillBarMsg := DefWindowProc(hWindow, Message,
      wParam, lParam);
  END;
END;

(* ==================== Info-Methoden =================== *)

FUNCTION FillBarInfo: tHandle; EXPORT;
VAR
  hInfo: tHandle;
  Info : pRWCtlInfo;
BEGIN
  hInfo := GlobalAlloc(gMem_Share OR gMem_ZeroInit,
    SizeOf(tRWCtlInfo));
  IF hInfo <> 0 THEN BEGIN
    Info := GlobalLock(hInfo);
    WITH Info^ DO BEGIN
      wVersion := 100;
      wCtlTypes := 1;
      StrCopy(szClass, 'ASFillBar');
      StrCopy(szTitle, 'AS - Custom Controls');
      WITH ctType[0] DO BEGIN
        wWidth := 263 OR $8000;
        wHeight := FillBarHeight OR $8000;
        StrCopy(szDescr, 'FillBar');
        dwStyle := ws_Child;
        hToolBit := 0;
        hDropCurs := 0;
      END;
    END;
    GlobalUnlock(hInfo);
  END;
  FillBarInfo := hInfo;
END;

FUNCTION FillBarStyleDlg(hWindow: hWND; Message: WORD;
         wParam: WORD; lParam: LONGINT): LONGINT; EXPORT;
CONST
  Prop = 'Prop';
VAR
  hRec : tHandle;
  Rec  : pParamRec;
  Style: pCtlStyle;
  s    : ARRAY[0..265] OF CHAR;
  Radio: INTEGER;
  I    : INTEGER;
BEGIN
  CASE Message OF
    wm_InitDialog:
      BEGIN
        hRec := LoWord(lParam);
        Rec := GlobalLock(hRec);
        Style := GlobalLock(Rec^.CtlStyle);
        SetProp(hWindow, Prop, hRec);
        WITH Rec^, Style^ DO BEGIN
          IdToStr(wID, s, SizeOf(s));
          SetDlgItemText(hWindow, 100, s);

          CheckRadioButton(hWindow, 110, 115,
            110+dwStyle);
        END;
        GlobalUnlock(Rec^.CtlStyle);
        GlobalUnlock(hRec);
      END;
    wm_Destroy:
        RemoveProp(hWindow, Prop);
    wm_Command:
      CASE wParam OF
        idCancel: EndDialog(hWindow, 0);
        idOk:
          BEGIN
            hRec := GetProp(hWindow, Prop);
            Rec := GlobalLock(hRec);
            Style := GlobalLock(Rec^.CtlStyle);
            WITH Rec^, Style^ DO BEGIN
              GetDlgItemText(hWindow, 100, s,
                SizeOf(s));
              wID := StrToId(s);
              Radio := 110;
              FOR I := 110 TO 115 DO
                IF IsDlgButtonChecked(hWindow, I) <> 0 THEN
                  Radio := I;
              dwStyle := Radio-110;
            END;
            GlobalUnlock(Rec^.CtlStyle);
            GlobalUnlock(hRec);
            EndDialog(hWindow, 1);
          END;
        ELSE FillBarStyleDlg := 0;
        END;
    ELSE FillBarStyleDlg := 0;
  END;
END;

FUNCTION FillBarStyle(hWindow: hWND; CtlStyle: tHandle;
         StrToId: tStrToId; IdToStr: tIdToStr): Bool;
         EXPORT;
VAR
  hRec  : tHandle;
  Rec   : pParamRec;
  hFocus: hWND;
BEGIN
  FillBarStyle := FALSE;
  hRec := GlobalAlloc(gMem_Share, SizeOf(tParamRec));
  IF hRec <> 0 THEN BEGIN
    Rec := GlobalLock(hRec);
    Rec^.IdToStr := IdToStr;
    Rec^.StrToId := StrToId;
    Rec^.CtlStyle := CtlStyle;
    GlobalUnlock(hRec);
    hFocus := GetFocus;
    FillBarStyle := Bool(DialogBoxParam(hInstance,
                         MakeIntResource(100), hWindow,
                         @FillBarStyleDlg, hRec));
    IF hFocus <> 0 THEN SetFocus(hFocus);
    GlobalFree(hRec);
  END;
END;

FUNCTION FillBarFlags(Style: LONGINT; Buff: pChar;
                      BuffLength: WORD): WORD; EXPORT;
BEGIN
  StrCopy(Buff, '');
END;

FUNCTION ListClasses(szAppName: pChar; wVersion: WORD;
             fnLoad: tLoad; fnEdit: tEdit): tHandle; EXPORT;
VAR
  hClasses: tHandle;
  Classes : pCtlClassList;
BEGIN
  hClasses := GlobalAlloc(gMem_Share OR gMem_ZeroInit,
              SizeOf(INTEGER) + SizeOf(TRWCtlClass));
  IF hClasses <> 0 THEN BEGIN
    Classes := GlobalLock(hClasses);
    WITH Classes^ DO BEGIN
      nClasses  := 1;
      WITH Classes[0] DO BEGIN
        fnInfo  := FillBarInfo;
        fnStyle := FillBarStyle;
        fnFlags := FillBarFlags;
      END;
    END;
    GlobalUnlock(hClasses);
  END;
  ListClasses := hClasses;
END;

EXPORTS
  FillBarMsg      INDEX 1,
  ListClasses     INDEX 2,
  SetFillBarValue INDEX 3;

VAR
  Class : tWndClass;

BEGIN
  WITH Class DO BEGIN
    lpszClassName := 'ASFillBar';
    hCursor       := LoadCursor(0, idc_Arrow);
    lpszMenuName  := NIL;
    Style         := cs_HRedraw OR cs_VRedraw OR cs_DblClks
                                OR cs_GlobalClass;
    lpfnWndProc   := tFarProc(@FillBarMsg);
    hInstance     := SYSTEM.hInstance;
    hIcon         := 0;
    cbWndExtra    := ofSize;
    cbClsExtra    := 0;
    hbrBackGround := 0;
  END;
  RegisterClass(Class);
  fbm_NewValue := RegisterWindowMessage('FillBar_NewValue');
END.

(*========================================================*)
(*                      Ende von FBDLL.PAS                *)