VBA之一

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

  1 Sub StringToByteArray()
  2     Dim strText As String
  3     Dim aByte() As Byte
  4     Dim int1 As Integer
  5     strText = "Hello"
  6     aByte() = strText
  7     For inti = LBound(aByte) To UBound(aByte)
  8         Debug.Print aByte(inti)
  9     Next inti
 10     
 11     Debug.Print
 12     
 13     strText = aByte()
 14     Debug.Print strText
 15 End Sub
 16 
 17 
 18 Sub GetString()
 19     Dim intI As Integer
 20     Dim strOut As String
 21     For intI = 1 To 26
 22         strOut = strOut & String(intI, Asc("A") + intI - 1)
 23     Next intI
 24     Debug.Print strOut
 25 End Sub
 26 
 27 
 28 ‘去掉多余的字符
 29 ‘如strText = dhTranslate("(213)555-1212", "()-", "")
 30 ‘结果为2135551212
 31 Public Function dhTranslate(ByVal strIn As String, ByVal strMapIn As String, ByVal strMapOut As String, Optional fCaseSensitive As Boolean = True) As String
 32     Dim intI As Integer
 33     Dim intPos As Integer
 34     Dim strChar As String * 1
 35     Dim strOut As String
 36     Dim intMode As Integer
 37     
 38     If Len(strMapIn) > 0 Then
 39         If fCaseSensitive Then
 40             intMode = vbBinaryCompare
 41         Else
 42             intMode = vbTextCompare
 43         End If
 44         
 45         If Len(strMapOut) > 0 Then
 46             strMapOut = Left$(strMapOut & String(Len(strMapIn), Right$(strMapOut, 1)), Len(strMapIn))
 47         End If
 48         
 49         For intI = 1 To Len(strIn)
 50             strChar = Mid$(strIn, intI, 1)
 51             intPos = InStr(1, strMapIn, strChar, intMode)
 52             If intPos > 0 Then
 53                 strOut = strOut & Mid$(strMapOut, intPos, 1)
 54             Else
 55                 strOut = strOut & strChar
 56             End If
 57         Next intI
 58     End If
 59     dhTranslate = strOut
 60 End Function
 61 
 62 
 63 ‘删除空格
 64 ‘strOut = dhTrimAll("   This is    a test    of how   his works")返回
 65 ‘This is a test of how his works
 66 Function dhTrimAll(ByVal strText As String, Optional fRemoveTabs As Boolean = True) As String
 67     Dim strTemp As String
 68     Dim strOut As String
 69     Dim intI As Integer
 70     Dim strCh As String * 1
 71     If fRemoveTabs Then
 72         strText = dhTranslate(strText, vbTab, " ")
 73     End If
 74     strTemp = Trim(strText)
 75     For intI = 1 To Len(strTemp)
 76         strCh = Mid$(strTemp, intI, 1)
 77         If Not (strCh = " " And Right$(strOut, 1) = " ") Then
 78             strOut = strOut & strCh
 79         End If
 80     Next intI
 81     dhTrimAll = strOut
 82 End Function
 83 
 84 ‘求序数
 85 Function dhOrdinal(intItem As Integer)
 86     Dim intDigit As Integer
 87     Dim strOut As String * 2
 88     Select Case intItem Mod 100
 89         Case 11 To 19
 90             strOut = "th"
 91         Case Else
 92             iniDigit = intItem Mod 10
 93             Select Case iniDigit
 94                 Case 1
 95                     strOut = "st"
 96                 Case 2
 97                     strOut = "nd"
 98                 Case 3
 99                     strOut = "rd"
100                 Case Else
101                     strOut = "th"
102             End Select
103     End Select
104     dhOrdinal = intItem & strOut
105 End Function
106 
107 ‘为每个自然段加上索引
108 Sub insertIndex()
109     Dim i, j As Integer
110     i = ActiveDocument.Paragraphs.Count
111     For j = 1 To i
112         Set myRange = ActiveDocument.Paragraphs(j).Range
113         ActiveDocument.Indexes.MarkEntry Range:=myRange, entry:="介绍" & Left(myRange.Text, 5), Italic:=True
114     Next j
115 End Sub
116 
117 ‘有时忘了给图片加上编号或注解,下面代码可以给图片加题注
118 Sub picIndex()
119     Dim i As Integer
120     i = ActiveDocument.InlineShapes.Count
121     For j = 1 To i
122         ActiveDocument.InlineShapes(j).Select
123         Selection.Range.InsertAfter (Chr(13) & "图" & j)
124     Next j
125 End Sub
126 
127 
128 
129 ‘新建一个DOC文件，并在其上画红色心形图
130 Sub AddInlineCanvas()
131     Dim docNew As Document
132     Dim shpCanvas As Shape
133     Set docNew = Documents.Add
134     'Add a drawing canvas to the new document
135     Set shpCanvas = docNew.Shapes.AddCanvas( _
136     Left:=150, Top:=150, Width:=70, Height:=70)
137     shpCanvas.WrapFormat.Type = wdWrapInline
138     'Add shapes to drawing canvas
139     With shpCanvas.CanvasItems
140     .AddShape msoShapeHeart, Left:=10, _
141     Top:=10, Width:=50, Height:=60
142     .AddLine BeginX:=0, BeginY:=0, _
143     EndX:=70, EndY:=70
144     End With
145     With shpCanvas
146     .CanvasItems(1).Fill.ForeColor _
147     .RGB = RGB(Red:=255, Green:=0, Blue:=0)
148     .CanvasItems(2).Line _
149     .EndArrowheadStyle = msoArrowheadTriangle
150     End With
151 End Sub
152 
153 
154 Sub 工作薄间工作表合并()
155     
156     Dim FileOpen
157     Dim X As Integer
158     Application.ScreenUpdating = False
159     FileOpen = Application.GetOpenFilename(FileFilter:="Microsoft Excel文件(*.xls),*.xls", MultiSelect:=True, Title:="合并工作薄")
160     X = 1
161     While X <= UBound(FileOpen)
162     Workbooks.Open Filename:=FileOpen(X)
163     Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
164     X = X + 1
165     Wend
166 ExitHandler:
167     Application.ScreenUpdating = True
168     Exit Sub
169         
170     
171 errhadler:
172         MsgBox Err.Description
173 End Sub
174 
175 函数作用:自动获取指定月的工作日
176 '################################################################
177 
178 Sub 自动填充工作日(month1 As Integer)
179     '获取指定月份天数
180     Dim days As Integer
181     Dim xdate As Date
182     xdate = CDate("2008-" + CStr(month1))
183     '初始化公共变量Col2的值
184     col2 = 4
185     '调用自定义Mday()函数获取指定月份的天数
186     days = MDay(xdate)
187     '循环获取指定月份的工作日
188     For i = 1 To days
189         '声明变量保存指定日期
190         Dim Curdate As String
191         Curdate = "2008-" + CStr(month1) + "-" + _
192                   CStr(i)
193         '判断指定日期是否为工作日
194         If Weekday(CDate(Curdate)) <> vbSaturday _
195                    And Weekday(CDate(Curdate)) <> vbSunday Then
196             Cells(2, col2) = i
197             col2 = col2 + 1
198         End If
199     Next i
200 End Sub
201 
202 '获取指定月份的天数
203 
204 Public Function MDay(Optional xdate _
205                      As Variant = 0) As Integer
206     If IsDate(xdate) Then
207         MDay = Day(DateSerial(Year(xdate), _
208                Month(xdate) + 1, 0))
209     Else
210         MDay = 0
211     End If
212 End Function

转载于:https://www.cnblogs.com/djcsch2001/archive/2011/07/20/2112109.html