Excel VBA質問箱 IV

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

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


11 / 13290 ツリー ←次へ | 前へ→

【80770】写真の取込(pictures.Insert⇒shapes.addpicture)を変えたいのですが、、、 ぽぽ 19/5/6(月) 6:39 質問[未読]
【80772】Re:写真の取込(pictures.Insert⇒shapes.... マナ 19/5/6(月) 15:44 発言[未読]
【80774】Re:写真の取込(pictures.Insert⇒shapes.... ぽぽ 19/5/6(月) 16:38 質問[未読]
【80775】Re:写真の取込(pictures.Insert⇒shapes.... マナ 19/5/6(月) 20:41 発言[未読]

【80770】写真の取込(pictures.Insert⇒shapes.a...
質問  ぽぽ  - 19/5/6(月) 6:39 -

引用なし
パスワード
   わたくし、初心者です。お時間あればぜひご教授お願いします。

画像データを取り込めるプログラムをネット上でいただきましたが、、
元ファイルが取り込んだ時のフォルダーに存在しないと表示できません。
写真をリンクせずに取込めるにはどこをどのように換えればよいのでしょうか?
なお、画像は640Mカメラ撮影(だいたい120K)、jpgのみです。


以下プログラム:


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


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

【80772】Re:写真の取込(pictures.Insert⇒shape...
発言  マナ  - 19/5/6(月) 15:44 -

引用なし
パスワード
   ▼ぽぽ さん:

>写真をリンクせずに取込めるにはどこをどのように換えればよいのでしょうか?

ht tps://www.moug.net/tech/exvba/0120020.html

↑では、CopyPicture を使用しています。

>  xlSheet.Shapes("Pic" & k).Copy
>  xlSheet.Shapes("Pic" & k).Delete
>  xlSheet.Paste

【80774】Re:写真の取込(pictures.Insert⇒shape...
質問  ぽぽ  - 19/5/6(月) 16:38 -

引用なし
パスワード
   マナさん:

早速の返信、大変ありがとうございました。
URL確認しましたが、今回添付したコマンドでの修正箇所は
どこになるのか見当がつかない状況です。

'写真挿入
  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

のコマンドを修正すればよいものなのでしょうか?そうであれば、
具体的にどのように修正したらよいのでしょうか?

【80775】Re:写真の取込(pictures.Insert⇒shape...
発言  マナ  - 19/5/6(月) 20:41 -

引用なし
パスワード
   ▼ぽぽ さん:

>画像データを取り込めるプログラムをネット上でいただきましたが、、

どこでいただいたのでしょうか。
問題がでるたびに修正依頼で大丈夫ですか。

>ht tps://www.moug.net/tech/exvba/0120020.html

まずは、↑のサンプルを理解してからではないでしょうか。

11 / 13290 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free