[新]パソコン忘備録
[新]パソコン忘備録

職場向けVBA

本項は書きかけの記事です。正確な情報は公式サイト、公式ドキュメント、記載の参照サイトでご確認ください。
OSS(OpenSourceSoftware)を利用しています。使用期限や保守、公開期間の確約がないことに留意してください。

目次

+ 読む


よく使うマクロ

Common

  • オブジェクト一括削除
  • 非表示行の一括表示
  • 描画オブジェクト、表、テキストボックスの一括縮小
  • シェイプ画像の一括圧縮

  • 関数
　　log4timestamp("文字列")


汎用処理

+ 読む 
'CommonLibrary
 
 
'オブジェクト一括削除
'todo: functionの引数を変えても変わらないバグ
 
 
Sub deleteAllObjects()
    Dim obj As Object
    Dim ws As Worksheet
    Dim hyperlink As hyperlink
'    Dim description As String
 
    Set ws = ActiveSheet
 
    For Each obj In ActiveSheet.Shapes
        obj.Delete
        log4timestamp ("Shapes")
    Next obj
 
    For Each obj In ActiveSheet.ChartObjects
        obj.Delete
        log4timestamp ("ChartObjects")
    Next obj
 
    For Each obj In ActiveSheet.OLEObjects
        obj.Delete
        log4timestamp ("OLEObjects")
    Next obj
 
    For Each obj In ActiveSheet.Buttons
        obj.Delete
        log4timestamp ("Buttons")
    Next obj
 
    For Each obj In ActiveSheet.ListBoxes
        obj.Delete
        log4timestamp ("ListBoxes")
    Next obj
 
    For Each obj In ActiveSheet.CheckBoxes
        obj.Delete
        log4timestamp ("CheckBoxes")
    Next obj
 
    For Each obj In ActiveSheet.OptionButtons
        obj.Delete
        log4timestamp ("OptionButtons")
    Next obj
 
    'delete hyperlins
 
    For Each hyperlink In ws.Hyperlinks
        hyperlink.Delete
        log4timestamp ("Hyperlinks")
    Next hyperlink
 
 
End Sub
 
Sub ShowHiddenRowsInRange()
    Dim rng As Range
 
    Set rng = Range("A1:A10") ' 表示したい範囲を指定
    rng.EntireRow.Hidden = False
 
    Rows.Hidden = False
 
    log4timestamp ("ShowHiddenRowsInRange")
End Sub
 
 
Sub ShrinkObjects()
    Dim obj As Object
    Dim ws As Worksheet
 
    Set ws = ActiveSheet ' 縮小したいオブジェクトが含まれているシートを指定
 
    ' シート上のすべてのオブジェクトを縮小する
    For Each obj In ws.Shapes
        obj.ScaleWidth 0.75, msoFalse, msoScaleFromTopLeft
        obj.ScaleHeight 0.75, msoFalse, msoScaleFromTopLeft
    Next obj
 
    ' シート上のすべてのチャートを縮小する
    For Each obj In ws.ChartObjects
        obj.Width = obj.Width * 0.75
        obj.Height = obj.Height * 0.75
    Next obj
 
    ' シート上のすべてのテキストボックスを縮小する
    For Each obj In ws.TextBoxes
        obj.Width = obj.Width * 0.75
        obj.Height = obj.Height * 0.75
    Next obj
 
    log4timestamp ("ShrinkObjects")
 
End Sub
 
Sub CompressImages()
    Dim ws As Worksheet
    Dim shp As Shape
 
    For Each ws In ThisWorkbook.Worksheets ' すべてのシートに対して処理を繰り返す
        For Each shp In ws.Shapes ' シート内のすべてのシェイプを取得する
            If shp.Type = msoPicture Then ' シェイプが画像である場合のみ処理を実行する
                shp.PictureFormat.Compression = 80 ' 圧縮率を設定する（ここでは80%に設定していますが、必要に応じて変更してください）
                shp.PictureFormat.SaveWithDocument = True ' 圧縮画像をブックに保存する
            End If
        Next shp
    Next ws
End Sub

メール送信

定期的に送信するメール用
+ 読む 
Sub createstarttelework()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim fso As Object
    Dim textFile As Object
 
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
    Dim mailDate As String
    mailDate Format(Now, "MM/DD")
 
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set textFile = fso.opentextfile("c:\aaa\bbb\importfile.txt", 1)
    bodyText = textFile.ReadAll
    textFile.Close
 
    With OutMail
        .To = "joshi@example.com; joshi2@example.com"
        .CC = "joshi@example.com; joshi2@example.com"
        .BCC = "me@example.com"
        .Subject = mailDate & "出勤"
        .Body = bodyText
        .Display
    End With
 
    Set OutMail = Nothing
    Set OutApp = Nothing
    Set fso = Nothing
 
End Sub
 
 
 

Outlook・特定のフォルダ―の件名、受信日時を取得したリストを書き出す


+ 読む
【注意】FSOは参照設定のMicrosoft Scripting Runnerを有効化する必要がある。 
Sub ExportEmailSubjectsAndReceivedDates()
    Dim outlookApp As Outlook.Application
    Dim namespace As Outlook.NameSpace
    Dim folder As Outlook.Folder
    Dim mailItems As Outlook.Items
    Dim mailItem As Object
    Dim startDate As Date
    Dim endDate As Date
    Dim filter As String
    Dim fso As Object
    Dim textFile As Object
    Dim filePath As String
 
    ' Outlookのセットアップ
    Set outlookApp = New Outlook.Application
    Set namespace = outlookApp.GetNamespace("MAPI")
 
    ' フォルダのパスに基づいてフォルダを取得
    Set folder = namespace.Folders("メールボックス名").Folders("受信トレイ").Folders("path").Folders("to").Folders("targetfolder") ' メールボックス名は基本はメールアドレス
 
    ' 取得するメールの期間を設定
    startDate = "2023/11/01"
    endDate = "2023/11/30"
 
    ' 期間に基づいてフィルタを設定
    filter = "[ReceivedTime] >= '" & Format$(startDate, "ddddd h:nn AMPM") & _
             "' And [ReceivedTime] <= '" & Format$(endDate, "ddddd h:nn AMPM") & "'"
 
    ' フィルタを適用してメールを取得
    Set mailItems = folder.Items.Restrict(filter)
    mailItems.Sort "[ReceivedTime]", True ' 受信日時でソート
 
    ' 出力するテキストファイルのパス
    filePath = "C:\EmailSubjectsAndDates.txt" ' ファイル名を含めたフルパスを記載
 
    ' FileSystemObjectのセットアップ
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set textFile = fso.CreateTextFile(filePath, True)
 
    ' メールの件名と受信日時をファイルに書き込む
    For Each mailItem In mailItems
        If mailItem.Class = olMail Then
            textFile.WriteLine "件名: " & mailItem.Subject & " - 受信日時: " & mailItem.ReceivedTime
        End If
    Next mailItem
 
    ' ファイルを閉じる
    textFile.Close
 
    ' オブジェクトの解放
    Set fso = Nothing
    Set textFile = Nothing
    Set mailItems = Nothing
    Set folder = Nothing
    Set namespace = Nothing
    Set outlookApp = Nothing
 
    ' 完了メッセージ
    MsgBox "メールの件名と受信日時が出力されました。", vbInformation
End Sub
 
 

メール本文に入れ込むファイルパスを指定したい場合

+ 読む 
Sub createweekendreport()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim fso As Object
    Dim textFile As Object
    Dim bodyText As String
 
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
    Dim mailDate As String
    mailDate Format(Now, "MM/DD")
 
    FilePath = InputBox("週報のファイルを指定", "入力", "c:\aaa\bbb\ccc")
    If FilePath = "" Then Exit Sub
 
    On Error Resume Next
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set textFile = fso.opentextfile("c:\aaa\bbb\importfile.txt", 1)
    If Err.Number <> 0 Then
        MsgBox "ファイルパスが不正", vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
 
    bodyText = textFile.ReadAll
    textFile.Close
 
    With OutMail
        .To = "joshi@example.com; joshi2@example.com"
        .CC = "joshi@example.com; joshi2@example.com"
        .BCC = "me@example.com"
        .Subject = mailDate & "出勤"
        .Body = bodyText
        .Display
    End With
 
    Set OutMail = Nothing
    Set OutApp = Nothing
    Set fso = Nothing
 
End Sub
 

ハイパーリンクからマクロを実行する

+ 読む
１．動かしたいサブプロシージャ―を作成
２．VBA・プロジェクトビューワのExcelObjectsにある「ThisWorkBook」で次のPrivate サブプロシージャ―を作成する 
Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
          Call 動かしたいサブプロシージャ―名
      End Sub
 
３．シートでハイパーリンクを作成する。
このときリンク先は自身のセルを指定すると良い。

（メリット）
マクロの起動にはメニューの開発からマクロを選択したり、オブジェクト画像にマクロをリンクさせる方法があるが
いずれも面倒さがある。ハイパーリンクから起動する場合、設置が楽で汎用性があるところがメリット。

（注意点）
ThisWorkBookにプロシージャ―を置いているので、ハイパーリンクを踏むと全てのシートで同一マクロを動かしてしまうので注意。
特定シート、セルからのみ動かしたい場合はWorkbook_SheetFollowHyperlinkの引数を利用して条件分けすることで対処できる。


シート別に動かすマクロを変える場合は、引数Sh、Targetを利用して条件分けする必要がある。
Sh.Nameでシート名を取得でき、
Target.SubAddressで「シート名!A1」形式でセル座標を取得でき、
Target.Nameで「ハイパーリンクにしている文字列」を取得できる
ので、細かく条件分けすることができる。


DL


参考

タグ：

職場 vba
「職場向けVBA」をウィキ内検索
最終更新：2024年01月09日 10:22

[Amazon商品]