Module declaration Option ExplicitPublic Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongPublic Const CB_RESETCONTENT = & H14BPublic Const CB_SHOWDROPDOWN = & H14FPublic Const CB_LIMITTEXT = & H141Public Const LB_RESETCONTENT = & h184 'Add Check, Combo, List, 2 Button' Features: Quick Clear, Combo Automatic Down, Limited CONST FAST_CLEAR = 1const Slow_Clear = 2DIM M_IAMOUNT AS INTEGER
Private Sub Command1_Click () ClearLists (fast_clear) populateListSend SUB
Private Sub command2_Click () clearlists (slow_clear) populatelistsEnd Sub 'slow and rapid clearance compared Clear Private Function clearlists (intspeed) Dim istart As LongDim iend As LongDim ielapsed As LongDim icomboelapsed As LongDim ilistelapsed As LongDim intret As IntegerDim intlistcount As IntegerDim intcounter As Integer
Me.MousePointer = vbHourglassSelect Case intspeedCase fast_clear istart = Timer intret = SendMessage (Combo1.hwnd, CB_RESETCONTENT, 1, ByVal 0 &) iend = Timer icomboelapsed = iend - istart istart = Timer intret = SendMessage (List1.hwnd, LB_RESETCONTENT, 1, ByVal 0 &) iend = Timer ilistelapsed = iend - istart Case slow_clear istart = GetTickCount intlistcount = Combo1.ListCount For icounter = 0 To intlistcount - 1 Combo1.RemoveItem intcounter Next iend = GetTickCount icomboelapsed = iend - istart istart = GetTickCount intlistcount = List1.ListCount For icounter = 0 to intlistcount - 1 List1.RemoveItem intcounter Next iend = GetTickCount ilistelapsed = iend - istartEnd SelectMe.MousePointer = vbDefaultMsgBox "clear time combo used:" Str $ (icomboelapsed) "millsecond" MsgBox "clear time list used : " Str $ (ilistelapsed) " Millsecond "End Function" Limited length private sub check1_click () intret = sendMessage (Combo1.hwnd, CB_LIMIT TEXT, 10, ByVal 0 &) End Sub 'when the focused, combo automatically drop down Private Sub Combo1_GotFocus () Dim intret As Longintret = SendMessage (Combo1.hwnd, CB_SHOWDROPDOWN, 1, ByVal 0 &) End SubPrivate Sub Form_Load () m_iamount = 500PopulatelistSend Sub
Private sub populatelists () populatecombopopuliteListBoxend Sub
Private sub populitelistbox () DIM ICOUNTER AS INTEGER
For icounter = 0 to m_iamountlist1.additem "Item" Str $ (iCounter) Nextme.MousePointer = VBDEFAULTLIST1.LISTINDEX = 0nd Sub
Private sub populationCombo () DIM ICOUNTER AS INTEGER
For icounter = 0 to m_iamountcombo1.additem "Item" Str $ (iCounter) Nextme.MousePointer = VBDEFAULTCOMBO1.LISTINDEX = 0nd Sub Database Information Table: TEST Field: BH (Profile, Text), BB (Text) Data: 101, 2001102 , respectively 2001103,2001104,2002105,2002106,2002107,2003107,2003 two buttons below illustrates two methods to extract information from the database is filled treeview referenced microsoft activex data objects 2.x libraryDim nddata As NodeDim cnn As ADODB.ConnectionDim rs1 As new adodb.recordsetdim rs2 as new adoDb.recordset
Private submmand1_click ()
ON Error ResMe next
Set nddata = TreeView1.nodes.add (, "db", "class information") nddata.expanded = true
DIM INTCOUNT AS INTEGERDIM INTTABLE AS INTEGERDIM INTFIELD AS INTEGERDIM INTFN AS INTEGERDIM MTABLE, FLD
Rs1.open "Select Bb from Test Group BB", CNN, 1, 3IntTable = rs1.recordcount
Do While INTTABLE <> INTCOUNT SET NDDATA = TreeView1.nodes.Add ("DB", TVWChild, "F" & RS1.Fields ("BB"), RS1.Fields ("BB")) rs2.open "SELECT BH, Bb from test where bb = '"& rs1.fields (" bb ") &"' ", cnn, 1, 3 intfield = rs2.recordcount if intfield <> 0 THEN INTFN = 0 do while intfield <> intfn set nddata = TreeView1.nodes.Add ("F" & RS1.Fields ("BB"), TVWChild, "S" & rs2.fields ("BH"), RS2.Fields ("BH")) rs2.movenext intfn = intfn 1 loop end if rs2.close = intcount 1looprs1.closend Sub
Private sub fascist2_click () on error resume next.com nddata = trecess (, "db", "class information") nddata.expanded = true
DIM INTCOUNT AS INTEGERDIM INTTABLE AS INTEGERDIM INTFIELD AS INTEGERDIM INTFN AS INTEGERDIM MTABLE, FLDDIM CA AS STRING
RS1.Open "Select * from test", CNN, 1, 3INTTABLE = RS1.Recordcount
Do While NOT RS1.EOF IF CA <> rs1.fields ("BB") THEN SET NDDATA = TreeView1.Nodes.Add ("DB", TVWChild, "F" & RS1.Fields ("BB"), RS1.Fields ("BB")) CA = rs1.fields ("bb") endiffs.add ("f" & rs1.fields ("f"), TVwchild, "s" & rs1.fields "BH"), RS1.Fields ("BH")) rs1.movenextLooprs1.closend Sub
Private Sub Form_Load () SET CNN = New AdoDb.connectionCn.Open "provike = microsoft.jet.oledb.4.0; Data Source = f: / 9cbs_vb / database / treeview Node Add / 1/Article.mdb"
End Sub
Private Sub Form_Unload (Cancel As Integer) Set Con = Nothingend Sub Classic VBS Code
Logout / Start / close Local Windows NT / 2000 Computer
Sub shutdown () DIM Connection, WQL, SystemClass, SYSTEM
Get connection to local wmiset connection = getObject ("Winmgmts: root / cimv2")
GET WIN32_OPERATISYSTEM OBJECTS - ONLY One Object in The CollectionWQL = "SELECT NAME FROM WIN32_OPERATINGSYSTEM" SESTEMCLASS = Connection.execQuery (WQL)
Get One System Objecti Think The IS No Way To Get The Object Url? For Each System in SystemClassystem.win32shutdown (2) Nextend Sub
Logout / restart / close remote Windows NT / 2000 computer
Sub ShutDownEx (Server, User, Password) Dim Connection, WQL, SystemClass, System Get connection To remote wmi Dim Locator Set Locator = CreateObject ( "WbemScripting.SWbemLocator") Set Connection = Locator.ConnectServer (Server, "root / cimv2", User, Password) Get Win32_OperatingSystem objects - only one object In the collection WQL = "Select Name From Win32_OperatingSystem" Set SystemClass = Connection.ExecQuery (WQL) Get one system object I think there is no way To get the object using URL For Each? SYSTEMCLASS System.Win32Shutdown (2) NEXTEND SUB The above two segments are used in WIN32_OPERATIONSYSTEM in WIN32SHUTDOWN (FLAG) in WIN32SHUTDOWN (FLAG) in WIN32SHUTDOWN (FLAG), can be any of the table below: Value Description 0 Logout 0 4 Mandatory cancellation 1 shutdown 1 4 forced shutdown 2 weight 2 4 forced restart 8 Turn off power 8 4 forced shutdown power supply
Write binary files using AdoDb.Stream object
Function savebinarydata (filename, byteArray) const adtypebinary = 1const AdsaveCreateOverWrite = 2
Create Stream Objectdim BinaryStream = CreateObject ("AdoDb.Stream")
Specify Stream Type - We Want to Save Binary Data.BinaryStream.Type = adtypebinary
Open the stream and write binary data to the objectbinarystream.openbinarystream.write byteArray
Save Binary Data To DiskbinaryStream.savetofile FileName, AdsavecreateOverWriteEnd Function
Write a text file using the Adodb.Stream object
Function SavetextData (FileName, Text, Charset) const adtypetext = 2const AdsavecreateOverWrite = 2
Create Stream Objectdim BinaryStream = CreateObject ("AdoDb.Stream")
Specify Stream Type - We Want to Save Text / String Data.BinaryStream.Type = AdTypetext
Specify Charset for the Source Text (Unicode) Data.if Len (Charset)> 0 ThenbinaryStream.charset = Charseteetend IF
Open the stream and write binary data to the objectbinarystream.openbinarystream.writext Textsave Binary Data To DiskbinaryStream.savetofile FileName, AdsaveCreateOverWriteEnd Function
Read binary files using AdoDb.Stream objects
Function readbinaryfile (filename) const adtypebinary = 1
Create Stream Objectdim BinaryStream = CreateObject ("AdoDb.Stream")
Specify Stream Type - We Want To Get Binary Data.BinaryStream.Type = Adtypebinary
Open the streambainarystream.open
Load The File Data from Disk to Stream ObjectBinaryStream.LoadFromfile FileName
Open the stream and get binary data from the objectReadbinaryfile = binarystream.read function
Read the text file using the AdoDb.Stream object
Function readtextfile (filename, charset) const adtypetext = 2
Create Stream Objectdim BinaryStream = CreateObject ("AdoDb.Stream")
Specify Stream Type - We Want To Get Binary Data.BinaryStream.Type = AdTypetext
Specify Charset for the Source Text (Unicode) Data.if Len (Charset)> 0 ThenbinaryStream.charset = Charseteetend IF
Open the streambainarystream.open
Load The File Data from Disk to Stream ObjectBinaryStream.LoadFromfile FileName
Open the stream and get binary data from the objectReadTextFile = binarystream.readtextend function
Write files using the FileSystemObject object
Function SavebinaryDataTextStream (FileName, ByteArray) Create FileSystemObject Objectdim Fs: Set Fs = CreateObject ("scripting.filesystemObject")
Create Text Street TextStream = fs.createtextFile (filename)
Convert binary data to text and write the the the filetextStream.write binarytostring (byteaRray) End function Read and write ini files for Windows
Sub WriteINIStringVirtual (Section, KeyName, Value, FileName) WriteINIString Section, KeyName, Value, _Server.MapPath (FileName) End SubFunction GetINIStringVirtual (Section, KeyName, Default, FileName) GetINIStringVirtual = GetINIString (Section, KeyName, Default, _Server.MapPath ( FileName)) End FunctionWork with INI files In VBS (ASP / WSH) v1.002003 Antonin Foller, PSTRUH Software, http: //www.pstruh.czFunction GetINIString (Section, KeyName, Default, FileName) Sub WriteINIString (Section, KeyName, Value, filename
Sub WriteinInstring (Section, Keyname, Value, FileName) DIM INICONTENTS, POSSECTION, POSENDSECTION
Get Contents of the INI File As a stringinicontents = getfile (filename)
Find sectionPosSection = InStr (1, INIContents, "[" & Section & "]", vbTextCompare) If PosSection> 0 ThenSection exists. Find end of sectionPosEndSection = InStr (PosSection, INIContents, vbCrLf & "[")? Is this last section ? If posendsection = 0 THEN POSENDSECTION = LEN (INICONTENTS) 1
Separate Section Contentsdim Oldscontents, NewsContents, Linedim SkeyName, Foundoldscontents = MID (INICONTENTENTS, POSSECTION, POSENDSECTION - POSSECTION) Oldscontents = Split (OldsContents, VBCRLF)
Temp variable to find a keyskeyname = lcase (keyname & "=")
Enumerate section linesFor Each Line In OldsContentsIf LCase (Left (Line, Len (sKeyName))) = sKeyName ThenLine = KeyName & "=" & ValueFound = TrueEnd IfNewsContents = NewsContents & Line & vbCrLfNext
If isempty (Found) Thenkey Not found - add it at the end of sectionNewsContents = NewsContents & KeyName & "=" & ValueElseremove last vbCrLf - the vbCrLf is at PosEndSectionNewsContents = Left (NewsContents, Len (NewsContents) - 2) End IfCombine pre- section, new section And post-section data.INIContents = Left (INIContents, PosSection-1) & _NewsContents & Mid (INIContents, PosEndSection) elseif PosSection> 0 ThenSection Not found. Add section data at the end of file contents.If Right ( INIContents, 2) <> vbCrLf And Len (INIContents)> 0 Then INIContents = INIContents & vbCrLf End IfINIContents = INIContents & "[" & Section & "]" & vbCrLf & _KeyName & "=" & Valueend ifif PosSection> 0 ThenWriteFile FileName , INICONTENTSEND SUB
Function GetInistring (Section, Keyname, Default, FileName) Dim INICONTENTS, POSSECTION, POSENDSECTION, SCONTENTS, VALUE, FOUND
Get Contents of the INI File As a stringinicontents = getfile (filename)
Find sectionPosSection = InStr (1, INIContents, "[" & Section & "]", vbTextCompare) If PosSection> 0 ThenSection exists. Find end of sectionPosEndSection = InStr (PosSection, INIContents, vbCrLf & "[")? Is this last section ? If posendsection = 0 THEN POSENDSECTION = LEN (INICONTENTS) 1
Separate Section ContentsSContents = MID (INICONTENTS, POSSECTION, POSENDSECTION - POSSECTION)
If InStr (1, sContents, vbCrLf & KeyName & "=", vbTextCompare)> 0 ThenFound = TrueSeparate value of a key.Value = SeparateField (sContents, vbCrLf & KeyName & "=", vbCrLf) End IfEnd IfIf isempty (Found) Then Value = DefaultGetINIString = ValueEnd FunctionSeparates one field between sStart And sEndFunction SeparateField (ByVal sFrom, ByVal sStart, ByVal sEnd) Dim PosB: PosB = InStr (1, sFrom, sStart, 1) If PosB> 0 ThenPosB = PosB Len (sStart Dim Pose: POSE = INSTR (POSB, SFROM, Send, 1) if Pose = 0 Then Pose = IF POSB, SFROM, VBCRLF, 1) IF POSE = 0 Then Pose = LEN (SFROM) 1seParateField = MID (SFROM) , POSB, POSE - POSB) End ifend function
File functionsFunction GetFile (ByVal FileName) Dim FS: Set FS = CreateObject ( "Scripting.FileSystemObject") Go To windows folder If full path Not specified.If InStr (FileName, ": /") = 0 And Left (FileName, 2) <> "//" Then filename = fs.getspecialfolder (0) & "/" & filenamend ifon error resume next
Getfile = fs.opentextfile (filename) .readallend function
Function Writefile (Byval FileName, BYVAL Contents)
DIM FS: SET FS = CreateObject ("scripting.filesystemObject") on error resume next
GO to Windows Folder if Full Path Not Specified.if Instr (filename, ": /") = 0 and Left (filename, 2) <> "//" Then filename = fs.getspecialfolder (0) & "/" & filenamend IF
Dim OutStream: Set OutStream = FS.OpenTextFile (FileName, 2, True) OutStream.Write ContentsEnd Function Change wallpaper Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any BYVAL Fuinini as long) As longconst spi_setdeskwallpaper = 20
Private submmand1_click ()
DIM CHANGEWPDIM S AS STRINGS = "C: /Windows/waves.bmp" changep = systemparametersinfo (spi_setdeskwallpaper, 0, s, 0)
MsgBox "Wallpaper has been changed to" & S & "," INSTANT WALLPAPER CHANGER "and how to call another menu to find the calculator window with getMenu to get the" View "menu with GetSubmenu The handle of the item Get the "scientific" ID to send WM_COMMAND to this calculator window with GetMenuitemid
Run this program, first turn on the calculator Option Explicit
Private Declare Function GetMenu Lib "user32.dll" (ByVal hwnd As Long) As LongPrivate Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any ) As LongPrivate Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPrivate Declare Function GetMenuItemID Lib "user32.dll" (ByVal hMenu As Long, ByVal nPos As Long) As Longprivate Declare Function GetSubmenu Lib "User32.dll" (Byval NPOS as long) As long
Private const wm_command as long = & h111
PRIVATE SUB Command1_Click () DIM H1 AS Long, H2 As Long, ID As long h1 = findwindow (VBnullString, "Calculator") 'Calculator H2 = GetMenu (H1) H2 = GetSubmenu (H2, 1)' "View "Handle ID = GetMenuItemID (H2, 1) 'scientific ID SendMessage H1, WM_COMMAND, ID, BYVAL 0 & End Sub Using API Trivate Type SHFILEOPSTRUCT HWND As Long Wfunc as long' on file operation instruction PFROM As String 'source file path or the pTo As String' object file or the path fFlags As Integer 'operation flag fAnyOperationsAborted As Long hNameMappings As Long lpszProgressTitle As StringEnd TypePrivate Declare Function SHFileOperation Lib _ "shell32" _ (lpFileOp As SHFILEOPSTRUCT) As Long
Const fo_copy = & h2const fo_delete = & h3const fo_move = & h1const fo_rename = & h4const fof_allowundo = & h40const FOF_NOCONFIrmation = & H10
Private submmand1_click () DIM XFile As Shfileopstruct 'Copy Xfile.pfrom = "C: / BBB /*] XFile.pto =" C: / AAA "XFile.fflags = FOF_NOCONFIRTION XFILE.WFUNC = FO_COPY XFILE.HWND = ME .hwnd if shfileOperation (xfile) THEN END IF End Sub
Private sub fascist2_click () DIM XFile AS SHFILEOPSTRUCT 'Delete XFile.pfrom = "C: / bmp /*.*"' XFile.PTO = "C: /" XFile.Wfunc = fo_delete XFile.hwnd = me.hwnd 'Put Fflags Set to FOF_ALLOWUNDO 'Allows the deleted file to be placed in the recycle station XFile.fflags = FOF_ALLOWUNDO if ShfileOperation (Xfile) Then Debug.print "Success" end iFend SUB
Private submmand3_click () DIM XFile As ShfileopStruct 'Change Name XFile.pfrom = "C: /123.Doc" xfile.pto = "c: /456.doc" xfile.wfunc = fo_renamexfile.hwnd = me.hwndif shfileOperation (xfile) Thenend IF 'Move XFile.pfrom = "C: /BMP/EEE.BMP" XFile.pto = "C: /" XFile.Wfunc = FO_MOVEXFILE.HWND = Me.hwndif ShfileOperation (Xfile) Thenend IFEND SUB uses a recursive algorithm delete strip Directory with multi-level subdirectory
Option expedition
Private submmand1_click () DIM strpathname as stringstrpathname = "" strpathname = inputbox ("Please enter the folder name you want to delete:", "Delete Folder") if strpathname = "" "Exit Sub
ON Error Goto ErrorHandleSetattr strpathname, VBNORMAL 'This trip is mainly to check the validity of folder name. RecurseTree strpathnamelabel1.caption = "folder" & strpathname "has been deleted!" EXIT SUBERRORHANDLE: MSGBOX "invalid folder name:" & StrPathnameEnd Sub
Sub Recursetree (Currpath As String) DIM SFileName As Stringdim NewPath As Stringdim Spath As StringStatic Oldpath As String
Spath = currpath & "/"
'31 meaning sFileName = Dir (sPath, 31) :31 = vbNormal vbReadOnly vbHidden vbSystem vbVolume vbDirectoryDo While sFileName <> "" If sFileName <> "." And sFileName <> ".." ThenIf GetAttr ( sPath & sFileName) and vbDirectory Then 'directories and folders if newPath = sPath & sFileNameRecurseTree newPathsFileName = Dir (sPath, 31) ElseSetAttr sPath & sFileName, vbNormalKill (sPath & sFileName) Label1.Caption = sPath & sFileName' delete process sFileName = Dirend ifelsesfilename = Dirend ifdoeventsloopSetattr currpath, VBNORMALRMDIR CURRPATHLABEL1.CAPTION = CURRPATHEND SUB Gets the hard disk serial number Option Explicit 'This line is required, and it is necessary to make structure replication. There are arrays in the structure. So, there is no way to miss the option base 0Private const DFP_GET_VERSION = & H74080Private const DFP_SEND_DRIVE_COMMAND = & H7C084Private const DFP_RECEIVE_DRIVE_DATA = & H7C088
'#Pragma pack (1) Private Type TGETVERSIONOUTPARAMS' {bVersion As Byte 'Binary driver version. BRevision As Byte' Binary driver revision. BReserved As Byte 'Not used. BIDEDeviceMap As Byte' Bit map of IDE devices. FCapabilities As Long 'Bit Mask of Driver Capabilities. dwreserved (3) as long 'forfuture us.end Type
Private Type TIDEREGS bFeaturesReg As Byte 'Used for specifying SMART "commands". BSectorCountReg As Byte' IDE sector count register bSectorNumberReg As Byte 'IDE sector number register bCylLowReg As Byte' IDE low order cylinder value bCylHighReg As Byte 'IDE high order cylinder value bDriveHeadReg As Byte 'IDE drive / head register bCommandReg As Byte' Actual IDE command. bReserved As Byte 'reserved for future use. Must be zero.End TypePrivate Type TSENDCMDINPARAMS cBufferSize As Long' Buffer size in bytes irDriveRegs As TIDEREGS 'Structure with drive register values BDRIVENUMBER AS BYTE 'Physical Drive Number To Send' Command TO (0, 1, 2, 3). BRESERVED (2) AS BYTE 'RESERVED for Future Expansion. Dwreserved (3) As long' for Future Use. 'BBuffer (0 ) AS BYTE 'Input Buffer.end Type
Private Type TDRIVERSTATUS bDriverError As Byte 'Error code from driver,' or 0 if no error. BIDEStatus As Byte 'Contents of IDE Error register.' Only valid when bDriverError 'is SMART_IDE_ERROR. BReserved (1) As Byte' Reserved for future expansion. DWRESERVED (1) As long 'reserved for Future Expansion.end Type
Private Type TSENDCMDOUTPARAMS cBufferSize As Long 'Size of bBuffer in bytes DRIVERSTATUS As TDRIVERSTATUS' Driver status structure. BBuffer (511) As Byte 'Buffer of arbitrary length' in which to store the data read from the drive.End Type
'The following structure is to copy data from another structure, so it must be the number of bytes and the VC's full consistency' without using a compatible variable, but we still use compatible variables, integer, because this structure This' type of variable program is not used in the program, if you want to use it, it is recommended to change to the Byte type. Because VB is no USHORTPrivate Type TIDSECTOR wGenConfig As Integer wNumCyls As Integer wReserved As Integer wNumHeads As Integer wBytesPerTrack As Integer wBytesPerSector As Integer wSectorsPerTrack As Integer wVendorUnique (2) As Integer sSerialNumber (19) As Byte wBufferType As Integer wBufferSize As Integer wECCSize As Integer sFirmwareRev ( 7) As Byte sModelNumber (39) As Byte wMoreVendorUnique As Integer wDoubleWordIO As Integer wCapabilities As Integer wReserved1 As Integer wPIOTiming As Integer wDMATiming As Integer wBS As Integer wNumCurrentCyls As Integer wNumCurrentHeads As Integer wNumCurrentSectorsPerTrack As Integer ulCurrentSectorCapacity (3) As Byte 'here only a byte, because there is no VB unsigned variable LONG wMultSectorStuff as Integer ulTotalAddressableSectors (3) as byte 'here only by byte, because there is no VB unsigned variable LONG wSingleWordDMA as Integer wMultiWordDMA as Integer bReserved (127) as ByteEnd type
'/ * Global Vars' --- * / Private Vers As TgetversionOutParamsprivate In_Data As Tsendcmdinparamsprivate Out_Data As Tsendcmdoutparamsprivate H AS Longprivate I As LongPrivate J AS Byte
Private Type OsversionInfo DWOSVERSIONFOSITION As Long Dwmajorversion As long dwminorversion as long dwbuildnumber as long dwplatformid as long szcsdversion as string * 128nd Type
Private Declare Function GetversionEx Lib "kernel32" Alias "getversionexa" _ (LPVERSIONICATION As OsversionInfo) AS Long
Private Const VER_PLATFORM_WIN32S = 0Private Const VER_PLATFORM_WIN32_WINDOWS = 1Private Const VER_PLATFORM_WIN32_NT = 2Private Declare Function CreateFile Lib "kernel32" _ Alias "CreateFileA" (ByVal lpFileName As String, _ ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, _ ByVal lpSecurityAttributes As Long, _ ByVal DWCREATIONDISPSITION As Long, _ Byval dwflagsandattributes as long, Byval HTemplateFile As Long _ as long
Private Const CREATE_NEW = 1Private Const GENERIC_READ = & H80000000Private Const GENERIC_WRITE = & H40000000Private Const OPEN_EXISTING = 3Private Const FILE_SHARE_READ = & H1Private Const FILE_SHARE_WRITE = & H2
Private Type Overlapped Internal As Long InternalHigh As Long Offset As Long Offseth AS Long HEVENT AS LONGEND TYPE
Private Declare Function DeviceIoControl Lib "kernel32" _ (ByVal hDevice As Long, ByVal dwIoControlCode As Long, _ lpInBuffer As Any, ByVal nInBufferSize As Long, _ lpOutBuffer As Any, ByVal nOutBufferSize As Long, _ lpBytesReturned As Long, lpOverlapped As OVERLAPPED) As Long
Private Declare Function CloseHandle Lib "Kernel32" (Byval Hobject As Long) AS Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RTLMoveMemory" (_ hpvdest as any, hpvsource as any, byval cbcopy as ring)
'Private sub copyright ()' 'VC original copyright code (when released, please pay attention to the way to use an annotation, please do not delete the way to infringe, thank you!)' ************* *********************************************************** ************ 'CERR << Endl << "HDD Identifier V1.0 for WIN95 / 98 / ME / NT / 2000. Written By Lu Lin" << Endl' 'CERR << "For more information, please visits" "2000.11.3" <************************************************ *********************************************************** **************** 'DIM STRMSG AS STRING'STRMSG = STRMSG & "Calls API Deviceiocontrol directly from Ring3 to get the VB program for hard disk information"' strmsg = strmsg & vbcrlf & "VC source is as follows:" 'strmsg = strmsg & vbcrlf & "********************************** *************************** "'strmsg = strmsg & vbcrlf &" HDD Identifier v1.0 for Win95 / 98 / ME / NT / 2000. Written By Lu Lin "'strmsg = strmsg & vbcrlf &" for more information, please visit inside programming: http://lu0.126.com "' strmsg = strmsg & vbcrlf &" 2000.11.3 "'strmsg = strmsg & vbcrlf & "**************************************************** ************* "'strmsg = strmsg & vbcrlf &" VB program System: BARDO "'strmsg = STRMSG & VBCRLF &" Site: Oriental Hot News: http://www.eaStht.net "' strmsg = strmsg & vbcrlf &" Mail: Sales@eaSTHOT.NET "'strmsg = strmsg & vbcrlf & "2003.01.23" 'MSGBOX STRMSG'ENEND SUB
SUB ChangeByte, USCSTRING () AS BYTE, USCSTRSIZE, USCSTRSIZE TEMP AS STRING for I = 0 TO USCSTRSIZE - 1 Step 2 Temp = Szstring (i) Szstring (i) = szstring (i 1) szstring i 1) = Temp next Iend Subprivate Function HDID9X (strHDID As String) AS String
'We start in 95/98 / me h = createfile ("//./ SmartVSD", 0, 0, 0, create_new, 0, 0) IF h = 0 THEN HDID9X = "open smartvsd.vxd failed" EXIT function end IF DIM OLP AS OVERLAPPED DIM LRET AS Long Dim LPIN AS Long Dim LPRET AS Long LPIN = 0 & LPRET = I Lret = DeviceioControl (H, DFP_GET_VERSION, VARPTR (LPIN), 0, VERS, LEN (VERS), VARPTR (LPRET), olp) If lRet = 0 Then hdid9x = "DeviceIoControl failed: DFP_GET_VERSION" CloseHandle (h) Exit Function End If 'If IDE identify command not supported, fails If (vers.fCapabilities And 1) <> 1 Then hdid9x = "Error: IDE identify command not supported. "CloseHandle (h) Exit Function End If 'Display IDE drive number detected Dim sPreOutStr As String sPreOutStr = DetectIDE (vers.bIDEDeviceMap) hdid9x = sPreOutStr j = 0Dim phdinfo As TIDSECTORDim s (40) As Byte
IF (j and 1) = 1 THEN IN_DATA.IRDRIVEREGS.BDRIVEHEADREG = & HB0ELSE IN_DATA.IRDRIVEREGS.BDRIVEHEADREG = & HA0END IFIF (Vers.Fcapabilities and (16 / (2 ^ j))) = (16 / (2 ^ j)) THEN 'We don't detect a atapi device. Hdid9x = "drive" & cstr (j 1) & "is a atapi device, we don't detect it" else in_data.irdriveRiveRIVEREGS.BCOMMANDREG = & hec in_data.bdrivenumber = j in_data .irDriveRegs.bSectorCountReg = 1 in_data.irDriveRegs.bSectorNumberReg = 1 in_data.cBufferSize = 512 LpRet = i lRet = DeviceIoControl (h, DFP_RECEIVE_DRIVE_DATA, in_data, Len (in_data), out_data, Len (out_data), VarPtr (LpRet), olp) If lRet = 0 Then hdid9x = "DeviceIoControl failed: DFP_RECEIVE_DRIVE_DATA" CloseHandle (h) Exit Function End If Dim StrOut As String CopyMemory phdinfo, out_data.bBuffer (0), Len (phdinfo) CopyMemory s (0), phdinfo.sSerialNumber (0 ), 20 s (20) = 0 ChangebyteORDER S, 20 strHDID = BYTEARRTOSTRING (S, 20) end if 'close handle reference quit closehandle (h)' CopyRightens Function restriction text box entry length Private sub text1_change () const definength = 6 'You allow the length of the entry. IF lenb (text1.text, vbfromunication)> DefineLength TEEN TEXT1.TEXT = Left (Text1.Text, Len (Text1.Text) - 1) Text1.Selstart = LEN (Text1.Text) End IFEND SUB first stickers of.
'Set screen resolution and color deep
Option expedition
Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As BooleanPrivate Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwFlags As Long) As LongPrivate Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As LongPrivate Const DM_BITSPERPEL = & H40000Private Const DM_PELSWIDTH = & H80000Private Const DM_PELSHEIGHT = & H100000Private Const CDS_TEST = & H4Private Const CDS_UPDATEREGISTRY = & H1Private Const DISP_CHANGE_SUCCESSFUL = 0Private Const DISP_CHANGE_RESTART = 1Private Const ccDevicename = 32Private const ccFormName = 32Private const EWX_REBOOT = 2
Private Type DEVMODE dmDeviceName As String * CCDEVICENAME dmSpecVersion As Integer dmDriverVersion As Integer dmSize As Integer dmDriverExtra As Integer dmFields As Long dmOrientation As Integer dmPaperSize As Integer dmPaperLength As Integer dmPaperWidth As Integer dmScale As Integer dmCopies As Integer dmDefaultSource As Integer dmPrintQuality As Integer dmColor As Integer dmDuplex As Integer dmYResolution As Integer dmTTOption As Integer dmCollate As Integer dmFormName As String * CCFORMNAME dmUnusedPadding As Integer dmBitsPerPel As Integer dmPelsWidth As Long dmPelsHeight As Long dmDisplayFlags As Long dmDisplayFrequency As LongEnd Type
Private Sub Command1_Click () SetDisplaySettings 800, 600, 16nd Sub
Private Sub Command2_Click () SetDisplaySettings 1024, 768, 32nd Sub
'Set the screen resolution and color depth' screen width is the Width, Height of the screen height, ColorDepth of color depth Function SetDisplaySettings (ByVal Width As Long, ByVal Height As Long, Optional ByVal ColorDepth As Integer) As Boolean Dim DevM As DEVMODE, r As Long, answer As Long EnumDisplaySettings 0 &, 0 &, DevM 'DevM collect information DevM.dmFields = IIf (ColorDepth = 0, DM_PELSWIDTH Or DM_PELSHEIGHT, DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL) DevM.dmPelsWidth = width' screen width DevM.dmPelsHeight = Height ' screen height DevM.dmBitsPerPel = ColorDepth 'color depth (8,16,32 bit) r = ChangeDisplaySettings (DevM, CDS_UPDATEREGISTRY) Select Case r Case DISP_CHANGE_RESTART SetDisplaySettings = True answer = MsgBox ( "you must restart your computer, you sure?" , vbYesNo vbSystemModal vbQuestion, "restart") If answer = vbYes Then r = ExitWindowsEx (EWX_REBOOT, 0 &) Case DISP_CHANGE_SUCCESSFUL SetDisplaySettings = True Case Else SetDisplaySettings = False End SelectEnd FunctionPrivate Su B form_load () Command1.caption = "800 x 600" Command2.caption = "1024 x 768" End Sub found a module, not bad, but not original, huh, it is a revised
'Call the system "Browse Folder" dialog box, and select the start path Declare Function SendMessage Lib "user32" alias "sendMessagea" (_ byval hwnd as long, _ byval wmsg as long, _ byval wparam as long, _ ByVal lParam As String) As LongDeclare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (_ ByVal pidl As Long, _ ByVal pszPath As String) As LongDeclare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (_ lpBrowseInfo As BROWSEINFO) As LongType BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfnCallback As Long lParam As Long iImage As LongEnd TypeDim xStartPath As StringFunction SelectDir (Optional StartPath As String, _ Optional Titel As String) As String Dim iBROWSEINFO As browseinfo with ibrowseinfo .lpsztitle = IIF (LEN (Titel), Titel, "[Please select Folder]") .ulflags = 7 if len (startpath) THEN XStartPath = StartPath & Vbnullchar .lpfnCallback = GetAddressOf (AddressOf CallBack) End If End With Dim xPath As String, NoErr As Long: xPath = Space $ (512) NoErr = SHGetPathFromIDList (SHBrowseForFolder (iBROWSEINFO), xPath) SelectDir = IIf (NoErr, Left $ (xPath, INSTR (XPath, Chr (0)) - 1), "") end function
Function GetDressof (Address As Long) As long getaddressof = addressend function
Function Callback (Byval Hwnd As Long, _ Byval PIDL As Long, _ Byval PIDL As Long, _ Byval PData As Long AS Long Select Case MSG Case 1 Call SendMessage (HWND, 1126, 1, XStartPath) Case 2 Dim Sdir As String * 64, tmp As Long tmp = SHGetPathFromIDList (pidl, sDir) If tmp = 1 Then SendMessage hWnd, 1124, 0, sDir End SelectEnd Function 'test code Private Sub Command1_Click () Dim sPath As String sPath = SelectDir ( "C: / ") If len (spath) Then msgbox spathend sub '***************************************************** *********************************************************** author: Li Shaolong 'set-up time: 2004.07.23' Modifier: 'modified:' ************************************************************ *********************************************************** *******
'Simulated Remove Table PUBLIC SUB DEGROW (Grid AS MSHFLEXGRID, ROW AS INTEGER) DIM ACOL AS INTEGERDIM AROW AS INTEGER IF GRID.ROWS> 2 THEN IF (Row> 0) And (ROW Public const lvm_first as long = & h1000public const lvm_setitemposition as long = lvm_first 15PUBLIC Const LVM_SETITETETET 49PUBLIC GLDEFWINDOPROC AS Long Public Function WindowProc (ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long On Error Resume Next Select Case uMsg Case LVM_SETITEMPOSITION, LVM_SETITEMPOSITION32 WindowProc = 0 Case Else WindowProc = CallWindowProc (glDefWindowProc, hwnd, UMSG, WPARAM, LPARAM) End SELECTEND FUNCTION ---------------------------------- Private Sub Form_Load () DIM HWND As long hwnd = listftp.hwnd GldefWindowProc = setWindowlong (HWND, GWL_WNDPROC, Addressof WINDOWPROC) End Sub 'Generate GUID Function Public Function GETGUIDID () AS Stringdim Pguid (16) AS BYTEDIM S AS STRING S = String (255, ") CocreateGuid Pguid (0) StringFromGuid2 Pguid (0), S, 255 S = Trim (s ) GetGuidid = strconv (s, vbfromunicode) End Function
