最近在学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
