关键字:delphi Marco clean

最近一个朋友的客户老是发一些报价文件会提示marco1提示的文件,再发过去,对方又不敢看,怕有毒.

经查,其实这种文件是曾经中过毒,杀毒后,有部分没有清理干净的原因,比较有空,所以帮他编了一个软件.

一.构思

功能一.拖放清除,二系统右键清除.

二.功能细节分解:

拖放功能,可以百度delphi 文件拖放.

右键可以用相关注册表操作,具体可以下载一个右键管理软件来看要对注册表作什么具体工作.

三.实现具体情况:

1.拖放功能.

TFORM1中增加声明.

Procedure FileIsDropped(Var Msg: TMessage); message WM_DropFiles;

后面增加定义:

Procedure TForm1.FileIsDropped(Var Msg: TMessage);
Var
    hDrop: THandle;
    fName: Array[0..254] Of CHAR;
    NumberOfFiles: integer;
    fCounter: integer;
    Names: String;
Begin
    hDrop := Msg.WParam;
    NumberOfFiles := DragQueryFile(hDrop, $FFFFFFFF, Nil, 254);
    Names := '';
    For fCounter := 0 To NumberOfFiles - 1 Do
    Begin
        DragQueryFile(hDrop, fCounter, fName, 254);
    // Here you have your file name 1 by 1
      //  Names := Names + #13#10 + fName;//调试用信息
        //showmessage(ExtractFileExt(fname));
        If ExtractFileExt(fName) = '.xls' Then
        Begin
            CM(fName);//清除尾巴
        End;
    End;
    //ShowMessage('Droped ' + inttostr(NumberOfFiles) + ' Files : ' + Names);//调试用信息

DragFinish(hDrop);
End;
难度不大

2.右键功能才是比较难的,主要一如何操作注册表,二该写什么数据进注册表,如何传文件名给程序,都一度难倒了我.

一样一样的说:

注册表操作部分:

Procedure RegServer();//注册函数
Var
    AR: TRegistry;
Begin
    AR := TRegistry.Create();
    AR.RootKey := HKEY_CLASSES_ROOT;
    If AR.OpenKey('Excel.Sheet.8\shell\', True) Then
    Begin
        AR.CreateKey('CleanMarco');
        AR.OpenKey('CleanMarco', True);
        AR.WriteString('', 'CleanMarco');
        AR.WriteBool('AutoClose', True);
        AR.WriteBool('AllDir', false);
        AR.CreateKey('Command');
        AR.OpenKey('Command', True);//在当前注册表目录打开下一层目录,可以理解为DOS下的CD.
        //ar.WriteString( 'CleanMarco', application.ExeName );
        // ar.WriteString( '', application.ExeName );
        AR.WriteExpandString('', Application.ExeName + ' /C %1');//传参数进程序.用string不行,无法运行,必须用expandstring
        //ar.WriteString( 'Command', application.ExeName );
    End;
    ShowMessage('注册右键成功，迎使用！');
            //善后处理
    AR.CloseKey;
    AR.Free;

//ar.Destroy ;
End;

Procedure UnRegServer();
Var
    AR: TRegistry;
    SL: TStringList;
Begin
    AR := TRegistry.Create();
    AR.RootKey := HKEY_CLASSES_ROOT;
    SL := TStringList.Create;
    If AR.OpenKey('Excel.Sheet.8\shell\', True) Then
    Begin
        AR.OpenKey('CleanMarco', True);//没有使用递归,步骤很烦.
        AR.GetKeyNames(SL);
        ShowMessage(SL.Text);
        AR.DeleteValue('AutoClose');
        AR.DeleteValue('AllDir');
        AR.OpenKey('Command', false);
        AR.DeleteValue('');
        AR.CloseKey;
        AR.RootKey := HKEY_CLASSES_ROOT;

AR.OpenKey('Excel.Sheet.8\shell\', True);
        AR.OpenKey('CleanMarco', True);
        AR.DeleteKey('Command');
        AR.DeleteValue('');
        AR.CloseKey;
        AR.RootKey := HKEY_CLASSES_ROOT;
        AR.OpenKey('Excel.Sheet.8\shell\', True);
        AR.DeleteKey('CleanMarco');
    //ShowMessage(inttostr(SL.Count));

AR.DeleteKey('CleanMarco');

End;
    ShowMessage('右键功能卸载成功，谢谢使用！');
            //善后处理
    AR.CloseKey;
    AR.Free;

//ar.Destroy ;
End;

参数传送部分:

Procedure TForm1.FormCreate(Sender: TObject);
Var
    S, CmdStr, ArgStr, TaskStr, TargeFileName: String;
    J, L, L1: integer;
    AR: TRegistry;
Begin
    DragAcceptFiles(Handle, True);
//Showmessage(ParamStr(0));
    AR := TRegistry.Create();
    AR.RootKey := HKEY_CLASSES_ROOT;
    If AR.OpenKey('Excel.Sheet.8\shell\', True) Then  //这样子.只能支持excel2003

Begin
        AR.OpenKey('CleanMarco', True);
        bAutoClose := AR.ReadBool('AutoClose');
        bAllDir := AR.ReadBool('AllDir');
        chkB1.Checked := bAllDir;
        ChkB2.Checked := bAutoClose;
    End;
    AR.Destroy;
    L1 := length(paramstr(1));
    //Label1.Caption := inttostr(L1);
    S := rightstr(paramstr(1), 1);
    If (S = 'i') Or (S = 'I') Then
    Begin
//直接安装
   // showmessage('AutoInstall!');
        Button1Click(Sender);
    End;
    If (S = 'C') Or (S = 'c') Then
    Begin
//清除MArco1尾巴
        CmdStr := GetCommandLine;//为防目录中有空格必须用这个取得完整命令行再处理...这个用了一天的时间都没有解决的问题

//后来想到用OD时经常看到的命令,就上这个了,这是一个winAPI,引用windows即可用.
    //Label3.Caption := application.ExeName;
        L := length(Application.ExeName);
        If leftstr(CmdStr, 1) = '"' Then L := L + 3;
        ArgStr := trim(rightstr(CmdStr, length(CmdStr) - L - L1)); //获取参数命令。
   // Label1.Caption := ArgStr;
        J := posex(' ', ArgStr, 2);

TaskStr := trim(leftstr(ArgStr, J)); //执行任务的命令这里不用。
        TargeFileName := trim(rightstr(ArgStr, length(ArgStr) - J - L1)); //目标文件或目录。
        If bAllDir Then
        Begin
            CleanMarco(ExtractFilePath(TargeFileName)); //清除整个目录
        End
        Else
        Begin
            CleanMarco(TargeFileName); //单个文件清除。

End;

If bAutoClose Then Application.Terminate;
    End;

//showmessage(inttostr(length(s) );
End;

最后功能实现

Procedure CM(FileName: String);//具体处理函数
Var
    ExcelApp, sht: Variant;
   // FileName: String;
    i, sC: integer;
Begin
   //FileName := 'F:\myFiles\delphi\CleanMacro\bak\测试\2222.xls';
    If FileExists(FileName) Then
    Begin
        Try
            ExcelApp := CreateOleObject('Excel.Application');
        Except
            ShowMessage('Excel 没有安装，请先安装！');
            exit;
        End;
        ExcelApp.Visible := True;
        ExcelApp.workbooks.open(FileName);
        ExcelApp.ScreenUpdating := false; //禁用刷新
        ExcelApp.AskToUpdateLinks := false; //不更新链接
        ExcelApp.DisplayAlerts := false; //不提示窗口
        ExcelApp.EnableEvents := false;
        ExcelApp.Calculation := xlCalculationManual;//对于有很多公式的文件这个很重要,不然,改一下,卡你半天.....这是我从VBA得到的经验....
        //ListBox1.Clear;
        sC := ExcelApp.activeworkbook.sheets.count;
        //ListBox1.Items.Add('表格数：' + inttostr(sC));
        For i := sC Downto 1 Do
        Begin
            sht := ExcelApp.activeworkbook.sheets[i];
            //ListBox1.Items.Add(sht.Name + inttostr(sht.type));
            If (lowercase(leftstr(sht.Name, 5)) = 'macro') Or (sht.type = xlExcel4IntlMacroSheet) Or (sht.type = xlExcel4MacroSheet) Then
            Begin
                sht.Visible := True;
                sht.delete;
            End;
        End;
        sC := ExcelApp.activeworkbook.Names.count;

For i := sC Downto 1 Do
        Begin
            If (ExcelApp.activeworkbook.Names.item(i, EmptyParam, EmptyParam).Visible = false) Then
                ExcelApp.activeworkbook.Names.item(i, EmptyParam, EmptyParam).delete;//excel名称的访问,试了很多次,后来这样过掉了,

//网上很少有这个信息,自己看函数接口文件,处理的.
        End;

ExcelApp.Calculation := xlCalculationAutomatic;
       // ExcelApp.activeworkbook.activesheet.cells(1, 1) := '`Ymf';//测试工作,正式版要注释掉.
        ExcelApp.activeworkbook.save;
        ExcelApp.activeworkbook.close;

ExcelApp.DisplayAlerts := True; //'恢复提示窗口
        ExcelApp.AskToUpdateLinks := True; //'恢复更新链接
        ExcelApp.ScreenUpdating := True; //'恢复屏幕刷新
        // excelapp.close;
        ExcelApp.quit;
        sht := unassigned;
        ExcelApp := unassigned;

End;
End;

Procedure CleanMarco(iFileName: String);
Var
    S, Ss: String;
    FileList: Tstrings;
    sr: TSearchRec;

Begin
    S := ExtractFileExt(iFileName);
    Ss := rightstr(iFileName, 1);
    If (Ss = '\') Or (Ss = '/') Then
    Begin
         //整目录清除。
        FileList := TStringList.Create;
        FileList.Clear;
        If DirectoryExists(iFileName) Then
        Begin
            S := iFileName + '*.xls';
            If FindFirst(S, faAnyFile, sr) = 0 Then
            Begin
                Repeat
                    If pos('.xls', lowercase(sr.Name)) > 0 Then
                        FileList.Add(sr.Name);
                    CM(iFileName + sr.Name);
                Until FindNext(sr) <> 0;
                FindClose(sr);
            End;
        End;
    End
    Else
    Begin
        If S = '.xls' Then
        Begin
 //单文件清除
            CM(iFileName);
        End;
    End;

End;