VBA技术技巧收集(一)

VBA技术技巧收集(一)
分类:ExcelVBA>>技术技巧

---

[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，则显示公式编辑栏。