//------------------------------------------------------------------------------
//Global.pas
//共享模块,保存字符串资源和共享常量、变量、函数及过程
//------------------------------------------------------------------------------
unit Global;
interface
uses
Messages,Controls,ADODB,Classes,Forms,windows,DBGrids,shellapi,StrUtils,
SysUtils,Variants,Graphics,XPMenu,Registry,DBGridEh,ShlObj,ComObj,ActiveX;
resourcestring
//------------------------------------------------------------------------------
//应用程序信息
//------------------------------------------------------------------------------
SAbout = '关于(&A)...';
SAppName = '物流管理系统';
SAppVer = ' (Delphi 版)'+#13+'版权所有(C) 2001-2002 蜗牛工作室';
SConnectionString = 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=%s;'
+'Jet OLEDB
atabase Password=%s;';
SConExcelString = 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=%s;'
+'Extended Properties=Excel 8.0;';
SDefDataBaseName = 'Stock.mdb';
SEMail = 'ysai_cn@hotmail.com';
// SExplainFileName = '物流管理系统说明.doc';
SLogFile = 'ErrorsLog.Txt';
SSuperUserName = 'Supervisor';
//------------------------------------------------------------------------------
//应用程序提示及其它字符串资源
//------------------------------------------------------------------------------
SAttrib = '属性';
SBackupOK = '备份数据库成功!';
SCheckPassWord = '检查密码';
SCompressOK = '压缩数据库成功!';
SDeleteRecord = '删除记录';
SEBackup = '备份数据库失败!';
SECompress = '压缩数据库错误!';
SEConExcelFile = '连接 Excel 文件错误,请重新选择文件!';
SEOpenSheet = '打开工作表错误,请选择其它工作表!';
SEFileExists = '文件已存在!';
SEInput = '输入错误!';
SEInsertOrder = '插入记录到订单表失败!';
SEInsertOrderDetail = '插入记录到订单明细表失败!';
SENoFoundFile = '找不到文件 - %s';
SEOpenDBFile = '打开数据库错误,请重新指定一个!';
SEOpenQueryForm = '打开查询窗口 "%s" 错误!';
SEPassWord = '密码错误!密码区分大小写!';
SEReadUserInfo = '读取用户信息错误!';
SEReadUserTable = '读取用户信息表错误,请重新指定一个数据库!';
SEClientNonentity = '客户不存在!';
SError = '错误';
SErrorInfo = '错误信息:%s';
SESQL = '查询语句语法错误!';
SEUpdate = '更新记录出错!';
SEUserName = '用户名错误!输入的用户名 %s 不存在!';
SINumber = '请输入 %d 到 %d 之间的数字!';
SInsertOrderComplete = '导入订单完成!';
SIRecNo = '请输入记录号: ';
SManage = '管理';
SNoFoundHelpFile = '没有找到帮助文件!';
SNoFoundDBFile = '没有找到数据库文件,请指定一个!';
SNoFoundRecord = '没有找到符合条件的记录!';
SNoHelpFile = '对不起,没有提供帮助文件!';
SNoPopedom = '您没有执行此操作的权限!';
SNoPrinter = '对不起!您的电脑没有安装打印机,不能执行此操作!';
SNotSort = '不排序';
SNoUserName = '无用户名';
SQAbort = '是否放弃编辑?';
SQCloseConnection = '请求的操作必须断开与数据库的连接,是否继续?';
SQConfirmExport = '需要导出的记录数太多,确定要导出吗?';
SQDeleteRecord = '此操作不能恢复!是否删除记录?';
SQDeleteRecords = '删除主表中的记录将删除从表中与主表相对应的记录!';
SQOverlay = '是否覆盖?';
SQOverlayHint = '选"是"将覆盖文件,选"否"将把数据追加到文件尾部。';
SQSave = '数据已被修改,是否保存编辑?';
SQuery = '查询';
SQClaimLimit = '部分材料超过限制值,是否继续提交?';
SQViewParticular = '是否查看详细信息?';
SRecordCountRecNo = '共 %d 条,第 %d 条';
SSELECT = 'SELECT %s FROM %s';
SSetRecNo = '记录定位';
SSortField = '排序列:';
SSQLChangeRecord = '执行查询语句成功,引响了 %d 条记录!';
SSQLNoChange = '执行查询语句成功,但没有更改任何记录!';
SSQLNoReturn = '查询语句语法正确,但没有符合条件的记录!';
SSQLReturn = '查询语句语法正确,符合条件的记录有 %d 条!';
SUserTableNoRecord = '用户信息表没有记录,请重新指定一个!';
SConfirmUpdataRecords = '此操作将提交对相关表的更改,且提交后不能对从表进行编辑,'
+'确认提交更改?';
SNoStockStuff = '当前没有任何材料库存数量低于预警值!';
SStuffWarning = '警告:部分材料库存数量低于预警值!'#13#13+
'您可以选择"文件->库存材料预警"'+
'查看需要采购的材料和数量.';
SStuffEarlyWarning = '库存预警';
SSum = '总计';
SWarning = '警告';
SWStuffLack = '库存不足!';
SOrderContainStuff = '订单ID为 %d 的订单包含的材料列表';
//------------------------------------------------------------------------------
//EhLib打印变量
//'&[Page]','&[ShortDate]','&[Date]','&[LongDate]','&[Time]','&[Pages]'
//------------------------------------------------------------------------------
SCurrentDate = '日期:&[Date]';
SPagesAndPage = '共 &[Pages] 页 第 &[Page] 页';
//------------------------------------------------------------------------------
//时间
//------------------------------------------------------------------------------
// SYear = '%d年';
// SMonth = '%d月';
// SDay = '%d日';
//------------------------------------------------------------------------------
//查询条件常量
//------------------------------------------------------------------------------
SCW0 = '不限';
SCW1 = '小于等于 <=';
SCW2 = '小于 <';
SCW3 = '等于 =';
SCW4 = '大于 >';
SCW5 = '大于等于 >=';
SCW6 = '不等于 <>';
SCW7 = '晚于 >';
SCW8 = '早于 <';
SCW9 = '包含 %';
SVW1 = '是';
SVW2 = '否';
//------------------------------------------------------------------------------
//注册表键常量
//------------------------------------------------------------------------------
SREGSubKey = '/Software/YSoft/';
SREGbSaveUserName = 'SaveUserName';
SREGbUseFlatHint = 'UseFlatHint';
SREGbUseHint = 'UseHint';
SREGbUseXPMenu = 'UseXPMenu';
SREGclBackColor = 'WindowBackColor';
SREGiDrawStyle = 'DrawStyle';
SREGiDropDownCount = 'DropDownCount';
SREGsBackImage = 'BackImage';
SREGsDataBaseName = 'DataBaseName';
SREGsUserName = 'UserName';
//------------------------------------------------------------------------------
//表名,常量名带下划线的是系统表
//------------------------------------------------------------------------------
STab_FieldsPropertiy = '_字段属性';
STab_UserInfo = '_用户信息';
// STab_UserUseRecord = '_使用记录';
STab_UserPopedom = '_用户权限';
STabDept = '部门';
STabEmployee = '员工';
// STabEmployeeLimit = '员工领料限制';
STabClient = '客户';
STabOrder = '订单';
STabOrderDetail = '订单明细';
STabDesign = '款号';
STabDesignDetail = '款号明细';
STabClass = '材料类别';
STabStuff = '材料';
STabAddStuff = '入库';
STabAddStuffDetail = '入库明细';
STabTakeStuff = '领料';
STabTakeStuffDetail = '领料明细';
STabReturnStuff = '退料';
STabReturnStuffDetail = '退料明细';
STabShipment = '出货';
STabShipmentDetail = '出货明细';
STabStockPlan = '材料采购计划';
// STabStockPlan = '采购计划';
// STabStockPlanDetail = '采购计划明细';
//------------------------------------------------------------------------------
//字段名,常量名带下划线的是系统表的字段
//------------------------------------------------------------------------------
SField_AccessPopedom = '访问权限';
SField_BrowseWidth = '浏览宽度';
SField_DataSource = '数据源';
SField_EditWidth = '编辑宽度';
SField_Explain = '说明';
SField_Hint = '提示';
SField_Impower = '授权用户';
SField_Memo = '备注';
SField_Name = '字段名';
SField_PassWord = '密码';
SField_Popedom = '权限';
SField_TermField = '条件字段';
SField_Type = '字段类型';
SField_UserGrade = '用户级别';
SField_UserName = '用户名';
SFieldDept = '部门';
SFieldEmployee = '员工';
SFieldEmployeeName = '姓名';
SFieldClient = '客户';
SFieldDesign = '款号';
SFieldStuff = '材料';
SFieldOrderID = '单据ID';
SFieldAddStuffID = '单据ID';
SFieldTakeStuffID = '单据ID';
SFieldReturnStuffID = '单据ID';
SFieldShipmentID = '单据ID';
// SFieldStockPlanID = '单据ID';
SFieldEmployeeID = '员工ID';
SFieldDate = '日期';
SFieldReceiptNo = '单据号';
SFiedlIndentDate = '订货日期';
SFieldDeliveryDate = '交货日期';
SFieldMemo = '备注';
SFieldFefer = '提交';
SFieldClaimEmployee = '领料员';
SFieldStockEmployee = '采购员';
SFieldWarehouseman = '仓库管理员';
//------------------------------------------------------------------------------
//SQL语句
//------------------------------------------------------------------------------
{
//插入登录时间到用户使用记录
SSQLI_UserUseRecord = 'INSERT INTO _使用记录 (用户名,登录时间)'+
'VALUES ("%s",#%s#)';
//更新用户使用记录的注销时间
SSQLU_UserUseRecord = 'UPDATE _使用记录 '+
'SET 注销时间=#%s# '+
'WHERE ID=%d';
//取得用户使用记录的ID
SSQLQ_UserUseRecordID = 'SELECT MAX(ID) FROM _使用记录';
//}
//根据提交的订单的ID,更新材料表的需求数量
SSQLUOrder_Stuff = 'UPDATE 材料,订单明细,款号明细 '+
'SET 需求数量=需求数量+(订单明细.数量*款号明细.数量) '+
'WHERE 材料.材料=款号明细.材料 '+
'AND 订单明细.款号=款号明细.款号 '+
'AND 订单明细.单据ID=%d';
//根据提交的订单的ID,更新款号表的订购数量
SSQLUOrder_Design = 'UPDATE 款号,订单明细 '+
'SET 订购数量=订购数量+数量 '+
'WHERE 订单明细.款号=款号.款号 '+
'AND 订单明细.单据ID=%d';
//根据提交的出货单的ID,更新材料表的需求数量
SSQLUShipment_Stuff = 'UPDATE 材料,出货明细,款号明细 '+
'SET 需求数量=需求数量-(出货明细.数量*款号明细.数量) '+
'WHERE 材料.材料=款号明细.材料 '+
'AND 出货明细.款号=款号明细.款号 '+
'AND 出货明细.单据ID=%d';
//根据提交的出货单的ID,更新款号的订购数量
SSQLUShipment_Design = 'UPDATE 款号,出货明细 '+
'SET 订购数量=订购数量-数量 '+
'WHERE 出货明细.款号=款号.款号 '+
'AND 出货明细.单据ID=%d';
//根据提交的入库单的ID,更新材料表的库存数量
SSQLUAddStuff_Stuff = 'UPDATE 材料,入库明细 '+
'SET 库存数量=库存数量+入库明细.数量 '+
'WHERE 材料.材料=入库明细.材料 '+
'AND 入库明细.单据ID=%d';
//根据提交的单据的ID,更新材料表的库存数量和需求数量
SSQLUTakeStuff_Stuff = 'UPDATE 材料,领料明细 '+
'SET 库存数量=库存数量-领料明细.数量,需求数量=需求数量-领料明细.数量 '+
'WHERE 材料.材料=领料明细.材料 '+
'AND 领料明细.单据ID=%d';
SSQLUReturnStuff_Stuff = 'UPDATE 材料,退料明细 '+
'SET 库存数量=库存数量+退料明细.数量,需求数量=需求数量+退料明细.数量 '+
'WHERE 材料.材料=退料明细.材料 '+
'AND 退料明细.单据ID=%d';
{ //根据材料名,查询材料的出入库记录
SSQLStuffAttrib = 'SELECT * '+
'FROM ('+
'SELECT 日期,"领料" AS 操作,领料.单据ID,'+
'数量,单价,数量*单价 AS 总价,领料明细.备注 '+
'FROM 领料,领料明细 '+
'WHERE 领料.单据ID=领料明细.单据ID '+
'AND 提交 AND 材料="%s" '+
'UNION '+
'SELECT 日期,"入库" AS 操作,入库.单据ID AS 单据ID,'+
'数量,单价,数量*单价 AS 总价,入库明细.备注 '+
'FROM 入库,入库明细 '+
'WHERE 入库.单据ID=入库明细.单据ID '+
'AND 提交 AND 材料="%s"'+
') ORDER BY 日期;';
//}
//查询需要采购的材料及数量
SSQLStockStuff = '(SELECT 材料,单位,库存数量,需求数量,预警数量,最小采购数量,'+
'-INT(-(需求数量+预警数量-库存数量)/最小采购数量)'+
'*最小采购数量 AS 计划采购数量,供应商 '+
'FROM 材料 '+
'WHERE 需求数量+预警数量-库存数量>0)';
{
SSQLStockStuff = '(SELECT 材料,单位,库存数量,需求数量,预警数量,最小采购数量,-INT(-'+
'(需求数量+预警数量-库存数量-采购数量)/最小采购数量) AS 计划采购数量,供应商 '+
'FROM 材料,('+
'SELECT 材料 AS 采购材料,SUM(数量) AS 采购数量 '+
'FROM 入库,入库明细 '+
'WHERE 入库.单据ID=入库明细.单据ID AND NOT 提交 GROUP BY 材料 '+
'UNION '+
'SELECT 材料 AS 采购材料,0 AS 采购数量 '+
'FROM 材料 '+
'WHERE 材料 NOT IN ('+
'SELECT 材料 '+
'FROM 入库,入库明细 '+
'WHERE 入库.单据ID=入库明细.单据ID AND NOT 提交))'+
'WHERE 需求数量+预警数量-库存数量-采购数量>0 AND 材料=采购材料)';
//根据需要采购的材料数量生成采购计划单(未提交的,也就是采购单)
SSQLMakeStockPlan = 'INSERT INTO 采购计划明细 (单据ID,材料,单位,数量,供应商) '+
'SELECT %d,材料,单位,计划采购数量 AS 数量,供应商 FROM %s';
//}
//根据需要采购的材料数量生成采购计划单
SSQLMakeStockPlan = 'INSERT INTO 材料采购计划 '+
'SELECT * FROM %s';
//根据单据ID检查所领材料的库存是否足够
SSQLQExcessStuff = '(SELECT 材料.材料,库存数量,数量 AS 将领数量,'+
'数量-库存数量 AS 超出数量 '+
'FROM 材料,领料明细 '+
'WHERE 材料.材料=领料明细.材料 '+
'AND 数量-库存数量>0 '+
'AND 单据ID=%d)';
//根据订单的ID,查询所需的材料数量
SSQLQOrderStuff = 'SELECT 材料.材料,SUM(订单明细.数量*款号明细.数量) AS 数量,单位 '+
'FROM 材料,订单明细,款号明细 '+
'WHERE 材料.材料=款号明细.材料 '+
'AND 订单明细.款号=款号明细.款号 '+
'AND 订单明细.单据ID=%d '+
'GROUP BY 材料.材料,单位';
{
//根据单据ID和领料员姓名检查领料是否超过限制
SSQLQClaimLimit = '(SELECT A.材料,B.数量 AS 限制数量,C.数量 AS 已领数量,'+
'A.数量 AS 将领数量,C.数量+A.数量-B.数量 AS 超出数量 '+
'FROM '+
'(SELECT 材料,数量 '+
'FROM 领料明细 '+
'WHERE 单据ID=%d) AS A,'+
'(SELECT 材料,数量 '+
'FROM 员工,员工领料限制 '+
'WHERE 员工.员工ID=员工领料限制.员工ID '+
'AND 员工.姓名="%s") AS B,'+
'(SELECT SA.材料,SUM(SA.数量) AS 数量 '+
'FROM 领料明细 AS SA,领料 AS SB,'+
'(SELECT 姓名,材料,数量,起始日期,终止日期 '+
'FROM 员工,员工领料限制 '+
'WHERE 员工.员工ID=员工领料限制.员工ID '+
'AND 员工.姓名="%s") AS SC '+
'WHERE SA.单据ID=SB.单据ID '+
'AND SA.材料=SC.材料 '+
'AND SB.提交 '+
'AND SB.日期>=SC.起始日期 '+
'AND SB.日期<=SC.终止日期 '+
'AND SB.领料员=SC.姓名 '+
'GROUP BY SA.材料) AS C '+
'WHERE B.材料=C.材料 '+
'AND C.数量+A.数量-B.数量>0)';
//}
const
//自定义消息,关于菜单
CM_MSG_ABOUT = WM_USER+400;
EDIT_HEIGHT = 18;
FIELD_MAX_HEIGHT = 25;
FIELD_MAX_LINES = 6;
FIELD_MAX_WIDTH = 200;
LABLE_MAX_WIDTH = 100;
PANEL_WIDTH = 300;
TITLE_MAX_LENGTH = 40;
MAX_EXPORT_RECORDS = 1000;
var
bColBarVisible : Boolean = True;
bSaveUserName : Boolean = True;
bShareError : Boolean = False;
bUseFlatHint : Boolean = True;
bUseHint : Boolean = True;
bUseXPMenu : Boolean = True;
clBackColor : TColor = clWindow;
iDrawStyle : Integer = 2;
iDropDownCount : Integer = 20;
iMaxRecords : Integer = 0;
iUserGrade : Integer = 0;
// iUserLoginID : integer;
rsTabFields : TADODataSet;
sBackImage : String = '';
sDataBaseName : String = SDefDataBaseName;
sUserName : String = '';
function ActiveForm(FormTitle:string):boolean;
function CompactDatabase(AFileName,APassWord:string):boolean;
function GetCaption(const Caption:string):string;
function GetPassWord:string;
function MsgBox(Msg:Variant;Title:string='';Flag:longint=0):integer;
function ShowAbout():boolean;
function AddAboutMenu(Handle:THandle):boolean;
function CreateShellLink(SAppName:string;SLinkName:string='';
ifolder:Integer=0;
SSubFolder:string='';SDescription:string=''):string;
function LoadSetting:boolean;
function SaveSetting:boolean;
procedure CreateXPMenu(AOwner:TComponent;AName:TXPMenu;AActive:Boolean=true);
procedure OpenForm(FormClass: TFormClass;
var AForm;
AOwner:TComponent=nil);
procedure SetDBGridWidth(ADBGrid:TDBGridEh{;ICount:integer=1});
function CreateAccessFile(FileName:String;PassWord:string=''):boolean;
implementation
uses MDIMain;
function GetTempPathFileName():string;
var
SPath,SFile:array [0..254] of char;
begin
GetTempPath(254,SPath);
GetTempFileName(SPath,'~SM',0,SFile);
result:=SFile;
DeleteFile(result);
end;
procedure CreateXPMenu(AOwner:TComponent;AName:TXPMenu;AActive:Boolean=true);
//建立XP菜单
begin
AName:=TXPMenu.Create(AOwner);
with ANamedo
begin
Active := AActive;
AutoDetect := AActive;
// ControlUseTrueXPStyle:=true;
{ CheckedColor := clGreen;
Color := clWhite;
DisabledColor := clTeal;
IconBackColor := clBtnFace;
MenuBarColor := clWhite;
SelectBorderColor := clNavy;
SelectColor := clSkyblue;
SelectFontColor := clMaroon;
SeparatorColor := clCream;
//}
end;
end;
procedure SetDBGridWidth(ADBGrid:TDBGridEh{;ICount:integer=1});
//设制DBGridEh的各列的宽度
var
i:integer;
begin
for i:=0 to adbgrid.FieldCount-1do
if rsTabFields.Locate(SField_Name,
adbgrid.Fields
.FieldName,[]) then
begin
if (rsTabFields.FieldByName(SField_AccessPopedom).AsInteger<iUserGrade) or
(rsTabFields.FieldByName(SField_BrowseWidth).AsInteger<=0) then
adbgrid.Columns.Visible:=false
else
adbgrid.Columns.Width:=rsTabFields.FieldByName(SField_BrowseWidth).AsInteger;
end;
end;
procedure OpenForm(FormClass: TFormClass;
var AForm;
AOwner:TComponent=nil);
//根据窗口类名建立窗口,如果窗口存在则只激活它
var
i: integer;
Child:TForm;
begin
for i := 0 to Screen.FormCount -1do
if Screen.Forms.ClassType=FormClass then
begin
Child:=Screen.Forms;
if Child.WindowState=wsMinimized then
Child.WindowState:=wsNormal;
Child.BringToFront;
Child.Setfocus;
TForm(AForm):=Child;
exit;
end;
Child:=TForm(FormClass.NewInstance);
TForm(AForm):=Child;
if not assigned(aowner) then
aowner:=application;
Child.Create(AOwner);
end;
function ActiveForm(FormTitle:string):boolean;
//根据窗口标题激活窗口,如果窗口不存在则返回假
var
i:integer;
Child:TForm;
begin
Result:=False;
for i:=0 to screen.FormCount-1do
begin
Child:=Screen.Forms;
if Child.caption=formtitle then
begin
Child:=Screen.Forms;
if Child.WindowState=wsminimized then
Child.WindowState:=wsnormal;
Child.BringToFront;
Child.SetFocus;
Result:=true;
end;
end;
end;
function MsgBox(Msg:Variant;Title:string='';Flag:longint=0):integer;
//简化MessageBox函数
begin
if length(title)=0 then
title:=SAppName;
if flag=0 then
flag:=MB_OK + MB_ICONINFORMATION;
Result:=application.MessageBox(pchar(vartostr(Msg)),pchar(Title),flag);
end;
function ShowAbout():boolean;
//显示关于窗口
var
hIcon,hInst:integer;
begin
hInst:=getwindowword(application.Handle,GWL_HINSTANCE);
hIcon:=ExtractIcon(hInst,pchar(application.exename),0);
Result:=boolean(shellabout(application.Handle,
pchar(SAppName),pchar(SAppName+sappver),hicon));
end;
function GetCaption(const Caption:string):string;
//取得一个字符串,如果长度太长则截去尾部并加上...
begin
if length(Caption)<=TITLE_MAX_LENGTH then
result:=Caption
else
result:=leftstr(Caption,TITLE_MAX_LENGTH-3)+'...';
end;
function LoadSetting:boolean;
//从注册表读取保存的设置
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
with Regdo
begin
RootKey:=HKEY_LOCAL_MACHINE;
if OpenKey(SREGSubKey+SAppName,True) then
begin
if ValueExists(SREGbSaveUserName) then
bSaveUserName := ReadBool (SREGbSaveUserName);
if ValueExists(SREGbUseFlatHint) then
bUseFlatHint := ReadBool (SREGbUseFlatHint);
if ValueExists(SREGbUseHint) then
bUseHint := ReadBool (SREGbUseHint);
if ValueExists(SREGbUseXPMenu) then
bUseXPMenu := ReadBool (SREGbUseXPMenu);
if ValueExists(SREGclBackColor) then
clBackColor := ReadInteger(SREGclBackColor);
if ValueExists(SREGiDrawStyle) then
iDrawStyle := ReadInteger(SREGiDrawStyle);
if ValueExists(SREGiDropDownCount) then
iDropDownCount := ReadInteger(SREGiDropDownCount);
if ValueExists(SREGsBackImage) then
sBackImage := ReadString (SREGsBackImage);
if ValueExists(SREGsDataBaseName) then
sDataBaseName := ReadString (SREGsDataBaseName);
if ValueExists(SREGsUserName) then
sUserName := ReadString (SREGsUserName);
CloseKey;
end;
if length(sBackImage)=0 then
begin
RootKey:=HKEY_CURRENT_USER;
if OpenKey('Control Panel/Desktop',True) then
begin
if ValueExists('Wallpaper') then
sBackImage:=ReadString('Wallpaper');
CloseKey;
end;
end;
//if
end;
//with
result:=true;
finally
Reg.Free;
end;
end;
function SaveSetting:boolean;
//保存当前设置到注册表
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
with Regdo
begin
RootKey := HKEY_LOCAL_MACHINE;
if OpenKey(SREGSubKey+SAppName,True) then
begin
WriteBool (SREGbSaveUserName, bSaveUserName);
WriteBool (SREGbUseFlatHint, bUseFlatHint);
WriteBool (SREGbUseHint, bUseHint);
WriteBool (SREGbUseXPMenu, bUseXPMenu);
WriteInteger(SREGclBackColor, clBackColor);
WriteInteger(SREGiDrawStyle, iDrawStyle);
WriteInteger(SREGiDropDownCount, iDropDownCount);
WriteString (SREGsBackImage, sBackImage);
WriteString (SREGsDataBaseName, sDataBaseName);
WriteString (SREGsUserName, sUserName);
CloseKey;
end;
end;
//with
result:=true;
finally
Reg.Free;
end;
end;
function CompactDatabase(AFileName,APassWord:string):boolean;
//压缩与修复数据库,覆盖源文件
var
STempFileName:string;
vJE:OleVariant;
begin
STempFileName:=GetTempPathFileName;
try
vJE:=CreateOleObject('JRO.JetEngine');
vJE.CompactDatabase(format(SConnectionString,[AFileName,APassWord]),
format(SConnectionString,[STempFileName,APassWord]));
result:=CopyFile(PChar(STempFileName),PChar(AFileName),false);
DeleteFile(STempFileName);
except
result:=false;
end;
end;
function CreateAccessFile(FileName:String;PassWord:string=''):boolean;
//建立Access文件,如果文件存在则失败
var
STempFileName:string;
vCatalog:OleVariant;
begin
STempFileName:=GetTempPathFileName;
try
vCatalog:=CreateOleObject('ADOX.Catalog');
vCatalog.Create(format(SConnectionString,[STempFileName,PassWord]));
result:=CopyFile(PChar(STempFileName),PChar(FileName),True);
DeleteFile(STempFileName);
except
result:=false;
end;
end;
function GetPassWord:string;
//取得默认密码
begin
Result:='';
end;
function AddAboutMenu(Handle:THandle):boolean;
//增加关于菜单
var
SysMenu:HMenu;
i:integer;
s:array[0..225] of char;
begin
SysMenu:=GetSystemMenu(Handle,False);
i:=GetMenuItemCount(SysMenu)-1;
InsertMenu(SysMenu,i,MF_BYPOSITION+MF_SEPARATOR,0,nil);
InsertMenu(SysMenu,i,MF_BYPOSITION,CM_MSG_ABOUT,PChar(SAbout));
GetMenuString(SysMenu,i-1,s,255,MF_BYPOSITION);
if s[0]<>#0 then
InsertMenu(SysMenu,i,MF_BYPOSITION+MF_SEPARATOR,0,nil);
// AppendMenu(SysMenu,MF_SEPARATOR,0,nil);
// AppendMenu(SysMenu,MF_STRING,CM_MsgAbout,PChar(SAbout));
result:=true;
end;
function CreateShellLink(SAppName:string;SLinkName:string='';
ifolder:Integer=0;
SSubFolder:string='';SDescription:string=''):string;
//创建快捷方式
{快捷方式文件夹
CSIDL_DESKTOP = $0000;
CSIDL_PROGRAMS = $0002;
CSIDL_CONTROLS = $0003;
CSIDL_PRINTERS = $0004;
CSIDL_PERSONAL = $0005;
CSIDL_FAVORITES = $0006;
CSIDL_STARTUP = $0007;
CSIDL_RECENT = $0008;
CSIDL_SENDTO = $0009;
CSIDL_STARTMENU = $000b;
CSIDL_DESKTOPDIRECTORY = $0010;
CSIDL_FONTS = $0014;
CSIDL_TEMPLATES = $0015;
CSIDL_COMMON_STARTMENU = $0016;
CSIDL_COMMON_PROGRAMS = $0017;
CSIDL_COMMON_STARTUP = $0018;
CSIDL_COMMON_DESKTOPDIRECTORY = $0019;
}
var
SL: IShellLink;
PF: IPersistFile;
FileName: WideString;
FilePath: array[0..MAX_PATH] of char;
begin
try
OleCheck(CoCreateInstance(CLSID_ShellLink, nil,
CLSCTX_INPROC_SERVER,IShellLink, SL));
PF:=SL as IPersistFile;
OleCheck(SL.SetPath(PChar(SAppName)));
if SDescription <> '' then
SL.SetDescription(PChar(SDescription));
if SLinkName='' then
SLinkName:=ExtractFileName(SAppName);
SHGetSpecialFolderPath(0,FilePath,IFolder,True);
FileName:=string(FilePath);
if SSubFolder<>'' then
begin
FileName:=FileName+'/'+SSubFolder;
if not DirectoryExists(FileName) then
CreateDir(FileName);
end;
FileName:=FileName+'/'+SLinkName+'.lnk';
PF.Save(PWideChar(FileName), True);
Result:=FileName;
except
Result:='';
end;
end;
end.
//------------------------------------------------------------------------------
//MDIMain.pas,MDIMain.dfm
//MDI主窗体
//------------------------------------------------------------------------------
unit MDIMain;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, ImgList, Menus, DBCtrls, StdActns, ActnList, ToolWin,
XPMenu, TFlatHintUnit,TFlatGaugeUnit, DB, ADODB, Global, ExtCtrls,Shellapi,
DBMDIChild, MDIChild, DBBrowse, DBEdit, MainDM,Child, CustomQuery,
SQLQuery, Option, LogIn, Splash,Compress,UserManage,ImportOrder,
StuffAttrib, StdCtrls;
type
TMyStatusBar = class(TStatusBar)
protected
procedure CreateParams(var Params: TCreateParams);override;
end;
TMDIMainForm = class(TForm)
ActList: TActionList;
ColBar: TCoolBar;
ToolsCompressLocalDBF: TAction;
dlgSave: TSaveDialog;
FileBackup: TAction;
FileExit: TFileExit;
FileLogout: TAction;
FileOption: TAction;
FileSQLQuery: TAction;
FileUserSet: TAction;
HelpAbout: TAction;
HelpContents: THelpContents;
HelpTopicSearch: THelpTopicSearch;
imgMain: TImage;
MainMenu: TMainMenu;
mfBackup: TMenuItem;
mfExit: TMenuItem;
mFile: TMenuItem;
mfLogout: TMenuItem;
mfN1: TMenuItem;
mfN2: TMenuItem;
mfOption: TMenuItem;
mfQuery: TMenuItem;
mfUser: TMenuItem;
mhContents: TMenuItem;
mHelp: TMenuItem;
mhN1: TMenuItem;
mhSeatch: TMenuItem;
mtCompLocal: TMenuItem;
mTools: TMenuItem;
mtComp: TMenuItem;
mwa: TMenuItem;
mwAbout: TMenuItem;
mwc: TMenuItem;
mwcl: TMenuItem;
mwh: TMenuItem;
mWindow: TMenuItem;
mwm: TMenuItem;
mwN1: TMenuItem;
mwra: TMenuItem;
mwSB: TMenuItem;
mwTB: TMenuItem;
mwv: TMenuItem;
mww: TMenuItem;
pmwa: TMenuItem;
pmwc: TMenuItem;
pmwcl: TMenuItem;
pmwh: TMenuItem;
pmWindow: TPopupMenu;
pmwm: TMenuItem;
pmwN1: TMenuItem;
pmwra: TMenuItem;
pmwS: TMenuItem;
pmwT: TMenuItem;
pmwv: TMenuItem;
pmww: TMenuItem;
TolBar: TToolBar;
ToolsCompressDBF: TAction;
WindowArrange: TWindowArrange;
WindowCascade: TWindowCascade;
WindowClose: TWindowClose;
WindowCloseAll: TAction;
WindowMinAll: TWindowMinimizeAll;
WindowRstAll: TAction;
WindowStaBar: TAction;
WindowTileHorizontal: TWindowTileHorizontal;
WindowTileVertical: TWindowTileVertical;
WindowToolsBar: TAction;
HelpExplain: TAction;
mhExplain: TMenuItem;
EmailMe: TMenuItem;
ManageStuff: TAction;
mManage: TMenuItem;
N2: TMenuItem;
ManageClass: TAction;
U1: TMenuItem;
ManageDesign: TAction;
D1: TMenuItem;
ManageOrder: TAction;
O1: TMenuItem;
HelpEMail: TAction;
ManageClient: TAction;
U2: TMenuItem;
QueryClient: TAction;
QueryOrder: TAction;
QueryDesign: TAction;
QueryStuff: TAction;
QueryClass: TAction;
mQuery: TMenuItem;
C1: TMenuItem;
O2: TMenuItem;
D2: TMenuItem;
S1: TMenuItem;
U3: TMenuItem;
ImportOrder: TAction;
mtImportOrder: TMenuItem;
ManageAddStuff: TAction;
QueryAddStuff: TAction;
I1: TMenuItem;
I2: TMenuItem;
ManageTakeStuff: TAction;
QueryTakeStuff: TAction;
T1: TMenuItem;
T2: TMenuItem;
ManageDept: TAction;
ManageEmployee: TAction;
QueryDept: TAction;
QueryEmployee: TAction;
N1: TMenuItem;
N3: TMenuItem;
N4: TMenuItem;
N5: TMenuItem;
ManageShipment: TAction;
QueryShipment: TAction;
S2: TMenuItem;
S3: TMenuItem;
ReportStuff: TAction;
FileStuffWarning: TAction;
S4: TMenuItem;
mfManage: TMenuItem;
N7: TMenuItem;
moN1: TMenuItem;
ManageStockPlan: TAction;
QueryStockPlan: TAction;
N9: TMenuItem;
N10: TMenuItem;
ManageStockNumber: TAction;
N11: TMenuItem;
msN1: TMenuItem;
ManageReturnStuff: TAction;
QueryReturnStuff: TAction;
N6: TMenuItem;
N8: TMenuItem;
ToolButton1: TToolButton;
ToolButton2: TToolButton;
ToolButton3: TToolButton;
ToolButton4: TToolButton;
ToolButton5: TToolButton;
ToolButton6: TToolButton;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure FileExedute(Sender: TObject);
procedure StaBarResize(Sender: TObject);
procedure ProgressStart(AMin:integer=0;AMax:integer=100);
procedure ProgressAdd(AValue:integer=1);
procedure Progressend;
procedure FormCloseQuery(Sender: TObject;
var CanClose: Boolean);
procedure FormMouseDown(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: Integer);
procedure FormClose(Sender: TObject;
var Action: TCloseAction);
procedure WindowExecute(Sender: TObject);
procedure ToolsExecute(Sender: TObject);
procedure HelpExecute(Sender: TObject);
procedure WindowUpdate(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure ManageExecute(Sender: TObject);
procedure QueryExecute(Sender: TObject);
private
FOldClientProc,
FNewClientProc: TFarProc;
FDrawDC: hDC;
procedure ClientWndProc(var Msg: TMessage);
protected
procedure CreateWnd;
override;
function SetUser:boolean;
public
XM:TXPMenu;
StaBar:TMyStatusBar;
PrgBar:TFlatGauge;
FH:TFlatHint;
FDrawImage:boolean;
procedure AppMessageHandler(var Msg:TMsg;var Handled:boolean);
procedure DrawImage(Style:integer);
end;
var
MDIMainForm: TMDIMainForm;
implementation
{$R *.dfm}
procedure TMyStatusBar.CreateParams(var Params: TCreateParams);
//让TStatusBar可以成为其它控件的父
begin
inherited CreateParams(Params);
params.Style :=params.Style or WS_CLIPSIBLINGS;
end;
procedure TMDIMainForm.AppMessageHandler(var Msg:TMsg;var Handled:boolean);
//拦截应用程序的消息
var
i:integer;
begin
case Msg.wParam of
CM_MSG_ABOUT: //自定义消息,显示关于菜单
ShowAbout;
SC_MINIMIZE : //最小化消息,隐藏所有非MDI子窗体并最小化应用程序
begin
if Assigned(Screen.ActiveForm) then
SetWindowPos(Application.Handle,Screen.ActiveForm.Handle,
Screen.ActiveForm.Left,Screen.ActiveForm.Top,
Screen.ActiveForm.Width,0,SWP_SHOWWINDOW);
DefWindowProc(Application.Handle,WM_SYSCOMMAND,SC_MINIMIZE,0);
for i:=0 to Screen.FormCount-1do
if Screen.Forms is TChildForm then
ShowWindow(Screen.Forms.Handle,SW_HIDE);
end;
SC_RESTORE : //还原消息,显示所有非MDI子窗体并还原应用程序
begin
if Assigned(Screen.ActiveForm) then
SetWindowPos(Application.Handle,Screen.ActiveForm.Handle,
Screen.ActiveForm.Left,Screen.ActiveForm.Top,
Screen.ActiveForm.Width,0,SWP_SHOWWINDOW);
DefWindowProc(Application.Handle,WM_SYSCOMMAND,SC_RESTORE,0);
for i:=0 to Screen.FormCount-1do
if Screen.Forms is TChildForm then
ShowWindow(Screen.Forms.Handle,SW_SHOW);
end;
end;
Handled:=false;
end;
procedure TMDIMainForm.FormCreate(Sender: TObject);
begin
// Application.Title:=SAppName;
CreateShellLink(application.ExeName,SAppName,$0019);
{
LoadSetting;
//显示闪现窗体并检查密码
if not (ShowSplashForm and CheckPassWord) then
begin
close;
application.Terminate;
exit;
end;
//}
AddAboutMenu(Handle);
//应用设置,建立相应控件
Application.ShowHint:=bUseHint;
if bUseFlatHint then
begin
fh := TFlatHint.Create(self);
fh.Font := Font;
end;
CreateXpMenu(self,xm,bUseXPMenu);
Menu:=mainmenu;
MainMenu.Images:=MainDMForm.ImgList;
StaBar:=TMystatusbar.Create(self);
with StaBardo
begin
Panels.Add;
Panels.Add;
Parent := self;
OnResize := StaBarResize;
AutoHint := true;
PopupMenu := pmWindow;
end;
PrgBar:=tFlatGauge.Create(self);
with PrgBardo
begin
Visible := false;
Parent := StaBar;
Top := 3;
Height := stabar.Height-5;
end;
RefreshDataSet;
if FileExists(sBackImage) then
try
imgMain.Picture.LoadFromFile(sBackImage);
FDrawImage:=true;
except
FDrawImage:=false;
end;
if FDrawImage then
begin
DrawImage(iDrawStyle);
InvalidateRect(ClientHandle, nil, True);
end;
Show;
StaBarResize(PrgBar);
//用户权限设置
if not SetUser then
begin
msgbox(SEReadUserInfo,SAppName,MB_ICONSTOP);
close;
application.Terminate;
end;
SetWindowPos(Application.Handle,Handle,
Left,Top,Width,0,SWP_SHOWWINDOW);
if GetRecordSetCount(format(SSELECT,['COUNT(*)',SSQLStockStuff]))>0 then
MsgBox(SStuffWarning,SStuffEarlyWarning,MB_ICONWARNING);
end;
procedure TMDIMainForm.StaBarResize(Sender: TObject);
//调整状态栏
begin
if width>PANEL_WIDTH then
stabar.Panels[0].Width:=Width-PANEL_WIDTH;
if width-stabar.Panels[0].Width-13>0 then
prgbar.Width:=width-stabar.Panels[0].Width-13;
prgbar.Left:=stabar.Panels[0].Width+3;
end;
procedure TMDIMainForm.ProgressStart(AMin:integer=0;AMax:integer=100);
//初始化状态栏进度条
begin
stabar.Refresh;
with PrgBardo
begin
MinValue := AMin;
MaxValue := AMax;
Progress := 0;
Visible := True;
end;
end;
procedure TMDIMainForm.ProgressAdd(AValue:integer=1);
//增加状态栏进度条进度
begin
if PrgBar.Progress+AValue>PrgBar.MaxValue then
PrgBar.Progress:=PrgBar.MaxValue
else
PrgBar.Progress:=PrgBar.Progress+AValue;
end;
procedure TMDIMainForm.Progressend;
//隐藏状态栏进度条
begin
PrgBar.Progress:=PrgBar.MaxValue;
PrgBar.Visible:=false;
end;
procedure TMDIMainForm.FormCloseQuery(Sender: TObject;
var CanClose: Boolean);
//关闭所有MDI子窗体并保存设置
begin
Windowcloseall.Execute;
SaveSetting;
{ ExecuteSQL(format(SSQLU_UserUseRecord,
[DateTimeToStr(now),iUserLoginID]));
//}
end;
procedure TMDIMainForm.FormMouseDown(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: Integer);
//弹出右键菜单
begin
if button=mbright then
pmwindow.Popup(Mouse.CursorPos.x,Mouse.CursorPos.y);
end;
procedure TMDIMainForm.FormClose(Sender: TObject;
var Action: TCloseAction);
//释放对象
begin
rsTabFields.Free;
PrgBar.Free;
StaBar.Free;
fh.Free;
xm.Free;
Application.OnMessage:=nil;
end;
procedure TMDIMainForm.FileExedute(Sender: TObject);
//文件菜单
begin
case TComponent(sender).Tag of
2:begin
//备份数据库
if MDIChildCount>0 then
if msgbox(SQCloseConnection,SAppName,mb_yesno+mb_iconquestion)=IDNO then
exit
else
WindowCloseAll.Execute;
if dlgSave.Execute then
if FileExists(dlgSave.FileName) then
msgbox(SEFileExists,'',MB_ICONSTOP)
else
begin
MainDMForm.CNMain.Close;
if CopyFile(PChar(sDataBaseName),PChar(dlgSave.FileName),True) then
msgbox(SBackupOK)
else
msgbox(SEBackup,'',MB_ICONSTOP);
RefreshDataSet;
end;
end;
3://检查库存材料预警值
if GetRecordSetCount(format(SSELECT,['COUNT(*)',SSQLStockStuff]))>0 then
OpenDBBrowseForm(SSQLStockStuff,STabStuff,0,'','',SStuffEarlyWarning,True)
else
MsgBox(SNoStockStuff);
4:OpenForm(TCustomQueryForm,CustomQueryForm);
//自定义查询
5:if checkpassword(sUserName) then
//用户管理
TUserManageForm.Create(self).Show;
6:TOptionForm.Create(self).Show;
//选项
7:begin
//注销并重新登录
if MDIChildCount>0 then
if msgbox(SQCloseConnection,SAppName,mb_yesno+mb_iconquestion)=IDYES then
WindowCloseAll.Execute
else
exit;
hide;
{ ExecuteSQL(format(SSQLU_UserUseRecord,
[DateTimeToStr(now),iUserLoginID]));
//}
if not CheckPassWord then
begin
close;
application.Terminate;
exit;
end;
setuser;
show;
end;
end;
end;
procedure TMDIMainForm.ManageExecute(Sender: TObject);
//管理菜单
begin
case TComponent(sender).Tag of
1:OpenDBEditForm(format(SSelect,['*',STabClient]),STabClient,
STabOrder,SFieldClient,'',true);
2:OpenDBEditForm(format(SSelect,['*',STabOrder]),STabOrder,
STabOrderDetail,SFieldOrderID);
3:OpenDBEditForm(format(SSelect,['*',STabDesign]),STabDesign,
STabDesignDetail,SFieldDesign);
4:OpenDBEditForm(format(SSelect,['*',STabStuff]),STabStuff);
5:OpenDBEditForm(format(SSelect,['*',STabClass]),STabClass);
6:OpenDBEditForm(format(SSelect,['*',STabAddStuff]),STabAddStuff,
STabAddStuffDetail,SFieldAddStuffID);
7:OpenDBEditForm(format(SSelect,['*',STabTakeStuff]),STabTakeStuff,
STabTakeStuffDetail,SFieldTakeStuffID);
8:OpenDBEditForm(format(SSelect,['*',STabReturnStuff]),STabReturnStuff,
STabReturnStuffDetail,SFieldReturnStuffID);
9:OpenDBEditForm(format(SSelect,['*',STabShipment]),STabShipment,
STabShipmentDetail,SFieldShipmentID);
10:OpenDBEditForm(format(SSelect,['*',STabDept]),STabDept,
STabEmployee,SFieldDept,'',true);
11:OpenDBEditForm(format(SSelect,['*',STabEmployee]),STabEmployee);
{ 11:OpenDBEditForm(format(SSelect,['*',STabEmployee]),STabEmployee,
STabEmployeeLimit,SFieldEmployeeID);
12:OpenDBEditForm(format(SSelect,['*',STabStockPlan]),STabStockPlan,
STabStockPlanDetail,SFieldStockPlanID);}
12:OpenDBEditForm(format(SSelect,['*',STabStockPlan]),STabStockPlan);
13:OpenDBEditForm(format(SSelect,['材料,单位,库存数量,需求数量,预警数量',STabStuff]),STabStuff);
end;
end;
procedure TMDIMainForm.QueryExecute(Sender: TObject);
//查询菜单
begin
case TComponent(sender).Tag of
1:OpenSQLQueryForm(STabClient,STabOrder,SFieldClient,false,true);
2:OpenSQLQueryForm(STabOrder,STabOrderDetail,SFieldOrderID);
3:OpenSQLQueryForm(STabDesign,STabDesignDetail,SFieldDesign);
4:OpenSQLQueryForm(STabStuff);
5:OpenSQLQueryForm(STabClass);
6:OpenSQLQueryForm(STabAddStuff,STabAddStuffDetail,SFieldAddStuffID);
7:OpenSQLQueryForm(STabTakeStuff,STabTakeStuffDetail,SFieldTakeStuffID);
8:OpenSQLQueryForm(STabReturnStuff,STabReturnStuffDetail,SFieldReturnStuffID);
9:OpenSQLQueryForm(STabShipment,STabShipmentDetail,SFieldShipmentID);
10:OpenSQLQueryForm(STabDept,STabEmployee,SFieldDept,false,true);
11:OpenSQLQueryForm(STabEmployee);
// 11:OpenSQLQueryForm(STabEmployee,STabEmployeeLimit,SFieldEmployeeID);
// 12:OpenSQLQueryForm(STabStockPlan,STabStockPlanDetail,SFieldStockPlanID);
end;
end;
procedure TMDIMainForm.ToolsExecute(Sender: TObject);
//工具菜单
begin
case TComponent(sender).Tag of
1:TImportOrderForm.Create(Self).Show;
//导入订单向导
2:TCompressForm.Create(Self).Show;
//压缩数据库工具
3:begin
//压缩当前数据库
if MDIChildCount>0 then
if msgbox(SQCloseConnection,SAppName,mb_yesno+mb_iconquestion)=IDNO then
exit
else
WindowCloseAll.Execute;
screen.Cursor:=crHourGlass;
MainDMForm.CNMain.Close;
if CompactDatabase(sDatabaseName,GetPassWord) then
msgbox(SCompressOK)
else
msgbox(SECompress,SAppName,MB_ICONSTOP);
RefreshDataSet;
end;
end;
screen.Cursor:=crDefault;
end;
procedure TMDIMainForm.WindowExecute(Sender: TObject);
//窗口菜单
var
i:integer;
begin
case TComponent(sender).Tag of
1:for i:=0 to MDIChildCount-1do
MDIChildren.WindowState:=wsnormal;
//还原所有
2:for i:=MDIChildCount-1do
wnto 0do
MDIChildren.Close;
//关闭所有
3:begin
//显示/隐藏工具栏
bColBarVisible:=WindowToolsbar.Checked;
colbar.Visible:=bColBarVisible;
for i:=0 to MDIChildCount-1do
if MDIChildren is TMDIChildForm then
TMDIChildForm(MDIChildren).ColBar.Visible:=bColBarVisible;
end;
4:stabar.Visible:=WindowStaBar.Checked;
//显示/隐藏状态栏
end;
end;
procedure TMDIMainForm.HelpExecute(Sender: TObject);
//帮助菜单
begin
case TComponent(sender).Tag of
1,2:msgbox(SNoHelpFile);
//帮助文件
3:showabout;
//显示关于
6:ShellExecute(Handle,'Open',PChar('MailTo:'+SEMail),nil,nil,SW_SHOWNORMAL);
end;
end;
procedure TMDIMainForm.WindowUpdate(Sender: TObject);
//窗口菜单更新
begin
if MDIChildCount=0 then
begin
WindowRstAll.Enabled := false;
WindowCloseAll.Enabled := false;
end else
begin
WindowRstAll.Enabled := true;
WindowCloseAll.Enabled := true;
end;
end;
function TMDIMainForm.SetUser:boolean;
//从数据库中读入数据并设置用户权限
var
i:integer;
sp,se:string;
rsTabUserPopedom:TADODataSet;
begin
result:=false;
rsTabUserPopedom:=getrecordset(format(sselect,['*',STab_UserPopedom]));
if assigned(rsTabUserPopedom) then
try
if rsTabUserPopedom.Locate(SField_UserGrade,iUserGrade,[]) then
begin
sp:=rsTabUserPopedom[SField_Popedom];
se:=rsTabUserPopedom[SField_Explain];
end;
Caption:=SAppName+' ('+se+' - '+sUserName+')';
for i:=0 to ActList.ActionCount-1do
if pos(ActList.Actions.Name,sp)>0 then
TAction(ActList.Actions).Enabled:=false
else
TAction(ActList.Actions).Enabled:=true;
if iUserGrade>1 then
iMaxRecords := 10
else
iMaxRecords := 0;
rsTabUserPopedom.Free;
{
ExecuteSQL(format(SSQLI_UserUseRecord,
[sUserName,DateTimeToStr(now)]));
iUserLoginID:=GetRecordSet(SSQLQ_UserUseRecordID).Fields[0].AsInteger;
//}
result:=true;
except
result:=false;
end;
end;
procedure TMDIMainForm.CreateWnd;
//画背景图代码需要的部分,用自己的过程代替系统过程
begin
inherited CreateWnd;
FNewClientProc := MakeObjectInstance(ClientWndProc);
FOldClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(FNewClientProc));
end;
procedure TMDIMainForm.DrawImage(Style:integer);
//画背景图
var
Row, Col: Integer;
CR, IR: TRect;
NumRows, NumCols: Integer;
begin
if not FDrawImage then
exit;
GetWindowRect(ClientHandle, CR);
case Style of
0:with imgMaindo
BitBlt(FDrawDC, ((CR.Right - CR.Left) - Picture.Width) div 2,
((CR.Bottom - CR.Top) - Picture.Height) div 2,
Picture.Graphic.Width, Picture.Graphic.Height,
Picture.Bitmap.Canvas.Handle, 0, 0, SRCCOPY);
1:StretchBlt(FDrawDC, 0, 0, CR.Right, CR.Bottom,
imgMain.Picture.Bitmap.Canvas.Handle, 0, 0,
imgMain.Picture.Width, imgMain.Picture.Height, SRCCOPY);
2:begin
IR := imgMain.ClientRect;
NumRows := CR.Bottom div IR.Bottom;
NumCols := CR.Right div IR.Right;
with imgMaindo
for Row := 0 to NumRows+1do
for Col := 0 to NumCols+1 do
BitBlt(FDrawDC, Col * Picture.Width, Row * Picture.Height,
Picture.Width, Picture.Height, Picture.Bitmap.Canvas.Handle,
0, 0, SRCCOPY);
end;
end;
end;
procedure TMDIMainForm.ClientWndProc(var Msg: TMessage);
//画背景图过程,用本过程代替了系统过程处理消息
begin
case Msg.Msg of
WM_ERASEBKGND:
begin
CallWindowProc(FOldClientProc, ClientHandle, Msg.Msg, Msg.wParam,
Msg.lParam);
FDrawDC := TWMEraseBkGnd(Msg).DC;
DrawImage(iDrawStyle);
Msg.Result := 1;
end;
WM_VSCROLL, WM_HSCROLL:
begin
Msg.Result := CallWindowProc(FOldClientProc, ClientHandle, Msg.Msg,
Msg.wParam, Msg.lParam);
InvalidateRect(ClientHandle, nil, True);
end;
else
Msg.Result := CallWindowProc(FOldClientProc, ClientHandle, Msg.Msg,
Msg.wParam, Msg.lParam);
end;
end;
procedure TMDIMainForm.FormResize(Sender: TObject);
//窗体尺寸变化让背景失效
begin
InvalidateRect(ClientHandle, nil, True);
end;
end.