[討論]分享圖面簡體轉繁體VBA程式
+8
phillipting66
櫻子
lcskc
lc0309
li60830
jason0401
et1029et
vincera
12 posters
AutoCAD顧問 :: 技術(發言等級:一般會員) :: :: 進階討論
第1頁(共1頁)
[討論]分享圖面簡體轉繁體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 編輯器
https://drive.google.com/file/d/0B41hPtWnOM8QOWNvY1VsWHZ1SVk/view?usp=sharing&resourcekey=0-SugCLuyifg70IT9uNy-A5g
備用: https://app.box.com/s/prs0iyvx5pan2080vw7xcgjaa0kc9368
因為最近一直在處理對岸來的圖面,雖然用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
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>
[公告]關於團隊成員的回文及貢獻
vincera 在 2016-02-03, 11:27 作了第 2 次修改
vincera- 初級會員
- 文章總數 : 15
年齡 : 34
來自 : kashsiung
職業 : me. eng.
愛好 : none
個性 : normal
使用年資 : 11
使用版本 : 2008
積分 : 2
經驗值 : 3483
威望值 : 93
注冊日期 : 2015-10-15
回復: [討論]分享圖面簡體轉繁體VBA程式
感謝大大的分享~
有機會再來試試!
有機會再來試試!
et1029et- 初級會員
- 文章總數 : 356
年齡 : 43
來自 : 桃園
職業 : 行政繪圖
愛好 : 學習
個性 : 隨和
使用年資 : 新手初學
使用版本 : 2013
積分 : 4
經驗值 : 5865
威望值 : 324
注冊日期 : 2013-07-02
回復: [討論]分享圖面簡體轉繁體VBA程式
真是很實用的程式,感恩分享!
jason0401- 初級會員
- 文章總數 : 71
年齡 : 51
來自 : Taichung, Taiwan
職業 : 自由業
愛好 : CAD sketchup
個性 : 殿殿的
使用年資 : 3 Year
使用版本 : 2010
積分 : 2
經驗值 : 5506
威望值 : 117
注冊日期 : 2010-09-18
回復: [討論]分享圖面簡體轉繁體VBA程式
對不起~請問該怎麼使用它啊~
li60830- 初級會員
- 文章總數 : 345
年齡 : 53
來自 : 亞洲
職業 : 待業
愛好 : 電動~游泳~看書~看影集
個性 : 固執
使用年資 : 18年
使用版本 : 2008 - 2014
積分 : 5
經驗值 : 5956
威望值 : 340
注冊日期 : 2013-04-17
回復: [討論]分享圖面簡體轉繁體VBA程式
也請教該如何使用VB?
lc0309- 一般會員
- 文章總數 : 73
年齡 : 58
來自 : 台東
職業 : 設計師
愛好 : 電腦,音樂
個性 : 隨和
使用年資 : 10
使用版本 : 2014
經驗值 : 3923
威望值 : 66
注冊日期 : 2015-02-12
回復: [討論]分享圖面簡體轉繁體VBA程式
看不懂怎麼用,樓主求救一下
lcskc- 一般會員
- 文章總數 : 59
年齡 : 52
來自 : 高雄
職業 : 模具
愛好 : pc相關
個性 : 安靜
使用年資 : 10
使用版本 : R12
經驗值 : 4128
威望值 : 31
注冊日期 : 2014-05-02
回復: [討論]分享圖面簡體轉繁體VBA程式
appload後 顯示:附件無法卸載ACADProject.dvb................無法載入
無法載入 要先安裝(以2014為例)
AutoCAD_2014_VBA_Enabler_r2_English_Win_64bit_dlm.sfx__0.exe 就可以了
無法載入 要先安裝(以2014為例)
AutoCAD_2014_VBA_Enabler_r2_English_Win_64bit_dlm.sfx__0.exe 就可以了
lc0309 在 2016-02-03, 12:36 作了第 1 次修改
lc0309- 一般會員
- 文章總數 : 73
年齡 : 58
來自 : 台東
職業 : 設計師
愛好 : 電腦,音樂
個性 : 隨和
使用年資 : 10
使用版本 : 2014
經驗值 : 3923
威望值 : 66
注冊日期 : 2015-02-12
回復: [討論]分享圖面簡體轉繁體VBA程式
多謝分享!感恩
櫻子- 一般會員
- 文章總數 : 82
年齡 : 41
來自 : l彰化
職業 : 繪圖員
愛好 : 繪圖
個性 : 內向+外向
使用年資 : 愛安靜
使用版本 : 2004
經驗值 : 4183
威望值 : 54
注冊日期 : 2014-05-27
回復: [討論]分享圖面簡體轉繁體VBA程式
新年快樂蘋果爸
____________________________________________________________________________________
phillipting66
回復: [討論]分享圖面簡體轉繁體VBA程式
感謝分享 超實用的 不然有一堆看不懂的...
kannadukil- 一般會員
- 文章總數 : 10
年齡 : 33
來自 : 新莊
職業 : 待業
愛好 : 聽聽音樂 唱歌
個性 : 悶騷
使用年資 : 4個月
使用版本 : 2012
經驗值 : 4405
威望值 : 0
注冊日期 : 2012-11-02
回復: [討論]分享圖面簡體轉繁體VBA程式
太感謝了,有了這個程式真的可以省不少事情,感謝各位無私地分享。
wkckmjs- 一般會員
- 文章總數 : 23
年齡 : 40
來自 : 桃園
職業 : 工程
愛好 : 高爾夫
個性 : 直來直往
使用年資 : 2
使用版本 : 2016
經驗值 : 3859
威望值 : 0
注冊日期 : 2014-06-12
回復: [討論]分享圖面簡體轉繁體VBA程式
感謝分享這麼不錯的工具~
謝謝!
謝謝!
bdsas- 一般會員
- 文章總數 : 25
年齡 : 49
來自 : 台南市
職業 : 營建繪圖
愛好 : 爬山
個性 : 內向
使用年資 : 400000
使用版本 : 2014
經驗值 : 3736
威望值 : 0
注冊日期 : 2014-11-04
載入後會一直跳出錯誤,不知道要如何解決
載入後會一直跳出錯誤,不知道要如何解決
MOXCHO- 一般會員
- 文章總數 : 36
年齡 : 43
來自 : 台中
職業 : 工程師
愛好 : 程式語言、繪圖
個性 : 隨意
使用年資 : 斷斷續續地用了3~4年
使用版本 : 2007、2010(目前主要)
經驗值 : 4237
威望值 : 36
注冊日期 : 2013-09-27
AutoCAD顧問 :: 技術(發言等級:一般會員) :: :: 進階討論
第1頁(共1頁)
這個論壇的權限:
您 無法 在這個版面回復文章