10分钟制作制作炫酷Windows Android IOS Dialogs对话框FMX界面
带透明度,可以将提示的内容问题和截屏任意分享至社交App
一、先看代码
unit CustomDialogsSimple1;
interface
uses
System.SysUtils, System.Types, System.UITypes,
System.Classes, System.Variants, System.Actions,
System.Rtti,//:运行时刻库
FMX.Types, FMX.Graphics, FMX.Controls,
FMX.Forms, FMX.Dialogs, FMX.StdCtrls,
FMX.Edit, FMX.Effects, FMX.Controls.Presentation,
FMX.Objects, FMX.Layouts,
FMX.ScrollBox, FMX.Memo,
FMX.ActnList, FMX.StdActns, ,FMX.Platform //:平台服务
;
type
TframeCustomDialogsSimple1 = class(TFrame)
LayoutDiologTranslucent: TLayout;
RectDiologTranslucent: TRectangle;
RectDiolog: TRectangle;
RectDiologTitle: TRectangle;
lblDiologTitle: TLabel;
RectDiologToolbar: TRectangle;
GlowEffect1: TGlowEffect;
lblRectDiologContentTips: TLabel;
imgDiologTitle: TImage;
LayoutRectDiologContent: TLayout;
MemoTips: TMemo;
LayoutRectDiologContentTips: TLayout;
imgRectDiologContentTips: TImage;
RectBtnOk: TRectangle;
imgBtnOk: TImage;
lblBtnOk: TLabel;
RectBtnCancel: TRectangle;
imgBtnCancel: TImage;
lblBtnCancel: TLabel;
btnCancel: TRectangle;
btnOk: TRectangle;
RectDiologContentTips: TRectangle;
RectBtnHelpme: TRectangle;
imgBtnHelpme: TImage;
lblBtnHelpme: TLabel;
btnHelpme: TRectangle;
imgShare: TImage;
LayoutShare: TLayout;
RectShare: TRectangle;
RectBtnShareText: TRectangle;
imgBtnShareText: TImage;
lblBtnShareText: TLabel;
BtnShareText: TRectangle;
RectBtnShareTo: TRectangle;
imgBtnShareTo: TImage;
lblBtnShareTo: TLabel;
BtnShareTo: TRectangle;
LayoutShareText: TLayout;
MemoShareText: TMemo;
LayoutShareTextTips: TLayout;
RectShareTextTips: TRectangle;
imgShareTextTips: TImage;
lblShareTextTips: TLabel;
RectShareText: TRectangle;
lblRectShare: TLabel;
RectLayoutShare: TRectangle;
SpBtnShareTo: TSpeedButton;
procedure btnOkClick(Sender: TObject);
procedure btnCancelClick(Sender: TObject);
procedure btnHelpmeClick(Sender: TObject);
procedure BtnShareTextClick(Sender: TObject);
procedure BtnShareToClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
//供调用者传入的回调参数:
//FTips:string;
frameCustomDialogsSimple1:TframeCustomDialogsSimple1;
FTControl:TControl;//:供调用者传入的截屏控件
end;
type
TAProc<T> = reference to procedure(const Arg :T);
TAFunc<T,TResult> = reference to function(const Arg :T):T;
var FTips:string;//:传出变量
///<summary>本单元通用截屏方法-可做入全局库:</summary>
procedure FMakeScreenshot(
ATControl:TControl;AImage:TImage);
implementation
uses myFuc_UnifiedPlatForm; // :我的通用库
{$R *.fmx}
procedure TframeCustomDialogsSimple1.btnCancelClick(Sender: TObject);
var LAProc:TAProc<string>;
LAFunc:TAFunc<string,Boolean>;
begin
//MemoRectDiologContent.Lines.Add(' 你点了取消,你要做什么在你的继承代码中写匿名过程TAProc<T>或写匿名函数TAFunc<T>');
FTips:=sLineBreak+'你点了取消:'+sLineBreak
+' 你点了取消,你要做什么在你的继承代码中调用你写好的过程或函数';
//:FTips:回调测试用
self.SendToBack;
self.Visible:=false;
end;
procedure TframeCustomDialogsSimple1.btnOkClick(Sender: TObject);
var LAProc:TAProc<string>;
LAFunc:TAFunc<string,Boolean>;
begin
//MemoRectDiologContent.Lines.Add(' 你点了确定,你要做什么在你的继承代码中写匿名过程TAProc<T>或写匿名函数TAFunc<T>');
FTips:=sLineBreak+'你点了确定:'+sLineBreak
+' 你点了确定,你要做什么在你的继承代码中调用你写好的过程或函数';
//:FTips:回调测试用
self.SendToBack;
self.Visible:=false;
end;
procedure TframeCustomDialogsSimple1.btnHelpmeClick(Sender: TObject);
begin
FMakeScreenshot(self.FTControl,self.imgShare);//:调截屏方法
FTips:=sLineBreak+'你点了询问:'+sLineBreak
+' 你点了询问,你可以用此接口截屏分享给需要帮助您的人';
//:FTips:回调测试用
LayoutDiologTranslucent.Visible:=true;
RectDiolog.Visible:=false;
LayoutShare.BringToFront;
LayoutShare.Visible:=true;
end;
procedure TframeCustomDialogsSimple1.BtnShareTextClick(Sender: TObject);
begin
LayoutShareText.Visible:=not(LayoutShareText.Visible);
end;
procedure TframeCustomDialogsSimple1.BtnShareToClick(Sender: TObject);
var LClipBoard:IFMXClipboardService; //:剪切板接口 //: FMX.Platform
LTValue:TValue;//:设置剪切板的泛型值 //: System.Rtti
begin
if MemoShareText.Lines.Text.Trim<>'' then
if TPlatformServices.Current.SupportsPlatformService(
IFMXClipboardService,IInterface(LClipBoard) ) then
begin
LTValue := TValue.From(MemoShareText.Lines.Text);
LClipBoard.SetClipboard(LTValue);
end;
//:剪切复制说两句的内容;界面显示处理:
LayoutShareText.Visible:=false;
LayoutShare.SendToBack;
LayoutShare.Visible:=false;
imgShare.Visible:=false;
LayoutDiologTranslucent.Visible:=true;
RectDiolog.Visible:=true;
end;
procedure FMakeScreenshot(
ATControl:TControl;AImage:TImage);
//本单元通用截屏方法-可做入全局库:
var LTBitmap:TBitmap;
begin
LTBitmap:=ATControl.MakeScreenshot;
//:FTControl:回调控件截屏
AImage.Bitmap.SetSize(LTBitmap.Size);
AImage.Bitmap.CopyFromBitmap(LTBitmap);
AImage.Visible:=true;
end;
end.
做出的效果：
二、怎么做的呢？步骤：
1、先用FMX Form临时窗体画UI界面（javaUI做的事情）：
底层Layout给透明度：
这样布局：
注意layer层之间Bringfront和SendToBack属性，
画出这样的效果：
2、创建Frame（javaUI做的事情）：
3、把你刚才在Form临时窗体中画的UI界面复制粘贴到上面的Frame（javaUI做的事情）：
这样的效果：
4、Frame UI界面简单的点击事件控制界面显示规则（java前端做的事情）：
// 几句话代码（见上面蓝色标注）:
5、将上述Frame界面拖入加载到你的APP应用窗体（javaUI做的事情）
6、写你的调用代码及逻辑代码（java后端开发做的事情）：
按钮事件代码：
分享代码：
一次一个分享动作：图片和文字只能二选一（除非 你做了多个动作代码，被某个Action连续调用，或者将文字画到图片中去）：
截屏传参：
大功告成！是不是很简单呀！
三、下面是在上述基础之上，附加：1、WIndows下拉起QQ、TIM、微信；2、访问注册表
3.1、全平台拉起QQ、TIM、微信等进行分享截屏及消息对话框内容
unit CustomDialogsSimple1;
interface
uses
{$IFDEF MSWINDOWS}
Winapi.ShellAPI,Winapi.Windows,
RegistryWin32,
{$ENDIF MSWINDOWS}
System.SysUtils, System.Types, System.UITypes,
System.Classes, System.Variants, System.Actions,
System.IOUtils,System.Rtti,//:运行时刻库
FMX.Types, FMX.Graphics, FMX.Controls,
FMX.Forms, FMX.Dialogs, FMX.StdCtrls,
FMX.Edit, FMX.Effects, FMX.Controls.Presentation,
FMX.Objects, FMX.Layouts,
FMX.ScrollBox, FMX.Memo,
FMX.ActnList, FMX.StdActns,
FMX.Ani
,FMX.ImgList
,FMX.Platform //:平台服务
,myFuc_UnifiedPlatForm
;
type
TframeCustomDialogsSimple1 = class(TFrame)
LayoutDiologTranslucent: TLayout;
RectDiologTranslucent: TRectangle;
RectDiolog: TRectangle;
RectDiologTitle: TRectangle;
lblDiologTitle: TLabel;
RectDiologToolbar: TRectangle;
GlowEffect1: TGlowEffect;
lblRectDiologContentTips: TLabel;
imgDiologTitle: TImage;
LayoutRectDiologContent: TLayout;
MemoTips: TMemo;
LayoutRectDiologContentTips: TLayout;
imgRectDiologContentTips: TImage;
RectBtnOk: TRectangle;
imgBtnOk: TImage;
lblBtnOk: TLabel;
RectBtnCancel: TRectangle;
imgBtnCancel: TImage;
lblBtnCancel: TLabel;
btnCancel: TRectangle;
btnOk: TRectangle;
RectDiologContentTips: TRectangle;
RectBtnHelpme: TRectangle;
imgBtnHelpme: TImage;
lblBtnHelpme: TLabel;
btnHelpme: TRectangle;
imgShare: TImage;
LayoutShare: TLayout;
RectShare: TRectangle;
RectBtnShareText: TRectangle;
imgBtnShareText: TImage;
lblBtnShareText: TLabel;
BtnShareText: TRectangle;
RectBtnShareTo: TRectangle;
imgBtnShareTo: TImage;
lblBtnShareTo: TLabel;
BtnShareTo: TRectangle;
LayoutShareText: TLayout;
MemoShareText: TMemo;
LayoutShareTextTips: TLayout;
RectShareTextTips: TRectangle;
imgShareTextTips: TImage;
lblShareTextTips: TLabel;
RectShareText: TRectangle;
lblRectShare: TLabel;
RectLayoutShare: TRectangle;
SpBtnShareTo: TSpeedButton;
HorzScrollBox1: THorzScrollBox;
PopupShareWindows: TPopup;
Layout1: TLayout;
Layout2: TLayout;
Layout3: TLayout;
Layout4: TLayout;
Layout101: TLayout;
Layout104: TLayout;
Layout103: TLayout;
Layout102: TLayout;
Layout201: TLayout;
Layout204: TLayout;
Layout203: TLayout;
Layout202: TLayout;
Image101: TImage;
Label101: TLabel;
Image102: TImage;
Label102: TLabel;
btnQQ: TSpeedButton;
btnWechat: TSpeedButton;
ActionListShareWindows: TActionList;
ActPopUpShareWindows: TControlAction;
btnTIM: TSpeedButton;
Image103: TImage;
Label103: TLabel;
procedure btnOkClick(Sender: TObject);
procedure btnCancelClick(Sender: TObject);
procedure btnHelpmeClick(Sender: TObject);
procedure BtnShareTextClick(Sender: TObject);
procedure BtnShareToClick(Sender: TObject);
procedure ActPopUpShareWindowsExecute(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
//供调用者传入的回调参数:
//FTips:string;
frameCustomDialogsSimple1:TframeCustomDialogsSimple1;
FTControl:TControl; //:供调用者传入的截屏控件
FCallmeForm:TForm; //:供调用者传入的调用本frame的窗体
FQQisRunning:Boolean; //:QQ是否手动登录(QQ不像微信,App拉起会被腾讯安全警告，只能由浏览器打开)
FTIMisRunning:Boolean;
end;
type
TAProc<T> = reference to procedure(const Arg :T);
TAFunc<T,TResult> = reference to function(const Arg :T):T;
var FTips:string;//:传出变量
FCurrShareName:string;
///<summary>本单元通用截屏方法-可做入全局库:</summary>
procedure FMakeScreenshot(
ATControl:TControl;AImage:TImage);
//function SetRegStr(const ARootKey,AKeyName,AName,AValue
//,AValueType:string):string;external 'ProDllWin32.dll' name 'SetRegStr';
//:Dll方式需解决回调问题:Dll执行完主程序就自动关闭啦
implementation
{$R *.fmx}
procedure TframeCustomDialogsSimple1.btnCancelClick(Sender: TObject);
var LAProc:TAProc<string>;
LAFunc:TAFunc<string,Boolean>;
begin
{$IFDEF MSWINDOWS}
KillApp('ProAPIRegistryWin32.exe');
{$ENDIF MSWINDOWS}
//MemoRectDiologContent.Lines.Add(' 你点了取消,你要做什么在你的继承代码中写匿名过程TAProc<T>或写匿名函数TAFunc<T>');
FTips:=sLineBreak+'你点了取消:'+sLineBreak
+' 你点了取消,你要做什么在你的继承代码中调用你写好的过程或函数';
//:FTips:回调测试用
self.SendToBack;
self.Visible:=false;
end;
procedure TframeCustomDialogsSimple1.btnOkClick(Sender: TObject);
var LAProc:TAProc<string>;
LAFunc:TAFunc<string,Boolean>;
begin
{$IFDEF MSWINDOWS}
KillApp('ProAPIRegistryWin32.exe');
{$ENDIF MSWINDOWS}
//MemoRectDiologContent.Lines.Add(' 你点了确定,你要做什么在你的继承代码中写匿名过程TAProc<T>或写匿名函数TAFunc<T>');
FTips:=sLineBreak+'你点了确定:'+sLineBreak
+' 你点了确定,你要做什么在你的继承代码中调用你写好的过程或函数';
//:FTips:回调测试用
self.SendToBack;
self.Visible:=false;
end;
procedure TframeCustomDialogsSimple1.btnHelpmeClick(Sender: TObject);
var AAppKeyValue:string;
begin
{$IFDEF MSWINDOWS}
AAppKeyValue:='ProAPIRegistryWin32.exe';
KillApp(AAppKeyValue);
{$ENDIF MSWINDOWS}
FMakeScreenshot(self.FTControl,self.imgShare);//:调截屏方法
FTips:=sLineBreak+'你点了询问:'+sLineBreak
+' 你点了询问,你可以用此接口截屏分享给需要帮助您的人';
//:FTips:回调测试用
LayoutDiologTranslucent.Visible:=true;
RectDiolog.Visible:=false;
LayoutShare.BringToFront;
LayoutShare.Visible:=true;
end;
procedure TframeCustomDialogsSimple1.BtnShareTextClick(Sender: TObject);
begin
LayoutShareText.Visible:=not(LayoutShareText.Visible);
end;
procedure TframeCustomDialogsSimple1.BtnShareToClick(Sender: TObject);
var LClipBoard:IFMXClipboardService; //:剪切板接口 //:FMX.Platform
LTValue:TValue;//:设置剪切板的泛型值 //:System.Rtti
begin
{$IFDEF MSWINDOWS}
PopupShareWindows.Visible:=true;
{$ELSE}
LayoutShareText.Visible:=false;
LayoutShare.SendToBack;
LayoutShare.Visible:=false;
imgShare.Visible:=false;
LayoutDiologTranslucent.Visible:=true;
RectDiolog.Visible:=true;
{$ENDIF}
//:界面显示处理;剪切复制说两句的内容:
if MemoShareText.Lines.Text.Trim<>'' then
if TPlatformServices.Current.SupportsPlatformService(
IFMXClipboardService,IInterface(LClipBoard) ) then
begin
LTValue := TValue.From(MemoShareText.Lines.Text);
LClipBoard.SetClipboard(LTValue);
end;
end;
procedure TframeCustomDialogsSimple1.ActPopUpShareWindowsExecute(
Sender: TObject);
{$IFDEF MSWINDOWS}
var AAppKeyValue:string;
LNativeUInt:NativeUInt;
{$ENDIF MSWINDOWS}
begin
{$IFDEF MSWINDOWS}
//MemoTips.Lines.Add(Sender.ToString);
try
if (Sender as TControlAction).Target.Name='btnQQ' then
begin
try
if FQQisRunning=false then
begin
//MemoTips.Lines.Add('QQ未运行');
AAppKeyValue:='QQ.exe';
try
try
FQQisRunning:=AppRunning(AAppKeyValue);
except
//
end;
finally
if FQQisRunning=false then
begin
ShowAMessage('请先手动登录您的QQ',procedure begin end);
Abort;
end;
end;
end;
finally
if FQQisRunning=True then
begin
//MemoTips.Lines.Add('QQ已运行');
AAppKeyValue:='';
FCurrShareName:='tencent://Message/?Uin=461655651&websiteName=q-zone.qq.com&Menu=yes';
//:测试纸适用Win32://ShellExecute(0, 'open','IExplore.EXE', PWideChar(WideString(FCurrShareName)), nil, SW_SHOWNORMAL);
try
ExeURL(AAppKeyValue,PWideChar(WideString(FCurrShareName)),SW_SHOWNORMAL);
//:QQ是否手动登录(QQ不像微信,
//:App拉起会被腾讯安全警告，只能由浏览器打开)
finally
FCallmeForm.Activate; self.SetFocus;
end;
end;
end;
end;
if (Sender as TControlAction).Target.Name='btnTIM' then
begin
try
if FTIMisRunning=false then
begin
//MemoTips.Lines.Add('TIM未运行');
AAppKeyValue:='TIM.exe';
try
try
FTIMisRunning:=AppRunning(AAppKeyValue);
except
//
end;
finally
if FTIMisRunning=false then
begin
ShowAMessage('请先手动登录您的qq办公版TIM',procedure begin end);
Abort;
end;
end;
end;
finally
if FTIMisRunning=True then
begin
//MemoTips.Lines.Add('TIM已运行');
AAppKeyValue:='';
FCurrShareName:='tencent://Message/?Uin=461655651&websiteName=q-zone.qq.com&Menu=yes';
//:测试纸适用Win32://ShellExecute(0, 'open','IExplore.EXE', PWideChar(WideString(FCurrShareName)), nil, SW_SHOWNORMAL);
try
ExeURL(AAppKeyValue,PWideChar(WideString(FCurrShareName)),SW_SHOWNORMAL);
//:QQ是否手动登录(QQ不像微信,
//:App拉起会被腾讯安全警告，只能由浏览器打开)
finally
FCallmeForm.Activate; self.SetFocus;
end;
end;
end;
end;
if (Sender as TControlAction).Target.Name='btnWechat' then
begin
FCurrShareName:='WeChat';
AAppKeyValue:='ProAPIRegistryWin32.exe';
//:AAppKeyValue:若参数=''则不调用:
LNativeUInt:=ExeApp(AAppKeyValue,FCurrShareName,SW_SHOW);
//LNativeUInt:=ExeApp(AAppKeyValue,'WeChat',SW_SHOW);
//:(SW_HIDE,SW_SHOW,...)
//if LNativeUInt.ToString.Trim<>'' then
//MemoTips.Lines.Add(LNativeUInt.ToString.Trim)
//;
//:LNativeUInt.ToString.Trim<>'':代表调用成功
//ToString:System.SysUtils.TNativeUIntHelper
end;
finally
LayoutShareText.Visible:=false;
LayoutShare.SendToBack;
LayoutShare.Visible:=false;
imgShare.Visible:=false;
LayoutDiologTranslucent.Visible:=true;
RectDiolog.Visible:=true;
end;
PopupShareWindows.Visible:=false;
{$ENDIF MSWINDOWS}
end;
procedure FMakeScreenshot(
ATControl:TControl;AImage:TImage);
//本单元通用截屏方法-可做入全局库:
var LTBitmap:TBitmap;
begin
LTBitmap:=ATControl.MakeScreenshot;
//:FTControl:回调控件截屏
AImage.Bitmap.SetSize(LTBitmap.Size);
AImage.Bitmap.CopyFromBitmap(LTBitmap);
AImage.Visible:=true;
end;
//initialization
//finalization
end.
3.2、访问Win32注册表
unit RegistryWin32;
{Win32 API Interface Unit}
interface
uses
Winapi.Windows,Winapi.ShellAPI,
Winapi.TlHelp32, Winapi.PsAPI,
System.Win.Registry,//:Windows注册表类
System.Classes,
System.SysUtils
,Vcl.Controls,Vcl.Forms
;
///<summary>设置注册表制定位置(ARootKey下AKeyName)键AName值AValue:</summary>
///<param name="ARootKey">=注册表主键</param>
///<param name="ARootKey">=主键下的某个目录键</param>
///<param name="AName">=目录键下的数值名称</param>
///<param name="AValue">=目录键下的数值数据</param>
///<param name="AValueType">=数值数据的类型('整型','字符串型','布尔型','浮点型','日期时间型','日期型','时间型')</param>
procedure SetRegStr(const ARootKey,AKeyName,AName,AValue
,AValueType:string);
///<summary>读取注册表制定位置(ARootKey下AAppNameKey)键值:</summary>
procedure readRegistry(
const ARootKey:NativeUInt;
const AAppNameKey:string;
const AAppKeyName:string;
var AAppKeyValue:String );
///<summary>当前Windows是64位还是32位操作系统:</summary>
///<summary>需要注意是GetNativeSystemInfo 函数从Windows XP 开始才有,</summary>
///<summary>而 IsWow64Process 函数从 Windows XP with SP2以及Windows Server 2003 with SP1开始才有</summary>
///<summary>所以使用该函数的时候最好用GetProcAddress:</summary>
function IsWin64: string;
///<summary>Windows获取操作系统优先级:</summary>
procedure GetPrivilege;
///<summary>Windows提示关机、强制关机、重启:</summary>
procedure RebootSystem(const RebootStyle:string='重启');
//调用ZwShutdownSystem()函数后，会通知硬件驱动保存内核数据，注册表和文件的缓存将会刷新到磁盘上,
//然后将立即重启或关机，未保存的应用程序数据将丢失。
//由于ZwShutdownSystem()通知硬件驱动后是瞬间关机的。为了系统与硬件的安全，
//应使用ExitWindowsEx()进行正常关机。
function RtlAdjustPrivilege(Privilege: ULONG; Enable: BOOLEAN;
CurrentThread: BOOLEAN; Enabled: PBOOLEAN): DWORD; stdcall; external 'ntdll.dll';
function ZwShutdownSystem(arg: DWORD): BOOLEAN; stdcall; external 'ntdll.dll';
///<summary>Win32执行一个外部应用:</summary>
///<param name="AppName">=外部应用全路径名称</param>
///<param name="AppParamStr">=向App传入的参数:ParamStr(0)不能调用(系统默认APP根目录):ParamStr(1)...ParamStr(N),可由分隔符代码调用</param>
///<param name="AShowWindowStyle">=(SW_HIDE,SW_SHOW,...)App显示方式</param>
function ExeApp(var AppName:string;const AppParamStr:string;const AShowWindowStyle:NativeUInt):NativeUInt;
function ExeURL(
var AppName:string;
const AppParamStr:string;
const AShowWindowStyle:NativeUInt):NativeUInt;
///<summary>Win32强行杀死一个外部应用:</summary>
///<param name="AppName">=外部应用全路径名称</param>
procedure KillApp(const AppName:string);
procedure KillProcess(ExeName: string);
function AppRunning(var AppName:string):Boolean;
implementation
procedure SetRegStr(const ARootKey,AKeyName,AName,AValue
,AValueType:string);
var Reg: TRegistry; AOldValue:string;
//比如AName:=EnableLUA
//比如AKeyName:='Software\Microsoft\Windows\CurrentVersion\Policies\System'
//AValueType:=('整型','字符串型','布尔型','浮点型','日期时间型','日期型','时间型')
begin
Reg := TRegistry.Create;
try
if ARootKey='HKEY_LOCAL_MACHINE' then
Reg.RootKey := HKEY_LOCAL_MACHINE;
Reg.OpenKey(AKeyName ,true);
if not Reg.ValueExists(AName) then
begin
if AValueType='整型' then Reg.WriteInteger(AName,StrToInt(AValue));
if AValueType='字符串型' then Reg.WriteString(AName,AValue);
if AValueType='浮点型' then Reg.WriteFloat(AName,StrToFloat(AValue));
if AValueType='日期时间型' then Reg.WriteDateTime(AName,StrToDateTime(AValue));
if AValueType='日期型' then Reg.WriteDate(AName,StrToDate(AValue));
if AValueType='时间型' then Reg.WriteTime(AName,StrToTime(AValue));
end else
begin
if AValueType='整型' then
begin
AOldValue:=IntToStr(Reg.ReadInteger(AName));
Reg.DeleteValue(AOldValue);
Reg.WriteInteger(AName,StrToInt(AValue));
end;
if AValueType='字符串型' then
begin
AOldValue:=(Reg.ReadString(AName));
Reg.DeleteValue(AOldValue);
Reg.WriteString(AName,(AValue));
end;
if AValueType='浮点型' then
begin
AOldValue:=FloatToStr(Reg.ReadFloat(AName));
Reg.DeleteValue(AOldValue);
Reg.WriteFloat(AName,StrToFloat(AValue));
end;
if AValueType='日期时间型' then
begin
AOldValue:=DateTimeToStr(Reg.ReadDateTime(AName));
Reg.DeleteValue(AOldValue);
Reg.WriteDateTime(AName,StrToDateTime(AValue));
end;
if AValueType='时间型' then
begin
AOldValue:=TimeToStr(Reg.ReadTime(AName));
Reg.DeleteValue(AOldValue);
Reg.WriteTime(AName,StrToTime(AValue));
end;
end;
finally
Reg.CloseKey;
Reg.Free;
end;
end;
procedure readRegistry(
const ARootKey:NativeUInt;
const AAppNameKey:string;
const AAppKeyName:string;
var AAppKeyValue:String );
//读取注册表制定位置(ARootKey下AAppNameKey)键值
{$IFDEF MSWINDOWS}
var
ifIsWin64: String;
TheReg: TRegistry;//注意:Win32 API:Windows 64-位下编译不生效的
KeyName: String;
ValueStr: String;
{$ENDIF MSWINDOWS}
begin
{$IFDEF MSWINDOWS}
if AAppNameKey.Trim='' then exit;
try
TheReg:=TRegistry.Create;
TheReg.RootKey:=ARootKey;
//:HKEY_LOCAL_MACHINE;//Winapi.Windows
//:等价于:NativeUInt($80000002) //System
//:HKEY_CURRENT_USER = HKEY(NativeUInt($80000001));
try
ifIsWin64:=IsWin64;
finally
if AAppNameKey.Trim='QQ2009' then
begin
KeyName := 'Software\Tencent\'
+AAppNameKey;
end else
if AAppNameKey.Trim='TIM' then
begin
KeyName := 'Software\Tencent\'
+AAppNameKey;
end else
begin
if pos('64-bit',ifIsWin64.trim)>=0 then //='64位操作系统'
KeyName := 'Software\Wow6432Node\Microsoft\Windows\CurrentVersion\Uninstall\'
+AAppNameKey; //+'WeChat';
if pos('32-bit',ifIsWin64.trim)>=0 then//='32位操作系统'
KeyName := 'Software\Microsoft\Windows\CurrentVersion\Uninstall\'
+AAppNameKey; //+'WeChat';
end;
end;
//:Windows任意安装和卸载的位置
//:如需知道某App的具体安装和卸载程序全路径,
//:就需要知道其下级的注册表节点名称,如+'WeChat'
if TheReg.OpenKey(KeyName,true) then
begin //回调安装全路径执行文件名AAppKeyValue:
AAppKeyValue:=(TheReg.ReadString(AAppKeyName));
//AAppKeyValue:=(TheReg.ReadString('DisplayIcon'));
//:DisplayIcon一般软件开发会设置其键值为安装全路径执行文件名,
//:但也不完全:取决于开发商
end;
finally
TheReg.CloseKey;
TheReg.Free;
end;
{$ENDIF MSWINDOWS}
end;
//需要注意是GetNativeSystemInfo 函数从Windows XP 开始才有，
//而 IsWow64Process 函数从 Windows XP with SP2 以及 Windows Server 2003 with SP1 开始才有。
//所以使用该函数的时候最好用GetProcAddress
function IsWin64: string;
var LOSVer:System.SysUtils.TOSVersion;
{$IFDEF MSWINDOWS}
{
var
Kernel32Handle: THandle;
IsWow64Process: function(Handle: THandle; var Res: BOOL): BOOL; stdcall;
GetNativeSystemInfo: procedure(var lpSystemInfo: TSystemInfo); stdcall;
isWoW64: Bool;
SystemInfo: TSystemInfo;
const
PROCESSOR_ARCHITECTURE_AMD64 = 9;
PROCESSOR_ARCHITECTURE_IA64 = 6;
}
{$ENDIF MSWINDOWS}
begin
Result :=LOSVer.ToString;
{
Result :=
'Name:'+LOSVer.Name
+',ToString:'+LOSVer.ToString
+',Build:'+IntToStr(LOSVer.Build)
+',Major:'+IntToStr(LOSVer.Major)
+',Minor:'+IntToStr(LOSVer.Minor)
+',ServicePackMajor:'+IntToStr(LOSVer.ServicePackMajor)
+',ServicePackMinor:'+IntToStr(LOSVer.ServicePackMinor)
; }
(*
//{$IFDEF MSWINDOWS}
{
Kernel32Handle := GetModuleHandle('KERNEL32.DLL');
if Kernel32Handle = 0 then Kernel32Handle := LoadLibrary('KERNEL32.DLL');
if Kernel32Handle <> 0 then
}
if LOSVer.Platform in [pfWindows,pfWinRT] then
begin
if LOSVer.Architecture in [arIntelX64,arARM64] //(LOSVer.Architecture=TOSVersion.TArchitecture.arIntelX64)
//or (LOSVer.Architecture=TOSVersion.TArchitecture.arARM64)
then
begin
{
IsWOW64Process := GetProcAddress(Kernel32Handle,'IsWow64Process');
GetNativeSystemInfo := GetProcAddress(Kernel32Handle,'GetNativeSystemInfo');
if Assigned(IsWow64Process) then
begin
IsWow64Process(GetCurrentProcess,isWoW64);
if (isWoW64 and Assigned(GetNativeSystemInfo)
)=true then
begin
GetNativeSystemInfo(SystemInfo);
if ( (SystemInfo.wProcessorArchitecture = PROCESSOR_ARCHITECTURE_AMD64)
or (SystemInfo.wProcessorArchitecture = PROCESSOR_ARCHITECTURE_IA64)
)
then
Result := '64位操作系统64位处理器' else Result := '64位操作系统32位处理器';
end;
end; }
Result := '64位操作系统'+LOSVer.ToString;
end else Result := '32位操作系统'+LOSVer.ToString;
end;
*)
//{$ENDIF MSWINDOWS}
end;
procedure RebootSystem(const RebootStyle:string='重启');
//:RebootStyle:Windows提示关机、强制关机、重启:
begin
{$IFDEF MSWINDOWS}
GetPrivilege;
if RebootStyle='提示关机' then
initiateSystemShutDown(nil,nil,0,true,false);
if RebootStyle='强制关机' then
ExitWindowsEx(EWX_SHUTDOWN+EWX_FORCE+EWX_POWEROFF+EWX_FORCEIFHUNG, 0);
if RebootStyle='重启' then
ExitWindowsEx(EWX_REBOOT OR EWX_FORCE or EWX_POWEROFF or EWX_FORCEIFHUNG, 0);
{$ENDIF MSWINDOWS}
end;
procedure GetPrivilege;
{$IFDEF MSWINDOWS}
var
NewState: TTokenPrivileges;
lpLuid: Int64;
ReturnLength: DWord;
ToKenHandle: THandle;
{$ENDIF MSWINDOWS}
begin
{$IFDEF MSWINDOWS}
OpenProcessToken(GetCurrentProcess,
TOKEN_ADJUST_PRIVILEGES
OR TOKEN_ALL_ACCESS
OR STANDARD_RIGHTS_REQUIRED
OR TOKEN_QUERY,ToKenHandle);
LookupPrivilegeValue(nil,'SeShutdownPrivilege',lpLuid);
NewState.PrivilegeCount:=1;
NewState.Privileges[0].Luid:=lpLuid;
NewState.Privileges[0].Attributes:=SE_PRIVILEGE_ENABLED;
ReturnLength:=0;
AdjustTokenPrivileges(ToKenHandle,False,NewState,0,nil,ReturnLength);
{$ENDIF MSWINDOWS}
end;
function ExeApp(var AppName:string;
const AppParamStr:string;
const AShowWindowStyle:NativeUInt):NativeUInt;
var LHandle:HWND;
StartInfo:STARTUPINFO;
begin
//AShowWindowStyle:=(SW_HIDE,SW_SHOW,...)
//AppParamStr:向App传入的参数:ParamStr(0)不能调用,系统默认APP根目录
//:ParamStr(1)...ParamStr(N),可由分隔符代码调用
{$IFDEF MSWINDOWS}
if AppName.Trim='' then exit;
LHandle:=0;
Result:=
ShellExecute(LHandle,'open'
,PWideChar(WideString(AppName))
,PWideChar(WideString(AppParamStr))//:向App传入的参数
,nil //:App默认目录
,AShowWindowStyle //:App显示方式
);
{$ENDIF MSWINDOWS}
end;
function ExeURL(
var AppName:string;
const AppParamStr:string;
const AShowWindowStyle:NativeUInt):NativeUInt;
var LHandle:HWND;
LNativeUInt:NativeUInt;
//StartInfo:STARTUPINFO;
begin
//AShowWindowStyle:=(SW_HIDE,SW_SHOW,...)
//AppParamStr:向App传入的参数:ParamStr(0)不能调用,系统默认APP根目录
//:ParamStr(1)...ParamStr(N),可由分隔符代码调用
{$IFDEF MSWINDOWS}
if AppParamStr.Trim='' then exit;
try
LHandle:=0;
LNativeUInt:=
ShellExecute(
0
,'open' //:nil:不能否则虽不影响执行但会报错
,'IExplore.EXE'
,PWideChar(WideString(AppParamStr))//:URL指令参数
,nil //:App默认目录
,SW_SHOW //:App显示方式
);
except
//
end;
Result:=LNativeUInt;
{$ENDIF MSWINDOWS}
end;
procedure KillApp(const AppName:string);
//Win32强行杀死一个外部应用:
begin
if AppName.Trim='' then exit;
WinExec( PAnsiChar(AnsiString('cmd.exe /c taskkill /f /t /im '+AppName))
,sw_hide); //AppName:比如:ProAPIRegistryWin32.exe
end;
procedure KillProcess(ExeName: string);
const
PROCESS_TERMINATE = $0001; //进程的PROCESS_TERMINATE访问权限
var
ContinueLoop: Boolean;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
begin
//获取系统所有进程快照
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
//调用Process32First前用Sizeof(FProcessEntry32)填充FProcessEntry32.dwSize
FProcessEntry32.dwSize := Sizeof(FProcessEntry32);
//获取快照中第一个进程信息并保存到FProcessEntry32结构体中
ContinueLoop := Process32First(FSnapshotHandle,FProcessEntry32);
while integer(ContinueLoop) <> 0 do //循环枚举快照中所有进程信息
begin
//找到要中止的进程名
if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) = UpperCase(ExeName))
or (UpperCase(FProcessEntry32.szExeFile) = UpperCase(ExeName))) then
TerminateProcess(OpenProcess(PROCESS_TERMINATE, BOOL(0),FProcessEntry32.th32ProcessID), 0); //中止进程
ContinueLoop := Process32Next(FSnapshotHandle,FProcessEntry32); //查找下一个符合条件进程
end;
end;
function AppRunning(var AppName:string):Boolean;
var
ContinueLoop: Boolean;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
LFindmeCount:Integer;
begin
LFindmeCount:=0;
//获取系统所有进程快照
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
//调用Process32First前用Sizeof(FProcessEntry32)填充FProcessEntry32.dwSize
FProcessEntry32.dwSize := Sizeof(FProcessEntry32);
//获取快照中第一个进程信息并保存到FProcessEntry32结构体中
ContinueLoop := Process32First(FSnapshotHandle,FProcessEntry32);
while integer(ContinueLoop) <> 0 do //循环枚举快照中所有进程信息
begin
//找到要中止的进程名
if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) = UpperCase(AppName))
or (UpperCase(FProcessEntry32.szExeFile) = UpperCase(AppName))) then
LFindmeCount:=LFindmeCount+1;
ContinueLoop := Process32Next(FSnapshotHandle,FProcessEntry32); //查找下一个符合条件进程
end;
if LFindmeCount=0 then
begin
Result:=False;
end else
begin //App已在运行:
Result:=true;
end;
end;
end.
3.3、Windows 64-bit、Windows 32-bit编译平台兼容调用第三方App
{Windows 64-bit、Windows 32-bit编译平台兼容调用第三方App:}
{:让操作系统:更改UAC用户账户控制设置}
unit APIRegistryWin32;
interface
uses
Winapi.Windows,
Winapi.ShellAPI, Winapi.Messages,
System.SysUtils, System.Variants,
System.Classes, System.IOUtils,
Vcl.Graphics,Vcl.Controls,
Vcl.Forms, Vcl.Dialogs
,RegistryWin32, Vcl.StdCtrls
,myFuc_UnifiedPlatForm // :我的通用库
;
type
TfrmRegistryWin32 = class(TForm)
edtParamStr: TEdit;
edtResultStr: TEdit;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
frmRegistryWin32: TfrmRegistryWin32;
implementation
{$R *.dfm}
procedure TfrmRegistryWin32.FormCreate(Sender: TObject);
var LAppKeyValue:string;
LStrList:TStringList;
LNativeUInt:NativeUInt;
begin
edtParamStr.Text:=System.ParamStr(1);
//:本工程被调用程序传入的参数
LStrList:=TStringList.Create;
try
try
SetRegStr('HKEY_LOCAL_MACHINE','Software\Microsoft\Windows\CurrentVersion\Policies\System'
,'EnableLUA','0','整型'); //\Wow6432Node
//:让操作系统:更改UAC用户账户控制设置
if trim(edtParamStr.Text)='WeChat' then
readRegistry( HKEY_LOCAL_MACHINE
,trim(edtParamStr.Text),'DisplayIcon',LAppKeyValue);
if trim(edtParamStr.Text)='QQ2009' then
begin //:未用:QQ用浏览器打开的方式:
try
readRegistry( HKEY_LOCAL_MACHINE
,trim(edtParamStr.Text),'Install',LAppKeyValue);
finally
LAppKeyValue:=LAppKeyValue +'\bin\QQ.exe';
end;
end;
if trim(edtParamStr.Text)='TIM' then
begin //:未用:TIM用浏览器打开的方式:
try
readRegistry( HKEY_LOCAL_MACHINE
,trim(edtParamStr.Text),'Install',LAppKeyValue);
finally
LAppKeyValue:=LAppKeyValue +'\bin\TIM.exe';
end;
end;
//:edtParamStr.Text根据传入参数读取注册表,打开第3方应用
//edtParamStr.Text:'WeChat'
//:HKEY_LOCAL_MACHINE;//Winapi.Windows
//:等价于:NativeUInt($80000002) //System
//:HKEY_CURRENT_USER = HKEY(NativeUInt($80000001));
finally
try
LNativeUInt:=ExeApp(LAppKeyValue,'',SW_HIDE);
finally
if LNativeUInt.ToString.Trim<>'' then //:调用完毕
begin
edtResultStr.Text:=LAppKeyValue+'调用完毕'+ LNativeUInt.ToString;
LAppKeyValue:=trim(edtResultStr.Text);
end;
end;
//WinExec(PAnsiChar(AnsiString(LAppKeyValue)), SW_SHOW);
// ShellExecute(1,'open',PWideChar(WideString(LAppKeyValue)),nil,nil,SW_SHOW);
//WinExec(PAnsiChar(AnsiString(LAppKeyValue)), SW_SHOW);
//:所有的原生字符串类型String转PAnsiChar都需要经过AnsiString过渡
end;
finally
FreeAndNil(LStrList);
end;
end;
end.
