Operacje matematyczne

001 Zaokrąglenie liczby rzeczywistej w dół lub w górę oraz do najbliższej liczby całkowitej >>

002 Część całkowita i ułamkowa liczby rzeczywistej >>

003 Część całkowita i reszta z dzielenia liczby naturalnej n1 przez liczbę naturalną n2 >>

004 Największy wspólny dzielnik dla dwóch lub więcej liczb naturalnych >>

005 Najmniejsza wspólna wielokrotność dwóch lub więcej liczb naturalnych >>

006 Sprawdzenie czy liczba naturalna jest parzysta >>

007 Podniesienie liczby x do potęgi y >>

008 Logarytm o podstawie n z liczby x >>

009 Funkcja arctg >>

010 Funkcja arcctg >>

011 Konwersja radianów na stopnie >>

012 Konwersja stopni na radiany >>

013 Losowa liczba naturalna >>

014 Losowa liczba rzeczywista >>

015 Losowa liczba rzeczywista rozkładu Gaussa >>

016 Obliczanie odległości między dwoma współrzędnymi geograficznymi >>

017 Obliczanie godziny wschodu słońca dla danego dnia i współrzędnych geograficznych >>

018 Obliczanie godziny zachodu słońca dla danego dnia i współrzędnych geograficznych >>

Operacje związane z łańcuchami String

019 Kopiowanie fragmentu łańcucha String >>

020 Kopiowanie początkowych znaków łańcucha String >>

021 Kopiowanie końcowych znaków łańcucha String >>

022 Usunięcie wewnętrznego fragmentu z łańcucha String >>

023 Usunięcie białych znaków występujących na początku i na końcu łańcucha String >>

024 Konwersja łańcucha String na małe lub na duże litery >>

025 Zamiana w łańcuchu String wszystkich łańcuchów s1 na s2 >>

026 Odwrócenie kolejności znaków w łańcuchu String >>

027 Sprawdzenie czy n-ty znak łańcucha String jest cyfrą >>

028 Sprawdzenie pierwszej pozycji ciągu znaków s1 w innym ciągu znaków s2 >>

029 Sprawdzenie ostatniej pozycji ciągu znaków s1 w innym ciągu znaków s2 >>

030 Sprawdzenie ostatniej pozycji dowolnego ze znaków a, b lub c w ciągu znaków s >>

031 Sprawdzenie czy ciąg znaków s pasuje do maski >>

032 Zmiana długości łańcucha String >>

033 Sprawdzenie czy łańcuch String jest liczbą >>

034 Sprawdzenie czy łańcuch String jest liczbą całkowitą >>

035 Sprawdzenie czy łańcuch String jest liczbą naturalną >>

036 Sprawdzenie czy łańcuch String jest liczbą heksadecymalną >>

037 Formatowanie liczby rzeczywistej na łańcuch String z zaokrągleniem >>

038 Formatowanie liczby rzeczywistej na łańcuch String z cyframi znaczącymi >>

039 Formatowanie liczby całkowitej do określonej liczby cyfr >>

040 Formatowanie łańcucha String do określonej liczby znaków z wyrównaniem do lewej lub prawej >>

041 Konwersja zapisu liczby naturalnej z systemu dziesiętnego na heksadecymalny >>

042 Konwersja zapisu liczby naturalnej z systemu heksadecymalnego na dzisiętny >>

043 Konwersja zapisu liczby naturalnej z systemu dziesiętnego na binarny >>

044 Konwersja zapisu liczby naturalnej z systemu dziesiętnego na binarny o określonej liczbie cyfr >>

045 Konwersja zapisu liczby naturalnej z systemu binarnego na dzisiętny >>

046 Konwersja łańcucha String o postaci prostej na postać heksadecymalno-bajtową >>

047 Konwersja łańcucha String o postaci heksadecymalno-bajtowej na postać prostą >>

048 Konwersja łańcucha String o postaci prostej na postać Base64 >>

049 Konwersja łańcucha String o postaci Base64 na postać prostą >>

050 Lista wszystkich możliwych permutacji znaków w łańcuchu String >>

051 Sprawdzenie liczby kolumn w wierszu z wyborem znaku separatora kolumn >>

052 Odczytanie zawartości wskazanej kolumny wiersza z wyborem znaku separatora kolumn >>

053 Sprawdzenie liczby kolumn w wierszu gdzie separatorem jest ciąg spacji >>

054 Odczytanie zawartości wskazanej kolumny wiersza gdzie separatorem jest ciąg spacji >>

055 Odczytanie lewej i prawej wartości z pary oddzielonej separatorem wieloznakowym >>

056 Odczytanie ścieżki dostępowej z pełnej ścieżki pliku lub folderu >>

057 Odczytanie nazwy pliku z jego pełnej ścieżki >>

058 Odczytanie rozszerzenia pliku z jego pełnej ścieżki >>

059 Odczytanie nazwy pliku z pominięciem rozszerzenia z jego pełnej ścieżki >>

060 Zmiana rozszerzenia pliku w ciągu znaków zawierającym jego nazwę lub pełną ścieżkę >>

061 Konwersja pełnej ścieżki pliku lub folderu do formatu DOS 8.3 >>

062 Sprawdzenie czy łańcuch String przechowuje ścieżkę pliku lub folderu >>

063 Sprawdzenie czy łańcuch String przechowuje adres IPv4 >>

064 Sprawdzenie czy łańcuch String przechowuje adres IPv6 >>

065 Sprawdzenie czy łańcuch String przechowuje adres FQDN >>

066 Sprawdzenie czy łańcuch String przechowuje datę o postaci RRRR-MM-DD >>

067 Sprawdzenie czy łańcuch String przechowuje godzinę o postaci GG:MM:SS >>

068 Sprawdzenie czy łańcuch String przechowuje czas o postaci RRRR-MM-DD GG:MM:SS >>

Operacje związane z datą i czasem

069 Sprawdzenie aktualnej daty >>

070 Ustawienie wartości zmiennej TDateTime >>

071 Sprawdzenie wartości składowych zmiennej TDateTime >>

072 Sprawdzenie numeru dnia w roku, miesiącu i tygodniu dla zmiennej TDateTime >>

073 Sprawdzenie numeru tygodnia w roku dla zmiennej TDateTime >>

074 Zmiana wartości zmiennej TDateTime o zadany okres czasu >>

075 Ustawienie wartości zmiennej TDateTime na ostatnią milisekundę danego okresu >>

076 Sprawdzenie liczby dni w danym roku lub miesiącu >>

077 Sprawdzenie czy dany rok jest przestępny >>

078 Sprawdzenie kolejności dwóch zmiennych TDateTime >>

079 Sprawdzenie odstępu między dwiema zmiennymi TDateTime >>

080 Sprawdzenie aktualnego czasu UTC >>

081 Sprawdzenie czasu pracy systemu >>

082 Konwersja czasu z liczby sekund do postaci hh:mm:ss >>

083 Konwersja czasu z liczby milisekund do postaci hh:mm:ss >>

084 Konwersja czasu do postaci yyyy-mm-dd hh:mm:ss zzz >>

085 Sprawdzenie czy dany dzień wypada w okresie stosowania czasu letniego >>

086 Wstrzymanie aplikacji na zadany okres czasu >>

087 Wstrzymanie wątku na zadany okres czasu >>

Operacje związane z komponentem RichEdit

088 Wyłączenie zwijania tekstu w komponencie RichEdit >>

089 Zmiana szerokości odstępów kolejnych tabulacji na krotność 8 znaków >>

090 Zwiększenie maksymalnej pojemności komponentu RichEdit do 1 GB tekstu >>

091 Prawidłowe wyświetlanie tekstu zawierającego znak "ń" w komponencie RichEdit >>

092 Zmiana sposobu kodowania tekstu w komponencie RichEdit z Windows-1250 na UTF-8 >>

093 Zmiana sposobu kodowania tekstu w komponencie RichEdit z Windows-1250 na ISO-8859-2 >>

094 Zapisanie zawartości komponentu RichEdit do pliku bez dodatkowych znaków formatu RTF >>

095 Sprawdzenie numeru wiersza z kursorem karetki i jego pozycji w komponencie RichEdit >>

096 Ustawienie kursora karetki na pozycji X w wierszu Y w komponencie RichEdit >>

097 Sprawdzenie numeru pierwszego wiersza widocznego w komponencie RichEdit >>

098 Sprawdzenie numeru ostatniego wiersza widocznego w komponencie RichEdit >>

099 Przesunięcie obszaru roboczego komponentu RichEdit na samą górę lub sam dół >>

100 Przesunięcie obszaru roboczego komponentu RichEdit o jedną stronę w górę lub w dół >>

101 Przesunięcie obszaru roboczego komponentu RichEdit o 5 wierszy w górę lub w dół >>

102 Przesunięcie obszaru roboczego komponentu RichEdit tak aby n-ty wiersz był pierwszym widocznym >>

103 Przesunięcie obszaru roboczego komponentu RichEdit tak aby widoczny był kursor karetki >>

104 Sprawdzenie oraz ustawienie pozycji suwaków komponentu RichEdit >>

105 Sprawdzenie wysokości pojedynczego wiersza w komponencie RichEdit >>

106 Zmiana czcionki fragmentu tekstu w komponencie RichEdit >>

107 Zmiana koloru tła fragmentu tekstu w komponencie RichEdit >>

108 Sprawdzenie koloru tekstu w komponencie RichEdit >>

109 Kopiowanie tekstu z komponentu RichEdit do schowka >>

110 Kopiowanie tekstu z komponentu RichEdit poprzez Ctrl+C jako zwykły tekst >>

111 Wklejanie tekstu do komponentu RichEdit poprzez Ctrl+V jako zwykły tekst >>

112 Wycinanie tekstu z komponentu RichEdit poprzez Ctrl+X jako zwykły tekst >>

113 Powiązanie komponentu FindDialog z komponentem RichEdit >>

114 Powiązanie komponentu ReplaceDialog z komponentem RichEdit >>

115 Wyszukiwanie tekstu w komponencie RichEdit z wykorzystaniem klawisza F3 >>

116 Wprowadzanie tabulacji w komponencie RichEdit >>

117 Przesuwalna belka dzieląca dwa komponenty RichEdit >>

118 Synchronizacja suwaków dwóch komponentów RichEdit >>

119 Zmienna TStringList jako usprawnienie komponentu RichEdit >>

Operacje związane z wyglądem i zachowaniem okna aplikacji

120 Ukrycie okna aplikacji >>

121 Ukrycie paska tytułowego okna aplikacji >>

122 Ustawienie przeźroczystości dla okna aplikacji >>

123 Ustawienie trybu zawsze na wierzchu dla okna aplikacji >>

124 Zmiana tytułu aplikacji wyświetlanego na pasku zadań >>

125 Włączenie migania przycisku aplikacji na pasku zadań >>

126 Ukrycie przycisku aplikacji na pasku zadań >>

127 Blokada rozciągania okna aplikacji >>

128 Zmiana ograniczenia systemowego maksymalnych wymiarów okna aplikacji >>

129 Wywołanie akcji z chwilą maksymalizacji okna aplikacji >>

130 Blokada wybranych przycisków z prawego górnego rogu okna aplikacji >>

131 Odświeżenie wyglądu okna aplikacji >>

Operacje związane z myszą i klawiaturą

132 Sprawdzenie czy klawisz ScrollLock jest wciśnięty >>

133 Wywołanie wciśnięcia klawisza na klawiaturze >>

134 Wpisanie znaków z łańcucha String w miejsce ustawienia kursora karetki >>

135 Nadpisanie akcji wykonywanej przez system po wciśnięciu określonego klawisza na klawiaturze >>

136 Blokada klawisza PrintScreen >>

137 Blokada myszy oraz blokada klawiatury >>

138 Przesunięcie kursora myszy o X w poziomie oraz Y w pionie >>

139 Kliknięcie lewym przyciskiem myszy w punkcie X od lewej i Y od góry na ekranie >>

140 Ograniczenie pola w którym może poruszać się kursor myszy >>

141 Zamiana przycisków myszy >>

142 Ukrycie kursora myszy >>

Operacje związane z ekranem i pulpitem

143 Sprawdzenie wymiarów obszaru roboczego ekranu >>

144 Sprawdzenie rozdzielczości ekranu >>

145 Zmiana rozdzielczości ekranu >>

146 Zapisanie do pliku BMP widoku ekranu >>

147 Zapisanie do pliku BMP widoku aktywnego okna >>

148 Sprawdzenie czy kolor piksela na ekranie oddalonego o X od lewej oraz Y od góry jest czerwony >>

149 Zmiana tapety pulpitu >>

150 Ukrycie ikon na pulpicie >>

Operacje związane z plikami i folderami

151 Sprawdzenie czy plik istnieje >>

152 Kopiowanie pliku >>

153 Zmiana nazwy pliku >>

154 Kasowanie pliku >>

155 Sprawdzenie czy folder istnieje >>

156 Tworzenie nowego folderu >>

157 Kopiowanie folderu wraz z zawartością >>

158 Przenoszenie folderu wraz z zawartością >>

159 Kasowanie pustego folderu >>

160 Kasowanie folderu w którym mogą znajdować się pliki lub podfoldery >>

161 Zmiana nazwy folderu >>

162 Sprawdzenie rozmiaru pliku w bajtach >>

163 Sprawdzenie czy dwa pliki są identyczne >>

164 Wczytanie do komponentu ListBox nazw plików typu *.roz znajdujących się w danym folderze >>

165 Wczytanie do komponentu ListBox nazw plików typu *.roz znajdujących się w folderze i jego podfolderach >>

166 Wczytanie do komponentu ListBox nazw plików i folderów po przeniesieniu ich na formę >>

167 Wczytanie do komponentu ListBox nazw plików i folderów po przeniesieniu ich na jego obszar >>

168 Wczytanie do komponentu Edit nazwy pliku lub folderu po przeniesieniu go na jego obszar >>

169 Wczytanie do komponentu ListBox nazw plików i folderów po przeniesieniu ich na ikonę aplikacji >>

170 Sortowanie listy plików w komponencie ListBox z uwzględnieniem drzewa folderów >>

171 Otwarcie folderu zawierającego wskazany plik i zaznaczenie tego pliku >>

172 Przenoszenie pliku lub folderu do kosza >>

173 Wybranie innej nazwy pliku lub folderu gdy wybrana jest zajęta >>

174 Wybranie innej nazwy folderu gdy wybrana jest zajęta >>

175 Wczytanie zawartości pliku do komponentu RichEdit >>

176 Zapisanie zawartości komponentu RichEdit do pliku >>

177 Wczytanie zawartości pliku do łańcucha String >>

178 Zapisanie łańcucha String do pliku >>

179 Zapisanie ustawień aplikacji do pliku nazwa.ini >>

180 Wczytanie ustawień aplikacji z pliku nazwa.ini >>

181 Ustawienie plikowi atrybutu tylko do odczytu >>

182 Ustawienie plikowi atrybutu ukryty >>

183 Ustawienie plikowi atrybutu systemowy >>

184 Ustawienie plikowi atrybutu archiwalny >>

185 Sprawdzenie daty utworzenia, modyfikacji i ostatniego dostępu do pliku >>

186 Zmiana daty utworzenia, modyfikacji i ostatniego dostępu do pliku >>

187 Sprawdzenie ścieżki oraz nazwy pliku exe uruchomionek aplikacji >>

188 Obsługa pliku metodą "Otwórz za pomocą..." ze wskazaniem na własną aplikację >>

189 Dodanie pliku do autostartu w rejestrze systemowym >>

190 Tworzenie pliku z zasobu TResourceStream >>

191 Tworzenie twardego linku >>

192 Wczytanie wartości wybranej komórki z pliku Excel >>

Operacje związane z systemem Windows

193 Sprawdzenie wersji systemu Windows >>

194 Sprawdzenie ścieżki katalogu w którym jest zainstalowany system Windows >>

195 Sprawdzenie ścieżki katalogu systemowego >>

196 Sprawdzenie ścieżki pulpitu i innych katalogów systemowych >>

197 Wylogowanie użytkownika, wyłączenie lub zrestartowanie komputera >>

198 Wykonanie komendy w wierszu poleceń >>

199 Sprawdzenie czy istnieje klucz w rejestrze systemowym >>

200 Sprawdzenie czy istnieje wartość klucza w rejestrze systemowym >>

201 Odczytanie danych z wartości klucza w rejestrze systemowym >>

202 Dodanie wartości klucza do rejestru systemowego >>

203 Usunięcie wartości klucza z rejestru systemowego >>

Operacje związane z procesami

204 Uruchomienie procesu >>

205 Uruchomienie procesu i wstrzymanie aplikacji do jego zakończenia >>

206 Sprawdzenie identyfikatora procesu aplikacji >>

207 Sprawdzenie identyfikatora procesu okna o danym uchwycie >>

208 Zmiana priorytetu procesu aplikacji >>

209 Zmiana priorytetu danego procesu >>

210 Wczytanie do komponentu ListBox informacji o wszystkich uruchomionych procesach >>

211 Wczytanie do komponentu ListBox informacji o wszystkich uruchomionych wątkach >>

212 Wczytanie do komponentu ListBox wszystkich uchwytów danego procesu >>

213 Zakończenie danego procesu >>

Operacje związane z uchwytami okien

214 Wczytanie do komponentu ListBox tytułów, typów oraz uchwytów wszystkich otwartych okien >>

215 Ustalenie uchwytu i tytułu aktywnego okna >>

216 Ustalenie uchwytu okna o znanym tytule >>

217 Ustalenie uchwytu okna danego typu >>

218 Sprawdzenie czy okno o danym uchwycie istnieje >>

219 Sprawdzenie czy okno o danym uchwycie jest widoczne >>

220 Sprawdzenie czy okno o danym uchwycie jest zminimalizowane >>

221 Sprawdzenie czy okno o danym uchwycie jest zmaksymalizowane >>

222 Sprawdzenie czy okno o danym uchwycie jest w trybie zawsze na wierzchu >>

223 Zminimalizowanie lub ukrycie okna gdy znany jest jego uchwyt >>

224 Przeniesienie okna na wierzch lub na spód względem innych okien gdy znany jest jego uchwyt >>

225 Zamknięcie okna gdy znany jest jego uchwyt >>

Operacje związane z siecią i Internetem

226 Sprawdzenie czy komputer jest połączony z Internetem >>

227 Sprawdzenie adresu IP komputera >>

228 Sprawdzenie wszystkich adresów IP komputera >>

229 Sprawdzenie adresu MAC karty sieciowej >>

230 Zapisanie na dysku pliku z Internetu >>

231 Zapisanie na dysku pliku z Internetu z podaniem identyfikatora aplikacji >>

232 Zapisanie na dysku pliku z Internetu z paskiem postępu pobierania i obsługą błędów >>

233 Otwarcie strony internetowej w przeglądarce domyślnej >>

234 Otwarcie strony internetowej we wskazanej przeglądarce >>

235 Wczytanie do komponentu RichEdit kodu źródłowego strony internetowej >>

Pozostałe

236 Struktura pętli z użyciem polecenia break >>

237 Struktura pętli z użyciem etykiety i polecenia goto >>

238 Deklaracja tablic >>

239 Tablica dynamiczna >>

240 Ukrycie wszystkich komponentów Button na oknie aplikacji >>

241 Ustawienie kursora karetki na końcu tekstu wyświetlanego w komponencie Edit >>

242 Zaznaczenie całego tekstu z komponentu Edit poprzez Ctrl+A >>

243 Komponent Edit do którego można wpisać tylko liczbę naturalną >>

244 Powiązanie komponentów Edit i UpDown by działały jak SpinEdit >>

245 Poziomy suwak w komponencie ListBox >>

246 Przesunięcie obszaru roboczego komponentu StringGrid tak aby widoczna była komórka [x,y] >>

247 Ustawienie kursora karetki w komórce [x,y] komponentu StringGrid >>

248 Sprawdzenie szerokości i wysokości tekstu komponentu Label >>

249 Umieszczenie komponentu Label na komponencie ProgressBar >>

250 Zmiana koloru komponentu ProgressBar >>

251 Ograniczenie częstotliwości aktualizacji komponentu ProgressBar w przypadku bardzo długiej pętli >>

252 Ustawienie niestandardowego skrótu dla akcji komponentu ActionList >>

253 Białe kontenery kolorów niestandardowych w komponencie ColorDialog >>

254 Wyłączenie migania zaznaczonego komponentu ScrollBar >>

255 Wczytanie do komponentu Image obrazu z pliku JPEG >>

256 Zmiana wymiarów obrazu komponentu Image bez zmiany proporcji >>

257 Odtworzenie dźwięku w komponencie MediaPlayer >>

258 Przeniesienie skupienia (focus) na inny komponent >>

259 Dynamiczne tworzenie komponentów oraz nadpisywanie ich procedur >>

260 Odwołanie się do komponentu o danej nazwie >>

261 Konwersja koloru na składowe RGB formatu HTML >>

262 Bezwarunkowe zamknięcie aplikacji >>

263 Zamkniecie aplikacji jeżeli jest już uruchomiona jej kopia >>

264 Zamknięcie aplikacji z wyświetleniem komunikatu o błędzie krytycznym >>

265 Wyłączenie powiadomień o błędach aplikacji >>

266 Wyświetlenie komunikatu ShowMessage z podziałem tekstu na linie >>

267 Wyświetlenie komunikatu MessageBox z opcjami tak lub nie >>

268 Wyświetlenie komunikatu MessageDlg z wieloma opcjami >>

269 Zamaskowanie gwiazdkami tekstu wprowadzanego w okno InputBox >>

270 Wykonywanie wielu operacji równolegle z wykorzystaniem wątków >>

271 Sprawdzenie jakimi literami oznaczone są poszczególne partycje dysku >>

272 Sprawdzenie wolnej i całkowitej przestrzeni na dysku >>

273 Sprawdzenie numeru seryjnego partycji >>


Operacje matematyczne


001 Zaokrąglenie liczby rzeczywistej w dół lub w górę oraz do najbliższej liczby całkowitej
uses Math;

wDol:=Floor(x);

wGore:=Ceil(x);

doNajblizszej:=Round(x);

002 Część całkowita i ułamkowa liczby rzeczywistej
calkowita:=Int(x);
calkowita:=Trunc(x);

ulamkowa:=Frac(x);
uwaga: funkcja Int zwraca wartość typu Extended natomiast funkcja Trunc zwraca wartość typu Int64


003 Część całkowita i reszta z dzielenia liczby naturalnej n1 przez liczbę naturalną n2
calkowita:=n1 div n2;

reszta:=n1 mod n2;

004 Największy wspólny dzielnik dla dwóch lub więcej liczb naturalnych
function TForm1.NWD(n1,n2: Integer): Integer;
begin
while (n1>0) and (n2>0) do
 begin
 if n1>n2
  then n1:=n1 mod n2
  else n2:=n2 mod n1;
 end;
Result:=0;
if (n1>0) and (n2=0)
 then Result:=n1;
if (n2>0) and (n1=0)
 then Result:=n2;
end;
uwaga: szukając NWD dla więcej niż dwóch liczb należy zastosować rekurencję, przykładowo dla czterech liczb będzie to:
NWD(n1,NWD(n2,NWD(n3,n4)));

005 Najmniejsza wspólna wielokrotność dwóch lub więcej liczb naturalnych
function TForm1.NWW(n1,n2: Integer): Integer;
var nn: Integer;
begin
nn:=n1*n2;
while (n1>0) and (n2>0) do
 begin
 if n1>n2
  then n1:=n1 mod n2
  else n2:=n2 mod n1;
 end;
Result:=0;
if (n1>0) and (n2=0)
 then Result:=n1;
if (n2>0) and (n1=0)
 then Result:=n2;
if Result>0
 then Result:=nn div Result;
end;
uwaga: szukając NWW dla więcej niż dwóch liczb należy zastosować rekurencję, przykładowo dla czterech liczb będzie to:
NWW(n1,NWW(n2,NWW(n3,n4)));

006 Sprawdzenie czy liczba naturalna jest parzysta
if not Odd(n)
 then ShowMessage('Ta liczba jest parzysta');
uwaga: funkcja Odd zwraca wartość True jeżeli liczba n jest nieparzysta i dlatego należy zastosować negację


007 Podniesienie liczby x do potęgi y
function TForm1.Potega(x,y: Double): Double;
begin
if x=0
 then Result:=0
 else Result:=Exp(y*Ln(Abs(x)));
end;
uwaga: powyższa funkcja działa poprawnie również dla potęg ujemnych oraz ułamkowych (pierwiastków)


008 Logarytm o podstawie n z liczby x
function TForm1.Lognx(n,x: Double): Double;
begin
Result:=Ln(x)/Ln(n);
end;
uwaga: wprowadzone wartości x oraz n muszą być dodatnie


009 Funkcja arctg
uses Math;

function TForm1.ArcTg(x: Double): Duoble;
begin
Result:=ArcSin((x)/(Sqrt(1+x*x)));
end;
uwaga: wynik podawany jest w radianach


010 Funkcja arcctg
uses Math;

function TForm1.ArcCtg(x: Double): Duoble;
begin
Result:=ArcCos((x)/(Sqrt(1+x*x)));
end;
uwaga: wynik podawany jest w radianach


011 Konwersja radianów na stopnie
function TForm1.RadianyNaStopnie(rad: Double): Double;
begin
Result:=(360*rad)/(2*Pi);
end;

012 Konwersja stopni na radiany
function TForm1.StopnieNaRadiany(sto: Double): Double;
begin
Result:=(sto*2*Pi)/360;
end;

013 Losowa liczba naturalna
procedure TForm1.FormCreate(Sender: TObject);
begin
Randomize;
end;

n:=Random(5);
uwaga: powyższa funkcja zwróci losową wartość od 0 do 4


014 Losowa liczba rzeczywista
procedure TForm1.FormCreate(Sender: TObject);
begin
Randomize;
end;

x:=Random;
uwaga: powyższa funkcja zwróci losową liczbę z przedziału <0,1)


015 Losowa liczba rzeczywista rozkładu Gaussa
procedure TForm1.FormCreate(Sender: TObject);
begin
Randomize;
end;

x:=RandG(0,1);
uwaga: pierwszy parametr powyższej funkcji to wartość średnia rozkładu a drugi to odchylenie standardowe


016 Obliczanie odległości między dwoma współrzędnymi geograficznymi
function TForm1.OdlegloscGeograficzna(lat1,lat2,lon1,lon2: Double): Double;
var rmax,rmin,r,a,b,lon11,lon22: Double;
begin
rmax:=6378.24;
rmin:=6356.86;
lon11:=lon1;
lon22:=lon2;
if lon1-lon2>180
 then
  begin
  lon11:=180-lon1;
  lon22:=-180-lon2;
  end;
if lon2-lon1>180
 then
  begin
  lon11:=-180-lon1;
  lon22:=180-lon2;
  end;
r:=(rmax-(rmax-rmin)*Sin((lat1+lat2)*Pi/360));
a:=(lon22-lon11)*Cos(lat1*Pi/180);
b:=(lat2-lat1);
Result:=Sqrt(a*a+b*b)*Pi*r/0.18;
end;
uwaga: parametry lat1, lat2, lon1 i lon2 to odpowiednio szerokość i długość geograficzna dwóch punktów

uwaga: dopuszczalne wartości to od -180 do 180 dla długości i od -90 do 90 dla szerokości geograficznej

uwaga: parametr rmax określa promień Ziemi na równiku, zaś rmin na biegunach

uwaga: wynik podawany jest w metrach


017 Obliczanie godziny wschodu słońca dla danego dnia i współrzędnych geograficznych
uses Math;

function TForm1.WschodSlonca(r,m,d: Integer; szer,dlug: Double): String;
var wHour,wMin: String; j,cent,l,g,o,f,e,a,c,w: Double;
begin
j:=367*r-Int(7*(r+Int((m+9)/12))/4)+Int(275*m/9)+d-730531.5;
cent:=j/36525;
l:=4.8949504201433+628.331969753199*cent;
while l>6.28318530718
 do l:=l-6.28318530718;
g:=6.2400408+628.3019501*cent;
while g>6.28318530718
 do g:=g-6.28318530718;
o:=0.409093-0.0002269*cent;
f:=0.033423*Sin(g)+0.00034907*Sin(2*g);
e:=0.0430398*Sin(2*(l+f))-0.00092502*Sin(4*(l+f))-f;
a:=ArcSin(Sin(o)*Sin(f+l));
c:=(Sin(0.017453293*-0.833)-Sin(0.017453293*szer)*Sin(a))/(Cos(0.017453293*szer)*Cos(a));
w:=(Pi-(e+0.017453293*dlug+1*ArcCos(c)))*57.29577951/15;
wHour:=FloatToStr(Floor(w)+(Round(60*Frac(w)) div 60));
if Length(wHour)=1
 then wHour:='0'+wHour;
wMin:=FloatToStr(Round(60*Frac(w)) mod 60);
if Length(wMin)=1
 then wMin:='0'+wMin;
Result:=wHour+':'+wMin;
end;
uwaga: powyższa funkcja zwraca godzinę według czasu uniwersalnego (Greenwich)

uwaga: powyższa funkcja nie uwzględnia stosowania czasu letniego


018 Obliczanie godziny zachodu słońca dla danego dnia i współrzędnych geograficznych
uses Math;

function TForm1.ZachodSlonca(r,m,d: Integer; szer,dlug: Double): String;
var zHour,zMin: String; j,cent,l,g,o,f,e,a,c,z: Double;
begin
j:=367*r-Int(7*(r+Int((m+9)/12))/4)+Int(275*m/9)+d-730531.5;
cent:=j/36525;
l:=4.8949504201433+628.331969753199*cent;
while l>6.28318530718
 do l:=l-6.28318530718;
g:=6.2400408+628.3019501*cent;
while g>6.28318530718
 do g:=g-6.28318530718;
o:=0.409093-0.0002269*cent;
f:=0.033423*Sin(g)+0.00034907*Sin(2*g);
e:=0.0430398*Sin(2*(l+f))-0.00092502*Sin(4*(l+f))-f;
a:=ArcSin(Sin(o)*Sin(f+l));
c:=(Sin(0.017453293*-0.833)-Sin(0.017453293*szer)*Sin(a))/(Cos(0.017453293*szer)*Cos(a));
z:=(Pi-(e+0.017453293*dlug+(-1)*ArcCos(c)))*57.29577951/15;
zHour:=FloatToStr(Floor(z)+(Round(60*Frac(z)) div 60));
if Length(zHour)=1
 then zHour:='0'+zHour;
zMin:=FloatToStr(Round(60*Frac(z)) mod 60);
if Length(zMin)=1
 then zMin:='0'+zMin;
Result:=zHour+':'+zMin;
end;
uwaga: powyższa funkcja zwraca godzinę według czasu uniwersalnego (Greenwich)

uwaga: powyższa funkcja nie uwzględnia stosowania czasu letniego


Operacje związane z łańcuchami String


019 Kopiowanie fragmentu łańcucha String
s:=Copy(s,5,3)
uwaga: powyższe polecenie kopiuje 3 znaki począwszy od 5-go (czyli 5-ty, 6-ty i 7-my)


020 Kopiowanie początkowych znaków łańcucha String
uses StrUtils;

s:=LeftStr(s,3);
uwaga: powyższe polecenie kopiuje 3 początkowe znaki


021 Kopiowanie końcowych znaków łańcucha String
uses StrUtils;

s:=RightStr(s,3);
uwaga: powyższe polecenie kopiuje 3 końcowe znaki


022 Usunięcie wewnętrznego fragmentu z łańcucha String
Delete(s,2,5);
uwaga: powyższe polecenie usuwa 5 znaków począwszy od 2-go


023 Usunięcie białych znaków występujących na początku i na końcu łańcucha String
s:=Trim(s);
uwaga: powyższe polecenie usuwa spacje oraz znaki kontrolne (np. tabulacja)

uwaga: by usunąć tylko początkowe białe znaki należy zastosować następujące polecenie:
s:=TrimLeft(s);
uwaga: by usunąć tylko końcowe białe znaki należy zastosować następujące polecenie:
s:=TrimRight(s);

024 Konwersja łańcucha String na małe lub na duże litery
s:=AnsiLowerCase(s);
uwaga: zamiana ciągu znaków na duże litery odbywa się poprzez poniższe polecenie:
s:=AnsiUpperCase(s);

025 Zamiana w łańcuchu String wszystkich łańcuchów s1 na s2
s:=StringReplace(s,s1,s2,[rfReplaceAll]);
uwaga: jeżeli wielkość liter nie ma znaczenia to należy zastosować następujące polecenie:
s:=StringReplace(s,s1,s2,[rfReplaceAll,rfIgnoreCase]);
uwaga: by zamienić tylko pierwsze wystąpienie ciągu s1 to należy zastosować następujące polecenie:
s:=StringReplace(s,s1,s2,[]);

026 Odwrócenie kolejności znaków w łańcuchu String
uses StrUtils;

s:=ReverseString(s);

027 Sprawdzenie czy n-ty znak łańcucha String jest cyfrą
function TForm1.CzyCyfra(s: String; n: Integer): Boolean;
begin
if s[n] in ['0','1','2','3','4','5','6','7','8','9']
 then Result:=True
 else Result:=False;
end;

028 Sprawdzenie pierwszej pozycji ciągu znaków s1 w innym ciągu znaków s2
n:=Pos(s1,s2);
uwaga: powyższa funkcja zwraca liczbę 0 jeżeli ciąg znaków s2 nie zawiera ani jednego ciągu znaków s1

uwaga: w przypadku sprawdzania pozycji pojedynczego znaku c szybciej zadziała poniższa funkcja:
function TForm1.CharPos(c: Char; s: String): Integer;
var i: Integer;
begin
Result:=0;
for i:=1 to Length(s) do
 if s[i]=c
  then
   begin
   Result:=i;
   break;
   end;
end;
uwaga: powyższa funkcja zadziała analogicznie jak wywołanie Pos(c,s) ale szybciej zwróci wynik


029 Sprawdzenie ostatniej pozycji ciągu znaków s1 w innym ciągu znaków s2
uses StrUtils;

function TForm1.LastPos(s1,s2: String): Integer;
begin
Result:=Pos(ReverseString(s1),ReverseString(s2));
if Result<>0
 then Result:=Length(s2)-Length(s1)-Result+2;
end;
uwaga: powyższa funkcja zwraca liczbę 0 jeżeli ciąg znaków s2 nie zawiera ani jednego ciągu znaków s1


030 Sprawdzenie ostatniej pozycji dowolnego ze znaków a, b lub c w ciągu znaków s
n:=LastDelimiter('abc',s);
uwaga: powyższa funkcja zwraca liczbę 0 jeżeli ciąg znaków s nie zawiera ani jednego z wymienionych


031 Sprawdzenie czy ciąg znaków s pasuje do maski
function TForm1.CzyPasujeDoMaski(s,maska: String; znakS,znakM: Integer): Boolean;
begin
if Length(maska)>znakM
 then
  begin
  case maska[znakM+1] of
   '?':
    begin
    if Length(s)>znakS
     then Result:=CzyPasujeDoMaski(s,maska,znakS+1,znakM+1)
     else Result:=False;
    end;
   '*':
    begin
    while (Length(maska)>znakM+1) and (maska[znakM+2]='*') do
     znakM:=znakM+1;
    Result:=CzyPasujeDoMaski(s,maska,znakS,znakM+1)
            or ((Length(s)>znakS) and CzyPasujeDoMaski(s,maska,znakS+1,znakM));
    end;
   else
    begin
    if (Length(s)>znakS) and (s[znakS+1]=maska[znakM+1])
     then Result:=CzyPasujeDoMaski(s,maska,znakS+1,znakM+1)
     else Result:=False;
    end;
   end;
  end
 else
  begin
  if Length(s)>znakS
   then Result:=False
   else Result:=True;
  end;
end;
uwaga: w masce znak zapytania zastępuje dokładnie jeden dowolny znak a gwiazdka dowolny ciąg znaków (również pusty)

uwaga: funkcja działa rekurencyjnie i przy wywołaniu należy przypisać wartościom znakS i znakM liczbę 0

uwaga: poniżej funkcja alternatywna (niedopracowana i nieco wolniejsza ale umożliwiająca stosowanie zestawu znaków):
uses Masks;

function TForm1.CzyPasujeDoMaski(s,maska: String): Boolean;
begin
s:='a'+s+'z';
maska:='a'+maska+'z';
maska:=StringReplace(maska,'[','[[]',[rfReplaceAll]);
Result:=MatchesMask(s,maska);
end;
uwaga: w powyższej funkcji przy sprawdzaniu dopasowania nie jest brana pod uwagę wielkość liter

uwaga: wstawienie znaku "[" w nawias kwadratowy wyłącza jego specjalne znaczenie (określanie zestawu znaków)

uwaga: dodanie litery na początku i końcu rozwiązuje błąd dopasowania dla niektórych postaci maski


032 Zmiana długości łańcucha String
SetLength(s,5);
uwaga: w przypadku gdy łańcuch będzie dłuższy to końcowe znaki zostaną usunięte

uwaga: w przypadku gdy łańcuch będzie krótszy to polecenie wydłuży go do 5 znaków (dodając znaki przypadkowe)

uwaga: w łańcuchu String znaki indeksowane są od 1 zaś komórka o indeksie 0 przechowuje długość łańcucha


033 Sprawdzenie czy łańcuch String jest liczbą
function TForm1.CzyLiczba(s: String): Boolean;
begin
if StrToFloatDef(s,0)=StrToFloatDef(s,1)
 then Result:=True
 else Result:=False;
end;

034 Sprawdzenie czy łańcuch String jest liczbą całkowitą
function TForm1.CzyLiczbaCalkowita(s: String): Boolean;
begin
if StrToIntDef(s,0)=StrToIntDef(s,1)
 then Result:=True
 else Result:=False;
end;

035 Sprawdzenie czy łańcuch String jest liczbą naturalną
function TForm1.CzyLiczbaNaturalna(s: String): Boolean;
begin
if StrToIntDef(s,-1)<0
 then Result:=False
 else Result:=True;
end;

036 Sprawdzenie czy łańcuch String jest liczbą heksadecymalną
function TForm1.CzyLiczbaHex(s: String): Boolean;
var i: Integer;
begin
Result:=True;
if s=''
 then Result:=False
 else
  for i:=1 to Length(s) do
   if not (AnsiLowerCase(s)[i]
      in ['0','1','2','3','4','5','6','7','8','9','a','b','c','d','e','f'])
    then Result:=False;
end;

037 Formatowanie liczby rzeczywistej na łańcuch String z zaokrągleniem
s:=FormatFloat('0.000',1234.5678);
uwaga: w powyższym przykładzie (zaokrąglenie do 3 cyfr po przecinku) wynikiem będzie 1234.568


038 Formatowanie liczby rzeczywistej na łańcuch String z cyframi znaczącymi
s:=FloatToStrF(1234.5678,ffFixed,4,3);
uwaga: w powyższym przykładzie (3 cyfry po przecinku ale tylko 4 cyfry znaczące) wynikiem będzie 1235.000


039 Formatowanie liczby całkowitej do określonej liczby cyfr
function TForm1.OLC(n,c: Integer): String;
begin
Result:=IntToStr(n);
while Length(Result)<c do
 Result:='0'+Result;
end;

040 Formatowanie łańcucha String do określonej liczby znaków z wyrównaniem do lewej lub prawej
function TForm1.OLZwL(s: String; c: Integer): String;
begin
Result:=s;
while Length(Result)<c do
 Result:=Result+' ';
end;

function TForm1.OLZwP(s: String; c: Integer): String;
begin
Result:=s;
while Length(Result)<c do
 Result:=' '+Result;
end;

041 Konwersja zapisu liczby naturalnej z systemu dziesiętnego na heksadecymalny
hex:=IntToHex(n,1);
uwaga: wartość 1 określa minimalną liczbę znaków


042 Konwersja zapisu liczby naturalnej z systemu heksadecymalnego na dzisiętny
n:=StrToInt64('$'+hex);

043 Konwersja zapisu liczby naturalnej z systemu dziesiętnego na binarny
function TForm1.DecToBin(n: Integer): String;
begin
Result:='';
while n>0 do
 begin
 if Odd(n)
  then Result:='1'+Result
  else Result:='0'+Result;
 n:=n shr 1;
 end;
end;

044 Konwersja zapisu liczby naturalnej z systemu dziesiętnego na binarny o określonej liczbie cyfr
function TForm1.DecToBinOLC(n,c: Integer): String;
begin
Result:='';
while n>0 do
 begin
 if Odd(n)
  then Result:='1'+Result
  else Result:='0'+Result;
 n:=n shr 1;
 end;
while Length(Result)<c do
 Result:='0'+Result;
end;
uwaga: zmiennej c należy przypisać liczbę cyfr (bitów)


045 Konwersja zapisu liczby naturalnej z systemu binarnego na dzisiętny
function TForm1.BinToDec(b: String): Integer;
var i,p2: Integer;
begin
Result:=0;
p2:=1;
for i:=Length(b) downto 1 do
 begin
 if b[i]='1'
  then Result:=Result+p2;
 p2:=p2*2;
 end;
end;

046 Konwersja łańcucha String o postaci prostej na postać heksadecymalno-bajtową
function TForm1.StringToHexBytes(s: String): String;
var i: Integer;
begin
Result:='';
for i:=1 to Length(s) do
 Result:=Result+IntToHex(Ord(s[i]),2);
end;

047 Konwersja łańcucha String o postaci heksadecymalno-bajtowej na postać prostą
function TForm1.HexBytesToString(hexB: String): String;
var n: Integer;
begin
Result:='';
n:=1;
while (Length(Result)=n-1) and (Length(hexB)>=n*2)
      and (Ord(hexB[n*2-1]) in [48..57,65..70,97..102])
      and (Ord(hexB[n*2]) in [48..57,65..70,97..102]) do
 begin
 Result:=Result+Chr(StrToInt64('$'+hexB[n*2-1]+hexB[n*2]));
 n:=n+1;
 end;
if Length(Result)*2<Length(hexB)
 then Result:='';
end;

048 Konwersja łańcucha String o postaci prostej na postać Base64
const znaki64='0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/';

function TForm1.ZakodujBase64(s: String): String;
var i,a,b,c,n: Integer;
begin
Result:=s+s;
n:=0;
a:=0;
b:=0;
for i:=1 to Length(s) do
 begin
 c:=Ord(s[i]);
 b:=b*256+c;
 a:=a+8;
 while a>=6 do
  begin
  a:=a-6;
  c:=b div (1 shl a);
  b:=b mod (1 shl a);
  n:=n+1;
  Result[n]:=znaki64[c+1];
  end;
 end;
if a>0
 then
  begin
  c:=b shl (6-a);
  n:=n+1;
  Result[n]:=znaki64[c+1];
  end;
SetLength(Result,n);
end;

049 Konwersja łańcucha String o postaci Base64 na postać prostą
const znaki64='0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/';

function TForm1.OdkodujBase64(s: String): String;
var i,a,b,c,n: Integer;
begin
Result:=s;
n:=0;
a:=0;
b:=0;
for i:=1 to Length(s) do
 begin
 c:=Pos(s[i],znaki64)-1;
 if c>=0
  then
   begin
   b:=b*64+c;
   a:=a+6;
   if a>=8
    then
     begin
     a:=a-8;
     c:=b shr a;
     b:=b mod (1 shl a);
     c:=c mod 256;
     n:=n+1;
     Result[n]:=Chr(c);
     end;
   end;
  end;
SetLength(Result,n);
end;

050 Lista wszystkich możliwych permutacji znaków w łańcuchu String
procedure TForm1.Permutacje(s: String; k: Integer);
var i: Integer; cTemp: Char;
begin
if k=1
 then
  begin
  RichEdit1.Lines.Add(s);
  end
 else
  begin
  for i:=1 to k do
   begin
   cTemp:=s[k];
   s[k]:=s[i];
   s[i]:=cTemp;
   Permutacje(s,k-1);
   Tempc:=s[k];
   s[k]:=s[i];
   s[i]:=cTemp;
   end;
  end;
end;
uwaga: funkcja działa rekurencyjnie i przy wywołaniu należy przypisać wartości k długość zmiennej s


051 Sprawdzenie liczby kolumn w wierszu z wyborem znaku separatora kolumn
function TForm1.LiczbaKolumn(s,sep: String): Integer;
var i: Integer;
begin
Result:=1;
for i:=1 to Length(s) do
 if s[i]=sep
  then Result:=Result+1;
end;
uwaga: zmiennej sep przypisać należy znak który traktowany będzie jako separator kolumn (np. średnik)

uwaga: funkcja stosuje format CSV (np. gdy separatorem jest średnik to ciąg znaków ";tekst;" zawiera 3 kolumny)


052 Odczytanie zawartości wskazanej kolumny wiersza z wyborem znaku separatora kolumn
function TForm1.KolumnaNta(s,sep: String; n: Integer): String;
var n2,p,k: Integer;
begin
Result:='';
if n>0
 then
  begin
  s:=sep+s;
  n2:=0;
  p:=1;
  k:=1;
  while (n2<n) and (p<Length(s)) do
   begin
   p:=k;
   k:=p+1;
   while (k<=Length(s)) and (s[k]<>sep) do
    k:=k+1;
   n2:=n2+1;
   end;
  Result:=Copy(s,p+1,k-p-1);
  end;
end;
uwaga: zmiennej sep przypisać należy znak który traktowany będzie jako separator kolumn (np. średnik)

uwaga: funkcja stosuje format CSV (np. gdy separatorem jest średnik to ciąg znaków ";tekst;" zawiera 3 kolumny)


053 Sprawdzenie liczby kolumn w wierszu gdzie separatorem jest ciąg spacji
function TForm1.LiczbaKolumnSpacje(s: String): Integer;
var i: Integer;
begin
Result:=0;
s:=s+' ';
for i:=1 to Length(s)-1 do
 if (s[i]<>' ') and (s[i+1]=' ')
  then Result:=Result+1;
end;
uwaga: powyższa funkcja traktuje wielokrotne powtórzenie spacji jako jeden separator

uwaga: funkcja stosuje format tekstowy (np. ciąg znaków "   tekst   tekst   " zawiera 2 kolumny)


054 Odczytanie zawartości wskazanej kolumny wiersza gdzie separatorem jest ciąg spacji
function TForm1.KolumnaNtaSpacje(s: String; n: Integer): String;
var n2,p,k: Integer;
begin
Result:='';
if n>0
 then
  begin
  s:=' '+s;
  n2:=0;
  p:=1;
  while (n2<n) and (p<Length(s)) do
   begin
   while (p<Length(s)) and (s[p]=' ') do
    p:=p+1;
   if s[p]<>' '
    then n2:=n2+1;
   k:=p;
   while (k<Length(s)) and (s[k+1]<>' ') do
    k:=k+1;
   if n2=n
    then Result:=Copy(s,p,k-p+1)
    else p:=k+1;
   end;
  end;
end;
uwaga: powyższa funkcja traktuje wielokrotne powtórzenie spacji jako jeden separator

uwaga: funkcja stosuje format tekstowy (np. ciąg znaków "   tekst   tekst   " zawiera 2 kolumny)


055 Odczytanie lewej i prawej wartości z pary oddzielonej separatorem wieloznakowym
function TForm1.WartoscLewa(s,sep: String): String;
begin
if Pos(sep,s)>0
 then Result:=Copy(s,1,Pos(sep,s)-1)
 else Result:=s;
end;

function TForm1.WartoscPrawa(s,sep: String): String;
begin
if Pos(sep,s)>0
 then Result:=Copy(s,Pos(sep,s)+Length(sep),Length(s)-Pos(sep,s)-Length(sep)+1)
 else Result:='';
end;
uwaga: zmiennej sep przypisać należy ciąg znaków który traktowany będzie jako separator

uwaga: przykładowo wywołanie WartoscPrawa('przyczyna => skutek',' => ') zwróci ciąg znaków "skutek"


056 Odczytanie ścieżki dostępowej z pełnej ścieżki pliku lub folderu
s:=ExtractFilePath('C:\sciezka\nazwa.roz');

057 Odczytanie nazwy pliku z jego pełnej ścieżki
s:=ExtractFileName('C:\sciezka\nazwa.roz');

058 Odczytanie rozszerzenia pliku z jego pełnej ścieżki
s:=ExtractFileExt('C:\sciezka\nazwa.roz');
uwaga: powyższa funkcja zwraca również kropkę zatem wynikiem powyższego przykładu będzie ".roz"


059 Odczytanie nazwy pliku z pominięciem rozszerzenia z jego pełnej ścieżki
function TForm1.BezRozszerzenia(s: String): String;
begin
Result:=ExtractFileName(Copy(s,1,Length(s)-Length(ExtractFileExt(s))));
end;

060 Zmiana rozszerzenia pliku w ciągu znaków zawierającym jego nazwę lub pełną ścieżkę
s:=ChangeFileExt('C:\sciezka\nazwa.roz1','.roz2');

061 Konwersja pełnej ścieżki pliku lub folderu do formatu DOS 8.3
function TForm1.SciezkaDOS83(s: String): String;
var dos83: String; dlugosc: Integer;
begin
SetLength(dos83,MAX_PATH);
dlugosc:=GetShortPathName(PChar(s),PChar(dos83),MAX_PATH-1);
SetLength(dos83,dlugosc);
Result:=dos83;
end;
uwaga: przykładowo dla ścieżki C:\Documents and Settings\Administrator wynikiem będzie C:\DOCUME~1\ADMINI~1

uwaga: konwertowana ścieżka musi wskazywać na istniejący plik lub folder


062 Sprawdzenie czy łańcuch String przechowuje ścieżkę pliku lub folderu
function TForm1.CzySciezkaPoprawna(s: String): Boolean;
begin
if (Pos(':',s)=2) and (LastDelimiter(':',s)=2)
 then Result:=True
 else Result:=False;
if (Result) and (not (s[1] in ['a'..'z','A'..'Z']))
 then Result:=False;
if (Result) and (Length(s)>2) and (s[3]<>'\')
 then Result:=False;
if (Result) and (Pos('\\',s)>0)
 then Result:=False;
if (Result) and (Pos('.\',s)>0)
 then Result:=False;
if (Result) and (Pos(' \',s)>0)
 then Result:=False;
if (Result) and (s[Length(s)]='.')
 then Result:=False;
if (Result) and (s[Length(s)]=' ')
 then Result:=False;
if (Result) and (LastDelimiter('/*?"<>|',s)>0)
 then Result:=False;
end;

063 Sprawdzenie czy łańcuch String przechowuje adres IPv4
function TForm1.CzyAdresIPv4(ip: String): Boolean;
begin
Result:=True;
if not (StrToIntDef(Copy(ip,1,Pos('.',ip)-1),256) in [0..255])
 then Result:=False;
ip:=Copy(ip,Pos('.',ip)+1,Length(ip)-Pos('.',ip));
if not (StrToIntDef(Copy(ip,1,Pos('.',ip)-1),256) in [0..255])
 then Result:=False;
ip:=Copy(ip,Pos('.',ip)+1,Length(ip)-Pos('.',ip));
if not (StrToIntDef(Copy(ip,1,Pos('.',ip)-1),256) in [0..255])
 then Result:=False;
if not (StrToIntDef(Copy(ip,Pos('.',ip)+1,Length(ip)-Pos('.',ip)),256) in [0..255])
 then Result:=False;
end;

064 Sprawdzenie czy łańcuch String przechowuje adres IPv6
function TForm1.CzyAdresIPv6(ip: String): Boolean;
var n,liczbaDwukropkow,dlugoscBloku: Integer; podwojnyDwukropek: Boolean;
begin
if Length(ip)>39
 then Result:=False
 else Result:=True;
n:=1;
while (Result) and (n<=Length(ip)) do
 begin
 if not (ip[n] in ['0'..'9','a'..'f','A'..'F',':'])
  then Result:=False;
 n:=n+1;
 end;
n:=1;
dlugoscBloku:=0;
liczbaDwukropkow:=0;
podwojnyDwukropek:=False;
while (Result) and (n<=Length(ip)) do
 begin
 if ip[n]=':'
  then
   begin
   liczbaDwukropkow:=liczbaDwukropkow+1;
   if liczbaDwukropkow>7
    then Result:=False;
   if (dlugoscBloku=0) and (podwojnyDwukropek)
    then Result:=False;
   if (dlugoscBloku=0) and (not podwojnyDwukropek) and (n>1)
    then podwojnyDwukropek:=True;
   dlugoscBloku:=0;
   end
  else
   begin
   dlugoscBloku:=dlugoscBloku+1;
   if dlugoscBloku>4
    then Result:=False;
   end;
 n:=n+1;
 end;
if (liczbaDwukropkow<7) and (not podwojnyDwukropek)
 then Result:=False;
end;

065 Sprawdzenie czy łańcuch String przechowuje adres FQDN
function TForm1.CzyAdresFQDN(fqdn: String): Boolean;
var n,dlugoscBloku: Integer;
begin
if (Length(fqdn) in [1..253]) and (Ord(fqdn[1]) in [48..57,65..90,97..122])
 then Result:=True
 else Result:=False;
n:=1;
dlugoscBloku:=1;
while Result and (n<Length(fqdn)) do
 begin
 n:=n+1;
 if (not (Ord(fqdn[n]) in [45,46,48..57,65..90,97..122]))
  then Result:=False;
 if ((fqdn[n]='.') or (fqdn[n]='-')) and ((fqdn[n-1]='.') or (fqdn[n-1]='-'))
  then Result:=False;
 if fqdn[n]='.'
  then dlugoscBloku:=0
  else dlugoscBloku:=dlugoscBloku+1;
 if dlugoscBloku>63
  then Result:=False;
 end;
if (dlugoscBloku=n) or (fqdn[n]='.') or (fqdn[n]='-')
 then Result:=False;
end;

066 Sprawdzenie czy łańcuch String przechowuje datę o postaci RRRR-MM-DD
uses DateUtils;

function TForm1.CzyRRRRMMDD(s: String): Boolean;
begin
if (Length(s)=10)
  and (s[5]='-')
  and (s[8]='-')
  and (IsValidDate(StrToIntDef(Copy(s,1,4),-1),StrToIntDef(Copy(s,6,2),-1)
   ,StrToIntDef(Copy(s,9,2),-1)))
 then Result:=True
 else Result:=False;
end;

067 Sprawdzenie czy łańcuch String przechowuje godzinę o postaci GG:MM:SS
uses DateUtils;

function TForm1.CzyGGMMSS(s: String): Boolean;
begin
if (Length(s)=8)
  and (s[3]=':')
  and (s[6]=':')
  and (IsValidTime(StrToIntDef(Copy(s,1,2),-1),StrToIntDef(Copy(s,4,2),-1)
   ,StrToIntDef(Copy(s,7,2),-1),0))
 then Result:=True
 then Result:=False;
end;

068 Sprawdzenie czy łańcuch String przechowuje czas o postaci RRRR-MM-DD GG:MM:SS
uses DateUtils;

function TForm1.CzyDataGodzina(s: String): Boolean;
begin
if (Length(s)=19)
  and (s[5]='-')
  and (s[8]='-')
  and (s[11]=' ')
  and (s[14]=':')
  and (s[17]=':')
  and (IsValidDate(StrToIntDef(Copy(s,1,4),-1),StrToIntDef(Copy(s,6,2),-1)
   ,StrToIntDef(Copy(s,9,2),-1)))
  and (IsValidTime(StrToIntDef(Copy(s,12,2),-1),StrToIntDef(Copy(s,15,2),-1)
   ,StrToIntDef(Copy(s,18,2),-1),0))
 then Result:=True
 else Result:=False;
end;

Operacje związane z datą i czasem


069 Sprawdzenie aktualnej daty
s1:=DateToStr(Now)+' '+TimeToStr(Now);
s2:=DateTimeToStr(Now);

070 Ustawienie wartości zmiennej TDateTime
uses DateUtils;

dt:=EncodeDateTime(1999,12,31,23,59,59,0);

071 Sprawdzenie wartości składowych zmiennej TDateTime
uses DateUtils;

n:=YearOf(dt);
n:=MonthOf(dt);
n:=WeekOf(dt);
n:=DayOf(dt);
n:=HourOf(dt);
n:=MinuteOf(dt);
n:=SecondOf(dt);
n:=MilliSecondOf(dt);

072 Sprawdzenie numeru dnia w roku, miesiącu i tygodniu dla zmiennej TDateTime
uses DateUtils;

n:=DayOfTheYear(dt);
n:=DayOfTheMonth(dt);
n:=DayOfTheWeek(dt);
uwaga: w przypadku funkcji DayOfTheWeek pierwszym dniem tygodnia jest poniedziałek

uwaga: w przypadku alternatywnej funkcji DayOfWeek pierwszym dniem tygodnia jest niedziela


073 Sprawdzenie numeru tygodnia w roku dla zmiennej TDateTime
uses DateUtils;

n:=WeekOfTheYear(Now);

074 Zmiana wartości zmiennej TDateTime o zadany okres czasu
uses DateUtils;

dt:=IncYear(dt,-1);
dt:=IncMonth(dt,1);
dt:=IncDay(dt,2);
dt:=IncHour(dt,3);
dt:=IncMinute(dt,4);
dt:=IncSecond(dt,5);
dt:=IncMilliSecond(dt,6);
uwaga: dodatnia liczba jednostek czasu powoduje przesunięcie w stronę przyszłości a ujemna w stronę przeszłości


075 Ustawienie wartości zmiennej TDateTime na ostatnią milisekundę danego okresu
uses DateUtils;

dt:=EndOfTheYear(dt);
dt:=EndOfTheMonth(dt);
dt:=EndOfTheWeek(dt);
dt:=EndOfTheDay(dt);

dt:=EndOfAYear(1999);
dt:=EndOfAMonth(1999,12);
dt:=EndOfAWeek(1999,52);
dt:=EndOfADay(1999,12,31)

076 Sprawdzenie liczby dni w danym roku lub miesiącu
uses DateUtils;

n:=DaysInMonth(dt);
n:=DaysInYear(dt);

n:=DaysInAYear(1999);
n:=DaysInAMonth(1999,12);

077 Sprawdzenie czy dany rok jest przestępny
if IsLeapYear(1999)
 then ShowMessage('Ten rok jest przestępny')
 else ShowMessage('Ten rok nie jest przestępny');

078 Sprawdzenie kolejności dwóch zmiennych TDateTime
uses DateUtils;

n:=CompareDateTime(dt1,dt2);
uwaga: powyższa funkcja zwraca wartość -1 gdy dt1 jest przed dt2, wartość 1 gdy jest przeciwnie, a wartość 0 gdy są równe


079 Sprawdzenie odstępu między dwiema zmiennymi TDateTime
uses DateUtils;

n:=YearsBetween(dt1,dt2);
n:=MonthsBetween(dt1,dt2);
n:=WeeksBetween(dt1,dt2);
n:=DaysBetween(dt1,dt2);
n:=HoursBetween(dt1,dt2);
n:=MinutesBetween(dt1,dt2);
n:=SecondsBetween(dt1,dt2);
n:=MilliSecondsBetween(dt1,dt2);

x:=YearSpan(dt1,dt2);
x:=MonthSpan(dt1,dt2);
x:=WeekSpan(dt1,dt2);
x:=DaySpan(dt1,dt2);
x:=HourSpan(dt1,dt2);
x:=MinuteSpan(dt1,dt2);
x:=SecondSpan(dt1,dt2);
x:=MiliSecondSpan(dt1,dt2);
uwaga: powyższe funkcje zwracają wartość bezwzględną (bez znaku)

uwaga: funkcje z grupy Between zwracają liczbę całkowitą (z zaokrągleniem w dół)

uwaga: funkcje z grupy Span zwracają liczbę rzeczywistą (z ułamkiem po przecinku)


080 Sprawdzenie aktualnego czasu UTC
function TForm1.CzasUTC: TDateTime;
var sdt: TSystemTime;
begin
GetSystemTime(sdt);
Result:=SystemTimeToDateTime(sdt);
end;

081 Sprawdzenie czasu pracy systemu
n:=GetTickCount;
uwaga: powyższa funkcja zwraca liczbę milisekund od chwili uruchomienia komputera


082 Konwersja czasu z liczby sekund do postaci hh:mm:ss
function TForm1.SekundyHHMMSS(n: Integer): String;
begin
Result:=IntToStr(n mod 60);
if Length(Result)=1
 then Result:='0'+Result;
Result:=IntToStr((n mod 3600) div 60)+':'+Result;
if Length(Result)=4
 then Result:='0'+Result;
Result:=IntToStr(n div 3600)+':'+Result;
if Length(Result)=7
 then Result:='0'+Result;
end;

083 Konwersja czasu z liczby milisekund do postaci hh:mm:ss
function TForm1.MilisekundyHHMMSS(ms: Integer): String;
var h,m,s: Integer;
begin
h:=ms div 3600000;
m:=(ms mod 3600000) div 60000;
s:=((ms mod 3600000) mod 60000) div 1000;
Result:=Format('%s:%s:%s',[FormatFloat('00',h),FormatFloat('00',m),FormatFloat('00',s)]);
end;

084 Konwersja czasu do postaci yyyy-mm-dd hh:mm:ss zzz
s:=FormatDateTime('yyyy-mm-dd hh:mm:ss zzz',Now);

085 Sprawdzenie czy dany dzień wypada w okresie stosowania czasu letniego
uses DateUtils;

function TForm1.CzyCzasLetni(dt: TDateTime): Boolean;
var i: Integer; start,stop: TDateTime; tzi: TTimeZoneInformation;
begin
GetTimeZoneInformation(tzi);
start:=EncodeDateTime(YearOf(dt),tzi.DaylightDate.wMonth,1
 ,tzi.DaylightDate.wHour,tzi.DaylightDate.wMinute,tzi.DaylightDate.wSecond,0);
if tzi.DaylightDate.wDay=5
 then
  begin
  start:=DateOf(EndOfTheMonth(start))+TimeOf(start);
  while Pred(DayOfWeek(start))<>tzi.DaylightDate.wDayOfWeek do
   start:=IncDay(start,-1)
  end
 else
  begin
  while Pred(DayOfWeek(start))<>tzi.DaylightDate.wDayOfWeek do
   start:=IncDay(start);
  for i:=1 to Pred(tzi.DaylightDate.wDay) do
   start:=IncWeek(start)
  end;
stop:=EncodeDateTime(YearOf(dt),tzi.StandardDate.wMonth,1
 ,tzi.StandardDate.wHour,tzi.StandardDate.wMinute,tzi.StandardDate.wSecond,0);
if tzi.StandardDate.wDay=5
 then
  begin
  stop:=DateOf(EndOfTheMonth(stop))+TimeOf(stop);
  while Pred(DayOfWeek(stop))<>tzi.StandardDate.wDayOfWeek do
   stop:=IncDay(stop,-1)
  end
 else
  begin
  while Pred(DayOfWeek(stop))<>tzi.StandardDate.wDayOfWeek do
   stop:=IncDay(stop);
  for i:=1 to Pred(tzi.StandardDate.wDay) do
   stop:=IncWeek(stop)
  end;
Result:=(dt>=start) and (dt<stop);
end;

086 Wstrzymanie aplikacji na zadany okres czasu
Sleep(1000);
uwaga: parametr powyższej funkcji to czas wstrzymania w milisekundach

uwaga: powyższa procedura powoduje zamrożenie okna aplikacji


087 Wstrzymanie wątku na zadany okres czasu
procedure TForm1.DelayMS(ms: Cardinal);
var t0: Cardinal;
begin
t0:=GetTickCount;
while (GetTickCount<t0+ms) do
 begin
 Application.ProcessMessages;
 Sleep(1);
 end;
end;
uwaga: powyższa procedura nie powoduje zamrożenia okna aplikacji


Operacje związane z komponentem RichEdit


088 Wyłączenie zwijania tekstu w komponencie RichEdit
RichEdit1.WordWrap:=False;
uwaga: właściwość tę ustawić można również w inspektorze obiektów


089 Zmiana szerokości odstępów kolejnych tabulacji na krotność 8 znaków
procedure TForm1.UstawSzerokoscTabulacjiRichEdit(re: TObject; liczbaZnakow: Integer);
var pf: TParaFormat; i,szerokoscZnaku: Integer;
begin
FillChar(pf,SizeOf(pf),0);
pf.cbSize:=SizeOf(pf);
pf.dwMask:=PFM_TABSTOPS;
pf.cTabCount:=32;
Canvas.Font.Assign((re as TRichEdit).SelAttributes);
szerokoscZnaku:=(Canvas.TextWidth('12345678')*1440) div (Screen.PixelsPerInch*Length('12345678'));
for i:=1 to pf.cTabCount do
 pf.rgxTabs[i]:=i*szerokoscZnaku*liczbaZnakow;
(re as TRichEdit).Perform(EM_SETPARAFORMAT,0,Integer(@pf));
end;
uwaga: w komponencie RichEdit należy ustawić czcionkę o stałej szerokości znaków (np. Courier New)

uwaga: wyczyszczenie lub nadpisanie RichEdit.Text przywraca ustawienia domyślne


090 Zwiększenie maksymalnej pojemności komponentu RichEdit do 1 GB tekstu
RichEdit1.MaxLength:=1073741824;
uwaga: domyślnie MaxLength wynosi 81920

uwaga: liczba 1073741824 wynika z podniesienia 2 do potęgi 30


091 Prawidłowe wyświetlanie tekstu zawierającego znak "ń" w komponencie RichEdit
uses RichEdit;

procedure TForm1.FormCreate(Sender: TObject);
begin
SendMessage(RichEdit1.Handle,EM_SETLANGOPTIONS,0,0);
end;
uwaga: powyższe polecenie należy powtórzyć dla każdego komponentu RichEdit


092 Zmiana sposobu kodowania tekstu w komponencie RichEdit z Windows-1250 na UTF-8
RichEdit1.Text:=AnsiToUtf8(RichEdit1.Text);
uwaga: zmianę kodowania w przeciwną stronę realizuje funkcja Utf8ToAnsi


093 Zmiana sposobu kodowania tekstu w komponencie RichEdit z Windows-1250 na ISO-8859-2
function TForm1.ZmianaKodowania(s: String; codePage1,codePage2: Integer): String;
var ws: PWideChar; ms: PChar; eCode,wSize,bSize: Integer; b: Bool; c: Char;
begin
ws:='';
ms:='';
wSize:=0;
bSize:=0;
b:=False;
c:='#';
Result:='';
try
  wSize:=MultiByteToWideChar(codePage1,1 or 0,PChar(s),-1,ws,0);
  GetMem(ws,wSize*SizeOf(WideChar));
  eCode:=MultiByteToWideChar(codePage1,1 or 0,PChar(s),-1,ws,wSize);
  if eCode<>0
   then
    try
      bSize:=WideCharToMultibyte(codePage2,0,ws,-1,ms,0,@c,@b);
      GetMem(ms,bSize*SizeOf(Char));
      eCode:=WideCharToMultibyte(codePage2,0,ws,-1,ms,bSize,@c,@b);
      if b
       then eCode:=-1;
      if eCode<>0
       then Result:=ms;
     finally
      FreeMem(ms,bSize*SizeOf(Char));
     end;
 finally
  FreeMem(ws,wSize*SizeOf(WideChar));
 end;
end;

RichEdit1.Text:=ZmianaKodowania(RichEdit1.Text,1250,28591);
uwaga: wartości codePage określa https://learn.microsoft.com/en-us/windows/win32/intl/code-page-identifiers


094 Zapisanie zawartości komponentu RichEdit do pliku bez dodatkowych znaków formatu RTF
RichEdit1.PlainText:=True;

095 Sprawdzenie numeru wiersza z kursorem karetki i jego pozycji w komponencie RichEdit
wiersz:=RichEdit1.CaretPos.Y;

pozycja:=RichEdit1.CaretPos.X;

096 Ustawienie kursora karetki na pozycji X w wierszu Y w komponencie RichEdit
RichEdit1.CaretPos:=Point(X,Y);

097 Sprawdzenie numeru pierwszego wiersza widocznego w komponencie RichEdit
n:=RichEdit1.Perform(EM_GETFIRSTVISIBLELINE,0,0);
uwaga: wiersze w komponencie RichEdit numerowane są od 0

uwaga: powyższa funkcja zwraca numer pierwszego wiersza który jest widoczny w całości


098 Sprawdzenie numeru ostatniego wiersza widocznego w komponencie RichEdit
function TForm1.NumerOstatniegoWidocznegoWiersza: Integer;
var i: Integer; r: TRect;
begin
RichEdit1.Perform(EM_GETRECT,0,Longint(@r));
r.Left:=r.Left+1;
r.Top:=r.Bottom-2;
i:=RichEdit1.Perform(EM_CHARFROMPOS,0,Integer(@r.TopLeft));
Result:=RichEdit1.Perform(WM_USER+54,0,i)-1;
end;
uwaga: wiersze w komponencie RichEdit numerowane są od 0

uwaga: powyższa funkcja zwraca numer ostatniego wiersza który jest widoczny w całości i zawiera znak zakończenia linii


099 Przesunięcie obszaru roboczego komponentu RichEdit na samą górę lub sam dół
SendMessage(RichEdit1.Handle,WM_VSCROLL,SB_TOP,0);

SendMessage(RichEdit1.Handle,WM_VSCROLL,SB_BOTTOM,0);

100 Przesunięcie obszaru roboczego komponentu RichEdit o jedną stronę w górę lub w dół
SendMessage(RichEdit1.Handle,WM_VSCROLL,SB_PAGEUP,0);

SendMessage(RichEdit1.Handle,WM_VSCROLL,SB_PAGEDOWN,0);

101 Przesunięcie obszaru roboczego komponentu RichEdit o 5 wierszy w górę lub w dół
SendMessage(RichEdit1.Handle,EM_LINESCROLL,0,-5);

SendMessage(RichEdit1.Handle,EM_LINESCROLL,0,5);

102 Przesunięcie obszaru roboczego komponentu RichEdit tak aby n-ty wiersz był pierwszym widocznym
SendMessage(RichEdit1.Handle,WM_VSCROLL,SB_TOP,0);
SendMessage(RichEdit1.Handle,EM_LINESCROLL,0,n);
uwaga: powyższa instrukcja umożliwia wyjechanie poza koniec tekstu (np. gdy pierwszym widocznym ma zostać wiersz ostatni)


103 Przesunięcie obszaru roboczego komponentu RichEdit tak aby widoczny był kursor karetki
SendMessage(RichEdit1.Handle,EM_SCROLLCARET,0,0);
uwaga: powyższa instrukcja przestaje działać po dodaniu RichEdit do listy modułów (uses RichEdit;) i należy ją zastąpić przez:
SendMessage(RichEdit1.Handle,WM_USER-841,0,0);

104 Sprawdzenie oraz ustawienie pozycji suwaków komponentu RichEdit
var p: TPoint;

RichEdit1.Perform(WM_USER+221,0,LParam(@p));
pozycjaSuwakaPoziomego:=p.X;
pozycjaSuwakaPionowego:=p.Y;

p.X:=pozycjaSuwakaPoziomego;
p.Y:=pozycjaSuwakaPionowego;
RichEdit1.Perform(WM_USER+222,0,LParam(@p));

105 Sprawdzenie wysokości pojedynczego wiersza w komponencie RichEdit
function TForm1.WysokoscWiersza: Integer;
var tm : TTextMetric; reDC: HDC;
begin
reDC:=GetDC(RichEdit1.Handle);
SelectObject(reDC,RichEdit1.Font.Handle);
GetTextMetrics(reDC,tm);
ReleaseDC(RichEdit1.Handle,reDC);
Result:=tm.tmHeight;
end;
uwaga: powyższa funkcja pozwala sprawdzić ile pełnych wierszy zmieści się w obszarze roboczym komponentu RichEdit:
n:=RichEdit1.ClientHeight div WysokoscWiersza;
end;

106 Zmiana czcionki fragmentu tekstu w komponencie RichEdit
RichEdit1.SelStart:=10;
RichEdit1.SelLength:=5;
RichEdit1.SelAttributes.Name:='Verdana';
RichEdit1.SelAttributes.Size:=10;
RichEdit1.SelAttributes.Color:=clRed;
RichEdit1.SelAttributes.Style:=[fsBold,fsItalic];
uwaga: parametr SelStart określa numer pierwszego znaku natomiast SelLength długość formatowanego fragmentu tekstu

uwaga: formatowanie wielu fragmentów tekstu można przyspieszyć zamrażając RichEdit na czas formatowania:
var poprzedniSelStart,poprzedniSelLength: Integer; focusObject: TWinControl;

poprzedniSelStart:=RichEdit1.SelStart;
poprzedniSelLength:=RichEdit1.SelLength;
focusObject:=Screen.ActiveControl;
RichEdit1.Perform(WM_SETREDRAW,WParam(False),0);
RichEdit1.Enabled:=False;
ProceduraFormatujacaTekst;
RichEdit1.Enabled:=True;
RichEdit1.Perform(WM_SETREDRAW,WParam(True),0);
RichEdit1.Repaint;
focusObject.SetFocus;
RichEdit1.SelStart:=poprzedniSelStart;
RichEdit1.SelLength:=poprzedniSelLength;

107 Zmiana koloru tła fragmentu tekstu w komponencie RichEdit
uses RichEdit;

var stylTekstu: TCharFormat2;

FillChar(stylTekstu,SizeOf(stylTekstu),0);
stylTekstu.cbSize:=SizeOf(stylTekstu);
stylTekstu.dwMask:=CFM_BACKCOLOR;
stylTekstu.crBackColor:=ColorToRGB(clRed);
RichEdit1.SelStart:=10;
RichEdit1.SelLength:=5;
RichEdit1.Perform(EM_SETCHARFORMAT,SCF_SELECTION,LParam(@stylTekstu));
uwaga: parametr SelStart określa numer pierwszego znaku natomiast SelLength długość formatowanego fragmentu tekstu


108 Sprawdzenie koloru tekstu w komponencie RichEdit
uses RichEdit;

var stylTekstu: TCharFormat2;

FillChar(stylTekstu,SizeOf(stylTekstu),0);
stylTekstu.cbSize:=SizeOf(TCharFormat);
RichEdit1.Perform(EM_GETCHARFORMAT,SCF_SELECTION,LParam(@stylTekstu));
if Integer(stylTekstu.crTextColor)=ColorToRGB($FF0000)
 then ShowMessage('Aktualnie wprowadzany tekst ma kolor czerwony')
 else ShowMessage('Aktualnie wprowadzany tekst ma kolor $'+IntToHex(stylTekstu.crTextColor,6));
uwaga: sprawdzenie koloru tekstu w miejscu innym niż kursor karetki wymaga chwilowej zmiany wartości RichEdit1.SelStart


109 Kopiowanie tekstu z komponentu RichEdit do schowka
uses Clipbrd;

Clipboard.AsText:=RichEdit1.Text;
uwaga: w analogiczny sposób można skopiować tekst ze schowka do komponentu RichEdit


110 Kopiowanie tekstu z komponentu RichEdit poprzez Ctrl+C jako zwykły tekst

Aby nadpisać procedurę Ctrl+C komponentu RichEdit należy:

1) umieścić na formie komponent ActionList z zakładki Standard
2) utworzyć akcję i ustawić jej właściwość Enabled na False
3) uzupełnić następujące procedury:
uses Clipbrd, Menus;

procedure TForm1.RichEdit1Enter(Sender: TObject);
begin
Action1.ShortCut:=TextToShortCut('Ctrl+C');
Action1.Enabled:=True;
end;

procedure TForm1.RichEdit1Exit(Sender: TObject);
begin
Action1.Enabled:=False;
Action1.ShortCut:=TextToShortCut('');
end;

procedure TForm1.Action1Execute(Sender: TObject);
begin
Clipboard.AsText:=RichEdit1.SelText;
end;

111 Wklejanie tekstu do komponentu RichEdit poprzez Ctrl+V jako zwykły tekst

Aby nadpisać procedurę Ctrl+V komponentu RichEdit należy:

1) umieścić na formie komponent ActionList z zakładki Standard
2) utworzyć akcję i ustawić jej właściwość Enabled na False
3) uzupełnić następujące procedury:
uses Clipbrd, Menus;

procedure TForm1.RichEdit1Enter(Sender: TObject);
begin
Action1.ShortCut:=TextToShortCut('Ctrl+V');
Action1.Enabled:=True;
end;

procedure TForm1.RichEdit1Exit(Sender: TObject);
begin
Action1.Enabled:=False;
Action1.ShortCut:=TextToShortCut('');
end;

procedure TForm1.Action1Execute(Sender: TObject);
begin
if Clipboard.HasFormat(CF_TEXT)
 then RichEdit1.SelText:=Clipboard.AsText;
end;

112 Wycinanie tekstu z komponentu RichEdit poprzez Ctrl+X jako zwykły tekst

Aby nadpisać procedurę Ctrl+X komponentu RichEdit należy:

1) umieścić na formie komponent ActionList z zakładki Standard
2) utworzyć akcję i ustawić jej właściwość Enabled na False
3) uzupełnić następujące procedury:
uses Clipbrd, Menus;

procedure TForm1.RichEdit1Enter(Sender: TObject);
begin
Action1.ShortCut:=TextToShortCut('Ctrl+X');
Action1.Enabled:=True;
end;

procedure TForm1.RichEdit1Exit(Sender: TObject);
begin
Action1.Enabled:=False;
Action1.ShortCut:=TextToShortCut('');
end;

procedure TForm1.Action1Execute(Sender: TObject);
begin
Clipboard.AsText:=RichEdit1.SelText;
RichEdit1.SelText:='';
end;

113 Powiązanie komponentu FindDialog z komponentem RichEdit
procedure TForm1.FindDialog1Find(Sender: TObject);
var pierwszyZnakWyniku,tempSelStart,tempSelLength: Integer;
    szukanyTekst,przeszukiwanyTekst,komunikat: String;
begin
szukanyTekst:=FindDialog1.FindText;
przeszukiwanyTekst:=RichEdit1.Text;
if FindDialog1.Options*[frMatchCase]=[]
 then
  begin
  szukanyTekst:=AnsiLowerCase(szukanyTekst);
  przeszukiwanyTekst:=AnsiLowerCase(przeszukiwanyTekst);
  end;
if FindDialog1.Options*[frDown]=[frDown]
 then
  begin
  tempSelStart:=RichEdit1.SelStart;
  if Copy(przeszukiwanyTekst,RichEdit1.SelStart+1,RichEdit1.SelLength)=szukanyTekst
   then tempSelStart:=tempSelStart+1;
  pierwszyZnakWyniku:=Pos(szukanyTekst,Copy(przeszukiwanyTekst,tempSelStart+1
   ,Length(przeszukiwanyTekst)-tempSelStart));
  if pierwszyZnakWyniku<>0
   then pierwszyZnakWyniku:=pierwszyZnakWyniku+tempSelStart;
  end
 else
  begin
  tempSelLength:=RichEdit1.SelLength;
  if Copy(przeszukiwanyTekst,RichEdit1.SelStart+1,RichEdit1.SelLength)=szukanyTekst
   then tempSelLength:=tempSelLength-1;
  pierwszyZnakWyniku:=0;
  while Pos(szukanyTekst,Copy(przeszukiwanyTekst,pierwszyZnakWyniku+1
   ,RichEdit1.SelStart+tempSelLength-pierwszyZnakWyniku))>0
   do pierwszyZnakWyniku:=Pos(szukanyTekst,Copy(przeszukiwanyTekst
    ,pierwszyZnakWyniku+1,RichEdit1.SelStart+tempSelLength-pierwszyZnakWyniku))
    +pierwszyZnakWyniku;
  end;
if pierwszyZnakWyniku=0
 then
  begin;
  if FindDialog1.Options*[frDown]=[frDown]
   then komunikat:='W dół'
   else komunikat:='W górę';
  komunikat:=komunikat+' od kursora karetki nie znaleziono wyrażenia "'+szukanyTekst+'"';
  ShowMessage(komunikat);
  RichEdit1.SetFocus;
  end
 else
  begin
  RichEdit1.SelStart:=pierwszyZnakWyniku-1;
  RichEdit1.SelLength:=Length(szukanyTekst);
  SendMessage(RichEdit1.Handle,EM_SCROLLCARET,0,0);
  end;
end;
uwaga: zamiast wywołania EM_SCROLLCARET można dla komponentu RichEdit ustawić właściwość HideSelection na False

uwaga: skutkuje to automatyczym przesuwaniem obszaru roboczego do zaznaczonego tekstu, co można selektywnie przywracać:
var poprzedniaPozycjaSuwaka: Integer;

poprzedniaPozycjaSuwaka:=RichEdit1.Perform(EM_GETFIRSTVISIBLELINE,0,0);
JakasProceduraZaznaczajacaTekst;
SendMessage(RichEdit1.Handle,WM_VSCROLL,SB_TOP,0);
SendMessage(RichEdit1.Handle,EM_LINESCROLL,0,poprzedniaPozycjaSuwaka);

114 Powiązanie komponentu ReplaceDialog z komponentem RichEdit
procedure TForm1.ReplaceDialog1Find(Sender: TObject);
var pierwszyZnakWyniku,tempSelStart: Integer;
    szukanyTekst,przeszukiwanyTekst,komunikat: String;
begin
szukanyTekst:=ReplaceDialog1.FindText;
przeszukiwanyTekst:=RichEdit1.Text;
if ReplaceDialog1.Options*[frMatchCase]=[]
 then
  begin
  szukanyTekst:=AnsiLowerCase(szukanyTekst);
  przeszukiwanyTekst:=AnsiLowerCase(przeszukiwanyTekst);
  end;
tempSelStart:=RichEdit1.SelStart;
if Copy(przeszukiwanyTekst,RichEdit1.SelStart+1,RichEdit1.SelLength)=szukanyTekst
 then tempSelStart:=tempSelStart+1;
pierwszyZnakWyniku:=Pos(szukanyTekst,Copy(przeszukiwanyTekst,tempSelStart+1
 ,Length(przeszukiwanyTekst)-tempSelStart));
if pierwszyZnakWyniku<>0
 then pierwszyZnakWyniku:=pierwszyZnakWyniku+tempSelStart;
if pierwszyZnakWyniku=0
 then
  begin;
  komunikat:='W dół od kursora karetki nie znaleziono wyrażenia "'+szukanyTekst+'"';
  ShowMessage(komunikat);
  RichEdit1.SetFocus;
  end
 else
  begin
  RichEdit1.SelStart:=pierwszyZnakWyniku-1;
  RichEdit1.SelLength:=Length(szukanyTekst);
  SendMessage(RichEdit1.Handle,EM_SCROLLCARET,0,0);
  end;
end;

procedure TForm1.ReplaceDialog1Replace(Sender: TObject);
var pierwszyZnakWyniku,oldSelStart: Integer;
    szukanyTekst,przeszukiwanyTekst,komunikat: String;
begin
szukanyTekst:=ReplaceDialog1.FindText;
przeszukiwanyTekst:=RichEdit1.Text;
if ReplaceDialog1.Options*[frMatchCase]=[]
 then
  begin
  szukanyTekst:=AnsiLowerCase(szukanyTekst);
  przeszukiwanyTekst:=AnsiLowerCase(przeszukiwanyTekst);
  end;
if ReplaceDialog1.Options*[frReplaceAll]=[frReplaceAll]
 then
  begin
  oldSelStart:=RichEdit1.SelStart;
  if ReplaceDialog1.Options*[frMatchCase]=[]
   then RichEdit1.Text:=StringReplace(RichEdit1.Text,ReplaceDialog1.FindText
    ,ReplaceDialog1.ReplaceText,[rfReplaceAll,rfIgnoreCase])
   else RichEdit1.Text:=StringReplace(RichEdit1.Text,ReplaceDialog1.FindText
    ,ReplaceDialog1.ReplaceText,[rfReplaceAll]);
  if oldSelStart<=Length(RichEdit1.Text)
   then RichEdit1.SelStart:=oldSelStart
   else RichEdit1.SelStart:=Length(RichEdit1.Text);
  RichEdit1.SelLength:=0;
  RichEdit1.SetFocus;
  end
 else
  begin
  if Copy(przeszukiwanyTekst,RichEdit1.SelStart+1,RichEdit1.SelLength)=szukanyTekst
   then
    begin
    oldSelStart:=RichEdit1.SelStart;
    RichEdit1.Text:=Copy(RichEdit1.Text,1,RichEdit1.SelStart)
     +ReplaceDialog1.ReplaceText+Copy(RichEdit1.Text,RichEdit1.SelStart
     +RichEdit1.SelLength+1,Length(RichEdit1.Text)-RichEdit1.SelStart-RichEdit1.SelLength);
    RichEdit1.SelStart:=oldSelStart+Length(ReplaceDialog1.ReplaceText);
    RichEdit1.SelLength:=0;
    end;
  przeszukiwanyTekst:=RichEdit1.Text;
  if ReplaceDialog1.Options*[frMatchCase]=[]
   then przeszukiwanyTekst:=AnsiLowerCase(przeszukiwanyTekst);
  pierwszyZnakWyniku:=Pos(szukanyTekst,Copy(przeszukiwanyTekst,RichEdit1.SelStart
   +1,Length(przeszukiwanyTekst)-RichEdit1.SelStart));
  if pierwszyZnakWyniku<>0
   then pierwszyZnakWyniku:=pierwszyZnakWyniku+RichEdit1.SelStart;
  if pierwszyZnakWyniku=0
   then
    begin;
    komunikat:='W dół od kursora karetki nie znaleziono wyrażenia "'+szukanyTekst+'"';
    ShowMessage(komunikat);
    RichEdit1.SetFocus;
    end
   else
    begin
    RichEdit1.SelStart:=pierwszyZnakWyniku-1;
    RichEdit1.SelLength:=Length(szukanyTekst);
    SendMessage(RichEdit1.Handle,EM_SCROLLCARET,0,0);
    end;
  end;
end;

115 Wyszukiwanie tekstu w komponencie RichEdit z wykorzystaniem klawisza F3
procedure TForm1.Action1Execute(Sender: TObject);
var pierwszyZnakWyniku,tempSelStart,tempSelLength: Integer; szukanyTekst,przeszukiwanyTekst: String;
begin
if Edit1.Text=''
 then
  begin
  Edit1.SetFocus;
  end
 else
  begin
  szukanyTekst:=AnsiLowerCase(Edit1.Text);
  przeszukiwanyTekst:=AnsiLowerCase(RichEdit1.Text);
  if not CheckBox1.Checked
   then
    begin
    tempSelStart:=RichEdit1.SelStart;
    if Copy(przeszukiwanyTekst,RichEdit1.SelStart+1,RichEdit1.SelLength)=szukanyTekst
     then tempSelStart:=tempSelStart+1;
    pierwszyZnakWyniku:=Pos(szukanyTekst,Copy(przeszukiwanyTekst,tempSelStart+1
     ,Length(przeszukiwanyTekst)-tempSelStart));
    if pierwszyZnakWyniku<>0
     then pierwszyZnakWyniku:=pierwszyZnakWyniku+tempSelStart;
    end
   else
    begin
    tempSelLength:=RichEdit1.SelLength;
    if Copy(przeszukiwanyTekst,RichEdit1.SelStart+1,RichEdit1.SelLength)=szukanyTekst
     then tempSelLength:=tempSelLength-1;
    pierwszyZnakWyniku:=0;
    while Pos(szukanyTekst,Copy(przeszukiwanyTekst,pierwszyZnakWyniku+1
     ,RichEdit1.SelStart+tempSelLength-pierwszyZnakWyniku))>0
     do pierwszyZnakWyniku:=Pos(szukanyTekst,Copy(przeszukiwanyTekst,pierwszyZnakWyniku+1
      ,RichEdit1.SelStart+tempSelLength-pierwszyZnakWyniku))+pierwszyZnakWyniku;
    end;
  if pierwszyZnakWyniku=0
   then
    begin;
    ShowMessage('Nie znaleziono tekstu "'+Edit1.Text+'"');
    end
   else
    begin
    RichEdit1.SelStart:=pierwszyZnakWyniku-1;
    RichEdit1.SelLength:=Length(szukanyTekst);
    SendMessage(RichEdit1.Handle,EM_SCROLLCARET,0,0);
    end;
  end;
end;
uwaga: należy umieścić na formie komponent Edit z zakładki Standard służący do wprowadzania wyszukiwanej frazy

uwaga: należy umieścić na formie komponent CheckBox służący do określenia czy szukać w górę od kursora karetki

uwaga: należy umieścić na formie komponent ActionList z zakładki Standard, dodać akcję i ustawić jej właściwość ShortCut na F3

uwaga: zamiast wywołania EM_SCROLLCARET można dla komponentu RichEdit ustawić właściwość HideSelection na False


116 Wprowadzanie tabulacji w komponencie RichEdit
private
 procedure ObsluzTabulacje(var tcmDK: TCMDialogKey); message CM_DIALOGKEY;

procedure TForm1.ObsluzTabulacje(var tcmDK: TCMDialogKey);
begin
if (tcmDK.CharCode=VK_TAB) and (ActiveControl.Name='RichEdit1')
 then
  begin
  RichEdit1.SelText:=Chr(9);
  tcmDK.Result:=1;
  end
 else
  begin
  inherited;
  end;
end;
uwaga: domyślnie wciśnięcie tabulacji nie zmienia tekstu tylko przenosi skupienie (focus) na inny komponent


117 Przesuwalna belka dzieląca dwa komponenty RichEdit
uses Math;

var
  x0,dx,formWidth0: Integer;
  re1Width0,re2Width0,re1WidthMin,re2WidthMin,re2Left0: Integer;
  przesuwanieBelki: Boolean;

procedure TForm1.FormCreate(Sender: TObject);
begin
re1WidthMin:=50;
re2WidthMin:=120;
formWidth0:=Form1.Width;
re1Width0:=RichEdit1.Width;
re2Width0:=RichEdit2.Width;
re2Left0:=RichEdit2.Left;
Form1.Constraints.MinWidth:=Max(Form1.Constraints.MinWidth,Form1.Width
 -RichEdit1.Width-RichEdit2.Width+re1WidthMin+re2WidthMin);
x0:=0;
dx:=0;
przesuwanieBelki:=False;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
if (X>RichEdit1.Left+RichEdit1.Width)
   and (X<RichEdit2.Left)
   and (Y>Max(RichEdit1.Top,RichEdit2.Top))
   and (Y<Min(RichEdit1.Top+RichEdit1.Height,RichEdit2.Top+RichEdit2.Height))
 then
  begin
  x0:=X-dx;
  przesuwanieBelki:=True;
  end;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);
begin
if (X>RichEdit1.Left+RichEdit1.Width)
   and (X<RichEdit2.Left)
   and (Y>Max(RichEdit1.Top,RichEdit2.Top))
   and (Y<Min(RichEdit1.Top+RichEdit1.Height,RichEdit2.Top+RichEdit2.Height))
 then Cursor:=crSizeWE
 else Cursor:=crDefault;
if (przesuwanieBelki)
   and (Floor((Form1.Width-formWidth0)/2)+re1Width0+(X-x0)+1>re1WidthMin)
   and (Ceil((Form1.Width-formWidth0)/2)+re2Width0-(X-x0)+1>re2WidthMin)
 then
  begin
  dx:=X-x0;
  Perform(WM_SETREDRAW,WParam(False),0);
  FormResize(Sender);
  Perform(WM_SETREDRAW,WParam(True),0);
  RedrawWindow(Form1.Handle,nil,0,RDW_FRAME or RDW_INVALIDATE or RDW_ALLCHILDREN);
  Repaint;
  end;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
przesuwanieBelki:=False;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
if Floor((Form1.Width-formWidth0)/2)+re1Width0+dx<re1WidthMin
 then dx:=re1WidthMin-(Floor((Form1.Width-formWidth0)/2)+re1Width0);
if Ceil((Form1.Width-formWidth0)/2)+re2Width0-dx<re2WidthMin
 then dx:=Ceil((Form1.Width-formWidth0)/2)+re2Width0-re2WidthMin;
RichEdit1.Width:=Floor((Form1.Width-formWidth0)/2)+re1Width0+dx;
RichEdit2.Left:=Floor((Form1.Width-formWidth0)/2)+re2Left0+dx;
RichEdit2.Width:=Ceil((Form1.Width-formWidth0)/2)+re2Width0-dx;
end;
uwaga: tymczasowa blokada WM_SETREDRAW poprawia wyświetlanie komponentów podczas przesuwania belki


118 Synchronizacja suwaków dwóch komponentów RichEdit
private
 procedure RichEdWndProc1(var msg: TMessage);
 procedure RichEdWndProc2(var msg: TMessage);

var
 PRichEdWndProc1,POldWndProc1,PRichEdWndProc2,POldWndProc2: Pointer;

implementation

procedure TForm1.FormCreate(Sender: TObject);
begin
PRichEdWndProc1:=Classes.MakeObjectInstance(RichEdWndProc1);
POldWndProc1:=Pointer(SetWindowLong(RichEdit1.Handle,GWL_WNDPROC,Integer(PRichEdWndProc1)));
PRichEdWndProc2:=Classes.MakeObjectInstance(RichEdWndProc2);
POldWndProc2:=Pointer(SetWindowLong(RichEdit2.Handle,GWL_WNDPROC,Integer(PRichEdWndProc2)));
end;

procedure TForm1.RichEdWndProc1(var msg: TMessage);
var pierwszyWiersz: Double;
begin
if msg.Msg=WM_VSCROLL
 then
  begin
  if ((RichEdit1.Lines.Count<4096) and (RichEdit2.Lines.Count<4096))
     or (RichEdit1.Lines.Count=RichEdit2.Lines.Count)
   then
    begin
    RichEdit2.Perform(msg.Msg,msg.WParam,msg.LParam);
    end
   else
    begin
    if RichEdit1.Lines.Count<4096
     then pierwszyWiersz:=HIWORD(msg.WParam)/16
     else pierwszyWiersz:=HIWORD(msg.WParam)*(RichEdit1.Lines.Count/65536)
    if RichEdit2.Lines.Count<4096
     then RichEdit2.Perform(msg.Msg,Min(Round(pierwszyWiersz*16)
      ,65535)*65536+LOWORD(msg.WParam),msg.LParam)
     else RichEdit2.Perform(msg.Msg,Min(Round(pierwszyWiersz*(65536/RichEdit2.Lines.Count))
      ,65535)*65536+LOWORD(msg.WParam),msg.LParam);
    end;
  end;
if msg.Msg=WM_MOUSEWHEEL
 then
  begin
  if msg.WParam<0
   then
    begin
    SendMessage(RichEdit1.Handle,EM_LINESCROLL,0,1);
    SendMessage(RichEdit2.Handle,EM_LINESCROLL,0,1);
    SendMessage(RichEdit1.Handle,EM_LINESCROLL,0,1);
    SendMessage(RichEdit2.Handle,EM_LINESCROLL,0,1);
    SendMessage(RichEdit1.Handle,EM_LINESCROLL,0,1);
    SendMessage(RichEdit2.Handle,EM_LINESCROLL,0,1);
    end
   else
    begin
    SendMessage(RichEdit1.Handle,EM_LINESCROLL,0,-1);
    SendMessage(RichEdit2.Handle,EM_LINESCROLL,0,-1);
    SendMessage(RichEdit1.Handle,EM_LINESCROLL,0,-1);
    SendMessage(RichEdit2.Handle,EM_LINESCROLL,0,-1);
    SendMessage(RichEdit1.Handle,EM_LINESCROLL,0,-1);
    SendMessage(RichEdit2.Handle,EM_LINESCROLL,0,-1);
    end;
  end;
if msg.Msg<>WM_MOUSEWHEEL
 then msg.Result:=CallWindowProc(POldWndProc1,RichEdit1.Handle,msg.Msg,msg.WParam,msg.LParam);
end;

procedure TForm1.RichEdWndProc2(var msg: TMessage);
var pierwszyWiersz: Double;
begin
if msg.Msg=WM_VSCROLL
 then
  begin
  if ((RichEdit1.Lines.Count<4096) and (RichEdit2.Lines.Count<4096))
     or (RichEdit1.Lines.Count=RichEdit2.Lines.Count)
   then
    begin
    RichEdit1.Perform(msg.Msg,msg.WParam,msg.LParam);
    end
   else
    begin
    if RichEdit2.Lines.Count<4096
     then pierwszyWiersz:=HIWORD(msg.WParam)/16
     else pierwszyWiersz:=HIWORD(msg.WParam)*(RichEdit2.Lines.Count/65536)
    if RichEdit1.Lines.Count<4096
     then RichEdit1.Perform(msg.Msg,Min(Round(pierwszyWiersz*16)
      ,65535)*65536+LOWORD(msg.WParam),msg.LParam)
     else RichEdit1.Perform(msg.Msg,Min(Round(pierwszyWiersz*(65536/RichEdit2.Lines.Count))
      ,65535)*65536+LOWORD(msg.WParam),msg.LParam);
    end;
  end;
if msg.Msg=WM_MOUSEWHEEL
 then
  begin
  if msg.WParam<0
   then
    begin
    SendMessage(RichEdit1.Handle,EM_LINESCROLL,0,1);
    SendMessage(RichEdit2.Handle,EM_LINESCROLL,0,1);
    SendMessage(RichEdit1.Handle,EM_LINESCROLL,0,1);
    SendMessage(RichEdit2.Handle,EM_LINESCROLL,0,1);
    SendMessage(RichEdit1.Handle,EM_LINESCROLL,0,1);
    SendMessage(RichEdit2.Handle,EM_LINESCROLL,0,1);
    end
   else
    begin
    SendMessage(RichEdit1.Handle,EM_LINESCROLL,0,-3);
    SendMessage(RichEdit2.Handle,EM_LINESCROLL,0,-3);
    end;
  end;
if msg.Msg<>WM_MOUSEWHEEL
 then msg.Result:=CallWindowProc(POldWndProc2,RichEdit2.Handle,msg.Msg,msg.WParam,msg.LParam);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
if Assigned(PRichEdWndProc1)
 then
  begin
  SetWindowLong(RichEdit1.Handle,GWL_WNDPROC,Integer(POldWndProc1));
  Classes.FreeObjectInstance(PRichEdWndProc1);
  end;
if Assigned(PRichEdWndProc2)
 then
  begin
  SetWindowLong(RichEdit2.Handle,GWL_WNDPROC,Integer(POldWndProc2));
  Classes.FreeObjectInstance(PRichEdWndProc2);
  end;
end;
uwaga: w przypadku wiadomości WM_VSCROLL, pozycję suwaka określa parametr HIWORD(msg.WParam) liczbą od 0 do 65535

uwaga: gdy RichEdit ma nie więcej niż 4096 wierszy, każdy przewinięty wiersz zwiększa pozycję suwaka o 16

uwaga: gdy RichEdit ma ponad 4096 wierszy, pozycja suwaka jest skalowana dynamicznie (pozycja górna to 0 a dolna 65535)

uwaga: w obsłudze WM_MOUSEWHEEL, trzykrotne przewinięcie o 1 wiersz w dół przeciwdziała wyjechaniu poza koniec tekstu

uwaga: procedura RichEdWndProc umożliwia także obsługę innych zdarzeń (np. WM_LBUTTONDBLCLK lub WM_MBUTTONDOWN)


119 Zmienna TStringList jako usprawnienie komponentu RichEdit
var
  sl: TStringList;

procedure TForm1.FormCreate(Sender: TObject);
begin
sl:=TStringList.Create;
end;

procedure TForm1.WczytajZmodyfikujZapisz;
begin
sl.LoadFromFile('C:\sciezka\nazwa.roz');
sl.Add('Nowy wiersz dodany na końcu');
sl.Insert(0,'Wiersz wstawiony na początku');
sl.Delete(0);
sl[0]:='Zmodyfikowany wiersz pierwszy';
sl[sl.Count-1]:='Zmodyfikowany wiersz ostatni';
sl.CaseSensitive:=True;
sl.Sort;
sl.SaveToFile('C:\sciezka\nazwa.roz');
RichEdit1.Text:=sl.Text;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
sl.Free;
end;
uwaga: operowanie na zawartości StringList jest szybsze niż w przypadku komponentu RichEdit

uwaga: parametr sl.CaseSensitive określa o sposób realizacji procedury sl.Sort (wartość domyślna to False)


Operacje związane z wyglądem i zachowaniem okna aplikacji


120 Ukrycie okna aplikacji
Application.ShowMainForm:=False;
uwaga: można również zastosować polecenie:
Form1.Visible:=False;
uwaga: właściwość tę ustawić można również w inspektorze obiektów


121 Ukrycie paska tytułowego okna aplikacji
procedure TForm1.FormCreate(Sender: TObject);
begin
SetWindowLong(Form1.Handle,GWL_STYLE,GetWindowLong(Form1.Handle,GWL_STYLE)
and not WS_CAPTION);
Height:=ClientHeight;
end;

122 Ustawienie przeźroczystości dla okna aplikacji
procedure TForm1.FormCreate(Sender: TObject);
begin
Form1.BorderStyle:=bsNone;
Form1.Brush.Style:=bsClear;
Form1.Refresh;
end;

123 Ustawienie trybu zawsze na wierzchu dla okna aplikacji
Form1.FormStyle:=fsStayOnTop;
uwaga: aby wyłączyć tryb zawsze na wierzchu należy zamienić parametr fsStayOnTop na fsNormal


124 Zmiana tytułu aplikacji wyświetlanego na pasku zadań
Application.Title:='Tytuł';

125 Włączenie migania przycisku aplikacji na pasku zadań
procedure TForm1.Timer1Timer(Sender: TObject);
begin
FlashWindow(Application.Handle,True);
end;
uwaga: należy umieścić na formie komponent Timer z parametrem Interval ustawionym na 500


126 Ukrycie przycisku aplikacji na pasku zadań
procedure TForm1.FormCreate(Sender: TObject);
var es: Integer;
begin
es:=GetWindowLong(Application.Handle,GWL_EXSTYLE);
es:=es or (WS_EX_TOOLWINDOW and (not WS_EX_APPWINDOW));
SetWindowLong(Application.Handle,GWL_EXSTYLE,es);
end;

127 Blokada rozciągania okna aplikacji
Form1.BorderStyle:=bsSingle;
uwaga: właściwość tę ustawić można również w inspektorze obiektów


128 Zmiana ograniczenia systemowego maksymalnych wymiarów okna aplikacji
private
 procedure WMGetMinMaxInfo(var msg: TWMGetMinMaxInfo); message WM_GETMINMAXINFO;

procedure TForm1.WMGetMinMaxInfo(var msg: TWMGetMinMaxInfo);
begin
msg.MinMaxInfo^.ptMaxTrackSize.x:=8000;
msg.MinMaxInfo^.ptMaxTrackSize.y:=6000;
msg.Result:=0;
end;

129 Wywołanie akcji z chwilą maksymalizacji okna aplikacji
private
 procedure WMSysCommand(var msg: TWMSysCommand); message WM_SYSCOMMAND;

procedure TForm1.WMSysCommand(var msg: TWMSysCommand);
var stan: TWindowState;
begin
stan:=Form1.WindowState;
inherited;
if (stan<>wsMaximized) and (Form1.WindowState=wsMaximized)
 then ShowMessage('Okno aplikacji zostało zmaksymalizowane');
end;

130 Blokada wybranych przycisków z prawego górnego rogu okna aplikacji
Form1.BorderIcons:=[biSystemMenu,biMinimize,biMaximize];
uwaga: aby zablokować wybrany przycisk należy usunąć z powyższego zbioru jego deklarację

uwaga: właściwość tę ustawić można również w inspektorze obiektów


131 Odświeżenie wyglądu okna aplikacji
Application.ProcessMessages;

Operacje związane z myszą i klawiaturą


132 Sprawdzenie czy klawisz ScrollLock jest wciśnięty
if GetKeyState(VK_SCROLL)=1
 then ShowMessage('Klawisz ScrollLock jest wciśnięty');

133 Wywołanie wciśnięcia klawisza na klawiaturze
keybd_event(Ord(Chr(32)),MapVirtualKey(Ord(Chr(32)),0),0,0);
keybd_event(Ord(Chr(32)),MapVirtualKey(Ord(Chr(32)),0),KEYEVENTF_KEYUP,0);
uwaga: numer klawisza (w przykładzie 32 oznacza spację) sprawdzić można wywołując procedurę OnKeyDown dla RichEdit:
procedure TForm1.RichEdit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
ShowMessage(IntToStr(Key));
end;

134 Wpisanie znaków z łańcucha String w miejsce ustawienia kursora karetki
uses Clipbrd;

procedure TForm1.Wpisz(s: String);
begin
Clipboard.AsText:=s;
keybd_event(VK_CONTROL,MapVirtualKey(VK_CONTROL,0),0,0);
keybd_event(Ord('V'),MapVirtualKey(Ord('V'),0),0,0);
keybd_event(Ord('V'),MapVirtualKey(Ord('V'),0),KEYEVENTF_KEYUP,0);
keybd_event(VK_CONTROL,MapVirtualKey(VK_CONTROL,0),KEYEVENTF_KEYUP,0);
end;
uwaga: powyższa procedura kopiuje tekst s do schowka a następnie symuluje wciśnięcie kombinacji klawiszy Ctrl+V


135 Nadpisanie akcji wykonywanej przez system po wciśnięciu określonego klawisza na klawiaturze
private
 procedure WMHotKey(var msg: TMessage); message WM_HOTKEY;

procedure TForm1.FormCreate(Sender: TObject);
begin
RegisterHotKey(Handle,$0001,0,VK_SPACE);
RegisterHotKey(Handle,$0002,MOD_ALT,VK_A);
RegisterHotKey(Handle,$0003,MOD_SHIFT,VK_2);
RegisterHotKey(Handle,$0004,0,VK_F12);
end;

procedure TForm1.WMHotKey(var msg: TMessage);
begin
if msg.WParam=$0001
 then ShowMessage('Wciśnięto spację');
if msg.WParam=$0002
 then ShowMessage('Wciśnięto znak ą');
if msg.WParam=$0003
 then ShowMessage('Wciśnięto znak @');
if msg.WParam=$0004
 then ShowMessage('Wciśnięto F12');
end;
uwaga: reakcja domyślna (np. zrobienie odstępu dla klawisza Space) po nadpisaniu nie zostanie wywołana

uwaga: niemożliwe jest nadpisanie tą metodą zdarzenia wywołanego dla kombinacji klawiszy Alt+Ctrl+Del

uwaga: poniżej lista oznaczeń klawiszy w notacji VK (ang. Virtual-Key):

VK_SHIFT - Shift
VK_CONTROL - Ctrl
VK_MENU - Alt
VK_BACK - BackSpace
VK_TAB - Tab
VK_RETURN - Enter
VK_PAUSE - Pause
VK_SNAPSHOT - PrintScreen
VK_CAPITAL - Caps Lock
VK_NUMLOCK - Num Lock
VK_SCROLL - Scroll Lock
VK_ESCAPE - Esc
VK_SPACE - Space
VK_PRIOR - Page Up
VK_NEXT - Page Down
VK_END - End
VK_HOME - Home
VK_INSERT - Insert
VK_DELETE - Delete
VK_LEFT - strzałka w lewo
VK_UP - strzałka do góry
VK_RIGHT - strzałka w prawo
VK_DOWN - strzałka w dół
VK_F1 - F1 (pozostałe analogicznie)
VK_A - litera A (pozostałe analogicznie)
VK_0 - cyfra 0 (pozostałe analogicznie)
VK_NUMPAD0 - cyfra 0 w części numerycznej (pozostałe analogicznie)
VK_MULTIPLY - gwiazdka w części numerycznej
VK_ADD - plus w części numerycznej
VK_SUBTRACT - minus w części numerycznej
VK_DECIMAL - kropka w części numerycznej
VK_DIVIDE - dzielenie w części numerycznej

uwaga: VK jest parametrem liczbowym którego wartość sprawdzić można przez procedurę OnKeyDown dla komponentu RichEdit:
procedure TForm1.RichEdit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
ShowMessage(IntToStr(Key));
end;
uwaga: stosowanie wartości liczbowych pozwala zmienić obsługę klawiszy nie posiadających oznaczenia VK


136 Blokada klawisza PrintScreen
private
 procedure WMHotKey(var msg: TMessage); message WM_HOTKEY;

procedure TForm1.FormCreate(Sender: TObject);
begin
RegisterHotKey(Handle,$0001,0,VK_SNAPSHOT);
end;

procedure TForm1.WMHotKey(var msg: TMessage);
begin
if msg.WParam=$0001 then
 begin
 //tu można wpisać polecenia wykonywane po wciśnięciu klawisza PrintScreen
 end;
end;

137 Blokada myszy oraz blokada klawiatury
uses ShellApi;

ShellExecute(Handle,PChar('open'),PChar('rundll32'),PChar('mouse,disable'),nil,SW_SHOWNORMAL);
uwaga: aby zablokować klawiaturę należy zamienić parametr mouse na keyboard

uwaga: jedynym znanym mi sposobem odblokowania myszy lub klawiatury jest ponowne uruchomienie komputera


138 Przesunięcie kursora myszy o X w poziomie oraz Y w pionie
procedure TForm1.Przesun(dx,dy: Integer);
var p: TPoint;
begin
GetCursorPos(p);
SetCursorPos(p.X+dx,p.Y+dy);
end;

139 Kliknięcie lewym przyciskiem myszy w punkcie X od lewej i Y od góry na ekranie
procedure TForm1.Klik(x,y: Integer);
begin
SetCursorPos(x,y);
mouse_event(MOUSEEVENTF_LEFTDOWN,x,y,0,0);
mouse_event(MOUSEEVENTF_LEFTUP,x,y,0,0);
end;
uwaga: aby wywołać kliknięcie prawym przyciskiem myszy należy zamienić parametr LEFT na RIGHT


140 Ograniczenie pola w którym może poruszać się kursor myszy
procedure TForm1.OgraniczPoleKursoraMyszy(x1,x2,y1,y2: Integer);
var r: TRect;
begin
r.Left:=x1;
r.Right:=x2;
r.Top:=y1;
r.Bottom:=y2;
ClipCursor(@r);
end;

141 Zamiana przycisków myszy
SwapMouseButton(True);
uwaga: aby przywrócić pierwotne ustawienia przycisków myszy należy zamienić parametr True na False


142 Ukrycie kursora myszy
ShowCursor(False);
uwaga: aby ponownie pokazać kursor myszy należy zamienić parametr False na True


Operacje związane z ekranem i pulpitem


143 Sprawdzenie wymiarów obszaru roboczego ekranu
procedure TForm1.ObszarRoboczy;
var r: TRect;
begin
SystemParametersInfo(SPI_GETWORKAREA,0,@r,0);
ShowMessage('Od ('+IntToStr(r.Left)+','+IntToStr(r.Top)+') do ('
 +IntToStr(r.Right)+','+IntToStr(r.Bottom)+')');
end;

144 Sprawdzenie rozdzielczości ekranu
szerokosc:=GetSystemMetrics(SM_CXSCREEN);

wysokosc:=GetSystemMetrics(SM_CYSCREEN);

145 Zmiana rozdzielczości ekranu
procedure TForm1.ZmienRozdzielczoscEkranu(w,h: Integer);
var dm: TDeviceMode;
begin
with dm do
 begin
 dmSize:=SizeOf(dm);
 dmBitsPerPel:=16;
 dmPelsWidth:=w;
 dmPelsHeight:=h;
 dmFields:=DM_PELSWIDTH+DM_PELSHEIGHT;
 ChangeDisplaySettings(dm,0)
 end;
end;

146 Zapisanie do pliku BMP widoku ekranu
procedure TForm1.ZapiszWidokEkranuDoBMP;
var bmp: TBitmap;
begin
bmp:=TBitmap.Create;
bmp.PixelFormat:=pf24bit;
bmp.Width:=Screen.Width;
bmp.Height:=Screen.Height;
BitBlt(bmp.Canvas.Handle,0,0,bmp.Width,bmp.Height,GetWindowDC(GetDesktopWindow),0,0,SRCCOPY);
bmp.SaveToFile('nazwa.bmp');
bmp.Free;
end;

147 Zapisanie do pliku BMP widoku aktywnego okna
procedure TForm1.ZapiszWidokOknaDoBMP;
var bmp: TBitmap; h: THandle; r: TRect;
begin
h:=GetForeGroundWindow;
GetWindowRect(h,r);
bmp:=TBitmap.Create;
bmp.PixelFormat:=pf24bit;
bmp.Width:=r.Right-r.Left;
bmp.Height:=r.Bottom-r.Top;
BitBlt(bmp.Canvas.Handle,0,0,bmp.Width,bmp.Height,GetWindowDC(h),0,0,SRCCOPY);
bmp.SaveToFile('nazwa.bmp');
bmp.Free;
end;
uwaga: funkcja GetWindowDC zwraca DC (device context) całego okna, razem z paskiem tytułowym i obwódką

uwaga: zastosowana poniżej funkcja GetDC zwraca DC obszaru roboczego okna
procedure TForm1.ZapiszWidokObszaruRoboczegoOknaDoBMP;
var bmp: TBitmap; h: THandle; r: TRect;
begin
h:=GetForeGroundWindow;
Windows.GetClientRect(h,r);
bmp:=TBitmap.Create;
bmp.PixelFormat:=pf24bit;
bmp.Width:=r.Right-r.Left;
bmp.Height:=r.Bottom-r.Top;
BitBlt(bmp.Canvas.Handle,0,0,bmp.Width,bmp.Height,GetDC(h),0,0,SRCCOPY);
bmp.SaveToFile('nazwa.bmp');
bmp.Free;
end;
uwaga: powyższa procedura pozwala zapisać widok konkretnego komponentu na oknie, po przypisaniu jego uchwytu:
h:=Edit1.Handle;

148 Sprawdzenie czy kolor piksela na ekranie oddalonego o X od lewej oraz Y od góry jest czerwony
procedure TForm1.CzyPikselCzerwny(x,y: Integer): Boolean;
var cnv: TCanvas;
begin
cnv:=TCanvas.Create;
cnv.Handle:=GetWindowDC(GetDesktopWindow);
if cnv.Pixels[x,y]=RGB(255,0,0)
 then Result:=True
 else Result:=False;
cnv.Free;
end;

149 Zmiana tapety pulpitu
uses Registry;

procedure TForm1.UstawTapete;
var reg: TRegistry;
begin
reg:=TRegistry.Create;
try
  reg.RootKey:=HKEY_CURRENT_USER;
  reg.OpenKey('Control Panel\Desktop',True);
  reg.WriteString('TileWallpaper','0');
  reg.WriteString('WallpaperStyle','2');
 finally
  reg.CloseKey();
  reg.Free;
 end;
SystemParametersInfo(SPI_SETDESKWALLPAPER,0,PChar('sciezka\nazwa.bmp')
 ,SPIF_UPDATEINIFILE or SPIF_SENDWININICHANGE);
end;
uwaga: plik nazwa.bmp musi być bitmapą

uwaga: aby nadać tapecie położenie Do środka należy zastosować wartości TileWallpaper=0 oraz WallpaperStyle=0

uwaga: aby nadać tapecie położenie Sąsiadująco należy zastosować wartości TileWallpaper=1 oraz WallpaperStyle=0

uwaga: aby nadać tapecie położenie Rozciągnięcie należy zastosować wartości TileWallpaper=0 oraz WallpaperStyle=2


150 Ukrycie ikon na pulpicie
procedure TForm1.UkryjIkonyPulpitu;
var uchwyt: HWND;
begin
uchwyt:=FindWindow(PChar('Progman'),nil);
ShowWindow(uchwyt,SW_HIDE);
end;
uwaga: aby ponownie pokazać ikony pulpitu należy zamienić parametr SW_HIDE na SW_SHOW


Operacje związane z plikami i folderami


151 Sprawdzenie czy plik istnieje
if FileExists('C:\sciezka\nazwa.roz')
 then ShowMessage('Plik istnieje');
uwaga: powyższa funkcja nie uwzględnia wielkości liter (wyświetli komunikat np. gdy istnieje plik NAZWA.ROZ)


152 Kopiowanie pliku
CopyFile(PChar('C:\sciezka1\nazwa1.roz1'),PChar('C:\sciezka2\nazwa2.roz2'),True);
uwaga: parametr True określa czy pozostawić plik C:\sciezka2\nazwa2.roz2 w przypadku gdy będzie istniał taki plik


153 Zmiana nazwy pliku
RenameFile('C:\sciezka\nazwa1.roz1','C:\sciezka\nazwa2.roz2');
uwaga: nazwa nie zostanie zmieniona jeżeli nowa nazwa jest zajęta


154 Kasowanie pliku
procedure TForm1.SkasujPlik(plik: String);
begin
FileSetAttr(plik,FileGetAttr(plik) and not (faReadOnly or faHidden));
DeleteFile(plik);
end;

155 Sprawdzenie czy folder istnieje
if DirectoryExists('C:\sciezka\folder')
 then ShowMessage('Folder istnieje');
uwaga: powyższa funkcja nie uwzględnia wielkości liter (wyświetli komunikat np. gdy istnieje folder C:\ScIeZkA\FoLdEr)


156 Tworzenie nowego folderu
CreateDir('C:\sciezka\folder');
uwaga: w przypadku gdy nie ma pewności czy istnieją foldery nadrzędne (czyli ścieżka) to należy zastosować polecenie:
ForceDirectories('C:\sciezka\folder');

157 Kopiowanie folderu wraz z zawartością
procedure TForm1.KopiujFolder(folder1,folder2: String);
var sr: TSearchRec; czyKoniec: Integer;
begin
czyKoniec:=FindFirst(folder1+'\*',faAnyFile,sr);
while czyKoniec=0 do
 begin
 if (sr.Name<>'.') and (sr.Name<>'..')
  then
   begin
   if not DirectoryExists(folder2)
    then ForceDirectories(folder2);
   if DirectoryExists(folder1+'\'+sr.Name)
    then KopiujFolder(folder1+'\'+sr.Name,folder2+'\'+sr.Name)
    else CopyFile(PChar(folder1+'\'+sr.Name),PChar(folder2+'\'+sr.Name),True);
   end;
 czyKoniec:=FindNext(sr);
 end;
FindClose(sr);
end;

158 Przenoszenie folderu wraz z zawartością
uses ShellApi;

procedure TForm1.PrzeniesFolder(folder1,folder2: String);
var fileOp: TSHFileOpStruct;
begin
FillChar(fileOp,SizeOf(fileOp),#0);
fileOp.Wnd:=GetDesktopWindow();
fileOp.wFunc:=FO_MOVE;
fileOp.pFrom:=PChar(folder1+#0);
fileOp.pTo:=PChar(folder2+#0);
fileOp.fFlags:=FOF_NOCONFIRMMKDIR;
ShFileOperation(fileOp);
end;
uwaga: parametr FOF_NOCONFIRMMKDIR wyłącza okno dialogowe potwierdzające tworzenie nowych folderów


159 Kasowanie pustego folderu
RemoveDir('C:\sciezka\folder');

160 Kasowanie folderu w którym mogą znajdować się pliki lub podfoldery
procedure TForm1.UsunFolder(folder: String);
var sr: TSearchRec; czyKoniec: Integer;
begin
czyKoniec:=FindFirst(folder+'\*',faAnyFile,sr);
while czyKoniec=0 do
 begin
 if (sr.Name<>'.') and (sr.Name<>'..')
  then
   begin
   if DirectoryExists(folder+'\'+sr.Name)
    then UsunFolder(folder+'\'+sr.Name)
    else
     begin
     FileSetAttr(folder+'\'+sr.Name,FileGetAttr(folder+'\'+sr.Name) and not (faReadOnly or faHidden));
     DeleteFile(folder+'\'+sr.Name);
     end;
   end;
 czyKoniec:=FindNext(sr);
 end;
FindClose(sr);
RemoveDir(folder);
end;
uwaga: proszę zachować ostrożność bo przypadkowe wywołanie UsunFolder('') rozpocznie usuwanie zawartości wszystkich dysków


161 Zmiana nazwy folderu
MoveFile(PChar('C:\sciezka\folder1'),PChar('C:\sciezka\folder2'));
uwaga: nazwa nie zostanie zmieniona jeżeli nowa nazwa jest zajęta


162 Sprawdzenie rozmiaru pliku w bajtach
function TForm1.RozmiarPliku(plik: String): Integer;
var sr: TSearchRec;
begin
if FindFirst(plik,faAnyFile,sr)=0
 then Result:=sr.Size
 else Result:=0;
FindClose(sr);
end;
uwaga: powyższa funkcja zwraca nieprawidłową wartość (także ujemną) dla plików o rozmiarze przekraczającym 2 GB

uwaga: dla większych plików należy zastosować poniższą funkcję:
function TForm1.RozmiarPlikuExt(plik: String): Extended;
var sr: TSearchRec;
begin
if FindFirst(plik,faAnyFile,sr)=0
 then Result:=sr.FindData.nFileSizeHigh*4294967296+sr.FindData.nFileSizeLow
 else Result:=0;
FindClose(sr);

163 Sprawdzenie czy dwa pliki są identyczne
function TForm1.CzyPlikiSaIdentyczne(plik1,plik2: String): Boolean;
var ms1,ms2: TMemoryStream;
begin
Result:=False;
if FileExists(plik1) and FileExists(plik2)
 then
  begin
  ms1:=TMemoryStream.Create;
  ms2:=TMemoryStream.Create;
  try
    ms1.LoadFromFile(plik1);
    ms2.LoadFromFile(plik2);
    if ms1.Size=ms2.Size
     then Result:=CompareMem(ms1.Memory,ms2.Memory,ms1.Size);
   finally
    ms2.Free;
    ms1.Free;
   end;
  end;
end;

164 Wczytanie do komponentu ListBox nazw plików typu *.roz znajdujących się w danym folderze
procedure TForm1.DodajPlikiFolderu(folder: String);
var sr: TSearchRec; czyKoniec: Integer;
begin
czyKoniec:=FindFirst(folder+'\*',faAnyFile,sr);
while czyKoniec=0 do
 begin
 if (sr.Name<>'.') and (sr.Name<>'..')
  then
   begin
   if (FileExists(folder+'\'+sr.Name)) and (AnsiLowerCase(Copy(sr.Name,Length(sr.Name)-3,4))='.roz')
    then ListBox1.Items.Add(folder+'\'+sr.Name);
   end;
 czyKoniec:=FindNext(sr);
 end;
FindClose(sr);
end;

165 Wczytanie do komponentu ListBox nazw plików typu *.roz znajdujących się w folderze i jego podfolderach
procedure TForm1.DodajPlikiFolderu(folder: String);
var sr: TSearchRec; czyKoniec: Integer;
begin
czyKoniec:=FindFirst(folder+'\*',faAnyFile,sr);
while czyKoniec=0 do
 begin
 if (sr.Name<>'.') and (sr.Name<>'..')
  then
   begin
   if DirectoryExists(folder+'\'+sr.Name)
    then DodajPlikiFolderu(folder+'\'+sr.Name)
    else
     if AnsiLowerCase(Copy(sr.Name,Length(sr.Name)-3,4))='.roz'
      then ListBox1.Items.Add(folder+'\'+sr.Name);
   end;
 czyKoniec:=FindNext(sr);
 end;
FindClose(sr);
end;

166 Wczytanie do komponentu ListBox nazw plików i folderów po przeniesieniu ich na formę
uses ShellApi;

private
 procedure WMDropFiles(var msg: TWMDropFiles); message WM_DROPFILES;

implementation

procedure TForm1.WMDropFiles(var msg: TWMDropFiles);
var cNazwaObiektu: array [0..MAX_PATH] of Char; i,liczbaObiektow: Integer;
begin
liczbaObiektow:=DragQueryFile(msg.Drop,$FFFFFFFF,nil,0);
for i:=0 to liczbaObiektow-1 do
 if DragQueryFile(msg.Drop,i,cNazwaObiektu,DragQueryFile(msg.Drop,i,nil,0)+1)>0
  then ListBox1.Items.Add(cNazwaObiektu);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
DragAcceptFiles(Handle,True);
end;

167 Wczytanie do komponentu ListBox nazw plików i folderów po przeniesieniu ich na jego obszar
uses ShellApi;

private
 procedure WMDropFilesListBox1(var msg: TMessage);
 procedure LBWindowProcListBox1(var msg: TMessage);

var
 OldLBWindowProcListBox1: TWndMethod;

implementation

procedure TForm1.LBWindowProcListBox1(var msg: TMessage);
begin
if msg.Msg=WM_DROPFILES
 then WMDropFilesListBox1(msg)
 else OldLBWindowProcListBox1(msg);
end;

procedure TForm1.WMDropFilesListBox1(var msg: TMessage);
var cNazwaObiektu: array [0..MAX_PATH] of Char; i,liczbaObiektow: Integer;
begin
liczbaObiektow:=DragQueryFile(msg.WParam,$FFFFFFFF,nil,0);
for i:=0 to liczbaObiektow-1 do
 if DragQueryFile(msg.WParam,i,cNazwaObiektu,DragQueryFile(msg.WParam,i,nil,0)+1)>0
  then ListBox1.Items.Add(cNazwaObiektu);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
OldLBWindowProcListBox1:=ListBox1.WindowProc;
ListBox1.WindowProc:=LBWindowProcListBox1;
DragAcceptFiles(ListBox1.Handle,True);
end;

168 Wczytanie do komponentu Edit nazwy pliku lub folderu po przeniesieniu go na jego obszar
uses ShellApi;

private
 procedure WMDropFilesEdit1(var msg: TMessage);
 procedure LBWindowProcEdit1(var msg: TMessage);

var
 OldLBWindowProcEdit1: TWndMethod;

implementation

procedure TForm1.LBWindowProcEdit1(var msg: TMessage);
begin
if msg.Msg=WM_DROPFILES
 then WMDropFilesEdit1(msg)
 else OldLBWindowProcEdit1(msg);
end;

procedure TForm1.WMDropFilesEdit1(var msg: TMessage);
var cNazwaObiektu: array [0..MAX_PATH] of Char;
begin
if DragQueryFile(msg.WParam,0,cNazwaObiektu,DragQueryFile(msg.WParam,0,nil,0)+1)>0
 then Edit1.Text:=cNazwaObiektu;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
OldLBWindowProcEdit1:=Edit1.WindowProc;
Edit1.WindowProc:=LBWindowProcEdit1;
DragAcceptFiles(Edit1.Handle,True);
end;

169 Wczytanie do komponentu ListBox nazw plików i folderów po przeniesieniu ich na ikonę aplikacji
procedure TForm1.FormCreate(Sender: TObject);
var i: Integer;
begin
for i:=1 to ParamCount do
 ListBox1.Items.Add(ParamStr(i));
end;
uwaga: ścieżki plików przeniesionych na ikonę aplikacji przekazywane są do niego w formie parametrów wiersza poleceń

uwaga: maksymalna długość wiersza poleceń wynosi 2047 znaków dla Windows 2000 oraz 8191 dla Windows XP lub nowszego


170 Sortowanie listy plików w komponencie ListBox z uwzględnieniem drzewa folderów
function PorownanieFolderowe(sl: TStringList; i1,i2: Integer): Integer;
var folder1,folder2,nazwa1,nazwa2: String;
begin
folder1:=ExtractFilePath(sl[i1]);
folder1:=StringReplace(folder1,' ','|',[rfReplaceAll]);
folder2:=ExtractFilePath(sl[i2]);
folder2:=StringReplace(folder2,' ','|',[rfReplaceAll]);
nazwa1:=ExtractFileName(sl[i1]);
nazwa2:=ExtractFileName(sl[i2]);
Result:=AnsiCompareText(folder1,folder2)*2+AnsiCompareText(nazwa1,nazwa2);
end;

procedure TForm1.Sortuj;
var sl: TStringList;
begin
sl:=TStringList.Create;
sl.Assign(ListBox1.Items);
sl.CustomSort(PorownanieFolderowe);
ListBox1.Items.Assign(sl);
sl.Free;
end;

171 Otwarcie folderu zawierającego wskazany plik i zaznaczenie tego pliku
WinExec(PChar('explorer.exe /n, /select, "C:\sciezka\nazwa.roz"'),SW_SHOWNORMAL);

172 Przenoszenie pliku lub folderu do kosza
uses ShellApi;

procedure TForm1.PrzeniesDoKosza(obiekt: String);
var fileOp: TSHFileOpStruct;
begin
FillChar(fileOp,SizeOf(fileOp),#0);
fileOp.Wnd:=Application.Handle;
fileOp.wFunc:=FO_DELETE;
fileOp.pFrom:=PChar(obiekt+#0);
fileOp.fFlags:=FOF_SILENT or FOF_ALLOWUNDO or FOF_NOCONFIRMATION;
ShFileOperation(fileOp);
end;
uwaga: parametr FOF_SILENT wyłącza okno paska postępu usuwania

uwaga: parametr FOF_NOCONFIRMATION wyłącza okno dialogowe potwierdzające usuwanie

uwaga: w przypadku pamięci flash przenoszenie pliku lub folderu do kosza powoduje zwykłe usunięcie


173 Wybranie innej nazwy pliku lub folderu gdy wybrana jest zajęta
function TForm1.PierwszaWolnaNazwaObiektu(obiekt: String): String;
var n: Integer;
begin
if (FileExists(obiekt)) or (DirectoryExists(obiekt))
 then
  begin
  n:=1;
  while (FileExists(Copy(obiekt,1,Length(obiekt)-Length(ExtractFileExt(obiekt)))
   +' ('+IntToStr(n)+')'+ExtractFileExt(obiekt)))
  or (DirectoryExists(Copy(obiekt,1,Length(obiekt)-Length(ExtractFileExt(obiekt)))
   +' ('+IntToStr(n)+')'+ExtractFileExt(obiekt))) do
   n:=n+1;
  Result:=Copy(obiekt,1,Length(obiekt)-Length(ExtractFileExt(obiekt)))
   +' ('+IntToStr(n)+')'+ExtractFileExt(obiekt);
  end
 else
  begin
  Result:=obiekt;
  end;
end;

174 Wybranie innej nazwy folderu gdy wybrana jest zajęta
function TForm1.PierwszaWolnaNazwaFolderu(folder: String): String;
var n: Integer;
begin
if DirectoryExists(folder)
 then
  begin
  n:=1;
  while DirectoryExists(Copy(folder,1,Length(folder)-Length(ExtractFileExt(folder)))+' ('
   +IntToStr(n)+')'+ExtractFileExt(folder)) do
   n:=n+1;
  Result:=Copy(folder,1,Length(folder)-Length(ExtractFileExt(folder)))+' ('
   +IntToStr(n)+')'+ExtractFileExt(folder);
  end
 else
  begin
  Result:=folder;
  end;
end;

175 Wczytanie zawartości pliku do komponentu RichEdit
RichEdit1.Lines.LoadFromFile('C:\sciezka\nazwa.roz');

176 Zapisanie zawartości komponentu RichEdit do pliku
RichEdit1.Lines.SaveToFile('C:\sciezka\nazwa.roz');
uwaga: plik nazwa.roz może mieć dowolne rozszerzenie, przykładowo nazwa.txt lub nazwa.html


177 Wczytanie zawartości pliku do łańcucha String
function TForm1.WczytajPlikDoString(plik: String): String;
var fs: TFileStream; s: String;
begin
fs:=TFileStream.Create(plik,fmOpenRead);
try
  SetLength(s,fs.Size);
  fs.Position:=0;
  fs.ReadBuffer(Pointer(s)^,fs.Size);
 finally
  fs.Free;
 end;
Result:=s;
end;
uwaga: plik może zawierać zarówno znaki czytelne (np. litery) jak i nieczytelne (np. Escape)

uwaga: poniżej metoda alternatywna z wykorzystaniem funkcji BlockRead (zajmująca więcej czasu):
function TForm1.WczytajPlikDoStringBlokami(plik: String): String;
var b: Integer; f: File; cBuffer: array [1..65536] of Char;
begin
FileSetAttr(plik,FileGetAttr(plik) and not faReadOnly);
AssignFile(f,plik);
Reset(f,1);
b:=1;
Result:='';
while b>0 do
 begin
 BlockRead(f,cBuffer,SizeOf(cBuffer),b);
 Result:=Result+Copy(cBuffer,1,b);
 end;
CloseFile(f);
end;

178 Zapisanie łańcucha String do pliku
procedure TForm1.ZapiszStringDoPliku(s,plik: String);
var fs: TFileStream;
begin
fs:=TFileStream.Create(plik,fmCreate);
try
  fs.WriteBuffer(Pointer(s)^,Length(s));
 finally
  fs.Free;
 end;
end;
uwaga: plik może zawierać zarówno znaki czytelne (np. litery) jak i nieczytelne (np. Escape)

uwaga: poniżej metoda alternatywna z wykorzystaniem funkcji BlockWrite (zajmująca więcej czasu):
procedure TForm1.ZapiszStringDoPlikuBlokami(s,plik: String);
var i,b: Integer; f: File; cBuffer: array [1..65536] of Char;
begin
AssignFile(f,plik);
if FileExists(plik)
 then Reset(f,1)
 else Rewrite(f,1);
while Length(s)>0 do
 begin
 if Length(s)<SizeOf(cBuffer)
  then b:=Length(s)
  else b:=SizeOf(cBuffer);
  for i:=1 to b do
   cBuffer[i]:=s[i];
  BlockWrite(f,cBuffer,b);
  s:=Copy(s,b+1,Length(s)-b);
 end;
CloseFile(f);
end;
uwaga: funkcje BlockRead i BlockWrite bardzo dobrze sprawdzają się na poziomie tablicy (bez korzystania z łańcucha String)


179 Zapisanie ustawień aplikacji do pliku nazwa.ini
uses IniFiles;

procedure TForm1.ZapiszUstawienia;
var ini: TIniFile; b: Boolean; n: Integer; s: String; dt: TDateTime; x: Double;
begin
b:=False;
n:=99;
s:='tekst';
dt:=Now;
x:=3.14;
ini:=TIniFile.Create(ExtractFilePath(Application.ExeName)+'nazwa.ini');
ini.WriteString('ustawienia','s',s);
ini.WriteBool('ustawienia','b',b);
ini.WriteInteger('ustawienia','n',n);
ini.WriteDateTime('ustawienia','dt',dt);
ini.WriteFloat('ustawienia','x',x);
ini.UpdateFile;
ini.Free;
end;
uwaga: plik ustawienia.ini utworzony zostanie w tym samym folderze co plik exe uruchomionej aplikacji


180 Wczytanie ustawień aplikacji z pliku nazwa.ini
uses IniFiles;

procedure TForm1.WczytajUstawienia;
var ini: TIniFile; b: Boolean; n: Integer; s: String; dt: TDateTime; x: Double;
begin
ini:=TIniFile.Create(ExtractFilePath(Application.ExeName)+'nazwa.ini');
b:=ini.ReadBool('ustawienia','b',True);
n:=ini.ReadInteger('ustawienia','n',0);
s:=ini.ReadString('ustawienia','s','');
dt:=ini.ReadDateTime('ustawienia','dt',Now);
x:=ini.ReadFloat('ustawienia','x',0);
ini.Free;
end;

181 Ustawienie plikowi atrybutu tylko do odczytu
FileSetAttr('C:\sciezka\plik.roz',FileGetAttr('C:\sciezka\plik.roz') or faReadOnly);
uwaga: usunięcie tego atrybutu odbywa się poprzez polecenie:
FileSetAttr('C:\sciezka\plik.roz',FileGetAttr('C:\sciezka\plik.roz') and not faReadOnly);

182 Ustawienie plikowi atrybutu ukryty
FileSetAttr('C:\sciezka\plik.roz',FileGetAttr('C:\sciezka\plik.roz') or faHidden);
uwaga: usunięcie tego atrybutu odbywa się poprzez polecenie:
FileSetAttr('C:\sciezka\plik.roz',FileGetAttr('C:\sciezka\plik.roz') and not faHidden);

183 Ustawienie plikowi atrybutu systemowy
FileSetAttr('C:\sciezka\plik.roz',FileGetAttr('C:\sciezka\plik.roz') or faSysFile);
uwaga: usunięcie tego atrybutu odbywa się poprzez polecenie:
FileSetAttr('C:\sciezka\plik.roz',FileGetAttr('C:\sciezka\plik.roz') and not faSysFile);

184 Ustawienie plikowi atrybutu archiwalny
FileSetAttr('C:\sciezka\plik.roz',FileGetAttr('C:\sciezka\plik.roz') or faArchive);
uwaga: usunięcie tego atrybutu odbywa się poprzez polecenie:
FileSetAttr('C:\sciezka\plik.roz',FileGetAttr('C:\sciezka\plik.roz') and not faArchive);

185 Sprawdzenie daty utworzenia, modyfikacji i ostatniego dostępu do pliku
procedure TForm1.SprawdzDatyPliku(plik: String);
var sr: TSearchRec; u,m,d: TDateTime; localFileTime: TFileTime; systemTime: TSystemTime;
begin
if FindFirst(plik,faAnyFile,sr)=0
 then
  begin
  FileTimeToLocalFileTime(sr.FindData.ftCreationTime,localFileTime);
  FileTimeToSystemTime(localFileTime,systemTime);
  u:=SystemTimeToDateTime(systemTime);
  FileTimeToLocalFileTime(sr.FindData.ftLastWriteTime,localFileTime);
  FileTimeToSystemTime(localFileTime,systemTime);
  m:=SystemTimeToDateTime(systemTime);
  FileTimeToLocalFileTime(sr.FindData.ftLastAccessTime,localFileTime);
  FileTimeToSystemTime(localFileTime,systemTime);
  d:=SystemTimeToDateTime(systemTime);
  FindClose(sr);
  ShowMessage('Data utworzenia: '+FormatDateTime('yyyy-mm-dd hh:mm:ss',u)+Chr(13)+Chr(10)
   +'Data ostatniej modyfikacji: '+FormatDateTime('yyyy-mm-dd hh:mm:ss',m)+Chr(13)+Chr(10)
   +'Data ostatniego dostępu: '+FormatDateTime('yyyy-mm-dd hh:mm:ss',d));
  end;
end;

186 Zmiana daty utworzenia, modyfikacji i ostatniego dostępu do pliku
procedure TForm1.ZmienDatyPliku(plik: String; dataU,dataM,dataD: TDateTime);
var f: File; ddtU,ddtM,ddtD,fHandle: Integer; lftU,lftM,lftD,ftU,ftM,ftD: TFileTime;
begin
if FileExists(plik)
 then
  begin
  try
    FileSetAttr(plik,FileGetAttr(plik) and not faReadOnly);
    AssignFile(f,plik);
    Reset(f);
    fHandle:=TFileRec(f).Handle;
    ddtU:=DateTimeToFileDate(dataU);
    ddtM:=DateTimeToFileDate(dataM);
    ddtD:=DateTimeToFileDate(dataD);
    DosDateTimeToFileTime(LongRec(ddtU).Hi,LongRec(ddtU).Lo,lftU);
    DosDateTimeToFileTime(LongRec(ddtM).Hi,LongRec(ddtM).Lo,lftM);
    DosDateTimeToFileTime(LongRec(ddtD).Hi,LongRec(ddtD).Lo,lftD);
    LocalFileTimeToFileTime(lftU,ftU);
    LocalFileTimeToFileTime(lftM,ftM);
    LocalFileTimeToFileTime(lftD,ftD);
    SetFileTime(fHandle,@ftU,@ftU,@ftD);
   finally
    CloseFile(f);
   end;
  end;
end;
uwaga: zmiennym dataU, dataM i dataD należy przypisać odpowiednio daty utworzenia, modyfikacji i ostatniego dostępu do pliku

uwaga: data i czas muszą być wprowadzone z sensem (przykładowo data 30 luty lub godzina 33:86 spowodują wystąpienie błędu)


187 Sprawdzenie ścieżki oraz nazwy pliku exe uruchomionek aplikacji
s:=Application.ExeName;

188 Obsługa pliku metodą "Otwórz za pomocą..." ze wskazaniem na własną aplikację
if ParamCount=1
 then plik:=ParamStr(1);
uwaga: po wykonaniu powyższego polecenia do zmiennej plik przypisana zostanie pełna ścieżka pliku "Otwartego za pomocą..."


189 Dodanie pliku do autostartu w rejestrze systemowym
uses Registry;

procedure TForm1.DodajDoKluczaRun(nazwa,plik: String);
var reg: TRegistry;
begin
reg:=TRegistry.Create;
try
  reg.RootKey:=HKEY_LOCAL_MACHINE;
  reg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Run',True);
  reg.WriteString(nazwa,plik);
 finally
  reg.CloseKey();
  reg.Free;
 end;
end;
uwaga: w obrębie pojedynczego klucza rejestru każdy wpis musi mieć inną nazwę (w przeciwnym wypadku zostanie nadpisany)


190 Tworzenie pliku z zasobu TResourceStream

Aby dodać plik do zasobów należy:

1) umieścić w dowolnym folderze cztery pliki:

a) plik który ma zostać dołączony do zasobów (np. nazwa.roz)
b) plik brcc32.exe z folderu Bin w katalogu Delphi
c) plik rw32core.dll z folderu Bin w katalogu Delphi
d) plik tekstowy zasoby.rc o treści:
PROGRAM RCDATA "nazwa.roz"
2) uruchomić wiersz poleceń (np. poprzez Start => Uruchom => cmd)
3) komendą "cd sciezka/folder" przejść do wspomnianego wcześniej folderu
4) skompilować zasoby poleceniem "brcc32 zasoby.rc"
5) powstały plik zasoby.res przenieść do folderu projektu
6) w części implementacyjnej projektu wstawić kod:
{$R ZASOBY.RES}
7) uruchomić aplikację

Do wypakowania pliku z zasobów służy następująca procedura:
procedure TForm1.WypakujZasoby(plik: String);
var res: TResourceStream;
begin
res:=TResourceStream.Create(hInstance,'PROGRAM',RT_RCDATA);
res.SaveToFile(plik);
res.Free;
end;

191 Tworzenie twardego linku
CreateHardLink(PChar('C:\sciezka2\nazwa2.roz2'),PChar('C:\sciezka1\nazwa1.roz1'),nil);
uwaga: powyższa funkcja tworzy plik nazwa2.roz2 i dowiązuje go do istniejącego pliku nazwa1.roz1 (tzw. twardy link)

uwaga: by usunąć dowiązanie wystarczy skasować jeden z tych plików


192 Wczytanie wartości wybranej komórki z pliku Excel
uses ComObj;

function TForm1.WartoscKomorkiExcel(wiersz,kolumna: Integer; plik: String): String;
var excelApp: OleVariant;
begin
try
  excelApp:=CreateOleObject('Excel.Application');
 except
  ShowMessage('Brak oprogramowania Excel');
  Exit;
 end;
excelApp.Workbooks.Open(plik);
Result:=excelApp.Cells[wiersz,kolumna].Value;
if not VarIsEmpty(excelApp)
 then excelApp.Quit;
end;
uwaga: powyższa funkcja wczytuje wartości dla różnych typów pliku Excel (np. xls, xlsx i csv)

uwaga: wartości komórek o niektórych formatach (np. czas) mogą zostać wczytane nieprawidłowo


Operacje związane z systemem Windows


193 Sprawdzenie wersji systemu Windows
ShowMessage(IntToStr(Win32MajorVersion)+'.'+IntToStr(Win32MinorVersion)+'.'+IntToStr(Win32BuildNumber));
uwaga: numerację major.minor określa https://learn.microsoft.com/en-us/windows/win32/sysinfo/operating-system-version

uwaga: wartość build rośnie wraz z kolejnymi kompilacjami (poniższa tabela zawiera wartości początkowe)

verbuildnazwa
3.10511Windows NT 3.1
3.50807Windows NT 3.5
4.0950Windows 95
4.01381Windows NT 4.0
4.101998Windows 98
5.02195Windows 2000
5.12600Windows XP
5.23790Windows Server 2003
6.06000Windows Vista
6.06001Windows Server 2008
6.17600Windows 7
6.17600Windows Server 2008 R2
6.29200Windows Server 2012
6.29200Windows 8
6.39600Windows 8.1
6.39600Windows Server 2012 R2
10.010240Windows 10
10.014393Windows Server 2016
10.017763Windows Server 2019
10.020348Windows Server 2022
10.022000Windows 11

uwaga: po uruchomieniu aplikacji w tzw. trybie zgodności komenda zwraca wartości przypisane do wskazanego systemu

uwaga: w trybie zgodności można sprawdzić wersję jakiegoś systemowego pliku poprzez poniższą funkcję:
function TForm1.WersjaSystemuWindows: String;
var cBuffer: array [0..MAX_PATH] of Char;
    verInfoSize,verValueSize,dummy: Cardinal;
    pVerInfo: Pointer; pVerValue: PVSFixedFileInfo;
    major,minor,build: String;
begin
Result:='';
GetSystemDirectory(cBuffer,SizeOf(cBuffer));
verInfoSize:=GetFileVersionInfoSize(PChar(cBuffer+'\ntdll.dll'),dummy);
if verInfoSize>0
 then
  begin
  GetMem(pVerInfo,verInfoSize);
  try
    if GetFileVersionInfo(PChar(cBuffer+'\ntdll.dll'),0,verInfoSize,pVerInfo)
     then
      begin
      if VerQueryValue(pVerInfo,'\',Pointer(pVerValue),verValueSize)
       then
        begin
        major:=IntToStr(HIWORD(pVerValue^.dwFileVersionMS));
        minor:=IntToStr(LOWORD(pVerValue^.dwFileVersionMS));
        build:=IntToStr(HIWORD(pVerValue^.dwFileVersionLS));
        Result:=major+'.'+minor+'.'+build;
        end;
      end;
   finally
    FreeMem(pVerInfo,verInfoSize);
   end;
  end;
end;

194 Sprawdzenie ścieżki katalogu w którym jest zainstalowany system Windows
function TForm1.SciezkaWindows: String;
var cBuffer: array [0..MAX_PATH] of Char;
begin
GetWindowsDirectory(cBuffer,SizeOf(cBuffer));
Result:=cBuffer;
end;

195 Sprawdzenie ścieżki katalogu systemowego
function TForm1.SciezkaSystemu: String;
var cBuffer: array [0..MAX_PATH] of Char;
begin
GetSystemDirectory(cBuffer,SizeOf(cBuffer));
Result:=cBuffer;
end;

196 Sprawdzenie ścieżki pulpitu i innych katalogów systemowych
uses ActiveX, ShlObj;

function TForm1.SciezkaPulpitu: String;
var shellMalloc: IMalloc; pIIL: PItemIdList;
begin
pIIL:=nil;
try
  if SHGetMalloc(shellMalloc)=NOERROR
   then
    begin
    SHGetSpecialFolderLocation(Form1.Handle,CSIDL_DESKTOP,pIIL);
    SetLength(Result,MAX_PATH);
    SHGetPathFromIDList(pIIL,PChar(Result));
    SetLength(Result,StrLen(PChar(Result)));
    end;
 finally
  if pIIL<>nil
   then shellMalloc.Free(pIIL);
 end;
end;
uwaga: poniżej wybrane identyfikatory CSIDL katalogów systemowych:

CSIDL_DESKTOPC:\Users\username\Desktop
CSIDL_PERSONALC:\Users\username\Documents
CSIDL_FAVORITESC:\Users\username\Favorites
CSIDL_INTERNET_CACHEC:\Users\username\AppData\Local\Microsoft\Windows\Temporary Internet Files
CSIDL_APPDATAC:\Users\username\AppData\Roaming
CSIDL_COOKIESC:\Users\username\AppData\Roaming\Microsoft\Windows\Cookies
CSIDL_SENDTOC:\Users\username\AppData\Roaming\Microsoft\Windows\SendTo
CSIDL_STARTMENUC:\Users\username\AppData\Roaming\Microsoft\Windows\Start Menu

uwaga: pozostałe identyfikatory CSIDL określa https://learn.microsoft.com/en-us/windows/win32/shell/csidl


197 Wylogowanie użytkownika, wyłączenie lub zrestartowanie komputera
function TForm1.Wyjscie(tryb: Longword): Boolean;
var h: THandle; tTokenPvg: TTokenPrivileges;
    cbtpPrevious: DWORD; rtTokenPvg: TTokenPrivileges;
    pcbtpPreviousRequired: DWORD; tpResult: Boolean;
begin
if Win32Platform=VER_PLATFORM_WIN32_NT
 then
  begin
  tpResult:=OpenProcessToken
   (GetCurrentProcess,TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,h);
  if tpResult
   then
    begin
    tpResult:=LookupPrivilegeValue(nil,'SeShutdownPrivilege',tTokenPvg.Privileges[0].Luid);
    tTokenPvg.PrivilegeCount:=1;
    tTokenPvg.Privileges[0].Attributes:=SE_PRIVILEGE_ENABLED;
    cbtpPrevious:=SizeOf(rtTokenPvg);
    pcbtpPreviousRequired:=0;
    if tpResult
     then Windows.AdjustTokenPrivileges
      (h,False,tTokenPvg,cbtpPrevious,rtTokenPvg,pcbtpPreviousRequired);
    end;
  end;
Result:=ExitWindowsEx(tryb,0);
end;
uwaga: aby wylogować użytkownika należy wywołać procedurę Wyjscie(EWX_LOGOFF or EWX_FORCE)

uwaga: aby wyłączyć komputer należy wywołać procedurę Wyjscie(EWX_POWEROFF or EWX_FORCE)

uwaga: aby ponownie uruchomić komputer należy wywołać procedurę Wyjscie(EWX_REBOOT or EWX_FORCE)


198 Wykonanie komendy w wierszu poleceń
WinExec(PChar('command.com /c ipconfig /renew'),SW_HIDE);
uwaga: komenda "ipconfig /renew" powoduje odnowienie konfiguracji sieci IP dla wszystkich kart sieciowych


199 Sprawdzenie czy istnieje klucz w rejestrze systemowym
uses Registry;

function TForm1.CzyIstniejeKluczRejestru(korzen: HKEY; klucz: String): Boolean;
var reg: TRegistry;
begin
reg:=TRegistry.Create;
try
  reg.RootKey:=korzen;
  Result:=reg.KeyExists(klucz);
 finally
  reg.Free;
 end;
end;
uwaga: zmiennej korzen przypisać należy korzeń klucza rejestru (np. HKEY_LOCAL_MACHINE)

uwaga: zmiennej klucz przypisać należy ścieżkę klucza rejestru (np. 'SOFTWARE\Microsoft\Windows NT\CurrentVersion\')


200 Sprawdzenie czy istnieje wartość klucza w rejestrze systemowym
uses Registry;

function TForm1.CzyIstniejeWartoscKluczaRejestru(korzen: HKEY; klucz,wartosc: String): Boolean;
var reg: TRegistry;
begin
reg:=TRegistry.Create;
try
  reg.RootKey:=korzen;
  reg.OpenKey(klucz,False);
  Result:=reg.ValueExists(wartosc);
 finally
  reg.CloseKey();
  reg.Free;
 end;
end;
uwaga: zmiennej korzen przypisać należy korzeń klucza rejestru (np. HKEY_LOCAL_MACHINE)

uwaga: zmiennej klucz przypisać należy ścieżkę klucza rejestru (np. 'SOFTWARE\Microsoft\Windows NT\CurrentVersion\')

uwaga: zmiennej wartość przypisać należy nazwę wartości klucza rejestru (np. 'ProductName')


201 Odczytanie danych z wartości klucza w rejestrze systemowym
uses Registry;

function TForm1.OdczytajWartoscKluczaRejestru(korzen: HKEY; klucz,wartosc: String): String;
var reg: TRegistry;
begin
reg:=TRegistry.Create;
try
  reg.RootKey:=korzen;
  reg.OpenKey(klucz,False);
  Result:=reg.ReadString(wartosc);
 finally
  reg.CloseKey();
  reg.Free;
 end;
end;
uwaga: funkcja ReadBinaryData odczytuje wartość typu REG_BINARY

uwaga: funkcja ReadInteger odczytuje wartość typu REG_DWORD

uwaga: funkcja ReadString odczytuje wartość typu REG_SZ

uwaga: aby dodać wartość (Default) należy zastosować pustą zmienną nazwa


202 Dodanie wartości klucza do rejestru systemowego
uses Registry;

procedure TForm1.DodajWartoscKluczaRejestru(korzen: HKEY; klucz,wartosc,dane: String);
var reg: TRegistry;
begin
reg:=TRegistry.Create;
try
  reg.RootKey:=korzen;
  reg.OpenKey(klucz,True);
  reg.WriteString(wartosc,dane);
 finally
  reg.CloseKey();
  reg.Free;
 end;
end;
uwaga: funkcja WriteBinaryData dodaje wartość typu REG_BINARY

uwaga: funkcja WriteInteger dodaje wartość typu REG_DWORD

uwaga: funkcja WriteString dodaje wartość typu REG_SZ

uwaga: aby dodać wartość (Default) należy zastosować pustą zmienną nazwa


203 Usunięcie wartości klucza z rejestru systemowego
uses Registry;

procedure TForm1.UsunWartoscKluczaRejestru(korzen: HKEY; klucz,wartosc: String);
var reg: TRegistry;
begin
reg:=TRegistry.Create;
try
  reg.RootKey:=korzen;
  reg.OpenKey(klucz,True);
  reg.DeleteValue(wartosc);
 finally
  reg.CloseKey();
  reg.Free;
 end;
end;

Operacje związane z procesami


204 Uruchomienie procesu
uses ShellApi;

ShellExecute(Handle,PChar('open'),PChar('C:\sciezka\nazwa.roz'),nil,nil,SW_SHOW);
uwaga: parametr SW_SHOW spowoduje że plik zostanie otwarty w trybie normalnym

uwaga: parametr SW_HIDE spowoduje że plik zostanie otwarty ale z niewidocznym oknem

uwaga: parametr SW_MAXIMIZE spowoduje że plik zostanie otwarty w trybie pełnoekranowym

uwaga: parametr SW_MINIMIZE spowoduje że plik zostanie otwarty i od razu zminimalizowany


205 Uruchomienie procesu i wstrzymanie aplikacji do jego zakończenia
function TForm1.UruchomCzekajNaZakonczenie(plik: String): Integer;
var processSI: STARTUPINFO; processPI: PROCESS_INFORMATION; exitCode: DWORD;
begin
GetStartupInfo(processSI);
processSI.dwFlags:=STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
processSI.wShowWindow:=SW_HIDE;
Result:=-1;
if CreateProcess(nil,PChar(plik),nil,nil,False,CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS
 ,nil,nil,processSI,processPI)
 then
  begin
  WaitforSingleObject(processPI.hThread,INFINITE);
  GetExitCodeProcess(processPI.hProcess,exitCode);
  Result:=exitCode;
  CloseHandle(processPI.hProcess);
  CloseHandle(processPI.hThread);
  end;
end;
uwaga: funkcja zwraca ExitCode procesu lub wartość -1 jeśli procesu nie udało się uruchomić

uwaga: wartość INFINITE powodującą czekanie do skutku zastąpić można limitem czasu wyrażonym w milisekundach


206 Sprawdzenie identyfikatora procesu aplikacji
GetCurrentProcessId;

207 Sprawdzenie identyfikatora procesu okna o danym uchwycie
function TForm1.SprawdzPidOkna(h: THandle): Integer;
begin
GetWindowThreadProcessId(h,@Result);
end;

208 Zmiana priorytetu procesu aplikacji
SetPriorityClass(GetCurrentProcess,NORMAL_PRIORITY_CLASS);
uwaga: dopuszczalne ustawienia priorytetu to:

REALTIME_PRIORITY_CLASS - czasu rzeczywistego
HIGH_PRIORITY_CLASS - wysoki
$8000 - powyżej normalnego
NORMAL_PRIORITY_CLASS - normalny
$4000 - poniżej normalnego
IDLE_PRIORITY_CLASS - niski

uwaga: dla priorytetów powyżej i poniżej normalnego konieczne jest stosowanie wartości liczbowych

uwaga: priorytet domyślny to NORMAL_PRIORITY_CLASS


209 Zmiana priorytetu danego procesu
SetPriorityClass(OpenProcess(PROCESS_SET_INFORMATION,False,pID),NORMAL_PRIORITY_CLASS);

210 Wczytanie do komponentu ListBox informacji o wszystkich uruchomionych procesach
uses Tlhelp32;

procedure TForm1.ListaProcesow;
var next: Boolean; h: THandle; pe32: TProcessEntry32;
begin
h:=CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS,0);
pe32.dwSize:=SizeOf(pe32);
next:=Process32First(h,pe32);
while next do
 begin
 ListBox1.Items.Add('plik='+pe32.szExeFile
  +' pID='+IntToStr(pe32.th32ProcessID)
  +' nadrzedny_pID='+IntToStr(pe32.th32ParentProcessID)
  +' priorytet='+IntToStr(pe32.pcPriClassBase)
  +' liczba_watkow='+IntToStr(pe32.cntThreads));
 next:=Process32Next(h,pe32);
 end;
CloseHandle(h);
end;

211 Wczytanie do komponentu ListBox informacji o wszystkich uruchomionych wątkach
uses Tlhelp32;

procedure TForm1.ListaWatkow;
var next: Boolean; h: THandle; te32: TThreadEntry32;
begin
h:=CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD,0);
if h<>INVALID_HANDLE_VALUE
 then
  try
    te32.dwSize:=SizeOf(te32);
    next:=Thread32First(h,te32);
    while next do
     begin
     ListBox1.Items.Add('tID='+IntToStr(te32.th32ThreadID)
      +' nadrzedny_pID='+IntToStr(te32.th32OwnerProcessID));
     next:=Thread32Next(h,te32);
     end;
    finally
     CloseHandle(h);
    end;
end;

212 Wczytanie do komponentu ListBox wszystkich uchwytów danego procesu
procedure TForm1.ListaUchwytowProcesu(pID: Cardinal);
var uchwyt: HWND; pID2: Cardinal;
begin
uchwyt:=GetWindow(Application.Handle,GW_HWNDFIRST);
while uchwyt<>0 do
 begin
 GetWindowThreadProcessId(uchwyt,pID2);
 if pID2=pID
  then ListBox1.Items.Add(IntToStr(uchwyt));
 uchwyt:=GetWindow(uchwyt,GW_HWNDNEXT);
 end;
end;
uwaga: zazwyczaj do jednego procesu przypisanych jest wiele uchwytów okien z których część jest niewidoczna


213 Zakończenie danego procesu
TerminateProcess(OpenProcess(PROCESS_TERMINATE,False,pID),0);
uwaga: wywołanie powyższego polecenia dla nieprzydzielonej wartości pID może spowodować zakończenie innego procesu


Operacje związane z uchwytami okien


214 Wczytanie do komponentu ListBox tytułów, typów oraz uchwytów wszystkich otwartych okien
function EnumWindowsProc(wHandle: HWND): Boolean; StdCall; Export;
var titleBuffer,classBuffer: array [0..128] of Char;
begin
Result:=True;
GetWindowText(wHandle,titleBuffer,SizeOf(titleBuffer));
GetClassName(wHandle,classBuffer,SizeOf(classBuffer));
if IsWindowVisible(wHandle)
 then Form1.ListBox1.Items.Add(titleBuffer+'/'+classBuffer+'/'+IntToStr(wHandle));
end;

EnumWindows(@EnumWindowsProc,0);
uwaga: usuwając warunek IsWindowVisible(wHandle) otrzymamy listę wszystkich uruchomionych procesów, również tych ukrytych


215 Ustalenie uchwytu i tytułu aktywnego okna
function TForm1.TytulAktywnegoOkna: String;
var h: THandle; tytul: String; dlugoscTytulu: Longint;
begin
Result:='';
h:=GetForegroundWindow;
if h<>0
 then
  begin
  dlugoscTytulu:=GetWindowTextLength(h)+1;
  SetLength(tytul,dlugoscTytulu);
  GetWindowText(h,PChar(tytul),dlugoscTytulu);
  Result:=TrimRight(tytul);
  end;
end;

216 Ustalenie uchwytu okna o znanym tytule
var uchwyt: HWND;

uchwyt:=FindWindow(nil,PChar('Tytuł okna'));
uwaga: w przypadku gdyby kilka okien miało ten sam tytuł to uchwycone zostanie to okno które było używane jako ostatnie


217 Ustalenie uchwytu okna danego typu
var uchwyt: HWND;

uchwyt:=FindWindow(PChar('Typ okna'),nil);
uwaga: w przypadku gdyby kilka okien było tego samego typu to uchwycone zostanie to okno które było używane jako ostatnie


218 Sprawdzenie czy okno o danym uchwycie istnieje
if IsWindow(uchwyt)
 then ShowMessage('Okno istnieje')
 else ShowMessage('Okno nie istnieje');

219 Sprawdzenie czy okno o danym uchwycie jest widoczne
if IsWindowVisible(uchwyt)
 then ShowMessage('Okno jest widoczne')
 else ShowMessage('Okno nie jest widoczne');

220 Sprawdzenie czy okno o danym uchwycie jest zminimalizowane
if IsIconic(uchwyt)
 then ShowMessage('Okno jest zminimalizowane')
 else ShowMessage('Okno nie jest zminimalizowane');

221 Sprawdzenie czy okno o danym uchwycie jest zmaksymalizowane
if IsZoomed(uchwyt)
 then ShowMessage('Okno jest zmaksymalizowane')
 else ShowMessage('Okno nie jest zmaksymalizowane');

222 Sprawdzenie czy okno o danym uchwycie jest w trybie zawsze na wierzchu
if (GetWindowLong(uchwyt,GWL_EXSTYLE) and WS_EX_TOPMOST)=WS_EX_TOPMOST
 then ShowMessage('Okno jest w trybie zawsze na wierzchu')
 else ShowMessage('Okno nie jest w trybie zawsze na wierzchu');

223 Zminimalizowanie lub ukrycie okna gdy znany jest jego uchwyt
ShowWindow(uchwyt,SW_MINIMIZE);
uwaga: parametr SW_MINIMIZE spowoduje że okno zostanie zminimalizowane

uwaga: parametr SW_MAXIMIZE spowoduje że okno zostanie zmaksymalizowane

uwaga: parametr SW_HIDE spowoduje że okno zostanie ukryte

uwaga: parametr SW_SHOWNORMAL spowoduje że okno stanie się widoczne


224 Przeniesienie okna na wierzch lub na spód względem innych okien gdy znany jest jego uchwyt
SetWindowPos(uchwyt,HWND_BOTTOM,0,0,0,0,SWP_NOMOVE or SWP_NOSIZE);
uwaga: parametr HWND_BOTTOM spowoduje że okno zostanie przesunięte na spód

uwaga: parametr HWND_TOP spowoduje że okno zostanie przesunięte na wierzch

uwaga: parametr HWND_TOPMOST spowoduje że okno przejdzie w tryb zawsze na wierzchu

uwaga: parametr HWND_NOTOPMOST spowoduje że okno wyjdzie z trybu zawsze na wierzchu


225 Zamknięcie okna gdy znany jest jego uchwyt
SendMessage(uchwyt,WM_CLOSE,0,0);

Operacje związane z siecią i Internetem


226 Sprawdzenie czy komputer jest połączony z Internetem
var
  polaczony: Boolean;

function TForm1.CzyJestPolaczenie: Boolean;
begin
IdIcmpClient1.Host:='www.witryna.pl';
IdIcmpClient1.Port:=80;
IdIcmpClient1.Ping;
Result:=polaczony;
end;

procedure TForm1.IdIcmpClient1Reply(ASender: TComponent; const AReplyStatus: TReplyStatus);
begin
if AReplyStatus.BytesReceived=0
 then polaczony:=False
 else polaczony:=True;
end;
uwaga: należy umieścić na formie komponent IdHTTP z zakładki Indy Clients

uwaga: w polu Host zamiast www.witryna.pl należy podać adres który nie odrzuca wiadomości PING

uwaga: w polu Port zamiast 80 można wpisać dowolną liczbę całkowitą od 0 do 65535

uwaga: aby aplikacja nie zamrażała się przy nawiązywaniu połączenia należy dodać komponent IdAntiFreeze z zakładki Indy Misc


227 Sprawdzenie adresu IP komputera
uses WinSock;

function TForm1.MojAdresIP: String;
var cBuffer: array [0..63] of Char; pHE: PHostEnt; wsaData: TWSAData;
begin
WSAStartup($101,wsaData);
GetHostName(cBuffer,SizeOf(cBuffer));
pHE:=GetHostByName(@cBuffer);
Result:=iNet_ntoa(PInAddr(pHE^.h_addr_list^)^);
WSACleanup;
end;
uwaga: adresy 0.0.0.0 oraz 127.0.0.1 oznaczają że komputer nie jest podłączony do sieci


228 Sprawdzenie wszystkich adresów IP komputera
uses WinSock;

function TForm1.MojeAdresyIP: String;
type tPInAddr = array [0..63] of PInAddr;
     pPInAddr = ^tPInAddr;
var cBuffer: array [0..63] of Char; pHE: PHostEnt; wsaData: TWSAData;
    n: Integer; pPIA: pPInAddr;
begin
WSAStartup($101,wsaData);
GetHostName(cBuffer,SizeOf(cBuffer));
pHE:=GetHostByName(cBuffer);
if pHE<>nil
 then
  begin
  pPIA:=pPInAddr(pHE^.h_addr_list);
  Result:=iNet_ntoa(pPIA^[0]^);
  n:=1;
  while pPIA^[n]<>nil do
   begin
   Result:=Result+','+iNet_ntoa(pPIA^[n]^);
   n:=n+1;
   end;
  end;
WSACleanup;
end;

229 Sprawdzenie adresu MAC karty sieciowej
uses WinSock;

function TForm1.MojAdresMAC: String;
var i: Integer; lEnum: PlanaEnum; systemID: String;
    ncb: PNCB; adapter: PAdapterStatus; retCode: Char;
begin
Result:='';
systemID:='';
GetMem(ncb,SizeOf(TNCB));
FillChar(ncb^,SizeOf(TNCB),0);
GetMem(lEnum,SizeOf(TLanaEnum));
FillChar(lEnum^,SizeOf(TLanaEnum),0);
GetMem(adapter,SizeOf(TAdapterStatus));
FillChar(adapter^,SizeOf(TAdapterStatus),0);
lEnum.Length:=Chr(0);
ncb.ncb_command:=Chr(NCBENUM);
ncb.ncb_buffer:=Pointer(lEnum);
ncb.ncb_length:=SizeOf(lEnum);
retCode:=Netbios(ncb);
i:=0;
 repeat
 FillChar(ncb^,SizeOf(TNCB),0);
 ncb.ncb_command:=Chr(NCBRESET);
 ncb.ncb_lana_num:=lEnum.lana[i];
 retCode:=Netbios(ncb);
 FillChar(ncb^,SizeOf(TNCB),0);
 ncb.ncb_command:=Chr(NCBASTAT);
 ncb.ncb_lana_num:=lEnum.lana[i];
 ncb.ncb_callname:='*               ';
 ncb.ncb_buffer:=Pointer(adapter);
 ncb.ncb_length:=SizeOf(TAdapterStatus);
 retCode:=Netbios(ncb);
 if (retCode=Chr(0)) or (retCode=Chr(6))
  then
   begin
   systemID:=IntToHex(Ord(adapter.adapter_address[0]),2)+'-'
    +IntToHex(Ord(adapter.adapter_address[1]),2)+'-'
    +IntToHex(Ord(adapter.adapter_address[2]),2)+'-'
    +IntToHex(Ord(adapter.adapter_address[3]),2)+'-'
    +IntToHex(Ord(adapter.adapter_address[4]),2)+'-'
    +IntToHex(Ord(adapter.adapter_address[5]),2);
   end;
 Inc(i);
 until (i>=Ord(lEnum.Length)) or (systemID<>'00-00-00-00-00-00');
FreeMem(ncb);
FreeMem(adapter);
FreeMem(lEnum);
Result:=systemID;
end;

230 Zapisanie na dysku pliku z Internetu
uses UrlMon;

UrlDownloadToFile(nil,PChar('http://www.witryna.pl/nazwa.roz'),PChar('C:\sciezka\nazwa.roz'),0,nil);

231 Zapisanie na dysku pliku z Internetu z podaniem identyfikatora aplikacji
uses Wininet;

procedure TForm1.PobierzPlik(adres,plik: String);
var hSession,hService: HINTERNET; dwBytesRead: DWORD;
    fs: TFileStream; cBuffer: array [0..4096+1] of Char;
begin
fs:=TFileStream.Create(plik,fmCreate);
hSession:=InternetOpen(PChar('identyfikator aplikacji'),INTERNET_OPEN_TYPE_PRECONFIG,nil,nil,0);
try
  if Assigned(hSession)
   then
    begin
    hService:=InternetOpenUrl(hSession,PChar(adres),nil,0,0,0);
    if Assigned(hService)
     then
      try
        while True do
         begin
         dwBytesRead:=4096;
         InternetReadFile(hService,@cBuffer,4096,dwBytesRead);
         if dwBytesRead=0
          then break;
         cBuffer[dwBytesRead]:=#0;
         fs.Write(cBuffer,dwBytesRead*SizeOf(Char));
         end;
       finally
        InternetCloseHandle(hService);
       end;
    end;
 finally
  InternetCloseHandle(hSession);
 end;
fs.Free;
end;

232 Zapisanie na dysku pliku z Internetu z paskiem postępu pobierania i obsługą błędów
uses IdException;

procedure TForm1.PobierzPlik(adres,plik: String); 
var fs: TFileStream; e: Exception;
begin
try
  IdHTTP1.Head(adres);
  fs:=TFileStream.Create(plik,fmCreate);
  IdHTTP1.Get(adres,fs);
  fs.Free;
  IdHTTP1.Disconnect;
 except
  on e: EIdProtocolReplyError do
   begin
   //tu można wpisać polecenia wykonywane w przypadku braku pliku
   end;
  on e: EIdSocketError do
   begin
   //tu można wpisać polecenia wykonywane w przypadku przekierowania
   end;
 end;
end;

procedure TForm1.IdHTTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;
  const AWorkCountMax: Integer);
begin
ProgressBar1.Max:=AWorkCountMax;
end;

procedure TForm1.IdHTTP1Work(Sender: TObject; AWorkMode: TWorkMode;
  const AWorkCount: Integer);
begin
ProgressBar1.Position:=AWorkCount;
end;

procedure TForm1.IdHTTP1WorkEnd(Sender: TObject; AWorkMode: TWorkMode);
begin
ProgressBar1.Position:=0;
end;
uwaga: należy umieścić na formie komponent IdHTTP z zakładki Indy Clients

uwaga: aby aplikacja nie zamrażała się przy nawiązywaniu połączenia należy dodać komponent IdAntiFreeze z zakładki Indy Misc


233 Otwarcie strony internetowej w przeglądarce domyślnej
uses ShellApi;

ShellExecute(Handle,PChar('open'),PChar('http://www.witryna.pl/'),nil,nil,SW_SHOW);

234 Otwarcie strony internetowej we wskazanej przeglądarce
uses ShellApi;

ShellExecute(Handle,PChar('open'),PChar('C:\Program Files\Mozilla Firefox\firefox.exe')
 ,PChar('http://www.witryna.pl/'),nil,SW_SHOW);

235 Wczytanie do komponentu RichEdit kodu źródłowego strony internetowej
RichEdit1.Text:=IdHTTP1.Get('http://www.witryna.pl');
uwaga: należy umieścić na formie komponent IdHTTP z zakładki Indy Clients

uwaga: adres strony musi zaczynać się od ciągu znaków http://

uwaga: aby aplikacja nie zamrażała się przy nawiązywaniu połączenia należy dodać komponent IdAntiFreeze z zakładki Indy Misc


Pozostałe


236 Struktura pętli z użyciem polecenia break
procedure TForm1.PetlaBreak;
var i: Integer;
begin
for i:=1 to 1000 do
 begin
  if i=8
   then break;
 end;
end;
uwaga: polecenie break powoduje natychmiastowe zakończenie wykonywania pętli w jej ósmym przebiegu


237 Struktura pętli z użyciem etykiety i polecenia goto
procedure TForm1.PetlaGoToLabel;
var i: Integer; label A;
begin
i:=0;
A:
i:=i+1;
if i<8
 then goto A;
end;
uwaga: polecenie goto powoduje zaniechanie wykonywania dalszych poleceń i przeskok do etykiety A:


238 Deklaracja tablic
const
 tablica1: array [0..9] of Integer = (0,1,4,2,3,4,5,6,7,8,9);
 tablica2: array [0..3,0..2] of Integer = ((11,12),(21,22),(31,32));
 tablica3: array [5..10] of String = ('a','b','c','d','e');

239 Tablica dynamiczna
var tablica: array of String;

SetLength(tablica,2);
tablica[0]:='1';
tablica[1]:='2';

240 Ukrycie wszystkich komponentów Button na oknie aplikacji
procedure TForm1.UkryjPrzyciski;
var i: Integer;
begin
for i:=0 to ControlCount-1 do
 if Controls[i] is TButton
  then Controls[i].Visible:=False;
end;

241 Ustawienie kursora karetki na końcu tekstu wyświetlanego w komponencie Edit
Edit1.SetFocus;
Edit1.SelStart:=Length(Edit1.Text);

242 Zaznaczenie całego tekstu z komponentu Edit poprzez Ctrl+A

Aby nadpisać procedurę Ctrl+A komponentu Edit należy:

1) umieścić na formie komponent ActionList z zakładki Standard
2) utworzyć akcję i ustawić jej właściwość Enabled na False
3) uzupełnić następujące procedury:
uses Clipbrd, Menus;

procedure TForm1.Edit1Enter(Sender: TObject);
begin
Action1.ShortCut:=TextToShortCut('Ctrl+A');
Action1.Enabled:=True;
end;

procedure TForm1.Edit1Exit(Sender: TObject);
begin
Action1.Enabled:=False;
Action1.ShortCut:=TextToShortCut('');
end;

procedure TForm1.Action1Execute(Sender: TObject);
begin
Edit1.SelectAll;
end;

243 Komponent Edit do którego można wpisać tylko liczbę naturalną
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
if not ((Key in ['0'..'9']) or (Ord(Key)=8))
 then Key:=#0;
end;
uwaga: liczba 8 jest numerem porządkowym klawisza BackSpace który również jest tym przypadku dozwolony


244 Powiązanie komponentów Edit i UpDown by działały jak SpinEdit
procedure TForm1.Edit1Change(Sender: TObject);
begin
if Edit1.Text=''
 then Edit1.Text:=IntToStr(UpDown1.Min);
if StrToIntDef(Edit1.Text,0)=StrToIntDef(Edit1.Text,1)
 then UpDown1.Position:=Max(Min(StrToInt(Edit1.Text),UpDown1.Max),UpDown1.Min);
Edit1.Text:=IntToStr(UpDown1.Position);
end;

procedure TForm1.UpDown1Click(Sender: TObject; Button: TUDBtnType);
begin
Edit1.Text:=IntToStr(UpDown1.Position);
end;
uwaga: komponentom Edit i UpDown można zmieniać wymiary Width i Height w większym zakresie niż komponentowi SpinEdit


245 Poziomy suwak w komponencie ListBox
procedure TForm1.PoziomySuwakListBox;
var i,w: Integer;
begin
ListBox1.Canvas.Font:=ListBox1.Font;
w:=0;
for i:=0 to ListBox1.Items.Count-1 do
 if ListBox1.Canvas.TextWidth(ListBox1.Items[i])>w
  then w:=ListBox1.Canvas.TextWidth(ListBox1.Items[i]);
SendMessage(ListBox1.Handle,LB_SETHORIZONTALEXTENT,w+5,0);
end;
uwaga: powyższą procedurę należy wywołać po każdej zmianie zbioru elementów (dodanie lub usunięcie) w komponencie ListBox


246 Przesunięcie obszaru roboczego komponentu StringGrid tak aby widoczna była komórka [x,y]
procedure TForm1.PrzesunStringGrid(x,y: Integer);
begin
StringGrid1.LeftCol:=x;
StringGrid1.TopRow:=y;
end;

247 Ustawienie kursora karetki w komórce [x,y] komponentu StringGrid
StringGrid1.SetFocus;
StringGrid1.Selection:=TGridRect(Rect(x,y,x,y));
uwaga: jeżeli SetFocus ustawiony zostanie na innym komponencie to pole [x,y] zostanie podświetlone


248 Sprawdzenie szerokości i wysokości tekstu komponentu Label
szerokosc:=Label1.Canvas.TextWidth(Label1.Caption);

wysokosc:=Label1.Canvas.TextHeight(Label1.Caption);

249 Umieszczenie komponentu Label na komponencie ProgressBar
Label1.Parent:=ProgressBar1;
Label1.Top:=1;
Label1.Left:=2;

250 Zmiana koloru komponentu ProgressBar
uses CommCtrl;

SendMessage(ProgressBar1.Handle,PBM_SETBARCOLOR,0,clRed);

251 Ograniczenie częstotliwości aktualizacji komponentu ProgressBar w przypadku bardzo długiej pętli
liczbaPrzebiegow:=1000000;
ProgressBar1.Max:=liczbaPrzebiegow;
for i:=1 to liczbaPrzebiegow do
 begin
 JakasProcedura;
 if (i mod ((ProgressBar1.Max div 100)+1))=0
  then
   begin
   ProgressBar1.Position:=ProgressBar1.Position+((ProgressBar1.Max div 100)+1);
   Application.ProcessMessages;
   end;
 end;
uwaga: powyższy warunek ogranicza liczbę aktualizacji do 100 (milion aktualizacji wydłużyłby pętlę nawet o kilka minut)


252 Ustawienie niestandardowego skrótu dla akcji komponentu ActionList
uses Menus;

Action1.ShortCut:=TextToShortCut('Shift+Ctrl+Alt+Enter');
ShowMessage(ShortCutToText(Action1.ShortCut));
uwaga: skrót Shift+Ctrl+Alt+Enter ustawić można także następującą procedurą:
Action1.ShortCut:=ShortCut(VK_RETURN,[ssAlt,ssCtrl,ssShift]);

253 Białe kontenery kolorów niestandardowych w komponencie ColorDialog
ColorDialog1.CustomColors.Add('ColorA=FFFFFF');
ColorDialog1.CustomColors.Add('ColorB=FFFFFF');
ColorDialog1.CustomColors.Add('ColorC=FFFFFF');
ColorDialog1.CustomColors.Add('ColorD=FFFFFF');
ColorDialog1.CustomColors.Add('ColorE=FFFFFF');
ColorDialog1.CustomColors.Add('ColorF=FFFFFF');
ColorDialog1.CustomColors.Add('ColorG=FFFFFF');
ColorDialog1.CustomColors.Add('ColorH=FFFFFF');
ColorDialog1.CustomColors.Add('ColorI=FFFFFF');
ColorDialog1.CustomColors.Add('ColorJ=FFFFFF');
ColorDialog1.CustomColors.Add('ColorK=FFFFFF');
ColorDialog1.CustomColors.Add('ColorL=FFFFFF');
ColorDialog1.CustomColors.Add('ColorM=FFFFFF');
ColorDialog1.CustomColors.Add('ColorN=FFFFFF');
ColorDialog1.CustomColors.Add('ColorO=FFFFFF');
ColorDialog1.CustomColors.Add('ColorP=FFFFFF');
uwaga: właściwości te ustawić można również w inspektorze obiektów


254 Wyłączenie migania zaznaczonego komponentu ScrollBar
ScrollBar1.TabOrder:=False;

255 Wczytanie do komponentu Image obrazu z pliku JPEG
uses Jpeg;

Image1.Picture.LoadFromFile('C:\sciezka\nazwa.jpeg');

256 Zmiana wymiarów obrazu komponentu Image bez zmiany proporcji
procedure TForm1.DopasujRozmiarObrazu(wMax,hMax: Integer);
begin
Image1.Width:=wMax;
Image1.Height:=hMax;
Image1.Proportional:=True;
Image1.Stretch:=True;
end;

257 Odtworzenie dźwięku w komponencie MediaPlayer
uses MMsystem;

procedure TForm1.Alarm;
var natezenie: Double;
begin
natezenie:=0.25;
waveOutSetVolume(-1,((Round(65535*natezenie)) shl 16)+Round(65535*natezenie));
MediaPlayer1.FileName:='alarm.wav';
MediaPlayer1.Open;
MediaPlayer1.Play;
end;
uwaga: należy umieścić na formie komponent MediaPlayer z zakładki System

uwaga: wartość 0.25 określa natężenie dźwięku w zakresie od 0 (cisza) do 1 (maksimum)

uwaga: w ten sam sposób odtwarzać można dźwięki zapisane w innych formatach (np. mp3)


258 Przeniesienie skupienia (focus) na inny komponent
procedure TForm1.PrzestawFocus;
var wc: TWinControl;
begin
wc:=Screen.ActiveControl;
Button1.SetFocus;
wc.SetFocus;
end;
uwaga: ustawienie skupienia na niewidocznym obiekcie (np. w procedurze FormCreate) można wykonać poleceniem:
ActiveControl:=wc;

259 Dynamiczne tworzenie komponentów oraz nadpisywanie ich procedur
uses StdCtrls;

procedure TForm1.GenerujLabel;
var nowyLabel: TLabel;
begin
nowyLabel:=TLabel.Create(Form1);
nowyLabel.Parent:=Form1;
nowyLabel.Name:=Label1;
nowyLabel.Caption:='Label1';
nowyLabel.Left:=10;
nowyLabel.Top:=10;
nowyLabel.Font.Name:='Verdana';
nowyLabel.Font.Size:=10;
nowyLabel.Font.Style:=[fsBold];
nowyLabel.OnClick:=LabelClick;
end;

procedure TForm1.LabelClick(Sender: TObject);
begin
(Sender as TLabel).Caption:='To jest '+(Sender as TLabel).Name;
end;

260 Odwołanie się do komponentu o danej nazwie
TLabel(FindComponent('Label'+IntToStr(1))).Caption:='tekst';

261 Konwersja koloru na składowe RGB formatu HTML
function TForm1.KolorToHex(c: TColor): String;
var r,g,b: Integer;
begin
r:=GetRValue(c);
g:=GetGValue(c);
b:=GetBValue(c);
Result:=AnsiLowerCase('#'+IntToHex(r,2)+IntToHex(g,2)+IntToHex(b,2));
end;

262 Bezwarunkowe zamknięcie aplikacji
Halt;
uwaga: jeżeli aplikacja ma przerwać wykonywanie tylko danej procedury to zamiast polecenia Halt można wstawić Exit

uwaga: wywołanie Exit w procedurze FormCreate nie wstrzymuje procedur OnShow, OnActivate, OnPaint, OnResize i OnPaint

uwaga: polecenie Application.Terminate nie wstrzymuje wykonywania dalszych instrukcji ani równoległych procedur


263 Zamkniecie aplikacji jeżeli jest już uruchomiona jej kopia
var
  h: THandle;

procedure TForm1.FormCreate(Sender: TObject);
begin
h:=CreateFileMapping(THandle($FFFFFFFF),nil,PAGE_READONLY,0,32,PChar('iDeNtYfIkAtOr'));
if GetLastError=ERROR_ALREADY_EXISTS 
 then Halt;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
CloseHandle(h);
end;
uwaga: ciąg znaków "iDeNtYfIkAtOr" musi być niepowtarzalny więc warto zastąpić go możliwie długim ciągiem losowych znaków


264 Zamknięcie aplikacji z wyświetleniem komunikatu o błędzie krytycznym
FatalAppExit(0,'Wystąpił błąd 408E a to bardzo źle...');
uwaga: wywołane okienko wygląda groźnie, ale niczego złego nie powoduje


265 Wyłączenie powiadomień o błędach aplikacji
private
 procedure MyAppException(Sender: TObject; e: Exception);

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnException:=MyAppException;
end;

procedure TForm1.MyAppException(Sender: TObject; e: Exception);
begin
//tu można wpisać polecenia wykonywane w przypadku dowolnego błędu
end;

266 Wyświetlenie komunikatu ShowMessage z podziałem tekstu na linie
ShowMessage('Pierwsza linia'+Chr(13)+Chr(10)+'Druga linia'+#13#10+'Trzecia linia');

267 Wyświetlenie komunikatu MessageBox z opcjami tak lub nie
if MessageBox(0,'Pytanie','Potwierdzenie',MB_YESNO)=mrYes
 then ShowMessage('Wcisnieto Tak');
 else ShowMessage('Wcisnieto Nie');

268 Wyświetlenie komunikatu MessageDlg z wieloma opcjami
case MessageDlg('Pytanie',mtConfirmation,[mbOk,mbCancel,mbAbort,mbRetry,mbIgnore,mbYes,mbNo],0) of
 1: ShowMessage('Wcisnieto OK);
 2: ShowMessage('Wcisnieto Cancel lub zamknięto okno pytania krzyżykiem);
 3: ShowMessage('Wcisnieto Abort);
 4: ShowMessage('Wcisnieto Retry);
 5: ShowMessage('Wcisnieto Ignore);
 6: ShowMessage('Wcisnieto Yes);
 7: ShowMessage('Wcisnieto No);
 end;
uwaga: typ komunikatu mtConfirmation można zmienić na mtWarning, mtError, mtInformation lub mtCustom


269 Zamaskowanie gwiazdkami tekstu wprowadzanego w okno InputBox
private
 procedure SetInputBoxPasswordChar(var msg: TMessage); message WM_USER+200;

procedure TForm1.SetInputBoxPasswordChar(var msg: TMessage);
var hInputForm,hEdit: HWND;
begin
hInputForm:=Screen.Forms[0].Handle;
if (hInputForm<>0)
 then
  begin
  hEdit:=FindWindowEx(hInputForm,0,PChar('TEdit'),nil);
  SendMessage(hEdit,EM_SETPASSWORDCHAR,Ord('*'),0);
  end;
end;

procedure TForm1.UstalHaslo;
var haslo: String;
begin
PostMessage(Handle,WM_USER+200,0,0);
haslo:=InputBox('','Hasło:','');
end;
uwaga: polecenie PostMessage działa jednorazowo i należy je ponowić przed każdym wywołaniem InputBox

uwaga: polecenie PostMessage nie wstrzymuje wykonywania kolejnych instrukcji (działa asynchronicznie)

uwaga: polecenie SendMessage wstrzymuje wykonywanie kolejnych instrukcji do czasu zakończenia obsługi SendMessage


270 Wykonywanie wielu operacji równolegle z wykorzystaniem wątków
uses Classes;

type
  TWatek = class(TThread)
  private
    n,x: Integer;
    procedure Procedura;
    procedure ProceduraKoncowa;
  protected
    procedure Execute; override;
  public
    constructor Create(numer: Integer);
  end;

implementation

constructor TWatek.Create(numer: Integer);
begin
inherited Create(True);
n:=numer;
x:=0;
end;

procedure TWatek.Execute;
begin
FreeOnTerminate:=True;
while not Terminated do
 begin
 x:=x+1;
 Sleep(100);
 Synchronize(Procedura);
 end;
Synchronize(ProceduraKoncowa);
end;

procedure TWatek.Procedura;
begin
TLabel(Form1.FindComponent('Label'+IntToStr(n))).Caption:=IntToStr(x);
end;

procedure TWatek.ProceduraKoncowa;
begin
TLabel(Form1.FindComponent('Label'+IntToStr(n))).Caption:='koniec';
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
watek1:=TWatek.Create(1);
watek2:=TWatek.Create(2);
watek1.Priority:=tpLower;
watek1.Resume;
watek2.Resume;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
watek1.Suspend;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
watek1.Resume;
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
watek1.Terminate;
end;

271 Sprawdzenie jakimi literami oznaczone są poszczególne partycje dysku
function TForm1.ListaPartycji: String;
var p: Char;
begin
Result:='';
for p:='A' to 'Z' do
 if GetDriveType(PChar(p+':\'))=DRIVE_FIXED
  then Result:=Result+p;
end;
uwaga: w przypadku dysku przenośnego funkcja GetDriveType zwraca wartość DRIVE_REMOVABLE


272 Sprawdzenie wolnej i całkowitej przestrzeni na dysku
procedure TForm1.PrzestrzenDyskowa;
var bajtyWolne,pojemnoscDysku: Int64;
begin
if SysUtils.GetDiskFreeSpaceEx(PChar('C:\'),bajtyWolne,pojemnoscDysku,nil)
 then ShowMessage('Dysk C ma '+IntToStr(pojemnoscDysku)+' bajtów ('+IntToStr(bajtyWolne)+' wolnych)');
end;

273 Sprawdzenie numeru seryjnego partycji
uses Tlhelp32;

function TForm1.NumerSeryjnyPartycji(p: String): DWORD;
var cBuffer: array [0..255] of Char; maxCompLength,fileSystemFlags,serial: DWORD;
begin
GetVolumeInformation(PChar(p+':\'),cBuffer,SizeOf(cBuffer)
 ,@serial,maxCompLength,fileSystemFlags,nil,0);
Result:=serial;
end;