#Dim All
#Include "Win32api.inc"
#Include "H:\PBCC\CGI\TNGMP3\PBCGI.INC"
Type MyApp
title As String * 17
ver As String * 4
creator As String * 27
copyrite As String * 19
rights As String * 20
ccsurl As String * 21
End Type
Global osinfo As OSVERSIONINFO
Global MemStat As MEMORYSTATUS
Global App as MyApp
Declare Function DrawCC() As Long
Declare Function GetWindowsVersion() As String
Declare Function GetPCTimeandDate(DateFormat As Long, TimeFormat As Long, Separator As String,tzInfo As TIME_ZONE_INFORMATION) As String
Declare Function GetRegistrationInfo(wRegUser As String,wRegCompany As String,wRegProdID As String) As Long
Declare Function GetSetting(lpKey As Long ,ByVal MainKey As String, ByVal SubKey As String, _
ByVal Default As String) As String
Declare Function CPUName () As String
Declare Function CPUSpeed () As String
Declare Function CPUMfc () As String
Declare Function GetPIIISerial As String
Declare Function CCSGetWindowsTempDir()As String
Declare Function CCSGetWindowsDirectory() As String
Declare Function CCSGetSystemDirectory() As String
Declare Function CCSGetVolumeInformation(Drive As String,SerialNo As String,VolLabel As String) As Long
Declare Function GetINIData( IniFile As String,GroupName As String, ParName As String, wDefault As String)As String
Declare Function DriveIsAvailable(ByVal Drive As String) As Long
Declare Function DriveType(Drive As String) As String
Function WinMain (ByVal hInstance As Long, _
ByVal hPrevInstance As Long, _
lpCmdLine As Asciiz Ptr, _
ByVal iCmdShow As Long) As Long
Local R As String
Local Windows As String
Local MS As String
Local MSCopyright As String
Dim Param(1) As String
Local st As String
Local tablebld As String
Local VolumeSerial As String
Local VolumeLabel As String
Local CGICommand As String
Local x As String
Local wRegUser As String
Local wRegCompany As String
Local wRegProdID As String
Local lResult As Long
Local lLoop As Long
Dim App As myapp
Dim osinfo As OSVERSIONINFO
Dim MemStat As MEMORYSTATUS
Dim tzInfo As TIME_ZONE_INFORMATION
Dim SysInfo As SYSTEM_INFO
' Read from STDIN
st = ReadCGI
' Count and parse the parameters into an array
lResult = ParseParams(x, Param())
'For use later
'CGICommand = Trim$(Parse$(Param(1),"=",1))
'Select Case CGICommand
' Case "action"
' x = Parse$(Param(1),"=",-1)
'End Select
app.creator = "Computer Creations Software"
app.ver = "v1.40"
app.title = "TNGSYSINFO"
app.copyrite = "Copyright © 2000"
app.rights = "All rights reserved."
app.ccsurl = "http://www.tngbbs.com"
If IsFalse Len(Server_Software) Then
DrawCC
Exit Function
End If
R = " (R) "
Windows = "Windows"
MS = "Microsoft" + R + Windows
MSCopyright = "Copyright 1981-1999 " + Left$(MS,10) + " Corp."
tablebld = String$(2,$CRLF) + "<!---------TNG Server info Listing Begins here------->" + String$(2,$CRLF)
tablebld = tablebld + "<TABLE BORDER=""1""" + ">" + String$(2,$CRLF)
tablebld = tablebld + "<TR><TD BGCOLOR=""#11FCFF"">" + App.Title + " " + App.Ver + " " + App.copyrite + " <a href=" + app.ccsurl + ">" + App.creator + "</A></TD></TR>" + $CRLF
tablebld = tablebld + "</TABLE>" + String$(2,$CRLF)
osinfo.dwOsVersionInfoSize = SizeOf(osinfo)
GetVersionEx osinfo
GlobalMemoryStatus MemStat
GetSystemInfo SysInfo
lResult = GetRegistrationInfo(wRegUser,wRegCompany,wRegProdID)
lResult = CCSGetVolumeInformation(Environ$("SystemDrive"),VolumeSerial,VolumeLabel)
WriteCGI "<html>"
WriteCGI "<head><Title>" & app.title & "</title>"
WriteCGI "</head>"
WriteCGI "<body bgcolor=""#FFFFFF"" text=""#000000""></body>"
'Write the table using above params
WriteCGI tablebld
WriteCGI "<TABLE BORDER=""1""" + ">" + String$(2,$CRLF)
WriteCGI "<TR><TD>Current Time/Date: </TD>" & "<TD>" & GetPCTimeandDate(%DATE_LONGDATE, %TIME_FORCE24HOURFORMAT, " ",tzinfo) & "</TD></TR>" & $CRLF
WriteCGI "<TR><TD>" & "Operating System </TD><TD>" & GetWindowsVersion & "</TD></TR>" & $CRLF
WriteCGI "<TR><TD>" & "RegisteredUser:</TD><TD>" & wRegUser & "</TD></TR>" & $CRLF
WriteCGI "<TR><TD>" & "RegisteredOrganization:</TD><TD>" & wRegCompany & "</TD></TR>" & $CRLF
WriteCGI "<TR><TD>" & "ProductId:</TD><TD>" & wRegProdID & "</TD></TR>" & $CRLF
WriteCGI "<TR><TD>" & "Memory Available: </TD><TD>" & Format$(MemStat.dwTotalPhys /1024,"###,###") & " kb" & $CRLF
WriteCGI "<TR><TD>" & "Number of Processors </TD><TD>" & Trim$(Str$(SysInfo.dwNumberorfProcessors)) & "</TD></TR>" & $CRLF
WriteCGI "<TR><TD>" & "Processor type:</TD><TD>" & CPUName & "</TD></TR>" & $CRLF
WriteCGI "<TR><TD>" & "Processor speed:</TD><TD>" & CPUSpeed & " Mhz" & "</TD></TR>" & $CRLF
WriteCGI "<TR><TD>" & "Processor Ser #: </TD><TD>" & GetPIIISerial & "</TD></TR>" & $CRLF
WriteCGI "<TR><TD>" & "TEMP Folder: </TD><TD>" & CCSGetWindowsTempDir & "</TD></TR>" & $CRLF
WriteCGI "<TR><TD>" & "Windows Directory: </TD><TD>" & CCSGetWindowsDirectory & "</TD></TR>" & $CRLF
WriteCGI "<TR><TD>" & "System Directory: </TD><TD>" & CCSGetSystemDirectory & "</TD></TR>" & $CRLF
'Volume Info for System Root
WriteCGI "<TR><TD>" & "System Root: </TD><TD>" & Environ$("SystemDrive") & "<BR>" & $CRLF
WriteCGI "Volume Label: " & VolumeLabel & "<br>" & $CRLF
WriteCGI "Volume Serial No: " & VolumeSerial & "</TD></TR>" & $CRLF
'Retrieve all available drives and volume info for each
WriteCGI "<TR><TD>Drives Available:</TD><TD>" & $CRLF
For lLoop = 65 To 90
If IsTrue DriveIsAvailable(ByVal Chr$(lLoop)) Then
VolumeSerial = "":VolumeLabel = ""
lResult = CCSGetVolumeInformation(Chr$(lLoop) + ":\",VolumeSerial,VolumeLabel)
WriteCGI "Drive " & Chr$(lLoop) & ":\<BR>" & $CRLF
WriteCGI "Volume Label: " & VolumeLabel & "<br>" & $CRLF
WriteCGI "Volume Serial No: " & VolumeSerial & "<BR>" & $CRLF
WriteCGI "Drive Type: <B>" & DriveType(Chr$(lLoop) & ":") & "</B><HR>" & $CRLF
End If
Next
WriteCGI "</TD></TR>" 'End drive enumeration TD
WriteCGI "</TABLE>"
WriteCGI "</body></html>"
End Function
'----------------------------------------------------------------------------------------------------
Function GetWindowsVersion() As String
Local osinfo As OSVERSIONINFO
Local lResult As Long
Local St As String
Local NTVer As String
osinfo.dwOsVersionInfoSize = SizeOf(osinfo)
lResult = GetVersionEx(osinfo)
If IsFalse lResult Then
Function = "Windows"
Exit Function
End If
If osinfo.dwPlatformId = %VER_PLATFORM_WIN32_NT Then
Select Case osinfo.dwMajorVersion'
Case 4
St = "Windows NT"
Case 5
St = "Windows 2000"
End Select
NTVer = St + " Version " + Trim$(Str$(osinfo.dwMajorVersion)) + "." + Trim$(Str$(osinfo.dwMinorVersion)) + _
" (Build " + Trim$(Str$(osinfo.dwBuildNumber)) + ": " + osinfo.szCSDVersion + ")"
Function = NTVer
ElseIf osinfo.dwPlatformId = %VER_PLATFORM_WIN32_WINDOWS Then
'dwPlatformId
Select Case osinfo.dwMinorVersion
Case < 10
Function = "Windows 95"
Case 10
If osinfo.dwPlatformId = 1 Then
Function = "Windows 98 OSR1"
ElseIf osinfo.dwPlatformId = 2 Then
Function = "Windows 98 OSR2"
Else
Function = "Windows 98"
End If
Case > 12
Function = "Windows Mil."
End Select
End If
End Function
'-----------------------------------------------------------------------------------
Function GetPCTimeandDate(DateFormat As Long, TimeFormat As Long, Separator As String,tzInfo As TIME_ZONE_INFORMATION) As String
Local stime As SYSTEMTIME
Local tDay As Asciiz * 64
Local tTime As Asciiz * 64
If Separator = "" Then Separator = " "
If DateFormat = 0 Then DateFormat = %DATE_SHORTDATE
If TimeFormat = 0 Then TimeFormat = %TIME_FORCE24HOURFORMAT
GetLocalTime sTime
GetDateFormat %LOCALE_USER_DEFAULT,DateFormat, sTime, ByVal %NULL, tDay, 64
GetTimeFormat %LOCALE_USER_DEFAULT, TimeFormat,sTime, ByVal %NULL, tTime, 64
GetTimeZoneInformation tzInfo
Function = tTime + Separator + tDay
End Function
'----------------------------------------------------------------------------------------------------
Function GetSetting(lpKey As Long ,ByVal MainKey As String, ByVal SubKey As String, _
ByVal Default As String) As String
Local Result As Long
Local KeyType As Long
Local Buffer As String * 2048
Local Size As Long
Local hKey As Long
If Len(MainKey) = 0 Then
Function = Default
Exit Function
End If
' ** Open the section
If RegOpenKeyEx(lpKey, MainKey + Chr$(0),0, %KEY_ALL_ACCESS, hKey) <> %ERROR_SUCCESS Then
Function = Default
Exit Function
End If
' ** Get the key value
Size = SizeOf(Buffer)
Result = RegQueryValueEx(hKey, SubKey + Chr$(0), 0, KeyType, Buffer, Size)
' ** Close the registry
RegCloseKey hKey
' ** Exit if not successful or nothing there
If (Result <> %ERROR_SUCCESS) Or (Size = 0) Then
Function = Default
Exit Function
End If
' ** Return the data
If KeyType = %REG_SZ Then
Function = Left$(Buffer, Size - 1)
Else
Function = Left$(Buffer, Size)
End If
End Function
'------------------------------------------------------------------------------------------
Function GetRegistrationInfo(wRegUser As String,wRegCompany As String,wRegProdID As String) As Long
Local RegKey As String
osinfo.dwOsVersionInfoSize = SizeOf(osinfo)
GetVersionEx osinfo
If osinfo.dwPlatformId = %VER_PLATFORM_WIN32_NT Then
RegKey = "Software\Microsoft\Windows NT\CurrentVersion"
Else
RegKey = "Software\Microsoft\Windows\CurrentVersion"
End If
wRegUser = GetSetting(%HKEY_LOCAL_MACHINE ,ByVal RegKey, "RegisteredOwner","")
wRegCompany = GetSetting(%HKEY_LOCAL_MACHINE ,ByVal RegKey,"RegisteredOrganization","")
wRegProdID = GetSetting(%HKEY_LOCAL_MACHINE ,ByVal RegKey,"ProductId","")
End Function
'------------------------------------------------------------------------------------------
'======================================================================================================================
' GetPIIISerial - Returns serial no on Intel PIII
'----------------------------------------------------------------------------------------------------------------------
Function GetPIIISerial As String
Local t As Dword, m As Dword, b As Dword
!mov eax,1
!cpuid
!mov t,eax
!mov eax,3
!cpuid
!mov m,edx
!mov b,ecx
Function = Hex$(HiWrd(t),4) + "-" + Hex$(LoWrd(t),4) + "-" + Hex$(HiWrd(m),4) + "-" + _
Hex$(LoWrd(m),4) + "-" + Hex$(HiWrd(b),4) + "-" + Hex$(LoWrd(b),4)
End Function
'======================================================================================================================
' CPUMfc - Returns manufacturer name string of CPU
'----------------------------------------------------------------------------------------------------------------------
Function CPUMfc () As String
Dim lID As Local String * 12
! xor eax,eax
! cpuid
! push edi
! lea edi, lID
! mov[edi],ebx
! mov[edi+4],edx
! mov[edi+8],ecx
! pop edi
Function = lID
End Function
'======================================================================================================================
' CPUSpeed - Returns CPU speed in MHz
'----------------------------------------------------------------------------------------------------------------------
Function CPUSpeed () As String
Local lCnt As Dword, lCnt1 As Quad, lCnt2 As Quad, lBoost As Long, lhMod As Long, lhProc As Long, lPrio As Long
lhMod = GetModuleHandle("KERNEL32.DLL")
If lhMod Then
lCnt = GetProcAddress (lhMod,"GetTickCount")
If lCnt Then
lhProc = GetCurrentProcess
lPrio = GetPriorityClass (lhProc) 'Must set back org.prio....
lBoost = SetPriorityClass (lhProc, %REALTIME_PRIORITY_CLASS)
If lBoost Then
! pushad
! call dword ptr lcnt
! mov ecx,eax
Waiter1:
! call dword ptr lcnt
! cmp ecx,eax
! je Waiter1
! mov ecx,eax
! db &h0f, &h31
! mov lcnt1[04],edx
! mov lcnt1[00],eax
! add ecx, 100 ;for 0.1 sec
Waiter2:
! call dword ptr lcnt
! cmp ecx,eax
! ja Waiter2
! db &h0f, &h31
! mov lcnt2[04],edx
! mov lcnt2[00],eax
! popad
SetPriorityClass lhProc, lPrio
Function = Format$((lCnt2 - lCnt1) \ 100000)
Exit Function
End If
End If
End If
Function = ""
End Function
'======================================================================================================================
' CPUName - Returns name string of a CPU
'----------------------------------------------------------------------------------------------------------------------
Function CPUName () As String
Local lFamily As Long, lModel As Long, lStepping As Long, lType As Long
Local lName As String, lCache As Long, lString As String
lString = CPUMfc
If lString = "GenuineIntel" Then
! mov eax,1
! cpuid
! and eax, &b1111
! mov lStepping, eax
! mov eax,1
! cpuid
! shr eax, 4
! and eax, &b1111
! mov lModel, eax
! mov eax,1
! cpuid
! shr eax, 8
! and eax, &b1111
! mov lFamily, eax
! mov eax,1
! cpuid
! shr eax, 12
! and eax, &b11
! mov lType, eax
! mov eax,2
! cpuid
! and edx, &b11111111
! mov lCache, edx
If lFamily = 3 Then
Select Case lModel
Case 0 : lName = "Intel386 DX"
Case 2 : lName = "Intel386 SX/CX"
Case 4 : lName = "Intel386 SL"
End Select
ElseIf lFamily = 4 Then
Select Case lModel
Case 0, 1 : lName = "Intel486 DX"
Case 2 : lName = "Intel486 SX"
Case 3 : lName = "IntelDX2"
Case 4 : lName = "Intel486 SL"
Case 5 : lName = "IntelSX2"
Case 7 : lName = "IntelDX2 Enhanced"
Case 8 : lName = "IntelDX4"
End Select
ElseIf lFamily = 5 Then
Select Case lModel
Case 1, 2 : If lType = 0 Then lName = "Pentium" Else lName = "Pentium OverDrive"
Case 3 : lName = "Intel486 Pentium OverDrive"
Case 4 : If lType = 0 Then lName = "Pentium MMX" Else lName = "Pentium MMX OverDrive"
End Select
ElseIf lFamily = 6 Then
Select Case lModel
Case 1 : lName = "Pentium Pro"
Case 3 : If lType = 0 Then lName = "Pentium II" Else lName = "Pentium II OverDrive"
Case 5
Select Case lCache
Case &h40 : lName = "Celeron"
Case &h41 : lName = "Celeron/128"
Case &h42,&h43,&h82,&h83 : lName = "Pentium II"
Case &h44,&h45,&h84,&h85 : lName = "Pentium II Xeon"
End Select
Case 6 : lName = "Celeron"
Case 7, 8
Select Case lCache
Case &h40 : lName = "Celeron"
Case &h41 : lName = "Celeron/128"
Case &h42,&h43,&h82,&h83 : lName = "Pentium III"
Case &h44,&h45,&h84,&h85 : lName = "Pentium III Xeon"
End Select
Case 10 : lName = "Pentium III Xeon-A"
End Select
Else
lName = "Intel"
End If
Function = lName
Else
Function = lString
End If
End Function
'----------------------------------------------------------------------------------------------------------------------
Function CCSGetWindowsTempDir()As String
Local lResult As Long
Local buff As Asciiz * 255
'GetTempFileName Lib "KERNEL32.DLL" Alias "GetTempFileNameA" (lpszPath As Asciiz, lpPrefixString As Asciiz, ByVal wUnique As Long, lpTempFileName As Asciiz) As Long
lResult = GetTempPath(ByVal SizeOf(buff), Buff)
Function = buff
End Function
'----------------------------------------------------------------------------------------------------------------------
Function CCSGetSystemDirectory() As String
Dim lpBuffer As Asciiz * %Max_Path
Dim PathLength As Long
PathLength = GetSystemDirectory(lpBuffer,%Max_Path)
Function = lpBuffer
End Function
'----------------------------------------------------------------------------------------------------------------------
Function CCSGetWindowsDirectory() As String
Dim lpBuffer As Asciiz * %Max_Path
Dim PathLength As Long
PathLength = GetWindowsDirectory(lpBuffer,%Max_Path)
Function = lpBuffer
End Function
'----------------------------------------------------------------------------------------------------------------------
Function CCSGetVolumeInformation(Drive As String,SerialNo As String,VolLabel As String) As Long
Local lResult As Long
Local HWord As Word
Local LWord As Word
Local lpVolumeNameBuffer As Asciiz * 255
Local lpVolumeSerialNumber As Long
Local lpMaximumComponentLength As Long
Local lpFileSystemFlags As Long
Local FileSysBuffer As Asciiz * 255
Local lpDrive As Asciiz * 4
lpDrive = Drive
lResult = GetVolumeInformation (lpDrive, lpVolumeNameBuffer, SizeOf(lpVolumeNameBuffer)-1, lpVolumeSerialNumber , lpMaximumComponentLength, _
lpFileSystemFlags , FilesysBuffer, SizeOf(FilesysBuffer))
If lResult <> 0 Or lResult = %ERROR_NO_VOLUME_LABEL Then
HWord = HiWrd(lpVolumeSerialNumber)
LWord = LoWrd(lpVolumeSerialNumber)
SerialNo = Right$("0000000"+Hex$(HWord), 4) + "-" + Right$("0000000"+Hex$(LWord), 4)
VolLabel = lpVolumeNameBuffer
Function = %TRUE
Else
Function = %FALSE
End If
End Function
'------------------------------------------------------------------------------------------------------------------------
Function GetINIData( IniFile As String,GroupName As String, ParName As String, wDefault As String) Export As String
Local Result As Long
Local zGroupName As Asciiz * 125
Local zParname As Asciiz * 125
Local zData As Asciiz * 150
Local zDefault As Asciiz * 150
Local zIniFile As Asciiz * 255
zGroupName = GroupName
zParname = Parname
zIniFile = IniFile
zDefault = wDefault
Result = GetPrivateProfileString(zGroupName,zParName,zDefault,zData,SizeOf(zData),zIniFile)
Function = zData
End Function
'------------------------------------------------------------------------------------------------------------------------
Function DriveIsAvailable(ByVal Drive As String) As Long
Local StringVar As String
Local LongVar As Long
Local LongVar2 As Long
Local lresult As Long
Local lptr As Long
Drive = Left$(Drive,1) 'Just the D, not the :
LongVar = GetLogicalDrives
For LongVar2 = 0 To 25
StringVar = StringVar + Ltrim$(Str$(Bit(LongVar, LongVar2),1))
Next
'65 is A
lptr = Asc(Drive) - 64
'1011110000000000
'ABCDEFGHIJKLMNOP etc
Function = Val(Mid$(StringVar,lptr,1))
End Function
'------------------------------------------------------------------------------------------------------------------------
Function DriveType(Drive As String) As String
Local sDrive As Asciiz * 255
Local lresult As Long
%DRIVE_TYPE_UNDTERMINED = 0
%DRIVE_ROOT_NOT_EXIST = 1
%DRIVE_REMOVABLE = 2
%DRIVE_FIXED = 3
%DRIVE_REMOTE = 4
%DRIVE_CDROM = 5
%DRIVE_RAMDISK = 6
sDrive = Drive
lResult = GetDriveType(sDrive)
Select Case lResult
Case %DRIVE_TYPE_UNDTERMINED
Function = "Undetermined"
Case %DRIVE_ROOT_NOT_EXIST
Function = "Root does not exist"
Case %DRIVE_CDROM
Function = "CD-ROM"
Case %DRIVE_FIXED
Function = "Fixed Disk"
Case %DRIVE_RAMDISK
Function = "RAM Disk"
Case %DRIVE_REMOTE
Function = "Remote Drive"
Case %DRIVE_REMOVABLE
Function = "Removable Drive"
End Select
End Function
'------------------------------------------------------------------------------------------------------------------------
Function DrawCC() As Long
Cls
Page 1,2
Local X As Integer
Local Y As Integer
Color 9,0
'1st row of "C1"
Print String$(5,32)+Chr$(220)+ Chr$(219)+ Chr$(223)+ Chr$(220)+ Chr$(219)
'2nd row of "C1"
Print String$(4,32)+Chr$(222)+Chr$(219)+Chr$(221)+String$(2,32)+Chr$(219)
'3rd row of "C1"
Print String$(4,32)+String$(2,219)+String$(3,32);
Color 11,0
'1st row of "C2"
Print Chr$(220)+ Chr$(219)+ Chr$(223)+ Chr$(220)+ Chr$(219)
'4th row of "C1"
Color 9,0
Print String$(4,32)+Chr$(222)+Chr$(219)+Chr$(221)+Chr$(32);
Color 11,0
'2nd row of "C2"
Print Chr$(222)+Chr$(219)+Chr$(221)+String$(2,32)+Chr$(219)
'5th row of "C1"
Color 9,0
Print String$(5,32)+Chr$(223)+Chr$(219)+Chr$(220);
'3rd row of "C2"
Color 11,0
Print String$(2,219)+String$(3,32);
Color 9,0:Print 'Left$(App.Creator,8)
'4th row of "C2"
Color 11,0
Print String$(8,32)+Chr$(222)+Chr$(219)+Chr$(221)+String$(3,32);
Color 9,0
Print " " + App.Creator
Color 11,0
'5th row of "C2"
Print String$(9,32)+Chr$(223)+Chr$(219)+Chr$(220)+Chr$(220)+Chr$(223);
Color 14,0: Print" " + App.title + " " + App.Ver + " 32 bit"
Y=CursorX
X=CursorY
If Y < 25 Then Locate X,17 Else Print:Locate X,17
Color 11,0
Print app.copyrite;
Print " " + app.rights
If Y < 25 Then Locate X + 1,17 Else Print:Locate X + 1,17
Color 15,0:Print "http://www.tngbbs.com"
StdOut
Color 15,0
StdOut "This is a CGI application and is not meant to be run from a Command Prompt"
Page 1,1
Function = 1
End Function
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------------------------------
PowerBASIC Forums
UBBFriend: Email This Page to Someone! 
posted March 26, 2001 02:59 PM
