ADO新增記錄與Unicode字元處理

                  Sub 加入adodb引用項目()
With Application.VBE.ActiveVBProject
    For Each rf In .References
    '    Debug.Print rf.Name
        If rf.Name = "ADODB" Then GoTo 1
    Next
    .References.AddFromFile "C:\Program Files\Common Files\system\ado\msado15.dll"
End With
1
Call e
End Sub

Sub e()
Dim cnt As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim rsttable As New ADODB.Recordset
Dim cmd As New ADODB.Command
Dim BuShou As String
Dim d As New Document, U As String, uD As Document, uWordCount As Long
Dim WSShell As Object

Set uD = ActiveDocument
Set d = CreateObject("word.document")
'd.UserControl = False
d.Windows(1).Visible = False
cnt.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:\千慮一得齋\書籍資料\圖書管理附件\查字.mdb")
'rsttable.CursorType = adOpenKeyset
'rsttable.LockType = adLockOptimistic
'rsttable.ActiveConnection = cnt
rsttable.Open "漢字總表_的複本TEST", cnt, adOpenKeyset, adLockOptimistic   '竟然原資料表名"漢字總表 的複本TEST"中間的空格還不行,會變成抓到"漢字總表"原資料表!! 2014/8/19
cmd.ActiveConnection = cnt
cmd.CommandText = "檢查已有漢字"
cmd.CommandType = adCmdTable
rst.CursorType = adOpenKeyset
For Each char In uD.Characters
    If char.Font.Color = RGB(0, 0, 255) Then GoTo 1 '直接作下一個字
    If Asc(char) <> 13 And char <> "】" Then
        If char = "【" Then GoTo exx
        uWordCount = uWordCount + 1
        If uWordCount Mod 300 = 0 Then
            d.UndoClear
            uD.UndoClear
            uD.Save
        End If
        With d.Windows(1).Selection
            .TypeText char    '取得 Unicode 字元 的 十六進位值
            .ToggleCharacterCode
            U = Mid(d.Range, 1, Len(d.Range) - 1)
            d.Range = ""
        End With
'        cmd.Parameters("q").Value = char '查詢所根據的資料表若更名 Access名稱自動校正無法生效,必須重開才行
'        rst.Open cmd
        rst.Open "SELECT 漢字總表_的複本TEST.ID,漢字總表_的複本TEST.漢字,漢字總表_的複本TEST.[Alt+X], 漢字總表_的複本TEST.字元集 FROM 漢字總表_的複本TEST WHERE (((StrComp([漢字],""" & char & """))=0));", cnt, , adLockPessimistic
        If rst.RecordCount = 0 Then
            With rsttable
                .AddNew
                .Fields("漢字").Value = char
                If Len(char) > 1 Then
                    If Len(char) > 2 Then Stop
                    .Fields("Ascw1").Value = AscW(Mid(char, 1, 1))
                    .Fields("Ascw2").Value = AscW(Mid(char, 2, 1))
                    .Fields("Alt+X").Value = U
                    .Fields("字元集").Value = "D"
                    .Fields("備註").Value = "黃老師<!!!!Unicode字表.doc>漏掉了"
                Else
                    rsttable.Fields("Ascw1").Value = AscW(char)
                    rsttable.Fields("Ascw2").Value = 0
                    .Fields("Alt+X").Value = U
                    .Fields("字元集").Value = "D"
                    .Fields("備註").Value = "黃老師<!!!!Unicode字表.doc>漏掉了"
                End If
                '.Fields("部首").Value = BuShou
                .Update
            End With
        Else
'            char.Select
'            Stop
            If rst.RecordCount > 1 Then Stop
            With rst '直播用查詢增補記錄好像資料庫會變得超肥大!!2014.8.26
                '.Index = "PrimaryKey"
                '.Seek
                If IsNull(.Fields("Alt+X").Value) Then
                    .Fields("Alt+X").Value = U  '十六進位值,Word VBA 有 ToggleCharacterCode 方法;Word插入符號裡叫字元代碼。  U+,hexadecimal value
                    .Update
                End If
                If IsNull(.Fields("字元集").Value) Then
                    .Fields("字元集").Value = "D" '擴充-B(ExtB)等等
                    .Update
                End If
            End With
        End If
        rst.Close
        char.Font.Color = RGB(0, 0, 255)
1   End If
Next
If rst.State = adStateOpen Then rst.Close
rsttable.Close
cnt.Close
Set cmd = Nothing
Set rst = Nothing
Set rsttable = Nothing
Set cnt = Nothing
d.Close wdDoNotSaveChanges
Set d = Nothing
Set uD = Nothing
Set WSShell = CreateObject("WScript.Shell")
WSShell.PopUp "完成", , , 64
'MsgBox "完成"
Exit Sub
exx:
char.Select
BuShou = char.Next
GoTo 1
End Sub



Sub z1_CJK_Unified_Ideographs_Extension_C() 'Modified on 21/06/2011'http://club.excelhome.net/thread-733771-1-1.html
  Dim t As Date
  Dim n As Single
  Dim WSShell As Object
  Dim btn As String
  Dim Title As String
  Title = "CJK Unified Ideographs Extension C " & ChrW$(&H5B57) & ChrW$(&H7B26) & ChrW$(&H96C6)
  Set WSShell = CreateObject("WScript.Shell")
  t = Now
  Selection.Font.NameFarEast = "Sun-ExtB"
  Selection.Font.NameAscii = "Sun-ExtB"
  Selection.Font.Size = 14
  For i = &H2A700 To &H2B734
    n = n + 1
    Selection.TypeText Text:=Hex(i)
    Selection.ToggleCharacterCode
  Next
  Selection.TypeText Text:=vbCrLf
  Selection.TypeText Text:=n
  btn = WSShell.PopUp(ChrW$(&H8FD0) & ChrW$(&H884C) & ChrW$(&H65F6) & ChrW$(&H95F4) & ChrW$(&HFF1A) & DateDiff("s", t, Now) & ChrW$(&H20) & ChrW$(&H79D2), 5, Title, 64)
End Sub

Sub z2_CJK_Unified_Ideographs_Extension_D() 'Modified on 21/06/2011
  Dim t As Date
  Dim n As Single
  Dim WSShell As Object
  Dim btn As String
  Dim Title As String
  Title = "CJK Unified Ideographs Extension D " & ChrW$(&H5B57) & ChrW$(&H7B26) & ChrW$(&H96C6)
  Set WSShell = CreateObject("WScript.Shell")
  t = Now
  Selection.Font.NameFarEast = "Sun-ExtB"
  Selection.Font.NameAscii = "Sun-ExtB"
  Selection.Font.Size = 14
  For i = &H2B740 To &H2B81D
    n = n + 1
    Selection.TypeText Text:=Hex(i)
    Selection.ToggleCharacterCode
  Next
  Selection.TypeText Text:=vbCrLf
  Selection.TypeText Text:=n
  btn = WSShell.PopUp(ChrW$(&H8FD0) & ChrW$(&H884C) & ChrW$(&H65F6) & ChrW$(&H95F4) & ChrW$(&HFF1A) & DateDiff("s", t, Now) & ChrW$(&H20) & ChrW$(&H79D2), 5, Title, 64)
End Sub

Sub z8_CJK_Unified_Ideographs_Extension_A()
  Dim n As Single
  Dim WSShell As Object
  Dim btn As String
  Dim Title As String
  t = Now
  Title = "CJK Unified Ideographs Extension A " & ChrW$(&H5B57) & ChrW$(&H7B26) & ChrW$(&H96C6)
  Set WSShell = CreateObject("WScript.Shell")
  Selection.Font.NameFarEast = "Sun-ExtA"
  Selection.Font.NameAscii = "Sun-ExtA"
  Selection.Font.Size = 12
  For i = &H3400 To &H4DB5
    n = n + 1
    Selection.TypeText Text:=Hex(i)
    Selection.ToggleCharacterCode
  Next
  Selection.TypeParagraph
  Selection.TypeText Text:=n
  btn = WSShell.PopUp(ChrW$(&H8FD0) & ChrW$(&H884C) & ChrW$(&H65F6) & ChrW$(&H95F4) & ChrW$(&HFF1A) & DateDiff("s", t, Now) & ChrW$(&H20) & ChrW$(&H79D2), 5, Title, 64)
End Sub

Sub z9_CJK_Unified_Ideographs_Extension_B()
  Dim t As Date
  Dim n As Single
  Dim WSShell As Object
  Dim btn As String
  Dim Title As String
  Title = "CJK Unified Ideographs Extension B " & ChrW$(&H5B57) & ChrW$(&H7B26) & ChrW$(&H96C6)
  Set WSShell = CreateObject("WScript.Shell")
  t = Now
  Selection.Font.NameFarEast = "Sun-ExtB"
  Selection.Font.NameAscii = "Sun-ExtB"
  Selection.Font.Size = 12
  Selection.Font.ColorIndex = wdAuto
  For i = &H20000 To &H2A6D6
    n = n + 1
    Selection.TypeText Text:=Hex(i)
    Selection.ToggleCharacterCode
  Next
  Selection.TypeParagraph
  Selection.TypeText Text:=n
  btn = WSShell.PopUp(ChrW$(&H8FD0) & ChrW$(&H884C) & ChrW$(&H65F6) & ChrW$(&H95F4) & ChrW$(&HFF1A) & DateDiff("s", t, Now) & ChrW$(&H20) & ChrW$(&H79D2), 5, Title, 64)
End Sub

Sub 加入adodb引用項目()
With Application.VBE.ActiveVBProject
    For Each rf In .References
    '    Debug.Print rf.Name
        If rf.Name = "ADODB" Then GoTo 1
    Next
    .References.AddFromFile "C:\Program Files\Common Files\system\ado\msado15.dll"
End With
1
Call e
End Sub

Sub e()
Dim cnt As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim rsttable As New ADODB.Recordset
Dim cmd As New ADODB.Command
Dim BuShou As String
Dim d As New Document, U As String, uD As Document, uWordCount As Long
Dim WSShell As Object

Set uD = ActiveDocument
Set d = CreateObject("word.document")
'd.UserControl = False
d.Windows(1).Visible = False
cnt.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:\千慮一得齋\書籍資料\圖書管理附件\查字.mdb")
'rsttable.CursorType = adOpenKeyset
'rsttable.LockType = adLockOptimistic
'rsttable.ActiveConnection = cnt
rsttable.Open "漢字總表_的複本TEST", cnt, adOpenKeyset, adLockOptimistic   '竟然原資料表名"漢字總表 的複本TEST"中間的空格還不行,會變成抓到"漢字總表"原資料表!! 2014/8/19
cmd.ActiveConnection = cnt
cmd.CommandText = "檢查已有漢字"
cmd.CommandType = adCmdTable
rst.CursorType = adOpenKeyset
For Each char In uD.Characters
    If char.Font.Color = RGB(0, 0, 255) Then GoTo 1 '直接作下一個字
    If Asc(char) <> 13 And char <> "】" Then
        If char = "【" Then GoTo exx
        uWordCount = uWordCount + 1
        If uWordCount Mod 300 = 0 Then
            d.UndoClear
            uD.UndoClear
            uD.Save
        End If
        With d.Windows(1).Selection
            .TypeText char    '取得 Unicode 字元 的 十六進位值
            .ToggleCharacterCode
            U = Mid(d.Range, 1, Len(d.Range) - 1)
            d.Range = ""
        End With
'        cmd.Parameters("q").Value = char '查詢所根據的資料表若更名 Access名稱自動校正無法生效,必須重開才行
'        rst.Open cmd
        rst.Open "SELECT 漢字總表_的複本TEST.ID,漢字總表_的複本TEST.漢字,漢字總表_的複本TEST.[Alt+X], 漢字總表_的複本TEST.字元集 FROM 漢字總表_的複本TEST WHERE (((StrComp([漢字],""" & char & """))=0));", cnt, , adLockPessimistic
        If rst.RecordCount = 0 Then
            With rsttable
                .AddNew
                .Fields("漢字").Value = char
                If Len(char) > 1 Then
                    If Len(char) > 2 Then Stop
                    .Fields("Ascw1").Value = AscW(Mid(char, 1, 1))
                    .Fields("Ascw2").Value = AscW(Mid(char, 2, 1))
                    .Fields("Alt+X").Value = U
                    .Fields("字元集").Value = "D"
                    .Fields("備註").Value = "黃老師<!!!!Unicode字表.doc>漏掉了"
                Else
                    rsttable.Fields("Ascw1").Value = AscW(char)
                    rsttable.Fields("Ascw2").Value = 0
                    .Fields("Alt+X").Value = U
                    .Fields("字元集").Value = "D"
                    .Fields("備註").Value = "黃老師<!!!!Unicode字表.doc>漏掉了"
                End If
                '.Fields("部首").Value = BuShou
                .Update
            End With
        Else
'            char.Select
'            Stop
            If rst.RecordCount > 1 Then Stop
            With rst '直播用查詢增補記錄好像資料庫會變得超肥大!!2014.8.26
                '.Index = "PrimaryKey"
                '.Seek
                If IsNull(.Fields("Alt+X").Value) Then
                    .Fields("Alt+X").Value = U  '十六進位值,Word VBA 有 ToggleCharacterCode 方法;Word插入符號裡叫字元代碼。  U+,hexadecimal value
                    .Update
                End If
                If IsNull(.Fields("字元集").Value) Then
                    .Fields("字元集").Value = "D" '擴充-B(ExtB)等等
                    .Update
                End If
            End With
        End If
        rst.Close
        char.Font.Color = RGB(0, 0, 255)
1   End If
Next
If rst.State = adStateOpen Then rst.Close
rsttable.Close
cnt.Close
Set cmd = Nothing
Set rst = Nothing
Set rsttable = Nothing
Set cnt = Nothing
d.Close wdDoNotSaveChanges
Set d = Nothing
Set uD = Nothing
Set WSShell = CreateObject("WScript.Shell")
WSShell.PopUp "完成", , , 64
'MsgBox "完成"
Exit Sub
exx:
char.Select
BuShou = char.Next
GoTo 1
End Sub



Sub z1_CJK_Unified_Ideographs_Extension_C() 'Modified on 21/06/2011'http://club.excelhome.net/thread-733771-1-1.html
  Dim t As Date
  Dim n As Single
  Dim WSShell As Object
  Dim btn As String
  Dim Title As String
  Title = "CJK Unified Ideographs Extension C " & ChrW$(&H5B57) & ChrW$(&H7B26) & ChrW$(&H96C6)
  Set WSShell = CreateObject("WScript.Shell")
  t = Now
  Selection.Font.NameFarEast = "Sun-ExtB"
  Selection.Font.NameAscii = "Sun-ExtB"
  Selection.Font.Size = 14
  For i = &H2A700 To &H2B734
    n = n + 1
    Selection.TypeText Text:=Hex(i)
    Selection.ToggleCharacterCode
  Next
  Selection.TypeText Text:=vbCrLf
  Selection.TypeText Text:=n
  btn = WSShell.PopUp(ChrW$(&H8FD0) & ChrW$(&H884C) & ChrW$(&H65F6) & ChrW$(&H95F4) & ChrW$(&HFF1A) & DateDiff("s", t, Now) & ChrW$(&H20) & ChrW$(&H79D2), 5, Title, 64)
End Sub

Sub z2_CJK_Unified_Ideographs_Extension_D() 'Modified on 21/06/2011
  Dim t As Date
  Dim n As Single
  Dim WSShell As Object
  Dim btn As String
  Dim Title As String
  Title = "CJK Unified Ideographs Extension D " & ChrW$(&H5B57) & ChrW$(&H7B26) & ChrW$(&H96C6)
  Set WSShell = CreateObject("WScript.Shell")
  t = Now
  Selection.Font.NameFarEast = "Sun-ExtB"
  Selection.Font.NameAscii = "Sun-ExtB"
  Selection.Font.Size = 14
  For i = &H2B740 To &H2B81D
    n = n + 1
    Selection.TypeText Text:=Hex(i)
    Selection.ToggleCharacterCode
  Next
  Selection.TypeText Text:=vbCrLf
  Selection.TypeText Text:=n
  btn = WSShell.PopUp(ChrW$(&H8FD0) & ChrW$(&H884C) & ChrW$(&H65F6) & ChrW$(&H95F4) & ChrW$(&HFF1A) & DateDiff("s", t, Now) & ChrW$(&H20) & ChrW$(&H79D2), 5, Title, 64)
End Sub

Sub z8_CJK_Unified_Ideographs_Extension_A()
  Dim n As Single
  Dim WSShell As Object
  Dim btn As String
  Dim Title As String
  t = Now
  Title = "CJK Unified Ideographs Extension A " & ChrW$(&H5B57) & ChrW$(&H7B26) & ChrW$(&H96C6)
  Set WSShell = CreateObject("WScript.Shell")
  Selection.Font.NameFarEast = "Sun-ExtA"
  Selection.Font.NameAscii = "Sun-ExtA"
  Selection.Font.Size = 12
  For i = &H3400 To &H4DB5
    n = n + 1
    Selection.TypeText Text:=Hex(i)
    Selection.ToggleCharacterCode
  Next
  Selection.TypeParagraph
  Selection.TypeText Text:=n
  btn = WSShell.PopUp(ChrW$(&H8FD0) & ChrW$(&H884C) & ChrW$(&H65F6) & ChrW$(&H95F4) & ChrW$(&HFF1A) & DateDiff("s", t, Now) & ChrW$(&H20) & ChrW$(&H79D2), 5, Title, 64)
End Sub

Sub z9_CJK_Unified_Ideographs_Extension_B()
  Dim t As Date
  Dim n As Single
  Dim WSShell As Object
  Dim btn As String
  Dim Title As String
  Title = "CJK Unified Ideographs Extension B " & ChrW$(&H5B57) & ChrW$(&H7B26) & ChrW$(&H96C6)
  Set WSShell = CreateObject("WScript.Shell")
  t = Now
  Selection.Font.NameFarEast = "Sun-ExtB"
  Selection.Font.NameAscii = "Sun-ExtB"
  Selection.Font.Size = 12
  Selection.Font.ColorIndex = wdAuto
  For i = &H20000 To &H2A6D6
    n = n + 1
    Selection.TypeText Text:=Hex(i)
    Selection.ToggleCharacterCode
  Next
  Selection.TypeParagraph
  Selection.TypeText Text:=n
  btn = WSShell.PopUp(ChrW$(&H8FD0) & ChrW$(&H884C) & ChrW$(&H65F6) & ChrW$(&H95F4) & ChrW$(&HFF1A) & DateDiff("s", t, Now) & ChrW$(&H20) & ChrW$(&H79D2), 5, Title, 64)
End Sub

View Oscar's Profile