-
Постов
69 -
Зарегистрирован
-
Посещение
-
Победитель дней
3
Весь контент Dmitry Stolyarov
-
Здравствуйте, поделитесь пжл у кого есть последним FireMonkeyPremiumStyles Pack ?
-
Есть клиентское приложение на Win, сервер на MySQL, связка через json+php. Как можно реализовать аналог Events. Например, когда на одном из клиентов была внесена запись в таблице, то надо чтобы на других клиентах появилось эта запись/или типа запрос на обновление таблицы. При этом постоянно мониторить таблицу на изменения, на мой взгляд, не самый лучший вариант.. Подскажите, как лучше реализовать?
-
Подскажите, пытаюсь выгрузить на сервер картинку в формате потока. ничего не получается, что не так? /// ... mStream := TMemoryStream.Create; bitmaptmp.SaveToStream(mStream); mStream.Position := 0; SendImgStream(Url, mStream); /// function TfmMain.SendImgStream(const Url: string; const FileName: TStream): Boolean; var lHttp: THTTPClient; lSendData: TMultipartFormData; lResponse: IHTTPResponse; begin Result := false; lHttp := THTTPClient.Create; lSendData := TMultipartFormData.Create; with lHttp do try try lSendData.AddStream('userfile', FileName); lResponse := lHttp.Post(Url, lSendData); Result := lResponse.StatusCode = 200; except on E: exception do ShowMessage('Ошибка сети: '+E.Message); end; finally FreeAndNil(lHttp); FreeAndNil(lSendData); end; end; на сервере: $dir = 'files/ID_'.$pIDPartner.'/ImgFromLesson'; if(!file_exists($dir)) mkdir($dir, 0777, true); $newfilename = md5(strtotime('now')).'_'.md5($_FILES['FileField']['tmp_name']).'jpg'; if (move_uploaded_file($_FILES["userfile"]["name"], $dir."/". $newfilename)) { // mysqli_query($DBLink, $query); } else { print "There some errors!"; }
-
Рабочий код: procedure TForm1.HandleActivityMessage(const Sender: TObject; const M: TMessage); var RequestCode, ResultCode: Integer; Intent: JIntent; uri : Jnet_Uri; bitmap: JBitmap; surface: TBitmapSurface; begin if not(M is TMessageResultNotification) then exit; TMessageManager.DefaultManager.Unsubscribe(TMessageResultNotification, FMessageSubscriptionID); FMessageSubscriptionID := 0; RequestCode:=TMessageResultNotification(M).RequestCode; ResultCode:=TMessageResultNotification(M).ResultCode; Intent:=TMessageResultNotification(M).Value; if (ResultCode = TJActivity.JavaClass.RESULT_OK) and Assigned(Intent) then begin try uri:=Intent.getData; bitmap := TJImages_Media.JavaClass.getBitmap(SharedActivity.getContentResolver, uri); surface := TBitmapsurface.Create; JBitMapToSurface(bitmap,surface); Image1.Bitmap.Assign(surface); finally surface.Free; end; end;
-
Открываю список фото в галерее с помощью: procedure TForm1.Button1Click(Sender: TObject); var chooserIntent, Intent: JIntent; ResultInt:integer; begin intent := TJIntent.Create; intent.setAction(TJIntent.JavaClass.ACTION_GET_CONTENT); intent.setType(StringToJString('image/* video/*')); chooserIntent := TJIntent.JavaClass.createChooser(Intent, StrToJCharSequence('Choose media file')); TAndroidHelper.Activity.startActivityForResult(chooserIntent, ResultInt); end; А как получить выбранную фотографию, например в Image1 не пойму.. Подскажите пжл...
-
не работает в Андроид TTabTransition.Slide
Dmitry Stolyarov опубликовал вопрос в Переключение вкладок
Подскажите, почему может не работать на Анройде плавное переключение вкладок? Под Win все работает. TabControl1.SetActiveTabWithTransition(TabControl1.Tabs[1], TTabTransition.Slide, TTabTransitionDirection.tdReversed) -
Вариант № 1 - не помогло. странно, но пример из ссылки "Helper для TBitmap - асинхронная" не работает на андроиде - после запуска картинки не отображаются в листвью.. при этом под OSX работает.. как теперь это запустить под андройдом фиг пойми.. поделитесь, пжл, рабочим кодом под Андроид загрузки картинок в листвью в отдельном потоке.
-
Где указать ownerBitmap := true (ImageListItemBottomDetail)
Dmitry Stolyarov опубликовал вопрос в TListView
Подскажите, пжл, как прописать ownerBitmap := true при режиме LV - ImageListItemBottomDetail ? проблема в том, что картинке по URL на MacOS не грузятся совсем.. под Win все работает. как я понял из форума причина в ownerBitmap , но как его прописать не понимаю... procedure TfmMain.lvSostavUpdateObjects(const Sender: TObject; const AItem: TListViewItem); begin if FlvSostavUpdating then exit; //LV в режиме редактирования списка if FlvSostavStateEdit then begin if (AItem.Purpose <> TListItemPurpose.Header)and (AItem.Objects.AccessoryObject <> nil) then begin AItem.Accessory:= TAccessoryType.Checkmark; AItem.Objects.AccessoryObject.Visible := FChecked.Contains(AItem.Tag); end end else AItem.Accessory:= TAccessoryType.Detail; end; procedure TfmMain.lvSostavUpdatingObjects(const Sender: TObject; const AItem: TListViewItem; var AHandled: Boolean); begin if FlvSostavUpdating then exit; //LV в режиме редактирования списка if (AItem.Data['sign_Loaded'].AsInteger = 0)and(AItem.Purpose <> TListItemPurpose.Header) then begin AItem.Data['sign_Loaded'] := 1; LoadBitmapFromURL(AItem.Data['sign_URL'].AsString, AItem, AItem.Bitmap, rcImg); end; end; Картинки загружаю по URL в отдельном потоке procedure TfmMain.LoadBitmapFromURL(const AURL: string; const AItem: TListViewItem; aBitmap: TBitmap; aSourceBmp: TRectangle); var K: Integer; // Анонимная процедура захватывает локальную переменную, а не обращается к AItem, которой уже может не быть в момент _окончания_ скачивания фотки FHTTPClient : THTTPClient; ResourceStream: TResourceStream; begin if Not Assigned(AItem) then Exit; if AItem.Data['ImageState'].AsInteger <> lvStudentsItemImageEmpty then Exit; if AURL.IsEmpty then begin AItem.Data['ImageState'] := lvStudentsItemImageLoading; ResourceStream := TResourceStream.Create(hInstance, 'PngImage_1', RT_RCDATA); ResourceStream.Position := 0; aSourceBmp.Fill.Bitmap.Bitmap.LoadFromStream(ResourceStream); FreeAndNil(ResourceStream); if not aSourceBmp.Fill.Bitmap.Bitmap.IsEmpty then begin aBitmap.SetSize(aSourceBmp.Fill.Bitmap.Bitmap.Width, aSourceBmp.Fill.Bitmap.Bitmap.Height); aBitmap.Assign(aSourceBmp.MakeScreenshot); AItem.Data['ImageState'] := lvStudentsItemImageLoaded; end; exit; end; AItem.Data['ImageState'] := lvStudentsItemImageLoading; K := AItem.Index;// Запоминаем индекс в локальную K, которая уйдёт в анонимку (время жизни K > времени жизни анонимки) FHTTPClient := THTTPClient.Create; FAsyncResultList.Items[K] := FHTTPClient.BeginGet( procedure (const ASyncResult: IAsyncResult) var AHTTPResponse: IHTTPResponse; begin if ASyncResult.IsCancelled then Exit; try AHTTPResponse := THTTPClient.EndAsyncHTTP(ASyncResult); if Not Assigned(AHTTPResponse) then Exit; if AHTTPResponse.StatusCode <> 200 then Exit; except Exit; end; TThread.Synchronize(Nil, procedure begin if FlvSostavUpdating or ASyncResult.IsCancelled then // Выходим, так как внутри анонимной процедуры AItem - не сброшены в nil, хотя их уже может и не быть Exit; if Not Assigned(AItem) then Exit; aSourceBmp.Fill.Bitmap.Bitmap.LoadFromStream(AHTTPResponse.ContentStream); if not aSourceBmp.Fill.Bitmap.Bitmap.IsEmpty then begin aBitmap.SetSize(aSourceBmp.Fill.Bitmap.Bitmap.Width, aSourceBmp.Fill.Bitmap.Bitmap.Height); aBitmap.Assign(aSourceBmp.MakeScreenshot); AItem.Data['ImageState'] := lvStudentsItemImageLoaded; FAsyncResultList.Items[K]:= nil; end end ); end, AURL ); end; Под WIN все грузится, под MacOS нет... -
Добрый день! можете дать пример реализации?
-
Помогите с помощью ISuperObject добраться до "phone_number":"79261060000" и user_id":57548 . То есть нужно найти и вернуть user_id":57548 по "phone_number":"79261060000" . {"ok":true,"result":[ {"update_id":789128,"message":{"message_id":6,"from":{"id":57548,"is_bot":false,"first_name":"\u0414\u0438\u043c\u0430","username":"smarik","language_code":"ru"},"chat":{"id":57548,"first_name":"\u0414\u0438\u043c\u0430","username":"smarik","type":"private"},"date":1560429,"text":"Sendcontact"}}, {"update_id":78129,"message":{"message_id":7,"from":{"id":57548,"is_bot":false,"first_name":"\u0414\u0438\u043c\u0430","username":"smarik","language_code":"ru"},"chat":{"id":57548,"first_name":"\u0414\u0438\u043c\u0430","username":"smarik","type":"private"},"date":156628,"contact":{"phone_number":"79261060000","first_name":"\u0414\u0438\u043c\u0430","user_id":57548}}},{"update_id":7886830, "message":{"message_id":11,"from":{"id":57348,"is_bot":false,"first_name":"\u0414\u0438\u043c\u0430","username":"smarik","language_code":"ru"},"chat":{"id":578,"first_name":"\u0414\u0438\u043c\u0430","username":"smarik","type":"private"},"date":1560911,"text":"\u041f\u043f"}}]}
-
а как это сделать c XSuperJSON?
-
Евгений, спасибо!
-
вроде работает, но за код php не уверен, что так правильно..
-
Подскажите, пжл, правильно ли принимаю на сервере JSON или нет. код вроде рабочий, но сомнения есть (т.к. опыта с PHP нет) формирую json и передаю его на сервер: procedure TfmNewGroup.Button1Click(Sender: TObject); var JSON: ISuperObject; Arr: ISuperArray; str: string; begin JSON:=TSuperObject.Create(); JSON.I['lessongrid_idpartner'] := 2; JSON.I['lessongrid_type'] := cbDirect.ListItems[cbDirect.ItemIndex].Tag; JSON.I['lessongrid_idpointcity'] := cbPoint.ListItems[cbPoint.ItemIndex].Tag;; JSON.I['lessongrid_iddircourses'] := cbDirCourse.ListItems[cbDirCourse.ItemIndex].Tag; JSON.I['lessongrid_idteacher'] := cbTeacher.ListItems[cbTeacher.ItemIndex].Tag; Arr:=TSuperArray.Create(); Arr.Add(FormatDateTime('t',tedSun.Time)); Arr.Add(FormatDateTime('t',tedM.Time)); Arr.Add(FormatDateTime('t',tedT.Time)); Arr.Add(FormatDateTime('t',tedW.Time)); Arr.Add(FormatDateTime('t',tedTh.Time)); Arr.Add(FormatDateTime('t',tedF.Time)); Arr.Add(FormatDateTime('t',tedS.Time)); JSON.A['schedule']:=arr; str:=JSON.AsJSON(); PostURL('http://is.sitename.ru/Ins.php',str); end; function PostURL(const aurl, json: string): string; var HTTPClient : THTTPClient; HttpResponse: IHttpResponse; JsonToSend: TStringStream; begin result:= ''; HTTPClient:= THTTPClient.Create; JsonToSend := TStringStream.Create(Json); with HTTPClient do try try if (Head('https://google.com').StatusCode < 400) then HttpResponse := Post(aurl,JsonToSend); Result := HttpResponse.ContentAsString(); except on E: exception do ShowMessage('Ошибка сети: '+E.Message); end; finally FreeAndNil(HTTPClient); FreeAndNil(JsonToSend); end; end; сформированный json: {"lessongrid_idpartner":2,"lessongrid_type":0,"lessongrid_idpointcity":1,"lessongrid_iddircourses":1,"lessongrid_idteacher":1,"schedule":["0:00","5:00","0:00","0:00","0:00","0:00","0:00"]} на сервере принимаю: <?php $s = file_get_contents("php://input", "r"); $obj=json_decode($s); echo $obj->schedule[2]; //так обращаюсь к массиву echo $obj->lessongrid_type; // так обращаюсь к конкретному параметру в JSon ?>
-
В ранее приложенном проекте код как у Евгений (KeeperWorld). В итоге я сделал так: procedure TForm1.Button2Click(Sender: TObject); var xJS, xObj: ISuperObject; vItemList, iHeader: TListViewItem; aJSON, URL: string; j: integer; begin ... with xJS.A['data'] do begin for j := 0 to length - 1 do begin xObj := O[j]; vItemList:= aLV.Items.Add; with vItemList do begin Text := ...; Data['sign_URL'] := 'http://is.kidscoders.ru/'+xObj.S['students_photo']; Data['sign_Loaded'] := 0; end; end; end; end; procedure TForm1.LoadBitmapFromURL(const AURL: string; aBitmap: TBitmap); var thread: TThread; begin thread := TThread.CreateAnonymousThread( procedure var HTTP: THTTPClient; HttpResponse: IHttpResponse; Result: TMemoryStream; ResourceStream: TResourceStream; begin Result := TMemoryStream.Create; HTTP := THTTPClient.Create; try try HttpResponse:= HTTP.Get(AURL, Result); if (HTTPResponse.StatusCode <> 200) then //если нет изображения на сервере, то default img begin ResourceStream := TResourceStream.Create(hInstance, 'PngImage_1', RT_RCDATA); ResourceStream.Position := 0; Result.LoadFromStream(ResourceStream); FreeAndNil(ResourceStream); end; TThread.Synchronize(TThread.CurrentThread, procedure var aSourceBmp: TBitmap; begin aSourceBmp := TBitmap.Create; aSourceBmp.LoadFromStream(Result); if not aSourceBmp.IsEmpty then begin aBitmap.SetSize(aSourceBmp.Width, aSourceBmp.Height); aBitmap.CopyFromBitmap(aSourceBmp); end; FreeAndNil(aSourceBmp); end); except FreeAndNil(Result); end; finally FreeAndNil(Result); FreeAndNil(HTTP); end; end); thread.FreeOnTerminate := true; thread.start; end; procedure TForm1.aLVUpdatingObjects(const Sender: TObject; const AItem: TListViewItem; var AHandled: Boolean); begin if AItem.Data['sign_Loaded'].AsInteger = 0 then begin AItem.Data['sign_Loaded'] := 1; LoadBitmapFromURL(AItem.Data['sign_URL'].AsString, AItem.Bitmap); end; end;
-
собрал в отдельный проект с указанным кодом и в итоге совсем картинки не грузятся... Projects.rar
-
FAsyncResultList.Items[K] := FHTTPClient.BeginGet(... странно, на этой строчке получаю ошибку "arguments out of range"
-
krapotkin, спасибо! Публикую, может кому-то пригодится.. на стороне PHP: $query1 = "SELECT ... FROM `...`;"; $query2 = "SELECT ... FROM `...`;"; $query3 = "SELECT ... FROM `...`;"; $query4 = "SELECT ... FROM `...`;"; function GetValuesAsJson($query, $Link) { if ($DBResult = mysqli_query($Link, $query)) { $ResultArray = array(); $Index = 0; while ($row = mysqli_fetch_array($DBResult, MYSQLI_ASSOC)) { $ResultArray[$Index] = $row; $Index++; } $ResultJSON = json_encode($ResultArray, JSON_PRETTY_PRINT | JSON_UNESCAPED_UNICODE); return $ResultJSON; mysqli_free_result($DBResult); } }; echo '{"Arr1":'. GetValuesAsJson($query1, $DBLink).', "Arr2":'.GetValuesAsJson($query2, $DBLink).', "Arr3":'.GetValuesAsJson($query3, $DBLink).', "Arr4":'.GetValuesAsJson($query4, $DBLink).'}'; mysqli_close($DBLink); на стороне delphi: xJS := SO(aJSON); with xJS.A['Arr1'] do // имя массива begin for j := 0 to length - 1 do begin xObj := O[j]; Memo1.Lines.Add(xObj.S['cities_name']); // собираем нужные данные ... end;