offline
- Dejan123
- Počasni građanin
- Pridružio: 29 Avg 2005
- Poruke: 720
- Gde živiš: Beograd
|
Custom MsgBox:
Ovo u modul:
Private Const MB_ICONINFORMATION As Long = &H40&
Private Const MB_ABORTRETRYIGNORE As Long = &H2&
Private Const MB_TASKMODAL As Long = &H2000&
Public Const IDOK = 1
Public Const IDCANCEL = 2
Public Const IDABORT = 3
Public Const IDRETRY = 4
Public Const IDIGNORE = 5
Public Const IDYES = 6
Public Const IDNO = 7
Private Const IDPROMPT = &HFFFF&
Private Const WH_CBT = 5
Private Const GWL_HINSTANCE = (-6)
Private Const HCBT_ACTIVATE = 5
Private Type MSGBOX_HOOK_PARAMS
hwndOwner As Long
hHook As Long
End Type
Private MSGHOOK As MSGBOX_HOOK_PARAMS
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Public Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function MessageBox Lib "user32" _
Alias "MessageBoxA" _
(ByVal hwnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As Long) As Long
Private Declare Function SetDlgItemText Lib "user32" _
Alias "SetDlgItemTextA" _
(ByVal hDlg As Long, _
ByVal nIDDlgItem As Long, _
ByVal lpString As String) As Long
Private Declare Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
Private Declare Function SetWindowText Lib "user32" _
Alias "SetWindowTextA" _
(ByVal hwnd As Long, _
ByVal lpString As String) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
Public Function MessageBoxH(hwndThreadOwner As Long, hwndOwner As Long) As Long
Dim hInstance As Long
Dim hThreadId As Long
hInstance = GetWindowLong(hwndThreadOwner, GWL_HINSTANCE)
hThreadId = GetCurrentThreadId()
With MSGHOOK
.hwndOwner = hwndOwner
.hHook = SetWindowsHookEx(WH_CBT, _
AddressOf MsgBoxHookProc, _
hInstance, hThreadId)
End With
MessageBoxH = MessageBox(hwndOwner, _
Space$(120), _
Space$(120), _
MB_ABORTRETRYIGNORE Or MB_ICONINFORMATION)
End Function
Public Function MsgBoxHookProc(ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
If uMsg = HCBT_ACTIVATE Then
SetWindowText wParam, "[i]proizvoljan txt[/i]"
SetDlgItemText wParam, IDABORT, "[i]proizvoljan txt[/i]"
SetDlgItemText wParam, IDRETRY, "[i]-ll-[/i]"
SetDlgItemText wParam, IDIGNORE, "[i]-ll-[/i]"
SetDlgItemText wParam, IDPROMPT, "[i]neki txt.[/i]" & "[i]neki txt[/i]"
UnhookWindowsHookEx MSGHOOK.hHook
End If
MsgBoxHookProc = False
End Function
Ovo u formu:
Private Sub Command1_Click()
Select Case MessageBoxH(Me.hwnd, GetDesktopWindow())
Case IDABORT: 'Vasa naredba
Case IDRETRY: 'Vasa naredba
Case IDIGNORE: 'Vasa naredba
End Select
End Sub
Dopuna: 09 Nov 2005 21:51
@Brksi
Nije potpuno isto... neka se nadje, sto vise primera to bolje
Dopuna: 11 Nov 2005 19:27
KeySpy:
1 textbox imenovan kao 'txtSpy' i 1 timer
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Dim Shift As Boolean
Private Sub mnuExit_Click()
Unload Me
End Sub
Private Sub Timer1_Timer()
If GetAsyncKeyState(vbKeyQ) = -32767 Then txtSpy.Text = txtSpy.Text & "q"
If GetAsyncKeyState(vbKeyW) = -32767 Then txtSpy.Text = txtSpy.Text & "w"
If GetAsyncKeyState(vbKeyE) = -32767 Then txtSpy.Text = txtSpy.Text & "e"
If GetAsyncKeyState(vbKeyR) = -32767 Then txtSpy.Text = txtSpy.Text & "r"
If GetAsyncKeyState(vbKeyT) = -32767 Then txtSpy.Text = txtSpy.Text & "t"
If GetAsyncKeyState(vbKeyY) = -32767 Then txtSpy.Text = txtSpy.Text & "y"
If GetAsyncKeyState(vbKeyU) = -32767 Then txtSpy.Text = txtSpy.Text & "u"
If GetAsyncKeyState(vbKeyI) = -32767 Then txtSpy.Text = txtSpy.Text & "i"
If GetAsyncKeyState(vbKeyO) = -32767 Then txtSpy.Text = txtSpy.Text & "o"
If GetAsyncKeyState(vbKeyP) = -32767 Then txtSpy.Text = txtSpy.Text & "p"
If GetAsyncKeyState(vbKeyA) = -32767 Then txtSpy.Text = txtSpy.Text & "a"
If GetAsyncKeyState(vbKeyS) = -32767 Then txtSpy.Text = txtSpy.Text & "s"
If GetAsyncKeyState(vbKeyD) = -32767 Then txtSpy.Text = txtSpy.Text & "d"
If GetAsyncKeyState(vbKeyF) = -32767 Then txtSpy.Text = txtSpy.Text & "f"
If GetAsyncKeyState(vbKeyG) = -32767 Then txtSpy.Text = txtSpy.Text & "g"
If GetAsyncKeyState(vbKeyH) = -32767 Then txtSpy.Text = txtSpy.Text & "h"
If GetAsyncKeyState(vbKeyJ) = -32767 Then txtSpy.Text = txtSpy.Text & "j"
If GetAsyncKeyState(vbKeyK) = -32767 Then txtSpy.Text = txtSpy.Text & "k"
If GetAsyncKeyState(vbKeyL) = -32767 Then txtSpy.Text = txtSpy.Text & "l"
If GetAsyncKeyState(vbKeyZ) = -32767 Then txtSpy.Text = txtSpy.Text & "z"
If GetAsyncKeyState(vbKeyX) = -32767 Then txtSpy.Text = txtSpy.Text & "x"
If GetAsyncKeyState(vbKeyC) = -32767 Then txtSpy.Text = txtSpy.Text & "c"
If GetAsyncKeyState(vbKeyV) = -32767 Then txtSpy.Text = txtSpy.Text & "v"
If GetAsyncKeyState(vbKeyB) = -32767 Then txtSpy.Text = txtSpy.Text & "b"
If GetAsyncKeyState(vbKeyN) = -32767 Then txtSpy.Text = txtSpy.Text & "n"
If GetAsyncKeyState(vbKeyM) = -32767 Then txtSpy.Text = txtSpy.Text & "m"
If GetAsyncKeyState(vbKey1) = -32767 Then txtSpy.Text = txtSpy.Text & "1"
If GetAsyncKeyState(vbKey2) = -32767 Then txtSpy.Text = txtSpy.Text & "2"
If GetAsyncKeyState(vbKey3) = -32767 Then txtSpy.Text = txtSpy.Text & "3"
If GetAsyncKeyState(vbKey4) = -32767 Then txtSpy.Text = txtSpy.Text & "4"
If GetAsyncKeyState(vbKey5) = -32767 Then txtSpy.Text = txtSpy.Text & "5"
If GetAsyncKeyState(vbKey6) = -32767 Then txtSpy.Text = txtSpy.Text & "6"
If GetAsyncKeyState(vbKey7) = -32767 Then txtSpy.Text = txtSpy.Text & "7"
If GetAsyncKeyState(vbKey8) = -32767 Then txtSpy.Text = txtSpy.Text & "8"
If GetAsyncKeyState(vbKey9) = -32767 Then txtSpy.Text = txtSpy.Text & "9"
If GetAsyncKeyState(vbKey0) = -32767 Then txtSpy.Text = txtSpy.Text & "0"
If GetAsyncKeyState(vbKeyShift) = -32767 Then txtSpy.Text = txtSpy.Text & " [Shift] "
If GetAsyncKeyState(vbKeyBack) = -32767 Then txtSpy.Text = txtSpy.Text & " [BackSpace] "
If GetAsyncKeyState(13) = -32767 Then txtSpy.Text = txtSpy.Text & " [Enter] "
If GetAsyncKeyState(17) = -32767 Then txtSpy.Text = txtSpy.Text & " [Ctrl] "
If GetAsyncKeyState(vbKeyTab) = -32767 Then txtSpy.Text = txtSpy.Text & " [Tab] "
If GetAsyncKeyState(18) = -32767 Then txtSpy.Text = txtSpy.Text & " [Alt] "
If GetAsyncKeyState(108) = -32767 Then txtSpy.Text = txtSpy.Text & " [Enter] "
If GetAsyncKeyState(32) = -32767 Then txtSpy.Text = txtSpy.Text & " [Space] "
If GetAsyncKeyState(91) = -32767 Then txtSpy.Text = txtSpy.Text & " [Windows] "
If GetAsyncKeyState(vbKeyShift) = -32767 Then txtSpy.Text = txtSpy.Text & " [Shift] "
If GetAsyncKeyState(27) = -32767 Then txtSpy.Text = txtSpy.Text & " [Esc] "
If GetAsyncKeyState(33) = -32767 Then txtSpy.Text = txtSpy.Text & " [PageUp] "
If GetAsyncKeyState(34) = -32767 Then txtSpy.Text = txtSpy.Text & " [PageDown] "
If GetAsyncKeyState(35) = -32767 Then txtSpy.Text = txtSpy.Text & " [End] "
If GetAsyncKeyState(36) = -32767 Then txtSpy.Text = txtSpy.Text & " [Home] "
If GetAsyncKeyState(45) = -32767 Then txtSpy.Text = txtSpy.Text & " [Insert] "
If GetAsyncKeyState(46) = -32767 Then txtSpy.Text = txtSpy.Text & " [Delete] "
If GetAsyncKeyState(144) = -32767 Then txtSpy.Text = txtSpy.Text & " [NumLock] "
If GetAsyncKeyState(112) = -32767 Then txtSpy.Text = txtSpy.Text & " [F1] "
If GetAsyncKeyState(113) = -32767 Then txtSpy.Text = txtSpy.Text & " [F2] "
If GetAsyncKeyState(114) = -32767 Then txtSpy.Text = txtSpy.Text & " [F3] "
If GetAsyncKeyState(115) = -32767 Then txtSpy.Text = txtSpy.Text & " [F4] "
If GetAsyncKeyState(116) = -32767 Then txtSpy.Text = txtSpy.Text & " [F5] "
If GetAsyncKeyState(117) = -32767 Then txtSpy.Text = txtSpy.Text & " [F6] "
If GetAsyncKeyState(118) = -32767 Then txtSpy.Text = txtSpy.Text & " [F7] "
If GetAsyncKeyState(119) = -32767 Then txtSpy.Text = txtSpy.Text & " [F8] "
If GetAsyncKeyState(120) = -32767 Then txtSpy.Text = txtSpy.Text & " [F9] "
If GetAsyncKeyState(121) = -32767 Then txtSpy.Text = txtSpy.Text & " [F10] "
If GetAsyncKeyState(122) = -32767 Then txtSpy.Text = txtSpy.Text & " [F11] "
If GetAsyncKeyState(123) = -32767 Then txtSpy.Text = txtSpy.Text & " [F12] "
If GetAsyncKeyState(37) = -32767 Then txtSpy.Text = txtSpy.Text & " [Left] "
If GetAsyncKeyState(38) = -32767 Then txtSpy.Text = txtSpy.Text & " [Up] "
If GetAsyncKeyState(39) = -32767 Then txtSpy.Text = txtSpy.Text & " [Right] "
If GetAsyncKeyState(40) = -32767 Then txtSpy.Text = txtSpy.Text & " [Down] "
If GetAsyncKeyState(188) = -32767 Then txtSpy.Text = txtSpy.Text & ","
If GetAsyncKeyState(190) = -32767 Then txtSpy.Text = txtSpy.Text & "."
If GetAsyncKeyState(186) = -32767 Then txtSpy.Text = txtSpy.Text & ";"
If GetAsyncKeyState(222) = -32767 Then txtSpy.Text = txtSpy.Text & "'"
If GetAsyncKeyState(119) = -32767 Then txtSpy.Text = TtxtSpy.Text & "["
If GetAsyncKeyState(121) = -32767 Then txtSpy.Text = txtSpy.Text & "]"
If GetAsyncKeyState(191) = -32767 Then txtSpy.Text = txtSpy.Text & "/"
If GetAsyncKeyState(220) = -32767 Then txtSpy.Text = txtSpy.Text & "\"
If GetAsyncKeyState(106) = -32767 Then txtSpy.Text = txtSpy.Text & "*"
End Sub
Private Sub txtSpy_KeyDown(KeyCode As Integer, Shift As Integer)
KeyCode = 0
End Sub
Private Sub txtSpy_KeyPress(KeyAscii As Integer)
KeyAscii = 0
End Sub
Private Sub txtSpy_KeyUp(KeyCode As Integer, Shift As Integer)
KeyCode = 0
End Sub
Ovo nije bas 'kvalitetan kod', ali cu se potruditi da do kraja dana napisem bolju verziju...
Dopuna: 12 Nov 2005 13:43
Ispisi putanju fajla koji je 'spusten' u formu ( Drag and Drop )
U properties forme podesite OLEDropMode na 1-manual.
Private Sub Form_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
For i = 1 To Data.Files.Count
Print Data.Files(i)
Next i
End Sub
Dopuna: 12 Nov 2005 13:49
MsgBox koji se sam gasi:
U modul:
Public Const NV_CLOSEMSGBOX As Long = &H5000&
Public Declare Function SetTimer& Lib "user32" (ByVal hWnd&, ByVal nIDEvent&, ByVal uElapse&, ByVal lpTimerFunc&)
Public Declare Function FindWindow& Lib "user32" Alias "FindWindowA" (ByVal lpClassName$, ByVal lpWindowName$)
Public Declare Function LockWindowUpdate& Lib "user32" (ByVal hwndLock&)
Public Declare Function SetForegroundWindow& Lib "user32" (ByVal hWnd&)
Public Declare Function MessageBox& Lib "user32" Alias "MessageBoxA" (ByVal hWnd&, ByVal lpText$, ByVal lpCaption$, ByVal wType&)
Public Declare Function KillTimer& Lib "user32" (ByVal hWnd&, ByVal nIDEvent&)
Public Const API_FALSE As Long = 0&
Public Sub TimerProc(ByVal hWnd&, ByVal uMsg&, ByVal idEvent&, ByVal dwTime&)
KillTimer hWnd, idEvent
Dim hMessageBox&
hMessageBox = FindWindow("#32770", "naslov")
If hMessageBox Then
Call SetForegroundWindow(hMessageBox)
SendKeys "{enter}"
End If
Call LockWindowUpdate(API_FALSE)
End Sub
U formu:
Private Sub Form_Load()
SetTimer hWnd, NV_CLOSEMSGBOX, 4000&, AddressOf TimerProc '4000 'mozete zameniti sa bilo kojim drugim brojem
Call MessageBox(hWnd, "msg box ce se ugasiti za ...sec", "naslov", MB_ICONQUESTION Or MB_TASKMODAL)
End Sub
Dopuna: 02 Dec 2005 21:32
Formatiranje flopija:
U formu staviti progressbar i komandno dugme
U formu:
Private Sub Command1_Click()
MsgBox "Format Floppy = " & FormatFloppy("A:", FD144mb)
End Sub
U modul:
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function SetErrorMode Lib "kernel32" (ByVal wMode As Long) As Long
Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Any) As Long
Private Declare Function FlushFileBuffers Lib "kernel32" (ByVal hFile As Long) As Long
Private Declare Function DeviceIoControl Lib "kernel32" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Any, ByVal nInBufferSize As Long, lpOutBuffer As Any, ByVal nOutBufferSize As Long, lpBytesReturned As Long, lpOverlapped As Any) As Long
Private Declare Function LockFile Lib "kernel32" (ByVal hFile As Long, ByVal dwFileOffsetLow As Long, ByVal dwFileOffsetHigh As Long, ByVal nNumberOfBytesToLockLow As Long, ByVal nNumberOfBytesToLockHigh As Long) As Long
Private Declare Function UnlockFile Lib "kernel32" (ByVal hFile As Long, ByVal dwFileOffsetLow As Long, ByVal dwFileOffsetHigh As Long, ByVal nNumberOfBytesToUnlockLow As Long, ByVal nNumberOfBytesToUnlockHigh As Long) As Long
Private Const SEM_FAILCRITICALERRORS = &H1
Private Const SEM_NOOPENFILEERRORBOX = &H8000&
Private Const CREATE_ALWAYS = 2
Private Const OPEN_EXISTING = 3
Private Const OPEN_ALWAYS = 4
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const GENERIC_EXECUTE = &H20000000
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const GENERIC_ALL = &H10000000
Private Const FILE_ANY_ACCESS As Long = 0
Private Const FILE_READ_ACCESS As Long = &H1
Private Const FILE_WRITE_ACCESS As Long = &H2
Private Const FILE_BEGIN = 0
Private Const INVALID_HANDLE_VALUE = -1
Private Const METHOD_BUFFERED As Long = 0
Private Const MAX_PATH As Long = 260
Private Const ERROR_FILE_NOT_FOUND As Long = 2
Private Const IOCTL_DISK_GET_DRIVE_GEOMETRY As Long = &H70000
Private Const FILE_DEVICE_DISK As Long = &H7
Private Const IOCTL_DISK_BASE As Long = FILE_DEVICE_DISK
Private Const IOCTL_DISK_GET_MEDIA_TYPES As Long = ((IOCTL_DISK_BASE * (2 ^ 16)) Or (FILE_ANY_ACCESS * (2 ^ 14)) Or (&H300 * (2 ^ 2)) Or METHOD_BUFFERED)
Public Enum FDFormat
FD144mb = 2
FD288mb = 3
FD720kb = 5
End Enum
Private Type DISK_GEOMETRY
Cylinders As Currency 'LARGE_INTEGER (8 bytes)
MediaType As Long
TracksPerCylinder As Long
SectorsPerTrack As Long
BytesPerSector As Long
End Type
Private Type Geometry
Sectors As Long
Heads As Long
SectorsPerFat As Long
SectorsPerCluster As Long
SectorsPerTrack As Long
BytesPerSector As Long
RootDirEntries As Long
DirectorySectors As Long
MediaDescriptor As Long
End Type
Public Function FormatFloppy(Device As String, ByVal FDF As FDFormat) As Boolean
Dim bIMG() As Byte
Dim Geo As Geometry
If Not GetGeometry(FDF, Geo) Then Exit Function
bIMG = StrConv(BootSector(Geo) & BlankFAT(Geo) & DirectorySectors(Geo) & DataSectors(Geo), vbFromUnicode)
FormatFloppy = WriteIMG(Device, bIMG, frmformat.ProgressBar1)
End Function
Public Function GetGeometry(FDF As FDFormat, ByRef Geo As Geometry) As Boolean
With Geo
Select Case FDF
Case 2 '1.44mb
.BytesPerSector = 512
.Sectors = 2880
.SectorsPerFat = 9
.SectorsPerCluster = 1
.RootDirEntries = 224 '112
.MediaDescriptor = &HF0
.Heads = 2
.SectorsPerTrack = 18
.DirectorySectors = 14
Case 3 '2.88mb
.BytesPerSector = 512
.Sectors = 5760
.SectorsPerFat = 9
.SectorsPerCluster = 2
.RootDirEntries = 240
.MediaDescriptor = &HF0
.Heads = 2
.SectorsPerTrack = 36
.DirectorySectors = 15
Case 5 '720kb
.BytesPerSector = 512
.Sectors = 1440
.SectorsPerFat = 3
.SectorsPerCluster = 2
.RootDirEntries = 112
.MediaDescriptor = &HF9
.Heads = 2
.SectorsPerTrack = 9
.DirectorySectors = 7
Case Else: Exit Function
End Select
End With
GetGeometry = True
End Function
Public Function WriteIMG(Device As String, ByRef bIMG() As Byte, Optional PB As ProgressBar) As Boolean
On Error GoTo ErrHandler
Dim ret As Long, Sector As Long, hDevice As Long
Dim i As Integer
Dim Geo As Geometry
Dim FDF As FDFormat
'Find the size of the device to determine the format
Select Case UBound(bIMG) + 1
Case 1474560: FDF = FD144mb
Case 2949120: FDF = FD288mb
Case 737280: FDF = FD720kb
End Select
If Not GetGeometry(FDF, Geo) Then Exit Function
With Geo
hDevice = CreateFile("\\?\" & Device, GENERIC_READ Or GENERIC_WRITE, 0, ByVal 0, OPEN_ALWAYS, 0, 0)
'hDevice = CreateFile("\\?\" & Device, GENERIC_WRITE Or GENERIC_READ, 0, ByVal 0, OPEN_ALWAYS, 0, 0)
If hDevice = INVALID_HANDLE_VALUE Then Exit Function
Call LockFile(hDevice, LoWord(1 * .BytesPerSector), HiWord(1 * .BytesPerSector), LoWord(.Sectors * .BytesPerSector), HiWord(.Sectors * .BytesPerSector))
If Not PB Is Nothing Then PB.Max = .Sectors
Call SetFilePointer(hDevice, 0, 0, FILE_BEGIN)
i = 32 'Sectors to write per WriteFile sub
For Sector = 0 To .Sectors - 1 Step i
DoEvents
WriteFile hDevice, bIMG(Sector * .BytesPerSector), .BytesPerSector * i, ret, ByVal 0&
If Not PB Is Nothing Then PB.Value = Sector
Next Sector
If Not PB Is Nothing Then PB.Value = .Sectors
WriteIMG = True
ErrHandler:
On Error Resume Next
Call FlushFileBuffers(hDevice)
Call UnlockFile(hDevice, LoWord(1 * .BytesPerSector), HiWord(1 * .BytesPerSector), LoWord(.Sectors * .BytesPerSector), HiWord(.Sectors * .BytesPerSector))
CloseHandle hDevice
On Error GoTo 0
End With
End Function
Function DirectorySectors(ByRef Geo As Geometry) As String
With Geo
DirectorySectors = String(.BytesPerSector * .DirectorySectors, 0)
End With
End Function
Function DataSectors(ByRef Geo As Geometry) As String
With Geo
DataSectors = String(.BytesPerSector * (.Sectors - .DirectorySectors - (.SectorsPerFat * 2) - 1), 246)
End With
End Function
Private Function BlankFAT(ByRef Geo As Geometry) As String
Dim BF As String
Dim i As Integer
With Geo
BF = Chr(240) & String(2, 255) & String(.BytesPerSector * .SectorsPerFat - 3, 0)
End With
BlankFAT = BF & BF
BF = ""
End Function
Public Function BootSector(ByRef Geo As Geometry, Optional BSVer As String = "XP", Optional VolumeName As String = "NO NAME") As String
Dim BS As String
With Geo
BS = "EB3C90" 'Jump Instruction
BS = BS & StrToHex("MSDOS5.0") 'OEM ID
BS = BS & Invert(Right("0000" & Hex(.BytesPerSector), 4)) 'Bytes Per sector
BS = BS & "0" & .SectorsPerCluster 'Sectors per cluster
BS = BS & "0100" 'Number of reserved sectors
BS = BS & "02" 'Number of FAT copies
BS = BS & Hex(.RootDirEntries) & "00" 'Number of Max Root Directory Entries
BS = BS & Invert(Right("0000" & Hex(.Sectors), 4)) 'Total number of sectors
BS = BS & Hex(.MediaDescriptor) 'Media Descriptor
BS = BS & Invert(Right("0000" & Hex(.SectorsPerFat), 4)) 'Number of sectors per FAT
BS = BS & Invert(Right("0000" & Hex(.SectorsPerTrack), 4)) 'Number of sectors per FAT
BS = BS & Right("00" & .Heads, 2) & "00" 'Number of heads
BS = BS & "0000" 'Number of hidden sectors
BS = BS & "0000" 'Number of large sectors
BS = BS & "000000000000" 'Extended BIOS Parameter Block
BS = BS & "29" & RandomSerial
BS = BS & StrToHex(Left(VolumeName & String(11, 32), 11))
BS = BS & StrToHex("FAT12" & String(3, 32))
Select Case BSVer
Case "XP"
BS = BS & "33C98ED1BCF07B8ED9B800208EC0FCBD007C _
384E247D248BC199E83C01721C83EB3A66A11C7 _
C26663B07268A57FC750680CA0288560280C310 _
73EB33C98A461098F7661603461C13561E03460 _
E13D18B7611608946FC8956FEB82000F7E68B5 _
E0B03C348F7F30146FC114EFE61BF0000E8E60 _
0723926382D741760B10BBEA17DF3A661743 _
24E740983C7203BFB72E6EBDCA0FB7DB47 _
D8BF0AC9840740C487413B40EBB0700C _
D10EBEFA0FD7DEBE6A0FC7DEBE1CD _
16CD19268B551A52B001BB0000E8 _
3B0072E85B8A5624BE0B7C8BFCC _
746F03D7DC746F4297D8CD9894EF2894EF6"
BS = BS &
"C606967DCBEA030000200FB6C8668B _
46F86603461C668BD066C1EA10EB5E _
0FB6C84A4A8A460D32E4F7E20346FC _
1356FEEB4A525006536A016A10918B _
4618969233D2F7F691F7F64287CAF7 _
761A8AF28AE8C0CC020ACCB80102 _
807E020E7504B4428BF48A5624CD _
136161720B40750142035E0B49750 _
6F8C341BB000060666A00EBB04E5 _
44C44522020202020200D0A52656 _
D6F7665206469736B73206F72206F _
74686572206D656469612EFF0D0A _
4469736B206572726F72FF0D0A50 _
7265737320616E79206B65792074 _
6F20726573746172740D0A00000 _
000000000ACCBD855AA"
Case "98se"
BS = BS &
"33C98ED1BCFC7B1607BD7800C _
576001E561655BF2205897E0089 _
4E02B10BFCF3A4061FBD007CC _
645FE0F384E247D208BC199E8 _
7E0183EB3A66A11C7C663B07 _
8A57FC750680CA0288560280 _
C31073ED33C9FE06D87D8A4 _
61098F7661603461C13561E0 _
3460E13D18B7611608946FC _
8956FEB82000F7E68B5E0B0 _
3C348F7F30146FC114EFE61 _
BF0007E82801723E382D741 _
760B10BBED87DF3A661743 _
D4E740983C7203BFB72E7E _
BDDFE0ED87D7BA7BE7F7D _
AC9803F0AC9840740C4874 _
13B40EBB0700CD10EBEFB _
E827DEBE6BE807DEBE1CD _
165E1F668F04CD19BE817 _
D8B7D1A8D45"
BS = BS &
"FE8A4E0DF7E10346FC1356FE _
B104E8C20072D7EA0002700 _
0525006536A016A10918B46 _
18A22605969233D2F7F691F _
7F64287CAF7761A8AF28AE _
8C0CC020ACCB80102807 _
E020E7504B4428BF48A56 _
24CD136161720A407501 _
42035E0B497577C30318 _
01270D0A496E76616C6 _
9642073797374656D20 _
6469736BFF0D0A44697 _
36B20492F4F20657272 _
6F72FF0D0A5265706C_
61636520746865206 _
469736B2C20616E6 _
4207468656E20707 _
265737320616E792 _
06B65790D0A00004 _
94F2020202020205359534D53444F532020 _
205359537F010041BB000760666A00E93BFF000055AA"
End Select
End With
BootSector = HexToStr(BS)
BS = ""
End Function
Private Function StrToHex(ByVal Uncooked As String) As String
Dim l As Long
Dim i As Integer
Dim cooked As String
For l = 1 To Len(Uncooked)
i = Asc(Mid(Uncooked, l, 1))
cooked = cooked & Right("00" & Hex(i), 2)
Next l
StrToHex = cooked
cooked = ""
End Function
Private Function HexToStr(ByVal Uncooked As String) As String
Dim l As Long
Dim cooked As String
For l = 1 To Len(Uncooked) Step 2
cooked = cooked & Chr(CLng("&H" & Mid(Uncooked, l, 2)))
Next l
HexToStr = cooked
cooked = ""
End Function
Private Function Invert(ByVal Uncooked As String) As String
Dim l As Long, cooked As String
For l = Len(Uncooked) To 1 Step -2
cooked = cooked & Mid(Uncooked, l - 1, 2)
Next l
Invert = cooked
cooked = ""
End Function
Private Function RandomSerial() As String
Randomize
RandomSerial = Right("00" & Hex(Int((255 * Rnd) + 1)), 2) & Right("00" & Hex(Int((255 * Rnd) + 1)), 2) & Right("00" & Hex(Int((255 * Rnd) + 1)), 2) & Right("00" & Hex(Int((255 * Rnd) + 1)), 2)
End Function
Private Function GeoSupport(Device As String, FDF As FDFormat) As Boolean
Dim ret As Long, l As Long, hDevice As Long
Dim Geos(0 To 20) As DISK_GEOMETRY
Dim i As Integer
hDevice = CreateFile("\\.\" & Device, 0, FILE_SHARE_READ, 0, OPEN_ALWAYS, 0, 0)
If (hDevice = INVALID_HANDLE_VALUE) Then Exit Function
If DeviceIoControl(hDevice, IOCTL_DISK_GET_MEDIA_TYPES, ByVal 0&, 0, Geos(0), Len(Geos(0)) * 21, ret, 0) Then
i = ret / Len(Geos(0))
End If
Call CloseHandle(hDevice)
For l = 0 To i - 1
If Geos(l).MediaType = FDF Then GeoSupport = True
Next l
End Function
Public Function LoWord(ByVal LongIn As Long) As Integer
Call CopyMemory(LoWord, LongIn, 2)
End Function
Public Function HiWord(ByVal LongIn As Long) As Integer
Call CopyMemory(HiWord, ByVal (VarPtr(LongIn) + 2), 2)
End Function
|
