[討論]分享圖面簡體轉繁體VBA程式

大家好~~
因為最近一直在處理對岸來的圖面，雖然用GBCBIG可以看簡體字，可是要在台灣發包，還是得轉成繁體字
用了一些現成的工具都覺得不理想，網路上的VB有些是用.NET的指令，或用LCMapString這個指令，可是我怎麼試都試不出來，最後只好自己東拼西湊弄出這個簡轉繁的工具
基本上就是找圖面上的文字，包括一般單行及多行文字、圖塊裡的文字以及尺寸線裡的文字，將簡體字轉成UNICODE，對照出繁體字的UNICODE，再轉成繁體字的字串，一次處理整張圖
因為在找資料的過程中，發現似乎不少人都有相同的困擾，程式也部份借用前輩們的心血，所以就想藉這個討論區提供大家參考，希望對大家有幫助
VB的功力普普通通，第一次發表，請大家多多指教~~
(使用於AUTOCAD 2008 / WIN 7 32bit)

同事說圖層和表格的簡體字也要繁體化，所以程式有做了修改
至於VBA的使用方式如下

我將程式另外存成一個dvb檔，方便匯入AUTOCAD使用：
(以AUTOCAD 2008為例)
做兩個步驟才能使用VBA的巨集，一個是載入VBA的套件，就是附件裡的ACADProject.dvb，以及將功能做成按鈕以方便使用。

一、載入VBA套件
命令列輸入APPLOAD
點啟動套件的”內容”

點”加入”

選”ACADProject”後，點”加入”

點”關閉”

之後每次啟動AUTOCAD都會自動載入


二、做成按鈕
工具 -> 自訂 -> 介面

點”建立新指令”

將名稱欄位改為”中文簡轉繁”
巨集欄位輸入”-vbarun Module1.MAIN_JTOF”
影像欄位選用附件裡的” PT-J2F.BMP”

將新按鈕拖放到工具列上，按下”確定”即可


三、測試
開啟附件裡的簡體字圖面”GEARPUMP.DWG” (圖面從網路找來的)
文字及表格是簡體字，如果只是要看的話，使用附件裡的GBCBIG.SHX就可以了

表格裡的標籤、提示及內容也都是簡體字

圖層也有簡體字


點工具列上的按鈕

待提示簡轉繁完成了，檢查一下圖面剛剛提到的幾個部份是否有轉成功


另外，如果要編輯程式碼
工具 -> 巨集 -> Visual Basic 編輯器

代碼:


Sub MAIN_JTOF()
'圖面簡轉繁主程式

Dim mapfile As String
Dim tmpstr As String
Dim ssAll As AcadSelectionSet
Dim mEntity As AcadEntity
Dim Textstyleslist As String
Dim currTextStyle As AcadTextStyle
Dim newTextStyle As AcadTextStyle
Dim strLayerName As String
Dim allLayers As AcadLayers
Dim objLayer As AcadLayer
Dim AttList As Variant
Dim blockobj As AcadBlock
Dim AttributeObj As AcadAttribute
Dim blkText As String
Dim n As Integer
Dim i As Integer
Dim z As Integer

On Error Resume Next

Set ssAll = ThisDrawing.SelectionSets.Add("xAllEntities")
If Err.Number <> 0 Then
    Set ssAll = ThisDrawing.SelectionSets.item("xAllEntities")
    ssAll.Clear
End If

ssAll.Select acSelectionSetAll
mapfile = "c:\SimplifiedHanFolding.txt"

For Each mEntity In ssAll
    '文字物件
    If mEntity.ObjectName = "AcDbText" Or "AcDbMText" Then
        tmpstr = ""
        For n = 1 To Len(mEntity.TextString)
            tmpstr = tmpstr + JTOF(Mid(mEntity.TextString, n, 1), mapfile)
        Next n
        mEntity.TextString = tmpstr
    End If
    
    '圖塊物件
    If mEntity.ObjectName = "AcDbBlockReference" Then
    If mEntity.HasAttributes Then
        AttList = mEntity.GetAttributes
        For i = LBound(AttList) To UBound(AttList)
            '內容
            tmpstr = ""
            For n = 1 To Len(AttList(i).TextString)
                tmpstr = tmpstr + JTOF(Mid(AttList(i).TextString, n, 1), mapfile)
            Next n
            AttList(i).TextString = tmpstr
            Debug.Print AttList(i).promptstring
            '標籤
            tmpstr = ""
            For n = 1 To Len(AttList(i).TagString)
                tmpstr = tmpstr + JTOF(Mid(AttList(i).TagString, n, 1), mapfile)
            Next n
            AttList(i).TagString = tmpstr
        Next
    End If
    End If
    Set AttList = Nothing
    
    '尺寸線物件
    If mEntity.ObjectName = "AcDbRotatedDimension" Or mEntity.ObjectName = "AcDbAlignedDimension" _
    Or mEntity.ObjectName = "AcDbDiametricDimension" Or mEntity.ObjectName = "AcDb2LineAngularDimension" Then
        tmpstr = ""
        For n = 1 To Len(mEntity.TextOverride)
            tmpstr = tmpstr + JTOF(Mid(mEntity.TextOverride, n, 1), mapfile)
        Next n
        mEntity.TextOverride = tmpstr
    End If

    
Next

ssAll.Clear
ssAll.Delete
Set ssAll = Nothing

'圖塊內文字
For i = 0 To ThisDrawing.Blocks.Count - 1
    For z = 0 To ThisDrawing.Blocks.item(i).Count - 1
        blkText = ""
        blkText = ThisDrawing.Blocks.item(i).item(z).TextString
        
        tmpstr = ""
        For n = 1 To Len(blkText)
            tmpstr = tmpstr + JTOF(Mid(blkText, n, 1), mapfile)
        Next n
        
        ThisDrawing.Blocks.item(i).item(z).TextString = tmpstr
    Next z
Next i

'圖塊內提示
Dim ssBlocks As AcadBlocks
Dim oObj As Object
Dim oBlock As AcadBlock
Dim item As Object

Set ssBlocks = ThisDrawing.Blocks
For Each oObj In ssBlocks
    If TypeOf oObj Is AcadBlock Then
        Set oBlock = oObj
        For Each item In oBlock
            If item.EntityName = "AcDbAttributeDefinition" Then
                tmpstr = ""
                For n = 1 To Len(item.TagString)
                    tmpstr = tmpstr + JTOF(Mid(item.TagString, n, 1), mapfile)
                Next n
                item.promptstring = tmpstr
                tmpstr = ""
                For n = 1 To Len(item.TagString)
                    tmpstr = tmpstr + JTOF(Mid(item.TagString, n, 1), mapfile)
                Next n
                item.TagString = tmpstr
                tmpstr = ""
                For n = 1 To Len(item.TextString)
                    tmpstr = tmpstr + JTOF(Mid(item.TextString, n, 1), mapfile)
                Next n
                item.TextString = tmpstr
            End If
        Next item
    End If
Next

ssBlocks.Clear
ssBlocks.Delete
Set ssBlocks = Nothing

'圖層名稱簡轉繁
Set allLayers = ThisDrawing.Layers
For Each objLayer In allLayers
    tmpstr = ""
    For n = 1 To Len(objLayer.Name)
        tmpstr = tmpstr + JTOF(Mid(objLayer.Name, n, 1), mapfile)
    Next n
    objLayer.Name = tmpstr
Next

'字型變更
For n = 0 To ThisDrawing.TextStyles.Count - 1
    Textstyleslist = ThisDrawing.TextStyles.item(n).Name
    If Len(Textstyleslist) > 1 Then
        Set newTextStyle = ThisDrawing.TextStyles.Add(Textstyleslist)
        ThisDrawing.ActiveTextStyle = newTextStyle
        ThisDrawing.ActiveTextStyle.fontFile = "c:\simplex.shx"
        ThisDrawing.ActiveTextStyle.BigFontFile = "c:\chineset.shx"
    End If
Next

Set currTextStyle = ThisDrawing.ActiveTextStyle
If currTextStyle.Name <> "Standard" Then
    Set newTextStyle = ThisDrawing.TextStyles.Add("standard")
    ThisDrawing.ActiveTextStyle = newTextStyle  '"Standard"
End If

ThisDrawing.Regen acAllViewports
MsgBox "簡轉繁完成"

End Sub


Function JTOF(simpc As String, strFile As String) As String

On Error GoTo errors

Dim intFile As Integer
Dim strIn As String
Dim bnFound As Boolean
Dim strKeyWord As String

booFound = False
strOut = vbNullString
intFile = FreeFile()

'字串轉成unicode
strKeyWord = Hex(AscW(simpc))

If Len(strKeyWord) = 4 Then
    '使用Open方式開啟純文字檔(不支援UTF8) 開啟簡繁對照表
    Open strFile For Input As #intFile

    Do While Not EOF(intFile)
        Line Input #intFile, strIn '依照「行」來讀取資料

        j = InStr(strIn, strKeyWord) '使用InStr字串搜尋
        If j > 0 Then
            bnFound = True
            '兩個chrB合成一個unicode字元
            strhexhi = ChrB(HEX_to_DEC(Mid(strIn, 3, 2)))
            strhexlo = ChrB(HEX_to_DEC(Left(strIn, 2)))
            JTOF = strhexhi & strhexlo
            Exit Do
        End If
    Loop
      
    Close #intFile

End If

If bnFound = False Then
    '找不到的字以原字
    JTOF = simpc
End If

Exit Function

errors:
    MsgBox "錯誤發生"

End Function


Public Function HEX_to_DEC(ByVal Hex As String) As Long
'十六進位轉十進位

Dim i As Long
Dim B As Long

Hex = UCase(Hex)
For i = 1 To Len(Hex)
    Select Case Mid(Hex, Len(Hex) - i + 1, 1)
        Case "0": B = B + 16 ^ (i - 1) * 0
        Case "1": B = B + 16 ^ (i - 1) * 1
        Case "2": B = B + 16 ^ (i - 1) * 2
        Case "3": B = B + 16 ^ (i - 1) * 3
        Case "4": B = B + 16 ^ (i - 1) * 4
        Case "5": B = B + 16 ^ (i - 1) * 5
        Case "6": B = B + 16 ^ (i - 1) * 6
        Case "7": B = B + 16 ^ (i - 1) * 7
        Case "8": B = B + 16 ^ (i - 1) * 8
        Case "9": B = B + 16 ^ (i - 1) * 9
        Case "A": B = B + 16 ^ (i - 1) * 10
        Case "B": B = B + 16 ^ (i - 1) * 11
        Case "C": B = B + 16 ^ (i - 1) * 12
        Case "D": B = B + 16 ^ (i - 1) * 13
        Case "E": B = B + 16 ^ (i - 1) * 14
        Case "F": B = B + 16 ^ (i - 1) * 15
    End Select
Next i
HEX_to_DEC = B

End Function



簡繁UNICODE對照表下載：
https://drive.google.com/file/d/0B41hPtWnOM8QOWNvY1VsWHZ1SVk/view?usp=sharing&resourcekey=0-SugCLuyifg70IT9uNy-A5g

簡轉繁附件下載：

https://drive.google.com/file/d/0B41hPtWnOM8QbjBKNzRxcnJySDQ/view?usp=sharing&resourcekey=0-BUlJ4TTskSc7M1BCB_DIhQ
備用: https://app.box.com/s/prs0iyvx5pan2080vw7xcgjaa0kc9368

---

Tiger&蘋果爸 寫到: 謝謝熱心程式分享~< 積分 +1>
[公告]關於團隊成員的回文及貢獻

感謝大大的分享~
有機會再來試試！

真是很實用的程式，感恩分享！

對不起~請問該怎麼使用它啊~

也請教該如何使用VB?

看不懂怎麼用,樓主求救一下

appload後  顯示：附件無法卸載ACADProject.dvb................無法載入


無法載入 要先安裝（以2014為例）
AutoCAD_2014_VBA_Enabler_r2_English_Win_64bit_dlm.sfx__0.exe 就可以了

多謝分享!感恩

新年快樂蘋果爸

感謝分享 超實用的 不然有一堆看不懂的...

太感謝了，有了這個程式真的可以省不少事情，感謝各位無私地分享。

感謝分享這麼不錯的工具~
謝謝!

載入後會一直跳出錯誤，不知道要如何解決