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 Wklejanie tekstu do komponentu RichEdit ze schowka >>

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

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

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

114 Powiązanie komponentu FindDialog z komponentem RichEdit >>

115 Powiązanie komponentu ReplaceDialog z komponentem RichEdit >>

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

117 Wprowadzanie tabulacji w komponencie RichEdit >>

118 Przesuwalna belka dzieląca dwa komponenty RichEdit >>

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

120 Zmienna TStringList jako usprawnienie komponentu RichEdit >>

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

121 Ukrycie okna aplikacji >>

122 Ukrycie paska tytułowego okna aplikacji >>

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

124 Ustawienie trybu zawsze na wierzchu dla okna aplikacji >>

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

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

127 Ukrycie przycisku aplikacji na pasku zadań >>

128 Blokada rozciągania okna aplikacji >>

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

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

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

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

Operacje związane z myszą i klawiaturą

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

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

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

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

137 Blokada klawisza PrintScreen >>

138 Blokada myszy oraz blokada klawiatury >>

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

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

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

142 Zamiana przycisków myszy >>

143 Ukrycie kursora myszy >>

Operacje związane z ekranem i pulpitem

144 Sprawdzenie wymiarów obszaru roboczego ekranu >>

145 Sprawdzenie rozdzielczości ekranu >>

146 Zmiana rozdzielczości ekranu >>

147 Zapisanie do pliku BMP widoku ekranu >>

148 Zapisanie do pliku BMP widoku aktywnego okna >>

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

150 Zmiana tapety pulpitu >>

151 Ukrycie ikon na pulpicie >>

Operacje związane z plikami i folderami

152 Sprawdzenie czy plik istnieje >>

153 Kopiowanie pliku >>

154 Zmiana nazwy pliku >>

155 Kasowanie pliku >>

156 Sprawdzenie czy folder istnieje >>

157 Tworzenie nowego folderu >>

158 Kopiowanie folderu wraz z zawartością >>

159 Przenoszenie folderu wraz z zawartością >>

160 Kasowanie pustego folderu >>

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

162 Zmiana nazwy folderu >>

163 Sprawdzenie rozmiaru pliku w bajtach >>

164 Sprawdzenie czy dwa pliki są identyczne >>

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

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

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

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

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

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

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

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

173 Przenoszenie pliku lub folderu do kosza >>

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

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

176 Wczytanie zawartości pliku do komponentu RichEdit >>

177 Zapisanie zawartości komponentu RichEdit do pliku >>

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

179 Zapisanie łańcucha String do pliku >>

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

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

182 Ustawienie plikowi atrybutu tylko do odczytu >>

183 Ustawienie plikowi atrybutu ukryty >>

184 Ustawienie plikowi atrybutu systemowy >>

185 Ustawienie plikowi atrybutu archiwalny >>

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

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

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

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

190 Dodanie pliku do autostartu w rejestrze systemowym >>

191 Tworzenie pliku z zasobu TResourceStream >>

192 Tworzenie twardego linku >>

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

Operacje związane z systemem Windows

194 Sprawdzenie wersji systemu Windows >>

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

196 Sprawdzenie ścieżki katalogu systemowego >>

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

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

199 Wykonanie komendy w wierszu poleceń >>

200 Sprawdzenie czy istnieje klucz w rejestrze systemowym >>

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

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

203 Dodanie wartości klucza do rejestru systemowego >>

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

Operacje związane z procesami

205 Uruchomienie procesu >>

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

207 Sprawdzenie identyfikatora procesu aplikacji >>

208 Sprawdzenie identyfikatora procesu okna o danym uchwycie >>

209 Zmiana priorytetu procesu aplikacji >>

210 Zmiana priorytetu danego procesu >>

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

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

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

214 Zakończenie danego procesu >>

Operacje związane z uchwytami okien

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

216 Ustalenie uchwytu i tytułu aktywnego okna >>

217 Ustalenie uchwytu okna o znanym tytule >>

218 Ustalenie uchwytu okna danego typu >>

219 Sprawdzenie czy okno o danym uchwycie istnieje >>

220 Sprawdzenie czy okno o danym uchwycie jest widoczne >>

221 Sprawdzenie czy okno o danym uchwycie jest zminimalizowane >>

222 Sprawdzenie czy okno o danym uchwycie jest zmaksymalizowane >>

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

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

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

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

Operacje związane z siecią i Internetem

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

228 Sprawdzenie adresu IP komputera >>

229 Sprawdzenie wszystkich adresów IP komputera >>

230 Sprawdzenie adresu MAC karty sieciowej >>

231 Zapisanie na dysku pliku z Internetu >>

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

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

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

235 Otwarcie strony internetowej we wskazanej przeglądarce >>

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

Pozostałe

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

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

239 Deklaracja tablic >>

240 Tablica dynamiczna >>

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

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

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

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

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

246 Poziomy suwak w komponencie ListBox >>

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

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

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

250 Umieszczenie komponentu Label na komponencie ProgressBar >>

251 Zmiana koloru komponentu ProgressBar >>

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

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

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

255 Wyłączenie migania zaznaczonego komponentu ScrollBar >>

256 Wczytanie do komponentu Image obrazu z pliku JPEG >>

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

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

259 Przeniesienie skupienia (focus) na inny komponent >>

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

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

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

263 Bezwarunkowe zamknięcie aplikacji >>

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

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

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

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

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

269 Wyświetlenie komunikatu MessageDlg z wieloma opcjami >>

270 Zamaskowanie gwiazdkami tekstu wprowadzanego w okno InputBox >>

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

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

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

274 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ę w formacie czasu uniwersalnego (UTC)


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ę w formacie czasu uniwersalnego (UTC)


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(maska,s: String; znakS,znakM: Integer): Boolean;
begin
if Length(maska)>znakM
 then
  begin
  case maska[znakM+1] of
   '*':
    begin
    Result:=CzyPasujeDoMaski(maska,s,znakS,znakM+1)
            or ((Length(s)>znakS) and CzyPasujeDoMaski(maska,s,znakS+1,znakM));
    end;
   '?':
    begin
    if Length(s)>znakS
     then Result:=CzyPasujeDoMaski(maska,s,znakS+1,znakM+1)
     else Result:=False;
    end;
   else
    begin
    if (Length(s)>znakS) and (s[znakS+1]=maska[znakM+1])
     then Result:=CzyPasujeDoMaski(maska,s,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(maska,s: 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: poniższa funkcja pozwala sprawdzić ile pełnych wierszy zmieści się w obszarze roboczym komponentu RichEdit:
function TForm1.LiczbaPelnychWierszy: Integer;
begin
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
RichEdit1.CopyToClipboard;
uwaga: skopiowany tekst zachowuje pierwotny format (czcionka, kolor itp.)


110 Wklejanie tekstu do komponentu RichEdit ze schowka
RichEdit1.PasteFromClipboard;
uwaga: wklejony tekst zachowuje pierwotny format (czcionka, kolor itp.)


111 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;

112 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;

113 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;

114 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);

115 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;

116 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


117 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


118 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


119 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)


120 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


121 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


122 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;

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

124 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


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

126 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


127 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;

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


129 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;

130 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;

131 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


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

Operacje związane z myszą i klawiaturą


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

134 Wywołanie wciśnięcia klawisza na klawiaturze
keybd_event(Ord(Chr(32)),0,0),0,0);
keybd_event(Ord(Chr(32)),0,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;

135 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,0,0,0);
keybd_event(Ord('V'),0,0,0);
keybd_event(Ord('V'),0,0),KEYEVENTF_KEYUP,0);
keybd_event(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


136 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


137 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;

138 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


139 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;

140 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


141 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;

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


143 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


144 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;

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

wysokosc:=GetSystemMetrics(SM_CYSCREEN);

146 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;

147 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;

148 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;

149 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;

150 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


151 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


152 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)


153 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


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


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

156 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)


157 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');

158 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;

159 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


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

161 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


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


163 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);
end;

164 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;

165 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;

166 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;

167 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;

168 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;

169 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;

170 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


171 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;

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

173 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


174 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;

175 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;

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

177 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


178 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;

179 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)


180 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


181 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;

182 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);

183 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);

184 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);

185 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);

186 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;

187 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)


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

189 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ą..."


190 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)


191 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;

192 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


193 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


194 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;

195 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;

196 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;

197 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


198 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)


199 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


200 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\')


201 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')


202 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


203 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


204 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


205 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


206 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


207 Sprawdzenie identyfikatora procesu aplikacji
GetCurrentProcessId;

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

209 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


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

211 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;

212 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;

213 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


214 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


215 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


216 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;

217 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


218 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


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

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

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

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

223 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');

224 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


225 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


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

Operacje związane z siecią i Internetem


227 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


228 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


229 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;

230 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;

231 Zapisanie na dysku pliku z Internetu
uses UrlMon;

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

232 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;

233 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


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

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

235 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);

236 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


237 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


238 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:


239 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');

240 Tablica dynamiczna
var tablica: array of String;

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

241 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;

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

243 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;

244 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


245 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


246 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


247 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;

248 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


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

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

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

251 Zmiana koloru komponentu ProgressBar
uses CommCtrl;

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

252 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)


253 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]);

254 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


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

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

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

257 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;

258 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)


259 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;

260 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;

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

262 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;

263 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


264 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


265 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


266 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;

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

268 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');

269 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


270 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


271 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;

272 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


273 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;

274 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;