Sunday 7 May 2023

Run procedure without crashing the application

I have a procedure called domainupdate().

When I run the procedure directly in the buton click, I got the cursor waits with the SQL icon and the program stops responding until the procedure is finished.

However, when I run the procedure with TThread, only the first record, or the first and second records, are updated.

How can I fix this issue?

procedure TForm1.domainupdate;
var
  I, A, J, K, B: Integer;
  domain, domain1, domain2, host, whois, expiry, status: string;
  sl: TStringList;
  fs, ds: TFormatSettings;
  dt: TDatetime;
begin
  DM.Qdomains.First;
  while not DM.Qdomains.Eof do begin
    domain := DM.Qdomains.FieldByName('domain').AsString;
    domain1 := '';
    domain2 := '';
    for J := Length(domain) downto 2 do begin
      if domain[J] = '.' then begin   // search host.co.uk
        if domain1 = '' then
          domain1 := Copy(domain, J + 1, MaxInt) + IcsSpace
          // found  uk
        else begin
          domain2 := Copy(domain, J + 1, MaxInt) + IcsSpace;
          // found co.uk
          Break;
        end;
      end;
    end;

    FWhoisServers := TStringList.Create;
    try
      for I := 0 to Length(WhoisNames) - 1 do
        FWhoisServers.Add(WhoisNames[I]);
      host := 'whois.ripe.net';
      K := -1;
      if FWhoisServers.Count > 0 then begin
        for I := 0 to FWhoisServers.Count - 1 do
        begin
          if (Pos(domain1, FWhoisServers[I]) = 1) then K := I;
          if (Pos(domain2, FWhoisServers[I]) = 1) then
          begin
            K := I;
            Break;
          end;
        end;
        if K >= 0 then begin
          J := Pos(IcsSpace, FWhoisServers[K]);
          host := Copy(FWhoisServers[K], J + 1, MaxInt);
        end;
      end;
      IdWhois1.Host := host;
    finally
      FWhoisServers.Free;
    end;

    expiry := '';
    sl := TStringList.Create;
    try
      whois := IdWhois1.WhoIs(domain);
      sl.Text := whois;
      sl.NameValueSeparator := ':';

      for I := 0 to sl.Count-1 do begin
        sl[I] := TrimLeft(sl[I]);
      end;
      for I := Low(FieldNames) to High(FieldNames) do begin
        expiry := Trim(sl.Values[FieldNames[I]]);
        if expiry <> '' then
          Break;
      end;
      for B := 0 to sl.Count-1 do begin
        sl[B] := TrimLeft(sl[B]);
        if SameText(sl.Names[B], 'status') then
        begin
          status := Trim(sl.ValueFromIndex[B]);
          status := Copy(status, 1);
        end
        else
        if SameText(sl.Names[B], 'Domain Status') then
        begin
          status := Trim(sl.ValueFromIndex[B]);
          status := Copy(status, -1);
          notes.Lines.Add(status);
        end;
      end;
    finally
      sl.Free;

      if expiry <> '' then begin
        fs := TFormatSettings.Create;
        fs.DateSeparator := '-';
        fs.TimeSeparator := ':';
        fs.ShortDateFormat := 'yyyy-mm-dd';
        fs.ShortTimeFormat := 'hh:nn:ss';
        dt := StrToDateTime(expiry, fs);
        ds := TFormatSettings.Create;
        ds.DateSeparator := '/';
        ds.TimeSeparator := ':';
        ds.ShortDateFormat := 'dd/mm/yyyy';
        ds.LongTimeFormat := 'hh:mm:ss';

        DM.Qdomains.Edit;
        try
          DM.Qdomains.FieldByName('domain').AsString := domain;
          DM.Qdomains.FieldByName('expiry').AsString := DateTimeToStr(dt, ds);
          DM.Qdomains.FieldByName('whois').AsString := whois;
          DM.Qdomains.FieldByName('update').AsString := DateTimeToStr(Now);
          DM.Qdomains.FieldByName('status').AsString := status;
          DM.Qdomains.Post;
          DM.Qdomains.next;
        except
          DM.Qdomains.Cancel;
          raise;
        end;
      end;
    end;
  end;
end;

Button:

procedure TForm1.RefreshDomainsClick(Sender: TObject);
begin
 TThread.CreateAnonymousThread(
    procedure
    begin
     domainupdate;
    end
  ).Start;
end;


from Run procedure without crashing the application

No comments:

Post a Comment