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

● Excel マクロの解説 「 写真貼付マクロ 」編 ●

2 15,124 2   

「 写真貼付マクロ 」について、簡単ですが赤字で解説を入れました。
参考になれば、幸いです。

下記は、本マクロで使用するフォームとボタン等の名前の関係です。

 2019.02.08 現在
------------------   ここから ThisWorkBook コード ----------------------
ブックを閉じた時に、アドインとユーザーフォームを消去する
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    Application.CommandBars("Cell").Reset
    B02リセット
    Unload Form2
End Sub
------------------------------------------------------------------------
ブックを開いた時に、アドインの設定とForm2のユーザーフォームを開く
Private Sub Workbook_Open()
    Application.CommandBars("Cell").Controls(1).BeginGroup = True
    B01セット
    Form2.Show vbModeless
End Sub
--------------------------   ここから Form2のコード  -------------------
[写真読込貼付け]ボタンクリックで写真貼付を実行
Private Sub CommandButton1_Click()
90°回転のチェックボタンをチェックする。
    mm = 1: If Form2.CheckBox2 = True Then mm = -1

    S写真選択 mm
    
貼付位置選択のチェックボタンを切り替える
    With Form2
        If .OB1 = True Then .OB1 = False: .OB2 = True: GoTo SCB1end
        If .OB2 = True Then .OB2 = False: .OB3 = True: GoTo SCB1end
        If .OB3 = True Then .OB2 = False: .OB3 = False: .OB1 = True
SCB1end:
    End With
End Sub
------------------------------------------------------------------------
[BOOK作成]ボタンクリックでシート原稿をコピーし、
新規ブックとして作成する             
Private Sub CommandButton52_Click()
    'シート別BOOKへcopy
    AAA = Form2.TextBox1.Text    <---- TextBox1のテキストデータを
                                                         ブック名にする
    If AAA = "" Then Exit Sub
    '
    ADir = Workbooks(AAname).Worksheets(CCname).Cells(3, 1).Value
    ' パスなしの時には、書込みフォルダ設定へ
    If ADir = "" Then パス設定W: Exit Sub    <---- 読込みのパスの設定が
                                                                       が無い時は強制終了
    ' 保存されているパスが有効かチェックする。
    '--------------------------------------------------------------------
    ' このマクロは、Windows Script Host Object Model を使用して
    ' いるので、マクロ-ツール-参照設定で上記のオブジェクトに
    ' チェックを入れて、使用すること。
    '--------------------------------------------------------------------
    With New IWshRuntimeLibrary.FileSystemObject
        If Not .FolderExists(ADir) Then
            MsgBox "書込み先のフォルダ" & BBB & "がありません。", _
                                                                          vbExclamation
            パス設定W     ' パス無効の時には、書込みフォルダ設定へ
            Exit Sub
        End If
    End With
    '
    Sheets("原稿").Select
    Sheets("原稿").Copy          <---- シート「原稿」をコピーする
    Sheets("原稿").Select
    Sheets("原稿").Name = AAA    <---- TextBox1のテキストデータを
    'BOOK保存                                       ブック名にする
 
    On Error GoTo CommandButton52_err:    <---- エラーの時のジャンプ先
    '    書き込み先のパス
    ADir = Workbooks(AAname).Worksheets(CCname).Cells(3, 1).Value
    '
    互換モード対応  Excelのバージョンコードを取得し、保存形式を決める
    '
    N = Val(Application.Version)
    ' Excelのバージョン"2000","2002","2003"
    If N = 9 Or N = 10 Or N = 11 Then GoTo Button52A:
     ' Excelのバージョン"2007","2010","2013"
    If N = 12 Or N = 14 Or N = 15 Or N = 16 Then GoTo Button52B:
    MsgBox ("このExcelのバージョンは、対応していませんので、_
                                                終了します。"): Exit Sub
    '
Button52A:
    互換モードの時の、処理(Excelのバージョン"2000","2002","2003")
    AAA = ADir & "\" & AAA & ".xls"
    ActiveWorkbook.SaveAs AAA
    GoTo Button52C:
    '
Button52B:
    Excelのバージョン"2007","2010"の時の、処理
    AAA = ADir & "\" & AAA & ".xlsx"    <---- 書込み先のフルパスを作成
    '---------------------------------------------------------------------
    '   Excel 2007 対策 書込み時に、拡張子の指定がいる。
    '   51=*.xlsxモードで保存
    'H23.12.13
    Application.DisplayAlerts = False    <---- 警告メッセージを止める
    ( TextBox1のテキストデータ ).xlsx で書込み
    ActiveWorkbook.SaveAs Filename:=AAA, _
                                    accessMode:=xlShared12, FileFormat:=51
    Application.DisplayAlerts = True     <---- 警告メッセージを抑制を解除
    'ActiveWorkbook.SaveAs AAA
    'Workbooks(AAname).Sheets(BBname).Cells(7, 1).Value = _
                                                      ActiveWorkbook.Name
    '---------------------------------------------------------------------
    '   Excel 2007 対策
    ' ブックの共有解除をしないとシートコピーできない。
    Application.DisplayAlerts = False
  シートコピーのため、事前にブックの共有解除
    If ActiveWorkbook.MultiUsered12iting Then _
                                     ActiveWorkbook.ExclusiveAccess    
    Application.DisplayAlerts = True
    '---------------------------------------------------------------------
Button52C:
    Workbooks(AAname).Sheets(CCname).Cells(2, 1).Value = _
                                                                 Form2.TextBox1.Text
    Exit Sub
    保存先が、設定されていないと、実行時エラー(エラーNo.1004)に
    なるので、その処理をする。
CommandButton52_err:
    M = Err.Number     <---- エラー番号確認用(デバック用)
    If M = 75 Then MsgBox ("設定されているフォルダのパス名は、_
                                                                            無効です。")
    If M = 76 Then MsgBox ("設定されているフォルダのパス名は、_
                                                                            間違っています。")
    If M = 1004 Then MsgBox ("同じブック名があるので保存しません。")
End Sub
--------------------------------------------------------------------------
[シートコピー]ボタンクリックでシートコピーを実行
Private Sub CommandButton53_Click()
    シートコピー
End Sub
------------------------------------------------------------------------
[↓]ボタンクリックで下向き矢印を描画する
Private Sub CommandButton54_Click()
    ' 下向き矢印
    '赤線描画する
    
    With Selection     <---- 書込み位置情報取得
        x = .Left
        y = .Top
        x2 = .Width
        y2 = .Height
    End With
    xx = 142 / 4 + 30     <---- xx=65.5 便宜上この様にしています
    図形を描くときには、この様に計算式にしておくと変更時、
    分かり安くなります。
    '  横線
    ActiveSheet.Shapes.AddLine(x + xx - 20, y - 21, x + xx, y).Select
------------------------------------------------------------------------
   図形の表示位置・サイズの指定方法
   上記、( )内の意味は、
        ( 始点の横位置, 始点の縦位置, 終点の横位置, 終点の縦位置 ) 
    位置座標の原点は、シート上の左上の端が、横 0, 縦 0 になります。 
------------------------------------------------------------------------

    Selection.ShapeRange.Line.EndArrowheadStyle = _
                              msoArrowheadTriangle    <---- 矢印 三角を指定
    Selection.ShapeRange.Line.EndArrowheadLength = _
                              msoArrowheadLengthMedium    <---- 長さ 中を指定

    Selection.ShapeRange.Line.EndArrowheadWidth = _
                              msoArrowheadWidthMedium   <---- 幅 中を指定
    Selection.ShapeRange.Line.Weight = 2.25            <---- 線の太さ
    Selection.ShapeRange.Line.ForeColor.RGB = _
                                                         vbred12  <---- 線の色 赤を指定
    Selection.ShapeRange.ZOrder msoBringToFront   <-- 矢印の表示を
                                                                           前面にする指定。
End Sub
------------------------------------------------------------------------
[↑]ボタンクリックで下向き矢印を描画する
Private Sub CommandButton55_Click()
    ' 上向き矢印
    '赤線描画する
    With Selection
        x = .Left
        y = .Top
        x2 = .Width
        y2 = .Height
    End With
    '
    xx = 142 / 4  + 30
    ActiveSheet.Shapes.AddLine(x + xx - 20, y , x + xx - 4, y - 21).Select
    Selection.ShapeRange.Line.EndArrowheadStyle = _
                                                msoArrowheadTriangle
    Selection.ShapeRange.Line.EndArrowheadLength = _
                                                msoArrowheadLengthMedium
    Selection.ShapeRange.Line.EndArrowheadWidth = _
                                                msoArrowheadWidthMedium
    Selection.ShapeRange.Line.Weight = 2.25
    Selection.ShapeRange.Line.ForeColor.RGB = vbred12
    Selection.ShapeRange.ZOrder msoBringToFront
End Sub
------------------------------------------------------------------------
[書込み場所設定]ボタンクリックで書込み先のディレクトリーを設定する。
Private Sub CommandButton56_Click()
    パス設定W
End Sub
------------------------------------------------------------------------
[写真読込場所設定]ボタンクリックで写真読込先のディレクトリーを設定する。
Private Sub CommandButton57_Click()
    パス設定R
End Sub
------------------------------------------------------------------------
[写真変更禁止]ボタンクリックで張付け写真変更禁止を設定する。
Private Sub CommandButton2_Click()
    '  写真変更禁止の設定
    ' セル範囲("B2:G42")を保護する。
    
    Lock_Hani = "B2:G42"   <---- 保護する範囲を設定する
    
    写真変更禁止 Lock_Hani

End Sub
------------------------------------------------------------------------
[シート名変更]ボタンクリックで、アクティブシート名を
[TextBox2]の名前に変更します。
Private Sub CommandButton16_Click()
    ' H29.01.19 追加
    Gname = ActiveWorkbook.Name
    If Gname = AAname Then Exit Sub
        ' シート名変更
    AAA = ActiveSheet.Name
    Sheets(AAA).Select
    Sheets(AAA).Name = Form2.TextBox2.Value
    Range("A1").Select
End Sub

------------------------------------------------------------------------
ユーザーフォームの左上隅の□をクリックすると、選択したセル・図形の
サイズが表示されます。
Private Sub CommandButton7_Click()
    図形位置サイズ
End Sub
------------------------------------------------------------------------
[文字書込]ボタンクリックで、選択されたセルにリストの指定された
文字列を書き込みます。
Private Sub CB2_Click()
    Dim 文字 As String
    文字 = ListBox1.Value
    S繰返 文字
End Sub
------------------------------------------------------------------------
ユーザーフォームのイニシャライズの処理
Private Sub UserForm_Initialize()
    Dim I As Integer
ListBox1に、「マクロの表紙」の16行目のデータをリストデータと
して書込みます。
  With ListBox1
      I = 3
    Do While Workbooks(AAname).Sheets(CCname).Cells(I, 16) <> ""
      ListBox1.AddItem Workbooks(AAname).Sheets(CCname).Cells(I, 16)
      I = I + 1
    Loop
  End With
  Form2.OB1 = True    <---- オプションボタン1をON(True)にします。
  TextBox1に、「マクロの表紙」のセル位置(2, 1)のデータを書込みます。
  If Workbooks(AAname).Sheets(CCname).Cells(2, 1).Value <> "" Then
    Form2.TextBox1.Text = _
                   Workbooks(AAname).Sheets(CCname).Cells(2, 1).Value
  End If
End Sub

---------------------   ここから module1のコード    -------------------
マクロブック・シートの名前を定義、変数の宣言
  Public AAA, mm, datax(16), ADir As String
  Public N, Nmax, Zom, Tate, Yoko, Ichi1, Ichi2 As Single
  Public Ue, Ue1, Ue2, Ue3, TT, SS As Single
  Public Ue4, Ue5, Ue6 As Single
  Public x1, x2, y1, y2, x3, x4, x, y As Single
  Public Const AAname As String = "写真貼付マクロ.xlsm"
  Public Const CCname As String = "表紙"
  Public BBB, CCC, Kname, B5name, S6name, B7name, S8name As String
  Public mystatusbar, Photname, Fpasu As String
  Public myFname, Sname, Gname, Tname As String
  ' ネットワークドライブの参照をしたい時には、下記を追加して、
'----------------------------------------------------------------------------
' ネットワークドライブの参照
' VBA7という定数を使うとEXCELのバージョンが2007以前か2010以降か
' が区別できる。
' Win64は、実行しているEXCELのバージョンが64bitか32bitかの区別が出来る。

        #If VBA7 And Win64 Then
'64Bit 版 かつ 2010以降
        Private Declare PtrSafe Function SetCurrentDirectory _
                Lib "kernel32" Alias "SetCurrentDirectoryA" _
                                 (ByVal lpPathName As String) As Long
        #Else
'32Bit 版
        Private Declare Function SetCurrentDirectory _
                Lib "kernel32" Alias "SetCurrentDirectoryA" _
                                 (ByVal lpPathName As String) As Long
        #End If
'-------------------------------------------------------------------------

------------------------------------------------------------------------
Excelブックがオープンした時に実行するサブルーチン
Sub auto_open()
    '----------------------------------------------------
    '  Excel 起動時にメニューバーをアドインに移動させる処理
    '----------------------------------------------------
    この様にしないといつまでも Excelブックがオープンしない
    '      タイムディレー処理
    Application.OnTime Now + TimeValue("00:00:00"), "AddIN" 
                                          直ぐに、サブルーチン AddIN を実行させる
End Sub
------------------------------------------------------------------------
メニューバーを「アドイン」に移動させる処理
Sub AddIN()
    Sheets(CCname).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]の
                                                                       キー入力を実行
End Sub
------------------------------------------------------------------------
アドインの表示処理
Sub B01セット()
    '
    '  Excel 2007/2010 に対応するように変更する
    ' 新規ブックは、*.xlsx(Excel2007形式)で作成する。
    '
    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 = "再表示"

    ' 表紙 関数書込み
    Worksheets(CCname).Activate         ' 「 表紙 」をアクティブ化
    ActiveSheet.Cells(2, 16).Select
    ActiveCell.FormulaR1C1 = "=COUNTA(R[1]C:R[31]C)"

End Sub
------------------------------------------------------------------------
アドインの削除処理
Sub B02リセット()
    Application.CommandBars("Worksheet Menu Bar").Reset
    'CommandBars("Worksheet Menu Bar").Controls("【■】").Delete
End Sub
------------------------------------------------------------------------
ニーザーフォームの表示処理
Sub 再表示()
    Form2.Show vbModeless
End Sub
------------------------------------------------------------------------
(おまけ)マクロの実行のさせ方
次の手順で、実行をさせます。
 [ツール] --> [マクロ] --> [マクロの表示] --> 実行のさせたい
  マクロを選び[実行] 
------------------------------------------------------------------------
(おまけ)Excelのバージョンコードを取得表示する。
Sub Aexcel_ver()
    Dim sv As String
    ' Excelのバージョンコードを取得
    N = Val(Application.Version)
    If N = 9 Then sv = "2000"
    If N = 10 Then sv = "2002"
    If N = 11 Then sv = "2003"
    If N = 12 Then sv = "2007"
    If N = 14 Then sv = "2010"
    If N = 15 Then sv = "2013"
    If N = 16 Then sv = "2016"
    MsgBox ("Excelのバージョンコードは " & N & " : Excel" & sv & " です")
End Sub
------------------------------------------------------------------------
Form2の表示位置を表示する。
Sub ichi()
    With Form2
      MsgBox "Left=" & .Left & " " & "Top=" & .Top
    End With
End Sub

------------------------------------------------------------------------
ダイヤログを表示し、参照したいフォルダのパス情報を取得するサブルーチン。
プログラムは、下記のとおりにして下さい。
また、参照設定で Microsoft Scripting Runtime と
 Microsoft Shell Controls And Automation の2つの設定を忘れない
ようして下さい。
設定の仕方が、分からない方は、このマクロをダウロードし、不要な箇所を
削除して、流用してください。

[参照設定]のダイヤログの開き方
次の手順で、VBE(Visual Basic Editor)を開きます。
@[ツール] --> [マクロ] --> [マクロの表示] --> 適当なマクロを選び
 [編集] ----> Visual Basicのダイヤログが開きます。
A[ツール] -->> [参照設定] --> 必要とするライブラリィにチェックを
 いれて [OK]

Sub フォルダ参照W(SFolda As Variant)
    '
    'このサブルーチンを使用するときは、下記2行の設定と
    '参照設定で Microsoft shell Controls And Automation の
    '参照設定をすること。
    'Private Const BIF_RETURNONLYFSDIRS As Long = &H1
    'Private Const BIF_EDITBOX As Long = &H10

    Dim myShell As Shell32.Shell
    Dim myFolder As Shell32.Folder3
    Dim myItem As Shell32.FolderItem
    Set myShell = New Shell32.Shell
    Set myFolder = myShell.BrowseForFolder( _
        0&, "Excelブックの書込みフォルダを選択してください。" _
        , BIF_RETURNONLYFSDIRS Or BIF_EDITBOX)
    If myFolder Is Nothing Then SFolda = "": Exit Sub
    
        MsgBox myFolder.Self.Path
    
    SFolda = myFolder.Self.Path
   
    Set myFolder = Nothing
    Set myShell = Nothing
End Sub
------------------------------------------------------------------------
ダイヤログを表示し、参照したいフォルダのパス情報を取得するサブルーチン。
Sub フォルダ参照R(SFolda As Variant)
    Set myShell = New Shell32.Shell
    Set myFolder = myShell.BrowseForFolder( _
        0&, "写真読込フォルダを選択してください。" _
        , BIF_RETURNONLYFSDIRS Or BIF_EDITBOX)
    If myFolder Is Nothing Then SFolda = "": Exit Sub
    
        MsgBox myFolder.Self.Path
    
    SFolda = myFolder.Self.Path
   
    Set myFolder = Nothing
    Set myShell = Nothing
End Sub
--------------------------------------------------------------------------------
[書込み場所設定]ボタンクリックで書込み先のディレクトリー
を設定するサブルーチン。

Sub パス設定W()
    '----------------------------------------------------
    ' パス設定
    '----------------------------------------------------
   
    フォルダ参照W SFolda
          
    If SFolda = "" Then Exit Sub    <---- フォルダの設定が無いときには、
                                                          強制終了にします。
 書込み先のフォルダのパスを「マクロの表紙」のセル位置(3, 1)を書込みます。
    Workbooks(AAname).Worksheets(CCname).Cells(3, 1).Value = SFolda
End Sub
--------------------------------------------------------------------------------
[写真読込場所設定]ボタンクリックで写真読込先のディレクトリーを
設定するサブルーチン。

Sub パス設定R()
    '----------------------------------------------------
    ' パス設定
    '----------------------------------------------------
   
    フォルダ参照R SFolda
          
    If SFolda = "" Then Exit Sub    <---- フォルダの設定が無いときには、
                                                      強制終了にします。
    写真読込先のフォルダのパスを「マクロの表紙」の
    セル位置(4, 1)を書込みます。
    Workbooks(AAname).Worksheets(CCname).Cells(4, 1).Value = SFolda
End Sub
--------------------------------------------------------------------------------
写真の選択・貼付を実行するサブルーチン 2019.02.05 貼付け方法変更

Sub S写真選択(mm As Variant)
    Dim fn As String
    Dim F_array As Variant
    Dim A_cnt, C_cnt, L_cnt As Integer
    Dim Filename, Photname As String
    Dim objShape As Shape

    On Error GoTo S写真選択0:        <---- ディレクトリの設定で、エラーが
                             発生したら強制的に貼り付け写真選択へジャンプさせる。
    ユーザーフォームのオプションボタンのON(true)状態によって、
    「マクロの表紙」の参照するセル位置を変える。

    If Form2.CheckBox1 = False Then        <---- 選択したセルへの貼付か?

        With Form2
           If .OB1 = True Then x2 = 2: y2 = 16
           If .OB2 = True Then x2 = 3: y2 = 16
           If .OB3 = True Then x2 = 4: y2 = 16
        End With
        写真を貼付けるセル位置データを取得する。
        ' 写真貼付位置取得
        y = Workbooks(AAname).Sheets(CCname).Cells(y2, x2).Value
        x = Workbooks(AAname).Sheets(CCname).Cells(y2 + 1, x2).Value
        ActiveSheet.Cells(y, x).Select      <---- 指定されたセルを選択する。

    End If
    写真データの保存先パス
    ADir = Workbooks(AAname).Worksheets(CCname).Cells(4, 1).Value
    
    If ADir <> "" Then
         If Left(ADir, 2) = "\\" Then
	     ' ネットワークドライブの参照
             Call SetCurrentDirectory(ADir)  <---- ネットワークドライブの参照
         Else
             ChDrive Left(ADir, 2)           <---- PC内ドライブの参照
             ChDir ADir
         End If
    End If
    ' 写真一覧のダイヤログを表示し、写真を選択させる。
    myFname = Application.GetOpenFilename("画像ファイル(*.JPG;
                              *.BMP;*.GIF;*.WMF),*.JPG;*.BMP;*.GIF;*.WMF")
    キャンセルの時・写真が選択されなかったときは強制終了する。
    If myFname = False Then mm = 0: Exit Sub         <-- 未選択時の処理
    If VarType(myFname) = vbBoolean Then _
                                         mm = 0: Exit Sub  <-- キャンセルの時の処理
        '
    '-----------------------------------------------------------------------
    ' 次読込の為のパスを記録する。
        C_cnt = Len(myFname)              ' 選択した写真のフルパス文字数
        F_array = Split(myFname, "\")     ' \ で分割して 配列 F_array に代入
        A_cnt = UBound(F_array)           ' 現在の大きさ(要素数)を調べます
        CCC = F_array(A_cnt)              ' 最後配列に写真名がある
        L_cnt = Len(CCC) + 1              ' 写真名の文字数 + \ の分
        
        ' 読込側のパス設定( \写真名 分を取る処理 )
        Workbooks(AAname).Worksheets(CCname).Cells(4, 1).Value = _
        Left(myFname, C_cnt - L_cnt)
    
        '------------------------------------------------------------------------
        ' 2019.02.05 写真貼り付け方法を改良( 簡素化出来ました )
        ' 下記マクロが、アクティブセルに張り付く事に注目しました。
        ' Left:=Selection.Left, Top:=Selection.Top でアクティブセルに貼付
        ' width:=Yoko, height:=Tate で貼付サイズ指定
        '------------------------------------------------------------------------
        With Selection
               Yoko = .width    ' * 0.75   ' ピクセル単位
               Tate = .height   ' * 0.118  ' ピクセル単位
        End With

        If mm > 0 Then
        '--------------- そのまま張付ける時の処理--------------------------------
        Set objShape = ActiveSheet.Shapes.AddPicture( _
            filename:=myFname, _       <----  挿入する写真ファイル名を
                                              > パス付きで指定
            LinkToFile:=False, _       <----  False で独立した写真としての指定
                                              True で元のファイルとのリンクを設定
            SaveWithDocument:=True, _  <----  True で Excelファイルと
                                 共に保存  False でリンク情報だけを保存
            Left:=Selection.Left, _    <----  アクティブセルの左端位置を指定
            Top:=Selection.Top, _      <----  アクティブセルの上端位置を指定
            Width:=yoko, _             <----  張付け写真の横幅を指定
            Height:=tate)              <----  張付け写真の高さを指定
            
            写真表面に文字・図形が描けるように、表示順序を最背面にする。
        width:=Yoko, height:=Tate)
        '-------------------------------------------------------------------------
        Else
        '---------------  90°回転する時の処理------------------------------------
        Set objShape = ActiveSheet.Shapes.AddPicture( _
            Filename:=myFname, _
            LinkToFile:=False, _
            SaveWithDocument:=True, _
            Left:=Selection.Left - Tate / 2 + Yoko / 2, _ <-- 90°回転を考慮
                                                      して貼付け位置を補正しています。
            Top:=Selection.Top + Tate / 2 - Yoko / 2, _ <-- 90°回転を考慮
                                                       して貼付け位置を補正しています。
            width:=Tate, height:=Yoko)
    補正値の計算方法については、[Excel 2007・2010・2013 
    対応マクロの勉強室 ]の [1. 写真の貼付けをする]で詳しく解説しています。
         With objShape
            ' 写真の回転は、センターを基準にして回転するので
            ' その分張付けるときに補正をして貼付回転をする。
            ' 用紙からはみ出すと移動しないので考慮が必要。
            '
            .Rotation = 90
        End With
        '-------------------------------------------------------------------------

        End If
            objShape.ZOrder msoSendToBack  <----  張付けた写真の上に
                      文字・線等が書けるように、写真の表示順序を最背面にします。
  Exit Sub

    エラー時の処理
S写真選択0:
    M = Err.Number
    If M = 75 Then _
              MsgBox ("設定されているフォルダのパス名は、無効です。")
    If M = 76 Then _
              MsgBox ("設定されているフォルダのパス名は、間違っています。")
End Sub
--------------------------------------------------------------------------------
ドラックされたセルに指定された文字列(変数 : 文字)を書き込むサブルーチン
Sub S繰返(文字 As String)
    ドラック範囲を取得する。
    With ActiveWindow.RangeSelection
        y1 = .Columns.Column
        y2 = .Columns(.Columns.Count).Column
        x1 = .Rows.Row
        x2 = .Rows(.Rows.Count).Row
    End With
    ドラック範囲に変数 : 文字の内容を書き込む。
    With ActiveSheet
    x = x2 - x1: y = y2 - y1
    If x = 0 And y = 0 Then
         .Cells(x1, y1) = 文字            <---- セル一箇所に書き込む。
    ElseIf x = 0 And y > 0 Then
        For I = 0 To y
         .Cells(x1, y1 + I) = 文字        <---- 横方向のセルだけに書き込む。
        Next I
    ElseIf x > 0 And y = 0 Then
        For I = 0 To x
        .Cells(x1 + I, y1) = 文字         <---- 縦方向のセルだけに書き込む。
        Next I
    ElseIf x > 0 And y > 0 Then
        For I = 0 To x
         For II = 0 To y
           .Cells(x1 + I, y1 + II) = 文字 <---- 縦横方向のドラックされたセルに
         Next II                                           書き込む。
        Next I
    End If
    End With
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
        mm = ActiveSheet.Name
        SS = Len(mm): BBB = Left(mm, SS - 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
--------------------------------------------------------------------------------
選択された図形位置・サイズを表示するサブルーチン
Sub 図形位置サイズ()
'
Dim x1, y1 As Single
Dim x2, y2 As Single
With Selection
    x1 = .Left
    y1 = .Top
    x2 = .Width
    y2 = .Height
End With

  MsgBox " 左 " + Format(x1, "#,##0") + " 上 " + Format(y1, "#,##0") _
    + "  横幅 " + Format(x2, "#,##0") + " 縦幅 " + Format(y2, "#,##0")
    
End Sub
--------------------------------------------------------------------------------
(おまけ)Excelを開くダイヤログを表示し、
選択されたファイルを開くサブルーチン
Sub EXCELファイル読込()
 Application.DisplayAlerts = False
 myFname = _
     Application.GetOpenFilename("EXCELファイル(*.xlsx),*.xlsx")
 '
 Workbooks.Open Filename:=myFname
 Application.DisplayAlerts = True
End Sub
--------------------------------------------------------------------------------
(おまけ)指定されたセル位置に、赤○を書き込むサブルーチン
Sub 丸描き()
'
    Dim x1, y1, N, Msize, MXsize, Wsize, Ssize, Xsize, Ysize As Single
    Dim SS, name1, name2 As String
    On Error GoTo 丸描き1end:
    With Selection
        x1 = .Left
        y1 = .Top
    End With
'          ○を描きます
    ActiveSheet.Shapes.AddShape(msoShapeOval, x1, y1, 24.8, 24.8). _
        Select
    Selection.ShapeRange.Fill.Visible = _
                            msoTrue              <--- これは、入れてください
    ' パターンなどが入っていない種類の塗りつぶしのこと
    Selection.ShapeRange.Fill.Solid 
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = _
                                           65     <--- 塗りつぶし前景色65:無地
    Selection.ShapeRange.Fill.Transparency = _
                                         1# <--- 塗りつぶし透明度 0(不透明)〜1(透明)
    Selection.ShapeRange.Line.Weight = _
                             1#                    <--- 線の太さ
    Selection.ShapeRange.Line.DashStyle = _
                                msoLineSolid       <--- 線の種類 : 実線
    Selection.ShapeRange.Line.Style = _
                            msoLineSingle          <--- 実線の種類 : 一本線
    Selection.ShapeRange.Line.Transparency = _
                                             0#    <--- 線の透明度 0(不透明) 〜 1(透明)
    Selection.ShapeRange.Line.Visible = _
                              msoTrue              <--- これは、入れてください
    Selection.ShapeRange.Line.ForeColor.SchemeColor = _
                                            10     <--- 線の色 : 赤指定
    Selection.ShapeRange.Line.BackColor.RGB = _
                               RGB(255, 255, 255)  <---- 線の背景色 : 白
丸描き1end:
End Sub

--------------------------------------------------------------------------------
張付けた写真のサイズ・位置等の変更を禁止するサブルーチン
Sub 写真変更禁止(Lock_Hani As Variant)
    Dim Abc As Single
    ' いきなり実行するのではなく、確認をしてから実行します。
    Abc = MsgBox("このページの写真変更禁止を設定します。", _
                                      vbYesNo, "写真変更禁止確認")
    If Abc = vbNo Then Exit Sub  <---- Noの時終了

    '---------------------------------------------------------------------

    ActiveSheet.Unprotect     <-- 一度シート保護を解除します。

    Cells.Select             <-- シート全体を選択します。
    Selection.Locked = _
                 False      <-- シート全体のセルの保護ロックフラグをOFFする
    ' Lock_Hani で定義されたセル範囲を保護する。
    ' 写真を張付けたセル範囲を選択します。
    Range(Lock_Hani).Select 
    Selection.Locked = _
                 True       <---- 選択されたのセルの保護ロックフラグをONする
    ActiveSheet.Protect userinterfaceonly:= _
                True        <---- マクロからの書換は、可能にする

    Range("A1").Select          <-- セル選択の解除
    MsgBox ("写真変更禁止完了") <-- 終了メッセージ
End Sub

TOPへ戻る