想要进一步读取档案的相关资讯， 必须先呼叫 API 函数的 OpenFile 取得档案的
Handle， 然後再利用 Handle 呼叫 GetFileInformationByHandle 读取档案的相关
资讯， 而在读取的档案相关资讯中便含有档案建立、修改、及存取时间， 程式执
行过程如下：(假设想读取的档案是"c:\autoexec.bat")

　
Public Const OFS_MAXPATHNAME = 128
Public Const OF_READ = &H0
Type OFSTRUCT
cBytes As Byte
fFixedDisk As Byte
nErrCode As Integer
Reserved1 As Integer
Reserved2 As Integer
szPathName(OFS_MAXPATHNAME) As Byte
End Type

Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type

Type FileTime
dwLowDateTime As Long
dwHighDateTime As Long
End Type


Type BY_HANDLE_FILE_INFORMATION
dwFileAttributes As Long
ftCreationTime As FileTime
ftLastAccessTime As FileTime
ftLastWriteTime As FileTime
dwVolumeSerialNumber As Long
nFileSizeHigh As Long
nFileSizeLow As Long
nNumberOfLinks As Long
nFileIndexHigh As Long
nFileIndexLow As Long
End Type

Type TIME_ZONE_INFORMATION
bias As Long
StandardName(32) As Integer
StandardDate As SYSTEMTIME
StandardBias As Long
DaylightName(32) As Integer
DaylightDate As SYSTEMTIME
DaylightBias As Long
End Type


Declare Function GetTimeZoneInformation Lib "kernel32" _
(lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
Declare Function OpenFile Lib "kernel32" (ByVal lpFileName As String, _
lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long
Declare Function GetFileInformationByHandle Lib "kernel32" (ByVal hFile As _
Long, lpFileInformation As BY_HANDLE_FILE_INFORMATION) As Long
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As _
FileTime, lpSystemTime As SYSTEMTIME) As Long

Dim FileHandle As Long
Dim FileInfo As BY_HANDLE_FILE_INFORMATION
Dim lpReOpenBuff As OFSTRUCT, ft As SYSTEMTIME
Dim tZone As TIME_ZONE_INFORMATION

Dim dtCreate As Date ' 建立时间
Dim dtAccess As Date ' 存取日期
Dim dtWrite As Date ' 修改时间
Dim bias As Long

' 先取得 autoexec.bat 的 File Handle
FileHandle = OpenFile("c:\autoexec.bat", lpReOpenBuff, OF_READ)
' 利用 File Handle 读取档案资讯
Call GetFileInformationByHandle(FileHandle, FileInfo)
Call CloseHandle(FileHandle)
' 读取 Time Zone 资讯， 因为上一步骤的档案时间是「格林威治」时间
Call GetTimeZoneInformation(tZone)
bias = tZone.bias ' 时间差， 以「分」为单位
Call FileTimeToSystemTime(FileInfo.ftCreationTime, ft) ' 转换时间资料结构
dtCreate = DateSerial(ft.wYear, ft.wMonth, ft.wDay) + ;
TimeSerial(ft.wHour, ft.wMinute - bias, ft.wSecond)
Call FileTimeToSystemTime(FileInfo.ftLastAccessTime, ft)
dtAccess = DateSerial(ft.wYear, ft.wMonth, ft.wDay) + ;
TimeSerial(ft.wHour, ft.wMinute - bias,ft.wSecond)
Call FileTimeToSystemTime(FileInfo.ftLastWriteTime, ft)
dtWrite = DateSerial(ft.wYear, ft.wMonth, ft.wDay) +
TimeSerial(ft.wHour, ft.wMinute - bias,ft.wSecond)

'执行以上程式所得到的 dtCreate、dtWrite、及 dtAccess 变数， 即分别为档案
'建立、修改、及存取时间。
返回

声明：
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

Declare Function GetDriveType Lib "kernel32" _
Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

Public Const DRIVE_CDROM = 5
使用：
Dim VolName As String, FSys As String, erg As Long
Dim VolNumber As Long, MCM As Long, FSF As Long
Dim Drive As String, DriveType As Long
VolName = Space(127)
FSys = Space(127)
Drive = "F:\" 'Enter the driverletter you want
DriveType& = GetDriveType(Drive$)
erg& = GetVolumeInformation(Drive$, VolName$, 127&, _
VolNumber&, MCM&, FSF&, FSys$, 127&)
Print "分区名称:" & vbTab & VolName$
Print "序列号:" & vbTab & VolNumber&
Print "最大文件名称长:" & vbTab & vbTab & MCM&
Print "文件系统标志:" & vbTab & vbTab & FSF&
Print "文件系统名称:" & vbTab & FSys$
Print "类型:" & vbTab & DriveType&;
'Is the drive a CDROM, if so, check for a CD
If DriveType& = DRIVE_CDROM Then
Print " (CDROM, ";
If erg& = 0 Then
Print "没有 CD )"
Else
Print "有 CD )"
End If
Else
Print " (非 CDROM)" '
End If
返回

声明：
Declare Function mciSendString Lib "winmm.dll" Alias _
"mciSendStringA" (ByVal lpstrCommand As String, ByVal _
lpstrReturnString As String, ByVal uReturnLength As Long, _
ByVal hwndCallback As Long) As Long
使用：
'打开
retvalue = mcisendstring("set CDAudio door open", returnstring, 127, 0)
'关闭
retvalue = mcisendstring("set CDAudio door closed", returnstring, 127, 0)
返回

利用 API 可以判断一个驱动器的类型。
声明：
Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
调用：
ret = GetDriveType ( "D:\")
如果 ret =2 软盘，=3 硬盘，=4 网络映射盘，=5 光驱，=6 RAM DISK
返回

磁盘序列号在每次软盘或硬盘格式化后都重新生成，并且不回重复。许多程序员用此加密。其实也可以修改该函数，可以得到磁盘卷标和文件系统类型信息。

声明：
Private Declare Function GetVolumeInformation Lib "kernel32.dll" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Integer, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long

代码：

Function GetSerialNumber(sRoot As String) As Long
Dim lSerialNum As Long
Dim R As Long
Dim sTemp1 As String, sTemp2 As String
strLabel = String$(255, Chr$(0))
' 磁盘卷标
strType = String$(255, Chr$(0))
' 文件系统类型 一般为 FAT
R = GetVolumeInformation(sRoot, strLabel, Len(strLabel), lSerialNum, 0, 0, strType, Len(strType))
GetSerialNumber = lSerialNum
'在 strLabel 中为 磁盘卷标
'在 strType 中为 文件系统类型
End Function

用法：

当驱动器不存在时，函数返回 0。如果是个非根目录，也将返回 0：

lSerial = GetSerialNumber("c:\")
返回

在Drive的参数中 "A:" = 0，类推。

Private Const SHFMT_ID_DEFAULT = &HFFFF&
'Currently the only fmtID supported.

Private Declare Function SHFormatDrive Lib "shell32.dll" (ByVal hWnd As Long, ByVal Drive As Long, fmtID As Long, Options As Long) As Long

Private Sub Command1_Click()
Dim lret As Long
lret = SHFormatDrive(Me.hWnd, 0, SHFMT_ID_DEFAULT, 0)
Select Case lret
Case -2
MsgBox "OK !"
Case -3
MsgBox "Cannot format a read only drive !"
End Select
End Sub
返回

Option Explicit

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
Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long

Public hnexthookproc As Long
Public Const HC_ACTION = 0
Public Const WH_KEYBOARD = 2

Public Sub UnHookKBD()
If hnexthookproc <> 0 Then
UnhookWindowsHookEx hnexthookproc
hnexthookproc = 0
End If
End Sub
Public Function EnableKBDHook()
If hnexthookproc <> 0 Then
Exit Function
End If
hnexthookproc = SetWindowsHookEx(WH_KEYBOARD, AddressOf _
MyKBHFunc, App.hInstance, 0)
If hnexthookproc <> 0 Then
EnableKBDHook = hnexthookproc
End If
End Function
Public Function MyKBHFunc(ByVal iCode As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
'这叁个参数是固定的，不能动，而MyKBHFunc这个名称只要和
'SetWindowsHookex()中 AddressOf後的名称一样便可，不一定叫什麽
'wParam 是传入按了哪个key的virtual-key code

'如果您将以下的两行unmark则所有键盘的输入皆没有作用
'MyKBHFunc = 1 '吃掉讯息
'Exit Function

MyKBHFunc = 0 '讯息要处理
If iCode < 0 Then
MyKBHFunc = CallNextHookEx(hnexthookproc, iCode, wParam, lParam)
Exit Function
End If
If wParam = vbKeySnapshot Then '侦测 有没有按到PrintScreen键
MyKBHFunc = 1 '在这个Hook便吃掉这个讯息
Debug.Print "haha"
Else
Call CallNextHookEx(hnexthookproc, iCode, wParam, lParam)
End If
End Function

'以下在Form
Private Sub Form_Load()
Call EnableKBDHook
End Sub

Private Sub Form_Unload(Cancel As Integer)
Call UnHookKBD
End Sub
返回

我们常见一些导览系统或教学系统，会自动移动Mouse与Keyin字，而那个时候，我们
不管Keyin或动Mouse都没有效，直到完成了导览系统的某个动作後才让使用者可以移
动Mouse与做Keyin的动作；想做到这个，要借重JournalPlayBack Hook。

JournalPlayBack Hook，它和JournalRecord Hook合称Journal Hook，它们作用
的范围是整个System，也就是挂上这个Hook後，影响的层面不单是这个Process，而是
所有的Process，而这两Hook又不用写在Dll之中，所以很好用。

首先我们要知道由键盘和Mouse输入等的硬体讯息，会存到一个System Queue而後OS会
到该System Queue看有没有讯息在其中，若有则撷取出来，看目前Active的Window是谁
而将讯息Post给它。而挂上JournalRecord Hook时，当有讯息被撷取出来时，会先执行
我们所设定的Hook Function(在vb中，一定要放在.BAS档之中)。这可以做什麽事呢？
例如们可以Check整个系统是否有按了键盘或有没有移动Mouse(一般来说，KeyUp,KeyDown
, MouseMove等Event只有Form在Active 时才收得到，挂上JournalRecord hook後，执行
Hook的thread便能收到所有这些讯息)。再如，它既然能收到Keyboard、Mouse的讯息，那
便可以将收到的讯息记录起来(记录於Memory或Disk都可以)，之後再依方才的顺序重新
将讯息放送出来，可重新执行方才的动作(这不就是巨集的作法吗)，或许
它叫JournalRecord便是这个原因。再来便是播放记录讯息的问题了，如果一面播放，一
面有其他讯息插队(如移动Mouse)，那就不对了，所以JournalPlayBack这个Hook它会
让Mouse、Keyboard都失效，当OS 要求读System Queue时，便会启动这个Hook，就在此
时，我们可以把方才记录起来的讯息丢出一个出来，OS再要求读System Queue时，再丢
下一个讯息，如此达重播的效果(所以才叫JournalPlayBack)，正因它会让键盘、Mouse
失效，拿它来做导览、教学系统的自动Move Mouse或文字显示是最适合的了。

Mouse的自动导引系统制作方式，可参考如何自动移动Mouse

'以下在.Bas中
Declare Sub Sleep Lib "KERNEL32" (ByVal dwMilliseconds As Long)
Const WM_MOUSELAST = &H209
Const WM_MOUSEFIRST = &H200
Public Const WM_KEYLAST = &H108
Public Const WM_KEYFIRST = &H100
Public Const WH_JOURNALRECORD = 0
Public Const WH_JOURNALPLAYBACK = 1

Type EVENTMSG
message As Long
paramL As Long
paramH As Long
time As Long
hwnd As Long
End Type
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
Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Public hNxtHook As Long ' handle of Hook Procedure
Public msg As EVENTMSG

Sub EnableHook()
hNxtHook = SetWindowsHookEx(WH_JOURNALPLAYBACK, AddressOf HookProc, App.hInstance, 0)
End Sub
Sub FreeHook()
Dim ret As Long
ret = UnhookWindowsHookEx(hNxtHook)
End Sub
Function HookProc(ByVal code As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
HookProc = CallNextHookEx(hNxtHook, code, wParam, lParam)
End Function

'以下在Form中，需求:一个Command1, 一个text1
Private Sub Command1_Click()
Dim str5 As String, len5 As Long, i As Long

Call EnableHook
str5 = "这是一个测试JournalPlayBackHook的程式"
len5 = Len(str5)
For i = 1 To len5
Text1.Text = Mid(str5, 1, i)
Text1.Refresh
Sleep (200)
Next
Call FreeHook
End Sub
返回

你可以使用API函数FindWindow和PostMessage来寻找一个窗口并且关闭它。下面的范例演示如何关闭一个标题为"Calculator"的窗口。
Dim winHwnd As Long
Dim RetVal As Long
winHwnd = FindWindow(vbNullString, "Calculator")
Debug.Print winHwnd
If winHwnd <> 0 Then
RetVal = PostMessage(winHwnd, WM_CLOSE, 0&, 0&)
If RetVal = 0 Then
MsgBox "Error posting message."
End If
Else
MsgBox "The Calculator is not open."
End If

For this code to work, you must have declared the API functions in a module in your project. You must put the following in the declarations section of the module.

Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Declare Function PostMessage Lib "user32" Alias _
"PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Public Const WM_CLOSE = &H10
返回

SUMMARY
=======

The Visual Basic Printer object allows you to get to many of a printer
driver's properties, but it does not give you access to all of them. The
following sample demonstrates how to retrieve information from a printer
driver using the WIN32 API.

MORE INFORMATION
================

A printer's settings are stored in a structure called the DEVMODE. This
sample retrieves the DEVMODE for the current default printer and displays
its settings in a ListBox. Note that these are numeric values that must be
compared to constants to determine their meaning. This article only
includes the constants for the values the code actually displays. Other
constants can be found in the REFERENCES section at the end of this
article.

The sample below contains two custom functions, StripNulls and
ByteToString. StripNulls simply takes a String and removes all characters
starting at the first Null. This is used in place of the RTrim function
because in Visual Basic 5.0, fixed-length strings are padded with Nulls
instead of the spaces used in Visual Basic 4.0. The ByteToString function
converts an array of Bytes into a String. The DEVMODE contains two such
arrays.

There are two special notes about the following sample when running under
Windows NT. First, many monochrome drivers will have their dmColor property
set to 2, which means they report being capable of color printing, but
really are not. Also, some settings for the "Generic / Text Only" printer
driver may not be accurate under NT.

Step-by-Step Example
--------------------

1. Open a new Standard EXE project. Form1 is created by default.

2. Add a CommandButton and a ListBox to the Form.

3. Add the following code to the Form's module:

Option Explicit

Private Const NULLPTR = 0&
' Constants for DEVMODE
Private Const CCHDEVICENAME = 32
Private Const CCHFORMNAME = 32
' Constants for DocumentProperties
Private Const DM_MODIFY = 8
Private Const DM_COPY = 2
Private Const DM_IN_BUFFER = DM_MODIFY
Private Const DM_OUT_BUFFER = DM_COPY
' Constants for dmOrientation
Private Const DMORIENT_PORTRAIT = 1
Private Const DMORIENT_LANDSCAPE = 2
' Constants for dmPrintQuality
Private Const DMRES_DRAFT = (-1)
Private Const DMRES_HIGH = (-4)
Private Const DMRES_LOW = (-2)
Private Const DMRES_MEDIUM = (-3)
' Constants for dmTTOption
Private Const DMTT_BITMAP = 1
Private Const DMTT_DOWNLOAD = 2
Private Const DMTT_DOWNLOAD_OUTLINE = 4
Private Const DMTT_SUBDEV = 3
' Constants for dmColor
Private Const DMCOLOR_COLOR = 2
Private Const DMCOLOR_MONOCHROME = 1

Private Type DEVMODE
dmDeviceName(1 To CCHDEVICENAME) As Byte
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName(1 To CCHFORMNAME) As Byte
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type

Private Declare Function OpenPrinter Lib "winspool.drv" Alias _
"OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, _
ByVal pDefault As Long) As Long

Private Declare Function DocumentProperties Lib "winspool.drv" _
Alias "DocumentPropertiesA" (ByVal hwnd As Long, _
ByVal hPrinter As Long, ByVal pDeviceName As String, _
pDevModeOutput As Any, pDevModeInput As Any, ByVal fMode As Long) _
As Long

Private Declare Function ClosePrinter Lib "winspool.drv" _
(ByVal hPrinter As Long) As Long

Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" _
(hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

Function StripNulls(OriginalStr As String) As String
If (InStr(OriginalStr, Chr(0)) > 0) Then
OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
End If
StripNulls = Trim(OriginalStr)
End Function

Function ByteToString(ByteArray() As Byte) As String
Dim TempStr As String
Dim I As Integer

For I = 1 To CCHDEVICENAME
TempStr = TempStr & Chr(ByteArray(I))
Next I
ByteToString = StripNulls(TempStr)
End Function

Function GetPrinterSettings(szPrinterName As String, hdc As Long) _
As Boolean
Dim hPrinter As Long
Dim nSize As Long
Dim pDevMode As DEVMODE
Dim aDevMode() As Byte
Dim TempStr As String

If OpenPrinter(szPrinterName, hPrinter, NULLPTR) Then
nSize = DocumentProperties(NULLPTR, hPrinter, szPrinterName, _
NULLPTR, NULLPTR, 0)
ReDim aDevMode(1 To nSize)
nSize = DocumentProperties(NULLPTR, hPrinter, szPrinterName, _
aDevMode(1), NULLPTR, DM_OUT_BUFFER)
Call CopyMemory(pDevMode, aDevMode(1), Len(pDevMode))

List1.Clear ' empty the ListBox
List1.AddItem "Printer Name: " & _
ByteToString(pDevMode.dmDeviceName)

If pDevMode.dmOrientation = DMORIENT_PORTRAIT Then
TempStr = "PORTRAIT"
ElseIf pDevMode.dmOrientation = DMORIENT_LANDSCAPE Then
TempStr = "LANDSCAPE"
Else
TempStr = "UNDEFINED"
End If
List1.AddItem "Orientation: " & TempStr

Select Case pDevMode.dmPrintQuality
Case DMRES_DRAFT
TempStr = "DRAFT"
Case DMRES_HIGH
TempStr = "HIGH"
Case DMRES_LOW
TempStr = "LOW"
Case DMRES_MEDIUM
TempStr = "MEDIUM"
Case Else ' positive value
TempStr = CStr(pDevMode.dmPrintQuality) & " dpi"
End Select
List1.AddItem "Print Quality: " & TempStr

Select Case pDevMode.dmTTOption
Case DMTT_BITMAP ' default for dot-matrix printers
TempStr = "TrueType fonts as graphics"
Case DMTT_DOWNLOAD ' default for HP printers that use PCL
TempStr = "Downloads TrueType fonts as soft fonts"
Case DMTT_SUBDEV ' default for PostScript printers
TempStr = "Substitute device fonts for TrueType fonts"
Case Else
TempStr = "UNDEFINED"
End Select
List1.AddItem "TrueType Option: " & TempStr

' Windows NT drivers often return COLOR from Monochrome printers
If pDevMode.dmColor = DMCOLOR_MONOCHROME Then
TempStr = "MONOCHROME"
ElseIf pDevMode.dmColor = DMCOLOR_COLOR Then
TempStr = "COLOR"
Else
TempStr = "UNDEFINED"
End If
List1.AddItem "Color or Monochrome: " & TempStr

If pDevMode.dmScale = 0 Then
TempStr = "NONE"
Else
TempStr = CStr(pDevMode.dmScale)
End If
List1.AddItem "Scale Factor: " & TempStr

List1.AddItem "Y Resolution: " & pDevMode.dmYResolution & " dpi"
List1.AddItem "Copies: " & CStr(pDevMode.dmCopies)
' Add any other items of interest ...

Call ClosePrinter(hPrinter)
GetPrinterSettings = True
Else
GetPrinterSettings = False
End If
End Function

Private Sub Command1_Click()
If GetPrinterSettings(Printer.DeviceName, Printer.hdc) = False Then
List1.AddItem "No Settings Retrieved!"
MsgBox "Unable to retrieve Printer settings.", , "Failure"
End If
End Sub

4. Run the project and Click on Command1. The current default printer's
settings will be displayed in the ListBox.

REFERENCES
==========

To find additional constants, please search on DEVMODE in either the Win32
Programmer's Reference or the Microsoft Developer Network (MSDN) Library
CD-ROM.

Additional query words: kbDSupport kbDSD kbVBp kbVBp400 kbVBp500 kbVBp600
kbAPI kbSDKWin32 kbPrinting
======================================================================
Platform : WINDOWS
Issue type : kbhowto

=============================================================================
返回

Back to top