Blog

クリックマクロコード

—

by

phg51672
in 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'★★★セルをダブルクリックした時に動作するマクロ

If Range("A1").Value = 1 Then ' セルA1の値が1の場合のみ処理を実行する
    Cancel = True   ' イベントをキャンセルして、元々のセルの編集を防止
    Dim txtBox As Object ' ActiveXコントロールのTextBoxを格納するための変数
    Set txtBox = ActiveSheet.OLEObjects("TextBox1").Object
    txtBox.text = txtBox.text & Target.Value & ", " ' テキストボックスに新しい文字列を設定
End If
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
'★★★セルを右クリックした時に動作するマクロ

If Range("A1").Value = 1 Then ' セルA1の値が1の場合のみ処理を実行する
    Cancel = True   ' イベントをキャンセルして、元々のセルの編集を防止
    Dim txtBox As Object ' ActiveXコントロールのTextBoxを格納するための変数
    Set txtBox = ActiveSheet.OLEObjects("TextBox2").Object
    txtBox.text = txtBox.text & Target.Value & ", " ' テキストボックスに新しい文字列を設定
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'★★★選択セルが変更された時に動作するマクロ
If Target.Column = 3 Then  ' 選択されたセルが指定の列の場合の処理をここに追加する
    ActiveWindow.ScrollRow = Target.Row
End If
End Sub
Sub 機能切替()
Dim textBox As Shape
Set textBox = ActiveSheet.Shapes("機能トグルボタン")    ' テキストボックスを取得
    If Range("A1").Value = 1 Then
        Range("A1").ClearContents ' A1が1の場合、空白にする
        textBox.TextFrame.Characters.text = "機能OFF"  ' テキストボックス内のテキストを取得
    Else
        Range("A1").Value = 1 ' A1が1でない場合、1にする
        textBox.TextFrame.Characters.text = "機能ON"  ' テキストボックス内のテキストを取得
    End If
End Sub
Sub テキストボックス文字列クリア()
    ActiveSheet.OLEObjects("TextBox1").Object.text = ""
    ActiveSheet.OLEObjects("TextBox2").Object.text = ""
End Sub
Sub テキストボックス文字列をクリップボードへ()

    Dim txtBox1 As Object ' TextBox1を格納するための変数
    Dim txtBox2 As Object ' TextBox2を格納するための変数
    
    ' TextBox2の内容をクリップボードへコピー
    Set txtBox2 = ActiveSheet.OLEObjects("TextBox2").Object
    With CreateObject("Forms.TextBox.1")
        .MultiLine = True
        .text = txtBox2.text
        .SelStart = 0
        .SelLength = .TextLength
        .copy
    End With
    
    Application.Wait Now + TimeValue("0:00:01")
    
    ' TextBox1の内容をクリップボードへコピー
    Set txtBox1 = ActiveSheet.OLEObjects("TextBox1").Object
    With CreateObject("Forms.TextBox.1")
        .MultiLine = True
        .text = txtBox1.text
        .SelStart = 0
        .SelLength = .TextLength
        .copy
    End With

End Sub
Sub オートフィル切替()
    ' 現在のオートフィル有効無効を確認して切り替える
    If Application.CellDragAndDrop = True Then
        Application.CellDragAndDrop = False
        ActiveSheet.Shapes("オートフィルトグルボタン").TextFrame.Characters.text = "オートフィル OFF"
    Else
        Application.CellDragAndDrop = True
        ActiveSheet.Shapes("オートフィルトグルボタン").TextFrame.Characters.text = "オートフィル ON"

    End If
End Sub


**********************
Option Explicit

Public olApp As Object
Public olInspector As Object
Public olMailItem As Object
Public 判定結果 As String

Sub 宛先に追加()

判定結果 = アイテム判定()
Debug.Print 判定結果
'**********アイテム判定_必要あれば新規メール作成****************
If Not 判定結果 = "メールアイテム_編集中" Then
    MsgBox "編集中メールが確認できないため、新規メールで作成します。"
    Set olApp = CreateObject("Outlook.Application")
    Set olMailItem = olApp.CreateItem(0)            ' 新規メールを作成、0はolMailItemを表します
    判定結果 = "メールアイテム_編集中"
End If

If 判定結果 = "メールアイテム_編集中" Then
    olMailItem.To = olMailItem.To & "," & ActiveSheet.OLEObjects("TextBox1").Object.text
    olMailItem.CC = olMailItem.CC & "," & ActiveSheet.OLEObjects("TextBox2").Object.text
Else
    MsgBox "予期しないエラー。終了します"
    Exit Sub
End If

'****************終了処理**************************
Application.Wait [Now()] + 1# / 86400
olMailItem.Display ' メールアイテムを更新

End Sub

Function アイテム判定()
'■現在のOutlookアイテムを判定する関数■

On Error GoTo アイテム無し 'エラー処理が発生する場合はアイテムなしと判定
    Set olApp = GetObject(, "Outlook.Application")
    Set olInspector = olApp.ActiveInspector
    Set olMailItem = olInspector.CurrentItem

If Not olMailItem.Class = 43 Then '43はMailItemのClassを表す。
    アイテム判定 = "メールアイテム以外"
Else
If olMailItem.Parent = "Draft" Or olMailItem.Parent = "送信トレイ" Then
    アイテム判定 = "メールアイテム_編集中"
Else
    アイテム判定 = "メールアイテム_編集中以外"
End If
End If
GoTo 判定終了

'****************ラベル処理**************************
アイテム無し:
    アイテム判定 = "アイテム無し"

'****************ラベル処理**************************
判定終了:
    On Error GoTo 0
End Function



********************************
通常テキストボックス版

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'★★★選択セルが変更された時に動作するマクロ
If Target.Column = 3 Then  ' 選択されたセルが指定の列の場合の処理をここに追加する
    ActiveWindow.ScrollRow = Target.Row
End If
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'★★★ダブルクリックした時に動作するマクロ
    
If Range("A1").Value = 1 Then ' セルA1の値が1の場合のみ処理を実行する
    Cancel = True   ' イベントをキャンセルして、元々のセルの編集を防止
        
    ' テキストボックスに新しい文字列を追加
    ActiveSheet.Shapes("宛先ボックス").TextFrame.Characters.Text = _
        ActiveSheet.Shapes("宛先ボックス").TextFrame.Characters.Text & Target.Value & "; " & vbCrLf
End If
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
'★★★右クリックした時に動作するマクロ

If Not Range("A1").Value = 1 Then Exit Sub ' セルA1の値が1の場合のみ処理を実行する
    
Cancel = True   ' イベントをキャンセルして、元々のセルの編集を防止
  
Dim 文字列 As String
Dim セル As Range

For Each セル In Target
    文字列 = 文字列 & セル.Value & "; " & vbCrLf
Next セル
    
' 選択範囲が1つのセルの場合
If Selection.Cells.Count = 1 Then
    ActiveSheet.Shapes("CCボックス").TextFrame.Characters.Text = _
        ActiveSheet.Shapes("CCボックス").TextFrame.Characters.Text & 文字列
    Exit Sub
End If
    
If Selection.Cells.Count > 1 Then
Dim 結果 As VbMsgBoxResult
結果 = MsgBox("はい      ⇒ 宛先に追加" & vbCrLf & "いいえ    ⇒ CCに追加" & vbCrLf & "キャンセル", Buttons:=vbYesNoCancel)
    If 結果 = vbYes Then
        ActiveSheet.Shapes("宛先ボックス").TextFrame.Characters.Text = _
         ActiveSheet.Shapes("宛先ボックス").TextFrame.Characters.Text & 文字列
    ElseIf 結果 = vbNo Then
        ActiveSheet.Shapes("CCボックス").TextFrame.Characters.Text = _
         ActiveSheet.Shapes("CCボックス").TextFrame.Characters.Text & 文字列
    Else
    
    End If
End If

End Sub
Sub テキストボックス文字列クリア()
    ActiveSheet.Shapes("宛先ボックス").TextFrame.Characters.Text = ""
    ActiveSheet.Shapes("CCボックス").TextFrame.Characters.Text = ""
End Sub
Sub テキストボックス文字列をクリップボードへ()

    ' TextBox2の内容をクリップボードへコピー
    With CreateObject("Forms.TextBox.1")
        .MultiLine = True
        .Text = ActiveSheet.Shapes("CCボックス").TextFrame.Characters.Text
        .SelStart = 0
        .SelLength = .TextLength
        .copy
    End With
    
    Application.Wait Now + TimeValue("0:00:01")
    
    ' TextBox1の内容をクリップボードへコピー
    With CreateObject("Forms.TextBox.1")
        .MultiLine = True
        .Text = ActiveSheet.Shapes("宛先ボックス").TextFrame.Characters.Text
        .SelStart = 0
        .SelLength = .TextLength
        .copy
    End With
End Sub
Sub TOP_メール作成()

判定結果 = アイテム判定()
Debug.Print 判定結果
'**********アイテム判定_必要あれば新規メール作成****************
If Not 判定結果 = "メールアイテム_編集中" Then
    MsgBox "編集中メールが確認できないため、新規メールで作成します。"
    Set olApp = CreateObject("Outlook.Application")
    Set olMailItem = olApp.CreateItem(0)            ' 新規メールを作成、0はolMailItemを表します
    判定結果 = "メールアイテム_編集中"
End If

If 判定結果 = "メールアイテム_編集中" Then
    olMailItem.To = olMailItem.To & ";" & ActiveSheet.Shapes("宛先ボックス").TextFrame.Characters.Text
    olMailItem.CC = olMailItem.CC & ";" & ActiveSheet.Shapes("CCボックス").TextFrame.Characters.Text
Else
    MsgBox "予期しないエラー。終了します"
    Exit Sub
End If
'****************終了処理**************************
Application.Wait [Now()] + 1# / 86400
olMailItem.Display ' メールアイテムを更新

End Sub
Sub 機能切替()
Dim textBox As Shape
Set textBox = ActiveSheet.Shapes("機能トグルボタン")    ' テキストボックスを取得
    If Range("A1").Value = 1 Then
        Range("A1").ClearContents ' A1が1の場合、空白にする
        textBox.TextFrame.Characters.Text = "機能OFF"  ' テキストボックス内のテキストを取得
    Else
        Range("A1").Value = 1 ' A1が1でない場合、1にする
        textBox.TextFrame.Characters.Text = "機能ON"  ' テキストボックス内のテキストを取得
    End If
End Sub
Sub オートフィル切替()
    ' 現在のオートフィル有効無効を確認して切り替える
    If Application.CellDragAndDrop = True Then
        Application.CellDragAndDrop = False
        ActiveSheet.Shapes("オートフィルトグルボタン").TextFrame.Characters.Text = "オートフィル OFF"
    Else
        Application.CellDragAndDrop = True
        ActiveSheet.Shapes("オートフィルトグルボタン").TextFrame.Characters.Text = "オートフィル ON"
    End If
End Sub

Sub 選択範囲をクリップボードに()
    Dim 選択範囲 As Range
    Dim cell As Range
    Dim 文字列 As String

' ①選択範囲を取得
    Set 選択範囲 = Selection
    
' ②選択範囲内の各セルの文字列を結合
    For Each cell In 選択範囲
        文字列 = 文字列 & cell.Value & vbCrLf
    Next cell
    
' ③結果をクリップボードにコピー
    With New MSForms.DataObject
        .SetText 文字列
        .PutInClipboard
    End With
End Sub

コメント

コメントを残す

メールアドレスが公開されることはありません。 ※ が付いている欄は必須項目です