1 unit Unit1;  2   3 interface  4   5 uses  6   Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,  7   Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.Buttons,System.Win.ComObj;  8   9 type 10   TForm1 = class(TForm) 11     BitBtn1: TBitBtn; 12     BitBtn2: TBitBtn; 13     Edit1: TEdit; 14     Label1: TLabel; 15     procedure BitBtn2Click(Sender: TObject); 16     procedure BitBtn1Click(Sender: TObject); 17     procedure FormDestroy(Sender: TObject); 18     procedure FormCreate(Sender: TObject); 19   private 20     FCSApp,FBarApp:Variant; 21     const 22       VARID=‘RID‘; 23     { Private declarations } 24     procedure PrintCS(ACopys:Integer=1); 25     procedure PrintBar(ACopys:Integer=1); 26     function VarIsExists(const Vars:Variant;AVarName : string):Boolean; 27     function GetBarObj:Variant; 28     function GetCSObj:variant; 29   public 30     { Public declarations } 31   end; 32  33 var 34   Form1: TForm1; 35  36 implementation 37  38 {$R *.dfm} 39  40 procedure TForm1.BitBtn1Click(Sender: TObject); 41 begin 42   PrintCS(StrToIntDef(Edit1.Text,1)); 43 end; 44  45 procedure TForm1.BitBtn2Click(Sender: TObject); 46 begin 47   PrintBar(StrToIntDef(Edit1.Text,1)); 48 end; 49  50 procedure TForm1.FormCreate(Sender: TObject); 51 begin 52  GetBarObj; 53  GetCSObj; 54 end; 55  56 procedure TForm1.FormDestroy(Sender: TObject); 57 begin 58   if not VarIsEmpty(FBarApp) then 59   try 60     FBarApp.quit(1); 61   except 62     FBarApp := Unassigned; 63   end; 64   if not VarIsEmpty(FCSApp) then 65   try 66     FCSApp.quit; 67   except on E: Exception do 68     FCSApp := Unassigned; 69   end; 70 end; 71  72 function TForm1.GetBarObj: Variant; 73 begin 74   try 75     result := GetActiveOleObject(‘BarTender.Application‘); 76   except on E: Exception do 77     try 78       result := CreateOleObject(‘BarTender.Application‘); 79     except on E: Exception do 80       result := varEmpty; 81     end; 82   end; 83 end; 84  85 function TForm1.GetCSObj: variant; 86 begin 87   try 88     result := GetActiveOleObject(‘Lppx.Application‘); 89   except on E: Exception do 90     try 91       result := CreateOleObject(‘Lppx.Application‘); 92     except on E: Exception do 93       result := varEmpty; 94     end; 95   end; 96 end; 97  98 procedure TForm1.PrintBar(ACopys: Integer); 99 var100   btFormat,Vars:Variant;101   i:integer;102   sFile:string;103 begin104 //  try105 //    FBarApp := CreateOleObject(‘BarTender.Application‘);106 //  except107 //    raise Exception.Create(‘BarTender not installed?‘);108 //  end;109   sFile := ExtractFilePath(Application.ExeName)+‘RID.btw‘;110   if not FileExists(sFile) then111   begin112     ShowMessage(‘模板文件(RID.btw)在当前目录下不存在!‘);113     Exit;114   end;115   FBarApp := GetBarObj;116   if VarIsEmpty(FBarApp) then Exit;117 118   FBarApp.Visible := False;119   try120     btFormat := FBarApp.formats.Open(sFile,true,‘‘);121     Vars := btFormat.NamedSubStrings;122     for i := 1 to ACopys do123     begin124       if VarIsExists(Vars,VARID) then125       begin126         btFormat.SetNamedSubStringValue(VARID,Concat(VARID,i.ToString));127         btFormat.PrintOut(False,False);128       end;129     end;130   finally131     btFormat.Close(1);132   //  FBarApp.Quit(1);133   end;134 end;135 136 procedure TForm1.PrintCS(ACopys: Integer);137 var138   Docs,Vars:Variant;139   i:integer;140   sFile:string;141 begin142 //  try143 //    FCsApp := CreateOleObject(‘lppx.Application‘);144 //  except145 //    raise Exception.Create(‘Codesoft not installed?‘);146 //  end;147   sFile := ExtractFilePath(Application.ExeName)+‘RID.lab‘;148   if not FileExists(sFile) then149   begin150     ShowMessage(‘模板文件(RID.lab)在当前目录下不存在!‘);151     Exit;152   end;153 154   FCSApp := GetCSObj;155   if VarIsEmpty(FCSApp) then Exit;156   FCsApp.Visible := False;157   try158     Docs := FCSApp.ActiveDocument;159     Docs.Open(sFile,false);160     Vars := Docs.Variables;161     for i := 1 to ACopys do162     begin163       if VarIsExists(Vars,VARID) then164       begin165         Vars.Item[VARID].value := Concat(VARID,i.ToString);166 167       end;168       Docs.PrintLabel(1);169     end;170     Docs.FormFeed;171   finally172     Docs.Close;173   //  Docs:=Unassigned;174 //    FCsApp.Quit;175 //    FCSApp := Unassigned;176   end;177 end;178 179 function TForm1.VarIsExists(const Vars: Variant; AVarName: string): Boolean;180 var181  i:integer;182 begin183   Result := False;184   if VarIsNull(Vars) or VarIsEmpty(Vars) then exit;185   for i := 1 to Vars.Count do186   begin187     Result := SameText(Vars.Item[i].Name,AVarName);188     if Result then Break;189   end;190 end;191 192 end.