分类 [ 学习编程 ] 下的全部文章

'此方法不需要引用IShellLink.

Private Type FILETIME
dwLowDateTime
As Long
dwHighDateTime As Long
End
Type

Private Type LNKHEAD
dwID
As Long
dwGUID(3) As Long
dwFlags As Long
dwFileAttributes As Long
dwCreationTime As FILETIME
dwModificationTime
As FILETIME
dwLastaccessTime
As FILETIME
dwFileLen
As Long
dwIconNum As Long
dwWinStyle As Long
dwHotkey As Long
dwReserved1 As Long
dwReserved2 As Long
End
Type

Private Type FILELOCATIONINFO
dwSize
As Long
dwFirstOffset As Long
dwFlags As Long
dwOffsetOfVolume As Long
dwOffsetOfBasePath As Long
dwOffsetOfNetworkVolume As Long
dwOffsetOfRemainingPath As Long
End
Type

Private Type LOCALVOLUMETAB
dwSize
As Long
dwTypeOfVolume As Long
dwVolumeSerialNumber As Long
dwOffsetOfVolumeName As Long
strVolumeName As Byte
End
Type

Private Type NETWORKVOLUMETAB
dwSize
As Long
dwUnknown1 As Long
dwOffsetOfNetShareName As Long
dwUnknown2 As Long
dwUnknown3 As Long
strNetShareName As Byte
End
Type

Private Const LNK_HASIDLIST = &H1
Private Const LNK_FILEDIR = &H2
Private Const LNK_HASDES = &H4
Private Const LNK_HASPATH = &H8
Private Const LNK_HASWORKDIR = &H10
Private Const LNK_HASCMD = &H20

Private Const LNK_LOCALVOLUME = &H1
Private Const LNK_NETSHARE = &H2

Public Function GetLinkPath(ByVal strShortCut As String) As String
Dim
objLinked As LNKHEAD
Dim intNo As Integer, intTmp As Integer
Dim
objInfo As FILELOCATIONINFO
Dim intSeek As Integer
Dim
bytBuffer() As Byte
intNo = FreeFile
Open strShortCut
For Binary As #intNo
Get #intNo, , objLinked
intSeek = Len(objLinked)
If objLinked.dwFlags And LNK_HASIDLIST Then
Get
#intNo, , intTmp
Else
Close #intNo
Exit Function
End If
intSeek = Seek(intNo)
intSeek = intSeek + intTmp
Seek
#intNo, intSeek
Get #intNo, , objInfo
Seek #intNo, objInfo.dwOffsetOfBasePath + intSeek
If objInfo.dwFlags And LNK_NETSHARE Then
intSeek = objInfo.dwOffsetOfNetworkVolume - objInfo.dwOffsetOfBasePath
Else
intSeek = objInfo.dwOffsetOfRemainingPath - objInfo.dwOffsetOfBasePath
End If
ReDim
bytBuffer(intSeek - 1)
Get #intNo, , bytBuffer
Close #intNo
GetLinkPath = StrConv(bytBuffer, vbUnicode)
End Function



Private Declare Function fCreateShellLink Lib "VB5STKIT.DLL" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String, ByVal lpstrLinkPath As String, ByVal lpstrLinkArgs As String) As Long

Sub
Command1_Click()
Dim lReturn As Long
'添加到桌面
lReturn = fCreateShellLink("..\..\Desktop","ShortcuttoCalculator","c:\windows\calc.exe","")
'添加到程序组
lReturn = fCreateShellLink("","ShortcuttoCalculator","c:\windows\calc.exe","")
'添加到启动组
lReturn = fCreateShellLink("\Startup","ShortcuttoCalculator","c:\windows\calc.exe","")
End Sub



Public Function ToExcel()
On Error GoTo ErrorHandler

Dim exlapp As Excel.Application
Dim exlbook As Excel.Workbook
Set exlapp = CreateObject("Excel.Application")
Set exlbook = exlapp.Workbooks.Add
exlapp.Caption =
"数据正在导出......"
exlapp.Visible = True
exlapp.DisplayAlerts = False

Dim
exlsheet As Excel.Worksheet

Set exlsheet = exlbook.Worksheets.Add

exlsheet.Activate
Set exlsheet = exlsheet
exlsheet.Name =
"【我导出的数据】"

'设置列宽
exlapp.ActiveSheet.Columns(1).ColumnWidth = 10

exlapp.ActiveSheet.Columns(2).ColumnWidth = 20


StrSql = "【你的SQL语句】"

Set exl_rs = PubSysCn.Execute(StrSql)

exlsheet.Range(
"A2").CopyFromRecordset exl_rs

exl_rs.Close
Set exl_rs = Nothing

exlapp.Worksheets("sheet1").Delete
exlapp.Worksheets(
"sheet2").Delete
exlapp.Worksheets(
"sheet3").Delete
exlapp.DisplayAlerts =
True
exlapp.Caption = "数据导出完毕!!"
exlapp.Visible = True

Set
exlapp = Nothing
Set
exlbook = Nothing
Set
exlsheet = Nothing

Exit Function

ErrorHandler:
MsgBox
"EXCEL : " & err.Number & " : " & err.Description
End Function



Option Explicit
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Const
SM_CXSCREEN = 0
Const SM_CYSCREEN = 1

Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean

Private Declare Function
ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwflags As Long) As Long

Const
CCDEVICENAME = 32
Const CCFORMNAME = 32
Const DM_PELSWIDTH = &H80000
Const DM_PELSHEIGHT = &H100000

Private Type DEVMODE
dmDeviceName
As String * CCDEVICENAME
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 As String * CCFORMNAME
dmUnusedPadding
As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End
Type
Dim DevM As DEVMODE


Sub ChangeRes(iWidth As Single, iHeight As Single)
Dim a As Boolean
Dim
i As Integer
Dim
b As Long
i = 0
Do
a = EnumDisplaySettings(0&, i, DevM)
i = i +
1
Loop Until (a = False)
DevM.dmFields = DM_PELSWIDTH
or DM_PELSHEIGHT
DevM.dmPelsWidth = iWidth
DevM.dmPelsHeight = iHeight
ChangeDisplaySettings DevM,
0
End Sub

Private Sub
Command1_Click()
Dim x As String
Dim
y As String

If
Val(x) <> 1024 or Val(y) <> 768 Then
Call
ChangeRes(1024, 768)
End If
x = CStr(GetSystemMetrics(SM_CXSCREEN))
y =
CStr(GetSystemMetrics(SM_CYSCREEN))
Me.Caption =
"当前显示器分辨率: " & x & "x" & y
End Sub

Private Sub
Form_Load()
Dim x As String
Dim
y As String
x = CStr(GetSystemMetrics(SM_CXSCREEN))
y =
CStr(GetSystemMetrics(SM_CYSCREEN))
Me.Caption =
"当前显示器分辨率: " t>& x & "x" & y
Call ChangeRes(800, 600) '将分辨率设置成800*600
End Sub




我们都知道在VB中TextBox默认是没有双击消息过程的(也就是双击事件,单击事件是有的.),那么看看本文是怎么实现TextBox双击消息的吧。

Option Explicit

Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function
SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function
CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Public Const
GWL_WNDPROC = (-4)
Public Const WM_NCLBUTTONDBLCLK = &H203 'DoubleClick Message
Public prevWndProc As Long

Public Function
WndProc(ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If
msg = WM_NCLBUTTONDBLCLK Then 'DoubleClick Message
'Eat The Message
Else 'Other Message send to next
WndProc = CallWindowProc(prevWndProc, hwnd, msg, wParam, lParam)
End If
End Function

'*************************************************************************
'**主要函数
'*************************************************************************
Public Sub TxtDoubleClickMassage(Frm As Form)
Dim i As Integer
For
i = 0 To 9 '
'区分符号
prevWndProc = GetWindowLong(Frm.txtKairo(i).hwnd, GWL_WNDPROC)
SetWindowLong Frm.txtKairo(i).hwnd, GWL_WNDPROC,
AddressOf WndProc
'名称1
prevWndProc = GetWindowLong(Frm.txtIkisaki1(i).hwnd, GWL_WNDPROC)
SetWindowLong Frm.txtIkisaki1(i).hwnd, GWL_WNDPROC,
AddressOf WndProc
'名称2
prevWndProc = GetWindowLong(Frm.txtIkisaki2(i).hwnd, GWL_WNDPROC)
SetWindowLong Frm.txtIkisaki2(i).hwnd, GWL_WNDPROC,
AddressOf WndProc
Next
End Sub



'按钮一是音量增加,按钮二是音量减少,按钮三是静音切换.
Option Explicit

Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long

Private Const
WM_APPCOMMAND As Long = &H319
Private Const APPCOMMAND_VOLUME_UP As Long = 10
Private Const APPCOMMAND_VOLUME_DOWN As Long = 9
Private Const APPCOMMAND_VOLUME_MUTE As Long = 8

Private Sub Command1_Click()
'音量增加
SendMessage Me.hwnd, WM_APPCOMMAND, &H30292, APPCOMMAND_VOLUME_UP * &H10000
End Sub

Private Sub
Command2_Click()
'音量减少
SendMessage Me.hwnd, WM_APPCOMMAND, &H30292, APPCOMMAND_VOLUME_DOWN * &H10000
End Sub

Private Sub
Command3_Click()
'静音
SendMessage Me.hwnd, WM_APPCOMMAND, &H200EB0, APPCOMMAND_VOLUME_MUTE * &H10000
End Sub




本博客有一篇类似的文章《VB 中运用 TimeSetEvent 代替 Timer 控件》与这篇不同。
本篇展示了另外两种方法,具体如下文所示。

方法1:
  用这个类可以替代VB自带的Timer控件,这样就不用在无窗体的项目中仅为了使用Timer而多加一个窗体了。我一般用在ActiveX exe中用来分离系统控制权,用Timer的好处是避免控制权死锁,这样也就模拟出了多线程(实际上是多进程),能给用户更好的体验。代码如下:
标准模块(mTimer.bas)

Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Public TimerColl As New VBA.Collection

Public Sub TimeProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
Dim Timer As Timer, lpTimer As Long
lpTimer = TimerColl("ID:" & idEvent)
CopyMemory Timer, lpTimer,
4&
Timer.PulseTimer
CopyMemory Timer,
0&, 4&
End Sub


类模块(Timer.bas)

Option Explicit

Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function
KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long

Private
m_TimerID As Long
Private
m_Interval As Long
Private
m_Enabled As Boolean

Public
Tag As Variant
Public Event
Timer()

Public Property Get Interval() As Long
Interval = m_Interval
End Property

Public Property Let
Interval(ByVal Value As Long)
m_Interval = Value
Enabled = m_Enabled
End Property

Public Property Get
Enabled() As Boolean
Interval = m_Enabled
End Property

Public Property Let
Enabled(ByVal Value As Boolean)
If Value Then
m_Enabled = StartTimer
Else
Call
StopTimer
End If
End Property

Private Function
StartTimer() As Boolean
If
m_TimerID = 0 Then
If
m_Interval > 0 Then
m_TimerID = SetTimer(0, 0, m_Interval, AddressOf TimeProc)
If m_TimerID <> 0 Then
TimerColl.Add ObjPtr(Me), "ID:" & m_TimerID
StartTimer =
True
End If
Else
m_Enabled = True
End If
End If
End Function

Friend Sub
PulseTimer()
RaiseEvent Timer
End Sub

Private Sub
StopTimer()
If m_TimerID <> 0 Then
KillTimer 0, m_TimerID
TimerColl.Remove
"ID:" & m_TimerID
m_TimerID =
0
m_Enabled = False
End If
End Sub

Private Sub
Class_Terminate()
Call StopTimer
ont color="#0000FF">End Sub

使用方法:
Private WithEvents Timer1 As Timer
Private Sub Form_Load()
Set Timer1 = New TimerLib.Timer
Timer1.Interval =
1000
Timer1.Enabled = True
End Sub
Private Sub
Timer1_Timer()
Debug.Print Now
End Sub


方法2:
用SetTimer函数定义一个ID,并标志一个触发时间(以MS为单位)和回调函数地址.
当指定的触发时间到了,系统就会调用那个指定的回调函数,并以你在SetTimer时定义的ID为参数,这样就可以区别多个定时器了.
当不需要使用某个定时器时,就使用KillTimer函数把指定ID的定时器干掉就可以了.
窗体代码:

Option Explicit

Const GWL_WNDPROC = (-4)

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Declare Function
SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function
KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long

Private Sub
Form_Load()
glngFuncAdd = SetWindowLong(hWnd, GWL_WNDPROC,
AddressOf WndProc_TimerTest)
Call SetTimer(hWnd, TIMERID, 500, 0&)
End Sub

Private Sub
Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If glngFuncAdd > 0 Then Call SetWindowLong(hWnd, GWL_WNDPROC, glngFuncAdd)
Call KillTimer(hWnd, TIMERID)
End Sub


模块代码:

Option Explicit

Const WM_TIMER = &H113

Public Const TIMERID = &H100 '自定义Timer的ID号

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Public
glngFuncAdd As Long

Public Function
WndProc_TimerTest(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If
wMsg = WM_TIMER Then
If
wParam = TIMERID Then
Debug.Print Timer
End If
End If

WndProc_TimerTest = CallWindowProc(glngFuncAdd, hWnd, wMsg, wParam, lParam)
End Function




  程序思想:用Select name From sysobjects Where xtype = 'u'得到所有表,然后循环打开表,根据 Rs_Colums.Fields(I).Name 得到字段名, FieldType(Rs_Colums.Fields(I).Type) 得到字段类型, Rs_Colums.Fields(I).DefinedSize 宽度
  由于Rs_Colums.Fields(I).Type返回类型是数字,程序中写了一个FieldType函数转化成中文类型。

Private Sub Command1_Click()
 Dim Cn
As New ADODB.Connection
 Dim Rs_Table
As New ADODB.Recordset
 Dim Rs_Colums
As New ADODB.Recordset
  
 With Cn 
'定义连接
  .CursorLocation = adUseClient
  .Provider =
"sqloledb"
  .Properties("Data Source").Value = "LIHG"
  .Properties("Initial Catalog").Value = "NorthWind"
  .Properties("User ID") = "sa"
  .Properties("Password") = "sa"
  .Properties("prompt") = adPromptNever
  .ConnectionTimeout =
15
  .Open
  
  If .State = adStateOpen
Then
  Rs_Table.CursorLocation = adUseClient  '得到所有表名
  Rs_Table.Open "Select name From sysobjects Where xtype = 'u'", Cn, adOpenDynamic, adLockReadOnly
  Rs_Table.MoveFirst
  Do
While Not Rs_Table.EOF
  Debug.Print Rs_Table.Fields(
"name")
  Rs_Colums.CursorLocation = adUseClient
  Rs_Colums.Open
"select top 1 * from [" & Rs_Table.Fields("name") & "]", Cn, adOpenStatic, adLockReadOnly
  For I =
0 To Rs_Colums.Fields.Count - 1  ' 循环所有列
  Debug.Print Rs_Colums.Fields(I).Name  '字段名
  Debug.Print FieldType(Rs_Colums.Fields(I).Type) '字段类型
  Debug.Print Rs_Colums.Fields(I).DefinedSize '宽度
  Next
  Rs_Colums.Close
  Rs_Table.MoveNext
  Loop
  Rs_Table.Close
  Set Rs_Colums =
Nothing
  Set Rs_Table = Nothing
  Else
  MsgBox
"数据库连接失败,请找系统管理员进行检查 !", 16, cProgramName
  End
  End
If
 End With
End Sub
  
'*********************************************************
'* 名称:FieldType
'* 功能:返回字段类型
'* 用法:FieldType(nType as integer)
'*********************************************************
Function FieldType(nType As Integer) As String
 Select Case nType
  Case
128
  FieldType = "BINARY"
  Case 11
  FieldType = "BIT"
  Case 129
  FieldType = "CHAR"
  Case 135
  FieldType = "DATETIME"
  Case 131
  FieldType = "DECIMAL"
  Case 5
  FieldType = "FLOAT"
  Case 205
  FieldType = "IMAGE"
  Case 3
  FieldType = "INT"
  Case 6
  FieldType = "MONEY"
  Case 130
  FieldType = "NCHAR"
  Case 203
  FieldType = "NTEXT"
  Case 131
  FieldType = "NUMERIC"
  Case 202
  FieldType = "NVARCHAR"
  Case 4
  FieldType = "REAL"
  Case 135
  FieldType = "SMALLDATETIME"
  Case 2
  FieldType = "SMALLMONEY"
  Case 6
  FieldType = "TEXT"
  Case 201
  FieldType = "TIMESTAMP"
  Case 128
  FieldType = "TINYINT"
  Case 17
  FieldType = "UNIQUEIDENTIFIER"
  Case 72
  FieldType = "VARBINARY"
  Case 204
  FieldType = "VARCHAR"
  Case 200
  FieldType = ""
 End Select
End Function


  此程序只是一个雏形,可以在此基础上开发成一个工具使用
  本程序在:VB 6.0 ,SQL SERVER 2000下运行通过
  注程序中须引用 ActiveX Data Objects (ADO)



'注释
The DeviceIoControl function sends a control code directly to a specified device driver, causing the corresponding device to perform the corresponding operation.

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

'各个参数注解
?hDevice
[in] Handle to the device on which to perform the operation, typically a volume, directory, file, or alternate stream. To retrieve a device handle, use the function.

?dwIoControlCode
[in] Specifies the control code for the operation. This value identifies the specific operation to be performed and the type of device on which to perform it.
For a list of the control codes and a short description of each control code, see Device Input and Output Control Codes .

For more detailed information on each control code, see its documentation. In particular, the documentation provides details on the usage of the lpInBuffer, nInBufferSize, lpOutBuffer, nOutBufferSize, and lpBytesReturned parameters.

?lpInBuffer
[in] Pointer to a buffer that contains the data required to perform the operation.
This parameter can be NULL if the dwIoControlCode parameter specifies an operation that does not require input data.

?nInBufferSize
[in] Specifies the size, in bytes, of the buffer pointed to by lpInBuffer.

?lpOutBuffer
[out] Pointer to a buffer that receives the operation's output data.
This parameter can be NULL if the dwIoControlCode parameter specifies an operation that does not produce output data.

?nOutBufferSize
[in] Specifies the size, in bytes, of the buffer pointed to by lpOutBuffer.

?lpBytesReturned
[out] Pointer to a variable that receives the size, in bytes, of the data stored into the buffer pointed to by lpOutBuffer.
If the output buffer is too small to return any data, then the call fails, returns the error code ERROR_INSUFFICIENT_BUFFER, and the returned byte count is zero.
If the output buffer is too small to hold all of the data but can hold some entries, then the operating system returns as much as fits, the call fails, GetLastError returns the error code ERROR_MORE_DATA, and lpBytesReturned indicates the amount of data returned. Your application should call DeviceIoControl again with the same operation, specifying a new starting point.
If lpOverlapped is NULL, lpBytesReturned cannot be NULL. Even when an operation produces no output data, and lpOutBuffer can be NULL, DeviceIoControl makes use of the variable pointed to by lpBytesReturned. After such an operation, the value of the variable is without meaning.
If lpOverlapped is not NULL, lpBytesReturned can be NULL. If this is an overlapped operation, you can get the number of bytes returned by calling . If hDevice is associated with an I/O completion port, you can get the number of bytes returned by calling .

?lpOverlapped
[in] Pointer to an structure.

If hDevice was opened with the FILE_FLAG_OVERLAPPED flag, lpOverlapped must point to a valid OVERLAPPED structure. In this case, the operation is performed as an overlapped (asynchronous) operation. If the device was opened with FILE_FLAG_OVERLAPPED and lpOverlapped is NULL, the function fails in unpredictable ways.
If hDevice was opened without specifying the FILE_FLAG_OVERLAPPED flag, lpOverlapped is ignored and DeviceIoControl does not return until the operation has been completed, or an error occurs.

'返回值
If the function succeeds, the return value is nonzero.

If the function fails, the return value is zero. To get extended error information, call GetLastError.


'例子
'Example by Howard Henry Schlunder
' This example requires one command button (Command1)
Private Declare Function GetVersion Lib "kernel32" () As Long
Private Declare Function
CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile 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
CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Const
INVALID_HANDLE_VALUE = -1
Private Const OPEN_EXISTING = 3
Private Const FILE_FLAG_Delete_ON_CLOSE = 67108864
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const IOCTL_STORAGE_EJECT_MEDIA = 2967560
Private Const VWIN32_DIOC_DOS_IOCTL = 1

Private Type DIOC_REGISTERS
reg_EBX
As Long
reg_EDX As Long
reg_ECX As Long
reg_EAX As Long
reg_EDI As Long
reg_ESI As Long
reg_Flags As Long
End
Type

Private Sub Command1_Click()
Dim hDrive As Long, DummyReturnedBytes As Long
Dim
EjectDrive As String, DriveLetterAndColon As String
Dim
RawStuff As DIOC_REGISTERS
EjectDrive = InputBox(
"Which drive shall we try to eject the media from?", "Eject Media")
If Len(EjectDrive) Then 'Confirm the user didn't cancel
DriveLetterAndColon = UCase(Left$(EjectDrive & ":", 2)) 'Make it all caps for easy interpretation
If GetVersion >= 0 Then 'We are running Windows NT/2000
hDrive = CreateFile("\\.\" & DriveLetterAndColon, GENERIC_READ Or GENERIC_WRITE, 0, ByVal 0, OPEN_EXISTING, 0, 0)
If hDrive <> INVALID_HANDLE_VALUE Then
'Eject media!
Call DeviceIoControl(hDrive, IOCTL_STORAGE_EJECT_MEDIA, 0, 0, 0, 0, DummyReturnedBytes, ByVal 0)
Call CloseHandle(hDrive) 'Clean up after ourselves
End If
Else
'We are running Win9x/Me
hDrive = CreateFile("\\.\VWIN32", 0, 0, ByVal 0, 0, FILE_FLAG_Delete_ON_CLOSE, 0)
If hDrive <> INVALID_HANDLE_VALUE Then
'Setup our raw registers to use Interrupt 21h Function 440Dh Minor Code 49h
RawStuff.reg_EAX = &H440D 'The function to use
RawStuff.reg_EBX = Asc(DriveLetterAndColon) - Asc("A") + 1 'The drive to do it on
RawStuff.reg_ECX = &H49 Or &H800 'The minor code of the function in the low byte of the low word and the device category of 8 in the high byte of the low word
'Eject media!
Call DeviceIoControl(hDrive, VWIN32_DIOC_DOS_IOCTL, RawStuff, LenB(RawStuff), RawStuff, LenB(RawStuff), DummyReturnedBytes, ByVal 0)
Call CloseHandle(hDrive) 'Clean up after ourselves
End If
End If
End If
End Sub



'模块说明:读取与替换ini项数据
Option Explicit

Public Type iniFiles
iniValue
As String '项值
iniType As String '项名
End Type

Public iniFile() As iniFiles

'函数名称 : ReadINI(iPath,TagType,iniFileValue())
'举 例 : ReadINI(文件路径,标签名,数值())
'作 用 : 读取ini文件指定标签中的所有数据
Public Function ReadINI(iPath As String, TagType As String, iniFileValue() As iniFiles) As Boolean
Dim
iFile As Integer, LoadBytes() As Byte
Dim
iniTmpFile As String, iniTmp As String '临时存储
Dim iniData() As iniFiles '最后赋值

Dim FstSearch As String, EndSearch As String '开始/最后
Dim FstPos As Long, EndPos As Long '开始/最后
Dim MidPos As Long, NexPos As Long '中间/下一
Dim LenFst As Integer, NowPos As Integer
'从数据文件中读取信息,加入到iniFileValue()中
If Dir(iPath) <> "" Then
'打开文件 开始
iFile = FreeFile
Open iPath
For Binary As #iFile
ReDim LoadBytes(1 To LOF(iFile)) As Byte
Get
#iFile, , LoadBytes
Close #iFile
iniTmpFile = StrConv(LoadBytes, vbUnicode) '先全部读取 在对字符串进行操作
'打开文件 结束
'[标签0]...[标签1]...[标签2]...[标签3]
FstSearch = UCase("[" & TagType & "]" & vbCrLf) '设置开始 字符
EndSearch = UCase(vbCrLf & "[") '设置结束 字符
LenFst = Len(FstSearch)

ReDim iniData(Len(iniTmpFile)) As iniFiles

FstPos = InStr(UCase(iniTmpFile), FstSearch)
'查找 开始字符 StaTag 的位置
EndPos = InStr(FstPos + LenFst, UCase(iniTmpFile), EndSearch) '查找 最后字符 EndTag 的位置
If EndPos = 0 Then EndPos = Len(iniTmpFile) + 1 '查找 错误 EndPos = 最后位置

If FstPos > 0 And EndPos > FstPos Then
iniTmp = Mid$(iniTmpFile, FstPos + LenFst, EndPos - (FstPos + LenFst)) '获取 区域字符串

FstPos = 1: NowPos = 0
MidPos = InStr(iniTmp, "=") '查找 开始字符 StaTag 的位置

EndPos = InStr(MidPos + 1, iniTmp, vbCrLf) '查找 结束字符 EndTag 的位置
If EndPos = 0 Then EndPos = Len(iniTmp) + 1 '查找 错误 EndPos = 最后位置

NexPos = InStr(EndPos + 1, iniTmp, "=") '查找 最后字符 EndTag 的位置
If NexPos = 0 Then NexPos = Len(iniTmp) '查找 错误 EndPos = 最后位置

iniData(NowPos).iniType = Trim$(Mid$(iniTmp, FstPos, MidPos - FstPos)) '获取 "Type = Value" 的 Type
iniData(NowPos).iniValue = Trim$(Mid$(iniTmp, MidPos + 1, EndPos - MidPos)) '获取 "Type = Value" 的 Value
'循环查找
While NexPos > 0 And NexPos <> Len(iniTmp)
FstPos = EndPos + Len(vbCrLf): NowPos = NowPos +
1
MidPos = InStr(FstPos, iniTmp, "=") '查找 开始字符 StaTag 的位置

color="#000000">EndPos = InStr(MidPos + 1, iniTmp, vbCrLf) '查找 结束字符 EndTag 的位置
If EndPos = 0 Then EndPos = Len(iniTmp) + 1 '查找 错误 EndPos = 最后位置

NexPos = InStr(EndPos + 1, iniTmp, "=") '查找 最后字符 EndTag 的位置
If NexPos = 0 Then NexPos = Len(iniTmp) '查找 错误 EndPos = 最后位置

iniData(NowPos).iniType = Trim$(Mid$(iniTmp, FstPos, MidPos - FstPos)) '获取 "Type = Value" 的 Type
iniData(NowPos).iniValue = Trim$(Mid$(iniTmp, MidPos + 1, EndPos - MidPos)) '获取 "Type = Value" 的
Wend
Else
NowPos = 0
iniData(NowPos).iniType = "Null"
iniData(NowPos).iniValue = "Null"
End If

ReDim
iniFileValue(NowPos) As iniFiles
For iFile = 0 To NowPos
iniFileValue(iFile) = iniData(iFile)
Next iFile
ReadINI =
True
End If
End Function

'函数名称 : ReplaceINI(iPath,TagType,iniFileValue())
'举 例 : ReplaceINI(文件路径,标签名,数值())
'作 用 : 替换ini文件指定标签中的所有数据
Function ReplaceINI(iPath As String, TagType As String, iniFileValue() As iniFiles)
Dim iFile As Integer
Dim
FstSearch As String, EndSearch As String '开始/最后
Dim FstPos As Long, EndPos As Long '开始/最后
Dim iniTmp As String, iniTmpFile(1) As String
Dim
iniFile As String

If
Dir(iPath) <> "" Then
'打开文件 开始
iFile = FreeFile
Open iPath
For Binary As #iFile
ReDim LoadBytes(1 To LOF(iFile)) As Byte
Get
#iFile, , LoadBytes
Close #iFile
iniTmp = StrConv(LoadBytes, vbUnicode) '先全部读取 在对字符串进行操作
'打开文件 结束
'[标签0]...[标签1]...[标签2]...[标签3]
FstSearch = UCase("[" & TagType & "]" & vbCrLf) '设置开始 字符
EndSearch = UCase(vbCrLf & "[") '设置结束 字符

FstPos = InStr(UCase(iniTmp), FstSearch) '查找 开始字符 StaTag 的位置
If FstPos = 0 Then FstPos = Len(iniTmp) + 1 '查找 错误 StaTag = 最后位置
EndPos = InStr(FstPos + 1, UCase(iniTmp), EndSearch) '查找 最后字符 EndTag 的位置
If EndPos = 0 Then EndPos = Len(iniTmp) + 1 '查找 错误 EndPos = 最后位置

If FstPos > Len(vbCrLf) Then FstPos = FstPos - Len(vbCrLf) + 1

If EndPos > Len(vbCrLf) Then EndPos = EndPos + Len(vbCrLf)
If FstPos <> 1 Then
iniTmpFile(0) = Mid$(iniTmp, 1, FstPos) '文件头
End If
iniTmpFile(1) = Mid$(iniTmp, EndPos, Len(iniTmp) + 1) '文件尾
Else
iniTmpFile(0) = "": iniTmpFile(1) = ""
End If

iniFile = iniTmpFile(0) '增加文件头
iniFile = iniFile & r="#808080">"[" & TagType & "]" & vbCrLf
For iFile = 0 To UBound(iniFileValue)
iniFile = iniFile & iniFileValue(iFile).iniType &
" = " & iniFileValue(iFile).iniValue & vbCrLf
Next iFile

If iniTmpFile(1) <> "" Then
iniFile = iniFile & iniTmpFile(1) '增加文件尾
Else
iniFile = Mid$(iniFile, 1, Len(iniFile) - Len(vbCrLf)) '过滤最后的回车键
End If

iFile = FreeFile
Open iPath
For Output As #iFile
Print #iFile, iniFile
Close #iFile
End Function