樓主,我的意思是:

您可以用您平常喜歡,或已設計好表格的word檔,看您怎麼調整都OK。調整好,看是檔案給我,我來幫您把新程式巨集(另外找時間來做)加到您的檔案中。(檔案不方便給我也OK,我們線上來研究,給您程式碼,幫助讓您能夠自己把程式碼加到您自己的檔案。)

之前的[插入照片new]檔,就當作是練習,測試....之後可以不管它。

所以您現在要做的,就是:
1.試試看,您能不能順利完成[在word檔中,把巨集和快速鍵結合起來並順利執行。]
2.考慮是不是需要程式改成:插入自動判斷寬高(不需要的話,我們就不需要重改程式.....要的話我就要修改一下)
3.準備(設計)好您真正要操作,有表格(按您自己需要設計)的word檔。

然後我再根據您的考慮結果,繼續下一步......是否修改程式,幫助樓主怎麼把巨集程式(舊的或新的)加入一個無巨集的檔案.....囉。
Der,misser1
misser wrote:
其實是可以的喔(就如S大後來提供的,一次可選3~4張)


剛剛突然想到,施工前、中、後,時間排序一定是小=>大
所以可以用拍攝時間來排序,只要照片沒做假的話


趁著中午沒事,稍微改寫一下
有興趣可以玩看看(空白文件即可,不需先建立表格)



Sub test()

Dim Open_jpg As Object, Jpg_File As String, i As Integer, j As Integer, r As Integer, c As Integer, n As Integer
Set Open_jpg = Application.FileDialog(FileDialogType:=msoFileDialogOpen)

Dim Row_h As Integer, Col_w As Integer, Table_Style As String, Jpg_Sort(1 To 5, 1 To 2) As String, Inline_Shape As InlineShape, shp As Shape
Table_Style = InputBox("表格種類1 or 2", "choose", 1)
If Table_Style <> 1 And Table_Style <> 2 Or Table_Style = "" Then Exit Sub


With Open_jpg
.AllowMultiSelect = True
.Filters.Add "照片", "*.jpg", 1
If .Show = -1 And .SelectedItems.Count = 3 Or .SelectedItems.Count = 4 Then

'add table 1 or 2
If Table_Style = 1 Then
Row_h = 180
Col_w = 360
Call Add_table1(.SelectedItems.Count, Row_h, Col_w)
Else
Row_h = 220
Col_w = 300
Call Add_table2(.SelectedItems.Count, Row_h, Col_w)
End If


For i = 1 To .SelectedItems.Count
Jpg_Sort(i, 1) = .SelectedItems(i)
Jpg_Sort(i, 2) = Shooting_Date(Jpg_Sort(i, 1), .InitialFileName, 12)
Next i


'sort
'刪掉以下9行,可取消排序
For i = 1 To .SelectedItems.Count - 1
For j = i + 1 To .SelectedItems.Count
If Jpg_Sort(i, 2) > Jpg_Sort(j, 2) Then
Jpg_Sort(5, 1) = Jpg_Sort(i, 1): Jpg_Sort(5, 2) = Jpg_Sort(i, 2)
Jpg_Sort(i, 1) = Jpg_Sort(j, 1): Jpg_Sort(i, 2) = Jpg_Sort(j, 2)
Jpg_Sort(j, 1) = Jpg_Sort(5, 1): Jpg_Sort(j, 2) = Jpg_Sort(5, 2)
End If
Next j
Next i


'AddPicture
For r = 1 + IIf(Table_Style = 1, 1, 0) To 3 + IIf(Table_Style = 1, 1, 0)

Select Case Table_Style
Case Is = 1
If ActiveDocument.Tables(1).Rows(r).Cells.Count = 3 And r = 3 Then c = 3 Else c = 2
Case Is = 2
If ActiveDocument.Tables(1).Columns.Count = 4 And r = 2 Then c = 4 Else c = 3
End Select

For i = 2 + IIf(Table_Style = 2, 1, 0) To c
n = n + 1
Set Inline_Shape = ActiveDocument.Tables(1).Cell(r, i).Range.InlineShapes.AddPicture(FileName:=Jpg_Sort(n, 1), LinkToFile:=False, SaveWithDocument:=True)
Set shp = Inline_Shape.ConvertToShape
With shp
'.LockAspectRatio = msoFalse
'.Height = Row_h - 10
'.Width = IIf(c = 3 + IIf(Table_Style = 2, 1, 0), Col_w / 2 - 10, Col_w - 10)

'center test
.LockAnchor = True
.LockAspectRatio = msoTrue
.Height = IIf(.Height > Row_h, Row_h - 10, .Height)
.Width = IIf(c = 3 + IIf(Table_Style = 2, 1, 0), IIf(.Width > Col_w / 2, Col_w / 2 - 10, .Width), IIf(.Width > Col_w, Col_w - 10, .Width))
.Top = IIf(Row_h - .Height > 20, (Row_h - .Height) / 2, 5)
.Left = wdShapeCenter

End With
Next i

Next r
Else
MsgBox "3 or 4"
Set Open_jpg = Nothing
Exit Sub
End If
End With

Set Open_jpg = Nothing
Set Inline_Shape = Nothing
Set shp = Nothing


End Sub


Function Shooting_Date(JpgFile_name As String, JpgFile_path, n As Integer) 'n=12

Dim Shell_Obj, Jpg_Folder, Jpg_Item

Set Shell_Obj = CreateObject("Shell.Application")
Set Jpg_Folder = Shell_Obj.Namespace(JpgFile_path)
Set Jpg_Item = Jpg_Folder.ParseName(Replace(JpgFile_name, JpgFile_path, ""))

If Not Jpg_Item Is Nothing Then
Shooting_Date = Jpg_Folder.GetDetailsOf(Jpg_Item, n)
Debug.Print Shooting_Date
'刪除不可見unicode字元
Shooting_Date = Replace(Shooting_Date, ChrW(8206), "")
Shooting_Date = Replace(Shooting_Date, ChrW(8207), "")
End If

If Shooting_Date = "" Then Shooting_Date = FileDateTime(JpgFile_name)
'如果照片沒拍攝日期,就改用修改日期代替
Set Shell_Obj = Nothing
Set Jpg_Folder = Nothing
Set Jpg_Item = Nothing

End Function


Sub Add_table1(n As Integer, Row_h As Integer, Col_w As Integer)

On Error Resume Next

ActiveDocument.Tables(1).Delete
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=4, NumColumns:=2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed
ActiveDocument.Tables(1).Rows.Height = Row_h
ActiveDocument.Tables(1).Rows(1).Height = 100
ActiveDocument.Tables(1).Columns(1).Width = 50
ActiveDocument.Tables(1).Columns(2).Width = Col_w
ActiveDocument.Tables(1).Rows(1).Cells.Merge
ActiveDocument.Tables(1).Rows(1).Borders(wdBorderTop).LineStyle = wdLineStyleNone
ActiveDocument.Tables(1).Rows(1).Borders(wdBorderLeft).LineStyle = wdLineStyleNone
ActiveDocument.Tables(1).Rows(1).Borders(wdBorderRight).LineStyle = wdLineStyleNone

If n = 4 Then ActiveDocument.Tables(1).Cell(3, 2).Split 1, 2

'input test
ActiveDocument.Tables(1).Cell(1, 1).Range = "abcdef" & vbNewLine & "ghijklmnopq"
ActiveDocument.Tables(1).Cell(2, 1).Range = "123"
ActiveDocument.Tables(1).Cell(3, 1).Range = "456"
ActiveDocument.Tables(1).Cell(4, 1).Range = "789"

End Sub

Sub Add_table2(n As Integer, Row_h As Integer, Col_w As Integer)

On Error Resume Next

ActiveDocument.Tables(1).Delete
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=3, NumColumns:=3, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed
ActiveDocument.Tables(1).Rows.Height = Row_h
ActiveDocument.Tables(1).Columns(1).Width = 70
ActiveDocument.Tables(1).Columns(2).Width = 40
ActiveDocument.Tables(1).Columns(3).Width = Col_w
ActiveDocument.Tables(1).Columns(1).Cells.Merge
ActiveDocument.Tables(1).Columns(1).Borders(wdBorderTop).LineStyle = wdLineStyleNone
ActiveDocument.Tables(1).Columns(1).Borders(wdBorderLeft).LineStyle = wdLineStyleNone
ActiveDocument.Tables(1).Columns(1).Borders(wdBorderBottom).LineStyle = wdLineStyleNone

If n = 4 Then ActiveDocument.Tables(1).Cell(2, 3).Split 1, 2

'input test
ActiveDocument.Tables(1).Cell(1, 1).Range = "abcdef" & Chr(13) & "ghijk" & Chr(13) & "lmnopq"
ActiveDocument.Tables(1).Cell(1, 2).Range = "123"
ActiveDocument.Tables(1).Cell(2, 2).Range = "456"
ActiveDocument.Tables(1).Cell(3, 2).Range = "789"

End Sub




misser wrote:
樓主,我的意思是:您...(恕刪)


M大 我有私訊你了
再麻煩你看一下謝謝
anson_830701 wrote:
M大 我有私訊你了再(恕刪)


關於01如何上傳檔案,可以參考某主題(7樓):
https://www.mobile01.com/topicdetail.php?f=511&t=6205117&p=1#79288675

該主題10樓:
https://www.mobile01.com/topicdetail.php?f=511&t=6205117&p=1#79292699

如果樓主覺得「不方便」的話再回覆一下,我們再來用您私訊提的方式來進行後續也是OK。~~(希望能盡快解決樓主的需求)

待會出門,晚上會晚點才上線喔~~

snare wrote:
剛剛突然想到,施工前...(恕刪)


感謝S大的方案,當然樓主也是可以好好思考囉(連表格都不用自己先建立)。

~~我的方案是比較「簡略」,前置需要樓主先把表格做好。....不過換個角度想,樓主剛好有表格大小修改的問題(要留左、上打標題字),為了遷就表格版面,那麼不把寬高「寫死」的作法,可以比較「彈性」一點囉。
Der,misser1
misser wrote:
樓主剛好有表格大小修改的問題(要留左、上打標題字)


表格大小,修改Row_h 、Col_w 2個變數就行
欄、 列大小,修改add_table1、add_table2副程式中.Height、.Width
插入的圖片會隨著表格大小,自動等比例縮小置中
(如果想填滿表格,請改用程式碼中center test註解上面3行,刪掉下面6行)

左、上,標題位置? 您大概還沒跑過程式吧,我有留喔…2種表格都有



snare wrote:
左、上,標題位置? 您大概還沒跑過程式吧,我有留喔


S大,其實我是看樓主提供的表格範例有自訂的標題(字體也有不同),而您的程式是一步到位,連標題都內建了,沒有留給樓主在程式外「自訂」的部分。(等於樓主直接拿空白的檔案來做就好。程式產生表格後,樓主想要更改標題內容及格式也都OK。)

如果樓主要修改欄寬、高、甚至是預設標題,都可以在程式內先改好,也不用後續調整~~甚至是一次插入整頁4個照片,不用逐列一一完成.......從運作效率來說,自然是超級方便,高下立判。

至於我的作法很「單純」,只有負責幫樓主插入那一格照片(1~2張),要能完成一頁的文件,至少也要執行3次插入上.....而標題、表格建立及大小調整,都得樓主自己來.......。唯一的「好處」,大概勉強只有:樓主不用自行到程式裡去修改參數......(但樓主得要自己在Word編輯環境下輸入文字、用滑鼠拖曳表格到想要的大小位置.....)

我只是想,樓主「似乎剛好」已經有現成的檔案(有標題、表格....),又「似乎剛好」不排斥自己逐列挑選照片(每次1~2張),也「似乎剛好」不想到到程式逐一測試參數要調整到多少最好........一連串的「剛好」,所以提供這個超簡單的小程式,那或許我的方案,樓主會覺得「還可以」。(只是真的功能很「簡單、侷限」)

但不論是樓主的狀況是如何,整體來看,s大程式能幫使用者做到「一步到位」,當然是更好的()。

現在就等幫樓主完成環境建置步驟,讓樓主可以在工作環境中順利引進、使用Word巨集功能。........本來看樓主好像有趕著要完成,但現在好像又不是(在忙其他事中?).....呃,或許樓主早已經自行克服巨集這一步,也順利成功引進s大完成的程式碼,正在一一趕工完成所有檔案中~~那就更恭喜了。(至於我另外抽時間做的小小程式方案,就晚點另外再post上來,有需要的再自行參考囉。)
Der,misser1
misser wrote:
沒有留給樓主在程式外「自訂」的部分


因為我回答的不是樓主的問題,是寫給您這種高手看的
只是很久沒用word vba,順便想看看是否有什麼我沒想到的地方
例如:簡單的地方,結果用太複雜方式處理…之類的
程式外什麼的,都不是我考慮的問題,因為程式內的東西,您一定看的懂
所以樓主才會練習您提供的方式,因為您的方式比較適合他使用
snare wrote:
是寫給您這種高手看的


S大,您太「佛心」了~~



~by 高手(「需要加強」的高手)
Der,misser1
這幾天公司臨時都在外面工作,暫時碰不到公司電腦,過幾天有使用,遇到問題再請教各位了。
想說樓主「失蹤」了~~還好~~呵。

上次說,來改一下內容,現在把完成的word檔案(裡面就一個巨集:insert_photo_to_tabel)丟上來.....
[點擊下載檔案]

巨集說明:
1.游標放在表格中,再執行,會出現[開啟舊檔]畫面,可讀入照片檔。
2.一次只能選取1或2張。(1張=自動調整大小至大約表格格子寬高、2張=約一半寬左右,並排在格子)
3.只負責讀照片、縮大小,無其他功能(也不會幫忙畫表格)。

程式碼如下:

Sub insert_photo_to_tabel()
On Error GoTo errhand: '執行錯誤時跳到底下errhand:
'照片檔案位置,預設空值
path1 = ""
path2 = ""
'開啟[讀取檔案]視窗
Set dlgOpen = Application.FileDialog(FileDialogType:=msoFileDialogOpen)
With dlgOpen
.AllowMultiSelect = True '設定只能單選一張照片(誤,應是可選1或2張)
.Filters.Add "照片", "*.jpg*", 1 '預設篩選jpg
If .Show = -1 Then
'按下確定(開啟)
If .SelectedItems.Count > 2 Then
MsgBox "抱歉,只能選擇1或2張照片喔!"
Exit Sub
End If
'讀取檔案位置
For Each vrtSelectedItem In .SelectedItems
'取得檔案位置名稱
If path1 = "" Then path1 = vrtSelectedItem Else path2 = vrtSelectedItem
Next
'如果按下取消
Else
Exit Sub
End If
End With

'設定寬高
side_f = 10 '留邊值
h_f = Selection.Range.Cells(1).Height - 10 '高度=表格格子高度-10
If path2 = "" Then
w_f = Selection.Range.Cells(1).Width - side_f '寬度=表格格子寬度-side_f
Else
w_f = (Selection.Range.Cells(1).Width - side_f) / 2 '寬度=(表格格子寬度-side_f)/2
End If
'插入照片
With Selection.InlineShapes.AddPicture(FileName:=path1, LinkToFile:=False, SaveWithDocument:=True)
.LockAspectRatio = msoFalse '不鎖定長寬比
.Height = h_f '設定高度
.Width = w_f '設定寬度
End With
'插入照片2(如果有指定第2張的話)
If path2 <> "" Then
With Selection.InlineShapes.AddPicture(FileName:=path1, LinkToFile:=False, SaveWithDocument:=True)
.LockAspectRatio = msoFalse '不鎖定長寬比
.Height = h_f '設定高度
.Width = w_f '設定寬度
End With
End If
Exit Sub

errhand:
MsgBox "發生錯誤,請確認游標已在表格中喔!"
On Error GoTo 0
End Sub

上面樓S大有提供更完整的做法(包括自動完成表格,一次最多可到4張=完成整頁),也建議樓主參考一下。

以上,樓主若有問題就再提出囉。
Der,misser1
文章分享
評分
評分
複製連結
請輸入您要前往的頁數(1 ~ 8)

今日熱門文章 網友點擊推薦!