VBA技术技巧收集

fanjy 发表于 2007-2-9 10:49:00
本辑目录：
[001]在工作表中插入图片
[002]将所选单元格区域存储为图片
[003]仿Word中的字数统计功能
[004]自动隐藏公式栏
[005] 从已关闭的工作簿中复制单元格区域
[006] 从已关闭的工作簿中获取该工作簿中的工作表名称
[007] 在VBA中使用DOS命令
= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
[001]在工作表中插入图片
使用Insert方法，例如，下面的代码将从Web网上相应的地址中获取图片并在当前工作表中以活动单元格为起点放置图片。
Sub InsertPicture()
ActiveSheet.Pictures.Insert “UploadFiles/2006-10/1025523341.jpg"
End Sub
同理，下面的代码将从您的计算机中的C盘相应文件夹中获取图片并在当前工作表中以活动单元格为起点放置图片。
Sub InsertPicture()
ActiveSheet.Pictures.Insert _
"C:/Documents and Settings/All Users/Documents/My Pictures/示例图片/Water lilies.jpg"
End Sub
[002]将所选单元格区域存储为图片
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Const CF_BITMAP = 2
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As PicBmp, RefIID As Guid, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'- - - - - - - - - - - - - - - - - - - - - - - - -
Sub SaveImage(rng As Range, strFileName As String)
Dim hwnd As Long
Dim hPtr As Long
hwnd = FindWindow("xlmain", Application.Caption)
rng.CopyPicture xlScreen, xlBitmap
OpenClipboard hwnd
hPtr = GetClipboardData(CF_BITMAP)
SavePicture CreateBitmapPicture(hPtr), strFileName
CloseClipboard
End Sub
'- - - - - - - - - - - - - - - - - - - - - - - - -
Function CreateBitmapPicture(ByVal hBmp As Long) As IPicture
Dim lngR As Long, Pic As PicBmp, IPic As IPicture, IID_IDispatch As Guid
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With Pic
.Size = Len(Pic)
.Type = 1
.hBmp = hBmp
End With
lngR = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
Set CreateBitmapPicture = IPic
End Function
'- - - - - - - - - - - - - - - - - - - - - - - - -
Sub selectRangeToBmp()
Dim rng As Range
Dim strName As String
On Error Resume Next
Set rng = Application.InputBox(prompt:="请选择单元格区域", Title:="将单元格区域存储为图片", Type:=8)
strName = InputBox(prompt:="请输入完整路径和扩展名的文件名", Title:="输入文件名")
SaveImage rng, strName
End Sub
[代码说明] 运行selectRangeToBmp()程序后，将出现两个对话框，第一个对话框要求用户选择当前工作表中想要存储为图片的单元格区域，第二个对话框要求用户输入图片的存放位置和文件名，要求写出完整的文件路径且须带.bmp或.jpg等扩展名，例如C:/<文件夹和子文件夹>/<文件名>.<扩展名>，若只写出文件名，则会将图片存放在默认文件夹中。
本示例代码摘自Mark Rowlinson的文章《Saving a Spreadsheet Range as a .bmp image file》，稍作调整和修改。
[003]仿Word中的字数统计功能
下面的代码仿照Word中的字数统计功能，对单元格或者单元格区域中的字数(字符数)进行分类统计：
Sub SubTotalSelectionCharNum()
Dim str As String, ChineseChar As Long
Dim Alphabetic As Long, Number As Long
Dim blank As Long, AlpAndNum As Long
Dim i As Long, rng As Range, j As Long, k As Long
For Each rng In Selection
j = j + Len(rng.Value)
For i = 1 To Len(rng)
str = Mid(rng.Value, i, 1)
If str Like "[一-龥]" = True Then
ChineseChar = ChineseChar + 1 '汉字累加
ElseIf str Like "[a-zA-Z]" = True Then
Alphabetic = Alphabetic + 1 '字母累加
'字母和数字在一起被认为是一个字
If i <> 1 And i = k + 1 Then AlpAndNum = AlpAndNum + 1
k = i
ElseIf str Like "[0-9]" = True Then
Number = Number + 1 '数字累加
If i <> 1 And i = k + 1 Then AlpAndNum = AlpAndNum + 1
k = i
ElseIf str Like " " = True Then
blank = blank + 1
End If
Next
Next
MsgBox "所选单元格区域中共有字符数(不计空格)" & j - blank & "个，其中：" & vbCrLf & "汉字：" & ChineseChar & "个" & _
vbCrLf & "字母：" & Alphabetic & "个" & _
vbCrLf & "数字：" & Number & "个" & _
vbCrLf & "- - - - - - - - -" & _
vbCrLf & "空格：" & blank & "个" & _
vbCrLf & "- - - - - - - - -" & _
vbCrLf & "所选单元格区域中共有字数(不计空格)" & j - blank - AlpAndNum & "个", _
vbInformation, "字数统计"
End Sub
运行后的结果如下图所示。
  图：字数统计信息
[004]自动隐藏公式栏
在Excel工作表的单元格中输入文字时，如果单个单元格中的字符数超过50个，则其公式编辑栏会展开并遮盖住部分单元格，这对于查看工作表或编辑工作表都很不方便。下面的代码将会通过隐藏公式编辑栏来解决这个问题。(参考自《巧学巧用Excel 2003 VBA与宏(中文版)》，我觉得本示例很有用)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
On Error Resume Next
If Len(Target.Text) > 50 Or Len(Target.Formula) > 50 Then
Application.DisplayFormulaBar = False
Else
Application.DisplayFormulaBar = True
End If
End Sub
在工作表模块中输入上述代码后，如果该工作表上的单元格中所输入的字符数超过50，则自动隐藏公式编辑栏，如果单元格中的字符数少于50，则显示公式编辑栏。
[005] 从已关闭的工作簿中复制单元格区域
下面分别介绍了从本计算机文件夹、网络计算机文件夹和Internet中已关闭的工作簿取值的技术。这三种情况均使用了同一个VBA过程GetRange。(来源于Ron de Bruin)
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
GetRange过程：
Sub GetRange(FilePath As String, FileName As String, SheetName As String, _
SourceRange As String, DestRange As Range)
Dim Start
'定位到目标单元格区域
Application.Goto DestRange
'调整目标区域的大小与源区域SourceRange大小相同
Set DestRange = DestRange.Resize(Range(SourceRange).Rows.Count, _
Range(SourceRange).Columns.Count)
'添加对已关闭文件的链接
With DestRange
.FormulaArray = "='" & FilePath & "/[" & FileName & "]" & SheetName _
& "'!" & SourceRange
'等待
Start = Timer
Do While Timer < Start + 2
DoEvents
Loop
'取值
.Copy
.PasteSpecial xlPasteValues
.Cells(1).Select
Application.CutCopyMode = False
End With
End Sub
说明：本过程有5个参数，分别为(1)文件路径；(2)文件名；(3)源工作表名；(4)源单元格区域；(5)目标工作表/区域。
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
第1种情况：从本地文件夹的工作簿中取值
Sub File_In_Local_Folder()
Application.ScreenUpdating = False
On Error Resume Next
'调用GetRange
GetRange "C:\Data", "test1.xls", "Sheet1", "A1:B100", _
Sheets("Sheet1").Range("A1")
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
第2种情况：从网络计算机文件夹的工作簿中取值
Sub File_In_Network_Folder()
Application.ScreenUpdating = False
On Error Resume Next
'调用GetRange
GetRange "\\Jdb\shareddocs", "test2.xls", "Sheet1", "A1:B100", _
Sheets("Sheet1").Range("A1")
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
第3种情况：从Internet网络文件工作簿中取值
Sub File_On_Website()
Application.ScreenUpdating = False
On Error Resume Next
'调用GetRange
GetRange "files", "test3.xls", "Sheet1", "A1:B100", _
Sheets("Sheet1").Range("A1")
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
[006] 从已关闭的工作簿中获取该工作簿中的工作表名称
可以使用ADO查询工作簿来获取该工作簿所包含的工作表。ADO将工作簿作为一个数据库，每个工作表作为一个表。下面的示例代码使用了一些技巧，从一个关闭的工作簿中返回该工作簿内所有工作表名称。适用于Excel 2000及以后的版本。(来源于appspro.com)
Public Sub DemoGetSheetNames()
Dim lNumEntries As Long
Dim szFullName As String
Dim aszSheetList() As String
Sheet1.UsedRange.Clear
szFullName = CStr(Application.GetOpenFilename("Excel Files (*.xls),*.xls", , "选择一个Excel文件"))
'如果用户没有单击删除按钮则继续
If szFullName <> CStr(False) Then
GetSheetNames szFullName, aszSheetList()
lNumEntries = UBound(aszSheetList) - LBound(aszSheetList) + 1
Sheet1.Range("A1").Resize(lNumEntries).Value = Application.WorksheetFunction.Transpose(aszSheetList())
Sheet1.Range("A1").EntireColumn.AutoFit
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' 返回指定工作簿内包含的工作表列表字符串数组
''' 注:需要添加下面对象库引用(较高版本也可以)：
'''    * Microsoft ActiveX Data Objects 2.5 Library
'''    * Microsoft ADO Ext. 2.5 for DDL and Security
'''
''' 参数:  szFullName      想要查询工作表列表的工作簿的完整路径和全名
'''        aszSheetList()   存放通过szFullName指定的工作簿中工作表名列表
'''
Private Sub GetSheetNames(ByRef szFullName As String, ByRef aszSheetList() As String)
Dim bIsWorksheet As Boolean
Dim objConnection As ADODB.Connection
Dim objCatalog As ADOX.Catalog
Dim objTable As ADOX.Table
Dim lIndex As Long
Dim szConnect As String
Dim szSheetName As String
Erase aszSheetList()
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & szFullName & ";Extended Properties=Excel 8.0;"
Set objConnection = New ADODB.Connection
objConnection.Open szConnect
Set objCatalog = New ADOX.Catalog
Set objCatalog.ActiveConnection = objConnection
For Each objTable In objCatalog.Tables
bIsWorksheet = False
szSheetName = objTable.Name
If Right$(szSheetName, 1) = "$" Then
''' 工作表名，移除后面的"$"
szSheetName = Left$(szSheetName, Len(szSheetName) - 1)
bIsWorksheet = True
ElseIf Right$(szSheetName, 2) = "$'" Then
''' 工作表名，带有空格或特定字符，移除右侧的字符"&'"
szSheetName = Left$(szSheetName, Len(szSheetName) - 2)
''' 移除单引号
szSheetName = Right$(szSheetName, Len(szSheetName) - 1)
''' 在工作表名中嵌入的单引号将成为两个单引号
''' 用一个单引号代替任何双重单引号
szSheetName = Replace$(szSheetName, "''", "'")
bIsWorksheet = True
End If
If bIsWorksheet Then
''' 将工作表名放入数组
ReDim Preserve aszSheetList(0 To lIndex)
aszSheetList(lIndex) = szSheetName
lIndex = lIndex + 1
End If
Next objTable
objConnection.Close
Set objCatalog = Nothing
Set objConnection = Nothing
End Sub
提示：在运行上面的程序前，需要添加下面对象库引用(较高版本也可以)：
* Microsoft ActiveX Data Objects 2.5 Library
* Microsoft ADO Ext. 2.5 for DDL and Security
方法是在VBE编辑器中，单击菜单“工具>>引用”，在出现的“引用”对话框中将相应对象库前的复选框选中。
单击此处下载示例
= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
[007] 在VBA中使用DOS命令
下面的代码将存放在F盘“我的文件”文件夹中的文件复制到C盘“我的XLS文件备份”文件夹中。
Sub test()
Dim retval
retval = Shell("XCOPY F:\我的文件\*.* C:\我的XLS文件备份/E", 0)
End Sub
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
加上更多的DOS参数，如/D 2007-2-5，即复制指定日期的文件。
Sub test()
Dim str As String
str = "XCOPY C:\SourceFolder\*.* C:\BACKUPS\*.* /E /D:" & Format(Date - 7, "mm-dd-yyyy")
Shell str
End Sub
上面的代码将源文件夹中7天前的文件复制到备份文件夹中。
(来源于vbaexpress.com)
有关Shell函数更详细的介绍请见EH论坛上agstick的贴子(细说shell函数——不得不看！)
分类:ExcelVBA>>技术技巧
By fanjy in 2007-2-9