I am receiving a 'Type Mistmatch' error on the HWNDSrc = objIE.HWND line below but HWND is a Long property & HWNDSrc has been set as Long
Sub Test()
Dim objIE As InternetExplorer
Set objIE = New InternetExplorer
Dim HWNDSrc As Long
HWNDSrc = objIE.HWND
SetForegroundWindow HWNDSrc
End Sub
SetForegroundWindow is a Windows API function that takes and returns LongPtr on 64-bit Office, and Long on 32 bit Office, so you need to account for that using conditional compilation constants. See this for reference.
Option Explicit
#If VBA7 Then
Public Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
#Else
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
#End If
Sub Test()
Dim objIE As InternetExplorer
Set objIE = New InternetExplorer
#If VBA7 Then
Dim HWNDSrc As LongPtr
#Else
Dim HWNDSrc As Long
#End If
HWNDSrc = objIE.hwnd
SetForegroundWindow HWNDSrc
End Sub
Related
We have a user table in a SQL Server 2014 that I link to in an Access database front end and the password is in binary 64 so that the password cannot be seen if someone were to open the table somehow in SSMS.
But Access knows all this and completely converts it to the actual password. How do I get around this yet still use it to validate data entered into a login form?
You hash the password. Storing passwords as plaintext without hashing is a major bad practice.
Read more about hashing on Wikipedia. The short version it's a one-way operation: if you have the password, you can create the hash, but if you have the hash, there's no way to get the password except trying to hash random passwords and see if they're the same.
However, hashing in VBA is rather complicated. There are more simple answers that use .Net hashing objects, but I use the CNG API, which has numerous advantages such as hardware crypto support, zero dependencies and flexibility in the choice of algorithm:
Public Declare PtrSafe Function BCryptOpenAlgorithmProvider Lib "BCrypt.dll" (ByRef phAlgorithm As LongPtr, ByVal pszAlgId As LongPtr, ByVal pszImplementation As LongPtr, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptCloseAlgorithmProvider Lib "BCrypt.dll" (ByVal hAlgorithm As LongPtr, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptCreateHash Lib "BCrypt.dll" (ByVal hAlgorithm As LongPtr, ByRef phHash As LongPtr, pbHashObject As Any, ByVal cbHashObject As Long, ByVal pbSecret As LongPtr, ByVal cbSecret As Long, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptHashData Lib "BCrypt.dll" (ByVal hHash As LongPtr, pbInput As Any, ByVal cbInput As Long, Optional ByVal dwFlags As Long = 0) As Long
Public Declare PtrSafe Function BCryptFinishHash Lib "BCrypt.dll" (ByVal hHash As LongPtr, pbOutput As Any, ByVal cbOutput As Long, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptDestroyHash Lib "BCrypt.dll" (ByVal hHash As LongPtr) As Long
Public Declare PtrSafe Function BCryptGetProperty Lib "BCrypt.dll" (ByVal hObject As LongPtr, ByVal pszProperty As LongPtr, ByRef pbOutput As Any, ByVal cbOutput As Long, ByRef pcbResult As Long, ByVal dfFlags As Long) As Long
Public Function NGHash(pData As LongPtr, lenData As Long, Optional HashingAlgorithm As String = "SHA1") As Byte()
'Erik A, 2019
'Hash data by using the Next Generation Cryptography API
'Loosely based on https://learn.microsoft.com/en-us/windows/desktop/SecCNG/creating-a-hash-with-cng
'Allowed algorithms: https://learn.microsoft.com/en-us/windows/desktop/SecCNG/cng-algorithm-identifiers. Note: only hash algorithms, check OS support
'Error messages not implemented
On Error GoTo VBErrHandler
Dim errorMessage As String
Dim hAlg As LongPtr
Dim algId As String
'Open crypto provider
algId = HashingAlgorithm & vbNullChar
If BCryptOpenAlgorithmProvider(hAlg, StrPtr(algId), 0, 0) Then GoTo ErrHandler
'Determine hash object size, allocate memory
Dim bHashObject() As Byte
Dim cmd As String
cmd = "ObjectLength" & vbNullString
Dim Length As Long
If BCryptGetProperty(hAlg, StrPtr(cmd), Length, LenB(Length), 0, 0) <> 0 Then GoTo ErrHandler
ReDim bHashObject(0 To Length - 1)
'Determine digest size, allocate memory
Dim hashLength As Long
cmd = "HashDigestLength" & vbNullChar
If BCryptGetProperty(hAlg, StrPtr(cmd), hashLength, LenB(hashLength), 0, 0) <> 0 Then GoTo ErrHandler
Dim bHash() As Byte
ReDim bHash(0 To hashLength - 1)
'Create hash object
Dim hHash As LongPtr
If BCryptCreateHash(hAlg, hHash, bHashObject(0), Length, 0, 0, 0) <> 0 Then GoTo ErrHandler
'Hash data
If BCryptHashData(hHash, ByVal pData, lenData) <> 0 Then GoTo ErrHandler
If BCryptFinishHash(hHash, bHash(0), hashLength, 0) <> 0 Then GoTo ErrHandler
'Return result
NGHash = bHash
ExitHandler:
'Cleanup
If hAlg <> 0 Then BCryptCloseAlgorithmProvider hAlg, 0
If hHash <> 0 Then BCryptDestroyHash hHash
Exit Function
VBErrHandler:
errorMessage = "VB Error " & Err.Number & ": " & Err.Description
ErrHandler:
If errorMessage <> "" Then MsgBox errorMessage
Resume ExitHandler
End Function
Public Function HashBytes(Data() As Byte, Optional HashingAlgorithm As String = "SHA512") As Byte()
HashBytes = NGHash(VarPtr(Data(LBound(Data))), UBound(Data) - LBound(Data) + 1, HashingAlgorithm)
End Function
Public Function HashString(str As String, Optional HashingAlgorithm As String = "SHA512") As Byte()
HashString = NGHash(StrPtr(str), Len(str) * 2, HashingAlgorithm)
End Function
You can now use the HashString function to hash passwords. When someone enters a password, always use HashString(password) to look up the password or store a hashed password. You never store an actual unhashed password.
Of course, this also means that even you can not view passwords of users, only their hashes.
If you want to improve this further, you can use a salt to avoid rainbow table attacks. But only adding a hash will already substantially improve security.
I'm using VBA in MS Access. I'm trying search through ie tabs (15 of them) bring the found tab to the foreground, maximise it, then find on page a string i'm searching for. I can find the tab using the code below but its not maximising the window and nor are the send keys working to find on page. Is there a way using the shell to do this?
Option Compare Database
#If Win64 Then
Private Declare PtrSafe Function SetForegroundWindow Lib "user32" _
(ByVal hWnd As LongPtr) As LongPtr
#Else
Private Declare Function SetForegroundWindow Lib "user32" _
(ByVal hWnd As Long) As Long
#End If
Private Sub P2_Click()
Dim sURL As String
Dim strSearch As String
Dim SWs As Object
sURL = CStr(Me.tblOdds_1_sURL)
strSearch = Mid(Me.P2, 1, 5)
'get windows
Set SWs = CreateObject("Shell.Application")
For Each ow In SWs.windows
If ow = "Internet Explorer" _
And sURL = Trim(ow.Document.Location) Then
SetForegroundWindow ow.hWnd
SendKeys "^f", False
SendKeys strSearch, False
SendKeys "{ENTER}", False
SendKeys "{ESC}", False
End If
Next ow
Set SWs = Nothing
End Sub
I have a access database with some forms and vba code behind the forms.
On Form_Open (on every form) I have this piece of code.
Dim hWindow As Long
Dim nResult As Long
Dim nCmdShow As Long
hWindow = Application.hWndAccessApp
nCmdShow = SW_HIDE
nResult = ShowWindow(ByVal hWindow, ByVal nCmdShow)
Call ShowWindow(Me.hWnd, SW_NORMAL)
This hides Access and shows only the opened form.
My problem is that Access is starting, but the form will not open.
I have to kill the Access task in task manager.
Is there any way to solve the problem?
EDIT: Every form is a PopUp
As I understand, you need to hide main form and leave popup form open. I normally use window opacity settings instead of hiding:
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Const LWA_ALPHA As Long = &H2&
Private Const LWA_COLORKEY As Long = &H1&
Private Const GWL_EXSTYLE As Long = -20
Private Const WS_EX_LAYERED As Long = &H80000
Public Function SetWndOpacity(hwnd As Long, opacity As Byte, clr As Long)
DoCmd.Maximize
SetWindowLong hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
SetLayeredWindowAttributes hwnd, 0&, opacity, LWA_ALPHA
End Function
Then call:
SetWndOpacity Access.hWndAccessApp(), 0, 0
I use this program in winx86 without any error but when i try use it in win x64 my problems started.
I use ptrsafe in my code to let me run in win 7 64bit, I'll add that this module have more code but for limitations of this site i had delete that. if need to now that lines of my code tell me to put them here.
please help me and tell me Why my code produce an error:
'UDT for passing data through the hook
Private Type MSGBOX_HOOK_PARAMS
hwndOwner As Long
hHook As Long
End Type
Private MSGHOOK As MSGBOX_HOOK_PARAMS
#If VBA7 Then
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
#Else
Private Declare Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
#End If
Public Function MsgBoxHookProc(ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
If uMsg = HCBT_ACTIVATE Then
SetDlgItemText wParam, vbYes, "بلـي"
SetDlgItemText wParam, vbNo, "خـير"
SetDlgItemText wParam, vbIgnore, "انصـراف"
SetDlgItemText wParam, vbOK, "تـــاييد"
UnhookWindowsHookEx MSGHOOK.hHook
End If
MsgBoxHookProc = False
End Function
Public Function MsgBoxFa(Prompt, Optional Buttons As VbMsgBoxStyle = vbOKOnly, Optional Tiltle = "", Optional HelpFile, Optional Context) As Long
'Wrapper function for the MessageBox API
Dim hwndThreadOwner As Long
Dim frmCurrentForm As Form
Set frmCurrentForm = Screen.ActiveForm
hwndThreadOwner = frmCurrentForm.hwnd
Dim hInstance As Long
Dim hThreadId As Long
Dim hwndOwner As Long
hwndOwner = GetDesktopWindow()
hInstance = GetWindowLong(hwndThreadOwner, GWL_HINSTANCE)
hThreadId = GetCurrentThreadId()
With MSGHOOK
.hwndOwner = hwndOwner
'in next line the error produced******************************
.hHook = SetWindowsHookEx(WH_CBT, _
AddressOf MsgBoxHookProc, _
hInstance, hThreadId)
End With
MsgBoxFa = MessageBox(hwndThreadOwner, Prompt, Tiltle, Buttons)
End Function
I have an access database with about 5000 records and each has a bmp stored in the database as an OLE. I am using Lebans OLEtoDisk, http://www.lebans.com/oletodisk.htm, to replace the objects with a file path, however, the code can only get through about 150 records and then I get an error "out of memory." I cannot figure out what is clogging up the memory. The OLEtoDisk functions use the clipboard, but I clear it after every record. Anyone have any ideas, or maybe just a way to clear all memory?
Here is the code I am using. First is the command button click event:
Option Compare Database
Option Explicit
Private Declare Function apiDeleteObject Lib "gdi32" Alias "DeleteObject" (ByVal hObject As Long) As Long
Private Declare Function apiOpenClipboard Lib "user32" Alias "OpenClipboard" (ByVal hwnd As Long) As Long
Private Declare Function apiEmptyClipboard Lib "user32" Alias "EmptyClipboard" () As Long
Private Declare Function apiCloseClipboard Lib "user32" Alias "CloseClipboard" () As Long
Private Declare Function CountClipboardFormats Lib "user32" () As Long
Sub EmptyClipboard()
Call apiOpenClipboard(0&)
Call apiEmptyClipboard
Call apiCloseClipboard
End Sub
Private Sub cmdCreateIPicture_Click()
DoCmd.SetWarnings False
' *********************
' You must set a Reference to: "OLE Automation" for this function to work. Goto the Menu and select Tools->References
' Scroll down to: Ole Automation and click in the check box to select this reference.
Dim lngRet, lngBytes, hBitmap As Long
Dim hpix As IPicture
Dim intRecordCount As Integer
intRecordCount = 0
Me.RecordsetClone.MoveFirst
Do While Not Me.RecordsetClone.EOF
If intRecordCount Mod 25 = 0 Then
EmptyClipboard
DoEvents
Excel.Application.CutCopyMode = False
Debug.Print "cleared"
End If
Me.Bookmark = Me.RecordsetClone.Bookmark
Me.OLEBound19.SetFocus
DoCmd.RunCommand acCmdCopy
hBitmap = GetClipBoard
Set hpix = BitmapToPicture(hBitmap)
SavePicture hpix, "C:\Users\PHammett\Images\" & intRecordCount & ".bmp"
DoCmd.RunSQL "INSERT INTO tblImageSave2 (newPath,oldPath) VALUES (""C:\Users\PHammett\Images\" & intRecordCount & """,""" & Me.RecordsetClone!Path & """);"
apiDeleteObject (hBitmap)
Set hpix = Nothing
EmptyClipboard
Me.RecordsetClone.MoveNext
intRecordCount = intRecordCount + 1
Loop
DoCmd.SetWarnings True
End Sub
Here is the code that resides in a module
Option Compare Database
Option Explicit
Private Const vbPicTypeBitmap = 1
Private Type IID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type PictDesc
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PictDesc, RefIID As IID, ByVal fPictureOwnsHandle As Long, Ipic As IPicture) As Long
'windows API function declarations
'does the clipboard contain a bitmap/metafile?
Private Declare Function IsClipboardFormatVailable Lib "user32" (ByVal wFormat As Integer) As Long
'open the clipbarod to read
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
'get a pointer to the bitmap/metafile
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
'empty the keyboard
Private Declare Function EmptyClipboard Lib "user32" () As Long
'close the clipobard
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function CopyEnhMetaFila Lib "gdi32" Alias "CopyEnhMetaFilaA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
'The API format types
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Const xlPicture = CF_BITMAP
Const xlBitmap = CF_BITMAP
Public Function BitmapToPicture(ByVal hBmp As Long, Optional ByVal hPal As Long = 0&) As IPictureDisp
'Copyr ight: Lebans Holdings 1999 Ltd.
' May not be resold in whole or part. Please feel
' free to use any/all of this code within your
' own application without cost or obligation.
' Please include the one line Copyright notice
' if you use this function in your own code.
'
'Name: BitmapToPicture &
' GetClipBoard
'
'Purpose: Provides a method to save the contents of a
' Bound or Unbound OLE Control to a Disk file.
' This version only handles BITMAP files.
' '
'Author: Stephen Lebans
'Email: Stephen#lebans.com
'Web Site: www.lebans.com
'Date: Apr 10, 2000, 05:31:18 AM
'
'Called by: Any
'
'Inputs: Needs a Handle to a Bitmap.
' This must be a 24 bit bitmap for this release.
Dim lngRet As Long
Dim Ipic As IPicture, picdes As PictDesc, iidIPicture As IID
picdes.Size = Len(picdes)
picdes.Type = vbPicTypeBitmap
picdes.hBmp = hBmp
picdes.hPal = hPal
iidIPicture.Data1 = &H7BF80980
iidIPicture.Data2 = &HBF32
iidIPicture.Data3 = &H101A
iidIPicture.Data4(0) = &H8B
iidIPicture.Data4(1) = &HBB
iidIPicture.Data4(2) = &H0
iidIPicture.Data4(3) = &HAA
iidIPicture.Data4(4) = &H0
iidIPicture.Data4(5) = &H30
iidIPicture.Data4(6) = &HC
iidIPicture.Data4(7) = &HAB
'create the picture from the bitmap handle
lngRet = OleCreatePictureIndirect(picdes, iidIPicture, True, Ipic)
Set BitmapToPicture = Ipic
End Function
Public Function GetClipBoard() As Long
' Adapted from original Source Code by:
'* MODULE NAME: Paste Picture
'* AUTHOR & DATE: STEPHEN BULLEN, Business Modelling Solutions Ltd.
'* 15 November 1998
'*
'* CONTACT: Stephen#BMSLtd.co.uk
'* WEB SITE: http://www.BMSLtd.co.uk
Dim hClipBoard As Long
Dim hBitmap As Long
Dim hBitmap2 As Long
hClipBoard = OpenClipboard(0&)
If hClipBoard <> 0 Then
hBitmap = GetClipboardData(CF_BITMAP)
If hBitmap = 0 Then GoTo exit_error
hBitmap2 = CopyImage(hBitmap, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
hClipBoard = EmptyClipboard
hClipBoard = CloseClipboard
GetClipBoard = hBitmap2
End If
Exit Function
exit_error:
GetClipBoard = -1
End Function
Public Function ClearClipboard()
EmptyClipboard
CloseClipboard
End Function
...but I clear it after every record
Try DoEvents after this code.