www.smiyasaka.com  は、2019 年2月から SSL 化し 通信を暗号化した方式で発信をしています。

● Excel マクロの解説 「 写真読込マクロ 」編 ●

2 6,868 3   

「 写真読込マクロ 」について、簡単ですが赤字で解説を入れました。
                                          参考になれば、幸いです。
 下記は、本マクロで使用するフォームです。
                         
     	Form1                Form2 
 2019.06.26 現在

----------------- ここから ThisWorkBook コード -----------------
ブックを閉じた時に、アドインとユーザーフォームを消去する
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    Application.CommandBars("Cell").Reset
    B02リセット
End Sub
-----------------------------------------------------------------
ブックを開いた時に、アドインの設定と
                          Form1のユーザーフォームを開く
Private Sub Workbook_Open()
 Application.CommandBars("Cell").Controls(1).BeginGroup=True
 B01セット
End Sub
---------------------- ここから Form1のコード  ------------------
[写真読込貼付け]ボタンクリックで写真貼付を実行
Private Sub CB2_Click()
  III = 0  <-- 終了時本マクロを終了させるかの判定フラグ。
  If UForm1.CheckBox1 = True _
          Then III = 1 <-- 終了時本マクロを終了させない フラグON。
                           「マクロの表紙」に保存する。
  Workbooks(AAname).Worksheets(BBname).Cells(3, 2).Value = _
  III
  '
  処理実行    <-- 処理を実行する。
  '
End Sub

------------------ ここから module1のコード --------------------
マクロブック・シートの名前を定義、変数の宣言
   Public mm, datax(16) As String
   Public B1name, S2name, B3name, S4name As String
   Public N, N1, N2, Nmax, Zom As Single
   Public tate, yoko, Wtate, Wyoko As Single
   Public ichix, Ichiy, Ue, TT, SS, SSS As Single
   Public Zcnt As Double
   Public I, II, III As Integer
   Public x1, x2, y1, y2, x3, x4, X, Y, zz, W, H As Single
   Public Const AAname As String = "写真読込マクロ.xlsm"
   Public Const BBname As String = "表紙"
   Public Const CCname As String = "一覧表"
   Public AAA, BBB, CCC, Kname As String
   Public B5name, S6name, B7name, S8name As String
   Public mystatusbar, Photname, Fpasu As String
   Public Fname1, Fname2 As String
   Public ADir, DirA, DirB As String
   Public myFname, folda, Sname, Gname2 As String
   Public Fname, Tname, Sname1, Sname2 As String
   Private Const BIF_RETURNONLYFSDIRS As Long = &H1
   Private Const BIF_EDITBOX As Long = &H10
   ' 写真日付取得用
   Dim ObjShell As Object
   Dim ObjFolder As Object
   Dim FolderName As Variant
   Dim myTExt As String
   Dim myFileName As String

------------------------------------------------------------------------
Excelブックがオープンした時に実行するサブルーチン
Sub auto_open()
    'Excel タイトル設定
    Application.Caption = "  www.smiyasak.com"
    ActiveWindow.Caption = "写真読込マクロ"
    '-----------------------------------------------------
    ' Excel 起動時にメニューバーをアドインに移動させる処理
    '-----------------------------------------------------
    'ファイルが開かれたときに実行されるマクロ
    ' この様にしないといつまでも Excel がオープンしない
    
    Application.OnTime Now + TimeValue("00:00:00"), "AddIN"
    
End Sub
メニューバーを「アドイン」に移動させる処理
Sub AddIN()
    Sheets(BBname).Select
    N = Val(Application.Version)      'Excelのバージョンを取得する
     
    ' Excelのバージョンの"2000 ; 9","2002 ; 10",
    ' "2003 ; 11"時は、何もしない
    If N = 9 Or N = 10 Or N = 11 Then Exit Sub
    
    ' Excelのバージョンの"2007 ; 12","2010 ; 14","2013 ; 15",
    ' "2016 ; 16"時は、 アドインに移動
    Application.SendKeys ("%X%")    ' [ALT]-->[X]-->[ALT]を実行
    B01セット
End Sub
------------------------------------------------------------------------
アドインの表示処理
Sub B01セット()
    Dim Mycontrol As CommandBarControl
    Dim mysubmenu As CommandBarControl
    ' 表示前に、メニューバーコマンドをリセット( 消去 )する。
    Application.CommandBars("Worksheet Menu Bar").Reset

    Set Mycontrol = CommandBars("Worksheet Menu Bar"). _
    Controls.Add(msoControlPopup)
    Mycontrol.Caption = "【■】"
    Mycontrol.OnAction = "Show表示"
    'シート非表示
    Show表示        <----  ユーザーフォームを表示する。
End Sub
------------------------------------------------------------------------
アドインの削除処理 
Sub B02リセット()
    Application.CommandBars("Worksheet Menu Bar").Reset
    'CommandBars("Worksheet Menu Bar").Controls("【■】").Delete
End Sub
------------------------------------------------------------------------
ニーザーフォームの表示処理
Sub Show表示()
    UForm1.Show vbModeless
End Sub
------------------------------------------------------------------------
シート「一覧表」非表示であったら、表示可能に設定する。
Sub シート表示()
    If Worksheets(CCname).Visible = False Then _
                           Worksheets(CCname).Visible = True
End Sub
------------------------------------------------------------------------
シート「一覧表」表示であったら、非表示に設定する。
Sub シート非表示()
    If Worksheets(CCname).Visible = True Then _
                           Worksheets(CCname).Visible = False
End Sub

------------------------------------------------------------------------
メインのサブルーチン。
Sub 処理実行()
  '
  Unload UForm1        <----  ユーザーフォームを消去する。
  '
  ファイルデータの一覧取得 tyuu       <----  貼り付ける写真の
                                                    ファイル名を取得する。
  If tyuu = 1 Then GoTo 処理実行end:      <----  中止フラグが ON の時
  'この段階では、「マクロの表紙」が、表示されています。      終了する。
  SScnt = ActiveSheet.Cells(2, 15).Value  <----  写真の枚数を取得する。
  '
  シート表示                   <----  シート「一覧表」を表示する。
  写真シート作成 SScnt      <----  シート「一覧表」を必要枚数コピーする。
  Windows(AAname).Activate     <----  「マクロ」を表示する。
  シート非表示>                <----  シート「一覧表」を非表示にする。
  '
  ' 書込みブックシートへ移動
  B1name = _
      Workbooks(AAname).Worksheets(BBname).Cells(1, 2).Value
  S2name = _
      Workbooks(AAname).Worksheets(BBname).Cells(2, 2).Value
  Windows(B1name).Activate     <----  書込みブックシートへ移動する。
  Worksheets(S2name).Activate
  '
  写真貼付    <----   写真貼付を実行する。
  '
  '警告メッセージをオフにする
  Application.DisplayAlerts = False    <----  警告メッセージをオフにする。
                                        これをしないと、閉じて良いか聞かれます。
  ' 終了時に、マクロを閉じるか?
  III = Workbooks(AAname).Worksheets(BBname).Cells(3, 2).Value
  If III = 0 Then _
           Workbooks(AAname).Close   <---- 本マクロを閉じる処理をする。
  Application.DisplayAlerts = True      <---- 警告メッセージをオンにする。
  '
処理実行end:
    '
End Sub
-------------------------------------------------------------------
シート「一覧表」を読み込んだ写真の枚数に応じてコピーするサブルーチン。
Sub 写真シート作成(SScnt As Variant)   <---- SScnt は、写真の枚数
    Worksheets(CCname).Activate   <---- シート「一覧表」を表示する。
    'シートcopy
    Sheets(CCname).Copy           <---- シート「一覧表」をコピーする。
    '
    '------------------------------------------------------------------------
    '   Excel 2007 対策
    ' ブックの共有解除をしないとシートコピーできない。
    Application.DisplayAlerts = False
        If ActiveWorkbook.MultiUsered12iting Then _
                                       ActiveWorkbook.ExclusiveAccess
    Application.DisplayAlerts = True
    '------------------------------------------------------------------------
    N = Int((SScnt + 28 - 1) / 28)    <----   コピーする枚数を計算する。
    If SS = 1 Then GoTo 写真シート作成end:
    For SS = 1 To N - 1   <----   必要枚数をコピーする。
        Worksheets(SS).Activate
        シートコピー
    Next SS
    
写真シート作成end:
    新規にできたブックの名前とシート名を「マクロの表紙」に保存する。
    Workbooks(AAname).Worksheets(BBname).Cells(1, 2).Value = _
                                                    ActiveWorkbook.Name
    Workbooks(AAname).Worksheets(BBname).Cells(2, 2).Value = _
                                                    ActiveSheet.Name
End Sub

----------------------------------------------------------------------
シート名に枝番号を付けてシートコピーをするサブルーチン
Sub シートコピー()
'
    N = Worksheets.Count    <-- シートの数を取得する。
    
    If N = 1 Then         <-- シートが一枚の時は、そのシート名を取得し、
                                    追加シート名に、"-1" を付けてシート名とする。
        BBB = ActiveSheet.Name
        AAA = ActiveSheet.Name & "-1"
        ActiveSheet.Name = AAA
        AAA = BBB & "-" & CStr(N + 1)
    Else                     <-- シートが複数枚の時の処理
        Worksheets(N).Activate
        SSS = Len(mm): BBB = Left(mm, SSS - 2) <-- シート名の枝番を
                                                                                 削除する。
        AAA = BBB & "-" & CStr(N + 1)   <-- 追加シート名に、"-n" を
                                                                 付けてシート名とする。
    End If
    Application.DisplayAlerts = False    <--  警告メッセージをオフにする。
    mm = ActiveSheet.Name
    Sheets(mm).Copy After:=Sheets(mm)  <--- シートを後ろへコピー
    CCC = ActiveSheet.Name
    
    ActiveSheet.Cells(44, 1).Value = CStr(N + 1)  <-- シートの下に
                                                                        ページ数を書き込む。
    Worksheets(CCC).Name = AAA         <-- シート名を変更する。
    Application.DisplayAlerts = True   <-- 警告メッセージをオンにする。
'
End Sub

----------------------------------------------------------------------
写真読込のダイヤログを表示し、任意写真クリックで写真のファイル名を
取得し、「マクロの表紙」のセル位置17列目に書き込みをするサブルーチン

Sub ファイルデータの一覧取得(tyuu As Variant)

   Dim filename,C_Range As Variant, 名前 As String
   'Windows(AAname).Activate
   Worksheets(BBname).Activate
   ' 写真枚数カウント関数書込み
   ActiveSheet.Cells(1, 14).FormulaR1C1 = _
                                       "=COUNTA(R[1]C[3]:R[9999]C[3])"
   '中止フラグ
    tyuu = 0    <----   中止フラグを OFF する。
 
   ' セルの内容を消去する
   N = ActiveSheet.Cells(1, 14).Value + 1     <---- 書込みデータの数 +1
   If N > 1 Then                   <---- 書込みがある時のみ消去
       C_Range = "O2:Q" & CStr(N)  <---- 消去範囲のレンジデータを作成
       Range(C_Range).Select       <---- 消去範囲を選択
       Selection.ClearContents   <-- 写真のファイル名を書き込む
   End If                                             エリヤを消去
   Range("O2").Select
   
   On Error GoTo エラー処理:    <----   エラー処理を定義する。
   貼付写真のフォルダを指定するダイヤログを表示する。
 filename = _
    Application.GetOpenFilename(fileFilter:="写真ファイル(*.*), _
    *.*", Title:="写真ディレクトリーと適当なファイルを指定して下さい")
   名前 = Dir(CurDir() & "\*.*", vbNormal)  <-- 配列として変数[名前]に
                                                                写真のファイル名を保存する
    ADir = CurDir()    <---- フォルダのパス
 'キャンセルの時は、終了する
    If filename = False Then _
                  GoTo tyuusi:    <---- 写真の指定がない時、中止処理をする
    If VarType(filename) = _
                  vbBoolean Then GoTo tyuusi:    <----  キャンセルの時は、
                                                                          中止処理をする。
 
    I = 2
    ActiveSheet.Cells(I, 16).Value = ADir <----  フォルダのパスを
                                                            「マクロの表紙」を書込む。

   配列変数[ 名前 ]  に書込まれているファイル名をすべて
  「マクロの表紙」に書込む。
   Do While 名前 <> ""
        
        ActiveSheet.Cells(I, 17).Value = 名前
        名前 = Dir()
      
      I = I + 1
     Loop
     
     フォルダ名 = CurDir()    <-- 次回のため、カレントパスを書き換える。
   
   '画像数の取得
    ActiveSheet.Cells(2, 15).Value = I - 2   <----  書込んだ写真の
                                     ファイル名の数を「マクロの表紙」に書込む。
    
   Exit Sub
   
tyuusi:

   '中止フラグ
    tyuu = 1    <----  中止フラグを ON する。

 Exit Sub

エラー処理:
   MsgBox "予期せぬエラーが発生したので終了します。"  <--- エラー処理

End Sub

------------------------------------------------------------------------

張付けるサブルーチン

Sub 写真貼付()
  ' 貼付写真取込
  '画面の更新を隠す
  UForm2.Show vbModeless   <-- 処理進行状況のユーザーフォームを表示
  Application.ScreenUpdating = False   <-- 画面の更新を停止する。
  '
  「マクロの表紙」から、写真の枚数を読み込む。
  N = Workbooks(AAname).Worksheets(BBname).Cells(2, 15).Value

  For I = 1 To N
  Form2 の処理状況の枚数カウンタ値更新させる。
  UForm2.Label2.Caption = CStr(I) & "/" & CStr(N) & "処理終了"
  '      これを入れないとユーザーフォームの文字が表示しない
  DoEvents   <----  この関数で
  '     「写真を貼付中 しばらくお待ちください。」が表示する。
  (I - 1)は、I が 28,56,・・・時と27,55・・・時、割り算の答え
  (整数値)が同じになるようにするためです。
   + 1 しているのは、割り算の最小値の時に、SS = 1 にするためです。

   SS = int((I - 1)/28) + 1

  ページ内の貼付位置を求める式です。
  ゼロの乗算を避けるため、if 文を使用しています。

  If SS = 1 then
    II = I
  Else
   II = I - 28 * (SS - 1)
  End if

------------------------------------------------------------------------
   Worksheets(SS).Activate   <--- SS番目のシートを表示する。
  ' 写真貼付位置取得
  写真を貼付けるセル位置データを取得する。
  y = Workbooks(AAname).Sheets(BBname).Cells(II + 1, 19).Value
  x = Workbooks(AAname).Sheets(BBname).Cells(II + 1, 20).Value
  ActiveSheet.Cells(y, x).Select   <--- 貼付けるセルを選択する。
  '
  ' 写真読出し・貼付
  写真のファイル名取得
  Tname = Workbooks(AAname).Worksheets(BBname).Cells(I _
                 + 1, 17).Value
  myFname = ADir & "\" & Tname    <--- 写真のフルのパスを作成
  ファイル名が無くなったら、for 文抜け出る。
  If Tname = "Thumbs.db" Then Exit For

  写真を貼付けるセルのサイズデータ( 幅・高さ )を取得する。
  With Selection.Height
  End With

  Set objShape = ActiveSheet.Shapes.AddPicture( _
  filename:=myFname, _  <--- 挿入する写真ファイル名をパス付きで指定
  LinkToFile:=False, _    <--- False で独立した写真としての指定
           True で元のファイルとのリンクを設定
  SaveWithDocument:=True, _   <--- True で Excelファイルと共に保存
           False でリンク情報だけを保存
  Left:=Selection.Left, _    <--- アクティブセルの左端位置を指定
  Top:=Selection.Top + 2, _  <--- アクティブセルの上端位置を指定
            + 2 は、枠線が被るので補正しています。
  Width:=Selection.Width, _      <--- アクティブセルの横幅を指定
  Height:=Selection.Height)       <--- アクティブセルの高さを指定
  '-------------------------------------------------------------------------
  写真名を所定の位置に書込む。
  y = Workbooks(AAname).Sheets(BBname).Cells(II + 1, 21).Value
  x = Workbooks(AAname).Sheets(BBname).Cells(II + 1, 22).Value
  ActiveSheet.Cells(y, x).Value = Tname

  枠線書込み

  ActiveSheet.Cells(y, x).Select

  セル枠線        <--- 枠線を書込む。

  '-------------------------------------------------------------------------
  ' 写真撮影日を所定の位置に書込む
  Y = Workbooks(AAname).Sheets(BBname).Cells(II + 1, 21).Value - 1
  X = Workbooks(AAname).Sheets(BBname).Cells(II + 1, 22).Value
  '-------------------------------------------------------------------------
  ' 写真撮影日を取得するVBAのコードは、先人の知恵を拝借しました。
  '-------------------------------------------------------------------------
  ' 写真ファイルのフルパス
  FolderName = Left$(myFname, InStrRev(myFname, "\") - 1) 
   ' 写真ファイル名
  myFileName = Mid$(myFname, InStrRev(myFname, "\") + 1) 
   ' フォルダ用シェルアプリケーション生成
   Set ObjShell = CreateObject("Shell.Application")
   ' ObjFolder="ピクチャ" に設定
   Set ObjFolder = ObjShell.Namespace(FolderName)
   myTExt = _
       ObjFolder.GetDetailsOf(ObjFolder.ParseName(myFileName), 12)
   '
   ' 文字列    ex. ?2013/?10/?06 ??7:25
   '   写真撮影日文字列の分解合成
   '    yyyy/   mm/    dd(半角スペース)  time(〇〇:〇〇)
   myTExt = Mid(myTExt, 2, 5) & Mid(myTExt, 8, 3) & _
                                 Mid(myTExt, 12, 3) & Mid(myTExt, 17)
   
   ActiveSheet.Cells(Y, X).Value = myTExt ' ・写真撮影書込み
   '-------------------------------------------------------------------------
   If I > 337 Then Exit For <--- 貼付枚数 336 以上になったら
                                                for 文抜け出る

  Next I

  '画面の更新を戻す
  Application.ScreenUpdating = True   <--- 画面の更新の停止を解除する
  Unload UForm2       <--- UForm2 の表示を解除する。
End Sub

------------------------------------------------------------------------
選択されているセルに枠線(罫線)を書き込むサブルーチン
Sub セル枠線()
たった一行で上下左右の罫線が引けることが分かったので実行しました

    Selection.Borders.LineStyle = xlContinuous ' 上下左右の罫線

    ' = True でも 上下左右の罫線 が引けます。
    'Selection.Borders.LineStyle = True

End Sub
------------------------------------------------------------------------
選択された図形位置・サイズを表示するサブルーチン
Sub A図形位置サイズ()
'
With Selection
    X = .Left
    Y = .Top
    W = .Width
    H = .Height
End With
Format文 "#,##0"は、整数表示指定、3桁目カンマ有 "#,###.0"は、
少数第1位まで表示指定、少数点以下が、ゼロ時は、0を表示する指定

    MsgBox " 左 " + Format(X, "#,##0") + " 上 " _
 + FormatY, "#,##0") + "  横幅 " + Format(W, "#,###.0") _
 + " 縦幅 " + Format(H, "#,###.0")
    
End Sub

TOPへ戻る