+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Programs (https://qb64phoenix.com/forum/forumdisplay.php?fid=7)
+---- Thread: Nasty volume delete program (/showthread.php?tid=2040)
Nasty volume delete program - eoredson - 09-27-2023
This a nasty program to delete all volume labels:
Code: (Select All)
These programs ARE PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND.
THE AUTHOR DISCLAIMS ALL WARRANTIES, EITHER EXPRESS OR IMPLIED, INCLUDING
THE WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
IN NO EVENT SHALL THE AUTHOR OR ANY SUPPLIER BE LIABLE FOR ANY DAMAGES
WHATSOEVER INCLUDING DIRECT, INDIRECT, INCIDENTAL, CONSEQUENTIAL, LOSS OF
BUSINESS PROFITS OR SPECIAL DAMAGES, EVEN IF THE AUTHOR OR ANY SUPPLIER HAS
BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
SOME STATES DO NOT ALLOW THE EXCLUSION OR LIMITATION OF LIABILITY FOR
CONSEQUENTIAL OR INCIDENTAL DAMAGES SO THE FOREGOING LIMITATION MAY NOT
APPLY. PLEASE CHECK WITH YOUR LOCAL AND STATE AGENCIES FOR INFORMATION
ABOUT ANY APPLIED RESPONSIBILITIES REGARDING THE ABOVE NOTICES.
Author: Erik Jon Oredson
Email: eoredson@gmail.com
Url: www.filegate.net
These programs and its source public domain 2023.Code: (Select All)
Rem The nasty volume delete program v1.1a PD 2023.
DefLng A-Z
' declare external libraries.
Dim Shared DriveType As String
Dim Shared ErrorBuffer As String * 260
Const MAX_PATH = 260
Declare Library
Function GetDriveType& (d$)
End Declare
Declare Dynamic Library "Shell32"
Function IsUserAnAdmin& ()
Sub ShellExecute Alias "ShellExecuteA" (ByVal hwnd As _Offset, lpOperation As String, lpFile As String, lpParameters As String, Byval lpDirectory As _Offset, Byval nShowCmd As Long)
End Declare
Declare Dynamic Library "kernel32"
Function GetVolumeInformationA& (lpRootPathName$, lpVolumeNameBuffer$, Byval nVolumeNameSize~&, lpVolumeSerialNumber~&, lpMaximumComponentLength~&, lpFileSystemFlags~&, lpFileSystemNameBuffer$, Byval nFileSystemNameSize&)
Function SetVolumeLabelA% (d$, f$)
Function GetLastError& ()
Function FormatMessageA& (ByVal f As Long, f$, Byval e As Long, Byval d As Long, g$, Byval s As Long, h$)
End Declare
If IsUserAnAdmin = 0 Then
Call ShellExecute(0, "runas" + Chr$(0), Command$(0) + Chr$(0), Command$ + Chr$(0), 0, 5)
System
End If
Color 15
v$ = "Are you sure you want to remove all volume labels(y/n)? "
Print v$;
Do
_Limit 50
x$ = InKey$
If x$ <> "" Then
Exit Do
End If
Loop
Print
If LCase$(x$) = "y" Then
f = 0
For Z = 1 To 26
f$ = UCase$(Chr$(Z + 64))
v = GetDriveExists(f$)
If v Then
' get drive info.
VarX$ = f$ + ":\" + Chr$(0)
Vname$ = Space$(MAX_PATH)
Fname$ = Space$(MAX_PATH)
r = GetVolumeInformationA(VarX$, Vname$, MAX_PATH, serial~&, empty1~&, empty2~&, Fname$, MAX_PATH)
If r = 0 Then
Print "Error 0x" + Hex$(GetLastError) + " reading drive: "; Chr$(Z + 64); ":\"
Print DisplayWinError$(r)
Else
' change volume label
f$ = f$ + ":\" + Chr$(0)
g$ = "" + Chr$(0)
x = SetVolumeLabelA%(f$, g$)
If x = 0 Then
Print "Error 0x" + Hex$(GetLastError) + " accessing drive: "; Chr$(Z + 64); ":\"
Print DisplayWinError$(x)
Else
Print "Volume "; Chr$(Z + 64); ":\ zapped."
f = f + 1
End If
End If
End If
Next
Color 14
If f Then
Print "Volume labels zapped:"; f
Else
Print "No volume labels zapped."
End If
Color 15
Print "-more-";
While InKey$ = ""
_Limit 50
Wend
Print
End If
End
' return -1 if drive exists
Function GetDriveExists (V$)
If UCase$(V$) = "A" Or UCase$(V$) = "B" Then
DriveType = "[FLOPPY]"
GetDriveExists = -1
Exit Function
End If
VarX$ = V$ + ":\" + Chr$(0)
VarX = GetDriveType(VarX$)
DriveType = ""
Select Case VarX
Case 0
DriveType = "[UNKNOWN]"
Case 1
DriveType = "[BADROOT]"
Case 2
DriveType = "[REMOVABLE]"
Case 3
DriveType = "[FIXED]"
Case 4
DriveType = "[REMOTE]"
Case 5
DriveType = "[CDROM]"
Case 6
DriveType = "[RAMDISK]"
End Select
If VarX > 1 Then
GetDriveExists = -1
Else
GetDriveExists = 0
End If
End Function
' display windows error message
Function DisplayWinError$ (x)
' define error message value
v& = GetLastError
' call windows error message routine
x& = FormatMessageA&(&H1200, "", v&, 0, ErrorBuffer$, 260, "")
If x& Then
DisplayWinError$ = Left$(ErrorBuffer$, x& - 2)
Else
DisplayWinError$ = "Unknown error 0x" + Hex$(v&) + "."
End If
x = -1
End FunctionThis is some code to rewrite volume labels with random hex strings:
Code: (Select All)
Rem The nasty volume rename program v1.1a PD 2023.
DefLng A-Z
' declare external libraries.
Dim Shared DriveType As String
Dim Shared ErrorBuffer As String * 260
Const MAX_PATH = 260
Declare Library
Function GetDriveType& (d$)
End Declare
Declare Dynamic Library "Shell32"
Function IsUserAnAdmin& ()
Sub ShellExecute Alias "ShellExecuteA" (ByVal hwnd As _Offset, lpOperation As String, lpFile As String, lpParameters As String, Byval lpDirectory As _Offset, Byval nShowCmd As Long)
End Declare
Declare Dynamic Library "kernel32"
Function GetVolumeInformationA& (lpRootPathName$, lpVolumeNameBuffer$, Byval nVolumeNameSize~&, lpVolumeSerialNumber~&, lpMaximumComponentLength~&, lpFileSystemFlags~&, lpFileSystemNameBuffer$, Byval nFileSystemNameSize&)
Function SetVolumeLabelA% (d$, f$)
Function GetLastError& ()
Function FormatMessageA& (ByVal f As Long, f$, Byval e As Long, Byval d As Long, g$, Byval s As Long, h$)
End Declare
If IsUserAnAdmin = 0 Then
Call ShellExecute(0, "runas" + Chr$(0), Command$(0) + Chr$(0), Command$ + Chr$(0), 0, 5)
System
End If
Color 15
v$ = "Are you sure you want to rewrite all volume labels(y/n)? "
Print v$;
Do
_Limit 50
x$ = InKey$
If x$ <> "" Then
Exit Do
End If
Loop
Print
If LCase$(x$) = "y" Then
f = 0
For Z = 1 To 26
f$ = UCase$(Chr$(Z + 64))
v = GetDriveExists(f$)
If v Then
' get drive info.
VarX$ = f$ + ":\" + Chr$(0)
Vname$ = Space$(MAX_PATH)
Fname$ = Space$(MAX_PATH)
r = GetVolumeInformationA(VarX$, Vname$, MAX_PATH, serial~&, empty1~&, empty2~&, Fname$, MAX_PATH)
If r = 0 Then
Print "Error 0x" + Hex$(GetLastError) + " reading drive: "; Chr$(Z + 64); ":\"
Print DisplayWinError$(r)
Else
' change volume label
f$ = f$ + ":\" + Chr$(0)
g$ = GetLabel$ + Chr$(0)
x = SetVolumeLabelA%(f$, g$)
If x = 0 Then
Print "Error 0x" + Hex$(GetLastError) + " accessing drive: "; Chr$(Z + 64); ":\"
Print DisplayWinError$(x)
Else
Print "Setting drive "; f$
f = f + 1
End If
End If
End If
Next
Color 14
If f Then
Print "Volume labels renamed:"; f
Else
Print "No volume labels renamed."
End If
Color 15
Print "-more-";
While InKey$ = ""
_Limit 50
Wend
Print
End If
End
' return -1 if drive exists
Function GetDriveExists (V$)
If UCase$(V$) = "A" Or UCase$(V$) = "B" Then
DriveType = "[FLOPPY]"
GetDriveExists = -1
Exit Function
End If
VarX$ = V$ + ":\" + Chr$(0)
VarX = GetDriveType(VarX$)
DriveType = ""
Select Case VarX
Case 0
DriveType = "[UNKNOWN]"
Case 1
DriveType = "[BADROOT]"
Case 2
DriveType = "[REMOVABLE]"
Case 3
DriveType = "[FIXED]"
Case 4
DriveType = "[REMOTE]"
Case 5
DriveType = "[CDROM]"
Case 6
DriveType = "[RAMDISK]"
End Select
If VarX > 1 Then
GetDriveExists = -1
Else
GetDriveExists = 0
End If
End Function
Function GetLabel$
X$ = ""
For L = 1 To 11
X = Int(Rnd * 16 + 1)
X$ = X$ + Hex$(X)
Next
GetLabel$ = X$
End Function
' display windows error message
Function DisplayWinError$ (x)
' define error message value
v& = GetLastError
' call windows error message routine
x& = FormatMessageA&(&H1200, "", v&, 0, ErrorBuffer$, 260, "")
If x& Then
DisplayWinError$ = Left$(ErrorBuffer$, x& - 2)
Else
DisplayWinError$ = "Unknown error 0x" + Hex$(v&) + "."
End If
x = -1
End FunctionRE: Nasty volume delete program - SpriggsySpriggs - 09-28-2023
But why?
RE: Nasty volume delete program - eoredson - 10-05-2023
(09-28-2023, 02:46 PM)SpriggsySpriggs Wrote: But why?
Well, you already know the answer: Why not!?
Seriously, I was looking at a function to rename a volume label and it prompted "Are you sure?" when left blank,
so I got to thinking (again) what if I loop through all drives and remove them so I wrote Zap...
In order to run Zap you need Administrator Privilege although Zap will attempt to force user as admin.
Erik.
RE: Nasty volume delete program - SpriggsySpriggs - 10-06-2023
Fair enough