- 积分
- 2468
- 明经币
- 个
- 注册时间
- 2004-7-22
- 在线时间
- 小时
- 威望
-
- 金钱
- 个
- 贡献
-
- 激情
-
|
楼主 |
发表于 2005-1-6 11:59:00
|
显示全部楼层
65.读写INI文件模块
Option Explicit
'读写INI文件模块
Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal AppName As String, ByVal KeyName As String, ByVal keydefault As String, ByVal Filename As String) As Long
Public Function myReadINI(iniFileName, iniSection, iniKey, iniDefault)
'该函数的使用与读注册表类似
'inifilename为INI文件名，inisection为INI文件中的项目，inikey为项目下的键名称，inidefault为默认键值
'If no section (appname), default is first appname
'（若无项目名，默认为初始名称）
'if no key, default is first key
'（若无键名，默认为初始键名）
Dim lpApplicationName As String
Dim lpKeyName As String
Dim lpDefault As String
Dim lpReturnedString As String
Dim nSize As Long
Dim lpFileName As String
Dim retval As Long
Dim Filename As String
'判断INI文件是否存在
If Dir(iniFileName) <> "" Then
lpDefault = Space$(254)
lpDefault = iniDefault
lpReturnedString = Space$(254)
nSize = 254
lpFileName = iniFileName
lpApplicationName = iniSection
lpKeyName = iniKey
Filename = lpFileName
retval = GetPrivateProfileString(lpApplicationName, lpKeyName, lpDefault, lpReturnedString, nSize, lpFileName)
myReadINI = lpReturnedString
End If
End Function
Public Function myWriteINI(iniFileName As String, iniSection As String, iniKey As String, Info As String) As String
'该函数的使用与写注册表类似，可在INI文件中添加或修改项、键、值
'iniFileName为INI文件名，inisection为INI文件中的项目，inikey为项目下的键名称，Info为键值
Dim retval As Long
retval = WritePrivateProfileString(iniSection, iniKey, Info, iniFileName)
myWriteINI = LTrim$(Str$(retval))
End Function
Public Sub DelSectionINI(iniFileName As String, iniSection As String)
'该过程可删除INI文件中指定的项
'iniFileName为INI文件名，iniSection为指定的项
'判断INI文件是否存在
If Dir(iniFileName) <> "" Then
WritePrivateProfileString iniSection, vbNullString, vbNullString, iniFileName
End If
End Sub
Public Sub DelKeyINI(iniFileName As String, iniSection As String, iniKey As String)
'该过程可删除INI文件中指定的键
'iniFileName为INI文件名，iniSection为指定的项，iniKey为指定的键
'判断INI文件是否存在
If Dir(iniFileName) <> "" Then
WritePrivateProfileString iniSection, iniKey, vbNullString, iniFileName
End If
End Sub
Public Sub DelValueINI(iniFileName As String, iniSection As String, iniKey As String)
'该过程可删除INI文件中指定键的值
'iniFileName为INI文件名，iniSection为指定的项，iniKey为指定的键
'判断INI文件是否存在
If Dir(iniFileName) <> "" Then
WritePrivateProfileString iniSection, iniKey, "", iniFileName
End If
End Sub
Public Sub DelFileINI(iniFileName As String)
'该过程可删除INI文件
'iniFileName为INI文件名
'判断INI文件是否存在
If Dir(iniFileName) <> "" Then
Kill iniFileName
End If
End Sub
66.显示浏览文件夹对话框
Option Explicit
'显示浏览文件夹对话框
' 调用方式:: string = BrowseForFolders(Hwnd,TitleOfDialog)
' 例如:String1 = BrowseForFolders(Hwnd, "Select target folder...")
Public Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Public Const BIF_RETURNONLYFSDIRS = 1
Public Const MAX_PATH = 260
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 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 Function BrowseForFolder(hwndOwner As Long, sPrompt As String) As String
Dim iNull As Integer
Dim lpIDList As Long
Dim lResult As Long
Dim sPath As String
Dim udtBI As BrowseInfo
'初始化变量
With udtBI
.hwndOwner = hwndOwner
.lpszTitle = lstrcat(sPrompt, "")
.ulFlags = BIF_RETURNONLYFSDIRS
End With
'调用 API
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String$(MAX_PATH, 0)
lResult = SHGetPathFromIDList(lpIDList, sPath)
Call CoTaskMemFree(lpIDList)
iNull = InStr(sPath, vbNullChar)
If iNull Then sPath = Left$(sPath, iNull - 1)
End If
'如果选择取消, sPath = ""
BrowseForFolder = sPath
End Function
67.注册表读写模块
Option Explicit
'注册表读写模块
'This program needs 3 buttons
Public Const REG_DWORD = 4
Const ERROR_SUCCESS = 0&
Const KEY_ALL_ACCESS = &H3F
Public Const REG_SZ = 1 ' Unicode nul terminated string
Public Const REG_BINARY = 3 ' Free form binary
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const REG1_KEY = "software\microsoft\windows\currentversion\run"
Public Const REG2_KEY = "software\microsoft\windows\currentversion\RunServices"
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Public Function RegQueryStringValue(ByVal hKey As Long, ByVal strValueName As String) As String
Dim lResult As Long, lValueType As Long, strBuf As String, lDataBufSize As Long
'retrieve nformation about the key
lResult = RegQueryValueEx(hKey, strValueName, 0, lValueType, ByVal 0, lDataBufSize)
If lResult = 0 Then
If lValueType = REG_SZ Then
'Create a buffer
strBuf = String(lDataBufSize, Chr$(0))
'retrieve the key's content
lResult = RegQueryValueEx(hKey, strValueName, 0, 0, ByVal strBuf, lDataBufSize)
If lResult = 0 Then
'Remove the unnecessary chr$(0)'s
RegQueryStringValue = Left$(strBuf, InStr(1, strBuf, Chr$(0)) - 1)
End If
ElseIf lValueType = REG_BINARY Then
Dim strData As Integer
'retrieve the key's value
lResult = RegQueryValueEx(hKey, strValueName, 0, 0, strData, lDataBufSize)
If lResult = 0 Then
RegQueryStringValue = strData
End If
End If
End If
End Function
Public Function GetString(hKey As Long, strPath As String, strValue As String)
Dim Ret
'Open the key
RegOpenKey hKey, strPath, Ret
'Get the key's content
GetString = RegQueryStringValue(Ret, strValue)
'Close the key
RegCloseKey Ret
End Function
Public Sub SaveString(hKey As Long, strPath As String, strValue As String, strData As String)
Dim Ret
'Create a new key
RegCreateKey hKey, strPath, Ret
'Save a string to the key
RegSetValueEx Ret, strValue, 0, REG_SZ, ByVal strData, Len(strData)
'close the key
RegCloseKey Ret
End Sub
Public Sub SaveStringLong(hKey As Long, strPath As String, strValue As String, strData As String)
Dim Ret
'Create a new key
RegCreateKey hKey, strPath, Ret
'Set the key's value
RegSetValueEx Ret, strValue, 0, REG_BINARY, CByte(strData), 4
'close the key
RegCloseKey Ret
End Sub
Public Sub DelSetting(hKey As Long, strPath As String, strValue As String)
Dim Ret
'Create a new key
RegCreateKey hKey, strPath, Ret
'Delete the key's value
RegDeleteValue Ret, strValue
'close the key
RegCloseKey Ret
End Sub
Public Sub SaveRegDWORD(hKey As Long, strPath As String, strValueName As String, strData As String)
Dim Ret
'Create a new key
RegCreateKey hKey, strPath, Ret
'Save a DWORD to the key
RegSetValueEx Ret, strValueName, 0, REG_DWORD, CByte(strData), 4
'close the key
RegCloseKey Ret
End Sub
68.API打造浮动按钮
Option Base 1
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Public Declare Function TrackMouseEvent Lib "user32" (lpEventTrack As TRACKMOUSEEVENTTYPE) As Long
'--------------------------------------------------------------------------------------------GDI相关函数
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public 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
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
'--------------------------------------------------------------------------------------------
Public Const TME_LEAVE = &H2&
Public Const ODS_SELECTED = &H1
Public Const ODT_BUTTON = 4
Public Const WM_DRAWITEM = &H2B
Public Const WM_MEASUREITEM = &H2C
Public Const IMAGE_BITMAP = 0
Public Const LR_LOADFROMFILE = &H10
Public Const BS_OWNERDRAW = &HB&
Public Const GWL_WNDPROC = (-4)
Public Const WM_MOUSEMOVE = &H200
Public Const WM_MOUSELEAVE = &H2A3
Public Const WM_LBUTTONUP = &H202
Public Const WS_CHILD = &H40000000
Public Const WS_VISIBLE = &H10000000
Public Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
'-------------------------以下是自定义按钮状态常数
Public Const Leave = 1 '离开按钮范围
Public Const Click = 2 ' 按下按钮
Public Const Undo = 3 '松开按钮
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type DRAWITEMSTRUCT '自绘控件的绘图结构，另外由于它在WIN32里面是唯一的结构，所以在VB里面要用到CopyMemory这个API函数直接指向它的地址
CtlType As Long
CtlID As Long
ItemID As Long
itemAction As Long
itemState As Long
hwndItem As Long
hdc As Long
rcItem As RECT
itemData As Long
End Type
Public Type MEASUREITEMSTRUCT '自绘时候设置控件的大小'同上
CtlType As Long
CtlID As Long
ItemID As Long
itemWidth As Long
itemHeight As Long
itemData As Long
End Type
Public Type TRACKMOUSEEVENTTYPE
cbSize As Long
dwFlags As Long
hwndTrack As Long
dwHoverTime As Long
End Type
Public ImageHandle(3) As Long
Public OldMainProc As Long
Public OldButtonProc As Long
Public CmdHwnd As Long
Public MouseLeave As Boolean
Public Sub Initialize() '初始化
LoadPic
MouseLeave = True
MainProc
CreateOwnerDrawButton
ButtonProc
End Sub
Public Sub MainProc() '窗口自类化（NewMainProc)
OldMainProc = SetWindowLong(Form1.hwnd, GWL_WNDPROC, AddressOf NewMainProc)
End Sub
Public Sub ButtonProc() '按钮自类化(NewButtonProc)
OldButtonProc = SetWindowLong(CmdHwnd, GWL_WNDPROC, AddressOf NewButtonProc)
End Sub
Public Sub CreateOwnerDrawButton() '创造一个自绘按钮
CmdHwnd = CreateWindowEx(0, "Button", "", WS_CHILD Or BS_OWNERDRAW Or WS_VISIBLE, 50, 60, 70, 25, Form1.hwnd, 0, App.hInstance, 0)
Dim dc As Long
dc = GetDC(CmdHwnd)
drawPic Leave
End Sub
Public Function NewMainProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long '处理主窗口消息
Select Case Msg
Case WM_DRAWITEM
OnDrawItem lParam
Exit Function
Case WM_MEASUREITEM
OnMeasureItem lParam
End Select
NewMainProc = CallWindowProc(OldMainProc, hwnd, Msg, wParam, lParam)
End Function
Public Function NewButtonProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long '处理按钮消息
Select Case Msg
Case WM_MOUSELEAVE
Button_MouseLeave
MouseLeave = True
Case WM_MOUSEMOVE
Button_MouseMove
Case WM_LBUTTONUP
Button_MouseLButtonUp
End Select
NewButtonProc = CallWindowProc(OldButtonProc, hwnd, Msg, wParam, lParam)
End Function
Public Sub Button_MouseMove() '鼠标移动事件
drawPic Undo
If MouseLeave = True Then
MouseLeave = False
Dim MouseTrack As TRACKMOUSEEVENTTYPE
With MouseTrack
.cbSize = Len(MouseTrack)
.dwFlags = TME_LEAVE
.hwndTrack = CmdHwnd
End With
TrackMouseEvent MouseTrack
End If
End Sub
Public Sub Button_MouseLButtonUp() '左键按下事件
Debug.Print "已按下左键"
End Sub
Public Sub Button_MouseLeave() '离开事件
drawPic Leave
Debug.Print "已离开按钮的范围"
End Sub
Public Sub OnMeasureItem(lParam As Long) '设置的大小
Dim lpMIS As MEASUREITEMSTRUCT
CopyMemory lpMIS, ByVal lParam, Len(lpMIS)
lpMIS.itemHeight = 25
lpMIS.itemWidth = 70
CopyMemory ByVal lParam, lpMIS, Len(lpMIS)
End Sub
Public Sub OnDrawItem(lParam As Long) '为按钮绘制样貌
Dim lpDIS As DRAWITEMSTRUCT
CopyMemory lpDIS, ByVal lParam, Len(lpDIS)
Dim mem As Long
Dim Object As Long
mem = CreateCompatibleDC(hdc)
If lpDIS.CtlType = ODT_BUTTON Then
If lpDIS.itemState And ODS_SELECTED Then '按下时外貌
drawPic Click
Else '松开时外貌
If MouseLeave = True Then
drawPic Leave
Else
drawPic Undo
End If
End If
End If
CopyMemory ByVal lParam, lpDIS, Len(lpDIS)
End Sub
Public Sub LoadPic() '读取图片
ImageHandle(1) = LoadImage(App.hInstance, App.Path & "\" & "1.bmp", IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE)
ImageHandle(2) = LoadImage(App.hInstance, App.Path & "\" & "2.bmp", IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE)
ImageHandle(3) = LoadImage(App.hInstance, App.Path & "\" & "3.bmp", IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE)
End Sub
Public Sub drawPic(State As Long) '为按钮绘制不同状态的图案
Dim hdc As Long
Dim mem As Long
Dim Object As Long
hdc = GetDC(CmdHwnd)
mem = CreateCompatibleDC(hdc)
Object = SelectObject(mem, ImageHandle(State))
BitBlt hdc, 0, 0, 70, 25, mem, 0, 0, SRCCOPY
DeleteObject Object
DeleteDC mem
End Sub
|
|
[复制链接]
显身卡
发表于 2005-1-6 22:06:00