注意此版必須結合 EXCEL 的漢字筆畫資料庫("HzBhJsBiao.xls"),否則不能單獨執行。
功能簡介：一次性取得任意選定數量的簡體漢字（GB2312字符集 6763個）的筆畫數。

Sub GetBhshu() Dim xlObj As Excel.Application, Wk As Excel.Workbook, C As Excel.Range Dim i As Range, Chars As String On Error Resume Next Application.ScreenUpdating = False '檢測工作列中是否有EXCEL程式 If Tasks.Exists("Microsoft Excel") = True Then '引用原有EXCEL程式 Set xlObj = GetObject(, "Excel.Application") '建立EXCEL程式 Else Set xlObj = CreateObject("Excel.Application") End If '開啟同一路徑下的EXCEL筆畫資料庫 Set Wk = xlObj.Workbooks.Open(ThisDocument.Path & "/HzBhJsBiao.xls") Set C = Wk.Sheets(1).Range("A1:B6764") '在當前文件中的字符集中迴圈 For Each i In Selection.Characters Cr = xlObj.WorksheetFunction.VLookup(i, C, 2, False) '設定錯誤陷阱 '如果錯誤則原有字元不變 If Err.Number <> 0 Then Err.Clear Cr = i Else '反之則用字元和該字元的筆畫來取代,注意儲存在記憶體中 Cr = i & "(" & Cr & ")" End If Chars = Chars & Cr '累加器 Next Selection.Text = Chars '將原有文字替換為新帶筆畫數的文字 Wk.Close False '退出筆畫資料庫工作薄 Application.ScreenUpdating = True End Sub '---------------------- Private Sub Document_Open() On Error Resume Next '引用EXCEL.APPLICATION ActiveDocument.VBProject.References.AddFromFile "C:/Program Files/Microsoft Office/Office" & Mid(Application.Version, 1, 2) & "/Excel.exe" End Sub