カテゴリー: ＶＢＡ

Shell "outlook.exe", vbMinimizedNoFocus

Shell ""C:￥Program Files (x86)￥Microsoft Office￥root￥Office16￥OUTLOOK.EXE"OUTLOOK.EXE", vbNormalFocus
AppActivate "Outlook"
SendKeys "% n", True

Private Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Const KEYEVENTF_KEYUP = &H2
Private Const VK_LWIN = &H5B

Public Sub window_saisyouka()
  keybd_event VK_LWIN, 0, 0, 0
  keybd_event vbKeyDown, 0, 0, 0
  keybd_event VK_LWIN, 0, KEYEVENTF_KEYUP, 0
  keybd_event vbKeyDown, 0, KEYEVENTF_KEYUP, 0
End Sub

 CreateObject("WScript.Shell").Run "C:\Users\mabo-2021\Desktop\Outlook"

Public WithEvents mySentItems As Outlook.Items

Option Explicit

Public myOutlookApp As Outlook.Application
Public mySentFolder As Outlook.Folder
Public WithEvents mySentItems As Outlook.Items

Private Sub Class_Initialize()
    Set myOutlookApp = Nothing    'objoutlookの初期値これがないとGetObjectに失敗するとobjoutlookはemptyのまま
    
    On Error Resume Next
        Set myOutlookApp = GetObject(, "Outlook.Application")     '起動済みのOutlookをクラス名を指定して取得
    On Error GoTo 0

    If myOutlookApp Is Nothing Then                               'objoutlookがNothingなら
        Set myOutlookApp = CreateObject("Outlook.Application")    'Outlookを起動
    End If

    Dim oNS As Namespace
    Set oNS = myOutlookApp.GetNamespace("MAPI")
    Set mySentFolder = oNS.GetDefaultFolder(olFolderSentMail)
    Set mySentItems = mySentFolder.Items

End Sub
Public Sub AddTrackInfo(ByVal objMail As MailItem, iRow As Integer, iCol As Integer)
     Dim olkApp As Outlook.Application
     Dim fldSentMail As Folder
     Dim strTrackInfo As String
     Dim propTrack As UserProperty

     ' 送信済みアイテム フォルダーを取得
     Set fldSentMail = objMail.Application.Session.GetDefaultFolder(olFolderSentMail)

     ' mySentItems が設定されていなければ送信済みアイテム フォルダーの Items を設定
     If mySentItems Is Nothing Then
         Set mySentItems = fldSentMail.Items
     End If


     ' メールに送信後の保存先フォルダーを設定

     Set objMail.SaveSentMessageFolder = fldSentMail


     ' 送信状況を追跡するためのプロパティを設定
     Set propTrack = objMail.UserProperties.Add("TrackInfo", olText, True)

     ' 送信日時を保存するセルの行番号と列番号を設定
     propTrack.Value = iRow & "," & iCol
     
End Sub


' 送信済みアイテム フォルダーにアイテムが追加されたときに実行されるイベント
Public Sub mySentItems_ItemAdd(ByVal Item As Object)
     Dim objMail As MailItem
     Dim propTrack As UserProperty
     Set objMail = Item
     ' 送信状況を追跡するプロパティの確認
     Set propTrack = objMail.UserProperties.Find("TrackInfo")

     ' プロパティが存在したら
     If Not propTrack Is Nothing Then
         Dim arrRC As Variant
         ' 送信日時を保存するセルの行番号と列番号を取得
         arrRC = Split(propTrack.Value, ",")
         ' 取得した行、列のセルに送信日時を保存
         Sheet1.Cells(CInt(arrRC(0)), CInt(arrRC(1))).Value = objMail.SentOn
     End If
End Sub

Public Function Mail_Sousin()
　　　　　　　　▼
		詳細設定略
　　　　　　　　▲　
           
                Dim clsSample1 As Class1 'Class1型のオブジェクト変数を宣言　「Class1」はクラスモジュール名
                Set clsSample1 = New Class1
    
                Call clsSample1.AddTrackInfo(objItem, 4, 9)　'objItemは，送信するメール本体4，9はRange(4,9)で
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　送信日時を記録すすセル
                           
                If jidou_sousin_flag = False Then
                    objItem.Display  '送信画面を表示
                End If
                If jidou_sousin_flag = True Then
                    objItem.Send    '自動で送信
                End If

              UserForm1.Show

               Set olkApp = Nothing
               Set objItem = Nothing
               Set acctToSend = Nothing

End Function

                Dim clsSample1 As Class1 'Class1型のオブジェクト変数を宣言　「Class1」はクラスモジュール名
                Set clsSample1 = New Class1
    
                Call clsSample1.AddTrackInfo(objItem, 4, 9)

 Private Sub ApplyConditionalFormatting()
     Dim ws As Worksheet
     Dim rng As Range
     
     ' シートと範囲を設定
     Set ws = ThisWorkbook.Sheets("Sheet1") ' シート名を適切に変更してください
     Set rng = ws.Range("A1:A100") ' 範囲を適切に変更してください
     
     ' 既存の条件付き書式をクリア
     rng.FormatConditions.Delete
     
     ' 新しい条件付き書式を追加
     With rng.FormatConditions.Add(Type:=xlExpression, Formula1:="=ROW()=CELL(""row"")")
         .Interior.Color = RGB(255, 255, 0) ' 背景色を黄色に設定
     End With
 End Sub

Private Sub CommandButton3_Click()
    'OPENしたBOOKのSHEET1に　”macro.txt”　のプロしィージャを書き込む
    Dim wb As Workbook
    
    fTyp = "Excelファイル(*.xlsm),*.xlsm,Excelファイル(*.xlsx),*.xlsx,Excelファイル(*.xls),*.xls"
    prompt = "Excelファイルを選択してください"
    fPath = Application.GetOpenFilename(fTyp, , prompt)
    
    Set wb = Workbooks.Open(fPath, UpdateLinks:=Ture, ReadOnly:=Ture)
    
    With wb.VBProject.VBComponents("Sheet1").CodeModule
        .AddFromFile "C:\Users\mabo-2021\Desktop\****\*****\*****\*****\macro.txt"
    End With
    
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 Application.ScreenUpdating = True
End Sub

 '読み込んだファイル名でブックを開く
    Set wb = Workbooks.Open(fPath, UpdateLinks:=Ture, ReadOnly:=Ture)
    Set Taisyou_Sheet = wb.Worksheets("受付名簿")
    
    '対象シートに条件付き書式を設定
    Taisyou_Sheet.Cells.FormatConditions.Delete
    Range(Taisyou_Sheet.Cells(4, 2), Taisyou_Sheet.Cells(101, 14)).FormatConditions.Add(Type:=xlExpression, Formula1:="=CELL(""COL"")=COLUMN()").Interior.Color = rgbPowderBlue

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 Application.ScreenUpdating = True
End Sub