Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

1685 / 76807

←次へ　｜　前へ→


	【80770】写真の取込（pictures.Insert⇒shapes.addpicture)を変えたいのですが、、、

ぽぽ - 19/5/6(月) 6:39 -


	引用なし

	パスワード

わたくし、初心者です。お時間あればぜひご教授お願いします。

画像データを取り込めるプログラムをネット上でいただきましたが、、
元ファイルが取り込んだ時のフォルダーに存在しないと表示できません。
写真をリンクせずに取込めるにはどこをどのように換えればよいのでしょうか？
なお、画像は６４０Ｍカメラ撮影（だいたい１２０Ｋ）、ｊｐｇのみです。

以下プログラム：

'ファイル名取得
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

どうぞご対応のほどよろしくお願いします。

0 hits

▼

【80770】写真の取込（pictures.Insert⇒shapes.addpicture)を変えたいのですが、、、 ぽぽ 19/5/6(月) 6:39