www.pudn.com > java_delphi.rar > Unit1.pas

unit Unit1; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
  Dialogs, ExtCtrls, StdCtrls, OoMisc, AdPort, ComCtrls, BinHexTools,ActiveX; 
type 
  TForm1 = class(TForm) 
    ComPort1: TApdComPort; 
    Button1: TButton; 
    Panel1: TPanel; 
    Label1: TLabel; 
    Label2: TLabel; 
    Label3: TLabel; 
    Label4: TLabel; 
    Label5: TLabel; 
    CB_ComNum: TComboBox; 
    CB_Baud: TComboBox; 
    CB_Parity: TComboBox; 
    CB_DataBits: TComboBox; 
    CB_StopBits: TComboBox; 
    Button2: TButton; 
    Shape_ComState: TShape; 
    Timer1: TTimer; 
    Memo_Show: TRichEdit; 
    SendMemo: TRichEdit; 
    Panel2: TPanel; 
    Label6: TLabel; 
    Edit1: TEdit; 
    Label7: TLabel; 
    Edit2: TEdit; 
    Label8: TLabel; 
    memo1: TMemo; 
    Button3: TButton; 
    Button4: TButton; 
    Button5: TButton; 
    Edit3: TEdit; 
    Button6: TButton; 
    Button7: TButton; 
    Edit4: TEdit; 
    Memo2: TMemo; 
    ProgressBar1: TProgressBar; 
    Timer2: TTimer; 
    Button8: TButton; 
    Memo3: TMemo; 
    procedure ComPortInit; 
    procedure Button2Click(Sender: TObject); 
    procedure Timer1Timer(Sender: TObject); 
    procedure FormShow(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
    procedure SendHex(S: string); 
    procedure ComPort1Trigger(CP: TObject; Msg, TriggerHandle, Data: Word); 
    procedure Button3Click(Sender: TObject); 
    procedure Button4Click(Sender: TObject); 
    procedure Button5Click(Sender: TObject); 
    procedure Button6Click(Sender: TObject); 
    procedure FormCreate(Sender: TObject); 
    procedure Button7Click(Sender: TObject); 
    function TranslateSMS(Asrc: string): string; 
    procedure Timer2Timer(Sender: TObject); 
    procedure Button8Click(Sender: TObject); 
       procedure myMemoAddText2(strAdd: string); stdcall; 
       procedure sendsms(sendtxt:string); 
       procedure delsms(sendtxt:string); 
  private 
    { Private declarations } 
  public 
    { Public declarations } 
  end; 
 
   procedure myMemoAddText(strAdd: string); stdcall; 
   function sendmalin(text: string):string; 
var 
  Form1: TForm1; 
  bj: Integer; 
  tempstr: string; 
 
implementation 
 
{$R *.dfm} 
 
procedure TForm1.myMemoAddText2(strAdd: string); stdcall; 
 
var 
  str: string; 
begin 
  str := Form1.Memo3.Lines[Form1.Memo3.Lines.Count - 1]; 
  if Form1.Memo3.Lines.Count = 0 then 
    Form1.Memo3.Lines[0] := str + strAdd 
  else 
    Form1.Memo3.Lines[Form1.Memo3.Lines.Count - 1] := str + strAdd; 
end; 
 
procedure myMemoAddText(strAdd: string); stdcall; 
var 
  temp1, str: string; 
  MyStrList: TStringList; 
  lencount, i: integer; 
begin 
  MyStrList := TStringList.Create; 
  MyStrList.Delimiter := char(13); //指定分隔符 
  MyStrList.DelimitedText := strAdd; 
  //ListBox1.Items := MyStrList; 
  lencount := MyStrList.Count - 2; 
 
  for i := 1 to lencount do 
  begin 
    temp1 := MyStrList.Strings[i]; 
    temp1 := Form1.TranslateSMS(temp1); 
    Form1.Memo_Show.Lines.Append(temp1); 
  end; 
 
end; 
 
function Decode_cn(MSG: string): WideString; 
var i, j, len, Cur: Integer; 
  twideChar: integer; 
begin 
  try 
    i := Length(MSG) mod 4; 
    if i <> 0 then 
    begin 
      for j := 1 to 4 - i do 
        MSG := MSG + '0'; 
    end; 
    Len := Length(MSG) div 4; 
    SetLength(Result, Len); 
    Result := ''; 
    for i := 1 to Len do 
    begin 
      tWideChar := StrToInt('$' + Copy(MSG, 1 + (i - 1) * 4, 4)); 
      Result := Result + WideChar(tWideChar); 
    end; 
  except 
    Result := ''; 
  end; 
end; 
 
function str_Gb2UniCode(text: string): string; 
var 
  i, j, len: Integer; 
  cur: Integer; 
  t: string; 
  ws: WideString; 
begin 
  Result := ''; 
  ws := text; 
  len := Length(ws); 
  i := 1; 
  j := 0; 
  while i <= len do 
  begin 
    cur := ord(ws[i]); 
    FmtStr(t, '%4.4X', [cur]); //BCD转换 
    Result := Result + t; 
    inc(i); 
    //移位计数达到7位的特别处理 
    j := (j + 1) mod 7; 
  end; 
end; 
 
function ConvertL2R(sMsg: string): string; 
var i: Integer; 
  cTmp: Char; 
  sRe: string; 
begin 
  sRe := Trim(sMsg); 
  i := Length(sRe); 
  if i = 0 then 
  begin 
    Result := ''; 
    Exit; 
  end; 
 
  if i mod 2 = 1 then 
    sRe := sRe + 'F'; 
 
  i := 1; 
  while i < Length(sRe) do 
  begin 
    cTmp := sRe[i]; 
    sRe[i] := sRe[i + 1]; 
    sRe[i + 1] := cTmp; 
    i := i + 2; 
  end; 
 
  Result := sRe; 
end; 
 
function TextToPdu(sCenter, sPhone, sMsg: string; var a: string; var b: string): boolean; 
var sAddr, sBody: string; 
  LCenter, LMsg, LBody: string; 
begin 
  sCenter := '91' + ConvertL2R(sCenter); 
  FmtStr(LCenter, '%2.2X', [Length(sCenter) div 2]); 
  sAddr := LCenter + sCenter; 
 
  sPhone := ConvertL2R(sPhone); 
  sMsg := str_Gb2UniCode(sMsg); 
  FmtStr(LMsg, '%2.2X', [Length(sMsg) div 2]); 
 
  sBody := '11000D9168' + sPhone + '000800' + LMsg + sMsg; 
  FmtStr(LBody, '%2.2D', [Length(sBody) div 2]); 
  a := 'AT+CMGS=' + LBody + #13; //要发送的长度 
  b := sAddr + sBody + #26 + #13; //要发送的pdu代码 
  Result := true; 
 
end; 
 
procedure TForm1.SendHex(S: string); 
var 
  buf1: array[0..50000] of byte; 
  i: integer; 
begin 
  for i := 0 to (length(s) div 2 - 1) do 
  begin 
    buf1[i] := strtoint('$' + copy(s, i * 2 + 1, 2)); 
  end; 
  Form1.ComPort1.PutBlock(buf1, (length(s) div 2)); 
end; 
 
//等待串口发送完毕 
 
procedure waitcommEmpty(x: integer); 
begin 
  application.ProcessMessages; 
  while (Form1.ComPort1.OutSize - Form1.ComPort1.OutBuffUsed < x) do 
  begin 
    sleep(200); 
  end; 
  sleep(20); 
end; 
 
procedure TForm1.ComPortInit; 
var 
  s, s2: string; 
  x, i: integer; 
begin 
  try 
    ComPort1.Open := false; 
    Shape_ComState.Brush.Color := clRed; 
    sleep(50); 
    ComPort1.ComNumber := CB_ComNum.ItemIndex + 1; 
    ComPort1.Baud := strtoint(CB_Baud.Text); 
    case CB_Parity.ItemIndex of 
      0: 
        ComPort1.Parity := pEven; 
      1: 
        ComPort1.Parity := pMark; 
      2: 
        ComPort1.Parity := pNone; 
      3: 
        ComPort1.Parity := pOdd; 
      4: 
        ComPort1.Parity := pSpace; 
    else 
      ComPort1.Parity := pNone; 
    end; 
    ComPort1.DataBits := strtoint(CB_DataBits.Text); 
    ComPort1.StopBits := strtoint(CB_StopBits.Text); 
    ComPort1.Open := true; 
 
    s := SendMemo.Text; 
    if ComPort1.Open then 
    begin 
      begin 
        x := length(s); 
        for i := 0 to (x div 16) do 
        begin 
          s2 := copy(s, i * 16 + 1, 16); 
          ComPort1.PutString(s2); 
          waitcommEmpty(16); 
        end; 
      end; 
    end; 
    timer2.Enabled := true; 
  except 
    showmessage('串口不存在或被占用。'); 
  end; 
 
end; 
 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  ComPortInit; 
end; 
 
procedure TForm1.Timer1Timer(Sender: TObject); 
var 
  mai, maj: integer; 
  mastr: string; 
begin 
   { mastr 
    maj:=pos('AT',s); 
    mai:=pos('OK',s); 
    if maj=0 then 
 
         if mai<>0 then 
             showmessage('手机联接成功！') 
         else 
             showmessage('手机联接失败！');   } 
  if ComPort1.Open then 
    Shape_ComState.Brush.Color := clLime 
  else 
    Shape_ComState.Brush.Color := clRed; 
end; 
 
procedure TForm1.FormShow(Sender: TObject); 
begin 
  CB_ComNum.ItemIndex := 1; 
  ComPortInit; 
end; 
 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  a1, a2, s, s2, s3: string; 
  x, i: integer; 
  zhujiao, beijiao, duanxintxt: string; 
begin 
  zhujiao := trim(edit1.Text); 
  beijiao := trim(edit2.Text); 
  duanxintxt := trim(memo1.Text); 
  TextToPdu(zhujiao, beijiao, duanxintxt, a1, a2); 
  s := a1; 
  if ComPort1.Open then 
  begin 
    x := length(s); 
    for i := 0 to (x div 16) do 
    begin 
      s2 := copy(s, i * 16 + 1, 16); 
      ComPort1.PutString(s2); 
      waitcommEmpty(16); 
    end; 
  end else 
  begin 
    showmessage('串口未打开。'); 
  end; 
  sleep(6000); 
  s := a2; 
  if ComPort1.Open then 
  begin 
    x := length(s); 
    for i := 0 to (x div 16) do 
    begin 
      s2 := copy(s, i * 16 + 1, 16); 
      ComPort1.PutString(s2); 
      waitcommEmpty(16); 
    end; 
  end else 
  begin 
    showmessage('串口未打开。'); 
  end; 
end; 
function sendmalin(text: string):string; 
 var 
  a1, a2, s, s2, s3: string; 
  x, i: integer; 
  zhujiao, beijiao, duanxintxt: string; 
begin 
  zhujiao := trim(form1.edit1.Text); 
  beijiao := trim(form1.edit2.Text); 
  duanxintxt := trim(form1.memo1.Text); 
  TextToPdu(zhujiao, beijiao, duanxintxt, a1, a2); 
  s := a1; 
  if form1.ComPort1.Open then 
  begin 
    x := length(s); 
    for i := 0 to (x div 16) do 
    begin 
      s2 := copy(s, i * 16 + 1, 16); 
      form1.ComPort1.PutString(s2); 
      waitcommEmpty(16); 
    end; 
  end else 
  begin 
    showmessage('串口未打开。'); 
  end; 
  sleep(6000); 
  s := a2; 
  if form1.ComPort1.Open then 
  begin 
    x := length(s); 
    for i := 0 to (x div 16) do 
    begin 
      s2 := copy(s, i * 16 + 1, 16); 
      form1.ComPort1.PutString(s2); 
      waitcommEmpty(16); 
    end; 
  end else 
  begin 
    showmessage('串口未打开。'); 
  end; 
  Result :='1'; 
end; 
 
 
 
procedure TForm1.ComPort1Trigger(CP: TObject; Msg, TriggerHandle, 
  Data: Word); 
var 
  I: Word; 
  C: Char; 
  s, sc: string; 
  nFind, nFindo: Integer; 
  hThread: THandle; 
  ThreadID: DWord; 
begin 
  try 
    case Msg of 
      APW_TRIGGERDATA: 
      {got 'login', send response} 
        ; 
      APW_TRIGGERAVAIL: 
      {extract and display/process the data} 
        begin 
          s := ''; 
          for I := 1 to Data do 
          begin 
 
            C := ComPort1.GetChar; 
            sc := trim(c); 
            nFind := Pos('+', sc); 
            nFindo := Pos('O', sc); 
            if (nFind <> 0) or (nFindo <> 0) then 
            begin 
              if bj <> 0 then 
                sc := char(13) + char(10) + sc 
              else 
                bj := 1; 
            end; 
            s := s + sc; 
            tempstr := tempstr + sc; 
            if (nFindo <> 0) then 
              begin 
           { hthread := createThread(nil,0,@myMemoAddText,@tempstr,0,ThreadID); 
            if hthread = 0 then 
              messageBox(Handle, 'No Thread', nil, MB_OK);   } 
              myMemoAddText(tempstr); 
           end; 
          end; 
 
 
          myMemoAddText2(s); 
        end; 
      APW_TRIGGERTIMER: 
      {timed out waiting for login prompt, handle error} 
        ; 
    end; 
  except 
  end; 
end; 
 
procedure TForm1.Button3Click(Sender: TObject); 
var 
  g: integer; 
  AString1, aa: string; 
begin 
  aa := trim(SendMemo.Text); 
  SendMemo.Text := Decode_cn(aa); 
end; 
 
procedure TForm1.Button4Click(Sender: TObject); 
var 
  a1, a2, s, s2, s3: string; 
  x, i: integer; 
begin 
  bj := 0; 
  tempstr := ''; 
  s := trim(memo1.Text) + char(13); 
  if ComPort1.Open then 
  begin 
    x := length(s); 
    for i := 0 to (x div 16) do 
    begin 
      s2 := copy(s, i * 16 + 1, 16); 
      ComPort1.PutString(s2); 
      waitcommEmpty(16); 
    end; 
  end else 
  begin 
    showmessage('串口未打开。'); 
  end; 
 
end; 
 
 
procedure TForm1.sendsms(sendtxt:string); 
var 
  a1, a2, s, s2, s3: string; 
  x, i: integer; 
begin 
  bj := 0; 
  tempstr := ''; 
  s := trim(sendtxt) + char(13); 
  if ComPort1.Open then 
  begin 
    x := length(s); 
    for i := 0 to (x div 16) do 
    begin 
      s2 := copy(s, i * 16 + 1, 16); 
      ComPort1.PutString(s2); 
      waitcommEmpty(16); 
    end; 
  end else 
  begin 
    showmessage('串口未打开。'); 
  end; 
 
end; 
 
procedure TForm1.delsms(sendtxt:string); 
begin 
  sendsms('AT+CMGD='+trim(sendtxt)); 
end; 
 
 
 
procedure TForm1.Button5Click(Sender: TObject); 
var 
  aa: string; 
begin 
  aa := trim(SendMemo.Text); 
  SendMemo.Text := str_Gb2UniCode(aa); 
end; 
 
function TForm1.TranslateSMS(Asrc: string): string; 
var 
  aDelid,aSMSC, aRelpyNum, aRecTime, aSMSlen, aSMS, bianmaBZ: string; 
  nSMS, nRepLen, a8091, strlen1: integer; 
begin 
  a8091 := Pos(',', Asrc); 
  aDelid:=copy(Asrc, 7, a8091-7); 
  if (aDelid<>'25')and(aDelid<>'23')and(aDelid<>'22') then 
    delsms(aDelid); 
  strlen1 := length(Asrc); 
  a8091 := Pos('0891', Asrc); 
  strlen1 := strlen1 - a8091; 
  Asrc := copy(Asrc, a8091, strlen1 + 1); 
  result := Asrc; 
  if (a8091 <> 0) then 
  begin 
 //短信息中心号码 
    aSMSC := copy(Asrc, 5, 14); 
    aSMSC := copy(ExchangeCode(aSMSC), 1, 13); //ignore 'F' 
 //writeln('短信息中心号码为：'+aSMSC); 
 
 //回复地址字节数十进制数 
    nRepLen := strtoint('$' + copy(Asrc, 21, 2)); 
 //回复号码 
    aRelpyNum := copy(Asrc, 25, nRepLen + 1); //1 is the length of 'F 
    a8091 := Pos('F', aRelpyNum); 
    if a8091 <> 0 then 
      aRelpyNum := copy(ExchangeCode(aRelpyNum), 1, nRepLen) //ignore 'F' 
    else 
      nRepLen := nRepLen - 1; 
 //writeln('回复号码为：'+aRelpyNum); 
 
 //短信息中心收到时间 
 //04-08-21 17:42:03 0时区 
 ////aRecTime:=copy(Asrc,41,14); //40-80-12 71246300 
    bianmaBZ := copy(Asrc, (nRepLen + 28), 2); 
 
    aRecTime := copy(Asrc, (nRepLen + 30), 14); 
    aRecTime := copy(ExchangeCode(aRecTime), 1, 12); 
 //04-09-27 08:35:23 
    insert('-', aRecTime, 3); 
    insert('-', aRecTime, 6); 
    insert(' ', aRecTime, 9); 
    insert(':', aRecTime, 12); 
    insert(':', aRecTime, 15); 
 //writeln('收到时间为：'+aRecTime); 
 //短信息正文长度 
    aSMSlen := copy(Asrc, (nRepLen + 44), 2); 
    aSMSlen := inttostr(strtoint('$' + aSMSlen)); 
 
 //短信息内容 
    nSMS := (strtoint(aSMSlen)) * 2; 
 //writeln('短信息长度为：'+inttostr(nSMS)); 
    aSMS := copy(Asrc, (nRepLen + 46), nSMS); 
    SendMemo.Text := bianmaBZ; 
    if (bianmaBZ <> '00') then 
      aSMS := Decode_cn(trim(aSMS)) 
    else 
      aSMS := DecodeSMS7Bit(trim(aSMS)); 
 
 //writeln('中文短信息为：'+aSMS); 
 
 (*下面为分析短信息内容的另外一种比较有效但不稳定的方法*) 
 { 
 //短信息中心号码 
 aSMSC:=copy(Asrc,5,14); 
 aSMSC:=copy(RecoverCode(aSMSC),1,13); 
 //回复号码 
 aRelpyNum:=copy(Asrc,25,14); 
 aRelpyNum:=copy(RecoverCode(aRelpyNum),1,13); 
 //短信息中心收到时间 
 //04-08-21 17:42:03 0时区 
 aRecTime:=copy(Asrc,43,14); //40-80-12 71246300 
 aRecTime:=copy(RecoverCode(aRecTime),1,14); 
 //短信息正文长度 
 aSMSlen:=copy(Asrc,57,2); 
 aSMSlen:=inttostr(strtoint('$'+aSMSlen)); 
 //短信息内容 
 nSMS:=(strtoint(aSMSlen))*2; 
 aSMS:=copy(Asrc,59,nSMS); 
 aSMS:=UniCode2GB(trim(aSMS)); 
 //} 
    result :=aDelid+ '#' + aSMSC + '#' + aRelpyNum + '#' + aRecTime + '#' + aSMS; 
  end; 
 
end; 
 
procedure TForm1.Button6Click(Sender: TObject); 
begin 
  SendMemo.Text := DecodeSMS7Bit(trim(edit3.Text)); 
end; 
 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  bj := 0; 
end; 
 
procedure TForm1.Button7Click(Sender: TObject); 
begin 
  myMemoAddText(trim(memo2.Text)); 
   //SendMemo.Text := TranslateSMS(trim(edit3.Text)); 
end; 
 
 
procedure TForm1.Timer2Timer(Sender: TObject); 
begin 
  Button4Click(Sender); 
end; 
 
procedure TForm1.Button8Click(Sender: TObject); 
begin 
  timer2.Enabled := false; 
end; 
 
initialization 
    CoInitialize(nil); 
finalization 
    CoUninitialize; 
 
end.