2024年6月15日发(作者：)

Word VBA：小写数字转换为大写数字

声明：原创内容，转发请注明出处及作者，盗版必究

作者：柴大人

QQ：24823610

使用方法：

把代码制作成宏（具体方法请自查），然后拉选需要转换的数字后执行宏，转换后会自动把结果复制到剪贴板

上，直接在需要插入大写数字的地方粘贴即可。在OFFICE 2013 64位中测试正常。

转换效果：

123456789

壹亿贰仟叁佰肆拾伍万陆仟柒佰捌拾玖元整

123456789.12

壹亿贰仟叁佰肆拾伍万陆仟柒佰捌拾玖元壹角贰分

123456789.02

壹亿贰仟叁佰肆拾伍万陆仟柒佰捌拾玖元零贰分

123456789.1

壹亿贰仟叁佰肆拾伍万陆仟柒佰捌拾玖元壹角整

123000789

壹亿贰仟叁佰万零柒佰捌拾玖元整

源码：

Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As LongPtr

Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal Format As LongPtr, ByVal hMem As

LongPtr) As LongPtr

Declare PtrSafe Function CloseClipboard Lib "user32" () As LongPtr

Declare PtrSafe Function EmptyClipboard Lib "user32" () As LongPtr

Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal Flags As LongPtr, ByVal length As

LongPtr) As LongPtr

Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr

Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr

Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr

Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal pDest As LongPtr,

ByVal pSource As LongPtr, ByVal length As LongPtr)

Sub Transform()

Dim Capital, Unit, Number, Capacity, Integers, Decimals, R1, R2, PrintOut, TempA, LastZero

Dim hMem As LongPtr, lHwnd As LongPtr

Capital = "壹贰叁肆伍陆柒捌玖"

Unit = "元拾佰仟万拾佰仟亿"

Number = ()

Number = e(Number, Chr(10), "")

Number = e(Number, Chr(13), "")

LastZero = 0

If ric(Number) Then

Integers = Int(Number)

If Int(Number) <> (Number) Then

Decimals = Replace((Number, 2), Integers & ".", "")

Else

Decimals = ""

End If

For R1 = 0 To Len(Integers) - 1

TempA = Mid(Integers, Len(Integers) - R1, 1)

If TempA = 0 And LastZero = 0 Then

PrintOut = "零" & PrintOut

LastZero = 1

ElseIf TempA > 0 Then

PrintOut = Mid(Capital, CInt(TempA), 1) & Mid(Unit, R1 + 1, 1) & PrintOut

LastZero = 0

End If

Select Case R1

Case 4

If (PrintOut, "万") = 0 Then PrintOut = "万" & PrintOut

End Select

Next R1

If (PrintOut, "元") = 0 Then PrintOut = PrintOut & "元"

Select Case Len(Decimals)

Case 0

PrintOut = PrintOut & "整"

Case 1

PrintOut = PrintOut & Mid(Capital, CInt(Left(Decimals, 1)), 1) & "角整"

Case 2

If CInt(Left(Decimals, 1)) > 0 Then

PrintOut = PrintOut & Mid(Capital, CInt(Left(Decimals, 1)), 1) & "角"

Else

PrintOut = PrintOut & "零"

End If

PrintOut = PrintOut & Mid(Capital, CInt(Right(Decimals, 1)), 1) & "分"

End Select

hMem = GlobalAlloc(&H42, LenB(PrintOut) + 2)

lHwnd = GlobalLock(hMem)

CopyMemory lHwnd, StrPtr(PrintOut), LenB(PrintOut) + 2

GlobalUnlock (hMem)

OpenClipboard (0)

EmptyClipboard

SetClipboardData 13, hMem

CloseClipboard

End If

End Sub