| Pedrote |
13-01-2013 10:51:56 |
Problema con la Label en este código
Código:
procedure TForm1.Button3Click(Sender: TObject);
var
HttpResult: boolean;
manufacturers_es, manufacturers, media, Res, URLData: String ;
respuesta: TStringList;
begin
if test then
begin
if ConnDBEjActual then
begin
// Limpiamos el label
Label1.Caption := '';
if MessageDlg('Advertencia', AdvMsg, mtConfirmation, [mbYes, mbNo] ,0) = mrYes then
begin
Label1.Caption := 'En proceso .... espere';
// Desactivamos el resto de operaciones que puede realizar el usuario
Button1.Enabled := False;
Button2.Enabled := False;
// Exportamos los datos en xml
SQLQuery1.SQL.Text := 'SELECT ' +
'ROW_NUMBER() OVER(ORDER BY codigo) AS virtuemart_manufacturer_id, ' +
'LTRIM(RTRIM(NOMBRE)) AS mf_name, ' +
''''' AS mf_email, ' +
''''' AS mf_desc, ' +
''''' AS mf_url ' +
'FROM ['+ MSSQLConnection1.DatabaseName +'].[dbo].[marcas] '+
'FOR XML RAW';
SQLQuery1.Open;
while not SQLQuery1.EOF do
begin
manufacturers_es := manufacturers_es+ SQLQuery1.Fields[0].AsString;
SQLQuery1.Next;
end;
SQLQuery1.Close;
SQLQuery1.SQL.Text := 'SELECT ' +
''''' AS virtuemart_manufacturer_id, ' +
//'ROW_NUMBER() OVER(ORDER BY codigo) AS virtuemart_manufacturer_id, ' +
''''' AS virtuemart_manufacturercategories_id, ' +
''''' AS hits, ' +
'''1'' AS published, ' +
''''' AS created_on, ' +
''''' AS created_by, ' +
''''' AS modified_on, ' +
''''' AS modified_by, ' +
''''' AS locked_on, ' +
''''' AS locked_by ' +
'FROM ['+ MSSQLConnection1.DatabaseName +'].[dbo].[marcas] '+
'FOR XML RAW';
SQLQuery1.Open;
while not SQLQuery1.EOF do
begin
manufacturers := manufacturers + SQLQuery1.Fields[0].AsString;
SQLQuery1.Next;
end;
SQLQuery1.Close;
SQLQuery1.SQL.Text := 'SELECT ' +
// Obtenemos el nombre de fichero
'CASE ' +
'WHEN REVERSE(SUBSTRING(REVERSE(foto), 0, CHARINDEX(''\'', REVERSE(foto), 1))) != '''' THEN ' +
'''images/stories/virtuemart/manufacturer/'' +' +
'RTRIM(REVERSE(SUBSTRING(REVERSE(foto), 0, CHARINDEX(''\'', REVERSE(foto), 1)))) ' +
'ELSE ' +
''''' ' +
'END ' +
'AS file_url, ' +
'codigo AS slug ' +
'FROM ['+ MSSQLConnection1.DatabaseName +'].[dbo].[marcas] '+
'ORDER BY codigo ' +
'FOR XML RAW';
SQLQuery1.Open;
while not SQLQuery1.EOF do
begin
media := media + SQLQuery1.Fields[0].AsString;
SQLQuery1.Next;
end;
SQLQuery1.Close;
MSSQLConnection1.Connected := False;
// QUIZÁS HAYA QUE REVISAR SI EL SERVIDOR SIGUE EN PIE (NO IMPLEMENTADO)
// Mandamos los datos en formato xml al servidor
HTTP := THTTPSend.Create;
respuesta := TStringList.Create;
URLData := 'a=marcas&';
URLData := URLData + '&k=' + id + '&';
URLData := URLData + '&p=' + App + '&';
URLData := URLData + '&v=' + IntToStr(Version) + '&';
URLData := URLData + '&f=' + MD5Print(MD5File(ParamStr(0))) + '&';
URLData := URLData + 't1=' + manufacturers + '&';
URLData := URLData + '&ft1=' + MD5Print(MD5String(manufacturers)) + '&';
URLData := URLData + '&t2=' + manufacturers_es + '&';
URLData := URLData + '&ft2=' + MD5Print(MD5String(manufacturers_es)) + '&';
URLData := URLData + '&t3=' + media + '&';
URLData := URLData + '&ft3=' + MD5Print(MD5String(media)) + '&';
HTTP.Document.Write(Pointer(URLData)^, Length(URLData));
HTTP.MimeType := 'application/x-www-form-urlencoded';
HttpResult := HTTP.HTTPMethod('POST', UrlSrv);
//ShowMessage(URLData);
if HttpResult then
begin
respuesta.LoadFromStream(HTTP.Document);
Res := trim(respuesta.Text);
respuesta.Free;
//ShowMessage(Res);
// Si todo ha ido bien subimos las fotos
if Res = 'ok' then
begin
if SubirFotos(GetValIni('GENERAL', 'DirImgsMarcas'), '\*', GetValIni('FTP', 'DirImgsMarcas'), GetValIni('GENERAL', 'ImgsMarcasFecha')) then
begin
Label1.Caption := 'Marcas actualizadas correctamente';
end
else
begin
Label1.Caption := 'Se produjo un error al subir las fotos de las marcas, póngase en contacto con nosotros.';
end;
end
else
begin
Label1.Caption := Res;
end;
end
else
begin
Label1.Caption := 'No se ha podido conectar con el servidor, así que ha ' +
'sido imposible actualizar las marcas';
end;
HTTP.Free;
Button1.Enabled := True;
Button2.Enabled := True;
end;
end;
end;
end;
Cuándo termine de programar el procedimiento anterior y viendo que todo funcionaba correctamente me puse a comentar todas aquellas líneas que usaba para debugear, bien pues exactamente cuándo comente la línea " //ShowMessage(Res);" (esta línea me devuelve lo que vuelca php al procesarse el formulario que estoy mandando con Lazarus) dejó de funcionar lo correspondiente a estos dos label:
Uno es este:
Código:
// Limpiamos el label
Label1.Caption := '';
Y otro este:
Código:
Label1.Caption := 'En proceso .... espere';
Sin embargo el resto de Labels si los hace de forma correcta, puesto que cuando termina de ejecutarse el procedimiento y todo ha ido bien si muestra el mensaje "Marcas actualizadas correctamente".
Mencionar que al siguiente "if MessageDlg('Advertencia', AdvMsg, mtConfirmation, [mbYes, mbNo] ,0) = mrYes then" entra correctamente.
¿Cuál puede ser el problema es que por muchas vueltas que le doy no doy con el?¿Y la posible solución?. Gracias a todos de antemano. |
