2020年6月2日火曜日

Excel Word PowerPoint (VBA) アドレスコピー マクロ

アドレスコピーマクロを作ってみました。以下詳細

●機能
開いているExcel,Word,Powerpointのアドレスをクリップボードに格納する


●用途
NAS等のネットワークドライブに保管している共同作業ファイルのメールによるアドレス送付
現在開いているファイルの保存先フォルダ確認に使用


●設定方法
Excel,Wordでは個人用マクロに登録後、ショートカットを設定することで使用する
Powerpointではマクロにショートカットを割り当てることができないためアドインを使用する
Powerpointのアドインは一番上のクイックアクセスツールバーを利用すると便利です
個人用マクロの設定とアドインの設定は以下を参照ください
↓個人用マクロ設定方法＆アドイン設定方法↓
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1160241916


●挙動詳細
1.5sec以内にショートカットキーを押した回数に応じてクリップボードの中身を変化させる

1回→Outlookでのハイパーリンク作成用の文字列を格納
【クリップボードの中身例】<C:\Users\Administrator\Desktop\test.xlsx>
※Outlookでは<>で囲まれたアドレスの後ろで改行（Enterを押す）を行うことによって自動でハイパーリンクを挿入する機能がある。

2回→アドレスをコピー
【クリップボードの中身例】C:\Users\Administrator\Desktop\test.xlsx

3回以上→ファイルの場所をコピー
【クリップボードの中身例】C:\Users\Administrator\Desktop


●マクロ
【Excel用マクロ】
Sub AddressCopy()
    '自分自身のアドレスをクリップボードに格納する
    '※下記の文字化け対策用サブルーチンを使用

    Static num As Integer
    Static previousTime As Single

    '初期化されていない場合は現在時刻を入力して初期化
    If previousTime = 0 Then
        previousTime = Timer
    End If

    '入力時間1.5sec以上でカウントをリセット
    If Timer - previousTime > 1.5 Then
        num = 0
        previousTime = Timer
    End If

    '指定秒数以内の実行回数(ショートカットの投下回数)に応じてコピー内容を変更
    If num = 0 Then '1回実行
        SetCB ("<" + ActiveWorkbook.FullName + ">") 'Outlookのハイパーリンク用
    ElseIf num = 1 Then '2回実行
        SetCB (ActiveWorkbook.FullName) 'ファイル名込みのアドレス
    ElseIf num >= 2 Then '3回以上実行
        SetCB (ActiveWorkbook.Path) 'ファイル名抜きのアドレス
    End If

    num = num + 1

End Sub
Sub SetCB(ByVal str As String)
    '引数をクリップボードに格納 ※文字化け対策のためテキストボックス経由でコビー

    With CreateObject("Forms.TextBox.1") 'ActiveXコントロールのテキストボックスを生成。親を指定していないのためメモリ上に生成。
        .MultiLine = True                'テキストボックスへの複数行入力を許可
        .Text = str                      '引数(str)で渡された文字列を入力
        .SelStart = 0                    'テキストボックスのテキストを全選択（スタート位置指定）
        .SelLength = .TextLength         'テキストボックスのテキストを全選択（エンド位置指定）
        .Copy                            'クリップボードに文字列を格納
    End With
End Sub

【Word用マクロ】
Sub AddressCopy()
    '自分自身のアドレスをクリップボードに格納する
    '※下記の文字化け対策用サブルーチンを使用

    Static num As Integer
    Static previousTime As Single

    '初期化されていない場合は現在時刻を入力して初期化
    If previousTime = 0 Then
        previousTime = Timer
    End If

    '入力時間1.5sec以上でカウントをリセット
    If Timer - previousTime > 1.5 Then
        num = 0
        previousTime = Timer
    End If

    '指定秒数以内の実行回数(ショートカットの投下回数)に応じてコピー内容を変更
    If num = 0 Then '1回実行
        SetCB ("<" + ActiveDocument.FullName + ">") 'Outlookのハイパーリンク用
    ElseIf num = 1 Then '2回実行
        SetCB (ActiveDocument.FullName) 'ファイル名込みのアドレス
    ElseIf num >= 2 Then '3回以上実行
        SetCB (ActiveDocument.Path) 'ファイル名抜きのアドレス
    End If

    num = num + 1

End Sub
Sub SetCB(ByVal str As String)
    '引数をクリップボードに格納 ※文字化け対策のためテキストボックス経由でコビー

    With CreateObject("Forms.TextBox.1") 'ActiveXコントロールのテキストボックスを生成。親を指定していないのためメモリ上に生成。
        .MultiLine = True                'テキストボックスへの複数行入力を許可
        .Text = str                      '引数(str)で渡された文字列を入力
        .SelStart = 0                    'テキストボックスのテキストを全選択（スタート位置指定）
        .SelLength = .TextLength         'テキストボックスのテキストを全選択（エンド位置指定）
        .Copy                            'クリップボードに文字列を格納
    End With
End Sub

【Powerpoint用マクロ】
Sub Auto_Open()
    'マクロを登録※アドインへの表示に必要
    Dim CBC As CommandBarControl
    Set CBC = Application.CommandBars("Tools").Controls.Add(Type:=msoControlButton)
    CBC.Caption = "AddressCopy"
    CBC.OnAction = "AddressCopy"
End Sub
Sub Auto_Close()
    'マクロの登録解除※アドインへの表示解除に必要
    Dim CBC As CommandBarControl
    For Each CBC In Application.CommandBars("Tools").Controls
        If CBC.Caption = "AddressCopy" Then CBC.Delete
    Next
End Sub
Sub AddressCopy()
    '自分自身のアドレスをクリップボードに格納する
    '※下記の文字化け対策用サブルーチンを使用

    Static num As Integer
    Static previousTime As Single

    '初期化されていない場合は現在時刻を入力して初期化
    If previousTime = 0 Then
        previousTime = Timer
    End If

    '入力時間1.5sec以上でカウントをリセット
    If Timer - previousTime > 1.5 Then
        num = 0
        previousTime = Timer
    End If

    '指定秒数以内の実行回数(ショートカットの投下回数)に応じてコピー内容を変更
    If num = 0 Then '1回実行
        SetCB ("<" + ActivePresentation.FullName + ">") 'Outlookのハイパーリンク用
    ElseIf num = 1 Then '2回実行
        SetCB (ActivePresentation.FullName) 'ファイル名込みのアドレス
    ElseIf num >= 2 Then '3回以上実行
        SetCB (ActivePresentation.Path) 'ファイル名抜きのアドレス
    End If

    num = num + 1

End Sub
Sub SetCB(ByVal str As String)
    '引数をクリップボードに格納 ※文字化け対策のためテキストボックス経由でコビー

    With CreateObject("Forms.TextBox.1") 'ActiveXコントロールのテキストボックスを生成。親を指定していないのためメモリ上に生成。
        .MultiLine = True                'テキストボックスへの複数行入力を許可
        .Text = str                      '引数(str)で渡された文字列を入力
        .SelStart = 0                    'テキストボックスのテキストを全選択（スタート位置指定）
        .SelLength = .TextLength         'テキストボックスのテキストを全選択（エンド位置指定）
        .Copy                            'クリップボードに文字列を格納
    End With
End Sub


●参考文献
Powerpointアドイン登録方法：
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1160241916

クリップボード文字化け対策：
https://teratail.com/questions/203287


0 件のコメント:

コメントを投稿

登録: コメントの投稿 (Atom)