常用过程或函数整理

本文均由糊涂无品(qq399457850)整理，源码借鉴于网络，转载请注明，仅供学习参考……
1.一维数组排序

Sub Quicksort(List, min As Long, max As Long) '自定义过程,带三个参数(数组,最小下标，最大下标) '快速排序算法（递归法）

Dim med_value As String, hi As Long, lo As Long, i As Long

If min >= max Then Exit Sub '判断参数2>=参数3退出过程

i = Int((max - min 1) * Rnd min) '取两参关系的随机整数

med_value = List(i)

List(i) = List(min)

lo = min

hi = max

Do While List(hi) >= med_value

hi = hi - 1

If hi <= lo Then Exit Do

Loop

If hi <= lo Then

List(lo) = med_value

Exit Do

End If

List(lo) = List(hi)

lo = lo 1

Do While List(lo) < med_value

lo = lo 1

If lo >= hi Then Exit Do

Loop

If lo >= hi Then

lo = hi

List(hi) = med_value

Exit Do

End If

List(hi) = List(lo)

Loop

Quicksort List, min, lo - 1 '递归调用

Quicksort List, lo 1, max

End Sub

Function QuickSort(Arr)‘冒泡法

Dim i, j

Dim bound, t

bound = UBound(Arr)

For i = 0 To bound - 1

For j = i 1 To bound

If Arr(i) > Arr(j) Then

t = Arr(i)

Arr(i) = Arr(j)

Arr(j) = t

End If

QuickSort = Arr

End Functio
2.取得文件中所有工作表名集合（EXCEL&ACCESS)

Function TablenameS(ByVal acc As String, Optional ByVal pass As String) '取得所有表名集合,工作簿或mdb数据库

Dim cat, sh

Dim cn As Object, rs As Object, st As String, srr(), s%

If acc Like '*.xlsx' Then

Set cat = CreateObject('ADOX.Catalog')

cat.ActiveConnection = 'dsn=excel files;dbq=' & acc

For Each sh In cat.tables

s = s 1

ReDim Preserve srr(1 To s)

srr(s) = sh.Name

ElseIf acc Like '*.mdb' Then

Set cn = CreateObject('ADODB.Connection')

Set rs = CreateObject('ADODB.Recordset')

cn.ConnectionString = 'Provider=Microsoft.ace.oledb.12.0;' & _

'Data Source=' & acc & _

';Jet OLEDB:Database Password=' & pass & ';'

cn.Open '打开数据库

Set rs = cn.OpenSchema(20)

Do Until rs.EOF

If rs!TABLE_TYPE = 'TABLE' Then

' If Left(rs!TABLE_NAME, 4) <> 'MSys' Then

st = rs!TABLE_NAME

If st <> '' Then

s = s 1

ReDim Preserve srr(1 To s)

srr(s) = st

End If

rs.MoveNext

Loop

cn.Close

Set cn = Nothing

End If

If s > 0 Then TablenameS = srr

End Function

3.最简单的显示文件夹选择对话框方法

Public Function ShowFolderDialog() As String

'/最简单的显示文件夹选择对话框方法

Dim spShell, spFolder, spFolderItem, spPath As String

Const WINDOW_HANDLE = 0

Const NO_OPTIONS = 0

Set spShell = CreateObject('Shell.Application')

Set spFolder = spShell.BrowseForFolder(WINDOW_HANDLE, '选择目录:', NO_OPTIONS, 'C:\Scripts')

If spFolder Is Nothing Then

ShowFolderDialog = ''

Else

Set spFolderItem = spFolder.Self

spPath = spFolderItem.path

spPath = Replace(spPath, '\', '\')

ShowFolderDialog = spPath

End If

End Function

4.判断文件夹或文件是否存在

Function WJYesNo(ByVal pat As String) As Boolean '判断文件夹或文件是否存在，参数“pat”要有盘符之类的

Dim MyFile As Object

Set MyFile = CreateObject('Scripting.FileSystemObject')

If MyFile.FileExists(pat) = True Then

WJYesNo = True

Else

WJYesNo = False

End If

End Function

5.判断EXCEL是否被打开

Function WJOpenClose(ByVal NAM As String) As Boolean '判断EXCEL是否被打开，参数“nam”是短文件名（不带路径的文件名）

On Error Resume Next

WJOpenClose = True

If StrComp(Workbooks(NAM).Name, NAM, vbTextCompare) <> 0 Then

WJOpenClose = False

End If

End Function

6.求得path文件夹下有多少个文件

Function WJcount(ByVal path As String) '求得path文件夹下有多个文件

Dim obj, fld

Set obj = CreateObject('Scripting.FileSystemObject')

Set fld = obj.GetFolder(path)

WJcount = fld.Files.Count

End Function

7.特殊文件夹名位置

Function TSWJFullName(文件夹名 As String) As String '特殊文件夹名位置

'AllUsersDesktop、AllUsersStartMenu、AllUsersPrograms、AllUsersStartup、Desktop、Favorites、Fonts

'MyDocuments、NetHood、PrintHood、Programs、Recent、SendTo、StartMenu、Startup、Templates、

Dim WSHShell As Object

Dim lj As String

Set WSHShell = CreateObject('Wscript.Shell')

lj = WSHShell.SpecialFolders(文件夹名)

Set WSHShell = Nothing

TSWJFullName = lj

End Function

8.读写记事本三种代码

Public Function GetTXT(path As String) '读取文本

On Error Resume Next

Open path For Input As #1

GetTXT = StrConv(InputB(LOF(1), 1), vbUnicode)

Close #1

End Function

Public Sub SetTXT(Strl As String, path As String) '写入文本

Open path For Output As #1

Print #1, Strl;

Close #1

End Sub

Public Sub SetTXTtoend(Strl As String, path As String) '可以逐行尾加写入文本

Open path For Append As #1

Print #1, Strl;

Close #1

End Sub

9.汉字转拼音首字函数

Function py(汉字) '汉字转拼首例：在单元格中键入'=py(a2)'

Dim hz As String, i%

hz = StrConv(汉字, vbNarrow)

For i = 1 To Len(hz)

If Asc(Mid(hz, i, 1)) = AscB(Mid(hz, i, 1)) Then

py = py & UCase(Mid(hz, i, 1))

Else

py = py & Application.VLookup(Mid(hz, i, 1), [{'阿','A';'芭','B';'擦','C';'搭','D';'蛾','E';'发','F';'噶','G';'哈','H';'击','J';'喀','K';'垃','L';'妈','M';'拿','N';'哦','O';'啪','P';'期','Q';'然','R';'撒','S';'塌','T';'挖','W';'昔','X';'压','Y';'匝','Z'}], 2)

End If

Next i

End Function

10.二维数组转置函数

Function RWZZ(zrr1) '数组转置

Dim i As Integer, j As Integer, zrr2()

ReDim zrr2(LBound(zrr1, 2) To UBound(zrr1, 2), LBound(zrr1, 1) To UBound(zrr1, 1))

For i = LBound(zrr1, 1) To UBound(zrr1, 1)

For j = LBound(zrr1, 2) To UBound(zrr1, 2)

If IsNull(zrr1(i, j)) = False Then zrr2(j, i) = zrr1(i, j)

Next j

Next i

RWZZ = zrr2

End Function

11.文件创建、访问、修改时间

Public Function ShowFileInfo(ByVal filespec As String) As Date '取得文件创建时间

'Debug.Print ObjFile.DateCreated '文件创建时间

'Debug.Print ObjFile.DateLastAccessed '文件访问时间

'Debug.Print ObjFile.DateLastModified '文件修改时间FileSizes = ObjFile.Size ‘文件大小字节为单位

Dim fs, f, s

Set fs = CreateObject('Scripting.FileSystemObject')

Set f = fs.GetFile(filespec)

' ShowFileInfo = f.DateCreated '文件创建时间

' ShowFileInfo = f.DateLastAccessed '文件访问时间

ShowFileInfo = f.DateLastModified '文件修改时间

End Function
12.创建文件夹
Public Sub 创建文件夹(ByVal pat As String)

On Error Resume Next

Dim oFso, arr, i As Integer, st As String

Set oFso = CreateObject('Scripting.FileSystemObject')

arr = Split(pat, '\')

st = arr(0)

For i = 1 To UBound(arr) - 1

st = st & '\' & arr(i)

oFso.CreateFolder st

Next i

End Sub
待续…… 2018-01-01

收藏本文，省得用的时候去找了。

本站仅提供存储服务，所有内容均由用户发布，如发现有害或侵权内容，请点击举报。