Jump to content

Leaderboard


Popular Content

Showing content with the highest reputation on 09/14/20 in all areas

  1. Anders Melander

    RzLauncher vs. Win API call

    I have no idea about how TRzLauncher is implemented, but regardless I would just use a thin wrapper around ShellExecuteEx. Here's the implementation I usually use: unit amShell; (* * Copyright © 2006 Anders Melander * * This Source Code Form is subject to the terms of the Mozilla Public * License, v. 2.0. If a copy of the MPL was not distributed with this * file, You can obtain one at http://mozilla.org/MPL/2.0/. *) interface uses Windows, Controls; type Shell = class private public class procedure DisplayURL(const URL: string; Parent: TWinControl = nil; const AdditionalParams: string = ''); class function DisplayFile(const Filename: string; Parent: TWinControl = nil): boolean; class function Execute(const Filename: string; const Parameters: string = ''; Parent: TWinControl = nil; Wait: boolean = False): boolean; overload; class function Execute(Parent: TWinControl; const FileName: string; const Operation: string = 'open'; const Parameters: string = ''; ShowCmd: Integer = SW_SHOWNORMAL; Wait: boolean = False): boolean; overload; static; end; resourcestring sShellExecuteBrowseError = 'Failed to open the homepage in your default browser.'+#13#13+ 'Homepage: %s'+#13+ 'Error: %s'; sShellExecuteFileOpenError = 'Failed to open the file.'+#13#13+ 'Filename: %s'+#13+ 'Error: %s'; implementation uses ActiveX, ShellAPI, SysUtils, IOUtils, Forms, Dialogs, StrUtils, Classes, Types, Messages, IdURI, amCursorService, amDialogs; class function Shell.DisplayFile(const Filename: string; Parent: TWinControl): boolean; var Error: integer; begin Result := Execute(Parent, Filename); if (not Result) then begin Error := GetLastError; MessageDlgEx(Format(sShellExecuteFileOpenError, [Filename, SysErrorMessage(Error)]), mtWarning, [mbOk], 0); end; end; class function Shell.Execute(const Filename, Parameters: string; Parent: TWinControl; Wait: boolean): boolean; var Error: integer; begin Result := Execute(Parent, Filename, '', Parameters, SW_SHOWNORMAL, Wait); if (not Result) then begin Error := GetLastError; MessageDlgEx(Format(sShellExecuteFileOpenError, [Filename, SysErrorMessage(Error)]), mtWarning, [mbOk], 0); end; end; class procedure Shell.DisplayURL(const URL: string; Parent: TWinControl; const AdditionalParams: string); var Error: integer; URI: TIdURI; FinalURL: string; FinalParams: string; ParamList: TStringDynArray; s: string; Params: TStringList; n: integer; Name, Value: string; begin try URI := TIdURI.Create(URL); try // Note that we use TIdURI even with no additional params as we would still like to get the original params encoded (' '->'%20'). if (AdditionalParams <> '') then begin Params := TStringList.Create; try Params.CaseSensitive := False; // Create a Key/Value list of original parameters ParamList := SplitString(URI.Params, '&'); for s in ParamList do Params.Add(s); // Add additional parameters, overriding the original values if there are duplicates ParamList := SplitString(AdditionalParams, '&'); for s in ParamList do begin n := Pos('=', s); if (n <> 0) then begin // Key/Value pair Name := Copy(s, 1, n-1); Value := Copy(s, n+1, MaxInt); Params.Values[Name] := Value; end else // No value, just key Params.Values[s] := ''; end; // Build parameter string FinalParams := ''; for s in Params do if (FinalParams = '') then FinalParams := s else FinalParams := FinalParams + '&' + s; finally Params.Free; end; URI.Params := FinalParams; end; FinalURL := URI.URI; finally URI.Free; end; except on E: EIdURIException do begin s := URL; if (AdditionalParams <> '') then s := s + '(' + AdditionalParams + ')'; MessageDlgEx(Format('Invalid URL: %s'#13'%s', [s, E.Message]), mtWarning, [mbOk], 0); exit; end; end; if (not Execute(Parent, 'rundll32.exe', 'open', 'url.dll,FileProtocolHandler '+FinalURL)) then begin Error := GetLastError; MessageDlgEx(Format(sShellExecuteBrowseError, [FinalURL, SysErrorMessage(Error)]), mtWarning, [mbOk], 0); end; end; class function Shell.Execute(Parent: TWinControl; const FileName, Operation, Parameters: string; ShowCmd: Integer; Wait: boolean): boolean; var Handle: HWND; ShellExecuteInfo: TShellExecuteInfo; Error: integer; Res: Cardinal; Msg: TMsg; begin if (Parent <> nil) then Handle := Parent.Handle else Handle := Application.MainForm.Handle; FillChar(ShellExecuteInfo, SizeOf(ShellExecuteInfo), 0); ShellExecuteInfo.cbSize := SizeOf(ShellExecuteInfo); ShellExecuteInfo.fMask := SEE_MASK_FLAG_NO_UI or SEE_MASK_HMONITOR or SEE_MASK_NOZONECHECKS;// or SEE_MASK_NOCLOSEPROCESS; if (Wait) then ShellExecuteInfo.fMask := ShellExecuteInfo.fMask or SEE_MASK_NOCLOSEPROCESS or SEE_MASK_NOASYNC; ShellExecuteInfo.Wnd := Handle; ShellExecuteInfo.hMonitor := THandle(Application.MainForm.Monitor.Handle); // Cast to avoind range check error if (Operation <> '') then ShellExecuteInfo.lpVerb := PChar(Operation); if (FileName <> '') then ShellExecuteInfo.lpFile := PChar(FileName); if (Parameters <> '') then ShellExecuteInfo.lpParameters := PChar(Parameters); ShellExecuteInfo.lpDirectory := PChar(TPath.GetDirectoryName(Filename)); ShellExecuteInfo.nShow := ShowCmd; SaveCursor(crAppStart); Result := ShellAPI.ShellExecuteEx(@ShellExecuteInfo); if (not Result) then begin Error := GetLastError; if (Error = ERROR_ACCESS_DENIED) then begin // See: // * https://support.microsoft.com/en-us/kb/287087 // * http://wellsr.com/vba/2016/excel/use-vba-shellexecute-to-open-url-in-default-browser/ if (ShellAPI.ShellExecute(Handle, ShellExecuteInfo.lpVerb, ShellExecuteInfo.lpFile, ShellExecuteInfo.lpParameters, nil, CmdShow) > SE_ERR_DLLNOTFOUND) then Result := True else SetLastError(Error); end; end else if (Wait) then begin try while (True) do begin Res := MsgWaitForMultipleObjects(1, ShellExecuteInfo.hProcess, False, INFINITE, QS_PAINT); case Res of WAIT_OBJECT_0: break; WAIT_OBJECT_0+1: while (PeekMessage(Msg, 0, QS_PAINT shl 16, QS_PAINT shl 16, PM_REMOVE)) do begin if (Msg.message = WM_QUIT) then begin PostQuitMessage(Msg.wParam); exit; end; TranslateMessage(Msg); DispatchMessage(Msg); end; else break; end; end; finally CloseHandle(ShellExecuteInfo.hProcess); end; end; end; var NeedCoUninitialize: boolean = False; initialization // ShellExecute needs CoInitialize NeedCoUninitialize := Succeeded(CoInitializeEx(nil, COINIT_APARTMENTTHREADED or COINIT_DISABLE_OLE1DDE)); finalization if (NeedCoUninitialize) then CoUninitialize; end.
  2. Remy Lebeau

    proper way to check server up or down in rest application

    The best way to handle that is to perform an actual REST request, and handle any error it may produce. Move the code to a worker thread so that it doesn't block the UI thread.
  3. Angus Robertson

    Invalid Compiler Directive: 'MESSAGES'

    These MacOS changes are now in SVN and will be zipped overnight. Angus
  4. You are simplifying things here - yes some collections such as list<T> can easily give ref access to its items but other collections might not. Working around the fact that you are dealing with value type semantics by accessing items by ref (or even giving raw access to the storage array such as the List property in the RTL TList<T> does) is borderline imo.
  5. My number one argument for constraining on class in a generic type argument when possible is that you then can build most of the generic in a non generic layer and just put a small generic layer on top. That makes for less bloat.
  6. FPiette

    Getting microphone Volume and sound Volume

    https://docs.microsoft.com/en-us/windows/win32/coreaudio/volume-controls
  7. I would use "Exit;". Having nearly same needs and have a created a tObject for managing a tDictionary<string, __myrecord> to manage everything ... very fast IMO. Be sure to use "MonitorEnter" and MonitorExit if this can be used in multithreaded applications like function tmyComponent.getvaluerecord(vName: string; const vDefaultValue: variant): __MyRecord; var vValue:__MyRecord; begin if MonitorEnter(fDATA, fMonitorTimeout) then begin try vname:=trim(lowercase(vname)); if fData.TryGetValue(vname, result)=false then begin // we don't have that key in dictionary ... return default value ... or create a new entry etc.. result.vwert:=vDefaultValue; result.isObject:=false; result.isFile:=false; result.doFreeObject:=false; result.vcomponent:=nil; result.vname:=''; result.vdtstamp:=0; result.vtype:=''; result.vgroup:=''; end; finally MonitorExit(fDATA); end; end; end;
  8. Mahdi Safsafi

    Filter Exception causing debugger errors

    You can get that info from the Parsed structure (see GetExceptionObjectNew) like this : type TExceptionInformation = array [0 .. 14] of UInt64; // this is a UInt64 and not NativeUInt as RTL ! PExceptionInformation = ^TExceptionInformation; var Params: PExceptionInformation; P := @Parsed[0]; Inc(P, $A8); P := PPointer(P)^; // -----> Internal Exception record (not like RTL record !) Params := (Pointer(PByte(P) + $30)); // -----> ExceptionInformation params. I guess, you will need to adjust GetExceptionObjectNew to return the new extra information.
  9. Vincent Parrett

    tMainmenu, imagelist, high-dpi

    https://www.axialis.com/icons/ not cheap when you end up buying multiple sets to get what you need, but other than that there are many websites that do svg's which can be uses with this library - https://github.com/EtheaDev/SVGIconImageList
  10. Does anyone have experience designing developer express VCL skins? We need someone to design skins that mimic the modern MAC OS UI. The one that comes with DevEx is ancient. Please feel free to pass this on and if someone has experience contact us at jobs@denovosoftware.com. Thanks.
  11. What Remy's approach does is accomplish OO 'separation of concerns'--decomposing all the logic of 'Save' into those component parts which might be subject to independent change and testing. So while a bit more code initially, it's much more maintainable and reusable. The pattern is equally applicable whether the storage mechanism is a TList or a zillion record database--only the technical details of how find, inset, and update work need be addressed. The higher level application logic is stable because all the underlying technical details have been isolated out. bobD
×