更新履歴

1. ver.1.40に対応した
2. 「ツール」-「情報」が翻訳されてなかった不具合を修正した

ダウンロード

使用方法

未翻訳箇所

1. IDC_USEARROW = Associa su/gi a immag. preced./successiva

　訳せない&表示箇所が不明（イタリア語）

2. IDS_CAP_AFFICH = Visual.

　表示箇所が不明で適切な訳語が推測できない

確認されている不具合

1. 表示形式を一覧にした状態でフォルダを選択した際、ファイル名が表示されない

　（他の言語でもおきるので、WM5かXnViewのバグかもしれません。）

2. オプション-ボタンの動作選択時に変更後の動作が一時英語表示となる


3. 機種によっては、ツールバーのお気に入りアイコンの右側が数ドット欠けます。

　（メニューの文字の短縮が不可能なので、これ以上の対応は出来ません）

サポート

更新履歴

1. メニューの削除を『フォルダの削除』に変更した（ご報告いただいたhedeさん、yujiさん、ご指摘ありがとうございます）

ダウンロード

使用方法

未翻訳箇所

1. IDC_USEARROW = Associa su/gi a immag. preced./successiva

　訳せない&表示箇所が不明（イタリア語）

2. IDS_CAP_AFFICH = Visual.

　表示箇所が不明で適切な訳語が推測できない

確認されている不具合

1. 表示形式を一覧にした状態でフォルダを選択した際、ファイル名が表示されない

　（他の言語でもおきるので、WM5かXnViewのバグかもしれません。）

2. オプション-ボタンの動作選択時に変更後の動作が一時英語表示となる


3. 機種によっては、ツールバーのお気に入りアイコンの右側が数ドット欠けます。

　（メニューの文字の短縮が不可能なので、これ以上の対応は出来ません）

サポート

Function IfError(formula As Variant, show As String)

    On Error GoTo ErrorHandler

    If IsError(formula) Then
        IfError = show
    Else
        IfError = formula
    End If

    Exit Function

ErrorHandler:
    Resume Next

End Function

プロットエリアに縦線を引くマクロ

Sub Line_PA2()
'
' プロットエリアに縦線 Macro
' マクロ記録日 : 2005/04/05  ユーザー名 : uzumaki7
'
Dim PIH As Single, PIW As Single, PIT As Single, PIL As Single
Dim SetScale As Single, MaxnScale As Single, MinScale As Single
    
    On Error GoTo ErrorHandler
    
    If ActiveChart Is Nothing Then

        MsgBox "アクティブなグラフがありません！"

        Exit Sub
    Else
        SetScale = InputBox("値を入力してください")
        If StrPtr(SetScale) = 0 Then
            Exit Sub
        End If
    End If
    
    With ActiveChart
        With .Axes(xlCategory)
            MinScale = .MinimumScale
            MaxScale = .MaximumScale
        End With
        With .PlotArea
            PIH = .InsideHeight
            PIW = .InsideWidth
            'プロットエリアの線の太さ分
            PIT = .InsideTop - 0.25
            PIL = .InsideLeft - 0.25
        End With
    End With

    ActiveChart.Shapes.AddLine((SetScale - MinScale) / (MaxScale - MinScale) * PIW + PIL, _
        PIT + PIH, _
        (SetScale - MinScale) / (MaxScale - MinScale) * PIW + PIL, _
        PIT).Select
    
ErrorHandler:

    Exit Sub
    
End Sub

グラフのマーカーを間引くマクロ

Sub ThinMarker()

' マーカーを間引く Macro
' マクロ記録日 : 2005/4/7  ユーザー名 : uzumaki7

Dim objChart                    As Object
Dim objChartSeriesCollection    As Object
Dim lngPointIndex               As Long     'Pointカウント用
Dim MarkerCount                 As Long     'Point総数

On Error Resume Next

Application.ScreenUpdating = False

    'ステップ数の入力
    MarkerStep = InputBox("マーカーのステップ数を入力して下さい")

    If StrPtr(MarkerStep) = 0 Then
        Exit Sub
    End If
    
    'すべてのチャートに適用
    For Each objChart In ActiveSheet.ChartObjects
        
        'すべての系列に適用
        For Each objChartSeriesCollection In objChart.Chart.SeriesCollection
             
            lngPointIndex = 1
            
            'マーカーの総数をカウント
            MarkerCount = objChartSeriesCollection.Points.Count
            
            For lngPointIndex = 2 To MarkerCount
                
                'マーカーを間引く
                If ((lngPointIndex - 1) Mod MarkerStep) <> 0 Then
                    objChartSeriesCollection.Points(lngPointIndex).MarkerStyle = xlNone
                End If
                               
            Next lngPointIndex
            
        Next
    
    Next

Application.ScreenUpdating = True

End Sub

グラフの判例を同じ位置にする

Sub LegendMove()
'
' 判例は、ここよ Macro
' マクロ記録日 : 2005/04/11  ユーザー名 : uzumaki7
'

'
Dim objChart     As Object
Dim LegendLeft   As Long
Dim LegendTop    As Long
Dim LegendHeight As Long
Dim LegendWidth  As Long

    On Error GoTo ErrorHandler
    
    If ActiveChart Is Nothing Then

        MsgBox "アクティブなグラフがありません！"
        Exit Sub

    End If
    
    'アクティブチャートの判例位置とサイズを取得
    With ActiveChart.Legend
        LegendLeft = .Left
        LegendTop = .Top
        LegendHeight = .Height
        LegendWidth = .Width
    End With
    
    'すべてのチャートに適用
    For Each objChart In ActiveSheet.ChartObjects
    
        With objChart.Chart.Legend
            .Left = LegendLeft
            .Top = LegendTop
            .Height = LegendHeight
            .Width = LegendWidth
        End With
        
    Next
    
ErrorHandler:

    Exit Sub
End Sub

散布図に対角線を引くマクロ

Sub Line_PA()
'
' プロットエリアに対角線 Macro
' マクロ記録日 : 2001/8/29  ユーザー名 : uzumaki7
'
Dim PIH As Single, PIW As Single, PIT As Single, PIL As Single
    
    On Error GoTo ErrorHandler
    
    If ActiveChart Is Nothing Then
        MsgBox "アクティブなグラフがありません！"
        Exit Sub
    End If
    
    With ActiveChart.PlotArea
        PIH = .InsideHeight
        PIW = .InsideWidth
        'プロットエリアの線の太さ分
        PIT = .InsideTop - 0.25
        PIL = .InsideLeft - 0.25
    End With
    
    ActiveChart.Shapes.AddLine(PIL, PIT + PIH, PIL + PIW, PIT).Select
    
ErrorHandler:
    Exit Sub
End Sub

散布図を正方形化するマクロ

Sub PAtoSQR()
'
' 散布図用　散布図は正方形Macro
' マクロ記録日 : 2001/8/29  ユーザー名 : uzumaki7
    On Error GoTo ErrorHandler
    
    If ActiveChart Is Nothing Then
        MsgBox "アクティブなグラフがありません！"
        Exit Sub
    End If

    With ActiveChart
        'フォントの自動サイズ変更の停止
        .ChartArea.AutoScaleFont = False
        
        '最大スケール合わせ(最大値に合わせる)
        If .Axes(xlCategory).MaximumScale >= .Axes(xlValue).MaximumScale Then
            .Axes(xlValue).MaximumScale = .Axes(xlCategory).MaximumScale
            .Axes(xlCategory).MaximumScaleIsAuto = False
        Else
            .Axes(xlCategory).MaximumScale = .Axes(xlValue).MaximumScale
            .Axes(xlValue).MaximumScaleIsAuto = False
        End If
        
        '最小スケール合わせ(最小値に合わせる)
        If .Axes(xlCategory).MinimumScale <= .Axes(xlValue).MinimumScale Then
            .Axes(xlValue).MinimumScale = .Axes(xlCategory).MinimumScale
            .Axes(xlCategory).MinimumScaleIsAuto = False
        Else
            .Axes(xlCategory).MinimumScale = .Axes(xlValue).MinimumScale
            .Axes(xlValue).MinimumScaleIsAuto = False
        End If
         
        '間隔合わせ
        If .Axes(xlCategory).MajorUnit >= .Axes(xlValue).MajorUnit Then
            .Axes(xlValue).MajorUnit = .Axes(xlCategory).MajorUnit
            .Axes(xlCategory).MajorUnitIsAuto = False
        Else
            .Axes(xlCategory).MajorUnit = .Axes(xlValue).MajorUnit
            .Axes(xlValue).MajorUnitIsAuto = False
        End If
        
        '正方形化
        With .PlotArea
            .Width = .Width - .InsideWidth + .InsideHeight
        End With
    End With

ErrorHandler:
    Exit Sub
End Sub

概要

VBAコード

Option Compare Text

Sub SetFolder()
 Dim olApp      As Outlook.Application
 Dim nspNameSpace  As NameSpace
 Dim fldFolder     As MAPIFolder
 Dim strAttachFileName   As String
 
 Dim intDelCount   As Integer
 Dim lngDelFileSize   As Long
 
 Set olApp = New Outlook.Application   ' Application オブジェクト
 Set nspNameSpace = olApp.GetNamespace("MAPI") ' Namespace オブジェクト
 Set fldFolder = nspNameSpace.PickFolder
 
 Dim blDelSubFolder As Boolean

 If fldFolder Is Nothing Then
  Exit Sub
 End If
 
 strAttachFileName = InputBox("検索する添付ファイル名の名前の一部を入れてください")
 
 If StrPtr(strAttachFileName) = 0 Then
  Exit Sub
 End If
 
 If MsgBox("サブフォルダの削除も行いますか？", vbYesNo) = vbYes Then
  blDelSubFolder = True
 Else
  blDelSubFolder = False
 End If
 
 Call DelAttachments(fldFolder, blDelSubFolder, strAttachFileName, _
			intDelCount, lngDelFileSize)
 
 MsgBox (intDelCount & "件," & Format(lngDelFileSize / 1024, 0) & _
    "KBの添付ファイルを削除しました")
 
End Sub

Sub DelAttachments(fldFolder As Outlook.MAPIFolder, _
     ByVal blDelSubFolder As Boolean, _
     ByVal strAttachFileName As String, _
     ByRef intDelCount As Integer, _
     ByRef lngDelFileSize As Long)

 Dim objItem    As Object
 Dim dteCreateDate    As Date
 Dim strSubject    As String
 Dim strItemType   As String
 Dim intCounter    As Integer
 Dim objAttachment    As Attachments
 
 Dim strOutputMessage As String
 
 On Error Resume Next
 
 'フォルダ内のすべてのアイテムに再帰関数
 If blDelSubFolder And fldFolder.Folders.Count > 0 Then
    For Each objItem In fldFolder.Folders
    Call DelAttachments(objItem, blDelSubFolder, strAttachFileName, intDelCount, lngDelFileSize)
    Next objItem
 End If
 
 'フォルダにアイテムがあり、それがメールであるか確認
 If fldFolder.Items.Count > 0 And fldFolder.Items(1).Class = olMail Then
  'フォルダ内のアイテムを削除するか確認する
'  If MsgBox("Folder '" & fldFolder.Name & "' (Contains " & fldFolder.Items.Count & _
   " items) の添付ファイルを削除しますか？", vbYesNo, 添付ファイルの削除) = vbYes Then
   
   For Each objItem In fldFolder.Items
    With objItem
     intCounter = .Attachments.Count
     Do While intCounter > 0
      If .Attachments(intCounter).FileName Like ("*" & strAttachFileName & "*") Then
       lngDelFileSize = lngDelFileSize + .Size
       .Attachments.Remove intCounter
       .Save
       lngDelFileSize = lngDelFileSize - .Size
       intDelCount = intDelCount + 1
      End If
      intCounter = intCounter - 1
     Loop
    End With
   Next objItem
'  End If
 End If
 
End Sub

導入方法

使い方

補足事項