AppleVB.com

在Form1中加入一个ListBox，并在Form1中加入如下代码：
Private Sub Form_Load()
Dim counter As Integer

For counter = 0 To Screen.FontCount - 1
List1.AddItem Screen.Fonts(counter)
Next
End Sub

Private Sub List1_Click()
Static tempheight As Single

If tempheight = 0 Then tempheight = List1.Height
List1.Font.Name = List1.List(List1.ListIndex)
List1.Height = tempheight
End Sub
返回

在Form1中加入如下代码：
Private Declare Function GetUserName Lib "advapi32.dll" Alias _
"GetUserNameA" (ByVal lpBuffer As String, nSize As Long) _
As Long

Private Sub Form_Load()
Dim s As String
Dim cnt As Long
Dim dl As Long
Dim CurUser As String

cnt = 199
s = String$(200, 0)
dl = GetUserName(s, cnt)
If dl <> 0 Then CurUser = Left$(s, cnt) Else CurUser = ""
Debug.Print CurUser
End Sub
返回

在Form1中加入一个CommandButton、一个Label并加入如下代码
Option Explicit

Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long

Const SM_CLEANBOOT = 67

Private Sub Command1_Click()
Select Case GetSystemMetrics(SM_CLEANBOOT)
Case 1: Label1 = "安全模式."
Case 2: Label1 = "支持网络的安全模式."
Case Else: Label1 = "Windows运行在普通模式."
End Select
End Sub
点击Command1就可以看到Windows是以何种方式启动的。
返回

使用ExitWindowsEx函数，函数有两个参数确定如何关闭Windows，其中第二个参数未使用
设置为0

Public Const EWX_LOGOFF = 0
Public Const EWX_SHUTDOWN = 1
Public Const EWX_REBOOT = 2
Public Const EWX_FORCE = 4
Declare Function ExitWindowsEx Lib "user32" Alias _
"ExitWindowsEx" (ByVal uFlags As Long, ByVal dwReserved _
As Long) As Long

If you wanted to forcefully reboot the computer use the following code:
如果想强制重新启动计算机，函数应该这样使用：
t& = ExitWindowsEx(EWX_FORCE OR EWX_REBOOT, 0)
返回

要获得Windows95运行的时间，使用以下函数：
Declare Function GetTickCount& Lib "kernel32" ()
函数返回的是以毫秒计算的时间。
在16位Windows下，使用GetCurrentTime 函数。
返回

声明：
Private Declare Function PwdChangePassword Lib "mpr" Alias "PwdChangePasswordA" _
(ByVal lpcRegkeyname As String, ByVal hwnd As Long, ByVal uiReserved1 As _
Long, ByVal uiReserved2 As Long) As Long
使用：
' 出现修改屏幕保护口令的窗口
Call PwdChangePassword("SCRSAVE", Me.hwnd, 0, 0)
返回

声明：
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg _
As Long, ByVal wParam As Long, ByVal lParam As Long) _
As Long
Const WM_SYSCOMMAND = &H112&
Const SC_SCREENSAVE = &HF140&
代码：
Dim result As Long
result = SendMessage(Form1.hWnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0&)
返回

Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Private Const MF_BYPOSITION = &H400&

Private Sub Form_Load()
Dim hwndMenu As Long
Dim c As Long
hwndMenu = GetSystemMenu(Me.hwnd, 0)

c = GetMenuItemCount(hwndMenu)

DeleteMenu hwndMenu, c - 1, MF_BYPOSITION

c = GetMenuItemCount(hwndMenu)
DeleteMenu hwndMenu, c - 1, MF_BYPOSITION

End Sub
返回

使用以下的 API ，得到与资源管理器相同的感觉！
Private Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Long
hNameMappings As Long
lpszProgressTitle As String '只有在 FOF_SIMPLEPROGRESS 时用
End Type

Private Declare Function SHFileOperation Lib _
"shell32.dll" Alias "SHFileOperationA" (lpFileOp _
As SHFILEOPSTRUCT) As Long

'wFunc 常数
'FO_COPY 把 pFrom 文件拷贝到 pTo。
Const FO_COPY = &H2
'FO_DELETE 删除 pFrom 中的文件（pTo 忽略）。
Const FO_DELETE = &H3
'FO_MOVE 把 pFrom 文件移动到 pTo。
Const FO_MOVE = &H1

'fFlag 常数
'FOF_ALLOWUNDO 允许 Undo 。
Const FOF_ALLOWUNDO = &H40
'FOF_NOCONFIRMATION 不显示系统确认对话框。
Const FOF_NOCONFIRMATION = &H10
'FOF_NOCONFIRMMKDIR 不提示是否新建目录。
Const FOF_NOCONFIRMMKDIR = &H200
'FOF_SILENT 不显示进度对话框
Const FOF_SILENT = &H4

例子：
Dim SHFileOp As SHFILEOPSTRUCT
' 删除
SHFileOp.wFunc = FO_DELETE
SHFileOp.pFrom = "c:\config.old" + Chr(0)
SHFileOp.fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMATION
Call SHFileOperation(SHFileOp)
' 删除多个文件
SHFileOp.wFunc = FO_DELETE
SHFileOp.pFrom = "c:\config.old" +Chr(0) + "c:\autoexec.old"+Chr(0)
SHFileOp.fFlags = FOF_ALLOWUNDO
Call SHFileOperation(SHFileOp)
' 拷贝
SHFileOp.wFunc = FO_COPY
SHFileOp.pFrom = "c:\t\*.*"
SHFileOp.pTo = "d:\t\*.*"
SHFileOp.fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMMKDIR
Call SHFileOperation(SHFileOp)
' 移动
SHFileOp.wFunc = FO_MOVE
SHFileOp.pFrom = "c:\config.old" + Chr(0)
SHFileOp.pTo = "d:\t"
SHFileOp.fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMATION
返回

在文件的第 24 字节，如果为40h，就是 Windows 的可执行文件。

Function WinExe (ByVal Exe As String) As Integer
Dim fh As Integer
Dim t As String * 1
fh = FreeFile
Open Exe For Binary As #fh
Get fh, 25, t
Close #fh
WinExe = (Asc(t) = &H40&)
End Function
返回

延迟在VB中非常有意义！举个例子，有时你需要等待一个额外的过程完成，才能运行程序下面的代码。延迟使程序摆脱了CPU的运算速度对程序运行速度的影响，但是在VB中却没有延迟这个很多语言都有的现成函数，所以还要依靠API函数，请看以下的代码：

Declare Sub Sleep Lib "kernel32" _

(ByVal dwMilliseconds As Long)

Windows applications typically write to the NT event log to provide the
user with useful information. In VB5/6, the App object now provides
methods to make writing to the event log in Windows NT a snap:

'-- Start Event Logging
Call App.StartLogging("", vbLogToNT)

'-- Log Events to NT
Call App.LogEvent("Info", vbLogEventTypeInformation)
Call App.LogEvent("Error", vbLogEventTypeError)
Call App.LogEvent("Warning", vbLogEventTypeWarning)

Be aware though, these functions will only work in the compiled EXE. They
will be ignored in design mode. Check out the Microsoft knowledge base
article Q161306 for more information.
返回

Recently a tip went out that showed you how to write to the NT EventLog
using the App object. This method has 2 limitations:

1) You cannot use the code during a debug session.
2) The source entry in the Event Log is always VBRuntime

Using the Win32 API alleviates these problems. Enter the following code
in the General Declarations of a module:

Declare Function RegisterEventSource Lib "advapi32.dll" Alias _
"RegisterEventSourceA" (ByVal lpUNCServerName As String, _
ByVal lpSourceName As String) As Long

Declare Function DeregisterEventSource Lib "advapi32.dll" ( _
ByVal hEventLog As Long) As Long

Declare Function ReportEvent Lib "advapi32.dll" Alias _
"ReportEventA" (ByVal hEventLog As Long, ByVal wType As Integer, _
ByVal wCategory As Integer, ByVal dwEventID As Long, _
ByVal lpUserSid As Any, ByVal wNumStrings As Integer, _
ByVal dwDataSize As Long, plpStrings As Long, _
lpRawData As Any) As Boolean

Declare Function GetLastError Lib "kernel32" () As Long

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

Declare Function GlobalAlloc Lib "kernel32" ( _
ByVal wFlags As Long, _
ByVal dwBytes As Long) As Long

Declare Function GlobalFree Lib "kernel32" ( _
ByVal hMem As Long) As Long

'-- Public Constants
Public Const EVENTLOG_SUCCESS = 0
Public Const EVENTLOG_ERROR_TYPE = 1
Public Const EVENTLOG_WARNING_TYPE = 2
Public Const EVENTLOG_INFORMATION_TYPE = 4
Public Const EVENTLOG_AUDIT_SUCCESS = 8
Public Const EVENTLOG_AUDIT_FAILURE = 10

Public Function WriteToEventLog(sMessage As String, _
sSource As String, _
iLogType As Integer, _
vEventID As Integer) As Boolean

Dim bRC As Boolean
Dim iNumStrings As Integer
Dim hEventLog As Long
Dim hMsgs As Long
Dim cbStringSize As Long
Dim iEventID As Integer

hEventLog = RegisterEventSource("", sSource)
cbStringSize = Len(sMessage) + 1
hMsgs = GlobalAlloc(&H40, cbStringSize)
CopyMemory ByVal hMsgs, ByVal sMessage, cbStringSize
iNumStrings = 1

'-- ReportEvent returns 0 if failed,
'-- Any other number indicates success
If ReportEvent(hEventLog, _
iLogType, 0, _
iEventID, 0&, _
iNumStrings, cbStringSize, _
hMsgs, hMsgs) = 0 Then
'-- Failed
WriteToEventLog = False
Else
'-- Sucessful
WriteToEventLog = True
End If

Call GlobalFree(hMsgs)
DeregisterEventSource (hEventLog)
End Function

An example of how to write to the NT EventLog:

Call WriteToEventLog("Warning, file exceeded recommended limit.", _
"Test App", _
EVENTLOG_WARNING_TYPE, 1003)
返回

PRODUCT :Microsoft Visual Basic for Windows
PROD/VER:WINDOWS:4.0,5.0
OPER/SYS:WINDOWS
KEYWORDS:

======================================================================
---------------------------------------------------------------------
The information in this article applies to:

- Microsoft Visual Basic Learning, Professional, and Enterprise Editions
for Windows, version 4.0, 5.0
---------------------------------------------------------------------

SUMMARY
=======

This article describes two ways to view the contents of a directory tree
from a RichTextBox control.

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

The following sample program uses a RichTextBox to display the entire
contents of a drive. It is also an example of recursion, the QuickSort
algorithm, and RichTextBox RTF formatting.

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

1. Start a new Standard EXE project in Visual Basic. Form1 is created by
default.

2. From the Project menu, select Components, check "Microsoft Common Dialog
Control" and "Microsoft RichTextBox Control," and then click OK.

3. Add the following controls to Form1:

4 CommandButton controls
2 DirListBox controls
1 DriveListBox control
1 FileListBox control
1 CommonDialog control
1 RichTextBox control

4. Add the following code to the General Declarations section of Form1:

Option Explicit

Dim InF As String ' Starting Directory
Dim DS As String ' Buffer for RFT control text
Const nL = "{\par }"

Function DbS(ByVal txt As String) As String
Dim k As Long, kLast As Long
Dim nt As String
k = 1
kLast = 1
Do ' Replace all \ characters with \\
k = InStr(kLast, txt, "\")
If k = 0 Then
Exit Do
Else
txt = Left$(txt, k) & Right$(txt, Len(txt) - k + 1)
kLast = k + 2
End If
Loop
DbS = txt
End Function

' ============================ QuickSort ============================
' QuickSort works by picking a random "pivot" element in SortArray,
' then moving every element that is bigger to one side of the pivot,
' & every element that is smaller to the other side. QuickSort is
' then called recursively with the two subdivisions created by the
' pivot. Once the number of elements in a subdivision reaches two,
' the recursive calls end and the array is sorted.
' ===================================================================
'
Private Sub QuickSort(SortArray() As String, ByVal Low As Long, _
ByVal High As Long)
Dim I As Long, J As Long, RandIndex As Long, Partition As String
If Low < High Then
' Only two elements in this subdivision; swap them if they are
' out of order, then end recursive calls:
If High - Low = 1 Then
If UCase(SortArray(Low)) > UCase(SortArray(High)) Then
SWAP SortArray(Low), SortArray(High)
End If
Else
' Pick a pivot element at random, then move it to the end:
RandIndex = Rnd() * (High - Low) + Low ' RandInt%(Low, High)
SWAP SortArray(High), SortArray(RandIndex)
Partition = UCase(SortArray(High))
Do
' Move in from both sides towards the pivot element:
I = Low: J = High
Do While (I < J) And (UCase(SortArray(I)) <= Partition)
I = I + 1
Loop
Do While (J > I) And (UCase(SortArray(J)) >= Partition)
J = J - 1
Loop

' If we haven't reached the pivot element it means that 2
' elements on either side are out of order, so swap them:
If I < J Then
SWAP SortArray(I), SortArray(J)
End If
Loop While I < J

' Move the pivot element to its proper place in the array:
SWAP SortArray(I), SortArray(High)

' Recursively call the QuickSort procedure (pass the
' smaller subdivision first to use less stack space):
If (I - Low) < (High - I) Then
QuickSort SortArray, Low, I - 1
QuickSort SortArray, I + 1, High
Else
QuickSort SortArray, I + 1, High
QuickSort SortArray, Low, I - 1
End If
End If
End If
End Sub

Private Sub ScanFoldersC(cD As Integer)
Dim subFolders As Integer
Dim tL As String
Dim J As Integer
Dim I As Long

tL = ""
For J = 0 To File1.ListCount - 1
DoEvents
tL = tL & Space(cD * 5) + File1.List(J) & nL
Next
DS = DS & tL
subFolders = Dir2.ListCount
If subFolders > 0 Then
For I = 0 To subFolders - 1
DoEvents
DS = DS & "{\b " & DbS(Dir2.List(I)) & "}" & nL
File1.path = Dir2.List(I)
ChDir CurDir 'Dir2.List(i)
Dir2.path = Dir2.List(I)
Call ScanFoldersC(cD + 1)
Next
DoEvents
End If
' MoveUp
If Dir2.List(-1) <> InF Then
ChDir Dir2.List(-2)
Dir2.path = Dir2.List(-2)
End If
File1.path = Dir2.path
End Sub

Private Sub ScanFoldersD(path$, cD As Integer)
Dim tL As String ' temporary buffer for filenames
Dim tPath As String ' temporary path string
Dim I As Integer ' loop index
Dim sd$(0 To 100) ' array of subdirectories
Dim nDir As Integer ' # of subdirectories in sd$
Dim sf() As String ' array of files in directory
Dim nFile As Integer ' # of files in sf
ReDim sf(1 To 256)

tL = ""
nDir = 0
nFile = 0
sd$(0) = Dir$(".", vbDirectory)
While sd$(nDir) <> ""
If (GetAttr(sd$(nDir)) And vbDirectory) <> 0 Then
If Left$(sd$(nDir), 1) <> "." Then
nDir = nDir + 1
End If
Else
' add the item to the list
nFile = nFile + 1
sf(nFile) = sd$(nDir)
If nFile Mod 256 = 0 Then
ReDim Preserve sf(1 To UBound(sf) + 256)
End If
End If
sd$(nDir) = Dir()
Wend
nDir = nDir - 1
Call QuickSort(sd$, 0, nDir)
Call QuickSort(sf, 1, nFile)
For I = 1 To nFile
tL = tL & Space(cD * 5) + sf(I) & nL
Next I
DS = DS & tL

If nDir >= 0 Then
For I = 0 To nDir
tPath = path$ & "\" & sd$(I)
DS = DS & "{\b " & DbS(tPath) & "}" & nL
ChDir tPath
Call ScanFoldersD(tPath, cD + 1)
Next I
End If
End Sub
Private Sub SWAP(first As String, second As String)
Dim temp As String
temp = first
first = second
second = temp
End Sub

Private Sub Command1_Click()
InF = CurDir
MsgBox "This program is about to go through the entire " & InF & _
" ,please be patient."
DS = "{{\b " & DbS(Dir1.List(-1)) & "}" + nL
Call ScanFoldersC(1)
DS = DS & "}"
RichTextBox1.TextRTF = DS
End Sub

Private Sub Command2_Click()
InF = CurDir
MsgBox "This program is about to go through the entire " & InF & _
" ,please be patient."
DS = "{{\b " & DbS(InF) & "}" + nL
Call ScanFoldersD(InF, 1)
DS = DS & "}"
RichTextBox1.TextRTF = DS
End Sub

Private Sub Command3_Click()
RichTextBox1.TextRTF = ""
CommonDialog1.ShowOpen
If CommonDialog1.filename <> "" Then _
RichTextBox1.filename = CommonDialog1.filename
End Sub

Private Sub Command4_Click()
CommonDialog1.Filter = "*.RTF|*.RTF"
CommonDialog1.filename = ""
CommonDialog1.ShowSave
On Error Resume Next
If CommonDialog1.filename <> "" Then _
RichTextBox1.SaveFile CommonDialog1.filename
End Sub

Private Sub Dir1_Change()
File1.filename = Dir1.path
End Sub

Private Sub Drive1_Change()
Dir1.path = Drive1.Drive
End Sub

Private Sub Form_Load()
Dir1.Visible = False
Drive1.Visible = False
Dir2.Visible = False
File1.Visible = False
Form1.Visible = True
Command1.Caption = "Directory View Method A"
Command2.Caption = "Directory View Method B"
Command3.Caption = "Open"
Command4.Caption = "Save"
End Sub

5. Run the program. Click either of the Directory View CommandButtons and
observe the effect. If your current directory is the root, the task may
take some time to complete.

NOTE: Name Spaces and other pseudo directory structures such as the
Internet temp directories may not be displayed using these methods.
返回

PRODUCT :Microsoft Visual Basic for Windows
PROD/VER:WINDOWS:5.0
OPER/SYS:WINDOWS
KEYWORDS:

======================================================================
---------------------------------------------------------------------
The information in this article applies to:

- Microsoft Visual Basic Learning, Professional, and Enterprise Editions
for Windows, version 5.0
---------------------------------------------------------------------

SUMMARY
=======

This article shows you how to list all the drives in a computer system
using the FileSystemObject. The article shows how to create a sample
project that lists all the drives in a system as well as the properties of
each drive.

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

This article assumes you are familiar with using objects, collections, and
object models in Visual Basic. The FileSystemObject allows you to perform a
number tasks on the file system of a computer. This object is available to
your project by making a reference to the Microsoft Script Runtime file
scrrun.dll. This file ships with Windows 98 and the following products:

Windows Scripting Host
Windows NT Option Pack
Microsoft Internet Information Server 3.0
Scripting 3.1 upgrade

After making a reference to the Script Runtime file, you create an instance
of the FileSystemObject using the CreateObject method or by creating a
variable as a new FileSystemObject. The object allows you to access each
Drive object in the Drives collection. Each Drive has a number of
properties that you can query to determine the drive type, the total space,
the free space, and the file system.

The next section shows you how to create a sample project that displays all
the drives in a system and the properties of each drive.

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

1. Start a new Standard EXE project in Visual Basic. Form1 is created by
default.

2. Add a reference to the Microsoft Script Runtime by completing the
following steps:

a. From the Project menu, click References to display the References
dialog box.

b. Click Browse to open the Add Reference dialog box.

c. Select the file scrrun.dll and click OK to close the Add Reference
dialog box. This file is installed in your system directory.
Microsoft Scripting Runtime appears with a check in the Available
Referenced list box of the References dialog box.

d. Click OK to close the References dialog box.

3. Add a CommandButton, ListBox, and Label to Form1.

4. Copy the following code to the Code window of Form1:

Option Explicit
Dim fso As New FileSystemObject
Dim fsoDrives As Drives
Dim fsoDrive As Drive

Private Sub Form_Load()
Label1.AutoSize = True
Command1.Caption = "List All Drives"
List1.Enabled = False
End Sub

Private Sub Command1_Click()
Dim sDrive As String
Dim sDriveType As String

Set fsoDrives = fso.Drives

List1.Enabled = True
For Each fsoDrive In fsoDrives
sDrive = "Drive " & fsoDrive.DriveLetter & ": "

Select Case fsoDrive.DriveType
Case 0: sDriveType = "Unknown"
Case 1: sDriveType = "Removable Drive"
Case 2: sDriveType = "Fixed Disk"
Case 3: sDriveType = "Remote Disk"
Case 4: sDriveType = "CDROM Drive"
Case 5: sDriveType = "RAM Disk"
End Select

sDrive = sDrive & sDriveType
List1.AddItem (sDrive)
Next
Set fsoDrives = Nothing
End Sub

Private Sub List1_Click()
Dim sDriveSpec As String
Dim sSelDrive As String

sSelDrive = List1.List(List1.ListIndex)
sSelDrive = Mid(sSelDrive, 7, 1)

Set fsoDrive = fso.GetDrive(sSelDrive)

With fsoDrive
If .IsReady = True Then
sDriveSpec = "Drive " & .DriveLetter & _
" Specifications" & vbLf
sDriveSpec = sDriveSpec & "Free Space: " & _
.FreeSpace & " bytes" & vbLf
sDriveSpec = sDriveSpec & "File System: " & _
.FileSystem & vbLf
sDriveSpec = sDriveSpec & "Serial Number: " & _
.SerialNumber & vbLf
sDriveSpec = sDriveSpec & "Total Size: " & _
.TotalSize & " bytes" & vbLf
sDriveSpec = sDriveSpec & "Volume Name: " & _
.VolumeName
Label1.Caption = sDriveSpec
Else
MsgBox ("Drive Not Ready")
End If
End With

Set fsoDrive = Nothing
End Sub

6. On the Run menu, select Start, or press the F5 key to start the program.
Click the "List All Drives" button to display all the drives in your
system in the ListBox. Click on a drive in the ListBox to display the
properties of the drive.
返回