Excel工作表繁簡轉換增益集-第三版

by chijanzen on 十二月 5th, 2009 | View: 1,971 views

Tags

No Tags

Comments (1)

索引	H0076
主題	Excel工作表繁簡轉換增益集-第三版
版本	>= 12.0(Office 2007)
說明	Excel工作表繁簡轉換增益集-第二版是調用 Word 中 TCSCConverter 方法來進行工作表中文字的繁簡轉換，而這次是使用LCMapString API函數來轉換字碼，比TCSCConverter 方法更有效率。
參考

Code

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Application.CommandBars("Standard").Controls("cmd_TCSC").Delete
Application.CommandBars("Standard").Controls("cmd_SCTC").Delete
End Sub
　

Private Sub Workbook_Open()
On Error Resume Next
Dim TCSCButton As CommandBarButton
Application.CommandBars("Standard").Controls("cmd_TCSC").Delete
Application.CommandBars("Standard").Controls("cmd_SCTC").Delete
Set Std_Bar = Application.CommandBars("Standard")
Set TCSC_Button = Std_Bar.Controls.Add(Type:=msoControlButton, Temporary:=True)
With TCSC_Button
    .Caption = "cmd_TCSC"
    .OnAction = "xls_TCSCConverter"
    ThisWorkbook.Sheets("Sheet2").Shapes("TCSC").Copy
    .PasteFace
    .Style = msoButtonIcon
    .TooltipText = "繁轉簡"
End With
Set TCSC_Button = Std_Bar.Controls.Add(Type:=msoControlButton, Temporary:=True)
With TCSC_Button
    .Caption = "cmd_SCTC"
    .OnAction = "xls_SCTCConverter"
    ThisWorkbook.Sheets("Sheet2").Shapes("SCTC").Copy
    .PasteFace
    .Style = msoButtonIcon
    .TooltipText = "簡轉繁"
End With
'清除上面的copy動作
Application.CutCopyMode = False
End Sub　

Code

Public Declare Function LCMapString Lib "kernel32.dll" Alias "LCMapStringA" _
        (ByVal Locale As Long, ByVal dwMapFlags As Long, ByVal lpSrcStr As String, _
        ByVal cchSrc As Long, ByVal lpDestStr As String, _
        ByVal cchDest As Long) As Long
Public Declare Function LCMapStringA Lib "kernel32.dll" (ByVal Locale As Long, _
        ByVal dwMapFlags As Long, ByRef lpSrcStr As Any, _
        ByVal cchSrc As Long, ByRef lpDestStr As Any, _
        ByVal cchDest As Long) As Long
Public Declare Function LCMapStringW Lib "kernel32.dll" (ByVal Locale As Long, _
        ByVal dwMapFlags As Long, ByVal lpSrcStr As Long, _
        ByVal cchSrc As Long, ByVal lpDestStr As Long, _
        ByVal cchDest As Long) As Long
'簡轉繁
Public Const LCMAP_SIMPLIFIED_CHINESE As Long = &H2000000
Public Const LCMAP_SORTKEY As Long = &H400
'繁轉簡
Public Const LCMAP_TRADITIONAL_CHINESE As Long = &H4000000
Public Const LCMAP_UPPERCASE As Long = &H200

'主語言ID
Public Const LANG_CHINESE As Long = &H4

'次語言ID
Public Const SUBLANG_CHINESE_TRADITIONAL As Long = &H1        '繁
Public Const SUBLANG_CHINESE_SIMPLIFIED As Long = &H2        '簡
Public Const SUBLANG_CHINESE_HONGKONG As Long = &H3        '港繁

'排序方式
Public Const SORT_CHINESE_PRCP As Long = &H0
Public Const SORT_CHINESE_BIG5 As Long = &H0
Public Const SORT_CHINESE_PRC As Long = &H2

'生成LCID
Public Const LCID_CHINESE_SIMPLIFIED As Long = ( _
        LANG_CHINESE Or SUBLANG_CHINESE_SIMPLIFIED * &H400) _
        And &HFFFF& Or SORT_CHINESE_PRCP * &H10000
Public Const LCID_CHINESE_TRADITIONAL As Long = ( _
        LANG_CHINESE Or SUBLANG_CHINESE_TRADITIONAL * &H400) _
        And &HFFFF& Or SORT_CHINESE_BIG5 * &H10000
　

Sub xls_TCSCConverter()
    Dim All_Rng As Range
    Dim crng As Range
    Dim strData As String
    TCSCForm.Show
    'TCSCForm.IsTCSC_Range
    If TCSCForm.IsTCSC_Range Then
        '判斷所選取的是否為儲存格
        If TypeName(Selection) = "Range" Then
            Set All_Rng = Selection
        Else
            '取得Sheet中有資料的Range 集合
            Set All_Rng = ActiveSheet.Cells.SpecialCells(xlCellTypeConstants, 2)
        End If
    End If
    If TCSCForm.IsTCSC_Sheet Then
        '取得Sheet中有資料的Range 集合
        If Not is_Sheet_Empty Then        '工作表是否為空
            Set All_Rng = ActiveSheet.Cells.SpecialCells(xlCellTypeConstants, 2)
            For Each shp In ActiveSheet.Shapes
                Select Case shp.Type
                Case msoTextBox, msoFormControl, msoAutoShape
                    shp.DrawingObject.Caption = BIG5ToGB(shp.DrawingObject.Caption)
                Case msoTextEffect
                    shp.TextEffect.Text = BIG5ToGB(shp.TextEffect.Text)
                End Select
            Next
        Else
            Exit Sub
        End If
    End If
    '關掉螢幕更新
    Application.ScreenUpdating = False
    For Each crng In All_Rng
        If Len(crng) > 0 Then
            '1 繁轉簡  0 簡轉繁
            crng = BIG5ToGB(crng.Text)
        End If
    Next crng
    Application.ScreenUpdating = True
    Unload TCSCForm
End Sub
　

Sub xls_SCTCConverter()
    Dim All_Rng As Range
    Dim crng As Range
    Dim strData As String
    Dim type_true As Boolean
    TCSCForm.Show
    '是否轉換選取儲存格範圍
    If TCSCForm.IsTCSC_Range Then
        '判斷所選取的是否為儲存格

        If TypeName(Selection) = "Range" Then
            Set All_Rng = Selection
        Else
            '取得Sheet中有資料的Range 集合
            Set All_Rng = ActiveSheet.Cells.SpecialCells(xlCellTypeConstants, 2)
        End If
    End If
    '是否轉換整張工作表
    If TCSCForm.IsTCSC_Sheet Then
        If Not is_Sheet_Empty Then        '工作表是否為空
            '取得Sheet中有資料的Range 集合
            Set All_Rng = ActiveSheet.Cells.SpecialCells(xlCellTypeConstants, 2)
            For Each shp In ActiveSheet.Shapes
                Select Case shp.Type
                Case msoTextBox, msoFormControl, msoAutoShape
                    shp.DrawingObject.Caption = GBToBIG5(shp.DrawingObject.Caption)
                Case msoTextEffect
                    shp.TextEffect.Text = GBToBIG5(shp.TextEffect.Text)
                End Select
            Next
        Else
            Exit Sub
        End If
    End If
    '關掉螢幕更新
    Application.ScreenUpdating = False
    For Each crng In All_Rng
        If Len(crng) > 0 Then
            '1 繁轉簡  0 簡轉繁
            crng = GBToBIG5(crng.Text)
        End If
    Next crng
    Application.ScreenUpdating = True
    Unload TCSCForm
End Sub
　

Public Function BIG5ToGB(Str As String) As String        '繁體轉簡體
    Dim szSrc As String
    Dim szDest As String
    szSrc = Str
    szDest = String$(Len(szSrc), 0)        '僅僅簡繁轉換長度不會變化
    Call LCMapStringW(LCID_CHINESE_SIMPLIFIED, LCMAP_SIMPLIFIED_CHINESE, _
            ByVal StrPtr(szSrc), Len(szSrc), ByVal StrPtr(szDest), Len(szDest))

BIG5ToGB = szDest
End Function
　

Public Function GBToBIG5(Str As String) As String        '簡體轉繁體
    Dim szSrc As String
    Dim szDest As String
    szSrc = Str
    szDest = String$(Len(szSrc), 0)        '僅僅簡繁轉換長度不會變化
    Call LCMapStringW(LCID_CHINESE_TRADITIONAL, LCMAP_TRADITIONAL_CHINESE, _
            ByVal StrPtr(szSrc), Len(szSrc), ByVal StrPtr(szDest), Len(szDest))
    GBToBIG5 = szDest
End Function
　

Public Function is_Sheet_Empty() As Boolean
is_Sheet_Empty = Application.CountA(ActiveSheet.Cells) = 0
End Function
　　

Code

Dim pIsTCSC_Range As Boolean
Dim pIsTCSC_Sheet As Boolean
　

Private Sub TDSC_Cmd_Click()

If Me.OptTCSC_Range Then
    pIsTCSC_Range = True
Else
    pIsTCSC_Range = fale
End If
If Me.OptTCSC_Sheet Then
    pIsTCSC_Sheet = True
Else
    pIsTCSC_Sheet = False
End If
Me.Hide
End Sub
　

Private Sub UserForm_Initialize()
'預設為整張工作表
Me.OptTCSC_Sheet = True
End Sub
　

Public Property Get IsTCSC_Range() As Boolean
IsTCSC_Range = pIsTCSC_Range
End Property
　

Public Property Get IsTCSC_Sheet() As Boolean
IsTCSC_Sheet = pIsTCSC_Sheet
End Property
　

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Cancel = True
End Sub
　　