| |
わたくし、初心者です。お時間あればぜひご教授お願いします。
画像データを取り込めるプログラムをネット上でいただきましたが、、
元ファイルが取り込んだ時のフォルダーに存在しないと表示できません。
写真をリンクせずに取込めるにはどこをどのように換えればよいのでしょうか？
なお、画像は６４０Ｍカメラ撮影（だいたい１２０Ｋ）、ｊｐｇのみです。
以下プログラム：
'ファイル名取得
Sub Getfn()
Dim dlg As FileDialog
Dim fol_path As String 'フォルダのフルパス
Dim f_name As String 'ファイル名
Dim i As Long 'ファイル名を出力する行番号
'前データクリア
Range("A2", Range("B2").End(xlDown)).ClearContents
fol_path = Range("G1").Value 'パスを変数に格納
f_name = Dir(fol_path & "\*") 'フォルダ内の一つ目のファイル名を取得
If f_name = "" Then
MsgBox fol_path & " にはファイルが存在しません。"
Exit Sub
End If
'A5セルから下にファイル名を書き出し
i = 2
Do Until f_name = ""
Cells(i, 1).Value = i - 1
Cells(i, 2).Value = f_name
i = i + 1
'次のファイル名を取得
f_name = Dir
Loop
MsgBox "ファイル名一覧を作成しました。"
End Sub
Sub Photo()
Dim Path As String '写真データパス
Dim i As Integer, j As Integer, k As Integer '繰り返し変数
Dim ShtNm As String 'シート名
Dim DestinationFile As String '作成ファイル名
Dim xlsApp As Application, xlBook As Workbook, xlSheet As Worksheet '作業用変数
Dim PicPath As String '写真挿入パス
Application.ScreenUpdating = False '画面更新非表示
'初期設定
Path = Cells(1, 7)
k = 1 'ファイルのNo
'保存フォルダの作成
If Dir(Path & "\写真票", vbDirectory) = "" Then
MkDir Path & "\写真票"
End If
DestinationFile = Path & "\写真票" & "\写真票.xlsx" ' 作成ファイル名設定
Sheets("写真票様式").Copy
ActiveWorkbook.SaveAs Filename:=DestinationFile, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 'ファイル作成
ActiveWorkbook.Close
Set xlsApp = CreateObject("Excel.Application")
Set xlBook = xlsApp.Workbooks.Open(DestinationFile)
Do Until Cells(k + 1, 1) = ""
Application.StatusBar = k & "枚目の処理をしています..."
'シートの追加
If k Mod 8 = 1 Then
i = 0
Set xlSheet = xlBook.Worksheets("写真票様式")
xlSheet.Copy Before:=xlSheet
Set xlSheet = xlBook.Worksheets("写真票様式 (2)" & "")
ShtNm = "写真票" & "-" & k \ 8 + 1
xlSheet.Name = ShtNm
Set xlSheet = xlBook.Worksheets(ShtNm)
End If
If k Mod 2 = 1 Then
j = 0
Else
j = 2
End If
'写真挿入
PicPath = Path & "\" & Cells(k + 1, 2)
xlSheet.Cells(6 + 17 * i, 2 + j).Select
xlSheet.Pictures.Insert(PicPath).Name = "Pic" & k
xlSheet.Shapes("Pic" & k).Copy
xlSheet.Shapes("Pic" & k).Delete
xlSheet.Paste
'サイズ変更
xlSheet.Pictures.ShapeRange.LockAspectRatio = msoTrue
xlSheet.Shapes("Pic" & k).Height = 250
'項目入力
xlSheet.Cells(3 + 17 * i, 2 + j) = Cells(k + 1, 3)
xlSheet.Cells(4 + 17 * i, 2 + j) = Cells(k + 1, 4)
xlSheet.Cells(1, 1).Select
k = k + 1
If j = 2 Then i = i + 1
Loop
xlBook.Close (True) 'ブックをクローズ (保存)
xlsApp.Quit 'エクセルを終了
Application.StatusBar = False
ThisWorkbook.Activate
Application.ScreenUpdating = True '画面更新表示
MsgBox "写真票を作成しました。"
End Sub
どうぞご対応のほどよろしくお願いします。
|
|
bonkan
- 19/5/10(金) 9:51 -
Mp
- 19/5/10(金) 6:03 -
HIHI
- 19/5/9(木) 22:11 -
bonkan
- 19/5/9(木) 19:00 -
