Einzelnen Beitrag anzeigen

Benutzerbild von KodeZwerg
KodeZwerg

Registriert seit: 1. Feb 2018
3.685 Beiträge
 
Delphi 11 Alexandria
 
#12

AW: Wallpaper und Windows 8+

  Alt 12. Okt 2018, 00:39
Code:
' Copyright © 2013 Dwight Grant. All rights reserved.
' Filename: Win8_WP_Curr_Image_Name-Folder.txt
' Version: 2.00.01
'
' Purpose: If (in Windows 8) running Desktop Wallpaper Slideshow:
'             To Display the Name of the Current Image (opt=1)
'                                     or
'             Display the Folder with the Current Image Selected (opt=2).
'
' This script reads and decodes registry key:
'     HKEY_CURRENT_USER\Control Panel\Desktop\TranscodedImageCache
'         and displays results on desktop
'
' How to Use -  Creation:
' 1. Save Text file at a location of your choosing.
' 2. Open Text file with "Notepad" and "Save As" same name with ".vbs" file type.
'      You will now have both "Win8_WP_Curr_Image_Name-Folder.txt" and
'                              "Win8_WP_Curr_Image_Name-Folder.vbs".
' 3. Create desktop shortcut to "Win8_WP_Curr_Image_Name-Folder.vbs".
'
' Operation: Double Click on the Desktop Icon Created,
'              Executes "Microsoft Windows Based Script Host" and
'                will display full path name of Wallpaper file.
'
'***  Author: Dwight Grant **** Revised: Nov. 27, 2013 ***
' based upon idea from Ramesh Srinivasan in program "WPTargetDir.vbs" for Win 7
' & revisions suggested by FleetCommand.
'
' ***  Please note: It is not unicode compliant - Path name needs to be ASCII to display properly.
'       If anyone has sugestions as to how to make it compliant, please explain, and I will try to
'            incorporate it into the next version.
' **********************************************************
Set Shell   = CreateObject("WScript.Shell")

strEr1       = "Error "
strSingle   = " "
strSelect   = " /select,"
strExplor   = "  "
opt         = 2         '1= Display File Name Only -  2=Display Folder w/ File Name Selected

strPath     = ""                         'Path Name w/ leading blanks removed
sQ1          = """"                       'A QUOTE mark
Results     = "  "

On Error Resume Next
arr         = Shell.RegRead("HKCU\Control Panel\Desktop\TranscodedImageCache")
If Err.Number <> 0 Then
     strEr1  = strEr1 & CStr(Err.Number)    'Set error display string
     msgbox strEr1,,"Win8 WP Curr Image Name" 'display error
     WScript.Quit
End If
On Error Goto 0

a           = arr
For I = LBound(arr) To Ubound(arr)        'Pull data from "arr" and convert to integer
a(I) = Cint(arr(I))                       'Store integer in array "a"
   if I > 23 then                         'Disregard the first 23 characters
       strSingle = Chr(a(I))              'Move byte in array "a" to "strSingle”
       if a(I) > 0 then                   'If byte > zero, use it, else ignore
           strPath = strPath & strSingle  'Add character to string for display
       end if
  end if
Next
       
' **********************************************************
if opt = 1 then
     msgbox strPath,,"The Wallpaper File Name is"  'Display results on desktop screen
end if
if opt = 2 then
     Results = sQ1 & strPath & sQ1
     strExplor = strSelect & Results
          'msgbox strExplor,,"The String Passed to Explorer is"    'Diagnostic Display
     return = Shell.run("explorer.exe" & strExplor,,true)
end if
' **********************************************************
Wscript.Quit
dieses .vbs script funktioniert auf fremdrechner.

edit
so habe ich es nun in delphi
Delphi-Quellcode:
procedure TForm1.Button1Click(Sender: TObject);
const
  CDataValue: string = 'TranscodedImageCache';
  CKeyName: string = 'Control Panel\Desktop\';
var
  regist: TRegistry;
  KeyExists: boolean;
  vSize, p, i: integer;
  tmpStr, tmp: string;
  arr: array of byte;
begin
// Edit1.Text := GetWallpaperBitmap;
  regist := TRegistry.Create;
  try
    regist.RootKey := HKEY_CURRENT_USER;
    try
      KeyExists := regist.OpenKey(CKeyName, false);
      if (KeyExists) then
      begin
        vSize := regist.GetDataSize(CDataValue);
        if (vSize > 0) then
        begin
          tmpStr := '';
          SetLength(arr, vSize);
          regist.ReadBinaryData(CDataValue, arr[0], vSize);
          for i := 23 to vSize -1 do
              if arr[i] > 31 then tmpStr := tmpStr + Chr(arr[i]);
          Edit1.Text := tmpStr;
        end;
      end;
    except
      regist.CloseKey;
    end
  finally
    regist.Free;
  end;
end;
Gruß vom KodeZwerg

Geändert von KodeZwerg (12. Okt 2018 um 00:59 Uhr)
  Mit Zitat antworten Zitat