XCommCtrls.pas 不要,没有引用到。
{***************************************************************}
{ }
{ PraiseSoft SoftWare System }
{ Copyright(c) 2004-2005 PraiseSoft Software Corporation }
{ SoftWareName: XCommDlg SDK }
{ Version: V1.0 }
{ DevIDE: Delphi7.0 Windows 2000 Professional }
{ Build: 2006-03-02 }
{ Author: jfyes Email: jf_yes@126.com QQ: 348677065 }
{ Function: System Dialog }
{ Description: Delphi for Windows SDK }
{ Noteice: 1.本信息资料仅用于个人和非商业用途,复制请保留此信息,}
{ 未经作者书面许可,不得作任何商业(营利性)用途。 }
{ 2.如用本信息资料,制造违法信息/软件,本人不负任何法律 }
{ 责任。 }
{ 3.如有修改请发份源码给我,谢谢! }
{***************************************************************}
unit XCommDlg;
interface
uses
Windows, CommDlg;
function OpenDialog(const FileName, Filter: PChar;
const Dir: PChar = nil; const Handle: THandle = 0): BOOL;
//function OpenDialogs(const FileName, Filter, Dir: PChar): BOOL;
function SaveDialog(const FileName, Filter: PChar;
const Dir: PChar = nil; const Handle: THandle = 0): BOOL;
implementation
//打开多个文件
//function OpenDialogs(const FileName, Filter, Dir: PChar): BOOL;
function SaveDialog(const FileName, Filter, Dir: PChar;
const Handle: THandle): BOOL;
var
OpenObj: TOpenFilename;
begin
FillChar(OpenObj, SizeOf(OpenObj), 0);
OpenObj.lStructSize := SizeOf(OpenObj);
if Handle = 0 then
OpenObj.hWndOwner := GetActiveWindow()
else OpenObj.hWndOwner := Handle;
OpenObj.hInstance := hInstance;
OpenObj.lpstrFile := FileName;
OpenObj.lpstrFilter := Filter;
OpenObj.lpstrFileTitle := 'Save file';
if Dir = nil then OpenObj.lpstrInitialDir := '.'
else OpenObj.lpstrInitialDir := Dir;
OpenObj.nFilterIndex := 0;
OpenObj.nMaxFile := 256;
OpenObj.Flags := OFN_HIDEREADONLY or OFN_EXPLORER;
Result := CommDlg.GetSaveFileName(OpenObj);
end;
function OpenDialog(const FileName, Filter, Dir: PChar;
const Handle: THandle): BOOL;
var
OpenObj: TOpenFilename;
begin
FillChar(OpenObj, SizeOf(OpenObj), 0);
OpenObj.lStructSize := SizeOf(OpenObj);
if Handle = 0 then
OpenObj.hWndOwner := GetActiveWindow()
else OpenObj.hWndOwner := Handle;
OpenObj.hInstance := hInstance;
OpenObj.lpstrFile := FileName;
if Filter = nil then OpenObj.lpstrFilter := 'All file(*.*)'#0'*.*'
else OpenObj.lpstrFilter := Filter;
OpenObj.lpstrFileTitle := 'Open file';
if Dir = nil then OpenObj.lpstrInitialDir := '.'
else OpenObj.lpstrInitialDir := Dir;
OpenObj.nFilterIndex := 0;
OpenObj.nMaxFile := 256;
OpenObj.Flags := OFN_HIDEREADONLY or OFN_EXPLORER;
Result := CommDlg.GetOpenFileName(OpenObj);
end;
end.
{***************************************************************}
{ }
{ PraiseSoft SoftWare System }
{ Copyright(c) 2004-2005 PraiseSoft Software Corporation }
{ SoftWareName: Windows API Standard GUIs }
{ Version: V1.0 }
{ DevIDE: Delphi7.0 Windows 2000 Professional }
{ Build: 2005-12-02 }
{ Author: jfyes Email: jf_yes@163.com }
{ Function: }
{ Description: Delphi for Windows SDK }
{ Noteice: 1.本信息资料仅用于个人和非商业用途,复制请保留此信息,}
{ 未经作者书面许可,不得作任何商业(营利性)用途。 }
{ 2.如用本信息资料,制造违法信息/软件,本人不负任何法律 }
{ 责任。 }
{***************************************************************}
unit XStdCtrls;
interface
uses
Windows, Messages;
const // 10 system global GUIs
TEdit = 'Edit';
TMemo = 'Memo';
TButton = 'Button';
TRadio = 'Radio';
TCheckBox = 'CheckBox';
TGroupBox = 'GroupBox';
TComboBox = 'Combobox';
TListBox = 'Listbox';
TLabel = 'static';
TScrollBar = 'ScrollBar';
// 注册一个Window类
function RegistryClass(const ClassName: PChar; const lpFunc: Pointer): WORD;
// Create system global GUIs
function CreateStdWnd(lpClassName: PChar;
const lpCaption: PChar = nil; const Parent: HWND = 0;
const X: Integer = 0; const Y: Integer = 0;
const W: Integer = 0; const H: Integer = 0;
const Style: DWORD = WS_CHILD or WS_VISIBLE or WS_TABSTOP;
const ExStyle: DWORD = WS_EX_CLIENTEDGE): HWND;
function CreateStdWndW(lpClassName: PWideChar;
const lpCaption: PWideChar = nil; const Parent: HWND = 0;
const X: Integer = 0; const Y: Integer = 0;
const W: Integer = 0; const H: Integer = 0;
const Style: DWORD = WS_CHILD or WS_VISIBLE or WS_TABSTOP;
const ExStyle: DWORD = WS_EX_CLIENTEDGE): HWND;
function Now: TSystemTime;
function ShowMessage(lpText: PChar; const OwnerHwnd: HWND = 0;
const BtnType: DWORD = MB_OK + MB_ICONHAND): BOOL;
procedure ShowErrorMsg(MSG: PChar; const Handle: HWND = 0);
procedure ShowWarningMsg(MSG: PChar; const Handle: HWND = 0);
procedure ShowInfoMsg(MSG: PChar; const Handle: HWND = 0);
procedure WindowGetText(Handle: HWND; var Text: PChar);
function GetWndText(Handle: HWND): PChar;
function FormatChar(OutPut: PChar; lpFormat: PChar; arglist: array of Integer): Integer;
{ Memo }
procedure MemoReadonly(Handle: HWND; const ReadOnly: BOOL = True);
procedure MemoClear(Handle: HWND);
function MemoCount(Handle: HWND): Integer;
procedure MemoAdd(Handle: HWND; const S: PChar);
procedure MemoPut(Handle: HWND; Index: Integer; const S: PChar);
procedure MemoInsert(Handle: HWND; Index: Integer; const S: PChar);
{ Edit }
procedure EdtReadonly(Handle: HWND; const ReadOnly: BOOL = True);
procedure EdtClear(Handle: HWND);
procedure EdtSetTextW(Handle: HWND; Value: PWideChar);
procedure EdtSetText(Handle: HWND; Value: PChar);
procedure EdtSetMaxLength(Handle: HWND; Value: Integer);
{ Font }
function MakeFont(AFontName: string; aSize: Integer;
const fdwItalic: DWORD = 0; const fdwUnderline: DWORD = 0): HFONT;
procedure SetChildWNDFont(hMain: HWND; const FontName: PChar = nil; const FontSize: Integer = 9);
function SetFont(hWnd: HWND; FontName: PChar; FontSize: Integer): BOOL;
implementation
{ Memo }
procedure MemoReadonly(Handle: HWND; const ReadOnly: BOOL);
begin
EdtReadonly(Handle, ReadOnly);
end;
procedure MemoClear(Handle: HWND);
begin
EdtClear(Handle);
end;
function MemoCount(Handle: HWND): Integer;
begin
Result := SendMessage(Handle, EM_GETLINECOUNT, 0, 0);
if SendMessage(Handle, EM_LINELENGTH,
SendMessage(Handle, EM_LINEINDEX, Result - 1, 0), 0) = 0 then
Dec(Result);
end;
procedure MemoAdd(Handle: HWND; const S: PChar);
var
Index: Integer;
begin
Index := MemoCount(Handle);
if Index < 0 then Index := 0;
MemoInsert(Handle, Index, S);
end;
procedure MemoInsert(Handle: HWND; Index: Integer; const S: PChar);
var
SelStart, LineLen: Integer;
Line: PChar;
begin
if Index >= 0 then
begin
GetMem(Line, lstrlen(S) + 3);
SelStart := SendMessage(Handle, EM_LINEINDEX, Index, 0);
if SelStart >= 0 then begin
Windows.lstrcpy(Line, S);
Windows.lstrcat(Line, #13#10);
end
else begin
SelStart := SendMessage(Handle, EM_LINEINDEX, Index - 1, 0);
if SelStart < 0 then Exit;
LineLen := SendMessage(Handle, EM_LINELENGTH, SelStart, 0);
if LineLen = 0 then Exit;
Inc(SelStart, LineLen);
Windows.lstrcpy(Line, #13#10);
Windows.lstrcat(Line, S);
end;
SendMessage(Handle, EM_SETSEL, SelStart, SelStart);
SendMessage(Handle, EM_REPLACESEL, 0, Longint(PChar(Line)));
end;
end;
procedure MemoPut(Handle: HWND; Index: Integer; const S: PChar);
var
SelStart: Integer;
begin
SelStart := SendMessage(Handle, EM_LINEINDEX, Index, 0);
if SelStart >= 0 then
begin
SendMessage(Handle, EM_SETSEL, SelStart, SelStart +
SendMessage(Handle, EM_LINELENGTH, SelStart, 0));
SendMessage(Handle, EM_REPLACESEL, 0, Longint(S));
end;
end;
{ Edit }
procedure EdtReadonly(Handle: HWND; const ReadOnly: BOOL);
begin
SendMessage(Handle, EM_SETREADONLY, Ord(ReadOnly), 0);
end;
procedure EdtClear(Handle: HWND);
begin
SendMessage(Handle, WM_SETTEXT, 0, 0);
end;
procedure EdtSetTextW(Handle: HWND; Value: PWideChar);
begin
SendMessage(Handle, WM_SETTEXT, 0, Longint(Value));
end;
procedure EdtSetText(Handle: HWND; Value: PChar);
begin
SendMessage(Handle, WM_SETTEXT, 0, Longint(Value));
end;
procedure EdtSetMaxLength(Handle: HWND; Value: Integer);
begin
// 该GUI的style 必须有ES_AUTOHSCROLL才能自动,否则直到尾部就不能在写缓冲了。
SendMessage(Handle, EM_LIMITTEXT, Value, 0);
end;
function CreateStdWnd(lpClassName: PChar;
const lpCaption: PChar = nil; const Parent: HWND = 0;
const X: Integer = 0; const Y: Integer = 0;
const W: Integer = 0; const H: Integer = 0;
const Style: DWORD = WS_CHILD or WS_VISIBLE or WS_TABSTOP;
const ExStyle: DWORD = WS_EX_CLIENTEDGE): HWND;
var
ExStyles, Styles: DWORD;
ClassName: array[0..128]of Char;
begin
ExStyles := ExStyle;
Styles := Style;
ClassName := TButton;
if lpClassName = TEdit then begin
ClassName := TEdit;
Styles := Styles or WS_BORDER or ES_LEFT or ES_AUTOHSCROLL;
end
else if lpClassName = TMemo then begin
ClassName := TEdit;
Styles := Styles or ES_AUTOVSCROLL or ES_AUTOHSCROLL or
WS_HSCROLL or WS_VSCROLL or ES_MULTILINE or ES_WANTRETURN;
end
else if lpClassName = TButton then begin
Styles := Styles or BS_MULTILINE or BS_PUSHBUTTON or BS_DEFPUSHBUTTON;
end
else if lpClassName = TRadio then begin
Styles := Styles or BS_MULTILINE or BS_AUTORADIOBUTTON;
end
else if lpClassName = TCheckBox then begin
Styles := Styles or BS_MULTILINE or BS_AUTOCHECKBOX;
end
else if lpClassName = TGroupBox then begin
Styles := Styles or BS_GROUPBOX or CS_HREDRAW or CS_VREDRAW;
end
else if lpClassName = TListBox then begin
ClassName := TListBox;
Styles := Styles or LBS_STANDARD or LBS_DISABLENOSCROLL or LBS_NOINTEGRALHEIGHT or WS_BORDER;
end
else if lpClassName = TLabel then begin
ClassName := TLabel; //SS_SUNKEN or WS_BORDER;
Styles := Styles or SS_LEFT or SS_NOTIFY;
ExStyles := 0;
end
else if lpClassName = TComboBox then begin
ClassName := TComboBox;
Styles := Styles or WS_VSCROLL or CBS_HASSTRINGS or CBS_AUTOHSCROLL or CBS_DROPDOWN;
end
else if lpClassName = TScrollBar then begin
ClassName := TScrollBar;
Styles := Styles or LBS_STANDARD or LBS_DISABLENOSCROLL or LBS_NOINTEGRALHEIGHT or WS_BORDER;
end else
Windows.lstrcpy(ClassName, lpClassName);
Result := Windows.CreateWindowEx(ExStyles, ClassName, lpCaption, Styles,
X, Y, W, H, Parent, 0, HInstance, nil);
end;
function CreateStdWndW(lpClassName: PWideChar;
const lpCaption: PWideChar = nil; const Parent: HWND = 0;
const X: Integer = 0; const Y: Integer = 0;
const W: Integer = 0; const H: Integer = 0;
const Style: DWORD = WS_CHILD or WS_VISIBLE or WS_TABSTOP;
const ExStyle: DWORD = WS_EX_CLIENTEDGE): HWND;
var
ExStyles, Styles: DWORD;
ClassName: array[0..128]of WideChar;
begin
ExStyles := ExStyle;
Styles := Style;
Windows.lstrcpyW(ClassName, TButton);
if lpClassName = TEdit then begin
Windows.lstrcpyW(ClassName, TEdit);
Styles := Styles or WS_BORDER or ES_LEFT;
end
else if lpClassName = TMemo then begin
Windows.lstrcpyW(ClassName, TEdit);
Styles := Styles or ES_AUTOVSCROLL or ES_AUTOHSCROLL or
WS_HSCROLL or WS_VSCROLL or ES_MULTILINE;
end
else if lpClassName = TButton then begin
Styles := Styles or BS_MULTILINE or BS_PUSHBUTTON or BS_DEFPUSHBUTTON;
end
else if lpClassName = TRadio then begin
Styles := Styles or BS_MULTILINE or BS_AUTORADIOBUTTON;
end
else if lpClassName = TCheckBox then begin
Styles := Styles or BS_MULTILINE or BS_AUTOCHECKBOX;
end
else if lpClassName = TGroupBox then begin
Styles := Styles or BS_GROUPBOX or CS_HREDRAW or CS_VREDRAW;
end
else if lpClassName = TListBox then begin
Windows.lstrcpyW(ClassName, TListBox);
Styles := Styles or LBS_STANDARD or LBS_DISABLENOSCROLL or LBS_NOINTEGRALHEIGHT or WS_BORDER;
end
else if lpClassName = TLabel then begin
Windows.lstrcpyW(ClassName, TLabel); //SS_SUNKEN or WS_BORDER;
Styles := Styles or SS_LEFT or SS_NOTIFY;
end
else if lpClassName = TComboBox then begin
Windows.lstrcpyW(ClassName, TComboBox);
Styles := Styles or WS_VSCROLL or CBS_HASSTRINGS or CBS_AUTOHSCROLL or CBS_DROPDOWN;
end
else if lpClassName = TScrollBar then begin
Windows.lstrcpyW(ClassName, TScrollBar);
Styles := Styles or LBS_STANDARD or LBS_DISABLENOSCROLL or LBS_NOINTEGRALHEIGHT or WS_BORDER;
end else
Windows.lstrcpyW(ClassName, lpClassName);
Result := Windows.CreateWindowExW(ExStyles, ClassName, lpCaption, Styles,
X, Y, W, H, Parent, 0, HInstance, nil);
end;
procedure ShowErrorMsg(MSG: PChar; const Handle: HWND);
begin
ShowMessage(MSG, MB_OK + MB_ICONERROR, Handle);
end;
procedure ShowWarningMsg(MSG: PChar; const Handle: HWND);
begin
ShowMessage(MSG, MB_OK + MB_ICONWARNING, Handle);
end;
procedure ShowInfoMsg(MSG: PChar; const Handle: HWND);
begin
ShowMessage(MSG, MB_OK + MB_ICONINFORMATION, Handle);
end;
function ShowMessage(lpText: PChar; const OwnerHwnd: HWND; const BtnType: DWORD): BOOL;
var
lpTitle: PChar;
H: HWND;
Len: Integer;
YESOK: Integer;
begin
YESOK := 0;
if (BtnType and MB_OKCANCEL = MB_OKCANCEL) then YESOK := IDOK
else if (BtnType and MB_YESNO = MB_YESNO) then YESOK := IDYES;
H := GetActiveWindow;
if OwnerHwnd <> 0 then H := OwnerHwnd;
Len := Windows.GetWindowTextLength(H) + 1;
Getmem(lpTitle, Len);
SendMessage(H, WM_GETTEXT, Len, Longint(lpTitle));
Result := Windows.MessageBox(H, lpText, lpTitle, BtnType) = YESOK;
FreeMem(lpTitle, Len);
end;
function Now: TSystemTime;
begin
Windows.GetLocalTime(Result);
end;
procedure WindowGetText(Handle: HWND; var Text: PChar);
var
Len: Integer;
begin
if Handle <> 0 then begin
Len := SendMessage(Handle, WM_GETTEXTLENGTH, 0, 0) + 1;
GetMem(Text, Len);
SendMessage(Handle, WM_GETTEXT, Len, Integer(Text));
end;
end;
function GetWndText(Handle: HWND): PChar;
var
Len: Integer;
begin
Result := nil;
if Handle <> 0 then begin
Len := SendMessage(Handle, WM_GETTEXTLENGTH, 0, 0) + 1;
GetMem(Result, Len);
SendMessage(Handle, WM_GETTEXT, Len, Integer(Result));
end;
end;
function FormatChar(OutPut: PChar; lpFormat: PChar; arglist: array of Integer): Integer;
begin
Result := Windows.wvsprintf(OutPut, lpFormat, @arglist[Low(arglist)]);
end;
function RegistryClass(const ClassName: PChar; const lpFunc: Pointer): WORD;
var
WNDClass: TWNDCLASS;
begin
//填充结构
FillChar(WNDClass, SizeOf(WNDClass), 0);
WNDClass.lpfnWndProc := lpFunc;
WNDClass.hInstance := hInstance;
WNDClass.hIcon := LoadICON(0, IDI_APPLICATION);
WNDCLass.hCursor := LoadCursor(0, IDC_ARROW);
WNDClass.lpszClassName := ClassName;
WNDClass.hbrBackground := 11;
//注册类
Result := Windows.RegisterClass(WNDClass);
end;
function MakeFont(AFontName: string; aSize: Integer;
const fdwItalic, fdwUnderline: DWORD): HFONT;
begin
Result := CreateFont(-aSize, // nHeight
0, // nWidth
0, // nEscapement
0, // nOrientaion
400, // fnWeight
fdwItalic, // fdwItalic
fdwUnderline, // fdwUnderline
0, // fdwStrikeOut
DEFAULT_CHARSET, // fdwCharSet
OUT_DEFAULT_PRECIS, // fdwOutputPrecision
CLIP_DEFAULT_PRECIS, // fdwClipPrecision
DEFAULT_QUALITY, // fdwQuality
DEFAULT_PITCH or FF_DONTCARE, // fdwPitchAndFamily
PChar(AFontName)); // lpszFace
end;
function SetFont(hWnd: HWND; FontName: PChar; FontSize: Integer): BOOL;
begin
Result := SendMessage(hWnd, WM_SETFONT, MakeFont(FontName, FontSize), 0) <> 0;
end;
var
AFontName: array [0..128] of Char;
AFontSize: Integer = 9;
procedure SetChildWNDFont(hMain: HWND; const FontName: PChar; const FontSize: Integer);
function SetChildWNDFontPrc(cH: HWND; lParam: Integer): BOOL; stdcall;
begin
SetFont(cH, AFontName, AFontSize);
Result := True;
end;
begin
if FontName = nil then AFontName := 'MS Sans Serif'
else Windows.lstrcpy(AFontName, FontName);
if FontSize <> 9 then AFontSize := FontSize;
Windows.EnumChildWindows(hMain, @SetChildWNDFontPrc, 0);
end;
end.