1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:

procedure TMain.RebuildIconCache;
var
  news, olds: string;
  sz: integer;
const
  sr_WindowMetrics = 'Control Panel\Desktop\WindowMetrics\';
  sr_ShellIconSize = 'Shell Icon Size';
  WaitCursor: TCursor = crHourGlass;
  WaitCount: Integer = 0;
  SaveCursor: TCursor = crDefault;
  function WindowsDir: string;
  var
    buffer: array[0..255] of char;
  begin
    GetWindowsDirectory(@Buffer, SizeOf(buffer));
    Result := Buffer;
  end;
  function UpdateAllWindowsCallback(WHandle: HWnd; var Parm: Pointer): Boolean;
    stdcall;
  begin
    SendMessage(WHandle, WM_SETTINGCHANGE, 0, 0);
    Result := True;
  end;
  procedure UpdateAllWindows;
  begin
    EnumWindows(@UpdateAllWindowsCallback, WM_SETTINGCHANGE);
  end;
  function GetIconCacheFile: string;
  begin
    Result := WindowsDir + 'ShellIconCache';
  end;
  procedure DeleteIconCache;
  var
    sfile: string;
  begin
    sfile := GetIconCacheFile;
    if fileexists(sfile) then
    begin
      if deletefile(sfile) = false then
        showmessage('Can not erase file: ' + sfile);
    end;
    // QueryRestartWindows;
  end;
  function RefreshActiveDesktop: boolean;
  const
    CLSID_ActiveDesktop: TGUID = '{75048700-EF1F-11D0-9888-006097DEACF9}';
  var
    ActiveDesktop: IActiveDesktop;
  begin
    try
      ActiveDesktop := CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;
      ActiveDesktop.ApplyChanges(AD_APPLY_ALL or AD_APPLY_FORCE);
      Result := true;
    except
      Result := false;
    end;
  end;
  procedure RefreshDesktop;
  var
    wnd: THandle;
    fl: boolean;
  begin
    fl := RefreshActiveDesktop;
    if fl = false then
    begin
      wnd := FindWindow('Progman', 'Program Manager');
      if wnd <> 0 then
        SendMessage(wnd, WM_COMMAND, $A065, 0)
      else
        UpdateAllWindows;
    end;
  end;
  function regreadstring(MyKey: HKey; MyValue: string): string;
  var
    reg: TRegistry;
    mp, mv: string;
  begin
    Result := '';
    mp := MyValue;
    if pos('\', mp) > 0 then
    begin
      while (copy(mp, length(mp), 1) <> '\') do
        mp := copy(mp, 1, length(mp) - 1);
      mp := copy(mp, 1, length(mp) - 1);
      mv := copy(MyValue, length(mp), length(MyValue));
      while (pos('\', mv) > 0) do
        mv := copy(mv, 2, length(mv));
    end
    else
    begin
      mp := '';
      mv := '';
    end;
    try
      reg := TRegistry.Create;
      reg.RootKey := MyKey;
      reg.OpenKey(mp, false);
      if reg.ValueExists(mv) = true then
        Result := reg.ReadString(mv);
    finally
      FreeAndNil(reg);
    end;
  end;
  procedure regwritestring(MyKey: HKey; MyValue, NewValue: string);
  var
    reg: TRegistry;
    mp, mv: string;
  begin
    mp := MyValue;
    if pos('\', mp) > 0 then
    begin
      while (copy(mp, length(mp), 1) <> '\') do
        mp := copy(mp, 1, length(mp) - 1);
      mp := copy(mp, 1, length(mp) - 1);
      mv := copy(MyValue, length(mp), length(MyValue));
      while (pos('\', mv) > 0) do
        mv := copy(mv, 2, length(mv));
    end
    else
    begin
      mp := '';
      mv := '';
    end;
    try
      reg := TRegistry.Create;
      reg.RootKey := MyKey;
      reg.OpenKey(mp, true);
      reg.WriteString(mv, NewValue);
    finally
      FreeAndNil(reg);
    end;
  end;
  procedure StartWait;
  begin
    if WaitCount = 0 then
    begin
      SaveCursor := Screen.Cursor;
      Screen.Cursor := WaitCursor;
    end;
    Inc(WaitCount);
  end;
  procedure StopWait;
  begin
    if WaitCount > 0 then
    begin
      Dec(WaitCount);
      if WaitCount = 0 then
        Screen.Cursor := SaveCursor;
    end;
  end;
begin
  Startwait;
  try
    deletefile(GetIconCacheFile);
    olds := regreadstring(HKEY_CURRENT_USER, sr_WindowMetrics +
      sr_ShellIconSize);
    sz := strtointdef(olds, 32);
    inc(sz);
    news := inttostr(sz);
    regwritestring(HKEY_CURRENT_USER, sr_WindowMetrics + sr_ShellIconSize,
      news);
    UpdateAllWindows;
    if olds = '' then
      olds := '32';
    regwritestring(HKEY_CURRENT_USER, sr_WindowMetrics + sr_ShellIconSize,
      olds);
    UpdateAllWindows;
    RefreshDeskTop;
  finally
    StopWait;
  end;
end;