Importing Customized Ribbon from Word to Excel / Changing a Word Document with Macros & Customized Ribbon into an Excel File

E

eamrichardson

New Member
Joined
Jul 20, 2015
Messages
2
Was hoping someone might have an answer for this...

I am new to working with macros and customized ribbons and have a Word document that was shared with me but I believe it will be more functional being used in Excel. Mostly to do with formatting and how the macros seem to work.

I have the coding for the macros and the exported file for the customizations but they don't seem to want to transfer into Excel.

Is there any way to transfer them into Excel? Or does the code need to be rewritten to work with Excel?

Or is there a way I can just turn the whole document from Word to Excel and it will keep the macros and custom ribbon?

Any helpe would be greatly appreciated. Been searching online and haven't been able to find anyone with the same issue.

Thank you
 

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).
Sort by date Sort by votes
Welcome to MrExcel,

Some parts of VBA and RibbonX customizations are interchangeable between Excel and Word, but in most cases, some modifications will be needed to transfer a macro from one application to another.

I don't know how much code you have, but if you'll post one or two macros and the corresponding Ribbon XML, I'd be glad to help you convert those.
With that starting point you may be able to convert some of the others on your own.
 
Upvote 0
Thank you for your response...This is the macro but I'm not sure how to open the customization file
Code: 
Sub CallSick()
'
' CallSick Macro
'
'
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Color = wdColorRed
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Superscript = wdToggle
    Selection.TypeText " C/S ("
    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "USERNAME  \* Lower ", PreserveFormatting:=True
        Selection.TypeText ")"
        Selection.Font.Superscript = wdToggle
        Selection.TypeText " "
    Selection.Font.UnderlineColor = wdColorAutomatic
    Selection.Font.Underline = wdUnderlineSingle
    Selection.Font.Color = wdColorRed
    Selection.TypeText "                        "
    End Sub
        
Sub ShiftTrade()
'
' ShiftTrade Macro
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Color = wdColorLightBlue
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Superscript = wdToggle
    Selection.TypeText " S/C ("
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "USERNAME  \* Lower ", PreserveFormatting:=True
        Selection.TypeText ")"
    Selection.Font.Superscript = wdToggle
    Selection.TypeText " "
    Selection.Font.UnderlineColor = wdColorAutomatic
    Selection.Font.Underline = wdUnderlineSingle
    'Selection.Font.Color = wdColorLightBlue
    'Selection.TypeText "                        "
End Sub
Sub Leaves()
'
' Leaves Macro
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Color = wdColorGreen
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Font.StrikeThrough = wdToggle
        Selection.Font.Superscript = wdToggle
    Selection.TypeText " LOA ("
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "USERNAME  \* Lower ", PreserveFormatting:=True
        Selection.TypeText ")"
    Selection.Font.Superscript = wdToggle
    Selection.TypeText " "
    Selection.Font.UnderlineColor = wdColorAutomatic
    Selection.Font.Underline = wdUnderlineSingle
    Selection.Font.Color = wdColorGreen
    Selection.TypeText "                        "
End Sub
Sub PostOther()
'
' PostOther Macro
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Color = wdColorGreen
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Font.StrikeThrough = wdToggle
        Selection.Font.Superscript = wdToggle
    Selection.TypeText " OTHER ("
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "USERNAME  \* Lower ", PreserveFormatting:=True
        Selection.TypeText ")"
    Selection.Font.Superscript = wdToggle
    Selection.TypeText " "
    Selection.Font.UnderlineColor = wdColorAutomatic
    Selection.Font.Underline = wdUnderlineSingle
    Selection.Font.Color = wdColorGreen
    Selection.TypeText "                        "
End Sub
Sub PostADOVAC()
'
' PostADOVAC Macro
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Color = wdColorGreen
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Superscript = wdToggle
    Selection.TypeText " ADO/VAC ("
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "USERNAME  \* Lower ", PreserveFormatting:=True
        Selection.TypeText ")"
    Selection.Font.Superscript = wdToggle
    Selection.TypeText " "
    Selection.Font.UnderlineColor = wdColorAutomatic
    Selection.Font.Underline = wdUnderlineSingle
    Selection.Font.Color = wdColorGreen
    Selection.TypeText "                        "
End Sub
Sub PostNA()
'
' PostNA Macro
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Color = wdColorGreen
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Superscript = wdToggle
    Selection.TypeText " NA# ("
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "USERNAME  \* Lower ", PreserveFormatting:=True
        Selection.TypeText ")"
    Selection.Font.Superscript = wdToggle
    Selection.TypeText " "
    Selection.Font.UnderlineColor = wdColorAutomatic
    Selection.Font.Underline = wdUnderlineSingle
    Selection.Font.Color = wdColorGreen
    Selection.TypeText "                        "
End Sub
Sub AddShift2()
'
' AddShift2 Macro
'
    Selection.TypeParagraph
    Selection.Font.Color = wdColorOrange
    Selection.TypeText "      Per/WBS:  "
    Selection.TypeText Text:=vbTab & vbTab & vbTab & vbTab
    Selection.TypeText Text:="     POSITION" & vbTab & vbTab & _
        "   ####  ####" & vbTab & vbTab & vbTab
    Selection.Font.Underline = wdUnderlineSingle
    Selection.TypeText "                         "
    Selection.Font.Underline = wdUnderlineNone
        Selection.Font.Color = wdColorAutomatic
    
End Sub
Sub AddShiftToday()
'
' AddShift2 Macro
'
    Selection.TypeParagraph
    Selection.Font.Color = wdColorTeal
    Selection.TypeText "      Per/WBS:  "
    Selection.TypeText Text:=vbTab & vbTab & vbTab & vbTab
    Selection.TypeText Text:="     POSITION" & vbTab & vbTab & _
        "   ####  ####" & vbTab & vbTab & vbTab
    Selection.Font.Underline = wdUnderlineSingle
    Selection.TypeText "                         "
    Selection.Font.Underline = wdUnderlineNone
        Selection.Font.Color = wdColorAutomatic
    
End Sub
Sub CallPersonal()
'
' CallPersonal Macro
'
'
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Color = wdColorRed
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Superscript = wdToggle
    Selection.TypeText " C/P "
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "USERNAME  \* Lower ", PreserveFormatting:=True
        Selection.TypeText ")"
    Selection.Font.Superscript = wdToggle
        Selection.TypeText " "
    Selection.Font.UnderlineColor = wdColorAutomatic
    Selection.Font.Underline = wdUnderlineSingle
    Selection.Font.Color = wdColorRed
    Selection.TypeText "                        "
    End Sub
    Sub CallTransport()
'
' CallTransport Macro
'
'
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Color = wdColorRed
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Superscript = wdToggle
    Selection.TypeText " C/T ("
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "USERNAME  \* Lower ", PreserveFormatting:=True
        Selection.TypeText ")"
    Selection.Font.Superscript = wdToggle
        Selection.TypeText " "
    Selection.Font.UnderlineColor = wdColorAutomatic
    Selection.Font.Underline = wdUnderlineSingle
    Selection.Font.Color = wdColorRed
    Selection.TypeText "                        "
    End Sub
    Sub CallDependent()
'
' CallDependent Macro
'
'
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Color = wdColorRed
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Superscript = wdToggle
    Selection.TypeText " C/D ("
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "USERNAME  \* Lower ", PreserveFormatting:=True
        Selection.TypeText ")"
    Selection.Font.Superscript = wdToggle
        Selection.TypeText " "
    Selection.Font.UnderlineColor = wdColorAutomatic
    Selection.Font.Underline = wdUnderlineSingle
    Selection.Font.Color = wdColorRed
    Selection.TypeText "                        "
    End Sub
    Sub CallCFRA()
'
' CallCFRA Macro
'
'
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Color = wdColorRed
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Superscript = wdToggle
    Selection.TypeText " CFRA/FMLA ("
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "USERNAME  \* Lower ", PreserveFormatting:=True
        Selection.TypeText ")"
    Selection.Font.Superscript = wdToggle
        Selection.TypeText " "
    Selection.Font.UnderlineColor = wdColorAutomatic
    Selection.Font.Underline = wdUnderlineSingle
    Selection.Font.Color = wdColorRed
    Selection.TypeText "                        "
    End Sub
    Sub CallPDL()
'
' CallPDL Macro
'
'
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Color = wdColorRed
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Superscript = wdToggle
    Selection.TypeText " PDL ("
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "USERNAME  \* Lower ", PreserveFormatting:=True
        Selection.TypeText ")"
    Selection.Font.Superscript = wdToggle
        Selection.TypeText " "
    Selection.Font.UnderlineColor = wdColorAutomatic
    Selection.Font.Underline = wdUnderlineSingle
    Selection.Font.Color = wdColorRed
    Selection.TypeText "                        "
    End Sub
    Sub CallADOVAC()
'
' CallADOVAC Macro
'
'
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Color = wdColorRed
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Superscript = wdToggle
    Selection.TypeText " ADO/VAC ("
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "USERNAME  \* Lower ", PreserveFormatting:=True
        Selection.TypeText ")"
    Selection.Font.Superscript = wdToggle
        Selection.TypeText " "
    Selection.Font.UnderlineColor = wdColorAutomatic
    Selection.Font.Underline = wdUnderlineSingle
    Selection.Font.Color = wdColorRed
    Selection.TypeText "                        "
    End Sub
Sub CallNA()
'
' CallNA Macro
'
'
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Color = wdColorRed
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Superscript = wdToggle
    Selection.TypeText " NA# ("
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "USERNAME  \* Lower ", PreserveFormatting:=True
        Selection.TypeText ")"
    Selection.Font.Superscript = wdToggle
        Selection.TypeText " "
    Selection.Font.UnderlineColor = wdColorAutomatic
    Selection.Font.Underline = wdUnderlineSingle
    Selection.Font.Color = wdColorRed
    Selection.TypeText "                        "
    End Sub
    Sub CallNCNS()
'
' CallNCNS Macro
'
'
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Color = wdColorRed
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Superscript = wdToggle
    Selection.TypeText " NCNS ("
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "USERNAME  \* Lower ", PreserveFormatting:=True
        Selection.TypeText ")"
    Selection.Font.Superscript = wdToggle
        Selection.TypeText " "
    Selection.Font.UnderlineColor = wdColorAutomatic
    Selection.Font.Underline = wdUnderlineSingle
    Selection.Font.Color = wdColorRed
    Selection.TypeText "                        "
    End Sub
    Sub CallOther()
'
' CallOther Macro
'
'
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Color = wdColorRed
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Superscript = wdToggle
    Selection.TypeText " OTHER ("
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "USERNAME  \* Lower ", PreserveFormatting:=True
        Selection.TypeText ")"
    Selection.Font.Superscript = wdToggle
        Selection.TypeText " "
    Selection.Font.UnderlineColor = wdColorAutomatic
    Selection.Font.Underline = wdUnderlineSingle
    Selection.Font.Color = wdColorRed
    Selection.TypeText "                        "
    End Sub
        Sub CallRain()
'
' CallRain Macro
'
'
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Font.Superscript = wdToggle
    Selection.Font.Color = wdColorSkyBlue
    Selection.TypeText " RAIN ("
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "USERNAME  \* Lower ", PreserveFormatting:=True
        Selection.TypeText ")"
    Selection.Font.Superscript = wdToggle
        Selection.TypeText " "
    
    End Sub
Sub Reset()
'
' Undo Reset
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Color = wdColorBlack
    Selection.Collapse Direction:=wdCollapseEnd
    
End Sub

        Sub Late()
'
' Calllate Macro
'
'
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Font.Superscript = wdToggle
    Selection.Font.Color = wdColorRed
    Selection.TypeText " LATE ("
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "USERNAME  \* Lower ", PreserveFormatting:=True
        Selection.TypeText ")"
    Selection.Font.Superscript = wdToggle
        Selection.TypeText " "
    
    End Sub
        Sub LATECFRAPDL()
'
' LateCFRAPDL Macro
'
'
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Font.Superscript = wdToggle
    Selection.Font.Color = wdColorRed
    Selection.TypeText " LATE CFRA/PDL ("
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "USERNAME  \* Lower ", PreserveFormatting:=True
        Selection.TypeText ")"
    Selection.Font.Superscript = wdToggle
        Selection.TypeText " "
    
    End Sub
    Sub TimeChange()
'
' Timechange Macro
'
'
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Color = wdColorViolet
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Superscript = wdToggle
    Selection.Font.Color = wdColorBlack
    End Sub
    Sub TOFROMDAYOF()
'
' TOFROMDAYOF Macro
'
'
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Color = wdColorRed
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Superscript = wdToggle
    Selection.TypeText " TO: ("
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "USERNAME  \* Lower ", PreserveFormatting:=True
        Selection.TypeText ")"
    Selection.Font.Superscript = wdToggle
        Selection.TypeText " "
    Selection.Font.UnderlineColor = wdColorAutomatic
    Selection.Font.Underline = wdUnderlineSingle
    Selection.Font.Color = wdColorRed
    Selection.TypeText "                        "
    End Sub
    Sub TOFROMPOST()
'
' TOFROMPOST Macro
'
'
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Color = wdColorGreen
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Font.StrikeThrough = wdToggle
    Selection.Font.Superscript = wdToggle
    Selection.TypeText " TO: ("
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "USERNAME  \* Lower ", PreserveFormatting:=True
        Selection.TypeText ")"
    Selection.Font.Superscript = wdToggle
        Selection.TypeText " "
    Selection.Font.UnderlineColor = wdColorAutomatic
    Selection.Font.Underline = wdUnderlineSingle
    Selection.Font.Color = wdColorGreen
    Selection.TypeText "                        "
    End Sub
Sub Hightlight()
'
' Hightlight Macro
'
'
    Selection.MoveRight Unit:=wdCharacter, Count:=9, Extend:=wdExtend
    Options.DefaultHighlightColorIndex = wdYellow
    Selection.Range.HighlightColorIndex = wdYellow
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.MoveRight Unit:=wdCharacter, Count:=4
    Selection.MoveRight Unit:=wdCharacter, Count:=2, Extend:=wdExtend
    Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    Options.DefaultHighlightColorIndex = wdYellow
    Selection.Range.HighlightColorIndex = wdNoHighlight
    Selection.MoveLeft Unit:=wdCharacter, Count:=5
End Sub
        Sub PossCallIn()
'
' PossCallIn Macro
'
'
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Font.Superscript = wdToggle
    Selection.Font.Color = wdColorRed
    Selection.TypeText " Poss ("
        Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "USERNAME  \* Lower ", PreserveFormatting:=True
        Selection.TypeText ")"
    Selection.Font.Superscript = wdToggle
        Selection.TypeText " "
    
    End Sub
Sub SendpdfTomorrow()
'Sends pdf of next day's dailies
'
    On Error Resume Next
    'Verify if the docment has been saved before so that we have a path to work with.
    'If not, notify the user that there will be a safe dialog first.
    If ActiveDocument.Path <> "" Then
        ActiveDocument.Save
    Else
        Dim Msg, Style, Title, Response
        Msg = "This document has not been saved before." & vbLf & _
        "Please save the document to disk first." & vbLf & _
        "Without saving first, only the pdf-file will be attached."
        Style = vbInformation + vbOKOnly
        Title = "Save current presentation"
        Response = MsgBox(Msg, Style, Title)
        
        Dim dlgSaveAs As FileDialog
        Dim strCurrentFile As String
        Set dlgSaveAs = Application.FileDialog(msoFileDialogSaveAs)
        
        If dlgSaveAs.Show = -1 Then
            strCurrentFile = dlgSaveAs.SelectedItems(1)
            ActiveDocument.SaveAs (strCurrentFile)
        End If
        Set dlgSaveAs = Nothing
    End If
    'Get the name of the open file and strip any extension.
    Dim MyFile As String
    MyFile = ActiveDocument.Name
    intPos = InStrRev(MyFile, ".")
    If intPos > 0 Then
        MyFile = Left(MyFile, intPos - 1)
    End If
    'Get the user's TempFolder to store the created pdf item in.
    Dim FSO As Object, TmpFolder As Object
    Set FSO = CreateObject("scripting.filesystemobject")
    Set FileName = FSO.GetSpecialFolder(2)
    
    'Create the full path name for the pdf-file
    FileName = FileName & "\" & MyFile & ".pdf"
    'Save the current document as pdf in the user's temp folder.
    ActiveDocument.ExportAsFixedFormat OutputFileName:= _
        FileName, ExportFormat:= _
        wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
        wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=0, To:=0, _
        Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=True, UseISO19005_1:=False
    'Declare an Outlook application an a mail item.
    Dim oOutlookApp As Outlook.Application
    Dim oItem As Outlook.MailItem
    'Start Outlook if it isn't running.
    Set oOutlookApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then
        Set oOutlookApp = CreateObject("Outlook.Application")
    End If
    'Create a new message.
    Set oItem = oOutlookApp.CreateItem(olMailItem)
    'Add the attachments.
    oItem.Attachments.Add FileName
    oItem.Subject = "Cars Land Attractions Dailies - " & Date + 1
    oItem.To = ""
    oItem.CC = Environ$("Username")
    oItem.Body = "Hello, attached are the dailies for business date: " & Date + 1 & ".  Please note additional changes will be relayed during the course of business." & vbCrLf & "*Confidential* Do not distribute to unintended parties."
    
    
    'oItem.Attachments.Add ActiveDocument.FullName
    'Show the message.
    oItem.Display
  'Cleanup
    Set FSO = Nothing
    Set FileName = Nothing
    Set oOutlookApp = Nothing
    Set oItem = Nothing
          
   'End With
    
End Sub
Sub SendpdfToday()
'Sends pdf of current day's dailies
'
    On Error Resume Next
    'Verify if the docment has been saved before so that we have a path to work with.
    'If not, notify the user that there will be a safe dialog first.
    If ActiveDocument.Path <> "" Then
        ActiveDocument.Save
    Else
        Dim Msg, Style, Title, Response
        Msg = "This document has not been saved before." & vbLf & _
        "Please save the document to disk first." & vbLf & _
        "Without saving first, only the pdf-file will be attached."
        Style = vbInformation + vbOKOnly
        Title = "Save current presentation"
        Response = MsgBox(Msg, Style, Title)
        
        Dim dlgSaveAs As FileDialog
        Dim strCurrentFile As String
        Set dlgSaveAs = Application.FileDialog(msoFileDialogSaveAs)
        
        If dlgSaveAs.Show = -1 Then
            strCurrentFile = dlgSaveAs.SelectedItems(1)
            ActiveDocument.SaveAs (strCurrentFile)
        End If
        Set dlgSaveAs = Nothing
    End If
    'Get the name of the open file and strip any extension.
    Dim MyFile As String
    MyFile = ActiveDocument.Name
    intPos = InStrRev(MyFile, ".")
    If intPos > 0 Then
        MyFile = Left(MyFile, intPos - 1)
    End If
    'Get the user's TempFolder to store the created pdf item in.
    Dim FSO As Object, TmpFolder As Object
    Set FSO = CreateObject("scripting.filesystemobject")
    Set FileName = FSO.GetSpecialFolder(2)
    
    'Create the full path name for the pdf-file
    FileName = FileName & "\" & MyFile & ".pdf"
    'Save the current document as pdf in the user's temp folder.
    ActiveDocument.ExportAsFixedFormat OutputFileName:= _
        FileName, ExportFormat:= _
        wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
        wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=0, To:=0, _
        Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=True, UseISO19005_1:=False
    'Declare an Outlook application an a mail item.
    Dim oOutlookApp As Outlook.Application
    Dim oItem As Outlook.MailItem
    'Start Outlook if it isn't running.
    Set oOutlookApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then
        Set oOutlookApp = CreateObject("Outlook.Application")
    End If
    'Create a new message.
    Set oItem = oOutlookApp.CreateItem(olMailItem)
    'Add the attachments.
    oItem.Attachments.Add FileName
    oItem.Subject = "Updated Cars Land Attractions Dailies - " & Date & " " & Time
    oItem.To = ""
    oItem.CC = Environ$("Username")
    oItem.Body = "UPDATED DAILIES: Please note, these dailies have been updated with additional changes from previous versions." & vbCrLf & "*Confidential* Do not distribute to unintended parties."
    
    
    
        
    'oItem.Attachments.Add ActiveDocument.FullName
    'Show the message.
    oItem.Display
  'Cleanup
    Set FSO = Nothing
    Set FileName = Nothing
    Set oOutlookApp = Nothing
    Set oItem = Nothing
          
   'End With
    
End Sub
Sub SaveCopyToday()

Dim myCopy  As Document
Dim docName  As String
' Retrieve name of ActiveDocument
docName = ActiveDocument.Name
' Test if Activedocument has previously been saved
If ActiveDocument.Path = "" Then
     ' If not previously saved
     MsgBox "Please save the document before proceeding."
Else
MsgBox "Today's Dailies local copy will now be updated."
    ' If previously saved, create a copy
    Set myCopy = Documents.Add(ActiveDocument.FullName)
     ' Show SaveAs dialog to allow user to save copy
    ' With Dialogs(wdDialogFileSaveAs)
        '  Set name in SaveAs dialog
        ' .Name = "Copy_of_" & docName
        ' .Show
         ActiveDocument.SaveAs FileName:="C:\Users\" & Environ$("Username") & "\Digital Dailies\" & "Today_Copy_" '& docName
         ' put this back between \dailies and today copy - & Environ$("Username") & "\Digital Dailies\"
         
ActiveDocument.Save
   '  End With
     ' Close copy
     myCopy.Close
End If
End Sub
Sub SaveCopyTomorrow()

Dim myCopy  As Document
Dim docName  As String
' Retrieve name of ActiveDocument
docName = ActiveDocument.Name
' Test if Activedocument has previously been saved
If ActiveDocument.Path = "" Then
     ' If not previously saved
     MsgBox "Please save the document before proceeding."
Else
MsgBox "Tomorrow's Dailies local copy will now be updated."
    ' If previously saved, create a copy
    Set myCopy = Documents.Add(ActiveDocument.FullName)
     ' Show SaveAs dialog to allow user to save copy
    ' With Dialogs(wdDialogFileSaveAs)
        '  Set name in SaveAs dialog
        ' .Name = "Copy_of_" & docName
        ' .Show
        ActiveDocument.SaveAs FileName:="C:\Users\" & Environ$("Username") & "\Digital Dailies\" & "Tomorrow_Copy_" '& docName
                 ' put this back between \dailies and today copy - & Environ$("Username") & "\Digital Dailies\"
                 
ActiveDocument.Save
   '  End With
     ' Close copy
     myCopy.Close
End If
End Sub
Sub Macro1()
'
' Macro1 Macro
'
'
    Options.DefaultHighlightColorIndex = wdNoHighlight
    Selection.Range.HighlightColorIndex = wdNoHighlight
End Sub
 
Last edited by a moderator:
Upvote 0
There isn't any easy way to convert all those macros from Word to Excel. There are some parts that can be adapted by simply changing a reference.

For example, this statement in your Word Macro:
Code: 
Selection.Font.Color = wdColorRed

...will fail in Excel because the value of "wdColorRed" isn't assigned in Excel's VBA.
You could add a reference to the MS Word Library, or assign the value in your code module, or simply change the statement to use one of Excel's equivalent ways to change a font to Red.

This will work in Excel:
Code: 
Selection.Font.Color = vbRed

Other parts aren't so simply converted. Your Word Macro is adding text to the originally selected text, then applying different formatting to the joined text.
In Excel, to apply different formatting to different parts of the text in a single cell, the Characters object is used.

Here's a rework of the first Word Macro in your post, "CallSick", that should arrive at an equivalent result in Excel. This assumes that your "Selection" when you run the macro is a single cell. If you are trying to apply this to a selection that consists of only a substring of the value in a Cell, that's a much more difficult problem. As far as I know, you can't run an Excel in macro while a formula is being edited (including selecting characters within the formula).

Code: 
Sub CallSick()
'
' CallSick Macro converted for Excel
'
'

 Dim lCharCountPart1 As Long
 Dim sPart2 As String, sPart3

 sPart2 = " C/S (" & LCase$(Application.UserName) & ") "
 sPart3 = "                        " & Chr(30)
 
 With ActiveCell
   '--get character count before append
   lCharCountPart1 = Len(.Value)
   
   '--append
   .Value = .Value & sPart2 & sPart3
   .Font.Color = vbRed
   
   '--format the 1st part
   With .Characters(1, lCharCountPart1).Font
      .Strikethrough = True
      .Superscript = False
   End With
   
   '--format the 2nd part
   With .Characters(lCharCountPart1 + 1, Len(sPart2)).Font
      .Strikethrough = False
      .Superscript = True
   End With
   
   '--format the 3rd part
   With .Characters(lCharCountPart1 + _
         Len(sPart2) + 1, Len(sPart3)).Font
      .Strikethrough = False
      .Superscript = False
      .Underline = xlUnderlineStyleSingle
   End With
   
 End With
   
End Sub

If this code works for you for CallSick, hopefully you can adapt many of the similar "Call*..." macros using this as a guide.

Regarding the Ribbon, this article provides an introduction.

https://msdn.microsoft.com/en-us/library/cc508991(v=office.12).aspx

There's a link at the bottom of that article to a site where you can download the Office Custom UI Editor. It's a free tool provides a relatively simple means for you to retrieve the Ribbon customizations from your Word file.
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
How to move custom VBA/ribbons
2
Replies
12
Views
485
missingsc
M
V
  • Question Question
Custom Ribbon
Replies
1
Views
210
myall_blues
myall_blues
J
  • Question Question
Need VBA code to get the list of top 10 recent files from Sharepoint link on the excel ribbon as macros in excel ribbon.
Replies
0
Views
49
Julia Kurakula
J
J
  • Question Question
How to get top 10 recently modified files from the file explorer on the Excel ribbon as 10 Macros(one Macro for each of the 10 Files)
Replies
2
Views
150
Julia Kurakula
J
B
  • Question Question
Custom View Fails with "Can't push objects off the sheet", but there are no objects!
Replies
5
Views
130
BoredTrevor
B

Forum statistics

Threads
1,223,214
Messages
6,170,772
Members
452,353
Latest member
strainu

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top