rzshellopenform.pas

Raize控件汉化版

      Exit;
    end;
    while ( UINT( endc ) > UINT( minpos ) ) and ( endc <> pwc ) and ( endc^ <> WideChar( '\' ) ) do
      Dec( endc );
    endc^ := WideChar( #0 );
  end;


  procedure StrAppendW( pdest, ptoappend: PWideChar );
  var len: Integer;
  begin
    len := StrLenW( pdest );
    pdest := PWideChar( Integer( pdest )+len*2 );
    while ptoappend^ <> WideChar( #0 ) do
    begin
      pdest^ := ptoappend^;
      Inc( pdest );
      Inc( ptoappend );
    end;
    pdest^ := WideChar( #0 );
  end;


  procedure GetTokenAndAdvance( var pwc: PWideChar;  ptoken: PWideChar );
  var ptok: PWideChar;
  begin
    ptok := ptoken;
    while ( pwc^ <> WideChar( #0 ) ) and ( pwc^ <> WideChar( '\' ) ) do
    begin
      ptok^ := pwc^;
      Inc( pwc );
      Inc( ptok );
    end;
    if ( pwc^ = WideChar( '\' ) ) then Inc( pwc );
    ptok^ := WideChar( #0 );
  end; {GetTokenAndAdvance - local}


  procedure Merge;
  var token: array[0..MAX_PATH] of WideChar;
      pinentered: PWideChar;
      i, max: Integer;
  begin
    Move( wcCurrent, wcResult, ( Length( aCurrent )+1 )*2 );
    pinentered := @wcEntered[0];

    token[0] := WideChar( #0 );
    GetTokenAndAdvance( pinentered, @token[0] );
    while token[0] <> WideChar( #0 ) do
    begin
      if AllDots( @token[0] ) then
      begin
        max := StrLenW( token )-1;
        for i := 1 to max do
          RemoveRightmostElement( @wcResult[0] );
      end
      else
      begin
        if ( wcResult[0] <> WideChar( #0 ) ) then
          EnsureTrailingSlash( @wcResult[0], -1 );
        StrAppendW( @wcResult[0], @token[0] );
      end;
      token[0] := WideChar( #0 );
      GetTokenAndAdvance( pinentered, @token[0] );
    end;
  end; {Merge - local}


type
  TPathType = ( ptAbsDisk, ptAbsNet, ptRel, ptErr );

  function GetPathTypeW( pwc: PWideChar ): TPathType;
  var
    len: Integer;
  begin
    len := StrLenW( pwc );
    if ( len>=2 ) and ( ( pwc+1 )^ = WideChar( ':' ) ) then
      Result := ptAbsDisk
    else if ( len>=3 ) and ( ( pwc+0 )^ = WideChar( '\' ) ) and ( ( pwc+1 )^ = WideChar( '\' ) ) then
      Result := ptAbsNet
    else if ( pwc^ = WideChar( '\' ) ) then
      Result := ptAbsDisk // Just one slash means 'current drive root directory'
    else if ( len>0 ) then
      Result := ptRel
    else
      Result := ptErr;
  end; {GetPathTypeW - local}


var
  pwc: PWideChar;

begin {= ApplyPathname =}
  if ( Length( aCurrent )>2 ) and ( aCurrent[ Length( aCurrent ) ]='\' ) then
    Delete( aCurrent,Length( aCurrent ),1 );

  stringToWideChar( aCurrent, @wcCurrent[0], Sizeof( wcCurrent ) );
  stringToWideChar( aEntered, @wcEntered[0], Sizeof( wcEntered ) );

  wcResult[0] := WideChar( #0 );

 // Determine if the entered string is an absolute path, if so we can ignore aCurrent
  case GetPathTypeW( wcEntered ) of
    ptAbsDisk:
      begin
        if wcEntered[0] = WideChar( '\' ) then
        begin
          case GetPathTypeW( wcCurrent ) of
            ptAbsDisk:
              begin
                wcResult[0] := wcCurrent[0];
                wcResult[1] := wcCurrent[1];
                wcResult[2] := WideChar( #0 );
              end;
            ptAbsNet:
              begin
                Move( wcCurrent, wcResult, ( Length( aCurrent )+1 )*2 );
                pwc := GetMinimumSizePtr( wcResult, -1 );
                pwc^ := WideChar( #0 );
              end;
            else // can't be ptRel, by definition the current path must be an absolute path
          end;
          StrAppendW( @wcResult[0], @wcEntered[0] );
        end
        else if Length( aEntered )=2 then
        begin
          wcResult[0] := wcEntered[0];
          wcResult[1] := wcEntered[1];
          wcResult[2] := WideChar( '\' );
          wcResult[3] := WideChar( #0 );
        end
        else
          Move( wcEntered, wcResult, ( Length( aEntered )+1 )*2 );
      end;

    ptAbsNet:
      begin
        Move( wcEntered, wcResult, ( Length( aEntered )+1 )*2 );
      end;

    ptRel:
      begin
        Merge;
      end;
    else
  end; {case}

  Result := WideCharTostring( @wcResult[0] );
end; {= ApplyPathname =}


function IsFileReadOnly( aFile: string ): Boolean;
var dw: DWORD;
begin
  dw := Windows.GetFileAttributes( PChar( aFile ) );
  Result := ( ( dw <> $FFFFFFFF ) and ( ( dw and FILE_ATTRIBUTE_READONLY )<>0 ) );
end;


function IsExtensionRegistered( const ext: string ): Boolean;
var r: TRegistry;
begin
  r := TRegistry.Create;
  try
    r.RootKey := HKEY_CLASSES_ROOT;
    Result := r.KeyExists( ext );
  finally
    r.Free;
  end;
end;


function MessageDlgCaption( const Caption, Msg: string; dlgType: TMsgDlgType; buttons: TMsgDlgButtons;
                            helpCtx: Integer ): Integer;
begin
  with Dialogs.CreateMessageDialog( Msg, dlgType, buttons ) do
    try
      Caption := Caption;
      HelpContext := helpctx;
      Result := ShowModal;
    finally
      Free;
    end;
end; {MessageDlgCaption}


procedure NotFound( const caption, filename: string );
begin
  MessageDlgCaption( caption, Format( SFileNotFound, [filename] ), mtWarning, [mbOk], 0 );
end;

function DoYouWishToCreateIt( const caption, filename: string ): Boolean;
begin
  Result := ( MessageDlgCaption( caption, Format( SDoesNotExistCreate, [filename] ), mtConfirmation, [mbYes, mbNo], 0 ) = mrYes );
end;

procedure NoReadOnlyReturn( const caption, filename: string );
begin
  MessageDlgCaption( Caption, Format( SExistsAndIsReadOnly, [filename] ), mtWarning, [mbOk], 0 );
end;

function FileExistsOverwrite( const caption, filename: string ): Boolean;
begin
  Result := ( MessageDlgCaption( caption, Format( SFileExistsReplace, [filename] ), mtWarning, [mbYes, mbNo], 0 ) = mrYes );
end;

procedure ThereCanBeOnlyOne( const caption, filename: string );
begin
  MessageDlgCaption( caption, Format( SThereCanBeOnlyOne, [filename] ), mtWarning, [mbOk], 0 );
end;

procedure ThisFilenameIsNotValid( const caption, filename: string );
begin
  MessageDlgCaption( caption, Format( SFilenameIsInvalid, [filename] ), mtWarning, [mbOk], 0 );
end;


{Returns True if a '*' or '?' char is found - DBCS enabled}
function AnyWildcardsDB( s: string ): Boolean;
var pos: Integer;
begin
  pos := 1;
  while ( pos <= Length( s ) ) do
  begin
    if IsDBCSLeadByte( Byte( s[pos] ) ) then
      Inc( pos,2 )
    else
    begin
      if ( s[pos] = '*' ) or ( s[pos] = '?' ) then
      begin
        Result := True;
        Exit;
      end;
      Inc( pos );
    end;
  end;
  Result := False;
end; {AnyWildcardsDB}


function AnyOfThisCharDB( const ins: string;  thisChar: Char ): Boolean;
var inpos: Integer;
begin
  inpos := 1;
  while ( inpos <= Length( ins ) ) do
  begin
    if IsDBCSLeadByte( Byte( ins[inpos] ) ) then
      Inc( inpos, 2 )
    else if ( ins[inpos] = thisChar ) then
    begin
      Result := True;
      Exit;
    end
    else
      Inc( inpos );
  end;
  Result := False;
end; {AnyOfThisCharDB}


procedure ParametizeDB_special( const ins: string;  outs: TStrings );
{$IFNDEF VCL30PLUS}
  function AnsiPos( const Substr, S: string ): Integer;
  begin
    Result := Pos( Substr, S );
  end;
{$ENDIF}
const WHITESPACE = [' ',#9];
var curs: string;
    state: ( sNormal, sInQuotes, sInWhitespace );
    inpos: Integer;
    curchar: Char;
    fIsDBCS: Boolean;
begin
  curs := '';
  state := sInWhitespace;
  inpos := 1;
  while ( inpos <= Length( ins ) ) do
  begin
    curchar := ins[inpos];
    fIsDBCS := IsDBCSLeadByte( Byte( curchar ) );
    case state of
      sNormal:
        begin
          if not fIsDBCS and ( curchar = '"' ) then
          begin
            curs := TrimRightDB( curs );
            if Length( curs )>0 then
            begin
              outs.Add( curs );
              curs := '';
            end;
            state := sInQuotes;
            Inc( inpos, 1 );
          end
          else
            CopyCharDB( inpos, ins, curs );
        end;

      sInQuotes:
        begin
          if not fIsDBCS and ( curchar = '"' ) then
          begin
            curs := TrimRightDB( curs );
            if Length( curs )>0 then
            begin
              outs.Add( curs );
              curs := '';
            end;
            state := sInWhitespace;
            Inc( inpos );
          end
          else
            CopyCharDB( inpos, ins, curs );
        end;

      sInWhitespace:
        begin
          if not fIsDBCS then
          begin
            if ( curchar = '"' ) then
            begin
              curs := '';
              state := sInQuotes;
            end
            else if not ( curchar in WHITESPACE ) then
            begin
              curs := curchar;
              state := sNormal;
            end;
            Inc( inpos, 1 );
          end
          else // fIsDBCS
          begin
            CopyCharDB( inpos, ins, curs );
            state := sNormal;
          end;
        end;
    end; {case}
  end; {while}

  curs := TrimRightDB( curs );
  if Length( curs )>0 then
    outs.Add( curs );
end; {ParametizeDB}



// Also input: all the selected items in ShellList
function TRzShellOpenSaveForm.ParseInputstring( const ins: string ): Boolean;
  function ApplyOptions( pathname: string;  options: TRzOpenSaveOptions ): Boolean;
  var fFileExists: Boolean;
  begin
    fFileExists := FileExists( pathname );
    if fFileExists then
    begin
      if IsFileReadOnly( pathname ) and ( osoNoReadOnlyReturn in options ) then
      begin
        NoReadOnlyReturn( Caption, pathname );
        Result := False;
        Exit;
      end;

      if ( osoOverwritePrompt in options ) then
      begin
        if not FileExistsOverwrite( Caption, pathname ) then
          begin Result := False; Exit; end;
      end;

      Result := True;
      Exit;
    end;
   // not FileExists

    if ( osoFileMustExist in options ) then
      begin NotFound( Caption, pathname ); Result := False; Exit; end;

    if ( osoCreatePrompt in options ) then
      if not DoYouWishToCreateIt( Caption, ExtractFileName( pathname ) ) then
        begin Result := False; Exit; end;

    Result := True;
  end; {ApplyOptions - local}

  function GetCurrentFolderPath: string;
  begin
    Result := ShellList.Folder.Pathname;
  end; {GetCurrentFolderPath - local}

  function IfFolderOpenIt( pathname: string ): Boolean;
  var dskishf, ishf: IShellFolder_NRC;
      fFileExists: Boolean;
      pidl: PItemIdList;
      wca: array[0..MAX_PATH] of WideChar;
      dw, dw2, dwAttrib, chEaten: DWORD;
  begin
    Result := False;

    dskishf:=nil; pidl:=nil; ishf:=nil;
    try
      stringToWideChar( pathname, @wca[0], SizeOf( wca ) );
      ShellGetDesktopFolder( dskishf );
      dw := dskishf.ParseDisplayName( Handle, nil, @wca[0], chEaten, pidl, dwAttrib );

      fFileExists := FileExists( pathname );
      if Succeeded( dw ) then
      begin
        dwAttrib := SFGAO_FOLDER;
        dw2 := dskishf.GetAttributesOf( 1, pidl, dwAttrib );
        if Succeeded( dw2 ) and ( not fFileExists ) and ( ( dwAttrib and SFGAO_FOLDER )<>0 ) then
        begin
          dw2 := dskishf.BindToObject( pidl, nil, IID_IShellFolder, Pointer( ishf ) );
          if Failed( dw2 ) then raise Exception.Create( SysErrorMessage( dw2 ) );
          ShellCombo.SelectedFolder.IdList := pidl;
          FileNameEdt.SelectAll;
          Result := True;
        end;
      end;
    finally
      if Assigned( ishf ) then ishf.Release;
      if Assigned( pidl ) then ShellMemFree( pidl );
      if Assigned( dskishf ) then dskishf.Release;
    end;
  end; {IfFolderOpenIt - local}

  function DereferenceShortcut( pathname: string ): string;
  var ld: TLinkData;
  begin
    if ( AnsiCompareText( ExtractFileExt( pathname ), '.lnk' )=0 ) and
       Succeeded( ResolveShortcut( pathname, ld, False ) ) and
       ( ld.pathname <> '' )
    then
      Result := ld.pathname
    else
      Result := pathname;
  end; {DereferenceShortcut - local}

  procedure HandleDefaultExt( var pathname: string );
    procedure HandleUnregisteredExt;
    var