| 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"は、整数表示指定、３桁目カンマ有 "#,###.0"は、
少数第１位まで表示指定、少数点以下が、ゼロ時は、0を表示する指定
MsgBox " 左 " + Format(X, "#,##0") + " 上 " _
+ FormatY, "#,##0") + " 横幅 " + Format(W, "#,###.0") _
+ " 縦幅 " + Format(H, "#,###.0")
End Sub
|
|
