WebSVN – spacemission – Diff – /Global.pas


unit Global;
 
interface
 
const
  ProgramVersion = '1.2.2';
  LevEditRasterW = 48;
  LevEditRasterH = 32;
  LevEditRows = 15; // Attention: if you change this, you also need to change the LevEditor GUI!
  LevEditCols = 13; // Attention: if you change this, you also need to change the LevEditor GUI!
  MaxPossibleEnemyLives = 999;
  MaxPossibleLevels = 999;
  RegistrySettingsKey = 'SOFTWARE\ViaThinkSoft\SpaceMission\Settings'; // do not localize
  MusicSettingKey = 'Music'; // do not localize
  SoundSettingKey = 'Sound'; // do not localize
  SpeedSettingKey = 'GameSpeed'; // do not localize
  DefaultLevelLength = 1200;
  StartLives = 6;
  SpeedEasy = 650 div 60; // 10
  SpeedMedium = 1000 div 60; // 16
  SpeedHard = 1350 div 60; // 22
  SpeedMaster = 2000 div 60; // 33
  DEFAULT_ANIMSPEED = 15/1000;
  BossWidth = 4;
  BossHeight = 2;
  SpaceMissionExe = 'SpaceMission.exe'; // do not localize
  LevEditExe = 'LevEdit.exe'; // do not localize
  DxgFile = 'DirectX\Graphics.dxg'; // do not localize
  DxwFile = 'DirectX\Sound.dxw'; // do not localize
  DxmFile = 'DirectX\Music.dxm'; // do not localize
  RandomLevelMaxEnemyLives = 10;
  RandomLevelMedikitEveryX = 250;
  RandomLevelAdditionalEnemiesPerLevel = 75; // Zufalls-Level
 
const
  // Cheat1 = 'Kmkjk'+#39+'Khyc';
  Cheat1 = #75+#109+#107+#106+#107+#127+#39+#75+#104+#121+#99; {Johnny Cash}
 
resourcestring
  Cheat1Text = 'Unendlich Leben!';
 
type
  TCheat = (ctUnknown, ctInfiniteLives);
  TCheatSet = set of TCheat;
 
  // DirectX\Music.dxm
  TSpaceMissionMusicTrack = (
    smmNone,
    smmBoss,   // dxmusic.Midis[0]
    smmGame,   // dxmusic.Midis[1]
    smmScene,  // dxmusic.Midis[2]
    smmTitle   // dxmusic.Midis[3]
  );
 
  // DirectX\Graphics.dxg
  TSpaceMissionGraphicSprite = (
    smgNone,
    smgEnemyDisk,         // ImageList.Items.Item[0]
    smgEnemyAttacker,     // ImageList.Items.Item[1]
    smgEnemyBoss,         // ImageList.Items.Item[2]
    smgBounce,            // ImageList.Items.Item[3]
    smgMachine,           // ImageList.Items.Item[4]
    smgEnemyAttacker2,    // ImageList.Items.Item[5]
    smgEnemyAttacker3,    // ImageList.Items.Item[6]
    smgEnemyMeteor,       // ImageList.Items.Item[7]
    smgBounce2,           // ImageList.Items.Item[8]
    smgEnemyDisk2,        // ImageList.Items.Item[9]
    smgLogo,              // ImageList.Items.Item[10]
    smgExplosion,         // ImageList.Items.Item[11]
    smgBackgroundPlanet1, // ImageList.Items.Item[12]
    smgMatrix,            // ImageList.Items.Item[13]
    smgStar1,             // ImageList.Items.Item[14]
    smgStar2,             // ImageList.Items.Item[15]
    smgStar3,             // ImageList.Items.Item[16]
    smgBackgroundBlue,    // ImageList.Items.Item[17]
    smgBackgroundRed,     // ImageList.Items.Item[18]
    smgBackgroundYellow,  // ImageList.Items.Item[19]
    smgHintergrundRot,    // ImageList.Items.Item[20]
    smgItemMedikit        // ImageList.Items.Item[21]
  );
 
  // DirectX\Sound.dxw
  TSpaceMissionSound = (
    smsNone,
    smsSceneMov,      // WaveList.Items.Item[0]
    smsExplosion,     // WaveList.Items.Item[1]
    smsHit,           // WaveList.Items.Item[2]
    smsShoot,         // WaveList.Items.Item[3]
    smsItemCollected  // WaveList.Items.Item[4]
  );
 
function OwnDirectory: string;
 
const
  FOLDERID_SavedGames: TGuid = '{4C5C32FF-BB9D-43b0-B5B4-2D72E54EAAA4}'; // do not localize
 
// Useful functions
procedure SpaceMission_SwitchLanguage;
function GetKnownFolderPath(const rfid: TGUID): string;
function KillTask(ExeFileName: string): Integer;
procedure CheckForUpdates(ViaThinkSoftProjectName: string; AVersion: string);
 
implementation
 
uses
  Windows, SysUtils, Dialogs, ActiveX, ShlObj, TlHelp32, wininet, Forms, ShellAPI,
  System.UITypes;
 
procedure SwitchLanguage(newLang: string);
var
  oldHInst: hInst;
  newHInst: hInst;
  bakOverride: string;
  FileName: array [0..MAX_PATH] of Char;
  Module: PLibModule;
begin
  Module := LibModuleList;
  GetModuleFileName(Module.Instance, FileName, Length(FileName));
 
  bakOverride := GetLocaleOverride('');
  try
    SetLocaleOverride(newLang);
 
    // Note: SetLocaleOverride() alone does not work, because LibModuleList.ResInstance
    // is already set and won't be re-set by the FindResourceHInstance()!
    newHInst := LoadResourceModule(FileName);
 
    if newHInst = 0 then newHInst := Module.Instance;
 
    oldHInst := Module.ResInstance;
    Module.ResInstance := newHInst;
    FreeLibrary(oldHInst);
  except
    SetLocaleOverride(bakOverride);
  end;
end;
 
function GetUserDefaultUILanguage: LANGID; stdcall; external 'kernel32';
 
procedure SpaceMission_SwitchLanguage;
const
  BaseLanguage = LANG_GERMAN;
  DesiredFallbackLanguage = 'ENU'; // English USA
begin
  // We need this because of a tricky problem...
  // Our base language is German (DE), and we have a translation for English USA (ENU)
  // If the system locale is not exactly ENU (even ENG is not accepted), then the base language (German) will be used.
  // But much more people are speaking English than German. So we need to force the system to use ENU instead of DE.
  // This decision if we choose DE or ENU is done by the language selected during setup.
  if (GetLocaleOverride('') = '') and
     ((GetUserDefaultUILanguage and $FF) <> BaseLanguage) then
  begin
    SwitchLanguage(DesiredFallbackLanguage);
  end;
end;
 
function GetKnownFolderPath(const rfid: TGUID): string;
var
  OutPath: PWideChar;
begin
  // https://www.delphipraxis.net/135471-unit-zur-verwendung-von-shgetknownfolderpath.html
  if ShGetKnownFolderPath(rfid, 0, 0, OutPath) {>= 0} = S_OK then
  begin
    Result := OutPath;
    // From MSDN
    // ppszPath [out]
    // Type: PWSTR*
    // When this method returns, contains the address of a pointer to a null-terminated Unicode string that specifies the path of the known folder
    // The calling process is responsible for freeing this resource once it is no longer needed by calling CoTaskMemFree.
    // The returned path does not include a trailing backslash. For example, "C:\Users" is returned rather than "C:\Users\".
    CoTaskMemFree(OutPath);
  end
  else
  begin
    Result := '';
  end;
end;
 
// https://stackoverflow.com/questions/43774320/how-to-kill-a-process-by-name
function KillTask(ExeFileName: string): Integer;
const
  PROCESS_TERMINATE = $0001;
var
  ContinueLoop: BOOL;
  FSnapshotHandle: THandle;
  FProcessEntry32: TProcessEntry32;
begin
  Result := 0;
  FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
  ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
 
  while Integer(ContinueLoop) <> 0 do
  begin
    if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
      UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =
      UpperCase(ExeFileName))) then
      Result := Integer(TerminateProcess(
                        OpenProcess(PROCESS_TERMINATE,
                                    BOOL(0),
                                    FProcessEntry32.th32ProcessID),
                                    0));
     ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
  end;
  CloseHandle(FSnapshotHandle);
end;
 
function OwnDirectory: string;
begin
  result := extractfilepath(paramstr(0));
end;
 
// https://www.delphipraxis.net/post43515.html , fixed , works for Delphi 12 Athens
function GetHTML(AUrl: string): RawByteString;
var
  databuffer : array[0..4095] of ansichar; // SIC! ansichar!
  ResStr : ansistring; // SIC! ansistring
  hSession, hfile: hInternet;
  dwindex,dwcodelen,dwread,dwNumber: cardinal;
  dwcode : array[1..20] of char;
  res    : pchar;
  Str    : pansichar; // SIC! pansichar
begin
  ResStr:='';
  if (system.pos('http://',lowercase(AUrl))=0) and // do not localize
     (system.pos('https://',lowercase(AUrl))=0) then // do not localize
     AUrl:='http://'+AUrl; // do not localize
 
  // Hinzugefügt
  if Assigned(Application) then Application.ProcessMessages;
 
  hSession:=InternetOpen('InetURL:/1.0', // do not localize
                         INTERNET_OPEN_TYPE_PRECONFIG,
                         nil,
                         nil,
                         0);
  if assigned(hsession) then
  begin
    // Hinzugefügt
    if Assigned(Application) then application.ProcessMessages;
 
    hfile:=InternetOpenUrl(
           hsession,
           pchar(AUrl),
           nil,
           0,
           INTERNET_FLAG_RELOAD,
           0);
    dwIndex  := 0;
    dwCodeLen := 10;
 
    // Hinzugefügt
    if Assigned(Application) then application.ProcessMessages;
 
    HttpQueryInfo(hfile,
                  HTTP_QUERY_STATUS_CODE,
                  @dwcode,
                  dwcodeLen,
                  dwIndex);
    res := pchar(@dwcode);
    dwNumber := sizeof(databuffer)-1;
    if (res ='200') or (res = '302') then // do not localize
    begin
      while (InternetReadfile(hfile,
                              @databuffer,
                              dwNumber,
                              DwRead)) do
      begin
 
        // Hinzugefügt
        if Assigned(Application) then application.ProcessMessages;
 
        if dwRead =0 then
          break;
        databuffer[dwread]:=#0;
        Str := pansichar(@databuffer);
        resStr := resStr + Str;
      end;
    end
    else
      ResStr := 'Status:'+AnsiString(res); // do not localize
    if assigned(hfile) then
      InternetCloseHandle(hfile);
  end;
 
  // Hinzugefügt
  if Assigned(Application) then application.ProcessMessages;
 
  InternetCloseHandle(hsession);
  Result := resStr;
end;
 
procedure CheckForUpdates(ViaThinkSoftProjectName: string; AVersion: string);
resourcestring
  SDownloadError = 'Ein Fehler ist aufgetreten. Wahrscheinlich ist keine Internetverbindung aufgebaut, oder der der ViaThinkSoft-Server vorübergehend offline.';
  SNewProgramVersionAvailable = 'Eine neue Programmversion ist vorhanden. Möchten Sie diese jetzt herunterladen?';
  SNoUpdateAvailable = 'Es ist keine neue Programmversion vorhanden.';
var
  cont: RawByteString;
begin
  cont := GetHTML('https://www.viathinksoft.de/update/?id='+ViaThinkSoftProjectName); // do not localize
  if copy(cont, 0, 7) = 'Status:' then
  begin
    MessageDlg(SDownloadError, mtError, [mbOk], 0);
  end
  else
  begin
    if string(cont) <> AVersion then
    begin
      if MessageDlg(SNewProgramVersionAvailable, mtConfirmation, mbYesNoCancel, 0) = mrYes then
        shellexecute(application.handle, 'open', pchar('https://www.viathinksoft.de/update/?id=@'+ViaThinkSoftProjectName), '', '', sw_normal); // do not localize
    end
    else
    begin
      MessageDlg(SNoUpdateAvailable, mtInformation, [mbOk], 0);
    end;
  end;
end;
 
end.
 

Rev 94	Rev 96
1	unit Global;	1	unit Global;
2		2
3	interface	3	interface
4		4
5	const	5	const
6	ProgramVersion = '1.2.2';	6	ProgramVersion = '1.2.2';
7	LevEditRasterW = 48;	7	LevEditRasterW = 48;
8	LevEditRasterH = 32;	8	LevEditRasterH = 32;
9	LevEditRows = 15; // Attention: if you change this, you also need to change the LevEditor GUI!	9	LevEditRows = 15; // Attention: if you change this, you also need to change the LevEditor GUI!
10	LevEditCols = 13; // Attention: if you change this, you also need to change the LevEditor GUI!	10	LevEditCols = 13; // Attention: if you change this, you also need to change the LevEditor GUI!
11	MaxPossibleEnemyLives = 999;	11	MaxPossibleEnemyLives = 999;
12	MaxPossibleLevels = 999;	12	MaxPossibleLevels = 999;
13	RegistrySettingsKey = 'SOFTWARE\ViaThinkSoft\SpaceMission\Settings'; // do not localize	13	RegistrySettingsKey = 'SOFTWARE\ViaThinkSoft\SpaceMission\Settings'; // do not localize
14	MusicSettingKey = 'Music'; // do not localize	14	MusicSettingKey = 'Music'; // do not localize
15	SoundSettingKey = 'Sound'; // do not localize	15	SoundSettingKey = 'Sound'; // do not localize
16	SpeedSettingKey = 'GameSpeed'; // do not localize	16	SpeedSettingKey = 'GameSpeed'; // do not localize
17	DefaultLevelLength = 1200;	17	DefaultLevelLength = 1200;
18	StartLives = 6;	18	StartLives = 6;
19	SpeedEasy = 650 div 60; // 10	19	SpeedEasy = 650 div 60; // 10
20	SpeedMedium = 1000 div 60; // 16	20	SpeedMedium = 1000 div 60; // 16
21	SpeedHard = 1350 div 60; // 22	21	SpeedHard = 1350 div 60; // 22
22	SpeedMaster = 2000 div 60; // 33	22	SpeedMaster = 2000 div 60; // 33
23	DEFAULT_ANIMSPEED = 15/1000;	23	DEFAULT_ANIMSPEED = 15/1000;
24	BossWidth = 4;	24	BossWidth = 4;
25	BossHeight = 2;	25	BossHeight = 2;
26	SpaceMissionExe = 'SpaceMission.exe'; // do not localize	26	SpaceMissionExe = 'SpaceMission.exe'; // do not localize
27	LevEditExe = 'LevEdit.exe'; // do not localize	27	LevEditExe = 'LevEdit.exe'; // do not localize
28	DxgFile = 'DirectX\Graphics.dxg'; // do not localize	28	DxgFile = 'DirectX\Graphics.dxg'; // do not localize
29	DxwFile = 'DirectX\Sound.dxw'; // do not localize	29	DxwFile = 'DirectX\Sound.dxw'; // do not localize
30	DxmFile = 'DirectX\Music.dxm'; // do not localize	30	DxmFile = 'DirectX\Music.dxm'; // do not localize
31	RandomLevelMaxEnemyLives = 10;	31	RandomLevelMaxEnemyLives = 10;
32	RandomLevelMedikitEveryX = 250;	32	RandomLevelMedikitEveryX = 250;
33	RandomLevelAdditionalEnemiesPerLevel = 75; // Zufalls-Level	33	RandomLevelAdditionalEnemiesPerLevel = 75; // Zufalls-Level
34		34
35	const	35	const
36	// Cheat1 = 'Kmkjk'+#39+'Khyc';	36	// Cheat1 = 'Kmkjk'+#39+'Khyc';
37	Cheat1 = #75+#109+#107+#106+#107+#127+#39+#75+#104+#121+#99; {Johnny Cash}	37	Cheat1 = #75+#109+#107+#106+#107+#127+#39+#75+#104+#121+#99; {Johnny Cash}
38		38
39	resourcestring	39	resourcestring
40	Cheat1Text = 'Unendlich Leben!';	40	Cheat1Text = 'Unendlich Leben!';
41		41
42	type	42	type
43	TCheat = (ctUnknown, ctInfiniteLives);	43	TCheat = (ctUnknown, ctInfiniteLives);
44	TCheatSet = set of TCheat;	44	TCheatSet = set of TCheat;
45		45
46	// DirectX\Music.dxm	46	// DirectX\Music.dxm
47	TSpaceMissionMusicTrack = (	47	TSpaceMissionMusicTrack = (
48	smmNone,	48	smmNone,
49	smmBoss, // dxmusic.Midis[0]	49	smmBoss, // dxmusic.Midis[0]
50	smmGame, // dxmusic.Midis[1]	50	smmGame, // dxmusic.Midis[1]
51	smmScene, // dxmusic.Midis[2]	51	smmScene, // dxmusic.Midis[2]
52	smmTitle // dxmusic.Midis[3]	52	smmTitle // dxmusic.Midis[3]
53	);	53	);
54		54
55	// DirectX\Graphics.dxg	55	// DirectX\Graphics.dxg
56	TSpaceMissionGraphicSprite = (	56	TSpaceMissionGraphicSprite = (
57	smgNone,	57	smgNone,
58	smgEnemyDisk, // ImageList.Items.Item[0]	58	smgEnemyDisk, // ImageList.Items.Item[0]
59	smgEnemyAttacker, // ImageList.Items.Item[1]	59	smgEnemyAttacker, // ImageList.Items.Item[1]
60	smgEnemyBoss, // ImageList.Items.Item[2]	60	smgEnemyBoss, // ImageList.Items.Item[2]
61	smgBounce, // ImageList.Items.Item[3]	61	smgBounce, // ImageList.Items.Item[3]
62	smgMachine, // ImageList.Items.Item[4]	62	smgMachine, // ImageList.Items.Item[4]
63	smgEnemyAttacker2, // ImageList.Items.Item[5]	63	smgEnemyAttacker2, // ImageList.Items.Item[5]
64	smgEnemyAttacker3, // ImageList.Items.Item[6]	64	smgEnemyAttacker3, // ImageList.Items.Item[6]
65	smgEnemyMeteor, // ImageList.Items.Item[7]	65	smgEnemyMeteor, // ImageList.Items.Item[7]
66	smgBounce2, // ImageList.Items.Item[8]	66	smgBounce2, // ImageList.Items.Item[8]
67	smgEnemyDisk2, // ImageList.Items.Item[9]	67	smgEnemyDisk2, // ImageList.Items.Item[9]
68	smgLogo, // ImageList.Items.Item[10]	68	smgLogo, // ImageList.Items.Item[10]
69	smgExplosion, // ImageList.Items.Item[11]	69	smgExplosion, // ImageList.Items.Item[11]
70	smgBackgroundPlanet1, // ImageList.Items.Item[12]	70	smgBackgroundPlanet1, // ImageList.Items.Item[12]
71	smgMatrix, // ImageList.Items.Item[13]	71	smgMatrix, // ImageList.Items.Item[13]
72	smgStar1, // ImageList.Items.Item[14]	72	smgStar1, // ImageList.Items.Item[14]
73	smgStar2, // ImageList.Items.Item[15]	73	smgStar2, // ImageList.Items.Item[15]
74	smgStar3, // ImageList.Items.Item[16]	74	smgStar3, // ImageList.Items.Item[16]
75	smgBackgroundBlue, // ImageList.Items.Item[17]	75	smgBackgroundBlue, // ImageList.Items.Item[17]
76	smgBackgroundRed, // ImageList.Items.Item[18]	76	smgBackgroundRed, // ImageList.Items.Item[18]
77	smgBackgroundYellow, // ImageList.Items.Item[19]	77	smgBackgroundYellow, // ImageList.Items.Item[19]
78	smgHintergrundRot, // ImageList.Items.Item[20]	78	smgHintergrundRot, // ImageList.Items.Item[20]
79	smgItemMedikit // ImageList.Items.Item[21]	79	smgItemMedikit // ImageList.Items.Item[21]
80	);	80	);
81		81
82	// DirectX\Sound.dxw	82	// DirectX\Sound.dxw
83	TSpaceMissionSound = (	83	TSpaceMissionSound = (
84	smsNone,	84	smsNone,
85	smsSceneMov, // WaveList.Items.Item[0]	85	smsSceneMov, // WaveList.Items.Item[0]
86	smsExplosion, // WaveList.Items.Item[1]	86	smsExplosion, // WaveList.Items.Item[1]
87	smsHit, // WaveList.Items.Item[2]	87	smsHit, // WaveList.Items.Item[2]
88	smsShoot, // WaveList.Items.Item[3]	88	smsShoot, // WaveList.Items.Item[3]
89	smsItemCollected // WaveList.Items.Item[4]	89	smsItemCollected // WaveList.Items.Item[4]
90	);	90	);
91		91
92	function OwnDirectory: string;	92	function OwnDirectory: string;
93		93
94	const	94	const
95	FOLDERID_SavedGames: TGuid = '{4C5C32FF-BB9D-43b0-B5B4-2D72E54EAAA4}'; // do not localize	95	FOLDERID_SavedGames: TGuid = '{4C5C32FF-BB9D-43b0-B5B4-2D72E54EAAA4}'; // do not localize
96		96
97	// Useful functions	97	// Useful functions
98	procedure SpaceMission_SwitchLanguage;	98	procedure SpaceMission_SwitchLanguage;
99	function GetKnownFolderPath(const rfid: TGUID): string;	99	function GetKnownFolderPath(const rfid: TGUID): string;
100	function KillTask(ExeFileName: string): Integer;	100	function KillTask(ExeFileName: string): Integer;
101	procedure CheckForUpdates(ViaThinkSoftProjectName: string; AVersion: string);	101	procedure CheckForUpdates(ViaThinkSoftProjectName: string; AVersion: string);
102		102
103	implementation	103	implementation
104		104
105	uses	105	uses
106	Windows, SysUtils, Dialogs, ActiveX, ShlObj, TlHelp32, wininet, Forms, ShellAPI,	106	Windows, SysUtils, Dialogs, ActiveX, ShlObj, TlHelp32, wininet, Forms, ShellAPI,
107	System.UITypes;	107	System.UITypes;
108		108
109	procedure SwitchLanguage(newLang: string);	109	procedure SwitchLanguage(newLang: string);
110	var	110	var
-		111	oldHInst: hInst;
111	bakHInst: hInst;	112	newHInst: hInst;
112	modFileName: string;	113	bakOverride: string;
-		114	FileName: array [0..MAX_PATH] of Char;
-		115	Module: PLibModule;
113	begin	116	begin
-		117	Module := LibModuleList;
-		118	GetModuleFileName(Module.Instance, FileName, Length(FileName));
-		119
-		120	bakOverride := GetLocaleOverride('');
-		121	try
114	SetLocaleOverride(newLang);	122	SetLocaleOverride(newLang);
115		123
116	// Note: SetLocaleOverride() does not work, because LibModuleList.ResInstance	124	// Note: SetLocaleOverride() alone does not work, because LibModuleList.ResInstance
117	// is already set and won't be re-set by the FindResourceHInstance()!	125	// is already set and won't be re-set by the FindResourceHInstance()!
118	bakHInst := LibModuleList.ResInstance;	126	newHInst := LoadResourceModule(FileName);
119	modFileName := ChangeFileExt(ParamStr(0),'.'+GetLocaleOverride(ParamStr(0)));	-
120	LibModuleList.ResInstance := LoadResourceModule(PChar(modFileName));	127	if newHInst = 0 then newHInst := Module.Instance;
-		128
121	if LibModuleList.ResInstance = 0 then	129	oldHInst := Module.ResInstance;
122	LibModuleList.ResInstance := LibModuleList.Instance;	130	Module.ResInstance := newHInst;
123	FreeLibrary(bakHInst);	131	FreeLibrary(oldHInst);
-		132	except
-		133	SetLocaleOverride(bakOverride);
-		134	end;
124	end;	135	end;
125		136
126	function GetUserDefaultUILanguage: LANGID; stdcall; external 'kernel32';	137	function GetUserDefaultUILanguage: LANGID; stdcall; external 'kernel32';
127		138
128	procedure SpaceMission_SwitchLanguage;	139	procedure SpaceMission_SwitchLanguage;
-		140	const
-		141	BaseLanguage = LANG_GERMAN;
-		142	DesiredFallbackLanguage = 'ENU'; // English USA
129	begin	143	begin
130	// We need this because of a tricky problem...	144	// We need this because of a tricky problem...
131	// Our base language is German (DE), and we have a translation for English USA (ENU)	145	// Our base language is German (DE), and we have a translation for English USA (ENU)
132	// If the system locale is not exactly ENU (even ENG is not accepted), then the base language (German) will be used.	146	// If the system locale is not exactly ENU (even ENG is not accepted), then the base language (German) will be used.
133	// But much more people are speaking English than German. So we need to force the system to use ENU instead of DE.	147	// But much more people are speaking English than German. So we need to force the system to use ENU instead of DE.
134	// This decision if we choose DE or ENU is done by the language selected during setup.	148	// This decision if we choose DE or ENU is done by the language selected during setup.
-		149	if (GetLocaleOverride('') = '') and
135	if (GetUserDefaultUILanguage and $FF) <> LANG_GERMAN then	150	((GetUserDefaultUILanguage and $FF) <> BaseLanguage) then
-		151	begin
136	SwitchLanguage('ENU');	152	SwitchLanguage(DesiredFallbackLanguage);
-		153	end;
137	end;	154	end;
138		155
139	function GetKnownFolderPath(const rfid: TGUID): string;	156	function GetKnownFolderPath(const rfid: TGUID): string;
140	var	157	var
141	OutPath: PWideChar;	158	OutPath: PWideChar;
142	begin	159	begin
143	// https://www.delphipraxis.net/135471-unit-zur-verwendung-von-shgetknownfolderpath.html	160	// https://www.delphipraxis.net/135471-unit-zur-verwendung-von-shgetknownfolderpath.html
144	if ShGetKnownFolderPath(rfid, 0, 0, OutPath) {>= 0} = S_OK then	161	if ShGetKnownFolderPath(rfid, 0, 0, OutPath) {>= 0} = S_OK then
145	begin	162	begin
146	Result := OutPath;	163	Result := OutPath;
147	// From MSDN	164	// From MSDN
148	// ppszPath [out]	165	// ppszPath [out]
149	// Type: PWSTR*	166	// Type: PWSTR*
150	// When this method returns, contains the address of a pointer to a null-terminated Unicode string that specifies the path of the known folder	167	// When this method returns, contains the address of a pointer to a null-terminated Unicode string that specifies the path of the known folder
151	// The calling process is responsible for freeing this resource once it is no longer needed by calling CoTaskMemFree.	168	// The calling process is responsible for freeing this resource once it is no longer needed by calling CoTaskMemFree.
152	// The returned path does not include a trailing backslash. For example, "C:\Users" is returned rather than "C:\Users\".	169	// The returned path does not include a trailing backslash. For example, "C:\Users" is returned rather than "C:\Users\".
153	CoTaskMemFree(OutPath);	170	CoTaskMemFree(OutPath);
154	end	171	end
155	else	172	else
156	begin	173	begin
157	Result := '';	174	Result := '';
158	end;	175	end;
159	end;	176	end;
160		177
161	// https://stackoverflow.com/questions/43774320/how-to-kill-a-process-by-name	178	// https://stackoverflow.com/questions/43774320/how-to-kill-a-process-by-name
162	function KillTask(ExeFileName: string): Integer;	179	function KillTask(ExeFileName: string): Integer;
163	const	180	const
164	PROCESS_TERMINATE = $0001;	181	PROCESS_TERMINATE = $0001;
165	var	182	var
166	ContinueLoop: BOOL;	183	ContinueLoop: BOOL;
167	FSnapshotHandle: THandle;	184	FSnapshotHandle: THandle;
168	FProcessEntry32: TProcessEntry32;	185	FProcessEntry32: TProcessEntry32;
169	begin	186	begin
170	Result := 0;	187	Result := 0;
171	FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);	188	FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
172	FProcessEntry32.dwSize := SizeOf(FProcessEntry32);	189	FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
173	ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);	190	ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
174		191
175	while Integer(ContinueLoop) <> 0 do	192	while Integer(ContinueLoop) <> 0 do
176	begin	193	begin
177	if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =	194	if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
178	UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =	195	UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =
179	UpperCase(ExeFileName))) then	196	UpperCase(ExeFileName))) then
180	Result := Integer(TerminateProcess(	197	Result := Integer(TerminateProcess(
181	OpenProcess(PROCESS_TERMINATE,	198	OpenProcess(PROCESS_TERMINATE,
182	BOOL(0),	199	BOOL(0),
183	FProcessEntry32.th32ProcessID),	200	FProcessEntry32.th32ProcessID),
184	0));	201	0));
185	ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);	202	ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
186	end;	203	end;
187	CloseHandle(FSnapshotHandle);	204	CloseHandle(FSnapshotHandle);
188	end;	205	end;
189		206
190	function OwnDirectory: string;	207	function OwnDirectory: string;
191	begin	208	begin
192	result := extractfilepath(paramstr(0));	209	result := extractfilepath(paramstr(0));
193	end;	210	end;
194		211
195	// https://www.delphipraxis.net/post43515.html , fixed , works for Delphi 12 Athens	212	// https://www.delphipraxis.net/post43515.html , fixed , works for Delphi 12 Athens
196	function GetHTML(AUrl: string): RawByteString;	213	function GetHTML(AUrl: string): RawByteString;
197	var	214	var
198	databuffer : array[0..4095] of ansichar; // SIC! ansichar!	215	databuffer : array[0..4095] of ansichar; // SIC! ansichar!
199	ResStr : ansistring; // SIC! ansistring	216	ResStr : ansistring; // SIC! ansistring
200	hSession, hfile: hInternet;	217	hSession, hfile: hInternet;
201	dwindex,dwcodelen,dwread,dwNumber: cardinal;	218	dwindex,dwcodelen,dwread,dwNumber: cardinal;
202	dwcode : array[1..20] of char;	219	dwcode : array[1..20] of char;
203	res : pchar;	220	res : pchar;
204	Str : pansichar; // SIC! pansichar	221	Str : pansichar; // SIC! pansichar
205	begin	222	begin
206	ResStr:='';	223	ResStr:='';
207	if (system.pos('http://',lowercase(AUrl))=0) and // do not localize	224	if (system.pos('http://',lowercase(AUrl))=0) and // do not localize
208	(system.pos('https://',lowercase(AUrl))=0) then // do not localize	225	(system.pos('https://',lowercase(AUrl))=0) then // do not localize
209	AUrl:='http://'+AUrl; // do not localize	226	AUrl:='http://'+AUrl; // do not localize
210		227
211	// Hinzugefügt	228	// Hinzugefügt
212	if Assigned(Application) then Application.ProcessMessages;	229	if Assigned(Application) then Application.ProcessMessages;
213		230
214	hSession:=InternetOpen('InetURL:/1.0', // do not localize	231	hSession:=InternetOpen('InetURL:/1.0', // do not localize
215	INTERNET_OPEN_TYPE_PRECONFIG,	232	INTERNET_OPEN_TYPE_PRECONFIG,
216	nil,	233	nil,
217	nil,	234	nil,
218	0);	235	0);
219	if assigned(hsession) then	236	if assigned(hsession) then
220	begin	237	begin
221	// Hinzugefügt	238	// Hinzugefügt
222	if Assigned(Application) then application.ProcessMessages;	239	if Assigned(Application) then application.ProcessMessages;
223		240
224	hfile:=InternetOpenUrl(	241	hfile:=InternetOpenUrl(
225	hsession,	242	hsession,
226	pchar(AUrl),	243	pchar(AUrl),
227	nil,	244	nil,
228	0,	245	0,
229	INTERNET_FLAG_RELOAD,	246	INTERNET_FLAG_RELOAD,
230	0);	247	0);
231	dwIndex := 0;	248	dwIndex := 0;
232	dwCodeLen := 10;	249	dwCodeLen := 10;
233		250
234	// Hinzugefügt	251	// Hinzugefügt
235	if Assigned(Application) then application.ProcessMessages;	252	if Assigned(Application) then application.ProcessMessages;
236		253
237	HttpQueryInfo(hfile,	254	HttpQueryInfo(hfile,
238	HTTP_QUERY_STATUS_CODE,	255	HTTP_QUERY_STATUS_CODE,
239	@dwcode,	256	@dwcode,
240	dwcodeLen,	257	dwcodeLen,
241	dwIndex);	258	dwIndex);
242	res := pchar(@dwcode);	259	res := pchar(@dwcode);
243	dwNumber := sizeof(databuffer)-1;	260	dwNumber := sizeof(databuffer)-1;
244	if (res ='200') or (res = '302') then // do not localize	261	if (res ='200') or (res = '302') then // do not localize
245	begin	262	begin
246	while (InternetReadfile(hfile,	263	while (InternetReadfile(hfile,
247	@databuffer,	264	@databuffer,
248	dwNumber,	265	dwNumber,
249	DwRead)) do	266	DwRead)) do
250	begin	267	begin
251		268
252	// Hinzugefügt	269	// Hinzugefügt
253	if Assigned(Application) then application.ProcessMessages;	270	if Assigned(Application) then application.ProcessMessages;
254		271
255	if dwRead =0 then	272	if dwRead =0 then
256	break;	273	break;
257	databuffer[dwread]:=#0;	274	databuffer[dwread]:=#0;
258	Str := pansichar(@databuffer);	275	Str := pansichar(@databuffer);
259	resStr := resStr + Str;	276	resStr := resStr + Str;
260	end;	277	end;
261	end	278	end
262	else	279	else
263	ResStr := 'Status:'+AnsiString(res); // do not localize	280	ResStr := 'Status:'+AnsiString(res); // do not localize
264	if assigned(hfile) then	281	if assigned(hfile) then
265	InternetCloseHandle(hfile);	282	InternetCloseHandle(hfile);
266	end;	283	end;
267		284
268	// Hinzugefügt	285	// Hinzugefügt
269	if Assigned(Application) then application.ProcessMessages;	286	if Assigned(Application) then application.ProcessMessages;
270		287
271	InternetCloseHandle(hsession);	288	InternetCloseHandle(hsession);
272	Result := resStr;	289	Result := resStr;
273	end;	290	end;
274		291
275	procedure CheckForUpdates(ViaThinkSoftProjectName: string; AVersion: string);	292	procedure CheckForUpdates(ViaThinkSoftProjectName: string; AVersion: string);
276	resourcestring	293	resourcestring
277	SDownloadError = 'Ein Fehler ist aufgetreten. Wahrscheinlich ist keine Internetverbindung aufgebaut, oder der der ViaThinkSoft-Server vorübergehend offline.';	294	SDownloadError = 'Ein Fehler ist aufgetreten. Wahrscheinlich ist keine Internetverbindung aufgebaut, oder der der ViaThinkSoft-Server vorübergehend offline.';
278	SNewProgramVersionAvailable = 'Eine neue Programmversion ist vorhanden. Möchten Sie diese jetzt herunterladen?';	295	SNewProgramVersionAvailable = 'Eine neue Programmversion ist vorhanden. Möchten Sie diese jetzt herunterladen?';
279	SNoUpdateAvailable = 'Es ist keine neue Programmversion vorhanden.';	296	SNoUpdateAvailable = 'Es ist keine neue Programmversion vorhanden.';
280	var	297	var
281	cont: RawByteString;	298	cont: RawByteString;
282	begin	299	begin
283	cont := GetHTML('https://www.viathinksoft.de/update/?id='+ViaThinkSoftProjectName); // do not localize	300	cont := GetHTML('https://www.viathinksoft.de/update/?id='+ViaThinkSoftProjectName); // do not localize
284	if copy(cont, 0, 7) = 'Status:' then	301	if copy(cont, 0, 7) = 'Status:' then
285	begin	302	begin
286	MessageDlg(SDownloadError, mtError, [mbOk], 0);	303	MessageDlg(SDownloadError, mtError, [mbOk], 0);
287	end	304	end
288	else	305	else
289	begin	306	begin
290	if string(cont) <> AVersion then	307	if string(cont) <> AVersion then
291	begin	308	begin
292	if MessageDlg(SNewProgramVersionAvailable, mtConfirmation, mbYesNoCancel, 0) = mrYes then	309	if MessageDlg(SNewProgramVersionAvailable, mtConfirmation, mbYesNoCancel, 0) = mrYes then
293	shellexecute(application.handle, 'open', pchar('https://www.viathinksoft.de/update/?id=@'+ViaThinkSoftProjectName), '', '', sw_normal); // do not localize	310	shellexecute(application.handle, 'open', pchar('https://www.viathinksoft.de/update/?id=@'+ViaThinkSoftProjectName), '', '', sw_normal); // do not localize
294	end	311	end
295	else	312	else
296	begin	313	begin
297	MessageDlg(SNoUpdateAvailable, mtInformation, [mbOk], 0);	314	MessageDlg(SNoUpdateAvailable, mtInformation, [mbOk], 0);
298	end;	315	end;
299	end;	316	end;
300	end;	317	end;
301		318
302	end.	319	end.
303		320

Subversion Repositories spacemission

spacemission/Global.pas – Rev 94 → 96