'此方法不需要引用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

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