main.pas

使用Net Send群发消息的程序

unit Main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons, IniFiles;

type
  TFrmMain = class(TForm)
    Memo1: TMemo;
    BtnSend: TButton;
    CbxMach: TComboBox;
    ChkBoxAll: TCheckBox;
    GroupBox1: TGroupBox;
    LBGrp: TListBox;
    LBMmb: TListBox;
    BtnAdd: TButton;
    BtnDel: TButton;
    SBtnMin: TBitBtn;
    GroupBox2: TGroupBox;
    Label1: TLabel;
    Label2: TLabel;
    MemHead: TMemo;
    MemEnd: TMemo;
    Label3: TLabel;
    procedure BtnSendClick(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure CbxMachDblClick(Sender: TObject);
    procedure CbxMachKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormShow(Sender: TObject);
    procedure SBtnMinClick(Sender: TObject);
    procedure BtnAddClick(Sender: TObject);
    procedure BtnDelClick(Sender: TObject);
    procedure LBGrpEnter(Sender: TObject);
    procedure LBMmbEnter(Sender: TObject);
    procedure LBGrpClick(Sender: TObject);
    procedure LBMmbClick(Sender: TObject);
    procedure MemHeadExit(Sender: TObject);
    procedure MemEndExit(Sender: TObject);
    procedure Label3DblClick(Sender: TObject);
  private
    { Private declarations }
    Procedure CreateIni ;
    Procedure GetGroup ;
    Procedure GetMember(sGrpName :String) ;
    Procedure AddGroup(sGrpName :String ) ;
    Procedure AddMember(sGrpName ,sMebName :String ) ;
    Procedure DelGroup(sGrpName :String ) ;
    Procedure DelMember(sGrpName ,sMebName :String ) ;
    Procedure GetLabel(bIsHead :Boolean) ;
    Procedure WriteLabel(sLabel :String ;bIsHead :Boolean) ;
  public
    { Public declarations }
  end;

var
  FrmMain: TFrmMain;
  bIsMin :Boolean ;
  sAppDir :String ;
  sIniFile :String ;
  sIniFileQM :String ;

implementation

{$R *.DFM}
Procedure TFrmMain.GetLabel(bIsHead :Boolean) ;
Var
  MsgIni :TIniFile ;
Begin
  MsgIni := TIniFile.Create(sIniFileQM) ;
  IF bIsHead Then
    MemHead.Lines.Add(MsgIni.ReadString('BEGIN','签名头' ,'============================'))
  Else
    MemEnd.Lines.Add(MsgIni.ReadString('END' ,'签名尾','============================')) ;
  MsgIni.Free ;
End ;

Procedure TFrmMain.WriteLabel(sLabel :String ;bIsHead :Boolean) ;
Var
  MsgIni :TIniFile ;
Begin
  MsgIni := TIniFile.Create(sIniFileQM) ;
  IF bIsHead Then
    MsgIni.WriteString('BEGIN','签名头' ,sLabel)
  Else
    MsgIni.WriteString('END' ,'签名尾',sLabel) ;
  MsgIni.Free ;
End ;

Procedure TFrmMain.CreateIni ;
Begin
  IF Not FileExists(sIniFile) Then Begin
    FileCreate(sIniFile) ;
  End ;
  IF Not FileExists(sIniFileQM) Then Begin
    FileCreate(sIniFileQM) ;
  End ;
End ;

Procedure TFrmMain.GetGroup ;
Var
  MsgIni :TIniFile ;
Begin
  MsgIni := TIniFile.Create(sIniFile) ;
  MsgIni.ReadSections(LBGrp.Items) ;
  MsgIni.Free ;
End ;

Procedure TFrmMain.GetMember(sGrpName :String) ;
Var
  MsgIni :TIniFile ;
Begin
  MsgIni := TIniFile.Create(sIniFile) ;
  MsgIni.ReadSection(sGrpName ,LbMmb.Items) ;
  MsgIni.Free ;
End ;

Procedure TFrmMain.AddGroup(sGrpName :String ) ;
Begin
  WritePrivateProfileString(pchar(sgrpname) ,'yang', '',pChar(sIniFile)) ;
End ;

Procedure TFrmMain.AddMember(sGrpName ,sMebName :String ) ;
Begin
  WritePrivateProfileString(pchar(sgrpname) ,pChar(sMebName), '',pChar(sIniFile)) ;
End ;

Procedure TFrmMain.DelGroup(sGrpName :String ) ;
Var
  MsgIni :TIniFile ;
Begin
  MsgIni := TIniFile.Create(sIniFile) ;
  MsgIni.EraseSection(sGrpName ) ;
  MsgIni.Free ;
End ;

Procedure TFrmMain.DelMember(sGrpName ,sMebName :String ) ;
Var
  MsgIni :TIniFile ;
Begin
  MsgIni := TIniFile.Create(sIniFile) ;
  MsgIni.DeleteKey(sGrpName ,sMebName) ;
  MsgIni.Free ;
End ;

procedure TFrmMain.BtnSendClick(Sender: TObject);
Var
  sText ,sMach :String ;
  i ,j :integer ;
Begin
  IF Not ChkBoxAll.Checked Then Begin
      sMach := CbxMach.Text ;
      sText := 'Net Send ' + sMach + ' ' + MemHead.Text + #13 + String(Memo1.Text)
               + #13 + MemEnd.Text ;
      WinExec(pChar(sText) , SW_HIDE) ;
      Caption := Caption + '  发送成功 ......' ;
      Sleep(600) ;
      Caption := '送短消息' ;

      i := CbxMach.Items.IndexOf(sMach) ;
      IF i = -1 Then CbxMach.Items.Add(sMach) ;
  End
  Else Begin
    i := LbMmb.Items.Count ;
    For j := 0 To i - 1 Do Begin
//      sMach := CbxMach.Items.Strings[j] ;
      sMach := LbMmb.Items.Strings[j] ;
      sText := 'Net Send ' + sMach + ' ' + MemHead.Text + #13 + String(Memo1.Text)
               + #13 + MemEnd.Text  ;
      WinExec(pChar(sText) , SW_HIDE) ;
    End ;
    Caption := Caption + '  发送成功 ......' ;
    Sleep(600) ;
    Caption := '送短消息' ;
  End ;
End ;

procedure TFrmMain.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  IF Key = VK_ESCAPE Then Close ;
end;

procedure TFrmMain.CbxMachDblClick(Sender: TObject);
begin
  Memo1.Clear ;
end;

procedure TFrmMain.CbxMachKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  IF Key = VK_RETURN Then Begin
    Memo1.Clear ;
  End ;
end;

procedure TFrmMain.FormShow(Sender: TObject);
   function ExtractFileDir(const FileName: string): string;
   var
     I: Integer;
   begin
    I := LastDelimiter('\:',Filename);
    if (I > 1) and (FileName[I] = '\') and
      (not (FileName[I - 1] in ['\', ':']) or
      (ByteType(FileName, I-1) = mbTrailByte)) then Dec(I);
    Result := Copy(FileName, 1, I);
  end;
begin
  bIsMin := True ;
  FrmMain.Height := 190 ;
  Try
    sAppDir := ExtractFileDir(Application.Exename) ;
    sIniFile := sAppDir + '\Msg.ini' ;
    sIniFileQM := sAppDir + '\QM.ini' ;
    Createini ;
    GetGroup ;
    GetLabel(True) ;
    GetLabel(False) ;
    sBtnMin.Glyph.LoadFromFile(sAppDir + '\Down.bmp' ) ;
  Except
    Exit ;
  End ;
end;

procedure TFrmMain.SBtnMinClick(Sender: TObject);
begin
  IF bisMin Then Begin
    FrmMain.Height := 385 ;
    bIsMin := False ;
    sBtnMin.Hint := '隐藏组' ;
    End
  Else Begin
    FrmMain.Height := 190 ;
    bIsMin := True ;
    sBtnMin.Hint := '查看组' ;
    End ;
  Try
    IF bisMin Then
      sBtnMin.Glyph.LoadFromFile(sAppDir + '\Down.bmp' )
    Else
      sBtnMin.Glyph.LoadFromFile(sAppDir + '\up.bmp' );
  Except
    Exit ;
  End ;
end;

procedure TFrmMain.BtnAddClick(Sender: TObject);
begin
  IF CbxMach.Text = '' Then Exit ;
  IF BtnAdd.Caption = '增加成员(&A)' Then Begin
    IF LbGrp.ItemIndex = -1 Then Exit ;
    AddMember(LBGrp.Items.Strings[LbGrp.ItemIndex] , CbxMach.text) ;
    LBGrpEnter(Nil) ;
  End
  Else //增加组
  Begin
    AddGroup(CbxMach.text) ;
    GetGroup ;
  End ;
end;

procedure TFrmMain.BtnDelClick(Sender: TObject);
begin
  IF BtnDel.Caption = '删除成员(&D)' Then Begin
    IF LbMmb.ItemIndex = -1 Then Exit ;
    DelMember(LBGrp.Items.Strings[LbGrp.ItemIndex] ,LBMmb.Items.Strings[LbMmb.ItemIndex] ) ;
    LBGrpEnter(Nil) ;
  End
  Else //删除组
  Begin
    IF LbGrp.ItemIndex = -1 Then Exit ;
    DelGroup(LBGrp.Items.Strings[LbGrp.ItemIndex] ) ;
    GetGroup ;
  End ;
end;

procedure TFrmMain.LBGrpEnter(Sender: TObject);
begin
  BtnDel.Caption := '删除组(&D)' ;
  BtnAdd.Caption := '增加组(&A)' ;
  IF LbGrp.ItemIndex = -1 Then Begin
    LbMmb.Clear ;
    Exit ;
  End ;
  GetMember(LBGrp.Items.Strings[LbGrp.ItemIndex]) ;
end;

procedure TFrmMain.LBMmbEnter(Sender: TObject);
begin
  BtnDel.Caption := '删除成员(&D)' ;
  BtnAdd.Caption := '增加成员(&A)' ;
end;

procedure TFrmMain.LBGrpClick(Sender: TObject);
begin
  BtnDel.Caption := '删除组(&D)' ;
  BtnAdd.Caption := '增加组(&A)' ;
  IF LbGrp.ItemIndex = -1 Then Begin
    LbMmb.Clear ;
    Exit ;
  End ;
  GetMember(LBGrp.Items.Strings[LbGrp.ItemIndex]) ;
end;

procedure TFrmMain.LBMmbClick(Sender: TObject);
begin
  IF LbMmb.ItemIndex = -1  Then Exit ;
  CbxMach.Text := LbMmb.Items.Strings[LbMmb.ItemIndex] ;
end;

procedure TFrmMain.MemHeadExit(Sender: TObject);
begin
  WriteLabel(MemHead.Text ,True) ;
end;

procedure TFrmMain.MemEndExit(Sender: TObject);
begin
  WriteLabel(MemEnd.Text ,False) ;
end;

procedure TFrmMain.Label3DblClick(Sender: TObject);
Var
  ss :String ;
begin
  ss := '' ;
  ss := ss + '*******************************************' + #13;
  ss := ss + '**  说明：本软件只能在Win98以上版本使用  **' + #13;
  ss := ss + '**        原理为封装了Net Send 命令      **' + #13;
  ss := ss + '**  常用功能：                           **' + #13;
  ss := ss + '**  ESC：退出ALT+S：发送TAB：控件间切换  **' + #13;
  ss := ss + '**  双击下拉列表即清除所写的内容         **' + #13;
  ss := ss + '**  选中复选框为群发选中的组内成员       **' + #13;
  ss := ss + '**  支持签名，但目前只支持一行，不够完美 **' + #13;
  ss := ss + '**  支持创建组与组员                     **' + #13;
  ss := ss + '**  如有兴趣可向我索取源码               **' + #13;
  ss := ss + '**                                       **' + #13;
  ss := ss + '**             作者：杨金海              **' + #13;
  ss := ss + '**             联系电话：[phone]     **' + #13;
  ss := ss + '**             邮箱：[e-mail]  **' + #13;  ss := ss + '*******************************************';
  ShowMessage(ss) ;
end;

end.