VBA之一

最近在学VBA，因为在看《WORD排班艺术》一书中，上面所写到我们只用到OFFICE的10%的功能，还有90%没有使用，或者我们不知道如何使用，故决定深入研究一番VBA，通过这几天对VBA的初步了解，感觉这里面确实有很多学问，如果能活用VBA宏代码，的确能省事不少，而且就可以说精通OFFICE了吧，下面为一些简单的VBA代码

Sub StringToByteArray()
    Dim strText As String
    Dim aByte() As Byte
    Dim int1 As Integer
    strText = "Hello"
    aByte() = strText
    For inti = LBound(aByte) To UBound(aByte)
        Debug.Print aByte(inti)
    Next inti
    
    Debug.Print
    
    strText = aByte()
    Debug.Print strText
End Sub


Sub GetString()
    Dim intI As Integer
    Dim strOut As String
    For intI = 1 To 26
        strOut = strOut & String(intI, Asc("A") + intI - 1)
    Next intI
    Debug.Print strOut
End Sub


‘去掉多余的字符
‘如strText = dhTranslate("(213)555-1212", "()-", "")
‘结果为2135551212
Public Function dhTranslate(ByVal strIn As String, ByVal strMapIn As String, ByVal strMapOut As String, Optional fCaseSensitive As Boolean = True) As String
    Dim intI As Integer
    Dim intPos As Integer
    Dim strChar As String * 1
    Dim strOut As String
    Dim intMode As Integer
    
    If Len(strMapIn) > 0 Then
        If fCaseSensitive Then
            intMode = vbBinaryCompare
        Else
            intMode = vbTextCompare
        End If
        
        If Len(strMapOut) > 0 Then
            strMapOut = Left$(strMapOut & String(Len(strMapIn), Right$(strMapOut, 1)), Len(strMapIn))
        End If
        
        For intI = 1 To Len(strIn)
            strChar = Mid$(strIn, intI, 1)
            intPos = InStr(1, strMapIn, strChar, intMode)
            If intPos > 0 Then
                strOut = strOut & Mid$(strMapOut, intPos, 1)
            Else
                strOut = strOut & strChar
            End If
        Next intI
    End If
    dhTranslate = strOut
End Function


‘删除空格
‘strOut = dhTrimAll("   This is    a test    of how   his works")返回
‘This is a test of how his works
Function dhTrimAll(ByVal strText As String, Optional fRemoveTabs As Boolean = True) As String
    Dim strTemp As String
    Dim strOut As String
    Dim intI As Integer
    Dim strCh As String * 1
    If fRemoveTabs Then
        strText = dhTranslate(strText, vbTab, " ")
    End If
    strTemp = Trim(strText)
    For intI = 1 To Len(strTemp)
        strCh = Mid$(strTemp, intI, 1)
        If Not (strCh = " " And Right$(strOut, 1) = " ") Then
            strOut = strOut & strCh
        End If
    Next intI
    dhTrimAll = strOut
End Function

‘求序数
Function dhOrdinal(intItem As Integer)
    Dim intDigit As Integer
    Dim strOut As String * 2
    Select Case intItem Mod 100
        Case 11 To 19
            strOut = "th"
        Case Else
            iniDigit = intItem Mod 10
            Select Case iniDigit
                Case 1
                    strOut = "st"
                Case 2
                    strOut = "nd"
                Case 3
                    strOut = "rd"
                Case Else
                    strOut = "th"
            End Select
    End Select
    dhOrdinal = intItem & strOut
End Function

‘为每个自然段加上索引
Sub insertIndex()
    Dim i, j As Integer
    i = ActiveDocument.Paragraphs.Count
    For j = 1 To i
        Set myRange = ActiveDocument.Paragraphs(j).Range
        ActiveDocument.Indexes.MarkEntry Range:=myRange, entry:="介绍" & Left(myRange.Text, 5), Italic:=True
    Next j
End Sub

‘有时忘了给图片加上编号或注解,下面代码可以给图片加题注
Sub picIndex()
    Dim i As Integer
    i = ActiveDocument.InlineShapes.Count
    For j = 1 To i
        ActiveDocument.InlineShapes(j).Select
        Selection.Range.InsertAfter (Chr(13) & "图" & j)
    Next j
End Sub



‘新建一个DOC文件，并在其上画红色心形图
Sub AddInlineCanvas()
    Dim docNew As Document
    Dim shpCanvas As Shape
    Set docNew = Documents.Add
    'Add a drawing canvas to the new document
    Set shpCanvas = docNew.Shapes.AddCanvas( _
    Left:=150, Top:=150, Width:=70, Height:=70)
    shpCanvas.WrapFormat.Type = wdWrapInline
    'Add shapes to drawing canvas
    With shpCanvas.CanvasItems
    .AddShape msoShapeHeart, Left:=10, _
    Top:=10, Width:=50, Height:=60
    .AddLine BeginX:=0, BeginY:=0, _
    EndX:=70, EndY:=70
    End With
    With shpCanvas
    .CanvasItems(1).Fill.ForeColor _
    .RGB = RGB(Red:=255, Green:=0, Blue:=0)
    .CanvasItems(2).Line _
    .EndArrowheadStyle = msoArrowheadTriangle
    End With
End Sub


Sub 工作薄间工作表合并()
    
    Dim FileOpen
    Dim X As Integer
    Application.ScreenUpdating = False
    FileOpen = Application.GetOpenFilename(FileFilter:="Microsoft Excel文件(*.xls),*.xls", MultiSelect:=True, Title:="合并工作薄")
    X = 1
    While X <= UBound(FileOpen)
    Workbooks.Open Filename:=FileOpen(X)
    Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    X = X + 1
    Wend
ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub
        
    
errhadler:
        MsgBox Err.Description
End Sub

函数作用:自动获取指定月的工作日
'################################################################

Sub 自动填充工作日(month1 As Integer)
    '获取指定月份天数
    Dim days As Integer
    Dim xdate As Date
    xdate = CDate("2008-" + CStr(month1))
    '初始化公共变量Col2的值
    col2 = 4
    '调用自定义Mday()函数获取指定月份的天数
    days = MDay(xdate)
    '循环获取指定月份的工作日
    For i = 1 To days
        '声明变量保存指定日期
        Dim Curdate As String
        Curdate = "2008-" + CStr(month1) + "-" + _
                  CStr(i)
        '判断指定日期是否为工作日
        If Weekday(CDate(Curdate)) <> vbSaturday _
                   And Weekday(CDate(Curdate)) <> vbSunday Then
            Cells(2, col2) = i
            col2 = col2 + 1
        End If
    Next i
End Sub

'获取指定月份的天数

Public Function MDay(Optional xdate _
                     As Variant = 0) As Integer
    If IsDate(xdate) Then
        MDay = Day(DateSerial(Year(xdate), _
               Month(xdate) + 1, 0))
    Else
        MDay = 0
    End If
End Function