Excel renaming Activex Controls on other computers

2019-03-04 15:40发布

I have a worksheet with Activex Controls(Combobox, Command Button, Option Button, CheckBox). On my computer I have renamed all the controls (Ex. CButtonPMR, OButton_Comp, etc) But when I open the file on other computer all the controls are renamed to default the default names (CheckBox1,Checkbox2, CommandButton1, etc) For that reason the code doesn't works on other computers. I am getting errors every time because the code can't compile. Is there a way to fix this?

I basically have 2 forms into one and there is 2 option button to chose wich one you want. When the user select a Button the other form is Hidden


 Private Sub OpButtonComp_Click()
 Dim ws As Worksheet
 Set ws = ThisWorkbook.Sheets("Sheet1")
Dim protect As Boolean
protect = False
If ActiveSheet.ProtectContents Then
        protect = True
        ActiveSheet.Unprotect Password:="password"
End If
Application.ScreenUpdating = False


ActiveSheet.Rows("13:61").Hidden = True
ActiveSheet.Rows("62:86").Hidden = False
ActiveSheet.Rows("6").Hidden = True
Dim rng As Range
Set rng = ActiveSheet.Range("A62:P62")
   With ActiveSheet.OLEObjects("CButtonPMB")
       .Top = rng.Top
        .Left = rng.Left
        .Width = rng.Width
        .Height = rng.RowHeight
    End With
ActiveSheet.OLEObjects("CButtonPMB").Visible = True


   Set rng = ActiveSheet.Range("A72:P72")
    With ActiveSheet.OLEObjects("CButtonMQSB")
        .Top = rng.Top
        .Left = rng.Left
        .Width = rng.Width
        .Height = rng.RowHeight
    End With
ActiveSheet.OLEObjects("CButtonMQSB").Visible = True

   Set rng = ActiveSheet.Range("A79:P79")
    With ActiveSheet.OLEObjects("CButtonMQS2B")
        .Top = rng.Top
        .Left = rng.Left
        .Width = rng.Width
        .Height = rng.RowHeight
    End With
ActiveSheet.OLEObjects("CButtonMQS2B").Visible = True

   Set rng = ActiveSheet.Range("A85:P85")
    With ActiveSheet.OLEObjects("CButtonPM2B")
        .Top = rng.Top
        .Left = rng.Left
        .Width = rng.Width
        .Height = rng.RowHeight
    End With
ActiveSheet.OLEObjects("CButtonPM2B").Visible = True


Application.ScreenUpdating = True
If Not (ActiveSheet.ProtectContents) And protect = True Then
            ActiveSheet.protect Password:="password"
            End If

End Sub





Private Sub OpButtonCon_Click()
Dim protect As Boolean
protect = False
If ActiveSheet.ProtectContents Then
        protect = True
        ActiveSheet.Unprotect Password:="password"
End If
Application.ScreenUpdating = False


ActiveSheet.Rows("13:61").Hidden = False
ActiveSheet.Rows("62:86").Hidden = True
ActiveSheet.Rows("6").Hidden = False
ActiveSheet.CButtonPMB.Visible = False
ActiveSheet.CButtonMQSB.Visible = False
ActiveSheet.CButtonMQS2B.Visible = False
ActiveSheet.CButtonPM2B.Visible = False

Application.ScreenUpdating = True
If Not (ActiveSheet.ProtectContents) And protect = True Then
            ActiveSheet.protect Password:="password"
            End If

End Sub

This is to pop up a DatePicker Form when those cells are selected.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)


      '   Only look at that range

    If Intersect(Target, Range("N12:P12")) Is Nothing _
    And Intersect(Target, Range("N15:P15")) Is Nothing _
    And Intersect(Target, Range("N29:P29")) Is Nothing _
    And Intersect(Target, Range("N37:P37")) Is Nothing _
    And Intersect(Target, Range("N44:P44")) Is Nothing _
    And Intersect(Target, Range("N50:P50")) Is Nothing _
    And Intersect(Target, Range("N51:P51")) Is Nothing _
    And Intersect(Target, Range("N59:P59")) Is Nothing _
    And Intersect(Target, Range("N70:P70")) Is Nothing _
    And Intersect(Target, Range("N78:P78")) Is Nothing _
    And Intersect(Target, Range("N83:P83")) Is Nothing Then
        Exit Sub
    Else
    'Show Datepicker
        CalendarFrm.Show
    End If
End Sub

Thank you

Since my answer was deleted I'll post the solution here. If anyone is wondering, I managed to fix it by following this http://www.excelclout.com/microsoft-update-breaks-excel-activex-controls-fix/

Copy and paste the following VBA code into any module in the spreadsheet.

Public Sub RenameMSFormsFiles() 
    Const tempFileName As String = "MSForms - Copy.exd"  
    Const msFormsFileName As String = "MSForms.exd"  
    On Error Resume Next 

    'Try to rename the C:\Users\[user.name]\AppData\Local\Temp\Excel8.0\MSForms.exd file  
    RenameFile Environ("TEMP") & "\Excel8.0\" & msFormsFileName, Environ("TEMP") & "\Excel8.0\" & tempFileName 
    'Try to rename the C:\Users\[user.name]\AppData\Local\Temp\VBE\MSForms.exd file  
    RenameFile Environ("TEMP") & "\VBE\" & msFormsFileName, Environ("TEMP") & "\VBE\" & tempFileName 
End Sub  

Private Sub RenameFile(fromFilePath As String, toFilePath As String) 
    If CheckFileExist(fromFilePath) Then 
        DeleteFile toFilePath  
        Name fromFilePath As toFilePath  
    End If  
End Sub  

Private Function CheckFileExist(path As String) As Boolean 
    CheckFileExist = (Dir(path) <> "")  
End Function  

Private Sub DeleteFile(path As String) 
    If CheckFileExist(path) Then 
        SetAttr path, vbNormal  
        Kill path  
    End If  
End Sub 

Call the RenameMSFormsFiles subroutine at the very beginning of the workbook_Open event.

Private Sub Workbook_Open() 
    RenameMSFormsFiles  
End Sub

0条回答
登录 后发表回答