|
|
All the subjects will be grouped (about 10-15 per page) for an easy download and update.
How to ...
Function LoWord(lArg)
LoWord= lArg And ( lArg Xor &HFFFF0000 )
End Function
Function HiWord(lArg)
If lArg > &H7FFFFFFF Then
HiWord = ( lArg And &HFFFF0000 ) \ &H10000
Else
HiWord = (( lArg And &HFFFF0000 ) \ &H10000) Xor &HFFFF0000
End If
End Function
Function LoByte(lArg)
LoByte= lArg Xor ( lArg And &HFF00 )
End Function
Function HiByte(lArg)
LoWord= ( lArg And &HFF00 ) \ &H100
End Function
and the second method
Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" ( _
lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Function LoWord(ByVal dw As Long) As Integer
CopyMemory LoWord, dw, 2
End Function
Function HiWord(ByVal dw As Long) As Integer
CopyMemory HiWord, ByVal VarPtr(dw) + 2, 2
End Function
On Error Resume Next 'Raise an error for 'Cancel' dlgPrintSetup.CancelError = True dlgPrintSetup.Copies = 1 dlgPrintSetup.FromPage = 1 dlgPrintSetup.Max = 2 dlgPrintSetup.Min = 1 dlgPrintSetup.ToPage = 1 dlgPrintSetup.HelpFile = "C:\WINDOWS\HELP\Winhlp32.hlp" dlgPrintSetup.HelpCommand = cdlHelpPartialKey dlgPrintSetup.HelpContext = 0 dlgPrintSetup.flags = cdlPDPrintSetup + cdlPDHidePrintToFile + cdlPDHelpButton dlgPrintSetup.ShowPrinter If Err = cdlCancel Then 'Was pressed 'Cancel' '... End If
Uses example:
Msgbox "Combo1 width = " & GetDropdownWidth(Combo1)
Call SetDropdownWidth(Combo1, GetDropdownWidth(Combo1) * 2)
In a modul:
Private Const CB_ERR = -1
Private Const CB_SETDROPPEDWIDTH = &H160
Private Const CB_GETDROPPEDWIDTH = &H15F
Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As _
Long) As Long
Public Function GetDropdownWidth(cbo As Control) As Long
Dim Ret As Long
Ret = SendMessage(cbo.hwnd, CB_GETDROPPEDWIDTH, 0, 0)
If Ret <> CB_ERR Then GetDropdownWidth = Ret
End Function
Public Sub SetDropdownWidth(cbo As Control, NewWidthPixel As Long)
Dim Ret As Long
Ret = SendMessage(cbo.hwnd, CB_SETDROPPEDWIDTH, NewWidthPixel, 0)
End Sub
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, _ ByVal nCmdShow As Long) As Long Private Const SW_HIDE = 0 Private Const SW_SHOWNORMAL = 1 Private Sub Command1_Click() Dim Ret As Long Dim ClassName As String Dim StartWindow As Long ClassName = Space(256) ClassName = "Shell_TrayWnd" StartWindow = FindWindow(ClassName, vbNullString) 'Hide the start menu bar Ret = ShowWindow(StartWindow, SW_HIDE) MsgBox "The Start Menu is hidden (or should be!)" End Sub Private Sub Command2_Click() Dim Ret As Long Dim ClassName As String Dim StartWindow As Long ClassName = Space(256) ClassName = "Shell_TrayWnd" StartWindow = FindWindow(ClassName, vbNullString) 'Display the start menu bar as normal Ret = ShowWindow(StartWindow, SW_SHOWNORMAL) MsgBox "The Start Menu should now be visible" End Sub
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Const WM_SYSCOMMAND = &H112&
Private Const SC_SCREENSAVE = &HF140&
Private Sub Command1_Click()
Dim Ret As Long
Ret = SendMessage(Form1.hWnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0&)
End Sub
Public Const SPIF_UPDATEINIFILE = &H1
Public Const SPI_SETDESKWALLPAPER = 20
Public Const SPIF_SENDWININICHANGE = &H2
Private Declare Function SystemParametersInfo Lib "User32" Alias "SystemParametersInfoA" _
(ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As String, _
ByVal fuWinIni As Long) As Long
Public Sub SetWallpaper(ByVal pFileName As String)
Dim Ret as long
Ret = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, pFileName, _
SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
End Sub
Dim objAccess As Access.Application
Set objAccess = CreateObject("access.application")
With objAccess
.OpenCurrentDatabase filepath:=App.Path & "\ceva.mdb"
.DoCmd.OpenReport reportname:="Un_raport", View:=acViewPreview
End With
Private Declare Function MCISendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Private Sub cmdOpen_Click()
Dim Ret As Long
Dim RetStr As String
Ret = MCISendString("set CDAudio door open", RetStr, 127, 0)
End Sub
Private Sub cmdClose_Click()
Dim Ret As Long
Dim RetStr As String
Ret = MCISendString("set CDAudio door closed", RetStr, 127, 0)
End Sub
Private Declare Function ModifyMenuPic Lib "user32" Alias "ModifyMenuA" (ByVal hmenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As Long) As Long Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function GetSubMenu Lib "user32" (ByVal hmenu As Long, ByVal nPos As Long) As Long Private Declare Function GetMenuItemID Lib "user32" (ByVal hmenu As Long, ByVal nPos As Long) As Long Const MF_BITMAP = 4 Const MF_BYCOMMAND = 0 Const MF_BYPOSITION = &H400& Sub Form_Load() Dim hmenu&, hSubmenu&, menuid&, result As Long ' Note the "&" characters Me.Show ' make me visible so all is initialized properly hmenu = GetMenu(Form1.hwnd) ' get handle to form menu hSubmenu = GetSubMenu(hmenu, 0) ' get handle to first submenu menuid = GetMenuItemID(hSubmenu, 0) ' get ID of first submenu item result = ModifyMenuPic(hSubmenu, menuid, MF_BYCOMMAND Or MF_BITMAP, _ menuid, Picture1.Picture) ' change first submenu item to bitmap menuid = GetMenuItemID(hSubmenu, 1) ' get second item ID result = ModifyMenuPic(hSubmenu, menuid, MF_BYCOMMAND Or MF_BITMAP, _ menuid, Picture2.Picture) ' change to bitmap End Sub
Private Type BITMAP bmType As Long bmWidth As Long bmHeight As Long bmWidthBytes As Long bmPlanes As Integer bmBitsPixel As Integer bmBits As Long End Type Private hBitmapChecked As Long Private hBitmapUnchecked As Long Private Const MF_BYPOSITION = &H400& Private Const MF_BYCOMMAND = &H0& Private Const SRCCOPY = &HCC0020 Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, _ ByVal nPos As Long) As Long Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" _ (ByVal hObject As Long, ByVal nCount As Long, _ lpObject As Any) As Long Private Declare Function GetMenuCheckMarkDimensions Lib "user32" () As Long Private Declare Function CreateBitmapIndirect Lib "gdi32" _ (lpBitmap As BITMAP) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" _ (ByVal hdc As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, _ ByVal hObject As Long) As Long Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long,_ ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, _ ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, _ ByVal ySrc As Long, ByVal dwRop As Long) As Long Private Declare Function SetMenuItemBitmaps Lib "user32" _ (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, _ ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function DeleteObject Lib "gdi32" _ (ByVal hObject As Long) As Long Private Sub Form_Activate() Dim hMenu As Long Dim x As Long Dim bm As BITMAP Dim hdc As Long Dim hOld As Long hMenu = GetMenu(Me.hwnd) ' get top-level menu If hMenu Then hMenu = GetSubMenu(hMenu, 0) ' get menu for first item x = GetMenuCheckMarkDimensions() GetObjectAPI Picture1.Image, Len(bm), bm ' get general bitmap specs bm.bmHeight = (x \ &HFFFF&) And &HFFFF& ' update size bm.bmWidth = x And &HFFFF& bm.bmBits = 0 hBitmapChecked = CreateBitmapIndirect(bm) ' create new bitmaps hBitmapUnchecked = CreateBitmapIndirect(bm) hdc = CreateCompatibleDC(Picture1.hdc) ' set up device context to use hOld = SelectObject(hdc, hBitmapChecked) ' copy bitmap... BitBlt hdc, 0, 0, bm.bmWidth, bm.bmHeight, Picture1.hdc, 0, 0, SRCCOPY x = SelectObject(hdc, hBitmapUnchecked) ' copy bitmap... BitBlt hdc, 0, 0, bm.bmWidth, bm.bmHeight, Picture2.hdc, 0, 0, SRCCOPY hOld = SelectObject(hdc, hOld) ' restore original setup DeleteDC hdc ' clean up scratch area x = SetMenuItemBitmaps(hMenu, 0, MF_BYPOSITION, hBitmapUnchecked, _ hBitmapChecked) End Sub Private Sub Form_Unload(Cancel As Integer) ' be sure to clean up memory properly! If hBitmapChecked Then DeleteObject hBitmapChecked If hBitmapUnchecked Then DeleteObject hBitmapUnchecked End Sub
Private Type MENUITEMINFO
cbSize As Long
fMask As Long
fType As Long
fState As Long
wid As Long
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As Long
cch As Long
End Type
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal bypos As Long, lpcMenuItemInfo As MENUITEMINFO) As Long
Private Const MF_BITMAP = &H4&
Private Const MFT_BITMAP = MF_BITMAP
Private Const MIIM_TYPE = &H10
Private Sub Form_Load()
Dim main_menu As Long
Dim sub_menu As Long
Dim menu_info As MENUITEMINFO
Dim i As Integer
main_menu = GetMenu(hwnd)
sub_menu = GetSubMenu(main_menu, 0)
For i = 0 To 2
With menu_info
.cbSize = Len(menu_info)
.fMask = MIIM_TYPE
.fType = MFT_BITMAP
.dwTypeData = picFace(i).Picture
End With
SetMenuItemInfo sub_menu, i, True, menu_info
Next i
End Sub
Of course, a solution is
if Check1 = vbChecked Then
Check1 = vbUnchecked
Else
Check1 = vbChecked
End If
Because Check1 = Not Check1 doesn't work we can use:
Check1 = (Not Check1) + 2
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Public Const GWL_STYLE = (-16)
Public Const ES_NUMBER = &H2000
SetWindowLong txtItins.hwnd, GWL_STYLE, _
GetWindowLong(txtItins.hwnd, GWL_STYLE) Or _
ES_NUMBER
Used like this:
Private Sub Command1_Click()
Dim MyBool As Boolean
MyBool = DelToRecycBin("c:\Myfile.txt")
If MyBool = True Then
MsgBox "File was deleted! You'll find it in Recycle Bin!"
Else
MsgBox "Error!"
End If
End Sub
In a module we have:
Private Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String
End Type
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Private Const F0_DELETE = &H3
Private Const F0F_ALLOWUNDO = &H40
Private Const FOF_CREATEPROGRESSDLG As Long = &H0
Public Function DelToRecycBin(FileName As String) As Boolean
Dim FileOperation As SHFILEOPSTRUCT
Dim lReturn As Long
On Error GoTo DelToRecycBin_Err
With FileOperation
.wFunc = F0_DELETE
.pFrom = FileName
.fFlags = F0F_ALLOWUNDO + F0F_CREATEPROGRESSDLG
End With
lReturn = SHFileOperation(FileOperation)
If lReturn <> 0 Then
DelToRecycBin = False
Else
DelToRecycBin = True
End If
Exit Function
DelToRecycBin_Err:
DelToRecycBin = False
MsgBox Err.Description
End Function
Work only with Win 98 or Win 95 with IE 4.0.
Private Declare Function SHEmptyRecycleBin Lib "shell32" Alias "SHEmptyRecycleBinA" (ByVal hwnd As Long, ByVal pszRootPath As String, ByVal dwFlags As Long) As Long
Private Sub Form_Load()
Call EmptyBin
End Sub
Private Sub EmptyBin(Optional drvBin As String)
Dim r As Long
Dim flags As Long
If drvBin = "" Then
drvBin = vbNullString 'Empty all Recycle Bins
End If
' flags values
' 1. SHERB_NOCONFIRMATION - No confirmation dialog box
' 2. SHERB_NOPROGRESSUI - No progress indicator, i.e. flying rubbish AVI
' 3. SHERB_NOSOUND - No confirmation sound
r = SHEmptyRecycleBin(Me.hwnd, drvBin, flags)
End Sub
'// At top level of a module, always include to be sure that all variables have the right type
Option Explicit
Option Compare Text
'// Then declare this array variable Crc32Table
Private Crc32Table(255) As Long
'// Then all we have to do is writing public functions like these...
Public Function InitCrc32(Optional ByVal Seed As Long = &HEDB88320, Optional ByVal Precondition As Long = &HFFFFFFFF) As Long
'// Declare counter variable iBytes, counter variable iBits, value variables lCrc32 and lTempCrc32
Dim iBytes As Integer, iBits As Integer, lCrc32 As Long, lTempCrc32 As Long
'// Turn on error trapping
On Error Resume Next
'// Iterate 256 times
For iBytes = 0 To 255
'// Initiate lCrc32 to counter variable
lCrc32 = iBytes
'// Now iterate through each bit in counter byte
For iBits = 0 To 7
'// Right shift unsigned long 1 bit
lTempCrc32 = lCrc32 And &HFFFFFFFE
lTempCrc32 = lTempCrc32 \ &H2
lTempCrc32 = lTempCrc32 And &H7FFFFFFF
'// Now check if temporary is less than zero and then mix Crc32 checksum with Seed value
If (lCrc32 And &H1) 0 Then
lCrc32 = lTempCrc32 Xor Seed
Else
lCrc32 = lTempCrc32
End If
Next
'// Put Crc32 checksum value in the holding array
Crc32Table(iBytes) = lCrc32
Next
'// After this is done, set function value to the precondition value
InitCrc32 = Precondition
End Function
'// The function above is the initializing function, now we have to write the computation function
Public Function AddCrc32(ByVal Item As String, ByVal Crc32 As Long) As Long
'// Declare following variables
Dim bCharValue As Byte, iCounter As Integer, lIndex As Long
Dim lAccValue As Long, lTableValue As Long
'// Turn on error trapping
On Error Resume Next
'// Iterate through the string that is to be checksum-computed
For iCounter = 1 To Len(Item)
'// Get ASCII value for the current character
bCharValue = Asc(Mid$(Item, iCounter, 1))
'// Right shift an Unsigned Long 8 bits
lAccValue = Crc32 And &HFFFFFF00
lAccValue = lAccValue \ &H100
lAccValue = lAccValue And &HFFFFFF
'// Now select the right adding value from the holding table
lIndex = Crc32 And &HFF
lIndex = lIndex Xor bCharValue
lTableValue = Crc32Table(lIndex)
'// Then mix new Crc32 value with previous accumulated Crc32 value
Crc32 = lAccValue Xor lTableValue
Next
'// Set function value the the new Crc32 checksum
AddCrc32 = Crc32
End Function
'// At last, we have to write a function so that we can get the Crc32 checksum value at any time
Public Function GetCrc32(ByVal Crc32 As Long) As Long
'// Turn on error trapping
On Error Resume Next
'// Set function to the current Crc32 value
GetCrc32 = Crc32 Xor &HFFFFFFFF
End Function
'// And for testing the routines above...
Public Sub Main()
Dim lCrc32Value As Long
On Error Resume Next
lCrc32Value = InitCrc32()
lCrc32Value = AddCrc32("This is the original message!", lCrc32Value)
Debug.Print Hex$(GetCrc32(lCrc32Value))
End Sub
Private Declare Function w32_WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA" (ByVal lpszLocalName As String, ByVal lpszUserName As String, lpcchBuffer As Long) As Long Private Sub Form_Load() Dim lpUserName As String, lpnLength As Long, lResult As Long lpUserName = String(256, Chr$(0)) lResult = w32_WNetGetUser(vbNullString, lpUserName, 256) If lResult = 0 Then lpUserName = Left$(lpUserName, InStr(1, lpUserName, Chr$(0)) - 1) MsgBox "User name is: " + lpUserName + ".", vbInformation + vbOKOnly, App.Title Else MsgBox "Don't find !", vbExclamation + vbOKOnly, App.Title End If End Sub
Option Explicit
Private Const WS_VERSION_REQD = &H101
Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
Private Const MIN_SOCKETS_REQD = 1
Private Const SOCKET_ERROR = -1
Private Const WSADescription_Len = 256
Private Const WSASYS_Status_Len = 128
Private Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLength As Integer
hAddrList As Long
End Type
Private Type WSADATA
wversion As Integer
wHighVersion As Integer
szDescription(0 To WSADescription_Len) As Byte
szSystemStatus(0 To WSASYS_Status_Len) As Byte
iMaxSockets As Integer
iMaxUdpDg As Integer
lpszVendorInfo As Long
End Type
Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired&, lpWSAData As WSADATA) As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal hostname$, HostLen&) As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal hostname$) As Long
Private Declare Sub RtlMoveMemory Lib "KERNEL32" (hpvDest As Any, ByVal hpvSource&, ByVal cbCopy&)
Function hibyte(ByVal wParam As Integer)
hibyte = wParam \ &H100 And &HFF&
End Function
Function lobyte(ByVal wParam As Integer)
lobyte = wParam And &HFF&
End Function
Sub SocketsInitialize()
Dim WSAD As WSADATA
Dim iReturn As Integer
Dim sLowByte As String, sHighByte As String, sMsg As String
iReturn = WSAStartup(WS_VERSION_REQD, WSAD)
If iReturn <> 0 Then
MsgBox "Winsock.dll is not responding."
End
End If
If lobyte(WSAD.wversion) < WS_VERSION_MAJOR Or (lobyte(WSAD.wversion) = WS_VERSION_MAJOR And hibyte(WSAD.wversion) < WS_VERSION_MINOR) Then
sHighByte = Trim$(Str$(hibyte(WSAD.wversion)))
sLowByte = Trim$(Str$(lobyte(WSAD.wversion)))
sMsg = "Windows Sockets version " & sLowByte & "." & sHighByte
sMsg = sMsg & " is not supported by winsock.dll "
MsgBox sMsg
End
End If
If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then
sMsg = "This application requires a minimum of "
sMsg = sMsg & Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."
MsgBox sMsg
End
End If
End Sub
Sub SocketsCleanup()
Dim lReturn As Long
lReturn = WSACleanup()
If lReturn <> 0 Then
MsgBox "Socket error " & Trim$(Str$(lReturn)) & " occurred in Cleanup """
End
End If
End Sub
Private Sub Command1_Click()
Dim hostname As String * 256
Dim hostent_addr As Long
Dim host As HOSTENT
Dim hostip_addr As Long
Dim temp_ip_address() As Byte
Dim i As Integer
Dim ip_address As String
If gethostname(hostname, 256) = SOCKET_ERROR Then
MsgBox "Windows Sockets error " & Str(WSAGetLastError())
Else
hostname = Trim$(hostname)
End If
hostent_addr = gethostbyname(hostname)
If hostent_addr = 0 Then
MsgBox "Winsock.dll is not responding."
End If
RtlMoveMemory host, hostent_addr, LenB(host)
RtlMoveMemory hostip_addr, host.hAddrList, 4
ReDim temp_ip_address(1 To host.hLength)
RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength
For i = 1 To host.hLength
ip_address = ip_address & temp_ip_address(i) & "."
Next
ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
MsgBox hostname
MsgBox ip_address
End Sub
Private Sub Form_Load()
SocketsInitialize
End Sub
Private Sub Form_Unload(Cancel As Integer)
SocketsCleanup
End Sub
© VB Work 2000, Last update