AutoCAD顧問
還沒有註冊嗎...即日起免費註冊,所有最完整的AutoCAD討論、教學及資源都在論壇裡喔~
[討論]分享圖面簡體轉繁體VBA程式 Oo-2-110 [討論]分享圖面簡體轉繁體VBA程式 Ia15010 [討論]分享圖面簡體轉繁體VBA程式 Ziao1510 [討論]分享圖面簡體轉繁體VBA程式 BPl3tjj [討論]分享圖面簡體轉繁體VBA程式 Uos15010 [討論]分享圖面簡體轉繁體VBA程式 Uos15011

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

向下

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

發表 由 vincera 于 2016-01-29, 18:24

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

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

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

一、載入VBA套件
命令列輸入APPLOAD
點啟動套件的”內容”
[討論]分享圖面簡體轉繁體VBA程式 2j4txqs
點”加入”
[討論]分享圖面簡體轉繁體VBA程式 2v01t1u
選”ACADProject”後,點”加入”
[討論]分享圖面簡體轉繁體VBA程式 23hodue
點”關閉”
[討論]分享圖面簡體轉繁體VBA程式 Dm885u
之後每次啟動AUTOCAD都會自動載入
[討論]分享圖面簡體轉繁體VBA程式 33ots3b

二、做成按鈕
工具 -> 自訂 -> 介面
[討論]分享圖面簡體轉繁體VBA程式 Wrb7ra
點”建立新指令”
[討論]分享圖面簡體轉繁體VBA程式 34zhhzp
將名稱欄位改為”中文簡轉繁”
巨集欄位輸入”-vbarun Module1.MAIN_JTOF”
影像欄位選用附件裡的” PT-J2F.BMP”
[討論]分享圖面簡體轉繁體VBA程式 120o3mf
將新按鈕拖放到工具列上,按下”確定”即可
[討論]分享圖面簡體轉繁體VBA程式 6pwyns

三、測試
開啟附件裡的簡體字圖面”GEARPUMP.DWG” (圖面從網路找來的)
文字及表格是簡體字,如果只是要看的話,使用附件裡的GBCBIG.SHX就可以了
[討論]分享圖面簡體轉繁體VBA程式 2v93vut
表格裡的標籤、提示及內容也都是簡體字
[討論]分享圖面簡體轉繁體VBA程式 S12qae
圖層也有簡體字
[討論]分享圖面簡體轉繁體VBA程式 2dr5unr

點工具列上的按鈕
[討論]分享圖面簡體轉繁體VBA程式 Ojmq01
待提示簡轉繁完成了,檢查一下圖面剛剛提到的幾個部份是否有轉成功
[討論]分享圖面簡體轉繁體VBA程式 2s0zqqq

另外,如果要編輯程式碼
工具 -> 巨集 -> Visual Basic 編輯器
[討論]分享圖面簡體轉繁體VBA程式 V2tslk
[討論]分享圖面簡體轉繁體VBA程式 2iglwxu

代碼:

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://goo.gl/na4iGn
簡轉繁附件下載:
https://goo.gl/SPRAov


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


vincera 在 2016-02-03, 11:27 作了第 2 次修改
vincera
vincera
初級會員
初級會員

文章總數 : 15
年齡 : 29
來自 : kashsiung
職業 : me. eng.
愛好 : none
個性 : normal
使用年資 : 11
使用版本 : 2008
積分 : 2
經驗值 : 1521
威望值 : 96
注冊日期 : 2015-10-15
男 摩羯座 蛇

回頂端 向下

[討論]分享圖面簡體轉繁體VBA程式 Empty 回復: [討論]分享圖面簡體轉繁體VBA程式

發表 由 et1029et 于 2016-02-01, 09:50

感謝大大的分享~
有機會再來試試!
et1029et
et1029et
初級會員
初級會員

文章總數 : 356
年齡 : 38
來自 : 桃園
職業 : 行政繪圖
愛好 : 學習
個性 : 隨和
使用年資 : 新手初學
使用版本 : 2013
積分 : 4
經驗值 : 3900
威望值 : 324
注冊日期 : 2013-07-02
藍鵲666號
女 天蝎座 猴

回頂端 向下

[討論]分享圖面簡體轉繁體VBA程式 Empty 回復: [討論]分享圖面簡體轉繁體VBA程式

發表 由 jason0401 于 2016-02-01, 14:03

真是很實用的程式,感恩分享!
jason0401
jason0401
初級會員
初級會員

文章總數 : 66
年齡 : 46
來自 : Taichung, Taiwan
職業 : 自由業
愛好 : CAD sketchup
個性 : 殿殿的
使用年資 : 3 Year
使用版本 : 2010
積分 : 2
經驗值 : 3522
威望值 : 117
注冊日期 : 2010-09-18
經典問與答讀者 藍鵲10號
男 白羊座 牛

回頂端 向下

[討論]分享圖面簡體轉繁體VBA程式 Empty 回復: [討論]分享圖面簡體轉繁體VBA程式

發表 由 li60830 于 2016-02-01, 14:31

對不起~請問該怎麼使用它啊~
li60830
li60830
初級會員
初級會員

文章總數 : 328
年齡 : 47
來自 : 亞洲
職業 : 待業
愛好 : 電動~游泳~看書~看影集
個性 : 固執
使用年資 : 18年
使用版本 : 2008 - 2014
積分 : 3
經驗值 : 3920
威望值 : 322
注冊日期 : 2013-04-17
藍鵲697號
男 處女座 豬

回頂端 向下

[討論]分享圖面簡體轉繁體VBA程式 Empty 回復: [討論]分享圖面簡體轉繁體VBA程式

發表 由 lc0309 于 2016-02-01, 18:09

也請教該如何使用VB?
lc0309
lc0309
一般會員
一般會員

文章總數 : 65
年齡 : 53
來自 : 台東
職業 : 設計師
愛好 : 電腦,音樂
個性 : 隨和
使用年資 : 10
使用版本 : 2014
經驗值 : 1923
威望值 : 63
注冊日期 : 2015-02-12
藍鵲696號
男 雙魚座 馬

回頂端 向下

[討論]分享圖面簡體轉繁體VBA程式 Empty 回復: [討論]分享圖面簡體轉繁體VBA程式

發表 由 lcskc 于 2016-02-01, 20:12

看不懂怎麼用,樓主求救一下
lcskc
lcskc
一般會員
一般會員

文章總數 : 58
年齡 : 46
來自 : 高雄
職業 : 模具
愛好 : pc相關
個性 : 安靜
使用年資 : 10
使用版本 : R12
經驗值 : 2158
威望值 : 31
注冊日期 : 2014-05-02
男 處女座 鼠

回頂端 向下

[討論]分享圖面簡體轉繁體VBA程式 Empty 回復: [討論]分享圖面簡體轉繁體VBA程式

發表 由 lc0309 于 2016-02-03, 12:20

appload後  顯示:附件無法卸載ACADProject.dvb................無法載入 愛哭


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


lc0309 在 2016-02-03, 12:36 作了第 1 次修改
lc0309
lc0309
一般會員
一般會員

文章總數 : 65
年齡 : 53
來自 : 台東
職業 : 設計師
愛好 : 電腦,音樂
個性 : 隨和
使用年資 : 10
使用版本 : 2014
經驗值 : 1923
威望值 : 63
注冊日期 : 2015-02-12
藍鵲696號
男 雙魚座 馬

回頂端 向下

[討論]分享圖面簡體轉繁體VBA程式 Empty 回復: [討論]分享圖面簡體轉繁體VBA程式

發表 由 櫻子 于 2016-02-03, 12:26

多謝分享!感恩
櫻子
櫻子
一般會員
一般會員

文章總數 : 82
年齡 : 36
來自 : l彰化
職業 : 繪圖員
愛好 : 繪圖
個性 : 內向+外向
使用年資 : 愛安靜
使用版本 : 2004
經驗值 : 2218
威望值 : 54
注冊日期 : 2014-05-27
藍鵲660號
女 射手座 狗

回頂端 向下

[討論]分享圖面簡體轉繁體VBA程式 Empty 回復: [討論]分享圖面簡體轉繁體VBA程式

發表 由 phillipting66 于 2016-02-14, 16:48

新年快樂蘋果爸
phillipting66
phillipting66
初級會員
初級會員

文章總數 : 43
年齡 : 60
來自 : 新竹市
職業 : 工程-冷凍空調與電工
愛好 : 音樂,運動(騎腳踏車)
個性 : 0型
使用年資 : 3年
使用版本 : auto cad 2010 (學生板)
積分 : 1
經驗值 : 2864
威望值 : 65
注冊日期 : 2012-02-14
2D基礎函授 顧問外掛程式 經典問與答讀者 藍鵲327號
男 雙子座 狗

http://www.fcaebook.com/phillipting33

回頂端 向下

[討論]分享圖面簡體轉繁體VBA程式 Empty 回復: [討論]分享圖面簡體轉繁體VBA程式

發表 由 kannadukil 于 2016-02-14, 18:35

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

文章總數 : 10
年齡 : 28
來自 : 新莊
職業 : 待業
愛好 : 聽聽音樂 唱歌
個性 : 悶騷
使用年資 : 4個月
使用版本 : 2012
經驗值 : 2440
威望值 : 0
注冊日期 : 2012-11-02
女 金牛座 羊

回頂端 向下

[討論]分享圖面簡體轉繁體VBA程式 Empty 回復: [討論]分享圖面簡體轉繁體VBA程式

發表 由 wkckmjs 于 2016-02-14, 20:18

太感謝了,有了這個程式真的可以省不少事情,感謝各位無私地分享。
wkckmjs
wkckmjs
一般會員
一般會員

文章總數 : 20
年齡 : 35
來自 : 桃園
職業 : 工程
愛好 : 高爾夫
個性 : 直來直往
使用年資 : 2
使用版本 : 2016
經驗值 : 1881
威望值 : 0
注冊日期 : 2014-06-12
男 天蝎座 豬

回頂端 向下

[討論]分享圖面簡體轉繁體VBA程式 Empty 回復: [討論]分享圖面簡體轉繁體VBA程式

發表 由 bdsas 于 2016-02-15, 13:30

感謝分享這麼不錯的工具~
謝謝!
bdsas
bdsas
一般會員
一般會員

文章總數 : 22
年齡 : 43
來自 : 台南市
職業 : 營建繪圖
愛好 : 爬山
個性 : 內向
使用年資 : 400000
使用版本 : 2014
經驗值 : 1756
威望值 : 0
注冊日期 : 2014-11-04
男 雙子座 兔

回頂端 向下

[討論]分享圖面簡體轉繁體VBA程式 Empty 載入後會一直跳出錯誤,不知道要如何解決

發表 由 MOXCHO 于 2019-01-16, 10:04

載入後會一直跳出錯誤,不知道要如何解決 愛哭
MOXCHO
MOXCHO
一般會員
一般會員

文章總數 : 30
年齡 : 38
來自 : 台中
職業 : 工程師
愛好 : 程式語言、繪圖
個性 : 隨意
使用年資 : 斷斷續續地用了3~4年
使用版本 : 2007、2010(目前主要)
經驗值 : 2239
威望值 : 36
注冊日期 : 2013-09-27
男 金牛座 雞

回頂端 向下

回頂端


 
這個論壇的權限:
無法 在這個版面回復文章
[討論]分享圖面簡體轉繁體VBA程式 Uos15011 [討論]分享圖面簡體轉繁體VBA程式 Uos15010 [討論]分享圖面簡體轉繁體VBA程式 BPl3tjj [討論]分享圖面簡體轉繁體VBA程式 Ziao1510 [討論]分享圖面簡體轉繁體VBA程式 Ia15010 [討論]分享圖面簡體轉繁體VBA程式 Oo-2-110