[討論]有關萃取的問題?

最近上來逛逛,新學到了萃取的功能想看看能不能用在我們公司上,但是似乎不太能用,所以想問問看各位前輩有沒有人有辦更好的方法.
我先說明一下我的情況:
1.上圖是我們公司AUTOCAD的圖檔,裡面的表格我是用<繪圖> ----> <表格>插入的,但是這樣不能萃取,所以我就把他炸開,才能萃取到文字
2.中圖,完成圖檔之後我們還需要把每個圖檔的編號,尺寸,數量等一一打在最外面的表單上如下,以往我們都是一個一個打進去,想說不知道能不能有更快的方法能直接把圖檔裡的文字萃取到以下的表單裡.
3.但是用了最近學到的萃取所萃取到的文字都只會像圖三一樣,都在同一欄裡,請問各位前輩有沒有辦法萃取成跟我AUTOCAD裡的表格的模式一樣,編號,數量,尺寸都在不同欄,這樣我要剪下再貼上也比較方便~~
或者各位前輩有更好的想法或做法可以教教我嗎?~~

方便的話 ~ 可以提供你的資料檔跟excel檔供測試嗎 ?

原則上資料必定是至少要輸入一次的 ~ 接下來就是資料格式轉換的問題吧(dwg to excel , excel to dwg)

在AutoCAD中的表格可以直接匯出給EXCEL使用(選表格>右鍵>匯出)，你可以先試試!
不然請將檔案上傳給阿希測試~
****************************************
在討論區發表問題時，請在主題前請加入[問題]，顏色請指定為[藍色]，論壇管理顧問會將您的主題置頂，方便大家即時討論。

阿希 寫到:方便的話 ~ 可以提供你的資料檔跟excel檔供測試嗎 ?

原則上資料必定是至少要輸入一次的 ~ 接下來就是資料格式轉換的問題吧(dwg to excel , excel to dwg)

感謝大大的幫忙,測試檔在此

謝謝歐

以前有處理過相關CASE，我是在步驟四用Y軸排序，再搭配X座標排序，不過這樣還是跟圖看起來不一樣，到EXCEL還是要調整。

neptune3 寫到:以前有處理過相關CASE，我是在步驟四用Y軸排序，再搭配X座標排序，不過這樣還是跟圖看起來不一樣，到EXCEL還是要調整。

請問:步驟四是指什麼?

smallworm16 寫到:

neptune3 寫到:以前有處理過相關CASE，我是在步驟四用Y軸排序，再搭配X座標排序，不過這樣還是跟圖看起來不一樣，到EXCEL還是要調整。

請問:步驟四是指什麼?

執行萃取精靈的第四步驟，可以用物件的座標值來排序，用X座標 or Y座標來排出順序，再匯出到Excel調整。
上傳圖片如下
https://2img.net/r/ihimizer/img29/7044/fbj.jpg

請問你要轉換的那一個表格有固定的尺寸嘛?如果沒有請往下看，我都是反其道而行的....
1.我會先在excel先建立好第二個圖片的發工單表格的格式，而且這一個格子的尺寸大小於scale指令後可以拉到跟原本圖面上所預設的格式大小可以相容。
2.當此發工單格式複製該區域格式貼到圖面的時後，就可以把excel關掉不需要任合的存檔。
3.當此表格有異動的時後只需要再貼上的圖面連點兩下後會執行excel檔，原有的表格不會有任何的變動，且可以隨意修改後可以再度貼回圖面。
4.該方法我只試過黑白出圖，因為我的工作也是會有一些大量計算的計算表格需要貼到圖面上做表示，如果按照市面上教科書的方法，資料太大需要用到資料萃取即時更新的方法只會lag+lag+lag...........
5.雖然圖面上有黑白底，但是在黑白列印上是不影響的，如果有影響的話請在excel上做完調整再度貼上即可。

以上看看合不合用摟..........

以前有處理過相關CASE使用VBA解決
大致上的程式碼如下 雖不適用於你但稍微更改既可
1.先打開EXECL
2.表格把他炸開圈選文字部分
3.執行以下程式
Sub cadtxt2execl()
Dim sstext As AcadSelectionSet
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
On Error Resume Next
ThisDrawing.SelectionSets.Item("ss1").Delete
On Error GoTo 0
Set sstext = ThisDrawing.SelectionSets.Add("ss1")
FilterType(0) = 0
FilterData(0) = "text"
sstext.SelectOnScreen FilterType, FilterData

Dim ent As Object
Dim i As Integer, j As Integer, l As Integer
Dim y As Variant
Dim txt As String
Dim txtb(0 To 1000)
Dim yb(0 To 1000)
j = 0
For Each ent In sstext
txtb(j) = ent.textstring
yb(j) = ent.insertionPoint
j = j + 1
Next
j = sstext.Count - 1
For i = 0 To j - 1
For c = i + 1 To j
If yb(c)(1) > yb(i)(1) Then
txt = txtb(i): txtb(i) = txtb(c): txtb(c) = txt
y = yb(i): yb(i) = yb(c): yb(c) = y
End If
Next
Next
Dim ly(0 To 1000)
txthi = sstext.Item(0).Height
l = 0
yl = 0
For i = 0 To j - 1
ny = yb(i)(1)
MY = ny - txthi * 0.5
ly(i) = yl
For c = i + 1 To j
If yb(c)(1) <= ny And yb(c)(1) >= MY Then
l = l + 1
ly(c) = yl
End If
Next
i = i + l
l = 0
yl = yl + 1
Next
If i = j Then
ly(i) = yl
End If
For i = 0 To j - 1
For c = i + 1 To j
If yb(c)(0) < yb(i)(0) Then
txt = txtb(i): txtb(i) = txtb(c): txtb(c) = txt
y = yb(i): yb(i) = yb(c): yb(c) = y
y = ly(i): ly(i) = ly(c): ly(c) = y
End If
Next
Next
Dim x(0 To 1000)
txthi = sstext.Item(0).Height
l = 0
lx = 0
For i = 0 To j - 1
nx = yb(i)(0)
mx = nx + Len(txtb(i)) * txthi * 0.7
x(i) = lx
For c = i + 1 To j
If yb(c)(0) >= nx And yb(c)(0) <= mx Then
l = l + 1
x(c) = lx
End If
Next
i = i + l
l = 0
lx = lx + 1
Next

Dim sheet As Object
Dim excel As Object
Dim excelSheet As Object
On Error Resume Next
Set excel = GetObject(, "Excel.Application")
If Err Then
Err.Clear
Set excel = CreateObject("Excel.Application")
If Err Then
Err.Clear
Exit Sub
End If
End If
excel.Visible = True
acsh = excel.ActiveSheet.Name
Set excelSheet = excel.ActiveWorkbook.Sheets(acsh)
On Error GoTo 0
a = excel.activecell.Column
b = excel.activecell.row

For i = 0 To j
excelSheet.cells(b + ly(i), a + x(i)).Value = "'" & txtb(i)
Next
b = b + yl + 1
excel.Worksheets(acsh).cells(b, a).Activate
End Sub

adslwang 寫到:請問你要轉換的那一個表格有固定的尺寸嘛?如果沒有請往下看，我都是反其道而行的....
1.我會先在excel先建立好第二個圖片的發工單表格的格式，而且這一個格子的尺寸大小於scale指令後可以拉到跟原本圖面上所預設的格式大小可以相容。
2.當此發工單格式複製該區域格式貼到圖面的時後，就可以把excel關掉不需要任合的存檔。
3.當此表格有異動的時後只需要再貼上的圖面連點兩下後會執行excel檔，原有的表格不會有任何的變動，且可以隨意修改後可以再度貼回圖面。
4.該方法我只試過黑白出圖，因為我的工作也是會有一些大量計算的計算表格需要貼到圖面上做表示，如果按照市面上教科書的方法，資料太大需要用到資料萃取即時更新的方法只會lag+lag+lag...........
5.雖然圖面上有黑白底，但是在黑白列印上是不影響的，如果有影響的話請在excel上做完調整再度貼上即可。

以上看看合不合用摟..........

感謝大大的大力幫忙,因為最近比較忙到現在才上來看,有空我會在試試的,如有不懂得地方在請教大大

小青蛙 寫到:以前有處理過相關CASE使用VBA解決
大致上的程式碼如下 雖不適用於你但稍微更改既可
1.先打開EXECL
2.表格把他炸開圈選文字部分
3.執行以下程式
Sub cadtxt2execl()
Dim sstext As AcadSelectionSet
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
On Error Resume Next
ThisDrawing.SelectionSets.Item("ss1").Delete
On Error GoTo 0
Set sstext = ThisDrawing.SelectionSets.Add("ss1")
FilterType(0) = 0
FilterData(0) = "text"
sstext.SelectOnScreen FilterType, FilterData

Dim ent As Object
Dim i As Integer, j As Integer, l As Integer
Dim y As Variant
Dim txt As String
Dim txtb(0 To 1000)
Dim yb(0 To 1000)
j = 0
For Each ent In sstext
txtb(j) = ent.textstring
yb(j) = ent.insertionPoint
j = j + 1
Next
j = sstext.Count - 1
For i = 0 To j - 1
For c = i + 1 To j
If yb(c)(1) > yb(i)(1) Then
txt = txtb(i): txtb(i) = txtb(c): txtb(c) = txt
y = yb(i): yb(i) = yb(c): yb(c) = y
End If
Next
Next
Dim ly(0 To 1000)
txthi = sstext.Item(0).Height
l = 0
yl = 0
For i = 0 To j - 1
ny = yb(i)(1)
MY = ny - txthi * 0.5
ly(i) = yl
For c = i + 1 To j
If yb(c)(1) <= ny And yb(c)(1) >= MY Then
l = l + 1
ly(c) = yl
End If
Next
i = i + l
l = 0
yl = yl + 1
Next
If i = j Then
ly(i) = yl
End If
For i = 0 To j - 1
For c = i + 1 To j
If yb(c)(0) < yb(i)(0) Then
txt = txtb(i): txtb(i) = txtb(c): txtb(c) = txt
y = yb(i): yb(i) = yb(c): yb(c) = y
y = ly(i): ly(i) = ly(c): ly(c) = y
End If
Next
Next
Dim x(0 To 1000)
txthi = sstext.Item(0).Height
l = 0
lx = 0
For i = 0 To j - 1
nx = yb(i)(0)
mx = nx + Len(txtb(i)) * txthi * 0.7
x(i) = lx
For c = i + 1 To j
If yb(c)(0) >= nx And yb(c)(0) <= mx Then
l = l + 1
x(c) = lx
End If
Next
i = i + l
l = 0
lx = lx + 1
Next

Dim sheet As Object
Dim excel As Object
Dim excelSheet As Object
On Error Resume Next
Set excel = GetObject(, "Excel.Application")
If Err Then
Err.Clear
Set excel = CreateObject("Excel.Application")
If Err Then
Err.Clear
Exit Sub
End If
End If
excel.Visible = True
acsh = excel.ActiveSheet.Name
Set excelSheet = excel.ActiveWorkbook.Sheets(acsh)
On Error GoTo 0
a = excel.activecell.Column
b = excel.activecell.row

For i = 0 To j
excelSheet.cells(b + ly(i), a + x(i)).Value = "'" & txtb(i)
Next
b = b + yl + 1
excel.Worksheets(acsh).cells(b, a).Activate
End Sub

我只能說這位大大你真的事太神了,但是請問一下要怎樣使用阿,希望能夠適合我用,因為我想如果不適合我應該也不會改吧!!

1.打開EXECL空白工作頁
2.打開ACAD先將視為表格部分 炸開 在炸開 回到文字狀態
3.工具->應用程式->打開vbA編輯器->檢視->程式碼(應會出現空白畫面)
4.複製上傳之程式->貼上
5.按 F5 功能鍵 (2至4步驟均在vbA編輯器中)
6.回到ACAD視窗 指令行出現 "選取物件: "
7.框選要轉到EXECL之文字 ENTER
8.看看EXECL有無資料

我是看ACAD說明檔自學,程式碼部分很陽春但可用
試試吧!! 不行就再問問周邊會VBA的朋友
% 也可不炸開 但程式須用AcadTable抓 %

---

---

謝謝熱心回覆~< 積分 +1>

[公告]關於團隊成員的回文及貢獻