MyMacros.bas

Option Explicit

Public LastMovedItems As Collection
Public LastSourceFolder As Folder
Public LastTargetFolderId As String
Public LastTargetFolderName As String

Public Sub FormatAsCode()
    Dim sel
    Set sel = ActiveInspector.WordEditor.Application.Selection
    sel.Font.Color = -553582695
    sel.Font.Name = "Courier New"
    sel.NoProofing = True
End Sub

Public Sub ZoomIn()
    Dim saved As Boolean
    On Error Resume Next
    saved = ActiveInspector.CurrentItem.saved
    ActiveInspector.WordEditor.Windows(1).View.Zoom = ActiveInspector.WordEditor.Windows(1).View.Zoom * 2
    If Err.Number <> 0 Then ActiveInspector.WordEditor.Windows(1).View.Zoom = 500
    If saved Then ActiveInspector.CurrentItem.saved = True
End Sub

Public Sub ZoomOut()
    Dim saved As Boolean
    On Error Resume Next
    saved = ActiveInspector.CurrentItem.saved
    ActiveInspector.WordEditor.Windows(1).View.Zoom = ActiveInspector.WordEditor.Windows(1).View.Zoom / 2
    If Err.Number <> 0 Then ActiveInspector.WordEditor.Windows(1).View.Zoom = 10
    If saved Then ActiveInspector.CurrentItem.saved = True
End Sub

Public Sub BuildForCurrent(Optional FolderName As String = "")
    If FolderName = "" Then FolderName = ActiveExplorer.CurrentFolder.Name
    Debug.Print "Sub MoveTo" & FolderName & "()" & vbCrLf _
              & "    MoveItemsToFolder """ & ActiveExplorer.CurrentFolder.EntryID & """" & vbCrLf _
              & "End Sub" & vbCrLf _
              & vbCrLf _
              & "Sub GoTo" & FolderName & "()" & vbCrLf _
              & "    GoToFolder """ & ActiveExplorer.CurrentFolder.EntryID & """" & vbCrLf _
              & "End Sub" & vbCrLf
End Sub

Sub OpenRemedyFromClipboard()
    Shell "wscript C:\OpenRemedyFromClipboard.vbs"
End Sub

Private Sub SetUndoButtonText(t As String, Enabled As Boolean)
    Dim menuControls As CommandBarControls
    Dim subMenuControls As CommandBarControls
    Set menuControls = ActiveExplorer.CommandBars("Menu Bar").Controls
    menuControls(menuControls.count).Caption = t
    menuControls(menuControls.count).Enabled = Enabled
    
    Dim GoToMenu As CommandBarControl
    For Each GoToMenu In menuControls
        If GoToMenu.Caption = "Go To..." Then
            Exit For
        End If
    Next
    
    If GoToMenu Is Nothing Then Exit Sub
    Set subMenuControls = GoToMenu.Controls ' Go to...
    subMenuControls(1).Caption = IIf(Enabled, " (" & LastTargetFolderName & ")", "N/A")
    subMenuControls(1).Enabled = Enabled
End Sub

Private Sub MoveItemsToFolder(folderID As String)
    Dim Item As Object ' MailItem
    Dim targetFolder As Folder
    ' Folder ID can be obtained by selecting the folder
    ' in Outlook and then typing in the immediate window:
    '   ?ActiveExplorer.CurrentFolder.EntryID
    Set targetFolder = GetNamespace("MAPI").GetFolderFromID(folderID)
    If ActiveExplorer.CurrentFolder = targetFolder Then
        MsgBox "You are already in '" & targetFolder.Name & "'.", vbCritical
        Exit Sub
    End If
    
    Set LastSourceFolder = ActiveExplorer.CurrentFolder
    LastTargetFolderId = folderID
    LastTargetFolderName = targetFolder.Name
    Set LastMovedItems = New Collection
    Dim movedItem As Object ' MailItem
    For Each Item In ActiveExplorer.Selection
        Set movedItem = Item.Move(targetFolder)
        LastMovedItems.Add movedItem
    Next Item
    
    Dim msg As String
    msg = "Undo moving " & LastMovedItems.count
    If LastMovedItems.count = 1 Then
        msg = msg & " item"
    Else
        msg = msg & " items"
    End If
    
    msg = msg & " to " & targetFolder.Name
    SetUndoButtonText msg, True
End Sub

Sub GoToFolder(folderID As String)
    Set ActiveExplorer.CurrentFolder = GetNamespace("MAPI").GetFolderFromID(folderID)
End Sub

Sub UndoLastMove()
    If LastMovedItems Is Nothing Or LastSourceFolder Is Nothing Then
        MsgBox "Cannot undo last move"
        SetUndoButtonText "Undo Move", False
        Exit Sub
    End If
        
    Dim Item As Object ' MailItem
    Dim doSelect As Boolean
    For Each Item In LastMovedItems
        Item.Move LastSourceFolder
    Next Item
    
    SetUndoButtonText "Undo Move", False
    
    Set LastSourceFolder = Nothing
    Set LastMovedItems = Nothing
End Sub

Sub GotoLastMovedToFolder()
    GoToFolder LastTargetFolderId
End Sub

Sub MoveToPrivate()
    MoveItemsToFolder "0000000045DC3C0FFF1EA54CBAD9147BB26AF269A2800000"
End Sub

Sub GoToPrivate()
    GoToFolder "0000000045DC3C0FFF1EA54CBAD9147BB26AF269A2800000"
End Sub

Sub MoveToSupport()
    MoveItemsToFolder "00000000A7E4D138E838B7489BA3F839949B055182800000"
End Sub

Sub GoToSupport()
    GoToFolder "00000000A7E4D138E838B7489BA3F839949B055182800000"
End Sub

Sub MoveToCodeProject()
    MoveItemsToFolder "00000000A7E4D138E838B7489BA3F839949B055122860000"
End Sub

Sub MoveToOpenOffice()
    MoveItemsToFolder "00000000A7E4D138E838B7489BA3F839949B0551628B0000"
End Sub

Sub MoveToHalemo()
    MoveItemsToFolder "00000000A7E4D138E838B7489BA3F839949B0551C2890000"
End Sub

Sub MoveToFindingJobs()
    MoveItemsToFolder "0000000045DC3C0FFF1EA54CBAD9147BB26AF269E28D0000"
End Sub

Sub MoveToUsability()
    MoveItemsToFolder "0000000024687E182CAC2B49A99683EA6F97E29A023A0900"
End Sub

Sub GoToUsability()
    GoToFolder "0000000024687E182CAC2B49A99683EA6F97E29A023A0900"
End Sub

Sub MoveToVersion370Maint()
    MoveItemsToFolder "0000000024687E182CAC2B49A99683EA6F97E29A22860A00"
End Sub

Sub GoToVersion370Maint()
    GoToFolder "0000000024687E182CAC2B49A99683EA6F97E29A22860A00"
End Sub

Sub MoveToVersion370MaintIntegration()
    MoveItemsToFolder "0000000024687E182CAC2B49A99683EA6F97E29AE2800E00"
End Sub

Sub MoveToBrim370()
    MoveItemsToFolder "0000000024687E182CAC2B49A99683EA6F97E29AE27F0E00"
End Sub

Sub MoveToVersion380()
    MoveItemsToFolder "0000000024687E182CAC2B49A99683EA6F97E29AE2A70000"
End Sub

Sub GoToVersion380()
    GoToFolder "0000000024687E182CAC2B49A99683EA6F97E29AE2A70000"
End Sub

Sub MoveToWebAccess()
    MoveItemsToFolder "0000000024687E182CAC2B49A99683EA6F97E29A028D0000"
End Sub

Sub MoveToTechForum()
    MoveItemsToFolder "00000000D250B7BA1662694E9BB21233BBF9CC5262840000"
End Sub

Sub MoveToOTL()
    MoveItemsToFolder "00000000D250B7BA1662694E9BB21233BBF9CC52A2820000"
End Sub

Sub MoveToBMCJunk()
    MoveItemsToFolder "00000000D250B7BA1662694E9BB21233BBF9CC5222800000"
End Sub

Sub MoveToYedion()
    MoveItemsToFolder "0000000045DC3C0FFF1EA54CBAD9147BB26AF269E29E0900"
End Sub

Sub MoveToFPAutomation()
    MoveItemsToFolder "0000000024687E182CAC2B49A99683EA6F97E29A62810E00"
End Sub

Sub GotoFPAutomation()
    GoToFolder "0000000024687E182CAC2B49A99683EA6F97E29A62810E00"
End Sub

Sub MoveToSelfService()
    MoveItemsToFolder "0000000024687E182CAC2B49A99683EA6F97E29A62830E00"
End Sub

Sub GotoSelfService()
    GoToFolder "0000000024687E182CAC2B49A99683EA6F97E29A62830E00"
End Sub

Sub MoveToFirstTimeUsageExperience()
    MoveItemsToFolder "0000000024687E182CAC2B49A99683EA6F97E29A82820E00"
End Sub

Sub GotoFirstTimeUsageExperience()
    GoToFolder "0000000024687E182CAC2B49A99683EA6F97E29A82820E00"
End Sub

Sub MoveToIzPackInstallation()
    MoveItemsToFolder "0000000024687E182CAC2B49A99683EA6F97E29AA2820E00"
End Sub

Sub GotoIzPackInstallation()
    GoToFolder "0000000024687E182CAC2B49A99683EA6F97E29AA2820E00"
End Sub

Public Function GetNewFilename(targetPath As String, ByVal filename As String) As String
    If filename = "" Then filename = "attached_file"
    
    If Dir(targetPath & "\" & filename) = "" Then
        GetNewFilename = targetPath & "\" & filename
        Exit Function
    End If

    Dim parts
    Dim counter As Long
    Dim orig As String
    counter = 0
    parts = Split(filename, ".")
    orig = parts(0)
    Do
        counter = counter + 1
        parts(0) = orig & "_" & counter
    Loop Until Dir(targetPath & "\" & Join(parts, ".")) = ""
    GetNewFilename = targetPath & "\" & Join(parts, ".")
End Function

Private Sub SaveAttachmentsToFolder(targetPath As String)
    If ActiveExplorer.Selection.count = 0 Then
        MsgBox "No item is selected", vbExclamation
        Exit Sub
    End If
    
    Dim count As Long
    count = 0
    Dim Item As Object ' MailItem
    Dim att As Object ' Attachment
    For Each Item In ActiveExplorer.Selection
        For Each att In Item.Attachments
            att.SaveAsFile GetNewFilename(targetPath, att.DisplayName)
            count = count + 1
        Next
    Next
    
    MsgBox "Saved " & count & " attachments from " & ActiveExplorer.Selection.count & " selected items to '" & targetPath & "'", vbInformation
End Sub

Public Sub SaveAttachmentsOfSelectedItems()
    SaveAttachmentsToFolder "C:\Attachments"
End Sub

Public Function GetFolderFromUser(initDir As String) As String
    Dim objShell As Object
    Set objShell = CreateObject("Shell.Application").BrowseForFolder(0, "Please choose a folder", 0, initDir)
    
    On Error Resume Next
    GetFolderFromUser = objShell.self.Path
    On Error GoTo 0
End Function

Function GetActiveEditor() As Object
    Dim doc As Object
    
    On Error Resume Next
    Set doc = ActiveWindow.ActiveInlineResponseWordEditor
    On Error GoTo 0
    If doc Is Nothing Then
        If ActiveInspector Is Nothing Then
            MsgBox "Can't find active inspector"
            Exit Function
        End If
        If ActiveInspector.EditorType = olEditorText Then
            MsgBox "Can't find active editor"
            Exit Function
        End If
        Set doc = ActiveInspector.WordEditor
    End If
    Set GetActiveEditor = doc
End Function

Sub Regards()
    GetActiveEditor().Application.Selection.TypeText "Regards," + vbNewLine + "Shmulik"
End Sub

Sub Thanks()
    GetActiveEditor().Application.Selection.TypeText "Thanks," + vbNewLine + "Shmulik"
End Sub

Public Sub AddLinkFromClipboard()
    Dim doc As Object
    Dim objHTM As Object
    Dim clipboardData As String
    Dim sel As Object
    Dim parts
    
    Set doc = GetActiveEditor()
    Set objHTM = CreateObject("htmlfile")
    clipboardData = HandleSpecialIds(objHTM.ParentWindow.clipboardData.GetData("text"))
    
    If Not ValidURL(clipboardData) Then
        clipboardData = InputBox("Clipboard doesn't seem to contain a valid URL. Please enter the URL you want to link:", "URL Not Found", clipboardData)
        If Len(clipboardData) = 0 Then Exit Sub
    End If
    
    Const wdBackward = &HC0000001
    Set sel = doc.Application.Selection
    If sel.Start = sel.End Then
        parts = Split(clipboardData, "/issue")
        If UBound(parts) > LBound(parts) Then
            sel.Text = "issue " & parts(UBound(parts))
        Else
            parts = Split(clipboardData, "/browse/") ' JIRA link
            If UBound(parts) > LBound(parts) Then
                sel.Text = parts(UBound(parts))
            Else
                parts = Split(clipboardData, "/commits/") ' Bitbucket
                If UBound(parts) > LBound(parts) Then
                    sel.Text = Left(parts(UBound(parts)), 11)
                Else
                    parts = Split(clipboardData, "=")
                    Dim found As Boolean
                    Dim i As Long
                    Dim t As String
                    For i = LBound(parts) To UBound(parts)
                        If Right(parts(i), 2) = "id" Then
                            t = parts(i + 1)
                            found = True
                            Exit For
                        End If
                    Next i
                    If Not found Then t = parts(UBound(parts))
                    parts = Split(t, "&")
                    sel.Text = parts(LBound(parts))
                End If
            End If
        End If
    End If
    
    Const WhiteSpace = " " & vbTab & vbCr & vbLf
    sel.MoveStartWhile WhiteSpace
    sel.MoveEndWhile WhiteSpace, wdBackward
    doc.Hyperlinks.Add Anchor:=sel.Range, _
                       Address:=clipboardData, _
                       SubAddress:="", _
                       ScreenTip:="", _
                       TextToDisplay:=sel.Text
End Sub

Private Function HandleSpecialIds(clipboardData As String) As String
    Dim regex As Object
    Dim matches As Object
    Dim trimmedClipboardData As String
    
    trimmedClipboardData = Trim(clipboardData)
    
    ' Handle special case of defect number in clipboard
    Set regex = CreateObject("vbscript.regexp")
    regex.Global = True
    regex.IgnoreCase = True
    
    regex.Pattern = "^QM[0-9]+$"
    Set matches = regex.Execute(trimmedClipboardData)
    If matches.count = 1 Then
        HandleSpecialIds = BuildRemedyUrl("csdefect", trimmedClipboardData)
        Exit Function
    End If
    
    regex.Pattern = "^CAR[0-9]+$"
    Set matches = regex.Execute(trimmedClipboardData)
    If matches.count = 1 Then
        HandleSpecialIds = BuildRemedyUrl("cscar", trimmedClipboardData)
        Exit Function
    End If
            
    regex.Pattern = "^ISS[0-9]+$"
    Set matches = regex.Execute(trimmedClipboardData)
    If matches.count = 1 Then
        HandleSpecialIds = BuildRemedyUrl("csissue", trimmedClipboardData)
        Exit Function
    End If
    
    regex.Pattern = "^SLN[0-9]+$"
    Set matches = regex.Execute(trimmedClipboardData)
    If matches.count = 1 Then
        HandleSpecialIds = BuildRemedyUrl("cssolutionint", trimmedClipboardData)
        Exit Function
    End If
       
    regex.Pattern = "^[0-9A-Za-z]+$"
    Set matches = regex.Execute(trimmedClipboardData)
    If matches.count = 1 Then
        HandleSpecialIds = BuildBitbucketUrl(trimmedClipboardData)
        Exit Function
    End If
       
    HandleSpecialIds = clipboardData
End Function

Private Function BuildRemedyUrl(remedyType As String, id As String) As String
        BuildRemedyUrl = "https://kb.bmc.com/render/KCSRenderController?type=" + remedyType + "&id=" + id
End Function

Private Function BuildBitbucketUrl(commit As String) As String
        BuildBitbucketUrl = "http://vl-tlv-scm-03:7990/projects/EM/repos/ecstop/commits/" + commit
End Function

Private Function ValidURL(s As String) As Boolean
    If Len(s) = 0 Then
        ValidURL = False
        Exit Function
    End If

    If LCase(Left(s, 4)) = "http" Then
        ValidURL = True
        Exit Function
    End If
    
    If LCase(Left(s, 2)) = "\\" Then
        ValidURL = True
        Exit Function
    End If
    
    If LCase(Left(s, 2)) = "c:" Then
        ValidURL = True
        Exit Function
    End If
    
    ValidURL = False
End Function

Public Sub SetHebrewSender() ' This macro is not working very well for some reason. Need to find a better way to set theSentOnBehalfOfName
    Dim Item As MailItem
    Set Item = ActiveInspector.CurrentItem
    Item.SentOnBehalfOfName = "ùîåìé÷ ôìéðè <splintor@gmail.com>"
    Item.SendUsingAccount = GetNamespace("MAPI").Accounts(2)
End Sub

'Public Sub QuickAttach() ' Add an attachment by

Public Sub AddAttachmentFromClipboard()
    Dim filename As String
    filename = CreateObject("htmlfile").ParentWindow.clipboardData.GetData("text")
    On Error Resume Next
    ActiveInspector.CurrentItem.Attachments.Add CreateObject("htmlfile").ParentWindow.clipboardData.GetData("text")
    If Err.Number <> 0 Then
        MsgBox "Failed to add '" + filename + "':" + vbCrLf + Err.Description
    End If
End Sub