home *** CD-ROM | disk | FTP | other *** search
- {Buttons - Copyright (C) Doug Overmyer 7/1/91}
- unit Buttons;
- {************************ Interface ***********************}
- interface
- uses WinTypes, WinProcs, WinDos, Strings, WObjects,WIN31,ShellAPI;
- const
- um_ButtonU = 198;
- um_ButtonD = 199;
-
- type
- hDrop=THandle;
- type {OD Button uses internal .bmp resource }
- PODButton = ^TODButton;
- TODButton = object(TRadioButton)
- HBmp :HBitmap;
- State:Integer;
- X,Y,W,H:Integer;
- constructor Init(AParent:PWindowsObject; AnID:Integer;ATitle:PChar;
- X1,Y1,W1,H1:Integer;IsDefault:Boolean;BMP:PChar;AGroup:PGroupBox);
- destructor Done;virtual;
- procedure DrawItem(var Msg:TMessage);virtual;
- procedure WMRButtonDown(var Msg:TMessage);virtual wm_First+wm_RButtonDown;
- end;
-
- PODDButton = ^TODDButton;{OD Button with D&D - .ICO file,extracted icon res, or internal bmp resource}
- TODDButton = object(TODButton)
- SourceName:Array[0..79] of Char;
- constructor Init(AParent:PwindowsObject;AnID:Integer;ATitle:PChar;
- X1,Y1,W1,H1:Integer;IsDefault:Boolean;BMP:PChar;AGroup:PGroupBox);
- procedure SetupWindow;virtual;
- function CanClose:Boolean;virtual;
- procedure ChangeBMP(BMPFile:PChar);
- procedure GetBMP;virtual;
- procedure WMDropFiles(var Msg:TMessage);virtual wm_First+wm_DropFiles;
- end;
-
- PODGroupBox = ^TODGroupBox; {Group box for TODButton }
- TODGroupBox = object(TGroupBox)
- OldID:Integer;
- constructor Init(AParent:PWindowsObject;AnID:Integer;AText:PChar;
- X,Y,W,H:Integer);
- procedure SelectionChanged(NewID:Integer);virtual;
- end;
-
- PODDGroupBox = ^TODDGroupBox; {Group box for TODDButton }
- TODDGroupBox = object(TODGroupBox)
- procedure SetupWindow;virtual;
- function CanClose:Boolean;virtual;
- procedure WMDropFiles(var Msg:TMessage);virtual wm_First+wm_DropFiles;
- end;
- {************************ Implementation **********************}
- implementation
- const
- SR_RECESSED = 1;
- SR_RAISED = 0;
- {************************ Functions ****************************}
- {************************ DrawHiLites ****************************}
- function DrawHilites(PaintDC:hDC;X1,Y1,X2,Y2,LW,State:Integer):Boolean;
- var
- LPts,RPts:Array[0..2] of TPoint;
- Pen1,Pen2,OldPen:HPen;
- Ofs,W,H:Integer;
- OldBrush:HBrush ;
- begin
- Pen1 := CreatePen(ps_Solid,1,$00000000); {Draw a surrounding blk frame}
- OldPen := SelectObject(PaintDC,Pen1);
- OldBrush := SelectObject(PaintDC,GetStockObject(null_Brush));
- Rectangle(PaintDC,X1,Y1,X2,Y2);
- SelectObject(PaintDC,OldPen);
- SelectObject(PaintDC,OldBrush);
- DeleteObject(Pen1);
- Ofs := Byte(State = SR_RECESSED) * lw;
-
- LPts[0].x := X1+Ofs; LPts[0].y := Y2-Ofs;
- LPts[1].x := X1+Ofs; LPts[1].y := Y1+Ofs;
- LPts[2].x := X2-Ofs; LPts[2].y := Y1+Ofs;
- RPts[0].x := X1+Ofs; RPts[0].y := Y2-Ofs;
- RPts[1].x := X2-Ofs; RPts[1].y := Y2-Ofs;
- RPts[2].x := X2-Ofs; RPts[2].y := Y1+Ofs;
- if State = SR_RAISED then
- begin
- Pen1 := CreatePen(ps_Solid,LW,$00FFFFFF);
- Pen2 := CreatePen(ps_Solid,LW,$00000000);
- end
- else
- begin
- Pen1 := CreatePen(ps_Solid,LW,$00000000);
- Pen2 := CreatePen(ps_Solid,LW,$00FFFFFF);
- end;
-
- OldPen := SelectObject(PaintDC,Pen1); {Draw the highlights}
- PolyLine(PaintDC,LPts,3);
- SelectObject(PaintDC,Pen2);
- DeleteObject(Pen1);
- PolyLine(PaintDC,RPts,3);
- SelectObject(PaintDC,OldPen);
- DeleteObject(Pen2);
- end;
-
- {Courtesy of Neil Rubenstein on CIS}
- function ICOtoBMP(FileName:PChar):HBitmap;
- {$I-}
- type
- IcoHeader = Record
- icoReserved0:Word;
- icoResourceType1:Word;
- icoResourceCount:Word;
- end;
- IcoDescript = Record
- Width,Height,ColorCount:Byte;
- Reserved1:Byte;
- Reserved2,Reserved3:Word;
- icoDIBSize:LongInt;
- icoDIBOffset:LongInt;
- end;
- var
- F:File;
- iH:IcoHeader;
- iD:icoDescript;
- ImNum,N:Word;
- Buf:Array[0..60] of Char;
- imSize,imOfs:LongInt;
- hNu:hBitmap;
- BI:PBitmapInfo;
- BitData:Pointer;
- Path,Dir,Name,Ext:Array[0..79] of Char;
- DC:hDC;
- const
- BISize:Word = sizeof(TBitmapInfoHeader)+16*sizeof(TRGBQuad);
-
- procedure Cleanup;
- begin
- Close(F);
- if IOresult <> 0 then ;
- if Bitdata <> nil then
- FreeMem(BitData,BI^.bmiHeader.biSizeImage);
- if BI <> nil then FreeMem(BI,BISize);
- end;
-
- begin
- IcoToBMP := 0;
- FileSplit(FileName,Dir,Name,Ext);
- StrCat(StrCat(StrCopy(Path,Dir),Name),'.ICO');
- Assign(F,Path);
- Reset(F,1);
- if IOResult <> 0 then Exit;
- BI := Nil;
- bitData := nil;
- BlockRead(F,IH,sizeof(IH));
- if (IOResult <> 0) or (IH.icoReserved0 <> 0) or (IH.icoResourceType1 <> 1) then
- begin
- Cleanup;
- Exit;
- end;
- imNum := IH.icoResourceCount;
- N :=0;imSize := 0;imOfs := 0;
- While (N < imNum) and (imOfs = 0) DO
- begin
- BlockRead(F,ID,sizeof(ID));
- if IOresult <> 0 then
- begin
- Cleanup;
- exit;
- End;
- if (ID.width=32) and (ID.height=32) and (ID.colorCount=16) then
- begin
- imSize := ID.icoDibSize;
- imOfs := ID.icoDibOffset;
- end;
- Inc(N);
- end;
- if imOfs <> 0 then
- begin
- GetMem(BI,BISize);
- Seek(F,imOfs);
- BlockRead(F,BI^,BISize);
- with BI^.bmiHeader do
- begin
- biHeight := 32;
- biSizeImage := (biWidth div 2)* biHeight;
- end;
- GetMem(BItData,BI^.bmiHeader.biSizeImage);
- BlockRead(F,bitData^,BI^.bmiHeader.biSizeImage);
- DC:=CreateDC('Display',nil,nil,nil);
- ICOToBMP := CreateDiBitmap(DC,BI^.bmiHeader,cbm_Init,bitData,BI^,DIB_RGB_COLORS);
- DeleteDC(DC);
- end;
- CleanUP;
- end;
-
- {***************************** TODButton *************************}
- constructor TODButton.Init(AParent:PWindowsObject; AnID:Integer;ATitle:PChar;
- X1,Y1,W1,H1:Integer;IsDefault:Boolean;BMP:PChar;AGroup:PGroupBox);
- begin
- TRadioButton.Init(AParent,AnID,ATitle,X1,Y1,W1,H1,AGroup);
- Attr.Style := Attr.Style or bs_OwnerDraw;
- HBmp := LoadBitmap(HInstance,BMP);
- X:= X1;Y:= Y1;H:=H1;W:= W1;
- State := SR_RAISED;
- end;
-
- destructor TODButton.Done;
- begin
- DeleteObject(HBmp);
- TButton.Done;
- end;
-
- procedure TODButton.DrawItem(var Msg:TMessage);
- var
- TheDC,MemDC:HDc;
- OldBitMap:HBitMap;
- PDIS :^TDrawItemStruct;
- PenWidth,OffSet:Integer;
- GKS,OldState:Integer;
- begin
- PDIS := Pointer(Msg.lParam);
- If IsIconic(hWindow) then Exit;
- OldState := State;
- if Group = NIL then
- begin
- if PDIS^.itemAction = oda_Focus then Exit;
- if ((PDIS^.itemAction and oda_Select ) > 0) and
- ((PDIS^.itemState and ods_Selected) > 0) then
- State := SR_RECESSED else State := SR_RAISED;
- end
- else
- begin
- GKS := GetKeyState(vk_LButton);
- if (PDIS^.itemAction = oda_DrawEntire) then
- State := State
- else if (PDIS^.itemAction = oda_Select) and
- (PDIS^.ItemState = ods_Selected + ods_Focus)
- then State := SR_RECESSED
- else if (PDIS^.itemAction = 2) and
- (PDIS^.ItemState = ods_Focus) and (GKS < 0)
- then State := SR_RAISED
- else Exit;
- end;
- if (State <> OldState) then
- SendMessage(Parent^.HWindow,wm_User+um_ButtonU+State,GetId,0);
- offset := 2;
- PenWidth := OffSet;
- MemDC := CreateCompatibleDC(PDIS^.HDC);
- OldBitMap := SelectObject(MemDC,HBMP);
- if State = SR_RAISED then BitBlt(PDIS^.HDC,0,0,W,H, MemDC,0,0,SrcCopy)
- else BitBlt(PDIS^.HDC,OffSet,OffSet,W,H, MemDC,0,0,SrcCopy);
- SelectObject(MemDC,OldBitMap);
- DeleteDC(MemDC);
- DrawHiLites(PDIS^.hDC,0,0,W,H,1,State);
- end;
-
- procedure TODButton.WMRButtonDown(var Msg:TMessage);
- begin
- SendMessage(Parent^.HWindow,wm_User+wm_RButtonDown,Integer(GetID),0);
- end;
- {********************* TODDButton *****************************}
- constructor TODDButton.Init(AParent:PwindowsObject;AnID:Integer;ATitle:PChar;
- X1,Y1,W1,H1:Integer;IsDefault:Boolean;BMP:PChar;AGroup:PGroupBox);
- begin
- TODButton.Init(AParent,AnId,ATitle,X1,Y1,W1,H1,IsDefault,'',AGroup);
- if BMP <> NiL then
- StrCopy(SourceName,BMP)
- else StrCopy(SourceName,'');
- end;
-
- procedure TODDButton.SetupWindow;
- begin
- TODButton.SetupWindow;
- DragAcceptFiles(HWindow,TRUE);
- GetBMP;
- end;
-
- function TODDButton.CanClose:Boolean;
- begin
- DragAcceptFiles(HWindow,FALSE);
- CanClose := TODButton.CanClose;
- end;
-
- procedure TODDButton.WMDropFiles(var Msg:TMessage);
- var
- DropItem:hDrop;
- FileNameBuf:Array[0..fsPathName] of Char;
- NewIcon:hIcon;
- GFileName:PChar;
- CtrlID:Integer;
- begin
- DropItem := Msg.wParam;
- DragQueryFile(DropItem,0,FileNameBuf,sizeof(FileNameBuf));
- GFileName :=StrNew(FileNameBuf);
- StrCopy(SourceName,FileNameBuf);
- GetBMP;
- DragFinish(DropItem);
- CtrlID := GetID;
- SendMessage(Parent^.HWindow,wm_User+wm_DropFiles,CtrlID,LongInt(GFileName));
- StrDispose(GFileName);
- end;
-
- procedure TODDButton.ChangeBMP(BMPFile:PChar);
- begin
- StrCopy(SourceName,BMPFile);
- GetBMP;
- end;
-
- procedure TODDButton.GetBMP;
- var
- Icon:hIcon;
- MemDC,MemDC2,DC:HDC;
- OldBmp,OldBMP2:HBitmap;
- OldBrush:HBrush;
- DIBmp:HBitmap ;
- begin
- if HBmp > 0 then DeleteObject(HBmp);
- Icon := 0; DIBmp := 0; HBmp := 0;
- Icon := ExtractIcon(HInstance,SourceName,0); {try to get an icon out of source}
- if Icon < 2 then {well, see if it's an .ICO file}
- DIBmp := ICOtoBMP(SourceName);
- if DiBmp = 0 then {last resort - see if it's an internal resource}
- DIBmp :=LoadBitmap(HInstance,SourceName);
- DC := GetDC(HWindow);
- hBmp := CreateCompatibleBitmap(DC,W,H);
- MemDC := CreateCompatibleDC(DC);
- OldBmp := SelectObject(MemDC,hBmp);
- OldBrush := SelectObject(MemDC,GetStockObject(ltGray_Brush));
- PatBlt(MemDC,0,0,Pred(W),Pred(H),PatCopy);
- if Icon >1 then
- DrawIcon(MemDC,1,1,Icon)
- else if DIBmp >0 then
- begin
- MemDC2 := CreateCompatibleDC(DC);
- OldBmp2 :=SelectObject(MemDC2,DIBmp);
- BitBlt(MemDC,1,1,Pred(W),Pred(H),MemDC2,0,0,SrcCopy);
- SelectObject(MemDC2,OldBmp2);
- DeleteObject(DIBmp);
- DeleteDC(MemDC2);
- end
- else
- Rectangle(MemDC,0,0,W,H);
- SelectObject(MemDC,OldBmp);
- SelectObject(MemDC,OldBrush);
- DeleteDC(MemDC);
- ReleaseDC(hWindow,DC);
- InvalidateRect(HWindow,nil,True);
- { UpdateWindow(HWindow); }
- end;
- {****************** TODGroupBox ******************************}
- constructor TODGroupBox.Init(AParent:PWindowsObject;AnID:Integer;AText:PChar;
- X,Y,W,H:Integer);
- begin
- TGroupBox.Init(AParent,AnId,AText,X,Y,W,H);
- Attr.Style := Attr.Style {and not ws_Visible};
- OldID := 0;
- end;
-
- procedure TODGroupBox.SelectionChanged(NewID:Integer);
- begin
- TGroupBox.SelectionChanged(NewID);
- if NewID = OldID then
- Exit;
- If OldID = 0 then
- OldID := NewID
- else
- begin
- PODButton(Parent^.ChildWithID(OldID))^.State := SR_RAISED;
- InvalidateRect(Parent^.ChildWithID(OldID)^.HWindow,nil,True);
- OldID := NewID;
- end;
- end;
- {************************* TODDGroupBox **************************}
- procedure TODDGroupBox.SetupWindow;
- begin
- TODGroupBox.SetupWindow;
- DragAcceptFiles(HWindow,TRUE);
- SetClassWord(HWindow,GCW_HBRBACKGROUND,GetStockObject(LTGRAY_BRUSH));
- end;
-
- function TODDGroupBox.CanClose:Boolean;
- begin
- DragAcceptFiles(HWindow,FALSE);
- CanClose := TGroupBox.CanClose;
- end;
-
- procedure TODDGroupBox.WMDropFiles(var Msg:TMessage);
- var
- DropItem:hDrop;
- FileNameBuf:Array[0..fsPathName] of Char;
- NewIcon:hIcon;
- MemDC,DC:HDC;
- OldBmp,NewBmp:HBitmap;
- OldBrush:HBrush;
- GFileName:PChar;
- CtrlID:Integer;
- Loc,SLoc:TPoint;
- ChildWin:HWnd;
- begin
- DropItem := Msg.wParam;
- DragQueryFile(DropItem,0,FileNameBuf,sizeof(FileNameBuf));
- GFileName :=StrNew(FileNameBuf);
- DragQueryPoint(DropItem,Loc);
- DragFinish(DropItem);
- SLoc := Loc;
- ClienttoScreen(HWindow,SLoc);
- ChildWin := WindowFromPoint(SLoc);
- CtrlID := GetDlgCtrlID(ChildWin);
- SendMessage(Parent^.HWindow,wm_User+wm_DropFiles,CtrlID,LongInt(GFileName));
- StrDispose(GFileName);
- end;
- end.
-