Последние записи

made in programmersforum 1

Интенсив по Python: Работа с API и фреймворками 24-26 ИЮНЯ 2022. Знаете Python, но хотите расширить свои навыки?
Slurm подготовили для вас особенный продукт! Оставить заявку по ссылке - https://slurm.club/3MeqNEk

Online-курс Java с оплатой после трудоустройства. Каждый выпускник получает предложение о работе
И зарплату на 30% выше ожидаемой, подробнее на сайте академии, ссылка - ttps://clck.ru/fCrQw

18th
Сен

Позиция в BASS

В каком формате BASS возвращает позицию и длину файла, если передавать флаг BYTE_POS (флаг написал по памяти, тот кто знает поймет)?
Это точно не байты, и не связано с секундами вроде никак.
Как перевести в наше человеческое время?

Код:


function qbass_gettime(const Channel: DWORD): DWORD;
var
  pPos: Cardinal;
  AllTime: Cardinal;
begin
  Result := 0;
  pPos := BASS_ChannelGetLength(Channel, BASS_POS_BYTE);
  if (pPos > 0) then
    begin
      Alltime := Trunc(BASS_ChannelBytes2Seconds(Channel, pPos));
      Result := Alltime;
    end;
end;

Получает длину трека, а в наше время переводит эта функа:

Код:


function qbass_formattime(const Sec: Integer;
  const IsURL: boolean): string;
(*******************************************
* RESULT: " 99:99" | "999:99" * | " Radio" *
*******************************************)
const
  time = ' 00:00';
  radio = ' Radio';
  null = '      ';
var
  H, M, S: Integer;
  Return: string;
begin
  if Sec = -1 then
    Return := null
  else
    if Sec < 0 then
      Return := time
    else
      if IsURL then
        Return := radio
      else
        begin
          H := Sec div 3600;
          S := Sec mod 3600;
          M := S div 60;
          M := M + (H * 60);
          S := (S mod 60);
          if M > 99 then Return := Format('%3d:%2.2d', [M, S])
          else Return := Format('%2.2d:%2.2d', [M, S]);
        end;
  Result := Return;
end;

Использовать:

Код:


var
  s:string;
  mCc,lng: DWORD;
begin
  mCc := BASS_StreamCreateFile(false, pointer(fail), 0, 0, 0 );
  try
    lng := qbass_gettime(mCc);
    s:= qbass_formattime(lng,false);

Тема на форуме.

Добавлено в Пост-обзор. Дата Сентябрь 18th, 2010

15th
Сен

Imageshack Upload Api

Листинг о том, как загружать изображения на сайт imageshack.us.

Код:


function sendimgs(path:string):string;
var
 HTTP: TIdHTTP;
 MPS: TIdMultiPartFormDataStream;
 s,s2,format:string;
begin
 HTTP := TIdHTTP.Create(nil);
 MPS := TIdMultiPartFormDataStream.Create;
 HTTP.HandleRedirects := True;
 s:='';
 if fileexists(path) then
  begin
   try
    {mps.AddFormField('Upload', 'Submit Query');
    s:= HTTP.Post('http://iload8.imageshack.us/upload_api.php', MPS); }
    mps.AddFile('fileupload', path, 'multipart/form-data');
    s:= HTTP.Post('http://imageshack.us/index.php', MPS);
    if pos('/images/blue/check.png', s)>0 then
    begin
      result:='Done';
    end;
    result:='Error while sending';
   finally
  MPS.Free;
  HTTP.Free;
  deletefile(path);
 end;
end else result:='File not found';
end;

Тема на форуме.

Добавлено в Пост-обзор. Дата Сентябрь 15th, 2010

14th
Сен

Как узнать разницу в часах между текущим системным временем и исходными данными?

Код:


uses DateUtils;
...................
var
t: TTime;
dt: TDateTime;
begin
t := StrToTime(Edit1.Text);
dt := DateTimePicker1.Date + t;

ShowMessage(FloatToStr(HoursBetween(Today,dt)));


end;

Тема на форуме.

Добавлено в Пост-обзор. Дата Сентябрь 14th, 2010

13th
Сен

idHTTP и кодировка

добрый вечер. в переменную типа стринг качается через идхттп гет запросом страница. страница в ютф8, после всего этого пытаюсь распарсить через pos (нужно найти фразу <liкакойтотекстнарусском<strong>) . соответственно, руские буквы кракозябрами, и пос их не ищет. пытался декодировать utf8toansi и наоборот – ничего не помогает. кракозябры меняются только

Код:


function UTF8ToStrSmart(Value: String): String;

      function UTF8ToStr(Value: String): String;
      var
        buffer: Pointer;
        BufLen: LongWord;
      begin
        BufLen := Length(Value) + 4;
        GetMem(buffer, BufLen);
        FillChar(buffer^, BufLen, 0);
        MultiByteToWideChar(CP_UTF8, 0, @Value[1], BufLen - 4, buffer, BufLen);
        Result := WideCharToString(buffer);
        FreeMem(buffer, BufLen);
      end;

var
  Digit: String;
  i: integer;
  HByte: Byte;
  Len: Byte;
begin
  Result := '';
  Len := 0;
  if Value = '' then Exit;
  for i := 1 to Length(Value) do
  begin
    if Len > 0 then
    begin
      Digit := Digit + Value;
      Dec(Len);
      if Len = 0 then
        Result := Result + UTF8ToStr(Digit);
    end else
    begin
      HByte := Ord(Value);
      if HByte in [$00..$7f] then       //Standart ASCII chars
        Result := Result + Value
      else begin
        //Get length of UTF-8 char
        if HByte and $FC = $FC then
          Len := 6
        else if HByte and $F8 = $F8 then
          Len := 5
        else if HByte and $F0 = $F0 then
          Len := 4
        else if HByte and $E0 = $E0 then
          Len := 3
        else if HByte and $C0 = $C0 then
          Len := 2
        else begin
          Result := Result + Value;
          Continue;
        end;
        Dec(Len);
        Digit := Value;
      end;
    end;
  end;
end;

Есть ещё 2 совета.
1. Брось инди и переходи на ICS.
2. Обнови инди до максимально последней версии.

Код:

function HttpGetUrl(url: string; idHttp: TidHttp): string;


var
M: TStringStream;
begin
M := TStringStream.Create('');
//  try


try
IdHTTP.Get(url, m);
if IdHTTP.ResponseCode = 502 then
begin
result := 'ошибка|'+url;
freeandnil(m);
exit;
end;
except
on e: exception do
begin
//          MessageBox(application.ActiveFormHandle, PAnsiChar('Произошла ошибка при получении текста страницы: '+#13+ url + #13+e.Message), 'Ошибка', IDOK);
result := 'ошибка|'+url;
freeandnil(m);
end;
end;

result := m.DataString;


//  finally
freeandnil(m);
//  end;
end;

итого полный код будет:
Код:

//получаем тест страницы со ссылками на объявления slText := UTF8ToStrSmart(HttpGetUrl(URL, idHttp1));

Тема на форуме.

Добавлено в Пост-обзор. Дата Сентябрь 13th, 2010

12th
Сен

Перевод PByte в TBytes

Код:


var
  p: PByte;
  p1: TBytes;
  i: byte;
begin
  GetMem(p, 5);

  for i := 0 to 4 do
  begin
    p^ := i;
    Inc(p, 1);
  end;

  Dec(p, 5);

  SetLength(p1, 5);

  Move(p^, p1[0], 5);
  FreeMem(p);
end;

Тема на форуме.

Добавлено в Пост-обзор. Дата Сентябрь 12th, 2010

12th

Анимированный Gif в компоненте Image

Есть модуль от Андерса Меландера, бесплатный. Подключаете его в секцию uses и пишете код:

Код:


procedure Tform1.FormCreate(Sender : Tobject);
var
gif : TGifImage;
begin
gif:=TGIfImage.Create;
try
Image1.Picture.LoadFromFile('1.gif);
finally
gif.Free;
end;
end;

А вот собственно сам модуль

Вложения

GIFImage.rar (53.6 Кб)

Тема на форуме.

Добавлено в Пост-обзор. Дата Сентябрь 12th, 2010

9th
Сен

Всплывающее окно и фокус

В программе есть всплывающее окно, как сделать чтобы когда оно будет всплывать, оно было поверх остальных окон, но при этом не брало на себя фокус ввода?

код:

procedure TForm1.Button1Click(Sender: TObject);
var
   Form2: TForm;
begin
   Form2 := TForm.Create(Form1);
   Form2.FormStyle := fsStayOnTop;
   …
   Form2.Show;
   Form1.Show;
end;

тема на форуме

Добавлено в Пост-обзор. Дата Сентябрь 9th, 2010

8th
Сен

Как в указанной папке и её подпапках найти все файлы определённого типа?

код:

procedure DirSearch(Dir: string; Mask : string; SL: TStrings);
var
SearchRec: TSearchRec;
begin
Dir := IncludeTrailingBackslash(Dir);

   if FindFirst(Dir + ‘*.*’, faAnyFile, SearchRec) = 0 then
     repeat
       Application.ProcessMessages;

       if (SearchRec.Attr and faDirectory) 0 then begin
         if (SearchRec.name ‘.’) and (SearchRec.name ‘..’) then
                 DirSearch(Dir + SearchRec.name, Mask, sl)
       end
       else
         if MatchesMask(ExtractFileName(SearchRec.Name), Mask) then
           Sl.Add(Dir + SearchRec.Name);
     until FindNext(SearchRec) 0;
   FindClose(SearchRec);
end;

// ИСПОЛЬЗОВАТЬ ТАК:
procedure TForm1.Button1Click(Sender: TObject);
begin
DirSearch(’C:\TEMP’, ‘*.AVI’, Memo1.Lines);
end;

Тема на форуме

Добавлено в Пост-обзор. Дата Сентябрь 8th, 2010

6th
Сен

Работа с com портом

Есть прибор, который подключаеться через com порт к компьютеру. Протокол обмена известен. Как отправить ему 16 ричное значение и как прочитать такое значение от него?

код:

function readcom: string;
var RX_Count : cardinal;
TempArray: array[1..255] of Byte;
Count : Integer;
begin
result:= ”;
ReadFile(Com, TempArray, 255, RX_Count, nil);
for Count:= 1 to RX_Count do result:= result + Chr(TempArray[Count])
end;

procedure sendcom(s: string);
var TempArray: array[1..255] of Byte;
Count : Integer;
TX_Count : cardinal;
begin
for Count:= 1 to Length(S) do TempArray[Count]:= Ord(S[Count]);
WriteFile(Com, TempArray,Length(S),TX_Count,nil)
end;

// или если компонентом пользуешся
type tb = array[1..255] of Char; //Определяем символьный массив
      pb = ^tb;
procedure Tmf.comReceiveData(Sender: TObject; Buffer: Pointer;
   BufferLength: Word);
var PX : pb;
     i : integer;
     str: string;
begin
PX:= buffer; str:=”;
for i:= 1 to BufferLength do
   str:=str+PX^;
packet(str)
end;